Skip to content

Instantly share code, notes, and snippets.

@alex-hhh
Created January 17, 2022 23:08
Show Gist options
  • Save alex-hhh/06d5e5429b50a60e5d25e301d4af3b4c to your computer and use it in GitHub Desktop.
Save alex-hhh/06d5e5429b50a60e5d25e301d4af3b4c to your computer and use it in GitHub Desktop.
#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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment