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

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

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

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

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



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

現象

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

error: Package `jsonrpc-1.0.7' is unavailable

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

error: Package `flymake-1.0.5' is unavailable

再現手順

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

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

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

$ emacs -nw

調査

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

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

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

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

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

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

追記:解決

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

Failed to download ‘gnu’ archive.

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

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

通りました

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

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

Obsolete: 解決?

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

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

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

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

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

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

問題2: gofmt が効かない

現象(・再現方法)

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

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

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

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

調査

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

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

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

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

解決?

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

下記の my-gofmt-hookbefore-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-hookrevert-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) のためのライブラリを実装してみました。

eshamster.hatenablog.com

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

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

github.com



面倒なところ

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

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

用語について

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

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

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

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

f:id:eshamster:20170812024633p:plain

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

各層の実装

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

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

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

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

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

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

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

f:id:eshamster:20170812024633p:plain

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

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

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

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

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

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

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

プロトコル

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

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

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

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

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

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

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

クライアント層

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

おわりに

これは忘れる!


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

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

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

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

github.com

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

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



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

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

クラウドゲーム:

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

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

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

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

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

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

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

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

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

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

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

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

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

作ったもの

概要

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

デモっぽいもの

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

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

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

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

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

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

f:id:eshamster:20190506021417g:plain

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

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

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

もう少し詳細

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

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

プロトコル (JSON)

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

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

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

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

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

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

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

個別のデータである 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-drivermake-server で作成するWebSocketサーバです。次のようにしてクライアント側へメッセージを送信することができます。

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

描画処理

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

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

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

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

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

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

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

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

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

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

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

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

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

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

入力処理

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

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

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

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

クライアント処理

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

通信処理

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

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

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

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

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

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

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

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

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

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

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

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

描画処理

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

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

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

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

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

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

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

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

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

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

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

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

入力処理

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

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

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

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


足りないもの

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

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

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

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

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

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

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

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

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

ドローコールの削減

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

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

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

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

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

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

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

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

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

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

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

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

認証機能

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

続きの記事

eshamster.hatenablog.com


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

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

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

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

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

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

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

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

LISP: '$e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E

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

github.com

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

e.lisp

(loop (print "e"))

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

e.c

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

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

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

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

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

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

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

そうリーダーマクロです。$eEまでが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 はありません……

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

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

前提:ps-experiment

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

github.com

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

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

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

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

次のように、先程定義したfunc1func2が書き出され、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-itemdefmethodごとに生成されます。例えば次のような定義に対しては、type-listには(type-a nil)が格納され、func には関数の実体(単純化すると(lambda (a b) (print a) (print b)))が格納されます。

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

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

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

ゴール

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

defgeneric

実装

defgeneric.psdefgeneric.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.psdefgeneric.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-methodnext-method-pの実装のためにやたら長ったらしいです。

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

内側のlambdaが実際に外から引数を受け取って呼び出される処理の実体です。ここでローカル関数としてcall-next-methodnext-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.psdefmethod.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を組み上げます。返り値はJavaScriptArray.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-funcdefmethod.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はちょっとした最適化のためのオプションで、orprogn, +, 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 となっていますが、これは束縛先の名前が変わっただけです。

次に、短めの実装では直接書き下していた本体部分を、いったん letform という変数に束縛しています*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. さあ?

*1:厳密にはeqlによるディスパッチもありますが

*2:この部分、CLHSの例ではShort Formの:identity-with-one-argumentで述べたような1引数の場合の最適化が入っているのですが、見辛いので省略しました。以降同じです

*3:関数またはマクロ?CLHSを見る限り明言されていないようでした