Commits

committed 6b262ca

Initial import

• Participants
• Branches master

File game-of-life.scm

• Ignore whitespace
+(use doodle loop matchable miscmacros (srfi 1) vector-lib)
+
+; world size in number of cells
+(define-constant +rows+ 50)
+(define-constant +cols+ 50)
+
+; our world is a flat vextor of pairs (current . next) generations
+(define *world* (make-vector (* +rows+ +cols+) '(0 . 0)))
+
+; these accessor bindings will get swapped after each iteration
+(define current car)
+(define next cdr)
+; convenience procedure to reset our accessors
+(define (reset-accessors!)
+  (set! current car)
+  (set! next cdr))
+
+; Map (x y) coordinates to an index in our vector
+(define (cell-ref x y)
+  (let ((idx (+ x (* y +cols+))))
+    (when (> idx (* +rows+ +cols+))
+      (error "Cell coordinates out of bounds " x y))
+    (vector-ref *world* idx)))
+
+; This list is the offset of neighbour cells to consider
+; +-+-+-+  for cell x. The offsets in this list are
+; | | | |  calculated from x's coordinates, starting
+; +-+-+-+  from the upper left corner going down.
+; | |x| |
+; +-+-+-+  A cell is alive if it has a 1 in it, 0 when
+; | | | |  dead.
+; +-+-+-+
+(define neighbours
+  '((-1 . -1)
+    (0 . -1)
+    (1 . -1)
+    (-1 . 0)
+    (1 . 0)
+    (-1 . 1)
+    (0 . 1)
+    (1 . 1)))
+
+; returns the number of neighbouring alive cells
+(define (neighbour-count x y)
+  (fold + 0 (map (lambda (n)
+                   (current (cell-ref (modulo (+ x (car n)) +cols+)
+                                      (modulo (+ y (cdr n)) +rows+))))
+                 neighbours)))
+
+; A cell is alive if stored 1 at its location
+(define (alive? x y)
+  (= 1 (current (cell-ref x y))))
+
+; This implements the rules according to
+; https://en.wikipedia.org/wiki/Conway%27s_Game_of_Life
+(define (eval-rule x y)
+  (let ((n (neighbour-count x y))
+        (alive (alive? x y)))
+    (cond
+     ((and alive (< n 2)) 0) ; under-population rule #1
+     ((and alive (< n 4)) 1) ; enough neighbours rule #2
+     ((and alive (> n 3)) 0) ; overcrowded rule #3
+     ((and (not alive) (= 3 n)) 1) ; reproduction rule #4
+     (else (if alive 1 0)))))
+
+; Does one iteration and mutates the world
+(define (iterate! world)
+  (loop for y from 0 below +rows+
+        do (loop for x from 0 below +cols+
+                 do (vector-set! world (+ x (* +rows+ y))
+                                 (if (eq? current car)
+                                     (cons (current (cell-ref x y)) (eval-rule x y))
+                                     (cons (eval-rule x y) (current (cell-ref x y)))))))
+  (exchange! current next)
+  'ok)
+
+; for debugging print an ascii art to current-output-port
+(define (print-world world)
+  (loop for y from 0 below +rows+
+        do (loop for x from 0 below +cols+
+                 do
+                 (display (if (alive? x y) #\* #\_))
+                 (when (= x (sub1 +cols+)) (newline))))
+  'ok)
+
+
+; Drawing code follows
+
+; window dimensions
+(define w 680)
+(define h 420)
+
+; size of one cell in pixels
+(define +box-size+ 8)
+
+; drawing offsets to place the world on the screen
+(define-constant +x-grid-offset+ 100)
+(define-constant +y-grid-offset+ 10)
+
+(new-doodle width: w height: h background: solid-white)
+
+; Draw a cell and take our grid offset into account
+(define (draw-cell x y is-alive)
+  (let* ((x1 (+ +x-grid-offset+ (* x +box-size+)))
+         (y1 (+ +y-grid-offset+ (* y +box-size+))))
+    (if is-alive
+        (filled-rectangle x1 y1 +box-size+ +box-size+ solid-black)
+        (rectangle x1 y1 +box-size+ +box-size+ solid-black))))
+
+(define (graph-generation world)
+  (loop for y from 0 below +rows+
+        do (loop for x from 0 below +cols+
+                 do (draw-cell x y (alive? x y))))
+  'ok)
+
+(define (living-cells world)
+  (vector-fold (lambda (i s x) (+ s (current x))) 0 world))
+
+(define (draw-legend world generation)
+  (text 550 25 (list
+                (sprintf "Generation #~a" generation)
+                (sprintf "Living cells: ~a"
+                         (living-cells world)))))
+
+
+; First run routine without event loop
+(define (run #!optional (iterations 1))
+  (let loop ((i iterations))
+    (cond ((or (= 0 i)
+               (= 0 (living-cells *world*))) 'done)
+          (else
+           (clear-screen)
+           (doto *world*
+                 (graph-generation)
+                 (draw-legend *gen*)
+                 (iterate!))
+           (draw-buttons!)
+           (show!)
+           (set! *gen* (add1 *gen*))
+           (loop (sub1 i))))))
+
+(define (fill-world world num-of-points)
+  (reset-accessors!)
+  (repeat num-of-points
+          (vector-set! world (random (vector-length world)) '(1 . 0)))
+  'ok)
+
+(define (new-world)
+  (set! *world* (make-vector (* +rows+ +cols+) '(0 . 0)))
+  (clear-screen)
+  (set! *gen* 0)
+  (doto *world*
+         (fill-world 200)
+         (graph-generation)
+         (draw-legend *gen*))
+  (draw-buttons!)
+  (show!))
+
+; UI stuff
+
+(define *buttons* '())
+(define-record button label x y width height action)
+
+(define (new-button! label x y width height action)
+  (push! (make-button label x y width height action) *buttons*))
+
+(define (draw-buttons!)
+  (for-each (lambda (b)
+              (rectangle (button-x b)
+                         (button-y b)
+                         (button-width b)
+                         (button-height b)
+                         solid-black)
+              (text (+ (button-x b) (/ (button-width b) 2))
+                    (+ (button-y b) 5 (/ (button-height b) 2))
+                    (button-label b) align: #:center))
+            *buttons*)
+  (show!))
+
+(define (which-buttons x y)
+  (filter (lambda (b)
+            (and
+             (<= (button-x b) x
+                 (+ (button-x b)
+                    (button-width b)))
+             (<= (button-y b) y
+                 (+ (button-y b)
+                    (button-height b)))
+             (button-label b)))
+          *buttons*))
+
+(define (handle-buttons btns)
+  (for-each (lambda (b)
+              ((button-action b)))
+            btns))
+
+(define (handle-key key)
+  (case key
+    ((#\p) (set! *running* (not *running*)))
+    ((#\n) (new-world))
+    ((#\q) (exit 0))
+    (else (void))))
+
+
+(define *painting* #f)
+
+; map a coordinate to a world cell
+(define (tick-cell x y)
+  (when (and (< +x-grid-offset+ x (+ +x-grid-offset+ (* +box-size+ +rows+)))
+           (< +y-grid-offset+ y (+ +y-grid-offset+ (* +box-size+ +cols+))))
+      (let ((cx (inexact->exact (floor (/ (- x +x-grid-offset+) +box-size+))))
+            (cy (inexact->exact (floor (/ (- y +y-grid-offset+) +box-size+)))))
+        (set! *painting* #t)
+        (vector-set!
+         *world*
+         (+ cx (* cy +cols+))
+         (if (equal? current car)
+             (cons 1 0)
+             (cons 0 1)))
+        (graph-generation *world*))))
+
+; Set up our game world incl. UI
+(define *gen* 0)
+(define *running* #f)
+
+
+(new-button! "Play" 550 50 60 30 (lambda () (set! *running* #t)))
+(new-button! "Pause" 550 100 60 30 (lambda () (set! *running* #f)))
+(new-button! "New" 550 150 60 30 new-world)
+(new-button! "Quit" 550 250 60 30 (lambda () (exit 0)))
+
+(world-inits new-world)
+
+; React to events and drive the loop
+(world-changes
+ (lambda (events dt escape)
+   (for-each
+    (lambda (e)
+      (match
+       e
+       (('mouse 'pressed x y 1)
+        (handle-buttons (which-buttons x y))
+        (tick-cell x y))
+       (('mouse 'released x y 1)
+        (set! *painting* #f))
+       (('mouse 'moved x y)
+        (when *painting* (tick-cell x y)))
+       (('pressed key) (handle-key key))
+       (else (void))))
+    events)
+   (when *running* (run))))
+
+(run-event-loop)