Common Lispでマクロ展開時エラーをテスト
前回記事の「Parenscriptで少し遊んで見る （5）defstruct編 - eshamster’s diary」ではdefstruc.psマクロ内で展開時のエラー処理を入れたので、テストも一緒に作っています。このときに、マクロ展開時のエラーをテストする方法が意外と見つからなかったのでメモ。探し方が悪いのか、そんなの当たり前でしょということで誰も書いていないのか。
CL-USER> (defmacro throw-error-macro (x) (if (numberp x) `(+ ,x 10) (error 'type-error))) THROW-ERROR-MACRO
特に意味のないマクロですが、数値型を受けとると10を足す式を返し、それ以外の型を受けとると（展開時に）type-errorを投げます。この挙動をテストしたい訳ですが…
CL-USER> (ql:quickload :prove :silent t) (:PROVE) CL-USER> (prove:is-error (throw-error-macro nil) 'type-error) ; ; compilation unit aborted ; caught 1 fatal ERROR condition ; caught 1 ERROR condition ; Evaluation aborted on #<SIMPLE-ERROR "unbound condition slot: ~S" {1005EC7663}>.
というように、prove:is-errorが呼び出される前のコンパイル段階でエラーになるため、prove:is-errorでエラーを捕捉できません。マクロを実行時に評価できれば良いわけですが、実行時評価となればevalの出番です。
CL-USER> (prove:is-error (eval '(throw-error-macro nil)) 'type-error) ✓ (EVAL '(THROW-ERROR-MACRO NIL)) is expected to raise a condition TYPE-ERROR (got #<TYPE-ERROR {1003C91FE3}>) T #<PASSED-TEST-REPORT RESULT: T, GOT: #<TYPE-ERROR {1003C91FE3}>, EXPECTED: TYPE-ERROR>
できました。一々evalやクォートを書くのが気持ち悪い場合、以下のようにprove-macro-expand-errorマクロを作成します。
CL-USER> (defmacro prove-macro-expand-error (code expected-error) `(prove:is-error (eval ',code) ,expected-error)) PROVE-MACRO-EXPAND-ERROR CL-USER> (prove-macro-expand-error (throw-error-macro nil) 'type-error) ✓ (EVAL '(THROW-ERROR-MACRO NIL)) is expected to raise a condition TYPE-ERROR (got #<TYPE-ERROR {10044945E3}>) T #<PASSED-TEST-REPORT RESULT: T, GOT: #<TYPE-ERROR {10044945E3}>, EXPECTED: TYPE-ERROR>
言われてみれば当たり前な気がしますが、個人的にはevalを使う機会がなかったので中々出てこない発想でした。
ちなみに、元々は「リードマクロ入門、の10分の1歩ぐらい後か前 - eshamster’s diary」のコメントで教えて頂いたREPL環境でのリードマクロの試用方法から思い至ったため、(format nil "~S" ...)で文字列化してread-from-stringをしてevalするという無駄なことをしていました。一方で、リードマクロのエラーをテストしたい場合はread-from-stringを使えば良さそうです。
追記：macroexpand
g000001さんからmacroexpand(-1)の方が一般的とのコメントを頂きました。evalは汎用的過ぎるので、可能な限りより用途の限定されたもので代用するのが適切だと思いますが、macroexpand(-1)はまさにぴったりの用途ですね。Lispを勉強し始めてからは前より人のソースを見ることが増えましたが、まだまだ勉強不足でした。
ということで、macroexpand版です。見た目としてはevalがmacroexpandに置き代わっただけです。
CL-USER> (prove:is-error (macroexpand-1 '(throw-error-macro nil)) 'type-error) ✓ (MACROEXPAND-1 '(THROW-ERROR-MACRO NIL)) is expected to raise a condition TYPE-ERROR (got #<TYPE-ERROR {10060A87D3}>) T #<PASSED-TEST-REPORT RESULT: T, GOT: #<TYPE-ERROR {10060A87D3}>, EXPECTED: TYPE-ERROR> ;; マクロ化 CL-USER> (defmacro prove-macro-expand-error (code expected-error) `(prove:is-error (macroexpand ',code) ,expected-error)) PROVE-MACRO-EXPAND-ERROR CL-USER> (prove-macro-expand-error (throw-error-macro nil) 'type-error) ✓ (MACROEXPAND '(THROW-ERROR-MACRO NIL)) is expected to raise a condition TYPE-ERROR (got #<TYPE-ERROR {1003246EA3}>) T #<PASSED-TEST-REPORT RESULT: T, GOT: #<TYPE-ERROR {1003246EA3}>, EXPECTED: TYPE-ERROR>
Parenscriptで少し遊んで見る （5）defstruct編
Parenscript（PS）用にdefstructのサブセットを作った話です。例によってParenscript拡張の実験場、ps-experimentプロジェクトで実装を試みています。今回の記事時点のタグblog-play-ps-5をつけています。
前書き：Parenscript拡張の方針
ここまでと今回の内容を振り返ってみると、大体次のような方針で拡張を進めているようです（後付け）。
- Common Lispとして書ける部分はそれなりにCommon Lispらしく
- 理想を言えば、Common Lispコードとしてもそのまま動く
- JavaScriptべったりなところはむしろよりJavaScriptらしく
- xx.jsのようなライブラリに依存する部分
前者はdefun編や今回のdefstruct編、後者はドット記法編やキャメルケース編です。前者の「それなり」の範囲は感覚的になんとなく許せない範囲です。
今回で言うと、基本的なデータ構造がJSべったりなのはちょっと…と感じたわけです。
defstruct.psの実装方針
defstructを全面的にカバーするのはオーバースペックなので、defstruct.psの目標を次のように設定しました。
- 作成時にスロットの初期化ができる
- 型判定ができる
- アクセサを生成する
- 継承ができる
見ての通りdefstructの仕様からすると超のつくサブセットです。まずは想定範囲内では使えそうというところです。
使い方
できあがったものを上記の目標に沿って一通り動かしてみます。出力はprintの横に逐次コメントで書いているので省略します。
展開結果
(print (pse:with-use-ps-pack (:this)))で見られる展開結果のうち、childの部分だけ抜粋。アクセサはPS用のマクロとして別に管理されているため、JSコードとしては見えません。
function child() { this.a = 10; this.b = null; return this.c = 30; }; function makeChild() { var _js4 = arguments.length; for (var n3 = 0; n3 < _js4; n3 += 2) { switch (arguments[n3]) { case 'a': a = arguments[n3 + 1]; break; case 'b': b = arguments[n3 + 1]; break; case 'c': c = arguments[n3 + 1]; }; }; var a = 'undefined' === typeof a ? 10 : a; var b; var c = 'undefined' === typeof c ? 30 : c; var result = new child(); result.a = a; result.b = b; result.c = c; return result; }; function childP(obj) { return (obj instanceof child); }; (function () { function tempCtor() { return null; }; tempCtor.prototype = parent.prototype; child.superClass_ = parent.prototype; child.prototype = new tempCtor(); return child.prototype.constructor = child; })();
Parenscriptのキーワード引数の実装が少々不恰好ですが、現状ではJSコードへのコンパイル段階でどの関数を呼んでいるかを知るすべがないので、止むを得ないというところです。
実装
ps環境下でのdefstruct
一部を切り出し。まずは、(ps:ps (defstruct test (a 10) b))のように、ps環境下でdefstructを利用可能にするためのコード。一番下の(defpsmacro defmacro ...)が本体で、その上に補助関数をずらっと並べています。
見ての通りparse-defstruct-xxxがひたすら並んでいます*1。また、生成されたJavaScriptを見て文法エラーを見つけるのは辛そうなので、パース時のエラー処理を（それなりに）入れています。
JavaScript側の継承を実現する上では「Google流 JavaScript におけるクラス定義の実現方法」を参考にしました。最初はObject.setPrototypeOfを使ったお手軽な方法を使おうと考えていました。一連の流れをOpera（Chromiumエンジン）のコンソールで再現すると以下のようになります。
> function Parent () { this.a = 10; this.b = 20 }; undefined > function Child () { Parent.call(this); this.c = 30; }; undefined > Object.setPrototypeOf(Child.prototype, Parent.prototype); Child {} > var child = new Child(); undefined > child instanceof Parent; true
が、上記のサイトには互換性に問題ありと書かれていて、どうせ古いIEのことだろうとタカをくくっていたところ、テストに利用しているcl-javascriptで動きませんでした…。ということで、上記のコード（同サイトで紹介されているgoog.inherit実装のParenscript版）になりました。
また、スロット周りの継承を実現するために*ps-struct-slots*というグローバルなハッシュを用意しています。スロットそのものの継承だけであればJavaScriptのcall関数で十分ですが、CLライクなアクセサの定義を行なうために必要になります。
トップレベルでのdefstruct.ps
「使い方」のRoswellスクリプトの様に、トップレベルでPS用の構造体定義を可能にするためのマクロdefstruct.psを生成します。直接には3,4行目が該当のものです。
2015/11/30追記：よろしくないバグを見つけたので修正。あえて古いコードもコメントで残しましたが、On Lispにもある「値を返す他には周囲の世界に影響しようとすべきではない」の原則に反していました。元のコードでは、例えばdefun.psを使ったライブラリxyzを(ql:quickload :xyz)しても、関数が登録されていませんでした。さらに困ったことに、稀に登録されてることがありました…。この辺りの内部的な挙動はまだ理解し切れていませんが。
2015/12/5追記：defstruct.ps内でもregister-defstruct-slotsを呼ばないと上の追記と同じ問題が起こることが分かったのでこのコミットで修正。ちょっと汚いのでどうにかならないものか…。ちなみに、eval-whenは試行錯誤の痕跡でただの消し忘れです。
register-ps-func関数の詳細は第4回参照ですが、PSコードを出力する関数をグローバルに登録するものです。登録した関数はwith-use-ps-pack内（上記実行例参照）で呼び出されてPSコードを出力します（最終的にこのPSコードがJSコードを出力します）。
defstruct.psで構造体hogeを定義すると、hogeを定義するPSコードを出力する関数がこのregister-ps-funcで登録されます。この辺りはdefun.psやdefvar.psでも共通のパターンであるため、def-ps-definerとしてマクロ化しました。
できていないもの
- defstructの機能色々
- 必要になったものから順次というスタンスです
- 再定義時の動作
Parenscript関連記事
Lisp-Parenscript カテゴリーの記事一覧 - eshamster’s diary
*1:S式≒リストのパースは本当に気軽にできますね
Parenscriptで少し遊んで見る （4）続・defun編
背景
第一回では、ps環境の外側でdefunするためのdefun+psを用意しました。そして、それをまとめてJavaScriptに出力するためのwith-import-ps-defマクロを作ったわけですが、出力する関数名を一々指定する必要がありました。
いったんはそこで妥協したのですが、実際に細かい関数をたくさん書いたときの面倒臭さや、複数ファイル（パッケージ）間での連携をどうするかという部分で実用上すぐに問題になるため、少し見直しました。
方針
以下、defun+ps, defun.psで定義した関数をPS関数と呼ぶことにします。
一つの理想はCommon Lispの柔軟なパッケージシステムを再現することだと思いますが、よく考えるとそこまでするのは無意味ではないかと思えてきます。次のような違いがあるためです。
- (Common) Lisp: たくさんの関数を定義をしても、export, importするのは一部
- Parenscript: たくさんのPS関数を定義したら、全てJavaScriptとして書き出す必要がある
第一回で重複書き出しの問題をどう避けるかが難しそうという話を書いたのですが、例えばいっそ定義されたPS関数を全て書き出す機能を用意する（それを何度も呼ぶ間違えはさすがに利用者の責任）、という乱暴な方法でも実用上は十分な解決方法になりえます。
ということで、以下の方針でdefun+psとwith-import-ps-defの改良を考えます。
- JavaScriptに書き出す対象は大きな単位で指定し、関数単位での柔軟な操作は必要ない
- 再利用性や今後の拡張性を考えてCommon Lispのパッケージを単位として採用する
- 実現のために、グローバルな環境にPS関数の情報を持たせる
PS関数を管理する
(defparameter *ps-func-store* (make-hash-table)) (defun register-ps-func (name_) (symbol-macrolet ((target-lst (gethash *package* *ps-func-store*))) (unless (find name_ target-lst) (push name_ target-lst)))) (defun intern-ub (sym) (intern (format nil "~A_" (symbol-name sym)))) (defmacro defun+ps (name args &body body) (let ((name_ (intern-ub name))) (register-ps-func name_) `(defun ,name_ () (ps (defun ,name ,args ,@body)))))
PS関数をグローバルに管理する構造として、*ps-func-store*を用意します。単なるハッシュで、パッケージをキーとし、関数（名）シンボルのリストを値として持ちます*1。
実際に登録を担うのがregister-ps-func関数です。パッケージごとに関数名の重複を確認しており、未登録なら登録し、登録済みなら何もしません。これをdefun+psマクロから呼び出すことで、defun+psしたPS関数がそのパッケージに登録されます（要はdefunの場合と似たような動作）。
PS関数をprintする
登録したPS関数をJavaScriptとして吐き出すのがwith-use-ps-packマクロです。
; (interleave '(1 2 3) "a") => (1 "a" 2 "a" 3 "a") (defun import-ps-funcs (ps-lst ps-body) (apply #'concatenate 'string (append (interleave (mapcar (lambda (elem) (funcall elem)) ps-lst) " ") (list ps-body)))) (defmacro with-use-ps-pack (pack-sym-lst &body body) (with-gensyms (pack-lst func-lst) `(let* ((,pack-lst (if (equal (symbol-name (car ',pack-sym-lst)) "ALL") (hash-table-keys *ps-func-store*) (mapcar (lambda (sym) (let ((name (symbol-name sym))) (if (equal name "THIS") ,*package* (aif (find-package name) it (error "There is no package named \"~A\"." name))))) ',pack-sym-lst))) (,func-lst (flatten (mapcar (lambda (pack) (reverse (gethash pack *ps-func-store*))) ,pack-lst)))) (import-ps-funcs ,func-lst (ps ,@(replace-dot-in-tree body))))))
次のようにパッケージのリストを指定すると、指定されたパッケージ内の関数を全て吐き出します。なお、特殊なキーワードとして:thisと:allを用意していて、:thisは自パッケージを指し示し、:allは*ps-func-store*で管理している全パッケージを指します。
=> function f1(a, b) { return a + b; }; function f2(b) { return f1(10, b); }; function f3(a, b) { return a - b; }; function f4(b) { return f2(200, b); }; f1(a, b);
なお、全容は以下のps-experimetプロジェクトにあります。今回のfunction周りのコードはsrc/utils-func.lispです。結構いじりそうなので、一応タグとしてblog-play-ps-4をつけました。
できていないもの
依存性の登録・管理
依存性を登録しておくと、with-use-ps-packで一々指定しなくても依存するパッケージを自動で指定してくれるような機能です。複数プロジェクトをまたいでの利用を考えると、サブパッケージまで全部指定させるのは現実的ではないため、早めに作っておきたい機能です。
defvarなどもこの機能上に乗せる
JavaScriptに出力するグローバルな構造は一通りこの線上に乗せる必要があります。defvarはこの一例です。defstructはParenscriptに機能自体がないですが、簡易なサブセットぐらいは作って乗せたいです。なお、マクロ定義はJavaScriptとしては見えないので、現状通り別口 (Parenscriptのまま) で問題ありません。
名前空間の分割
PS関数をパッケージごとに管理はしているのですが、今のところJavaScript側にはパッケージ名なしの関数名しか出力しません*2。Parenscriptもパッケージシステムを再現しようとしているため乗っかろうとしたのですが、use-pacakgeやin-packageが望むものでなかった*3ため、とりあえず断念しました。自力で作成するには「Let Over Lambdaのnlet-tailがよく分からなかったのでメモ - eshamster’s diary」でも触れたコードウォークの問題があるため簡単ではなさそうです。必要なら取り組みたいですが、まずはこのままでも割りと実用にはなるかなと。
- 前の記事：「Parenscriptで少し遊んで見る （3）キャメルケース編 - eshamster’s diary」
- 次の記事：「Parenscriptで少し遊んで見る （5）defstruct編 - eshamster’s diary」
Parenscript関連記事
Parenscriptで少し遊んで見る （3）キャメルケース編
リードマクロによるキャメルケース
今更ですが、Parenscriptでは大文字を表現するために、文字の直前にハイフンを置きます。
CL-USER> (ps (@ document get-element-by-id)) "document.getElementById;"
Common Lispでは通常シンボル名は大文字として解釈される（|Test|のようにすると大文字・小文字を区別可）ための処置で、上記の通り大抵は妥当な見た目になります。
ただ、WebGLでも触ってみようかと、その上に構築されたライブラリであるthree.jsのサンプルをParenscriptに置き換えていたのですが…、「THREE.WebGLRenderer」なるクラス名が出てきました。何かの嫌がらせかと思いましたが、そのまま書き下すと「(@ -t-h-r-e-e -web-g-l-renderer)」とさえないことになります（どちらかと言うと読むより書くのが辛い）。
THREE配下のクラスは他にもあるため、まずは下のようなマクロを書いて「(three -web-g-l-renderer)」のように凌ぎました。
(defmacro+ps three (&rest rest) `(@ -t-h-r-e-e ,@rest))
が、どうせなら局所的にキャメルケース（ないしは大文字小文字の区別）を許せないかと考えてみました。シンボル名を大文字として解釈するデフォルトリーダの動作を乗っ取る必要があるので、ここはリーダマクロの出番です。ということで、次のようにして「#j.TEST.WebGLRenderer#」という記述を可能にしてみます。
(eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\j (lambda (stream &rest rest) (declare (ignore rest)) (let ((char (read-char stream))) (when (or (null char) (not (char= char #\.))) (error "\".\" is required in the next of \"#j\""))) (let (chars) (do ((char (read-char stream) (read-char stream))) ((char= char #\#)) (if (upper-case-p char) (progn (push #\- chars) (push char chars)) (push (char-upcase char) chars))) (intern (coerce (nreverse chars) 'string))))))
readを使っても大文字になったシンボルが返ってくるだけなので、read-charで一文字ずつ取り出して、大文字の場合は直前にハイフンを入れつつcharsにpushしていきます。これで、「#j.TEST.WebGLRenderer#」は「-t-h-r-e-e.-web-g-l-renderer」に変換され、さらに前回の"ps."マクロ内でこれを使うことで無事「(@ -t-h-r-e-e -web-g-l-renderer)」が得られます。
なお、キーワードに選んだ"j"はjavascriptの"j"です。また、最初は「#jTEST.WebGLRenderer#」（"j"の後の"."なし）としても、大抵は次が大文字なので大丈夫じゃないか…と思ったのですが、意外と見にくかったので"."を必須としました。
試しに書いてみる
ここまでの3回で書いたマクロを使ってサンプルを書いてみます。なお、defun.psは第一回のdefun+psに第二回相当のドット記法を追加したものです。
対象とするのは「初心者でも絶対わかる、WebGLプログラミング＜three.js最初の一歩＞ | HTML5Experts.jp」で紹介されているthree.jsのサンプル＋αです。まず直接書いたものが以下です。
(defun.ps rotate-mesh (mesh) (with-slots ((rot rotation) (pos position)) mesh (rot.set 0 (+ rot.y 0.01) (+ rot.z 0.01)) (if is-keydown (pos.set 0 0 0) (pos.set (+ pos.x 0.05) (+ pos.y 0.05) 0)))) (defun.ps main () (let* ((scene (new (#j.THREE.Scene#))) (width 600) (height 400) (fov 60) (aspect (/ width height)) (near 1) (far 1000) (camera (new (#j.THREE.PerspectiveCamera# fov aspect near far))) (renderer (new #j.THREE.WebGLRenderer#))) (camera.position.set 0 0 50) (renderer.set-size width height) (document.body.append-child renderer.dom-element) (let ((light (new (#j.THREE.DirectionalLight# 0xffffff)))) (light.position.set 0 0.7 0.7) (scene.add light)) (let* ((geometry (new (#j.THREE.CubeGeometry# 30 30 30))) (material (new (#j.THREE.MeshPhongMaterial# (create :color 0xff0000)))) (mesh (new (#j.THREE.Mesh# geometry material)))) (scene.add mesh) (labels ((render-loop () (request-animation-frame render-loop) (rotate-mesh mesh) (renderer.render scene camera))) (render-loop)))))
defun.psをそれぞれexpandして、ほぼ素のps相当であるdefun+psにしてみると、以下のようになります（見栄えを揃えるためにmacroexpandの結果を整形しています）。
(defun+ps rotate-mesh (mesh) (with-slots ((rot rotation) (pos position)) mesh ((@ rot set) 0 (+ (@ rot y) 0.01) (+ (@ rot z) 0.01)) (if is-keydown ((@ pos set) 0 0 0) ((@ pos set) (+ (@ pos x) 0.05) (+ (@ pos y) 0.05) 0)))) (defun+ps main () (let* ((scene (new ((@ -t-h-r-e-e -scene)))) (width 600) (height 400) (fov 60) (aspect (/ width height)) (near 1) (far 1000) (camera (new ((@ -t-h-r-e-e -perspective-camera) fov aspect near far))) (renderer (new (@ -t-h-r-e-e -web-g-l-renderer)))) ((@ camera position set) 0 0 50) ((@ renderer set-size) width height) ((@ document body append-child) (@ renderer dom-element)) (let ((light (new ((@ -t-h-r-e-e -directional-light) 0xffffff)))) ((@ light position set) 0 0.7 0.7) ((@ scene add) light)) (let* ((geometry (new ((@ -t-h-r-e-e -cube-geometry) 30 30 30))) (material (new ((@ -t-h-r-e-e -mesh-phong-material) (create :color 0xff0000)))) (mesh (new ((@ -t-h-r-e-e -mesh) geometry material)))) ((@ scene add) mesh) (labels ((render-loop () (request-animation-frame render-loop) (rotate-mesh mesh) ((@ renderer render) scene camera))) (render-loop)))))
コードを劇的に短くするような改良ではないので微妙な差かもしれません。書いている分にはだいぶ書きやすいのですが。ただ、rotate-mesh関数については"@"が見た目の上でも非常に鬱陶しく、中身がすっと頭に入ってこないと感じますがどうでしょうか。
最後に、これを以下のような関数でjavascriptに出力します。なお、js-main内で使っているwith-use-ps-packは、第一回のwith-import-ps-defの改良（と信じている）版です。この辺りの話はまた次回に。
(defun js-main () (with-use-ps-pack (this) (defvar is-keydown false) (window.add-event-listener "keydown" (lambda (e) (setf is-keydown true))) (window.add-event-listener "keyup" (lambda (e) (setf is-keydown false))) (window.add-event-listener "DOMContentLoaded" main false)))
結果は以下のとおりです。
function rotateMesh(mesh) { mesh.rotation.set(0, mesh.rotation.y + 0.01, mesh.rotation.z + 0.01); return isKeydown ? mesh.position.set(0, 0, 0) : mesh.position.set(mesh.position.x + 0.05, mesh.position.y + 0.05, 0); }; function main() { var scene = new THREE.Scene(); var width = 600; var height = 400; var fov = 60; var aspect = width / height; var near = 1; var far = 1000; var camera = new THREE.PerspectiveCamera(fov, aspect, near, far); var renderer = new THREE.WebGLRenderer; camera.position.set(0, 0, 50); renderer.setSize(width, height); document.body.appendChild(renderer.domElement); var light = new THREE.DirectionalLight(0xffffff); light.position.set(0, 0.7, 0.7); scene.add(light); var geometry = new THREE.CubeGeometry(30, 30, 30); var material = new THREE.MeshPhongMaterial({ 'color' : 0xff0000 }); var mesh = new THREE.Mesh(geometry, material); scene.add(mesh); var renderLoop = function () { requestAnimationFrame(renderLoop); rotateMesh(mesh); return renderer.render(scene, camera); }; return renderLoop(); }; var isKeydown = false; window.addEventListener('keydown', function (e) { return isKeydown = true; }); window.addEventListener('keyup', function (e) { return isKeydown = false; }); window.addEventListener('DOMContentLoaded', main, false);
今回はほぼ1対1対応なので、JavaScriptに対する優位性は余りないかと思います。ただし、今回の範囲でもParenscriptのデフォルトマクロであるwith-slots（rotate-mesh関数内）は優位性を主張できる部分かと思います。同様にマクロを利用することで記述量を大幅に減らせる可能性があるというのがParenscriptの優位性と言えるでしょうか。
Lispそのものと同じで、本当にそうなのかは実際にもっと書いてみないと分からなさそうですが。
動作可能なサンプル
一応動作可能なサンプル（caveman2上で構築）は以下です。試す人もいないと思うのでおざなり解説ですが、quicklisp管理下にclone（submoduleのinit, updateも必要）後、(ql:quickload :caveman-sample)をし、(caveman-sample:start :port 8080)のようにすれば指定のポートで動作します。念のため、今回の記事時点でつけたタグは"blog-play-ps-3"です。
- 前の記事：「Parenscriptで少し遊んで見る （2）ドット記法編 - eshamster’s diary」
- 次の記事：「Parenscriptで少し遊んで見る （4）続・defun編 - eshamster’s diary」
Parenscript関連記事
Lisp-Parenscript カテゴリーの記事一覧 - eshamster’s diary
Parenscriptで少し遊んで見る （2）ドット記法編
@マクロが長い
Parenscriptを書いていると真っ先に気になってくるのが@マクロです。下記の最初の例のように一つ程度ではそうでもないですが、いくつか並ぶと主張が激しく気になってきます。newに至っては単体でもだいぶ見づらいです。
CL-USER> (import 'ps:@) T CL-USER> (ps:ps (setf (@ $scope -test) 20)) "$scope.Test = 20;" CL-USER> (ps:ps (ps:new ((@ test create) 10))) "new test.create(10);"
試しにドット記法で書いてみると一応動きますが警告が出ます*1。
CL-USER> (ps:ps (setf $scope.-test 20)) ; Warning: Symbol $SCOPE.-TEST contains one of '.[]' - this compound naming convention is no longer supported by Parenscript! "$scope.Test = 20;"
また、実際に問題になるのは他の機能と連携が取れないという部分で、例えばwith-slotsによるシンボル置き換えに反応してくれません。
; 警告とダブルクォーテーションの出力を省略 CL-USER> (ps:ps (with-slots (-test) $scope (setf (@ -test a1) 20) (setf -test.a2 20))) $scope.Test.a1 = 20; Test.a2 = 20;
力業でドット記法に対応する
要はドットがあったら「test.abc.def → (@ test abc def)」のように変換すればいいわけですよね、ということで、コードツリーを全走査して見つけたドット記法を片っ端から置き換えるps.マクロを作るという力業に出てみます。
(ql:quickload :parenscript) (ql:quickload :cl-ppcre) (defun replace-dot-sep (elem) (if (and (symbolp elem) (not (null (symbol-package elem)))) ; gensym case (let ((name (symbol-name elem)) (pack-name (package-name (symbol-package elem)))) (cond ((and (> (length name) 1) (string= name "!!" :start1 0 :end1 2)) (intern (subseq name 2) pack-name)) ((ppcre:scan "\\." name) `(ps:@ ,@(mapcar (lambda (x) (intern x pack-name)) (ppcre:split "\\." name)))) (t elem))) elem)) (defun replace-dot-in-tree (tree) (labels ((rec (rest) (let (result) (when rest (dolist (elem rest) (push (if (listp elem) (rec elem) (replace-dot-sep elem)) result))) (nreverse result)))) (rec tree))) (defmacro ps. (&body body) `(ps:ps ,@(replace-dot-in-tree body)))
2015/11/13追記: gensymで作られたシンボルのように、パッケージにinternされていないシンボルを渡された場合、(symbol-package elem)がNILとなってsymbol-name関数でエラーとなることがあったため、replace-dot-sep関数にNILチェックを追加しました。
シンボル名の頭に"!!"があるときは変換しないという逃げ道もつけてみました*2。余計かもしれません。試し打ちしてみます。
(ps. (setf $scope.abc.def 123) (with-slots (abc) $scope (setf abc.def 123) (setf !!abc.def 123))))
=> $scope.abc.def = 123; $scope.abc.def = 123; abc.def = 123;
ps.マクロの展開結果も見てみます。
(PARENSCRIPT:PS (SETF (@ $SCOPE ABC DEF) 123) (WITH-SLOTS (ABC) $SCOPE (SETF (@ ABC DEF) 123) (SETF ABC.DEF 123)))
いい感じですが、まだ問題があります。defmacro+psで定義したマクロなど、ps.マクロの外で作ったものを持ち込むと反応できません。
(ps:defmacro+ps test-mac (a) `(ps:with-slots (abc) ,a (ps:setf abc.value 100))) (print (ps. (test-mac $scope)))
=> abc.value = 100;
ps.マクロ側ではいかんともしがたいので、defmacro+ps側をラップしてdefmacro.psマクロを作成します。
(defmacro defmacro.ps (name args &body body) `(ps:defmacro+ps ,name ,args ,@(replace-dot-in-tree body))) (defmacro.ps test-mac (a) `(ps:with-slots (abc) ,a (ps:setf abc.value 100))) (print (ps. (test-mac $scope)))
=> $scopeabc.value = 100;
まだ抜けがあるかもしれませんが、その都度defmacro.psのように3行程度書けば対応可能なはずです。
ひとまとめ。
=> $scope.abc.def = 123; $scope.abc.def = 123; abc.def = 123; $scope.abc.value = 100;
別解（リンク）
もっときれいに、しかもCommon Lispのパッケージシステムの中に取り込む形で解決しているのが「http://e-arrows.sakura.ne.jp/2011/01/cl-wrapper-for-google-closure.html」です。
- 前の記事：「Parenscriptで遊んで見る (1) defun編 - eshamster’s diary」
- 次の記事：「Parenscriptで少し遊んで見る （3）キャメルケース編 - eshamster’s diary」
Parenscript関連記事
Lisp-Parenscript カテゴリーの記事一覧 - eshamster’s diary
Parenscriptで遊んで見る (1) defun編
TypeScriptやCoffeeScriptといったJavaScriptを吐き出す言語の名前をしばしば聞きます（まだ使ったことはないです…。）が、Common LispにはParenscriptというものがあります。少しいじってみていたのですが、defun周りが気になったので少し遊んでみたという記事です。
次のように、ps環境下でdefunすると、javascriptの関数定義が出力されます。
(defun test-ps () (ps:ps (defun f1 (a b) (+ a b)) (f1 10 20))) (print (test-ps))
=> function f1(a, b) { return a + b; }; f1(10, 20);
ネストした環境下でdefunを書くというのもなんか気持ち悪いので…、外に出してみます。
; NG (defun f1 (a b) (+ a b)) (defun test-ps () (ps:ps (f1 10 20))) (print (test-ps))
=> f1(10, 20);
ダメでした。次、psマクロは結局のところ文字列を出力しているのでconcatenateしてみます。見栄えのため改行を補っています。
(defun f1_ () (ps:ps (defun f1 (a b) (+ a b)))) (defun test-ps () (concatenate 'string (f1_) " " (ps:ps (f1 10 20)))) (print (test-ps))
=> function f1(a, b) { return a + b; }; f1(10, 20);
出力は合いました。パターンが見えてきたらマクロ化するに限ります*1（defun+ps）。
(defun intern-ub (sym) (intern (format nil "~A_" (symbol-name sym)))) (defmacro defun+ps (name args &body body) (let ((name_ (intern-ub name))) `(defun ,name_ () (ps:ps (defun ,name ,args ,@body))))) (defun+ps f1 (a b) (+ a b)) (defun+ps f2 (a) (+ a (f1 a 20)))
それっぽくなってきました。
defunをもう一つ並べて同名のLisp関数も定義したら便利かもしれない、とおせっかいなことも考えました*2が、body部が必ずしもLisp環境でコンパイルできるわけではないはずなのでやめました。別名で提供するのはありかもしれません。
今度は一々concatenateするのが面倒なのでマクロ化します（with-import-ps-def）。
; (interleave '(1 2 3) "a") => (1 "a" 2 "a" 3 "a") (defun interleave (lst delim) (labels ((rec (result rest) (if (null rest) result (rec (append result (list (car rest) delim)) (cdr rest))))) (rec nil lst))) (defmacro with-import-ps-def (ps-lst &body body) `(concatenate 'string ,@(interleave (mapcar (lambda (elem) (list (intern-ub elem))) ps-lst) " ") (ps:ps ,@body))) (defun test-ps () (with-import-ps-def (f1 f2) (f1 10 20)))
=> function f1(a, b) { return a + b; }; function f2(a) { return a + f1(a, 20); }; f1(10, 20);
関数名を二度（定義とimport）書く必要があるのはいまいちですね…。これを減らそうとするとグローバルに環境を作っていかないとできなさそうです。さらに、JavaScript側での二重定義をどう避けるかと考えるとそう簡単ではないように思います。Parenscriptでマクロを定義するためのdefmacro+psが用意されている一方で、defun+psがないのはこういった辺り*3が原因なのかと思う次第です。
切れ切れになってしまったので、最後に動作するroswellスクリプトを。やめましたと言いつつ、おせっかい版のdefun+psです。main関数内でLisp関数としてf2を使ってみています。
続く？
マクロって楽しいですね Parenscriptいいですね。ドキュメントを見ると、ちょっと変換してみました、ではなくて本気でLispの世界を持ち込もうという意気込みが伝わってきます。とはいえ、Parenscriptを触っていると不満に思うところもあるので、その辺りをいじくり回した結果がいくつか記事になりそうです。
Parenscript関連記事
Lisp-Parenscript カテゴリーの記事一覧 - eshamster’s diary
Common Lispでナイーブベイズをナイーブに実装
精度を問わず簡単に使える分類器が欲しかったので、Common Lispでナイーブベイズ分類器cl-naive-bayesを作りました。
使い方は簡単です。まずは学習。学習結果を保持するlearned-storeを用意した後は、learn-a-document関数にこのstore，ドキュメント = 単語のリスト*1，カテゴリ（スパムメール判定であれば「スパム」or「非スパム」）の3つを渡すだけです。
(defparameter *store* (nbayes:make-learned-store)) ; (カテゴリ 単語のリスト) (defparameter *documents* (list '("A" ("a1" "a2" "a3" "a4" "ab")) '("A" ("a3" "a4" "a5" "a6")) '("B" ("b1" "b2" "b3" "b4" "ab")) '("C" ("c1" "c2" "c3")))) (dolist (doc *documents*) (nbayes:learn-a-document *store* (cadr doc) (car doc)))
次に分類ですが、学習したstoreと単語のリスト（ドキュメント）をsort-category-by-prob関数に渡すだけです。以下のように事後確率の高い順にソートして出力してくれます。事後確率も同時に取得したい場合は、sort-category-with-post-probを使います。
(nbayes:sort-category-by-prob *store* '("a1" "ab" "c1" "new")) => ("A" "C" "B") (nbayes:sort-category-with-post-prob *store* '("a1" "ab" "c1" "new")) => (("A" . 0.4211471) ("C" . 0.3527683) ("B" . 0.22608456))
解説の方針
ナイーブベイズ分類器自体についてはすでに良い解説があるので参考にしたリンクを張るにとどめ、作るには結局どうすんのさというところだけ書きます。ということでまずはリンクを。
- 解説とPythonによる実装例：ナイーブベイズを用いたテキスト分類 - 人工知能に関する断創録
- ベイズ確率自体などもう少し基礎的な話も：[WIP]単純ベイズ分類器がまったく単純じゃないので入門 | moxt
データ構造
上で紹介したサイトは、アルゴリズムの解説は大変分かりやすいのですが、データ構造に関わる情報が分散していて分かりづらかったように記憶しています。ということで、アルゴリズムの解説は置いてデータ構造だけ説明しようと思います。データ構造が分かればできたようなものだという人もいるのできっと問題ないでしょう。
学習データとテストデータ
まず学習や分類（テスト）の一単位はドキュメントです。例えば、スパムメール分類であれば一つのメールが一つのドキュメントにあたります。ナイーブベイズ分類器がこのドキュメントをどう認識するかというと、単なる単語の羅列として認識します。これがナイーブたる所以で、文脈やら順序やら何もかも無視して、誰かがドキュメントを単語の羅列に分解したものを受け取ります。
また、学習データとテストデータの差は、前者が教師情報にあたるカテゴリ（文字列）を持っているという部分だけです。
学習用のlearn-a-document関数と、分類用のsort-category-by-prob関数のシグネチャを見るとおおむね了解できると思います。storeは次に述べる学習データを保持している構造体です。
; シグネチャのみ ; 例：word-lst: '("I" "am" "a" "pen"), category: "spam" (defun learn-a-document (store word-lst category)) (defun sort-category-by-prob (store word-lst))
学習結果の保持
導出は上記のリンクを参照して欲しい*2のですが、データ構造を決める上で必要な式だけ取り出します。
簡単に説明します。doc, catと並ぶとdogとcatに見えて仕方ないのですが、documentとcategoryです。第1式の事後確率P(cat|doc)が求めたいものです。値が大きいほど与えられたドキュメント（例．メール）がそのカテゴリ（例．スパム or スパムじゃない）に属する確率が高いということで、これを全カテゴリについて計算して比較します。計算方法が右辺になりますが、カテゴリ分けのためには大小関係だけ分かればよいので、カテゴリに依存しないP(doc)は除いて事前確率P(cat)と尤度P(doc|cat)だけを計算します。
第2式の事前確率P(cat)は見たままですが、分子・分母に「学習における」と接頭辞をつけるとより分かりやすいでしょうか。第3式の尤度P(doc|cat)を求めるためには、見ての通りとにかくカテゴリにおける各単語の登場数さえ覚えておけばよいことが分かります。なお、の各要素は非常に小さい値になる場合が多いため、logをとって足し算として計算するのが普通のようです。cl-naive-bayesでも踏襲しています。
(defstruct learned-store (category-data-hash (make-hash-table :test #'equal)) (num-document 0) (num-word-kind 0)) (defstruct category-data (count 0) (sum-word-count 0) (word-count (make-hash-table :test #'equal)))
ということでこのようになりました。全体として必要なデータ（learned-store）は学習したドキュメントの総数（num-document）とカテゴリごとのデータ（category-data-hash）になります。カテゴリごとに持っておくデータ（category-data）は学習した回数（count）と各単語の出現回数（word-count）です。
今記述しなかった二つのデータはキャッシュ（計算で求められるデータ）で、learned-storeのnum-word-kindは学習した単語の種類数であり、category-dataのsum-word-countはカテゴリ内での全単語の登場数の和です。後者はともかく前者は上記の式にも出ていませんが、ラプラス・スムージング（Laplace Smoothing）に利用します。この目的は、そのカテゴリで未知の単語が出てきたときにP(doc|cat)が0になることを避けることです。偉そうな名前がついていますが、単に初めての単語も1回出たものとして計算するという代物です。同様にn回出た単語はn+1回出たと考えるので、第3式の分子には1を足します。これを学習した全種類の単語で行うため、分母には単語の種類数を足します。ここで足す値がnum-word-kindです。
ここまで分かればアルゴリズムはほぼ自明だと思います。学習ではカテゴリと単語リストの組を受け取って、learned-storeの適切なスロットをカウントアップします。実際の分類では、上記の式に従ってP(cat|doc)の大小関係を計算するだけです。注意が必要なのは、計算過程ではlogをとるということと、ラプラス・スムージングぐらいです。
ソース全体は以下の通りです。ハッシュ内にデータがあるかないかで処理が変わる部分が多いため、anaphoraが大活躍しています。
cl-naive-bayes/cl-naive-bayes.lisp at master · eshamster/cl-naive-bayes · GitHub
cl-naive-bayesの実装上の工夫
特にないです…も悲しいので小さいものを二つ。
事後確率の求め方
一般的なナイーブベイズ実装にならい、事後確率の分母を無視して分子の（logの）大小比較のみでソートをしています。上記リンク先のPython実装では疑似的に事後確率を求める方法として、logで分子を求めた後にそれぞれexpをとった和で割って正規化するという方法が紹介されています。が、expに渡す値が-1000などという値になっていると、0しか返って来ないため計算できません。下記使用例のスパム判定のように超ナイーブな使い方をするとこういう値が普通に出てきます。ということで計算上の簡単な工夫ですが、(log a, log b, log c)の状態からいきなりexpをとるのではなく、全体からlog aを引いて(log 1, log b/a, log c/a)としてからexpをとっています。
incf-plus
学習用の関数learn-a-documentで使っています。適当に命名したので何も伝わらないと思いますが、引数なしincfの拡張版で、数値に対してはincfと同じく（破壊的に）1を足す一方で、nilの場合はエラーとせず1を代入する点が異なります。目的は下記のように何度もgethashを使うのを避けることです。
; これを… (if (gethash word (category-data-word-count it)) (incf (gethash word (category-data-word-count it))) (setf (gethash word (category-data-word-count it)))) ; こうしたい (incf-plus (gethash word (category-data-word-count it)))
実装はOn Lispの汎変数の章を参考に、define-modify-macroを使いました。
なお、元々はanaphoraのsif（aifと異なり代入可能なitが提供される）を使おうとしていましたが、上記例の通りすでにit（anaphoraのsletによる）を使っているため、意図通りに動きませんでした。
試しに使ってみる
バグチェックも兼ねてスパム判定を試してみようとroswellスクリプトを起こしました（データを用意する部分はshellスクリプトに逃げました）。
cl-naive-bayes/judge-spam.ros at master · eshamster/cl-naive-bayes · GitHub
英文のスパムメール判別コーパス（http://spamassassin.apache.org/publiccorpus/）の2002年版easy_hamとspamを使います。メール本文をいかにして単語のリストに変換するかが腕の見せどころ…のはずですが、tokenize-mail関数ではヘッダのタグも何もかも空白・改行区切りでリストにして分類器にぶち込むゴミ実装になっています（例えば、"From:"なんかは全部のメールに出そうです…）。さすがにこれだと60～70%ぐらいで頭打ちになりそうなので、簡単なヘッダ解析とか品詞分類ぐらいはしないと…と思って事前に調べていたのですが、意外と95%ぐらいまで正解していたので満足してしまった次第です*3。ナイーブベイズ恐るべし。
一応グラフを。テストデータを後ろから3割で固定し、学習データを前からX割で変化させた場合の正解率（5%信頼区間つき）です*4。全データ数は、非スパムが2546, スパムが497です。
- メモ
できていないもの
- ダンプやリストア
- 実運用を考えると、DBに保管したりそこから復元したりという機能は必須でしょう。
- 全ダンプだけでなくて、DB更新用にlearn-a-documentに更新差分を吐かせるようなオプションも必要でしょうね。実装面倒そうですが…。
- 解析用の機能
- カテゴリごとの事後確率の高い単語ランキングなんて面白そうです。
- チューニング用の機能
- ポール・グレアムの「ベイジアンフィルタの改善 --- Better Bayesian Filtering」を見ると様々な工夫をして性能を上げていますが、そういった柔軟性をどこまで持たせるのかという部分です。
- 今のところそんなにガチガチの用途を考えていないのでやる気低です。
