Parenscriptで少し遊んで見る （3）キャメルケース編

Lisp JavaScript プログラミング Lisp-Parenscript

リードマクロによるキャメルケース

今更ですが、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"です。

github.com

Parenscript関連記事

Lisp-Parenscript カテゴリーの記事一覧 - eshamster’s diary

Parenscriptで少し遊んで見る （2）ドット記法編

JavaScript Lisp プログラミング Lisp-Parenscript

@マクロが長い

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関連記事

Lisp-Parenscript カテゴリーの記事一覧 - eshamster’s diary

*1:出ないパターンもあるので直接ドット記法に対するエラーではないようですが。いまいち警告文の意味するところが分かっていないです。

*2:最初は"!"と1文字でしたが、"!="が"="になるという事象が起きたので2文字にしました（"!!="とは書けます）。"!="自体はdeprecatedなので使うべきではないですが。

Parenscriptで遊んで見る (1) defun編

JavaScript Lisp プログラミング Lisp-Parenscript

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

*1:まだまだLisp初心者なので、痛い目見るまではマクロ書きまくるスタンスで突っ走る所存です

*2:外側でdefunする関数名の後ろにアンダーバーを付けているのはこの名残です。実際には同名でも構いません。

*3:グローバルな環境が必要という部分は同じで実際そうなっています。defun+psよりも簡単なのは、マクロによる変換処理はLispの世界で完結するため、JavaScript側へ定義を反映させる必要がないという部分です。

Common Lispでナイーブベイズをナイーブに実装

プログラミング Lisp 機械学習

精度を問わず簡単に使える分類器が欲しかったので、Common Lispでナイーブベイズ分類器cl-naive-bayesを作りました。

github.com

使い方は簡単です。まずは学習。学習結果を保持する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))

解説の方針

ナイーブベイズ分類器自体についてはすでに良い解説があるので参考にしたリンクを張るにとどめ、作るには結局どうすんのさというところだけ書きます。ということでまずはリンクを。

データ構造

上で紹介したサイトは、アルゴリズムの解説は大変分かりやすいのですが、データ構造に関わる情報が分散していて分かりづらかったように記憶しています。ということで、アルゴリズムの解説は置いてデータ構造だけ説明しようと思います。データ構造が分かればできたようなものだという人もいるのできっと問題ないでしょう。

学習データとテストデータ

まず学習や分類（テスト）の一単位はドキュメントです。例えば、スパムメール分類であれば一つのメールが一つのドキュメントにあたります。ナイーブベイズ分類器がこのドキュメントをどう認識するかというと、単なる単語の羅列として認識します。これがナイーブたる所以で、文脈やら順序やら何もかも無視して、誰かがドキュメントを単語の羅列に分解したものを受け取ります。

また、学習データとテストデータの差は、前者が教師情報にあたるカテゴリ（文字列）を持っているという部分だけです。

学習用の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のですが、データ構造を決める上で必要な式だけ取り出します。

{ \displaystyle \begin{array}{l} P(cat|doc) = \frac{P(cat)P(doc|cat)}{P(doc)} \propto P(cat)P(doc|cat)\\ P(cat) = \frac{カテゴリの登場数}{ドキュメント数}\\ P(doc|cat) = \prod_{i} P(word_{i}|cat) = \prod_{i} \frac{カテゴリにおけるword_{i}の登場数}{カテゴリにおける全単語の登場数の和} \end{array} }

簡単に説明します。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)を求めるためには、見ての通りとにかくカテゴリにおける各単語の登場数さえ覚えておけばよいことが分かります。なお、\prod_{i}の各要素は非常に小さい値になる場合が多いため、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です。

f:id:eshamster:20151018145427p:plain

  • メモ
    • 日本語の形態素解析ではMeCabの名前を知っていたのですが、英語だと何があるのかと調べたところCommon Lispではg000001さんの公開されているtaggerが簡単に使えそうでした
    • コーパスの文字コードがそろっていなかったので、とりあえず"nkf --overwrite -w"しているのですが、変換元を指定しないためか不可思議な動きが見られました
      • 一回でUTF-8 or ASCIIにならないものがいくつかあったので見てみたのですが、変換を繰り返すと以下のような動きをするものが見つかりました。なんだこれ。
      • 今のところ、収束性に不安があるので1回目の変換でUTF-8 or ASCIIにならなかったものは一律削除しています。

