2018-12-13

LISP: '$e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E

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

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

(loop (print "e"))

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

e.c

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

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

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

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

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

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

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

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

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

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

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

おまけです。

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

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

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

「(ﾟДﾟ)」: 48個分 (※48 = '0')
「工」: 8個分
「エ」: 4個分
「ェ」: 1個分

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

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

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

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

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

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

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

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

動かしてみます。

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

0
1
1
2
3
5
8
13
21
34
NIL

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

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

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

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

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

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

補足です。

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

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

一応同関数の実装です。

(ql:quickload :alexandria)

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

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

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

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

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

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

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

2018-12-10

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

Lisp Lisp-Parenscript プログラミング

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

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

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

完成品: https://github.com/eshamster/ps-experiment/blob/729e74261e45f30cba8b106443e111175466f24e/defines/defmethod.lisp

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

実装しないもの
前提：ps-experiment
実装
動作確認

実装しないもの

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

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

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

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

前提：ps-experiment

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

github.com

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

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

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

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

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

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

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

commonLispUser._internal.__psMainFunc__();"

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

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

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

実装

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

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

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

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

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

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

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

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

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

ゴール

先に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で型を文字列として取り出して文字列比較するみたいな話になるので、ディスパッチのような基礎的な部分に入るオーバーヘッドとしては許容しがたい雰囲気もあり、余り前向きではないです…

2018-12-03

小ネタ: define-method-combinationで遊ぶ

Common Lisp

Lisp メソッドコンビネーション Advent Calendar 2018の4日目の記事です。

枠が空きそうな雰囲気だったので、前日の define-method-combination 解説記事を書いていて思い付いた小ネタを供養しておきます。

Blackhole: 呼ぶと消える
Escher: 親の親は自分
Increment: 呼んだらインクリメント
FizzBuzz: 王道ネタ

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でスタックオーバーフローしてしまうので泣く泣く回数制限をつけました。

2018-12-02

define-method-combinationを理解する

Lisp

Lisp メソッドコンビネーション Advent Calendar 2018の3日目の記事です。

任意のメソッドコンビネーションを自作するマクロであるdefine-method-combinationのリファレンス(CLHS)を眺めていたのですが、中々理解するのに苦労しました。次のような所に難しさがある気がします。

どの部分が任意に決めて良いもので、どの部分が決まった文法なのか分かりにくい
どの部分がいつ利用・評価されるのか分かりにくい
- defgeneric時なのか、defmethod時なのか、コンパイル時なのか、実行時なのか…
（そもそも用語が多い上に動きもイメージし辛いので、↑の辺りが飲み込めてこないと説明を見ても頭に入ってこない）

この辺りを念頭に置きつつ、例を見ながら理解した内容を整理したいと思います。

段階的で良い感じだったので、例としてはCLHS内のorの例を中心に見ていきます。

前置き：メソッドコンビネーション or の動作
Short Form
Long Form
- 短めのLong Form
- 長めのLong Form
落ち穂拾い
- :arguments
- :generic-function
おまけ: standardの実装
おわりに

