ルート探索を用いた型変換
Scheme のような、強い型付けがされた言語でプログラミングしていると、型変換の作業が面倒になることがあると思います。あるいは、複数の型のデータが流れ込んできて、それらを統一的に扱いたいというケースもあるかも知れません。
ということで、型変換の関数を自分で作ることにしたんですが、できるだけ面倒の無いように、変換の方法をプログラムが勝手に調べてくれれば楽だなぁと思いました。
そこで、次のような方法を考えてみました。
まず、隣接する型同士の変換関数を洗いざらいリストアップしておきます。型変換のリクエストがあると、2つの型を繋ぐルートを調べます。そのルート上にある関数を順に合成することで、離れた型同士の変換関数が自動的に生成される、という要領です。
以下、定義です。
(fun (hany f h)
(reset0
(hash-for-each h
(fn (k v)
(awhen (f k v)
(shift0 _ it))))
#f))ハッシュ表を活用するので、ハッシュ検索の関数を作ってみました。脱出のために部分継続を使ってあります。
(define-values (install-type type-of)
(let ((h (make-hasheq)))
(values (fn (a a?) (hash-set! h a a?))
(fn (x)
(hany (fn (a a?)
(and (a? x) a))
h)))))型名を登録する関数と、型名を調べる関数です。何となくハッシュ表をグローバルに置きたくなかったのでちょっと妙な定義方法になっています。ローカル変数を複数の関数で共有したい場合の Scheme 流のやり方です。
(define-values (relate-types make-search)
(let ((h (make-hasheq)))
(values (let ((a-hash
[hash-ref! h _ (fn () (make-hasheq))]))
(fn (a b a->b)
(hash-set! (a-hash a) b a->b)))
(fn (a path)
(aand (hash-ref h a #f)
(fn (b)
(or (hash-ref it b #f)
(hany (fn (a~ a->a~)
(aand (not (memq a~ path))
(relation a~ b path)
(compose it a->a~)))
it))))))))型同士の関係 (変換関数) を登録する関数と、それをルート探索で調べる関数です。
探索のアルゴリズムは深さ優先と幅優先をミックスしたような感じになっています。が、常に最短経路が見つかるわけではないので、ちょっと回りくどい変換関数が作られてしまうことがあるかも知れません。
引数の path は、例えば vector と list の間をぐるぐるループしたりしないように、これまでの経路を覚えておくためのものです。
(fun (relation from to path)
(cond ((eq? from to) values)
((make-search from (cons from path)) => [_ to])
(else #f)))
(fun (coerce type x)
(or (aand (type-of x) (relation it type '()) (it x))
(error 'coerce "coercion method not known for ~s to ~a" x type)))relation は2つの型の関係を返す関数です。これはメモ化した方が良いでしょうね。
coerce が型変換のインターフェースとなります。type-of でデータの型名を得て、relation でそれと対象の型との関係を調べます。あとはそれをデータに適用すれば良いだけです (aand 超便利！)。
ちなみに、CL や Arc の coerce とは引数の順番が逆になっていますが、自動カリー化が行われる言語ではこういう順番にするのが一般的です。
関数の定義は以上です。
型と型変換の定義はこのように分けて行います。
(for-each [apply install-type _]
`((char ,char?)
(bytes ,bytes?)
(number ,number?)
(string ,string?)
(symbol ,symbol?)
(vector ,vector?)
(list ,list?)))
(for-each [apply relate-types _]
`((char string ,string)
(char number ,char->integer)
(bytes list ,bytes->list)
(bytes string ,bytes->string/utf-8)
(number string ,number->string)
(string bytes ,string->bytes/utf-8)
(string number ,string->number)
(string symbol ,string->symbol)
(string list ,string->list)
(symbol string ,symbol->string)
(vector list ,vector->list)
(list string ,list->string)
(list vector ,list->vector)))内容的にはまだまだ不十分ですが、まぁテスト段階なのでこんなものです。本当なら数値型をもっとちゃんと定義したいところです。
また、バイト列から文字列への変換を、文字コードを自動検知して変換するようにすれば、例えばポートから文字列まで、文字コードのことを考えることなく変換できるようになるなぁとか、いろいろ想像と期待が膨らみます。
もちろんユーザー定義の型も登録可能です。が、注意すべきなのは
;; wrong (install-type 'atom (negate pair?))
のような一般的な型を登録してしまうと、型の検知 (type-of) がうまく機能しなくなるということです。したがって、常に他のデータ型と重ならない、ユニークな型を登録する必要があります。
ただし、hany の代わりに hmany のような複数の型候補を返す関数を作って、それぞれについて平行して対象との relation を調べるようなシステムに変更すれば、この問題は解決されるんじゃないかと思います。
あと、リストから文字列への変換は以下のように定義した方が良いかもしれません。
(relate-types 'list
'string
[list->string (map (coerce 'char) _)])
実行例:
> (map (coerce 'symbol)
(coerce 'list #"abc"))
(a b c)バイト列からリストへの変換は一発なんですが、その要素 (整数) からシンボルまでは探索しなければ辿り着けませんね。
> (coerce 'symbol (coerce 'list #"abc")) abc
これは数値のリストから文字列、さらにシンボルへと変換されています (たぶん)。リストから文字列への変換が list->string のままだとエラーが生じているはずです。
追記 (探索方式の見直し)
上で、この型システムにはオーバーラップする型を含められない制限があると言ったんですが、それだと一般の数値から整数への変換なども出来ないことに気付きました。ということで、atom の例えの所で思い付いた hmany 関数というのを作って、複数の型の候補から経路を探索できるようにしてみます。
(fun (hmany f h)
(reset0
(hash-for-each h
(fn (k v)
(awhen (f k v)
(shift0 cont
(cons it (cont))))))
'()))(fun (one-or-many l)
(cond ((null? l) #f)
((null? (cdr l)) (car l))
(else l)))
(define-values (install-type type-of)
(let ((h (make-hasheq)))
(values (fn (a a?) (hash-set! h a a?))
(fn (x)
(aand (one-or-many
(hmany (fn (a a?)
(and (a? x) a))
h))
(if (pair? it)
(sort-types it)
it))))))type-of は、このバージョンでは #f か型 (シンボル) か、型のリストを返すようになります。
(define-values (order<types sort-types)
(let ((h (make-hasheq)))
(values (fn (lo hi)
(hash-set! h hi (adjoin lo (hash-ref h hi '()))))
(fn (l)
(sort l
(afn (x y)
(aand (hash-ref h y #f)
(or (memq x it)
(ormap (self x) it)))))))))型のリストを返す場合は、型階層の低い順から並ぶようにします (e.g. (integer number))。経路を全探索した時に、その結果から辺の数が最少のものを正しい経路として採用するんですが、たまに等しい距離の経路が並んでしまうことがあるので、その場合に備えて優先順位を付けるんです。
型階層は
(define-values (raise-type reduce-type)
(values (fn (lo hi raise)
(order<types lo hi) (relate-types lo hi raise))
(fn (hi lo reduce)
(order<types lo hi) (relate-types hi lo reduce))))
(reduce-type 'number 'integer (compose inexact->exact round))のようにして定義します。型システム全体は階層の無いネットワークなんですが、その中に numerical tower のような階層構造を部分グラフとして組み込むというイメージです。
次に型システムの実装です。
(fun (make-graph)
(let* ((h (make-hasheq))
(a-hash [hash-ref! h _ (fn () (make-hasheq))]))
(case-lambda
((a) (hash-ref h a #f))
((a b) (aand (hash-ref h a #f) (hash-ref it b #f)))
((a b a->b) (hash-set! (a-hash a) b a->b) a->b))))初めのバージョンを作った時に、型の集合と型同士の変換の集合がグラフ構造を成すことに気付いたので、このような関数を作ってみました。型システムの定義と、経路探索のメモ化に使用します。
(define-values (relate-types search-paths)
(let ((g (make-graph)))
(values (fn (a b a->b) (g a b a->b))
(afn (a b path)
(if (eq? a b)
'(())
(aand (g a)
(apply append
(hmany (fn (a~ a->a~)
(aand (not (memq a~ path))
(self a~ b (cons a path))
(map [append _ `(,a->a~)]
it)))
it))))))))search-paths は少々ややこしいですが、型 a から b への経路のリストを返す関数です。self で再帰呼び出しすることで深さ優先、hmany を使うことで全探索となっています。
(fun (sorted-car < l)
(and (pair? l) (car (sort l <))))
(define least-cdr
(sorted-car (fn ((cons _ x) (cons _ y)) (< x y))))
(fun (map-types from to)
(aand (least-cdr
(map [cons _ (length _)]
(search-paths from to '())))
(cons (apply compose (car it))
(cdr it))))
map-types は2つの型の間の全ての経路のうち最短のものを選ぶ関数です。
この経路というのは隣接する型同士の変換関数のリストなので、compose を適用するとそのまま from から to への変換関数になってくれます。
返り値はその変換関数と経路の長さのペアとなっています。
メモ化バージョン。
(define-values (map-types remap-types)
(let ((g (make-graph)))
(values (fn (from to)
(or (g from to)
(aand (least-cdr
(map [cons _ (length _)]
(search-paths from to '())))
(g from to
(cons (apply compose (car it))
(cdr it))))))
(fn (from to)
(set! g (make-graph))
(map-types from to)))))型システムは実行時に自由に変更可能なため、いちおうルートの再計算ができるようにしておきます。
(fun (relation from to)
(aand (if (and (symbol? from) (symbol? to))
(map-types from to)
(least-cdr
(cond ((symbol? from)
(filter-map (map-types from) to))
((symbol? to)
(filter-map [map-types _ to] from))
(else
(append-map [filter-map (map-types _) to]
from)))))
(car it)))
(fun (coerce type x)
(or (aand (type-of x) (relation it type) (it x)) x))relation は map-types の car を取り出す関数となります。
探索の始点と終点が1対1の場合もあれば、下の例みたいに coerce の第1引数に type-of を使うと多対多となることもあるので、場合分けが必要です。
1対1以外の場合は、変換関数と辺の数のペアのリストが得られるので、その中から least-cdr で最少辺のものを選んでいます。
(fun (inc n x)
(coerce (type-of x)
(+ (coerce 'integer x) (or n 1))))
ライブラリ:
mlfun.ss arcfun.ss anaphora.ss
ML や Haskell でよく見る ' (プライム) 記号がうらやましかった件について
数学でよく使われる記号だと思うんですが、ML系のプログラムとか論文を読んでいると、1重引用符が識別子の後に付けられているのをよく見かけます。
ある関数の変種とか、ある変数に基づいて一時変数を作る時などに、いちいち新しい名前を考えなくて済むので便利なんですよね。
でも Scheme や Lisp では、この記号は quote の省略形という特別な意味を持っているので、使いたくても使えません。
で、何か良い案は無いものかとずっと思っていたんですが、ついに思い付きました。
チルダです。
(define (map~ f l)
(cond ((null? l) l)
((f (car l))
=> (lambda (x)
(cons x (map~ f (cdr l)))))
(else
(let* ((t (cdr l))
(t~ (map~ f t)))
(if (eq? t t~)
l
(cons (car l) t~))))))emacs の一時ファイルみたいで、まさにぴったりという感じですよね。何で今まで気付かなかったんだろう…
部分継続について本気出して考えてみた
以前何度か部分継続について書いたことがあるんですが、当時は表面的な振る舞いを観察して何となく分かった気になった程度の拙い説明しか出来ませんでした。
その上、最近のプログラミングでもほとんど活用しておらず、改めて理解し直す必要を感じてきた次第です。
そこで今回は、部分継続の概念的な理解を目指し、基礎的な事柄を中心にまとめていきたいと思います。
基本的に PLT Scheme (MzScheme) の評価モデルに即して書いていくため、Scheme 一般に当てはまる話になっていない部分もあるかも知れません。その点ご了承ください。
Redex と継続
Scheme の評価モデルにおいて、
(+ 1 (+ 2 0))
という式を評価するとき、まず
(+ 2 0)
の部分が評価され、その結果の値に対して
(+ 1 [])
という残りの計算が行われます。
ここで角括弧で示した部分を reducible expression (redex) と言います。簡約 (単純化) 可能な式、という意味です。そして、もうそれ以上簡約できないところまで簡約を続けて値を得ることを「評価」と呼ぶわけです。
一方、角括弧を包む「残りの計算」の部分を「継続」と言います。
つまり、redex のある所には常に継続があるのです。両者が対概念と言うか、相補的な関係にあるものだということが分かりますね。
この redex と継続という、プログラムの評価中に当然に存在して、なおかつ分かちがたく合わさっているもののうち、継続を第一級オブジェクトとして取り出すのが Scheme の call/cc 関数です。
継続は関数なり
ここで
(+ 1 [])
という継続の意味を考えてみましょう。
角括弧で示された穴の部分には、何らかの値 (数値) が入ることが期待されます。そこで継続を、この穴の前後の文脈だと考えることができます。
しかし別の見方をすると、この「文脈」は、値を与えられるとそれに応じて値を返す働きをするわけですから、数学的な意味での関数そのものであるとも言えますね。
したがって、これは本質的に
(lambda (x) (+ 1 x))
という関数に等しいと考えられるわけです。
普通の継続と合成可能な継続
call/cc に触れる前に、MzScheme の プリミティブである call-with-composable-continuation 関数を紹介しておきます。
> (define c #f)
> (+ 1 (+ 2 (call-with-composable-continuation
(lambda (k)
(set! c k)
0))))
3ここで、call-with-composable-continuation を呼び出した位置がちょうど redex の位置で、それを包む式が継続ということになります。この場合は
(+ 1 (+ 2 []))
という文脈が k として返されます (c として保存)。
これに 0 を与えてみると、当然ながら
> (c 0) 3
という値が得られることになります。
また、c の呼び出しの外側を別の式で包むと
> (+ 1 (c 0)) 4
となり、さらに続きの計算が行われています。
一方、伝統的な call-with-current-continuation (call/cc) はどうでしょうか？
> (+ 1 (+ 2 (call-with-current-continuation
(lambda (k)
(set! c k)
0))))
3> (c 0) 3
ここまでは同じです。
が、次の式は
> (+ 1 (c 0)) 3
となります。c を呼び出した時点で脱出が起こるため、この式における継続そのものは破棄されてしまうんです。
この「脱出」が起こるというのが伝統的な継続の振る舞いであり、脱出を起こさない前者の継続のことは composable continuation と呼びます (他の継続と組み合わせたり、普通の関数と合成することも可能なため)。
もう一度、その非脱出性を確認しておきましょう。
> (+ 1 (+ 2 (call-with-composable-continuation
(lambda (k)
(k 0)))))
6となって、
(+ 1 (+ 2 []))
という計算が、k が呼ばれた場所とその外側で2回行われていることが分かりますね。
部分継続とは
脱出が起こる起こらないという話をしましたが、では起こる場合、一体どこに向かって脱出するのでしょうか？
次の例を見てください。
> (+ 1 (+ 2 (call-with-current-continuation
(lambda (k)
(k 0)))))
3composable の方を使った時は 6 が返ってきた計算ですが、こちらでは k を適用した時点で脱出が起こって、call-with-current-continuation 自体の継続が破棄されているんです。
で、どこに脱出したかということですが、結論から言うと、トップレベルに向かって脱出しています。
しかし、これは裏を返せば call/cc がトップレベルからの継続を捉えていたからだと言えるんです。
実は MzScheme における継続というのは全て部分継続 (delimited continuation) と呼ばれる種類のものです。
部分継続とは、継続全体のうち、プロンプトという特殊な継続フレーム (後述) で delimit された、つまり、区切られた部分のことです (このことから、プロンプトのことをデリミタと呼ぶ流儀もあります)。
上の例では REPL 自体が暗黙的にプロンプトに包まれているので、それと call/cc 呼び出しとの間が部分継続として切り取られていたことになります。
そして、部分継続における脱出というのは対応する (直近の) プロンプトに対して行われるので、この場合は REPL を包んでいるプロンプトに向かって脱出したというわけです。
プロンプトというものを理解するために、明示的なプロンプトを導入して実験してみましょう。
> (require scheme/control)
> (+ 1
(prompt
(+ 2 0)))
3ただ導入しただけでは begin と何の変わりもありません。
脱出してみます。
> (+ 1
(prompt
(+ 2 (abort 0))))
1トップレベルではなく prompt の位置までの脱出なので、その先の継続はちゃんと評価されていますね。
当然ながら prompt を外すと
> (+ 1
(+ 2 (abort 0)))
0となります。
また、
> (define c #f)
> (+ 1
(prompt
(+ 2
(call-with-current-continuation
(lambda (k)
(set! c k)
0)))))
3c は prompt までの継続なので、その外側の継続は入っていません。ゆえに、
> (c 0) 2
となります。
継続フレーム
MzScheme において継続は、継続フレームという構成単位の連続として実装されています。
通常の評価過程においても継続フレームは増えたり減ったりしているんですが、これを明示的に操作することで、部分継続やエラー処理などの応用的な制御構造が作られるのです。
プロンプトというのも継続フレームの一種で、プロンプト・タグという目印によって、部分継続を切り取る際の区切りを示します。
また、現在の継続を任意のプロンプトに置き換えると、その時の続きの計算は破棄され、制御がプロンプトの位置に移ります。これが脱出のメカニズムというわけです。
基本的な制御オペレータ - prompt/control, reset/shift
いちいち call-with- なんちゃらとタイプするのは面倒なので、MzScheme ではプロンプトの設定や継続の取り出しのためのオペレータが scheme/control ライブラリで提供されています。
既にその内 prompt と abort を使ったんですが、さらに幾つか例を示していくのでぜひ慣れていってください。
> (+ 1 (prompt (+ 2 (control k 0)))) 1
control で部分継続 (k) を取り出している例です。このように prompt で区切られた部分継続は control で捕捉するのが通例となっています。
control の呼び出しにより、部分継続が取り出されると同時に control 式本体の継続がプロンプトに移ります (つまり、脱出します)。
ここでは 2 を加える計算を取り出したわけですが、使わずに捨てているので単に abort したのと同じです。
k を使うと
> (+ 1 (prompt (+ 2 (control k (k 0))))) 3
となります。
繰り返し適用することもできます。
> (+ 1 (prompt (+ 2 (control k (k (k 0)))))) 5
これは脱出を伴う call/cc では出来ないんでしたね。
> (+ 1 (prompt
(+ 2 (call-with-current-continuation
(lambda (k)
(k (k 0)))))))
3最初に k を適用したところで脱出が起こるためです。
control の場合、あくまでも control の呼び出しにおいて脱出が起こるだけで、取り出された k 自体は脱出を起こさない、composable な継続だということが分かります。
次に、独習 Scheme のツリー・マッチングの問題を解いてみましょう。
prompt/control と似たペアで、reset/shift というのを使います。
(define (tree->generator t)
(reset
(let loop ((t t))
(cond ((not (list? t))
(shift k (cons t k)))
((pair? t)
(loop (car t))
(loop (cdr t)))
(else #f)))))リーフの列挙関数が既に存在した場合は、このように定義することもできます。
(define (tree->generator t)
(reset
(for-each-leaf (lambda (x)
(shift k (cons x k)))
t)
;; Mark the end of traversal
#f))すっきりしましたね。いずれにしてもループが回っている途中の状態が k として取り出され、リーフの値と共に外に放出されます。
shift が一時停止ボタン、k が再生ボタンと考えると分かりやすいかも知れません。取り出されたデータを保存しておいて、(それこそトイレ休憩をはさみつつ) REPL で手作業で回していくことだって可能です。
ループが回りきると #f が返り、終了が通知されます。
(define (same-fringe? t1 t2)
(let loop ((x (tree->generator t1))
(y (tree->generator t2)))
(or (not (or x y))
(and x y (eqv? (car x) (car y))
(loop ((cdr x) 'next)
((cdr y) 'next))))))> (same-fringe? '(1 2 3 4 5)
'(1 (((2 ((3)))) (4 (((5)))))))
#t
ちなみに。tree->generator を再掲しますが
(define (tree->generator t)
(reset
(let loop ((t t))
(cond ((not (list? t))
(shift k (cons t k)))
((pair? t)
(loop (car t))
(loop (cdr t)))
(else #f)))))これは深さ優先探索のアルゴリズムを実装したものです。ところが、これにちょっとした変更を加えるだけで、幅優先バージョンが作れてしまうんです (Biernacki et al.)。
(define (tree->generator/bf t)
(reset
(let loop ((t t))
(cond ((not (list? t))
(shift k (cons t k)))
((pair? t)
(control k
(k #f)
(loop (car t))
(loop (cdr t))))
(else #f)))))pair? の節に2行加えただけですよ。
では確かめてみましょう。
> (define (gen-for-each f g)
(when g
(f (car g))
(gen-for-each f ((cdr g) #f))))
> (define t '(1 (((2 ((3)))) (4 (((5)))))))
> (gen-for-each (lambda (x)
(display x) (newline))
(tree->generator t))
1
2
3
4
5
> (gen-for-each (lambda (x)
(display x) (newline))
(tree->generator/bf t))
1
2
4
3
5これはかなり凄いことなんじゃないでしょうか？
control と shift の違い
control で部分継続を捕捉する時は prompt で区切りを設定、shift を使うときは reset で、という風に、決まった組み合わせで使うのが慣例となっているんですが、実は prompt と reset は同じものの別名に過ぎません。
一方 control と shift は、次のような等式が成り立つ関係にあります。
(shift k k) = (control k (lambda (x) (prompt (k x))))
つまり shift は、k が適用される時にその場にプロンプトを設定するという性質があるんです。
以下の例でその効果の違いを見ることができます。
> (reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'(1 2 3))
'())
(1 2 3)
> (prompt
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'(1 2 3))
'())
(3 2 1)いずれの場合も、k が for-each ループを最後まで回して、その先にある空リストを捉えるという動作をする点では同じです。
ではなぜ結果が異なるのか、それを理解するために、評価ステップを書き出してみましょう。
reset/shift を使った方は
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'(1 2 3))
'())
(reset
(cons 1
((lambda (v)
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'(2 3))
'()))
'next)))
(reset
(cons 1
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'(2 3))
'())))
(reset
(cons 1
(reset
(cons 2
((lambda (v)
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'(3))
'()))
'next)))))
(reset
(cons 1
(reset
(cons 2
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'(3))
'())))))
(reset
(cons 1
(reset
(cons 2
(reset
(cons 3
((lambda (v)
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'())
'()))
'next)))))))
(reset
(cons 1
(reset
(cons 2
(reset
(cons 3
(reset
(for-each (lambda (x)
(shift k
(cons x (k 'next))))
'())
'())))))))
(reset
(cons 1
(reset
(cons 2
(reset
(cons 3
(reset '())))))))のようになります。
冒頭の継続と redex の議論でいくと、redex の位置に継続が埋め込まれていくという、逆のことが起こっているようにも見えますね。
ここで重要なのは、ループごとに次の shift の脱出先が設定されているということです。言い換えると、ネストする shift の呼び出しにおいて、先行する shift で区切られた領域を後続の shift は超えられないようになっているのです。
この性質が、ローカル変数で言うところのレキシカル (静的) スコープに似ているということから、shift のことを静的な制御オペレータと呼ぶ場合があります。
後者では、ループ毎に同じ prompt の位置に脱出しますから cons の呼び出しが常に左側に積み上がっていくことになります。
(prompt
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'(1 2 3))
'())
(prompt
(cons 1
((lambda (v)
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'(2 3))
'())
'next)))
(prompt
(cons 1
(let ()
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'(2 3))
'())))
(prompt
(cons 2
((lambda (v)
(cons 1
(let ()
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'(3))
'())))
'next)))
(prompt
(cons 2
(cons 1
(let ()
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'(3))
'()))))
(prompt
(cons 3
((lambda (v)
(cons 2
(cons 1
(let ()
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'())
'()))))
'next)))
(prompt
(cons 3
(cons 2
(cons 1
(let ()
(for-each (lambda (x)
(control k
(cons x (k 'next))))
'())
'())))))
(prompt
(cons 3
(cons 2
(cons 1
'()))))やはりここでも shift と同様の議論が成り立って、ネストする control 呼び出しにおいて1つの領域が共有される点が、変数の動的スコープ (dynamic extent) に似ているということで、control のことを動的な制御オペレータと呼びます。
その他のオペレータ
プロンプトを毎回新たに設定する・しないという話をしましたが、実はさらに、直前に設定されたプロンプトを保つ・保たないというバリエーションもあり得るんです。このことから、次の4つのオペレータの組を得ることができます (Shan)。
- reset/shift
- prompt/control
- reset0/shift0
- prompt0/control0
後の2組がプロンプトを保たないバージョンです。
例えば前節の例で reset0/shift0 を使うと
(reset0
(for-each (lambda (x)
(shift0 k
(cons x (k 'next))))
'(1 2 3))
'())経過は略しますが
(cons 1
(cons 2
(cons 3
(reset '()))))のように評価され、結果的には同じリストが作られます。ただ、プロンプトが消えてしまうため、shift のような静的な性質は完全には保たれないことになります。
まぁ、このことに一体どんな便利な応用があり得るのかは、まだ良く分かっていない (研究されていない) んじゃないかと思います。
ただ、プロンプトを除去することが、保つことに比べて効率的だという実装面での理由があれば、このように結果が変わらない場合には 0 のバージョンを選択できる、という点ではメリットと言えるかも知れません。
[追記]
reset0/shift0 の用例を1つだけ思い付きました。Zipper というデータ構造の基本的なイテレーション関数 (fold-zipper) があるんですが、これを reset0/shift0 で定義しておくと
(define (fold-zipper kons knil zipper)
(reset0
(traverse-zipper (lambda (zipper)
(shift0 k (kons zipper (k #f))))
zipper)
knil))それに基づく関数で簡単に値の取り出し (脱出) が出来るようになるんです。
(define (find-zipper p? zipper)
(reset0
(fold-zipper (lambda (zipper _)
(and (p? (zipper-node zipper))
(shift0 k zipper)))
#f
zipper)))これは reset/shift を使用した場合は無理です。そう考えると結構便利ですよね。認識不足でした。
参考文献
PLT Scheme Reference:
1.1 Evaluation Model
9.4 Continuations
Shan, Chung-chieh. Shift to Control
Biernacki, Dariusz., et al. On the Dynamic Extent of Delimited Continuations
もっと！ ML/Haskell っぽい関数構文
ML や Haskell では、関数を定義する時に、変数だけでなくリテラルやデータ・コンストラクタなどでパターンマッチをすることができますね。
> (require scheme/match)
> (match '(1 . 2)
((cons x y) (list x y)))
(1 2)これを利用して、以前の ML風および Haskell風関数構文を、より本物っぽくする方法を考えてみました。
結果から言うと、こういう関数定義ができるようになります。
> (fact 0 := 1
n := (* n (fact (- n 1))))
> (fact 5)
120(Haskell の文法とは少し異なる点に注意してください。関数名を繰り返さなくて済むというメリットを重視したものですが、後述のようにデメリットもあります)
まず、無名関数をパターンマッチに対応させるところから始めましょう。
PLT の match 構文では1つのデータに対するパターンマッチしか定義できないので、2変数以上の関数をパターンマッチ対応にするのはちょっと苦労しそうです。
と思ったんですが、match-let という派生構文と generate-temporaries という関数を使えば簡単でした。
(define-syntax (fn stx)
(syntax-case stx ()
((fn () . expr)
(syntax/loc stx (begin . expr)))
((fn params . expr)
(stx-every identifier? #'params)
(curry (syntax/loc stx (lambda params . expr))))
((fn (param ...) . expr)
(with-syntax (((g ...) (generate-temporaries #'(param ...))))
(curry
(syntax/loc stx
(lambda (g ...)
(match-let ((param g) ...) . expr))))))))パターンを直接 lambda の変数リストの中に置くことはできないので、一旦パターンに対応する一時変数を用意しておき (generate-temporaries)、それを lambda の変数リストにするんです。
そして match-let により、元のパターンと受け取った引数の組のリストを平行してマッチしていきます。
テスト
> ((fn ((cons x y))
(list x y))
'(1 . 2))
(1 2)cons によるパターンマッチを関数のパラメータとしている例です。Haskell だと \(x:y) -> という風に書くところですね。
もちろん普通の変数をパラメータにすることもできます。
> ((fn ((cons x y) z)
(list x y z))
'(1 . 2) 3)
(1 2 3)
> (((fn ((cons x y) z)
(list x y z))
'(1 . 2))
3)
(1 2 3)(カリー化もばっちり！)
さて次に関数定義の構文なんですが、これまで導入を見送ってきた複数の節でのパターンマッチをサポートしてみましょう (Haskell 風構文との整合性もあるので fn ではサポートしません)。
節の区切りには ML と同じく縦棒を使いたいんですが、Scheme (Lisp) ではこれは特別な意味を持つ文字なので、そのまま使うことはできません。
> (string->symbol "|") \|
というわけで、バックスラッシュでエスケープする必要がありますね。
(fun (fact 0) 1 \| (fact n) (* n (fact (- n 1))))
という定義ができるようにしましょう。
(define-syntax fun
(let ((vbar? (same-id? '\|))
(cl:name
(lambda (clause)
(car (syntax-e (car clause)))))
(cl:params
(lambda (clause)
(cdr (syntax-e (car clause)))))
(cl:body cdr))
(lambda (stx)
(syntax-case stx ()
((fun . clauses)
(stx-any vbar? #'clauses)
(let ((clauses (stx-break* vbar? #'clauses)))
(with-syntax ((name
(cl:name
(foldl (lambda (x y)
(or (and (= (length (cl:params x))
(length (cl:params y)))
(free-identifier=? (cl:name x)
(cl:name y))
y)
(raise-syntax-error
#f "malformed definition" stx)))
(car clauses)
(cdr clauses))))
(temps
(generate-temporaries (cl:params (car clauses)))))
(quasisyntax/loc stx
(define name
(fn temps
#,(let loop ((cl (car clauses))
(rest (cdr clauses)))
(let ((binds
(map list
(cl:params cl)
(stx->list #'temps)))
(body (cl:body cl)))
(if (stx-every identifier? (cl:params cl))
;; No error handlers needed; ignore rest of
;; clauses, if any
#`(let #,binds #,@body)
#`(with-handlers ((exn:misc:match?
(lambda (x)
#,(if (pair? rest)
(loop (car rest)
(cdr rest))
#'(raise x)))))
(match-let #,binds
#,@body)))))))))))
((fun (name . params) . expr)
(syntax/loc stx
(define name (fn params . expr))))))))最初の節でマッチに失敗したら例外を捕えて次の節を試す、という流れをお馴染みの再帰で組み立てています。
以下は縦棒で区切られた節を集める関数です (stx-break*)。
(require (only-in srfi/1 break))
(define (stx-break p? stx)
(receive (l r)
(break p? (if (syntax? stx)
(syntax->list stx)
stx))
(values l
;; remove separator
(if (pair? r) (cdr r) '()))))
(define (stx-break* p? stx)
(let loop ((l stx) (r '()))
(if (stx-null? l)
(reverse r)
(receive (x y) (stx-break p? l)
(loop y (cons x r))))))これで ML 版の関数構文は完成です。
次に Haskell 版ですが、これは元々 ML 版の糖衣構文だったので楽勝だろうと思いきや、以外とてこずってしまいました。
無名関数は変更無しなので関連部分のみ示します。
(require (only-in scheme/list add-between))
(define declare? (same-id? ':=))
(define-syntax (app-fun stx)
(syntax-case stx ()
((app-fun n . e)
(stx-any declare? #'e)
;; Convert
;; (fact 0 := 1
;; n := (* n (fact (- n 1))))
;; =>
;; (fun (fact 0) 1
;; \| (fact n) (* n (fact (- n 1))))
(quasisyntax/loc stx
(fun
#,@(apply append
(add-between
(map (lambda (x)
(list (cons #'n (car x))
(cdr x)))
(let loop ((l (syntax->list #'e)) (r '()))
(if (null? l)
(reverse r)
(receive (v e) (stx-break declare? l)
(if (null? e)
(raise-syntax-error
#f "Malformed definition" stx)
(loop (cdr e)
(cons (cons v (car e))
r)))))))
'(\|))))))
[snip]))中置記法の := では上で作った stx-break* が役に立たないことに気付き、愕然としたのがてこずった理由です。
また、ML 版と違い、関数のボディーには1つの式しか置けないという制限も生じました (前の実装には無かった制限です)。ボディー部分と次の節の変数リストとの区切りが無いため、やむを得ない措置です。
Anaphoric If
Arc の aif のように、意図的な変数キャプチャ (マクロ定義の中で作られた変数をマクロユーザーが参照できるようにすること) を用いたマクロを作る時、Scheme では一般に datum->syntax という関数を使います。
(define-syntax (aif stx)
(syntax-case stx ()
((aif expr then else)
(with-syntax ((it (datum->syntax #'aif 'it)))
#'(let ((it expr))
(if it then else))))))datum->syntax の第1引数で、第2引数が有効になる範囲を指定します (ここでは aif 構文内)。なお、この場合 syntax-rules ではなく syntax-case で定義する必要があります。
これで、
> (aif (assq 'a '((a . 1) (b . -2)))
(cdr it)
0)
1it によって (assq...) の値が参照できるようになるわけです。
さて、こちらは PLT Scheme のコミュニティーで知られている方法なんですが、
(require scheme/stxparam)
(define-syntax-parameter it
(lambda (stx)
(raise-syntax-error #f "can only be used inside anaphora" stx)))
(define-syntax aif
(syntax-rules ()
((aif expr then else)
(let ((val expr))
(if val
(syntax-parameterize ((it
(make-rename-transformer #'val)))
then)
else)))))構文パラメータというものによって、syntax-case や datum->syntax を使わずに特別な識別子を導入することができます。
この aif に基づいて、派生マクロが以下のようにいとも簡単に書けます。
(define-syntax awhen
(syntax-rules ()
((awhen expr . body)
(aif expr (begin . body) (void)))))
(define-syntax aand
(syntax-rules ()
((aand) #t)
((aand expr) expr)
((aand expr . rest)
(aif expr (aand . rest) #f))))
(define-syntax acond
(syntax-rules (else)
((acond) (void))
((acond (else . body))
(begin . body))
((acond (expr) . rest)
(or expr (acond . rest)))
((acond (expr . body) . rest)
(aif expr (begin . body) (acond . rest)))))構文パラメータを使わないバージョンの aif ではこれは不可能です。上述の datum->syntax の第1引数云々の事情により、it が有効になる場所が元の aif 構文の中だけに限定されてしまうため、派生構文の中では it が使えないのです (実際には不可能ではないらしいんですが、分かりにくい方法なので紹介しないでおきます)。
さてここで、前回作った Arc の角括弧構文が使えるようにしてみましょう。モジュールを跨いで構文を拡張するのは若干気が引けますが
(require (only-in "arcfun.ss" make-brackets-funny)) (make-brackets-funny aif awhen aand acond)
> (map [aand (cdr _) (abs it)]
'((a . 1) (b . -2) (c . #f)))
(1 2 #f)あっさり出来ました。
追記:
モジュールを跨いでマクロを拡張するのは云々という不安の背景について、少し技術的な補足をいたします。
カリー化関数構文の部分評価の処理において、local-expand を使って式をフルに展開している箇所があります。
コードの分析のため、核構文のみの形にする必要があるからなんですが、そうすると、マクロ展開された式の中に、モジュールでエクスポートされていない識別子やローカル変数などが出てくる場合があるんです。
マクロが定義されているモジュールの外からそのような識別子にアクセスされることは、モジュールの安全性を脅かす事態です。というわけで、MzScheme では syntax certificate というものを問題のある識別子に付与し、アクセス権限の無い文脈でのアクセスがあるとコンパイル・エラーを発する仕組みになっています。
これが実は悩みの種で、以前の実装では、例えば fun 構文の中で aif 構文を使うと
compile: reference is more certified than binding in: val
のようなエラーが出てしまっていました。val は anaphora モジュールの中の aif 構文の定義に出てくるローカル変数であるため、サードパーティーのマクロ (まぁどっちも自分で作ってるんですが) からのアクセスが許可されないわけです。
悩み抜いた結果、ようやく解決方法が分かったのでここに書いておきます。
(define (collect-certs stx)
(let loop ((stx stx) (certs '()))
(cond ((syntax? stx)
(loop (syntax-e stx) (cons stx certs)))
((pair? stx)
(loop (cdr stx) (loop (car stx) certs)))
(else certs))))
(define (stx-recertify stx)
(let ((certs (collect-certs stx))
(insp (current-code-inspector)))
(lambda (stx)
(let loop ((certs certs) (stx stx))
(if (null? certs)
stx
(loop (cdr certs)
(syntax-recertify stx (car certs) insp #f)))))))
(define (stx->tree stx stop? (certify values))
(let loop ((stx stx))
(cond ((stop? stx) (certify stx))
((syntax? stx)
(loop (syntax-e stx)))
((pair? stx)
(cons (loop (car stx))
(loop (cdr stx))))
(else stx))))collect-certs により、expand して得られた構文オブジェクト (stx) に含まれる全ての syntax certificate を集めます。保護された識別子だけでなく、それを包む式に付与されたものも含めてです。実際に集めているのは構文オブジェクトなんですが、それに certificate が含まれています。
そして stx-recertify によって、個別に取り出された識別子に対し、集められた certificate を全て与えてしまいます (syntax-recertify)。
呼び出し方
(stx->tree expanded-syntax
identifier?
(stx-recertify expanded-syntax))後はツリーのトラバーサル関数を使って自由にコード変形をすることができます。
一般に、1つのコードには複数のモジュールに由来するマクロの呼び出しがあるものなので、識別子の出自に関わらず全ての certificate を付与してしまうこの方法は少々乱暴な気もするんですが、エラーが出なくなったので取り敢えず良しとしておきます。
ファイル:
anaphora.ss arcfun.ss hasfun-helper.ss mlfun.ss
参考文献:
On Lisp - Anaphoric Macros
PLT Scheme Blog - Dirty Looking Hygiene
マクロを書くマクロで Arc の角括弧構文
Haskellっぽいカリー化関数の構文で、「Haskellっぽい」と言いながらも Arc の角括弧みたいな構文を導入しました。
実際にはそれにも偽りがありまして、見た目は Arc っぽいんですが実体は SRFI-26 の cut の糖衣構文に過ぎなかったわけです (次のように変換されます)
[+ _ 1] ; => (cut + <> 1)
個人的に cut は見た目が美しくないと感じるので全く使ってなかったんですが、この構文ならスマートですよね。
ただ、Arc のコードを見ていると、こんな用法もあることに気付きます。
[is (cadr _) name] [if _ (+ _ 1) 1]
cut とはまるで別物です。_ で受けた値に関数を適用したり、if 文までも関数化したりしています。
前者はともかくとして、後者は関数適用の構文をハックする前回の手法ではどうしようもありません。
便利そうなのでやってみたいんですが、Arc のように reader に手を入れるのは何となく気が引けます (やったことが無いので)。
あきらめかけたところ、これも何となくなんですが、マクロを1つ書けば良いだけなんじゃ？という閃きがあり、その通りにしてみたら、驚くほど簡単に実現できました。
先に実装を示します:
(define (syntax->tree src-stx stop?)
(define (cert stx)
(syntax-recertify stx src-stx (current-code-inspector) #f))
(let loop ((stx src-stx))
(cond ((stop? stx) (cert stx))
((syntax? stx)
(loop (syntax-e stx)))
((pair? stx)
(cons (loop (car stx))
(loop (cdr stx))))
(else stx))))
;; Adapted from: http://okmij.org/ftp/Scheme/zipper-in-scheme.txt
(define (map* f l)
(if (not (pair? l))
l
(cons (f (car l)) (map* f (cdr l)))))
(define (depth-first handle tree)
(cond ((handle tree))
((pair? tree)
(map* (lambda (kid)
(depth-first handle kid))
tree))
(else tree)))
(define (bracketed? stx)
(and (syntax? stx)
(eq? (syntax-property stx 'paren-shape) #\[)))
(define (unbracket stx)
(syntax-property stx 'paren-shape #f))
(define (underscore? stx)
(and (syntax? stx) (eq? (syntax-e stx) '_)))
(define-syntax (make-brackets-funny stx)
(syntax-case stx ()
((make-brackets-funny orig)
(with-syntax ((new
(string->symbol
(format "new-~a" (syntax-e #'orig)))))
(syntax/loc stx
(begin
(define-syntax (new stx)
(syntax-case stx ()
((new . e)
(bracketed? stx)
(let ((g (gensym)))
(quasisyntax/loc stx
(lambda (#,g)
(orig . #,(depth-first
(lambda (x)
(and (underscore? x) g))
(syntax->tree (unbracket #'e)
(lambda (x)
(or (identifier? x)
(bracketed? x))))))))))
((new . e)
(syntax/loc stx (orig . e)))))
(provide (rename-out (new orig)))))))
((make-brackets-funny orig rest ...)
(syntax/loc stx
(begin (make-brackets-funny orig) (make-brackets-funny rest ...))))))
(make-brackets-funny #%app if or and)関数適用や if 等の構文で角括弧が使われていた場合に、Arc 同様1変数のラムダに変換するという macro-generating macro です (make-brackets-funny)。すなわち、例えば
[if _ (+ _ 1) 1] ; => (lambda (g) (if g (+ g 1) 1))
という変換が行われるように任意の構文を拡張するマクロを書くマクロです。
syntax->tree でコードをコンスのツリー構造に変換、ツリー探索 (depth-first) によりアンダースコアを探して実際の変数 (g) で置き換えていきます。
ただしその際、角括弧がネストできるように内側の角括弧の _ を置き換えてしまわないよう注意しなければなりません。
syntax->tree の第2引数はこのための対策で、コード分解を途中で止めるための停止条件を与えています。角括弧の式はバラさないでおくことで、内側の _ を置き換えから保護しているわけです。
用例を幾つか示しましょう。
cdr 部が 0 のコンスを探す
> (findf [= (cdr _) 0] '((a . 1) (b . 2) (c . 0))) (c . 0)
絶対値関数はこのように書けます。
> (my-abs := [if (negative? _) (- _) _]) > (my-abs 1) 1 > (my-abs -1) 1
ネストの例
> ([map [+ _ 1] _] (1 .. 3)) (2 3 4)
thunk を呼ぶ例1
> (for-each [newline] (1 .. 3)) >
thunk を呼ぶ例2
> (map [_]
(list (lambda () 1)
(lambda () 2)
(lambda () 3)))
(1 2 3)
Haskellっぽいカリー化関数の構文
以前作ったMLっぽいカリー化関数の構文を使って、今度はHaskellっぽいのを作ってみました。
こういうことが出来るようになります。
関数定義:
> (add x y := (+ x y)) > (add 1 2) 3 > ((add 1) 2) 3
ラムダ式:
> (map (x -> (+ x 1))
'(1 2 3))
(2 3 4)
> (map (x y -> (+ x y))
'(1 2 3) '(4 5 6))
(5 7 9)セクション、と言うか Arc の角括弧:
> (map [+ _ 1] '(1 2 3)) (2 3 4) > (map (+ _ 1) '(1 2 3)) (2 3 4)
以下、実装です。関数適用のフォームの評価をインターセプトし、新たな構文規則を追加するという、かなり過激なハックとなっています。
(provide (rename-out (my-app #%app)))
(define-syntax (my-app stx)
(syntax-case stx ()
((my-app n . e)
(stx-any declare? #'e)
(receive (v e) (stx-break declare? #'e)
(quasisyntax/loc stx
(fun (n #,@v) #,@e))))
((my-app . e)
(stx-any lambda? #'e)
(receive (v e) (stx-break lambda? #'e)
(quasisyntax/loc stx
(fn #,v #,@e))))
((my-app . e)
(stx-any hole? #'e)
(quasisyntax/loc stx
(cute
#,@(map (lambda (stx)
(if (hole? stx) (syntax/loc stx <>) stx))
(syntax->list #'e)))))
((my-app . e)
(syntax/loc stx (#%app . e)))))ユーティリティ:
(begin-for-syntax
(fun (same-id? id stx) (eq? id (syntax-e stx)))
(define-values (declare? lambda? hole?)
(values (same-id? ':=) (same-id? '->) (same-id? '_)))
(define (stx-any p? stx)
(ormap p? (syntax->list stx)))
(define (stx-break p? stx)
(receive (l r) (break p? (syntax->list stx))
(values l (cdr r)))))構文展開系によって関数適用と見なされた式を捕らえ、特殊な識別子を含むかどうかチェックしています。
:= を含んでいれば関数定義、-> があればラムダ式、という風に分岐して振る舞いを変えるわけです。
Haskell みたく = を関数定義のために使いたかったんですが、そうすると関数としての = を引数として渡すことが不可能になるため、:= にしました。
追記:
Haskellの [i .. j] の構文を加えてみました。
数値
> (1 .. 10) (1 2 3 4 5 6 7 8 9 10) > (1 3 .. 10) (1 3 5 7 9)
文字
> (#\a .. #\c) (#\a #\b #\c) > (#\a #\c .. #\z) (#\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u #\w #\y)
関数構文と
> (map [+ _ 1] (1 3 .. 10)) (2 4 6 8 10)
実装
(define (stop? start stop)
(let ((cmp (if (> stop start) > <)))
(lambda (x) (cmp x stop))))
(define (succ start next stop)
(cond (next
(let ((step (- next start)))
(lambda (x) (+ x step))))
((> stop start) add1)
(else sub1)))
(define (unfold-args value number start next stop)
(receive (start next stop)
(values (number start) (and next (number next)) (number stop))
(values (stop? start stop) value (succ start next stop) start)))
(define (accum start next stop)
(call-with-values
(lambda ()
(cond ((number? start)
(unfold-args values values start next stop))
((char? start)
(unfold-args integer->char char->integer start next stop))))
unfold))
(define-syntax (app-range stx)
(define (stx-every p? l)
(andmap p? (map syntax-e l)))
(define (literal? . l)
(or (stx-every number? l)
(stx-every char? l)))
(syntax-case* stx (..)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
((app-range i .. j)
(literal? #'i #'j)
(quasisyntax/loc stx
'#,(accum (syntax-e #'i) #f (syntax-e #'j))))
((app-range i .. j)
(syntax/loc stx (accum i #f j)))
((app-range i j .. k)
(literal? #'i #'j #'k)
(quasisyntax/loc stx
'#,(accum (syntax-e #'i) (syntax-e #'j) (syntax-e #'k))))
((app-range i j .. k)
(syntax/loc stx (accum i j k)))
((app-range . e)
(syntax/loc stx (app-fun . e)))))リテラルが与えられた場合、コンパイル時にリスト生成が行われるのがポイントです:
> (syntax->datum (expand '(1 3 .. 10))) (quote (1 3 5 7 9))
iota とかを使うよりも効率が良いわけです。
変数を含んでいる場合はこのようになります:
> (syntax->datum
(expand
'(let ((next 3)) (1 next .. 10))))
(let-values (((next) (quote 3))) (#%app accum (quote 1) next (quote 10)))なお、リスト生成には iota ではなく、同じく SRFI-1 の unfold という関数を使っています。あまりポピュラーな関数ではないと思うんですが、なかなか奥が深そうです。
ファイル:
mlfun.ss
hasfun.ss
hasfun-helper.ss
参考文献:
Fun with paran-shape
