hashlife

解説と続きを書いた→ http://d.hatena.ne.jp/Nos/20140928/1411884782
前回lispbuilderでライフゲームを作った。ただあれはあまり大きなサイズのものは動かせない。
大きいサイズのパターンを扱う手段としてはhashlifeという超高速のアルゴリズムがあって、一度実装してみたかったので今回挑戦してみた。

上のパターンはpuffer train。
hashlifeを採用した利点として上下キーでステップの刻み巾を変更出来る。上を押して行くと加速する！あとマウスで落書きもできるようにしてみた(消しゴムは実装してない)。

あんまりコードが整理されていないが、とりあえず動いて嬉しかったので貼ってみるというエントリー。

参考にしたもの

• hashlife自体について
  • python implementation http://davidbau.com/archives/2006/07/26/python_curses_life.html
  • original paper http://www.sciencedirect.com/science/article/pii/0167278984902513 or https://www.lri.fr/~filliatr/m1/gol/gosper-84.pdf
  • article at Dr. Dobbs http://www.drdobbs.com/jvm/an-algorithm-for-compressing-space-and-t/184406478
• lispbuilder-sdl api https://code.google.com/p/lispbuilder/wiki/UsingLispbuilderSDL

本体

GUIとか初期パターンは一番最後のlife関数の中で設定している。

シェルスクリプトとして実行出来るという小技を使ってみたので、以下に実行権限をつけて

$ ./hashlife.lisp

で動くはず。非常にメモリ食いなのでヒープを大きくするオプションをつけてあるが、それでも調子に乗ってマウスで落書きしているとそのうちヒープを使い切って落ちる。上のpythonの実装のようにハッシュテーブル(board-cache)を時々構築し直すといいのだと思う。→むしろ各nodeの構造体のキャッシュにハッシュテーブルを使っているからだった。週末に改めて更新しようと思う。

quicklispがインストールされている必要がある。macでlispbuilder-sdlが動かないという場合は前エントリー参照。

hashlife.lisp:

#!/bin/bash
#|
# http://speely.wordpress.com/2010/11/27/writing-scripts-with-common-lisp/ 
exec sbcl --dynamic-space-size 4Gb --script $0 # hashlife consumes much memory
exit
|#

;; for debug
;; (declaim (optimize (debug 3) (safety 3)
;;                    (speed 0) (space 0) (compilation-speed 0)))
(setf *print-circle* t)

(declaim (optimize (debug 0) (safety 0)
                   (speed 3) (space 3) (compilation-speed 0)))


;;;; cores

(defstruct node
  nw ne sw se (level -1 :type fixnum) (id -1 :type fixnum) population board (result (make-hash-table)))

(defstruct (board (:constructor make-board-raw))
  root cache origin (next-id -1 :type fixnum) empty-nodes zero one)

