Common Lispの練習でライフゲーム

Lispの練習でライフゲームを作ってみた。まだCUIで眺めることしかできない。
適当なパターンをランダムに置くことだけはできるようにしてみた。

> (generate-random-lives)
> (lifegame)

ってやるとランダムな初期配置から一番メジャーなルールでライフゲームが動く。境界は周期的にした。

> (funcall glyder)
> (lifegame)

とかやるとglyderだったり適当なパターンをランダムに配置してライフゲームが動く。

見た目はこんな感じになる。

(defparameter *width* 80)
(defparameter *height* 30)
(defparameter *lives* (make-hash-table :test #'equal))

(defun count-surrounding-lives (pos lives)
  (let ((ctr 0))
    (mapc (lambda (neighbor)
            (if (gethash neighbor lives)
                (incf ctr)))
          (neighbors pos))
    ctr))

(defun neighbors (pos)
  (let* ((x (car pos))
         (y (cdr pos))
         (x-1 (mod (1- x) *width*))
         (x+1 (mod (1+ x) *width*))
         (y-1 (mod (1- y) *height*))
         (y+1 (mod (1+ y) *height*)))
    (list (cons x-1 y+1) (cons x  y+1) (cons x+1 y+1) (cons x+1 y)
          (cons x+1 y-1) (cons x y-1) (cons x-1 y-1) (cons x-1 y))))

(defun alivep (pos lives)
  (let ((surr (count-surrounding-lives pos lives)))
    (cond ((= surr 3) t)
          ((or (<= surr 1) (>= surr 4)) nil)
          (t (gethash pos lives)))))

(defun generate-random-lives (life-density)
  (let ((lives (make-hash-table :test #'equal)))
    (loop for x
       below *width*
       do (loop for y
             below *height*
             do (if (< (random 100) life-density)
                    (setf (gethash (cons x y) lives) t))))
    (setf *lives* lives)))

(defun reset-lives ()
  (setf *lives* (make-hash-table :test #'equal)))

(defun evolution ()
  (let ((new-lives (make-hash-table :test #'equal)))
    (mapc (lambda (pos)
            (if (alivep pos *lives*)
                (setf (gethash pos new-lives) t)))
          (gen-pairs *width* *height*))
    (setf *lives* new-lives)))

(defun gen-pairs (xrange yrange)
  (let ((lst ()))
    (loop for x
       below xrange
       do (loop for y
             below yrange
             do (push (cons x y) lst)))
    lst))

(defun lifegame ()
  (labels ((lifegame-sub (ctr)
             (fresh-line)
             (princ "Generation:")
             (princ ctr)
             (draw-lives)
             (evolution)
             (sleep 0.2)
             (lifegame-sub (incf ctr))))
    (lifegame-sub 0)))

(defun draw-lives ()
  (fresh-line)
  (loop for i
     below (+ 2 *width*)
     do (princ #\-))
  (loop for y
     below *height*
     do (progn (fresh-line)
               (princ #\|)
               (loop for x
                  below *width*
                  do (if (gethash (cons x y) *lives*)
                         (princ #\*)
                         (princ #\ )))
               (princ #\|)))
  (fresh-line)
  (loop for i
     below (+ 2 *width*)
     do (princ #\-)))

(defun maker (lst)
  (lambda ()
    (let* ((xoffset (random *width*))
           (yoffset (random *height*))
           (lstt (rotate (invert lst (random 2)) (random 4)))
           (width (length (car lstt)))
           (height (length lstt)))
      (loop for y
         below height
         do (loop for x
               below width
               do (if (= 1 (nth x (nth y lstt)))
                      (setpoint (+ xoffset x) (+ yoffset y))))))))


(defparameter *glyder-template* '((1 1 1)
                                  (1 0 0)
                                  (0 1 0)))

(defparameter *light-spacecraft-template* '((0 1 0 0 1)
                                            (1 0 0 0 0)
                                            (1 0 0 0 1)
                                            (1 1 1 1 0)))

(defun setpoint (x y)
  (setf (gethash (cons x y) *lives*) t))

(defun invert (lst inversion)
  (case inversion
    (0 lst)
    (1 (invertx lst))))

(defun invertx (lst)
  (mapcar #'reverse lst))

(defun inverty (lst)
  (reverse lst))

(defun transpose (lst)
  (labels ((col (lst)
             (if (some #'null lst)
                 nil
                 (cons (mapcar #'car lst)
                       (col (mapcar #'cdr lst))))))
    (col lst)))

(defun rotate (lst rotation)
  (case rotation
    (0 lst)
    (1 (invertx (transpose lst)))
    (2 (inverty (invertx lst)))
    (3 (inverty (transpose lst)))))

(setf glyder (maker *glyder-template*))
(setf light-spacecraft (maker *light-spacecraft-template*))

Land of Lispを読んだせいで多少影響でてる気がする。
transpose関数なんかはなかなかLispっぽくかけた気がする。
GUIに拡張するのもやりたいけどルール変えるのもやってみたいなあ。