Parenscript上でシンボルのインポートやエクスポートを模倣する

前書き

Lisp Advent Calendar 2017の20日目の記事です。

Common LispのサブセットコードをJavaScriptに変換するParenscriptというライブラリの上でそれらしい名前空間を導入してみた記事です。考え方や実装の整理・メモという意味合いが強いので、果たしてこれを読んで何かの役に立つのかは疑問ですが、Common Lispのパッケージ・シンボルシステムを利用したメタプログラミングについて考える一つの題材になる…かもしれません。

今回の話の発端ですが、まずParenscriptで不便に思ったところを適当に拡張した自作ライブラリps-experimentというものを作っています（quicklispリポジトリ未登録）。

github.com

かれこれ2年ほどいじっていて、割合この上で快適にプログラムを書けるようになってきたのですが、ふと名前の衝突を気にしながら書いていることに気付きました。というのも、グローバル変数や関数の定義をパッケージでグループ化するという程度の簡易パッケージシステムは導入していたものの、名前空間の分割までは行っていなかったためです。そこで、Common Lispのパッケージ・シンボルが持つ情報やJavaScriptのクロージャを使えば案外簡単にJavaScript上でシンボルのインポートやエクスポートを模倣できるのではないか、と思って試したところ意外と苦労したというような話です。

誤解のないように強調しておくと、今回の話はParenscript上に独自のパッケージ管理構文を作りこむような話ではなく、あくまで既存のCommon Lispのパッケージ・シンボルの情報を利用することで名前空間が分離されたJavaScriptコードを吐き出すという話です。

なお、該当のコミットは"cef5d6: Change to split namespace by package"になります（コミットログが割と本記事の要約）。

前提知識

Parenscript

超簡易紹介

ParenscriptはCommon Lispの（サブセット）コードをJavaScriptコードに変換してくれるライブラリです。下のように ps:ps マクロの中にCommon Lispコードを書くとJavascriptコードを文字列として出力してくれます。

CL-USER> (ql:quickload :parenscript :silent t)
(:PARENSCRIPT)
CL-USER> (ps:ps (test-func 10 20))
"testFunc(10, 20);"
CL-USER> (ps:ps (funcall (lambda (a b) (+ a b))
                         10
                         20))
"(function (a, b) {
    return a + b;
})(10, 20);"

参考：Parenscriptの持つ名前空間システム

参考程度の話ですが、Parenscript自身も名前空間システムを持っています。ps:ps-package-prefixというマクロを利用して、パッケージとそれに対応するプレフィックスを登録しておくというものです。すると、登録されたパッケージ下のシンボルをJavaScriptコードとして出力する際に、プレフィックスが付与されます。

実際のところ、これに素直に乗っかれば今回引っかかったような各種問題は発生しないはずです。が、下記の通り、該当するあらゆるシンボルにプレフィックスがついてしまうため余り見た目が良くない*1ですし、また曲がりなりにもJavaScriptにも名前空間を分ける仕組み（クロージャ）はあるにも関わらずそれを使っていない…という辺りが悶々とします。

CL-USER> (defpackage test-pack (:use :cl :parenscript))
#<Package "TEST-PACK">
CL-USER> (in-package :test-pack)
#<Package "TEST-PACK">
TEST-PACK> (setf (ps-package-prefix "TEST-PACK") "some_prefix_")
"some_prefix_"
TEST-PACK> (ps (defvar x 100)
               (defun test (y)
                 (let ((temp (+ x y)))
                   (+ temp 100))))
"var some_prefix_x = 100;
function some_prefix_test(some_prefix_y) {
    var some_prefix_temp = some_prefix_x + some_prefix_y;
    return some_prefix_temp + 100;
};"

ps-experimentにおける従来のパッケージの扱い

もともとps-experimentでもパッケージの情報を少し使っていたのですが、せいぜいシンボルのグループ化と、package-use-listを利用した依存性解決程度でした。

簡単なRoswellスクリプトで利用イメージを書くと下のような感じです。defvar.psやdefun.psはパッケージ配下にJavaScript用の定義をひもづけるためにps-experimentで定義しているマクロです（なお、defvar.ps+やdefun.ps+とするとCommon Lisp用のコードも同時に出力されます）。最後にwith-use-ps-packマクロを利用して指定されたパッケージ（とそこから再帰的にuseされるパッケージ）配下のJavaScriptの定義を吐き出します。

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(ql:quickload :ps-experiment)

(defpackage pack-a
  (:use :cl :ps-experiment))
(defpackage pack-b
  (:use :cl :ps-experiment))

;; ----- Package A ----- ;;
(in-package :pack-a)

(defvar.ps *num* 0)

(defun.ps inc-num (x)
  (incf *num* x))

(defun.ps add (x y)
  (+ x y))

;; ----- Package B ----- ;;
(in-package :pack-b)

;; *num* in pack-a is not guarded
(defun.ps dec-num (x) 
  (incf *num* x))

;; :this = :pack-b
(defun main (&rest argv)
  (declare (ignorable argv))
  (print
   (with-use-ps-pack (:pack-a :this)
     (inc-num (dec-num 10)))))

結果は下記の通りです。見ての通り、名前空間の情報は失われてフラットに関数を並べているだけです。

var NUM = 0;
function incNum(x) {
    return NUM += x;
};
function add(x, y) {
    return x + y;
};
function decNum(x) {
    return NUM -= x;
};
incNum(decNum(10));

大まかなアイディアについて

まずは、実装を抜きにして順次アイディアを検討していきます。実装はその後まとめて見ていきます。

※用語について：JavaScriptコードになった時点で「パッケージ」や「シンボル」は存在しないため、JavaScript側の説明では「Common Lispコードにおいてはパッケージ（シンボル）であったもの」などと呼ぶのが正確ですが、冗長なので特に区別せずに「パッケージ」、「シンボル」と呼びます（微妙に違和感はありますが、たぶん混乱はないだろう…）

基本的なアイディア

最初の方向性として、まずは下記を満たすことを考えます。

• パッケージ間での名前空間の分離
• シンボルのインポートの模倣
  • インポートした別パッケージのシンボルを、プレフィックスなしに参照できる
• シンボルのエクスポートの模倣
  • 自パッケージのエクスポートしたシンボルを、他パッケージから（プレフィックスつきで）参照できる

例えば、下記のパッケージ2つの単純なケースを考えます。

;; --- パッケージA --- ;;
(in-package :cl-user)
(defpackage :temp.pack-a
  (:use :cl :ps-experiment)
  (:export :ex-a1 :ex-a2))
(in-package :temp.pack-a)

(defun.ps+ internal-fn (x) x)

