home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / gambit.cpt / mac-examples.scm < prev    next >
Encoding:
Text File  |  1992-03-18  |  7.4 KB  |  207 lines
  1. ;============================================================================
  2.  
  3. ; Quickdraw example
  4. ; -----------------
  5.  
  6. ; (represent obj) pops up a window with the graphical representation of 'obj'.
  7. ; To get control back, press the mouse button.
  8. ;
  9. ; try: (represent '(define (fact n) (if (< n 2) 1 (* (fact (- n 1)) n))))
  10.  
  11. (define (represent obj)
  12.  
  13.   (define v-offs  0) ; vertical offset of grid
  14.   (define h-offs 20) ; horizontal
  15.  
  16.   (define grid-v 24) ; vertical spacing between grid lines
  17.   (define grid-h 48) ; horizontal
  18.  
  19.   (define cons-v 12) ; vertical size of cons cell
  20.   (define cons-h 24) ; horizontal
  21.  
  22.   (define arrow-head-length 6) ; size of arrows
  23.   (define arrow-head-width  6)
  24.   (define arrow-space       2)
  25.  
  26.   (define fontsize 12)
  27.  
  28.   (define (draw-cons-cell x y)
  29.     (let ((v (+ (* y grid-v) v-offs))
  30.           (h (+ (* x grid-h) h-offs)))
  31.       (mac#framerect (mac#rect v h (+ v cons-v) (+ h cons-h)))
  32.       (mac#moveto (+ h (quotient cons-h 2)) v)
  33.       (mac#line 0 (- cons-v 1))))
  34.  
  35.   (define (draw-car-arrow x y d) ; draw arrow downwards 'd' grid squares
  36.     (let ((v (+ (* y grid-v) v-offs))
  37.           (h (+ (* x grid-h) h-offs)))
  38.       (mac#moveto (+ h (quotient cons-h 4)) (+ v (quotient cons-v 2)))
  39.       (mac#line 0 (- (* d grid-v) (+ (quotient cons-v 2) arrow-space)))
  40.       (mac#line (quotient arrow-head-width 2) (- arrow-head-length))
  41.       (mac#move (- arrow-head-width) 0)
  42.       (mac#line (quotient arrow-head-width 2) arrow-head-length)))
  43.  
  44.   (define (draw-cdr-arrow x y d) ; draw arrow to the right 'd' grid squares
  45.     (let ((v (+ (* y grid-v) v-offs))
  46.           (h (+ (* x grid-h) h-offs)))
  47.       (mac#moveto (+ h (quotient (* cons-h 3) 4)) (+ v (quotient cons-v 2)))
  48.       (mac#line (- (* d grid-h) (+ (quotient (* cons-h 3) 4) arrow-space)) 0)
  49.       (mac#line (- arrow-head-length) (quotient arrow-head-width 2))
  50.       (mac#move 0 (- arrow-head-width))
  51.       (mac#line arrow-head-length (quotient arrow-head-width 2))))
  52.  
  53.   (define (draw-nil x y) ; draw nil in cdr of cons cell
  54.     (let ((v (+ (* y grid-v) v-offs))
  55.           (h (+ (* x grid-h) h-offs)))
  56.       (mac#moveto (+ h (quotient cons-h 2)) (+ v (- cons-v 1)))
  57.       (mac#line (- (quotient cons-h 2) 1) (- (- cons-v 1)))))
  58.  
  59.   (define (object->string obj)
  60.     (let ((port (open-output-string)))
  61.       (write obj port)
  62.       (let ((str (get-output-string port)))
  63.         (close-output-port port)
  64.         str)))
  65.  
  66.   (define (object-length obj) ; length of object in grid squares
  67.     (cond ((null? obj)
  68.            0)
  69.           ((pair? obj)
  70.            (+ 1 (object-length (cdr obj))))
  71.           (else
  72.            (+ 1 (quotient (+ (mac#stringwidth (object->string obj)) fontsize)
  73.                           grid-h)))))
  74.  
  75.   (define (initial-profile) 0)
  76.   (define (car-profile p) (if (pair? p) (car p) p))
  77.   (define (cdr-profile p) (if (pair? p) (cdr p) p))
  78.  
  79.   (define (make-profile len p)
  80.     (define (fit1 len p)
  81.       (if (> len 1)
  82.         (let ((p* (fit1 (- len 1) (cdr-profile p))))
  83.           (cons (car-profile p*) p*))
  84.         (fit2 (+ (car-profile p) 1) p)))
  85.     (define (fit2 y p)
  86.       (if (pair? p)
  87.         (cons (max y (car-profile p)) (fit2 y (cdr-profile p)))
  88.         (max y p)))
  89.     (fit1 len p))
  90.  
  91.   (define (draw-list lst x y p)
  92.     (draw-cons-cell x y)
  93.     (let* ((tail (cdr lst))
  94.            (tail-p (cdr-profile p))
  95.            (new-p (cond ((null? tail)
  96.                          (draw-nil x y)
  97.                          tail-p)
  98.                         ((pair? tail)
  99.                          (draw-cdr-arrow x y 1)
  100.                          (draw-list tail (+ x 1) y tail-p))
  101.                         (else
  102.                          (draw-cdr-arrow x y 1)
  103.                          (mac#move arrow-space (quotient fontsize 2))
  104.                          (mac#drawstring (object->string tail))
  105.                          tail-p))))
  106.       (draw-object (car lst) x y (cons (car-profile p) new-p))))
  107.  
  108.   (define (draw-object obj x y p)
  109.     (if (pair? obj)
  110.       (let ((len (object-length obj)))
  111.         (let ((new-p (make-profile len p)))
  112.           (let ((yy (car-profile new-p)))
  113.             (draw-car-arrow x y (- yy y))
  114.             (draw-list obj x yy new-p))))
  115.       (let ((text (object->string obj)))
  116.         (draw-car-arrow x y 1)
  117.         (mac#move (- (quotient (mac#stringwidth text) 2)) fontsize)
  118.         (mac#drawstring text)
  119.         (make-profile 1 p))))
  120.  
  121.   (let ((w (mac#newwindow (mac#rect 40 10 250 500) "represent" #t)))
  122.     (if (not (= w 0)) ; make sure it was created...
  123.       (begin
  124.         (mac#setport w)
  125.         (mac#textfont 3) ; geneva
  126.         (mac#textface 1) ; bold
  127.         (mac#textsize fontsize)
  128.         (draw-object obj 0 0 (initial-profile))
  129.         (let loop () (if (not (mac#button)) (loop)))
  130.         (mac#disposewindow w)))))
  131.  
  132. ;============================================================================
  133.  
  134. ; Event processing example
  135. ; ------------------------
  136.  
  137. ; (read-keyboard echo?) returns the string of characters that are typed at
  138. ; the keyboard.  Input is terminated by the return key.  The characters are
  139. ; echoed if 'echo?' is true.
  140. ;
  141. ; Read-keyboard installs a special handler procedure to intercept the events
  142. ; that are produced by the toolbox routine 'GetNextEvent'.  Here, only
  143. ; keydown and autokey events are intercepted, but all events can be
  144. ; intercepted.
  145. ;
  146. ; Note: Because this procedure can be interrupted by the preemption clock,
  147. ; it is possible that some of the characters will be processed out of order.
  148. ; This is more noticeable in interpreted code than compiled code.  The wait
  149. ; loop is also a problem when interpreted because it causes frequent garbage
  150. ; collections.
  151.  
  152. (define (read-keyboard echo?)
  153.   (let ((original-intercept-os-event ##intercept-os-event)
  154.         (final-key-sequence #f)
  155.         (key-sequence '()))
  156.  
  157.     (define (new-intercept-os-event event)
  158.       (if (memv (mac#event-what event) '(3 5)) ; keydown or autokey
  159.         (let ((key (modulo (mac#event-message event) 256)))
  160.           (cond ((= key 13) ; return key?
  161.                  (set! ##intercept-os-event original-intercept-os-event)
  162.                  (set! final-key-sequence key-sequence))
  163.                 (else
  164.                  (set! key-sequence (cons key key-sequence))
  165.                  (if echo? (write-char (integer->char key)))))
  166.           #t) ; #t = process other events
  167.         (original-intercept-os-event event))) ; otherwise do normal processing
  168.  
  169.     (set! ##intercept-os-event new-intercept-os-event) ; setup the new handler
  170.  
  171.     (let loop () ; wait until final-key-sequence is known
  172.       (let ((x final-key-sequence))
  173.         (if (not x)
  174.           (loop)
  175.           (list->string (map integer->char (reverse x))))))))
  176.  
  177. ;============================================================================
  178.  
  179. ; Window example
  180. ; --------------
  181.  
  182. ; (query prompt) pops up a window, displays the prompt and returns the
  183. ; expression typed in the window.  Note that a window is both an input and
  184. ; output port.
  185. ;
  186. ; try: (query "Enter value of 'n': ")
  187.  
  188. (define (query prompt)
  189.   (let ((p (mac#open-window "query")))
  190.     (display prompt p)
  191.     (let ((x (read p)))
  192.       (close-output-port p)
  193.       x)))
  194.  
  195. ; (pretty obj) pops up a window with the pretty printed representation
  196. ; of 'obj'.  Note that the result of 'pretty' is a port.  You should close
  197. ; this port to get rid of the window.
  198. ;
  199. ; try: (let ((p (pretty '(1 2 3)))) (read-keyboard #f) (close-output-port p))
  200.  
  201. (define (pretty obj)
  202.   (let ((p (mac#open-window "pretty")))
  203.     (pp obj p)
  204.     p))
  205.  
  206. ;============================================================================
  207.