【マクロ小ネタ】Common Lisp で defer してみる

Common Lisp Lisp Go プログラミング マクロ

時には実用を考えずにマクロを書いて遊んでいると楽しいというだけの記事です。

Go言語の defer が簡単に実装できそうな気がしたので書いてみました。と思っていたら、途中で記事後半の事実に気付いて思ったよりも長くなりました。

defer の単純な模倣

Go言語における defer の動作

Go言語において、defer を利用することで、関数スコープを抜けるときに実行する動作を記述することができます。リソースのクローズなどに利用しますが、ここではそうした実践的な例は捨ておき、次のような例のための例を見ます（以下は適宜抜粋したもの。動作するコードは https://play.golang.org/p/EWOSf5oa3_5 ）

func test(x bool) {
    fmt.Println("before")
    defer fmt.Println("after")

    if !x {
        return
    }

    defer func() {
        fmt.Println("1")
        fmt.Println("2")
    }()
    fmt.Println("3")
}

この defer には次のような特徴があります。

  1. 複数の defer がある場合、通ったのとは逆順で実行される
  2. 実行時に通った defer のみが動作する

まず特徴1を見るため、test(true)として実行すると次のような出力になります。後ろにある "1", "2" を出力する defer の方が、"after" を出力する defer よりも先に実行されています。

before
3
1
2
after

次に特徴2を見るため、test(false)として実行すると次のような出力になります。途中で return して通過しなかった "1", "2" を出力する defer は実行されません。

before
after

マクロを書いて模倣する: with-defer

上で見たような特徴を持つ defer を利用することができるマクロ with-defer を作ってみます。

実装は後で見ますが、これを利用することで先程の test 関数と同じ動作の関数を次のように書けます。ただし、defer が実行されるのは関数スコープを抜けるときではなく、with-defer を抜けるときになります*1。

