ehaliewicz/fast-gol.lisp

## 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))))))))))
	(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))))))))))