fix と memo とそのおまけ。
不動点オペレータと関数のメモ化で大いに遊ぶのが流行っているみたいで（k.inaba さんの発端の記事、結城浩さんによるリンク集）、楽しそうなのでひっそり書いてみます。Common Lisp で、というか xyzzy でちょこちょこしてみます。
まずは普通に。
とりあえず不動点オペレータを教科書的に書いてみます。funcall が健全な精神に対して極めて有害そうであることがよく判ります。
;;;figure.1
(defun %fib (f)
#'(lambda (x)
(if (<= x 1) 1
(+ (funcall f (- x 1))
(funcall f (- x 2))))))
(defun fix (f)
(funcall #'(lambda (g) (funcall g g))
#'(lambda (h)
#'(lambda (x)
(funcall (funcall f (funcall h h)) x)))))
(setf (symbol-function 'fib) (fix #'%fib))メモ化やデバッグ処理の埋め込みに関しても、不動点オペレータにオリジナルの JavaScript 版と同じ様な変更を加えることで書けます。
;;;figure.2
(defun fix/memo (f)
(let ((ht (make-hash-table)))
(funcall #'(lambda (g) (funcall g g))
#'(lambda (h)
#'(lambda (x)
(let ((y (gethash x ht)))
(or y (setf (gethash x ht)
(funcall (funcall f (funcall h h)) x)))))))))
(defun fix/debug (f)
(funcall #'(lambda (g) (funcall g g))
#'(lambda (h)
#'(lambda (x)
(format t "call : ~S " x)
(let ((y (funcall (funcall f (funcall h h)) x)))
(format t "retn : ~S~&" y)
y)))))
(setf (symbol-function 'fib/memo) (fix/memo #'%fib))
(setf (symbol-function 'fib/debug) (fix/debug #'%fib))
少しいじる。
このままだと一引数の関数に対してしか fix を適用できません。それは切ないので少しいじって可変長引数を取れるようにしてみます。徒らに cps 変換した fib でも渡してみます。
;;;figure.3
(defun fix* (f)
(funcall #'(lambda (g) (funcall g g))
#'(lambda (h)
#'(lambda (&rest x) ;可変長引数をとるように変更。
(apply (funcall f (funcall h h)) x))))) ;funcall を apply に。
(defun %fib/cps (f)
#'(lambda (x &optional (k #'identity))
(if (<= x 1) (funcall k 1)
(funcall f (- x 1)
#'(lambda (w)
(funcall k (+ w (funcall f (- x 2) #'identity))))))))
(setf (symbol-function 'fib/cps) (fix* #'%fib/cps))再帰の度に rest パラメータでリストに詰めて apply で受けるのは効率が気になるなあ、という向きもありそうです。再帰の度に新しい関数を作っているのでそもそも効率を気にしたら負けな気もしますが、せっかくなので引数の個数を明示的に受け取って、その引数用の関数定義に展開されるようなマクロを書いてみます。
;;;figure.4
(defun gensym-list (n ls)
(if (< n 1) ls
(gensym-list (- n 1) (cons (gensym) ls))))
(defmacro fix/mac (&optional (arity 1) rest?)
(let ((arg-ls (gensym-list arity nil))
(rest (gensym)))
`#'(lambda (f)
(funcall #'(lambda (g) (funcall g g))
#'(lambda (h)
#'(lambda (,@arg-ls ,@(when rest? `(&rest ,rest)))
,(if rest?
`(apply (funcall f (funcall h h)) ,@arg-ls ,rest)
`(funcall (funcall f (funcall h h)) ,@arg-ls))))))))
(setf (symbol-function 'fib/cps) (funcall (fix/mac 2) #'%fib/cps))
もうちょっといじる。その１
ついでだから構文抽象もしてみます。ついでといいながらここからがメインな気もします。まず fix 側からです。改めて定義とにらめっこしてみます。
(defun fix (f)
(funcall #'(lambda (g) (funcall g g)) ;*1
#'(lambda (h) ;*2
#'(lambda (x) ;*3
(funcall (funcall f (funcall h h)) x) ;*4
))))*1 にしても *2 にしても、memo 版と debug 版のどちらでもいじりませんでした。つまり変更部分は *3 に集中していることになります。そして、いづれでも出現の仕方に違いがあるものの、*4 の式自体の形は共通でした。となるとこれらについてはテンプレート化できそうです。*1 *2 に関してはそのままテンプレート化して、*4 に関しては局所マクロを使って構文を利用する側で適宜貼り付ける場所を指定してもらうことにします。
*3 もガワ自体はいじらなさそうですが、引数リストは別の形になり得ます。また、*3 の内部で引数を触れないとどうしようもないので、この引数リストは構文を利用する側で指定できるようにしておくことにします。そして、*3 の内部を本体として書けるようにします。
また、memo 版では関数本体全体を包む環境を作っていました。ですから、これは包めるようになっていないといけません。言い換えれば、define-fixer とかそんな感じの定義構文を作るのではなく、defun の中に貼り付けるような仕方で使える構文を定義するようにしておく必要があります。
以上を踏まえて、まずパラメータ g h の名前については隠蔽してしまってよさそうです。f に関しては、defun の引数と名前をすり合わせる必要があるので、不恰好ですがとりあえず名前を明示的に渡してもらうことにします。上記 fix/mac のように匿名関数の定義の形に展開されるようにしてもいいかもと一瞬思いましたが、何となく鬱陶しそうなのでやっぱりやめます。
引数リストに関しても明示的に渡してもらうわけですが、書くのが面倒くさいし何より使う上で無駄に混乱しそうなので必須パラメータと rest パラメータのみを許可することにします。実用上は optional パラメータや keyword パラメータを受け取るような関数について処理したい場合には rest パラメータで受け取って apply することにしておいた方が無難でしょうし。
そんなこんなでこんな感じになりました。
;;;figure.5
;;;ユーティリティ関数
(defun %split-parm (parm)
(mapc #'(lambda (x)
(let ((not-acceptable? (find x parm)))
(when not-acceptable?
(error "lambda keyword ~S is not acceptable."
not-acceptable?))))
'(&optional &key &aux))
(let ((rest? (member '&rest parm)))
(if rest? (values (subseq parm 0 (position '&rest parm))
(cadr rest?))
(let ((tail (cdr (last parm))))
(if tail
(values (subseq parm 0 (length parm)) tail)
(values parm nil))))))
(defun %make-fix-form (req rst f h)
(if rst
`(apply (funcall ,f (funcall ,h ,h)) ,@req ,rst)
`(funcall (funcall ,f (funcall ,h ,h)) ,@req)))
;;;本体
(defmacro fixation (f (&rest parms) &body body)
(let ((g (gensym))(h (gensym)))
(multiple-value-bind (req rst) (%split-parm parms)
`(macrolet ((,(intern "%call") ()
',(%make-fix-form req rst f h)))
(funcall #'(lambda (,g) (funcall ,g ,g))
#'(lambda (,h)
#'(lambda (,@parms) ,@body)))))))実際にこれを使って書き直してみると以下のようになります。何となくデバッグ出力をネストさせてみたり。symbol-macrolet があるともうちょっとすっきり書けるようにできそうかな。
;;;figure.6
(defun fix (f)
(fixation f (x) (%call)))
(defun fix/memo (f)
(let ((ht (make-hash-table)))
(fixation f (x)
(let ((y (gethash x ht)))
(or y (setf (gethash x ht) (%call)))))))
(defvar *fix-debug/indent* 0)
(defun %fix/debug (f)
(fixation f (&rest x)
(let ((*fix-debug/indent* (+ *fix-debug/indent* 2)))
(format t "~V,T-> ~S~%" *fix-debug/indent* x)
(let ((y (%call)))
(format t "~V,T<- ~S~%" *fix-debug/indent* y)
y))))
もうちょっといじる。その２
次は fib の方を。普通に書いた fib と見比べてみます。
(defun fib (x)
(if (<= x 1) 1
(+ (fib (- x 1))
(fib (- x 2)))))
(defun %fib (f)
#'(lambda (x)
(if (<= x 1) 1
(+ (funcall f (- x 1))
(funcall f (- x 2))))))要するに 1)「x を取る関数」から、「x を取る関数を返す f を取る関数」に変わっており、更に 2) 再帰的に呼ばれていた自分自身 fib が funcall f に置き換わっている、だけです。普通の定義から合成用の定義に書き換えるのは結構簡単そうです。
1) の書き換えについては何も考えることはありません。本来の引数リストを貼り付けた #'(lambda ...) で関数定義本体を囲ってやって、定義しようとしている関数の引数リストを (f) に置き換えるだけです。
2) ですが、素直に関数名を funcall f に置き換える、というのは素直な割に手間がかかります。局所関数・マクロ定義で関数名がシャドウイングされる可能性があるからで、しかもマクロによって局所定義構文が暗黙に導入される可能性があるからです。つまり、マクロを全て展開した本体を対象に、局所定義されていない範囲のみ置換する必要があります。それはやりたいことに対してちょっとヘビーです。
ですので、発想を変えます。「f に引数を適用する関数」に、そもそもの関数の名前がついていれば、それを呼び出すだけで済みます。局所定義があろうが何だろうが通常の評価ルールに従うだけです。というわけでそうします。
あと、通常の関数定義があるわけですから、ついでに通常の関数も定義しておいてみます。何だかふりだしに戻ったきたような感がありますが、えーと気付かない振りをしておきます。
そんなこんなでこんな感じになりました。
;;;figure.7
(defvar *fixable-function-prefix* "%")
(defun lambda-keyword-exist? (parm)
(dolist (x '(&optional &rest &key &aux) nil)
(when (member x parm) (return t))))
(defmacro define-fixable-function (name (&rest parm) &body body)
(let ((f (gensym))
(g (gensym))
(key? (lambda-keyword-exist? parm))
(str (concatenate 'string
*fixable-function-prefix*
(symbol-name name))))
`(progn
(defun ,name (,@parm) ,@body)
(defun ,(intern str) (,f)
(flet ((,name (,@(if key? (list '&rest g)
parm))
,(if key? `(apply ,f ,g)
`(funcall ,f ,@parm))))
#'(lambda (,@parm) ,@body)))
(values ',name ',(intern str)))))
(define-fixable-function fib (x)
(if (<= x 1) 1
(+ (fib (- x 1))(fib (- x 2))))) ;=> fib,%fib
感想とか。
ぺちぺち適当に書いたので色々統一感に欠けています。最後の二つをまとめて色々体裁を整えるといいのかもしれないなあという思いが胸をよぎりましたが、そこまでするほどのものでもないのでやっぱりやめます。
fixation とか fixable とかは名前として微妙、というか誤解に満ちた名前かも。combination とか combinatable とか？ 何かいい名前はないでしょうか。
最後の define-fixable-function は scheme だったらもっと楽に書けそうで、2) の箇所に関してわざわざ局所関数を定義しなくても本来の関数名を f のところに置くだけで実現できそうです。できそうですが、scheme の define-syntax をよく理解してないので私には無理です。Common Lisp というか xyzzy にしといたのは実はそれが理由だったりもします。
マクロとコンビネータを併用するのって、箸とフォークを併用して食事するような曰く言い難い微妙さがあるような気がしてきたのは、書き終わってからのことなのでした。再帰・ループに処理を挟むとき、手続きに名前付けていいんだったらトランポリンぽくした方が素直なのかな。
と言うかそもそも Common Lisp だったら CLOS のメソッド・コンビネーションでどうとでもなるのかなあ。なるんでしょうか。CLOS よく判ってません。AspectLとか、あることは知っていてもあることまでしか知りません。とまれ、その辺があくまで Common Lisp じゃなくて xyzzy な理由だったりもします。
Trampolining Architectures
11p.
直接関係ないけれど、このスライドの gif アニメが可愛くて仕方ないです。
■
仮更新してみるテスト。本更新があるのかは判りませんが。
