gol.rkt

#lang typed/racket
(require math/array typed/racket/unsafe)
;; needed because (apply array-map ...) doesn't work
(unsafe-require/typed math/array
		      [(array-map unsafe-array-map)
		       ((Integer * -> Integer) (Array Integer) * -> (Array Integer))])
;; 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.
(: game-rules (-> Integer Integer Integer))
(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)))

(: rol (All (A) (-> (Array A) Integer (Listof Integer))))
(define (rol a dimension)               ; rotate left
  (define n (vector-ref (array-shape a) dimension))
  (append (list (sub1 n)) (build-list (sub1 n) (lambda ([x : Integer]) x))))

(: ror (All (A) (-> (Array A) Integer (Listof Integer))))
(define (ror a dimension)               ; rotate right
  (define n (vector-ref (array-shape a) dimension))
  (append (build-list (sub1 n) add1) '(0)))

(: make-shifts (All (A) (-> (Array A) (Listof (List Slice-Spec Slice-Spec)))))
(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.
(: neighbour-count (-> (Array Integer) (Listof (List Slice-Spec Slice-Spec)) (Array Integer)))
(define (neighbour-count a shifts)
  (define ns : (Listof (Array Integer))
    (map (lambda ([shift : (List Slice-Spec Slice-Spec)]) (array-slice-ref a shift)) shifts))
  (apply unsafe-array-map (ann + (Integer * -> Integer)) ns))

;; Calculate the next step for the array A by applying the game rules.
(: advance (->* ((Array Integer)) ((Listof (List Slice-Spec Slice-Spec))) (Array Integer)))
(define (advance a [shifts (make-shifts a)])
  (array-map game-rules a (neighbour-count a shifts)))

;; Code below is the visualization snip.

(require typed/racket/gui typed/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-type GOL-Snip% (Class (init-field [initial-state (Array Integer)]
                                          [update-interval Integer]
                                          [width Nonnegative-Real #:optional]
                                          [height Nonnegative-Real #:optional])
                              #:implements Snip%))

(: game-of-life-snip% GOL-Snip%)
(define game-of-life-snip%
  (class snip%
    (super-new)
    (init-field [initial-state : (Array Integer)] [update-interval : Integer] [width 200.] [height 200.])
    (send this set-snipclass game-of-life-snip-class)
    
    (define state : (Array Integer) initial-state)
    (define shifts : (Listof (List Slice-Spec Slice-Spec)) (make-shifts initial-state))
    (define indexes : (Array Indexes) (indexes-array (array-shape state)))
    (: cols Nonnegative-Real)
    (: rows Nonnegative-Real)
    (match-define (vector rows cols) (array-shape state))

    (define pen (send the-pen-list find-or-create-pen "black" 0.1 'transparent))
    (define brush (assert (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 : Nonnegative-Real (cast (/ width cols) Nonnegative-Real))
    (define bh : Nonnegative-Real (cast (/ height rows) Nonnegative-Real))
    
    (define (on-refresh) : Void
      (define admin (send this get-admin))
      (when admin
        (set! state (advance state shifts))
        (send admin needs-update this 0 0 width height)))

    (: timer : (Instance Timer%))
    (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 game-of-life-snip%
           [initial-state state]
           [update-interval update-interval]
           [width width]
           [height height]))
    
    (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
      (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 : Integer] [index : Indexes])
         (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))))

(: animate (-> (Array Integer) Any))
(define (animate a)
  (new game-of-life-snip%
       [initial-state a] [update-interval 20]))

(: space-ship (Array Integer))
(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)