ライフゲーム

■2012-10-05 追記: いろいろ変えました。→ ライフゲーム 2 (高速化) - armbrust の日記

lispbuilder-sdl を Quicklisp で入れてみる - armbrust の日記 の続きです。

lispbuilder-sdlでライフゲーム書いてみた - masatoi’s blog
を参考にさせていただき、ちょこちょこ変えてみたりして遊んでいます。

で、「新しい銃 ｘ ３の宇宙船工場」とか作ってみたりして。
(このへんの情報は 宇宙船 (ライフゲーム) - Wikipedia とか グライダー銃 - Wikipedia あたりを見ました)

あ、永久に動き続けるパターンにはなってません。
宇宙船が反対側から出てきて衝突しちゃったら壊れちゃいます。
ちょうどいい場所に宇宙船イーターを出せるようにしてありますが、
まあ、このまま崩壊の過程を見るのも結構楽しいです。

■2012-10-01 追記: 写真を変更しました。ソースも変わってます。

以下、ソースです。
Lisp の基本が分かっていないので、だいぶ汚くしてしまったと思いますけど・・・。

■2012-10-01 追記: ALEXANDRIA と CL-PPCRE も使っています。
■2012-10-04 追記: update-next-gen に不要な処理が混じっていたので削除しました。
■2012-10-10 追記: cl-ppcre:split が不要なのに気づいたので削除しました。

life.cl:

;; original: http://d.hatena.ne.jp/masatoi/20111029/1319893156

(require :lispbuilder-sdl)
(require :lispbuilder-sdl-gfx)

;; ドットサイズとフィールドサイズ
(defparameter dt 3) ; 余白に 1 ドット使ってしまうので 2 以上で指定
(defparameter wx 240)
(defparameter wy 160)

;; いろいろ用意しておく
(defparameter world nil)
(defparameter map-init nil) ; 初期表示用
(defparameter gen 0) ; 世代表示用
(defparameter skip-gen 1) ; 2 以上にすると早送り、0 にすると止る


