スクリーンキャスト→mov→gif (mac)
スクリーンキャプチャをgifに変換したい
QuickTime Playerで ファイル→新規画面収録 でスクリーンを動画キャプチャ出来る。
Mac OS X で動画のスクリーンキャプチャを撮る方法 - maruko2 Note.
movファイルができるが、gifsicleというプログラムでgif形式に変換出来る。homebrewでもmacportsでも入る。
Mac で MOV ファイルをアニメーション GIF に変換 - present
$ ffmpeg -i input.mov -s 400x300 -pix_fmt rgb24 -r 10 -f gif - | gifsicle --delay=10 --optimize=3 > output.gif'
ffmpegの-rオプションがフレームレート、-sが画面サイズ(横x縦)、gifsicleの--delayオプションがディレイが100分の何秒かという意味。
auto-save-buffers.el に1行パッチを当てた
その昔、「紙」というwindows用のフリーソフトがあった。今で言うevernoteみたいなスクラップ機能が充実したテキストエディタで、軽快な動作、また多数のファイルを高速に「めくる」機能が特徴的だった。
#いや、今も紙copiと名前を変えて残ってるんだけど、僕はmacに移ったしemacsに慣れてしまったしで使わなくなってしまったのだった。
この「紙」の大きな特徴がファイル保存の概念が「ない」というところで、というかテキストを編集するたびに勝手に上書き保存するようになっている。PCがクラッシュしたりしても大事な長文を失ったりという事故が起きないわけだ。
emacsでもそういう使い勝手が欲しいと思って前探したところ実装している人がいた。http://0xcc.net/misc/auto-save/ の auto-save-buffers.elというやつで、便利に使わせてもらっている。
ただepa(ファイルをgpgで暗号化するやつ)のような、保存時にプロンプトが出てくるモードとはちょっと相性が悪かった。初回保存のときにepaはどのキーで暗号化するか聞いてくるのだけど、このキーを選んでいる最中にauto-save-buffersがまた発動してフォームが初期化されてしまうのだ。
というわけで自動保存の発動中は一旦自動保存フラグを下ろすように書き換えた。
$ diff auto-save-buffers.el auto-save-buffers.el.orig 52,53c52 < (let ((auto-save-buffers-active-p nil)) < (save-buffer))) --- > (save-buffer))
バイトコンパイルし直すのを忘れずに。
これを書いている途中で機能強化版を作っているひとを見つけた http://blog.kentarok.org/entry/20080222/1203688543 のでこっちも試してみるつもり。
sbcl で asteroidsを動かしてみるメモ on mac
asteroidsというlispbuilder-sdlを使ったゲームがある。手元でうまく動いていなかったのだが今日試したら動いたのでメモ程度に。
環境
ライブラリの場所の指定
~/.sbclrc に
(ql:quickload :cffi) #+darwin(pushnew #P"/opt/local/lib/" cffi:*foreign-library-directories* :test #'equal) #+darwin(pushnew #P"/opt/local/Library/Frameworks/" cffi:*darwin-framework-directories* :test #'equal)
パスの最後の/は重要らしい
浮動小数点例外
どうもinvalidやらdivide-by-zero例外を投げるようなのでtrapしないようにしてしまう
(sb-ext::set-floating-point-modes :traps nil)
起動
(ql:quickload :asteroids) ;; なぜかこの時点で起動するけど
(asteroids:main) ;; こうしてももう一度起動出来る
windowsでsbcl + lispbuilder-sdl
メモ。環境はwindows 7 64bit。
前半は思い出しながら書いているので間違いもあるかもしれない。quicklisp ができたおかげで昔に比べて結構楽になっているようだ。
sbclをインストールする
http://www.sbcl.org/platform-table.html から windows x86 用をダウンロードする。以下この記事を書いてる時点のsbcl 1.2.1 を仮定。
パスを通す:
スタートメニューで「コンピュータ」を右クリック→「プロパティ」→左にある「システムの詳細設定」→「環境変数」
ユーザー環境変数のPATH、SBCL_HOMEの両方にsbclがインストールされた場所を指定する必要がある。これらの環境変数がなければ「新規」で以下を設定、あれば「編集」からセミコロン区切りで以下を追加。
C:\Program Files (x86)\Steel Bank Common Lisp\1.2.1
lispbuilder-sdlに必要なバイナリをインストール
本家から必要なライブラリ類をインストールする。
http://code.google.com/p/lispbuilder/downloads/list から以下をダウンロード。
- win32-lispbuilder-sdl-gfx-binaries-2.0.13.tgz
- win32-lispbuilder-sdl-ttf-binaries-2.0.9.tgz
- win32-lispbuilder-sdl-mixer-binaries-1.2.11.tgz
- win32-lispbuilder-sdl-image-binaries-1.2.10.tgz
- win32-lispbuilder-sdl-binaries-1.2.14.tgz
- lispbuilder-sdl-ttf-0.3.0.tgz
- lispbuilder-sdl-mixer-0.4.tgz
- lispbuilder-sdl-image-0.5.0.tgz
- lispbuilder-sdl-gfx-0.7.0.tgz
- lispbuilder-sdl-0.9.8.1.tgz
sbclをインストールしたディレクトリにsiteという名のディレクトリ(C:\Program Files (x86)\Steel Bank Common Lisp\1.2.1\site)を作って、ダウンロードしてきたファイルを全部ここに解凍する。
quicklispをインストールする
http://beta.quicklisp.org/quicklisp.lisp をホームディレクトリ*1 C:\Users\USERNAME\ にダウンロードしてsbclから (load "quicklisp.lisp") で読み込む。
読み込めたようなら (quicklisp-quickstart:install) (ql:add-to-init-file) する。
slimeを使いたいなら (ql:quickload "quicklisp-slime-helper") もして、出てくる指示にそって .emacs に追記するといいのだと思う。
lispbuilder-sdl をインストールする
sbclから (ql:quickload :lispbuilder-sdl) する。
大丈夫そうなら (ql:quickload :lispbuilder-sdl-examples) して、(sdl-examples:mandelbrot) とか (sdl-examples:fireworks) とかしてみる。それっぽい画面が出たらok。
ちなみに (do-external-symbols (s :sdl-examples) (when (fboundp s) (print s))) とするとデモ一覧が見られる。
*1:じゃなくてもいいけど面倒なので
lispbuilder-sdl on clozure cl (on mac)
以下の記述に沿ってもslimeだと動きません…うーん。
clozure clとかcclとか言われるのはANSI Common Lispの処理系の一つで、かつてはFranzからMacintosh Allegro Common Lispとして売られてた事もあるが、現在はオープンソースになっている*1。原則mac向けだがwindowsとかlinux、FreeBSDなどでも動くらしい。
うちの環境(Mac OS X 10.9.5)だとclozure clでのlispbuilder-sdlが挙動が変(というかマウス操作とかができない)だったのだけど、どうやらclozure cl自身に single-threaded な動作をさせないといけないらしい。というか本家にもそうあった。
quicklispにsingle-threaded-cclというのがあるのでこれを使えばsingle-threadedで動くimageを作れる。
$ ccl64 --version
Version 1.9 (DarwinX8664)
$ ccl64
Welcome to Clozure Common Lisp Version 1.9 (DarwinX8664)!
? (ql:quickload :single-threaded-ccl)
To load "single-threaded-ccl":
Load 1 ASDF system:
single-threaded-ccl
; Loading "single-threaded-ccl"
(:SINGLE-THREADED-CCL)
? (ccl::save-application
"single-threaded-ccl"
:prepend-kernel t)
$ # 終了してshellに落ちてくる
$ ./single-threaded-ccl
Welcome to Clozure Common Lisp Version 1.9 (DarwinX8664)!
? (ql:quickload :lispbuilder-sdl-examples)
(:LISPBUILDER-SDL-EXAMPLES)
? (sdl-examples:mandelbrot)できたイメージ( ./single-threaded-ccl )を適当な名前でpathの通ったところに置いておくといい気がする。
macだとcclのほうが評判がいいっぽいのでこれからこっちを使ってみようかなあ。
ところで前回のhashlifeのプログラムがなぜかcclだと挙動が変(たまにライフゲームのルールに沿ってない生死の挙動を見せる)んだけどなんでだろうか…。puffer trainが崩壊していってしまう…。→たぶんハッシュの衝突が原因。前エントリーの追記を参照
hashlife その2
前回のつづき。
今回は解説もしてみた。
使い方
環境はsbclで、quicklispがインストール済、かつlisp-builder-sdlが動く状態になっていること(これがちょっと面倒なんだけど…)。
$ ./hashlife.lisp
と打つとpuffer trainが動き出すはず。
キー操作は
- ↑↓←→: 移動
- Ctrl ↑/↓: ズームイン/アウト
- Shift ↑/↓: スピードアップ/ダウン
- スペース: 一時停止/解除
- f: フルスクリーンモード/解除
- c: クリア
- q: 終了
あとマウスでお絵描きができる。
右下を掴むと画面サイズが変えられるが、画面の内部で掴むとお絵描きも発動してしまうので気持ち画面の外側を掴んでもらえれば。
あと.rle形式と.lif形式のファイルが読めて、例えばGollyについてくる宇宙船ブリーダー*1は
$ ./hashlife.lisp ~Downloads/golly-2.6-mac109/Patterns/Life/Breeders/LWSS-breeder.rle
みたいな感じで動かせる。壮観。
puffer train(フルスクリーンモード)
そもそもhashlifeってなに
Gosperにより考案されたアルゴリズムで、フィールドを一つ一つの升目ではなく4分木として扱うのが特徴。
基本データ構造であるnodeは 2^n x 2^n の正方形のフィールドを表す。以下nをレベルと呼ぶ。各ノードは5つのフィールド: nw、ne、sw、se、RESULT を持つ。nw〜se は自身の1/4の大きさの子ノードで、例えば今考えているノードが 2^4 x 2^4 の大きさ(level 4)であれば子ノードは全て 2^3 x 2^3 の大きさ(level 3)である。RESULTも子ノードと同じ大きさのノードなのだが、後述。
+---------------+ +-------+-------+
| | | | |
| | | | |
| | | | |
| | | nw | ne | +-------+
| | | | | | |
| | | | | | |
| n n | | | | | |
node = | 2 x 2 | = +-------+-------+ | RESULT|
| | | | | | |
| | | | | | |
| | | | | | |
| | | sw | se | +-------+
| | | | |
| | | | |
| | | | |
+---------------+ +-------+-------+
規則的なパターンを扱うのであれば必要なノード数は非常に少なくなる。
例えば1024x1024の空のフィールドなら、1x1の空のノード(level 0)、それを4つ集めた2x2のノード(level 1)、それを4つ集めた4x4のノード(level 2)、...、それを4つ集めた2^10x2^10のノード(level 10)と、たった11個のノードを保持するだけで済んでしまう。この倍の大きさのフィールドを考えるにはもう1個ノードを使うだけでよい。こういうことをするためにはもう使われているノードとまだ使われてなくて新しく作る必要のあるノードを効率的に区別する必要があるが、これはハッシュテーブルを使うことで解決出来る(4つの子ノードをキーにする)。
"次"の世代を計算するにはどうするかだが、各ノードの情報だけでは自分自身が次どういうノードになるかわからない(端があるので)。そこで、2^n x 2^n のうち真ん中の 2^(n-1) x 2^(n-1) だけを計算する。
具体的には、まず自分の子ノードの子ノード(孫ノード)を組み合わせて、自分よりレベルが1つ下のノードを9つ作る。nw、se、sw、se はすでにあるので、こいつらの子を組み合わせる事で東西南北と真ん中(図の e、w、s、n、c) を作る。この9つが互いに重なり合っているのに注意。
(重なり合った9ノード) +-------+-------+ +---+---+---+---+ | | | | | | | | | | | | | | | | | | | | | | | | | | | +---+---+---+---+ nw n se | | | 分割 | | | | | | | | ・ | | | | | | | | 組む | | | | | +-------+-------+ → +---+---+---+---+ : w c e | | | | | | | | | | | | | | | | | | | | | | | | | | | +---+---+---+---+ sw s se | | | | | | | | | | | | | | | | | | | | | | | | +-------+-------+ +---+---+---+---+
で、この9つについて、再帰的にそれぞれの"次の真ん中"が計算出来たとしよう。すると、うまい具合にちょうど重なりのない9つのノードになる。こいつらを組み合わせると重なり合った4つのノードになる。
(重なり合った9ノード) +---+---+---+---+ | | | | | (重ならない9ノード) (重なりあった4ノード) | | | | | +---+---+---+ +---+---+---+ | | | | | | | | | | | | | +---+---+---+---+ | | | | | | | | | | | | | | | | | | | | | | | | | | +---+---+---+ +---+---+---+ nw ne | | | | | step | | | | 組む | | | | +---+---+---+---+ → | | | | → | | | | : | | | | | | | | | | | | | | | | | | +---+---+---+ +---+---+---+ sw se | | | | | | | | | | | | | +---+---+---+---+ | | | | | | | | | | | | | | | | | | | | | | | | | | +---+---+---+ +---+---+---+ | | | | | +---+---+---+---+
で、この重なってる4ノードについて今と同じようにそれぞれの"次の真ん中"を計算して組み合わせれば、欲しかったノードが手に入る。
(重なり合った4ノード)
+---+---+---+
| | | | (重ならない4ノード)
| | | | +---+---+ +-------+
| | | | | | | | |
+---+---+---+ | | | | |
| | | | step | | | 組む | |
| | | | → +---+---+ → | | : 目標ノード
| | | | | | | | |
+---+---+---+ | | | | |
| | | | | | | | |
| | | | +---+---+ +-------+
| | | |
+---+---+---+
このやりかたの利点としてはノードのレベルによらず同じ手続きが使える事だ(一番下の数レベルを除けば)。そして、今の手続きに自分より1個下のレベルの"次"を求める作業が2回入っているのに注目してほしい。ノードのレベルが1個上がると、"次"というのは世代数にして倍になることがわかる。
再帰手続きの最後はどうなっているかというと、最終的にレベル2のノードで1世代先に進む:
(レベル2)
(レベル1)
....
OO.. step O.
O.O. → ..
O...
結局、レベル n のノードについて今の手続きを適用すると一度に 2^(n-2) 世代先まで計算する事になる。
この計算結果を RESULT に格納しておいて、次からは今の手続きを行わず単にこれを参照する。同じ形のフィールドが100回繰り返し出てくるような規則的なパターンを扱うとき、これによって実際には1回しか計算をしなくてよくなるわけだ。
こういうわけで、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
- グライダーガンパターンとその表し方を使わせてもらった http://d.hatena.ne.jp/armbrust/20120930/1349020237
- gollyのファイルフォーマット http://golly.sourceforge.net/Help/formats.html
この実装はpython実装をかなり参考にしている。
あとあの後見つけたが和田氏による解説スライドがわかりやすいと思う。p.19〜 http://www.iijlab.net/~ew/slide2j.pdf
変更点
- 初期パターン配置部分を分離した。
- 前回は各nodeがハッシュテーブルを持っていたためものすごくメモリを食っていたのでリストに変更。
- 描画部分で一旦画面内の全生存セルのリストを作っていたのをやめて、直接再帰的に四分木をたどりつつ描画するようにしたらかなり速くなった。その時の表示スケールでは細かくて見えない部分の描画を打ち切れるようになったのも大きいはず。
コード
gistで貼れるようなのでそうしてみる
hashlife.lisp:
フォントもう少し小さくできないだろうか…
その他
metapixelなんかの.mc形式ファイルも読めるようにはしてみているのだけど、ズームアウトして行くと急に重くなってしまう。
引いてない状態では軽快に動くようなので描画部分の問題だと思うのだけど、プロファイラで見てもどれがボトルネックか判然としない。
違うGUIライブラリを試してみるのもいいかもしれない。
2014/10/5 追記: JIS/USキーボードの配列の違いに対処するため操作方法を変更。あと実装や環境によってはハッシュが衝突するようなので hash table の扱いをcommon lispに任せるように戻した。フルスクリーンモードも追加。
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:移動、ズームイン/アウト
- ファイルを読めるようにする
- コンパイルの正しい作法を知らない
