クライアントサイドレンダリング (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:他にもありますが、ここで見ているのはそれだけです
LISP: '$e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E
ひたすら「e」が並んでいるだけのリポジトリが話題になってました。
Lispはどうかと見てみると、シンプルに無限ループで面白いというのが初見の感想でした。
(loop (print "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 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はありません……
- standardについても
余談ですが、できたらメソッドコンビネーションも実装してみようかと 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 を利用します（今回の多重ディスパッチ自体もこのライブラリ内に実装します）。
今回主に使うのは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のリストから適用可能な関数を探して呼び出す
- この関数内では、
defmethoddispatch-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で型を文字列として取り出して文字列比較するみたいな話になるので、ディスパッチのような基礎的な部分に入るオーバーヘッドとしては許容しがたい雰囲気もあり、余り前向きではないです…
小ネタ: define-method-combinationで遊ぶ
Lisp メソッドコンビネーション Advent Calendar 2018の4日目の記事です。
枠が空きそうな雰囲気だったので、前日の define-method-combination 解説記事を書いていて思い付いた小ネタを供養しておきます。
Blackhole: 呼ぶと消える
一度呼んだら消えてしまう儚いメソッドを定義できるメソッドコンビネーションです。
(define-method-combination blackhole () ((primary ())) (:generic-function gen) `(list ,@(mapcar #'(lambda (method) `(prog1 (call-method ,method) (remove-method ,gen ,method))) primary))) (defgeneric vanish (a) (:method-combination blackhole)) (defmethod vanish (a) "a is any type") (defmethod vanish ((a number)) "a is number") (defmethod vanish ((a fixnum)) "a is fixnum") (defun call-vanish (a) (handler-case (vanish a) (error (e) (print e) nil)))
呼んでみます。
;; 呼びます CL-USER> (call-vanish 10.0) ("a is number" "a is any type") ;; 消えます CL-USER> (call-vanish 10.0) #<NO-APPLICABLE-METHOD-EXISTS #x302000E4A6AD> NIL ;; 呼んでないところは生きてます CL-USER> (call-vanish 10) ("a is fixnum") ;; でもやっぱり消えます CL-USER> (call-vanish 10) #<NO-APPLICABLE-METHOD-EXISTS #x302000E11F0D> NIL
defgenericの引数で別の generic-function を指定できるようにして、 そこに add-method することでメソッドが移動するホワイトホールとか、それをお互いに指定することで呼ぶ度に相手に移動する惑星メソッドとかできるんじゃないかと考え始めた辺りでやめました。
Escher: 親の親は自分
call-next-method で親？メソッドを辿っていくと自分自身に行きつくメソッドを定義できるメソッドコンビネーションです*1。
(define-method-combination escher (&optional (num-repeat 100)) ((primary ())) (let ((shifted (append (rest primary) (list (first primary))))) `(call-method ,(first primary) ,(loop :for i :from 0 :below num-repeat :append shifted)))) (defgeneric fact (a) (:method-combination escher 100)) (defmethod fact (a) (format t "in root: ~a~%" a) (if (and (numberp a) (> a 1)) (* a (call-next-method (1- a))) 1)) (defmethod fact ((a fixnum)) (format t "in fixnum: ~d~%" a) (if (> a 1) (* a (call-next-method (1- a))) 1))
呼んでみます。
CL-USER> (fact 5) in fixnum: 5 in root: 4 in fixnum: 3 in root: 2 in fixnum: 1 120
Increment: 呼んだらインクリメント
呼び出す度にインクリメントする関数の定義というと、クロージャの説明で良く利用されますね。
メソッドコンビネーションで同じようなことをやってみます。呼び出す度に defmethod で定義し直す力業です。
(ql:quickload :closer-mop) (define-method-combination increment () ((primary ())) (:generic-function gen) (let ((method (first primary))) `(let* ((result (call-method ,method)) (next (if (typep result 'fixnum) (1+ result) 0))) (defmethod ,(closer-mop:generic-function-name gen) (&optional (a next)) a) result))) (defgeneric inc (&optional a) (:method-combination increment)) (defmethod inc (&optional a) :start)
呼んでみます。
CL-USER> (dotimes (i 10) (print (inc))) :START 0 1 2 3 4 5 6 7 8 NIL
オプショナル引数を利用することで、任意の値から再開することもできます。
CL-USER> (inc 100) 100 CL-USER> (inc) 101
最早コンビネーション感がありません。
FizzBuzz: 王道ネタ
Incrementのマイナーチェンジですが、せっかくなのでFizzBuzzしてみます。
なお、メソッドコンビネーションによるFizzBuzzには下記の先行研究があります。
(ql:quickload :closer-mop) (define-method-combination fizz-buzz () ((primary ())) (:generic-function gen) (let ((method (first primary))) `(multiple-value-bind (result real-value) (call-method ,method) (let ((next (if (typep real-value 'fixnum) (1+ real-value) 1))) (defmethod ,(closer-mop:generic-function-name gen) (&optional (a next)) (if (typep a 'fixnum) (values (cond ((= (mod a 15) 0) "Fizz Buzz") ((= (mod a 5) 0) "Buzz") ((= (mod a 3) 0) "Fizz") (t a)) a) (values 1 1))) result)))) (defgeneric fz (&optional a) (:method-combination fizz-buzz)) (defmethod fz (&optional (a)) :start)
呼んでみます。内部の defmethod は多値を返すように定義していますが、表からは見えない辺りが気持ち悪くて良い感じです。
CL-USER> (dotimes (i 20) (print (fz))) :START 1 2 "Fizz" 4 "Buzz" "Fizz" 7 8 "Fizz" "Buzz" 11 "Fizz" 13 14 "Fizz Buzz" 16 17 "Fizz" 19 NIL
こちらも、オプショナル引数を渡すことで任意位置からの再開ができます。
CL-USER> (fz 3) "Fizz" CL-USER> (fz) 4
メソッドコンビネーションがなんだか分からなくなってきました。
おわり
*1:本当は call-method の第2引数に循環リストを渡したかったのですが、call-next-methodでスタックオーバーフローしてしまうので泣く泣く回数制限をつけました。
define-method-combinationを理解する
Lisp メソッドコンビネーション Advent Calendar 2018の3日目の記事です。
任意のメソッドコンビネーションを自作するマクロであるdefine-method-combinationのリファレンス(CLHS)を眺めていたのですが、中々理解するのに苦労しました。次のような所に難しさがある気がします。
- どの部分が任意に決めて良いもので、どの部分が決まった文法なのか分かりにくい
- どの部分がいつ利用・評価されるのか分かりにくい
defgeneric時なのか、defmethod時なのか、コンパイル時なのか、実行時なのか…
- （そもそも用語が多い上に動きもイメージし辛いので、↑の辺りが飲み込めてこないと説明を見ても頭に入ってこない）
この辺りを念頭に置きつつ、例を見ながら理解した内容を整理したいと思います。
段階的で良い感じだったので、例としてはCLHS内のorの例を中心に見ていきます。
前置き：メソッドコンビネーション or の動作
メソッドコンビネーション or の動作について1例を。or という名称から想像が付くように、非nilが返る（か最後に到達する）まで適用可能なメソッドを順に呼んでいきます。
;; ※def系の出力略 CL-USER> (defgeneric test-or (a) (:method-combination or)) CL-USER> (defmethod test-or or ((a fixnum)) ; 結果がnilなので次も呼ぶ (print "fixnum type returns nil") nil) CL-USER> (defmethod test-or or ((a number)) ; 結果がtrueなのでここで終わり (print "number type returns t") t) CL-USER> (defmethod test-or or (a) ; 下の例では呼ばれない (print "any type returns nil") nil) CL-USER> (test-or 1) "fixnum type returns nil" "number type returns t" T
なお、"7.6.6.4 Built-in Method Combination Types"にあるようにビルトインのメソッドコンビネーションとして存在します。
Short Form
define-method-combination には、Short FormとLong Formの2つの形態があります。この記事ではLong Formの説明を中心に行いたいので、Short Formについては下のようにすれば or を定義できますという程度に留めます。
(define-method-combination or :identity-with-one-argument t)
なお、:identity-with-one-argumentはちょっとした最適化のためのオプションで、or や progn, +, max のように、1引数で呼び出した場合にその引数の結果がそのまま全体の結果となる（Ex. (or x) -> x）ようなオペレータに対して指定できます。
Long Form
本題のLong Formです。
CLHSのdefine-method-combinationの項より、定義のうち後ろの説明で出てくるあたりを抜粋しておきます。
define-method-combination name lambda-list (method-group-specifier*) form* method-group-specifier::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
短めのLong Form
orの実装例として3つのLong Formが示されていますが、まずはその中でもShortなLong Formの例です。後述のLongなLong Formと見比べるとかなり短いですが、こちらがじっくり理解できれば、Longな方もすんなり入ってくると思います。
(define-method-combination or () ((methods (or))) `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) methods)))
前の方から順番に見ていきます。
まずは定義の name に当たる or ですが、これはもちろん (defgeneric method (:method-combination or)) で指定する名前です。Long Formにおいては名前以上の意味を持たないので任意につけて問題ありません。
次にlambda-formに当たる部分ですが…今の例では空（()）なので後ろで見ます。ここで定義したものもdefgenericで利用するという部分だけ抑えておきます。
肝となるのが、次の(method-group-specifier*)に当たる((methods (or)))です。これはletのように(変数名 束縛対象)の組み合わせが並んだものです。ここでは、(methods (or))の一組だけが定義されています。
まずはmethodsです。この部分、他の例も合わせて見るとbeforeやらafterやらprimaryやら、いかにも意味ありげな名前がついているため、何か決まりがあるようにも見えます。が、define-method-combination内部（後に続くform内）だけで利用する変数名なので、letの要領で好きに名前をつければ良いです。ここには、defmethodで定義されるメソッドのリストが（よりspecificなものが前に来る順序で）束縛されます。例えば、下のような定義がある場合、(test-or 100)という呼び出しに対してはA, B, Cの3つのメソッドが、(test-or :hoge)という呼び出しに対してはCのメソッドのみが、リストの要素になってmethodsに束縛されます。
;; ※冒頭の例を再掲 CL-USER> (defgeneric test-or (a) (:method-combination or)) CL-USER> (defmethod test-or or ((a fixnum)) ; --- A (print "fixnum type returns nil") nil) CL-USER> (defmethod test-or or ((a number)) ; --- B (print "number type returns t") t) CL-USER> (defmethod test-or or (a) ; --- C (print "any type returns nil") nil)
束縛時に選択されるメソッドについてさらに詳しく見ると、次の2つに共に合致するものが選ばれます。
- 実行時の情報を利用する動的なマッチング
- 平たく言えば型による（多重）ディスパッチのことです *1
- 定義時の情報を利用する静的なマッチング（以下の2つのマッチング）
define-method-combinationで指定するmethod-group-specifier（ここで議論している(methods (or))のこと）defmethodで指定するmethod-qualifier(defmethod hoge-method :a :b :c (x y) ...)のようにメソッド名と引数リストの間に任意の数のシンボルを書くことができ、これをリストにしたもの（(:a :b :c)）をmethod-qualifierと呼びます
つまり、(methods (or))の(or)はdefmethod時に、定義されたメソッドをmethodsに束縛するべきかを静的に判断するための情報になります。(defmethod test-or or (a) ...)におけるorの指定は一見二度手間に見えますが、define-method-combinationで指定されているために必要なものということになります。逆に言うと、defmethod時に指定させたいものであればなんでも良く、メソッドコンビネーション自体の名前orと一致させているのは単にその方が分かり易いからというだけの理由です。
さて、(or)はリスト形式での指定の1例でしたが、大きくは以下3つの指定方法があります。定義上は最初の2つが qualifier-pattern にあたるもので、3つ目が predicate に相当します。
- シンボル（
*のみ可）: 任意の値・数のmethod-qualifierにマッチ- 例.
(methods *)
- 例.
- リスト:
method-qualifierとのequal結果がtrueとなるものにマッチ- 例.
(methods (a b))とした場合、(defmethod hoge a b (arg) ...)のようなメソッドにマッチ - 補足
()とすると、(defmethod hoge (arg) ...)のようにmethod-qualifierの指定がないものにマッチ(a . *)のようにすると、car部がaの任意のmethod-qualifierにマッチ要素数2つ以上のリストなんていつ使うんだろうか…
- 例.
- 関数シンボル:
method-qualifierを引数として渡して結果がtrueとなるものにマッチ- 例. 次のような定義の
qualifier-number-p関数を定義したとすると、(methods qualifeir-number-p)は(defmethod hoge 999 (arg) ...)のようなメソッドにマッチ
- 例. 次のような定義の
(defun qualifier-number-p (method-qualifier) (and (= (length method-qualifier) 1) (numberp (car (method-qualifier)))))
なお、複数の method-group-specifier にマッチする場合は、定義順で最初にマッチしたものに束縛される仕様です。
最後にようやく form* 部分です。formの目的は、methods に束縛されたメソッドのリストをどのように呼び出すかを決定することです。例えば、先頭のメソッドを1つ呼びたいだけであれば次のように書けます。
`(call-method ,(first methods))
特徴的なのは call-method ですが、名前の通りメソッドの呼び出しを指示するものです。関数に対する funcall のメソッド版とイメージすると分かり易いかと思います。ただし、funcall とは異なりメソッド自体の引数は隠蔽されています。メソッドそのものとは別にoptionalな引数を1つ取りますが、これについては次の節で見ていきます。
さて、改めて実装例を見てみると、form部分ではorの中にリスト内の各メソッドに対する call-method を繋ぎ込んでいることが分かります。これにより、前から順にtrueが出るまでメソッドを呼び出すという動作を実現できたことになります。
;; ※再掲 (define-method-combination or () ((methods (or))) `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) methods)))
長めのLong Form
CLHSには or のより長い実装例が2つありますが、一度に色々取り込んでいて説明しづらいので、少しずつ足しながら見ていきます。
aroundの実装
いわゆるaround機能を付加します。この実装から次のことを見ていきます。
call-methodの第2引数についてmake-methodについて
先にaroundの動作を簡単に確認します。下記のように、本来呼び出されるはずの{1}に先立ち、{2}でaroundとして定義したメソッドが呼び出されます。本来のメソッド{1}を呼び出すためには call-next-method を利用して明示的に呼び出す必要があります。
CL-USER> (defgeneric test-or (a) (:method-combination or)) CL-USER> (defmethod test-or or (a) (print "primary") t) ; --- {1} CL-USER> (defmethod test-or :around (a) ; --- {2} (print "around") (call-next-method a)) CL-USER> (test-or 100) "around" "primary" t
そしてその実装です。
(define-method-combination or () ((around (:around)) (primary (or)) (let ((form `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))
まず目に付くのは、method-group-specifier が2つに増えている部分です。(defmethod hoge :around (...) ...)を引っかけるために、(around (:around)) が追加されています。なお短めの実装の方で methods となっていたものは primary となっていますが、これは束縛先の名前が変わっただけです。
次に、短めの実装では直接書き下していた本体部分を、いったん let で form という変数に束縛しています*2。続く (if around ...) のelse部分では単純にこれを置くだけなので、短めの実装と同じ動作になります。
ということで、around が存在する場合の処理を見てみます。まず、call-methodの第1引数としてaroundの最初のメソッドを渡すことで、aroundとして定義したメソッドを呼び出していることが分かります。そして第2引数としてメソッドのリストを渡しています。これは、call-next-method（とnext-method-p）で内部的に利用されるリストで、ここにあるものを前から順に呼んでいくことになります。さて、実装例を見ると2つのものを連結してリストを作成しています。1つはaroundの残りの部分です。もう1つが初登場のmake-methodの返り値です。これは、読んで字のごとくメソッドを生成する関数 *3 です。引数として form を受け取って、これをメソッド化します。
orderの実装
次にメソッドの呼び出し順序の実装です。この実装から次のことを見ていきます。
- メソッドコンビネーションの引数
method-group-specifierの引数
先に呼び出し順を逆順にする例を確認します。
;; defgeneric で :most-specific-last を指定 TEMP> (defgeneric test-or-rev (a) (:method-combination or :most-specific-last)) TEMP> (defmethod test-or-rev or ((a fixnum)) ; ここは呼ばれない (print "fixnum type returns nil") nil) TEMP> (defmethod test-or-rev or ((a number)) ; ここまで呼ばれる (print "number type returns t") t) TEMP> (defmethod test-or-rev or (a) ; ここから呼ばれる (print "any type returns nil") nil) TEMP> (test-or-rev 1) "any type returns nil" "number type returns t" T
そしてその実装です。
(define-method-combination or (&optional (order ':most-specific-first)) ; ここに引数 order を追加 ((around (:around)) (primary (or) :order order)) ; ここで order を指定 (let ((form `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary))))) (if around `(call-method ,(first around) (,@ (rest around) (make-method ,form))) form)))
さっくり見ていきます。
- メソッドコンビネーションの引数 =
(&optional (order ':most-specific-first)defgeneric時に利用されるもので、本節最初の例で:most-specific-lastを指定していた部分に相当します- ※短めの例では空リストとなっていた部分です
method-group-specifierの引数 =(primary (or) :order order)defgeneric時に指定した引数を元に実行順序を指定しています- この引数には
:orderの他に次の2つがあります:descriptionは名前の通りドキュメント用の文字列を取ります:requiedをtrueとすると、該当するメソッドが見つからない場合実行時にエラーとなります
long-form-option::= :description description |
:order order |
:required required-p
なお、method-group-specifier の引数 :order を利用せずとも、次のように自前で実行順序の実装をすることもできます。前述のように、primary にはメソッドのリストが束縛されるため、逆順にしたければ単にこれを reverse するだけです。もちろん、必要に応じて任意の順序に並び換えることもできます。
(define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or))) ;; 自前での実行順序実装 (case order (:most-specific-first) (:most-specific-last (setq primary (reverse primary))) (otherwise (method-combination-error "~S is an invalid order.~@ :most-specific-first and :most-specific-last are the possible values." order))) (let ((form `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary)))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))
requiredの実装
orderの部分で既に触れていますが、該当するメソッドが見つからない場合、実行時にエラーとする機能の実装です。
単純なので実装を並べて終わりにします。次の例では、 primary に該当するメソッドがない場合、実行時にエラーとなります。
(define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or) :order order :required t)) ; ここに追加 (let ((form `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary))))) (if around `(call-method ,(first around) (,@ (rest around) (make-method ,form))) form)))
もちろん、自前でも実装できます。
(define-method-combination or (&optional (order ':most-specific-first)) ((around (:around)) (primary (or))) (case order (:most-specific-first) (:most-specific-last (setq primary (reverse primary))) (otherwise (method-combination-error "~S is an invalid order.~@ :most-specific-first and :most-specific-last are the possible values." order))) ;; ここが required に相当する実装 (unless primary (method-combination-error "A primary method is required.")) (let ((form `(or ,@(mapcar #'(lambda (method) `(call-method ,method)) primary)))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form)))
落ち穂拾い
上記で抜粋した定義では省略していましたが、他に :arguments と :generic-function という任意オプションがありますので、それぞれ簡単に見てみます。
define-method-combination name lambda-list (method-group-specifier*) [(:arguments . args-lambda-list)] [(:generic-function generic-function-symbol)] form*
:arguments
:arguments を利用すると、メソッド実行時にメソッドの引数を拾うことができます。
(define-method-combination ex-of-arguments () ((primary ())) (:arguments a) `(progn (format t "Use arguments: ~A" ,a) ,@(mapcar #'(lambda (method) `(call-method ,method)) primary))) (defgeneric arg-test (x y) (:method-combination ex-of-arguments)) (defmethod arg-test ((x fixnum) (y fixnum)) (+ x y)) ;; 実行例 CL-USER> (arg-test 1 2) Use arguments: 1 3
何に使えるのかは良く分かりませんが、CLHSではロックに使う例を紹介しています。
(define-method-combination progn-with-lock () ((methods ())) (:arguments object) `(unwind-protect (progn (lock (object-lock ,object)) ,@(mapcar #'(lambda (method) `(call-method ,method)) methods)) (unlock (object-lock ,object))))
:generic-function
:generic-function を利用すると、generic function自体を受け取ることができます。
(ql:quickload :closer-mop) (define-method-combination ex-of-gen () ((primary ())) (:generic-function gen) `(progn (print (closer-mop:generic-function-name ,gen)) ,@(mapcar #'(lambda (method) `(call-method ,method)) primary))) (defgeneric gen-test () (:method-combination ex-of-gen)) (defmethod gen-test () :hoge)
何に使えるのかはさっぱり見当がつきません。こちらに至ってはCLHSにすら例がありません。
おまけ: standardの実装
method-qualifierを取らなかったり、:beforeや:afterがあったりと、何かと特別な感じがするデフォルトのメソッドコンビネーションですが、その気になれば自前で実装できますという例がCLHSに載せられています。
新しい要素はないため例をそのまま掲載するだけですが、これを眺めていると define-method-combination は良くできているものだなあと感心してしまいます。
(define-method-combination standard () ((around (:around)) (before (:before)) (primary () :required t) (after (:after))) (flet ((call-methods (methods) (mapcar #'(lambda (method) `(call-method ,method)) methods))) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 (progn ,@(call-methods before) (call-method ,(first primary) ,(rest primary))) ,@(call-methods (reverse after))) `(call-method ,(first primary))))) (if around `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))))
おわりに
Q. それで、define-method-combination っていつ使うんですか？ A. さあ？
AWS LambdaでDockerHubの定期ビルドを設定したときのメモ
DockerHubに登録しているCommon Lisp実行環境eshamster/cl-baseと、それをベースとした開発環境eshamster/cl-devel2ですが、RoswellやQuicklispリポジトリがそれなりの頻度で更新されるので、latestに対しては定期的に更新をかけておきたかったです。そのために、AWS Lambdaをcron代わりに設定したときのメモです。
単なるメモなので過不足たくさんで、特にまとまってもいません。
想定読者
想定シチュエーション
- 大体の操作はWebコンソールで実施する
- 特に高度な使い方はしていないので、メモは極薄です
- 言語には取りあえずNode.jsを選択する（執筆時点で最新のNode.js 8.10）
- Node.jsのモジュールを含めたいので関数の実体は手元の開発機で作成する
- 開発機がリモートにあってWebコンソールではzipの移動が面倒なので、アップロードだけはawsコマンドで実施する
開発環境の用意（on Docker）
Node.jsの開発やAWSへのアップロードを行うための開発環境を作っておきます。ということで、まずDockerfileを用意します。
lessは最初から入っていますが、デフォルトではaws helpでエラーになってしまうので、アップデートしておきます。ついでに、デフォルトのviだけでは物寂しいのでvimを入れておきます。
FROM node:8.10.0-alpine
RUN apk --update add py-pip && \
pip install awscli &&\
apk --update add less groff && \
apk --update add vim
WORKDIR /root
RUN mkdir /root/.aws
COPY credentials config /root/.aws/
COPY .vimrc /root/
毎回 aws configure するのも面倒なので、同コマンドで生成されるファイルを用意しておいて、docker build時にコピーしてしまいます。後から思うに、この辺りは環境変数の設定でやる方が賢かった気がします。
$ cat config [default] output = json region = us-west-2
$ cat credentials [default] aws_access_key_id = XXXXXXXXXXXXX aws_secret_access_key = XXXXXXXXXXXXX
.vimrcですが、普段はEmacsを使っていて特にこだわりの設定もないので、タブの設定だけしておきます。好み8割、AWS LambdaのWebエディタのデフォルト設定に合わせて置きたい気持ちが2割です。
$ cat .vimrc set expandtab set tabstop=4 set shiftwidth=4
ここまでのものはcredentialsを.gitignoreした上でGitHubに上げました。
IAMの設定
- 適当にユーザを用意します
- （credentialsの設定をしているので済のはずですが）
- 適当にグループを用意して上記のユーザを所属させます
- グループにインラインポリシーを設定します
「AWS Lambda でアイデンティティベースのポリシー (IAM ポリシー) を使用する」あたりも見つつ、必要なActionだけを登録していく…つもりだったのですが、面倒になってlamdba:*としてAWS Lambda系の関数を全許可しています*2。
なお、アップロードしたファイルはS3上に置かれるようなので、ダウンロードしようと思うとS3系の権限もいるのかもしれません（今回は一方的なアップロードしかしていないので試していません）。
{ "Version": "2012-10-17", "Statement": [ { "Sid": "AllLambdaFunctions", "Effect": "Allow", "Action": "lambda:*", "Resource": "*" } ] }
反映には数分かかるようなので他にすることがなければ待ちます。
# Dockerコンテナ上 $ while : ; do aws lambda list-functions ; if [ $? -eq 0 ]; then break ; fi ; sleep 10; done
関数を作成する
AWS Lambdaに関数を追加する
Webコンソール上で適当に作成してNode.js 8.10を選んでおきます。以上。
関数の実体を作成する
Dockerコンテナ上での作業です。Docker HubのビルドをトリガするためのNode.jsファイルを作成します。
準備として、フォルダを用意してcurl代わりのrequestモジュールをインストールしておきます。
$ mkdir sample $ cd sample $ npm install request
Node.jsコードの前に、curlでlatestタグのビルドをトリガする凡例を示すと次のようになります。<image_name>は、例えばeshamster/cl-baseで、<token>はDocker HubのBuild Settingsのページで取得できます（また、同ページでcurlの例を見ることもできます）。
$ curl -H "Content-Type: application/json" --data '{"docker_tag": "latest"}' -X POST https://registry.hub.docker.com/u/<image_name>/trigger/<token>/
requestモジュールを使って、これをNode.js実装に置き換えます。TODOがあったりエラー処理がおざなりだったりしますが見なかったことにします。${event.*}の部分が実行時に与えるパラメータです。docker_tagの指定もパラメータ化した方が良い気もしますが、当面latest以外に適用する見込みもなかったので直に指定しました。
$ cat index.js exports.handler = (event, context) => { const request = require('request'); /* TODO: Check event.image_name and event.token */ let options = { url: `https://registry.hub.docker.com/u/${event.image_name}/trigger/${event.token}/`, method: 'POST', headers: { 'Content-Type': 'application/json', }, body: JSON.stringify({ "docker_tag": "latest" }) }; let response = request(options, (err, res, body) => { console.log('ERR: ' + err); }); return response; };
アップロードする
zip化した上で、AWS Lambdaにアップロードします。
zip化ですが、解凍されたときにindex.jsがルートに来るように注意します。
$ cd ~/sample $ ls index.js node_modules package-lock.json $ zip -r ../sample.zip * ...
ここまで来れば、後はコマンド1発でアップロード完了です。
$ cd $ aws lambda update-function-code --zip-file fileb://sample.zip --function-name <function名>
helpが充実しているので、それらしいサブコマンドを aws lambda help で見繕って、さらにそのサブコマンドのhelpを見る、という感じで使い方が分かるのは良いですね。
AWS Lambdaの設定
ここからはまたWebコンソール上での作業です。
タイムアウトの設定変更
DockerHubからレスポンスが返ってくるまで数秒かかるので、デフォルトのタイムアウト（3秒）では心許ないです。10秒にしておきます。
CloudWatchの設定
cron代わりにCloudWatch Eventsを設定します。
イベントソースはcron式のスケジュールを設定します（例. 0 15 ? * FRI * ← 日本時間の土曜0時）。rate式にしなかったのは、 近い時間にcl-base → cl-devel2 と実行したかったためです。
入力の設定は「定数 (JSON テキスト)」を選択し、先程のNode.jsソースの${event.*}に対応する値を設定します。
{ "image_name": "eshamster/cl-base", "token": "xxxxxxxxxxxxxxx" }
以上で週1でDockerHub上のイメージの更新が走るようになりました（完）
[Common Lisp] Obsoletedなエイリアスを定義するマクロ
小さなマクロ1個の小ネタ（＋おまけ）です。
ライブラリを書き、ある程度使ったあたりで関数名などの命名のまずさに気付くこともあると思います。かといって、いくつかのプロジェクトで使い始めているので、今さら名前を変更するのも面倒臭い…。そういったときに、旧名はエイリアスとして残しておいて、使われたときには警告を出すというのは常套手段であると思います。
Common Lispにはそういった時にデフォルトで利用できるものが見つからなかったので、6行程度の簡単なマクロを書いてみたメモです。
目次
利用イメージ
(defun bad-name-func (x y) (+ x y))
うっかりダメな名前で関数を作ってしまった…。しかも、もう外で使われている…。
(defun good-name-func (x y) (+ x y)) (def-obsoleted-alias bad-name-func good-name-func)
関数名を改善する。互換性を保ちたいので、旧名もエイリアスとして残しておく（def-obsoleted-alias の実装は後述）。
> (bad-name-func 1 2) ; Warning: "BAD-NAME-FUNC" is obsoleted. Please use "GOOD-NAME-FUNC" instead. ; While executing: BAD-NAME-FUNC, in process repl-thread(13). 3
引き続き旧名も使える、が怒られる。
実装
def-obsoleted-alias の実装は次の通りです。エイリアスとして旧名でマクロを生成します。生成されたマクロは利用時（コンパイル時）に警告を出力します。
(defmacro def-obsoleted-alias (obsoleted-name alter-fn) (let ((rest (gensym))) `(defmacro ,obsoleted-name (&rest ,rest) (warn ,(format nil "\"~A\" is obsoleted. Please use \"~A\" instead." obsoleted-name alter-fn)) `(,',alter-fn ,@,rest))))
未だにマクロを生成するマクロはじっくり見ていると良く分からなくなってくるので、一例展開してみると次のようになります。生成されたbad-name-macroマクロは、利用箇所で単なるgood-name-funcの呼び出しに展開されるため、実行時のオーバーヘッドはありません。
(def-obsoleted-alias bad-name-func good-name-func) ;; -> (defmacro bad-name-func (&rest #:g346681) (warn "\"bad-name-func\" is obsoleted. Please use \"good-name-func\" instead.") `(good-name-func ,@#:g346681))
次に書く問題はあるのですが、お手軽なのでちょっとした用途には十分かと思います。
その問題ですが、bad-name-funcが関数からマクロに変わってしまったため、applyしているなど明示的に関数扱いしているコードに対しては互換性を保てないというものです。後ろのおまけで関数生成バージョンも試してみますが、マクロ生成バージョンではコンパイル時に警告を出せるのに対し、関数生成バージョンでは実行時まで警告を出せません。差し引きで（簡易利用用途としては）マクロ生成バージョンの方が良いだろうと思っています。
おまけ
関数生成バージョン
エイリアスをマクロとしてではなく関数として生成してみます。
前述の通り、警告の出力タイミングは実行時になります。頻繁に利用する関数で何度も警告を出すと応答不可になりかねないので、一度警告が出された関数はハッシュテーブルに記録して二度は出ないようにしています*1。
(defvar *table-output-obsoleted-warning* (make-hash-table)) (defun has-output-obsoleted-warning-p (obsoleted-name) (gethash obsoleted-name *table-output-obsoleted-warning*)) (defun register-output-obsoleted-warning (obsoleted-name) (setf (gethash obsoleted-name *table-output-obsoleted-warning*) t)) (defmacro def-obsoleted-fun (obsoleted-name alter-fn) (let ((rest (gensym))) `(defun ,obsoleted-name (&rest ,rest) (unless (has-output-obsoleted-warning-p ',obsoleted-name) (warn ,(format nil "\"~A\" is obsoleted. Please use \"~A\" instead." obsoleted-name alter-fn)) (register-output-obsoleted-warning ',obsoleted-name)) (apply #',alter-fn ,rest))))
展開例は次のようになります。
(def-obsoleted-fun bad-name-func good-name-func) ;; -> (defun bad-name-func (&rest #:g346722) (unless (has-output-obsoleted-warning-p 'bad-name-func) (warn "\"bad-name-func\" is obsoleted. Please use \"good-name-func\" instead.") (register-output-obsoleted-warning 'bad-name-func)) (apply #'good-name-func #:g346722))
アノテーションにしてみる
関数のObsolete化というと、C# のObsolete属性や Java の @deprecated アノテーションのように、アノテーション的にやるイメージがあるので、試しに cl-annotを使ってアノテーション化してみます。
(ql:quickload :cl-annot) (use-package :cl-annot) (enable-annot-syntax) (defannotation obsoleted-alias ((&rest obsoleted-names) definition-form) (:arity 2) `(progn ,@(mapcar (lambda (name) `(def-obsoleted-alias ,name ,(cl-annot.util:definition-form-symbol definition-form))) obsoleted-names) ,definition-form))
次のように使います。一応、obsoletedな名前はカッコ内に複数並べて書けるようにしています。これで何度下手な名付けをしても安心です :-)
@obsoleted-alias (bad-name-func) (defun good-name-func (x y) (+ x y))
本格的にcl-annot と連携しようと思うと、 @export （など？）との兼ね合いも考えないといけないので、これでは足りないのでしょうね…。
追記：コンパイラマクロ利用版
コメントでコンパイラマクロを利用する方法を教えて頂きました。「コンパイル時に何か（警告出力）したい」という話なので確かにコンパイラマクロが適任ですね。頭になかったです……。
(defmacro def-obsoleted-alias (obsoleted-name alter-fn) (let ((rest (gensym))) (flet ((make-body () (if (macro-function alter-fn) ``(,',alter-fn ,@,rest) `(apply #',alter-fn ,rest)))) `(progn (,(if (macro-function alter-fn) 'defmacro 'defun) ,obsoleted-name (&rest ,rest) ,(make-body)) (define-compiler-macro ,obsoleted-name (&rest ,rest) (warn ,(format nil "\"~A\" is obsoleted. Please use \"~A\" instead." obsoleted-name alter-fn)) ,(make-body))))))
REPLでの利用時はコンパイルが走らないため警告が出ませんが、最終的にコードに落とす段階で気付けるので実用上の問題はないと思われます。
さらに追記：最初 def-obsoleted-fun の代替として関数対応版を書いたのですが、せっかくなので関数・マクロ両用版に書き直しました。
; ; 準備 (defun good-name-func ()) (defmacro good-name-macro ()) ;; 関数の場合 (def-obsoleted-alias bad-name-func good-name-func) ;; -> (progn (defun bad-name-func (&rest #:g347909) (apply #'good-name-func #:g347909)) (define-compiler-macro bad-name-func (&rest #:g347909) (warn "\"bad-name-func\" is obsoleted. Please use \"good-name-func\" instead.") (apply #'good-name-func #:g347909))) ;; マクロの場合 (def-obsoleted-alias bad-name-macro good-name-macro) ;; -> (progn (defmacro bad-name-macro (&rest #:g347910) (list* 'good-name-macro #:g347910)) (define-compiler-macro bad-name-macro (&rest #:g347910) (warn "\"bad-name-macro\" is obsoleted. Please use \"good-name-macro\" instead.") (list* 'good-name-macro #:g347910)))
*1:流石に1回出力ではどこで利用されているかの追跡が困難なので、キーにパッケージも加えて、1つのパッケージで1回までなどとした方が良さそうです