(defun.ps+ ex-a1 ()
  (internal-fn 100))

(defun.ps+ ex-a2 ()
  (internal-fn 200))

;; --- パッケージB --- ;;
(defpackage :temp.pack-b
  (:use :cl :ps-experiment)
  (:import-from :temp.pack-a
                :ex-a1)
  (:export :ex-b))
(in-package :temp.pack-b)

(defun.ps+ internal-fn (x) (* x 2))

(defun.ps+ ex-b ()
  (+ (ex-a1) (internal-fn 200)))

パッケージBに注目すると、パッケージAでエクスポートされたシンボルex-a1をインポートして利用しており、かつ、internal-fnというパッケージAにも（internalに）存在する名称の関数を定義しています。これを次のようにJavaScriptに変換すれば良さそうです。

/* --- パッケージA --- */
var temp_packA = (function() { /* (1) */
  /* --- define objects --- */
  function testA2() {
      return internalFn(200);
  };
  function internalFn(x) {
      return x;
  };
  function exA1() {
      return internalFn(100);
  };
  function exA2() {
      return internalFn(200);
  };
  /* --- extern symbols --- */ /* (2) */
  return {
    'exA1': exA1,
    'exA2': exA2,
  };
})();

/* --- パッケージB --- */
var temp_packB = (function() {
  /* --- import symbols --- */ /* (3) */
  var exA1 = temp_packA.exA1;
  /* --- define objects --- */
  function internalFn(x) {
      return x * 2;
  };
  function exB() {
      return exA1() + internalFn(200);
  };
  /* --- extern symbols --- */
  return {
    'exB': exB,
  };
})();

• (1) 名前空間の分離を行うため、各パッケージ内の定義をクロージャで囲います。これで、例えば両パッケージに存在するinternalFn（internal-fn）の名前空間が分離されます
• (2) シンボルのエクスポートを模倣するため、シンボルと同名の文字列をキー、シンボル自身を値としたハッシュを返します。これによって、例えばtemp_packAパッケージ内のexA1にはtemp_packA.exA1として外部からアクセスできるようになります。
• (3) シンボルのインポートを模倣するため、クロージャの冒頭で同名のローカル変数に外部パッケージでエクスポートされた変数を入れておきます。これで、パッケージB内からはプレフィックスなしにtemp.pack-a:exA1にアクセスできるようになります。

ここまでは（実装的にも）順調です。

インポートしていないシンボルの参照

上記はエクスポートしたシンボルをインポートして参照するだけのお行儀の良い例でした。しかし、周知の通りCommon Lispにおいては<パッケージ名>:<シンボル名>としてインポートしなくても（エクスポートされた）シンボルを参照できますし、<パッケージ名>::<シンボル名>とすればインターナルなシンボルに触ることもできます。特にここまでのアイディアでは後者を実現する手段がないため、対処が必要です。

インターナルなシンボルに触るコードを直接書くケースは余りないと思いますが、他パッケージのマクロを利用する場合、自パッケージでインポートしていないシンボルが展開されるということが普通に起こり得ます。

(defpackage :temp.pack-a
  (:use :cl)
  (:export :ex-macro))
(in-package :temp.pack-a)

(defun internal-fn (x) x)
(defmacro ex-macro (x) `(internal-fn ,x))

(defpackage :temp.pack-b
  (:use :cl)
  (:import-from :temp.pack-a
                :ex-macro))
(in-package :temp.pack-b)

(defun internal-fn (y) (+ y 20))

(print (macroexpand-1 '(ex-macro (internal-fn 200))))
;; -> (TEMP.PACK-A::INTERNAL-FN (INTERNAL-FN 200))

表面上パッケージBはインポートしたマクロex-macroを利用しているだけですが、実際にはマクロ展開時にインポートしていないシンボルtemp.pack-a::internal-fnがパッケージB上に展開されてしまいます。もちろん、Common Lispではprint結果のように、適切にパッケージが考慮されていることが分かります。

Parenscript上で同様のことを実現するためには次の2つの要素が足りません。

• 未エクスポートのシンボルを外から触れるようにする
• 未インポートのシンボルを識別して↑のシンボルを触るようなJavaScriptコードを出力する

イメージとしては次のようになります。まずはParenscript側のコード。

(in-package :cl-user)
(defpackage :temp.pack-a
  (:use :cl :ps-experiment)
  (:export :ex-macro :ex-fn))
(in-package :temp.pack-a)

(defun.ps+ internal-fn (x) x)
(defun.ps+ ex-fn (x) x)
(defmacro.ps+ ex-macro (x) `(internal-fn ,x))

(in-package :cl-user)
(defpackage :temp.pack-b
  (:use :cl :ps-experiment)
  (:import-from :temp.pack-a
                :ex-macro))
(in-package :temp.pack-b)

(defun.ps+ internal-fn (y) (+ y 20))

(defun.ps+ hoge () (ex-macro (internal-fn 200)))

(print (with-use-ps-pack (:temp.pack-a :temp.pack-b)))

これが下記のようにJavaScriptに変換されれば良さそうです。

var temp_packA = (function() {
  /* --- define objects --- */
  function internalFn(x) {
      return x;
  };
  function exFn(x) {
      return x;
  };
  /* --- extern symbols --- */
  return {
    'exFn': exFn,
    /* ★internalなシンボルを触れるようにする */
    '_internal': {
      'internalFn': internalFn,
    }
  };
})();

var temp_packB = (function() {
  /* --- define objects --- */
  function internalFn(y) {
      return y + 20;
  };
  function hoge() {
      /* ★外部のシンボルを識別してprefixをつける */
      return temp_packA._internal.internalFn(internalFn(200));
  };
  /* --- extern symbols --- */
  return {
    '_internal': {
      'internalFn': internalFn,
      'hoge': hoge,
    }
  };
})();

後ろで見るように、実装する上で、一通りのシンボルをエクスポートする部分は何ということはないのですが、未インポートシンボルの識別ではダーティな対処が必要になっています…。

（今のところ）最後の関門：Type Specifier

唐突ですが、よく知られているように、Common Lispにおいて変数と関数の名前空間は分離されています（Lisp-2）。また、それ以外に型（Type Specifier）の名前空間も分離されています。