(defun make-board ()
  (let ((b (make-board-raw :cache (make-hash-table :test #'equalp)
			   :origin (cons 0 0))))
    (let ((zero (make-node :level 0 :id 0 :population 0 :board b))
	  (one  (make-node :level 0 :id 1 :population 1 :board b))
	  (cache (board-cache b)))
      (loop for i below 16 do
	   (setf (gethash (list (if (logbitp 0 i) 1 0)
				(if (logbitp 1 i) 1 0)
				(if (logbitp 2 i) 1 0)
				(if (logbitp 3 i) 1 0)) cache)
		 (make-node :level 1 :id (+ i 2)
			    :population (logcount i)
			    :board b
			    :nw (if (logbitp 0 i) one zero)
			    :ne (if (logbitp 1 i) one zero)
			    :sw (if (logbitp 2 i) one zero)
			    :se (if (logbitp 3 i) one zero))))
      (setf (board-zero b)        zero
	    (board-one  b)        one
	    (board-next-id b)     18
	    (board-root b)        zero
	    (board-empty-nodes b) (list zero))
      b)))

(defun board-get-node (b nw ne sw se)
  (let ((ids (mapcar #'node-id (list nw ne sw se))))
    (unless (gethash ids (board-cache b))
      (setf (gethash ids (board-cache b))
	    (make-node :nw nw :ne ne :sw sw :se se :level (1+ (node-level nw))
		       :id (incf (board-next-id b)) :population (reduce #'+ (mapcar #'node-population (list nw ne sw se))) :board b)))
    (gethash ids (board-cache b))))

(defun board-get-empty (b level)
  (declare (fixnum level))
  (if (< level (the fixnum (length (board-empty-nodes b))))
      (nth level (board-empty-nodes b))
      (let ((e (board-get-empty b (1- level))))
	(board-get-node b e e e e))))

(defun node-width (n)
  (ash 1 (node-level n)))

(defun node-step-size (n)
  (ash 1 (- (node-level n) 2)))

(defun node-get (n x y)
  (cond ((or (< x 0) (< y 0)
	     (>= x (node-width n)) (>= y (node-width n))) 0)
	((zerop (node-level n)) (node-id n))
	(t (let ((half (/ (node-width n) 2)))
	     (if (< x half)
		 (if (< y half)
		     (node-get (node-nw n) x y)
		     (node-get (node-sw n) x (- y half)))
		 (if (< y half)
		     (node-get (node-ne n) (- x half) y)
		     (node-get (node-se n) (- x half) (- y half))))))))
      
(defun node-get-list (n origx origy &optional rect)
  (let ((width (node-width n))
	(half (/ (node-width n) 2)))
    (when rect
      (destructuring-bind (x0 y0 x1 y1) rect
	(when (or (< x1 origx) (< y1 origy)
		  (<= (+ origx width) x0) (<= (+ origy width) y0))
	  (return-from node-get-list nil))))
    (cond
      ((zerop (node-level n))
       (if (= 1 (node-id n))
	   (list (list origx origy))
	   nil))
      (t (append
	  (node-get-list (node-nw n) origx origy rect)
	  (node-get-list (node-ne n) (+ origx half) origy rect)
	  (node-get-list (node-sw n) origx (+ origy half) rect)
	  (node-get-list (node-se n) (+ origx half) (+ origy half) rect))))))

(defun node-set (n new origx origy x y)
  (let ((width (node-width n))
	(half  (ash (node-width n) -1))
	(b  (node-board n)))
    (if (or (< x origx) (< y origy)
	    (<= (+ origx width) x) (<= (+ origy width) y))
	(error "node-set out of range: ~a" (list x y))
	(if (zerop (node-level n))
	    (if new (board-one b) (board-zero b))
	    (let ((nw (node-nw n))
		  (ne (node-ne n))
		  (sw (node-sw n))
		  (se (node-se n)))
	      (if (< y (+ origy half))
		  (if (< x (+ origx half))
		      (board-get-node b (node-set nw new origx origy x y) ne sw se)
		      (board-get-node b nw (node-set ne new (+ origx half) origy x y) sw se))
		  (if (< x (+ origx half))
		      (board-get-node b nw ne (node-set sw new origx (+ origy half) x y) se)
		      (board-get-node b nw ne sw (node-set se new (+ origx half) (+ origy half) x y)))))))))

(defmacro defnn__ ()
  "define sub-sub-quad accessors:
nn00 nn01 nn02 nn03
nn04 nn05 nn06 nn07
nn08 nn09 nn10 nn11
nn12 nn13 nn14 nn15"
  `(progn
     ,@(let ((l '(nw ne sw se)))
	    (loop for i below 4 append
		 (loop for j below 4 collect
		      `(defun ,(intern (format nil "NN~2,'0d" (+ (* 1 (mod   i 2))
							     (* 4 (floor i 2))
							     (* 2 (mod   j 2))
							     (* 8 (floor j 2))))) (n)
			 (,(intern (format nil "NODE-~a" (nth i l))) (,(intern (format nil "NODE-~a" (nth j l))) n))))))))
(defnn__)
(defun sub-sub-quad-list (n)
  (list (nn00 n) (nn01 n) (nn02 n) (nn03 n)
	(nn04 n) (nn05 n) (nn06 n) (nn07 n)
	(nn08 n) (nn09 n) (nn10 n) (nn11 n)
	(nn12 n) (nn13 n) (nn14 n) (nn15 n)))

(defun node-get-subquad (n x y)
  (let ((b (node-board n)))
    (case y
      (0 (case x
	   (0 (node-nw n))
	   (1 (board-get-node b (nn01 n) (nn02 n) (nn05 n) (nn06 n)))
	   (2 (node-ne n))))
      (1 (case x
	   (0 (board-get-node b (nn04 n) (nn05 n) (nn08 n) (nn09 n)))
	   (1 (board-get-node b (nn05 n) (nn06 n) (nn09 n) (nn10 n)))
	   (2 (board-get-node b (nn06 n) (nn07 n) (nn10 n) (nn11 n)))))
      (2 (case x
	   (0 (node-sw n))
	   (1 (board-get-node b (nn09 n) (nn10 n) (nn13 n) (nn14 n)))
	   (2 (node-se n)))))))

(defmacro defn_ ()
  "define (mutually overlapping) sub-quad accessors:
n0 n1 n2
n3 n4 n5
n6 n7 n8"
  `(progn ,@(loop for i below 3 append
		 (loop for j below 3 collect
		      `(defun ,(intern (format nil "N~d" (+ j (* 3 i)))) (n)
			 (node-get-subquad n ,j ,i))))))
(defn_)
(defun sub-quad-list (n)
  (list (n0 n) (n1 n) (n2 n)
	(n3 n) (n4 n) (n5 n)
	(n6 n) (n7 n) (n8 n)))

(defun life-rule (self count)
  (if (if self
	  (member count '(2 3))
	  (= count 3))
      1 0))

(defun node-next-center% (n step)
  (cond ((zerop step) (n4 n))
	((<= step (node-step-size n))
	 (if (= (node-level n) 2)
	     (let* ((l   (sub-sub-quad-list n))
		    (b   (node-board n))
		    (one (board-one b))
		    (ids (mapcar #'life-rule
				 (loop for x in '(5 6 9 10) collect
				      (eq (nth x l) one))
				 (loop for x in '(5 6 9 10) collect
				      (count one (loop for dx in '(-5 -4 -3 -1 1 3 4 5) collect
						      (nth (+ x dx) l)))))))
	       (gethash ids (board-cache b)))
	     (let* ((b (node-board n))
		    (halfstep (ash (node-step-size n) -1))
		    (halfstepp (>= step halfstep))
		    (remain (if halfstepp (- step halfstep) step)))
	       (let ((nexts (mapcar
			     (if halfstepp (lambda (n) (node-next-center n halfstep)) #'n4)
			     (sub-quad-list n))))
		 (destructuring-bind (n0 n1 n2 n3 n4 n5 n6 n7 n8) nexts
		   (board-get-node b
				   (node-next-center (board-get-node b n0 n1 n3 n4) remain)
				   (node-next-center (board-get-node b n1 n2 n4 n5) remain)
				   (node-next-center (board-get-node b n3 n4 n6 n7) remain)
				   (node-next-center (board-get-node b n4 n5 n7 n8) remain)))))))
	(t (error "something went wrong"))))

(defun node-next-center (n step)
  (unless (gethash step (node-result n))
    (setf (gethash step (node-result n))
	  (node-next-center% n step)))
  (gethash step (node-result n)))
      

(defun board-trim% (b)
  "trim board. return non-nil if success"
  (let ((pop (node-population (board-root b))))
    (cond
      ((zerop pop)
       (prog1
	   (not (zerop (node-level (board-root b))))
	 (setf (board-root b) (board-zero b)
	       (board-origin b) (cons 0 0))))
      (t
       (let* ((subquads (sub-quad-list (board-root b)))
	      (pos (position pop (mapcar #'node-population subquads))))
	 (when pos
	   (setf (board-root b) (nth pos subquads))
	   (incf (car (board-origin b)) (* (mod   pos 3) (/ (node-width (board-root b)) 2)))
	   (incf (cdr (board-origin b)) (* (floor pos 3) (/ (node-width (board-root b)) 2)))))))))

(defmacro while (pred &body body)
  `(loop (unless ,pred (return))
      ,@body))

(defun board-trim (b)
  (while (board-trim% b)))

(defun board-double (b)
  (let ((n (board-root b)))
    (if (zerop (node-level n))
	(progn
	  (decf (car (board-origin b)) 1)
	  (decf (cdr (board-origin b)) 1)
	  (setf (board-root b)
		(if (zerop (node-population n))
		    (board-get-empty b 1)
		    (gethash '(0 0 0 1) (board-cache b)))))
	(let ((e (board-get-empty b (1- (node-level (board-root b))))))
	  (decf (car (board-origin b)) (/ (node-width n) 2))
	  (decf (cdr (board-origin b)) (/ (node-width n) 2))
	  (setf (board-root b)
		(board-get-node b (board-get-node b e e e (node-nw n))
				(board-get-node b e e (node-ne n) e)
				(board-get-node b e (node-sw n) e e)
				(board-get-node b (node-se n) e e e)))))
    b))
	
    

(defun board-clear (b)
  (setf (board-root b) (board-zero b)
	(board-origin b) (cons 0 0)))

(defun board-get (b x y)
  (let ((r (board-root b)))
    (node-get r (- x (car (board-origin b))) (- y (cdr (board-origin b)) ))))

(defun board-get-all (b rect)
  (let ((r (board-root b)))
    (node-get-list r (car (board-origin b)) (cdr (board-origin b)) rect)))

(defun node-within (n x y)
  (and (<= 0 x) (< x (node-width n))
       (<= 0 y) (< y (node-width n))))

(defun board-within (b x y)
  (node-within (board-root b) (- x (car (board-origin b))) (- y (cdr (board-origin b)))))

(defun board-set (b new x y)
  (while (not (board-within b x y))
    (board-double b))
  (setf (board-root b)
	(node-set (board-root b) new
		  (car (board-origin b)) (cdr (board-origin b))
		  x y)))

(defun board-print-rect (b rect)
  (destructuring-bind (x0 y0 x1 y1) rect
  (let ((poss (board-get-all b rect)))
    (loop for y from y0 to y1
          for xs = (remove-if-not (lambda (p) (= y (cadr p))) poss) do
	 (progn (fresh-line)
		(loop for x from x0 to x1 do
		     (princ
		      (if (find x xs :key  #'car)
			  #\o #\.))))))))

(defun board-step (b step)
  (while (or (< (node-step-size (board-root b)) step)
	     (zerop (node-level (board-root b))))
    (board-double b))
  (let ((diff (node-width (board-root b))))
    (board-double b)
    (board-double b)
    (incf (car (board-origin b)) diff)
    (incf (cdr (board-origin b)) diff)
    (setf (board-root b) (node-next-center (board-root b) step))))

#|
(defparameter *b* (make-board))
(board-clear *b*) (mapcar (lambda (pos) (board-set *b* t (car pos) (cadr pos))) '((0 0) (0 -1) (-1 -2) (-1 0) (-2 0))) (board-print-rect *b* '(-2 -2 2 2))
(board-step *b* 1)(board-print-rect *b* '(-2 -2 2 2))
(board-step *b* 4)(board-print-rect *b* '(-2 -2 2 2))

|#

;;;; gui codes

#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
                                       (user-homedir-pathname))))
  (when (probe-file quicklisp-init)
    (load quicklisp-init)))
(ql:quickload :lispbuilder-sdl)

(defparameter *board* nil)

(defun life ()
  (setf *board* (make-board))
  (let ((scale 1)
	(w 700)
	(h 400)
	(origx -40) ; coodinate of window top left
	(origy -200)
	(mouse-state (make-hash-table))
	(prevpos nil)
	(update t)
	(step-size 1))

    ;; initial pattern

    ;; (mapcar (lambda (pos) (board-set *board* t (car pos) (cadr pos))) '((0 -1) (1 -1) (-1 0) (0 0) (0 1))) ; r pentomino
    ;; (mapcar (lambda (pos) (board-set *board* t (car pos) (cadr pos))) '((0 0) (0 -1) (-1 -2) (-1 0) (-2 0))) ; glider
    ;; (mapcar (lambda (pos) (board-set *board* t (car pos) (cadr pos))) '((50 40) (50 41) (50 42) (50 43) (50 44) (50 45) (50 46) (50 47) (50 48) (50 49))) ; pentadecathlon
    ;;(dotimes (i (floor (/ (* w h) scale scale 3))) ; random
    ;;	     (board-set *board* t (random (/ w scale)) (random (/ h scale))))
    (loop for y from 0			;puffer train http://www.argentum.freeserve.co.uk/lex_p.htm#puffertrain
          for l in '(".OOO...........OOO"
		     "O..O..........O..O"
		     "...O....OOO......O"
		     "...O....O..O.....O"
		     "..O....O........O.")
	 do (loop for x from 0
		  for c across l
		 do (board-set *board* (char= c #\O) (- y) x)))
	 
	 
    (labels ((get-rect ()
	       (list origx origy (+ origx (floor w scale)) (+ origy (floor h scale))))
	     (board-coodinate (x y)
	       (list (+ origx (floor x scale))
		     (+ origy (floor y scale))))
	     (display-coodinate (x y)
	       (list (* scale (- x origx))
		     (* scale (- y origy))))
	     (draw-cell (x y color)
	       (sdl:draw-box (sdl:rectangle :x (* scale (- x origx))
					    :y (* scale (- y origy))
					    :w scale
					    :h scale)
				       :color color)))
      (sdl:with-init ()
	(sdl:window w h :title-caption "life")
	(setf (sdl:frame-rate) 30)

	(sdl:with-events ()
	  (:quit-event () t)
	  (:key-down-event (:key key)
			   (case key
			     (:sdl-key-q    (sdl:push-quit-event))
			     (:sdl-key-up   (setf step-size (* step-size 2)))
			     (:sdl-key-down (when (not (= step-size 1))
					      (setf step-size (/ step-size 2))))))
	  (:mouse-button-down-event (:button button :x x :y y)
				    (setf (gethash button mouse-state) t
					  prevpos (board-coodinate x y))
				    (when (= button sdl:sdl-button-left)
				      ;; (format t "~&!1") (finish-output)
				      (setf update nil)
				      (destructuring-bind (x y) (board-coodinate x y)
					(board-set *board* t x y))))
	  (:mouse-button-up-event (:button button)
				  (setf (gethash button mouse-state) nil
					prevpos nil)
				  (when (= button sdl:sdl-button-left)
				    (setf update t)))
	  (:mouse-motion-event (:x x :y y)
	    (when (gethash sdl:sdl-button-left mouse-state)
	      (destructuring-bind (x y) (board-coodinate x y)
		(if (and prevpos (not (and (= x (car  prevpos))
					   (= y (cadr prevpos)))))
		    (destructuring-bind (x0 y0) prevpos
		      (if (> (abs (- x x0)) (abs (- y y0)))
			  (loop for dx to (abs (- x x0))
			        for xx =  (abs (- x x0))
			     do (board-set
				 *board* t
				 (+ x0 (* (- x x0) (/ dx xx)))
				 (+ y0 (* (- y y0) (/ dx xx)))))
			  (loop for dy to (abs (- y y0))
			        for yy =  (abs (- y y0))
			     do (board-set
				 *board* t
				 (+ x0 (* (- x x0) (/ dy yy)))
				 (+ y0 (* (- y y0) (/ dy yy)))))))
		    (board-set *board* t x y))
		(setf prevpos (list x y)))))
	  (:idle ()
		 (sdl:clear-display sdl:*black*)
		 (when update
		     (board-step *board* step-size)
		     (board-trim *board*))
		 (loop for pos in (board-get-all *board* (get-rect)) do
		      (draw-cell (car pos) (cadr pos) sdl:*white*))
		 (sdl:update-display)))))))

(compile 'life)

;;;; run
#+sbcl (sb-int:with-float-traps-masked (:invalid) (life))
#-sbcl (life)

todo?

• ヒープを適宜解放する
• UI:移動、ズームイン/アウト
• ファイルを読めるようにする
• コンパイルの正しい作法を知らない