home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p1 / Examples / drawing-demo.scm next >
Encoding:
Text File  |  1994-07-26  |  1.2 KB  |  48 lines  |  [TEXT/gamI]
  1. ; This is a demo of the drawing window.
  2.  
  3. (define (sierpinsky n)
  4.  
  5.   (define size 256)
  6.  
  7.   (define (sierp j)
  8.  
  9.     (let* ((h (/ (/ size 4) (expt 2 j)))
  10.            (current-x (- (* h 2) 128))
  11.            (current-y (- h 128)))
  12.  
  13.       (define (draw d l)
  14.         (let ((inc-x (case d ((0 1 7) l) ((3 4 5) (- l)) (else 0)))
  15.               (inc-y (case d ((1 2 3) l) ((5 6 7) (- l)) (else 0))))
  16.           (set! current-x (+ current-x inc-x))
  17.           (set! current-y (- current-y inc-y))
  18.           (draw-line-to current-x current-y)
  19.           #f))
  20.  
  21.       (define (s1 k i)
  22.         (if (> k 0)
  23.           (let ((k (- k 1)))
  24.             (s1 k i                 ) (draw (modulo (- i 1) 8) h)
  25.             (s1 k (modulo (+ i 6) 8)) (draw i                  (* h 2))
  26.             (s1 k (modulo (+ i 2) 8)) (draw (modulo (+ i 1) 8) h)
  27.             (s1 k i                 ))))
  28.  
  29.       (define (s2 k)
  30.         (s1 k 0) (draw 7 h)
  31.         (s1 k 6) (draw 5 h)
  32.         (s1 k 4) (draw 3 h)
  33.         (s1 k 2) (draw 1 h))
  34.  
  35.       (position-pen current-x current-y)
  36.  
  37.       (s2 j)))
  38.  
  39.   (clear-graphics) ; clear drawing window
  40.  
  41.   (let loop ((j 0))
  42.     (if (<= j n)
  43.       (begin
  44.         (sierp j)
  45.         (loop (+ j 1))))))
  46.  
  47. (sierpinsky 4)
  48.