newLISP で On Lisp する．．．第２２章（その４）

（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）

　今回で、第２２章 非決定性 は、終わりです。
　真の非決定性 の 最初は、決定的な検索 のスクリプト。

(define (path node1 node2)
  (bf-path node2 (list (list node1))))

(define (bf-path dest queue)
  (if (null? queue)
      '@
      (letn ((path (first queue))
             (node (first path)))
        (if (= node dest)
            (reverse path)
            (bf-path dest
                     (append (rest queue)
                             (map (lambda (n)
                                    (cons n path))
                                  (neighbors node))))))))

(define (neighbors node)
   (map (curry nth 1) (find-all (list node '?) '((a b) (b c) (c a) (a d) (d e)))))

　関数neighbors は、“On Lisp”本書では、定義されていないのですが、ループのある有向グラフ から類推で作りました。
　引数のnode から行ける先をリストで返します。本章（その１）で定義している関数kids を使って、（defun は、newlisp-utility.lsp に定義してあります）

(defun kids (n)
    (case n
      (a '(b d))
      (b '(c))
      (c '(a))
      (d '(e))))

　としても、同じです。どちらを使うかは、お好みで。ただし、kids を使う場合は、neighbors に関数名を変更することをお忘れなく（笑）。
　動作させると、

> (path 'a 'e)
(a d e)
> (path 'a 'c)
(a b c)
> 

　“On Lisp”本書に動作例がないので比較できませんが、こんなところでしょう。
　さて、上記関数kids で、これまでの 非決定的な検索 を行うと、間違いなく a → b → c → a でループします。
　そのために、Scheme による真の choose が必要となります。
　しかし、残念ながら、“On Lisp”本書には、Common Lisp の実装例は載っていません。
　なので、割愛？ いえいえ、そんなことは、ありません（笑）。
　本章（その１）で定義した非決定的オペレータ・マクロ choose-bind で、変更が必要なのは、中で使っている補助関数cb のみです。
　（mklist は、newlisp-utility.lsp に定義してあります）

(define *paths* '())
(define failsym '@)

(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)
  (let (chlist (mklist choices))
    (dolist (ch chlist)
      (letex (_f f _ch ch)
        (push (fn () (_f '_ch)) *paths* -1))))
    (fail))

　これを使って、先ほどの関数kids と本章（その２）で定義した、（=defun と =values は onnewlisp.lsp に定義してあります）

(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 'a 'c)
(a b c)
> (fail)
@
> (descent 'a 'e)
(a d e)
> 

　無限ループに陥らず、解が出ます。
　ただし、場合によっては、(fail) で、終了シンボル@ にたどり着きません。
　例えば、上記の例に続けて、(fail) を実行すると、

> *paths*
((lambda () ((lambda (n) 
    (begin 
     (letex (_n n) (descent-tr '_n 'e (push 'c '(a b) -1))))) 'a)))
> (fail)
(a b c a d e)
> (fail)
(a b c a b c a d e)
> 

　解としては間違っていないけど、(a d c) の繰り返しが、追加されていくだけ(笑)。
　こういう時、クロージャが全て見える newLISP は、重宝します。何が起こっているのか、一目瞭然です。
　試してはいませんが、“On Lisp”本書にある Scheme による真のchoose でも、同じようになると思うのですが、如何でしょうか？
　“On Lisp” 本書にもあるように、“元の実装で大抵は、十分だ。” ということで、真の非決定性 は、このあたりで終わります。

　さて、番外編から始まった 第２２章 非決定性、ようやく、まとめです。

• newLISPでも、継続渡しを使った非決定性を実装できます。
  しかし、継続 の時と同様に、Common Lispでの実装よりも制限が多くなります。

　以上、如何でしょうか？

newLISP で On Lisp する．．．第２２章（その３）

（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）

　さて今回は、第２２章 非決定性 の カット。
　“On Lisp” 本書では、Scheme のスクリプトのみで解説が進みます。
　Scheme 似の newLISP にとっては、実装しやすい？
　とは、いっても、継続渡しマクロを暗に使っているので、onnewlisp.lsp は、必須です（同時に、newlisp-utility.lsp も必要です）。
　当たりキャンディー検索の網羅的な例 のスクリプトは、こうなります（choose-bind は、本章（その１）に定義してあります）。

(define (find-boxes)
  (setq *paths* '())
  (choose-bind city '(la ny bos)
    (println)
    (choose-bind store '(1 2)
      (choose-bind box '(1 2)
        (let ((triple (list city store box)))
          (print triple)
          (if (coin? triple)
              (print 'c))
          (fail))))))

(define (coin? x)
  (member x '((la 1 2) (ny 1 1) (bos 2 2))))

　動作させると、

> (find-boxes)

(la 1 1)(la 1 2)c(la 2 1)(la 2 2)
(ny 1 1)c(ny 1 2)(ny 2 1)(ny 2 2)
(bos 1 1)(bos 1 2)(bos 2 1)(bos 2 2)c@
> 

　ここで、letex を使わなくても動作するのは、choose-bind の引数が即値だから。
　そして、検索ツリーのマークと枝刈り のスクリプトは、

(define (mark) (setq *paths* (cons fail *paths*)))

(define (cut)
  (cond ((null? *paths*))
        ((= (first *paths*) fail)
         (setq *paths* (rest *paths*)))
        (true
          (setq *paths* (rest *paths*))
          (cut))))

　となり、これを前述の関数find-boxes に組み込むと、次のようになります。

(define (find-boxes)
  (setq *paths* '())
  (choose-bind city '(la ny bos)
    (mark)
    (println)
    (choose-bind store '(1 2)
      (choose-bind box '(1 2)
      (let ((triple (list city store box)))
        (print triple)
        (when (coin? triple)
           (cut)
           (print 'c))
        (fail))))))

　動作は、

> (find-boxes)

(la 1 1)(la 1 2)c
(ny 1 1)c
(bos 1 1)(bos 1 2)(bos 2 1)(bos 2 2)c@
> 

　すんなり動きます。毎回このように進めば、いいのですが（笑）。
　きりがいいので、真の決定性 からは、次回に。

　以上、如何でしょうか？

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 で 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 する．．．第２１章（その１）

（この 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 で 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での実装よりも制限が多くなります。

　以上、如何でしょうか？