A quick game of life algorithm.

fast-gol.lisp

(ql:quickload "lispbuilder-sdl")
(ql:quickload "lispbuilder-sdl-gfx")

(deftype triplet () '(unsigned-byte 16))

(defmacro pixel-to-cell (val) `(/ ,val *cell-size*))
(defmacro cell-to-col (val) `(floor ,val 3))

(defmacro pixel-to-col (val) `(cell-to-col (pixel-to-cell ,val)))

(defmacro cell-to-pixel (val) `(* *cell-size* ,val))
(defmacro col-to-cell (val) `(* ,val 3))
(defmacro col-to-pixel (val) `(* *cell-size* (col-to-cell ,val)))

(defmacro edge (cell) `(ldb (byte 1 15) ,cell))
(defmacro next-states (cell) `(ldb (byte 3 12) ,cell))
(defmacro cur-states (cell)  `(ldb (byte 3 9) ,cell))
(defmacro a-neighbors (cell) `(ldb (byte 3 6) ,cell))
(defmacro b-neighbors (cell) `(ldb (byte 3 3) ,cell))
(defmacro c-neighbors (cell) `(ldb (byte 3 0) ,cell))


;; gets next cell states based on current states and neighbors
(defun cell-changes (cell)
  (let* ((cur-states (cur-states cell))
         (a (ldb (byte 1 2) cur-states))
         (b (ldb (byte 1 1) cur-states))
         (c (ldb (byte 1 0) cur-states))
         (a-neighbors (+ b (a-neighbors cell)))
         (b-neighbors (+ a c (b-neighbors cell)))
         (c-neighbors (+ b (c-neighbors cell))))
    (let ((res 0))
      (setf (ldb (byte 1 2) res) (case a-neighbors
                                   (2 a)
                                   (3 1)
                                   (otherwise 0))
            (ldb (byte 1 1) res) (case b-neighbors
                                   (2 b)
                                   (3 1)
                                   (otherwise 0))
            (ldb (byte 1 0) res) (case c-neighbors
                                   (2 c)
                                   (3 1)
                                   (otherwise 0)))
      res)))

;; lookup-table optimization
;; maps cell triplets and neighbor counts (bitmap) to the next cell states
(defparameter *second-pass-table* (make-array 4096 :element-type '(unsigned-byte 3)
                                              :initial-contents
                                              (loop for x below 4096 collect
                                                   (cell-changes x))))





;;  keep track of cells in triplets
;;  and keep track of cells that will change next generation in a
;;  change list

;; triplet and cell are interchangeable

;;
;; to create the next generation we make two passes over the change
;; list

;; first pass
;; - for each triplet in the change list
;;   - move the next cell states to the current cell states
;;   - update neighbor counts of neighboring triplets based on the change
;;   - draw cells based on the change
;;
;; second pass
;; - for each adjacent triplet in the change list (including the changed triplet)
;;   - check neighbor counts and current cell states
;;   - if the cell states will change, set the next cell state in the triplet
;;   - and add it to the change list
;;   - flip a bit in another array to avoid checking or adding the
;;     same triplet to the change list more than once



;; there are more optimizations I can do with this algorithm
;; (precalculating optimized update functions for the first pass, etc.)
;; but the graphics are the bottleneck most of the time


;;  start-list is a list ((x y) (x y) (x y))
;; of live cells

;; width must be a multiple of 3 (because of the triplet structure)
(defun main (&key start-list (cell-size 4)
               (height 56) (width 240))
  (declare (optimize (speed 3))
           (type fixnum cell-size width height))
  (assert (zerop (rem width 3)) () "Width must be a multiple of 3.")
  
  (sdl:window (* cell-size width) (* cell-size height) :hw t)
  (let* ((change-list (list))
        (num-rows height)
         (num-cols (/ width 3))
         (draw-surf (sdl:create-surface (* cell-size width) (* cell-size height) :type :sw))
         (added-map (make-array `(,num-rows ,num-cols) :element-type 'boolean))
         (table (make-array `(,num-rows ,num-cols) :element-type 'triplet)))
    (labels ((draw-live-cell (x y surf)
               (sdl-gfx-cffi::box-color surf
                                       (* cell-size x) (* cell-size y)
                                       (* cell-size (1+ x)) (* cell-size (1+ y))
                                       #xFFFFFFFF))
             (draw-dead-cell (x y surf)
               (sdl-gfx-cffi::box-color surf
                                       (* cell-size x) (* cell-size y)
                                       (* cell-size (1+ x)) (* cell-size (1+ y))
                                       #x000000FF))
             (draw-states (states x y surf)
               ;; draw a cell
               (let ((x (* 3 x)))
                 (if (plusp (ldb (byte 1 2) states))
                     (draw-live-cell x y surf)
                     (draw-dead-cell x y surf))
                 ;; draw b cell
                 (if (plusp (ldb (byte 1 1) states))
                     (draw-live-cell (+ x 1) y surf)
                     (draw-dead-cell (+ x 1) y surf))
                 ;; draw c cell
                 (if (plusp (ldb (byte 1 0) states))
                     (draw-live-cell (+ x 2) y surf)
                     (draw-dead-cell (+ x 2) y surf))))

             ;; update neighbor counts of surrounding triplets
             (update-neighbors (cell x y)
               (let* ((next-states (next-states cell))
                      (cur-states (cur-states cell))
                      (na (ldb (byte 1 2) next-states))
                      (nb (ldb (byte 1 1) next-states))
                      (nc (ldb (byte 1 0) next-states))
                      (a (ldb (byte 1 2) cur-states))
                      (b (ldb (byte 1 1) cur-states))
                      (c (ldb (byte 1 0) cur-states))
                      (da (- na a))
                      (db (- nb b))
                      (dc (- nc c)))
                 ;; abc abc abc
                 ;; abc abc abc
                 ;; abc abc abc
                 (let ((lx (if (minusp (1- x)) (1- num-cols) (1- x)))
                       (rx (if (>= (1+ x) num-cols) 0 (1+ x)))
                       (uy (if (minusp (1- y)) (1- num-rows) (1- y)))
                       (dy (if (>= (1+ y) num-rows) 0 (1+ y))))
                   (symbol-macrolet ((ul (aref table uy lx))
                                     (u  (aref table uy x))
                                     (ur (aref table uy rx))
                                     (l  (aref table y lx))
                                     (r  (aref table y rx))
                                     (dl (aref table dy lx))
                                     (d  (aref table dy x))
                                     (dr (aref table dy rx)))
                     (unless (zerop da)
                       ;; ul c
                       (incf (c-neighbors ul) da)
                       ;; u ab
                       (incf (a-neighbors u) da)
                       (incf (b-neighbors u) da)
                       ;; l c
                       (incf (c-neighbors l) da)
                       ;; dl c
                       (incf (c-neighbors dl) da)
                       ;; d ab
                       (incf (a-neighbors d) da)
                       (incf (b-neighbors d) da))

                     (unless (zerop db)
                       ;; u abc
                       (incf (a-neighbors u) db)
                       (incf (b-neighbors u) db)
                       (incf (c-neighbors u) db)
                       ;; d abc
                       (incf (a-neighbors d) db)
                       (incf (b-neighbors d) db)
                       (incf (c-neighbors d) db))

                     (unless (zerop dc)
                       ;; u bc
                       (incf (b-neighbors u) dc)
                       (incf (c-neighbors u) dc)
                       ;; ur a
                       (incf (a-neighbors ur) dc)
                       ;; r a
                       (incf (a-neighbors r) dc)
                       ;; d bc
                       (incf (b-neighbors d) dc)
                       (incf (c-neighbors d) dc)
                       ;; dr a
                       (incf (a-neighbors dr) dc))))))

             ;; get the next cell states
             ;; based on the current states and neighbor counts
             (cell-changes-p (cell)
               (let* ((cur-states (cur-states cell))
                      (a (ldb (byte 1 2) cur-states))
                      (b (ldb (byte 1 1) cur-states))
                      (c (ldb (byte 1 0) cur-states))
                      (a-neighbors (+ b (a-neighbors cell)))
                      (b-neighbors (+ a c (b-neighbors cell)))
                      (c-neighbors (+ b (c-neighbors cell))))
                 (let ((res 0))
                   (setf (ldb (byte 1 2) res) (case a-neighbors
                                                (2 a)
                                                (3 1)
                                                (otherwise 0))
                         (ldb (byte 1 1) res) (case b-neighbors
                                                (2 b)
                                                (3 1)
                                                (otherwise 0))
                         (ldb (byte 1 0) res) (case c-neighbors
                                                (2 c)
                                                (3 1)
                                                (otherwise 0)))
                   res)))
             
             ;; clear board
             (clear-table ()
               (loop for y below num-rows do
                    (loop for x below num-cols do
                         (setf (aref table y x)
                               (let ((cell 0))
                                 (when (or (zerop x)
                                           (zerop y)
                                           (= x (1- num-cols))
                                           (= y (1- num-rows)))
                                   
                                   (setf (ldb (byte 1 15) cell) 1))
                                 cell)))))
             ;; clear added/checked table
             (clear-map ()
               (loop for y below num-rows do
                    (loop for x below num-cols do
                         (setf (aref added-map y x) nil)))))

      
      (labels ((first-loop ()
                 (let ((surf (sdl:fp draw-surf)))
                   (loop for el in change-list do
                        (destructuring-bind (x . y) el
                          (let* ((cell (aref table y x))
                                 (next-states (next-states cell))
                                 (cur-states (cur-states cell))
                                 (mask (ash (logand #b1111111000000000) -9)))
                            (when (/= next-states cur-states)
                              (draw-states next-states x y surf)
                              (update-neighbors cell x y)

                              (setf (cur-states (aref table y x))
                                    (next-states (aref table y x))))
                            )))))
               (second-loop ()
                 (let ((new-list (list)))
                   (loop for el in change-list do
                        (destructuring-bind (x . y) el
                          (loop for y from (1- y) to (1+ y) do
                               (loop for x from (1- x) to (1+ x) do
                                    (let ((x (mod x num-cols))
                                          (y (mod y num-rows)))
                                      (unless (aref added-map y x)
                                        (let* ((cell (aref table y x))
                                               (res (aref *second-pass-table* (logand #b0000111111111111 cell))))
                                          (when (/= (cur-states (aref table y x))
                                                    res)
                                            (setf (next-states (aref table y x))
                                                  res)
                                            (push (cons x y) new-list)))
                                        (setf (aref added-map y x) t)))))))
                   
                   (setf change-list new-list))))
        
        
        (sdl:with-init ()

          
          (sdl:clear-display sdl:*black*)

          (sdl:update-display)
          
          (clear-table)
          (clear-map)
          
          (loop for cell in start-list do
             ;; set next state
             ;; add to change list
               (destructuring-bind (x y) cell
                 (multiple-value-bind (col cell) (floor x 3)
                   (setf (ldb (byte 1 (- 2 cell)) (next-states (aref table y col)))
                         1)
                   (unless (aref added-map y col) (push (cons col y) change-list)
                           (setf (aref added-map y col) t)))))
          (clear-map)
          (setf (sdl:frame-rate) 0)
          (let ((update nil))
            (sdl:with-events ()
              (:quit-event () t)
              (:key-down-event (:key k) (when (eql :sdl-key-space k)
                                          (setf update (not update))))
              (:idle ()
                     (when update
                       (first-loop)
                       (second-loop)
                       
                       (clear-map)
                       (sdl:blit-surface draw-surf)
                       (sdl:update-display)
                       (setf update t))))))))))