Archive for 2010年8月|Monthly archive page
newLISP で On Lisp する．．．第２２章（その２）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
“問題が正しく定義できれば、半ば解けた同然である。” と言ったのは、アメリカの教育学者John Dewey氏。
それはさておき、前回の関数descent は、うまく動作していませんが、バックトラックはうまくいっていることが判っています。
ただ、全ての再帰の道筋が返ってきているだけ。つまり、関数descent が再帰した分だけ n1 が cons され、返ってくる。
問題点がわかりました。つまり、必要な分だけ再帰で戻ってきてほしいのです。それが、解決方法。
そこで考えました、末尾再帰を使えば良いのでは！
（defun は newlisp-utility.lsp に、=defun と =values は onnewlisp.lsp に、kids と choose-bind は 本章（その１）に定義してあります）
(defun descent (n1 n2)
(letex (_n1 n1 _n2 n2)
(descent-tr '_n1 '_n2 '())))
(=defun descent-tr (n1 n2 res)
(cond ((= n1 n2) (=values (push n2 res -1)))
((kids n1) (letex (_n1 n1)
(choose-bind n (kids '_n1)
(descent-tr n n2 (push '_n1 res -1)))))
(true (fail))))
これなら、戻ってきてほしい要素だけが、末尾再帰関数descent-tr に引数として渡されます。
こういう時、リストの末尾に追加できるnewLISP組込push が、便利です。
> (descent 'a 'g) (a c f g) > (fail) @ > (descent 'a 'd) (a b d) > (fail) (a c d) > (fail) @ > (descent 'a 'f) (a c f) > (fail) @ >
うまくいきました！
ま、でも、Common Lisp や Scheme で試していたら、“うまく言った” で終わって、進歩しなかったでしょうね。newLISP を選んで正解でした（笑）。
また、前回書き忘れましたが、前の時と違って、“On Lisp”本書のように括弧が一個なのは、今回が多値対応だからです。
さて、letex で渡している変数が、n1 だけですが、全てを記述すると、
(=defun descent-tr (n1 n2 res)
(cond ((= n1 n2) (=values (push n2 res -1)))
((kids n1) (letex (_n1 n1 _n2 n2 _res res)
(choose-bind n (kids '_n1)
(letex (_n n)
(descent-tr '_n '_n2 (push '_n1 '_res -1))))))
(true (fail))))
当然、このスクリプトでも動きます。
と、いうより、こちらが本来の書き方かも（笑）。では、何故前述のスクリプトでも動くのか？
このスクリプトで n2 は、最後まで変わりませんからね。
ちなみに、入り口の関数descent は、
(defun descent (x y)
(descent-tr x y ‘()))
なら、letex は、いりません。変数 n1、n2 を 変数 x、y に変えてあるのがポイント。つまり、変数補足の問題です。
これで、Common Lisp での実装 ならぬ newLISP による実装 が完成しました（笑）。
カット からは、次回に。
以上、如何でしょうか？
newLISP で On Lisp する．．．第２２章（その１の続き）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
さて、“On Lisp” 第20章の 継続渡しマクロ と共に使った例を（=defun、=values、=bind は onnewlisp.lsp に、choose-bind は 本章（その１）に定義してあります定義してあります）。
(=defun two-numbers ()
(choose-bind n1 '(0 1 2 3 4 5)
(letex (_n1 n1)
(choose-bind n2 '(0 1 2 3 4 5)
(=values '_n1 n2)))))
(=defun parlor-trick (sum)
(=bind (n1 n2) (two-numbers)
(if (= (+ n1 n2) sum)
(list "the sum of" n1 n2)
(fail))))
これを実行すると、
> (parlor-trick 7)
("the sum of" 2 5)
入れ子も出来ます。（multiple-value-list は onnewlisp.lsp に定義してあります）
> [cmd]
(multiple-value-list
(choose-bind first-name '(henry william)
(letex (_first-name first-name)
(choose-bind last-name '(james higgins)
(=values '_first-name last-name)))))
[/cmd]
(henry james)
> (multiple-value-list (fail))
(henry higgins)
> (multiple-value-list (fail))
(william james)
> (multiple-value-list (fail))
(william higgins)
> (multiple-value-list (fail))
(@)
>
letex を使うのが、お約束です。また、*cont* の初期値の values は、以前は、list で代用していましたが、今回は多値対応を使っています。ですから、multiple-value-list で受けないとリストになりません。
ここまでは、順調でした。
つまずいたのは、次のスクリプトdescent 。気分も急降下です（笑）。（kids は最初の方に、t は newlisp-utility.lsp に、kids は 本章（その１）に定義してありますに記述してあります。）
(=defun descent (n1 n2)
(cond ((= n1 n2) (=values n2))
((kids n1) (letex (_n1 n1)
(choose-bind n (kids '_n1)
;(println '_n1 " " n)
(=bind (p) (descent n n2)
(=values (cons '_n1 p))))))
(t ;(println "fail")
(fail))))
これを実行すると、
> (descent 'a 'g) (a b b a c c f g) >
あれれ、余計なものが！
コメント・アウトしてある println文を動作させてみると、その様子がわかります。
> (descent 'a 'g) a b b d fail b e fail a c c d fail c f f g (a b b a c c f g) >
バック・トラックは、うまくいっているのです。ただ、たどった道のりを全て返しているだけで（悲）。
これは、ダイナミック･スコープによる変数補足を letex を使って回避した副作用なのです。
そして、その解決方法は、、、次回に。
以上、如何でしょうか？
newLISP で On Lisp する．．．第２２章（その１）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
番外編から始まった 第２２章 非決定性 の本体の始まりです（笑）。
最初の 概念 は飛ばして、探索 から。
まずは手慣らしに、決定的なツリーによる探索 の Schemeスクリプトを newLISP で記述すると、
(define (descent n1 n2)
(if (= n1 n2)
(list n2)
(let (p (try-paths (kids n1) n2))
(if p (cons n1 p) nil))))
(define (try-paths ns n2)
(if (null? ns)
nil
(or (descent (first ns) n2)
(try-paths (rest ns) n2))))
(define (kids n)
(case n
(a '(b c))
(b '(d e))
(c '(d f))
(f '(g))))
こんな感じです。ついでに、後で使う関数kids も定義しておきます。
当然動きます。
> (descent 'a 'g) (a c f g) >
もちろん本題は、非決定的なツリーによる検索 です。
newLISP には、Scheme のように call-with-current-continuation が無いので、次の Scheme での実装 を飛ばして、Common Lisp での実装 に入ります。
そして、Common Lisp による非決定的オペレータ を newLISP で実装します。
（defun は newlisp-utility.lsp に定義してあります）
(define *paths* '())
(define failsym '@)
(define-macro (choose)
; (choose &rest choices)
(letex (_choice (args 0)
_choices (args))
(if '_choices
(begin (map (fn (c) (letex (_c c) (push (fn () _c) *paths*)))
(reverse (rest '_choices)))
_choice)
(fail))))
(define-macro (choose-bind)
; (choose-bind var choices &body body)
(letex (_var (args 0)
_choices (args 1)
_body (cons 'begin (2 (args))))
(cb (fn (_var) _body) _choices)))
(defun cb (f choices)
(if choices
(progn
(if (cdr choices)
(letex (_f f _ch choices)
(push (fn () (cb _f (cdr '_ch)))
*paths*)))
(f (car choices)))
(fail)))
(defun fail ()
(if *paths*
((pop *paths*))
failsym))
さて、動作例を、まずは、choose から、
> (defun do2 (x) (choose (+ x 2) (* x 2) (pow x 2))) (lambda (x) (choose (+ x 2) (* x 2) (pow x 2))) > (do2 3) 5 > (fail) ERR: value expected in function * : x called from user defined function fail > (define *paths* '()) () > (defun do2 (x) (letex (_x x) (choose (+ _x 2) (* _x 2) (pow _x 2)))) (lambda (x) (letex (_x x) (choose (+ _x 2) (* _x 2) (pow _x 2)))) > (do2 3) 5 > (fail) 6 > (fail) 9 > (fail) @ >
番外編でも書きましたが、newLISP のダイナミック･スコープで、継続を行う時は、newLISP組込letex を使って変数をクロージャに組み込んでおく必要があります。
そうしないと、最初の関数do2 のように、fail を実行した時、エラーとなります。
そして、choose-bind の例。
> (choose-bind x '(marrakesh strasbourg vegas) (format "Let's go to %s." (string x))) "Let's go to marrakesh." > (fail) "Let's go to strasbourg." > (fail) "Let's go to vegas." > (fail) @ >
choose のマクロ展開例のスクリプトには、やはり、letex を使います。
(let (x 2)
(letex (_x x)
(choose
(+ _x 1)
(+ _x 100))))
例によって、展開式すると、
(if '((+ 2 1) (+ 2 100))
(begin
(map (lambda (c)
(letex (_c c) (push (lambda () _c) *paths*)))
(reverse (rest '((+ 2 1) (+ 2 100)))))
(+ 2 1))
(fail))
変数ｘ をすべて展開して組み込みますから、“On Lisp” 本書例より複雑になります（汗）。
動作は、
> [cmd]
(let (x 2)
(letex (_x x)
(choose
(+ _x 1)
(+ _x 100))))
[/cmd]
3
> (fail)
102
> (fail)
@
>
同じですが。
長くなってきたので、継続渡しマクロ と共に使った例は、次回に。
以上、如何でしょうか？
newLISP で On Lisp する．．．第２２章（番外編）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
第２２章 非決定性 の始まり、と言いたいところですが、いきなり番外編です（笑）。
第２２章を開始する前に、継続 の問題点を明確にしておきたいからです。
一番わかりやすい例が、第２０章 最後の Code-Walker と CPS変換 の続渡し版リスト逆転スクリプトでしょう （defun 、car、cdr、null は newlisp-utility.lsp に定義してあります）。
(defun identity (x) x)
(defun rev2 (x)
(revc x identity))
(defun revc (x k)
(if (null x)
(k '())
(revc (cdr x)
(letex (_k k
_x x)
(lambda (w)
(_k (append w (list (car '_x)))))))))
何気なく、newLISP組込letex を使っていますが、これを使わないと動きません。
単純に “On Lisp” 本書のスクリプトを newLISP用に変換しただけなら、
(defun revc (x k)
(if (null x)
(k '())
(revc (cdr x)
(lambda (w)
(k (append w (list (car x))))))))
で、すむばずですが、これでは、所望の動作をしません。
何故か？それは次のコードを動かしてみれば判ります。
(defun revc (x k)
(if (null x)
(k '())
(revc (cdr x)
(letex (_k k
_x x)
(lambda (w)
(println "x=" x " _x=" '_x)
(_k (append w (list (car '_x)))))))))
x と _x を出力するようにしたものです。動作させると、
> (rev2 '(a b c)) x=nil _x=(c) x=nil _x=(b c) x=nil _x=(a b c) (c b a) >
見ての通り、ｘ には nil です。 newLISP では、関数recv の引数ｘ と、 lambda 内の ｘ は別物として扱われます。
“On Lisp” のスクリプトは、CommonLisp のレキシカル・スコープにより同じになることを前提に書いてあります。
一方、ダイナミック･スコープの newLISP では、別物として扱われています。このため、letex を使って、ローカルな x の値を lambda式内に埋め込む必要があったのです。
これが、newLISP での継続渡しの制約であり、“On Lisp”本書の継続渡しマクロを使う際、最大の問題となります。
さて、第２２章 非決定性 の本題は次回から（汗）。
以上、如何でしょうか？
newLISP のハッシュ関数
題名に“ハッシュ関数”と書いて置きながら、newLISPにはハッシュがありません。その代わりに、“On newLISP”でも、たびたび使っている context を使かった簡単で高速な検索方法があります。
マニュアルでその項を見てみると
（newLISP Users Manual and Reference の16章 The context default functor の Hash functions and dictionaries 項）
名前空間 context にシンボルを置くために使える機能はいくつかあります。
シンプルなハッシュ・ライクの変数コレクション→値ペア用の辞書として使う時は、初期値を与えていない default functor を使って下さい。
There are several functions that can be used to place symbols into namespace contexts. When using dictionaries as simple hash-like collections of variable → value pairs, use the uninitialized default functor:
使い方は簡単で、同じくマニュアルから
(define Myhash:Myhash) ; create namespace and default functor ; or as an alternative use (new Tree 'Myhash) ; create from built-in template
どちらの方法も、MyHash の辞書空間と default functor を作るのに使えます。
キー・値ペアの生成と値の呼び出しは簡単です：
Either method can be used to make the Myhash dictionary space and default functor. Creating key-value pairs and retrieving a value is easy:(Myhash "var" 123) ; create and set variable/value pair (Myhash "var") ; → 123 ; retrieve value
といった具合です。
とても便利な方法ですが、たった一つだけ制約があります。
これも、マニュアルから、
default functor には、nil 以外のいかなる値も入れてはいけないことに注意して下さい。default functor は、文字列からシンボルを生成し、値が指定されていれば、それを設定する辞書ハッシュ関数のように動作します。
Note that the default functor should not be initialized to any value other than nil. The default functor works like a dictionary hash function creating the symbols in the string following it and setting it to the value if specified.
どう言うことか、マニュアルの例で試して見ましょう。
> (define Myhash:Myhash) nil > (Myhash "var" 123) 123 > (Myhash "var") 123 > (symbols Myhash) (Myhash:Myhash Myhash:_var) >
上記例のように、Myhash の default functor は nil で、ハッシュ・ライクに使えています。そして、キーの”var” に対して、_var という変数が Myhash の名前空間に作られています。
この状態で、Myhash の default functor に、nil 以外を設定すると
> Myhash:Myhash nil > (Myhash "var") 123 > (setq Myhash:Myhash '()) () > (Myhash "var") ERR: list index out of bounds : "var" > (symbols Myhash) (Myhash:Myhash Myhash:_var) >
Myhash の名前空間に変数_var が残っていますが、ハッシュ・ライクにアクセスできません。
再び、Myhash の default functor に、nil を設定すると、
> Myhash:Myhash () > (setq Myhash:Myhash nil) nil > (Myhash "var") 123 >
この通り、ハッシュ・ライクに使えます。
拙作の context版構造体マクロが、ハッシュ・ライク方法を使わずに context を使っているのは、このためです。default functor に構造体の定義を入れていますから。 構造体の定義を、別な context 、例えば、*structure*:*structure* に入れて置くとかすれば、ハッシュ・ライク手法を使えたのですが、、、
さて、このハッシュ・ライク手法では、キー・値ペアの連想リストを簡単に取り出せ、また、逆に連想リストからキー・値ペアを登録することもできる、とマニュアルにあります。
> (Myhash)
(("var" 123))
> (Myhash '(("#1234" "hello world") ("John Doe" 123) ("var" (a b c d))))
Myhash
> (Myhash)
(("#1234" "hello world") ("John Doe" 123) ("var" (a b c d)))
>
やはり、マニュアルは読んでおくべきですね。
> (dolist (x (Myhash)) (println x))
("#1234" "hello world")
("John Doe" 123)
("var" (a b c d))
("var" (a b c d))
> (dotree (x Myhash) (println x))
Myhash:Myhash
Myhash:_#1234
Myhash:_John Doe
Myhash:_var
Myhash:_var
> (dotree (x Myhash true) (println x))
Myhash:_#1234
Myhash:_John Doe
Myhash:_var
Myhash:_var
>
組込dotree のオプション・フラグを使って、取り出すことしか知らなかった私、、、（汗）
以上、如何でしょうか？
newLISP で On Lisp する．．．第２１章（その２の続き）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
今回は、第２１章 マルチプロセス の動作例、黒板を使った同期 からです。
(define *bboard* '())
(defun claim () (push (args) *bboard*))
(defun unclaim () (replace (args) *bboard*))
(defun check () (find (args) *bboard*))
(=defun visitor (door)
(print (format "Approach %s. " (string (term door))))
(claim 'knock door)
(wait d (check 'open door)
(print (format "Enter %s. " (string (term door))))
(unclaim 'knock door)
(claim 'inside door)))
(=defun host (door)
(wait k (check 'knock door)
(print (format "Open %s. " (string (term door))))
(claim 'open door)
(wait g (check 'inside door)
(print (format "Close %s.\n" (string (term door))))
(unclaim 'open door))))
(program ballet ()
(forkx (visitor 'door1) 1)
(forkx (host 'door1) 1)
(forkx (visitor 'door2) 1)
(forkx (host 'door2) 1))
newLISP組込format を使うとこんな感じのコードになります。
ballet を実行すると、
> (ballet) Approach door2. Open door2. Enter door2. Close door2. Approach door1. Open door1. Enter door1. Close door1. >>*bboard* ((MAIN:inside MAIN:door1) (MAIN:inside MAIN:door2)) >>(halt) nil >
といった感じ。所望の動作をしているようです。
次に関数setpri を使った、優先順位の変更の効果。
(=defun capture (city)
(take city)
(setpri 1)
(yield
(fortify city)))
(=defun plunder (city)
(loot city)
(ransom city))
(defun take (c) (print "Liberating " c ".\n"))
(defun fortify (c) (print "Rebuilding " c ".\n"))
(defun loot (c) (print "Nationalizing " c ".\n"))
(defun ransom (c) (print "Refinancing " c ".\n"))
(program barbarians ()
(forkx (capture 'rome) 100)
(forkx (plunder 'rome) 98))
これを、動作させると、
> (barbarians) Liberating rome. Nationalizing rome. Refinancing rome. Rebuilding rome. >>(halt) nil >
となります。
最後に、関数kill でプロセスを終了させて見ましょう。
すでに、program で ped プロセスを生成してある状態で、
> (setq *open-doors* '()) () > (ped) >>*procs* (gensym12) >>(kill gensym12) >>*procs* () >>(halt) nil >
といった感じです。
これで、windows版newLISP でもマルチ・プロセスが使える？（笑）
さて、第２１章 マルチプロセス のまとめです。
- newLISP でも、“On Lisp” 本書で定義されたようなマルチプロセスを記述できます。
本来マルチプロセス対応の newLISP が、windows版でも動作するようになってほしいものです（笑）。
以上、如何でしょうか？
newLISP で On Lisp する．．．第２１章（その２）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
今回は、第２１章 マルチプロセス の動作例ですが、その前に前回紹介したコードの修正です。
(define *default-proc*
(make-proc (state (fn (x)
(print "\n>>")
(print (eval-string (read-line) 'MAIN))
(pick-process)))))
eval-string文 に、context シンボルのオプションを追加しています。何故かは、後ほど。
手始めに、マクロforkx から 。前回紹介したコードを動かすには、2010/ 8/24版以降の onnewlisp.lsp と newlisp-utility.lsp が必要です（i+ は newlisp-utility.lsp に、=defun は onnewlisp.lsp に定義してあります）。
> [cmd] (=defun foo (x) (print "Foo was called with " x ".\n") (=values (i+ x))) [/cmd] (lambda (*cont* _x) (letex ((x _x)) (begin (print "Foo was called with " x ".\n") (=values (i+ x))))) > (forkx (foo 2) 25) (foo 2) > *procs* (gensym12) > (proc-state gensym12) (lambda (gensym11) (foo 2) (pick-process)) > (proc-pri gensym12) 25 >
*procs* に登録されたプロセスが gensym変数なのは、context版構造体の仕様です。 stateフィールドのラムダ式の最後に (pick-process) がありますから、継続してプロセスが実行されます。デフォルトのプロセス *default-proc* でも、最後に、pick-process を呼び出していますしね。
次にマクロprogram を
> [cmd]
(program two-foos (a b)
(forkx (foo a) 25)
(forkx (foo b) 25))
[/cmd]
(lambda (*cont* _a _b)
(letex ((a _a) (b _b))
(begin
(setq *procs* nil)
(begin
(forkx (foo a) 25)
(forkx (foo b) 25))
(catch
(while true
(pick-process)) '*halt*) *halt*)))
> (two-foos 1 2)
Foo was called with 2.
Foo was called with 1.
>>(halt)
nil
>
優先順位が同じですから、後から追加されたプロセスから実行されます。
しかし、優先順位を変えて実行すると、
> [cmd]
(program two-foos (a b)
(forkx (foo a) 25)
(forkx (foo b) 12))
[/cmd]
(lambda (*cont* _a _b)
(letex ((a _a) (b _b))
(begin
(setq *procs* nil)
(begin
(forkx (foo a) 25)
(forkx (foo b) 12))
(catch
(while true
(pick-process)) '*halt*) *halt*)))
> (two-foos 1 2)
Foo was called with 1.
Foo was called with 2.
>>(halt)
nil
>
優先度の高いプロセスから実行されます。
ここで、先頭に >> がある行は、pick-process 中でデフォルトのプロセス *default-proc* が動作している状態です。そして、それは、multiple-value-bind 中で動作しています。ところで、multiple-value-bind は、multiple-value-bind の context で定義しています。つまり、デフォルトのプロセス *default-proc* の eval-string 文が multiple-value-bind の context で引数を評価してしまうのです。そのため、冒頭のスクリプト、eval-string が引数の文字列を評価する時に使う context を指定することにした訳です。普通の関数処理なら、問題ないのですが、、、
さて、言い訳はこれくらいにして、次は、マクロwait の動作、 wait 式を１つ持つプロセス です。
> (define *open-doors* '())
()
> [cmd]
(=defun pedestrian ()
(wait d (car *open-doors*)
(print "\nEntering " (term d) ".\n")))
[/cmd]
(lambda (*cont*)
(letex ()
(begin
(wait d (car *open-doors*) (print "\nEntering " (term d) ".\n")))))
> (program ped () (forkx (pedestrian) 1))
(lambda (*cont*)
(letex ()
(begin
(setq *procs* nil)
(begin
(forkx (pedestrian) 1))
(catch
(while true
(pick-process)) '*halt*) *halt*)))
> (ped)
>>(push 'door *open-doors*)
(MAIN:door)
Entering MAIN:door.
>>(halt)
nil
>
*open-doors* に要素が入るまで、本体のコードの実行が抑制されます。(MAIN:door) は、push の戻り値ですが、MAIN の context が付いてきているのは、前述の理由です。pedestrian で、format の代わりに使っている newLISP組込print で term を使い、出力から context 部分を取り除いています。
予定外に長くなってきたので（汗）、黒板を使った同期 からは、次回に。
以上、如何でしょうか？
newLISP で On Lisp する．．．第２１章（その１）
Filed under: On newLISP | タグ: arbitrator, fork, halt, kill, program, setpri, wait, yield
コメントを残す （この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
第２１章 マルチプロセス に入ります。
実は、newLISP は、マルチプロセス対応なのですが、Linux/Unix バージョンのみの機能です。残念ながら、私が使っている windows バージョンでは、使えません（泣）。それだけに、実装し甲斐がある？（笑）
最初の プロセスの抽象化 にある、マルチプロセス対応の基本要素は、そのまま適用されます。それらは、実装で見てもらった方が早いでしょう。
実装 では、まず、プロセスの構造体とその生成 を定義します。とはいっても、newLISP には、構造体がありません。以前定義した構造体マクロを使います。第２０章で定義した継続渡しマクロと共に onnewlisp.lsp に追加しました。
(defstruct proc pri state wait)
(define *procs* '())
(define *proc* '())
(define *halt* (gensym))
(define *default-proc*
(make-proc (state (fn (x)
(print "\n>>")
(print (eval-string (read-line) 'MAIN))
(pick-process)))))
(define-macro (forkx)
; (forkx expr pri)
(letex (_expr (args 0)
_pri (args 1)
_gvar (gensym))
(push (make-proc
(state (fn (_gvar)
_expr
(pick-process)))
(pri _pri))
*procs*)
'_expr))
(define-macro (program)
; (program name args &body body)
(letex (_name (args 0)
_args (args 1)
_body (cons 'begin (2 (args))))
(=defun _name _args
(setq *procs* nil)
_body
(catch (while true (pick-process)) '*halt*) *halt*)))
早速、継続渡しマクロが使われます。“On Lisp” 本書と、ほぼ同様な実装です。letex が多用されているとか、nil が 空リストになるとか、defvar は define になるとかありますけど（笑）。
構造体の表記は、、“newLISP で構造体を使う” を参照して下さい。コロン（：）を使わず、括弧で括るだけですけど（笑）。
また、マクロ名fork は forkx と改名してあります。 windowsバージョンでは使えませんが、newLISP組込だからです。
そして、プロセスのスケジューリング の実装は、こうなります。（defun、remove、multiple-value-bind、values、 reference-inversion:setf は newlisp-utility.lsp に定義してあります）
(define setfr reference-inversion:setf)
(defun pick-process ()
;(println "pick process")
(multiple-value-bind (p val) (most-urgent-process)
(setq *proc* p
*procs* (remove p *procs*))
((proc-state p) val)))
(defun most-urgent-process ()
(let ((proc1 *default-proc*) (max1 -1) (val1 t))
(dolist (p *procs*)
(let ((pri (proc-pri p)))
(if (> pri max1)
(let ((val (or (not (proc-wait p))
((proc-wait p)))))
(when val
(setq proc1 p
max1 pri
val1 val))))))
(values proc1 val1)))
(defun arbitrator (test cont)
(setfr (proc-state *proc*) cont
(proc-wait *proc*) test)
(push *proc* *procs*)
(pick-process))
(define-macro (wait)
; (wait parm test &body body)
(letex (_parm (args 0)
_test (args 1)
_body (cons 'begin (2 (args))))
(arbitrator (fn () _test)
(fn (_parm) _body))))
(define-macro (yield)
; (yield &body body)
(letex (_body (cons 'begin (args))
_gsym (gensym))
(arbitrator nil (fn (_gsym) _body))))
(defun setpri (n) (setfr (proc-pri *proc*) n))
(defun halt (val) (throw val)) ; 2008/02/19 corrected
(defun kill (obj)
(if obj
(setq *procs* (remove obj *procs*)))
(pick-process))
setf の代わりに、reference-inversion:setf を setfr として使っています。構造体定義に context バージョンを使ったのは、これが使えるから。おかげで、こちらも、本書とほぼ同様な定義で済みました。
さて、気になる動作は、どうなるでしょうか？
実装だけで長くなってしまったので、動作例は次回に（笑）。
以上、如何でしょうか？
newLISP のnil と 空リスト()
“newLISP で On Lisp する．．．第２０章（その１）．．．または、newLISP と scheme の違い” でも書いていますが、newLISP では nil と 空リスト () は別のものです。
実際、マニュアルには、
newLISP では、nil と空リスト () は、他の Lisp のように同じではありません。条件式、and, or, if, while, unless, until, cond、においてのみ、それらはブールの偽として扱われます。
In newLISP, nil and the empty list () are not the same as in some other Lisps. Only in conditional expressions are they treated as a Boolean false, as in and, or, if, while, unless, until, and cond.
とあります。
つまり、空リストは、フロー制御式の条件式においては nil ですが、それ以外の組込関数では、true 相当です。
ここで、フロー制御式には、do-while と do-until も含まれます。
それ以外では、true 相当ですから、例えば、組込filter や clean で、
> (map rest '((a b) (a) ())) ((b) () ()) > (filter rest '((a b) (a) ())) ((a b) (a) ()) > (clean rest '((a b) (a) ())) () >
となります。これは、以前、私が使い方を間違えた例です(汗)。
組込filter は、第一引数の関数を第二引数のリストの項目に適用して、true に評価されるものを取り除きます。組込clean は、逆に残します。これらの関数では、空リストは true 相当ですから、上記のような結果になったわけです。
ここでは、次のようにして、空リストを nil にすべきだったのです。
> (map rest '((a b) (a) ())) ((b) () ()) > (filter (fn (x) (or (rest x) nil)) '((a b) (a) ())) ((a b)) > (clean (fn (x) (or (rest x) nil)) '((a b) (a) ())) ((a) ()) >
ここで、使っているラムダ式は、newlisp-utility.lsp で定義している cdr と同じです。
> cdr (lambda (lst) (or (rest lst) nil)) >
引数が空リストなら、マニュアルにあるように組込or では、空リストは、nil 相当ですから、次の項目に進み、nil が返ります。
ちなみに、newlisp-utility.lsp で定義している car は、
> car (lambda (lst) (if (empty? lst) nil (first lst))) > (car '()) nil >
としています。空リストに組込first を適用するとエラーですから。
“newLISP で On Lisp する”で、car と first、cdr と rest の両方を使い分けているのは、こういう理由だったりします（笑）。
以上、如何でしょうか？
newLISP で On Lisp する．．．第２０章（その４）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
第２０章 継続 も４回目。今回で終わります。
では、新しい 継続渡しマクロを使ったツリーの探索 の実装です。
（=bind、=defun、=value は onnewlisp.lsp に定義してあります）
(setq *saved* '())
(=defun dft-node (tree)
(cond ((null tree) (restart))
((atom tree) (=values tree))
(true (push (list *cont* (fn () (dft-node (cdr tree))))
*saved*)
(dft-node (first tree)))))
(=defun restart ()
(if *saved*
(let (cc (pop *saved*))
(let (*cont* (cc 0)) ((cc 1))))
(=values 'done)))
(=defun dft2 (tree)
(setq *saved* nil)
(=bind (node) (dft-node tree)
(cond ((= node 'done) (=values nil))
(true (print node)
(restart)))))
前回と違うのは、dft-node と restart のみです。dft-node で、複数の探索の例 で継続渡しを可能にするために、変数 *cont* も push し、restart で取り出しています。
単独の探索の結果は前回と同じとなります。
> (setq t1 '(a (b (d h)) (c e (f i) g)) t2 '(1 (2 (3 6 7) 4 5))) (1 (2 (3 6 7) 4 5)) > (dft2 t1) abdhcefignil > (dft2 t2) 1236745nil >
そして、複数の探索の例。*cont* で継続渡しているのはラムダ式だけなので、変数の引渡しも必要です。
> (setq t1 '(a (b (d h)) (c e (f i) g)) t2 '(1 (2 (3 6 7) 4 5)))
(1 (2 (3 6 7) 4 5))
> [cmd]
(=bind (tmp) (dft-node t1)
(if (= tmp 'done)
'done
(begin
(setq node1 tmp)
(=bind (node2) (dft-node t2)
(list node1 node2)))))
[/cmd]
(a 1)
> (restart)
(a 2)
> (time (restart) 60)
6
> (restart)
(g 5)
> (restart)
done
>
となります。変数の引き渡しとして、変数 node1 をグローバル変数にしています。継続仕様から見れば、反則技かもしれません。しかし、ダイナミック・スコープの newLISP で、継続渡しをする際の制限です。私の実力かもしれませんが（汗）。
Code-Walker と CPS変換 では、継続渡し版リスト逆転スクリプトを実装してみます。（defun と null は、newlisp-utility.lspp に定義してあります）
(defun identity (x) x)
(defun rev2 (x)
(revc x identity))
(defun revc (x k)
(if (null x)
(k '())
(letex (_k k
_1st (first x))
(revc (rest x)
(fn (w) (_k (append w (list '_1st))))))))
ここでは、letex での変数置換だけで済みます。
動作は、
> (rev2 '(a b c)) (c b a) >
この通り、継続表現は可能です。
さて、第２０章 継続 のまとめです。
- newLISPでも、継続渡しを実装できます。しかし、Common Lispでの実装よりも制限が多くなります。
以上、如何でしょうか？
新リスプな日々 