;; ※Clozure CLで実行（各 def... の出力は省略）
CL-USER> (defparameter x 100)
CL-USER> (defun x ())
CL-USER> (defstruct x)
CL-USER> (describe 'x)
X
Type: SYMBOL
Class: #<BUILT-IN-CLASS SYMBOL>
;; --- 変数であり、関数であり、Type Specifierでもある ---
Special Variable, Function, Type Specifier, Class Name
INTERNAL in package: #<Package "COMMON-LISP-USER">
Print name: "X"
Value: 100
Function: #<Compiled-function X #x30200190257F>
Arglist: NIL
Plist: NIL
Class: #<STRUCTURE-CLASS X>
; No value

Common Lispにおいては下記のようにして使い分けられます。

x    ; 変数としてのアクセス
(x)  ; 関数としてのアクセス
;; Type specifierとしてのアクセス（の一例）
(let ((xx 'x))
  (typep (make-x) xx)) ;; ※直接'xを書くこともできる

これらをParenscriptにかけると下記のようになります（ただし、Parenscriptでtypepは実装されていないため、ps-experiment側で（Parensript用マクロとして）補ったものです）。なお、JavaScript上では変数と関数の名前空間が分離されていないため、同時にはどれか一つしか成立しません。が、これは目をつむることにします*2。

x;   /* 変数としてのアクセス */
x(); /* 関数としてのアクセス */
/* Type specifierとしてのアクセス */
(function () {
    var xx = 'x';
    return (makeX() instanceof (typeof xx === 'string' ? eval(xx) : xx));
})();

さて、typepが変換されたものを見てみると非常に怪しげなものがあります。そう、evalです。なぜこんなものが必要になるのか…。Common Lispにおいて、プログラマが直接Type Specifierを指定する手段はシンボルの利用になります。一方で、Parenscriptを通すとシンボルはただの文字列に変換されます。しかし、JavaScriptの文字列は型を指示するものではありません。このため、evalによって型の情報にひもづけられた変数を取り出すことが必要になります。

これがどのように問題になるのかを次の例で考えてみます*3。

;; defpackage 省略
(in-package :pack-a)
(defvar.ps+ *some-symbol-list* nil)
(defun.ps+ find-typed-symbol (type-specifier)
  (find (lambda (sym) (typep sym type-specifier)) *some-symbol-list*))

(in-package :pack-b)
(defstruct.ps+ test-st-b)
(push (make-test-st-b) pack-a::*some-symbol-list*)
(pack-a::find-typed-symbol 'test-st-b)

pack-a::find-typed-symbol内のtypepがポイントです。Common Lispとしては特に問題のないコードです。pack-bから'test-st-bというシンボルが渡ってきますが、シンボル自身がパッケージの情報を持っているため、問題なくpack-b::test-st-bにたどり着けます。一方、ここまで説明した形でJavaScriptに変換すると、'test-st-bシンボルは'test-st-b'という文字列に変換され、パッケージの情報が失われます。find-typed-symbolはこれを受け取るわけですが、pack-a名前空間にはtest-st-bなどというものは定義されていませんので、eval(type-specifier) すなわち eval('test-st-b')はエラーとなります。

なお、名前空間の分離をしていなかった世界では、test-st-bはグローバルに見えていたためこの問題は生じませんでした。また、Parenscriptの名前空間機能を素直に使った場合、'test-st-b'にはprefixがつけられてグローバルに見える名前になるため、やはりこの問題は生じません。

さて、この対処の方針は次のようになります。こうすると、上記の例で言えばfind-typed-symbolには型の実体が渡されるようになるため、evalが不要になります。

• Type Specifierが定義されるときにそのシンボルを記録する
  • 幸いType Specifierが定義されるタイミングは限られています。まあ、現行のParenscript + ps-experimentでサポートしているのはdefstructだけですね…
• JavaScriptへの変換時に、Type Specifierを見つけたら問答無用でquoteを剥ぎ取る
  • 例. 'test-st-b →(quoteをとる)→ test-st-b →(JavaScriptへ変換)→ testStB（文字列ではなく変数として出力される）

これは、今までは変数＋関数の名前空間からなんとなく遊離していたType Specifierを明確に同一の名前空間に引き込む行為と解釈できそうです。解決方法として場当たり的すぎないか悩ましかったのですが、そう考えればそれなりに理のある対処ではなかろうかと思います。…結果だけ書くと割とシンプルなのですが、これを解決することに正当性があるのか（≒根本的に何が問題なのか）、実装の方針をどうすべきなのかという部分が非常に悩ましく、あやうく本稿のタイトルが「～模倣しようとしてうまくいかなかった話」になりかけた程のものではありました。

実装について

ここから先、上記で述べたアイディアの実装の話ですが、必要と思われる部分をかいつまんで説明していきます。小さな落とし穴が色々あることや、Parenscriptの関数を上書き（ps-experiment側で同じ関数を再定義）するなどというダーティな実装をしていることに目をつむれば、Common Lispのシンボルが持つ情報を利用することでベースは非常にシンプルに作れることが分かると思います。

なお、実装はおおむねps-experiment/src/package.lisp配下で行っています。また、該当のコミットは"cef5d6: Change to split namespace by package"になります（再掲）。

前置き：ps-experimentにおけるこれまでのパッケージ管理

※今回の変更の前に色々いじったので実は以下の説明と完全に一致するコミットは存在しなかったりします…。後ろの話につなげるための細部は架空な実装です。

まずは、単なるグループ化のためだけにパッケージを利用していた頃のパッケージ管理方法の概要について述べます。ポイントとなるのは、with-use-ps-packで出力するためのシンボルを独自に管理しておくという点です*4。この部分はこの後も同じです。

(defparameter *ps-func-store* (make-hash-table))

管理主体はこの*ps-func-store*です。これはパッケージをキーとしたハッシュになっており、値は次のような構造体のリストです。

(defstruct ps-func 
    name-keyword  ; シンボルを同名のキーワードにしたもの
    (func (lambda () "")))  ; これをfuncallするとJavaScriptコード（文字列）が返される

• 細かい話
  • name-keywordでキーワードでなく、シンボル自身を登録しておけば、（シンボル自身がパッケージの情報を持っているので）キーとしてのパッケージは不要です。が、今回はあった方が扱いやすそうです
  • ps-funcでいうname-keywordを2段目のキー、funcをその値とするような2重ハッシュとしないのは、できるだけ元の定義順を保存しておきたいためです*5

実装は省略しますが、defun.psなどはロード時に*ps-func-store*への登録を行います。このため、

(in-package :test-pack)
(defun.ps test-fn (x) x)

としておくと、下記のようにしてtest-fnをJavaScript関数として書き出せます。

;; *ps-func-store*のパッケージプレフィックス略
(funcall (ps-func-func
          (find (lambda (ps-func)
                  (eq (ps-func-name-keyword ps-func) :test-fn))
                (gethash (find-package "TEST-PACK") *ps-func-store*))))
;; --- 以下出力 --- ;;
"function testFn(x) {
    return x;
};"

例えば他にも、TEST-PACKパッケージ配下のものをすべて出力したければ下記のようにすればよいことになります。

(dolist (ps-func (gethash (find-package "TEST-PACK")
                          *ps-func-store*))
  (print (funcall (ps-func-func ps-func))))

基本的なインポート・エクスポート

まずは、基本的なインポート・エクスポート部分の実装です。「基本的アイディア」節の内容に加え、「インポートしていないシンボルの参照」節で述べたうちの「未エクスポートのシンボルを外から触れるようにする」まではまとめてやってしまいます。

基礎知識：シンボルからの情報取り出し

以降で主に利用するものは、シンボルの持つパッケージについての情報と「状態」についての情報の2つだけです。

パッケージの情報の取り出しは単にsymbol-package関数を利用するだけです（※以降、REPLの出力は適宜省略します）。

CL-USER> (defvar some-var 100)
CL-USER> (symbol-package 'some-var)
#<PACKAGE "COMMON-LISP-USER">

この情報は、あるパッケージから見えているシンボルが、自パッケージで定義したものか他パッケージからインポートしてきたものかを識別するのに使います。

CL-USER> (defpackage test-pack (:use :cl) (:export :aaa))
CL-USER> (defvar test-pack:aaa 100)
CL-USER> (import 'test-pack:aaa)
CL-USER> (symbol-package 'aaa)
#<PACKAGE "TEST-PACK"> ; ← CL-USERパッケージの外から来たことが分かる

次に、シンボルの「状態」ですが、こちらはfind-symbol関数で簡単に取り出せます。

CL-USER> (defvar var-a 100)
CL-USER> (defvar var-b 100)
CL-USER> (export 'var-b)
CL-USER> (find-symbol "VAR-A")
VAR-A
:INTERNAL ; ← これ
CL-USER> (find-symbol "VAR-B")
VAR-B
:EXTERNAL ; ← これも

エクスポートしていない'var-aの状態は:internalで、エクスポートしている'var-bの状態は:externalとなっています。これを利用して、エクスポートされているシンボルなのかを判別します。なお、他パッケージからインポートしたシンボルも:internalとして扱われるため、「状態」を見てシンボルが自パッケージのものかを判別することはできません。このため、その判別はsymbol-packageを利用して行います（useしたものは、もう1つの状態である:inheritedとなるため判別はつくのですが、あえて:internalと分けて考える意味もないので、ここでは:externalか否かだけに注目します）。

インポート・エクスポートの実装

前置きが長かったですが、「基本的なアイディア」節で目標としていた次のものを実装していきます。

• パッケージ間での名前空間の分離
• シンボルのインポートの模倣
• シンボルのエクスポートの模倣

ついでに、「インポートしていないシンボルの参照」節で述べたうちの下記も実現しておきます。

• 未エクスポートのシンボルを外から触れるようにする

さて肝心の実装ですが、ここまでのsymbol-package, find-symbol、あるパッケージ内の全シンボルでループするdo-symbolsマクロさえ知っていればあとは簡単です。そのため、以降はコードを並べて中に必要なコメントを追記して流していきます。

まずは、インポート部分の実装です。今後もformatが（特にスペースの数や改行が決め打ちだったりで）汚いのですが読み流してください。

#|
Create string like the following (The sort order is not stable):
var symA = packageA.symA;
var symB = packageA.symB;
var symC = packageB.symC;
|#
(defun make-imported-js-symbols (pack)
  (let ((imported-lst nil))
    ;; インポート対象シンボルの抽出
    (do-symbols (sym pack)
      (let* ((target-pack (symbol-package sym))
             ;; find-ps-funcは*ps-func-store*を探索する関数
             (ps-func (find-ps-func sym target-pack)))
        ;; ★インポートすべきシンボルであるかの判定
        ;;         ;; 1. 他パッケージのシンボルか？
        (when (and (not (eq target-pack pack))
                   ;; 2. *ps-func-store*に登録されたシンボルか？
                   ps-func
                   ;; 3. （詳細略：Top LevelなFormを実現するためにps-funcに追加した情報)
                   (ps-func-require-exporting-p ps-func)) 
          (push sym imported-lst))))
    ;; formatで頑張って文字列化（汚い）
    (format nil "~{~{var ~A = ~A.~A;~}~%~}"
            (mapcar (lambda (sym)
                      ;; symbol-to-js-stringは読んで字のごとく。Parenscriptの持ち物
                      (let ((js-sym (symbol-to-js-string (make-keyword sym))))
                        (list js-sym
                              ;; package-to...も読んでの通り。こちらはps-experiment実装
                              (package-to-js-string (symbol-package sym))
                              js-sym)))
                    imported-lst))))

次はエクスポート部分の実装です*6。

#|
Create string like the following (The sort order is not stable):
return {
  'externalSymA': externalSymA,
  'externalSymB': externalSymB,
  _internal: {
    'internalSymA': internalSymA,
    'internalSymB': internalSymB,
  }
};
|#
(defun make-exported-js-symbols (pack)
  (let ((extern-lst nil)
        (internal-lst nil))
    (flet ((keyword-to-js-string (key)
             (check-type key keyword)
             (symbol-to-js-string key)))
      ;; 自パッケージで定義したものが対象と分かっているので、
      ;; do-symbolsを使わず*ps-func-store*から直接候補を取り出す
      (let ((ps-func-lst (gethash pack *ps-func-store*)))
        (dolist (ps-func ps-func-lst)
          (when (ps-func-require-exporting-p ps-func)
            (let ((key (ps-func-name-keyword ps-func)))
              ;; ★エクスポートされたシンボルかどうかのチェック
              ;; get-symbol-statusは内部でfind-symbolを呼んでいる
              (if (eq (get-symbol-status key pack) :external)
                  (push (keyword-to-js-string key) extern-lst)
                  (push (keyword-to-js-string key) internal-lst)))))))
    ;; 出力  ※(defvar *internal-symbol-prefix* "_internal")
    (format nil
            "return {
~{  '~A': ~:*~A,~%~}  '~A': {
~{    '~A': ~:*~A,~%~}  }
};"
            extern-lst *internal-symbol-prefix* internal-lst)))

後は、これらと定義本体を合わせて出力すれば、1パッケージの完成です。仕上げ部分なので実装を載せますが、うわ汚い、と思ってスクロールするのが吉です。

(defun make-packaged-js (pack)
  (let ((ps-funcs (gethash pack *ps-func-store*)))
    (unless ps-funcs
      (return-from make-packaged-js nil))
    (let ((js-pack-name (package-to-js-string pack))
          ;; 定義本体。ここだけを出力すると、名前空間がなかった時の出力と同じになる
          (js-body (format nil "~{~A~%~}"
                           (mapcar (lambda (ps-func)
                                     (funcall (ps-func-func ps-func)))
                                   (reverse ps-funcs)))))
      ;; ★(function() { ... })();とクロージャで囲うことで名前空間を分離している
      (format nil "var ~A = (function() {~%~{~A~%~}})();~%"
              js-pack-name
              (mapcar (lambda (str)
                        (ppcre:regex-replace
                         "\\s*$"
                         (ppcre:regex-replace-all (ppcre:create-scanner "^" :multi-line-mode t)
                                                  str
                                                  "  ")
                         ""))
                      (list "/* --- import symbols --- */" (make-imported-js-symbols pack)
                            "/* --- define objects --- */" js-body
                            "/* --- extern symbols --- */" (make-exported-js-symbols pack)))))))

メイン関数の実装

名前空間が分かれたことで、実はもう一ヶ所考慮が必要な場所があります。

with-use-ps-packは第一引数としてパッケージ名（キーワード）のリストをとり、body部にメインの処理を書くことができます。

(in-package :test-pack)
(defvar.ps some-var 100)

(with-use-ps-pack (:this) ; :this == :test-pack
  (alert some-var))

名前空間の分かれていなかった今までは、単にこのbody部をJavaScriptコードに変換してベタに置いておくだけで良かったです。しかし、名前空間の分かれた今、with-use-ps-packの呼ばれたパッケージの名前空間に明示的に置いてあげる必要があります。そうしないと、上の例では(alert some-var)においてsome-varへアクセスすることができません。

そこで、同パッケージ内に一時的にメイン関数相当の__psMainFunc__という関数を作ることにします。

(defmacro with-use-ps-pack (pack-sym-lst &body body)
  (with-gensyms (pack-lst)
    `(let* ((,pack-lst ... ;; 略：依存性解決をしてパッケージのリストを作る処理
             ))
            ;; グローバル環境を汚さないように*ps-func-store*のコピーを作成
            (*ps-func-store* (copy-ps-func-store)))
       ;; __psMainFunc__ を定義する
       ;; ※defun.psは同名・同引数で内部は空のCL関数を同時に定義してしまうので、defun.ps-onlyを利用
       (defun.ps-only ,(intern "__PS-MAIN-FUNC__" *package*) () ,@body)
       (import-ps-funcs (make-package-list-with-depend ,pack-lst)
                        ;; 末尾で__psMainFunc__を呼び出す
                        (format nil "~A.~A.__psMainFunc__();"
                                (package-to-js-string ,*package*)
                                *internal-symbol-prefix*)))))

例えば、空の状態でwith-use-ps-packを呼び出すと次のようになります。

(in-package :pack-a)
(with-use-ps-pack (:this))

var packA = (function() {
  /* --- import symbols --- */

  /* --- define objects --- */
  function __psMainFunc__() {
      return null;
  };
  /* --- extern symbols --- */
  return {
    '_internal': {
      '__psMainFunc__': __psMainFunc__,
    }
  };
})();

packA._internal.__psMainFunc__();

未インポートなシンボルの識別とプレフィックスの付与

「インポートしていないシンボルの参照」節で述べたように、未インポートのシンボルを参照している場合には、「基本的なアイディア」に加えて下記を実装することが必要でした。1つ目については前節で一緒に実装したので、この節では2つ目の実装を考えます。

• 未エクスポートのシンボルを外から触れるようにする
• 未インポートのシンボルを識別して↑のシンボルを触るようなJavaScriptコードを出力する

これを実現するためには、シンボルをJavaScript用の文字列に変換している場所で、パッケージ情報などを利用して適切なプレフィックスをつけてあげる必要があります。このためには、Parenscriptで最終的にシンボル名の変換を司っているps:symbol-to-js-stringを再定義するしかないだろうというのが現状の結論です。利用しているライブラリの関数を上書きするなど汚い話なので避けたいのは山々なのですが…。

書き換えたものが下記になります。*original-package*は後述しますが、基本的には*package*と同じく定義場所のパッケージを格納したものです。

(defun ps:symbol-to-js-string (symbol &optional (mangle-symbol-name? t))
  ;; ※let*のsymbol-nameとidentiferは元の実装のまま。残りは追加
  (let* (;  明示的にPSのobfuscationを利用していない限り、単なるシンボル名
         (symbol-name (symbol-name (ps::maybe-obfuscate-symbol symbol)))
         ;; "some-symbol" -> "someSymbol"のように変換されたシンボル名
         (identifier (if mangle-symbol-name?
                         (ps::encode-js-identifier symbol-name)
                         symbol-name))
         (package (symbol-package symbol))
         (same-name-symbol (when *original-package*
                             (find-symbol (symbol-name symbol) *original-package*))))
    (if *original-package*
        ;; こちらが追加の実装
        ;; ★プレフィックスをつけるべきかの判定（詳細本文）
        (if (and (not (eq *original-package* package))
                 ;; Check if it is imported
                 (or (null same-name-symbol)
                     (not (eq symbol same-name-symbol)))
                 ;; Check if it is registered as a ps-function
                 (find-ps-func symbol package))
            (let ((*original-package* nil)
                  (package-name (package-to-js-string package)))
              ;; ★適切なプレフィックスの付与
              (if (eq (get-symbol-status symbol package) :external)
                  (concatenate 'string package-name "." identifier)
                  (concatenate 'string package-name "." *internal-symbol-prefix* "." identifier)))
            identifier)
        ;; こちらはオリジナルの実装
        (aif (ps-package-prefix (symbol-package symbol))
             (concatenate 'string it identifier)
             identifier))))

判別部分は次を見てプレフィックス（パッケージ名）をつけるべきか判定しています。

1. 自パッケージのシンボルではないこと（(not (eq *original-package* package))）
2. そのシンボルをインポートしていないこと（(or ...)）
   • 直接に判断する方法がないので次の2つの条件を見ています
     • 自パッケージから同名のシンボルが見えない（(null same-name-symbol)）、もしくは、
     • 別パッケージの同名のシンボルが見えている（(not (eq symbol same-name-symbol))）
3. *ps-func-store*で管理しているシンボルであること（(find-ps-func symbol package)）

後回しにしていた*original-package*ですが、所望の場所では必ず*package*がCL-USERパッケージに束縛されてしまうため、代替として用意したものです*7。なぜCL-USERが束縛されているかですが、これはps:psマクロ内で呼び出される出力用関数ps::parenscript-printの中でwith-standard-io-syntaxが利用されているためです。

この*original-package*への束縛を行っているのは、defvar.psやdefun.ps等で共通して利用しているps.です。

(defvar *original-package* nil)

(defmacro ps. (&body body)
  `(let ((*original-package* ,*package*))
     (macroexpand '(ps ,@(replace-dot-in-tree body)))))

ps.は元々ドット記法をサポートするためだけに導入したps:psのラッパーでした（参考：過去記事：Parenscriptで少し遊んで見る （2）ドット記法編）が意外なところで役に立ちました。ここで、ps:psを直接呼び出さずmacroexpandを挟んでいる点も今回変更が必要になった部分です。ps:psはマクロ展開時にJavaScriptコードを生成するという少々行儀の悪い作りになっているため、このように処理を遅らせないと*original-package*の束縛前にJavaScriptコードの生成処理が走ってしまいます。なお、この変更で割と不便になった点として、今まではSLIMEのマクロ全展開ショートカット（C-c M-m）で簡単にJavaScriptコードを確認できていたのですが、それができくなったという点があります（確認用の補助関数ぐらいは用意しないと…と思いつつまだしてません）。

Type Specifierの登録とquoteの剥ぎ取り

Type Specifierをパッケージ間で取り回すには下記の実装が必要でした。どちらも方針さえ決まってしまえば実装上難しい部分はありません。

• Type Specifierが定義されるときにそのシンボルを記録する
• JavaScriptへの変換時に、Type Specifierを見つけたら問答無用でquoteを剥ぎ取る

まずはType Specifierとなるシンボルの記録です。

(defparameter *ps-type-store* (make-hash-table))

(defun ps-type-p (symbol)
  (gethash symbol *ps-type-store*))

(defun register-ps-type (type-specifier)
  (check-type type-specifier symbol)
  (setf (gethash type-specifier *ps-type-store*) t))

記憶する場所としては*ps-type-store*というハッシュテーブルを用意します。シンボルをキーにgethashすると、Type Specifierであればt、そうでなければnilが返るというだけのものです（ps-type-p）。Type Specifierを生み出す側（現行のps-experimentではdefsturct.ps, defsturct.ps+のみ）はロード時にregister-ps-typeが呼び出されるようにしておくだけです（コード略：defstruct.psの実装は長く良い感じに抜き出せないので…）。

次に、quoteの剥ぎ取りです。自力でコードウォークをしてquoteを正しく探し出す…というのは非常に骨なので、ダーティ覚悟でParenscriptで実装されているquoteを上書きしてしまうことにします。

(ps::define-expression-operator quote (x)
  (flet ((quote% (expr) (when expr `',expr)))
    (ps::compile-expression
     (typecase x
       (cons `(array ,@(mapcar #'quote% x)))
       ((or null (eql [])) '(array))
       (keyword x)
       ;; ★変更点はこのsymbol部分だけ、elseは元の実装のまま
       ;; Type Specifierは文字列化せずに返す。これでquoteを剥いだことになる。
       (symbol (if (ps-type-p x)
                   x
                   (symbol-to-js-string x)))
       (number x)
       (string x)
       (vector `(array ,@(loop for el across x collect (quote% el))))))))

コメントのように変更点は1ヶ所だけです。リストや配列のquoteについても、各要素のquote処理は最終的にここに辿り着くため、これだけで対応できます。

終わりに

以上で、新たな構文を一切付け足すことなく、既存のパッケージ・シンボル情報を利用することで、JavaScript側での名前空間の分離を達成することができました。実際、ps-experimentの上に実装しているEntity Component Systemもどきライブラリのcl-ps-ecsでは一切書き換えは不要でしたし、さらにその上に実装しているWeb向け2Dゲームライブラリcl-web-2d-gameではエクスポート・インポートがいい加減であった部分の修正だけで事足りました（前者は全体がCommon Lispコードとしても動かせるので整っていたのですが、後者はJavaScriptコードとしてしか動かない部分が結構あるのでそこに抜けがありました）。

今回の機能変更で吐き出されるJavaScriptコードの量が一気に増えるので、そこは少々気がかりです（特に、大きいパッケージをuseしたりすると…）。説明を省きましたが、今回useしなくともインポートさえしていれば依存パッケージとみなすような変更もし加えたので、極力インポートを使うようにして不必要なuseをしないという地道な改善は可能です。いざとなったら、インポートの模倣はあきらめて、外部パッケージのシンボルはすべてパッケージプレフィックス付きで呼ぶようにすれば、いくらかは短くなるかもしれません。

ひとまず、当面はまだ見ぬ問題に怯えながら使っていってみようと思います。

関連過去記事

• Parenscriptで遊んで見る (1) defun編 - eshamster’s diary：ps-experiment黎明期の記事です（(5)まであります）
  • 「Parenscript」でググると割と上の方に来たりするのですが、気になったところをつまんでいるだけで余り役に立たないこれが上に来てしまうのはなんか申し訳ない気分になります…
• 木構造の親子関係を考慮したソート - eshamster’s diary：パッケージ間の依存性解決コードを書くため、問題を一般化して考えてみた記事
  • なお、同記事内では循環参照をエラーにする方法と適当にやり過ごす方法を書きましたが、ps-experiment上では前者までを実装しています
• Three.jsなWebアプリをCommon Lispで書く話 - eshamster’s diary：昨年のAdvent Calendar記事。「終わりに」で触れたcl-ps-ecsやcl-web-2d-gameについて
• [Common Lisp] システム内のパッケージ間の関係をグラフ化 - eshamster’s diary：最初にdo-symbolsを使ったのはこの頃でした

付録：最終的な出力例

Roswellコード：

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(ql:quickload :ps-experiment)

(defpackage pack-a
  (:use :cl :ps-experiment)
  (:export :inc-num :negate))
(defpackage pack-b
  (:use :cl :ps-experiment)
  (:import-from :pack-a
                :inc-num))

;; ----- Package A ----- ;;
(in-package :pack-a)

(defvar.ps *num* 0)

(defun.ps inc-num (x)
  (incf *num* x))

(defun.ps negate (x)
  (* x -1))

;; ----- Package B ----- ;;
(in-package :pack-b)

(defstruct.ps test-st)

(defun.ps dec-num (x)
  (inc-num (pack-a:negate x)))

;; :this = :pack-b
(defun main (&rest argv)
  (declare (ignorable argv))
  (print
   (with-use-ps-pack (:this)
     (list 'test-st 'some-sym pack-a::*num*))))

JavaScriptコード（printの出力抜き出し）：

var packA = (function() {
  /* --- import symbols --- */

  /* --- define objects --- */
  var NUM = 0;
  function incNum(x) {
      return NUM += x;
  };
  function negate(x) {
      return x * -1;
  };
  /* --- extern symbols --- */
  return {
    'incNum': incNum,
    'negate': negate,
    '_internal': {
      'NUM': NUM,
    }
  };
})();

var packB = (function() {
  /* --- import symbols --- */
  var incNum = packA.incNum;
  /* --- define objects --- */
  function testSt() {
      return this;
  };
  function makeTestSt() {
      var _js2 = arguments.length;
      for (var n1 = 0; n1 < _js2; n1 += 2) {
          switch (arguments[n1]) {
          };
      };
      var result = new testSt();
      return result;
  };
  function testStP(obj) {
      return (obj instanceof testSt);
  };
  function decNum(x) {
      return incNum(packA.negate(x));
  };
  function __psMainFunc__() {
      return [testSt, 'someSym', packA._internal.NUM];
  };
  /* --- extern symbols --- */
  return {
    '_internal': {
      'testSt': testSt,
      'makeTestSt': makeTestSt,
      'testStP': testStP,
      'decNum': decNum,
      '__psMainFunc__': __psMainFunc__,
    }
  };
})();

packB._internal.__psMainFunc__();

---

*1:あくまで本体はParenscript側のコードなので、JavaScript側の見た目は重要でないといえばそうなのですが…

*2:えー、と思うかもしれませんが、まずはパッケージ間の名前空間分離が目的ですので…

*3:実を言うと、(symbol-value 'x)として値を取り出すとか、(funcall (symbol-function 'x) )として関数を呼び出すような、シンボルを直接扱う操作をされると変数や関数でも同じ問題が起きます…。が、普通やらないでしょうということで制限としておきます

*4:シンボルを使ってメタなことをやろうとする場合はよくやる手段なのではないかと思います

*5:パッケージ自体の定義順序は、ここで保存しておく必要はありません。出力時に依存性を考慮して並び替えるためです

*6:細かい割りに長い話なので脚注。Common Lispではエクスポートの有無に関わらず :: （コロン2つ）でシンボルにアクセスできます。これに合わせるためには、JavaScript側でもエクスポートするオブジェクトを"internal"の内外両方に置いておく必要があります。しかし、エクスポートされたシンボルについては、コロン1つで参照されたのか2つで参照されたのかを後から知るすべはない（はず…）です。そのため、JavaScript側でわざわざ"internal"内外にそれぞれ用意しておいても、Common Lisp側の（字面上の）記述に合わせて使い分けることができないため、意味がありません

*7:なお、*original-package*のおかげでifのelse側に元の実装を残せたのですが、これは副産物でした

斑鳩における解放の挙動について ～C2虎鶫第二ジェネレータ～

前書き

斑鳩について少し気になることがあったので考察してみた記事です。動機としては、単なる興味が大半なので攻略の役に立つかは分かりません…。

解放の挙動が1回転多めにくるりんって回る条件なんやろ？解放のコトわかってるようでわかってないんよなあ… pic.twitter.com/sjn9Ckcmma

— シャモ (@shamo_tx) 2017年12月2日

気になったのはこのツイートです。C2の虎鶫（敵の名称、斑鳩内で最もサイズが小さい敵）第二ジェネレータで起こる解放の挙動について言及しています。頻度的にはそれほどでないので無視していましたが、確かに時々起こる挙動で、頭の隅に引っかかってはいました。せっかくこうして動画が手に入ったので少し考えてみた次第です。

解放挙動の基本

※この章は表面的に推測しただけなので間違っている可能性は大いにあります

解放の割り当て

解放の各本がどの敵に割り当たるかというところが今回一番重要な部分だと考えています。結論から言うと、距離の近い敵から特定の順で割り当たっているようです*1。

画像は動画から引き抜いたもので12本のフル解放です。説明のために左下から順に番号を振ります（9と11、10と12がほぼ重なっているので少々見分けづらいですが、よく見ると少し膨らんで見えると思います）。

まず、敵が全員解放1本で倒せる場合を考えると、最も距離の近い敵が1番の解放、次に近い敵が2番の解放…と近い敵から上の順番で解放が割り当たっていくようです。次に、倒すのに複数本必要な敵がいる場合ですが、そうした敵に対しては倒せるまで連続して割り当たるようです（5,6,7,…のように）。

全て割り当てても解放が余っている場合の挙動は分かっていないです…。余った解放に対して、上記の割り当てを再度行うのが自然そうではありますが未検証です。

追尾の挙動

追尾の基本的な挙動としては、対象のいる方向に角度を変えつつ前に進むというシンプルな形がベースのようです。このとき、最大旋回角度は固定で、角度が離れているときは速度を落とす（角度が近いときは逆に上げる）ことでいつまでも敵の周りを回り続けることを回避しているようです*2。

今回の挙動というよりは、対策を考えるうえで気に留めておく価値がありそうなのは、発射後一定時間は速度が一定もしくは加速している（上記の速度減少が起こらない）ということと、番号が上の解放ほど初速が大きいというあたりでしょうか*3。

余談ですが、上記の挙動はあくまで基本であり、カッコよさとプレイのしやすさのバランスをとるために相当色々な工夫が入っているようです。前に色々調べていたのですが半端なところで放置してしまっています…。

今回の場合

さて、ようやく今回の場合についてです。上記のように解放の割り当てが一番問題と考えています。そこで、動画を繰り返し見てどの解放がどこに飛んでいるかを見てみました。結果は上の画像の通りです。？がついていないものはほぼ間違いないだろうというもの、ついているものは若干自身がないが正しいだろうというものです*4。少なくとも偶奇（＝左右どちらから発射されたか）は正しいと思っています。

ここで重要なのは、例のくるりと解放が回ってしまった敵に9番が割り当たっていることです。9番の解放は左側では上から2番目の解放であり、初速が非常に速いです。このため、減速に時間がかかる→中々敵に照準が合わない→ぐるぐる回るということになったのではないかと推測します。

なぜ9番という高い番号が割り当たったか、別の言い方をすると、なぜ真ん中のジェネレータの方が若い番号が割り当たったのかを考えてみます。上の画像では解放箇所から広がる同心円に注目しています。これを見ると、例の虎鶫とジェネレータがほぼ同じ距離にあったことが分かります*5。見た目上は正直どちらが近いか判断がつかないですが、「近い敵ほど若い番号が割りつく」ことを考えると、ジェネレータの方がわずかに近かったようです。このため、より若い番号の解放がジェネレータに（２つも！）消費されてしまったと考えられます。

ここからは推測ですが、今回のケースは虎鶫とジェネレータの距離関係が非常に近いという稀なケースで、たいていの場合は虎鶫の方が近いのだと思います。より若い番号の解放を割り当てることだけ考えるのであれば、より左側で解放を行えばよいという結論になります。そうすると、若い番号 = 初速の遅い解放が割り当たるため、今回の現象も起きにくくはなるはずです。ただし、本当にまったく起こらないのか…というところは自身がないです。

---

*1:本題ではないので脚注ですが、いったん割り当たった敵が変更されることはないようです。そのため、対象の敵が先にショットで倒れたなどの場合はそのまま飛び去ります。ただ、たまに画面外から戻ってくるような挙動を見せることがあるので、疑問は残ります

*2:最大旋回角の方が変わっている可能性もあるのですが、どちらが正しいか決定的なところは見えていないです。見た目の速度が違う解放でも旋回角度は同じように見えたという程度の根拠で、実際に速度が変わっているのだろうと考えた程度の根拠です。

*3:細かいことを言うと、1と2や5と6のように左右対称な解放の初速は同じです

*4:消去法で10番が決まりますが、特に注目していなかったので振っていません

*5:距離の計算を、中心点で行っているのか、より広い範囲で行っているのか確証がなかったのですが、今回の挙動を見ると後者で決まりのようです

木構造の親子関係を考慮したソート

前置き

Common Lisp（サブセット）をJavaScriptコードに変換するParenscriptを色々拡張しているps-experimentで以前パッケージもどきを追加したことがありました。

eshamster.hatenablog.com

単に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つでも一致すれば等値です

(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)))

（きちんと証明する能がないですが…）こうした定義から下記の性質を持つ点が重要です。

性質

1. グループはノードとしての性質（等値比較ができる、子供を定義できる）を満たす
2. 循環参照する複数のグループに属するノードを集めることで、一つのグループを構成できる
3. 同一グループ内の任意の2ノードは循環参照している
   • つまりグループ内のノード間では上下関係を決定できません
4. 循環参照の関係にないグループA, Bがあり、かつAがBに依存しているとき、Bの全てのノードはAのどのノードから見ても（一方向の）子孫ノードである
   • 平たく言えば、ノード間の親子（先祖/子孫）関係はグループ化しても保存されるということです

これらの性質を利用すると、下記のような手順で「循環参照を塊とみなしたソート」を実現できます

手順

1. ノードのリストから、各ノードを要素とするグループのリストを作成する
2. グループのリストから（自己参照でない）循環参照を探す。なければ手順5へ飛ぶ
   • 性質1により、ノード用の循環参照検知関数をそのまま利用できる]
3. 手順2で見つけた循環参照グループからノードを取り出して一つのグループにまとめ（性質2による）、元のグループは破棄する
   • この操作によりリストの要素が減るので、無限ループにならない
4. 手順2へ戻る
5. グループをノードとみなし（性質1による）、段階2：複数の親を許すがループは存在しない木の場合に従ってソートする
6. 手順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つほど例を見てみます。

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))

2つの循環参照間に相互依存が存在する木

(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
  • 1986年、マイケル・ストーンブレーカー博士により、自身の開発したRDBであるIngresの後継としてPOSTGRES（= Post + Ingres）プロジェクトが発足された
  • 1987年には最初のプロトタイプが公開された
  • 問い合わせ言語はSQLではなく、Ingresの流れを汲むQUELであった
  • 1993年にはこのPOSTGRESプロジェクトは終了した
• PostgreSQL
  • BSDライセンスで公開されていたPOSTGRESのソースを元に、問い合わせ言語をSQLに変更したものが起源になっている
  • 1995年に初版が公開された
  • 1997年まではPostgres95という名称だった

実際に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に乗り換えても（未定）考え方は使えると思い、気を取り直して進めます。さて、こんなものを作りました。

• https://cl-shigi-simulator.arukascloud.io/shigi*1

斑鳩という素敵STGの3面中ボスである「鴫（シギ）」に関するシミュレータ（絶賛未完成）ですが、Qiitaから来られた方の10割はなんのことか分からないと思うのでこれ自体の話はまた別に記事を起こせたらと思います（ちなみに、Twitterから来られた方の8割はなんのことか分かると思います）。

ポイントはThree.js（WebGLを簡単に利用するためのライブラリ）を利用したWeb2Dゲームアプリであり、サーバサイドからフロントエンドまで*2Lispで記述されているという点です。これを実現するためにどのようなベースを作り、その上でどのような開発サイクルを回していったかが記事の焦点です。

一応動かし方

github.com

これを動かすこと自体に興味のある人がどれだけいるか甚だ疑問ですが、一番簡単なのは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コンテナです
    • 関連記事：「Alpineベースの（多少）軽いCommon Lisp実行用コンテナ - eshamster’s diary

それぞれのライブラリ（自作物のみ）

上のライブラリを使ってどのように開発を回してきたかという話を淡々と書いていきます。

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ブランチ）

1. <プロジェクト名>.asdの編集："templates"モジュールの下にテンプレート名を追加
2. Lispファイルの追加と編集：templates/<テンプレート名>.lispを追加
   • パッケージ定義：<プロジェクト名>.templates.<テンプレート名>の名前で作成
   • render関数の作成：HTMLコードを文字列として返す関数
     • このHTMLコード作成のためにCL-Markupを使う想定
     • 引数は任意
3. テンプレートを利用：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ブランチ）

1. <プロジェクト名>.asdの編集："static/js"モジュールの下にファイル名を追加
2. Lispファイルの追加と編集：static/js/<name>.lispを追加
   • パッケージ定義：<プロジェクト名>.static.js.<name>の名前で作成
   • js-main関数の作成：JavaScriptコードを文字列として返す関数
     • このJavaScriptコード作成のためにParenscriptを使う想定
     • 引数はなし
3. テンプレート側での読み出し：<プロジェクト名>.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コードとして出力します
  • 第1引数で指定したパッケージに属する定義が対象です
  • 指定がなくとも、useしているパッケージは再帰的に探して定義を出力します（上記で:sample.static.js.some-packageを省略できるのはそのため）*9
  • また、:thisは自身（上記では:sample.static.js.index）のエイリアスです
• 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構造（ハッシュ）を作るためのDSL
• get-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: 描画用のSystem
  • camera.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のプレビュー版を使っています。仮置きなので、メンテのために適当に止まったり、いつの間にか消滅していたりするかもしれません。

*2:CSSを除く

*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とか）のインストール用に欲しいのでひとまず入れておきます
• 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ベースにしました。

eshamster.hatenablog.com

*1:前記の開発環境もこの上に移し換えようかという目論見もあったのですが、面倒でやってません