【Common Lisp】REPL 上で手軽にスレッドの動作を試すためのライブラリを作った
Lisp Advent Calendar 2019 12日目の記事です。Commmon Lisp の REPL (Read Eval Print Loop) 上でお手軽にスレッドの動作を試すための小さなライブラリ repl-thread を作ってみた話です。
前置き
REPL駆動開発 *1 とも言われるように、Common Lisp 開発においては組み込み関数や自分で書いた関数の動作の確認に REPL を使い倒すことと思います。これの良いところは、きっちりとしたテストや動作確認用のプログラムを書くことなく、思いつくままにパパッと動作を試せるところにあります。
しかし、スレッドの動作を試そうと思った瞬間そう気軽にいかなくなります。スレッドが一度走り始めてしまうと介入できないので、例えばロックを試すために少なくとも2つの関数を用意して、この辺で止まっているときの動作を見たいのでこっちに sleep を入れあっちに sleep を入れ...という具合に計画性が求められるようになります。さらに、走り切った後は一気に流れた print ログを追いかけながら、これがこの順番で出てるから思った通りの順序で動いているはず...というように検証も面倒です。
そうした面倒臭さを多少とも避けて、気軽にあちらのスレッドでこれ動かして、続けてこちらのスレッドでこれを動かして...ということが REPL 上でできるちょっとしたライブラリ repl-threads を作ってみました。
動かしてみる
現状 repl-threads は quicklisp に登録していないので ql:quickload できるような位置にソースを持ってくることが必要です。Roswell を利用している場合は下記が簡単です。
$ ros install eshamster/repl-threads
REPL 上で quickload できたら準備完了です。
CL-USER> (ql:quickload :repl-threads)
まずは所望の数のスレッドを立ち上げます（rts は repl-thraeds のニックネームです）。
CL-USER> (defparameter *rts* (rts:make-repl-threads 2)) *RTS*
スレッド内で指定の動作をさせるには、with-thread マクロに上記で作った repl-threads とスレッド番号（0からの連番）を指定して処理を書くだけです。
CL-USER> (rts:with-thread (*rts* 0) (print :test)) T :TEST
これだけでは本当にスレッド内で動いているのか分からないので適当にロックをかけてみます。なお、bt は各種 Commmon Lisp 処理系のスレッド操作を抽象化している bordeaux-threads パッケージのニックネームです。repl-threads が依存しているので改めて quickload する必要はないです。
CL-USER> (defparameter *lock* (bt:make-lock)) *LOCK* CL-USER> (rts:with-thread (*rts* 0) (bt:acquire-lock *lock*) ; まだ誰もロックを取っていないので (print :thread0)) ; ← の print はすぐ実行される T :THREAD0 CL-USER> (rts:with-thread (*rts* 1) (bt:acquire-lock *lock*) ; thread 0 にロックを取られているので (print :thread1) ; ← の print は待たされる (bt:release-lock *lock*)) T CL-USER> (rts:with-thread (*rts* 0) (bt:release-lock *lock*)) ; ← ロックを手放すと... T :THREAD1 ; ← 待たされていた thread 1 の print が実行される
また、スペシャル変数 *thread-index* にスレッド番号を格納しています。
CL-USER> (defun test () (print rts:*thread-index*)) TEST CL-USER> (rts:with-thread (*rts* 1) (test)) T 1
掃除は一関数で済みます。スレッドを破棄するだけで各種リソースの面倒まで見てくれるものではないですが...。
CL-USER> (rts:destroy-repl-methods *rts*) NIL
中身
概要
基本的なアイディアは単純です。
- 各スレッドはキューを持ち、関数が投げ込まれるのを待ち受ける
- 投げ込まれた関数を順次実行する
REPL から各スレッドのキューに関数を投げ込むことで、任意の処理を後付けで実行できます。
ということで、次のような順序で作っていきます。
queue: ただのキュー（スレッドアンセーフ）wait-queue: スレッドセーフなキューrepl-thread: 2 を利用して前述の動作をするスレッドrepl-threads: 3 のスレッドを束ねるクラス
queue: ただのキュー
https://github.com/eshamster/repl-threads/blob/master/queue.lisp
特別なところはないただのキューなのでリンクだけ貼ります。head からの取り出しと tail への追加しかできない双方向リストとして実装しています。
こんな感じで利用します。
CL-USER> (use-package :repl-threads/queue) T CL-USER> (defparameter *q* (make-queue)) *Q* CL-USER> (queue *q* 0) 0 CL-USER> (queue *q* 1) 1 CL-USER> (dequeue *q*) 0 CL-USER> (dequeue *q*) 1 CL-USER> (dequeue *q*) NIL
wait-queue: スレッドセーフなキュー
https://github.com/eshamster/repl-threads/blob/master/wait-queue.lisp
先ほどのキューを使って次のようなキューを作ります。
- スレッドセーフである
- dequeue 時にキューが空なら queue されるまで待機する
まずは パッケージの定義ですが、先ほど作ったキューの他 bordeaux-threads から Lock, Condition Variable 関連の関数・マクロをインポートします。
(defpackage repl-threads/wait-queue (:use :cl) (:export :wait-queue :make-wait-queue :queue :dequeue) (:import-from :repl-threads/queue :make-queue :queue :dequeue :queue-length) (:import-from :bordeaux-threads :make-lock :with-lock-held :make-condition-variable :condition-notify :condition-wait)) (in-package :repl-threads/wait-queue)
クラス定義はこんな感じです。
(defclass wait-queue () ((queue :initform (make-queue) :reader wq-queue) (cond-var :initform (make-condition-variable :name "WAIT QUEUE COND") :reader wq-cond-var) (wait-count :initform 0 :accessor wq-wait-count) (lock :initform (make-lock "WAIT QUEUE LOCK") :reader wq-lock))) (defun make-wait-queue () (make-instance 'wait-queue))
dequeue メソッドでは、キューに何か入っていればロックを取って値を取り出し、ロックを解放するだけです（when 内を通らないルート）。キューが空の場合は Condition variable を利用してキューに何か入るのを待ちます。 condition-wait は次のような動作をします。
- 渡されたロックを解放する
- 渡された Condition variable にシグナルが来るまで待つ
- シグナルが来たらロックを取得して次に進む
(defmethod dequeue ((wq wait-queue)) (let ((lock (wq-lock wq)) (q (wq-queue wq))) (with-lock-held (lock) (when (= (queue-length q) 0) (incf (wq-wait-count wq)) ;; wait until some value is queued (condition-wait (wq-cond-var wq) lock)) (assert (> (queue-length q) 0)) (dequeue q))))
次に queue メソッドですが、基本的にはロックを取ってキューに値を詰め、ロックを解放するだけです。ただし、待ち状態の dequeue メソッドが存在する場合は、condition-notify でシグナルを出して待ちを解除します*2。
(defmethod queue ((wq wait-queue) value) (let ((q (wq-queue wq))) (with-lock-held ((wq-lock wq)) (queue q value) (when (> (wq-wait-count wq) 0) (decf (wq-wait-count wq)) (condition-notify (wq-cond-var wq))))))
repl-thread: 投げ込まれた関数を実行するスレッド
https://github.com/eshamster/repl-threads/blob/master/repl-thread.lisp
パッケージの定義は次の通りです。ロック周りは wait-queue にお任せしているので、bordeaux-threads からはスレッドの生成・破棄関数だけを import します。
(defpackage repl-threads/repl-thread (:use :cl) (:export :make-repl-thread :queue-process :destroy-repl-thread) (:import-from :repl-threads/wait-queue :wait-queue :make-wait-queue :queue :dequeue) (:import-from :bordeaux-threads :make-thread :destroy-thread)) (in-package :repl-threads/repl-thread)
クラス定義と生成、破棄関数は次の通りです。
(defclass repl-thread () ((thread :initarg :thread :reader rt-thread) (process-queue :initarg :process-queue :reader rt-process-queue))) (defun make-repl-thread () (let ((q (make-instance 'wait-queue))) (make-instance 'repl-thread :thread (make-thread (make-repl-thread-process q)) :process-queue q))) (defmethod destroy-repl-thread ((rt repl-thread)) (destroy-thread (rt-thread rt)))
次に、スレッド内で動作する関数を生成する make-repl-thread-process を見ます。といっても、dequeue で待ち、関数が来たら funcall で実行、を繰り返す関数を作るだけです。
(defmethod make-repl-thread-process ((process-queue wait-queue)) (lambda () (loop (funcall (dequeue process-queue)))))
そして、外部からスレッドに関数を供給するのが queue-process 関数です。受け取った関数をキューに詰め込むだけです。一応受け取ったものが関数かどうか程度のチェックはしていますが、引数ありの関数が funcall されるとスレッドが死んでしまうので、引数のチェックぐらいは追加しても良いかもしれません。
(defmethod queue-process ((rt repl-thread) process) (assert (functionp process)) (queue (rt-process-queue rt) process) t)
repl-threads: repl-thread を束ねる
最後に repl-thread を束ねた repl-threads を作ります。パッケージの定義は次の通りです。repl-thread のラッパーなので、そこへだけ依存しています。
(defpackage repl-threads/repl-threads (:use :cl) (:export :make-repl-threads :queue-process-to :with-thread :destroy-repl-threads :*thread-index*) (:import-from :repl-threads/repl-thread :make-repl-thread :queue-process :destroy-repl-thread)) (in-package :repl-threads/repl-threads)
クラスとしては repl-thread の配列を持っているだけです。生成と破棄も素直に指定個数の repl-thread の生成と破棄をするだけです。
(defclass repl-threads () ((threads :initarg :threads :reader rts-threads))) (defun make-repl-threads (n) (let ((threads (loop :for i :from 0 :below n :collect (make-repl-thread)))) (make-instance 'repl-threads :threads (make-array n :initial-contents threads)))) (defmethod destroy-repl-threads ((rts repl-threads)) (let ((threads (rts-threads rts))) (dotimes (i (length threads)) (destroy-repl-thread (aref threads i)))))
queue-process-to は、インデックスで指定された repl-thread に対して queue-process を呼びます。
(defmethod queue-process-to ((rts repl-threads) thread-index process) (let ((threads (rts-threads rts))) (assert (< thread-index (length threads))) (queue-process (aref threads thread-index) process)))
これをラップしているのが with-thread マクロです。単純なラッパーとして動作するのに加えて、*thread-index* にスレッド番号を束縛する役割もあります。
(defvar *thread-index* -1) (defmacro with-thread ((rts thread-index) &body body) (let ((g-thread-index (gensym "THREAD-INDEX"))) `(let ((,g-thread-index ,thread-index)) (queue-process-to ,rts ,g-thread-index (lambda () (let ((*thread-index* ,g-thread-index)) (declare (ignorable *thread-index*)) ,@body))))))
おまけ: 色々試してみる
せっかく作ったので色々試してみます。
Recursive Lock
Recursive Lock は通常のロックと異なり、同一スレッド内であれば何度でも取得できるロックになります（解放はロックと同じ回数だけ必要）。なお、これは SBCL には実装されていないようです。下記は CCL 1.11.5 での動作例になります。
CL-USER> (defparameter *rts* (rts:make-repl-threads 2)) *RTS* CL-USER> (defparameter *rec-lock* (bt:make-recursive-lock)) *REC-LOCK* CL-USER> (rts:with-thread (*rts* 0) (bt:acquire-recursive-lock *rec-lock*) (print :thread0-1)) T :THREAD0-1 CL-USER> (rts:with-thread (*rts* 0) (bt:acquire-recursive-lock *rec-lock*) ; 同じスレッド内なのでもう一度取れる (print :thread0-2)) T :THREAD0-2 CL-USER> (rts:with-thread (*rts* 1) (bt:acquire-recursive-lock *rec-lock*) ; 別スレッドなので待たされる (print :thread1-1)) T CL-USER> (rts:with-thread (*rts* 0) (bt:release-recursive-lock *rec-lock*)) T CL-USER> (rts:with-thread (*rts* 0) (bt:release-recursive-lock *rec-lock*)) T :THREAD1-1 ; 2回解放するとスレッド1が進めるようになる
Semaphore
セマフォ（Semaphore）は資源数に限りがある対象に触る場合に、同時に N 個のスレッドしか触れないようにする、といった操作を実現するために利用するものです。
CL-USER> (defparameter *rts* (rts:make-repl-threads 3)) *RTS* ;; 資源数2のセマフォをつくる CL-USER> (defparameter *sem* (bt:make-semaphore :count 2)) *SEM* CL-USER> (rts:with-thread (*rts* 0) (bt:wait-on-semaphore *sem*) (print :thread0)) T :THREAD0 CL-USER> (rts:with-thread (*rts* 1) (bt:wait-on-semaphore *sem*) (print :thread1)) T :THREAD1 ;; 既に thread 0, 1 が資源を占有しているので待たされる CL-USER> (rts:with-thread (*rts* 2) (bt:wait-on-semaphore *sem*) (print :thread2)) T CL-USER> (rts:with-thread (*rts* 0) (bt:signal-semaphore *sem*)) T :THREAD2 ; thread 0 が資源を手放したので thread 2 が動いた
Condition Variable
Condition Variable は wait-queue の実装でも利用したように、「何らかの条件が成立するまで待つ」（wait-queue であれば「キューに何か入るまで待つ」）用途で利用できます。ただし、こうした用途に適しているというだけで、Condition Variable 自体が何かの条件処理をしてくれる訳ではありません。
再掲すると、待ち側である condition-wait は下記のような動作をします。待ちを解除する condition-notify は単にシグナルを送るだけです。
- 渡されたロックを解放する
- 渡された Condition variable にシグナルが来るまで待つ
- シグナルが来たらロックを取得して次に進む
試してみます。
CL-USER> (defparameter *rts* (rts:make-repl-threads 2)) *RTS* CL-USER> (defparameter *lock* (bt:make-lock)) *LOCK* CL-USER> (defparameter *cond-var* (bt:make-condition-variable)) *COND-VAR* CL-USER> (rts:with-thread (*rts* 0) (bt:acquire-lock *lock*) (print :thread0-before) ;; ここでロックが解除される (bt:condition-wait *cond-var* *lock*) (print :thread0-after) (bt:release-lock *lock*)) T :THREAD0-BEFORE CL-USER> (rts:with-thread (*rts* 1) ;; ロックを取れる (bt:acquire-lock *lock*) (bt:condition-notify *cond-var*) (print :thread1)) T :THREAD1 ;; ※condition-wait はロックを再取得できないのでまだ待たされる CL-USER> (rts:with-thread (*rts* 1) (bt:release-lock *lock*)) T :THREAD0-AFTER ; シグナルを受け取り、ロックも解除されたので進めた
wait queue
せっかくなので部品として作った wait-queue も試してみます。
CL-USER> (defparameter *rts* (rts:make-repl-threads 2)) *RTS* CL-USER> (use-package :repl-threads/wait-queue) T CL-USER> (defparameter *wq* (make-wait-queue)) *WQ* CL-USER> (rts:with-thread (*rts* 0) (queue *wq* 0) (queue *wq* 1)) T CL-USER> (rts:with-thread (*rts* 1) (print (dequeue *wq*)) (print (dequeue *wq*)) ;; ↓2つしか入っていなかったので待たされる (print (dequeue *wq*))) T 0 1 CL-USER> (rts:with-thread (*rts* 0) (queue *wq* 2)) T 2 ; ← 待たされたものが動いた
cl-base + rove + Travis CI でテストする
Lisp Advent Calendar 2019 6日目の記事です。小ネタです。
動機
かねてより Common Lisp のリポジトリでは Roswell を利用して SBCL, CCL の2処理系ぐらいで Travis CI 上で CI を回すようにしています（例: .travis.yml）。ただ、（依存している SBCL の更新の影響が多い印象ですが）ちょくちょく Roswell のインストールに失敗して CI が死ぬことがあります（最近死んだ原因）。
そこで、Roswell インストール済みの拙作 eshamster/cl-base コンテナ上でテストを走らせることで、この辺りの悩みからある程度解放されるのでは...という期待がこの記事の動機です。なお、この cl-base の latest は週1で自動ビルドされています。バージョンタグは...気紛れで更新されます（現在 2.4.1 が最新）。
他、記事タイトルの rove は深町さん作のテストライブラリです。 package-inferred-system に対応しているあたりを理由にいつも使わせて頂いています。
できたもの
本題に入る前に、下記のリポジトリを作って試行錯誤していました。CC0ライセンスなので万が一使いたい方が入れば適当にコピーして持っていってください。rove + Travis CI + SBCL & CCL な CI が目的であれば .travis.yml ファイルと test-docker フォルダをそのまま持っていけば動くはずです。（Roswellでインストール可能な）処理系を足し引きしたい場合は2箇所ほど手を入れれば動くはずです。
中身
本題は下記の4ファイルだけなのでササッと見ていきます。いずれも短いものなので全文コピーしています。
.
├── .travis.yml
└──test-docker
├── Dockerfile
├── run.sh
└── test.sh
まずは入口になる .travis.yml を見ます。
https://github.com/eshamster/try-test-in-docker/blob/master/.travis.yml
services:
- docker
env:
matrix:
- LISP=sbcl-bin
- LISP=ccl-bin
before_install:
- docker build -t test test-docker
script:
- test-docker/run.sh
envのmatrixで対象の処理系を指定します- 処理系の足し引きで要書き換えな箇所その1
before_installはtest-dockerフォルダのファイルで docker build するだけですscriptも同フォルダのスクリプトを走らせるだけです
※2019/12/24 追記：警告が出ていたことに気付いたので若干修正しました
次に Dockerfile です。
https://github.com/eshamster/try-test-in-docker/blob/master/test-docker/Dockerfile
FROM eshamster/cl-base:2.4.1
ADD ./test.sh /root
RUN ros install ccl-bin && \
ros install rove
CMD ["/root/test.sh"]
- SBCL は Roswell と共に入るので、追加で CCL (ccl-bin) をインストールします
- 処理系の足し引きで要書き換えな箇所その2
次にここの CMD で走らせる test.sh です。
https://github.com/eshamster/try-test-in-docker/blob/master/test-docker/test.sh
#!/bin/sh set -eux ros use ${LISP} cd ~/.roswell/local-projects/target rove *.asd
- 基本的に後述の
run.shのお膳立てのもとに rove を走らせるだけです- お膳立て1:
LISP環境変数の供給 - お膳立て2:
~/.roswell/local-projects/targetへのプロジェクト設置
- お膳立て1:
- ここで
ros install ${LISP}をすれば処理系足し引き時に Dockerfile の書き換えは不要になりますが build 時にやっておきたい気持ち
最後に run.sh です。
https://github.com/eshamster/try-test-in-docker/blob/master/test-docker/run.sh
#!/bin/sh set -eux base_dir=$(dirname ${0}) cd ${base_dir}/.. docker run -e LISP=${LISP} -v $(pwd):/root/.roswell/local-projects/target -t test
test.shのためのお膳立てをして docker run します。
ということで小ネタでした。
【マクロ小ネタ】Common Lisp で defer してみる
時には実用を考えずにマクロを書いて遊んでいると楽しいというだけの記事です。
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 には次のような特徴があります。
- 複数の
deferがある場合、通ったのとは逆順で実行される - 実行時に通った
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 の面白いところですね。
【小ネタ】 簡易な関数定義マクロ, マクロ定義マクロを自作してみる
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 を書くことになり、Mac 上で Emacs + LSP（サーバ: gopls, クライアント: eglot）な環境を作りました。これには下記の記事に全面的に依拠しております。
そして、割と良い感じに動いているので、1年ぐらい前に作って放置していた Docker 開発環境にも反映させるか...と思ってだいぶハマったというのが本記事の内容です。一応の解決はしたつもりですが、どう見てもアドホックな方法なので、何か知っている人がいたら教えて欲しいというぐらいの精度です。
Docker 上では下記OSをゲストとして利用しています。
なお、現状確認できているのは、Mac 上に直接インストールした Emacs では問題なかったということと、Docker 上の Alpine Linux で問題があったということだけなので、実は Docker は関係ないかもしれないです。
- GitHubリンク: https://github.com/eshamster/docker-go-devel/
- DockerHubリンク: https://cloud.docker.com/repository/docker/eshamster/go-devel/general
問題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 パッケージが見つからないようになってエラーになったようです。
- 当初は jsonrpc は独立したパッケージとして開発されていた
- これが Emacs 本体に取り込まれることになった
- そして、MELPA (Emacs のパッケージリポジトリの一つ) も本体に jsonrpc があることを期待するようになった
- しかし、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 に画像描画機能を追加した話
前回記事でクライアントサイドレンダリング (2D) のためのライブラリを実装してみました。
この時点では丸や四角といったプリミティブな図形の描画しかできませんでした。画像（テクスチャ）の描画機能も必要だろうなと思いつつ面倒なので後回しにしていました。そして、ようやく実装したというのが今回の話ですが、思った通り面倒だったので後から見返すためのメモを残しておこうという趣旨のメモ記事です。
見返し用に作ったセルフプルリク↓
面倒なところ
おおむね下記が面倒なところです。
- 単一の画像ファイルに複数の画像が埋め込まれている
- 透過処理のために2つの画像（元画像とアルファマップ）が必要になる
- 層によってデータの形が異なる
- ライブラリ外部へのインタフェース層
- プロトコル層
- クライアント層
用語について
本題の前に、textureとimageという用語を勝手に定義して使ってしまっているのでその説明です。
- texture: 物理的な画像ファイル1つ1つに対応する情報
- 正確には、アルファマップがある場合は元画像 + アルファマップの2ファイルに対して1つのtextureが対応します
- image: 1つのtextureに対して複数のimageが対応する。1つの画像ファイルは複数の画像を含む場合があり、どこからどこまでを1つの画像として扱うかという情報をimageで持っている
何となくtextureの方が具象的な印象があり、一方でimageの方が抽象的な印象があったのでこの名付けにしていますが、そんなに深くは考えていません。
うまく説明できている気がしないので具体例で見ます。
「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つの画像ファイルにまとめたものです。
ここから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-textureload-imagedraw-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-textureTHREE.TextureLoaderにより、マテリアルに渡すmapとalpha-mapをロードする- ロード後にテクスチャ情報をテーブルに保存しておく
:load-image- どの texture にひも付いているかと、ジオメトリに渡すUV座標の情報を保存する
loadという名前ではあるが実は何もロードしていない
- どの texture にひも付いているかと、ジオメトリに渡すUV座標の情報を保存する
: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 で実装してみる
2019年と令和元年、二重に本年最初の記事です。あけましておめでとうございます。
クラウドゲームをつくる技術 ―マルチプレイゲーム開発の新戦力 (中嶋謙互) （以下、「クラウドゲーム技術」）で提唱されている「クライアントサイドレンダリング」が面白そうだったので Common Lisp でプロトタイプ (2D版) を書いてみています。
作成しているものは下記です。今回の記事用に blog-20190506 というタグを打っています。記事中のソースへのリンクも同タグのものを貼っています。
プロトタイプとしても不足が目立つので記事にするには時期尚早な感じですが、GW中に一記事仕上げてみた次第です。
なお、こんなショボショボなプロトタイプでなくちゃんとしたものを見たい方は、同書と kengonakajima/moyai を参照しましょう（実装はC++）。
導入：クライアントサイドレンダリング概要
「クラウドゲーム技術」で提唱されているクライアントサイドレンダリングについて簡単に見てみます。関連する定義は次の2つです。
クラウドゲーム：
ゲームロジック（ゲームのあらゆる判定）のすべてがサーバー側で実行され、エンドユーザー側はその処理結果をリアルタイムに受信する汎用のViewer（ゲームビューワー）を通じてプレイする設計になっているゲーム
クライアントサイドレンダリング：
クライアントサイドレンダリングとは、サーバー側でビデオゲームの画面へのレンダリングを行わず、抽象度の高い描画コマンドをクライアントに送って、クライアント側のGPUを使って描画をする方法です。
～「クラウドゲーム技術」: 「1. 5 クラウドマルチプレイ最大の課題『インフラ費用』」>「『クライアントサイドレンダリング』という発想」より～
ネットワークを通じてゲームを配信する従来の方法と比較すると分かり易いです。下記2つが従来の方法です。
- 専用クライアント方式：ゲーム専用のサーバとクライアントを実装する方法（Final Fantasy XIV など）
- ロジック処理は分担し、描画はクライアントのみが担う
- ストリーミング方式：サーバ側でロジック処理から描画まで行い、クライアントへストリーミングする方法（PlayStation Now など）
- （入力はクライアントで受け付けてサーバへ送信する）
1 の方法はクライアントを専用に作成するだけあって、ロジック処理や通信などサーバ側の負荷を低く抑えられる利点があり、大量のユーザを捌くことができます。一方で、ネットワーク処理や同期処理を中心にプログラミングのコストが非常に高くなる欠点があります。
2 の方法では利点・欠点が逆転します。つまり、単一サーバでの動作となるためオフラインゲームと同程度のプログラミングコストで実装ができる一方で、GPU処理の負荷やストリーミング帯域の大きさからユーザ数の限界は小さくなります。
以上を踏まえて改めてクラウドゲームとクライアントサイドレンダリングの定義を見ると、これらの中間を行く手法であることが分かります。つまり、1 の方法よりもいくらか高い程度のサーバ負荷・通信量で、オフラインゲームと同程度のプログラミングコストという方法 2 の利点を享受することができるという訳です*1。
ところで、クラウドゲームの定義の「すべてがサーバー側で実行され」という文言を見て、何かを思い出す人もいるのではないでしょうか。そう、ポール・グレアムの「普通のやつらの上を行け ---Beating the Averages---」です。
もしあなたが、あなたのサーバー上でだけ走るソフトウェアを書くのなら、 あなたは自分の好むどんな言語でも使えるということだ。 （中略） もしどんな言語でも使えるとなったら、いったい何を使う? 私達はLispを選んだ。
つまりそういうことです。
作ったもの
概要
- クライアント
- WebGL（Three.js）を利用したブラウザアプリとして実装します
- ただし、Lispコードとして記述し、Parenscriptとそのラッパーであるps-experiment（拙作）によって JavaScript に変換します
- つまり自分では JavaScript を一行も書きません :-)
- WebGL（Three.js）を利用したブラウザアプリとして実装します
- 通信
- クライアント自体は静的なHTML, JavaScriptとして配信します
- なお、HTML はcl-markupを利用して書いています
- 描画コマンドと入力のやり取りには WebSocket を利用します
- プロトコルはJSON形式（を文字列化したもの）で定義します
- 柔軟ですが非常に帯域効率が悪いです。moyaiでは遥かにまともなプロトコルを定義していますが、まあプロトタイプだし...
- クライアント自体は静的なHTML, JavaScriptとして配信します
- サーバ
デモっぽいもの
デモ…というより、動作確認用のサンプルの動かし方とスクリーンショットです。動作確認は 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/ にアクセスします。
GIF 中の各種オブジェクトについて：
- 縦軸中央付近で常に動いている5つの円や矩形は基本的な図形描画の確認用
- 他の図形も含め、描画指示はサーバから出していて、ブラウザ側はビューアとしてのみ働いています
- 白い円は入力の確認用
- GIF 中ではマウスドラッグに追随させています
- 他にキーボードの矢印入力でも動きます
- 位置情報はサーバ側で持っているため、ブラウザを更新しても位置が保たれます
- 右上の青や赤の円はクライアントごとに別の情報を送る確認用
- クライアントにはサーバ側で連番IDを振っています。そして、偶数番には赤い円を、奇数番には青い円を送付しています。
以上から、ブラウザを更新するとIDが振り直され、表示される情報が変わります
- GIF中では一度ブラウザを更新していますが、その前後で青丸が赤丸になります
- …という分かりにくデモです
- クライアントにはサーバ側で連番IDを振っています。そして、偶数番には赤い円を、奇数番には青い円を送付しています。
以上から、ブラウザを更新するとIDが振り直され、表示される情報が変わります
- 左上の枠内の文字列・数値はデバッグ情報
- 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を呼び出す処理
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 共通で動作するコードとして書いているためです。
認証機能
現状つなぎ直した場合にクライアントの同一性を確認する手段がないので、認証機能、というよりは他の認証機能と連携できるような機能が必要になりそうです。この辺全然考えられていません。
続きの記事
*1:冗長になるので本文からは省きましたが、クライアント側の（主にGPUの）負荷は専用クライアント方式と同程度に高くなります
*2:lack のミドルウェアについては、以前簡単に紹介したことがあるので見てみると参考になる…かもしれません → Common Lispでホットローディングを試しに作る (2) 実装について。ちなみに、今回作ったライブラリはその記事で実装した cl-hot-loads を下敷にしていたりします
*3:フレームの区切りについてはサーバ側に責任があるので、クライアントから送るコマンド（= 入力系）については、フレームの区切りを意識せずに単純に送るだけです
*4:なお、差分更新をしない場合は、毎フレーム全ての描画オブジェクトを削除して全部描き直すだけなので、idは不要です
*5:game-loop.lisp に置くのは適切でない気はしていますが…
*6:ここを含め、全体的にクライアント側とサーバ側でファイル命名の一貫性が弱いのでどこかで直したいなと思いつつ
*7:半端な描画を防ぐため、本来は:frame-startの方も考慮すべきですが現状さぼってます
*8:他にもありますが、ここで見ているのはそれだけです