(defun test (x)
  (with-defer
    (print 'before)
    (defer (print 'after))
    (unless x
      (return-from test))
    (defer (print 1) (print 2))
    (print 3)))

動かしてみます。まずは (test t) です。下記の通り、後に出てくる defer （"1", "2" を出力）が最初の defer（"AFTER" を出力）よりも先に実行されます。

BEFORE
3
1
2
AFTER

次に (test nil) です。下記の通り、到達しなかった2つ目の defer は実行されません。

BEFORE
AFTER

さて肝心の実装ですが、下記の通り10行程度のマクロで実現できます。

(defmacro with-defer (&body body)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    `(push (lambda () ,@,g-body)
                           ,',g-defer-list)))
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

with-defer の中でのみ動作するローカルマクロ defer は、渡された g-body 部で無名関数を組み上げ、リスト g-defer-list に追加します。このリストに詰め込まれた無名関数は unwind-protect を抜けるとき（いわゆる try-finally の fianlly 部）に、リストに入れたのとは逆の順序で取り出されて実行されます。

という感じで、容易に動作を模倣することができました。

ちなみに、複数行に渡る動作を defer に渡す場合、Go言語では次のように明示的に無名関数で包んであげる必要があります。

   defer func() {
        fmt.Println("1")
        fmt.Println("2")
    }()

一方で、上で実装した defer は暗黙的に無名関数で包んでいるため、複数行に渡る動作も単に並べるだけで良いです。

(defer
  (print 1)
  (print 2))

deferの直接呼び出し形式における引数の先行評価

Go言語の場合

実は、上記で実装した defer では1つ模倣できていないことがあります。それは、直接呼び出し形式における引数の先行評価です...というと分かりにくいですが、例を見てみます（ https://play.golang.org/p/HwOBMnxEe33 ）。

func test() {
    for i := 0; i < 3; i++ {
        defer fmt.Printf("direct:  %d\n", i) // 直接呼び出す
    }
    for i := 0; i < 3; i++ {
        defer func() {
            fmt.Printf("closure: %d\n", i)   // クロージャに包んで呼び出す
        }()
    }
}

この test 関数を実行すると次のような結果になります*2。見ての通り、クロージャに包んだ方は、ループが回りきった後の i の値である3を出力し、直接呼び出した方は defer が評価された時点の i の値を出力します。

closure: 3
closure: 3
closure: 3
direct:  2
direct:  1
direct:  0

これは、直接呼び出しの場合に限り、引数をその場で評価することから来る動作のようです。次のようにすると、その動作がよりはっきりします（ https://play.golang.org/p/z_m-Kr-pxsM ）。

func f(s string) string {
    fmt.Println(s)
    return "inner"
}

func test() {
    defer f(f("outer"))
    fmt.Println("normal")
}

この test 関数を実行すると次のような結果になります。defer に渡した f(f("outer")) の「引数」である f("outer") は defer を通過した時点で評価されます。このため、"normal" よりも先に "outer" の出力が来ることになります。

outer
normal
inner

引数の先行評価を模倣する: with-defer2

先程作成した with-defer マクロ内の defer は単にクロージャで包んでいるだけであるため、上で見たような先行評価を模倣することができていません。

(with-defer
  (dotimes (i 3)
    (defer (print i))))

上記を実行すると、ループ後の i の値3が取り出されています。

3
3
3

さて、引数の先行評価を模倣するにあたり、まずは実現方式を考えてみます。現在の with-defer を手で展開すると次のようになります。

(let (lst)
  (unwind-protect
       (dotimes (i 3)
         (push (lambda ()
                 (print i)) ; ← この i は...
               lst))
    (dolist (fn lst)
      (funcall fn))))       ; ← この funcall 時点まで評価されない

次のようにすることで、defer = push 時点で i を評価させることができます。

(let (lst)
  (unwind-protect
       (dotimes (i 3)
         (push (let ((x i)) ; ← この時点で i が評価される
                 (lambda ()
                    (print x)))
               lst))
    (dolist (fn lst)
      (funcall fn)))) ; ← x の評価はここだが、評価済みの i が入っている

上記の出力は目的通りの形になります。

2
1
0

後はこれをマクロとして実装するだけです。その前の準備として、ネストしたバッククォートを扱い続けるのはしんどいので、補助関数を切り出します。先程の with-defer と等価な実装は下記の通りです。

(defun defer% (defer-list body)
  `(push (lambda () ,@body)
         ,defer-list))

(defmacro with-defer (&body body)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    (defer% ',g-defer-list ,g-body))) ; ← ここを切り出した
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

できあがったものがこちらです。行数としては30行程度ですが、だいぶしんどい実装になっています。しんどい主な原因はGo言語の defer における「直接呼び出しで書けるのは関数呼び出しに限る」という制約がないためです。with-defer の場合、アトム, 関数, マクロ, スペシャルフォームのいずれも許容していますが、このうち単純に引数を評価してよいのは関数だけです。この辺りの振り分けをしているのが true-function-p です（たぶんバグがあります）。

(defun true-function-p (head env)
  (if (listp head)
      (functionp head)    ; ← (lambda (x) x) 形式を捕捉するため
      (and (fboundp head)
           (not (special-operator-p head))
           (not (macro-function head env)))))

(defun defer2% (defer-list body env)
  `(push ,(if (and (= (length body) 1) ; ← body部が1つのときだけ先行評価をする
                   (listp (car body))
                   (true-function-p (caar body) env))
              ;; ↓の部分は (fn x y z) を次のように展開する操作
              ;; (let ((a0 x)
              ;;       (a1 y)
              ;;       (a2 z))
              ;;   (fn a0 a1 a2))
              (let ((args (loop :for i :from 0 :below (length (cdar body))
                             :collect (intern (format nil "A~D" i)))))
                `(let ,(loop :for arg :in args
                             :for exp :in (cdar body)
                          :collect (list arg exp))
                   (lambda () (,(caar body) ,@args))))
              ;; ↓（いわゆる）else部は元の defer% と同じ
              `(lambda () ,@body))
         ,defer-list))

(defmacro with-defer2 (&body body &environment env)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    ;; ↓ここで defer2% を呼ぶことと、
                    ;;   引数に &environment を取っている以外は with-defer と同じ
                    (defer2% ',g-defer-list ,g-body ,env)))
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

ということで、下記のように呼び出してみると...

(with-defer2
  (dotimes (i 3)
    (defer (print i))))

所望の通り、先行評価できていることが分かります。

2
1
0

しかし、せっかく関数以外も受け入れられたり、複数行（= body部が2つ以上）を受け入れられたりするのに、次の例に見るように色々な制約があって今いちしっくりきません。

;; これは先行評価にならない（スペシャルフォーム let で包んだので）
(with-defer2
  (dotimes (i 3)
    (defer (let ()
             (print i)))))

;; これも先行評価にならない（body部が2つ以上あるので）
(with-defer2
  (dotimes (i 3)
    (defer (print i) (print i))))

関数以外の場合に、必要な部分だけ正しく先行評価をするのは結構大変です。複数行に渡って先行評価を行うようにすることはまだ容易ですが、関数以外への対応をしないまま導入しても、式によって先行評価されたりされなかったりとなって余り嬉しくはなさそうです。

別の道を探ってみる: with-defer!

さて、前節で実装した with-defer2 ですが、動作はGo言語を模倣しているものの今いちしっくりこない結果となってしまいました。

ここで、マクロ側に自動で先行評価の有無を判断させるという方向性を捨てて、マクロの利用者に先行評価をコントロールさせる道を考えてみます。Common Lisp は多大な自由を与える代わりにプログラマにその制御の責を負わせる傾向が強い言語であるため、こうした方向の方が馴染みそうです。

ということで、次のようにプレフィックス c! をつけたシンボルは先行評価された元の（=プレフィックスなしの）シンボルの値が入るような with-defer! マクロを書くことにします。

(with-defer!
  (dotimes (i 3)
    (defer (format t "~D:~D~%"
                   c!i   ; ← 先行評価した i の値が入る
                   i)))) ; ← 先行評価しない

実行結果は次のようになります。

2:3
1:3
0:3

実装は次のようになります。行数的には with-defer2 より若干長いですが、関数の判定といった辛い作業がないため、かなり気楽な実装になっています。なお、読んだことのある方は分かると思いますが、Let Over Lambda の defmacro! マクロの実装やインタフェースを多いに参考にしています*3。

;; 補助関数：ネストしたリストをフラットなリストに変換する
;; Ex. (1 2 (3 4 (5)) 6 7) -> (1 2 3 4 5 6 7)
(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec
                       (car x)
                       (rec (cdr x) acc))))))
    (rec x nil)))

;; 補助関数：シンボル名に "c!" のプレフィックスがあるか判定する
(defun c!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "C!"
                :start1 0
                :end1 2)))

(defmacro with-defer! (&body body)
  (let ((g-defer-list (gensym "DEFER-LIST"))
        (g-body (gensym "BODY")))
    `(let (,g-defer-list)
       (macrolet ((defer (&body ,g-body)
                    (let (; ↓ "c!" プレフィックスつきのシンボルを抽出する
                          (syms (remove-duplicates
                                 (remove-if-not #'c!-symbol-p
                                                (flatten ,g-body)))))
                      ;; ↓ c!a, c!b, c!c を見つけたとすると、次のように変換される
                      ;;   (let ((c!a a)
                      ;;         (c!b b)
                      ;;         (c!c c))
                      ;;     ...)
                      `(push (let ,(mapcar (lambda (s)
                                             `(,s ,(intern (subseq
                                                            (symbol-name s)
                                                            2))))
                                           syms)
                               (lambda () ,@,g-body))
                             ,',g-defer-list))))
         (unwind-protect
              (progn ,@body)
           (dolist (func ,g-defer-list)
             (funcall func)))))))

この方法であれば、defer の中に式が複数あるとダメとか let のようなスペシャルフォームで包むとダメといった制約はありません。

(with-defer!
  (dotimes (i 3)
    (defer (print c!i)
           (let ((x 100))
             (print (+ c!i x))))))
;; ↓実行結果
2
102
1
101
0
100

こうして様々な「構文」をいじって遊べるのは Lisp の面白いところですね。

*1:例ではやっていませんがネストさせることもできます

*2:ちなみに、クロージャの方は "loop variable i captured by func literal" と go vet に怒られます

*3:実装が似ているだけで動作的には無関係なので、defmacro! の詳細は略します

【小ネタ】 簡易な関数定義マクロ, マクロ定義マクロを自作してみる

Lisp Common Lisp プログラミング

defunまでマクロで出来ているということはユーザがその気になれば関数定義の構文に手を入れたりも出来るということだ。 ～中略～ このような設計はマクロで制御構造までも作れるから出来るのだ。関数定義構文をマクロで定義している言語はLisp以外に私は知らない。

～マクロについて整理してみる | κeenのHappy Hacκing Blog～

とあるように、多くの言語において言語の基本要素である関数定義構文すらマクロで作れてしまうという点は、Lisp の特異でありまた面白い点です。そんな訳で、ごく簡易なものであればほんの数行で作れてしまう、という所を実際の Common Lisp のコードで見てみたいと思います。

なお、記事中の出力例は Clozure CL 1.11.5 を利用しています。

my-defun

まずは、結局のところ defun による名前付き関数の定義とは何をしているのかを見てみます。

とりあえず関数を一個定義してみます。

CL-USER> (defun hoge (a b)
           (+ a b))
HOGE
CL-USER> (hoge 1 2)
3

少々天下り式になりますが、このとき hoge シンボルの関数領域に「関数の実体」がひもづけられます。これは symbol-function によって確認することができます。

CL-USER> (symbol-function 'hoge)
#<Compiled-function HOGE #x3020045173AF>
CL-USER> (funcall #<Compiled-function HOGE #x3020045173AF> 1 2)
3

いきなり結論になりますが、この「シンボルの関数領域への関数のひもづけ」が「名前つき関数の定義」という操作の本質的な部分です。実際、シンボルの関数領域へ直接無名関数をひもづけてみると、同シンボルを関数として扱うことができてしまいます。

CL-USER> (setf (symbol-function 'hoge2)
               (lambda (a b)
                 (- a b)))
#<Anonymous Function #x3020045F404F>
CL-USER> (hoge2 1 2)
-1

ということで、「シンボルの関数領域へ無名関数をひもづける」操作をマクロ化した my-defun を作ってみます。

CL-USER> (defmacro my-defun (name args &body body)
           `(setf (symbol-function ',name)
                  (lambda ,args
                    ,@body)))
MY-DEFUN

使ってみます。できていますね。

CL-USER> (my-defun hoge3 (a b)
           (* a b))
#<Anonymous Function #x30200460884F>
CL-USER> (hoge3 2 3)
6

もちろん、これは実際のdefun に比べると全然機能が足りません。例えば、block を置いていないので、関数の途中で return-from することができません。が、そのぐらいであれば簡単に my-defun へ追加できます。

CL-USER> (defmacro my-defun (name args &body body)
           `(setf (symbol-function ',name)
                  (lambda ,args
                    (block ,name ; ← これ
                      ,@body))))
MY-DEFUN

return-from してみます。

CL-USER> (my-defun hoge4 ()
           (return-from hoge4 100)
           0)
#<Anonymous Function #x3020045E972F>
CL-USER> (hoge4)
100

ついでに、一々 (return-from <関数名>) と書くの面倒臭い！と思ったと仮定して、関数名なしでreturnできる my-return を使えるようにしてみます。

CL-USER> (defmacro my-defun (name args &body body)
           `(setf (symbol-function ',name)
                  (lambda ,args
                    (block ,name
                      (macrolet ((my-return (&optional return-value) ; ← これ
                                   `(return-from ,',name ,return-value)))
                        ,@body)))))
MY-DEFUN

my-return してみます。

CL-USER> (my-defun hoge5 ()
           (my-return 100)
           0)
#<Anonymous Function #x30200462C7AF>
CL-USER> (hoge5)
100

こんな感じで、シンプルな操作から始めて、自分で必要十分なところまで自作関数定義マクロを定義できてしまうというのは実に面白いところです。

my-defmacro

この辺から少々気味が悪くなるような話です。

defun はマクロとして定義されていたので、自身で再定義することができました。では、マクロを定義するのに利用した defmacro が何者かというと...CLHS に「Macro DEFMACRO」と書かれています。そう、defmacro もマクロです。つまり、自身で再定義することができます。

さて、関数定義と同じように、（名前付きの）マクロを定義するとシンボルのマクロ関数領域に（特定の形式の）関数がひもづけられます。これは、macro-function によって確認できます。

CL-USER> (macro-function 'my-defun)
#<Compiled-function MY-DEFUN Macroexpander #x30200453175F>

これまた my-defun で見たのと同様に、マクロ関数領域に自身で関数をひもづけることができます。

CL-USER> (setf (macro-function 'my-defun2)
               (lambda (param env)
                 (declare (ignore env))
                 (destructuring-bind (name args &body body) (cdr param)
                   `(setf (symbol-function ',name)
                          (lambda ,args
                            ,@body)))))
#<Anonymous Function #x30200463142F>

ここでは2つの引数をとる関数をひもづけています。第1引数 param は先頭にマクロ自身の名前、それ以降（(cdr param)）にいわゆるマクロの引数が入っています。なので、引数を destructuring-bind で取り出しています。第2引数 env はレキシカルな環境の情報が入っていますが、ややこしいので無視します*1。

使ってみます。さすがにSLIMEの構文解析が追いつかないのでインデントはおかしくなっていますが動いています。

CL-USER> (my-defun2 hoge6 (a b)
                    (/ a b))
#<Anonymous Function #x3020046254BF>
CL-USER> (hoge6 1 2)
1/2

ここでまた my-defun と同じように...といきたいところですが、defmacro を利用するのは本末転倒です。いったん立ち止まって、ここまでで何が分かったのかを考えてみると、次のようになります。

「任意の」マクロを定義する = macro-function 領域に「任意の」コードを出力する関数をひもづける

この「任意の」は本当に任意です。つまりネストすることもできます。この左辺がやりたいことです。

「任意のマクロを定義する」マクロを定義する
  = macro-function 領域に
   「macro-function 領域に任意のコードを出力する関数をひもづける」
   コードを出力する関数をひもづける

右辺をじっくり見ていると頭が痛くなりそうですが、深く考えずにコードの方もネストさせてみます。

CL-USER> (setf (macro-function 'my-defmacro)
               (lambda (param env)
                 (declare (ignore env))
                 (destructuring-bind (name lambda-list &body body) (cdr param)
                   `(setf (macro-function ',name)
                          (lambda (param env)
                            (declare (ignore env))
                            (destructuring-bind ,lambda-list (cdr param)
                              ,@body))))))
#<Anonymous Function #x30200464CD9F>

この my-defmacro を利用して改めて関数定義マクロを定義します。

CL-USER> (my-defmacro my-defun3 (name args &body body)
                      `(setf (symbol-function ',name)
                             (lambda ,args
                               ,@body)))
#<Anonymous Function #x3020045F928F>

確かに動いています。

CL-USER> (my-defun3 hoge7 (a b)
                    (+ a a b b))
#<Anonymous Function #x3020045E580F>
CL-USER> (hoge7 1 2)
6

そんな訳で、マクロを定義するマクロを自身で再定義することができました。マクロの実用的な面白さはどんなマクロを書けるのかという方向にある訳ですが、ときには逆方向を眺めてみるのも面白いですね。

*1:扱おうと思ったら、param 内の &environment を自前で解析して env を束縛してあげればできそうな気はします...が、試していません

【Emacs】 Docker 上で Go 開発環境を作ろうとしてハマった（ている）話

Go Emacs Docker

近頃お仕事で Go を書くことになり、Mac 上で Emacs + LSP（サーバ: gopls, クライアント: eglot）な環境を作りました。これには下記の記事に全面的に依拠しております。

そして、割と良い感じに動いているので、1年ぐらい前に作って放置していた Docker 開発環境にも反映させるか...と思ってだいぶハマったというのが本記事の内容です。一応の解決はしたつもりですが、どう見てもアドホックな方法なので、何か知っている人がいたら教えて欲しいというぐらいの精度です。

Docker 上では下記OSをゲストとして利用しています。

なお、現状確認できているのは、Mac 上に直接インストールした Emacs では問題なかったということと、Docker 上の Alpine Linux で問題があったということだけなので、実は Docker は関係ないかもしれないです。

問題1: eglot がインストールできない

現象

通常は (pacakge-install 'eglot) で何事もなく終わるはずの eglot （LSP クライアント）のインストールですが...以下のエラーでインストールに失敗しました。

error: Package `jsonrpc-1.0.7' is unavailable

なお、これを後述の方法で解決すると、今度は次のエラーで怒られるので同様に対処が必要です。

error: Package `flymake-1.0.5' is unavailable

再現手順

下記の手順で再現します。

$ docker run --name alp -it alpine:3.10 /bin/sh
# - 以下コンテナ内の操作 - #
$ cd
$ apk add --no-cache emacs
$ mkdir .emacs.d
$ cat<<EOF>.emacs.d/init.el
(require 'package nil t)
(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t)
(package-initialize)
(package-refresh-contents)
(package-install 'eglot)
EOF

ここで、Emacs を起動すると *Warning* バッファに先程のエラーが表示されます。

$ emacs -nw

調査

調べてみたものの、類似の現象として straight.el という別パッケージでの下記 issue が引っかかったぐらいでした。

Can't install elpa package jsonrpc · Issue #293 · raxod502/straight.el

この issue によると、下記のような経緯で jsonrpc パッケージが見つからないようになってエラーになったようです。

  1. 当初は jsonrpc は独立したパッケージとして開発されていた
  2. これが Emacs 本体に取り込まれることになった
  3. そして、MELPA (Emacs のパッケージリポジトリの一つ) も本体に jsonrpc があることを期待するようになった
  4. しかし、Emacs 側はまだ開発段階であったので、2 の反映には次のバージョンアップを待つ必要があった

しかし、解決方法が straight.el 固有なものであることと、現在 (Emacs 26.2) では上記4の状況は解消されていることから、今回の現象の解決には利用できません。

ただ、jsonrpc にしても flymake にしても、Emacs 本体に存在するものであるという共通点はあり、原因の根はそこにありそうです。

追記：解決

記事を上げた後、Common Lisp 開発環境のcl-devel2 でビルドエラーが起きていたので調べていたのですが、ふと下記のメッセージが目につきました *1。

Failed to download ‘gnu’ archive.

とりあえず、gnu アーカイブのURLを明示的に指定してみました。

$ docker run --name alp -it alpine:3.10 /bin/sh
# - 以下コンテナ内の操作 - #
$ cd
$ apk add --no-cache emacs
$ mkdir .emacs.d
$ cat<<EOF>.emacs.d/init.el
(require 'package nil t)
;; ----- ↓ これ ----- ;;
(add-to-list 'package-archives '("gnu" . "http://elpa.gnu.org/packages/"))
(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/") t)
(package-initialize)
(package-refresh-contents)
(package-install 'eglot)
EOF
$ emacs -nw

通りました

Leaving directory `/root/.emacs.d/elpa/flymake-1.0.8'
^L
Compiling file /root/.emacs.d/elpa/flymake-1.0.8/flymake.el at Mon Jul 15 07:17:11 2019
Entering directory `/root/.emacs.d/elpa/flymake-1.0.8/'
^L
Compiling no file at Mon Jul 15 07:17:12 2019
Leaving directory `/root/.emacs.d/elpa/jsonrpc-1.0.7'
^L
Compiling file /root/.emacs.d/elpa/jsonrpc-1.0.7/jsonrpc.el at Mon Jul 15 07:17:12 2019
Entering directory `/root/.emacs.d/elpa/jsonrpc-1.0.7/'
^L
Compiling no file at Mon Jul 15 07:17:12 2019
Leaving directory `/root/.emacs.d/elpa/eglot-20190702.2158'
^L
Compiling file /root/.emacs.d/elpa/eglot-20190702.2158/eglot.el at Mon Jul 15 07:17:12 2019
Entering directory `/root/.emacs.d/elpa/eglot-20190702.2158/'
Warning (bytecomp): Unused lexical variable `desc'
Warning (bytecomp): Unused lexical variable `file1'

ただ、*Messages* バッファの方には依然として Failed to download ‘gnu’ archive. が出ているので、きっかけにはなりましたが別の現象のようです。

Obsolete: 解決？

上記の原因の根と思われるものの解明には至っておらず...力業で解決しました。ローカルに jsonrpc.el, flymake.el を落としてきて手ずからインストールする方法です。

まず、適当なフォルダに両ファイルを落としてきます（実際には下記に相当する操作を Dockerfile 側に書いています）。

$ emacs_src="~/.emacs.d/src/"
$ mkdir ${emacs_src}
$ cd ${emacs_src}
$ wget https://raw.githubusercontent.com/emacsmirror/jsonrpc/master/jsonrpc.el
$ wget https://raw.githubusercontent.com/emacsmirror/flymake/master/flymake.el

次に ~.emacs.d/init.el に下記の記述を加えて、両パッケージをインストールします*2。なお、各 .el を単に load-path するだけではパッケージマネージャが認識してくれないので不十分です。

(dolist (pack-name '("jsonrpc" "flymake"))
  (package-install-file
   (concat "~/.emacs.d/src/" pack-name ".el")))

これで、(package-install 'eglot) が無事通るようにはなり、eglot も無事動作しているようです。

問題2： gofmt が効かない

現象（・再現方法）

セーブ時に自動で goimports をかけるためには、下記のようにフックを設定します。

(use-package go-mode
  :commands go-mode
  :config
  (setq gofmt-command "goimports")
  (add-hook 'before-save-hook 'gofmt-before-save))

しかし、これまた Mac では起きていなかったエラーが発生しました...。

Invalid rcs patch or internal error in go--apply-rcs-patch

調査

取りあえずエラーメッセージでググってみたものの... go-mode.el ソースのエラーメッセージぐらいしかヒットしませんでした。

https://github.com/dominikh/go-mode.el/blob/35f6826e435c3004dabf134d0f2ae2f31ea7b6a2/go-mode.el#L1038 *3

(defun go--apply-rcs-patch (patch-buffer)
  "Apply an RCS-formatted diff from PATCH-BUFFER to the current buffer."
...
          (unless (looking-at "^\\([ad]\\)\\([0-9]+\\) \\([0-9]+\\)")
            (error "Invalid rcs patch or internal error in go--apply-rcs-patch"))
...

goimports した前後の差分をチェックして適用するみたいな動作をしているようです。チェックで落ちているようですが原因は良く分かりません。

解決？

マイナーっぽい問題をマジメに調査するのも辛いな...と思い、 gomimports をかける関数を自作することにしました。アドホックですね。

下記の my-gofmt-hook を before-save-hook に設定して、セーブ前に動作させます。フック内でいったんセーブ（save-buffer）してしまってから goimports -w で直接ファイルを書き換えるという乱暴な方法をとっています*4。なお、フックをかけたままセーブしようとすると無限に save-buffer してしまうので、いったんフックを外してから最後にフックを戻すという操作をしています。アドホックですね。

(defun my-gofmt-hook ()
  (unwind-protect
      (progn
        (remove-hook 'before-save-hook 'my-gofmt-hook)
        (save-buffer)
        (shell-command (concat "goimports -w " (buffer-file-name)))
        (revert-buffer t t t))
    (add-hook 'before-save-hook 'my-gofmt-hook)))

実際にフックを設定しているのが下記です。セーブ後に revert-buffer でバッファを読み直さないと構文解析が狂ってしまうようだったので、after-save-hook で revert-buffer をかけています。アドホックですね。

(use-package go-mode
  :commands go-mode
  :defer t
  :config
  (add-hook 'before-save-hook 'my-gofmt-hook)
  ;; The following is required to avoid wrong analysis by LSP server.
  (add-hook 'after-save-hook
            '(lambda ()
               (revert-buffer t t t))))

*1:なお、cl-devel2 の方のエラーはこれとは無関係です

*2:この操作が終わった段階でwgetした.elファイルは消して良いと思いますが、念のため残しています

*3:一応、引用した同関数の末尾に同じエラーメッセージがありますが、パッと見た感じ引用部分が通っていれば末尾の方にいくことはなさそうに見えます

*4:慎重にやるのであれば、一時ファイルを作成してバッファの内容をコピーしてセーブ。一時ファイルに goimports をかけてから書き戻すようにするのが良さそうです。元々使おうとしていた go-mode のフックも大枠はそのような動作をしているように見えます（ちゃんと調査してませんが...）

proto-cl-client-side-rendering に画像描画機能を追加した話

ゲーム プログラミング Lisp Common Lisp

前回記事でクライアントサイドレンダリング (2D) のためのライブラリを実装してみました。

eshamster.hatenablog.com

この時点では丸や四角といったプリミティブな図形の描画しかできませんでした。画像（テクスチャ）の描画機能も必要だろうなと思いつつ面倒なので後回しにしていました。そして、ようやく実装したというのが今回の話ですが、思った通り面倒だったので後から見返すためのメモを残しておこうという趣旨のメモ記事です。

見返し用に作ったセルフプルリク↓

github.com

面倒なところ

おおむね下記が面倒なところです。

  • 単一の画像ファイルに複数の画像が埋め込まれている
  • 透過処理のために2つの画像（元画像とアルファマップ）が必要になる
  • 層によってデータの形が異なる
    • ライブラリ外部へのインタフェース層
    • プロトコル層
    • クライアント層

用語について

本題の前に、textureとimageという用語を勝手に定義して使ってしまっているのでその説明です。

  • texture: 物理的な画像ファイル1つ1つに対応する情報
    • 正確には、アルファマップがある場合は元画像 + アルファマップの2ファイルに対して1つのtextureが対応します
  • image: 1つのtextureに対して複数のimageが対応する。1つの画像ファイルは複数の画像を含む場合があり、どこからどこまでを1つの画像として扱うかという情報をimageで持っている

何となくtextureの方が具象的な印象があり、一方でimageの方が抽象的な印象があったのでこの名付けにしていますが、そんなに深くは考えていません。

うまく説明できている気がしないので具体例で見ます。

f:id:eshamster:20170812024633p:plain

「A」と「B」という2つの画像を含んだ1つの画像ファイルで、これが1つのtextureに対応します。実際に描画する際には、「A」は「A」、「B」は「B」で個別に扱いたいとします。そのためには2つのimageをこのtextureに対応づけます。1つ目のimageはtextureの左半分の領域を指定し、2つ目のimageはtextureの右半分の領域を指定します。そして、「A」を描画したいときには1つ目のimageを、「B」を描画したいときには2つ目のimageを選択して描画する、といった形になります。

各層の実装

下記の層を順番に見ていきます。

  • ライブラリ外部へのインタフェース層
  • プロトコル層
  • クライアント層

ライブラリ外部へのインタフェース層

利用例として、ライブラリ配下に置いているサンプル sample/sample-texture.lisp を見てみます。

まず、画像ファイル = textureをロードする部分です。 multiple_image.png とそのアルファマップである multiple_image_alpha.png（パスの起点は後述）に :multiple-image という名前をつけてロードしています。

  (load-texture :name :multiple-image
                :path "multiple_image.png"
                :alpha-path "multiple_image_alpha.png")

これは先程も載せた、「A」と「B」を1つの画像ファイルにまとめたものです。

f:id:eshamster:20170812024633p:plain

ここから2つのimageを抽出します。1つは左半分を取り出した :a で、もう1つは右半分を取り出した :b です。取り出し範囲は、画像の左下を (0, 0)、右上を (1, 1) とする、いわゆる UV 座標系で指定します。

  (load-image :image-name :a
              :texture-name :multiple-image
              ;; 補足: デフォルトは x = 0, y = 0, width = 1, height = 1
              :uv (make-image-uv :width 0.5))
  (load-image :image-name :b
              :texture-name :multiple-image
              :uv (make-image-uv :x 0.5 :width 0.5))

こうして作成した image は次のように使います。:image-name として :a を指定し、あとは座標や大きさなど描画に必要な情報を指定します。

    (draw-image :id (incf id)
                :image-name :a
                :x 500 :y 300
                :width 50 :height 50
                :rotate (* -1/10 *temp-counter*)
                :depth 0 :color #xffffff)

この辺りのインタフェースは良い感じにできたんじゃないかなーと思ってます。

いったん飛ばした、画像指定時に起点となるパスはミドルウェア（middleware.lisp）に渡す引数から決まり、<resource-root>/<image-relative-path> になります。先程のサンプルでは <proto-cl-client-side-renderingのルートパス>/sample/resource/img フォルダにしています。

(defun make-client-side-rendering-middleware (&key
                                                resource-root
                                                (image-relarive-path "img/"))
  (ensure-js-files  (merge-pathnames "js/" resource-root))
  (set-image-path resource-root image-relarive-path)
  ...

プロトコル層

クライアントに情報を送付するプロトコル層ですが、ここはインタフェース層と大きくは変わりません。

これは protocol.lisp で定義していて、おおむねインタフェース層の load-texture, load-image, draw-image に対応していることが見てとれると思います（frame, index-in-frame は前回記事と同じなので詳細略）。

(defun send-load-texture (frame index-in-frame
                          &key path alpha-path texture-id)
  (send-message :load-texture frame index-in-frame
                `(:path ,path :alpha-path ,alpha-path :texture-id ,texture-id)))

(defun send-load-image (frame index-in-frame
                        &key texture-id image-id uv-x uv-y uv-width uv-height)
  (send-message :load-image frame index-in-frame
                `(:texture-id ,texture-id :image-id ,image-id
                  :uv-x ,uv-x :uv-y ,uv-y :uv-width ,uv-width :uv-height ,uv-height)))

(defun send-draw-image (frame index-in-frame
                        &key id image-id x y depth color width height rotate)
  (send-draw-message :draw-image frame index-in-frame
                     `(:image-id ,image-id :width ,width :height ,height :rotate ,rotate)
                     :id id
                     :x x :y y :depth depth :color color))

これらのプロトコルを抽象化してインタフェースとして提供する層が texture.lisp です。ざっくり次のような役割を持っています。

  • インタフェースの提供
    • load-texture
    • load-image
    • draw-image
  • texture, image それぞれについて、idと名前の対応付け
    • インタフェースとしては名前を利用する
    • プロトコルにはidの方を渡している
  • 適切なタイミングでの上記プロトコルのクライアントへの送信
    • send-load-texture, send-load-image
      • 接続済みのクライアントについては load-texture, load-image が呼ばれたタイミング
      • 後からつないできた新規接続のクライアントについては接続したタイミング
    • send-draw-image
      • （通常の描画命令と同じく）draw-image が呼ばれたタイミング

クライアント層

クライアント層は受け取ったプロトコルに応じて実際に画像をロードし、Three.js に適切にデータを渡して画像の描画を行います。

同じような処理は cl-web-2d-game でも一度書いたことがある...のですが、すっかり忘れていて調べ直したので、この機会に一度メモを残しておきたいところです。というのが今回の記事を書こうと思った大きな要因だったりします。

この辺りの処理は client/texture.lisp に書いています。

まずはデータ構造を整理します。

ゴールとなるデータ構造は THREE.Mesh です。これを、THREE.Scene に追加することで描画ができます。THREE.Mesh のコンストラクタには次の2つを渡します。

  • THREE.Geometry: ジオメトリ = 形状に関する情報
    • vertices: 頂点情報。THREE.Vector3 の配列
      • 今回は四角形にテクスチャを貼り付けるので4頂点必要
    • faces: ポリゴン情報。THREE.Face3 の配列
      • THREE.Face3 は vertices に登録したどの3頂点で三角形を構成するかを表す
      • 今回は2つの三角形で1つの四角形を表すので2つ必要
    • face-vertex-uvs: テクスチャの貼り方についての情報。THREE.Vector2 の2重配列
      • faces で指定した各頂点にテクスチャのどの部分を割り当てるかを UV 座標で表す
  • THREE.MeshBasicMaterial: マテリアル = 見た目に関する情報
    • map: THREE.Texture ≒ 画像を渡す
    • alpha-map: map に同じく THREE.Texture で、こちらはアルファマップ = 透過情報を示す画像を渡す
      • これを利用する場合は transparent を true にする
    • color: ベースとなる色
      • 画像の色に合成される

次にこのデータ構造と各種プロトコルの関係をみます。

  • :load-texture
    • THREE.TextureLoader により、マテリアルに渡す map と alpha-map をロードする
    • ロード後にテクスチャ情報をテーブルに保存しておく
  • :load-image
    • どの texture にひも付いているかと、ジオメトリに渡すUV座標の情報を保存する
      • load という名前ではあるが実は何もロードしていない
  • :draw-image
    • :load-texture, :load-image それぞれで保存した情報を使って、 実際にジオメトリとマテリアルを生成して THREE.Mesh をつくる

実装については、基本的に上記のプロトコル・構造に基づいて淡々と実装していくだけですが、画像ロード周りはどうしても非同期処理がからむのでそこだけ少々面倒です。

まず、:load-texture の部分です。Promiseを利用して、画像（下記の bitmap-image）とそのアルファマップ（下記のalpha-bitmap-image）をロードを非同期に待ってから、texture の情報（texture-info 構造体；定義略）をテーブルに保存します。

(defun.ps load-texture (&key path alpha-path id)
  (let* ((loader (new (#j.THREE.TextureLoader#)))
         (image-promise
          (make-texture-load-promise loader path))
         (alpha-image-promise
          (make-texture-load-promise loader alpha-path)))
    (chain -promise
           (all (list image-promise alpha-image-promise))
           (then (lambda (images)
                   (push (make-texture-info
                          :id id
                          :bitmap-image (aref images 0)
                          :alpha-bitmap-image (aref images 1))
                         *texture-info-buffer*))))))

(defun.ps make-texture-load-promise (loader path)
  (new (-promise
        (lambda (resolve reject)
          (if path
              (loader.load path
                           (lambda (bitmap-image)
                             (console.log (+ path " has been loaded"))
                             (funcall resolve bitmap-image))
                           (lambda (err)
                             (console.log err)
                             (funcall reject err)))
              (funcall resolve nil))))))

次に、:load-image については特に非同期的な要素はなく、単に image の情報（image-info 構造体；定義略）をテーブルに保存するだけです。

(defun.ps+ register-image (&key id texture-id
                                uv-x uv-y uv-width uv-height)
  (setf (gethash id *image-info-table*)
        (make-image-info :id id
                         :texture-id texture-id
                         :uv-x uv-x
                         :uv-y uv-y
                         :uv-width uv-width
                         :uv-height uv-height)))

最後の :draw-image も非同期的な要素があって少々面倒です。指定された image（にひもづくtexture）がロード済みか（image-loaded-p）で処理を変える必要があります。ロード済みの場合は素直にテクスチャーつきの THREE.Mesh を生成するだけです。ロード済みでない場合、いったん幅と高さを合わせたジオメトリと、単色のマテリアルで THREE.Mesh を生成します。そして、ロードが完了した段階で正式なジオメトリとマテリアルに差し替えます。

(defun.ps make-image-mesh (&key image-id width height color)
  (flet ((make-geometry-and-material ()
           (let ((img-info (find-image-info-by-image-id image-id))
                 (tex-info (find-tex-info-by-image-id image-id)))
             (values
              (with-slots (uv-x uv-y uv-width uv-height) img-info
                (make-image-geometry :width width
                                     :height height
                                     :uv-x uv-x
                                     :uv-y uv-y
                                     :uv-width uv-width
                                     :uv-height uv-height))
              (make-image-material :tex-info tex-info
                                   :color color)))))
    ;; If the image has not been loaded, returns a temoral mesh with
    ;; same width, height, and monochromatic. Then, rewrites by the image
    ;; after loading it.
    (unless (image-loaded-p image-id)
      (let ((result-mesh (new (#j.THREE.Mesh#  ; 仮のMesh
                               (make-image-geometry :width width
                                                    :height height)
                               (new (#j.THREE.MeshBasicMaterial#
                                     (create :color #x888888)))))))
        ;; 補足: register-func-with-pred は cl-ps-ecs
        ;; (https://github.com/eshamster/cl-ps-ecs) で定義している関数で、
        ;; フレーム開始時に第2引数で渡した条件をチェックして、条件を満たしていたら
        ;; 第1引数に渡した処理を実行する
        (register-func-with-pred
         (lambda ()
           ;; 正式なジオメトリとマテリアルに差し替える
           (multiple-value-bind (geometry material)
               (make-geometry-and-material)
             (setf result-mesh.geometry geometry
                   result-mesh.material material)))
         (lambda () (image-loaded-p image-id)))
        (return-from make-image-mesh
          result-mesh)))
    ;; The case where the image has been loaded.
    (multiple-value-bind (geometry material)
        (make-geometry-and-material)
      (new (#j.THREE.Mesh# geometry material)))))

なお、ここで利用している、ジオメトリを生成する make-image-geometry とマテリアルを生成する make-image-material は、前述のデータ構造に従って地道にデータを組み上げるだけです。

(defun.ps make-image-geometry (&key width height
                                    (uv-x 0) (uv-y 0) (uv-width 1) (uv-height 1))
  (let ((geometry (new (#j.THREE.Geometry#))))
    (setf geometry.vertices
          (list (new (#j.THREE.Vector3# 0 0 0))
                (new (#j.THREE.Vector3# width 0 0))
                (new (#j.THREE.Vector3# width height 0))
                (new (#j.THREE.Vector3# 0 height 0))))
    (setf geometry.faces
          (list (new (#j.THREE.Face3# 0 1 2))
                (new (#j.THREE.Face3# 2 3 0))))
    (let ((uv-x+ (+ uv-x uv-width))
          (uv-y+ (+ uv-y uv-height)))
      (setf (aref geometry.face-vertex-uvs 0)
            (list (list (new (#j.THREE.Vector2# uv-x  uv-y ))
                        (new (#j.THREE.Vector2# uv-x+ uv-y ))
                        (new (#j.THREE.Vector2# uv-x+ uv-y+)))
                  (list (new (#j.THREE.Vector2# uv-x+ uv-y+))
                        (new (#j.THREE.Vector2# uv-x  uv-y+))
                        (new (#j.THREE.Vector2# uv-x  uv-y ))))))
    (geometry.compute-face-normals)
    (geometry.compute-vertex-normals)
    (setf geometry.uvs-need-update t)
    geometry))

(defun.ps make-image-material (&key tex-info color)
  (let ((alpha-bitmap (texture-info-alpha-bitmap-image tex-info)))
    (new (#j.THREE.MeshBasicMaterial#
          (create map (texture-info-bitmap-image tex-info)
                  alpha-map alpha-bitmap
                  transparent (if alpha-bitmap true false)
                  color color)))))

おわりに

これは忘れる！

クライアントサイドレンダリング (2D版) を Common Lisp で実装してみる

ゲーム プログラミング Lisp Common Lisp

2019年と令和元年、二重に本年最初の記事です。あけましておめでとうございます。

クラウドゲームをつくる技術 ―マルチプレイゲーム開発の新戦力 (中嶋謙互) （以下、「クラウドゲーム技術」）で提唱されている「クライアントサイドレンダリング」が面白そうだったので Common Lisp でプロトタイプ (2D版) を書いてみています。

作成しているものは下記です。今回の記事用に blog-20190506 というタグを打っています。記事中のソースへのリンクも同タグのものを貼っています。

github.com

プロトタイプとしても不足が目立つので記事にするには時期尚早な感じですが、GW中に一記事仕上げてみた次第です。

なお、こんなショボショボなプロトタイプでなくちゃんとしたものを見たい方は、同書と kengonakajima/moyai を参照しましょう（実装はC++）。

導入：クライアントサイドレンダリング概要

「クラウドゲーム技術」で提唱されているクライアントサイドレンダリングについて簡単に見てみます。関連する定義は次の2つです。

クラウドゲーム：

ゲームロジック（ゲームのあらゆる判定）のすべてがサーバー側で実行され、エンドユーザー側はその処理結果をリアルタイムに受信する汎用のViewer（ゲームビューワー）を通じてプレイする設計になっているゲーム

～「クラウドゲーム技術」: 「1.1 クラウドゲームとクラウドの基礎知識」>「クラウドゲームの定義」より～

クライアントサイドレンダリング：

クライアントサイドレンダリングとは、サーバー側でビデオゲームの画面へのレンダリングを行わず、抽象度の高い描画コマンドをクライアントに送って、クライアント側のGPUを使って描画をする方法です。

～「クラウドゲーム技術」: 「1. 5 クラウドマルチプレイ最大の課題『インフラ費用』」>「『クライアントサイドレンダリング』という発想」より～

ネットワークを通じてゲームを配信する従来の方法と比較すると分かり易いです。下記2つが従来の方法です。

  1. 専用クライアント方式：ゲーム専用のサーバとクライアントを実装する方法（Final Fantasy XIV など）
    • ロジック処理は分担し、描画はクライアントのみが担う
  2. ストリーミング方式：サーバ側でロジック処理から描画まで行い、クライアントへストリーミングする方法（PlayStation Now など）
    • （入力はクライアントで受け付けてサーバへ送信する）

1 の方法はクライアントを専用に作成するだけあって、ロジック処理や通信などサーバ側の負荷を低く抑えられる利点があり、大量のユーザを捌くことができます。一方で、ネットワーク処理や同期処理を中心にプログラミングのコストが非常に高くなる欠点があります。

2 の方法では利点・欠点が逆転します。つまり、単一サーバでの動作となるためオフラインゲームと同程度のプログラミングコストで実装ができる一方で、GPU処理の負荷やストリーミング帯域の大きさからユーザ数の限界は小さくなります。

以上を踏まえて改めてクラウドゲームとクライアントサイドレンダリングの定義を見ると、これらの中間を行く手法であることが分かります。つまり、1 の方法よりもいくらか高い程度のサーバ負荷・通信量で、オフラインゲームと同程度のプログラミングコストという方法 2 の利点を享受することができるという訳です*1。

ところで、クラウドゲームの定義の「すべてがサーバー側で実行され」という文言を見て、何かを思い出す人もいるのではないでしょうか。そう、ポール・グレアムの「普通のやつらの上を行け ---Beating the Averages---」です。

もしあなたが、あなたのサーバー上でだけ走るソフトウェアを書くのなら、 あなたは自分の好むどんな言語でも使えるということだ。 （中略） もしどんな言語でも使えるとなったら、いったい何を使う? 私達はLispを選んだ。

つまりそういうことです。

作ったもの

概要

  • クライアント
  • 通信
    • クライアント自体は静的なHTML, JavaScriptとして配信します
      • なお、HTML はcl-markupを利用して書いています
    • 描画コマンドと入力のやり取りには WebSocket を利用します
    • プロトコルはJSON形式（を文字列化したもの）で定義します
      • 柔軟ですが非常に帯域効率が悪いです。moyaiでは遥かにまともなプロトコルを定義していますが、まあプロトタイプだし...
  • サーバ
    • 上記のクライアント・通信から分かるように、静的コンテンツの配信機能とWebSocket通信機能を持ちます

デモっぽいもの

デモ…というより、動作確認用のサンプルの動かし方とスクリーンショットです。動作確認は Clozure CL 1.11.5 で行っています。

まず、依存ライブラリの1つとライブラリ自身がQuicklisp未登録なのでcloneしてきます。

$ cd <quicklisp が検知できるフォルダ>
$ git clone https://github.com/eshamster/ps-experiment.git
$ git clone https://github.com/eshamster/proto-cl-client-side-rendering.git

次にREPL上でライブラリのロードとサーバの起動を行います。

CL-USER> (ql:register-local-projects) ; ※quickload がライブラリを認識しない場合
CL-USER> (ql:quickload :sample-proto-cl-client-side-rendering)
CL-USER> (sample-proto-cl-client-side-rendering:start :port 5000)

ブラウザから http://localhost:5000/ にアクセスします。

f:id:eshamster:20190506021417g:plain

GIF 中の各種オブジェクトについて：

  • 縦軸中央付近で常に動いている5つの円や矩形は基本的な図形描画の確認用
    • 他の図形も含め、描画指示はサーバから出していて、ブラウザ側はビューアとしてのみ働いています
  • 白い円は入力の確認用
    • GIF 中ではマウスドラッグに追随させています
    • 他にキーボードの矢印入力でも動きます
    • 位置情報はサーバ側で持っているため、ブラウザを更新しても位置が保たれます
  • 右上の青や赤の円はクライアントごとに別の情報を送る確認用
    • クライアントにはサーバ側で連番IDを振っています。そして、偶数番には赤い円を、奇数番には青い円を送付しています。 以上から、ブラウザを更新するとIDが振り直され、表示される情報が変わります
      • GIF中では一度ブラウザを更新していますが、その前後で青丸が赤丸になります
    • …という分かりにくデモです
  • 左上の枠内の文字列・数値はデバッグ情報
    • 1フレーム内にサーバから送付されてきたコマンドの種類と数、さらにその総数を表示しています

なお、動作がカクカクしているのは約2FPSという超低レートにしているためです。さすがにこれが限界値という訳ではなく、現状の動作が不安定な段階では低レートでじっくり見れた方が良いとの判断からです。

もう少し詳細

もう少し詳細な部分として、プロトコル・サーバ処理・クライアント処理について見てみます。

途中でなんのためにこんな詳細を書いているのか分からなくなってきたのですが、ちょっと詳しめのメモぐらいのスタンスで適当に書いていきます。

プロトコル (JSON)

サーバからもしくはクライアントから送られる一つ一つのコマンドは次の形をしています（JSON）。

{
  "kind": ...,  // コマンドの種類を表す (int)
  "frame": ..., // 何フレーム (*) 目かを表す数値 (int) [server to client のみ]
  "no": ...,    // フレーム内での連番 (int)  [server to client のみ]
  "data": {
    ... // コマンドごとの固有の情報 (hash)
  }
}
// (*) ゲームのいわゆる1フレームのこと

kind はこのコマンドが何であるかを示しています。現状定義しているコマンドは protocol.lisp の下記になります。

;; ※ ~.ps+: Common Lisp用とJavaScript (Parenscript) 用の2つの定義を生成する
(defvar.ps+ *code-to-name-table* nil)
(defvar.ps+ *name-to-code-table* nil)

(defun.ps+ initialize-table ()
  (setf *code-to-name-table* (make-hash-table)
        *name-to-code-table* (make-hash-table))
  (dolist (pair '(;  server to client
                  (0 :frame-start)         ; フレームの開始
                  (1 :frame-end)           ; フレームの終了
                  (10 :delete-draw-object) ; 描画オブジェクトの削除
                  (11 :draw-rect)          ; 矩形描画
                  (12 :draw-circle)        ; 円描画
                  (21 :log-console)        ; コンソールログ出力
                  ;; client to server
                  (-1 :key-down)           ; キーボード押す
                  (-2 :key-up)             ; キーボード離す
                  (-11 :mouse-down)        ; マウス押す
                  (-12 :mouse-up)          ; マウス離す
                  (-13 :mouse-move)))      ; マウス動かす
    (let ((code (car pair))
          (name (cadr pair)))
      (setf (gethash code *code-to-name-table*) name
            (gethash name *name-to-code-table*) code))))

若干分かりにくいのは :frame-start と :frame-end かと思いますが、クライアントはこの2つのコマンドの間に来たコマンドを1フレーム内のコマンドとして認識します*3。

何か順序保証などに使えるかなと思って frame や no といったフレームに関する情報をサーバから送っていますが、今のところ使っていません。

個別のデータである data 部分については、サーバから送る例として :draw-rect コマンドを、クライアントから送る例として :mouse-down コマンドを見てみます。

まず、:draw-rect コマンドの data 部分は次のようになります。

  data: {
    "id": ...,    // 描画オブジェクトのID (int)
    "x": ...,     // x 方向の位置 (float)
    "y": ...,     // y 方向の位置 (float)
    "depth": ..., // 描画順序 (float)
    "color": ..., // 色 (int [RGB])
    "fill-p": ... // 図形内部を塗り潰すか (bool)
    "rotate": ... // 矩形の回転 (float [rad])
    "width": ...  // 矩形の幅   (float)
    "height": ... // 矩形の高さ (float)
  }

おおむね見ての通りかと思いますが、id だけ補足します。本ライブラリでは「クラウドゲーム技術」に従い、更新のあった（または新規の）描画オブジェクトの情報のみをクライアントに送信する差分更新を行います。そのため、クライアント側はどの描画オブジェクトを更新すべきかを識別する必要があり、そのときに利用するのが id になります*4。

次に、:mouse-down コマンドです。

  data: {
    "button": ..., // 押されたボタンの種類 (string)
    "x": ...,      // x 方向の位置 (int)
    "y": ...,      // y 方向の位置 (int)
  }

これと言って説明するものもなく見ての通りです。

サーバ処理

サーバ側の処理として、通信処理・描画処理・入力処理周りをみます。これらはライブラリのルートフォルダ上に置いています。

通信処理

各クライアントとのWebSocketの情報は下記の構造体で管理します。

(defstruct client-info
  target-server
  (id (incf *latest-client-id*)))

target-server は、websocket-driver の make-server で作成するWebSocketサーバです。次のようにしてクライアント側へメッセージを送信することができます。

(websocket-driver:send (client-info-target-server hoge) "some message")

実際にそうした処理をしているのが、同 ws-server.lisp 内の send-from-server です。

(defvar *target-client-id-list* :all
  "If ':all', a message is sent to all clients.
Otherwise, it is sent to the listed clients.")

(defun send-from-server (message)
  (dolist (client-info (copy-list *client-info-list*))
    (let ((server (client-info-target-server client-info))
          (id (client-info-id client-info)))
      (case (ready-state server)
        (:open (when (or (eq *target-client-id-list* :all)
                         (find id *target-client-id-list*))
                 (send server message)))
        (:closed (format t "~&Connection closed: ~D" id)
                 (setf *client-info-list* (remove client-info *client-info-list*))
                 (maphash (lambda (key callback)
                            (declare (ignore key))
                            (funcall callback id))
                          *callback-on-disconnecting-table*))
        ;; otherwise do nothing
        ))))

サーバ側でクライアントにメッセージを送りたい場合はこの関数を呼び出します。この関数自体はプロトコルを意識せず単に文字列を送付するだけです。スペシャル変数 *target-client-id-list* が比較的重要で、特定のクライアントのみへのメッセージ送信を実現するためのものです。具体的には次のように使います。

;; ID2番と4番のクライントのみに送付する
(let ((*target-client-id-list* '(2 4)))
  (send-from-server "hoge"))

さて、一方でクライアントからの通信受け付け処理は make-server 後にコールバック関数としてひも付けます。

(defparameter *ws-app*
  (lambda (env)
    (let* ((server (make-server env))
           (client-info (make-client-info :target-server server))
           (client-id (client-info-id client-info)))
      (push client-info *client-info-list*)
      ;; （略）
      (on :message server       ; ← コールバック関数のひも付け
          (lambda (json-string)
            ;; （略）
            ))
      (lambda (responder)
        (declare (ignore responder))
        (format t "~&Connection started: ~D" client-id)
        (start-connection server)))))

ここで定義している *ws-app* がサーバ側でWebSocket通信の開始を受け付ける lack アプリケーションです。ライブラリ外部に対しては、これを組み込んだlackミドルウェアを生成する下記の関数を提供します（middleware.lisp）。

(defun make-client-side-rendering-middleware (&key resource-root)
  ;; クライアントで利用する外部JavaScriptのダウンロード
  (ensure-js-files  (merge-pathnames "js/" resource-root))
  (lambda (app)
    (lambda (env)
      ;; クライアントの実体を生成
      (output-client-js (merge-pathnames "js/client.js" resource-root))
      (let ((uri (getf env :request-uri)))
        (if (string= uri "/ws")
            (funcall *ws-app* env)
            (funcall (make-static-middleware ; "/js/..." に来たらJavaScriptファイルを返す
                      app :resource-root resource-root)
                     env))))))

WebSocket開始の通信を *ws-app* に流す他、クライアントの実体である JavaScript ファイルの生成やその配信も担っています（少々盛り込み過ぎ感）。

使う側は次のような感じです（sample/server.lisp）。

(defvar *ningle-app* (make-instance 'ningle:<app>))

(defun start (&key (port 5000))
  (stop) ; 動いてたら止める
  (start-sample-game-loop)
  (setf *server*
        (clack:clackup
         (lack:builder
          (make-client-side-rendering-middleware
           :resource-root (merge-pathnames
                           "resource/"
                           (asdf:component-pathname
                            (asdf:find-system :sample-proto-cl-client-side-rendering))))
          *ningle-app*)
         :port port)))

HTML 部分の定義が同サンプルファイルの下の方にあるのですが、本来はガワだけ用意してライブラリ側で面倒見るべきだろうなと思っています。

描画処理

プロトコル定義に従ってクライアントに各種コマンドを送信する関数群は protocol.lisp で定義しています。

(defun send-message (kind-name frame index-in-frame data)
  (send-from-server
   (to-json (down-case-keyword `(:kind ,(name-to-code kind-name)
                                 :frame ,frame
                                 :no ,index-in-frame
                                 :data ,data)))))

(defun send-draw-message (kind-name frame index-in-frame data
                          &key id x y depth color)
  (send-message kind-name frame index-in-frame
                `(:id ,id :x ,x :y ,y :depth ,depth :color ,color ,@data)))

(defun send-draw-rect (frame index-in-frame
                       &key id x y depth color fill-p width height rotate)
  (send-draw-message :draw-rect frame index-in-frame
                     `(:fill-p ,(bool-to-number fill-p)
                       :width ,width :height ,height :rotate ,rotate)
                     :id id
                     :x x :y y :depth depth :color color))

send-message は全コマンド共通の関数です。具体的なコマンドの例として、矩形描画用の send-draw-rect 関数（とそれが利用している描画用の共通関数 send-draw-message）を載せています。受け取ったパラメータを所定のJSON形式に変換しているだけです。

:frame（フレーム番号）や :no（フレーム内連番） をライブラリ利用者側に指定させるのも微妙なので、外部に提供する関数は game-loop.lisp で上記のラッパーとして作成しています*5。

(defstruct draw-info sender client-id-list param-table)

(defvar *draw-info-table* (make-hash-table)
  "Key: id, Value: draw-info")
(defvar *prev-draw-info-table* (make-hash-table))

(defun draw-rect (&key id x y depth color fill-p width height rotate)
  (setf (gethash id *draw-info-table*)
        (make-draw-info :sender #'send-draw-rect
                        :param-table (init-table-by-params
                                      id x y depth color fill-p width height rotate)
                        :client-id-list *target-client-id-list*)))

先程 protocol.lisp で定義していた send-draw-rect ですが、直接は呼び出さずいったん *draw-info-table* というテーブルにコマンドの情報を格納しておきます。フレームの終わりに下記の process-all-draw-messages でまとめて送信します。

(defun process-all-draw-messages ()
  (maphash (lambda (id draw-info)
             (let ((*target-client-id-list* (calc-target-client-id-list id)))
               (call-sender-by-param-table
                (draw-info-sender draw-info)
                (draw-info-param-table draw-info))))
           *draw-info-table*)
  ;; （略: 前回フレームにしか存在しない描画オブジェクトの削除コマンドを生成する）
  (switch-draw-info-table))

基本的には *draw-info-table* に格納した情報に従って描画コマンドを送るだけですが、送り先クライアントの指定（*target-client-id-list*）は前フレームの情報を加味して少々いじります。3行目の calc-target-client-id-list がそれで、定義は次の通りです。

(defun calc-target-client-id-list (object-id)
  (let ((info (gethash object-id *draw-info-table*)) ; 今フレームの情報
        (prev-info (gethash object-id *prev-draw-info-table*))) ; 前フレームの情報
    (let ((list-in-info (draw-info-client-id-list info)))
      (cond ;; 1. 新規オブジェクトであれば指定されたクライアントへコマンドを送る
            ((null prev-info) list-in-info)
            ;; 2. 差分がなければ送らない
            ;;    ただし、新たに接続したクライアントが対象に含まれている場合は、
            ;;    それらに対してのみコマンドを送る
            ((same-draw-info-p info prev-info)
             (if *new-client-list*
                 (calc-common-target list-in-info *new-client-list*)
                 nil))
            ;; 3. 差分があれば指定されたクライアントへコマンドへ送る
            (t list-in-info)))))

差分更新を実現するために、コメントに入れたような形でコマンドの送り先を決定しています。

入力処理

クライアントから受け取った入力情報を処理しているのが input.lisp です。さほど書くことがないのでポイントだけ。

  • WebSocketを通して送られてきた入力情報は process-input-message 関数で処理する
  • フレーム途中で情報が変わるのを避けたかったため、同関数はバッファに書き込むだけ
  • フレーム開始時に update-input を呼ぶことで、バッファの情報を参照してライブラリ外に見せる情報を更新する
    • 呼び出しているのは game-loop.lisp 側

ライブラリを使う側は次の例のように入力状態を取得します。

;; Xキーが押された直後（1フレーム）であるかを知りたい
(key-down-now-p :x)
;; エンターキーが押された状態であるかを知りたい
(key-down-p :enter)
;; マウスの位置を知りたい
(multiple-value-bind (x y)
  (get-mouse-pos))

クライアント処理

クライアント側の処理として、サーバと同じく通信処理・描画処理・入力処理周りをみます。これらは clientフォルダ 内で定義しています。また、Lisp として書いていますが、全て JavaScript に変換した上でブラウザへ送付します。

通信処理

WebSocketの定義周りと受信時の処理周りを見ていきます。

まず、WebSocket通信周りは client/socket.lisp で定義しています*6。

短いので全体抜き出します。

;; ソケット作成
(defvar.ps *ws-socket*
    (new (#j.WebSocket# (+ "ws://" window.location.host "/ws"))))

;; メッセージ受信時のコールバック登録
(defun.ps register-socket-on-message (callback)
  (setf *ws-socket*.onmessage
        (lambda (e)
          (funcall callback e.data))))

;; サーバへのメッセージ送信
(defun.ps send-json-to-server (json)
  (*ws-socket*.send ((@ #j.JSON# stringify) json)))

Parenscript では比較的素直な JavaScript コードに変換されるので、おおむね見ての通りだと思います。

次に、受信時の処理、すなわち上記に登録するコールバックを見ます。client/message.lispで定義している process-message 関数が該当のものです。

(defun.ps receiving-to-json (message)
  (#j.JSON.parse# message))

(defun.ps+ process-message (message)
  (let ((parsed-message (receiving-to-json message)))
    (push-message-to-buffer parsed-message)
    (when (target-kind-p :frame-end parsed-message)
      ;; （略: フレーム内に送られてきたコマンドを集計するデバッグ処理）
      (queue-draw-commands-in-buffer)
      (setf *frame-json-buffer* (list)))))

プロトコルの項で説明したように、フレームの開始と終わりはそれぞれ :frame-start コマンドと :frame-end コマンドで示されます。そのため、:frame-end が来るまではバッファにコマンドを溜め込みます（push-message-to-buffer）*7。:frame-end が来た段階でバッファに溜まった描画コマンドをまとめてキューに詰め込み（queue-draw-commands-in-buffer）、バッファをクリアします。

描画用には別途 Three.js のループが回っているため、キューに詰め込まれた描画コマンドはそちらで拾われます。そちらの処理は次の「描画処理」の中で見ていきます。

描画処理

描画処理には大きく2つのパートがあります。

  1. 四角や丸のモデルを生成するプリミティブな関数群
  2. サーバから送られた描画コマンドを解釈して1を呼び出す処理

1の関数群は client/graphics.lisp で定義しています。ジオメトリ（頂点など形状情報）とマテリアル（色など描画情報）を詰め込んだ THREE.Mesh というクラスのインスタンスを返します。これを THREE.scene クラスに add したり remove したりすることで、オブジェクトを描いたり消したりできます。個別の処理については、地道に頂点等の情報を作成しているだけなので詳細略です。

2のエントリポイントとなる部分、すなわち「通信処理」でキューに詰めた情報を取り出しているのは client/core.lisp で定義している update-draw 関数です。

(defun.ps+ update-draw (scene)
  (let ((draw-commands (dequeue-draw-commands)))
    (when draw-commands
      (dolist (command draw-commands)
        (interpret-draw-command scene command)))))

処理の実体である interpret-draw-command 関数は client/message.lisp で定義しています。これは次の add-or-update-mesh 関数を呼び出しているだけなので、こちらを見ていきます。

(defun.ps+ add-or-update-mesh (scene command)
  (let* ((kind (code-to-name (gethash :kind command)))
         (data (gethash :data command))
         (id (gethash :id data))
         (prev-info (gethash id *draw-info-table*)))
    (cond ((eq kind :delete-draw-object) ; delete
           (remhash id *draw-info-table*)
           (remove-mesh-from-scene scene (draw-info-mesh prev-info)))
          ((null prev-info) ; add
           (let* ((mesh (make-mesh-by-command command)))
             (setf (gethash id *draw-info-table*)
                   (make-draw-info :kind kind
                                   :data data
                                   :mesh mesh))
             (add-mesh-to-scene scene mesh)))
          ((should-recreate-p prev-info kind data) ; recreate
           (remhash id *draw-info-table*)
           (remove-mesh-from-scene scene (draw-info-mesh prev-info))
           (add-or-update-mesh scene command))
          (t ; simple update
           (update-common-mesh-params
            (draw-info-mesh prev-info) data)
           (setf (draw-info-data prev-info) data)))))

2つほどポイントがありますが、1つは差分更新を行うための現在の描画情報の管理です。これは下記のように定義した *draw-info-table* というハッシュテーブル上に載せています。

(defstruct.ps+ draw-info
  kind ; :draw-rect/:draw-circle
  data ; 描画コマンド
  mesh ; THREE.Mesh
)

(defvar.ps+ *draw-info-table* (make-hash-table)
  "Key: id, Value: draw-info")

なお、サーバ側でもこうしたフレーム間比較のための情報を持っていましたが、そちらでは今フレームと前フレームの情報を管理するため2枚のテーブルでした。一方こちらは、（送られてきたコマンドそのものが今フレームの情報であるため）1枚のテーブルを直接書き換える形を取っています。

もう1つのポイントとなるのは Three.js のアーキテクチャに依存した（ちょっとした）最適化です。ここで、add-or-update-mesh の cond 内部を見ると "delete", "add", "recreate", "simple update" の4つの処理があります。前者2つは見たままですが、後者2つの区別が該当の最適化になります。Three.js では一度 add したメッシュについては、位置や角度*8の更新だけであれば、単純に値を更新すれば反映してくれます。これが "simple update" です。それ以外の、例えば頂点情報の更新などはもう一手間あるため、楽をして再作成をしています。これが "recreate" です。

入力処理

入力処理については、サーバと同じでそれほど見所はありません。基本的には各種入力イベントに反応してサーバへ入力情報を送信するだけです。

一応、例としてマウス関連のコマンドの送信部分を見てみます。入力系はマウス関連含め、client/input.lisp で定義しています。

(defun.ps send-mouse-message (kind e)
  (multiple-value-bind (x y)
      (calc-adjusted-input-point e.client-x e.client-y))
  (send-json-to-server (ps:create :kind (name-to-code kind)
                                  :data (ps:create
                                         :button (mouse-button-to-string e.button)
                                         :x x
                                         :y y))))

入力位置補正のための calc-adjusted-input-point の中身がちょっと汚かったりするのですが目をつむります。

足りないもの

色々足りないのですが、思い付くもので比較的大きめのものを順不同に。

フレームレートの高速化・安定化

デモの所で書いたように、現状 2FPS というひどいフレームレートで動作しています。このため、60FPS（か30FPS）で安定動作させる必要があります。

クライアント側は既に60FPSで回っているので、サーバ側の sleep 処理をいじるだけといえばそれだけです。が、昔 C# + Windows Forms なゲームライブラリを作ってフレームレートの安定化に苦労した記憶があるので中々腰が上がりにくく…。

また、現状クライアント側は描画コマンドキューにいくらでも溜め込むようになっているので、これを避ける必要があります。定常的な動作については、多少溜まってもキューがなくなるまでコマンドを処理をしてから描画、とすれば（時々カクつくぐらいで）問題なさそうです。ただ、デバッガで描画ループを止めた場合などはすごい勢いで溜まっていくので、一定以上溜まった場合はキューの中身を破棄して全体再送するようにサーバに要求する必要があると思います。もしくは、破棄した上で接続を打ち切り、リロードしてくださいでも実用上問題ないかもしれません。

なんにせよ必須ではあるのでどこかでやります。

サーバ側からクライアントの初期化パラメータを指定する

現状スクリーンのサイズを横800・縦600（論理的なサイズ。実サイズはブラウザの画面サイズに応じてスケールしています）で決め打ちにしていますが、サーバ側からこれを指定できるようにする必要があります。

洗い出してませんが他にもサーバから指定すべきパラメータはありそうです。

ドローコールの削減

現状描画オブジェクトごとに単に一つのMeshを作成して add しているため、描画オブジェクトごとにドローコールがなされてしまいます。今後描画オブジェクトが増えると致命的にパフォーマンスに影響してくるため、可能な限り少ないドローコールで済むように改善が必要です。

クライアントごとのカメラの管理・移動

現状、左下座標が(0,0)、右上座標が(800, 600)になる位置でカメラを固定していますが、「クラウドゲーム技術」に従い、位置や縮尺をクライアントごとに移動できるようにする必要があります。それができてからの話ですが、カメラ外にある描画オブジェクトのコマンドを送信しないというカリング処理も必要になってきます。

中継 (レプリケーション) サーバ

「クラウドゲーム技術」ではサーバとクライアントの間に、描画コマンドを受け取って（複数の）クライアントに情報を配信するだけのレプリケーションサーバが記述されています。サーバ側のカリング処理などが軽くなり、許容クライアント数を大幅に増やすことができます。

とはいえ、そこまで大規模化する展望はまだないので優先度は低いです。

ログ用クライアントとリプレイ

これも「クラウドゲーム技術」に記載の内容ですが、クライアントに送信する描画コマンドをライブラリ側で全て把握していることから、描画コマンドを保管しておくことでリプレイ機能を容易に実現できるという嬉しい性質があります。

単一のクライアントのリプレイだけであれば、クライアントと全く同じ情報を保管しておけば十分そうです。ただ、任意のクライアントのリプレイを実現するためには、どのクライアントに向けたコマンドであるかも同時に保管しておく必要がありそうです。

ゲーム用ライブラリのガワを被せる

作成したライブラリはゲームライブラリというより描画・入力ライブラリなので、実際にゲームを書くにはもう一層ライブラリを被せる必要があります。

これには、以前作った（現在も作りつつある）cl-web-2d-game を移植すればベースは簡単にできるのではと思ってます。同ライブラリはブラウザ側で全てのロジックを処理する前提で書いたものですが、描画・入力周りを除いた結構な部分は Common Lisp, JavaScript 共通で動作するコードとして書いているためです。

認証機能

現状つなぎ直した場合にクライアントの同一性を確認する手段がないので、認証機能、というよりは他の認証機能と連携できるような機能が必要になりそうです。この辺全然考えられていません。

続きの記事

eshamster.hatenablog.com

*1:冗長になるので本文からは省きましたが、クライアント側の（主にGPUの）負荷は専用クライアント方式と同程度に高くなります

*2:lack のミドルウェアについては、以前簡単に紹介したことがあるので見てみると参考になる…かもしれません → Common Lispでホットローディングを試しに作る (2) 実装について。ちなみに、今回作ったライブラリはその記事で実装した cl-hot-loads を下敷にしていたりします

*3:フレームの区切りについてはサーバ側に責任があるので、クライアントから送るコマンド（= 入力系）については、フレームの区切りを意識せずに単純に送るだけです

*4:なお、差分更新をしない場合は、毎フレーム全ての描画オブジェクトを削除して全部描き直すだけなので、idは不要です

*5:game-loop.lisp に置くのは適切でない気はしていますが…

*6:ここを含め、全体的にクライアント側とサーバ側でファイル命名の一貫性が弱いのでどこかで直したいなと思いつつ

*7:半端な描画を防ぐため、本来は:frame-startの方も考慮すべきですが現状さぼってます

*8:他にもありますが、ここで見ているのはそれだけです

LISP: '$e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E

プログラミング Lisp Common Lisp

ひたすら「e」が並んでいるだけのリポジトリが話題になってました。

github.com

Lispはどうかと見てみると、シンプルに無限ループで面白いというのが初見の感想でした。

e.lisp

(loop (print "e"))

しかし、ここでC言語の実装を見てみると何やら面白いことをしているではありませんか。

e.c

#include <stdio.h>
#define e "e"
#define ee int
#define eee main
#define eeee (
#define eeeee )
#define eeeeee {
#define eeeeeee }
#define eeeeeeee for
#define eeeeeeeee ;
#define eeeeeeeeee printf
#define eeeeeeeeeee return
#define eeeeeeeeeeee on_exit
#define eeeeeeeeeeeee [
#define eeeeeeeeeeeeee ]
#define eeeeeeeeeeeeeee 0

ee eee eeee eeeee eeeeee eeeeeeee eeee eeeeeeeee
eeeeeeeee eeeee eeeeee eeeeeeeeee eeee e eeeee
eeeeeeeee eeeeeee eeeeeee ee eeeeeeeeeeee eeee
eeeee eeeeee eeeeeeeeeee e eeeeeeeeeeeee
eeeeeeeeeeeeeee eeeeeeeeeeeeee eeeeeeeee eeeeeee

これを見ていると、Cでこんな頑張っているのになんだあのLispは、エイリアン分が足りないのではないかという気分になってきました。

ということで書き換えてみました。(loop (print "e"))と等価なコードです。

(make-dispatch-macro-character #\$)

(set-dispatch-macro-character
 #\$ #\e
 (lambda (stream &rest rest)
   (declare (ignore rest))
   (let ((count 0)
         (char-list nil))
     (do ((char #1=(read-char stream) #1#))
         ((eq char #\E)
          (intern (coerce (nreverse char-list) 'string)))
       (case char
         (#\  (when (> count 0)
                (push (code-char (+ count (char-code #\0)))
                      char-list)
                (setf count 0)))
         (#\e (incf count)))))))

($e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E
  ($e eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E "e"))

そうリーダーマクロです。$e～Eまでが1つのシンボルに対応します。下の例を見るのが分かり易いと思いますが、スペース区切りで連続した「e」の個数を数えて、個数に応じたASCII文字に変換するという単純なアイディアです。なお、文字コードの「0」= 48個上乗せはうっとうしいので、「0」をオフセットにしています。

eeeeeeeeeeeeeeeeeeeeeeeeeeee     → eが28個 → '0' + 28 → 'L'
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee  → eが31個 → '0' + 31 → 'O'
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee  → eが31個 → '0' + 31 → 'O'
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee → eが32個 → '0' + 32 → 'P'
↓
LOOP

カッコも「e」にしてしまいたいところですが、面倒なのでそれは置いておき…

'$a 工工エェェ(ﾟДﾟ)ェ工 工工エェ(ﾟДﾟ)工 工ェ(ﾟДﾟ)工 工工ェェ(ﾟДﾟ)ェ工 工エェ(ﾟДﾟ)工 A

おまけです。

さて、日本語で「e」=「え」が沢山並ぶものというと、個人的にはまず次のAAが思い浮かびます。

工工工ｴｴｴｴｴｴｪｪｪｪｪｪ(ﾟДﾟ)ｪｪｪｪｪｪｴｴｴｴｴｴ工工工

これを活用してみます。やることは単純で、上記の「e」で1ずつカウントしていたものを、次のようなカウント方式に変更するだけです。

  • 「(ﾟДﾟ)」: 48個分 (※48 = '0')
  • 「工」: 8個分
  • 「エ」: 4個分
  • 「ェ」: 1個分
(make-dispatch-macro-character #\$)

(defun integer-string-p (str)
  (multiple-value-bind (parsed count)
      (parse-integer str :junk-allowed t)
    (and parsed (= (length str) count))))

;; ※ついでに数値も扱えるようにしておく
(defun my-intern (str)
  (if (integer-string-p str)
      (parse-integer str)
      (intern str)))

(set-dispatch-macro-character
 #\$ #\a
 (lambda (stream &rest rest)
   (declare (ignore rest))
   (let ((count 0)
         (char-list nil))
     (do ((char #1= (read-char stream) #1#))
         ((eq char #\A)
          (my-intern (coerce (nreverse char-list) 'string)))
       (case char
         (#\  (when (> count 0)
                (push (code-char count)
                      char-list)
                (setf count 0)))
         (#\( (if (and (eq (read-char stream) #\ﾟ)
                       (eq (read-char stream) #\Д)
                       (eq (read-char stream) #\ﾟ)
                       (eq (read-char stream) #\) ))
                  (incf count 48)
                  (error "Not allowed AA")))
         (#\工 (incf count 8))
         (#\エ (incf count 4))
         (#\ェ (incf count 1)))))))

このリーダーマクロを利用することで、(loop (print "e"))は次のように書けます。…文字列の扱いはちょっとサボってます。

($a 工工エ(ﾟДﾟ)工 工工エェェ(ﾟДﾟ)ェ工 工工エェェ(ﾟДﾟ)ェ工 工工(ﾟДﾟ)工工 A
  ($a 工工(ﾟДﾟ)工工 工工ェ(ﾟДﾟ)ェ工工 工工ェ(ﾟДﾟ)工 工工エェ(ﾟДﾟ)ェ工 工工エ(ﾟДﾟ)工工 A "e"))

せっかくなので、あの有名な再帰関数を書いてみます。

($a 工エ(ﾟДﾟ)工 工エェ(ﾟДﾟ)工 工エェ(ﾟДﾟ)ェ工 工工エェ(ﾟДﾟ)工工 工工エェ(ﾟДﾟ)ェ工 A $a 工エェ(ﾟДﾟ)ェ工 工工ェ(ﾟДﾟ)工 工ェ(ﾟДﾟ)ェ工 A
    ($a 工工エェ(ﾟДﾟ)ェ工 A )
  ($a 工ェェ(ﾟДﾟ)ェ工 工ェ(ﾟДﾟ)工 工工ェェ(ﾟДﾟ)ェ工工 工エェ(ﾟДﾟ)工 A
      $a 工工エェ(ﾟДﾟ)ェ工 A
    ($a (ﾟДﾟ) A $a (ﾟДﾟ) A )
    (($a ェ(ﾟДﾟ) A $a ェ(ﾟДﾟ)ェ A )$a ェ(ﾟДﾟ) A )
    ($a 工工エ(ﾟДﾟ)工工 A
      ($a 工工工ェェェ工工 A ($a 工エェ(ﾟДﾟ)ェ工 工工ェ(ﾟДﾟ)工 工ェ(ﾟДﾟ)ェ工 A
                             ($a 工工工エェ工工 A $a 工工エェ(ﾟДﾟ)ェ工 A $a ェ(ﾟДﾟ) A ))
                           ($a 工エェ(ﾟДﾟ)ェ工 工工ェ(ﾟДﾟ)工 工ェ(ﾟДﾟ)ェ工 A
                             ($a 工工工エェ工工 A $a 工工エェ(ﾟДﾟ)ェ工 A $a ェ(ﾟДﾟ)ェ A ))))))

動かしてみます。

CL-USER> ($a 工エ(ﾟДﾟ)工 工工エェェ(ﾟДﾟ)ェ工 工工エ(ﾟДﾟ)工工 工工ェ(ﾟДﾟ)工 工工エェ(ﾟДﾟ)工 工エェ(ﾟДﾟ)工 工工ェェ(ﾟДﾟ)ェ工工 A ($a 工工ェ(ﾟДﾟ)工 A $a ェ(ﾟДﾟ) (ﾟДﾟ) A )
             ($a 工工(ﾟДﾟ)工工 工工ェ(ﾟДﾟ)ェ工工 工工ェ(ﾟДﾟ)工 工工エェ(ﾟДﾟ)ェ工 工工エ(ﾟДﾟ)工工 A
                 ($a 工エェ(ﾟДﾟ)ェ工 工工ェ(ﾟДﾟ)工 工ェ(ﾟДﾟ)ェ工 A $a 工工ェ(ﾟДﾟ)工 A )))

0
1
1
2
3
5
8
13
21
34
NIL

そうフィボナッチ関数です。

;; インデント合わせ版
(defun fib
    (n)
  (case n
    (0 0)
    ((1 2) 1)
    (t
     (+ (fib
         (- n 1))
        (fib
         (- n 2))))))

;; 普通にインデント版
(defun fib (n)
  (case n
    (0 0)
    ((1 2) 1)
    (t (+ (fib (- n 1))
          (fib (- n 2))))))

なお、動作確認は次のように行いました。

(dotimes (i 10)
  (print
    (fib i)))

'$a 工工(ﾟДﾟ)工 工工エェェ(ﾟДﾟ)ェ工 工工ェェ(ﾟДﾟ)ェ工工 工工エェェ(ﾟДﾟ)ェ工 工工ェェ(ﾟДﾟ)ェ工 工工エェ(ﾟДﾟ)工工 A

補足です。

さすがに手で書きくだすのは辛いので、次のような convert-tree-to-aa 関数を書いて変換しています。1行目がprincの出力ですので、これをコピペします。

CL-USER> (convert-tree-to-aa '(loop (print "e")))
($a 工工エ(ﾟДﾟ)工 工工エェェ(ﾟДﾟ)ェ工 工工エェェ(ﾟДﾟ)ェ工 工工(ﾟДﾟ)工工 A ($a 工工(ﾟДﾟ)工工 工工ェ(ﾟДﾟ)ェ工工 工工ェ(ﾟДﾟ)工 工工エェ(ﾟДﾟ)ェ工 工工エ(ﾟДﾟ)工工 A "e"))
"($a 工工エ(ﾟДﾟ)工 工工エェェ(ﾟДﾟ)ェ工 工工エェェ(ﾟДﾟ)ェ工 工工(ﾟДﾟ)工工 A ($a 工工(ﾟДﾟ)工工 工工ェ(ﾟДﾟ)ェ工工 工工ェ(ﾟДﾟ)工 工工エェ(ﾟДﾟ)ェ工 工工エ(ﾟДﾟ)工工 A \"e\"))"

一応同関数の実装です。

(ql:quickload :alexandria)

(defun multi-mod (value mod-list)
  "各パーツがどれだけ必要かを計算する"
  ;; (multi-mod 9 '(2 1)) -> (4 1) :: 9 -> 4 * 2 + 1 * 1
  (labels ((rec (rest-value rest-mod-list result)
             (if rest-mod-list
                 (let ((modular (car rest-mod-list)))
                   (rec (mod rest-value modular)
                        (cdr rest-mod-list)
                        (cons (floor (/ rest-value modular)) result)))
                 (values (nreverse result) rest-value))))
    (rec value (sort mod-list #'>) nil)))

(defun concat-string-list (str-list)
  (apply #'concatenate `(string ,@str-list)))

(defun sort-string (str-list count-list)
  "必要個数に応じてパーツを良い感じに並べる"
  ;; (sort-string '("Z" "a") '(4 2)) -> ("Z" "Z" "a" "a" "Z" "Z")
  (assert (= (length str-list) (length count-list)))
  (let ((split-count-list
         (mapcar (lambda (count)
                   (cons (ceiling (/ count 2))
                         (floor (/ count 2))))
                 count-list)))
    (flet ((collect-string (target-str-list place)
             (apply #'append
                    (loop
                       :for str :in target-str-list
                       :for count :in (mapcar place split-count-list)
                       :collect (loop :for i :from 0 :below count
                                   :collect str)))))
      (concat-string-list
       (append (collect-string str-list #'car)
               (reverse (collect-string str-list #'cdr)))))))

(defvar *mod-list* '(48 8 4 1))

(defun convert-to-aa (str)
  "文字列をAAに変換する"
  ;; (convert-to-aa "012") -> "(ﾟДﾟ) ェ(ﾟДﾟ) ェ(ﾟДﾟ)ェ "
  (format nil "~{~A ~}"
          (mapcar (lambda (count-list)
                    (sort-string '("工" "エ" "ェ" "(ﾟДﾟ)")
                                 count-list))
                  (mapcar (lambda (char)
                            (alexandria:rotate (multi-mod (char-code char) *mod-list*)
                                               -1))
                          (coerce str 'list)))))

(defun convert-tree-to-aa (form)
  "完成品: 木をたどって（文字列以外の）全ての要素をAA化する"
  (labels ((rec (rest-form)
             (if (listp rest-form)
                 (format nil "(~{~A~})"
                         (mapcar (lambda (form)
                                   (rec form))
                                 rest-form))
                 (typecase rest-form
                   (string (format nil "\"~A\"" rest-form))
                   (t (format nil "$a ~AA "
                              (convert-to-aa (write-to-string rest-form))))))))
    (princ (rec form))))

'$a 工工エェェ(ﾟДﾟ)ェ工 工工エェェ(ﾟДﾟ)ェ工工 工ェ(ﾟДﾟ)工 工工ェ(ﾟДﾟ)ェ工工 工工ェ(ﾟДﾟ)工 A

多重ディスパッチの実装 on Parenscript

Lisp Lisp-Parenscript プログラミング

lisp Advent Calendar 201810日目の記事です。

今年はCommon LispサブセットをJavaScriptに変換するParenscript + three.js な2Dゲームライブラリ（もどき）のcl-web-2d-gameが育ってきたので、テトリスを作ってみたりブロック崩しを作ってみたりして遊んでいました。コンポーネントベースであることもあり、この範囲では特に型ディスパッチが必要になることはありませんでした。

が、A*アルゴリズムを作ったりして遊んでいると、ナビゲーションメッシュ部分を抽象化してみたくなりました。とすると型によるディスパッチが必要になるので、defgeneric, defmethodのサブセットという形で多重ディスパッチを実装することにしました。これは、cl-web-2d-gameの基盤にもなっている、Parenscriptの独自拡張ps-experiment上に実装します。

なお、Parenscript用のCLOSのサブセット実装としてPSOSがあるのですが、今回欲しいのは多重ディスパッチ部分だけだったことと、なんとなく面白そうだったので自前実装しました。

実装しないもの

今回実装するものはdefgenerc, defmethodのサブセットも良いところなので足りないものは多々ありますが、代表的なものは次のあたりでしょうか。

  • generic function未定義時にdefmethodしたときのデフォルト定義
  • eql によるディスパッチ
    • 言い換えると型によるディスパッチしかできません
  • fmakunbound
  • メソッドコンビネーション
    • standardについても:before, :after, :around はありません……

余談ですが、できたらメソッドコンビネーションも実装してみようかと define-method-combination について調べていた副産物が Lisp メソッドコンビネーション Advent Calender 2018の3日目の記事（define-method-combinationを理解する）でした。が、利用する見込みもないのに実装するには少々重いことが分かったため頓挫しました。決して Besiegeにハマっている内にどうでも良くなってきた訳ではないのです。

なお、仕様の全体は一応ps-experimentのREADMEに記載しています。

前提：ps-experiment

今回、Parenscript上にdefmethodのサブセットを起こしていくということで、マクロとして実装する部分はCommon Lispとして、実行時に動作する部分はParenscript (JavaScript) として実装していくことになります。後者の実装にはParenscriptをラップして勝手に色々拡張しているps-experiment *1 を利用します（今回の多重ディスパッチ自体もこのライブラリ内に実装します）。

github.com

今回主に使うのはJavaScript関数を定義する defun.ps+ 程度なので、簡単に使用例を見てみます。

基本的には下記のように、普通のdefunのような感覚で関数を定義したりexportしたりできます。

CL-USER> (use-package :ps-experiment)
T
CL-USER> (defun.ps+ func1 (a b)
           (+ a b))
FUNC1
CL-USER> (defun.ps+ func2 (a)
           (+ a 100))
FUNC2
CL-USER> (export 'func2)
T

これをJavaScriptコードとして書き出すのが、with-use-ps-packというさえない名前のマクロです。これは、第一引数に渡されたパッケージ（群）を起点に依存パッケージを含めてJavaScriptコードを書き出します。第2引数以降 = form部分に受け取ったものはトップレベルで実行する処理として書き出します。

次のように、先程定義したfunc1やfunc2が書き出され、func2がエクスポートされていることが分かります*2。

CL-USER> (with-use-ps-pack (:this) ; :this は *package* のエイリアス
           (func2 200))
var commonLispUser = (function() {
  /* --- import symbols --- */

  /* --- define objects --- */
  function func1(a, b) {
      return a + b;
  };
  function func2(a) {
      return a + 100;
  };
  function __psMainFunc__() {
      return func2(200);
  };
  /* --- extern symbols --- */
  return {
    'func2': func2,
    '_internal': {
      'func1': func1,
      '__psMainFunc__': __psMainFunc__,
    }
  };
})();

commonLispUser._internal.__psMainFunc__();"

REPL上で簡単に動作確認をしたい場合、cl-javascript (cl-js)が利用できます。cl-js:run-js関数にJavaScriptコードを渡すことで実行してくれるため、下記のようなjst *3 マクロを定義しておくことで、サクッとREPL上でお試しすることができます。

CL-USER> (defmacro jst (&body body)
           `(cl-js:run-js (with-use-ps-pack (:this) ,@body)))
JST
CL-USER> (jst (func2 20))
120

最後に細かい点ですが、以降ではdefun.ps, defun.ps+と似たような名前のマクロを使い分けています。前者はJavaScript関数のみを、後者はそれに加えてCommon Lisp関数を書き出します。今回両者で共通利用する関数はないのですが、後者であればCommon Lispコンパイラの恩恵（関数の引数違いの警告など）を得られるため、可能な限り後者を利用します。なお、厳密に言うとdefun.psは実装が空でシグネチャが同じCommon Lisp関数も書き出すので、defun.psで定義した関数はdefun.ps+内で利用しても警告なしにコンパイルできます（実行したら勿論エラーですが…）。空関数の定義も避けたい場合はdefun.ps-onlyを利用します。後ろでも少し使います。

実装

基本的なアイディア（データ構造）

後ろに細々と実装が続きますが、基本的なアイディアは単純です。

主要なデータ構造は次のものになります（defstruct.ps+とdefvar.ps+もps-experimentの持ちものですが、名前から動作は推測できると思います）。

(defstruct.ps+ dispatch-item type-list func)

(defvar.ps+ *dispatch-list-table* (make-hash-table)
  "Key: method name, Value: sorted list of dispatch-item")

*dispatch-list-table* には、メソッドごとに dispatch-item のリストを格納します。このdispatch-itemはdefmethodごとに生成されます。例えば次のような定義に対しては、type-listには(type-a nil)が格納され、func には関数の実体（単純化すると(lambda (a b) (print a) (print b))）が格納されます。

(defmethod.ps+ test ((a type-a) b)
  (print a)
  (print b))

これを踏まえて、今回実装するdefgenericとdefmethodの役割は次のようになります。

  • defgeneric
    • *dispatch-list-table* へメソッド名をキーとして空のリストを追加する
    • メソッド名と同名の関数をdefunする
      • この関数内では、dispatch-itemのリストから適用可能な関数を探して呼び出す
  • defmethod
    • dispatch-itemを作成し *dispatch-list-table*内からメソッド名で探したリストに格納する
      • type-listを生成し、よりspecificな型のものが手前に来るようにソートして格納する
        • 動的に型の上下関係が変わるケースを想定すると事前ソートはNGだが、そのケースは考えない
      • funcにはdefmethodで指定した処理をlambda関数にして詰め込む。この際、下記2つのローカル関数を付け加える

ゴール

先にdefgeneric, defmethod自体の実装を見てしまいます。実装に必要な補助関数群は後ろでチクチク見ていきます。

defgeneric

実装

defgeneric.psやdefgeneric.ps+の実体となる defgeneric.ps-onlyは、「基本的なアイディア」の項で述べたものを実装していきます。

(defstruct defgeneric-options (documentation ""))

(defmacro defgeneric.ps-only (function-name gf-lambda-list &rest options)
  (let ((opt (parse-defgeneric-options options))
        (call-list (convert-gf-lambda-list-to-call-list gf-lambda-list)))
    `(progn
       (def-top-level-form.ps ,(symbolicate '_defgeneric_form_ function-name)
         ;; -- *dispatch-list-table*へ空のリストを追加 --
         (setf (gethash ,(make-table-key function-name) *dispatch-list-table*)
               (list)))
       ;; -- メソッド名と同名の関数を定義 --
       (defun.ps-only ,function-name ,gf-lambda-list
         ,(defgeneric-options-documentation opt)
         ;; -- 最もspecificなメソッドを呼び出す --
         ,(call-next-method% :function-name function-name
                             :lambda-list gf-lambda-list
                             :call-list call-list
                             :start-func-index 0)))))

さほど見るべき所もないのですが、メソッドコンビネーションがないのを良いことに、最もspecificなメソッドを呼び出すだけにしているのが特徴と言えば特徴でしょうか。

寄り道ですがdef-top-level-form.psの補足です。ps-experimentでは各種defineが評価されたときに定義を格納する（格納したものをwith-use-ps-packで書き出す）形を取っているため、トップレベルのフォームをParenscriptコードとして認識すことができません。そのため、トップレベルのフォームを定義するための専用のdefineを用意するという苦肉の策に出ています。しかも、再評価時に上書きして良いかを判断するために、第1引数に識別子となるシンボルを渡している辺りがさらに冴えない感じです。

さて、このdefgeneric.ps-onlyを使って、主なインタフェースとなるdefgeneric.psとdefgeneric.ps+を次のように実装します。前者はCommon Lispとしてはいわゆる宣言だけを行うためのものですが、defgenericは定義（form）部分を持たないので後者と全く同じ形になります。

(defmacro defgeneric.ps (function-name gf-lambda-list &rest options)
  `(progn (defgeneric.ps-only ,function-name ,gf-lambda-list ,@options)
          (defgeneric ,function-name ,gf-lambda-list ,@options)))

(defmacro defgeneric.ps+ (function-name gf-lambda-list &rest options)
  `(defgeneric.ps ,function-name ,gf-lambda-list ,@options))

展開してみる

展開形も見てみます。

(defgeneric.ps-only some-method (a b)
  (:documentation "This is a sample method"))

まずはこれが次のようにマクロ展開されて…

(progn (def-top-level-form.ps _defgeneric_form_some-method
         (setf (gethash "COMMON-LISP-USER::SOME-METHOD"
                        ps-experiment/defines/defmethod::*dispatch-list-table*)
               (list)))
       (defun.ps-only some-method (a b)
         "This is a sample method"
         (let* ((ps-experiment/defines/defmethod::table-key
                 "COMMON-LISP-USER::SOME-METHOD")
                (ps-experiment/defines/defmethod::func-index
                 (let ((ps-experiment/defines/defmethod::table-key
                        "COMMON-LISP-USER::SOME-METHOD"))
                   (ps-experiment/defines/defmethod::find-dispatch-func-index
                     ps-experiment/defines/defmethod::table-key
                     (list a b)
                     :from 0
                     :if-does-not-exist :error))))
           (funcall (funcall (ps-experiment/defines/defmethod::get-dispatch-func
                               ps-experiment/defines/defmethod::table-key
                               ps-experiment/defines/defmethod::func-index)
                             ps-experiment/defines/defmethod::func-index)
                    a b))))

次のようなJavaScriptコードになります。

  psExperiment_defines_defmethod._internal.DISPATCHLISTTABLE['COMMON-LISP-USER::SOME-METHOD'] = [];
  /** This is a sample method */
  function someMethod(a, b) {
      var tableKey69;
      var tableKey = 'COMMON-LISP-USER::SOME-METHOD';
      var funcIndex = (tableKey69 = 'COMMON-LISP-USER::SOME-METHOD',
                       psExperiment_defines_defmethod._internal.findDispatchFuncIndex(
                         tableKey69, [a, b],
                         'from', 0,
                         'if-does-not-exist', 'error'));
      return psExperiment_defines_defmethod._internal.getDispatchFunc(tableKey, funcIndex)(funcIndex)(a, b);
  };

defmethod

実装

defmethod.ps-onlyについても、同様に「基本的なアイディア」で述べたものを実装します。

(defmacro defmethod.ps-only (function-name specialized-lambda-list &body body)
  (let* (; dispatch-item-type-list = dispatch-types の生成
         (dispatch-types (extract-dispatch-types specialized-lambda-list))
         (lambda-list (convert-specialized-lambda-list-to-lambda-list
                       specialized-lambda-list))
         (call-list (convert-gf-lambda-list-to-call-list lambda-list))
         (table-key (make-table-key function-name))
         (dispatch-func-index (gensym)))
    `(def-top-level-form.ps ,(symbolicate '_defmethod_form_ function-name
                                          (format nil "_(~{~A~^ ~})" dispatch-types))
       ;; dispatch-itemをリストへ追加する（内部でspecificな順にソート）
       (push-dispatch-func
        ,table-key
        ',dispatch-types
        ;; 外側のlambda: 関数のインデックスを保管（これがdispatch-item-funcの実体）
        (lambda (,dispatch-func-index)
          ,(flet ((declare-p (line)
                    (and (listp line)
                         (eq (car line) 'declare))))
             ;; 内側のlambda: 処理の実体
             `(lambda ,lambda-list
                ;; declare部の取り出し
                ,@(loop :for line :in body
                     :until (not (declare-p line)) :collect line)
                ;; 内部関数としてcall-next-method, next-method-pを実装
                (flet ((call-next-method ,lambda-list
                         ,(call-next-method% :function-name function-name
                                             :lambda-list lambda-list
                                             :call-list call-list
                                             :start-func-index `(1+ ,dispatch-func-index)))
                       (next-method-p ()
                         (not (null ,(find-dispatch-func-index%
                                      :function-name function-name
                                      :lambda-list lambda-list
                                      :start-func-index `(1+ ,dispatch-func-index)
                                      :if-does-not-exist nil)))))
                  ;; 本来の処理の実体 (declareは取り除く)
                  ,@(member-if (lambda (line)
                                 (not (declare-p line)))
                               body)))))))))

主にcall-next-methodやnext-method-pの実装のためにやたら長ったらしいです。

ソース中に入れたコメントで概ね雰囲気は掴めるかと思いますが、push-dispatch-func へ渡している関数が二重lambdaになっている点が少々特徴的な部分でしょうか。前述のように、メソッドごとにdispatch-itemがspecificな順にソートされてリストに入っている訳ですが、call-next-methodで次のメソッドを呼び出すためには自身が何番目の要素であるかを知っている必要があります。ということで、外側のlambdaではdispatch-func-indexとして自身が何番目の要素であるかを受け取ります。なお、通常のLispであればリストのcdr部を取っておきたい所ですが、リストはJavaScriptの配列に変換されることを意識してインデックスを利用しています。

内側のlambdaが実際に外から引数を受け取って呼び出される処理の実体です。ここでローカル関数としてcall-next-methodとnext-method-pを実装しています。どちらもstart-func-indexを起点に次のメソッドを探すため、両方を呼ぶと探索が二回走ります。が、next-method-pなんてそんな使わんだろうと思って妥協しています…。

他にそれほど特徴らしいところもありませんが、冒頭のlet*内でspecialized-lambda-listをあれこれパースしている部分の例を見てみます。

例. specialized-lambda-form: (a (b type-b) &key (c 100))
-> 
dispatch-types: (nil type-b)
lambda-list   : (a b &key (c 100))
call-list     : (a b :c c)

このdefmethod.ps-onlyを使って、主なインタフェースとなるdefmethod.psとdefmethod.ps+を次のように実装します。前者では空のCommon Lispメソッドを実装するためにignore宣言を入れたりエラーを入れたりで少々長くなっています。

(defmacro defmethod.ps (function-name specialized-lambda-list &body body)
  (let ((args (mapcar (lambda (elem)
                        (if (listp elem) (car elem) elem))
                      specialized-lambda-list)))
    `(progn (defmethod.ps-only ,function-name ,specialized-lambda-list ,@body)
            (defmethod ,function-name ,specialized-lambda-list
              (declare ,(cons 'ignore
                              (extract-arg-names args)))
              (error (format nil "~A for ~A is only defined but not implemented as a CL method"
                             ',function-name
                             ',(extract-dispatch-types specialized-lambda-list)))))))

(defmacro defmethod.ps+ (function-name specialized-lambda-list &body body)
  `(progn (defmethod.ps-only ,function-name ,specialized-lambda-list ,@body)
          (defmethod ,function-name ,specialized-lambda-list ,@body)))

展開してみる

こちらも展開形を見てみます。

(defmethod.ps-only some-method ((a type-a) b)
  (compute-something a b))

まずはこれが次のようにマクロ展開されて…

(def-top-level-form.ps _defmethod_form_some-method_\(type-a\ nil\)
  (ps-experiment/defines/defmethod::push-dispatch-func
    "COMMON-LISP-USER::SOME-METHOD"
    '(type-a nil)
    (lambda (#:g1262)
      (lambda (a b)
        (flet ((call-next-method (a b)
                 (let* ((ps-experiment/defines/defmethod::table-key
                         "COMMON-LISP-USER::SOME-METHOD")
                        (ps-experiment/defines/defmethod::func-index
                         (let ((ps-experiment/defines/defmethod::table-key
                                "COMMON-LISP-USER::SOME-METHOD"))
                           (ps-experiment/defines/defmethod::find-dispatch-func-index
                             ps-experiment/defines/defmethod::table-key
                             (list a b)
                             :from (1+ #:g1262)
                             :if-does-not-exist :error))))
                   (funcall (funcall (ps-experiment/defines/defmethod::get-dispatch-func
                                       ps-experiment/defines/defmethod::table-key
                                       ps-experiment/defines/defmethod::func-index)
                                     ps-experiment/defines/defmethod::func-index)
                            a b)))
               (next-method-p nil
                 (not (null (let ((ps-experiment/defines/defmethod::table-key
                                   "COMMON-LISP-USER::SOME-METHOD"))
                              (ps-experiment/defines/defmethod::find-dispatch-func-index
                                ps-experiment/defines/defmethod::table-key
                                (list a b)
                                :from (1+ #:g1262)
                                :if-does-not-exist nil))))))
          (compute-something a b))))))

次のようなJavaScriptコードになります。

  psExperiment_defines_defmethod._internal.pushDispatchFunc(
    'COMMON-LISP-USER::SOME-METHOD',
    [typeA, null],
    function (g1251) {
      return function (a, b) {
          var callNextMethod = function (a, b) {
              var tableKey90;
              var tableKey = 'COMMON-LISP-USER::SOME-METHOD';
              var funcIndex = (tableKey90 = 'COMMON-LISP-USER::SOME-METHOD',
                               psExperiment_defines_defmethod._internal.findDispatchFuncIndex(
                                 tableKey90, [a, b],
                                 'from', g1251 + 1,
                                 'if-does-not-exist', 'error'));
              return psExperiment_defines_defmethod._internal.getDispatchFunc(tableKey, funcIndex)(funcIndex)(a, b);
          };
          var nextMethodP = function () {
              var tableKey;
              return (tableKey = 'COMMON-LISP-USER::SOME-METHOD',
                      psExperiment_defines_defmethod._internal.findDispatchFuncIndex(
                        tableKey, [a, b],
                        'from', g1251 + 1,
                        'if-does-not-exist', null))
                     != null;
          };
          return computeSomething(a, b);
      };
  });

こうしてマクロの中に実装が畳み込まれている様を見ると気分が良いですね :-)

道具作り

あとは淡々と defgenerc.ps-only, defmethod.ps-only の実装で利用していた道具を作っていきます。

大きくは次の2つです。

  • Parenscript（JavaScript）側: 実行時の各種補助関数（主に型に関する処理）
  • Common Lisp側: マクロ用の各種補助関数（主にlambda-listのパース）

Parenscript（JavaScript）部分

Parenscript側で行うのは主に型に関する処理です。下記2種類の処理が必要になります。

  • 型とインスタンスの比較
    • 実行時 = メソッド呼び出し時のディスパッチに利用します
  • 型同士の比較
    • 定義時 = defmethod の際に実施するソートに利用します

型とインスタンスの比較

型とインスタンスの比較を行うための基本的な関数が以下になります。

(defun.ps instance-dispatch-p (test-instance target-type)
  (or (null target-type)
      (instanceof test-instance target-type)))

(defun.ps+ instance-list-dispatch-p (test-instance-list target-type-list)
  "Note: Used for dispatching in execution time"
  (assert (= (length test-instance-list) (length target-type-list)))
  (loop
     for test-instance in test-instance-list
     for target-type in target-type-list
     do (unless (instance-dispatch-p test-instance target-type)
          (return-from instance-list-dispatch-p nil)))
  t)

まず、下記のような定義と呼び出しを例として、instance-list-dispatch-pの引数の内容をそれぞれ示します。

(defmethod.ps+ some-method ((a type-a) b)...)
(some-method x y)
  • test-instance-list: (x y)
  • target-type-list: (type-a nil)

これをinstance-dispatch-pに渡して1つ1つチェックしていきます。なお、型判別をinstanceofによって行っているため、プリミティブ型を扱えないという重大な制限があります…。当面自身で定義した型だけで利用するつもりですが、そのうち直すかもしれません*4。

さて、ここで定義したinstance-list-dispatch-pを利用して、実行時にディスパッチ可能な関数（のリスト内でのインデックス）を探し出すのが次のfind-dispatch-func-indexです。

(defun.ps+ find-dispatch-func-index (function-name instance-list
                                                   &key (from 0) (if-does-not-exist :error))
  (let ((dispatch-item-list (gethash function-name *dispatch-list-table*)))
    (unless dispatch-item-list
      (error "There is no generic function \"~A\"" function-name))
    (loop :for i :from from :below (length dispatch-item-list)
       :do (let ((item (nth i dispatch-item-list)))
             (when (instance-list-dispatch-p instance-list (dispatch-item-type-list item))
               (return-from find-dispatch-func-index i))))
    (case if-does-not-exist
      (:error (error "Can't find a function for ~A" instance-list))
      (t nil))))

前述のように、dispatch-item-listはspecificな順にソートされているため、fromから探し始めて最初に見つかったものを返します。また、この関数の利用パターンには下記の2つがあるため、if-does-not-existでディスパッチ可能な関数が見つからない場合の処理を分けています。

  • 最初の呼び出し or call-next-method: 見つからなければエラー
  • next-method-p: 見つからなければnilを返す

型同士の比較

次に、型同士を比較するための関数です。

(defun.ps type-dispatch-p (test-type target-type)
  (or (and (null test-type)
           (null target-type))
      (and (not (null test-type))
           (instance-dispatch-p (new (test-type)) target-type))))

(defun.ps+ type-prior-p (test-type target-type)
  (and (not (eq test-type target-type))
       (type-dispatch-p test-type target-type)))

(defun.ps+ compare-dispatch-prior (type-list-a type-list-b)
  (assert (= (length type-list-a) (length type-list-b)))
  (dotimes (i (length type-list-a))
    (let ((type-a (nth i type-list-a))
          (type-b (nth i type-list-b)))
      (cond ((type-prior-p type-a type-b)
             (return-from compare-dispatch-prior -1))
            ((type-prior-p type-b type-a)
             (return-from compare-dispatch-prior 1)))))
  0)

type-dispatch-pが各型についてのディスパッチ可能性を見ている関数です。型同士を直接比較する術が見つからなかったので、いったんnewしてからインスタンスと型の比較に持ち込んでます。オブジェクト生成のオーバーヘッドはかかりますが、ロード（defmethod）時に走るだけなので無視して良いでしょう。これに同型の判定を加えたtype-prior-pを利用して、型のリストの比較をするcompare-dispatch-priorを組み上げます。返り値はJavaScriptのArray.sort()の仕様に合わせており、次のように利用しています。

(defun.ps sort-dispatch-item-list (list)
  (list.sort (lambda (a b)
               (compare-dispatch-prior (dispatch-item-type-list a)
                                       (dispatch-item-type-list b)))))

ここまで来れば、後はdefmethod.ps-onlyで利用していたpush-dispatch-funcは次のように構成できます。

;; 重複削除に利用する補助関数
(defun.ps+ same-type-list-p (type-list-a type-list-b)
  (unless (= (length type-list-a) (length type-list-b))
    (return-from same-type-list-p nil))
  (dotimes (i (length type-list-a))
    (unless (eq (nth i type-list-a) (nth i type-list-b))
      (return-from same-type-list-p nil)))
  t)

(defun.ps push-dispatch-func (function-name type-list func)
  (symbol-macrolet ((item-list (gethash function-name *dispatch-list-table*)))
    ;; 重複を削除
    (setf item-list
          (item-list.filter
           (lambda (item)
             (not (same-type-list-p (dispatch-item-type-list item) type-list)))))
    ;; 追加
    (push (make-dispatch-item :type-list type-list
                              :func func)
          item-list)
    ;; specificな順にソート
    (sort-dispatch-item-list item-list)))

独立した小さな補助関数なので触れる場所がなかったですが、次のget-dispatch-funcもdefmethod.ps-onlyの実装に利用していたものです。

(defun.ps+ get-dispatch-func (function-name index)
  (dispatch-item-func (nth index (gethash function-name *dispatch-list-table*))))

引数の処理

マクロ実装で利用する補助関数群です。

  • ほとんどは引数（lambda-list）を加工するための関数です
  • 他、Parenscriptの関数呼び出しを埋め込むための補助関数がいくつかあります

まずは引数の加工関数群ですが、やりたいことは各関数のコメントで分かるでしょうし、実装もひたすらリスト処理しているだけなので、ざっくり並べて終わりにします（全体的に関数名がやたらと長い…）。

;; alexandriaとanaphoraを利用している部分があるので、
;; 参考のためdefpacageのインポート部分も載せます
(defpackage ps-experiment/defines/defmethod
  ...
  (:import-from :alexandria
                :make-keyword
                :parse-ordinary-lambda-list
                :symbolicate)
  (:import-from :anaphora
                :aif
                :it))

  (defun extract-dispatch-pair (lambda-list)
    "Ex. (a (b type-b) &key c) -> ((a nil) (b type-b))"
    (labels ((rec (rest result)
               (let ((head (car rest)))
                 (if (or (not rest)
                         (and (symbolp head)
                              (string= (subseq (symbol-name head) 0 1)
                                       "&")))
                     (nreverse result)
                     (rec (cdr rest)
                          (cons (if (listp head)
                                    head
                                    (list head))
                                result))))))
      (rec lambda-list nil)))

  (defun extract-dispatch-instances (lambda-list)
    "Ex. (a (b type-b)) -> (a b)"
    (mapcar #'car (extract-dispatch-pair lambda-list)))

  (defun extract-dispatch-types (lambda-list)
    "Ex. (a (b type-b)) -> (nil type-b)"
    (mapcar #'cadr (extract-dispatch-pair lambda-list)))

  (defun convert-gf-lambda-list-to-call-list (gf-lambda-list)
    "Ex. (a b &key c) -> (a b :c c)"
    (multiple-value-bind (required optional rest
                                   keys allow-other-keys aux keyp)
        (parse-ordinary-lambda-list gf-lambda-list
                                    :normalize nil)
      (declare (ignore allow-other-keys aux keyp))
      (labels ((make-a-list (got)
                 (if (listp got)
                     (mapcar (lambda (elem)
                               (if (atom elem) elem (car elem)))
                             got)
                     (list got))))
        ;; 下記はかなり雑に処理しているので、&restやら&optionalやらが
        ;; 同時に使われたりすると正しく処理できない気がします…
        (mapcan #'make-a-list
                (list required optional rest
                      (mapcan (lambda (key) (list (make-keyword key) key)) keys))))))

  (defun convert-specialized-lambda-list-to-lambda-list (specialized-lambda-list)
    "Ex. (a (b type-b) &key (c 10)) -> (a b &key (c 10))"
    (let* ((count-required (aif (position-if (lambda (elem)
                                               (and (atom elem)
                                                    (string= (subseq (symbol-name elem) 0 1)
                                                             "&")))
                                             specialized-lambda-list)
                                it
                                (length specialized-lambda-list)))
           (required (subseq specialized-lambda-list 0 count-required))
           (rest (nthcdr count-required specialized-lambda-list)))
      (append (mapcar (lambda (elem) (if (atom elem) elem (car elem)))
                      required)
              rest)))

次に、Parenscriptの関数呼び出しを埋め込むための補助関数です。

  (defun make-table-key (sym)
    (format nil "~A::~A" (package-name (symbol-package sym)) (symbol-name sym)))

  (defun find-dispatch-func-index% (&key function-name lambda-list start-func-index
                                      (if-does-not-exist :error))
    `(let ((table-key ,(make-table-key function-name)))
       (find-dispatch-func-index
        table-key
        (list ,@(extract-dispatch-instances lambda-list))
        :from ,start-func-index
        :if-does-not-exist ,if-does-not-exist)))

  (defun call-next-method% (&key function-name lambda-list call-list start-func-index)
    `(let* ((table-key ,(make-table-key function-name))
            (func-index ,(find-dispatch-func-index%
                          :function-name function-name
                          :lambda-list lambda-list
                          :start-func-index start-func-index)))
       (funcall
        (funcall (get-dispatch-func table-key func-index) func-index)
        ,@call-list)))

find-dispatch-func-index%はnext-method-pの実装で利用していたもので、ディスパッチ可能なメソッドを探し出す処理を埋め込みます。call-next-method%の方でもこれを利用していますが、こちらは探した上で見つけたものを呼び出す処理を埋め込みます。defgeneric内で定義する関数での最初のメソッドの呼び出しや、call-next-methodの実装で利用していました。

若干悩ましいのが、*dispatch-list-table*のキーを生成するmake-table-key関数です。JavaScript化された時点でシンボルのパッケージ情報が除かれてしまうため、この時点でパッケージ名を含んだ文字列をキーとして生成しています。しかし、失われる情報を利用しているため、JavaScript側でこのキーを生成する術がありません。このため、例えばディスパッチ可能なメソッドを一式を取り出すcompute-applicable-methods関数がこのままでは実装できないという問題に直面することになります。現状の範囲では問題ないため今のところこのままにしています。

さて、あとは、(defgeneric some-method (a) (:documentation "Some document"))のオプション部分 = (:documentation "Some document")を処理するための関数が残っています。とはいえ、:documentationしかサポートしていないので特に見るべきところもないです。

  (defun parse-defgeneric-options (options)
    (let ((result (make-defgeneric-options)))
      (dolist (opt options)
        (let ((kind (car opt))
              (rest (rest opt)))
          (ecase kind
            (:documentation
             (let ((doc (car rest)))
               (check-type doc string)
               (setf (defgeneric-options-documentation result) doc))))))
      result))

動作確認

最後にREPL上で動作を確認してみます。

;; --- 各種準備 --- ;;
CL-USER> (ql:quickload '(:ps-experiment :cl-js) :silent t)
(:PS-EXPERIMENT :CL-JS)
CL-USER> (use-package :ps-experiment)
T
CL-USER> (defmacro jst (&body body)
           `(cl-js:run-js (with-use-ps-pack (:this) ,@body)))
JST
;; ※defclassがないので、defstructで代用…
CL-USER> (defstruct.ps+ type-a a)
TYPE-A
CL-USER> (defstruct.ps+ (type-b (:include type-a)))
TYPE-B

;; --- 定義 --- ;;
CL-USER> (defgeneric.ps+ test-method (x y))
#<STANDARD-GENERIC-FUNCTION TEST-METHOD #x3020015BE7EF>
;; ※formに文字列しかないと正しく処理できない（コメントとして取り除かれてしまう）
;;   というParenscriptのバグがあるので 無駄にnilを入れて回避しています…
CL-USER> (defmethod.ps+ test-method ((x type-a) (y type-b))
           nil "X is type-a : Y is type-b")
#<STANDARD-METHOD TEST-METHOD (TYPE-A TYPE-B)>
CL-USER> (defmethod.ps+ test-method ((x type-b) (y type-a))
           nil "X is type-b : Y is type-a")
#<STANDARD-METHOD TEST-METHOD (TYPE-B TYPE-A)>

;; --- 呼び出し --- ;;
CL-USER> (jst (test-method (make-type-a) (make-type-b)))
"X is type-a : Y is type-b"
CL-USER> (jst (test-method (make-type-b) (make-type-a)))
"X is type-b : Y is type-a"

~.ps+を利用してCommmon Lispのメソッドとしても定義しているので、ついでにjstを挟まずにCommon Lispとして実行してみます。同じ結果が返っていることが分かります。

CL-USER> (test-method (make-type-a) (make-type-b))
"X is type-a : Y is type-b"
CL-USER> (test-method (make-type-b) (make-type-a))
"X is type-b : Y is type-a"

*1:主に良い名前が思いつかないのが理由でquicklispのリポジトリに未だ登録しておらず…。試してみたい方がいたら ros install eshamster/ps-experiment などでインストールお願いします…

*2:なお、最新版では今回実装する多重ディスパッチ処理用のコード（パッケージ）が手前に付くので少し汚くなります…

*3:JavaScript Testぐらいの意味合い。Japan Standard Timeではないです

*4:プリミティブ型を判定しようとするとtypeofで型を文字列として取り出して文字列比較するみたいな話になるので、ディスパッチのような基礎的な部分に入るオーバーヘッドとしては許容しがたい雰囲気もあり、余り前向きではないです…