(require :ltk)
(in-package :cl-user)
(defpackage :byl
(:use :common-lisp :alexandria :iterate :ltk)
(:export :byl))
(in-package :byl)
(defparameter *size* 40)
(defparameter *edge-length* 10)
(defparameter *delay* 100 "ms")
(define-constant +transitions+
'(((0 0 0 0 3) . 1) ((0 0 0 1 2) . 2) ((0 0 0 1 3) . 1) ((0 0 0 1 5) . 2)
((0 0 0 2 5) . 5) ((0 0 0 3 1) . 5) ((0 0 0 3 2) . 3) ((0 0 0 4 2) . 2) ((0 x x x x) . 0)
((1 0 0 0 0) . 0) ((1 0 0 0 1) . 0) ((1 0 0 0 3) . 3) ((1 0 0 0 4) . 0) ((1 0 0 3 3) . 0)
((1 0 0 4 3) . 1) ((1 0 3 2 1) . 3) ((1 1 2 5 3) . 1) ((1 2 4 5 3) . 3) ((1 x x x x) . 4)
((2 0 0 0 0) . 0) ((2 0 0 1 5) . 5) ((2 0 0 2 2) . 0) ((2 0 2 0 2) . 0)
((2 0 2 1 5) . 5) ((2 0 2 3 5) . 3) ((2 0 2 5 2) . 5) ((2 x x x x) . 2)
((3 0 0 0 1) . 0) ((3 0 0 0 3) . 0) ((3 0 0 1 1) . 0) ((3 0 0 1 2) . 1)
((3 0 1 2 1) . 1) ((3 0 1 2 3) . 1) ((3 1 1 2 2) . 1) ((3 1 1 2 3) . 1)
((3 1 2 1 5) . 1) ((3 1 2 2 3) . 1) ((3 1 2 3 3) . 1) ((3 1 2 3 5) . 5)
((3 1 4 3 2) . 1) ((3 1 4 5 2) . 5) ((3 1 5 2 3) . 1) ((3 x x x x) . 3)
((4 0 0 0 3) . 5) ((4 0 0 4 3) . 4) ((4 0 2 1 2) . 4) ((4 0 2 3 2) . 4)
((4 0 2 4 2) . 4) ((4 0 2 5 2) . 0) ((4 0 3 2 5) . 5) ((4 x x x x) . 3)
((5 0 0 2 2) . 5) ((5 0 0 3 2) . 5) ((5 0 2 1 2) . 4)
((5 0 2 2 2) . 0) ((5 0 3 2 2) . 0) ((5 x x x x) . 2))
:test 'equal
:documentation "Rules are in the order CNWSE->C' (not CNESW, as in the book/paper!),
where the NWSE part can be rotated. The 31523->1 rule was missing even from the original article.")
(define-constant +start+
'((0 2 2 0)
(2 3 1 0)
(2 3 4 2)
(0 2 5 0))
:test 'equal)
(defvar *cells*)
(defvar *rectangles*)
(defvar *canvas*)
(defun next-state (c n e s w)
(or (cdr (assoc (list c w s e n) +transitions+ :test 'equal))
(cdr (assoc (list c s e n w) +transitions+ :test 'equal))
(cdr (assoc (list c e n w s) +transitions+ :test 'equal))
(cdr (assoc (list c n w s e) +transitions+ :test 'equal))
(cdr (assoc (cons c '(x x x x)) +transitions+ :test 'equal))))
(let ((colors '("white" "yellow" "orange" "red" "brown" "black")))
(defun color (n)
(elt colors n)))
(defun update-colors ()
(dotimes (i *size*)
(dotimes (j *size*)
(itemconfigure *canvas* (aref *rectangles* i j) :fill (color (aref *cells* i j))))))
(defun one-cycle ()
(let ((tmp (make-array (array-dimensions *cells*))))
(iter (for i from 1 below (1- *size*))
(iter (for j from 1 below (1- *size*))
(for n = (aref *cells* i (1- j)))
(for s = (aref *cells* i (1+ j)))
(for w = (aref *cells* (1- i) j))
(for e = (aref *cells* (1+ i) j))
(for c = (aref *cells* i j))
(setf (aref tmp i j)
(next-state c n e s w))))
(setf *cells* tmp)
(update-colors)
(after *delay* #'one-cycle)))
(defun byl ()
(with-ltk ()
(let* ((size (* *size* *edge-length*)))
(setf *canvas* (make-instance 'canvas :width size :height size :background "white"))
(setf *cells* (make-array (list *size* *size*) :initial-element 0))
(setf *rectangles* (make-array (list *size* *size*)))
(dotimes (i *size*)
(dotimes (j *size*)
(let ((x (* i *edge-length*))
(y (* j *edge-length*)))
(setf (aref *rectangles* i j)
(create-rectangle *canvas* x y (+ x *edge-length* -1) (+ y *edge-length* -1)))
(itemconfigure *canvas* (aref *rectangles* i j) :outline "grey"))))
(let ((start (- (floor *size* 2) 2)))
(dotimes (i 4)
(dotimes (j 4)
(setf (aref *cells* (+ start i) (+ start j)) (elt (elt +start+ j) i)))))
(update-colors)
(wm-title *tk* "Byl Automaton")
(pack *canvas*)
(bind *tk* "<Escape>"
(lambda (event)
(declare (ignore event))
(setf *exit-mainloop* t)))
(after *delay* #'one-cycle))))