;; 部分的な初期配置を行う関数 (はみ出し置きには非対応)
(defun put-shape (world list-pos-shape)
  (let* ((pos   (nth 0 list-pos-shape))
         (shape (nth 1 list-pos-shape))
         (px (nth 0 pos))
         (py (nth 1 pos))
         (swx (length (nth 0 shape)))
         (swy (length shape)))
    (loop for i from 0 to (1- swx) do
      (loop for j from 0 to (1- swy) do
        (setf (aref world (+ px i) (+ py j))
              (if (string= (char (nth j shape) i) #\Space) 0 1))))))

;; フィールドの初期化
(defun init ()
  (setf world (make-array (list wx wy) :element-type 'fixnum))
  (load "map-init.cl") ; 初期配置のリストは別ファイルで書いておく
  (map nil #'(lambda (x) (put-shape world x)) map-init)
  (setf gen 0))


;; 生きている個体が隣接する8個のセルにどれだけいるかをカウントする
(defun count-neighboring-individual (world i j)
  (let* ((max-i (1- wx))
         (max-j (1- wy))
         (next-i (if (= i max-i) 0     (1+ i)))
         (prev-i (if (= i 0)     max-i (1- i)))
         (next-j (if (= j max-j) 0     (1+ j)))
         (prev-j (if (= j 0)     max-j (1- j))))
    (+ (aref world prev-i prev-j) (aref world prev-i j) (aref world prev-i next-j)
       (aref world i      prev-j)                       (aref world i      next-j)
       (aref world next-i prev-j) (aref world next-i j) (aref world next-i next-j))))


;; 1世代後のフィールドを返す
(defun update-next-gen (world)
  (let ((next-world (alexandria:copy-array world)))
    (loop for i from 0 to (1- wx) do
      (loop for j from 0 to (1- wy) do
        (let ((sell-value (aref world i j))
              (sell-neighboring (count-neighboring-individual world i j)))
          (cond ((and (zerop sell-value) ; 誕生
                      (= sell-neighboring 3))
                 (setf (aref next-world i j) 1))
                ((and (> sell-value 0) ; 過疎or過密
                      (or (<= sell-neighboring 1)
                          (>= sell-neighboring 4)))
                 (setf (aref next-world i j) 0))))))
    next-world))

(defun life ()
  (sdl:with-init ()
    (sdl:window (* dt wx) (* dt wy)) ; ウインドウのサイズ
    (setf (sdl:frame-rate) 60) ; フレームレートを60fpsに
    (init)
    (sdl:with-events ()
      (:quit-event () t) ; ウインドウが閉じられたときの処理
      (:idle ()

             (dotimes (n skip-gen)
               (setf world (update-next-gen world))
               (incf gen))

             (loop for i from 0 to (1- wx) do
               (loop for j from 0 to (1- wy) do
                 (sdl-gfx:draw-box (sdl:rectangle :x (* i dt) :y (* j dt) :w (1- dt) :h (1- dt))
                     :color (if (zerop (aref world i j))
                                (sdl:color :r #x55 :g #x55 :b #x55)
                                sdl:*white*))))

             (sdl:set-caption (format nil "generations: ~a" gen) nil) ; 世代表示
             (sdl:update-display)
             ))))

(life)

map-init.cl:

;; 反転用の関数など
(defun reverse-shape-v (shape)
  (reverse shape))

(defun reverse-shape-h (shape)
  (mapcar #'reverse shape))

(defun reverse-shape-vh (shape)
  (mapcar #'reverse (reverse shape)))


;; 新しい銃 左上方向に発射
(defparameter gun-lu
              '(
                "                                  "
                "               ooo              oo"
                "               o   o            oo"
                "               o    o             "
                "                o   o             "
                "                                  "
                " oo             o   o             "
                " oo            o    o             "
                "               o   o            oo"
                "               ooo              oo"
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "  o     o                         "
                " ooo   ooo                        "
                "oo o   o oo                       "
                "                                  "
                "                                  "
                "   o   o                          "
                "   o   o                          "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                " oo     oo                        "
                " oo     oo                        "
                ))

;; 新しい銃 右下方向に発射  (発射のタイミングがちょっと違う)
(defparameter gun-rd
              '(
                "                        oo     oo "
                "                        oo     oo "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                       oo o   o oo"
                "                       o  o   o  o"
                "                        ooo   ooo "
                "                                  "
                "                                  "
                "                                  "
                "                                  "
                "                 o                "
                "oo               oo               "
                "oo                oo              "
                "             oo  oo            oo "
                "                               oo "
                "                                  "
                "                                  "
                "             oo  oo               "
                "oo                oo              "
                "oo               oo               "
                "                 o                "
                ))

;; 新しい銃 右上方向に発射 (gun-rd を上下反転したもの)
(defparameter gun-ru (reverse-shape-v gun-rd))

;; 宇宙船を食うやつ
(defparameter eater
              '(
                "oo  "
                "o o "
                "  o "
                "  oo"
                ))

;; ブリンカー
(defparameter blinker
              '(
                "  o  "
                "  o  "
                "  o  "
                ))

;; 初期配置のリスト (座標と名前)
(defparameter map-init
      (list
       (list '( 20  10) gun-rd)
       (list '( 23 101) gun-ru)
       (list '( 96 101) gun-lu)
      ))



#|
;; repl から ↓ を評価して直接置いてみたりとか
(put-shape world (list '(220 75) eater))
(put-shape world (list '(220 10) blinker))

;; repl から ↓ を評価して更新速度を変えたり初期状態にしたりとか
(setf skip-gen 14)
(setf skip-gen  7)
(setf skip-gen  2)
(setf skip-gen  1)
(setf skip-gen  0)
(init)

;; あ、Windows の SBCL だと、実行中に repl が入力を受け付けないので・・・orz
|#