(Franz) 社の (Common Lisp 無料セミナー) が行われます(毎月1回開催).
とりあえず, 各種定番? ドキュメント.
今のところ, 書けたのはこれだけ.
高階関数を使ったプログラミング例として, ツリー構造を扱う高階関数を作ってみます.
まず以下のようなツリー構造の場合,
(define tree '(1 (2 3) (4 (5 6) 7 ((8)) 9 10)))
標準のリスト処理関数は一番浅いノードにしか適用されません. 例えば reverse の場合,
> (reverse tree) ((4 (5 6) 7 ((8)) 9 10) (2 3) 1)
となってしまいます. これを全ての深さのノードに適用できるようにしてみます. まず以下のような汎用の高階関数を作ります.
(define (for-each-tree f g n tree)
(cond ((null? tree) n)
((not (pair? tree)) (f tree))
(else
(g (for-each-tree f g n (car tree))
(for-each-tree f g n (cdr tree))))))
ここで,
f は 1 個の引数を取る関数でツリーの末端に適用されます.
g は 2 個の引数を取る関数で, car 側の結果と cdr 側の結果を結合します.
n はツリーが空リストの場合に返す値です.
この for-each-tree という高階関数を使って, ツリー構造に対してさまざまな処理を行う関数を作ってみます. でも, その前にユーティリティ関数を定義しておきます.
(define (identity obj)
obj)
(define (r-cons x y)
(append y (list x)))
(define (r-append x y)
(append y x))
(define-syntax block
(syntax-rules ()
((block tag body1 body2 ...)
(call-with-current-continuation
(lambda (tag)
body1 body2 ...)))))
block は(継続の使い方)で説明していますのでそちらを参照してください. それ以外は見たままです.
では, 新しい関数群を作成してみます.
(define (copy-tree tree)
(for-each-tree identity cons '() tree))
(define (reverse-tree tree)
(for-each-tree identity r-cons '() tree))
(define (map-tree f tree)
(for-each-tree f cons '() tree))
(define (flatten-tree tree)
(for-each-tree list append '() tree))
(define (sum-tree tree)
(for-each-tree + + 0 tree))
(define (mul-tree tree)
(for-each-tree * * 1 tree))
(define (length-tree tree)
(for-each-tree (lambda (x) 1) + 0 tree))
(define (filter-tree f tree)
(for-each-tree (lambda (x) (if (f x) (list x) '())) append '() tree))
(define (find-if-tree f tree)
(block return
(for-each-tree (lambda (x) (if (f x) (return x) #f))
(lambda (x y) #f)
#f
tree)))
(define (max-tree tree)
(for-each-tree identity
(lambda (x y) (if (and x y) (max x y) (or x y)))
#f
tree))
このように, さまざまな処理を行う関数が for-each-tree を使って書くことができます. 実行結果は以下の通りです.
> (copy-tree tree) (1 (2 3) (4 (5 6) 7 ((8)) 9 10)) > (reverse-tree tree) ((10 9 ((8)) 7 (6 5) 4) (3 2) 1) > (map-tree - tree) (-1 (-2 -3) (-4 (-5 -6) -7 ((-8)) -9 -10)) > (flatten-tree tree) (1 2 3 4 5 6 7 8 9 10) > (sum-tree tree) 55 > (mul-tree tree) 3628800 > (length-tree tree) 10 > (filter-tree odd? tree) (1 3 5 7 9) > (find-if-tree (lambda (x) (= x 5)) tree) 5 > (max-tree tree) 10
次に, これらの関数を末尾再帰にするため for-each-tree を改良してみます.
(define (for-each-tree f g n tree r)
(cond ((null? tree) r)
((not (pair? tree)) (f tree))
(else
(for-each-tree f g n (cdr tree)
(g (for-each-tree f g n (car tree) n) r)))))
元の for-each-tree と比べて r という引数が追加されています. この r は結果を累積していくパラメータで accumulator と呼ばれます. accumulator の詳細については(OnLisp Section 2.8)を参照してください.
この新しい for-each-tree を使って上記の関数群を定義し直してみます. r-xxx 関数と xxx 関数が置き換わっているのところに注意してください.
(define (copy-tree tree)
(for-each-tree identity r-cons '() tree '()))
(define (reverse-tree tree)
(for-each-tree identity cons '() tree '()))
(define (map-tree f tree)
(for-each-tree f r-cons '() tree '()))
(define (flatten-tree tree)
(for-each-tree list r-append '() tree '()))
(define (sum-tree tree)
(for-each-tree + + 0 tree 0))
(define (mul-tree tree)
(for-each-tree * * 1 tree 1))
(define (length-tree tree)
(for-each-tree (lambda (x) 1) + 0 tree 0))
(define (filter-tree f tree)
(for-each-tree (lambda (x) (if (f x) (list x) '())) r-append '() tree '()))
(define (find-if-tree f tree)
(block return
(for-each-tree (lambda (x) (if (f x) (return x) #f))
(lambda (x y) #f)
#f
tree
#f)))
(define (max-tree tree)
(for-each-tree identity
(lambda (x y) (if (and x y) (max x y) (or x y)))
#f
tree
#f))
実行結果は元の関数と同様です.
まとめ
for-each-tree は以下のようなループ構造を使って書くこともできる.
(define (for-each-tree f g n tree r)
(do ((tree tree (cdr tree))
(r r (g (for-each-tree f g n (car tree) n) r)))
((not (pair? tree)) (if (null? tree) r (f tree)))))
継続を使った簡単なマクロ集.
まず一番単純な Common Lisp の block に似たものを作ってみます.
(define-syntax block
(syntax-rules ()
((block tag body1 body2 ...)
(call-with-current-continuation
(lambda (tag)
body1 body2 ...)))))
Common Lisp と違うことは, ブロックからの脱出方法が (return-from tag value) ではなく, (tag value) と書くところです. block の使い方はこんな感じです.
> (define (print . objs)
(for-each (lambda (o) (display o)) objs)
(newline))
> (block return
(print 'before)
(return 'hello)
(print 'after))
before
hello
> (block foo
(print 'foo-1)
(block bar
(print 'bar-1)
(foo 'hello)
(bar 'bye)
(print 'bar-2))
(print 'foo-2))
foo-1
bar-1
hello
この block を使って Common Lisp の simple loop を作ってみます.
(define-syntax loop
(syntax-rules ()
((loop tag body1 body2 ...)
(block tag
(let rec ()
body1 body2 ...
(rec))))))
使い方はこんな感じ.
> (let ((i 0))
(loop return
(print i)
(if (= i 5) (return 'bye))
(set! i (+ i 1))))
0
1
2
3
4
5
bye
次に C 言語ちっくな break と continue の使える while を作ってみます. break と continue を引数に渡さないといけないところがちょっとダサい気がしますが, とりあえず良しとしましょう. (注: 上で作成した block を利用しています)
(define-syntax while
(syntax-rules ()
((while test break continue body1 body2 ...)
(block break
(let loop ()
(cond (test
(block continue
body1 body2 ...)
(loop))))))))
使い方はこんな感じです. ネストした while からも一気に外側に抜けることができます.
> (let ((i 0))
(while (< i 10) break continue
(print i)
(cond ((= i 1)
(set! i 3)
(continue)))
(if (= i 5) (break 'bye))
(set! i (+ i 1))))
0
1
3
4
5
bye
> (let ((i 0))
(while (< i 5) break-i continue-i
(let ((j 0))
(while (< j 5) break-j continue-j
(print `((i ,i) (j ,j)))
(if (and (= i 1) (= j 1)) (break-i 'bye))
(set! j (+ j 1))))
(set! i (+ i 1))))
((i 0) (j 0))
((i 0) (j 1))
((i 0) (j 2))
((i 0) (j 3))
((i 0) (j 4))
((i 1) (j 0))
((i 1) (j 1))
bye
まとめ
block 内で脱出するには (return-from tag value) ではなく, (tag value) を使う.
block から一気に外側へ抜けることができる.
クロージャを使うときの典型的なパターンを紹介します.
まず例として次のような関数を考えてみます.
(define gensym
(lambda (n)
(string->symbol (string-append "#:G" (number->string n)))))
> (gensym 1)
|#:G1|
> (gensym 2)
|#:G2|
この関数 gensym の目的は, ユニークなシンボルを生成することです. 変数 n を毎回引数に渡すのは使いづらいので, この変数 n を渡さなくて済むように, トップレベル変数(グローバル変数)を使って改造してみます.
(define *gensym-n* 0)
(define gensym
(lambda ()
(set! *gensym-n* (+ *gensym-n* 1))
(string->symbol (string-append "#:G" (number->string *gensym-n*)))))
これで, ユニークなシンボルを得るという当初の目的を達成することができました. しかしクロージャにすると, グローバル変数を使わずに書くことができます.
(define gensym
(let ((n 0))
(lambda ()
(set! n (+ n 1))
(string->symbol (string-append "#:G" (number->string n))))))
上記の追加した変数 n は gensym 関数外からはアクセスできません. つまり関数自体が n という状態を持っているかのように振舞います.
このパターンは,
(define 関数名
(lambda (仮引数1 ...)
ボディ))
という関数を,
(define 関数名
(let ((変数1 初期値1) ...)
(lambda (仮引数1 ...)
ボディ)))
とすることにより, 上記の 変数1 ... を関数内にとじこめることができます.
letrec でも大丈夫です. 以下の例では fact の計算時にパスワード入力を求められます.
> (define protected-fact
(letrec ((passwd 'foo)
(fact (lambda (n)
(if (<= n 1) 1
(* n (fact (- n 1)))))))
(lambda (n)
(if (eq? passwd (read)) (fact n)
'sorry))))
> (protected-fact 5)
bar ; 入力
sorry
> (protected-fact 5)
foo ; 入力
120
このパターンを使った例をもう一つ.
(define (make-point init-x init-y)
(let ((x init-x) (y init-y))
(lambda (method . param)
(cond ((eq? method 'get-x) x)
((eq? method 'get-y) y)
((eq? method 'set-x) (set! x (car param)))
((eq? method 'set-y) (set! y (car param)))
((eq? method 'print) (display `((x ,x) (y ,y))) (newline))
(else 'hum?)))))
> (define p (make-point 10 20))
> (p 'print)
((x 10) (y 20))
> (p 'get-x)
10
> (p 'set-x 100)
> (p 'print)
((x 100) (y 20))
> (define q (make-point 55 88))
> (q 'print)
((x 55) (y 88))
> (p 'print)
((x 100) (y 20))
> p
<closure 0xa09b900(method param)>
> q
<closure 0xa09b340(method param)>
クロージャを使ったオブジェクト指向みたいなことができます.
通常の再帰関数を自動的に末尾再帰関数に変換する関数を作成します.
例として以下のような再帰関数 fact を末尾再帰関数に変換することを考えてみます.
(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1))))))
↓変換
(define (fact n acc)
(if (<= n 1) acc
(fact (- n 1) (* n acc))))
この変換は以下のようなステップに分けられます.
(define (fact n) ...) → (define (fact n acc) ...)
(if (<= n 1) 1 ...) → (if (<= n 1) acc ...)
(* n (fact (- n 1))) → (* n acc) → (fact (- n 1) (* n acc))
ステップ 3 がすこしややこしいですが, それほど難しいわけではありません. アキュムレータについては(OnLisp Section 2.8)を参照してください. 終端文脈については(R5RS 正しい終端再帰)を参照してください.
このような変換を行う関数 rec->tailrec を作成してみましょう. ひとまず, rec->tailrec が以下のような動作をすることを目標とします.
> (rec->tailrec '(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1))))))
(define (fact n acc)
(if (<= n 1) acc
(fact (- n 1) (* n acc))))
まずはじめにユーティリティ関数を定義しておきます.
(define (atom? obj)
(not (pair? obj)))
(define (find-if p lst)
(cond ((null? lst) #f)
((p (car lst)) (car lst))
(else (find-if p (cdr lst)))))
(define (append-atom lst obj)
(append lst (list obj)))
(define gensym
(let ((n 0))
(lambda ()
(set! n (+ n 1))
(string->symbol (string-append "G" (number->string n))))))
gensym はほとんどの処理系で用意されているので, そちらを使ったほうがよいでしょう. また, (クロージャの使い方)で説明していますのでそちらを参照してください. それ以外は見たままです.
では, rec->tailrec を作成します.
(define (rec->tailrec func-def)
(let ((def (car func-def))
(name (caadr func-def))
(args (cdadr func-def))
(body (cddr func-def))
(acc (gensym)))
`(,def (,name ,@args ,acc)
,@(rec->tailrec-body acc name body))))
rec->tailrec は引数で与えられた func-def を, 関数名(name), 仮引数(args), 関数本体(body) に分解し, アキュムレータ変数(acc)を仮引数に追加します. これは, 上述のステップ 1 に相当します. 関数本体は rec->tailrec-body で変換します.
ここで, アキュムレータ変数が gensym で生成されたユニークなシンボルであることに注意してください. こうしないと, もしも仮引数(args)中に偶然 acc というシンボルが入っていたときに, エラーとなってしまいます (仮引数群の中に同じ変数が 2 度以上現れてはならないため. (R5RS 手続き)を参照).
とりあえず, ダミーの rec->tailrec-body を定義して, rec->tailrec がどのような動作をするか試してみましょう.
> (define (rec->tailrec-body acc name body)
body)
> (rec->tailrec '(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1))))))
(define (fact n G1)
(if (<= n 1) 1
(* n (fact (- n 1)))))
G1 というアキュムレータ変数が追加されています. これでステップ 1 は実現できました. 残りはステップ 2, 3 を実現する rec->tailrec-body を定義することです.
まずステップ 2 を考えてみましょう. 以下のように rec->tailrec-body を定義してみます.
(define (rec->tailrec-body acc name body)
(define (if? expr) (and (pair? expr) (eq? 'if (car expr))))
(cond ((atom? body) body)
((if? body)
`(if ,(cadr body) ,acc
,(rec->tailrec-body acc name (cadddr body))))
(else (map (lambda (expr) (rec->tailrec-body acc name expr)) body))))
((if? body) ...) の部分は, body が (if ...) の場合に
(if test then else) → (if test acc else)
という変換を行います. 見つからなかった場合はリストの要素に対して再帰的に rec->tailrec-body を適用します.
試してみます.
> (rec->tailrec '(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1))))))
(define (fact n G2)
(if (<= n 1) G2
(* n (fact (- n 1)))))
元の関数で 1 を返す部分がアキュムレータ変数 G2 に置換されています. if 以外の対応をしていませんが, 一応ステップ 2 は実現できました.
次にステップ 3 ですが, 以下のように rec->tailrec-body を改良します.
(define (rec->tailrec-body acc name body)
(define (if? expr) (and (pair? expr) (eq? 'if (car expr))))
(define (self-call? expr) (and (pair? expr) (eq? name (car expr))))
(cond ((atom? body) body)
((if? body)
`(if ,(cadr body) ,acc
,(rec->tailrec-body acc name (cadddr body))))
((find-if self-call? body)
(append-atom (find-if self-call? body)
(map (lambda (x) (if (self-call? x) acc x)) body)))
(else (map (lambda (expr) (rec->tailrec-body acc name expr)) body))))
(define (self-call? expr) ...) と ((find-if self-call? body) ...) の部分が今回追加した部分です. body 中で自分自身を呼び出している式が見つかった場合に,
(... (name ...) ...) → (... acc ...) → (name ... (... acc ...))
という変換を行います.
試してみます.
> (rec->tailrec '(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1))))))
(define (fact n G3)
(if (<= n 1) G3
(fact (- n 1) (* n G3))))
ステップ 3 も実現できました. これで, fact を末尾再帰関数に変換するという当初の目的を達成できました.
この rec->tailrec には注意しなければならないことがあります. それは, 元の関数で (fact 5) は,
(* 5 (* 4 (* 3 (* 2 1))))
と計算されますが, 変換後の関数で (fact 5 1) は,
(* 2 (* 3 (* 4 (* 5 1))))
と計算されます. fact の場合は両者の結果は同じですので問題はありませんが, 以下の copy-list のような関数の場合には
> (define (copy-list lst)
(if (null? lst) lst
(cons (car lst) (copy-list (cdr lst)))))
> (copy-list '(1 2 3))
(1 2 3)
以下のように変換されます.
> (rec->tailrec '(define (copy-list lst)
(if (null? lst) lst
(cons (car lst) (copy-list (cdr lst))))))
(define (copy-list lst G4)
(if (null? lst) G4
(copy-list (cdr lst) (cons (car lst) G4))))
> (copy-list '(1 2 3) '())
(3 2 1)
そのため, 異なる結果を返す関数を生成してしまいます.
これをきちんと同じ結果を返すように rec->tailrec-body を改良します. 基本的な考え方は, クロージャを使って評価を遅延することにより元の関数と同じ計算順序にすることです.
(define (rec->tailrec-body acc name body)
(define (if? expr) (and (pair? expr) (eq? 'if (car expr))))
(define (self-call? expr) (and (pair? expr) (eq? name (car expr))))
(cond ((atom? body) body)
((if? body)
`(if ,(cadr body) (,acc ,(caddr body))
,(rec->tailrec-body acc name (cadddr body))))
((find-if self-call? body)
(append-atom
(find-if self-call? body)
(let ((i (gensym)))
`(lambda (,i)
(,acc ,(map (lambda (x) (if (self-call? x) i x)) body))))))
(else (map (lambda (expr) (rec->tailrec-body acc name expr)) body))))
(let ((i (gensym))) ...) の部分が今回修正した部分です. とりあえず, 実行してどのような変換を行うか見てみましょう.
> (rec->tailrec '(define (copy-list lst)
(if (null? lst) lst
(cons (car lst) (copy-list (cdr lst))))))
(define (copy-list lst G5)
(if (null? lst) (G5 lst)
(copy-list (cdr lst) (lambda (G6) (G5 (cons (car lst) G6))))))
> (copy-list '(1 2 3) (lambda (x) x))
(1 2 3)
(G5 lst) と (lambda (G6) ...) の部分は, 前のバージョンと異なる部分です. 前のバージョンの変換結果と比べると, アキュムレータ変数の値が関数になっています. そのため, 終了条件が真の場合に返す値が,
G5 → (G5 lst)
のように関数呼び出しに変更されています. また, 計算結果を累積する部分が
(cons (car lst) G5) → (lambda (G6) (G5 (cons (car lst) G6)))
のようにクロージャによって評価が遅延されています. この遅延された計算は終了条件が真になった時点で, 関数呼び出し (G5 lst) によって一気に計算されます.
例として (copy-list '(1 2 3) (lambda (x) x)) の場合, 以下のようにクロージャが次々と生成された後, 最後に計算が行われます. その結果 (1 2 3) が得られます.
((lambda (G6)
((lambda (G6)
((lambda (G6)
((lambda (x) x)
(cons 1 G6)))
(cons 2 G6)))
(cons 3 G6)))
'())
ここで注意しておくべきことは, 元の再帰関数から末尾再帰関数に変換したことによりスタックの消費はなくなりましたが, 評価の遅延のためにクロージャを次々と生成するためヒープ消費量が増加してしまうことです.
まとめ
rec->tailrec により再帰関数を末尾再帰関数に自動的に変換することができる.
rec->tailrec は元の関数と同じ計算順序で計算を行うことができるが, 再帰呼び出し回数に比例してヒープ消費量が増大する.
fact), 一つ前のバージョンの rec->tailrec を使ったほうがよい.
defmacro の場合).
(defmacro define-tailrec (func-def)
(rec->tailrec func-def))
;; 使い方
(define-tailrec
(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1))))))
rec->tailrec の元ネタは, 昔読んだ論文です. 論文の名前を忘れてしまったので, 知っている方がおられたら, ccbcc55@hotmail.com までご連絡いただけるとありがたいです.
if 以外(例えば cond)は変換できない.
> (rec->tailrec '(define (fact n)
(cond ((<= n 1) 1)
(else (* n (fact (- n 1)))))))
(define (fact n G7)
(cond ((<= n 1) 1) ; おかしい
(else (fact (- n 1) (lambda (G8) (G7 (* n G8)))))))
if の「代わりの帰結」でない場合に変換できない.
> (rec->tailrec '(define (fact n)
(if (> n 1) (* n (fact (- n 1))) ; 「帰結」で再帰呼び出し
1)))
(define (fact n G9)
(if (> n 1) (G9 (* n (fact (- n 1)))) ; おかしい
1)) ; おかしい
> (rec->tailrec '(define (fact n)
(if (<= n 1) 1
(+ 0 (* n (fact (- n 1)))))))
(define (fact n G10)
(if (<= n 1) (G10 1)
(+ 0 (fact (- n 1) (lambda (G11) (G10 (* n G11))))))) ; 末尾再帰でない
非常に計算コストのかかる関数があり, かつその関数を同じ引数で複数回呼び出すような場合, 次のように結果をキャッシュする memoize という関数を作成して計算コストを削減することができます.
(define (memoize proc)
(let ((cache '()))
(lambda args
(let ((hit (assoc args cache)))
(if hit (cdr hit)
(let ((result (apply proc args)))
(set! cache (cons (cons args result) cache))
result))))))
引数 args をキーとし, 関数の結果を値とする連想リスト(cache)をクロージャ内に保持し, キャッシュにヒットしなかった場合のみ関数 proc を実行します.
例として, 次のような関数 fact をキャッシュ可能な関数にしてみましょう. (注: この fact は以下の説明のためしょぼい実装にしています)
(define (fact n)
(if (<= n 1) 1
(* n (fact (- n 1)))))
この関数のキャッシュ可能な関数を生成するには, 以下のようにします.
(define memoized-fact (memoize fact))
では, 実際に期待した通りに動作しているかトレースして確かめてみます.
> (trace fact) (fact) > (memoized-fact 5) [fact 5] | [fact 4] | | [fact 3] | | | [fact 2] | | | | [fact 1] | | | | 1 | | | 2 | | 6 | 24 120 120
一度目の呼び出しでは当然キャッシュされていませんので関数 fact が呼び出されています. もう一度呼び出してみると,
> (memoized-fact 5) 120
今度はキャッシュにヒットしたので関数 fact は呼び出されませんでした. 期待通りに動作しているようです.
まとめ
assoc のコストより元の関数のコストが小さい場合には適用しないほうがよい.
(define (memoize proc)
(let ((cache '()))
(cons (lambda args
(let ((hit (assoc args cache)))
(if hit (cdr hit)
(let ((result (apply proc args)))
(set! cache (cons (cons args result) cache))
result))))
(lambda ()
(set! cache '())))))
(define f (memoize fact))
(define memoized-fact (car f))
(define clear-fact-cache (cdr f))
Common Lisp には遅延評価のための関数(delay, force)が標準で用意されていませんが, クロージャを使って簡単に実装することができます.
(defun make-promise (f)
(let ((ready-p nil)
(result nil))
#'(lambda ()
(if ready-p result
(let ((r (funcall f)))
(if ready-p result
(setq ready-p t
result r)))))))
(defun promise-p (f)
(functionp f))
(defmacro delay (expr)
`(make-promise #'(lambda () ,expr)))
(defun force (f)
(if (promise-p f) (funcall f)
f))
まとめ
遅延評価を利用して無限リストを表現してみます.
(define (make-inf-list generator inits)
(cons (car inits) (delay (make-inf-list generator (generator inits)))))
(define inf-car car)
(define (inf-cdr lst)
(force (cdr lst)))
(define (inf-truncate lst limit)
(let loop ((i 0) (lst lst) (r '()))
(if (= i limit) (reverse r)
(loop (+ i 1) (inf-cdr lst) (cons (inf-car lst) r)))))
この make-inf-list を使って自然数のリストを表現してみます.
> (define natual-numbers (make-inf-list (lambda (x) (list (+ (car x) 1))) '(1))) > (inf-car natual-numbers) 1 > (inf-car (inf-cdr natural-numbers)) 2 > (inf-truncate natual-numbers 20) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
make-inf-list を使ってフィボナッチ列を表現してみます.
> (define fibs (make-inf-list (lambda (x) (list (cadr x) (+ (car x) (cadr x)))) '(0 1))) > (inf-truncate fibs 20) (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181)
まとめ
(display `((a ,a) (b ,b) (c ,c)))
let) を Common Lisp で使うには
(defmacro nlet (tag var-vals &body body)
`(labels ((,tag ,(mapcar #'car var-vals) ,@body))
(,tag ,@(mapcar #'cadr var-vals))))
> (defun rev (lst)
(nlet loop ((lst lst) (r nil))
(if (null lst) r
(loop (cdr lst) (cons (car lst) r)))))
REV
> (rev '(1 2 3 4 5))
(5 4 3 2 1)
(Mac OS X 10.2.6) + (Mac OS X Developer Tools December 2002) + (fink-0.5.2.cvs)
% uname -a Darwin foo 6.6 Darwin Kernel Version 6.6: Thu May 1 21:48:54 PDT 2003; root:xnu/xnu-344.34.obj~1/RELEASE_PPC Power Macintosh powerpc
% fink install dlcompat
% fink install libiconv
% curl -O http://easynews.dl.sourceforge.net/sourceforge/gauche/Gauche-0.6.8.tgz
% tar xfz Gauche-0.6.8.tgz
% cd Gauche-0.6.8
% ./configure --with-local=/sw --with-rpath=/sw/lib --with-iconv=/sw \
--enable-threads=pthreads
% make
% make test
% sudo make install
% cd doc
% sudo make install
% sudo vi /usr/local/info/dir
The Algorithmic Language Scheme * Gauche Reference: (gauche-refe.info). An R5RS Scheme implementation. * Gauche Reference (ja): (gauche-refj.info). An R5RS Scheme implementation.
~/.emacs に
(setq scheme-program-name "/usr/local/bin/gosh -i") (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme process. " t)
% fink install guile16
% curl -O http://download.plt-scheme.org/bundles/204/plt/PLT_Scheme.dmg
Finder で
注意: 以下の情報はかなり古いです. 最近筆者はメイン環境を Mac OS X に移行したので, 今後更新することはおそらくないと思います.
Windows-2000 + (cygwin-1.3.2)
% uname -a CYGWIN_NT-5.0 FOO 1.3.2(0.39/3/2) 2001-05-20 23:28 i686 unknown
guile-1.4 が(Project HeavyMoon ftp サイト)からダウンロードできるが, 色々と気に入らないこと(ドキュメントがほとんどない等)があるので, 最新版をコンパイルした.
/ で展開する.
% wget ftp://ftp.st.ryukoku.ac.jp/pub/ms-windows/HeavyMoon/rpm-3.0.6.bin.tar.gz % cp rpm-3.0.6.bin.tar.gz / % cd / % tar xfz rpm-3.0.6.bin.tar.gz
% wget http://www.geocities.co.jp/SiliconValley-PaloAlto/7043/guile-core-20020223-2.i686-cygwin.rpm % rpm -ivh --nodeps guile-core-20020223-2.i686-cygwin.rpm
% wget ftp://krusty.e-technik.uni-dortmund.de/pub/guile/snapshots/guile-core-20020223.tar.gz
% wget http://www.geocities.co.jp/SiliconValley-PaloAlto/7043/guile-core-20020223-cygwin.patch.txt % tar xfz guile-core-20020223.tar.gz % cd guile-core-20020223 % patch -p1 < ../guile-core-20020223-cygwin.patch.txt
% ./configure --disable-shared % make % make install ;; なぜか guile-snarf がインストールされないので手動でコピー % install -m 755 libguile/guile-snarf /usr/local/bin
% cd doc/ref % texi2html guile.texi % cd ../goops % texi2html goops.texi % cd ../r5rs % texi2html r5rs.texi % cd ../tutorial % texi2html guile-tut.texi
% wget http://swissnet.ai.mit.edu/ftpdir/scm/slib2d2.zip % unzip slib2d2.zip -d /usr/local/lib ;; 環境変数の設定 ;; [マイコンピュータ右クリック]-[プロパティ]-[詳細]-[環境変数] ;; または c:\autoexec.bat に set SCHEME_LIBRARY_PATH=C:\cygwin\usr\local\lib\slib\ % vi ~/.bashrc ----------------------------------------------- export SCHEME_LIBRARY_PATH=/usr/local/lib/slib/ ----------------------------------------------- % source ~/.bashrc
% wget http://swissnet.ai.mit.edu/ftpdir/scm/scm5d4.zip
% unzip scm5d4.zip
% cd scm
;; bignum を大きめにする
% perl -i.orig -pe 's/# define NUMDIGS_MAX 1000/# define NUMDIGS_MAX 20000/o' scmfig.h
;; コンパイル
% make scmlit
% ./build -p unix -F arrays array-for-each bignums cautious compiled-closure \
dynamic-linking engineering-notation generalized-c-arguments inexact \
macro posix record regex rev2-procedures tick-interrupts > makescm
% perl -i.orig -nle 'chop; s/^cc/gcc/o; s/-O/-O2/o; print;' makescm
% rm -f scm.exe ; sh ./makescm && test -f scm.exe && echo "done"
done
;; テスト
% ./scm r4rstest.scm
:
Passed all tests
:
> (test-cont) (test-sc4) (test-delay)
:
Passed all tests
:
> (exit)
;; SCM では定義されていないものを定義
% vi ~/ScmInit.scm
-----------------------------------------------
(define call/cc call-with-current-continuation)
-----------------------------------------------
(Gauche - A Scheme Interpreter)
/ で展開する.
% wget ftp://ftp.st.ryukoku.ac.jp/pub/ms-windows/HeavyMoon/rpm-3.0.6.bin.tar.gz % cp rpm-3.0.6.bin.tar.gz / % cd / % tar xfz rpm-3.0.6.bin.tar.gz
% wget http://www.geocities.co.jp/SiliconValley-PaloAlto/7043/Gauche-eucjp-0.6-1.i686-cygwin.rpm % rpm -ivh --nodeps Gauche-eucjp-0.6-1.i686-cygwin.rpm
% tar xfz Gauche-0.5.7.tgz % cd Gauche-0.5.7 ;; --with-pthread をつけると configure に失敗する % ./configure --with-slib=/usr/local/lib/slib ;; ext/termios, ext/fcntl の make に失敗するがそれ以外は成功 % make -k ;; ほとんど成功する % make -k test % make -k install
(Kawa, the Java-based Scheme system)
;; source から make は失敗するのでバイナリを使う % wget ftp://ftp.gnu.org/pub/gnu/kawa/kawa-1.6.97.tar.gz ;; ~/.emacs に ----------------------------------------------- (setq scheme-program-name "C:/jdk1.3.1_01/bin/java.exe -cp D:/home/foo/kawa/kawa-1.6.97.jar kawa.repl") -----------------------------------------------
% wget http://guile-pg.sourceforge.net/guile-pg-0.07.tar.gz
% wget http://www.geocities.co.jp/SiliconValley-PaloAlto/7043/guile-pg-0.07.patch.txt
% tar xfz guile-pg-0.07.tar.gz
% cd guile-pg-0.07
;; パッチをあてる
% patch -p1 < ../guile-pg-0.07.patch.txt
% ./configure --with-libpq-includes=/usr/include/postgresql --with-lib-pq-lib=/usr/lib
% make -k
# エラーがでるので以下を実行
% gcc -g -O2 -Wall -Wmissing-prototypes -o guile-pg -L/usr/local/lib \
-lguile -lcrypt -lregex -lpq -static guile-pg.o /usr/local/lib/libguile.a \
/usr/local/lib/libltdl.a -lcrypt -lregex .libs/libpostgres.a -lpq -lpq \
-lcrypt -lpq -lpq -lcrypt -lpq
% make -k
% make check
:
==================
All 2 tests passed
==================
:
% make install
% mkdir pseudo-2.12 % cd pseudo-2.12 % wget http://www.swiss.ai.mit.edu/ftpdir/pseudo/pseudo-2.12.tar.gz % tar xfz pseudo-2.12.tar.gz
:
#+:ccl "LISP" ;Coral
;; #+allegro "cl"
"lisp" ;For Unix, Exploder, and anyone else
:
realp のところでコンパイルに失敗するので, core.lisp の 117 行目に #-allegro を追加.
: ;This function is new in CLtL II / ANSI. #-allegro (defun realp (obj) :
CL-USER(1): :cd lisp/pseudo-2.12 CL-USER(2): (load "loadit") CL-USER(3): (load-pseudoscheme "./") CL-USER(4): (ps:scheme) SCHEME(5): (display 'hello)
scheme-program-name で起動したい処理系を指定して M-x run-scheme で起動する.
;; (setq scheme-program-name "D:/home/foo/scm/scm.exe") ;; (setq scheme-program-name "C:/jdk1.3.1_01/bin/java.exe -cp D:/home/foo/kawa/kawa-1.6.97.jar kawa.repl") (setq scheme-program-name "C:/cygwin/usr/local/bin/gosh.exe -i") ;; (setq scheme-program-name "C:/cygwin/bin/guile.exe") ;; (setq scheme-program-name "C:/cygwin/usr/local/bin/guile-pg.exe") (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme process. " t)
(eq 'a 'A) => nil
Common Lisp だとこれはエラーになるが, Emacs Lisp では問題なし.
(defun foo ()
x)
(defun bar ()
(let ((x -1))
(foo)))
Common Lisp だと,
(defvar x)としておくか,
(defun bar ()
(let ((x -1))
(declare (special x))
(foo)))
とすると Emacs Lisp と同じ動作になる.
(setq f (let ((n 0))
#'(lambda () (setq n (1+ n)))))
(funcall f) => error: (void-variable n)
f => (lambda nil (setq n (1+ n)))
(consp f) => t
ていうか lambda はただのコンス.
cl パッケージの lexical-let を使えばクロージャにできるようだ.
(require 'cl)
(setq g (lexical-let ((n 0))
#'(lambda () (setq n (1+ n)))))
(funcall g) => 1
(funcall g) => 2
g => (lambda (&rest --cl-rest--)
(apply (lambda (G5215)
(set G5215 (1+ (symbol-value G5215))))
(quote --n--) --cl-rest--))
(defun fact-aux (n r)
(if (<= n 1) r
(fact-aux (1- n) (* n r))))
(defun fact (n)
(fact-aux n 1))
(fact 5) => 120
しかし, かなり強引だが以下のようにすればほとんど末尾再帰のように書くことができる.
(defun fact-aux (n r)
(if (<= n 1) r
`(fact-aux ,(1- n) ,(* n r))))
(defun fact (n)
(do ((next (fact-aux n 1) (funcall (car next) (cadr next) (caddr next))))
((not (consp next)) next)))
(fact 5) => 120
Scheme 等の再帰で書かれたコードを移植するときに便利.
もうひとつ別の例.
(defun even-p (n)
(if (zerop n) t
(odd-p (1- n))))
(defun odd-p (n)
(if (zerop n) nil
(even-p (1- n))))
(even-p 10) => t
(odd-p 10) => nil
相互末尾再帰でも同じように書ける.
(defun even-p-aux (n)
(if (zerop n) t
`(odd-p-aux ,(1- n))))
(defun odd-p-aux (n)
(if (zerop n) nil
`(even-p-aux ,(1- n))))
(defun even-p (n)
(do ((next (even-p-aux n) (funcall (car next) (cadr next))))
((not (consp next)) next)))
(defun odd-p (n)
(do ((next (odd-p-aux n) (funcall (car next) (cadr next))))
((not (consp next)) next)))
(even-p 10) => t
(odd-p 10) => nil
(japanese-tokenizer.el) の bigram の実装を参照.
(defun foo (func) (print `(foo-func => ,func)) (funcall func)) (defun bar (func) (print `(bar-func => ,func)) (foo #'(lambda () (print "bar") (funcall func)))) (defun test () (bar #'(lambda () (print "test")))) (test) -| (bar-func => (lambda nil (print "test"))) -| (foo-func => (lambda nil (print "bar") (funcall func))) -| "bar" -| "bar" -| "bar" : => error: (error "Lisp nesting exceeds max-lisp-eval-depth")となって無限ループしてしまう. 高階関数の仮引数の名前に
func なんていう安易な名前をつけてはいけないようだ.
これを回避するには, 単純に仮引数の名前にプレフィックスを付けて名前が被らないようにすればよい(ただし完全にこの問題を回避することはできない).
(defun foo (foo-func) (print `(foo-func => ,foo-func)) (funcall foo-func)) (defun bar (bar-func) (print `(bar-func => ,bar-func)) (foo #'(lambda () (print "bar") (funcall bar-func)))) (defun test () (bar #'(lambda () (print "test")))) (test) -| (bar-func => (lambda nil (print "test"))) -| (foo-func => (lambda nil (print "bar") (funcall bar-func))) -| "bar" -| "test" => "test"以下のようにして
func を評価させる手もあるが, プレフィックスをつけるほうが楽.
(defun foo (func) (print `(foo-func => ,func)) (funcall func)) (defun bar (func) (print `(bar-func => ,func)) (foo `(lambda () (print "bar") (funcall ,func)))) ; ココ (defun test () (bar #'(lambda () (print "test")))) (test) -| (bar-func => (lambda nil (print "test"))) -| (foo-func => (lambda nil (print "bar") (funcall (lambda nil (print "test"))))) -| "bar" -| "test" => "test"参考: (2ch Emacs Lisp スレッド).
Emacs Lisp では以下のように書けない.
(defun foo (a &optional (b 0)) ...)仕方ないので以下のように書く.
(defun foo (a &optional b)
(let ((b (or b 0)))
...)
当然 supplied-p もないので (foo 1) と (foo 1 nil) が区別できない. ちなみに &body もない.
こういうマクロを作ってみた.
(defmacro optional-bind (var-vals &rest body)
`(let (,@(mapcar #'(lambda (var-val)
`(,(car var-val) (or ,(car var-val) ,(cadr var-val))))
var-vals))
,@body))
このマクロを使えばこう書ける.
(defun foo (a &optional b)
(optional-bind ((b 0))
...))
コンパイル時に cl パッケージを使う分には問題ないので,
(eval-when-compile (require 'cl))としておけば,
setf や dolist 等のマクロが使える.
こんな感じでハッシュテーブルが組み込みかどうかを判別できる.
(if (and (fboundp 'make-hash-table) (subrp (symbol-function 'make-hash-table)))
(eval-when-compile (require 'cl)) ; 組み込み
(require 'cl)) ; cl パッケージ
(シンボル表を利用したハッシュ) を利用するという手もある.
[Update 2004/02/15] (approx-search-0.2.tar.gz) ; 曖昧度を設定できるようにしました. (Meadow) に対応しました.
曖昧検索, approximate pattern matching を可能にする Emacs Lisp ライブラリ.
他人の書いたプログラムや, 遠い昔に自分で書いたプログラムをメンテしている時, 難しい単語やスペルミスした単語がうまく検索できなくて困ったことありませんか? そういう時に曖昧検索できると便利だと思ってこのライブラリを書きました.
以前 (Levenshtein distance) というアルゴリズムを使って曖昧検索を実装したのですが, あまりにも遅すぎるため, いまいち使えませんでした. 今回は正規表現ベースのアルゴリズムを使って高速に曖昧検索できるようにしました.
基本的なアイデアは, 入力された文字列から曖昧検索のための正規表現を生成するというもので, (Migemo) を参考にしました. (Migemo) の場合はローマ字入力から日本語の正規表現を生成しますが, このライブラリでは入力から曖昧検索の正規表現を生成します. 具体的にはこんな感じです.
(approx-generate-regexp "abcd") => "\\(bcd\\|acd\\|abd\\|abc\\|a.cd\\|ab.d\\|ab.cd\\)"
この生成された正規表現を re-search-forward に渡して曖昧検索を実現しています. 入力された文字数を N 個とすると, だいたい 3N 個程度のパターンを生成して, その OR パターンで正規表現検索します.
曖昧度, ambiguousness を指定できるようにしました. 曖昧度を大きくすると再帰的にパターンを生成して, より曖昧な検索が可能となります.デフォルトの曖昧度は 1 です. M-x approx-set-ambiguousness で曖昧度を設定できます.
インクリメンタルサーチ, isearch にも対応しています. (Meadow) でも動作するように修正しました (*).
(Migemo) を使った曖昧検索はできません. (Migemo) に対応することもできますが, 作者がこのライブラリを使う場面は主にプログラムを編集する時(つまり (Migemo) を off にしている時)なので, 今のところ (Migemo) で利用できるようにする必要はあまり感じていません.
search-forward, search-backward と同じインターフェースで曖昧検索ができます.
isearch をカスタマイズして, 曖昧検索によるインクリメンタルサーチが利用できます.
このライブラリは以後メンテナンスされません. (approx-search.el) を使ってください.
(Levenshtein distance) (edit distance, 編集距離) を使った曖昧検索を可能にする Emacs Lisp ライブラリ.
通常の search-forward は引数で与えた文字列に完全にマッチする文字列を検索する. しかし, 数文字くらい違っていてもかまわないから検索してほしい場面がある.
例えば SPAM メールのフィルタで "未承諾広告" と設定している場合, 簡単なマッチングでは "末承諾広告" を逃してしまう. この場合, search-forward-regexp を使って正規表現で ".承諾広告" などとすれば事足りるのだが, 例えば "未承諾廣告" は逃してしまう. まあ, ひたすら正規表現を凝ったものにすればよいのだが, 面倒だし, きりがない.
こういう場合に, 文字列を曖昧に検索できると便利である. このライブラリの ld-search-forward を使って "未承諾広告" を検索すると, "末承諾広告" も "未承諾廣告" もマッチさせることができる.
search-forward, search-backward と同じインターフェースで曖昧検索ができます.
isearch をカスタマイズして, 曖昧検索によるインクリメンタルサーチが利用できます.
wl-refile-rule-alist と同じようにリファイルルールを記述して, 曖昧検索によるリファイルができます.
[Update 2003/01/22] (spamfilter-1.1.tar.gz) ; コーパスから単語を削除する API を追加しました.
近頃, 流行っている Paul Graham さんの (A Plan for Spam) および (Better Bayesian Filtering) を Emacs Lisp で実装した SPAM フィルタリングライブラリです. Emacs 上のメーラ内で使うことを想定しています. 筆者は (Wanderlust) 上で使っています.
日本語に対応したベイジアンフィルタは色々ありますが((scbayes), (bsfilter), (bogofilter + kakasi) 等), それらと比べて以下の特徴があります.
日本語の場合, token への分解は英語のように単純ではない (*) ため, 以下の 3 種類の手法を選択できるようにしました.
筆者の環境で同じデータ(spam 約 250 通, nonspam 約 1000 通)をもとに簡単にテストした限りでは,
上記 3 種類のどの手法でも
という結果が得られています. 筆者のおすすめは bigram です.
`o' や `C-o' を実行すると SPAM かどうかの判定を行い, SPAM と判断されると "+spam" マークをつけます.
`x' でリファイルを実行すると, リファイル対象のメールを解析してコーパスの学習を行います.
`o' , `M-o' , `x' で利用できます.
友人, 仕事関係, ML, メールマガジンの類いのほとんどはルールによるフィルタ((Wanderlust) の場合は wl-refile-rule-alist)を使って判別できます. また, 例のサブジェクトが「未承諾広告」のメールも, ルールでつかまえられます. したがって, これらのメールはベイジアンフィルタで処理しなくても判別できるので コーパスには登録しないほうが検出精度が向上するようです.
設定例はこんな感じ. spamf-wl-ignore-register-folder-names で除外するフォルダを指定します.
(setq wl-refile-rule-alist
'(("From"
("@mailmagazine\\.co\\.jp" . "+mailmagazine")
("otomodati@bar\\.ne\\.jp" . "+friend")
("okyaku@foo\\.co\\.jp" . "+work"))
(("To" "Cc")
("ml@baz\\.org" . "+ml"))
("Subject"
("未承諾広告" . "+trash"))))
(setq spamf-wl-ignore-register-folder-names
'("+trash" "+mailmagazine" "+friend" "+work" "+ml"))
筆者の場合はルールだけでほぼ 90% のメールは振り分けできています. 残りの 10% がベイジアンフィルタに委ねられます.
ただし, これらのルールで判別したメールに SPAM が混じりはじめたら(例えば ML に SPAM が送られてきたりしたら)ルールを変更してベイジアンフィルタで処理しなければなりません.
上記は筆者の環境での話ですのであなたの環境ではうまくいかないかもしれません.
他にも検出精度を向上させるための Tips があれば ccbcc55@hotmail.com に教えてください.
こんな感じの Perl スクリプトを,
while (<>) {
chop;
print $.;
print ": ";
s/define/DEFINE/;
if (/let/) { print "LET "; }
print;
print "\n";
}
Scheme でこんな感じに書くためのライブラリ.
(while (<>) (chop!) (print *.*) (print ": ") (s! "define" "DEFINE") (if (m "let") (print "LET ")) (print) (newline))
#!/usr/local/bin/gosh と書き, 実行属性を立てておくと通常コマンドのように使えます. (他の処理系でもできます)
ちなみにちゃんと Scheme っぽく書くこともできます.
(while (<> line '("perl.scm" "pregexp/pregexp.scm"))
(set! line (chop line))
(print *.*)
(print ": ")
(set! line (s "define" "DEFINE" #f line))
(if (m "let" line) (print "LET "))
(let loop ((line (split "\\s+" line)))
(cond ((null? line) #t)
(else (print "[") (print (car line)) (print "]")
(loop (cdr line)))))
(newline))
since 2002/02/10
Susumu Ota (ccbcc55@hotmail.com)