game-of-life.rkt

#lang racket
(require math/array)
;; https://en.wikipedia.org/wiki/Conway's_Game_of_Life

;; These are the game rules for a single CELL which can be 1 (alive) or 0
;; dead.  NEIGHBOR-COUNT is the number of live neighbors the cell has.
(define (game-rules cell neighbor-count)
  (cond
    ;; Any live cell with fewer than two live neighbours dies, as if by
    ;; underpopulation.
    ((and (equal? cell 1) (< neighbor-count 2)) 0)
    ;; Any live cell with two or three live neighbors lives on to the next
    ;; generation.
    ((and (equal? cell 1) (or (= neighbor-count 2) (= neighbor-count 3))) 1)
    ;; Any live cell with more than three live neighbors dies, as if by
    ;; overpopulation.
    ((and (equal? cell 1) (> neighbor-count 3)) 0)
    ;; Any dead cell with exactly three live neighbours becomes a live cell,
    ;; as if by reproduction.
    ((and (equal? cell 0) (= neighbor-count 3)) 1)
    ;; All else, cell remains unchanged
    (else cell)))

(define (rol a dimension)               ; rotate left
  (define n (vector-ref (array-shape a) dimension))
  (append (list (sub1 n)) (build-list (sub1 n) values)))

(define (ror a dimension)               ; rotate right
  (define n (vector-ref (array-shape a) dimension))
  (append (build-list (sub1 n) add1) '(0)))

(define (make-shifts a)
  `((,(::) ,(rol a 1))            ; left
    (,(::) ,(ror a 1))            ; right
    (,(rol a 0) ,(::))            ; up
    (,(ror a 0) ,(::))            ; down
    (,(rol a 0) ,(rol a 1))       ; up-left
    (,(rol a 0) ,(ror a 1))       ; up-right
    (,(ror a 0) ,(rol a 1))       ; down-left
    (,(ror a 0) ,(ror a 1))))     ; down-right

;; Return an array with the neighbor-count of each cell in the array A.  We
;; shift A up/down, left right, etc and add all resulting arrays together.
(define (neighbour-count a shifts)
  (define ns (map (lambda (shift) (array-slice-ref a shift)) shifts))
  (apply array-map + ns))

;; Calculate the next step for the array A by applying the game rules.
(define (advance a [shifts (make-shifts a)])
  (array-map game-rules a (neighbour-count a shifts)))

;; Code below is the visualization snip.

(require racket/gui racket/draw)

(define game-of-life-snip-class
  (make-object
   (class snip-class%
     (super-new)
     (send this set-classname "game-of-life-snip-class"))))

(define game-of-life-snip%
  (class snip%
    (init-field initial-state update-interval [width 200] [height 200])
    (super-new)
    (send this set-snipclass game-of-life-snip-class)
    
    (define state initial-state)
    (define shifts (make-shifts initial-state))
    (define indexes (indexes-array (array-shape state)))
    (match-define (vector rows cols) (array-shape state))

    (define pen (send the-pen-list find-or-create-pen "black" 0.1 'transparent))
    (define brush (send the-brush-list find-or-create-brush "black" 'solid))

    ;; Since the width/height of the snip does not change, we can compute
    ;; these once only.
    (define bw (/ width cols))
    (define bh (/ height rows))
    
    (define (on-refresh)
      (define admin (send this get-admin))
      (when admin
        (set! state (advance state shifts))
        (send admin needs-update this 0 0 width height)))

    (define timer (new timer% [notify-callback on-refresh]))

    (define/override (set-admin a)
      (super set-admin a)
      (if (send this get-admin)         ; admin was accepted
          (send timer start update-interval)
          (send timer stop)))

    (define/override (copy)
      (new this%
           [initial-state state]
           [update-interval update-interval]
           [width width]
           [height height]))
    
    (define/override (get-extent dc x y w h descent space lspace rspace)
      (when w (set-box! w width))
      (when h (set-box! h height))
      (when descent (set-box! descent 0.0))
      (when space (set-box! space 0.0))
      (when lspace (set-box! lspace 0.0))
      (when rspace (set-box! rspace 0.0)))
    
    (define/override (draw dc x y . other)
      (define old-pen (send dc get-pen))
      (define old-brush (send dc get-brush))
      (send dc set-pen pen)
      (send dc set-brush brush)
      (array-map
       (lambda (cell index)
         (when (> cell 0)
           (match-define (vector r c) index)
           (send dc draw-rectangle (+ x (* bw c)) (+ y (* bh r)) bw bh)))
       state
       indexes)
      (send dc set-brush old-brush)
      (send dc set-pen old-pen))))

(define (animate a)
  (new game-of-life-snip% [initial-state a] [update-interval 20]))

(define space-ship
  (array
   #[#[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]]))

;; Pattern downloaded from here:
;; https://www.conwaylife.com/wiki/Gosper_glider_gun gosperg-glider-gun-60
(define glider-gun
  (array
   #[#[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 1 1 0 0 0 0 0 0]
     #[0 0 0 1 1 0 0 0 1 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 1 1 0 0 0 0 0 0]
     #[0 0 0 1 1 0 0 0 1 1 0 0 0 1 0 0 0 0 1 0 1 0 1 1 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 0 0 0 1 1 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 1 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[1 1 0 0 0 0 0 1 1 1 0 0 0 0 0 1 0 0 1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
     ]))

(define glider
  (array
   #[#[0 0 0 0 0 0 0 0 0 0]
     #[0 0 1 0 0 0 0 0 0 0]
     #[0 0 0 1 0 0 0 0 0 0]
     #[0 1 1 1 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0]
     #[0 0 0 0 0 0 0 0 0 0]]))

;; (animate glider)
;; (animate space-ship)
;; (animate glider-gun)