木構造の親子関係を考慮したソート
前置き
Common Lisp（サブセット）をJavaScriptコードに変換するParenscriptを色々拡張しているps-experimentで以前パッケージもどきを追加したことがありました。
単にuse-packageしているパッケージをたどっていって、その配下で定義したParenscript用関数をすべてJavaScriptに変換するという代物です。このときに、パッケージの出力順については「まあJavaScriptで出力順序が影響するケースも少ないだろうし、問題が起きた時に考えよう…」と思っていたのですが、とうとう問題が起きたので真面目に考えてみたというのが今回の発端です*1。
この出力順の問題は、一般化するとパッケージをノード、use-packageの関係をエッジ（useしている側が親、されている側が子）とした木構造として捉えられます。このノードを以下の条件を満たすように一列に並び替えます。
- 親ノードは子ノードよりも後ろに配置される
面倒なのは一つの子ノードが複数の親ノードを持つ可能性がある可能性や、循環参照が存在する可能性があるため、単なる深さ優先探索では不十分という点です。ひとまずは(1)親ノードは1つだけで循環参照も存在しないという条件から始めて、(2)循環参照はなしで親ノードを複数持てる場合、(3)循環参照をエラーにする場合、(4)循環参照を許可する場合*2と徐々に条件を厳しくして考えていきます。
たぶん世界中で100万人は考えたことのある問題です。
準備
コード込みで考えていきたいので、道具となる構造体や関数を定義しておきます。なおこの記事全般に言えることですが、コードは読み飛ばしてもだいたい意味は通る…はずです。
パッケージの依存関係処理に使いたいというのがそもそもの発端であったため、汎用に使えるようにgenericを定義しておきます。
(defgeneric get-node-name (node)) ; プリント用 (defgeneric node-equalp (node1 node2)) ; ノード間の等値比較 (defgeneric get-children (node)) ; 子ノードの取得
単純なnode構造体とメソッドを作成します。
(defstruct node name children) (defmethod get-node-name ((node node)) (node-name node)) (defmethod node-equalp ((node1 node) (node2 node)) (eq (node-name node1) (node-name node2))) (defmethod get-children ((node node)) (node-children node))
次に、実験用に木を簡単に構成するための補助関数を作成します。木の定義は((:parentA :childA1 :childA2) (:parentB :childB1 :childB2) ...)のように簡単に書けるようにします。例えば、上図の木の場合は次のように書き下します。
(defparameter *simple-tree* '((:a :b :c) (:c :d :e) (:d :f :g)))
これを、親子関係（node-children）を設定しながらnode構造体のリストにするのがmake-treeです。なおaifやitはanaphoraライブラリのものです。
(defun make-tree (parent-children-pair) (let ((node-pool (make-hash-table)) (result nil)) (flet ((ensure-node (name) (check-type name keyword) (aif (gethash name node-pool) it (setf (gethash name node-pool) (make-node :name name))))) (dolist (pair parent-children-pair) (let ((parent (ensure-node (car pair)))) (dolist (child-name (cdr pair)) (push (ensure-node child-name) (node-children parent))) (push parent result)))) (dolist (node result) (setf (node-children node) (nreverse (node-children node)))) result))
また、与えられたノードのリストの子供をたどって、重複なしに全てのノードを一列に並べる関数linearize-all-nodesを用意します*3。
(defun linearize-all-nodes (node-list) (let ((result nil)) (labels ((rec (node) (unless (some (lambda (target) (node-equalp target node)) result) (push node result) (dolist (child (get-children node)) (rec child))))) (dolist (node node-list) (rec node))) result))
本題
段階1：親ノードを一つしか持てず循環参照も存在しない木の場合
まずは1番単純な、親ノードを一つしか持てず循環参照も存在しない、下図のような木を考えます。
こうした木の場合は一番上のノードを取り出して、そこから深さ優先探索を行うだけで問題ありません。この制約下では、深さ優先探索で子ノードが親ノードよりも先に訪問されることはないためです。
(defun sort-tree-node-simply (node-list) (let ((top-node (find-if (lambda (target) ;; If the target is not child of any node, it is a top node. (notany (lambda (parent) (some (lambda (child) (node-equalp target child)) (get-children parent))) node-list)) node-list))) (assert top-node) ;; linealize-all-nodes が深さ優先探索であることを仮定しています。汚いですがまあ前座なので… (linearize-all-nodes (list top-node))))
ソートした結果を表示するための関数（以降使いまわします）を作って結果を見てみると、正しくソートされていることが分かります。
(defun print-result (tree sort-fn) (format t "~A~%" (mapcar #'get-node-name (funcall sort-fn (make-tree tree))))) (print-result *simple-tree* #'sort-tree-node-simply) ;; -> (E G F D C B A)
段階2：複数の親を許すが循環参照は存在しない木の場合
次に、循環参照はないものの、ノードに複数の親を持つことを許した木を考えます。下図の例では、ノードFはAとDの2つの親を持ちます。
(defparameter *duplicated-tree* (make-tree '((:a :b :f :c) (:c :d :e) (:d :f :g) (:f :h :i))))
これを段階1の深さ優先ソートで出力してみると…
(print-result *duplicated-tree* #'sort-tree-node-simply) (E G D C I H F B A)
子であるFが出てくる前にDが出てきてしまっています。その親子関係まで見ると"DC"と"IHF"を入れ替えないと正しい結果にならないことが分かります。複数の親を許したために、A→Fというより早く探索されるパスができてしまったためにうまくいかなくなりました。
そこで、全ノードのリストからソート済みリストへ移すときに、既に子ノードがすべて後者の移されているかをチェックする機構を入れる必要があります。あとは、全ノードリストからチェックを通るものを一つずつピックアップしてソート済みリストに持っていくだけです。第1段階で仮定していたような、全ノードの取得部分linearize-all-nodesが深さ優先探索であるという仮定もいらなくなります。
;; 子ノードが全てソート済みリストに入っているかをチェックする ;; （ここではまだ関係ありませんが、自己参照は無視しています） (defun all-children-are-processed (node processed-node-list) (every (lambda (child) (or (node-equalp node child) ; Ignore self dependency (find child processed-node-list :test #'node-equalp))) (get-children node))) (defun sort-tree-node-with-duplication (node-list) (labels ((rec (rest-nodes result) (aif (find-if (lambda (node) (all-children-are-processed node result)) rest-nodes) (rec (remove it rest-nodes :test #'node-equalp) (cons it result)) result))) (reverse (rec (linearize-all-nodes node-list) nil))))
結果を見ると、今度はノードDとCの前にI, H, Fが全て出てきており、正しい順番にソートされることが分かります。
(print-result *duplicated-tree* #'sort-tree-node-with-duplication) ;; -> (B E G I H F D C A)
段階3：循環参照を検知してエラーにする
次は循環参照の存在する木を考えます。下図は「F→G→D→F→G→D→…」の循環参照が存在する木です。
(defparameter *circular-tree1* '((:a :b :f :c) (:f :h :g) (:g :d) (:d :f) (:c :d :e)))
循環参照部分は「親ノードは子ノードよりも後ろに配置される」という条件を決して満たせないため、検知してエラーにする必要があります。なお、試しに前節のsort-tree-node-with-duplicationで並び替えてみると…循環参照を形成するF, G, Dの他、それらに依存するA, Cも巻き込まれて出力されません。
(print-result *circular-tree1* #'sort-tree-node-with-duplication) ;; -> (B E H)
さて、まずは循環参照を検出する関数extract-circular-nodesを作成します。内部関数recが本体になりますが、深さ優先探索で木を探索しながら、トップから現在ノードまでの経路をtraverse-listに格納しています。新たに辿ろうとした子ノードがtraverse-listに既に含まれていた場合、循環参照が存在することが分かります。また、このときtraverse-listの先頭から同リスト内の子ノードまでが循環経路になります（コード上ではtraverse-listをreverseしてmemberで子ノード以降を取り出すという操作をしています）。この辺りのアイディアは、後述のASDFでの循環参照検知方法を参考にしています（というよりそのままです）。なお、自己参照も循環参照の一種ではありますが、害はないので素通しにしています。
(defun extract-circular-nodes (node-list) (labels ((rec (current-node traverse-list) (setf traverse-list (cons current-node traverse-list)) (dolist (child (get-children current-node)) (unless (node-equalp current-node child) ; Ignore self dependency (when (find child traverse-list :test #'node-equalp) (let ((result (member child (reverse traverse-list) :test #'node-equalp))) (return-from rec result))) (let ((next-result (rec child traverse-list))) (when next-result (return-from rec next-result))))) nil)) ;; ※通過済みのノードであってもチェックすることになるので ;; さすがにちょっとバカっぽいループです… (dolist (node node-list) (awhen (rec node nil) (return-from extract-circular-nodes it)))))
後はこれを利用して循環参照をエラーにするチェック関数を用意して、sort-tree-node-with-duplicationの手前に設置すれば、循環参照をエラーにするsort-tree-node-checking-circularの完成です。
(defun check-circular-dependency (node-list) (awhen (extract-circular-nodes node-list) (error "There is (a) circular dependency: ~A" (mapcar #'get-node-name it)))) (defun sort-tree-node-checking-circular (node-list) (check-circular-dependency (linearize-all-nodes node-list)) (sort-tree-node-with-duplication node-list))
次のように、循環参照を検知してエラーにしつつ、そうでなければsort-tree-node-with-duplicationと同等のソート性能を持つことが分かります。
(print-result *duplicated-tree1* #'sort-tree-node-checking-circular) ;; -> (B E G I H F D C A) (print-result *circular-tree* #'sort-tree-node-checking-circular) ;; -> （次のようなエラーを出力）There is (a) circular dependency: (F G D)
余談：ASDFにおける循環参照検知
ここで余談ですが、今回パクった参考にしたASDFのコードについてです。
ASDFでは.asdファイルにdefsystemでシステムを定義しますが、ここで各モジュールを構成するファイル間の依存関係を定義します。asdf:load-system時にはこれを見て、循環参照があればエラーにしています。実際にエラーを検知してエラーを出力しているのはasdf.lispの下記call-while-visiting-actionです。なお、これは1ノード分の処理であり、木の探索自体はより上位の関数で実行します。
若干用語を補足します。
action: 今回で言うノードに当たるようですaction-list: 今回でいうtraverse-listで、現在の通過経路が入ったリストですaction-set:actionをキーとし、ブール値を値とするハッシュです。ここでは通過経路にt、それ以外にnilを入れているようです*4
循環参照の検知をしているのは(gethash action action-set)で、通過経路に現在のactionがあるかを判定しています。検知した場合は、循環参照エラーにします。このとき、action-listをreverseしてmemberで現在のaction以降を取り出すことで、循環経路を取り出しています。…というように、ハッシュを使っている以外はそのまま参考にしました。
;; ※ASDF 3.1.5のコードより (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) (with-accessors ((action-set plan-visiting-action-set) (action-list plan-visiting-action-list)) plan (let ((action (cons operation component))) (when (gethash action action-set) (error 'circular-dependency :actions (member action (reverse action-list) :test 'equal))) (setf (gethash action action-set) t) (push action action-list) (unwind-protect (funcall fun) (pop action-list) (setf (gethash action action-set) nil)))))
段階4：循環参照ノードをグループ化して解決する
※警告：この段階4は実用性が微妙なくせに説明がとても長いです…
循環参照がある時点で基本的におかしいので、即エラーの段階3まででも良い気もします。ただ、ASDFにおけるファイル間の循環参照とは違い、パッケージ間の循環参照については検知される契機がないため、どこかでやらかしているライブラリがあると詰む可能性が考えられます。そのため、将来的な逃げ道のために循環参照をある程度いなして解決する方法を考えておきます。
ここで、改めて循環参照の存在する木を眺めてみると、循環参照をグループ化して一つの塊だと思えばうまくいきそうです。つまり、FGDを1つのグループと見て、FGDはHに依存し、AとCはそれぞれFGDに依存しているといった具合です。そして、同じグループに属するノードの出力順は任意で良いことにします。さて、図を見ながら考えると、グループやグループ間の等値性、グループ間の依存は下記のように定義できそうです*5。なお、ノードとグループを別個に扱うのは面倒そうなので、ノード1つの「塊」もグループとして扱うことにします。
- 定義：グループ
- 1つ以上のノードから構成され、かつ、
- 2つ以上のノードが存在する場合、グループ内の全ノードを含む循環参照が存在する
- 要は循環参照をグループ化しますということです
(defstruct node-group nodes ; グループを構成するノードのリスト children ; 子グループのキャッシュ ; （後述の「グループ間の依存」の定義に従い、依存するグループを集めたもの） )
- 定義：グループの等値比較
- グループAとグループBが等値であるとは、構成するノードが同じであることを言う
- 1つのノードは必ずある1つのグループだけに属しているという制約を設けるため、実際にはノードが1つでも一致すれば等値です
- グループAとグループBが等値であるとは、構成するノードが同じであることを言う
(defmethod node-equalp ((node1 node-group) (node2 node-group)) (let ((first-node (first (node-group-nodes node1)))) ;; An empty group is not allowed. (assert first-node) (find first-node (node-group-nodes node2) :test #'node-equalp)))
- 定義：グループ間の依存
- グループAがグループBに依存しているとき、グループAに含まれるノードの子ノードのうち、少なくとも1つがBに含まれる
(defun group-depend-p (target base) (some (lambda (base-node) (some (lambda (target-node) (find target-node (get-children base-node) :test #'node-equalp)) (node-group-nodes target))) (node-group-nodes base)))
（きちんと証明する能がないですが…）こうした定義から下記の性質を持つ点が重要です。
性質
- グループはノードとしての性質（等値比較ができる、子供を定義できる）を満たす
- 循環参照する複数のグループに属するノードを集めることで、一つのグループを構成できる
- 同一グループ内の任意の2ノードは循環参照している
- つまりグループ内のノード間では上下関係を決定できません
- 循環参照の関係にないグループA, Bがあり、かつAがBに依存しているとき、Bの全てのノードはAのどのノードから見ても（一方向の）子孫ノードである
- 平たく言えば、ノード間の親子（先祖/子孫）関係はグループ化しても保存されるということです
これらの性質を利用すると、下記のような手順で「循環参照を塊とみなしたソート」を実現できます
手順
- ノードのリストから、各ノードを要素とするグループのリストを作成する
- グループのリストから（自己参照でない）循環参照を探す。なければ手順5へ飛ぶ
- 性質1により、ノード用の循環参照検知関数をそのまま利用できる]
- 手順2で見つけた循環参照グループからノードを取り出して一つのグループにまとめ（性質2による）、元のグループは破棄する
- この操作によりリストの要素が減るので、無限ループにならない
- 手順2へ戻る
- グループをノードとみなし（性質1による）、段階2：複数の親を許すがループは存在しない木の場合に従ってソートする
- 手順5でソートされた順にグループを取り出し、含まれるノードを取り出してリストとする。このリストのノードは正しくソートされている（性質4による）
- 同一グループ内のノードの順序は任意でよい（性質3による）
手順1～4の実装は次のようになります。
;; ※循環参照グループをまとめる際に親子関係が変わるため、 ;; 再計算用の関数を用意 (defun calc-group-children (group group-list) (remove-if (lambda (target) (not (group-depend-p target group))) group-list)) (defun recalc-groups-children (group-list) (dolist (group group-list) (setf (node-group-children group) (calc-group-children group group-list))) group-list) ;; 手順3: 循環参照するグループ内のノードを一つのグループにまとめる (defun gather-ciruclar-node-group (circular-list group-list) (let ((new-group (make-node-group :nodes (apply #'append (mapcar (lambda (group) (node-group-nodes group)) circular-list))))) (recalc-groups-children (cons new-group (remove-if (lambda (group) (find group circular-list :test #'node-equalp)) group-list))))) ;; 手順1～4の一連の操作: グループ間の全ての循環参照をまとめあげる (defun make-group-resolving-circular (all-node-list) (labels ((rec (group-list) (aif (extract-circular-nodes group-list) (rec (gather-ciruclar-node-group it group-list)) group-list))) (rec (recalc-groups-children (mapcar (lambda (node) (make-node-group :nodes (list node))) all-node-list)))))
後は手順5に従い、make-group-resolving-circularの結果をsort-tree-node-with-duplicationに渡すことでグループ間のソートは完了です*6。
(defun sort-tree-node-with-circular (top-node-list) (sort-tree-node-with-duplication (make-group-resolving-circular (extract-all-nodes-by-dfs top-node-list))))
なお、見た目としてはグループをまとめたままの方が分かり易いため、以降では手順6（グループ内ノードのフラット化）を省略して出力します。
上記の循環参照する木をソートした結果を見ると、グループDFGがまとまり、またそれらに依存するA, Cは後から出てくるなど正しくソートできています。
((B) (E) (H) (D F G) (C) (A))
また、複数の循環参照を含む木でうまく動くかを確認するため、2つほど例を見てみます。
(defparameter *circular-tree2* '((:a :b :f :c) (:f :h :g) (:g :d :x) (:d :f) (:c :d :e) (:x :y) (:y :z) (:z :x))) ;; → ((B) (E) (H) (X Y Z) (D F G) (C) (A))
(defparameter *circular-tree3* '((:a :b :f :c) (:f :h :g) (:g :d :x) (:d :f) (:c :d :e) (:x :y :g) (:y :z) (:z :x))) ;; → ((B) (E) (H) (X Y Z D F G) (C) (A))
なお、グループ自体もノードとしての性質を満たすため、グループを要素としたグループを（再帰的に）作成できるはずですが、特に実用的な価値はないと思われます。
コード全体
最後に、全コードを貼り付けます。
Sort nodes in tree according to their dependencies …
Roswellスクリプトとして実行でき、下記を出力します。
$ ./sort-tree-node-with-circular.ros -------------------- --- Sort simply --- -------------------- *SIMPLE-TREE*: ((A B C) (C D E) (D F G)) -> (E G F D C B A) *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> (E G D C I H F B A) -------------------- --- Sort considering duplicated parent --- -------------------- *SIMPLE-TREE*: ((A B C) (C D E) (D F G)) -> (B E G F D C A) *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> (B E G I H F D C A) *CIRCULAR-TREE1*: ((A B F C) (F H G) (G D) (D F) (C D E)) -> (B E H) -------------------- --- Sort checking circular --- -------------------- *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> (B E G I H F D C A) *CIRCULAR-TREE1*: ((A B F C) (F H G) (G D) (D F) (C D E)) ERROR: There is (a) circular dependency: (F G D) -------------------- --- Sort considering circular --- -------------------- *SIMPLE-TREE*: ((A B C) (C D E) (D F G)) -> ((F) (G) (D) (E) (C) (B) (A)) *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> ((H) (I) (F) (G) (D) (E) (C) (B) (A)) *CIRCULAR-TREE1*: ((A B F C) (F H G) (G D) (D F) (C D E)) -> ((E) (B) (H) (F G D) (C) (A)) *CIRCULAR-TREE2*: ((A B F C) (F H G) (G D X) (D F) (C D E) (X Y) (Y Z) (Z X)) -> ((E) (B) (H) (X Y Z) (F G D) (C) (A)) *CIRCULAR-TREE3*: ((A B F C) (F H G) (G D X) (D F) (C D E) (X Y D) (Y Z) (Z X)) -> ((E) (B) (H) (D F G X Y Z) (C) (A)) -------------------- --- (Test self dependncy) --- -------------------- *TREE-TO-TEST-SELF-DEPENDENCY*: ((A A B F C) (C C D E) (D F G) (F H I)) -> (B E G I H F D C A) *TREE-TO-TEST-SELF-DEPENDENCY*: ((A A B F C) (C C D E) (D F G) (F H I)) -> (B E G I H F D C A) *TREE-TO-TEST-SELF-DEPENDENCY*: ((A A B F C) (C C D E) (D F G) (F H I)) -> ((H) (I) (F) (G) (D) (E) (C) (B) (A))
以上
*1:具体的には、ps-experimentで実装しているdefstructのサブセットで問題が起こりました。includeした場合に継承関係をつけるコードを出力するのですが、このコードが親となる構造体の定義よりも先に出てきてしまうと、うまく継承関係を定義できないようでした
*2:「親ノードは子ノードよりも後ろに配置される」をそのままでは満たせないため、少し条件を緩和して考えます
*3:パッケージの親子関係をたどるケースを考えると、最初に全てのパッケージが並んでいるのではなく、起点となるいくつかのパッケージを与えられるのが普通だと思います。ソートの中で徐々に展開しても良さそうですが、最初にすべて並べてしまった方が簡単そうなのでこうした関数を用意しています
*4:循環参照のチェックが終わると、action-setのキーの集合が全actionのリストとなる辺り賢いです。そこまで見ていないのですが、この後ロードを行う際にここでロード済みか否かを管理するのではないかと予想しています。ちなみに、ハッシュの値としてnilを入れておく（≒キーが存在しないことと同等に扱う）手法の実用的な価値をイメージできていなかったのですが、初めて分かった気がします
*5:というように「グループ」を素直に扱えば解決できるという所に行きつくまでに、実はすごい迷走してました…
*6:万全を期するのであれば、循環参照が確かに解消されたことを確認するために、check-circular-dependencyを入れた方が良いです
[小ネタ] アルファマップを生成するRoswellスクリプト
小ネタ。アルファマップを生成するRoswellスクリプトを作成したメモです。
Three.jsのように、透過画像を表示するためには（画像自体のアルファ値は無視して）アルファマップと呼ばれる、透過具合をグレースケールで表した画像（黒が完全透過で白が完全不透明）を要求するものがあります。
このアルファマップを一々手で作成するのは面倒なので、元画像（PNG）のアルファ値を読み取ってアルファマップを生成するスクリプトを書いてみました。こんな感じに使います。
$ ./create-alpha-map.ros -i ab.png -o ab-alpha.png
Before (ab.png):
After (ab-alpha.png):
スクリプト自体は40行程度の簡単なものです。
Create an alpha map png from a png file
画像処理ライブラリであるopticlとコマンドライン引数処理ライブラリであるCL-CLIのおかげで、思いの外簡単に書けた次第です。今回はどちらも基本的な部分しか使っていませんが…。
CL-CLIについて何点か。サブコマンドの定義など高度な機能も持っているようですが、基本的には上記のようにオプションを定義したリスト（*options*）を作成してcl-cli:parse-cliに渡すだけです。ちょっとした注意点として、この関数はコマンドライン引数の1要素目にコマンド自体が入ることを想定しているようですが、Roswellのargvには含まれていないので適当に空文字を追加しています（(cl-cli:parse-cli (cons "" argv) *options*)）。
また、cl-cli:helpで下記のように自動でヘルプを生成してくれるのも嬉しいです。
$ ./create-alpha-map.ros
NIL
[ OPTIONS ]
Global options:
-i,--input-path <file> [Required] Input image file path
-o,--output-path <file> Input image file path (default:
/tmp/temp.png)
PostgreSQL (POSTGRES) におけるLisp
前書き
LispからPostgreSQLを扱う記事…ではなく、PostgreSQLの歴史に見え隠れするLispについての調査もどき記事です。
発端は次のようなものです。仕事柄PostgreSQLのメーリスやソースを見たり見なかったりするのですが、今年の1月にRustgreSQLというスレッドがありました。PostgreSQLをRust言語にポーティングするような話はないのかという 何を言っているんだこいつは 話題です。あり得るとしてもせいぜいC++だろうとか、いまだにC99ですらなっていないのに…*1とか、PostgreSQLのC言語の使い倒しっぷりを考えると死ぬほど非現実的だよとか、大変好意的な返信が並ぶ中、Robert Haas *2 の以下の発言が目を惹きました。
I'm tempted to snarkily reply that we should start by finishing the conversion of PostgreSQL from LISP to C before we worry about converting it to anything else.
なんとPostgreSQLの歴史上Lispで書かれていた時期があるようです。当時はへーと思って終わっていたのですが、ふと思い出して気になったので調べてみたという次第です。
PostgreSQLのソースにおけるLispの残滓
現行のPostgreSQLのソースにLispらしき痕跡があるのかを少し見てみます。Robert Haasは上記の発言に続いてこう言っています。
There are various code comments that imply that it actually was LISP at one time and I can certainly believe that given our incredibly wasteful use of linked lists in so many places.
論点は2つで、1つ目はコメントにLISPであった名残が見られることで、もう1つは現行のPostgreSQLがリンクリストを過剰に利用している原点はLispだろうということです。
前者の例としてgram.yのコメントを挙げています。
* HISTORY * AUTHOR DATE MAJOR EVENT * Andrew Yu Sept, 1994 POSTQUEL to SQL conversion * Andrew Yu Oct, 1994 lispy code conversion
確かにLispからコンバートしたと書かれています。このスレッドには書かれていませんが、似たようなものとして命名規則にもLispの名残が見られます。リスト操作用のヘッダはsrc/include/nodes/pg_list.hですが、ここを眺めてみると…
/* ※下記実際には行が離れていますが、一々省略記号を書くのも面倒なので続けて引用しています */ #define NIL ((List *) NULL) extern List *lappend(List *list, void *datum); extern List *lcons(void *datum, List *list); define nconc(l1, l2) list_concat(l1, l2) #define nth(n, list) list_nth(list, n)
Lispだ…。なお、残念ながらcarやcdrはありませんでした。
もう1つの論点であるリンクリストの多用についてですが…確かにあちこちリストだらけだなという程度で、余りLispっぽい印象を受けたことがないです…。とりあえずLispでプロトタイプを書くとリスト濫用になるよねというのは分かるのですが。
補足：POSTGRESとPostgreSQL
本題である、実際にPostgreSQLがLispで書かれていた時代について…の前に、用語の補足です。今では「ポストグレス」と言えばPostgreSQLのことですが、実はPOSTGRESという前身となるデータベースが存在しています。詳しい歴史はWikipediaのPostgreSQLの記事などにありますが、概要は下記の通りです。以降の話題であるLisp時代を直接に経験しているのはこのPOSTGRESの方になります。
- POSTGRES
- PostgreSQL
実際にLispで書かれていた時代
さて、現在の名残は前述の通りですが、実際にLispで書かれていた当時のことが分かるものとして下記の2つが見つかりました。
- 文献1: 1990年のストーンブレーカー博士の論文：THE IMPLEMENTATION OF POSTGRES (PDF)
- 「5.3. Programming Language Used」に言語選択に関する記載があります
- 文献2: メーリスのスレッド：Re: [HACKERS] Historical trivia (was Re: First Major Open Source Database)
- 投稿者は当時の開発者の一人のようです
お互い微妙に情報が足りないので、適宜両者を参照して進めていきます。
まず、そもそもLispが選択された動機についてです。これは文献1に記載があります。だいぶ端折って説明すると、CはIngresで使ったから真新しさがないし、C++はまだ安定した処理系がないし、他に検討した言語も諸々の理由で落とした結果Lispが残ったようです。ポジティブな理由としては、リスト処理（≒木構造処理）が得意なLispはオプティマイザや推論エンジン（？）が作りやすいのではないかと考えたそうです。
Lispといってもどの方言なのか書いてないのですが、それは文献2の方に記載があります。それによると、Franz Lispを使っていたとのことです。この辺りの古い方言は馴染みがないのですが…、g000001さんの「レトロLisp探検: Franz Lisp」などを見るとC言語との連携性の高さに特徴があるようです。POSTGRESの初版は結果的にLispが17000行、C言語が63000行となったそうです（文献1）が、最初の選択の時点でその辺りが斟酌されたのかは分かりません。なお、結果的にC言語を併用することになったのは、メモリ周りなどの低レイヤの処理を扱うにはやはり一日の長があったからとのことです（文献1）。
横道ですが、Franz Lispを作っていたFranz社は、現在では主要な商用Common Lisp処理系の一つであるAllegro Common Lispで知られています。この処理系が登場したのが1986年でPOSTGRESプロジェクトの発足とちょうど同じ年です。もう少しPOSTGRESプロジェクトの発足が遅ければCommon Lispが使われていたのかもしれません。
本題に戻って、次にLispがどの部分で使われたのか、すなわち前述のLisp17000行とC言語63000行の内訳はどうなっていたかです。これも文献1には記載がなく、、文献2の方に記載があります。parser（クエリの解析）、optimizer（実行計画の作成、plannerとも）、executor（その名の通り実際に実行する人）辺りがLispで作られていたようです。…ただ、parserに関しては、
steven wrote and maintained the parser, which was always written using lex/yacc (i.e., C) but had to generate (in C!) a lisp parse tree.
と書いてあり、lex/yaccからLispコードを生成したということなんでしょうか…？
最後に、当時は確かに存在していたLispコードがなぜ消滅することになったのか…ですが、文献1によるとLisp選んだのは完全に失敗だったねという評価になったからのようです（哀しい…）。最大の理由は、2言語の混ぜ合わせはとにかくデバッグが辛かったというところにあるとのことです。他に、大きな欠点として下記3つを挙げています。
- メモリ使用量が大き過ぎる
- 全体として、走らせるだけで4MBものメモリを使うことになってしまった（数値に時代を感じます）
- DBとしてはガベージコレクタの動作は許容しがたい
- GCが動かないように頑張ったそうです
- 遅い
- Lispエキスパートがいればなんとかなったのかも知れないが…とは補足しています
なお、（Lisp単体の範囲では）生産性の高さという部分で恩恵もあったようですが、言語自体よりはインタラクティブなデバッガなど環境面の素晴らしさにによるものだろうと評価しています。
in late 1989, jeff goh wrote a postgres-specific lisp->C translator that automated most of the conversion.
そんな訳で1989年にはコンバータが作られてLispコード消滅の運びとなりました（文献2）*3。
以上、PostgreSQL (POSTGRES) におけるLispの歴史の調査でした。
*1:移植性の問題で過去に却下されたようです。代表的なところではVisual C++がC99サポートし始めたのがようやく2013年…
*2:PostgreSQLの主要なコミッターの一人です
*3:上の方で引用したコードのコメントでは1994年となっているのが不思議ですが、文献1の書かれた時期を考えても1989年が実際にコンバートされた時期で、1994年はまた別の契機のように思います
Three.jsなWebアプリをCommon Lispで書く話
前書き
Lisp Advent Calendar 2016の20日目の記事です。
13日目の記事「フロントエンドもサーバーサイドもCommon Lispで書く試み - @peccul is peccu」のタイトルを見た瞬間「あっ」と思ったのですが、テーマがダダ被りです。しかも、pecculさんの方はメンテされているjsclをベースにしている一方で、こちらはメンテされていないParenscriptをベースに頑張っ（てしまっ）た記事です。
冒頭から残念感あふれますが、jsclに乗り換えても（未定）考え方は使えると思い、気を取り直して進めます。さて、こんなものを作りました。
斑鳩という素敵STGの3面中ボスである「鴫（シギ）」に関するシミュレータ（絶賛未完成）ですが、Qiitaから来られた方の10割はなんのことか分からないと思うのでこれ自体の話はまた別に記事を起こせたらと思います（ちなみに、Twitterから来られた方の8割はなんのことか分かると思います）。
ポイントはThree.js（WebGLを簡単に利用するためのライブラリ）を利用したWeb2Dゲームアプリであり、サーバサイドからフロントエンドまで*2Lispで記述されているという点です。これを実現するためにどのようなベースを作り、その上でどのような開発サイクルを回していったかが記事の焦点です。
一応動かし方
これを動かすこと自体に興味のある人がどれだけいるか甚だ疑問ですが、一番簡単なのはDockerHubに上げてあるイメージを使うことです。
$ docker pull eshamster/app-cl-shigi-simulator $ docker run -p 5000:8080 -d eshamster/app-cl-shigi-simulator
これでhttp://localhost:5000でアクセスできるはずです（docker runコマンドはすぐに返ってきますが、アクセス可能になるまでに10～20秒ほどかかります）。
開発環境にロードする場合は次のような感じです。quicklispに登録していない自作ライブラリに依存しているため、qlot installでgithubから拾わないとql:quickloadできません…*3。
# bash側 $ ros install eshamster/cl-shigi-simulator $ cd .roswell/local-projects/eshamster/cl-shigi-simulator/ $ ros install qlot $ qlot install ---- ;; REPL側 $ (ql:quickload :cl-shigi-simulator) $ (cl-shigi-simulator:start :port 5000)
概要
次のような階層で実現しています。
- 主に使わせて頂いたもの
- Caveman2：ご存じCommon Lisp製Webフレームワーク
- Parenscript：Common Lisp（サブセット）コードをJavaScriptに変換するライブラリ
- その上に構築したもの
- caveman-skeltons：Common Lispでフロントエンドを書くための準備をしたCaveman2用のスケルトン群
- ps-experiment：Parenscriptそのままでは不足する部分を適当に拡張するライブラリ
- cl-ps-ecs：Entity Component System（後述）もどきを実現するためのライブラリ
- cl-web-2d-game（予定）: レンダー部分をThree.jsに依存した2Dゲーム用ライブラリ
- 切り離し予定ですが、現状
cl-shigi-simulator/js-libフォルダ配下に内蔵されています
- 切り離し予定ですが、現状
- デプロイ用
- eshamster/cl-base: Alpineベースの（まあまあ）軽量Common Lispコンテナです
それぞれのライブラリ（自作物のみ）
上のライブラリを使ってどのように開発を回してきたかという話を淡々と書いていきます。
caveman-skeltons
Caveman2は非Lisperとの協業を視野に入れており、フロントエンド側は無理にLispにされていません。デフォルトのテンプレートエンジンとしてはDjulaを採用し、JavaScriptについてはそのままであり、必ずしもLispに親しくない人を驚かさないようになっています。
が、一人で書く分には全部Lispでも問題ありません。殊に今回のようにサーバエンドが軽い場合はただのJavaScript開発になってしまうので悲しい限りです。というわけで、Caveman2のスケルトンを下敷きにフロントエンド側もLispで記述するスケルトンを用意したものがcaveman-skeltonsです。
Gitのブランチで複数のスケルトンを管理しています*4。必要なブランチに切り替えたのち、以下のようにしてスケルトンからプロジェクトを作成します（この作成操作は純正のCaveman2と基本同じです）。
> (ql:quickload :caveman-skeltons) > (caveman-skeltons:make-project #p"/path/to/project")
現状3つ（事実上2つ）のブランチがあります*5。
master: これはCaveman2そのままwith_cl_markup: Djulaに代わり、CL-Markupをテンプレートエンジンに採用したスケルトンwith_parenscript:with_cl_markupをベースに、さらにJavaScript側をParenscriptで書くための準備を施したスケルトン
以下はマニュアルの英語もどきに少し肉付けしたものです。
まず、HTML部分の開発サイクル（新しいページの追加）は次の流れです*6。（with_cl_markupブランチ or with_parenscriptブランチ）
<プロジェクト名>.asdの編集："templates"モジュールの下にテンプレート名を追加- Lispファイルの追加と編集：
templates/<テンプレート名>.lispを追加- パッケージ定義：
<プロジェクト名>.templates.<テンプレート名>の名前で作成 render関数の作成：HTMLコードを文字列として返す関数- このHTMLコード作成のために
CL-Markupを使う想定 - 引数は任意
- このHTMLコード作成のために
- パッケージ定義：
- テンプレートを利用：Caveman2でルーティングの定義を行う
src/web.lispで作業<your project name>.view:render関数を利用(render :<テンプレート名> <引数（あれば）>)
templates/index.lispがこのサンプルになっています。テンプレートエンジン感を出すため、templates/layouts/default.lispで定義したデフォルトのテンプレートを利用するという形をとっています。このwith-default-layoutはただのマクロなので、必要であれば引数などは好きに追加できます。
;; templates/index.lisp (in-package :cl-user) (defpackage <% @var name %>.templates.index (:use :cl :cl-markup) (:import-from :<% @var name %>.templates.layouts.defaults :with-default-layout)) (in-package :<% @var name %>.templates.index) (defun render () (with-default-layout (:title "Welcome to Caveman2") (:div :id "main" "Welcome to " (:a :href "http://8arrow.org/caveman/" "Caveman2") "!")))
これを使う側（ルーティング側）は次のような感じです（src/web.lisp抜粋）。
(defroute "/" () (render :index))
次はJavaScript側の開発サイクルです。（with_parenscriptブランチ）
<プロジェクト名>.asdの編集："static/js"モジュールの下にファイル名を追加- Lispファイルの追加と編集：
static/js/<name>.lispを追加- パッケージ定義：
<プロジェクト名>.static.js.<name>の名前で作成 js-main関数の作成：JavaScriptコードを文字列として返す関数- このJavaScriptコード作成のためにParenscriptを使う想定
- 引数はなし
- パッケージ定義：
- テンプレート側での読み出し：
<プロジェクト名>.static.js.utils:load-js関数を利用する(load-js :<name>)static/js/_<name>.jsを作成する- 返り値は文字列
'_<name>.js'
static/js/index.lispがJavaScriptコードを作成する側の例です。
(in-package :cl-user) (defpackage <% @var name %>.static.js.index (:use :cl :parenscript)) (in-package :<% @var name %>.static.js.index) (defun js-main () (ps (alert "Hello Parenscript!!")))
これを使う側はtemplates/index.lisp @ with_parenscriptのようになります（load-jsしている部分）。
(in-package :cl-user) (defpackage <% @var name %>.templates.index (:use :cl :cl-markup) (:import-from :<% @var name %>.templates.layouts.defaults :with-default-layout) (:import-from :<% @var name %>.static.js.utils :load-js)) (in-package :<% @var name %>.templates.index) (defun render () (with-default-layout (:title "Welcome to Caveman2") (:div :id "main" "Welcome to " (:a :href "http://8arrow.org/caveman/" "Caveman2") "!") (:script :src (load-js :index) nil)))
ちなみに、load-jsはこんな感じです（関連関数は一部のみ抜粋）。
(defun write-to-js-file (name) (with-open-file (out (make-js-full-path name) :direction :output :if-exists :supersede :if-does-not-exist :create) (format t "(re-)load js: ~A" name) (format out (funcall (intern "JS-MAIN" (string-upcase (concatenate 'string "<% @var name %>.static.js." name))))))) (defun load-js (js-name &key (base-path nil)) (check-type js-name keyword) (let ((name (string-downcase (symbol-name js-name)))) (when (or *force-reload-js* (is-js-older name)) (write-to-js-file name)) (make-js-load-path name base-path)))
一応is-js-olderでファイルの新旧を見てコンパイルするか判断などやっているのですが、開発中は*force-reload-js*をずっとtにしています*7。上記サイクルの2番目でプロジェクト名を指定している理由はwrite-to-jsにあります。export, importの手間を省くためにパッケージが上記の命名に従っていることを仮定してjs-mainを呼び出すということをしています*8。
ps-experiment
ps-experimentはParenscriptの不便だと思ったところを気まぐれに拡張しているライブラリです。
ここまでの開発サイクルに関する話題としては、パッケージもどきシステムを備えている点が重要です。上記のwith_parenscriptテンプレートの利用方法ではParenscriptコードの複数ファイルへの分割方法に言及していませんが、そこを補うものになってきます。
helloという関数を別のパッケージ（ファイル）で作成して一緒にロードする例を下記に示します。なお、通常のCommon Lisp開発と同じくsome-packageの方も.asdファイルに追加しておく必要があります。
;; static/js/some-package.lisp (in-package :cl-user) (defpackage sample.static.js.some-package (:use :cl :parenscript :ps-experiment) (:export :hello)) (in-package :sample.static.js.some-package) ;; 普通のdefunのように関数を定義 (defun.ps+ hello (name) (concatenate 'string "Hello " name "!"))
;; static/js/index.lisp (in-package :cl-user) (defpackage sample.static.js.index (:use :cl :parenscript :ps-experiment :sample.static.js.some-package)) (in-package :sample.static.js.index) (defvar.ps+ *my-name* "eshamster") (defun.ps+ main () (hello *my-name*)) (defun js-main () ;; def~.ps[+]で定義したものも含めてJavaScriptを出力 (pse:with-use-ps-pack (:this) (alert (main))))
主なポイントは次の通りです。
def~.ps+は同等のCommon Lispマクロdef~と同じように使えますdef~.ps+はCommon Lisp用の定義とJavaScript用の定義を同時に行います- 可能な限りこちらを使っておくと、シンボルの参照や関数の引数チェックなどCommon Lisp相当のコンパイル時チェックができて嬉しいです
def~.ps（+がない）バージョンはJavaScript用の定義だけを行います- JavaScriptのライブラリに依存している部分や、Parenscriptやps-experimentで未対応であるためにCommon Lispままではコンパイルできない部分は止むを得ずこちらを使う感じです
defun,defvar,defmacro,defstructがこの形で利用できます
def~.ps[+]で定義したものはwith-use-packageでまとめてJavaScriptコードとして出力しますjs-mainは上で解説したものです- 残念ながらJavaScript側では名前空間を分けることができていません…
- 単純にグループ化しているに過ぎないので「パッケージもどき」と言っています
js-main関数を直接呼んでみると下記のようなJavaScriptコードが（文字列として）出力されます。
function hello(name) { return 'Hello ' + name + '!'; }; var MYNAME = 'eshamster'; function main() { return hello(MYNAME); }; alert(main());
細かい部分の話。
def~.ps[+]は共通して各単位でのコンパイルが可能です。つまり、SlimeであればC-c C-cで定義を更新できます- といっても、ブラウザ側へ反映させるためには、さらにブラウザ側でのリロードが必要になってしまいますが
- 出力されるJavaScriptコードを確認する一番手っ取り早い方法は
def~.ps[+]に対するマクロ全展開（SlimeでC-c M-m）です。周囲に直接関係のないCommon Lispコードも出てしまいますが、JavaScript部分は文字列としてまとまっているので、目視で見分けるのは簡単です。 - 上記以外も含め
ps-experimentは全体として以下のような機能を持ちます*10- 上述のパッケージもどき（グループ化）機能
defstructサブセットの提供- ドット記法のサポート
- キャメルケース用のリードマクロ（Ex.
#j.div.innerHTML#） - src/utils:
car,cdr,findその他、Common Lispとしては欲しい関数をParenscriptで使うためのマクロ群 - src/common-macros.lisp: Parenscriptコードを書いていてよく出てくるパターンをマクロ化したもの
ps-experimentの趣旨と少しずれるので、ps-experiment.common-macrosを明示的にインポートしないと使えないようにしています
cl-ps-ecs
ps-experimentまでは基盤よりのライブラリでしたが、ここからはアプリよりのライブラリです。
cl-ps-ecsはCommon Lisp兼Parenscript用のEntity Component System（ECS）ライブラリです*11。ECSがどの領域にどの程度知られているか良く分からないのですが、個人的には［GDC 2015］エンジンとツールがないなら自作しよう。「World of Tanks Blitz」ローンチまでの道のりを開発者が振り返る - 4Gamer.net」の記事で名前を知って以来一度作ってみたいと思っていました。
良い解説は調べれば出てくる（Understanding Component-Entity-Systems - Game Programming - Articles - Articles - GameDev.netとか。英語記事ですが図を見るだけでも問題意識は伝わると思います）ので、ECSについては簡単で適当な解説だけします。Unity知っている人はそのイメージで大体良い気がします*12。
パッと見誤解しやすいですが、「EntityとComponentからなるSystem」ではなく「EntityとComponentとSystemからなるアーキテクチャ」です。それぞれ次のようなものです。
- Entity: 識別子と複数のComponentを持つ
- Component: 型とデータを持つ
- System: 特定のComponent（の組み合わせ）を持つEntityを認識して処理を行う
- 例えば、「当たり判定」Systemは「物理」Componentを持ったEntityを処理する
保持するComponentによってEntityが分類される = 適切なSystemに認識されるという点が重要です。ここがクラス継承による型ベースのオブジェクト表現（GameObjectクラスがあって、それを継承したPlayerクラスとEnemyクラスがあって、さらにEnemyを継承したFlyingEnemyクラスがあって…というもの）と大きく異なる点です。多重継承の罠に陥ることなく、必要なComponentを付け外しするだけでEntityに機能を柔軟に追加・削除できる点が、試行錯誤が多く、柔軟性が求められるゲーム開発に向いていると言われています。
さて、このライブラリの使い方ですが、こんな感じになります。まずはecs-componentを継承してComponentを適当に定義します。
(defstruct (vector-2d (:include ecs-component)) (x 0) (y 0)) (defstruct (position-2d (:include vector-2d))) (defstruct (velocity-2d (:include vector-2d)))
次にecs-systemを継承してSystemを定義して登録（register-ecs-system）します。このmove-systemは位置（point-2d）と速度（velocity-2d）を持ったEntityに対して、位置を速度の分だけ更新します。
(defun process-move-system (entity) (with-ecs-components ((pos position-2d) (vel velocity-2d)) entity (incf (position-2d-x pos) (velocity-2d-x vel)) (incf (position-2d-y pos) (velocity-2d-y vel)))) (defstruct (move-system (:include ecs-system ;; どのコンポーネントを持つEntityを処理するか (target-component-types '(position-2d velocity-2d)) ;; 対象Entityに対してどのような処理をするか (process #'process-move-system)))) ;; 第1引数の:moveは単なる識別子なので適当に (register-ecs-system :move (make-move-system))
そして、ecs-entity型のEntityを生成し、add-ecs-component[-list]で必要なComponentを追加します。Systemに認識させるためにこれをグローバルに登録（add-ecs-entity）します。
(let ((entity (make-ecs-entity))) (add-ecs-component-list entity (make-position-2d :x 0 :y 0) (make-velocity-2d :x 1 :y 0)) (add-ecs-entity entity)) (let ((entity (make-ecs-entity))) (add-ecs-component-list entity (make-position-2d :x 0 :y 0) (make-velocity-2d :x 0 :y -1)) (add-ecs-entity entity)) ;; velocity-2dを持たないEntity (let ((entity (make-ecs-entity))) (add-ecs-component-list entity (make-position-2d :x 0 :y 0)) (add-ecs-entity entity))
ecs-mainを呼び出すと登録済みのSystemが一度走ります。
(defun print-all-entities () (do-ecs-entities entity (with-ecs-components (position-2d) entity (format t "ID = ~D, pos = (~A, ~A)~%" (ecs-entity-id entity) (vector-2d-x position-2d) (vector-2d-y position-2d))))) (progn (print-all-entities) (format t "--- Run ecs-main ---~%") ;; ↓これ (ecs-main) (print-all-entities))
出力は次のような感じです。「速度」Componentを持たないEntity（ID = 3）は移動していないことが分かります。
ID = 3, pos = (0, 0) ID = 2, pos = (0, 0) ID = 1, pos = (0, 0) --- Run ecs-main --- ID = 3, pos = (0, 0) ID = 2, pos = (0, -1) ID = 1, pos = (1, 0)
cl-web-2d-game
次のcl-web-2d-gameはアプリ側のライブラリで、Web上で2Dのゲームを作るためのライブラリになる…といいですが、まだ柔らか過ぎて使い方など提示できる感じではありません…。もともとcl-shigi-simulatorと一緒に育てたのち分離する予定だったのですが、まだ間に合っておらず、cl-shigi-simulator/js-libフォルダに内蔵されたままです。
主な特徴は次の通りです。
- 描画周りはThree.jsをある程度抽象化する形で書いている
- このため両対応な
cl-ps-ecsとは異なりあくまでParenscript用ライブラリです
- このため両対応な
cs-ps-ecsを用いたECSなアーキテクチャである- ベーシックなComponentやSystemを提供している
- その他便利そうな関数群を提供している
まだ柔らかなので紹介しづらいです…。記事の方も力尽き気味なので、気の向いたところだけ説明する形にします（そのうちまた記事にしたい…）。
このキャプチャに写っているのは、cl-shigi-simulatorというタイトルにも入っている中ボス「鴫（シギ）」を模したものです。本体部分2パーツとビット4つの計6パーツからなります。全部は長いので、ビット作成部分とそれらをまとめて鴫を構成する部分から抜粋して見ていきます。全体はstatic/js/shigi.lispです。
まずはビットの作成部分です。以降も含めてですが、必要な定義を全て記載しているわけではないので、コメントから雰囲気を察してください。
;; ビットEntityeを4つ作成し、リストにして返す (defun.ps make-shigi-bits () (let ((result '()) (num-bit 4) (rot-speed (get-param :shigi :bit :rot-speed)) (r (get-param :shigi :bit :r)) (dist (get-param :shigi :bit :dist))) (dotimes (i num-bit) (let* ((bit (make-ecs-entity)) (angle (* 2 PI i (/ 1 num-bit))) (model-offset (make-vector-2d :x (* -1 r) :y (* -1 r) :angle 0)) (point (make-point-2d))) ;; --- 円周上に並ぶように位置調整 --- ;; (adjustf-point-by-rotate point dist angle) ;; --- タグを付与 --- ;; (add-entity-tag bit "shigi-part" "shigi-bit") ;; --- 各種コンポーネントを持たせる部分 --- ;; (add-ecs-component-list bit ;; 描画用コンポーネント（円…を作成する関数を作っていないので、辺の多い正多角形） (make-model-2d :model (make-wired-regular-polygon :r r :n 100 :color (get-param :shigi :color)) :depth (get-param :shigi :depth) :offset model-offset) ;; 当たり判定用コンポーネント (make-physic-circle :r r :on-collision #'toggle-shigi-part-by-mouse :target-tags *shigi-collision-targets*) ;; 位置コンポーネント（ローカル座標） point ;; 回転移動用コンポーネント (make-rotate-2d :speed rot-speed :angle angle :radious dist) ;; Key-Valueパラメータ用コンポーネント (init-entity-params :color (nth i (get-param :color-chip :colors)) :display-name (+ "Bit" (1+ i)) :bit-id i :enable t))) (push bit result)) result))
かいつまんで見ていきます。
まず、一番特徴的なのはやはりECSがベースになっていることです。描画をするのか（model-2d）や当たり判定をするのか（physic）はComponentの有無によって変わってきます。ここにはないですが、あらゆる操作に対していちいちSystemを作成することは現実的ではないため、script-2dという、Entityを引数にとる任意の関数を登録するためのComponentも存在します。
次に、本システムで用意しているパラメータ管理機構には大きくglobalレベルのものとentityレベルのものがあります。globalレベルのものは上記でも所々で利用されているget-paramです。cl-web-2d-gameライブラリとして提供しているのは下記です。
convert-to-layered-hash: 階層的なKey-Value構造（ハッシュ）を作るためのDSLget-layered-hash: 上記で作成した構造から値を取り出す（もしくは関数を実行する）
;; 下記の(+ 10 20)のようにリストを書いた部分は ;; get時に関数として評価 (defvar *hash* (convert-to-layered-hash (:position (:x 12 :y (+ 10 20)) :size (:width (* 2 3) :height 100) :some-list (list 1 2 3)))) (get-layered-hash *hash* :position :x) => 12 (get-layered-hash *hash* :position :y) => 30 (get-layered-hash *hash* :size :width) => 6 (get-layered-hash *hash* :size :height) => 100 (get-layered-hash *hash* :some-list) => (1 2 3)
本アプリではglobalなハッシュはせいぜい一つしか必要でないため、get-paramでget-layered-paramをラップしてハッシュの指定を省略しています。
もう一つのEntityレベルのパラメータはinit-entity-paramsでコンポーネントとして持たせています。中身は単なる1階層のハッシュです。抜粋部分にはありませんが、利用はget-entity-paramやset-entity-paramによって行います（setfには対応できておらず…）。
だいぶおざなりな解説をしている自覚はありますが、ここで鴫全体を構成するためのコードへ向かいます。
(defun.ps make-shigi () ;; centerは全体をまとめる親となるEntityでグラフィックを持たない ;; bodiesは鴫本体の2パーツ (let ((center (make-shigi-center)) (bodies (make-shigi-bodies)) (bit-list (make-shigi-bits))) (add-ecs-entity center) ;; centerを親にしてbodyとbitをadd-ecs-entityしていく (dolist (body bodies) (add-ecs-entity body center) ;; markerは上記画像の各パーツ中心にある四角のこと (add-ecs-entity (make-center-point-marker) body)) (dolist (bit bit-list) (add-ecs-entity bit center) (add-ecs-entity (make-center-point-marker) bit) (when (oddp (get-entity-param bit :bit-id)) (toggle-shigi-part bit)))))
ここで特徴的なのはEntityの親子関係の登録です。cl-ps-ecs:add-ecs-entityは第2引数で親となるEntityを指定できます。cl-web-2d-gameではこの親子関係を主に座標の管理に利用しています。具体的には、子は座標データ（位置と回転）を親に対する相対座標として持っています*13。
この方法をとると嬉しいのは、親と子の移動処理を独立して書けるという点です。例えば、一番親となるcenterから見ると、子供であるbodyやbitのことを気にせずに移動しても（今回は固定位置ですが）、子供は勝手についてきてくれます。子供、例えばbitの方から見ると、親の中心点に対して回転するという動作だけ記述しておけば、親がどこにいるかを気にする必要はありません。今回の例で極端なものはmake-center-point-markerから作っているマーカで、マーカ自身は一切移動の処理（Component）を持ちませんが、勝手に親のbodyやbitについていっています。
あとはjs-libフォルダ配下のファイルレベルで何ができているかをざっと見て終わりにします。
- Three.jsへの依存が強い部分
2d-geometry.lisp: 描画用のモデル作成。丸や四角形や多角形を作れますdraw-model-system.lisp: 描画用のSystemcamera.lisp: 2Dに十分な形で3Dカメラを初期化・管理
- その他のJavaScriptライブラリに依存する部分
input.lisp: マウス、キーボード、タップといった入力関係の処理gui.lisp: アプリ右上の操作パネル。dat.GUIのラッパー
- JavaScriptへの依存がない部分
basic-components.lisp: 2Dのベクタなど基本的なComponent群calc.lisp: 主にベクタ関連の計算collision.lisp: 衝突計算。現状、円と円、円と任意凸多角形の判定ができます- 任意凸多角形同士の判定はまだ実装していません
utils.lisp: その他整理できていない諸々- ゲームの初期化・スタート（ここはThree.jsに依存）
- wtf-trace用のラッパー
- 上記のglobalなパラメータの作成・読み込み（ここは依存なし）
まとめ
見ての通りだいぶ荒削りですが、どうにかオールCommon LispでThree.jsなWebアプリを作れるようになりました。基盤となるライブラリを整えつつでしたが、軌道に乗ってくると全部Common Lisp（もどき）で書けて嬉しいです。また、前々から気になっていたECSを作れたのも良かったです。
今後としては、jsclやClojureScriptといったところをちゃんと調べて反映させていかないとだめですね…。その前に、今回作ったシミュレータはもう少し仕上げておきたいと思います。他、触った方は分かると思いますがまだまだパフォーマンスが悪いのでその改善も…。
最後に、もっと小分けにして少しずつ記事にしておけば良かったと思いました まる
*1:さくらのDockerホスティングサービスArukasのプレビュー版を使っています。仮置きなので、メンテのために適当に止まったり、いつの間にか消滅していたりするかもしれません。
*3:qlotに限らず新しくlocal-project配下にプログラムを置いたときなのですが、自身の環境ではなぜか大本のbashをいったん落とさないとql:quickloadから見えるようになりません…。前掲のDockerイメージを作るDockerfileではそれができないので、ql:*local-project-directories*にcl-shigi-simulator配下にできたquicklispフォルダをpushすることでどうにか回避しています
*4:もっと良いやり方がありそうですが、ベースとなるスケルトンの更新の反映を考えると、他に良い方法が思いつきませんでした…
*5:CSS部分をLisp化したものがないのは単にCSSヘビーなものを書いていないからです…。
*6:ここは以前記事（Caveman2でCL-Markupを使う準備 - eshamster’s diary）にしたものを少し整理してスケルトン化したものです
*7:理由は後述のps-experimentに関連します。1つ目は関数コンパイルだけで定義更新できるので、ファイルの保存を一々したくないこと。もう1つは、load-js関数の定義されたファイルしか見ていないため、ps-experimentで実現するファイル分割に対応できていないことです…。
*8:Dirtyかもしれません
*9:useは汚いのでimportしているシンボルの属するパッケージを探す形の方がまだ良さそうですね…。少し重そうなのが気になりますが。
*10:基本的には以前「Parenscriptで遊んでみる」シリーズで記事にしていた内容です
*11:細かな定義論が分かっていないので「ECSもどき」が適切かもしれません
*12:自身はUnity少ししか触ったことがないですが…。また、Unity社はECSとは似て非なるものだと言っているはずです
*13:割と普通の設計だとは思うのですが、以前書いたライブラリはそうしていなかったため、個人的には印象の強いポイントです
Alpineベースの（多少）軽いCommon Lisp実行用コンテナ
前書き
以前「Common Lisp開発環境 on Docker - eshamster’s diary」で紹介した開発用環境とは別に、Common Lispを実行するためだけの環境を作ってみました*1。が、手元でdocker imagesを見ると800MB、Docker Hubで見ても212MBと巨大でした。これをベースにいくつもコンテナ起こすには辛いサイズだろう…と思い、軽量化を試みました。
CentOSをやめて、ベースにもっと軽いOSを使おうと調べてみると、Alpine Linux（紹介記事：「Alpine Linux で Docker イメージを劇的に小さくする - Qiita」）というOSが軽さを武器にシェアを広げているようでした。ということで、そこにCommon Lisp実行用コンテナを乗せ換えてみましたという記事です。
Dockerコンテナ作成
目標
下記が入った状態にします。
- Roswell
- 実行環境入れるのも楽ですし（Quicklispの設定自動でしてくれたり）、デプロイ用のスクリプト（
clackupとか）のインストール用に欲しいのでひとまず入れておきます
- 実行環境入れるのも楽ですし（Quicklispの設定自動でしてくれたり）、デプロイ用のスクリプト（
- SBCL
- Roswell入った時点で簡単に入れられるのですが、そこそこ処理時間がかかるのでデフォルトで入れてみました
- どの処理系入れるかはこのリポジトリを引き継ぐ側に任せた方がよいのかもしれませんが…
- 少なくともサイズを見たいという目的では、処理系ありのサイズを見ないと意味がないという理由もありますが
Dockerfile
こんな感じのDockerfileになりました。Roswellのインストールに必要なモジュールは一通り掃除してますが、SBCL周りの掃除は甘めです。Roswellのおかげでだいぶ楽ができているので、ポイントらしいポイントもないです。あえて言えば、Alpineの作法に則ってvirtualでビルド用ライブラリをグループ化してapk delでまとめて消しているぐらいでしょうか。
結果
一応Docker Hubに上げました（Version 2.0からがAlpine版）。
https://hub.docker.com/r/eshamster/cl-base/
サイズのBefore→After
docker imagesでの表示：800MB→192MB- Docker Hub上の表示：212MB→52MB
割と満足な結果です。内部を見てみるとやはりSBCL関連のサイズが大きいです。ソースの入った~/.roswell/srcが47.8MBで、バイナリやダンプイメージの入った~/.roswell/impls配下が99.1MBでした。さらに小さくするのであればこの辺りの整理が必要です。
使ってみる
Webサーバを立てて動かせるとそれっぽい感じがするので、とりあえずCaveman2のテンプレートでサーバを立ててみます。
2ファイル用意します。CMDで直接clackupしても良いのですが、環境変数を利用できないようなので起動用にシェル（1行）を分けました。
- Dockerfile
FROM eshamster/cl-base:2.1 RUN ros run -e '(ql:quickload :caveman2)' -e '(caveman2:make-project #p"/root/.roswell/local-projects/sample-app")' -e '(ql:quickload :sample-app)' -q RUN ros install clack ENV VIRTUAL_PORT 8080 COPY run_app.sh /root CMD ["/root/run_app.sh"]
- run_app.sh
#!/bin/sh clackup --port ${VIRTUAL_PORT} ${HOME}/.roswell/local-projects/sample-app/app.lisp
後はbuildしてrunするだけです。
$ docker build -t sample-cl . $ docker run --name=sample -p 8888:8080 -d sample-cl
ローカル環境であれば、あとはhttp://localhost:8888/にアクセスすればWelcome to Caveman2!の文字が見えるはずです（手元の環境だと起動に10秒ほどかかりました）。
できていないこと
実際の運用に必要なあれこれがまだ分かっていないです。
あと開発環境の方もAlpineベースにして軽くしたいです…そのうち。
後続の関連記事
- 開発環境の方もAlpineベースにしました。
*1:前記の開発環境もこの上に移し換えようかという目論見もあったのですが、面倒でやってません
リーダーマクロで非公開シンボルの参照を簡略化する @ テスト
「#:g1: リーダーマクロでシンボルの略記をする」を読んでいて、こういうリーダーマクロの使い方することあるなと思ったので投稿。大した用途ではないですが…。
こんなことはないでしょうか。
- インタフェースとしては不要なので公開はしたくない補助関数がある
- とはいえ、それなりに面倒な関数なので単体でテストしておかないと不安がある
- しかも、それなりに数があるので、毎回
<package>::<symbol>と書くのも面倒くさい
Domain Specific Language（DSL）まがいの大き目なマクロを書いていると良くある…のかもしれません。
自身の例ではkv-kneaderというライブラリ*1がありました。src/kneader.lispという実質120行程度のファイルがありますが、公開しているのはkneadという15行のマクロひとつで、後はこのマクロのための補助関数（マクロ）です。
こうなってくると補助関数もテストしておかないと落ち着かないのですが、都度kv-kneader.kneader::parse-a-key-descriptionなどと書くと見るのも辛いです。
ようやく本題ですが、こんなときに$:parse-a-key-descriptionと書けると幸せかと思い、こんなリーダーマクロを書きました。
(eval-when (:compile-toplevel :load-toplevel :execute) (make-dispatch-macro-character #\$) (set-dispatch-macro-character #\$ #\: #'(lambda (stream &rest rest) (declare (ignore rest)) (intern (symbol-name (read stream nil)) (regex-replace "-TEST" (package-name *package*) "")))))
利用にあたっては、<hoge>.<fuga>というパッケージのテストは<hoge>-test.<fuga>というパッケージで行うという前提が必要です。このとき、<hoge>-test.<fuga>パッケージ内で$:piyoとすると、"-test"がとれて<hoge>.<fuga>::piyoというシンボルになります*2。
kv-kneader/kneader.lisp at master · eshamster/kv-kneader · GitHubが件のテストファイルですが、これの$:が全部kv-kneader.kneader::になっていたら、中々気が狂いそうです。
Common LispでSlack botを作る
チャットbotなるものにも（今さら）手を出してみようと、Slack用のサンプルbotをCommon Lispで書いてみました。
使い方
一応使い方です。
- 上記プロジェクトをquicklispからロード可能な場所にclone
settings.json.inを参考にsettings.json（下記参照）を作成- REPL上でサーバを立ち上げる。
(ql:quickload :sample-cl-bot)(clack:clackup sample-cl-bot:*app* :port 16111)
- SlackのOutgoing hookに
http://<アドレス>:16111/を登録
基本編：Slackとのやりとり
そもそもSlackとどうやりとりするのか、という話です。この手の解説は既に良いものが沢山あると思いますので、実装を簡単に見る程度にします。
流れだけ言いますと、Slack側ではOutgoing Hookにキーワード（上記の画像では"alien:"）とLispサーバのアドレスを設定し、サーバ側ではSlackから受け取ったポストを元に適切なIncoming HookのURLへメッセージ（JSON形式）を投げ返すだけです。
サーバ部分は以下のような感じで、ningleを使ってルーティングしています。
(defvar *app* (make-instance 'ningle:<app>)) (setf (ningle:route *app* "/" :method :POST) #'(lambda (params) (aif (get-incoming-hook-url params) (dex:post it :content (parse-input (extract-posted-text params) params) :headers '(("content-type" . "application/json"))))))
get-incoming-hook-urlとparse-inputについて簡単に解説。
まず、get-incoming-hook-urlはその名の通り、投稿すべきIncoming Hookのアドレスを取り出す関数です。Outgoing Hookによるポストはtokenの情報を持っているので、下記の設定ファイルを基にこのtokenと宛先のIncoming Hookの対応をとります。
{ "pairs": [ { "token": "<XXX>" "incoming_hook": "https://hooks.slack.com/services/XXXX/XXXX/XXXX" }, { "token": "<YYY>" "incoming_hook": "https://hooks.slack.com/services/YYYY/YYYY/YYYY" } ] }
次に、parse-inputですが、これは受け取ったメッセージを解析して、適切なメッセージ（JSON形式）を作り出す関数（の入り口）です。内部では最終的に以下の関数を呼び出してJSONを構成します。
(defun make-post-content (text) (jonathan:to-json (list :|text| text :|icon_url| "http://www.lisperati.com/lisplogo_alien_128.png" :|username| "Lisp Alien")))
応用編：対話式のやりとり
このbotでは下記画像のように対話式のやりとりをサポートしています（画像ではrememberコマンドの後2つの応答。getコマンドは単なる結果確認用）。その実装に関する話です。
実現機構
肝になる部分は下記のように簡単な実装になっています（上記基本編で呼んでいたparse-input関数の定義がこれ）。なお、slet, itはanaphoraライブラリからインポートしたものです*1。
(defvar *continuity-table* (make-hash-table :test 'equalp)) (defun parse-input (text params) (slet (gethash (make-params-hash params) *continuity-table*) (multiple-value-bind (content continuity) (if it (funcall it text params) (parse-command text params)) (setf it continuity) content)))
Slackから受け取ったメッセージをパースしているのは、(if it (funcall it text params) (parse-command text params))の部分です。ifの分岐方向によらず下記のように動作します。
- 引数
text：受け取ったメッセージparams：その他Slackから受け取ったパラメータ一式*2
- 返り値
ポイントとなるのが第2返り値であるcontinuityです。この関数（またはNIL）は*continuity-table*に格納されます。このテーブルのキーとなっているのはユーザ識別情報です。したがって、同じユーザから再度メッセージが来た場合、下記のように動作します。
- テーブルにNILが格納されている → 標準のパーサである
parse-commandを呼び出す - テーブルに関数が格納されている → 対話用のパーサであるその関数を呼び出す（
(funcall it text params)）
結局、普段はparse-commandで標準的な処理を行い、対話処理をしたい場合は後継の対話処理を登録しておき次回はそれを使う、というのが全体像です。
上記画像の例では下記のように対応します。
なお、聞きかじった程度の「継続」に近い気がしたので、continuityと名付けていますが、違うかもしれません…。
継続して利用する値の受け渡しについて
もう1点、"alien: the best game"とした時点で、ひとつ前の入力内容（"斑鳩"）がどこかに保存されている必要があります。これをどこに保存しているかという話ですが、クロージャに捕捉しています。
実例を見るのが早いかと思います。下記のmake-asking-value-fn関数がこの"alien: the best game"とした時点で呼ばれる関数を生成します。前段の"斑鳩"はkeyとして捕捉され、後で呼ばれる関数であるlambda以下から「見る」ことができます。
(defun make-asking-value-fn (key) (lambda (text params) (if (is-empty-string text) (values (make-post-to-mention ;; 「@<ユーザ名> ...」なポストを作る関数 (format nil "What is '~A'?" key) params) (make-asking-value-fn key)) (register-pair-and-make-post key text params))))
（一応）機能紹介
機能紹介…といっても、サンプル用に実装しただけなので、特に実用的な機能はありません。
remember/get/forget
多少実用的なものその1。
見てのとおりのkey, valueストアです。覚えた情報は基本的にtoken単位（≒チャンネル単位）で管理しているので、同じチャンネルであれば他の人が登録した情報もgetで見ることができます。
なお、永続化していないので環境を再起動すると消えます…*3。
rememberコマンドは「応用編」では対話式に覚えさせましたが、この画像のようにremember <key> = <value>で一発登録もできます。
画像にはありませんが、forget <key>で覚えた<key>の情報を削除します。
weather
多少実用的なものその2。
livedoorのお天気WebサービスのAPI*4を利用して、指定した地域の天気予報をとってきます。
なお、上記画像ではweatherのエイリアスであるwf（"Weather Forecasts"）を利用しています。
また、地味にrememberコマンドと連係しています。この画像のように、rememberコマンドで覚えたキー（上記のremember/getの例で覚えさせたもの）を地域名の代わりに利用できます。
その他
純粋なサンプル達
- hello：こんにちは
- echo：そのまま返します
- 余談ですが、下記画像のように、echoした情報にキーワード（
alien:）が含まれればコマンドとして解釈してしまいます- 必ずキーワードを消費するので無限ループはしない…はず
- 余談ですが、下記画像のように、echoした情報にキーワード（
- number game：対話式インタフェースのサンプルに作りました
- エイリアンの考えている番号を当てるだけのゲームです
- 勝率おおよそ1/7の○○ゲーです
