(declaim (optimize (speed 3) (safety 1)))

(deftype cell () '(integer 0 2))
(deftype brain () '(simple-array cell (*)))
(deftype neighbours () '(simple-array cell (8)))
(deftype array-index () `(integer 0 ,array-dimension-limit))

(defun make-brain (w h)
  (declare (type fixnum w h))
  (make-array (* w h) :element-type 'cell))

(defun make-initialised-brain (w h)
  (let ((cells (make-brain w h))
        (mid (floor w 2)))
    (setf (aref cells mid) 1)
    (setf (aref cells (1+ mid)) 1)
    cells))

(defun rules (state neighbours)
  (declare (type cell state)
           (type neighbours neighbours))
  (case state
    (1 2)
    (2 0)
    (t (if (= 2 (loop for x across neighbours counting (= 1 x))) 1 0))))

(defun neighbours (cells i w h)
  (declare (type brain cells)
           (type array-index i)
           (type fixnum w h))
  (let ((result (the neighbours (load-time-value (make-array 8 :element-type 'cell))))
        (l (length cells))
        (mx (1- w))
        (my (1- h)))
    (multiple-value-bind (y x)
        (truncate i w)
      (flet ((up (i) (if (zerop y) (- (+ i l) w) (- i w)))
             (dn (i) (if (= y  my) (- (+ i w) l) (+ i w)))
             (lt (i) (if (zerop x) (1- (+ i w))  (1- i)))
             (rt (i) (if (= x  mx) (1+ (- i w))  (1+ i))))
        (let* ((u (up i))
               (d (dn i))
               (l (lt i))
               (r (rt i))
               (ul (lt u))
               (ur (rt u))
               (dl (lt d))
               (dr (rt d)))
          (setf (aref result 0) (aref cells ul)
                (aref result 1) (aref cells u)
                (aref result 2) (aref cells ur)
                (aref result 3) (aref cells l)
                (aref result 4) (aref cells r)
                (aref result 5) (aref cells dl)
                (aref result 6) (aref cells d)
                (aref result 7) (aref cells dr))
          result)))))

(defun evolve (src w h)
  (declare (type brain src))
  (let* ((l (length src))
         (dst (make-brain w h)))
    (declare (type brain dst))
    (loop for i below l
       do (setf (aref dst i)
                (rules (aref src i) (neighbours src i w h))))
    dst))

(defun simulate (steps initial w h)
  (declare (type fixnum steps w h)
           (type brain initial))
  (loop with brain = initial
     repeat steps
     do (setf brain (evolve brain w h))
     finally (return brain)))

(defun benchmark ()
  (format *trace-output* "Benchmarking on ~A ~A~%"
          (lisp-implementation-type)
          (lisp-implementation-version))
  ;; Warmup.
  (simulate 10000 (make-initialised-brain 16 16) 16 16)
  (loop
     for (w h i) in '((32    32  32768)
                      (64    64  8192)
                      (128  128  2048)
                      (256  256  512)
                      (512  512  128)
                      (1024 1024 32)
                      (2048 2048 8)
                      (4096 4096 2))
     do #+ccl (gc)
        #+sbcl (gc :full t)
        (let ((initial (make-initialised-brain w h)))
          (format *trace-output* "*** ~Dx~D ~D iteration~:P ***~%" w h i)
          (time (simulate i initial w h))
          (finish-output *trace-output*)))
  (values))