前置き：メソッドコンビネーション `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. さあ？

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

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

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

2018-10-22

AWS LambdaでDockerHubの定期ビルドを設定したときのメモ

AWS AWS Lambda プログラミング

DockerHubに登録しているCommon Lisp実行環境eshamster/cl-baseと、それをベースとした開発環境eshamster/cl-devel2ですが、RoswellやQuicklispリポジトリがそれなりの頻度で更新されるので、latestに対しては定期的に更新をかけておきたかったです。そのために、AWS Lambdaをcron代わりに設定したときのメモです。

単なるメモなので過不足たくさんで、特にまとまってもいません。

想定読者

AWSアカウント作ったは良いものの特に使ってない人
それcronで良くない？と言わない人 *1

想定シチュエーション

大体の操作はWebコンソールで実施する
- 特に高度な使い方はしていないので、メモは極薄です
言語には取りあえずNode.jsを選択する（執筆時点で最新のNode.js 8.10）
Node.jsのモジュールを含めたいので関数の実体は手元の開発機で作成する
- 開発機がリモートにあってWebコンソールではzipの移動が面倒なので、アップロードだけはawsコマンドで実施する

開発環境の用意（on Docker）
IAMの設定
関数を作成する
AWS Lambdaの設定
- タイムアウトの設定変更
- CloudWatchの設定

開発環境の用意（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に上げました。

github.com

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上のイメージの更新が走るようになりました（完）

*1:cronにしなかったのは、単にAWS Lambda 使ってみたかったというのが主な理由で、開発機（VM）はできるだけ軽くしておきたいというのがもう一つの理由です

*2:権限が足りない場合、エラーメッセージでどのActionの権限がないか丁寧に教えてくれるので難しいことはないのですが、後述の、反映に数分かかるのが面倒臭く…

2018-10-02

[Common Lisp] Obsoletedなエイリアスを定義するマクロ

Common Lisp Lisp

小さなマクロ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回までなどとした方が良さそうです

2018-06-03

XBLA版, Steam版の斑鳩におけるアナログスティックの挙動について

ゲームゲーム-STG ゲーム-STG-斑鳩

XBLA版, Steam版*1の斑鳩におけるアナログスティックの挙動について、↓のような雑なツイートをしました。

（分かりにくい説明）Steam斑鳩のアナログスティック操作は単方向が3段階なので、単純に組み合わせると32方向に操作できる。外周に限っても図右上の赤線のように24方向（5×4+4）。実際には左上の紫の点に限定しているようで、青線のように16方向（3×4+4）になっている（たぶん） pic.twitter.com/TANtCKwOWY
— ESH (@eshamster) 2018年5月30日

個人的にはこのアナログスティックの挙動は大変素晴らしいものだと思っていて、また決して偶然にできるものではなく、アナログな操作感とデジタルな精密さを両立すべく良く練られたものだと思っています。…という内容や気持ちを伝えるにはツイッターでは余白が狭すぎたので、記事にしてみた次第です*2。

前段：8方向の場合
アナログスティックの挙動
- 上下左右の移動
- 斜め方向の移動
  - 8方向版を単純に拡張した場合の挙動
  - 実際の挙動
終わりに

前段：8方向の場合

ツイートでは図の見方も説明できていなかったので、その説明も兼ねて8方向のシンプルな場合について考えます。

十字キーやアーケードスティックで自機を操作する場合、上下左右と斜め4方向の、計8方向に動かすことができます。このとき、それぞれの方向の速さを考えてみます。特別な理由がなければ上下左右の4つの速さは等しくするでしょうし、同じく斜め方向の4つの速さも等しくするでしょう。しかし、前者の速さと後者の速さの関係については概ね2つの選択肢が考えられます。

1つはどちらも同じ速さにするというものです。横方向・縦方向の速さを軸とした平面上にこれらを置くと下図のように円周上に並びます。

f:id:eshamster:20180602144720p:plain:w450

もう1つは、斜め移動の場合でも、縦方向の速度、横方向の速度をともに維持するというものです。言い方を変えると、単純に横方向の速度と縦方向の速度を合成したものになります。同じく平面上に置くと下図のように四角形の上に並び、斜め方向は長い= 速さが大きいことになります。

f:id:eshamster:20180602145608p:plain:w450

物理的（？）にはどの方向にも等速で動く円形型が正しいですが、ゲームにおいてどちらが適しているかは場合によると思います。実際、斑鳩では後者の四角形型を採用しています。理由は推測するしかないですが、画面の広い範囲を動く傾向が強い斑鳩においては、速度を落とす選択肢を取りたくないといったことや、上下方向もしくは左右方向の速度は常に一定にしたいといったことなどが考えられそうです。

アナログスティックの挙動

本題のアナログスティックの挙動です。

特に弾幕系のような狭い隙間を正確に抜ける瞬間があるSTGでは、確実に真っ直ぐ動くことができるということは死活的に重要です。そのため、あえてアナログな挙動を突き詰める意味がない場合が多いと思われます。しかし、斑鳩というゲームにおいては数ドット単位での正確な立ち回り、という種類の精密さが求められることは皆無に等しく、そうした挙動を突き詰める余地があると言えます。それでも真っ直ぐに動けることの重要性は依然大きい訳ですが、XBLA版においてはこの辺りのバランスをきちんと詰めて来ました *3。

上下左右の移動

とりあえずは斜め方向は無視して、上下左右方向の移動がどうなっているかを見てみます。

ここで考えるべきことは単純で、例えば右なら右方向の速さを何段階に分けるかという点です。斑鳩において10段階や20段階に分けても嬉しくなさそうなことは直感的に想像できます。狙って速さを調整できる範囲を考えると、選択肢としては2段階～4段階程度が妥当と思われます。そして斑鳩では3段階を選んでいます*4。

f:id:eshamster:20180602184118p:plain:w450

調整の結果そうなったのだろう…だけでは詰まらないので少し理由を考えてみます。実際のところ、斑鳩ではほとんど3段階目=一番スティックを倒した状態しか使わないのですが、1段階目や2段階目にも特定の場面で使い所があります。それは敵レーザーに押されるときです。自機の最大速度はレーザーに押される速さより大きいので、アーケードスティック等で位置を維持するには細かくスティックを入れる・離すの繰り返しが必要になります。アナログスティックにおいてはその忙しさを解消しようとする意図が感じられます。特に1段階目は明らさまで、レーザーに押される速さと同じ速さに設定されています。そして2段階目はレーザーを僅かに押し返す速さに設定されています。こうした1段階目による静止、2段階目による微調整という辺りがアナログスティックで持ち込みたかった操作感なのかなと考えています。このためには、最低でも3段階が必要です。一方、これ以上細かく調整できても細か過ぎて有効には使えない…という辺りで3段階に落ち着いたように思います。

斜め方向の移動

ようやく冒頭のツイートで言及していた斜め方向の移動についての話題です。

8方向版を単純に拡張した場合の挙動

さて、アーケードスティックのような8方向の移動においては、斑鳩では単純に縦方向と横方向の合成して斜め方向の速度とする、四角形型のモデルを採用していました。一方、アナログスティックでの上下左右の移動としては、一方向に3段階の速さ持つ形を採用していました。ここでは、その2つを単純に組み合わせた場合に斜め移動がどうなるかを考えてみます。

斜め右上の方向について図にしてみます。

f:id:eshamster:20180602230416p:plain:w450

上方向に3段階、右方向に3段階あるため、これらを単純に組み合わせると、斜め方向の速度は3×3マスのグリッドの各頂点に相当します。したがって、スティックを目一杯倒して操作することを考えると、斜めには赤色の矢印で示した5方向に動けることになります。同じことが右下、左下、左上についても言えるので、斜めには5×4=20方向、これに上下左右を合わせて全部で24方向に動けます（無視した青い矢印も含めれば32方向）。

しかし、実装的には8方向版の自然な拡張であるこの挙動を、XBLA版斑鳩では採用していません。

実際の挙動

実際に採用されている挙動について、同じく斜め右上の方向を図示します。

f:id:eshamster:20180603013028p:plain:w450

先程と同様に計算すると、斜めには3×4=12方向、これに上下左右を合わせて全部で16方向となりました*5。結論だけを見ると元の8方向を2倍細かくしただけのように見えます。しかし、図を見ての通り、8方向で採用したモデル = 四角形型のモデルの単なる延長にあるものではないことから、明確な意図と綿密な調整の基に選びとられた仕様だと見るべきではないでしょうか。

これがいかに「自然」で馴染む操作になっているかの一つの証左として、（個人の感想でしかないですが…）少なくとも、自身はXBLA版をプレイしている最中にこの工夫に気づくことはなかった、ということを挙げたいと思います。同様の調整がなされていなかったSteam初期版を触って、初めてXBLA版での工夫に思い至ったのです。

終わりに

XBLAは海外で広く普及したハードであり、斑鳩を初めて触る人に届く可能性は大いに考えられたと思います。とすると、まずは手元の純正コントローラのアナログスティックで触ってみる人が多くいると想像できます。そのため、初対応で正解のない中で、アナログな挙動を突き詰めることには合理性があったのだと思います。

一方、Steam初期版は挙動が細か過ぎて真っ直ぐ進むことすら難しい（少なくとも自分の技量では）調整になってしまっていたことも、ある面では仕方のないものなのかと納得していました。というのは、パターンをNAOMI版に寄せることを優先していたように見えますし、複数解像度やキーボード操作への対応など泥くさい調整が多くあったようですし*6、またPCでは特定のコントローラを想定することが難しいため、アナログ挙動の調整の優先度が下がるのは止むを得ないと思えたからです。むしろ、アップデートによって、ニッチと思われる操作系を調整して頂けたのは大変ありがたいことだったと思っています。

あとは愚痴と妄想ですが、去る5月30日に販売の始まったNintendo Switch版、またもや真っ直ぐ進むことも難しい調整となっていました*7。Nintendo Switchの広まり方を考えれば、新たな客層にもそれなりに届くでしょうし、となるとまずは公式コントローラのアナログスティックでの操作が試みられるでしょう。そこに対してこの調整…。トレジャーはここ数年新作も移植も出しておらず、事実上解散状態にしか見えませんでしたが、余り深く考えないようにしてました。そして、移植とはいえ久々の作品で、優先しても良さそうなアナログスティックの操作、それもかつてはできていたもの、がおざなりな状態で出てきたのは、トレジャーの現状を突き付けてくるようで見るのが辛かったです。…というのが全部考え過ぎの妄想であればいいなと願っています。

→ 追記：8月8日配信のパッチでSwitch版にも調整が入りました。ありがとうございます！

*1: 2014年5月9日のアップデート後

*2:なお、XBLA版と修正後Steam版の挙動が同じ前提で書いていますが、きちんと裏を取っている訳ではないです…。実機確認はSteam版でやってます

*3:この辺りまで書いてから、そういえばDCやGCもアナログスティックついているけれど、アナログの挙動に対応していなかったのだろうか…とようやく疑問に思いました。実物を触ったことがないので確信を持てないのですが、一応ウィキペディアの記事を見る限りはXBLA版が初出のようですが

*4:なお、図では便宜上単純に3等分していますが、実際の速さはそうではないように思います

*5:青色の矢印で示した方向の速さが複数段階あるかは検証できていません

*6:参考: 『斑鳩』がSteamで近日配信　なぜいまSteamなのかをトレジャーに直撃 - ファミ通.com

*7:試した限り、上下左右方向が1つ増えて4段階で、しかもそれをそのまま斜めに拡張したように見えました

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

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

実装しないもの

前提：ps-experiment

実装

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

ゴール

defgeneric

実装

展開してみる

defmethod

実装

展開してみる

道具作り

Parenscript（JavaScript）部分

型とインスタンスの比較

型同士の比較

引数の処理

動作確認

Blackhole: 呼ぶと消える

Escher: 親の親は自分

Increment: 呼んだらインクリメント

FizzBuzz: 王道ネタ

前置き：メソッドコンビネーション or の動作

Short Form

Long Form

短めのLong Form

長めのLong Form

aroundの実装

orderの実装

requiredの実装

落ち穂拾い

:arguments

:generic-function

おまけ: standardの実装

おわりに

開発環境の用意（on Docker）

IAMの設定

関数を作成する

AWS Lambdaに関数を追加する

関数の実体を作成する

アップロードする

AWS Lambdaの設定

タイムアウトの設定変更

CloudWatchの設定

利用イメージ

実装

おまけ

関数生成バージョン

アノテーションにしてみる

追記：コンパイラマクロ利用版

前段：8方向の場合

アナログスティックの挙動

上下左右の移動

斜め方向の移動

8方向版を単純に拡張した場合の挙動

実際の挙動

終わりに

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

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

前置き：メソッドコンビネーション `or` の動作