home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / gambit.cpt / graphics.scm < prev    next >
Encoding:
Text File  |  1992-03-18  |  8.3 KB  |  274 lines
  1. ; Graphics examples
  2. ;
  3. ; mandala and koch were originally written for MacScheme.
  4. ; sierpinsky was originally written in Modula2.
  5.  
  6.  
  7. ; Utilities
  8.  
  9. (define (move-to x y)
  10.   (mac#moveto (floor (inexact->exact x)) (floor (inexact->exact y))))
  11.  
  12. (define (line-to x y)
  13.   (mac#lineto (floor (inexact->exact x)) (floor (inexact->exact y))))
  14.  
  15. (define (draw-line x1 y1 x2 y2)
  16.   (mac#moveto (floor (inexact->exact x1)) (floor (inexact->exact y1)))
  17.   (mac#lineto (floor (inexact->exact x2)) (floor (inexact->exact y2))))
  18.  
  19.  
  20. ; Mandala
  21. ;
  22. ; try: (mandala 140 30)
  23. ;
  24. ; Note: floating point is really slow if you don't have a FPU.  This is
  25. ; because every 68881 instruction has to be emulated in software.  A lot
  26. ; of time is spent in 'inexact->exact' which converts floating point
  27. ; numbers to an exact rational representation.  This is needed because
  28. ; 'floor' of a floating point number returns a floating point number.
  29.  
  30. (define (mandala r n)
  31.   (let ((w (mac#newwindow
  32.              (mac#rect 40
  33.                        2
  34.                        (+ 40 (floor (inexact->exact (* (+ r 5) 2))))
  35.                        (+ 2 (floor (inexact->exact (* (+ r 5) 2)))))
  36.              "Mandala"
  37.              #f)))
  38.     (if (not (= w 0))
  39.       (begin
  40.         (mac#setport w)
  41.         (mand (+ r 5) (+ r 5) r n)
  42.         (mac#disposewindow w)))))
  43.  
  44. (define (mand x0 y0 radius npoints) ; example modified from MacScheme
  45.   (move-to (+ x0 radius) y0)
  46.   (do ((x (make-vector npoints))
  47.        (y (make-vector npoints))
  48.        (i (- npoints 1) (- i 1))
  49.        (delta (/ (* 2 3.14159265) npoints))
  50.        (theta 0 (+ theta delta)))
  51.       ((negative? i)
  52.        (line-to (vector-ref x (- npoints 1))
  53.                 (vector-ref y (- npoints 1)))
  54.        (do ((i (- (quotient npoints 2) 1) (- i 1)))
  55.            ((negative? i))
  56.            (do ((j 0 (+ j 1)))
  57.                ((= j npoints))
  58.                (move-to (vector-ref x j) (vector-ref y j))
  59.                (line-to
  60.                 (vector-ref x (remainder (+ j i) npoints))
  61.                 (vector-ref y (remainder (+ j i) npoints))))))
  62.       (vector-set! x i (round (inexact->exact (+ x0 (* radius (cos theta))))))
  63.       (vector-set! y i (round (inexact->exact (+ y0 (* radius (sin theta))))))
  64.       (line-to (vector-ref x i) (vector-ref y i))))
  65.  
  66.  
  67. ; Koch
  68. ;
  69. ; try: (koch 4)
  70. ;
  71. ; Once again, this is really slow if you don't have a FPU.
  72.  
  73. (define (koch n)
  74.   (let ((w (mac#newwindow (mac#rect 40 2 240 202) "Koch" #f)))
  75.     (if (not (= w 0))
  76.       (begin
  77.         (mac#setport w)
  78.         (fractal1-for-half-window 101 101 60 n)
  79.         (mac#disposewindow w)))))
  80.  
  81. (define fractal1-for-half-window
  82.   (lambda (xorig yorig scaling n)
  83.     (letrec ((sin60 .866)
  84.              (side
  85.               (lambda (x1 y1 x2 y2 n)
  86.                 (if (= n 1)
  87.                     (draw-line (+ x1 xorig)
  88.                                (+ y1 yorig)
  89.                                (+ x2 xorig)
  90.                                (+ y2 yorig))
  91.                     (let ((xdiff (- x2 x1))
  92.                           (ydiff (- y2 y1)))
  93.                       (let ((x3 (+ x1 (round (/ xdiff 3))))
  94.                             (y3 (+ y1 (round (/ ydiff 3))))
  95.                             (x4 (+ x1 (round (- (/ xdiff 2)
  96.                                                 (/ (* ydiff sin60)
  97.                                                    3)))))
  98.                             (y4 (+ y1 (round (+ (/ ydiff 2)
  99.                                                 (/ (* xdiff sin60)
  100.                                                    3)))))
  101.                             (x5 (+ x1 (round (/ (* xdiff 2) 3))))
  102.                             (y5 (+ y1 (round (/ (* ydiff 2) 3)))))
  103.                         (begin
  104.                          (side x1 y1 x3 y3 (- n 1))
  105.                          (side x3 y3 x4 y4 (- n 1))
  106.                          (side x4 y4 x5 y5 (- n 1))
  107.                          (side x5 y5 x2 y2 (- n 1)))))))))
  108.       (let
  109.         ((x1 0)
  110.          (y1 (round (* scaling sin60)))
  111.          (x2 (round scaling))
  112.          (y2 (- (round (* scaling sin60))))
  113.          (x3 (- (round scaling)))
  114.          (y3 (- (round (* scaling sin60)))))
  115.         (begin
  116.          (side x1 y1 x2 y2 n)
  117.          (side x2 y2 x3 y3 n)
  118.          (side x3 y3 x1 y1 n))))))
  119.  
  120.  
  121. ; Sierpinsky
  122. ;
  123. ; try: (sierpinsky 5)
  124.  
  125. (define (sierpinsky n)
  126.  
  127.   (define h 2)
  128.   (define border 10)
  129.   (define size 256)
  130.  
  131.   (define (refresh line)
  132.  
  133.     (define (sierp j)
  134.  
  135.       (let* ((h (/ (/ size 4) (expt 2 j)))
  136.              (current-x (+ border (* h 2)))
  137.              (current-y (+ border h)))
  138.  
  139.         (define (draw d l)
  140.           (let ((inc-x (case d ((0 1 7) l) ((3 4 5) (- l)) (else 0)))
  141.                 (inc-y (case d ((1 2 3) l) ((5 6 7) (- l)) (else 0))))
  142.             (line current-x current-y
  143.                   (+ current-x inc-x) (- current-y inc-y))
  144.             (set! current-x (+ current-x inc-x))
  145.             (set! current-y (- current-y inc-y))
  146.             #f))
  147.  
  148.         (define (s k i)
  149.           (if (> k 0)
  150.             (let ((k (- k 1)))
  151.               (s k i                 ) (draw (modulo (- i 1) 8) h)
  152.               (s k (modulo (+ i 6) 8)) (draw i                  (* h 2))
  153.               (s k (modulo (+ i 2) 8)) (draw (modulo (+ i 1) 8) h)
  154.               (s k i                 ))))
  155.  
  156.         (define (ss k)
  157.           (s k 0) (draw 7 h)
  158.           (s k 6) (draw 5 h)
  159.           (s k 4) (draw 3 h)
  160.           (s k 2) (draw 1 h))
  161.  
  162.         (ss j)))
  163.  
  164.     (let loop ((j 0))
  165.       (if (<= j n)
  166.         (begin
  167.           (sierp j)
  168.           (loop (+ j 1))))))
  169.  
  170.   (let ((w (mac#newwindow (mac#rect 40 2
  171.                                     (+ 40 size (* border 2))
  172.                                     (+ 2 size (* border 2)))
  173.                           (string-append "(sierpinsky " (number->string n) ")")
  174.                           #f)))
  175.     (if (not (= w 0))
  176.       (begin
  177.         (mac#setport w)
  178.         (refresh draw-line)
  179.         (mac#disposewindow w)))))
  180.  
  181.  
  182. ; Bounce
  183. ;
  184. ; try: (bounce)
  185.  
  186. (define (bounce)
  187.  
  188.   (define n 1)
  189.  
  190.   (define radius 5)
  191.   (define sqr-2*radius 100)
  192.   (define w 200)
  193.  
  194.   (define old #f) ; old state
  195.   (define new #f) ; new state
  196.  
  197.   (define (compute-new-state)
  198.     (let loop1 ((i (- n 1)))
  199.       (if (>= i 0)
  200.         (let* ((b-old (vector-ref old i))
  201.                (b-new (vector-ref new i))
  202.                (vx (vector-ref b-old 2))
  203.                (vy (vector-ref b-old 3))
  204.                (x (+ (vector-ref b-old 0) vx))
  205.                (y (+ (vector-ref b-old 1) vy))
  206.                (r (vector-ref b-new 4)))
  207.           (vector-set! b-new 0 x)
  208.           (vector-set! b-new 1 y)
  209.           (vector-set! b-new 2
  210.             (if (or (< x radius) (> x (- w radius))) (- vx) vx))
  211.           (vector-set! b-new 3
  212.             (if (or (< y radius) (> y (- w radius))) (- vy) vy))
  213.           (mac#rect-top-set! r (- y radius))
  214.           (mac#rect-left-set! r (- x radius))
  215.           (mac#rect-bottom-set! r (+ y radius))
  216.           (mac#rect-right-set! r (+ x radius))
  217.           (loop1 (- i 1))))))
  218.  
  219.   (define (display-new-state)
  220.     (let loop ((i (- n 1)))
  221.       (if (>= i 0)
  222.         (begin
  223.           (mac#invertoval (vector-ref (vector-ref old i) 4))
  224.           (mac#invertoval (vector-ref (vector-ref new i) 4))
  225.           (loop (- i 1))))))
  226.  
  227.   (define (bounce-balls)
  228.     (compute-new-state)
  229.     (display-new-state)
  230.     (let ((temp new))
  231.       (set! new old)
  232.       (set! old temp))
  233.     (if (not (mac#button)) (bounce-balls)))
  234.  
  235.   (set! old
  236.     (let ((state (make-vector n)))
  237.       (let loop ((i (- n 1)))
  238.         (if (>= i 0)
  239.           (let ((v (vector (floor (+ radius (* (rand) (- w (* 2 radius)))))
  240.                            (floor (+ radius (* (rand) (- w (* 2 radius)))))
  241.                            (floor (* (rand) radius))
  242.                            (floor (* (rand) radius))
  243.                            (mac#rect 0 0 0 0))))
  244.             (vector-set! state i v)
  245.             (loop (- i 1)))
  246.           state))))
  247.  
  248.   (set! new
  249.     (let ((state (make-vector n)))
  250.       (let loop ((i (- n 1)))
  251.         (if (>= i 0)
  252.           (let ((v (vector 0 0 0 0 (mac#rect 0 0 0 0))))
  253.             (vector-set! state i v)
  254.             (loop (- i 1)))
  255.           state))))
  256.  
  257.   (let ((w (mac#newwindow (mac#rect 40 2 (+ w 40) (+ w 2)) "Bounce" #f)))
  258.     (if (not (= w 0))
  259.       (begin
  260.         (mac#setport w)
  261.         (bounce-balls)
  262.         (mac#disposewindow w)))))
  263.  
  264. (define *seed* 222498987)
  265.  
  266. (define (rand)
  267.   (let* ((hi (quotient *seed* 127773))
  268.          (lo (modulo *seed* 127773))
  269.          (test (- (* 16807 lo) (* 2836 hi))))
  270.     (if (> test 0)
  271.         (set! *seed* test)
  272.         (set! *seed* (+ test 2147483647)))
  273.     (/ *seed* 2147483648)))
  274.