John Conway's game of life

game-of-life.lisp

(declaim (optimize (debug 0) (safety 1) (speed 1)))

(defmacro aref-with-default (default array &rest subscripts)
  `(if (array-in-bounds-p ,array ,@subscripts)
       (aref ,array ,@subscripts)
       ,default))

(defmacro iterate-array (dimensions array &rest body)
  (labels ((index-symbol (n)
	     (intern (concatenate 'string "V" (write-to-string n))))
	   (loops (n m)
	      (if (> n m)
		  (cons 'progn body)
		  `(loop for ,(index-symbol n) to (1- (array-dimension ,array ,n)) do ,(loops (1+ n) m)))))
    (loops 0 (1- dimensions))))

(defun get-neighbors (array x y)
  (map 'list (lambda (xy)
	       (aref-with-default nil array (car xy) (cdr xy)))
       `((,(1- x) . ,(1- y)) (,x . ,(1- y)) (,(1+ x) . ,(1- y))
	 (,(1- x) . ,y)                     (,(1+ x) . ,y)
	 (,(1- x) . ,(1+ y)) (,x . ,(1+ y)) (,(1+ x) . ,(1+ y)))))

(defun num-alive-neighbors (array x y)
  (count t (get-neighbors array x y)))

(defun make-flatland ()
   (make-array '(24 80) :element-type 'boolean :initial-element nil))

(defun display-flatland (array)
  (iterate-array 2 array
		 (if (and (> v0 0)
			  (= v1 0))
		     (princ #\Newline))
		 (if (alivep v0 v1 array)
		     (princ #\#)
		     (princ #\.))))

(defun kill (x y flatland)
  (setf (aref flatland x y) nil))

(defun revive (x y flatland)
  (setf (aref flatland x y) t))

(defun alivep (x y flatland)
  (aref flatland x y))

(defun game-of-life (flatland new-flatland)
  (labels ((update-cell (x y flatland new-flatland)
	     (let ((neighbors (num-alive-neighbors flatland x y)))
	       (if (alivep x y flatland)
		   (if (or (= 2 neighbors)
			   (= 3 neighbors))
		       (revive x y new-flatland)
		       (kill x y new-flatland))
		   (if (= 3 neighbors)
		       (revive x y new-flatland)
		       (kill x y new-flatland))))))
    (iterate-array 2 new-flatland
		   (update-cell v0 v1 flatland new-flatland))
      (display-flatland new-flatland)
      (sleep 1)
      (game-of-life new-flatland flatland)))

(defun main ()
  (let ((initial-flatland (make-flatland)))
    (map nil (lambda (xy)
	       (revive (car xy) (cdr xy) initial-flatland))
	 '((5 . 25) (5 . 26) (5 . 27) (4 . 25) (3 . 26)))
    (game-of-life initial-flatland (make-flatland))))