できていないもの

  • ダンプやリストア
    • 実運用を考えると、DBに保管したりそこから復元したりという機能は必須でしょう。
    • 全ダンプだけでなくて、DB更新用にlearn-a-documentに更新差分を吐かせるようなオプションも必要でしょうね。実装面倒そうですが…。
  • 解析用の機能
    • カテゴリごとの事後確率の高い単語ランキングなんて面白そうです。
  • チューニング用の機能

*1:ここがイコールになるところがナイーブベイズの仮定です

*2:特に3つ目の式の最初の等号は、ナイーブベイズにおける単語の独立性の仮定があって初めて成り立つ式なので注意が必要です

*3:もちろん実用としては全く話になりませんが、まあテストとしては…

*4:judge-spam.rosの引数ですが、例えば"./judge-spam.ros 0.2 0.3"とすると、学習データを前から2割、テストデータを後ろから3割という意味になります

Let Over Lambdaのnlet-tailがよく分からなかったのでメモ

在庫切れになっていたLet Over Lambdaの訳本にオンデマンド版なるものが出ていることに気付いたので買って読んでいます。

LET OVER LAMBDA―Edition 1.0

LET OVER LAMBDA―Edition 1.0

  • 作者: ダグホイト,Doug Hoyte,タイムインターメディアHOPプロジェクト
  • 出版社/メーカー: エスアイビーアクセス
  • 発売日: 2014/12/22
  • メディア: 単行本
  • この商品を含むブログを見る

電車で少しずつ読んでいますが、「4.4 macroletを使ったコードウォーク」に出てくるnlet-tailマクロがよく分からなかったので展開してみたメモです。なお、quicklispには同書で書かれたユーティリティ一式を備えた"let-over-lambda"が登録されているので、(ql:quicklisp :let-over-lambda)とすればすぐに試せます。

まずこの4.4節の目的は、マクロで受け取ったリスト内のシンボルをどう置き換えるかというところにあります。そんなもの、ちょっと再帰でネストしたリストを手繰ってシンボルを探すとか、sublis関数を使うとかで簡単にできるでしょ…と思えるのですが、例えばクォートされたシンボルを置き換えるのはまずいですし、letの左辺（？）を置き換えるのもまずいです。仕様上同様の考慮が必要なスペシャルフォームは25個もあるので、とてもじゃないが自力で正しくなんてできない、というのが提起されている問題です。

そこで、macroletを使うことでそれ、すなわちコードウォークをさせればよい。その例として末尾再帰最適化を明示的に行うnletマクロ、名付けてnlet-tailマクロを作る、とのことですが…

(defmacro! nlet-tail (n letargs &body body)
  (let ((gs (loop for i in letargs
               collect (gensym))))
    `(macrolet
         ((,n ,gs
            `(progn
               (psetq
                ,@(apply #'nconc
                         (mapcar
                          #'list
                          ',(mapcar #'car letargs)
                          (list ,@gs))))
               (go ,',g!n))))
       (block ,g!b
         (let ,letargs
           (tagbody
              ,g!n (return-from
                    ,g!b (progn ,@body))))))))

…すいません、分かりません。とりあえず以下を知りたいところです。

  1. ナニコレ
  2. macroletでコードウォークするってつまりどういうこと？

ということで、電車で脳をスタックオーバーフローさせるのはやめて家で展開してみました。展開する対象は同書でも例として挙げられている階乗計算関数の定義です。

(defun nlet-tail-fact (n)
  (let-over-lambda:nlet-tail fact ((n n) (acc 1))
    (if (zerop n)
        acc
        (fact (1- n) (+ acc n)))))

定義部分のlet-over-lambda:nlet-tail以下を展開してみます。

