PasteRack.org
Paste # 63086
2018-04-02 11:14:26

Fork as a new paste.

Paste viewed 854 times.


Embed:

game of life

  1. #lang racket
  2. (require racket/control)
  3. (require racket/gui/base)
  4.  
  5. (define (print p) (display p) (newline))
  6.  
  7. (define (iterator:iota n)
  8.   (lambda ()
  9.     (shift k
  10.            (let loop ((i 0))
  11.              (when (< i n)
  12.                (k i)
  13.                (loop (+ i 1)))))))
  14.  
  15. (define (iterator:adjacent x y)
  16.   (lambda ()
  17.     (shift k
  18.            (k (+ x 1) (+ y 1))
  19.            (k x       (+ y 1))
  20.            (k (- x 1) (+ y 1))
  21.            (k (+ x 1) y)
  22.            (k (- x 1) y)
  23.            (k (+ x 1) (- y 1))
  24.            (k x       (- y 1))
  25.            (k (- x 1) (- y 1)))))
  26.  
  27. (define (for iterator body)
  28.   (reset (call-with-values iterator body)))
  29.  
  30. (define (t)
  31.   (begin
  32.     (print 'start)
  33.     (for (iterator:iota 5)
  34.       (lambda (n)
  35.         (print `(,n ...))))
  36.     (for (iterator:iota 5)
  37.       (lambda (n)
  38.         (for (iterator:iota 2)
  39.           (lambda (m)
  40.             (print `(,n ,m ...))))))
  41.     (for (iterator:adjacent 4 3)
  42.       (lambda (x y)
  43.         (print `(,x ,y))))
  44.     (print 'end)))
  45.  
  46. (define board-w 80)
  47. (define board-h 70)
  48.  
  49. (define (cell board  x y)
  50.   (vector-ref board (+ x (* y board-w))))
  51.  
  52. (define (cell-set! board x y val)
  53.   (vector-set! board (+ x (* y board-w)) val))
  54.  
  55. (define (life-update board-w board-h board tmp-board)
  56.   (define (in-bounds x y)
  57.     (and (<= 0 x) (< x board-w) (<= 0 y) (< y board-h)))
  58.   (for (iterator:iota board-w)
  59.     (lambda (x)
  60.       (for (iterator:iota board-h)
  61.         (lambda (y)
  62.           (let ((neighbours 0))
  63.             (for (iterator:adjacent x y)
  64.               (lambda (x^ y^)
  65.                 (when (and (in-bounds x^ y^) (cell board x^ y^))
  66.                   (set! neighbours (+ 1 neighbours)))))
  67.             (cell-set! tmp-board x y (cell board x y))
  68.             (if (cell board x y)
  69.                 (when (or (< neighbours 2) (> neighbours 3))
  70.                   (cell-set! tmp-board x y #f))
  71.                 (when (= neighbours 3)
  72.                   (cell-set! tmp-board x y #t))))))))
  73.     (for (iterator:iota (* board-w board-h))
  74.       (lambda (i)
  75.         (vector-set! board i (vector-ref tmp-board i)))))
  76.  
  77. (define (main)
  78.   (define sz 6)
  79.   (define board
  80.     (build-vector (* board-w board-h) (lambda (i) (= 0 (random 3)))))
  81.   (define tmp-board
  82.     (make-vector (* board-w board-h) #f))
  83.   (define my-timer #f)
  84.   (define frame (new frame%
  85.                      [label "Life"]
  86.                      [width (* board-w sz)]
  87.                      [height (* board-h sz)]))
  88.   (new canvas% [parent frame]
  89.        [paint-callback
  90.         (lambda (canvas dc)
  91.           (send dc erase)
  92.           (send dc set-brush "black" 'solid)
  93.           (for (iterator:iota board-w)
  94.             (lambda (x)
  95.               (for (iterator:iota board-h)
  96.                 (lambda (y)
  97.                   (when (cell board x y)
  98.                     (send dc draw-rectangle (* x sz) (* y sz) sz sz)))))))
  99.         ])
  100.   (set! my-timer
  101.         (new timer%
  102.              [interval 300]
  103.              [notify-callback (lambda ()
  104.                                 (life-update board-w board-h board tmp-board)
  105.                                 (send frame refresh))]))
  106.   (send frame show #t))
  107.  
  108. (main)

=>