; macroexpandしてみる
(LET ()
  (MACROLET ((FACT (#:G990 #:G991)
               `(PROGN
                 (PSETQ ,@(APPLY #'NCONC
                                 (MAPCAR #'LIST '(N ACC)
                                         (LIST #:G990 #:G991))))
                 (GO ,'#:N988))))
    (BLOCK #:B989
      (LET ((N N) (ACC 1))
        (TAGBODY
         #:N988
          (RETURN-FROM #:B989
            (PROGN
             (IF (ZEROP N)
                 ACC
                 (FACT (1- N) (+ ACC N))))))))))

; 見づらいのでgensymで生成されたオブジェクトをそれらしい名前で書き換える
(LET ()
  (MACROLET ((FACT (n-value acc-value)
               `(PROGN
                 (PSETQ ,@(APPLY #'NCONC
                                 (MAPCAR #'LIST '(N ACC)
                                         (LIST n-value acc-value))))
                 (GO ,'tag))))
    (BLOCK blk
      (LET ((N N) (ACC 1))
        (TAGBODY
         tag
          (RETURN-FROM blk
            (PROGN
             (IF (ZEROP N)
                 ACC
                 (FACT (1- N) (+ ACC N))))))))))

; 手で最終行のFACTを展開（macroletは省略）
(LET ()
  (BLOCK blk
    (LET ((N N) (ACC 1))
      (TAGBODY
       tag
       (RETURN-FROM blk
         (PROGN
           (IF (ZEROP N)
               ACC
               (PROGN (PSETQ N (1- N)
                             ACC (+ ACC N))
                      (GO tag)))))))))

こうして展開してみると、確かに末尾再帰呼び出しをループ（このとき、goで飛ぶ手前で引数に当たるn, accをpsetqで更新）に展開していることが見てとれます。デフォルトではreturn-fromで抜けるようにして、続けたい場合はgo（goto）でreturn-fromの手前まで投げ返すのですね。乱暴な感じもしますが、マクロで隠してしまえば表にはきれいな構造しか見えないのでありだということでしょうか。ちょっと思考の幅が広がる感じがします。…ということで知りたいこと1番目の「ナニコレ」は分かりました。

次はmacroletでコードウォークってどういうことかという部分です。展開してみるまで勘違いしていたのですが、ここでの目的は任意の位置にあるシンボルを置き換えることではなく、一見関数シンボルに見せているもの（上記ではfact）を別の処理で置き換えるということでした*1。関数の位置にあるシンボルを認識して別の処理に変換する、かつクォートされたリストの先頭などの置き換えは避ける…という動作を冷静に考えると、マクロ展開の動作そのものです。そんなわけで、別に独自のコードウォークなんて書かなくても、マクロを使えば目的は達成できますよという話のようです。ここでdefmacroではなく、macroletを使うのは単純に無用な名前衝突を避けるためですね。

まだ4章までしか読めていませんが、Let Over Lambdaは面白い本ですね。不満があればなんであれ自ら書き換えるのがLisperの性質だということは納得しつつあったので、全部が全部驚くわけではないのですが。特に興味をひかれているのは第1章終わりの下記の一文です。

値割り当て可能なセルと古き良きラムダ式があれば、オブジェクトシステムは、よく言っても有効なこともある抽象化の手段に過ぎず、悪くすると特殊な場合であり余計なのである。

信奉する気はなかったにせよ、短いプログラマ人生の中でオブジェクト指向が大きい位置を占める言語（特にC#）との付き合いは長かったので、その原始的なところには何があり、便利にする過程で何をそぎ落としてしまったのか、というところは多分に興味があります。この先まだまだその源流である"let over lambda"の威力を見せつけてくれるとのことなので大変楽しみです。

*1:そのつもりで手前の文章を読み直してみると実際そう書いてありますね…

引数文字列をinternするアナフォリックマクロでハマったこと

Lisp プログラミング

CSVファイルを処理するために、引数の文字列をシンボル化して（intern）束縛するアナフォリックなマクロを書いていてハマったことのメモ。シンボルとパッケージの関係は段々と分かってきたつもりでしたが、まだまだハマるときはハマりますね。

悪い例

例のための例ですが、まずパッケージAで目的のマクロwith-interned-strを定義します。すぐ下の使用例を見ると分かる通り、第一引数の文字列（"abc"）をinternしてできあがったシンボル（ABC）に、第二引数の値（100）を束縛し、body内では変数のように扱えるという代物です。

次に、パッケージBではwith-interned-strを利用するマクロsome-macro*1を定義します。実際に下でsome-macroを試してみると、意図通りシンボルDEFに値が束縛されており、渡した200という値が出力されます。

よしよしと思って今度はパッケージCからsome-macroを呼び出してみると、PACK-B::DEFが束縛されていないと怒られてエラーになります。with-interned-strの引数strはパッケージCのコンパイル時にinternされる一方で、some-macroの(print def)のdefはパッケージBのコンパイル時にinternされているためです。つまり、前者はPACK-C::DEF（束縛あり）、後者はPACK-B::DEF（束縛なし）と全く違うシンボルなのでエラーになったということでした。

なお、このテストコードは余りにも意味のない例ですが、実際にはCSVのヘッダ名を渡して同名のシンボルに値を束縛して…というマクロを書いていました。

割と大丈夫な例

パッケージ間で共通して使えるシンボルというとキーワード（:str もしくは (intern "str" "KEYWORD")）が思い当たるのですが、値を束縛できないので今回は使えません。とりあえず両者が同じパッケージでinternされていることを保証できればいいので、body内に同名のシンボルを見つけたらstrをinternしたもので全て置き換えるという力技で解決してみました。

sublis関数でsymをsymで置き換えるという一見怪しげなことをしていますが、test関数にパッケージを無視してシンボル名のみを比較するequal-nameを指定しているため、これで目的の動作が得られます。この手のtestキーワードを受け取る関数について深く考えたことがありませんでしたが、こう見ると応用範囲は結構広そうです。

大丈夫でない部分があるので「割と」とつけましたが、気付いた問題だけ書いていきます。明示的にパッケージを指定したシンボルまで置き換えてしまうので、わざわざパッケージ名をつけて書いたのに上書きされてしまうという、分かり辛いバグを仕込む可能性があります。そうそう困らなさそうですし、いい解決策がすぐに思いつかなかったので妥協していますが何かいい解決法はあるのでしょうか…。

また、デフォルトの関数名やマクロ名とかぶると（特に後者の一部は）回避手段がないのでは…と思ったのですが、名前空間が分かれている恩恵なのか下のようなコードも問題なく動きました（他にマクロ"loop"やスペシャルフォーム"let"も大丈夫でした）。まだ理解不足できちんと説明できないのですが、use, importしているものは問題なさそうです。

(with-interned-str "print" 100
  (print print))

原因不明でハマったこと（原因不明で直ったこと）

再現性はないですが、もともとハマったコードの方では実行後にSBCLの環境に何やらゴミが残ったらしく、リスタートしても該当のシンボル（上記の例でいえばPACK-B::DEF）がunboundだとエラーで怒られ続ける現象が起きました。上記のような解決方法が間違っていると思い試行錯誤していたので中々気付かなかったのですが、ちょうど気付いた辺りでなぜか直ったので結局なんだかよく分かりませんでした。

明示的に直すのであればunintenすれば良いのかもしれません。

*1:名前を考えるのが面倒になったわけではありますん

Common Lispで遅延評価を作って遊ぶ（4, 完）　－ 数列生成リードマクロ

今回の目的

第3回（その1、その2）では、作成した数列生成リードマクロでひとしきり遊んでみたわけですが、今回はそのリードマクロの話を書きます。なお、リードマクロそのものについて（浅く）理解した内容については別記事「リードマクロ入門、の10分の1歩ぐらい後か前 - eshamster’s diary」にまとめたので、この記事では淡々と書いていきます。

そろそろ遅延評価関係ないですが…。

eshamster/cl-lazy · GitHub

作成したリードマクロの目標

目標は次のような数学的な数式の定義に近づけることでした。例によって"amp;"は読み飛ばしてください。

{ \displaystyle a_{n}= \left \{ \begin{array}{l} 0 & n = 0 \\ 1 & n = 1 \\ a_{n-1} + a_{n-2} & n > 1 \end{array} \right. }

完成形はこんな感じです。

; 関数版でのフィボナッチ数列作成
CL-USER> (make-series '(0 1) (lambda (a n) (+ (lnth (- n 1) a)
                                              (lnth (- n 2) a))))

; 関数版にリードマクロを被せてみた版
CL-USER> #<a[n] = 0, 1, (+ a[n-1] a[n-2])>

はじめからこの形を目指していたわけではなく、次のようにいまいちな部分を順に直していったところこのようになりました。

; スタート
(make-series '(0 1) (lambda (a n) (+ (lnth (- n 1) a) (lnth (- n 2) a))))

; 実装（遅延評価, lnth）が見えてるのはいまいち
; ついでにaとnの順番も数式に合わせる
(make-series '(0 1) (lambda (a n) (+ #{a (- n 1)} #{a (- n 2)})))

; (- n 1)は空白が多くて書きづらい、見づらい
(make-series '(0 1) (lambda (a n) (+ #{a #[n-1]} #{a #[n-2]})))

; なんか#が多くて思ったほど映えない…
(make-series '(0 1) (lambda (a n) (+ #{a[n-1]} #{a[n-2]})))

; 左辺(a n)と右辺a[n-1]で形が違って気持ち悪い
; lambdaキーワードごと変換（※今は動かないコード）
(make-series '(0 1) #<a[n] = (+ #{a[n-1]} #{a[n-2]})>)

; 初期値の定義も入れてしまえばいいよね
; そうなるとmake-seriesもいらないか
#<a[n] = 0, 1, (+ #{a[n-1]} #{a[n-2]})>

; これはなかなｋ…いや、なんか思ったほどでも…
; あ、やっぱり#が多い
#<a[n] = 0, 1, (+ {a[n-1]} {a[n-2]})>

; 今度は{}がジャマな気がする…
; これだ（完成）
#<a[n] = 0, 1, (+ a[n-1] a[n-2])>

最後の足し算はS式がむきだしです。a[n-1] + a[n-2]の実現が単に面倒だったということもありますが、S式そのままの方が柔軟に使えるだろうという選択の結果でもあります。第3回で色々遊べたので間違った選択ではなかったように思います。

[]リードマクロ

まずは#[n-1]のような中置記法もどきを可能にしている部分ですが…下記の通り謝罪を要求されるレベルのひどい実装だったりします。こんなでも以前見たように意外と不自由なく遊べましたし、もっとまじめな中置記法の実装はすでに例がある（シンタックスが無ければ作ればいいじゃない[PDF]）のでここは頑張りどころではないか、と思ったので放置しています…。

(defun [-reader (stream &rest rest)
  (declare (ignore rest))
  (let ((lst nil)
        (*readtable* (copy-readtable *readtable*)))
    (set-separate-character #\-)
    (set-separate-character #\*)
    (set-separate-character #\+)
    (set-separate-character #\/)
    (set-macro-character #\] (get-macro-character #\)))
    (setf lst (read-delimited-list #\] stream t))
    (case (length lst)
      (1 (car lst))
      (3 (case (cadr lst)
           (#\- `(- ,(car lst) ,(caddr lst)))
           (#\+ `(+ ,(car lst) ,(caddr lst)))
           (#\/ `(/ ,(car lst) ,(caddr lst)))
           (#\* `(* ,(car lst) ,(caddr lst)))))
      (t (error 'simple-error)))))

(defun set-separate-character (char)
  (set-macro-character char
                       #'(lambda (s c)
                           (declare (ignore s c))
                           char)))

一応解説。#[n]のように要素が一つの場合は、read-delimited-listで(n)を受け取ってnを返します。

要素が三つの場合。まず、set-separate-character関数を使って、-, +, *, /は同名のcharを返すようになっています。例えば、#[n-1]の場合はread-delimited-listから(n #\- 1)というリストが返されます。真ん中の"#\-"をcase文で見て(- n 1)と並べ替えて返します。…以上です。

実装的な部分を見ると、set-separate-characterと対応した処理が分離しているのが気持ち悪いところで、マクロを使ってもっときれいに書けそうですね。

{}リードマクロ

(lnth 1 a)を#{a 1}や#{a[1]}と書いたり、(lnth 1 (lnth (- n 2) b))を#{b[1][n-2]}と書いたりするためのリードマクロです。

(defun {-reader (stream &rest rest)
  (declare (ignore rest))
  (let ((*readtable* (copy-readtable *readtable*))
        (pair nil))
    (set-macro-character #\} (get-macro-character #\)))
    (set-macro-character #\[ #'[-reader)
    (setf pair (read-delimited-list #\} stream t))
    (labels ((recursive-lnth (lst)
               (if (null (cdr lst))
                   (car lst)
                   `(lnth ,(car lst) ,(recursive-lnth (cdr lst))))))
      (recursive-lnth (reverse pair)))))

初めて書いたリードマクロ（[]リードマクロや再帰なしバージョンが）だけあってやっていることは単純です。例えば、#{a 1}の場合、read-delimited-listが(a 1)というリストを返すので、並び替えて頭にlnthをつけて(lnth 1 a)とするだけです。あとはこれに再帰処理を加えて#{a 1 2}を(lnth 1 (lnth 2 a))とできるようにしたり、char文字'['に前述の"[-reader"を設定して#{a[1]}や#{a[n-1]}と書けるようにしたらできあがりです。

こういった再帰や他のリードマクロとの組み合わせが簡単にできるのは素敵です。

<>リードマクロ

未処理のTODOが残っていたりしますが…中身の割に長いコードが以下になります。

(defun <-reader (stream &rest rest)
  (declare (ignore rest))
  (let ((*readtable* (copy-readtable *readtable*))
        (buf) (a) (n))
    (set-separate-character #\>)
    (set-separate-character #\=)
    (set-separate-character #\[)
    (set-separate-character #\])
    (setf buf (read-delimited-list #\= stream t))
    ; TODO: check #\[ #\]
    (setf a (car buf))
    (setf n (caddr buf))

    (set-macro-character #\[ #'(lambda (s c)
                                 (list #\[
                                       (funcall #'[-reader s c))))
    (set-separate-character #\,)
    (setf buf (read-delimited-list #\> stream t))
    (labels ((sort-ref-series (buf)
               ; Basically this function traces the list recursively
               ; and only reconstructs the same list.
               ; But if finds (a (#\[ b)), sorts this to (lnth b a).
               (let ((res nil))
                 (dolist (elem buf)
                   (if (listp elem)
                       (let ((child (sort-ref-series elem)))
                         (when (eq (car child) #\[)
                           (setf child `(lnth ,(cadr child) ,(car res)))
                           (setf res (cdr res)))
                         (setf res (cons child res)))
                       (setf res (cons elem res))))
                 (reverse res))))
      (let* ((splitted (split-by-last buf #\,))
             (init-list (remove #\, (car splitted)))
             (body-list (cadr splitted)))
        `(make-series ,(if (null init-list) nil `(list ,@(sort-ref-series init-list)))
                      #'(lambda (,a ,n)
                          (declare (ignorable ,a ,n))
                          ,@(sort-ref-series body-list)))))))

(defun split-list (lst index)
  (let ((target (if (null index) 0 (1+ index))))
    (list (subseq lst 0 target)
          (nthcdr target lst))))

(defun split-by-last (lst delimiter)
  (split-list lst
              (position delimiter lst :from-end t)))

まずは定義よりmacroexpandということで、フィボナッチ数列の展開例を。sort-ref-series関数でゴチャゴチャと処理はしていますが、"`(make-series..."に始まる出力部分が素直に出ています。なお、コード中のa, nと紛らわしいので、b[k]=...の形で書いています。

CL-USER> (macroexpand '#<b[k] = 0, 1, (+ b[k-1] b[k-2])>)
(MAKE-SERIES (LIST 0 1)
             #'(LAMBDA (B K)
                 (DECLARE (IGNORABLE B K))
                 (+ (LNTH (- K 1) B) (LNTH (- K 2) B))))

コード全体を見ると、"="の左辺を読むパート、右辺を読むパートで大きく2つに分かれます。

左辺パートの目的は、lambda式の引数に利用する配列名（aに束縛）とインデックス名（nに束縛）を取得することです。"(setf n (caddr buf))"の行までがこのパートになります。ここでは単に"="までの4要素をread-delimited-listからリスト、例えば"(a #[ n #])"として受け取って、第1要素を配列名として、第3要素をインデックス名として受け取っています*1。

右辺パートの目的は、make-seriesの引数として必要な、初期化リストとlambda式内の処理本体を取得することです。"["の処理やsort-ref-series関数周りはいったん飛ばして見てみます。まずは、read-delimited-listから(0 #\, 1 #\, (+ a[n-1] a[n-2])のようなカンマ区切り？のリスト*2を受け取ります。最終要素が処理本体、その手前が初期値リストになるので、この2つを"(splitted (split-by-last buf #\,)"で分離します*3。初期値側は"(init-list (remove #\, (car splitted))"として不要なカンマを削除して先頭に"list"をつけて完成です。本体側はそのままです、"(body-list (cadr splitted))"。

最後に、ここまで飛ばしてきたsort-ref-series関数ですが、目的は、例えば"a[n]"を"(lnth n a)"の形に変換することになります。当初は（read-delimited-list関数ではなく）read関数を直接使うことで、"["を見つけたら前を見て…ということを考えていたのですが、ストリームなので前方参照ができない*4ことに気づいて詰まりました。

そこで、いったんマーク付きで全部リストに出力してから、マークを読み取って一部を書き換えるという力業に出てみました。このマークをつけているのが"#\["のリーダマクロで、マークを読み取っているのがsort-ref-series関数です。前者は"[-reader"関数のリード結果に"#\["というゴミ…もといマークをつけています。後者は（ソースの怪しげな英文コメントにある通り）、基本的には受け取ったリストをそのまま返すだけですが、マーク、例えば"(a (#\[ n))"を発見するとその部分を"(lnth n a)"というリストに置き換えて返します*5。

実際、変換前のリストである(car body-list)をprintすると次のような結果が得られます。

(+ A (#\[ (- N 1)) A (#\[ (- N 2)))

ちなみに、このリードマクロを作ったときは何もいっぺんに作ったわけではなく、まずは左辺の処理を作って"(LAMBDA (A N))"だけ出力してみて、次に初期値（カンマ区切り）なしで内部の処理を読んでみて"(LAMBDA (A N)(+ (LNTH (- N 1) A) (LNTH (- N 2) A))))"を出力して、、、と順々に積み重ねて上の形になりました。

感想

深く考えたことがなかったですが、あんなものでも四則演算のリードマクロを書くと「だから多くの言語では変数名にハイフン許可していないのか」と気づいたりします（"#[a-b]"とした時に「a引くb」なのか「"a-b"という変数名」なのか一意に決まらない）。Cを勉強するとポインタレベルの動きに敏感になるように、Lispを触っているとコンパイラレベルの動きに敏感になるようです*6。

便利な文法を作ろうとすると実装の都合による制約というのが容易に入り込むという感想も持ちました（今回のようなサボり実装で悟ったようなことを言うと怒られそうですが）。問題は影響範囲が大きいことで、例えば#[]リードマクロの中ではどうあがいてもハイフンつきの変数名は許可されません。そういった実装の都合を最小化する意味で、S式で一貫しているLispの選択はありだと感じます。

余談ですが、こうした実装都合による制約で度肝を抜かれたのがRuby（バージョン2.0.0で確認）で、2変数以上の関数で引数にカッコをつけて呼び出す場合、関数とカッコの間にスペースがあると文法エラーをはくというものです。あえて「2変数以上」と書いたのはそのままの意味で、1変数のときはスペースの有無によらずエラーになりません。また、2変数以上でも関数定義部分ではスペースがあってもOKでした。まったく意味が分かりませんが、様々な便利文法を提供する過程でやむにやまれず諦めた部分だろうと想像すると多少納得がいきます。

また、通常の関数などと比べて完全性を確保するのが難しいと感じました。これは再帰性に起因するところだと思いますが、内部でどのようなS式でも受け入れてしまうので、何が動いて何が動かないかを予測することができなかったです（第三回の2次元数列なんてよく動いたなと他人事のような印象でした）。逆に、何もしなければS式として解釈されるので、全部作る必要がない点は実装の労力や柔軟性という面でよかったです。

シリーズ完

思いついたことは何でも書くという方針のため無駄に長かった「Common Lispで遅延評価を作って遊ぶ」シリーズですがこれで完です。終わると記事のネタがなくなるかもしれないので吸えるだけ吸い尽くしておこうという不純な動機もあったりしましたが、現状まだ2，3個はネタがありそうです。こう詰まらないものでも定期的にアウトプットしていける状態を維持したいものです。

シリーズリンク

*1:TODOにある通り最低限のエラー処理もサボってますが…

*2:実際には、最終要素はリーダマクロで処理済みのものになりますが

*3:最初に(remove #\, ...)してから分ければいいだけのような…と記事を書いてて思いました。なんかアホなことをした気がしてきました

*4:恐ろしいことに、リーダ自体の動作を上書きして前方参照を可能にしている方もいますが…：SBCLのリーダを上書きして"超リードマクロ"を実装 - 八発白中

*5:sort-ref-series関数はコメントの必要性を感じるレベルで汚い実装になっているので、もう少しきれいに書ければいいのですが…。リストを再帰的に探索して条件に合ったリストを置き換える汎用関数を書いたら少しはきれいになるでしょうか。

*6:参考：「あなたがLispを無視することができない理由 - 八発白中」での「Lispの進化（The Evolution of Lisp）」の引用