SICP 4.4.4 Implementing the Query System

4.4章のサンプルを動かしたり、問題を解く為に既に写経してあるけど、中身を読んだ訳ではないので。

ノート

4.4.4.1 The Driver Loop and Instantiation

ドライバーループは入力がassert!で始まれば事実かルールを保存、そうでなければクエリとして扱う。qevalがクエリの評価を行う。
クエリの引数として空のストリームを渡し、評価の結果としてパターン変数が拘束された値が入ったストリームが返って来る。

instantiateはパターンリストの変数部分をそれが拘束された値に置き換える。値が見つからなかった時には引数のunbound-var-handlerを呼び出す様になっている。*1

4.4.4.2 The Evaluator

予め登録された演算子で始まるクエリの場合、テーブルに登録された手続きを呼び出す。andとかorとか。
それ以外はシンプルクエリとして扱う。

Simple queries

stream-flatmapを使って引数のストリームの一つ一つの要素（frame）に対して、パターンにマッチする事実を探す。
find-assertionsがマッチする事実を探索し、apply-rulesが適用出来るルールを探索する。stream-append-delayedが双方の結果を結合する。

Compound queries

andとorを扱う。
conjunctsがandで結ばれた複数のパターン。最初のパターンを評価して、結果返って来たストリームを引数と残りのパターンを引数に再帰呼び出しする。
disjunctsがorで結ばれた複数のパターン。最初のパターンを評価して返って来たストリームと、残りのパターンを再帰呼び出しした結果をinterleave-delayedでマージする。

Filters

入力の一つ一つのフレームに対してqevalの結果が空だった（マッチしなかった）場合に、そのフレームを出力する。
lisp-valueは逆で述語がtrueを返したらそのフレームを出力する。evalに渡す引数はinstantiateで用意する。
always-trueは本体がない結論部のみのルールを評価する時に使用する。

4.4.4.3 Finding Assertions by Pattern Matching

fetch-assersionsはデータベースにある事実を要領良く取り出す。これがなくても動作するが、その場合毎回全ての事実を舐めるので効率が悪い。
pattern-matchが実際のパターンマッチを行う。バラバラの要素になるまで再帰呼び出し。
extend-if-consistentが変数の拘束を行う。

Patterns with dotted tails

評価器で特に何をする訳でもなく、ベースのSchemeの評価器がよしなに解釈してくれる。

4.4.4.4 Rules and Unification

同じ名前のパターン変数同士が混在しない様に評価の前にユニークな名前に変更する。
unify-matchはpattern-matchと基本的に同じだが、変数を拘束する部分が両方のパターンに対して行う部分が異なる。
変数を拘束するextend-if-possibleも基本的にはextend-if-consistentと同じだが、val側も変数だった時にその先まで追わなければならない事と、変数に対してマッチさせようとしているパターンにその変数そのものが含まれていないかをチェックする部分が追加されている。

4.4.4.5 Maintaining the Data Base

関係のないアサートを探索しない様に、アサートの最初のシンボル毎にテーブルを作る。
ルールの場合は結論となるパターンの先頭要素毎のテーブルを作る。
indexable?はやはりExercise 4.69とは合わない気がする。

Exercise 4.70

1. cons-streamはシンタックスなのでその引数が評価されてからcons-streamに渡される訳ではなく、ここにcons-streamの定義が展開される。
2. cons-streamの第２引数は遅延評価されるので値が必要になった時に評価される。

この状況では、この第２引数は値が必要になった時点での値が使われるため、THE-ASSERTIONSを渡してしまうとcons-streamが評価された時の値ではなくその後set!で書き換えられ、更に他の呼び出しによって書き換えられた値を使われてしまうためストリームを正しく辿れなくなってしまう。正確にはTHE-ASSERTIONSはストリームの先頭を指しているので、ストリームを辿ろうとすると毎回ストリームの先頭に戻ってしまう事になる。
ここではcons-streamを呼び出す時点でのTHE-ASSERTIONSの値が必要なのでletで別の新しい変数を作り、そこにスナップショットを取ってcons-streamに渡す必要がある。こうするとcons-streamの第２引数は過去にストリームの先頭だった要素を指す事になるので正しくストリームを辿る事が出来る。

4.4.4.6 Stream Operations

stream-append-delayedは二つのストリームを結合するが、第２引数はdelayされたものを受ける様になっていて、最初の要素以外は遅延評価する形で結合する。simple-queryでアサートを探索した結果とルールを提供した結果を結合するのに使われている。
interleave-delayedも同様に第２引数がdelayされたものを受ける様になっていて、内容も同じく最初の要素以外は遅延評価される形でマージする。orを評価するdisjoinとflatten-streamで使われている。
stream-flatmapは普通のflatmapと機能は同じだが扱うのがストリームなので結果を構築するのにflatten-streamを使う。

4.4.4.7 Query Syntax Procedures

typeとcontentsは評価器の入力（assert!かクエリ）の最初の要素、および残りの部分。
query-syntax-processはパターン変数をリストの形式に変換する。シンボルを文字列に変換するsymbol->stringはひょっとするとこの教科書で初めて出て来たかも。変数はシンボル?を先頭要素に持つtagged-listになる。
make-new-variableはルールを適用する時に変数名が重複しない様にrule-counterを使って変数名に番号を挿入する。
結果を表示する時に値に拘束されていない変数を表示する為に、contract-question-markは変数名と通し番号をハイフンで繋いだシンボルに変換する。

4.4.4.8 Frames and Bindings

ここは単純。バインドは変数と値のペア。それぞれのアクセッサとframeはリストなので新しいバインドはそこにconsするのみ。

Exercise 4.71

ここではストリームの要素を遅延評価する事で、先頭の要素から順番に評価と結果の印字を繰り返す。ストリームの要素を遅延評価にしないと全ての評価が終わるまで結果を印字する事は出来ない。
とすると顕著に違いが出るのは無限ループに陥った時。

;;; Query input:
(assert! (married Minnie Mickey))

Assertion added to data base.
;;; Query input:
(assert! (rule (married ?x ?y)
               (married ?y ?x)))

Assertion added to data base.
;;; Query input:
(married Mickey ?who)

;;; Query results:
(married Mickey Minnie)
(married Mickey Minnie)
(married Mickey Minnie)
…
(married Mickey Minnie)
(. . user break
> 

3.5.3からinterleaveを持って来て実行すると：

;;; Query input:
(assert! (married Minnie Mickey))

Assertion added to data base.
;;; Query input:
(assert! (rule (married ?x ?y)
               (married ?y ?x)))

Assertion added to data base.
;;; Query input:
(married Mickey ?who)

;;; Query results:. . user break
> 

一切、答えが返って来ない。
無限ループがdesiredと言う訳ではないが、orの場合やsimple-queryのアサートの探索結果のみだけでも先に表示される方がどちらかと言うと意味のある結果と言える。

Exercise 4.72

3.5.3のinterleaveの定義の直前に書いてある通り、最初のストリームが無限リストだった場合に２番目のストリームは永久に評価されないので。あるいは双方とも無限リストの可能性もあるので。二つのストリームを平等に最初の要素から評価するには互い違いに評価する必要がある為。

Exercise 4.73

flatten-streamの引数streamはストリームのストリームであり、それらを一列のストリームにする。各要素をinterleaveするのは、それらを均等に評価しながら辿れる様にするため。ここでinterleaveを使わずにinterleave-delayedとするのはExercise 4.71と同じ理由で、途中に無限ストリームが入ってもそれ以降の要素で評価出来る物があれば結果を印字出来る様にするため。interleaveを使うと無限ストリームの要素を評価し始めた所以降の結果は永遠に評価、印字される事はない。

Exercise 4.74

確かにnegate、lisp-valueはsingleton-streamかthe-empty-streamしか返さない。find-assertionsはcheck-an-assertionが返すsingleton-streamかthe-empty-streamをstream-flatmapで一続きのストリームにした物を返す。
a.
要は

1. 不要なthe-empty-streamを取り除いて
2. singleton-streamの要素を取り出して
3. 全体を一続きのストリームに構成し直す

3.5.1のstream-filterをコピーして来て

(define (simple-flatten stream)
  (stream-map stream-car
              (stream-filter (lambda (s) (not (stream-null? s))) stream)))

(define (negate operands frame-stream)
  (simple-stream-flatmap
   (lambda (frame)
     (if (stream-null? (qeval (negated-query operands)
                              (singleton-stream frame)))
         (singleton-stream frame)
         the-empty-stream))
   frame-stream))

(define (lisp-value call frame-stream)
  (simple-stream-flatmap
   (lambda (frame)
     (if (execute
          (instantiate
           call
           frame
           (lambda (v f)
             (error "Unknown pat var -- LISP-VALUE" v))))
         (singleton-stream frame)
         the-empty-stream))
   frame-stream))

(define (find-assertions pattern frame)
  (simple-stream-flatmap (lambda (datum)
                    (check-an-assertion datum pattern frame))
                  (fetch-assertions pattern frame)))

b.
評価器の挙動に変化はない筈。

元の実装での実行結果

;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:
(and (supervisor ?x (Bitdiddle Ben))
     (not (job ?x (computer programmer))))

;;; Query results:
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (not (job (Tweakit Lem E) (computer programmer))))
;;; Query input:
(and (salary ?person ?amount)
     (lisp-value > ?amount 30000))

;;; Query results:
(and (salary (Scrooge Eben) 75000) (lisp-value > 75000 30000))
(and (salary (Warbucks Oliver) 150000) (lisp-value > 150000 30000))
(and (salary (Fect Cy D) 35000) (lisp-value > 35000 30000))
(and (salary (Hacker Alyssa P) 40000) (lisp-value > 40000 30000))
(and (salary (Bitdiddle Ben) 60000) (lisp-value > 60000 30000))
;;; Query input:

simple-stream-flatmapを使った実行結果

;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:
(and (supervisor ?x (Bitdiddle Ben))
     (not (job ?x (computer programmer))))

;;; Query results:
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (not (job (Tweakit Lem E) (computer programmer))))
;;; Query input:
(and (salary ?person ?amount)
     (lisp-value > ?amount 30000))

;;; Query results:
(and (salary (Scrooge Eben) 75000) (lisp-value > 75000 30000))
(and (salary (Warbucks Oliver) 150000) (lisp-value > 150000 30000))
(and (salary (Fect Cy D) 35000) (lisp-value > 35000 30000))
(and (salary (Hacker Alyssa P) 40000) (lisp-value > 40000 30000))
(and (salary (Bitdiddle Ben) 60000) (lisp-value > 60000 30000))
;;; Query input:

同じ結果が出ている。

Exercise 4.75

notの実装に倣って作ると

(define (uniquely-asserted operands frame-stream)
  (stream-flatmap
   (lambda (frame)
     (let ((result (qeval (unique-query operands) (singleton-stream frame))))
       (cond ((null? result) the-empty-stream)
             ((null? (stream-cdr result)) result)
             (else the-empty-stream))))
   frame-stream))
(put 'unique 'qeval uniquely-asserted)

(define (unique-query exps) (car exps))

実行結果

;;; Query input:
(unique (job ?x (computer wizard)))

;;; Query results:
(unique (job (Bitdiddle Ben) (computer wizard)))
;;; Query input:
(unique (job ?x (computer programmer)))

;;; Query results:
;;; Query input:
(and (job ?x ?j) (unique (job ?anyone ?j)))

;;; Query results:
(and (job (Aull DeWitt) (administration secretary)) (unique (job (Aull DeWitt) (administration secretary))))
(and (job (Cratchet Robert) (accounting scrivener)) (unique (job (Cratchet Robert) (accounting scrivener))))
(and (job (Scrooge Eben) (accounting chief accountant)) (unique (job (Scrooge Eben) (accounting chief accountant))))
(and (job (Warbucks Oliver) (administration big wheel)) (unique (job (Warbucks Oliver) (administration big wheel))))
(and (job (Reasoner Louis) (computer programmer trainee)) (unique (job (Reasoner Louis) (computer programmer trainee))))
(and (job (Tweakit Lem E) (computer technician)) (unique (job (Tweakit Lem E) (computer technician))))
(and (job (Bitdiddle Ben) (computer wizard)) (unique (job (Bitdiddle Ben) (computer wizard))))
;;; Query input:

ひとりの人だけを監督するスーパーバイザーは、スーパーバイザーをしている人のリストを出して、それぞれの人に対してもう一度クエリを掛けて答えが一つであれば表示。

(and (supervisor ?assistant ?boss)
     (unique (supervisor ?sole-assistant ?boss)))

実行結果

;;; Query input:
(supervisor ?assistant ?boss)

;;; Query results:
(supervisor (Aull DeWitt) (Warbucks Oliver))
(supervisor (Cratchet Robert) (Scrooge Eben))
(supervisor (Scrooge Eben) (Warbucks Oliver))
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
(supervisor (Reasoner Louis) (Hacker Alyssa P))
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;; Query input:
(and (supervisor ?assistant ?boss)
     (unique (supervisor ?sole-assistant ?boss)))

;;; Query results:
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (unique (supervisor (Cratchet Robert) (Scrooge Eben))))
(and (supervisor (Reasoner Louis) (Hacker Alyssa P)) (unique (supervisor (Reasoner Louis) (Hacker Alyssa P))))
;;; Query input:

Exercise 4.76

ここでのandの実装は最初のクエリで生成したフレームひとつひとつについてもう一度２番目のクエリでデータベースを一通り探索するので非効率。これを二つのクエリを独立に評価して結果を比較する様にした方が効率が良いとの事。

二つのクエリの結果を使う点に於いてはorを実現するdisjoinに近い。disjoinが無条件にinterleaveするのに対し、二つのクエリの結果がコンパチな場合にのみ結果のフレームを出力する必要がある。問題は何を以てコンパチとするのか。
要は二つのフレームで一つの変数が別の値に拘束されていなければ良い。片側にだけ拘束されている変数をもう片方に足せば良い。この作業はextend-if-possibleそのもの。ここがユニフィケーションと似ていると言っている部分かな。

ただextend-if-possibleを呼び出すまでの部分は新規に作る必要がある。

conjoinは最初のクエリだけを評価して、その結果を持って残りのクエリをconjoinの再帰呼び出しに渡していた。これを最初のクエリだけの評価と、残りのクエリの評価（conjoinの再帰呼び出し）を同じフレームで行って、その結果をマージする方法に変更する。

二つのフレームのストリームをマージする事になるので、stream-mapを二重に使って、二つのフレームのマージに落とし込む。stream-mapを単純に二重に使うとその結果はフレームのストリームのストリームになってしまうが、欲しいのはフレームのストリームなので外側のmapにはstream-flatmapを使う。

二つのフレームをマージするには、片方のフレームのバインドを順にもう片方のフレームにextend-if-possibleを使って移動させる。一つのバインドでも拡張出来なければその二つのフレームはマージ出来ないと言う事。

stream-flatmapの結果はシンボルfailedを含んでいるので、それを最後にstream-filterで取り除く。stream-filterは3.5.1から借用。

(define (conjoin conjuncts frame-stream)
  (if (empty-conjunction? conjuncts)
      frame-stream
      (conjoin-frame-streams (qeval (first-conjunct conjuncts) frame-stream)
                             (conjoin (rest-conjuncts conjuncts) frame-stream))))
(put 'and 'qeval conjoin)

(define (conjoin-frame-streams fs1 fs2)
  (stream-filter (lambda (frame) (not (equal? frame 'failed)))
                 (stream-flatmap (lambda (frame1)
                                   (stream-map
                                    (lambda (frame2)
                                      (conjoin-frames frame1 frame2))
                                    fs2))
                                 fs1)))

(define (conjoin-frames frame1 frame2)
  (if (null? frame1)
      frame2
      (let ((extended-frame2 (extend-if-possible (caar frame1) (cdar frame1) frame2)))
        (if (eq? extended-frame2 'failed)
            'failed
            (conjoin-frames (cdr frame1) extended-frame2)))))

実行結果

;;; Query input:
(and (job ?person (computer programmer))
     (address ?person ?where))

;;; Query results:
(and (job (Fect Cy D) (computer programmer)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (job (Hacker Alyssa P) (computer programmer)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
;;; Query input:
(job ?x (computer ?type))

;;; Query results:
(job (Tweakit Lem E) (computer technician))
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
(job (Bitdiddle Ben) (computer wizard))
;;; Query input:
(or (supervisor ?x (Bitdiddle Ben))
    (supervisor ?x (Hacker Alyssa P)))

;;; Query results:
(or (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (supervisor (Tweakit Lem E) (Hacker Alyssa P)))
(or (supervisor (Reasoner Louis) (Bitdiddle Ben)) (supervisor (Reasoner Louis) (Hacker Alyssa P)))
(or (supervisor (Fect Cy D) (Bitdiddle Ben)) (supervisor (Fect Cy D) (Hacker Alyssa P)))
(or (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (supervisor (Hacker Alyssa P) (Hacker Alyssa P)))
;;; Query input:

一応動いていそう。simple-queryとかorは影響を受けていない。

Exercise 4.77

4.4.3のProblems with notで議論した問題を解決する。4.4.3ではnotの問題を二つ挙げている。一つ目はnotはフィルタとして動作する為に、予め変数が拘束された状態のストリームに適用しないと正しい答えが出力されないと言うもの。二つ目は論理的なnotは条件を満たす物以外の全てだが、この全ては全てではなくデータベースに登録されている事実の中でしか適用されないと言う事。

4.4.3の記述と問題文を見る限りは、andの中でnotが使われた時のケースのみを対象としている様子。not単独で使った時に該当しない事実を全部挙げる事は含まれていない様に思う。

not以降の条件については関連している変数が全て拘束されてから評価する様に遅延させる。ここで効率の為に評価出来る状況になったら直ぐに評価するとあるので、アイデアとしては各変数毎に条件文をフレームの中に保存してしまって、次にその変数を拘束する時点でその辺数を持つフレームを入力に条件文を評価すれば良さそう。
ここで遅延と言っても遅延させる段階では未知のフレームに対して評価を遅延させなければならないので所謂delayとforceを使った遅延評価は使えないと思う。新しい引数に差し替えてforceとかやって出来なくないだろうけど、set!が必要だしかなり面倒な感じ。

(define (extract-variables pattern)
  (cond ((null? pattern) '())
        ((var? (car pattern))
         (cons (car pattern) (extract-variables (cdr pattern))))
        ((pair? (car pattern))
         (append (extract-variables (car pattern))
                 (extract-variables (cdr pattern))))
        (else
         (extract-variables (cdr pattern)))))

(define (all-variables-bound? vars frame)
  (cond ((null? vars) true)
        ((binding-in-frame (car vars) frame) (all-variables-bound? (cdr vars) frame))
        (else false)))

(define (extend-vars vars val frame)
  (if (null? vars)
      frame
      (extend (car vars) val (extend-vars (cdr vars) val frame))))

(define (extend-delayed-pattern vars op exp frame)
  (extend-vars vars (cons 'delayed-query (cons op exp)) frame))

(define (negate operands frame-stream)
  (stream-flatmap
   (lambda (frame)
     (let ((vars (extract-variables operands)))
       (if (all-variables-bound? vars frame)
           (if (stream-null? (qeval (negated-query operands)
                                    (singleton-stream frame)))
               (singleton-stream frame)
               the-empty-stream)
           (singleton-stream (extend-delayed-pattern vars 'not operands frame)))))
   frame-stream))

(define (lisp-value call frame-stream)
  (stream-flatmap
   (lambda (frame)
     (let ((vars (extract-variables call)))
       (if (all-variables-bound? vars frame)
           (if (execute
                (instantiate
                    call
                  frame
                  (lambda (v f)
                    (error "Unknown pat var -- LISP-VALUE" v))))
               (singleton-stream frame)
               the-empty-stream)
           (singleton-stream (extend-delayed-pattern vars 'lisp-value call frame)))))
   frame-stream))

extract-variablesはnotやlisp-valueに含まれる変数のリスト。
all-variables-bound?はリストに含まれる変数が全て拘束されているか。全てが拘束されていない場合には遅延させる。
extend-varsはリスト中の全ての変数についてある値を拘束する。要はパターンに含まれる変数全てに遅延させる条件文を拘束する。条件文には'delayed-queryと言うタグが付いている。
extend-delayed-patternはフレームに対して遅延させる条件文を追加する。

(define (delayed-query? val)
  (tagged-list? val 'delayed-query))

(define (delayed-eval exp frame-stream)
  (qeval exp frame-stream))

(define (extend-if-possible var val frame)
  (let ((binding (binding-in-frame var frame)))
    (cond (binding
           (cond ((delayed-query? (binding-value binding))
                  (let ((result (delayed-eval (cdr (binding-value binding)) (singleton-stream (extend var val '())))))
                    (if (stream-null? result)
                        'failed
                        (extend var val frame))))
                 ((delayed-query? val)
                  (let ((result (delayed-eval (cdr val) (singleton-stream (extend (binding-variable binding) (binding-value binding) '())))))
                    (if (stream-null? result)
                        'failed
                        frame)))
                 (else
                  (unify-match
                   (binding-value binding) val frame))))
          ((delayed-query? val)
           (extend var val frame))
…

extend-if-possibleではまず、新規の変数の値にdelayed-queryタグが付いている場合にはそのままフレームに足す。ここでフレームに足さないとdepends-on?に引っ掛かってフレームに足して貰えない。
次に先にフレームに遅延された条件が入っていた場合、つまり同じ変数に対してパターンではない値を拘束しようとしている時には、新しい値だけのフレームを作って遅延させた条件を評価する。
最後に先に変数が拘束されている所に遅延された条件文を拘束しようとしている場合。条件文の全ての変数が拘束されないと遅延させるのでこのケースが必要。ここではフレームに入っていた当該変数のみのフレームを作り、それに対して条件文を評価する。

動作確認

;;; Query input:
(and (supervisor ?x ?y)
     (not (job ?x (computer programmer))))

;;; Query results:
(and (supervisor (Aull DeWitt) (Warbucks Oliver)) (not (job (Aull DeWitt) (computer programmer))))
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (not (job (Cratchet Robert) (computer programmer))))
(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (not (job (Scrooge Eben) (computer programmer))))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (not (job (Bitdiddle Ben) (computer programmer))))
(and (supervisor (Reasoner Louis) (Hacker Alyssa P)) (not (job (Reasoner Louis) (computer programmer))))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (not (job (Tweakit Lem E) (computer programmer))))
;;; Query input:
(and (not (job ?x (computer programmer)))
     (supervisor ?x ?y))

;;; Query results:
(and (not (job (Aull DeWitt) (computer programmer))) (supervisor (Aull DeWitt) (Warbucks Oliver)))
(and (not (job (Cratchet Robert) (computer programmer))) (supervisor (Cratchet Robert) (Scrooge Eben)))
(and (not (job (Scrooge Eben) (computer programmer))) (supervisor (Scrooge Eben) (Warbucks Oliver)))
(and (not (job (Bitdiddle Ben) (computer programmer))) (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
(and (not (job (Reasoner Louis) (computer programmer))) (supervisor (Reasoner Louis) (Hacker Alyssa P)))
(and (not (job (Tweakit Lem E) (computer programmer))) (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
;;; Query input:
(and (salary ?person ?amount)
     (lisp-value > ?amount 30000))

;;; Query results:
(and (salary (Scrooge Eben) 75000) (lisp-value > 75000 30000))
(and (salary (Warbucks Oliver) 150000) (lisp-value > 150000 30000))
(and (salary (Fect Cy D) 35000) (lisp-value > 35000 30000))
(and (salary (Hacker Alyssa P) 40000) (lisp-value > 40000 30000))
(and (salary (Bitdiddle Ben) 60000) (lisp-value > 60000 30000))
;;; Query input:
(and (lisp-value > ?amount 30000) (salary ?person ?amount))

;;; Query results:
(and (lisp-value > 75000 30000) (salary (Scrooge Eben) 75000))
(and (lisp-value > 150000 30000) (salary (Warbucks Oliver) 150000))
(and (lisp-value > 35000 30000) (salary (Fect Cy D) 35000))
(and (lisp-value > 40000 30000) (salary (Hacker Alyssa P) 40000))
(and (lisp-value > 60000 30000) (salary (Bitdiddle Ben) 60000))
;;; Query input:

もっと複雑なパターンにも対応出来ているのかは今ひとつ自信はない。
ただ、notやlisp-valueの順番には左右されない、また遅延させた評価は必要な変数が拘束される時点で評価するので無駄なフレームは生成していない筈。

本来のandは可換な筈なので遅延を使うよりもandにぶら下がっている条件のうちnot、lisp-valueではない条件を先に評価する方が簡単な気もする。

Exercise 4.78

try-againはamb評価器の機能と言うよりはamb評価器を呼び出すREPLの機能。なので仮にambを実装した言語をamb-Lispと呼ぶ事にすると、amb-Lisp上でtry-againが出来るREPLは実装出来ない。

となると、queryに対するREPLもamb評価器を呼び出すREPLを動かす必要がある。つまりamb-Lispによるquery言語評価器の実装も、queryも同じamb評価器のREPLに入力する必要があるので、外部DSL的にquoteの中に全てのquery言語プログラムを入れたamb言語のプログラムとして実装するか、amb言語に入力機能を追加して、query言語を受け取って評価結果をambのREPLに戻す関数をamb言語で実装するかしか無さそう。

でも毎回query用のプロンプトを出す関数を呼び出して、queryを入力するのではプロンプトを呼び出す関数を入力する手間の分だけ無駄なので、外部DSL的にqueryをquoteの中に入れて実行する事にする。

【ambを使ったquery評価器】
ambを使う時の基本アイテムrequire、an-element-ofはそのまま定義。
query言語の演算子と処理関数のマップ、index化したassertを保存する為のテーブルを作る為のmake-tableもそのまま。ただしRacket上で実装するに当たりset-cdr!の互換性の問題があったので、dictを使った版を使ったので、これらに関連する関数はamb評価器でプリミティブとして実装する必要がある。

■assert!
今回はassert!をREPLから入力する口は設けず

(add-rule-or-assertion! (add-assertion-body '(assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))))
(add-rule-or-assertion!
 (add-assertion-body '(assert! (can-do-job (computer programmer)
                                           (computer programmer trainee)))))

の様な形式でデータベースに登録する事にする。
add-rule-or-assertion!はそのまま。

THE-ASSERTIONS、get-all-assertionsはそのままで、

(define (add-assertion! assertion)
  (store-assertion-in-index assertion)
  (let ((old-assertions THE-ASSERTIONS))
    (set! THE-ASSERTIONS
          (cons assertion old-assertions))
    'ok))

(define (store-assertion-in-index assertion)
  (if (indexable? assertion)
      (let ((key (index-key-of assertion)))
        (let ((current-assertion
               (get-indexed-assertions key)))
          (put key
               'assertion
               (cons assertion
                     current-assertion))))
      (error "store-assersion-in-index: assersion is not indexable")))

(define (get-indexed-assertions key)
  (get-or-null key 'assertion))

はcons-streamをconsに代えて、キーとしてのシンボル名や変数名からstreamを取り除いただけ。

get-streamの代わりにget-or-nullを定義。getは値が見つからない時にfalseを返す設計になっているが、空リストが帰って欲しい所があるので。

(define (get-or-null key-1 key-2)
  (let ((val (get key-1 key-2)))
    (if val
        val
        '())))

ルールも同様。

(define (add-rule! rule)
  (store-rule-in-index rule)
  (let ((old-rules THE-RULES))
    (set! THE-RULES (cons rule old-rules))
    'ok))

(define (store-rule-in-index rule)
  (let ((pattern (conclusion rule)))
    (if (indexable? pattern)
        (let ((key (index-key-of pattern)))
          (let ((current-rule
                 (get-indexed-rules key)))
            (put key
                 'rule
                 (cons rule
                       current-rule))))
        (error "store-rule-in-index: pattern is not indexable"))))

(define (get-indexed-rules key)
  (get-or-null key 'rule))

但し、この時点では気付かないがruleは動作しない。ルール変数をユニークにする為のrule-counterがバックトラックの影響で値が戻ってしまいちゃんと動かない。

■query
queryの入り口。

(define (query input)
  (let ((q (query-syntax-process input)))
    (instantiate
        q
      (qeval q '())
      (lambda (v f)
        (contract-question-mark v)))))

inputは元々はreadで返されたリストだが、ここではquoteしたリストとしてのquery言語を想定。amb評価器のREPLから呼び出してinstantiateした結果をREPLに返す。

元々

(qeval q (singleton-stream '()))

となっていた所はストリームではなく空のフレームを渡すのみ。また、元々、qevalはストリームを返していたのでstream-mapでinstantiateを呼び出していたが、今回はフレームを一つだけ返すので、直接instantiateを呼び出して結果をREPLに返す。

query-syntax-process、map-over-symbols、expand-question-mark、instantiate、contract-question-markはそのまま。

(define (qeval query frame)
  (let ((qproc (get (type query) 'qeval)))
    (if qproc
        (qproc (contents query) frame)
        (simple-query query frame))))

frame-streamがframeに変わっただけ。

simple-queryは今回最も大きく変わった所。

(define (simple-query query-pattern frame)
  (amb (find-assertions query-pattern frame) (apply-rules query-pattern frame)))

要はambを使ってassertとruleを順に走査する。見つからなければfailとなってバックトラックが起きる。

同様にfind-assertions、apply-rulesはan-element-ofとrequireを使ってデータベースに入っている情報がマッチするか順番に走査する。

(define (find-assertions pattern frame)
  (let ((datum (an-element-of (fetch-assertions pattern))))
    (let ((result (check-an-assertion datum pattern frame)))
      (require (not (eq? result 'failed)))
      result)))

(define (apply-rules pattern frame)
  (let ((rule (an-element-of (fetch-rules pattern frame))))
    (let ((result (apply-a-rule rule pattern frame)))
      (require (not (eq? result 'failed)))
      result)))

(define (check-an-assertion assertion query-pat query-frame)
  (pattern-match query-pat assertion query-frame))


(define (apply-a-rule rule query-pattern query-frame)
  (let ((clean-rule (rename-variables-in rule)))
    (let ((unify-result
           (unify-match query-pattern
                        (conclusion clean-rule)
                        query-frame)))
      (if (eq? unify-result 'failed)
          'failed
          (qeval (rule-body clean-rule)
                 unify-result)))))

check-an-assertionはpattern-matchがfailedを返したら、それをそのままfind-assertionsに返す事で次の選択肢を試す事になる。ruleの場合はconclusionがマッチした所で本体を評価する必要があるので、その結果を返す事になる。
pattern-matchやunify-match以下は元々frameレベルでの操作なのでそのまま。

■演算
andは要するに最初の条件で拘束されたフレームで次の条件を評価して失敗せずに条件が全部無くなれば最後まで残ったフレームが全ての条件を満たしていると言う事。

(define (conjoin conjuncts frame)
  (if (empty-conjunction? conjuncts)
      frame
      (conjoin (rest-conjuncts conjuncts)
               (qeval (first-conjunct conjuncts)
                      frame))))

orの場合は最初の条件が成功すればそれをそのまま返す。その先で失敗したりREPLでtry-againからバックトラックした時に次の条件の評価に進む。バックトラックして来てもう条件が無くなったら失敗となる。

(define (disjoin disjuncts frame)
  (if (empty-disjunction? disjuncts)
      (amb)
      (amb
       (qeval (first-disjunct disjuncts) frame)
       (disjoin (rest-disjuncts disjuncts)
                       frame))))

notはひょっとするとこのexerciseの最大の問題。どうやらambではそのままでは実装出来ない模様。Exercise 4.52で実装したif-failを使うと評価に失敗した時に先に進む（※１）様に実装出来るが、評価が成功した時にはバックトラックしなければならない。例えばqevalを成功して抜けて来た時にバックトラックすると同じqeval内の最後のambに戻るだけで、それより前には戻れない。仮にこのambで選択肢が無くなって失敗すると※１と同じ状況になり、この二つの状況（最初の評価とバックトラックして来た時の評価）を区別する事は不可能。つまりバックトラックした時に再評価してはならないのでPrologのカット演算子の様な仕組みが必要。

lisp-valueは実行結果がfalseの時に失敗となる様にするだけ。

(define (lisp-value call frame)
  (if (execute
       (instantiate
           call
         frame
         (lambda (v f)
           (error "Unknown pat var -- LISP-VALUE" v))))
      frame
      (amb)))

基本的には変更はこれだけで、その他は元のquery languageの評価器と同じままで実装可能。

【amb-lisp評価器】
殆ど変更は要らないが、面倒なのでquery評価器で使う関数の多くをプリミティブとして実装する。

(define primitive-procedures
  (list (list 'car car)
…
        (list 'eq? eq?)
        (list 'equal? equal?)
        (list 'pair? pair?)
        (list 'error error)
        (list 'symbol? symbol?)
        (list 'number? number?)
        (list 'symbol->string symbol->string)
        (list 'string->symbol string->symbol)
        (list 'number->string number->string)
        (list 'string-append string-append)
        (list 'string=? string=?)
        (list 'substring substring)
        (list 'string-length string-length)
        (list 'make-hash make-hash)
        (list 'dict-set! dict-set!)
        (list 'dict-ref dict-ref)
        (list 'assoc assoc)
        (list 'apply apply)
        (list 'eval eval)
        (list 'make-base-namespace make-base-namespace)
        ))

【動作確認】
元々の挙動：

;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:

ambでは

;;; Amb-Eval input:
(query '(job ?x (computer programmer)))

;;; Starting a new problem ;;; Amb-Eval value:
(job (Fect Cy D) (computer programmer))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(job (Hacker Alyssa P) (computer programmer))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(query '(job ?x (computer programmer)))
;;; Amb-Eval input:

元の挙動

;;; Query input:
(job ?x (computer ?type))

;;; Query results:
(job (Tweakit Lem E) (computer technician))
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
(job (Bitdiddle Ben) (computer wizard))
;;; Query input:

amb

;;; Amb-Eval input:
(query '(job ?x (computer ?type)))

;;; Starting a new problem ;;; Amb-Eval value:
(job (Tweakit Lem E) (computer technician))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(job (Fect Cy D) (computer programmer))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(job (Hacker Alyssa P) (computer programmer))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(job (Bitdiddle Ben) (computer wizard))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(query '(job ?x (computer ?type)))
;;; Amb-Eval input:

元の挙動

;;; Query input:
(and (job ?person (computer programmer))
     (address ?person ?where))

;;; Query results:
(and (job (Fect Cy D) (computer programmer)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (job (Hacker Alyssa P) (computer programmer)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
;;; Query input:

amb

;;; Amb-Eval input:
(query '(and (job ?person (computer programmer))
     (address ?person ?where)))

;;; Starting a new problem ;;; Amb-Eval value:
(and (job (Fect Cy D) (computer programmer)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(and (job (Hacker Alyssa P) (computer programmer)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(query '(and (job ?person (computer programmer)) (address ?person ?where)))
;;; Amb-Eval input:

元の挙動

;;; Query input:
(or (supervisor ?x (Bitdiddle Ben))
    (supervisor ?x (Hacker Alyssa P)))

;;; Query results:
(or (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (supervisor (Tweakit Lem E) (Hacker Alyssa P)))
(or (supervisor (Reasoner Louis) (Bitdiddle Ben)) (supervisor (Reasoner Louis) (Hacker Alyssa P)))
(or (supervisor (Fect Cy D) (Bitdiddle Ben)) (supervisor (Fect Cy D) (Hacker Alyssa P)))
(or (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (supervisor (Hacker Alyssa P) (Hacker Alyssa P)))
;;; Query input:

amb

;;; Amb-Eval input:
(query '(or (supervisor ?x (Bitdiddle Ben))
    (supervisor ?x (Hacker Alyssa P))))

;;; Starting a new problem ;;; Amb-Eval value:
(or (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (supervisor (Tweakit Lem E) (Hacker Alyssa P)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(or (supervisor (Fect Cy D) (Bitdiddle Ben)) (supervisor (Fect Cy D) (Hacker Alyssa P)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(or (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (supervisor (Hacker Alyssa P) (Hacker Alyssa P)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(or (supervisor (Reasoner Louis) (Bitdiddle Ben)) (supervisor (Reasoner Louis) (Hacker Alyssa P)))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(query '(or (supervisor ?x (Bitdiddle Ben)) (supervisor ?x (Hacker Alyssa P))))
;;; Amb-Eval input:

元の挙動

;;; Query input:
(and (salary ?person ?amount)
     (lisp-value > ?amount 30000))

;;; Query results:
(and (salary (Scrooge Eben) 75000) (lisp-value > 75000 30000))
(and (salary (Warbucks Oliver) 150000) (lisp-value > 150000 30000))
(and (salary (Fect Cy D) 35000) (lisp-value > 35000 30000))
(and (salary (Hacker Alyssa P) 40000) (lisp-value > 40000 30000))
(and (salary (Bitdiddle Ben) 60000) (lisp-value > 60000 30000))
;;; Query input:

amb

;;; Amb-Eval input:
(query '(and (salary ?person ?amount)
     (lisp-value > ?amount 30000)))

;;; Starting a new problem ;;; Amb-Eval value:
(and (salary (Scrooge Eben) 75000) (lisp-value > 75000 30000))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(and (salary (Warbucks Oliver) 150000) (lisp-value > 150000 30000))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(and (salary (Fect Cy D) 35000) (lisp-value > 35000 30000))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(and (salary (Hacker Alyssa P) 40000) (lisp-value > 40000 30000))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(and (salary (Bitdiddle Ben) 60000) (lisp-value > 60000 30000))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(query '(and (salary ?person ?amount) (lisp-value > ?amount 30000)))
;;; Amb-Eval input:

You will probably also find, however, that your new query language has subtle differences in behavior from the one implemented here. Can you find examples that illustrate this difference?

違いと言ったら

1. ambのREPLに戻る必要がある事
2. notが実装出来ない事
3. rule-counter方式とバックトラックは同居出来ないのでruleが動作しない事
4. try-againすると必ず最後に「There are no more values of」を返して来る事。
5. ひょっとするとデータベースを最後まで走査せずに答えを返して来るので、最初の答えが返って来るまでの時間が早いかもしれない。（けど、そもそも二重に評価器を実装していてamb上のquery languageは評価が遅いので良く分からない）

位しか思い当たらない。

Exercise 4.79

環境モデルの場合、直近の環境から変数の値を探しに行く。同じ名前の変数がある場合には内側の環境にある方が外側の環境にある変数を隠す。ただし、ここまでに出て来た環境では変数に対して値が割り当てられていて、他の変数等を参照している事はなかった。

今の実装でframeをダンプして整形すると以下の様になる。

(((? 2 z) c d)
 ((? 4 y) c d)
 ((? 1 z) (? 2 u) ? 2 z)
 ((? 2 y) c d)
 ((? 2 v))
 ((? 2 u) . b)
 ((? z) (? 1 u) ? 1 z)
 ((? 1 y) c d)
 ((? 1 v) b)
 ((? 1 u) . a))

つまり、まず値に変数への参照が含まれている事と、ある変数が参照している変数は別の環境に属しているので、これまでのLISP実行系で考えていた環境と同じ概念では捉えられない。

ただし、このframeを見ていると

1. 変数を書き換えるのに使用される番号は実は環境を表したIDと捉える事が出来る
2. ある環境に属する変数の値は別の環境に属する変数あるいは式を参照している
3. 一つの式が複数の環境に属する変数を含む事はない

事が分かる。

だとすると、

1. それぞれの変数に付加していた数字を「環境ID」として
2. 各「環境ID」毎に変数のバインドを持つ
3. 各変数の値にも「環境ID」を付加する
4. グローバルスコープ（assertionとかruleとかREPLの入力ライン）の「環境ID」は0とする

として、このframeを以下の様に書き換える事が出来る筈。

((4 (((? y) 0 c d)))
 (2 (((? z) 0 c d)
     ((? y) 0 c d)
     ((? v))
     ((? u) 0 b)))
 (1 (((? z) 2 (? u) (? z))
     ((? y) 0 c d)
     ((? v) 0 b)
     ((? u) 0 a)))
　(0 (((? z) 1 (? u) ? z))))

元のframeでドット記法になってる部分がちょっと正確ではないけど。

frameをこの様に書き換えれば、(? y)等の変数名は書き換える事なく同じ事が実装出来る筈。

そこでqueryの式の前に常に「環境ID」を付加するモデルで実装してみる。

【query-driver-loop】タイプされた式は変数qに入るが、グローバル環境IDとして0を先頭に付加した式として（environmental expressionと言う意味で）変数e-expに保存。qevalではこのenvironmental expressionを評価する事にする。

(define (query-driver-loop)
  (prompt-for-input input-prompt)
  (let ((q (query-syntax-process (read))))
    (cond ((assertion-to-be-added? q)
           (add-rule-or-assertion! (add-assertion-body q))
           (newline)
           (display "Assertion added to data base.")
           (query-driver-loop))
          (else
           (let ((e-exp (cons 0 q)))  ;***
             (newline)
             (display output-prompt)
             (display-stream
              (stream-map
               (lambda (frame)
                 (instantiate e-exp  ;***
                              frame
                              (lambda (v f)
                                (contract-question-mark v))))
             (qeval e-exp (singleton-stream '())))))  ;***
           (query-driver-loop)))))

【environment-id / environment-expression】environmental expressionから環境のIDと本体の式を取り出す関数。

(define (environment-id exp)
  (if (pair? exp)
      (car exp)
      (error "Unknown expression ENVIRONMENT-ID" exp)))
  
(define (environment-expression exp)
  (if (pair? exp)
      (cdr exp)
      (error "Unknown expression ENVIRONMENT-EXPRESSION" exp)))

【binding-in-environment】
frameの形式を環境ID毎に纏めたので、binding-in-frameの外側に環境IDに対応するframeから検索する関数として定義。

(define (binding-in-environment eid variable frame)
  (let ((env (assq eid frame)))
    (if env
        (binding-in-frame variable (cadr env))
        #f)))

【instantiate】内部関数copyではenvironmental expressionではなく環境IDと本体の式を別々に取り扱う。frameにバインドされている値はenvironmental expressionなので次のcopyに渡す時にはやはり環境IDと本体の式に分離する。

(define (instantiate exp frame unbound-var-handler)
  (define (copy env-id exp)
    (cond ((var? exp)
           (let ((binding (binding-in-environment env-id exp frame)))
             (if binding
                 (copy (environment-id (binding-value binding)) (environment-expression (binding-value binding)))
                 (unbound-var-handler env-id exp frame))))
          ((pair? exp)
           (cons (copy env-id (car exp)) (copy env-id (cdr exp))))
          (else exp)))
  (copy (car exp) (cdr exp)))

【qeval】今回compound queryには対応しないが、always-trueに対応する必要がある。qprocを探すのに環境IDを取り除いて最初にキーワードを取り出す。qprocを適用する時には最初のキーワードを除いてenvironment expressionを作り直して適用する。

(define (qeval query frame-stream)
  (let ((qproc (get (type (environment-expression query)) 'qeval)))
    (if qproc
        (qproc (cons (environment-id query) (contents (environment-expression query))) frame-stream)
        (simple-query query frame-stream))))

テストの為に簡単なassertionのqueryをサポートする。

【find-assertions】 check-an-assertion、fetch-assertionsをそのまま使う為にパターンから環境IDを除いて渡す様に変更。

(define (find-assertions env-pattern frame)
  (let ((pattern (environment-expression env-pattern)))
    (stream-flatmap (lambda (datum)
                      (check-an-assertion datum pattern frame))
                    (fetch-assertions pattern frame))))

【extend-if-consistent】frameに入っている値を得るのにbinding-in-frameの代わりにbinding-in-environmentを使う。またassertionの場合は全ての環境IDは0とする。extendには変数の環境IDと値の環境IDを渡す。

(define (extend-if-consistent var dat frame)
  (let ((binding (binding-in-environment 0 var frame)))
    (if binding
        (pattern-match (binding-value binding) dat frame)
        (extend 0 var 0 dat frame))))

【extend】変数とその値に加えてそれぞれの環境IDを引数に貰って、環境ID毎にframeを形成する。

(define (extend var-id var val-id val frame)
  (cond ((null? frame) (list (cons var-id (list (list (make-binding var val-id val))))))
        ((eq? (caar frame) var-id) (cons (cons (caar frame) (list (cons (make-binding var val-id val) (cadar frame)))) (cdr frame)))
        (else (cons (car frame) (extend var-id var val-id val (cdr frame))))))

【make-binding】値の環境IDを引数に追加。

(define (make-binding variable value-env-id value)
  (cons variable (cons value-env-id value)))

ここからはruleをサポートする為の変更。

【apply-a-rule】新規に適用するルールの為の環境IDを生成して、それで変数名を書き換えるのではなく、それをそのままunify-matchに渡す。また、続きのqevalにはその環境IDを付けた式を渡す様に変更。

(define (apply-a-rule rule query-pattern query-frame)
  (let ((rule-env (new-rule-application-id)))
    (let ((unify-result
           (unify-match (environment-id query-pattern)
                        (environment-expression query-pattern)
                        rule-env
                        (conclusion rule)
                        query-frame)))
      (if (eq? unify-result 'failed)
          the-empty-stream
          (qeval (cons rule-env (rule-body rule))
                 (singleton-stream unify-result))))))

【unify-match】二つの式それぞれの環境IDを引数として受け取る様に変更。二つの式が完全に一致しているか否かはその式が変数を含んでいる場合には環境IDも含めて比較し、変数を含まない場合には環境IDは無視して比較する。

(define (unify-match p1-env p1 p2-env p2 frame)
  (cond ((eq? frame 'failed) 'failed)
        ((and (not (include-var? p1)) (not (include-var? p2)) (equal? p1 p2)) frame)
        ((and (or (include-var? p1) (include-var? p2)) (eq? p1-env p2-env) (equal? p1 p2)) frame)
        ((var? p1) (extend-if-possible p1-env p1 p2-env p2 frame))
        ((var? p2) (extend-if-possible p2-env p2 p1-env p1 frame))
        ((and (pair? p1) (pair? p2))
         (unify-match p1-env (cdr p1)
                      p2-env (cdr p2)
                      (unify-match p1-env (car p1)
                                   p2-env (car p2)
                                   frame)))
        (else 'failed)))

【extend-if-possible】変数、値それぞれに環境IDを取る様に変更。frame内のbindingを探すのにbinding-in-environmentを使用する。

(define (extend-if-possible var-env var val-env val frame)
  (let ((binding (binding-in-environment var-env var frame)))
    (cond (binding
           (unify-match
            (environment-id (binding-value binding)) (environment-expression (binding-value binding)) val-env val frame))
          ((var? val)
           (let ((binding (binding-in-environment val-env val frame)))
             (if binding
                 (unify-match
                  var-env var (environment-id (binding-value binding)) (environment-expression (binding-value binding)) frame)
                 (extend var-env var val-env val frame))))
          ((depends-on? val-env val var-env var frame)
           'failed)
          (else (extend var-env var val-env val frame)))))

【depends-on?】要はある環境に属する変数の値が同じ環境の自分自身を参照しているかをチェックする。

(define (depends-on? exp exp-id var var-id frame)
  (define (tree-walk e id)
    (cond ((var? e)
           (if (equal? var e)
               true
               (let ((b (binding-in-environment id e frame)))
                 (if b
                     (tree-walk (binding-value b) id)
                     false))))
          ((pair? e)
           (or (tree-walk (car e) id)
               (tree-walk (cdr e) id)))
          (else false)))
  (if (eq? exp-id var-id)
      (tree-walk exp exp-id)
      false))

【include-var?】新規の関数。引数の式が変数を含んでいるか否かを返す述語。

(define (include-var? exp)
  (cond ((null? exp) #f)
        ((pair? exp)
         (if (var? exp)
             #t
             (or (include-var? (car exp)) (include-var? (cdr exp)))))
        (else #f)))

実装の変更はここまで。

さて、これで単純なクエリとルールの適用を実行してみる。

;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:
(assert! (rule (append-to-form () ?y ?y)))

Assertion added to data base.
;;; Query input:
(assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
      (append-to-form ?v ?y ?z)))

Assertion added to data base.
;;; Query input:
(append-to-form (a b) (c d) ?z)

;;; Query results:
(append-to-form (a b) (c d) (a b c d))
;;; Query input:
(append-to-form (a b) ?y (a b c d))

;;; Query results:
(append-to-form (a b) (c d) (a b c d))
;;; Query input:
(append-to-form ?x ?y (a b c d))

;;; Query results:
(append-to-form (a b c d) () (a b c d))
(append-to-form () (a b c d) (a b c d))
(append-to-form (a) (b c d) (a b c d))
(append-to-form (a b) (c d) (a b c d))
(append-to-form (a b c) (d) (a b c d))
;;; Query input:
.

一応動いてるっぽい。

本質的には変数名に番号を入れてるのと同じ事をしているけど、変数名を書き換えずに実装出来た。これを環境と呼ぶのかはちょっと微妙な感じだが、関数呼び出しの環境と全く同じ実装で出来る訳ではなさそう。

4.78のルールが動作しない問題から繋がっていると考えると、前問のquery言語の違いはルールが動作しない事を意図しているのかも知れない。だとすると実はこの問題は4.78の続きとしてやった方が面白いかもしれない。

See if you can build on your environment structure to create constructs in the query language for dealing with large systems, such as the rule analog of block-structured procedures.

1.1.8のInternal Definition and Block Structureでは

Such nesting of definitions, called block structure, is basically the right solution to the simplest name-packaging problem.

と書いてあるので、恐らくルールの中にローカルなルールを作る様な事を言っている様な気がする。
現状はルールは全てグローバルのデータベースに保存しているので、特定のルール内でのみ適用出来るルールは実現出来ない。
ルールの定義を環境に保存すれば出来ない事はないが、Prologにもルール内だけのルールと言う文法は無い模様なので、あまり意味のある事ではないのかも知れない。
また、ルールの定義の中に別のルールを定義するとなると、query-driver-loopでassert!で始まる定義かそれ以外をクエリと解釈している部分を、全てqevalで処理する必要がある。

Can you relate any of this to the problem of making deductions in a context (e.g., ``If I supposed that P were true, then I would be able to deduce A and B.'') as a method of problem solving? (This problem is open-ended. A good answer is probably worth a Ph.D.)

（）の部分を取り除くと

Can you relate any of this to the problem of making deductions in a context as a method of problem solving?

any of this = renaming implementation or environment imprementation
と解釈して、『推論を使って解決する様な問題にこれらの実装は使えるか？』

単純な推論の問題であれば可能。
少しでも複雑になると各種Prologの実装の様に色々な要素を取り込まなければならないと思う。

*1:エラー処理を呼び出し側に任せるのは例外処理に似ている？

SICP 4.4.2 How the Query System Works

ノート

明らかにquery evaluatorは何らかの探索を行う。
一つの方法は非決定論的プログラミングでambを使った実装。もう一つはストリームを使う実装。（ここではストリームで実装する）
query systemは大きく分けて二つの操作からなる：パターンマッチと単一化。

Pattern matching

パターンマッチャーへの入力は、パターン、データ、パターン変数の拘束を持つフレーム。パターンがマッチした場合には新たに変数を拘束したフレームを返す。
simple queryはこれだけで実現出来る。

Streams of frames

可能なパターンをストリームとして入力し、データとマッチしたものだけを出力のストリームに流す。マッチするものだけをフィルターする感じ。
出力のフレームは入力のフレームの拡張。複数マッチする場合は共通の入力フレームにそれぞれの拡張が付いたフレームが出力のストリームに流れる。

なるほど。ambの場合は答えが出る度にtry-againして別のパターンを試す感じか。

Compound queries

andを実現するには二つのqueryを直列にする。
orを実現するには二つのqueryの出力ストリームをマージする。
notは入力ストリームのフレームのうちマッチしなかったものを出力ストリームに流す。
lisp-valueはマッチャートは異なるが同様にフィルターとして働く。

Unification

ルールの結論部はアサートと似ているが、パターン変数を含むので更に一般化した探索が必要。これが単一化。ここではパターンもデータもパターン変数を含む。

ユニファイヤは二つのパターンを入力とし、二つのパターンが同じになる様な変数の拘束が可能か試す。
可能な拘束が見つかったらそのフレームを返す。

Applying rules

1. まず問い合わせにマッチするアサートを探す
2. 次に問い合わせとマッチするルールを探す
3. ルールが見つかったらフレームを返し、今度はそのフレーム内でruleの本体の評価を続ける

このプロセスはLispのevalとapplyのプロセスと似ている。

Simple queries

ルールも考慮すると、シンプルなクエリの結果はパターンマッチの結果とルールを適用した結果をマージしたものになる。

The query evaluator and the driver loop

query evaluatorにはevalに相当するqevalがあり、Lisp同様幾つかのスペシャルフォームがある。
問い合わせではないassert!はスペシャルコマンド。

4.4.3 Is Logic Programming Mathematical Logic?

and、or、notはこれまでの数学的な演算子とは少し意味が違う。
andにぶら下がる条件は本来可換だが、現実には結果は同じであっても効率は条件式の順番によって相当変わる。

論理プログラミングの目的は、問題をwhatとhowの部分に分離する事。
数学的な論理は計算には十分強力だが、手続き的な順序を制御するのには向いていない。
論理プログラミングのプログラムはコンピュータで効率よく計算出来る様に記述しなければならない。
節の順番で計算順序を制御する。

query languageは手続き的に解釈出来る数学的論理と解釈出来る。

Infinet loops

簡単な例としては、一つの事実がマッチしてもシステムは他にもマッチするパターンが無いか探してしまい、また最初のルールがマッチしてしまう様な場合無限ループに陥る。

Problems with not

数学的論理としては同じに見える二つのクエリは結果が異なる。

;;; Query input:
(and (supervisor ?x ?y)
     (not (job ?x (computer programmer))))

;;; Query results:
(and (supervisor (Aull DeWitt) (Warbucks Oliver)) (not (job (Aull DeWitt) (computer programmer))))
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (not (job (Cratchet Robert) (computer programmer))))
(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (not (job (Scrooge Eben) (computer programmer))))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (not (job (Bitdiddle Ben) (computer programmer))))
(and (supervisor (Reasoner Louis) (Hacker Alyssa P)) (not (job (Reasoner Louis) (computer programmer))))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (not (job (Tweakit Lem E) (computer programmer))))
;;; Query input:
(and (not (job ?x (computer programmer)))
     (supervisor ?x ?y))

;;; Query results:
;;; Query input:

最初のクエリはsupervisorのリストを挙げて、次に?xのjobがcomputer programmerではない人に絞っている。
notはフィルタとして働くので最初に入力としてリストが挙っていないといけない。入力が無ければnotは何も出力しないので二番目のクエリは空を返す事になる。

;;; Query results:
;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:
(not (job ?x (computer programmer)))

;;; Query results:
;;; Query input:

notが拘束されていない変数を含むフレームに適用されると期待通りの結果は得られない。lisp-valueもフィルタなので同じことが起きる。
論理演算ではnot PとはPはtrueではない事。クエリシステムでのnot PはPは推定出来ない事を意味している。
ここでのnotは限られた情報の中での補集合の様に働く。

Exercise 4.64

元の定義。

(rule (outranked-by ?staff-person ?boss)
      (or (supervisor ?staff-person ?boss)
          (and (supervisor ?staff-person ?middle-manager)
               (outranked-by ?middle-manager ?boss))))

実行結果。

;;; Query input:
(assert! (rule (outranked-by ?staff-person ?boss)
      (or (supervisor ?staff-person ?boss)
          (and (supervisor ?staff-person ?middle-manager)
               (outranked-by ?middle-manager ?boss)))))

Assertion added to data base.
;;; Query input:
(outranked-by (Bitdiddle Ben) ?who)

;;; Query results:
(outranked-by (Bitdiddle Ben) (Warbucks Oliver))

書き換えられた定義

(rule (outranked-by ?staff-person ?boss)
      (or (supervisor ?staff-person ?boss)
          (and (outranked-by ?middle-manager ?boss)
               (supervisor ?staff-person ?middle-manager))))

最後の二つの条件が入れ替わっている。
実行すると

;;; Query input:
(assert! (rule (outranked-by ?staff-person ?boss)
      (or (supervisor ?staff-person ?boss)
          (and (outranked-by ?middle-manager ?boss)
               (supervisor ?staff-person ?middle-manager)))))

Assertion added to data base.
;;; Query input:
(outranked-by (Bitdiddle Ben) ?who)

;;; Query results:
(outranked-by (Bitdiddle Ben) (Warbucks Oliver))

と言ったまま、次の入力待ちにならず返って来ない。
?middle-managerは拘束されずにoutranked-byを再帰探索（？）してしまうので無限再帰に陥る。
最上位の結合子がorなので、両方の探索を必ず行い、andの最初の条件なのでoutranked-byが呼ばれると必ず再帰する。

Exercise 4.65

実際にそうなるか確かめてみる。

;;; Query input:
(assert! (rule (wheel ?person)
      (and (supervisor ?middle-manager ?person)
           (supervisor ?x ?middle-manager))))

Assertion added to data base.
;;; Query input:
(wheel ?who)

;;; Query results:
(wheel (Warbucks Oliver))
(wheel (Warbucks Oliver))
(wheel (Bitdiddle Ben))
(wheel (Warbucks Oliver))
(wheel (Warbucks Oliver))
;;; Query input:

確かに。wheelの条件を分解してみる

;;; Query input:
(supervisor ?middle-manager ?person)

;;; Query results:
(supervisor (Aull DeWitt) (Warbucks Oliver))
(supervisor (Cratchet Robert) (Scrooge Eben))
(supervisor (Scrooge Eben) (Warbucks Oliver))
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
(supervisor (Reasoner Louis) (Hacker Alyssa P))
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;; Query input:

Oliver Warbucksは3人のsupervisor。それぞれの部下を調べると。

;;; Query input:
(supervisor ?x (Aull DeWitt))

;;; Query results:
;;; Query input:
(supervisor ?x (Scrooge Eben))

;;; Query results:
(supervisor (Cratchet Robert) (Scrooge Eben))
;;; Query input:
(supervisor ?x (Bitdiddle Ben))

;;; Query results:
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;; Query input:

と合計で4人の孫部下を持っているので、孫部下が見つかる度に表示される。

Exercise 4.66

;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:

このクエリの答えには重複が無いので良いが、一般化した時にの部分は重複した答えを返す可能性があるので、重複を取り除く必要がある。

Exercise 4.67

無限ループに関して分かっている事は

• simple queryでは蓄積されている事実に付いて一通り探索するだけなので、無限ループになる事は無い。
• ルールがマッチした場合に、もう一度最初から探索が始まるのでループに陥る可能性がある。
• 同じルールがマッチしたとしても、論理変数の拘束状態が変わっていれば無限ループではない筈。

とすると、ルールを適用しようとする時に過去に探索したパターン（論理変数の拘束も含む）と同じかどうかが分かれば良い。

実装の詳細は次節だが、apply-a-ruleの所にこの仕組みを組み込めば良さそう。apply-a-ruleに入って来るquery-patternを見てみると

(married Mickey (? who))
(married (? 1 y) (? 1 x))
(married (? 2 y) (? 2 x))
(married (? 3 y) (? 3 x))
(married (? 4 y) (? 4 x))

こんな感じ。拘束された値を展開させてみる。

(define (apply-a-rule rule query-pattern query-frame)
  (let ((clean-rule (rename-variables-in rule))
        (intermediate-pattern (instantiate query-pattern query-frame (lambda (v f) v))))
...

このintermediate-patternを見てみると

(married Mickey (? who))
(married (? 1 y) Mickey)
(married Mickey (? 2 x))
(married (? 3 y) Mickey)
(married Mickey (? 4 x))

と言う事は(married Mickey (? 2 x))が来た時点で(married Mickey (? who))と同じである事が検出出来れば良い。
二つ関数を作る。same-pattern?は二つのパターンが同じかどうか、(? ...)は中身が何であろうが同じとみなす。contain-same-pattern?はパターンのリストpsがパターンpを含んでいるか否か。

(define (same-pattern? p1 p2)
  (cond ((and (null? p1) (null? p2)) true)
        ((or (null? p1) (null? p2)) false)
        ((or (and (pair? (car p1)) (pair? (car p2)) (eq? (caar p1) '?) (eq? (caar p2) '?))
             (eq? (car p1) (car p2)))
         (same-pattern? (cdr p1) (cdr p2)))
        (else false)))

(define (contain-same-pattern? ps p)
  (cond ((or (null? p) (null? ps)) false)
        ((same-pattern? (car ps) p) true)
        (else (contain-same-pattern? (cdr ps) p))))

動作確認

> (same-pattern? '(married Mickey (? who)) '(married Mickey (? 2 x)))
#t
> (same-pattern? '(married Mickey (? who)) '(married (? 1 y) Mickey))
#f
> (contain-same-pattern? '((married (? 147 y) Mickey a) (married (? 147 y) Minnie) (married (? 147 y) Mickey)) '(married (? 145 y) Mickey))
#t
> (contain-same-pattern? '((married (? 147 y) Mickey a) (married (? 147 y) Minnie)) '(married (? 145 y) Mickey))
#f
> 

空リストから始めてapply-a-ruleでパターンを蓄積させて行く。同じパターンを検出したらunificationに失敗した時と同じくthe-empty-streamを返す。

(define (query-driver-loop)
（中略）
             (qeval q (singleton-stream '()) '())))
           (query-driver-loop)))))

(define (apply-a-rule rule query-pattern query-frame history)
  (let ((clean-rule (rename-variables-in rule))
        (intermediate-pattern (instantiate query-pattern query-frame (lambda (v f) v))))
    (if (contain-same-pattern? history intermediate-pattern)
        the-empty-stream
        (let ((unify-result
               (unify-match query-pattern
                            (conclusion clean-rule)
                            query-frame)))
          (if (eq? unify-result 'failed)
              the-empty-stream
              (qeval (rule-body clean-rule)
                     (singleton-stream unify-result) (cons intermediate-pattern history)))))))

この二つの手続きの間に入る関数全てにhistoryをたらい回しするのがやや面倒だが組み込むと：

(define (qeval query frame-stream history)
  (let ((qproc (get (type query) 'qeval)))
    (if qproc
        (qproc (contents query) frame-stream history)
        (simple-query query frame-stream history))))

(define (simple-query query-pattern frame-stream history)
  (stream-flatmap
   (lambda (frame)
     (stream-append-delayed
      (find-assertions query-pattern frame)
      (delay (apply-rules query-pattern frame history))))
   frame-stream))

(define (conjoin conjuncts frame-stream history)
  (if (empty-conjunction? conjuncts)
      frame-stream
      (conjoin (rest-conjuncts conjuncts)
               (qeval (first-conjunct conjuncts)
                      frame-stream
                      history)
               history)))

(define (disjoin disjuncts frame-stream history)
  (if (empty-disjunction? disjuncts)
      the-empty-stream
      (interleave-delayed
       (qeval (first-disjunct disjuncts) frame-stream history)
       (delay (disjoin (rest-disjuncts disjuncts)
                       frame-stream
                       history)))))

(define (negate operands frame-stream history)
  (stream-flatmap
   (lambda (frame)
     (if (stream-null? (qeval (negated-query operands)
                              (singleton-stream frame)
                              history))
         (singleton-stream frame)
         the-empty-stream))
   frame-stream))

(define (lisp-value call frame-stream history)
  (stream-flatmap
   (lambda (frame)
     (if (execute
          (instantiate
           call
           frame
           (lambda (v f)
             (error "Unknown pat var -- LISP-VALUE" v))))
         (singleton-stream frame)
         the-empty-stream))
   frame-stream))

(define (always-true ignore frame-stream history) frame-stream)

(define (apply-rules pattern frame history)
  (stream-flatmap (lambda (rule)
                    (apply-a-rule rule pattern frame history))
                  (fetch-rules pattern frame)))

では動作確認。MickeyとMinnieの例

;;; Query input:
(assert! (married Minnie Mickey))

Assertion added to data base.
;;; Query input:
(married Mickey ?who)

;;; Query results:
;;; Query input:
(assert! (rule (married ?x ?y)
               (married ?y ?x)))

Assertion added to data base.
;;; Query input:
(married Mickey ?who)

;;; Query results:
(married Mickey Minnie)
;;; Query input:

無限ループに入らずに止まる。
Exercise 4.64のoutranked-byの例
元のルールでは

;;; Query input:
(assert! (rule (outranked-by ?staff-person ?boss)
      (or (supervisor ?staff-person ?boss)
          (and (supervisor ?staff-person ?middle-manager)
               (outranked-by ?middle-manager ?boss)))))

Assertion added to data base.
;;; Query input:
(outranked-by (Bitdiddle Ben) ?who)

;;; Query results:
(outranked-by (Bitdiddle Ben) (Warbucks Oliver))
;;; Query input:

間違えて書き換えた方の例

;;; Query input:
(assert! (rule (outranked-by ?staff-person ?boss)
      (or (supervisor ?staff-person ?boss)
          (and (outranked-by ?middle-manager ?boss)
               (supervisor ?staff-person ?middle-manager)))))

Assertion added to data base.
;;; Query input:
(outranked-by (Bitdiddle Ben) ?who)

;;; Query results:
(outranked-by (Bitdiddle Ben) (Warbucks Oliver))
;;; Query input:

無限ループせずにちゃんと同じ答えが返って来る。

Exercise 4.68

普通に単純に考えると

(assert! (rule (reverse (?x) (?x))))
(assert! (rule (reverse (?x . ?y) ?z)
               (and (reverse ?y ?w)
                    (append-to-form ?w (?x) ?z))))

ところが、これだと片方向にしか計算出来ない。

;;; Query input:
(reverse (1 2 3) ?x)

;;; Query results:
(reverse (1 2 3) (3 2 1))
;;; Query input:
(reverse ?x (1 2 3))

;;; Query results:
;;; Query input:

二つの引数を対称に扱おうとして以下の様にすると

(assert! (rule (reverse (?x) (?x))))
(assert! (rule (reverse (?x . ?y) (?a . ?b))
               (or (and (reverse ?y ?w)
                        (append-to-form ?w (?x) (?a . ?b)))
                   (and (reverse ?b ?c)
                        (append-to-form ?c (?a) (?x . ?y))))))

結果

;;; Query input:
(reverse (1 2 3) ?x)

;;; Query results:
(reverse (1 2 3) (3 2 1))
(reverse (1 2 3) (3 2 1))
;;; Query input:
(reverse ?x (1 2 3))

;;; Query results:
(reverse (3 2 1) (1 2 3))
(reverse (3 2 1) (1 2 3))
;;; Query input:

どちら方向も動く事は動くが結果が二つ出てしまう。実はorは対称ではないのでこれ以上はどうにもならないか。
Prologの世界では上手く動いている以下の定義

(assert! (rule (reverse ?x ?y)
               (rev ?x () ?y)))
(assert! (rule (rev () ?x ?x)))
(assert! (rule (rev (?a . ?x) ?y ?z)
               (rev ?x (?a . ?y) ?z)))

は、このquery systemではやはり片方向にしか計算出来ない。

;;; Query input:
(assert! (rule (reverse ?x ?y)
               (rev ?x () ?y)))

Assertion added to data base.
;;; Query input:
(assert! (rule (rev () ?x ?x)))

Assertion added to data base.
;;; Query input:
(assert! (rule (rev (?a . ?x) ?y ?z)
               (rev ?x (?a . ?y) ?z)))

Assertion added to data base.
;;; Query input:
(reverse (1 2 3) ?x)

;;; Query results:
(reverse (1 2 3) (3 2 1))
;;; Query input:
(reverse ?x (1 2 3))

;;; Query results:. . user break
> 

答えが２回表示されるけど双方向に答えが出るのが良いか、答えは一つしか表示されないが片方向にしか答えが出せないのが良いか。

Exercise 4.69

親子関係の事実に対して世代を一つ増やす、sonに対してはgrand-sonを作る様なルール。

そもそも

;;; Query input:
(assert! ((great grandson) Adam Irad))
. . store-assersion-in-index: assersion is not indexable
> 

indexable?が最初の要素はシンボルか論理変数（?で始まるリスト）である事を要求しているので、この形式は受け付けられない。

;;; Query input:
(assert! (rule ((great . ?rel) ?x ?y)))
. . store-rule-in-index: pattern is not indexable
> 

なので取り敢えず、indexable?は先頭がシンボルのリストも許す事にする。

(define (indexable? pat)
  (or (constant-symbol? (car pat))
      (constant-symbol? (caar pat))
      (var? (car pat))))

これで、リストをインデックスにした事実を登録出来て、simple queryが出来る。

;;; Query input:
(assert!  ((great grandson) Adam Irad))

Assertion added to data base.
;;; Query input:
((great grandson) Adam ?who)

;;; Query results:
((great grandson) Adam Irad)
;;; Query input:
((great grandson) ?who Irad)

;;; Query results:
((great grandson) Adam Irad)
;;; Query input:

まずはルールの名前部分のリストが段々減って来る事を想定して、最後がgrandsonだけ残った時のルールを作る。

;;; Query input:
(assert! (rule ((grandson) ?grand-father ?grand-son)
               (grand-son-of ?grand-father ?grand-son)))

Assertion added to data base.
;;; Query input:
((grandson) Adam ?who)

;;; Query results:
((grandson) Adam Enoch)
;;; Query input:
((grandson) ?who Enoch)

;;; Query results:
((grandson) Adam Enoch)
;;; Query input:

一応答えは合っている。
次に、問題の((great . ?rel) ?x ?y)と言うルールを作る。?relの部分はgreatが

;;; Query input:
(assert! (rule ((great . ?rel) ?x ?y)
               (and (son-of ?x ?w)
                    (?rel ?w ?y))))

Assertion added to data base.
;;; Query input:
((great grandson) ?g ?ggs)

;;; Query results:
((great grandson) Adam Irad)
((great grandson) Mehujael Jubal)
((great grandson) Irad Lamech)
((great grandson) Mehujael Jabal)
((great grandson) Enoch Methushael)
((great grandson) Cain Mehujael)
((great grandson) Adam Irad)
;;; Query input:
(?relationship Adam Irad)

;;; Query results:
((great grandson) Adam Irad)
((great great . son) Adam Irad)
((great grandson) Adam Irad)
((great great . son-of) Adam Irad)
((great . grand-son-of) Adam Irad)
;;; Query input:

こんなクエリも出来る。

;;; Query input:
((great . son) Adam ?who)

;;; Query results:
((great . son) Adam Enoch)
;;; Query input:
((great . son-of) Adam ?who)

;;; Query results:
((great . son-of) Adam Enoch)
;;; Query input:

となると、(grandson)を作って意味は良く分からなくなって来る。
ルールの名前にリストを許して、そこに論理変数を入れるとルールそのものも可変になる。

SICP 4.4 Logic Programming

Nondeterministic Computingで少し雰囲気を感じつつ、ついに論理プログラミングに到達。
第５章はまた毛色が違う話なので、ここが一つの到達点なのかな。

ノート

数学はdeclarative（宣言的）、コンピュータサイエンスはimperative（命令的）。
高級言語になるとどうやって計算するのかのの多くの部分について言語が提供してくれてプログラマは気にしなくて済む。

式ベースの言語では関数の値を表す式が、その値の計算方法にもなっている。この事により、これらの言語ではunidirectional、つまり入力から出力への一方通行の計算方法を基本にしている。

そうではない言語もある。
制約プログラミングがひとつ。非決定論的コンピューティングもひとつ。
論理プログラミングはユニフィケーションによってこれらのアイデアを更に発展させる。

appendの定義は以下の二つのルールをLispに翻訳したものと解釈出来る：

• 任意のリストyに関して、空リストにyを繋いだものがy。
• 任意のu、v、y、zに関して、vにyを結合したものをzとした時に、(cons u v)にyを結合したものが(cons u z)

って全然意味が分からないが、x=(cons u v）と考えるとu = (car x) 、v = (cdr x)。
「v and y append form z」はz = (append v y)つまり z = (append (cdr x) y)の事。
「(cons u v) and y append to form (cons u z)」は(append (cons u v) y)即ち(append x y)は(cons u z)即ち(cons (car x) (append (cdr x) y))であると言う事。

論理プログラミングではプログラマは上記二つのルールを各だけで以下の3つの問いの答えを出す事が出来る。

• (a b)と(c d)のappendは？
• (a b)にappendしたら(a b c d)となるリストyは？
• appendしたら(a b c d)となる二つのリストxとyは？

4.4.1 Deductive Information Retrieval

論理プログラミングはデータベースのインターフェースとして優れている。

A sample data base

一つ一つのリストをassertionと呼んでいる。前節の自然言語解釈のパース結果の様に先頭にタグが付いたシンボルのリストっぽい。

Simple queries

やはりサンプルが出て来ると実際に動かしたいので、4.4.4節のコードを使って動かしてみる。
挙動の理解は兎も角4.4.4節のコードを全てコピーする。

3.3.3節のテーブルを使うが、この中でset-cdr!が使われていてこれがRacketには標準から外れている。mpairとか使えば使えない事も無いが色々と厄介な事が付いて来る。なのでハッシュを使って再実装。

#lang racket
(require racket/dict)

(define (make-table)
  (let ((local-table (make-hash)))
    (define (lookup key-1 key-2)
      (let ((subtable (dict-ref local-table key-1 #f)))
        (if subtable
            (dict-ref subtable key-2 #f)
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (dict-ref local-table key-1 #f)))
        (if subtable
            (dict-set! subtable key-2 value)
            (dict-set! local-table key-1 (let ((h (make-hash)))
                                           (dict-set! h key-2 value)
                                           h)))
      'ok))
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))
(define eval-table (make-table))
(define get (eval-table 'lookup-proc))
(define put (eval-table 'insert-proc!))

まぁ一応同じ動きをする筈。

次にストリーム。cons-streamはテキストには提供されていなかったが自前で作ったのを再利用。

(define-syntax cons-stream
  (syntax-rules ()
    ((cons-stream a b)
     (cons a (delay b)))))

stream-null?とthe-empty-streamもテキストには定義は無いが脚注に従って自分で定義。

(define stream-null? null?)
(define the-empty-stream null)

stream-car、stream-cdr、stream-map、stream-for-each、display-stream、display-lineは3.5.1節から、stream-appendを3.5.3節から、tagged-listを4.1.2節から、prompt-for-inputを4.1.4節からコピーする。

user-initial-environmentは定義されていないが、Racketの場合make-base-namespaceで作った名前空間をevalが受け取るので以下の様に定義する。

(define user-initial-environment (make-base-namespace))

また、Racketはelse部がないif構文を許さないのでstore-assertion-in-indexとstore-rule-in-indexを以下の様に変更。

(define (store-assertion-in-index assertion)
  (if (indexable? assertion)
      (let ((key (index-key-of assertion)))
        (let ((current-assertion-stream
               (get-stream key 'assertion-stream)))
          (put key
               'assertion-stream
               (cons-stream assertion
                            current-assertion-stream))))
      (error "store-assersion-in-index: assersion is not indexable")))

(define (store-rule-in-index rule)
  (let ((pattern (conclusion rule)))
    (if (indexable? pattern)
        (let ((key (index-key-of pattern)))
          (let ((current-rule-stream
                 (get-stream key 'rule-stream)))
            (put key
                 'rule-stream
                 (cons-stream rule
                              current-rule-stream))))
        (error "store-rule-in-index: pattern is not indexable"))))

これで評価器は完成。

まず、Sample data baseのアサート達を全部4.4.2の最後に書いてある通り(assert! ...)で登録する。

;;; Query input:
(assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))

Assertion added to data base.
;;; Query input:

こんな感じ。

では、クエリを実行してみる。

;;; Query input:
(job ?x (computer programmer))

;;; Query results:
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
;;; Query input:

テキストと表示される順番は違うけど動いた。

クエスチョンマーク＋シンボルをパターン変数とする。

;;; Query input:
(address ?x ?y)

;;; Query results:
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(address (Cratchet Robert) (Allston (N Harvard Street) 16))
(address (Scrooge Eben) (Weston (Shady Lane) 10))
(address (Warbucks Oliver) (Swellesley (Top Heap Road)))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(address (Tweakit Lem E) (Boston (Bay State Road) 22))
(address (Fect Cy D) (Cambridge (Ames Street) 3))
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
;;; Query input:

住所の登録は全部で９件。

;;; Query input:
(supervisor ?x ?x)

;;; Query results:
;;; Query input:

自分自身を監督している人は誰もいない。
問い合わせのリストの中に含まれる要素の数も意味を持つ。

;;; Query input:
(job ?x (computer ?type))

;;; Query results:
(job (Tweakit Lem E) (computer technician))
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
(job (Bitdiddle Ben) (computer wizard))
;;; Query input:

可変長のリストにマッチさせるにはLispの可変長引数の様に指定する。

;;; Query input:
(job ?x (computer . ?type))

;;; Query results:
(job (Reasoner Louis) (computer programmer trainee))
(job (Tweakit Lem E) (computer technician))
(job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer))
(job (Bitdiddle Ben) (computer wizard))
;;; Query input:

Exercise 4.55

;;; Query input:
(supervisor ?x (Bitdiddle Ben))

;;; Query results:
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;; Query input:
(job ?x (accounting . ?y))

;;; Query results:
(job (Cratchet Robert) (accounting scrivener))
(job (Scrooge Eben) (accounting chief accountant))
;;; Query input:
(address ?x (Slumerville . ?y))

;;; Query results:
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
;;; Query input:

Compound queries

andの例。

;;; Query input:
(and (job ?person (computer programmer))
     (address ?person ?where))

;;; Query results:
(and (job (Fect Cy D) (computer programmer)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (job (Hacker Alyssa P) (computer programmer)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
;;; Query input:

orの例。

;;; Query input:
(or (supervisor ?x (Bitdiddle Ben))
    (supervisor ?x (Hacker Alyssa P)))

;;; Query results:
(or (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (supervisor (Tweakit Lem E) (Hacker Alyssa P)))
(or (supervisor (Reasoner Louis) (Bitdiddle Ben)) (supervisor (Reasoner Louis) (Hacker Alyssa P)))
(or (supervisor (Fect Cy D) (Bitdiddle Ben)) (supervisor (Fect Cy D) (Hacker Alyssa P)))
(or (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (supervisor (Hacker Alyssa P) (Hacker Alyssa P)))
;;; Query input:

notの例。

;;; Query input:
(and (supervisor ?x (Bitdiddle Ben))
     (not (job ?x (computer programmer))))

;;; Query results:
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (not (job (Tweakit Lem E) (computer programmer))))
;;; Query input:

lisp-valueの例。

;;; Query input:
(and (salary ?person ?amount)
     (lisp-value > ?amount 30000))

;;; Query results:
(and (salary (Scrooge Eben) 75000) (lisp-value > 75000 30000))
(and (salary (Warbucks Oliver) 150000) (lisp-value > 150000 30000))
(and (salary (Fect Cy D) 35000) (lisp-value > 35000 30000))
(and (salary (Hacker Alyssa P) 40000) (lisp-value > 40000 30000))
(and (salary (Bitdiddle Ben) 60000) (lisp-value > 60000 30000))
;;; Query input:

Exercise 4.56

a.

;;; Query input:
(and (supervisor ?person (Bitdiddle Ben))
     (address ?pserson ?where))

;;; Query results:
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Scrooge Eben) (Weston (Shady Lane) 10)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Scrooge Eben) (Weston (Shady Lane) 10)))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Scrooge Eben) (Weston (Shady Lane) 10)))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben)) (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben)) (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
;;; Query input:

b.

;;; Query input:
(and (salary (Bitdiddle Ben) ?Bens-salary)
     (and (salary ?person ?salary)
          (lisp-value > ?Bens-salary ?salary)))

;;; Query results:
(and (salary (Bitdiddle Ben) 60000) (and (salary (Aull DeWitt) 25000) (lisp-value > 60000 25000)))
(and (salary (Bitdiddle Ben) 60000) (and (salary (Cratchet Robert) 18000) (lisp-value > 60000 18000)))
(and (salary (Bitdiddle Ben) 60000) (and (salary (Reasoner Louis) 30000) (lisp-value > 60000 30000)))
(and (salary (Bitdiddle Ben) 60000) (and (salary (Tweakit Lem E) 25000) (lisp-value > 60000 25000)))
(and (salary (Bitdiddle Ben) 60000) (and (salary (Fect Cy D) 35000) (lisp-value > 60000 35000)))
(and (salary (Bitdiddle Ben) 60000) (and (salary (Hacker Alyssa P) 40000) (lisp-value > 60000 40000)))
;;; Query input:

c.

;;; Query input:
(and (supervisor ?person ?supervisor)
     (not (job ?supervisor (computer . ?x))))

;;; Query results:
(and (supervisor (Aull DeWitt) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?x))))
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (not (job (Scrooge Eben) (computer . ?x))))
(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?x))))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?x))))
;;; Query input:

Rules

手続きの様に問い合わせに名前をつけて抽象化する事が出来る。

;;; Query input:
(assert! (rule (lives-near ?person-1 ?person-2)
      (and (address ?person-1 (?town . ?rest-1))
           (address ?person-2 (?town . ?rest-2))
           (not (same ?person-1 ?person-2)))))

Assertion added to data base.
;;; Query input:
(assert! (rule (same ?x ?x)))

Assertion added to data base.
;;; Query input:
(lives-near ?x (Bitdiddle Ben))

;;; Query results:
(lives-near (Aull DeWitt) (Bitdiddle Ben))
(lives-near (Reasoner Louis) (Bitdiddle Ben))
;;; Query input:
(and (job ?x (computer programmer))
     (lives-near ?x (Bitdiddle Ben)))

;;; Query results:
;;; Query input:

Exercise 4.57

どうしても癖で、未知数を関数値として該当者を返す様な考え方になってしまい勝ちだが、lives-nearの例を見ると分かる様に未知数はどこにでも置けるので、未知数も含めて引数と言うか変数とする。
条件は

1. person1のjobをjob1、
2. person2のjobをjob2とした時に、
3. job1とjob2が同じか
4. job2はjob1を兼任出来る（can-do-jobを使う）
5. かつperson1とperson2は別人

(assert! (rule (same ?x ?x)))
(assert! (rule (replace ?person1 ?person2)
               (and (job ?person1 ?job1)
                    (job ?person2 ?job2)
                    (or (same ?job1 ?job2)
                        (can-do-job ?job2 ?job1))
                    (not (same ?person1 ?person2)))))

a.
この問い合わせは単純。

;;; Query input:
(replace (Fect Cy D) ?x)

;;; Query results:
(replace (Fect Cy D) (Bitdiddle Ben))
(replace (Fect Cy D) (Hacker Alyssa P))
;;; Query input:

b.
person1がperson2の仕事を代われて、しかもperson2の給料の方が高い。

(and (replace ?person1 ?person2)
     (salary ?person1 ?salary1)
     (salary ?person2 ?salary2)
     (lisp-value < ?salary1 ?salary2))

実行結果。

;;; Query input:
(and (replace ?person1 ?person2)
     (salary ?person1 ?salary1)
     (salary ?person2 ?salary2)
     (lisp-value < ?salary1 ?salary2))

;;; Query results:
(and (replace (Reasoner Louis) (Fect Cy D)) (salary (Reasoner Louis) 30000) (salary (Fect Cy D) 35000) (lisp-value < 30000 35000))
(and (replace (Reasoner Louis) (Hacker Alyssa P)) (salary (Reasoner Louis) 30000) (salary (Hacker Alyssa P) 40000) (lisp-value < 30000 40000))
(and (replace (Tweakit Lem E) (Bitdiddle Ben)) (salary (Tweakit Lem E) 25000) (salary (Bitdiddle Ben) 60000) (lisp-value < 25000 60000))
(and (replace (Fect Cy D) (Bitdiddle Ben)) (salary (Fect Cy D) 35000) (salary (Bitdiddle Ben) 60000) (lisp-value < 35000 60000))
(and (replace (Hacker Alyssa P) (Bitdiddle Ben)) (salary (Hacker Alyssa P) 40000) (salary (Bitdiddle Ben) 60000) (lisp-value < 40000 60000))
(and (replace (Fect Cy D) (Hacker Alyssa P)) (salary (Fect Cy D) 35000) (salary (Hacker Alyssa P) 40000) (lisp-value < 35000 40000))
;;; Query input:

Exercise 4.58

条件はほぼそのまま。スペルミスに気をつけないと何も言わずにシカトされる。

(assert! (rule (big-shot ?person ?division)
               (and (supervisor ?person ?supervisor)
                    (job ?person (?division . ?job-p))
                    (job ?supervisor (?division-s . ?job-s))
                    (not (same ?division ?division-s)))))

実行結果。

;;; Query input:
(big-shot ?person ?division)

;;; Query results:
(big-shot (Scrooge Eben) accounting)
(big-shot (Bitdiddle Ben) computer)
;;; Query input:

Exercise 4.59

a.

;;; Query input:
(meeting ?div (Friday ?time))

;;; Query results:
(meeting administration (Friday 1pm))
;;; Query input:

b.

(assert! (rule (meeting-time ?person ?day-and-time)
               (and (job ?person (?division . ?position))
                    (or (meeting ?division ?day-and-time)
                        (meeting whole-company ?day-and-time)))))

実行結果

;;; Query input:
(meeting-time (Hacker Alyssa P) ?time)

;;; Query results:
(meeting-time (Hacker Alyssa P) (Wednesday 3pm))
(meeting-time (Hacker Alyssa P) (Wednesday 4pm))
;;; Query input:

c.
Alyssaは水曜日にしかミーティングを持っておらず分かりにくいので、Aull DeWittで試す。

;;; Query input:
(meeting-time (Hacker Alyssa P) (Wednesday . ?time))

;;; Query results:
(meeting-time (Hacker Alyssa P) (Wednesday 3pm))
(meeting-time (Hacker Alyssa P) (Wednesday 4pm))
;;; Query input:
(meeting-time (Aull DeWitt) (Wednesday . ?time))

;;; Query results:
(meeting-time (Aull DeWitt) (Wednesday 4pm))
;;; Query input:
(meeting-time (Aull DeWitt) (Monday . ?time))

;;; Query results:
(meeting-time (Aull DeWitt) (Monday 10am))
;;; Query input:

Exercise 4.60

２回表示されるのは出力例にある様に、Alyssaがperson-1に割り当てられてperson-2を探してCyを見つけた時と、Cyをperson-1に割り当ててAlyssaを見つけた時のどちらも表示されるから。
実際の結果

;;; Query input:
(lives-near ?person-1 ?person-2)

;;; Query results:
(lives-near (Aull DeWitt) (Reasoner Louis))
(lives-near (Aull DeWitt) (Bitdiddle Ben))
(lives-near (Reasoner Louis) (Aull DeWitt))
(lives-near (Reasoner Louis) (Bitdiddle Ben))
(lives-near (Hacker Alyssa P) (Fect Cy D))
(lives-near (Fect Cy D) (Hacker Alyssa P))
(lives-near (Bitdiddle Ben) (Aull DeWitt))
(lives-near (Bitdiddle Ben) (Reasoner Louis))
;;; Query input:

２回表示させるのを防ぐ方法。基本的には対象となるデータの順序を判断する事になる。何とか

1. 新しいデータを導入せず
2. 評価器に変更を加えず
3. このquery languageの文法内で出来ないものか

と考えたが、どうもlisp-valueに頼らざるを得ない感じ。
Racketのfoldrを使って半ば強引にシンボルのリストを文字列にして名前を比較。

;;; Query input:
(and (lives-near ?person-1 ?person-2)
     (lisp-value (lambda (a b) (define (conv name) (foldr string-append "" (map symbol->string name))) (string<? (conv a) (conv b))) ?person-1 ?person-2))

;;; Query results:
(and (lives-near (Aull DeWitt) (Reasoner Louis)) (lisp-value (lambda (a b) (define (conv name) (foldr string-append  (map symbol->string name))) (string<? (conv a) (conv b))) (Aull DeWitt) (Reasoner Louis)))
(and (lives-near (Aull DeWitt) (Bitdiddle Ben)) (lisp-value (lambda (a b) (define (conv name) (foldr string-append  (map symbol->string name))) (string<? (conv a) (conv b))) (Aull DeWitt) (Bitdiddle Ben)))
(and (lives-near (Fect Cy D) (Hacker Alyssa P)) (lisp-value (lambda (a b) (define (conv name) (foldr string-append  (map symbol->string name))) (string<? (conv a) (conv b))) (Fect Cy D) (Hacker Alyssa P)))
(and (lives-near (Bitdiddle Ben) (Reasoner Louis)) (lisp-value (lambda (a b) (define (conv name) (foldr string-append  (map symbol->string name))) (string<? (conv a) (conv b))) (Bitdiddle Ben) (Reasoner Louis)))
;;; Query input:

ただこれでは出力が見にくいので、新しいルールを作る。

;;; Query input:
(assert! (rule (lives-near-2 ?person-1 ?person-2)
               (and (address ?person-1 (?town . ?rest-1))
                    (address ?person-2 (?town . ?rest-2))
                    (not (same ?person-1 ?person-2))
                    (lisp-value (lambda (a b) (define (conv name) (foldr string-append "" (map symbol->string name))) (string<? (conv a) (conv b))) ?person-1 ?person-2))))

Assertion added to data base.
;;; Query input:
(lives-near-2 ?person-1 ?person-2)

;;; Query results:
(lives-near-2 (Aull DeWitt) (Reasoner Louis))
(lives-near-2 (Aull DeWitt) (Bitdiddle Ben))
(lives-near-2 (Fect Cy D) (Hacker Alyssa P))
(lives-near-2 (Bitdiddle Ben) (Reasoner Louis))
;;; Query input:

一応出来ているかな。

Logic as programs

Logical implicationは論理的含意？
パターン変数がルールの本文を満足しているとき、その変数の値はその結論を満足している。
これを使ってlogical deduction（論理的推論）が可能。

appendのルールをもう一度見直してみると、（appendを+と表記すると）

1. ()+?y=?yである。
2. ?v+?y=?zであるとき、(?u . ?v)+?y=(?u . ?z)である。

ルールの本体にappend-to-formが出て来ているので再帰的に適用している感じ。
第１引数のcdrをどんどん取って行って、最終的に空リストになると最初のルールを満足する。ここから再帰されていたルールを戻るイメージ。
つまり?vが空になったら、?uは最初のリストの最後の要素（?u0とする）。appendの結果?zはは(?u0 . ?y)。
その１段手前では、?uは最後から２番目の要素（?u1とする）。appendの結果は(?u1 . ?z)。ここの?zは前の段の結果なので(?u0 . ?y)だから、この段での?zは(?u1 . (?u0 . ?y))。
と言った具合。

;;; Query input:
(assert! (rule (append-to-form () ?y ?y)))
(assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
      (append-to-form ?v ?y ?z)))

Assertion added to data base.
;;; Query input:

Assertion added to data base.
;;; Query input:
(append-to-form (a b) (c d) ?z)

;;; Query results:
(append-to-form (a b) (c d) (a b c d))
;;; Query input:

未知数（数じゃないけど）を入力側に持って来る事も可能。ただこの動きはこの先を読まないと分からない。

;;; Query input:
(append-to-form (a b) ?y (a b c d))

;;; Query results:
(append-to-form (a b) (c d) (a b c d))
;;; Query input:
(append-to-form ?x ?y (a b c d))

;;; Query results:
(append-to-form (a b c d) () (a b c d))
(append-to-form () (a b c d) (a b c d))
(append-to-form (a) (b c d) (a b c d))
(append-to-form (a b) (c d) (a b c d))
(append-to-form (a b c) (d) (a b c d))
;;; Query input:

Exerise 4.61

中置記法も出来るのか。
(?x next-to ?y in (1 (2 3) 4))に対しては、?x=1、?y=(2 3)。
(?x next-to 1 in (2 1 3 1))に対しては、?x=2と予想。

;;; Query input:
(assert! (rule (?x next-to ?y in (?x ?y . ?u))))

Assertion added to data base.
;;; Query input:
(assert! (rule (?x next-to ?y in (?v . ?z))
      (?x next-to ?y in ?z)))

Assertion added to data base.
;;; Query input:
(?x next-to ?y in (1 (2 3) 4))

;;; Query results:
((2 3) next-to 4 in (1 (2 3) 4))
(1 next-to (2 3) in (1 (2 3) 4))
;;; Query input:
(?x next-to 1 in (2 1 3 1))

;;; Query results:
(3 next-to 1 in (2 1 3 1))
(2 next-to 1 in (2 1 3 1))
;;; Query input:

お、なるほど。3もありか。

Exercise 4.62

忘れ勝ちなのは結果が入る変数も引数の様に持つ必要がある事。なので変数（引数）はリストと要素。last-pairと言っても最後のconsペアの事なので、最後の要素とNilをポイントする最後のペアの事。
これまでと同じ感じで、

1. リストのcdrが空であれば、carが最後の要素
2. リストのcdrが空でなければ、cdrの最後の要素を探す

(rule (last-pair (?y . ()) ?y))
(rule (last-pair (?x . ?y) ?z)
      (last-pair ?y ?z))

実行結果

;;; Query input:
(last-pair (3) ?x)

;;; Query results:
(last-pair (3) 3)
;;; Query input:
(last-pair (1 2 3) ?x)

;;; Query results:
(last-pair (1 2 3) 3)
;;; Query input:
(last-pair (2 ?x) (3))

;;; Query results:
(last-pair (2 (3)) (3))
;;; Query input:
(last-pair ?x (3))

;;; Query results:. . user break
>

(last-pair ?x (3))に対しては答えが戻って来ない。
理屈としては3を最後の要素に持つ任意の長さのリストが?xに当てはまるので?xは確定しない。
具体的に考えると3の前に何を持って来るのかどうやって決めようとしているのか、どこでループにはまっているのかは実装の詳細を学ばないと分からない。

Exercise 4.63

子供とはsonで定義された子供と、妻の子供の両方があるのでson-ofと言うルールを作る。

(rule (son-of ?parent ?son)
      (or (son ?parent ?son)
          (and (wife ?parent ?mother)
               (son ?mother ?son))))

(rule (grand-son-of ?grand-father ?grand-son)
      (and (son-of ?grand-father ?father)
           (son-of ?father ?grand-son)))

実行結果

;;; Query input:
(grand-son-of Cain ?x)

;;; Query results:
(grand-son-of Cain Irad)
;;; Query input:
(son-of Lamech ?x)

;;; Query results:
(son-of Lamech Jubal)
(son-of Lamech Jabal)
;;; Query input:
(grand-son-of Methushael ?x)

;;; Query results:
(grand-son-of Methushael Jubal)
(grand-son-of Methushael Jabal)
;;; Query input:

SICP 4.3.3 Implementing the Amb Evaluator

ここで漸く実装部分。

ノート

普通のschemeの式であれば値が返るか、永久に返って来ないか、エラーで止まる。非決定論的schemeではそれに加えて行き止まりに辿り着いた時に選択ポイントまで戻って評価をやり直すと言う動作が追加される。
バックトラックを実装するのに評価と実行が混ざっている状態では尚更難しい事になる。

Execution procedures and continuations

ここのexecution procedureはanalyzeが返した手続き。
元のanalyzeが返す手続きの引数は環境ひとつのみ。amb評価器では環境に加えて成功したときの継続、失敗したときの継続の二つを引数に取る。

『継続』と言ってもここではcall-with-current-continutionとかを使う訳ではない。引数として手続きを渡すだけ。

評価をする各手続きは必ずどちらかの継続を呼ぶ事が前提で、呼び出し元の手続きに戻る事は想定されていない。この実行モデルでバックトラックを実現する。

成功継続は、値と失敗継続を受け取る。この継続はそのまま評価を続けるが、その先で受け取った値が評価に失敗する事が分かった時には受け取った失敗継続を呼び出す。

失敗継続は選択肢から別の値を選び、受け取った成功継続を呼び出す。成功継続には新たに選んだ値、その値で評価が失敗した時の失敗継続を渡す。ここで渡す失敗継続はまた別の値を選んで成功継続を呼び出すクロージャ。

amb構文で選択肢が無くなった時に評価の失敗が起きる。ここで失敗継続が呼ばれるが、これは直近の選択ポイントで作られた失敗継続が呼ばれ、新たな選択肢を選び直す事になる。入力からtry-againとタイプされた時も同じ挙動。

副作用を持つ操作の評価では、その先で評価に失敗した時の為に副作用を元に戻す為の失敗継続が用意される。この失敗継続は副作用を元に戻した後、最初に呼ばれた時の失敗継続を呼び出す。

失敗継続が作られるのは以下の3つ

1. amb構文
2. REPL
3. 代入構文

失敗継続が呼ばれるのは評価に失敗した時で以下の二つのケース

1. 空のambが評価されたとき
2. REPLでtry-againがタイプされたとき。

失敗継続が中継されるとき

1. 代入構文が作った失敗継続が呼ばれたとき。値を元に戻して元の失敗継続を呼び出す
2. amb構文が作った失敗継続が呼ばれて、それ以上選択肢が無くなったとき。元の失敗継続を呼び出す

Structure of the evaluator

新しい構文ambを導入。
evalはambevalと名前を変える。ambevalも環境と二つの継続を受け取りanalyzeが返して来た手続きをそれらに適用する。

成功継続は値と失敗継続を引数に取り、失敗継続には引数は無い。
評価手続きは必ず環境、成功継続、失敗継続を受け取り、最後に必ずどちらかの継続を呼び出す。呼び出し元に戻るとは考えない方が良い。スタックの状況がどうなるのか少し気になるが末尾再帰の最適化の様に実はスタックは食わないのかもしれない。

成功継続の呼び出しを普通の手続きからの戻り、失敗継続の呼び出しを例外を投げる様にイメージしても良いかもしれない。実際に戻り値と例外でも実装出来るのかも。

Simple expressions

基本的な評価手続きは値を返す代わりに値を受け取った成功継続に渡す手続きを返す。（この成功継続は基本的にはREPLから来ている筈）
特に失敗継続を用意する様な事は無いので、受け取った失敗継続をそのまま呼び出す成功継続に渡す。

変数が見つからないのはバグであって『評価の失敗』ではないので、errorを呼んで止まりバックトラックする訳ではない。

Conditionals and sequences

条件分岐は、条件部を呼び出すが戻って来た値で分岐する訳ではなく、その呼び出しに渡す成功継続の中で渡された値（条件部評価の結果）で判断するので、新たに成功継続を作る。
新たに作った成功継続でconsequent部、alternative部を呼び出す。ここの呼び出しで渡す成功継続は条件分岐の評価だ最初に受け取った成功継続だが、渡す失敗継続は条件評価から新たな成功継続が受け取った失敗継続を渡す事になる。その間に新しい失敗継続が作られているかもしれない。

シーケンスの場合、また二つの手続きを接続する手続きを数珠繋ぎにして評価結果として返す。
以前と違う所は一つ目の手続き（analyzeされた実行手続き）に新しい成功継続を渡す事。この成功継続から二つ目の手続きを呼び出す。
sequentiallyの引数aは最初はシーケンスの最初の式を実行する手続きだが、再帰で構築された最後の手続きではaは1〜n-1番目迄の式を実行する手続きでbが一番最後の手続きなので、シーケンス全体として受け取った成功継続を最後のbが受け取って呼び出せば良い。
一方失敗継続は式の実行途中で作られた場合にそれを呼び出す必要があるので、毎回成功継続が受け取った失敗継続をその次の呼び出しで渡す。

テキストにはEmpty sequenceのエラーの部分に対してelse部が無い。Racketではエラーとなるので、loopの呼び出しをelse部とする。

Definitions and assignments

defineでは値部を評価してその結果に名前を拘束する必要がある。なので、値部の評価に対して新しい成功継続を渡して、これが呼ばれたら新しい変数に割り当てて、元の成功継続を呼び出す。

前に出て来ている通り代入では失敗継続を作る。（これまでは受け取った失敗継続をそのまま渡していただけ）
最初のlambdaはanalyzeの結果として返す実行用手続き。
二番目のlambdaは値部評価の為の成功継続。この成功継続は変数の値を変更した後、続きの実行の為に上位から受け取った成功継続を呼び出すが、そこに新しい失敗継続を渡す。これが三番目のlambda。
新しい失敗継続はその先の実行で評価が失敗し、手前側の選択ポイント迄戻る途中。変更した変数の値を元に戻し、最初の成功継続が受け取った失敗継続を呼び出す。
上位から受け取った失敗継続は値部評価に渡され、この途中で評価に失敗した時に呼ばれる。

Procedure applications

aprocsはオペランド部を評価する手続きのリスト。
fprocは呼び出す手続きそのものではなく、指定された手続きを呼び出す手続き。なので引数は成功継続と失敗継続。
fprocは実際にはlambdaを評価するか変数テーブルから手続きを引っ張って来てそれを値として成功継続を呼び出す。

引数の評価結果を持つリストを用意するのにget-argsが呼ばれる。
get-argsはaprocsの先頭を呼び出す。ここで渡す成功継続は受け取った値をargsに追加して次の引数の評価をする為にget-argsを再帰呼び出しする。
get-argsはaprocが空になったら最初に渡された成功継続を呼び出す。これが実際の手続き呼び出しを行うexecute-applicationを呼び出す。

実際の手続きの呼び出しは継続の受け渡し以外は以前と変わらない。

Evaluating amb expressions

cprocsはambの選択肢一つ一つを評価する手続きのリスト。
try-nextは渡された選択肢の最初の値（）を評価する手続きを呼び出す。成功継続は上位から受け取った継続。
失敗継続は次の選択肢を以てtry-nextを呼び出す。
try-nextは選択した無くなったら上位から受け取った失敗継続を呼び出す。

Driver loop

ambevalに渡す成功継続は評価結果の値と失敗継続を受け取る。評価結果を表示した後internal-loopに引数として受け取った失敗継続を渡す。
internal-loopは入力がtry-againだった場合にはこの失敗継続を呼び出す。そうすると評価ポイント迄戻って別の選択肢でもう一度評価される。最初に渡した失敗継続が呼ばれる。最初に渡した失敗継続はinternal-loopは呼ばずに最初のdriver-loopを呼び出す。

スタックの事は考えずに成功継続、失敗継続を呼び出す、ループとしてinternal-loopやdriver-loopを呼び出すのはどこかgotoプログラミングを思わせる。規模が大きくなると手に負えなくなりそう。

Exercise 4.50

Racketのshaffleをありがたく使わせて頂き。

(define (ramb? exp) (tagged-list? exp 'ramb))
(define (analyze-ramb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-next choices)
        (if (null? choices)
            (fail)
            ((car choices) env
                           succeed
                           (lambda ()
                             (try-next (shuffle (cdr choices)))))))
      (try-next (shuffle cprocs)))))

やはりmaybe-extendがあると収拾がつかないくらい長い文章になってしまうので、シンプルな最初の文法だけで試す。

;;; Amb-Eval input:
;;; Amb-Eval input:
(parse-sentence)

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb studies))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb sleeps))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb eats))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb lectures))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun cat)) (prep-phrase (prep for) (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun student)) (prep-phrase (prep by) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun class)))))) (prep-phrase (prep with) (noun-phrase (simple-noun-phrase (article the) (noun cat)) (prep-phrase (prep to) (noun-phrase (noun-phrase (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun professor)))) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun student)))) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article a) (noun professor)) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun student)))))) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun class)))))))))) (prep-phrase (prep to) (noun-phrase (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep for) (noun-phrase (simple-noun-phrase (article a) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article a) (noun cat)))))) (prep-phrase (prep for) (noun-phrase (simple-noun-phrase (article the) (noun cat)) (prep-phrase (prep to) (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun student)) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun professor)))))))))) (verb studies))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun cat)) (prep-phrase (prep for) (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun student)) (prep-phrase (prep by) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun class)))))) (prep-phrase (prep with) (noun-phrase (simple-noun-phrase (article the) (noun cat)) (prep-phrase (prep to) (noun-phrase (noun-phrase (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun professor)))) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun student)))) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article a) (noun professor)) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun student)))))) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun class)))))))))) (prep-phrase (prep to) (noun-phrase (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep for) (noun-phrase (simple-noun-phrase (article a) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article a) (noun cat)))))) (prep-phrase (prep for) (noun-phrase (simple-noun-phrase (article the) (noun cat)) (prep-phrase (prep to) (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun student)) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun professor)))))))))) (verb sleeps))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun cat)) (prep-phrase (prep for) (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun student)) (prep-phrase (prep by) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun class)))))) (prep-phrase (prep with) (noun-phrase (simple-noun-phrase (article the) (noun cat)) (prep-phrase (prep to) (noun-phrase (noun-phrase (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun professor)))) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun student)))) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article a) (noun professor)) (prep-phrase (prep for) (simple-noun-phrase (article a) (noun student)))))) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun class)))))))))) (prep-phrase (prep to) (noun-phrase (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep for) (noun-phrase (simple-noun-phrase (article a) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article a) (noun cat)))))) (prep-phrase (prep for) (noun-phrase (simple-noun-phrase (article the) (noun cat)) (prep-phrase (prep to) (noun-phrase (noun-phrase (simple-noun-phrase (article a) (noun student)) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep for) (simple-noun-phrase (article the) (noun professor)))))))))) (verb eats))
;;; Amb-Eval input:

直ぐに長い文章になってしまうが、最初の４つは動詞をランダムな順番に選んでいる事が分かる。

Exercise 4.51

(define (analyze exp)
  (cond ((self-evaluating? exp) 
;…中略
        ((assignment? exp) (analyze-assignment exp))
        ((permanent-assignment? exp) (analyze-permanent-assignment exp))
;…以下省略

(define (permanent-assignment? exp)
  (tagged-list? exp 'permanent-set!))
(define (analyze-permanent-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc env
             (lambda (val fail2)
               (set-variable-value! var val env)
               (succeed 'ok fail2))
             fail))))

;;; Starting a new problem ;;; Amb-Eval value:
(a b 2)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(a c 3)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(b a 4)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(b c 6)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(c a 7)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(c b 8)
;;; Amb-Eval input:
try-again
;;; There are no more values of
(let ((x (an-element-of '(a b c))) (y (an-element-of '(a b c)))) (permanent-set! count (+ count 1)) (require (not (eq? x y))) (list x y count))
;;; Amb-Eval input:
(permanent-set! count 0)

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))

;;; Starting a new problem ;;; Amb-Eval value:
(a b 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(a c 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(b a 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(b c 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(c a 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(c b 1)
;;; Amb-Eval input:
try-again
;;; There are no more values of
(let ((x (an-element-of '(a b c))) (y (an-element-of '(a b c)))) (set! count (+ count 1)) (require (not (eq? x y))) (list x y count))
;;; Amb-Eval input:

set!だとバックトラックする度に元の値、ここでは0に戻してしまうので、表示される時には常に１。

Exercise 4.52

(define (analyze exp)
  (cond ((self-evaluating? exp) 
;…中略
        ((if? exp) (analyze-if exp))
        ((if-fail? exp) (analyze-if-fail exp))
;…以下省略

(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (if-fail-expression exp) (cadr exp))
(define (if-fail-failure exp) (caddr exp))
(define (analyze-if-fail exp)
  (let ((pproc (analyze (if-fail-expression exp)))
        (failed (analyze (if-fail-failure exp))))
    (lambda (env succeed fail)
      (pproc env
             succeed
             (lambda () (failed env succeed fail))))))

if-failの最初の式を評価した手続きをpproc、二番目の式を評価した手続きをfailedに拘束。
pprocを呼び出して、失敗しなかった場合にはそのままsuccessを呼び出して貰う。
失敗した場合には、failedを呼び出し、その結果をsuccessに受け継いでもらう事で評価結果としてREPLに戻される。
failedの呼び出しで何か失敗したら普通にfailを呼び出して貰う。

even?は定義出来なくもないが面倒なのでプリミティブとして登録。

;;; Amb-Eval input:
(define (require p) (if (not p) (amb)))
(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(if-fail (let ((x (an-element-of '(1 3 5))))
           (require (even? x))
           x)
         'all-odd)

;;; Starting a new problem ;;; Amb-Eval value:
all-odd
;;; Amb-Eval input:
(if-fail (let ((x (an-element-of '(1 3 5 8))))
           (require (even? x))
           x)
         'all-odd)

;;; Starting a new problem ;;; Amb-Eval value:
8
;;; Amb-Eval input:

Exercise 4.53

1. 最初pairsは空。
2. pにprime-sum-pairの最初の解が割り当てられる。
3. pairsの先頭にpが挿入される。
4. (amb)で強制的にバックトラックが起きてprime-sum-pairに戻る。
5. prime-sum-pairの候補が無くなってバックトラックが起きると、if-failのfail節に入ってpairsが返される。

もう一度prime-sum-pairを動かすのに必要な関数達を引っ張って来て。

;;; Amb-Eval input:
(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             (permanent-set! pairs (cons p pairs))
             (amb))
           pairs))

;;; Starting a new problem ;;; Amb-Eval value:
((8 35) (3 110) (3 20))
;;; Amb-Eval input:

と言う事で自動的にtry-againしてくれる。

Exercise 4.54

(define (analyze-require exp)
  (let ((pproc (analyze (require-predicate exp))))
    (lambda (env succeed fail)
      (pproc env
             (lambda (pred-value fail2)
               (if (not (true? pred-value))
                   (fail)
                   (succeed 'ok fail2)))
             fail))))

何故態々notを使って順番を入れ替えるのか？とも思うが、戻る方向が上、進む方向が下と言う事だろうか？
requireの定義無しに動作させてみる。

;;; Amb-Eval input:
(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(an-element-of '(1 2 3 4))

;;; Starting a new problem ;;; Amb-Eval value:
1
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
2
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
3
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
4
;;; Amb-Eval input:
try-again
;;; There are no more values of
(an-element-of '(1 2 3 4))
;;; Amb-Eval input:

期待通り動いている。

SICP 4.3.2 Examples of Nondeterministic Programs

ノート

非決定論的プログラムの例。
組み合わせ生成とフィルタリングする部分をシステム側に隠す事で、プログラムはより抽象化されて問題をストレートに表現出来る。

Logic Puzzles

『ニコリ』の推理パズル。
プリミティブにequal?を足してmemberを定義。absもプリミティブに足して実行。

;;; Amb-Eval input:
(define (require p) (if (not p) (amb)))
(define (member obj lst)
  (cond ((null? lst) #f)
        ((equal? obj (car lst)) lst)
        (else (member obj (cdr lst)))))
(define (distinct? items)
  (cond ((null? items) true)
        ((null? (cdr items)) true)
        ((member (car items) (cdr items)) false)
        (else (distinct? (cdr items)))))
(define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4 5))
        (cooper (amb 1 2 3 4 5))
        (fletcher (amb 1 2 3 4 5))
        (miller (amb 1 2 3 4 5))
        (smith (amb 1 2 3 4 5)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (> miller cooper))
    (require (not (= (abs (- smith fletcher)) 1)))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem ;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(multiple-dwelling)
;;; Amb-Eval input:

解は一つしか無いらしい。

Exercise 4.38

;;; Amb-Eval input:
(define (require p) (if (not p) (amb)))
(define (member obj lst)
  (cond ((null? lst) #f)
        ((equal? obj (car lst)) lst)
        (else (member obj (cdr lst)))))
(define (distinct? items)
  (cond ((null? items) true)
        ((null? (cdr items)) true)
        ((member (car items) (cdr items)) false)
        (else (distinct? (cdr items)))))
(define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4 5))
        (cooper (amb 1 2 3 4 5))
        (fletcher (amb 1 2 3 4 5))
        (miller (amb 1 2 3 4 5))
        (smith (amb 1 2 3 4 5)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (> miller cooper))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem ;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(multiple-dwelling)
;;; Amb-Eval input:

解は５個見つかる。

Exercise 4.39

全てのrequireは一塊に書いてあり、各条件はANDで結合されているのと等価なので、その順番によって答えが変わる事は無い。
requireに渡している条件式の評価に時間が掛かるものがある場合、その順番によって計算時間に影響がある。
テキストの例では一番時間が掛かると思われるdistinct?が最初に来ていて、これは全ての組み合わせに対して呼び出される。このdistinct?の呼び出し回数を減らす方が計算時間は短くなる筈。

ambevalの時間を計れる様にして試してみる。
distinct?を呼び出す回数を測りたいのだがset!はバックトラックが起きるともとの値に戻してしまうので計測が出来ない。
元のコードで計測。

;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
9380.698974609375 [msec]
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:

凡そ9.4秒掛かっている。
distinct?を最後にする。

(define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4 5))
        (cooper (amb 1 2 3 4 5))
        (fletcher (amb 1 2 3 4 5))
        (miller (amb 1 2 3 4 5))
        (smith (amb 1 2 3 4 5)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (require (> miller cooper))
    (require (not (= (abs (- smith fletcher)) 1)))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (list (list 'baker baker)
          (list 'cooper cooper)
          (list 'fletcher fletcher)
          (list 'miller miller)
          (list 'smith smith))))

実行結果

;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
3460.27490234375 [msec]
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:

凡そ3.5秒にまで速くなった。

元のコードではdistinct?を呼び出す回数は5⁵=3125回。
これがbacker!=5、cooper!=1、fetcher!=5、fetcher!=1、miller>cooperだけで、4×4×3×3×5=720回に減り、更に二つの条件で減っている筈である。

これまたtry-againに掛かった時間を計測するのが難しいので、ここでは最初の解が見つかる所までの時間しかはかれなかった。

Exercise 4.40

distinct?の手前では5⁵=3125通り。distinct?によって絞られて5!=120通り。

It is very inefficient to generate all possible assignments of people to floors and then leave it to backtracking to eliminate them.

veryかどうかの判断は難しいが、バックトラックに時間が掛かっている様であれば組み合わせの回数を減らすべき。

却下される事が予め分かっている様な組み合わせは最初から作らない方が得策。
baker!=5なので(amb 1 2 3 4)で良い。
cooperも同じく(amb 2 3 4 5)。
fletcherは(amb 2 3 4)。
millerはcooperより上の階なので(amb 3 4 5)、そうするとcooperは(amd 2 3 4)。
cooperが2では無い時には無駄な候補を生成してしまうので、cooperの階数からan-integer-betweenで生成する。
smithの条件はややこしいのでrequireを残すしか無い。
fletcherとcooperは互いが2階と4階の組み合わせが生成されるので、この組み合わせを却下する為にrequireは残す必要がある。
これでプログラムを作り直すと。

(define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4))
        (cooper (amb 2 3 4))
        (fletcher (amb 2 3 4))
        (smith (amb 1 2 3 4 5)))
    (let ((miller (an-integer-between (+ cooper 1) 5)))
      (require (not (= (abs (- smith fletcher)) 1)))
      (require (not (= (abs (- fletcher cooper)) 1)))
      (require
       (distinct? (list baker cooper fletcher miller smith)))
      (list (list 'baker baker)
            (list 'cooper cooper)
            (list 'fletcher fletcher)
            (list 'miller miller)
            (list 'smith smith)))))

実行する。

;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
1005.8408203125 [msec]
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
943.3330078125 [msec]
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem 
966.682861328125 [msec]
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:
try-again

25439.947021484375 [msec]
;;; There are no more values of
(multiple-dwelling)
;;; Amb-Eval input:

１秒前後くらいで答えが出るので10倍くらい速くなった。

based upon generating only those possibilities that are not already ruled out by previous restrictions.

と言う意味ではmillerの部分しか応えていない。そもそも自明な部分を最初から削除するだけで随分速くなる。

Exercise 4.41

2.2.3のNested Mappingsで登場するpermutationsを利用する。これで1〜5の全ての組み合わせを生成する。この組を(backer cooper fletcer miller smith)の住んでいる階を表しているものとして条件でフィルターする。最初の組み合わせの時点で重複は無いのでdistinct?の条件は不要。

(define (multiple-dwelling)
  (define (backer a) (car a))
  (define (cooper a) (cadr a))
  (define (fletcher a) (caddr a))
  (define (miller a) (cadddr a))
  (define (smith a) (cadddr (cdr a)))
  (filter (lambda (a)
            (and (not (= 5 (backer a)))
                 (not (= 1 (cooper a)))
                 (not (= 5 (fletcher a)))
                 (not (= 1 (fletcher a)))
                 (> (miller a) (cooper a))
                 (not (= (abs (- (smith a) (fletcher a))) 1))
                 (not (= (abs (- (fletcher a) (cooper a))) 1))))
          (permutations '(1 2 3 4 5))))

実行結果

> (multiple-dwelling)
'((3 2 4 5 1))
> (map (lambda (name floor) (list name floor))
       '(backer cooper fletcher miller smith)
       (car (multiple-dwelling)))
'((backer 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
> 

Exercise 4.42

Kittyは2番、Maryは4番との記述しか無いが、これが正しいとは限らない。同様にそれぞれ自分の順位と他人一人の順位を述べているが、どちらの記述が正しいかは分からないので、記述から取り得る順位を絞り込むのは難しそう。
次に記述のどちらかしか正しくない事をどう表現するのかと考えたら、xorを使ってrequireすれば良いらしい。条件が二つとも揃ったらfalseで、どちらか片方だけtrueの時にtrueになる。
R5RSにxorは無い様だが、Racketにはあるのでちょっと甘えてプリミティブに登録。

(define (lairs)
  (let ((betty (amb 1 2 3 4 5))
        (ethel (amb 1 2 3 4 5))
        (joan (amb 1 2 3 4 5))
        (kitty (amb 1 2 3 4 5))
        (mary (amb 1 2 3 4 5)))
    (require (xor (= kitty 2) (= betty 3)))
    (require (xor (= ethel 1) (= joan 2)))
    (require (xor (= joan 3) (= ethel 5)))
    (require (xor (= kitty 2) (= mary 4)))
    (require (xor (= mary 4) (= betty 1)))
    (require
     (distinct? (list betty ethel joan kitty mary)))
    (list (list 'Betty betty)
          (list 'Ethel ethel)
          (list 'Joan joan)
          (list 'Kitty kitty)
          (list 'Mary mary))))

プログラムは全く問題文そのままなので驚く。付け足したのは『当たり前だけど必要』なdistinct?のみ。
実行結果。

;;; Amb-Eval input:
(lairs)

;;; Starting a new problem ;;; Amb-Eval value:
((Betty 3) (Ethel 5) (Joan 2) (Kitty 1) (Mary 4))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(lairs)
;;; Amb-Eval input:

Ethelが一番の大嘘つき。

Exercise 4.43

問題文をそのままrequireの条件文に翻訳してみると

    (require (eq? (father 'Mary-Ann) 'Moore))
    (require (not (eq? (daughter 'Moore) (yacht-name 'Moore))))
    (require (not (eq? (daughter 'Downing) (yacht-name 'Downing))))
    (require (not (eq? (daughter 'Hall) (yacht-name 'Hall))))
    (require (not (eq? (daughter 'Barnacle) (yacht-name 'Barnacle))))
    (require (not (eq? (daughter 'Parker) (yacht-name 'Parker))))
    (require (eq? (yacht-name 'Barnacle) 'Gabrielle))
    (require (eq? (yacht-name 'Moore) 'Lorna))
    (require (eq? (yacht-name 'Hall) 'Rosalind))
    (require (eq? (yacht-name 'Downing) 'Melissa))
    (require (eq? (father 'Melissa) 'Barnacle))
    (require (eq? (yacht-name (father 'Gabrielle)) (daughter 'Parker)))

こんな感じ。
このfather、yacht-name、daughterの3つの関数がサポート出来るデータ構造を考える。

(define (find proc lst)
  (cond ((null? lst) #f)
        ((proc (car lst)) (car lst))
        (else (find proc (cdr lst)))))
(define (assq obj lst)
  (find (lambda (f) (eq? (car f) obj)) lst))

(define (lornas-father)
  (let ((data (list (list 'Moore    (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa)))
                    (list 'Downing  (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa)))
                    (list 'Hall     (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa)))
                    (list 'Barnacle (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa)))
                    (list 'Parker   (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa))))))
    (define (daughter name) (car (car (cdr (assq name data)))))
    (define (yacht-name name) (car (cdr (car (cdr (assq name data))))))
    (define (father name) (car (find (lambda (f) (eq? (car (car (cdr f))) name)) data)))
    (require
     (distinct? (list (daughter 'Moore) (daughter 'Downing) (daughter 'Hall) (daughter 'Barnacle) (daughter 'Parker))))
    (require (eq? (father 'Mary-Ann) 'Moore))
    (require (not (eq? (daughter 'Moore) (yacht-name 'Moore))))
    (require (not (eq? (daughter 'Downing) (yacht-name 'Downing))))
    (require (not (eq? (daughter 'Hall) (yacht-name 'Hall))))
    (require (not (eq? (daughter 'Barnacle) (yacht-name 'Barnacle))))
    (require (not (eq? (daughter 'Parker) (yacht-name 'Parker))))
    (require (eq? (yacht-name 'Barnacle) 'Gabrielle))
    (require (eq? (yacht-name 'Moore) 'Lorna))
    (require (eq? (yacht-name 'Hall) 'Rosalind))
    (require (eq? (yacht-name 'Downing) 'Melissa))
    (require (eq? (father 'Melissa) 'Barnacle))
    (require (eq? (yacht-name (father 'Gabrielle)) (daughter 'Parker)))
    (father 'Lorna)))

ただ、これは流石に無駄が多くいつまで経っても実行が終わらない。
分かりきっている条件は削る。

(define (lornas-father)
  (let ((data (list (list 'Moore    (list 'Mary-Ann 'Lorna))
                    (list 'Downing  (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) 'Melissa))
                    (list 'Hall     (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) 'Rosalind))
                    (list 'Barnacle (list 'Melissa 'Gabrielle))
                    (list 'Parker   (list (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa) (amb 'Mary-Ann 'Gabrielle 'Lorna 'Rosalind 'Melissa))))))
    (define (daughter name) (car (car (cdr (assq name data)))))
    (define (yacht-name name) (car (cdr (car (cdr (assq name data))))))
    (define (father name) (car (find (lambda (f) (eq? (car (car (cdr f))) name)) data)))
    (require
     (distinct? (list (daughter 'Moore) (daughter 'Downing) (daughter 'Hall) (daughter 'Barnacle) (daughter 'Parker))))
    (require (not (eq? (daughter 'Downing) (yacht-name 'Downing))))
    (require (not (eq? (daughter 'Hall) (yacht-name 'Hall))))
    (require (not (eq? (daughter 'Barnacle) (yacht-name 'Barnacle))))
    (require (not (eq? (daughter 'Parker) (yacht-name 'Parker))))
    (require (eq? (yacht-name (father 'Gabrielle)) (daughter 'Parker)))
    (father 'Lorna)))

実行結果。

;;; Amb-Eval input:
(lornas-father)

;;; Starting a new problem ;;; Amb-Eval value:
Downing
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
Downing
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
Downing
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
Downing
;;; Amb-Eval input:
try-again
;;; There are no more values of
(lornas-father)
;;; Amb-Eval input:

何か条件を削り過ぎたのか、他の部分の解は確認していないが、この結果は4通りの解があるが、何れにしてもLornaの父はDowningである。

Exercise 4.44

色々と使えない標準手続きがあるのでExercise 2.42とは少し違う解き方をする。

1. ボードのサイズを引数に開始
2. 一つの列を作る手続きを呼ぶ
   1. an-integer-betweenを使ってクイーンの位置を決める←ここがamb
   2. その位置からの手筋にそれまでに置いたクイーンが乗っていないかをチェックする←ここがrequire
   3. （手筋に乗っていなければ）その列の位置として再帰する

と言う考え方。
手筋のチェック（safe）も単純で、１列ずつ戻りながら手筋にクイーンが乗っていないかをチェックするだけ。orの構文を作っていないのでcondで条件を全部並べる。

(define (safe? pos board)
  (define (attack a b c board)
    (if (null? board)
        #t
        (let ((q (car (cdr (car board)))))
          (cond ((= a q) #f)
                ((= b q) #f)
                ((= c q) #f)
                (else (attack (- a 1) b (+ c 1) (cdr board)))))))
  (attack (- pos 1) pos (+ pos 1) board))
  
(define (queens n)
  (define (add-row k board)
    (if (= k 0)
        board
        (let ((pos (an-integer-between 1 n)))
          (require (safe? pos board))
          (add-row (- k 1)
                   (cons (list k pos)
                         board)))))
  (add-row n null))

実行結果

;;; Amb-Eval input:
(queens 4)

;;; Starting a new problem ;;; Amb-Eval value:
((1 3) (2 1) (3 4) (4 2))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 2) (2 4) (3 1) (4 3))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(queens 4)
;;; Amb-Eval input:
(queens 5)

;;; Starting a new problem ;;; Amb-Eval value:
((1 4) (2 2) (3 5) (4 3) (5 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 3) (2 5) (3 2) (4 4) (5 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 5) (2 3) (3 1) (4 4) (5 2))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 4) (2 1) (3 3) (4 5) (5 2))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 5) (2 2) (3 4) (4 1) (5 3))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 1) (2 4) (3 2) (4 5) (5 3))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 2) (2 5) (3 3) (4 1) (5 4))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 1) (2 3) (3 5) (4 2) (5 4))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 3) (2 1) (3 4) (4 2) (5 5))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 2) (2 4) (3 1) (4 3) (5 5))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(queens 5)
;;; Amb-Eval input:
(queens 6)

;;; Starting a new problem ;;; Amb-Eval value:
((1 5) (2 3) (3 1) (4 6) (5 4) (6 2))
;;; Amb-Eval input:
(queens 7)

;;; Starting a new problem ;;; Amb-Eval value:
((1 6) (2 4) (3 2) (4 7) (5 5) (6 3) (7 1))
;;; Amb-Eval input:
(queens 8)

;;; Starting a new problem ;;; Amb-Eval value:
((1 4) (2 2) (3 7) (4 3) (5 6) (6 8) (7 5) (8 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 5) (2 2) (3 4) (4 7) (5 3) (6 8) (7 6) (8 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 3) (2 5) (3 2) (4 8) (5 6) (6 4) (7 7) (8 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 3) (2 6) (3 4) (4 2) (5 8) (6 5) (7 7) (8 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((1 5) (2 7) (3 1) (4 3) (5 8) (6 6) (7 4) (8 2))
;;; Amb-Eval input:

４×４で鏡像関係を含めて2解、５×５では10解。８×８でもそれぞれの解は数秒程度で出て来る。96解もあるので以下省略。

Parsing natural language

自然言語処理。
名詞、動詞、冠詞のリストを用意。
文章は以下の様に表現出来る。

(sentence (noun-phrase (article the) (noun cat))
          (verb eats)

これは手続き呼び出しではなく全部シンボルのリスト。
文をパースする手続きparse-sentenceは「シンボルsentenceと名詞句、動詞をパースした結果」と定義する。
名詞句をパースする手続きparse-noun-phraseは「シンボルnoun-phraseと、冠詞、名詞をパースした結果」と定義する。
パースを始める時に文章は*unparsed*にセットされる。
parse-wordは*unparsed*の先頭の単語をword-listから見つけて、その品詞と見つけた単語をリストにする。ここ迄の所ambのバックトラックは使っていない。
自前でmemqを定義して実行してみる。

;;; Amb-Eval input:
(parse '(the cat eats))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun cat)) (verb eats))
;;; Amb-Eval input:

parse-sentenceの(parse-word verbs)の部分を(parse-verb-phrase)に拡張。

parse-verb-phrase内のmaybe-extendは最初は(parse-word verbs)の結果（期待しているのは('verb 'eats)とか）をambの候補として、失敗したらタグをverb-phraseに切り替えて、引数としてprepositional-phraseのパース結果を加えてmaybe-extendを呼び直す。prepositional-phraseは前置詞+名詞で一致したものが返って来るので、この部分は動詞で終わっているか、オプションとして「前置詞付きの目的語」にも一致する様になっている。

名詞句も同様に前置詞付きの形容詞句をオプショナルで付ける。

;;; Amb-Eval input:
(parse '(the student with the cat sleeps in the class))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))) (verb-phrase (verb sleeps) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))
;;; Amb-Eval input:
(parse '(the professor lectures to the student with the cat))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student)))) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb lectures) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures to the student with the cat))
;;; Amb-Eval input:

二つ目の文章は、二つの解釈が出来る事が示されている。動詞「lectures」に一塊の名詞句「to the student with the cat」が付いていると言う解釈と、動詞句「lectures to the student」に副詞句「with the cat」が付いていると言う解釈。

Exercise 4.45

実行結果。

;;; Amb-Eval input:
(parse '(the professor lectures to the student in the class with the cat))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student)))) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student)))) (prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb lectures) (prep-phrase (prep to) (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb lectures) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures to the student in the class with the cat))
;;; Amb-Eval input:

括弧を整理すると
(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb-phrase
(verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
|

要は目的語部分のグルーピングの問題。
lecturesの目的語はto the studentのみ。それに副詞句in the classが付き全体で動詞句を形成。その動詞句にwith the catと言う副詞句が付く。『教授は教室で猫を抱きながら生徒に教える。』

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
  (prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class))
                                      (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))

目的語は変わらないが、in the classとwith the catが一つの副詞句になっている。『教授は猫が住んでる教室で生徒に教える。』

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb-phrase (verb lectures)
               (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (noun student))
                                                   (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))))
  (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))

目的語としてto the studentとin the classがグループになった。『教授は猫を抱きながら教室内にいる生徒に教える。』

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb lectures)
  (prep-phrase (prep to) (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student))
                                                   (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
                                      (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))

目的語全体がthe student in the classとwith the catの両方にtoが付く形。『教授は教室内の生徒と猫に教える』

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb lectures)
  (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (noun student))
                                      (prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class)) 
                                                                          (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))))

the studentと言う目的語にin "the class with the cat"と言う副詞句。『教授は猫がいる教室にいる生徒に教える。』

Exercise 4.46

parse-sentence等で解釈後のリストを形成する時にparse-***と言う手続きを引数に並べているが、この引数の並びは文章に単語、あるいは句が出現する順番に一致しているので左から順に評価しないと文章が解釈出来ない。

Exercise 4.47

一旦は普通に解釈して、try-againが呼ばれて別の解釈をしようとして(parse-word verbs)が失敗したときが問題。ambは構文なので既にambの解釈に入っているので、(parse-word verbs)が失敗すると次に(parse-verb-phrase)を呼び出してしまう。これはまた(parse-word verbs)を呼び出して失敗してと無限ループに陥る。
元の定義では(phase-word verbs)がamb構文に入る前に呼ばれているので、ここで失敗するともっと前迄バックトラックする。
amb内の式の順番を入れ替えると、parse-verb-phaseに入って来ると最初にまた無条件にparse-verb-phraseを呼んでしまうので明らかに無限ループに陥る。

;;; Amb-Eval input:
(parse '(the cat eats))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun cat)) (verb eats))
;;; Amb-Eval input:
try-again
. . user break
> 

返って来ない。
順番を入れ替える。

(define (parse-verb-phrase)
  (amb (list 'verb-phrase
             (parse-verb-phrase)
             (parse-prepositional-phrase))
       (parse-word verbs)))

こういう事か？
動かしてみる。

;;; Amb-Eval input:
(parse '(the cat eats))

;;; Starting a new problem . . user break
> 

最初から全然返って来ない。

Exercise 4.48

副詞の追加は以下の通り。

(define (parse-verb-phrase)
  (define (maybe-extend verb-phrase)
    (amb verb-phrase
         (maybe-extend (list 'verb-phrase
                             verb-phrase
                             (parse-adverb-phrase)))))
  (maybe-extend (parse-word verbs)))

(define (parse-adverb-phrase)
  (amb (parse-word adverbs)
       (parse-prepositional-phrase)
       (list 'adverb-phrase
             (parse-word adverbs)
             (parse-prepositional-phrase))))

(define adverbs '(adverb enthusiastically))

動作確認。

;;; Amb-Eval input:
(parse '(the professor lectures))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb lectures))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures))
;;; Amb-Eval input:
(parse '(the professor lectures in the class))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb lectures) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures in the class))
;;; Amb-Eval input:
(parse '(the professor lectures enthusiastically))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb lectures) (adverb enthusiastically)))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures enthusiastically))
;;; Amb-Eval input:
(parse '(the professor lectures enthusiastically in the class))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb-phrase (verb lectures) (adverb enthusiastically)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb-phrase (verb lectures) (adverb-phrase (adverb enthusiastically) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures enthusiastically in the class))
;;; Amb-Eval input:

形容詞の追加。

(define (parse-simple-noun-phrase)
  (amb (list 'simple-noun-phrase
             (parse-word articles)
             (parse-word nouns))
       (list 'noun-with-adjective
             (parse-word articles)
             (parse-word adjectives)
             (parse-word nouns))))

(define adjectives '(adjective smart cute little))

動作確認。

;;; Amb-Eval input:
(parse '(the cat eats))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun cat)) (verb eats))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the cat eats))
;;; Amb-Eval input:
(parse '(the cute cat eats))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (noun-with-adjective (article the) (adjective cute) (noun cat)) (verb eats))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the cute cat eats))
;;; Amb-Eval input:
(parse '(the cute cat in the class eats))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (noun-phrase (noun-with-adjective (article the) (adjective cute) (noun cat)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))) (verb eats))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the cute cat in the class eats))
;;; Amb-Eval input:

複合文。andで繋いでもう一つ文章がある形。

(define (parse-sentence)
  (define (maybe-extend sentence)
    (amb sentence
         (maybe-extend (list 'compound-sentence
                             sentence
                             (parse-word conjunctions)
                             (parse-single-sentence)))))
  (maybe-extend (parse-single-sentence)))

(define (parse-single-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (parse-verb-phrase)))

(define conjnctions '(conjunction and))

動作確認

;;; Amb-Eval input:
(parse '(the professor lectures))

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun professor)) (verb lectures))
;;; Amb-Eval input:
(parse '(the professor lectures and the cat eats))

;;; Starting a new problem ;;; Amb-Eval value:
(compound-sentence (sentence (simple-noun-phrase (article the) (noun professor)) (verb lectures)) (conjunction and) (sentence (simple-noun-phrase (article the) (noun cat)) (verb eats)))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(parse '(the professor lectures and the cat eats))
;;; Amb-Eval input:

まぁ、この文法では駄目パターンが沢山ある訳だが。。。

Exercise 4.49

parse-wordはword-listの一致した単語をリストにして返していたが、word-listの中から順に選んで返す様にする。

;;; Amb-Eval input:
(parse-sentence)

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb studies))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(compound-sentence (sentence (simple-noun-phrase (article the) (noun student)) (verb studies)) (conjunction and) (sentence (simple-noun-phrase (article the) (noun student)) (verb studies)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(compound-sentence (compound-sentence (sentence (simple-noun-phrase (article the) (noun student)) (verb studies)) (conjunction and) (sentence (simple-noun-phrase (article the) (noun student)) (verb studies))) (conjunction and) (sentence (simple-noun-phrase (article the) (noun student)) (verb studies)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(compound-sentence (compound-sentence (compound-sentence (sentence (simple-noun-phrase (article the) (noun student)) (verb studies)) (conjunction and) (sentence (simple-noun-phrase (article the) (noun student)) (verb studies))) (conjunction and) (sentence (simple-noun-phrase (article the) (noun student)) (verb studies))) (conjunction and) (sentence (simple-noun-phrase (article the) (noun student)) (verb studies)))
;;; Amb-Eval input:

複合文が延々と続くので、複合文無しにする。

;;; Amb-Eval input:
(parse-single-sentence)

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb studies))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb-phrase (verb studies) (adverb enthusiastically)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb-phrase (verb-phrase (verb studies) (adverb enthusiastically)) (adverb enthusiastically)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb-phrase (verb-phrase (verb-phrase (verb studies) (adverb enthusiastically)) (adverb enthusiastically)) (adverb enthusiastically)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb-phrase (verb-phrase (verb-phrase (verb-phrase (verb studies) (adverb enthusiastically)) (adverb enthusiastically)) (adverb enthusiastically)) (adverb enthusiastically)))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (noun student)) (verb-phrase (verb-phrase (verb-phrase (verb-phrase (verb-phrase (verb studies) (adverb enthusiastically)) (adverb enthusiastically)) (adverb enthusiastically)) (adverb enthusiastically)) (adverb enthusiastically)))
;;; Amb-Eval input:

どうも、maybe-extendがあるとそこから抜け出せなくなる。
parse-sentenceとparse-noun-phaseを最初のに戻してみる。

;;; Amb-Eval input:
(parse-sentence)

;;; Starting a new problem ;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun student)) (verb studies))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun student)) (verb lectures))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun student)) (verb eats))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun student)) (verb sleeps))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun professor)) (verb studies))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun professor)) (verb lectures))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (noun-phrase (article the) (noun professor)) (verb eats))
;;; Amb-Eval input:

まぁこんな感じか。

SICP 4.3 Variations on a Scheme -- Nondeterministic Computing

ここは全く予備知識の無い分野。Prologへの布石の様に思える。

ノート

非決定論的コンピューティング？
評価器に「automatic search」を組み込む。遅延評価よりも言語に対して大きな変更となる。

非決定論的コンピューティングは『生成してテストする』タイプのアプリケーションに向いている。
これまでに二つの正の整数の和が素数となる組み合わせを探すやり方を二通り実装した。どちらにしても取り得る全ての組み合わせを生成して和が素数であるかを確認していた。組み合わせを作る部分は問題としては本質的な部分ではなかった。

『aはlist1のある数で、bはlist2のある数。このaとbに於いて(prime? (+ a b))を満足するaとbをリストにする』みたいなプログラム。

普通の言語の実行モデルではrequireの所で条件が成り立たなければ、別のa、bの組み合わせを生成してもう一度チェックする様なループ（もしくは再帰）で書かれていたが、非決定論的コンピューティングの実行モデルではrequireが成り立たないとaとbを選んだ所まで戻ってもう一度進む。

なので組み合わせも含めて値の候補を選ぶ部分と、失敗した時に候補を選び直す箇所まで逆戻りする仕組みを実行モデル自身が勝手にやってくれて、プログラムとして書く必要がない様なシステム。

非決定論的コンピューティングでは式が複数の値の候補を持っている。システムがその候補から一つ値を選び（どれを選んでどれが残っているのかはちゃんと管理して）式の評価を進めて、評価が失敗したら候補を選んだ所まで戻って来る仕組みをサポートする。

4.3.1 Amb and Search

The expression (amb ... ) returns the value of one of the n expressions ``ambiguously.''

ambiguously（曖昧に）とか言われても意味は分からない。要は、まずどれかを選んで返すので返す値は普通の値。ポイントは

1. 過去に選んだ候補、今選んだ候補、残っている候補は管理されている事
2. この先の式の評価が失敗した時にここまで戻って来るので、その時には残っている候補から値を選ぶ事

この仕組みがシステムによってサポートされる。値が返ってからは普通に式の評価が進む。

ambiguouslyと言う言葉は余り気にしないで読み進めた方が良さそう。

(list (amb 1 2 3) (amb 'a 'b))は６つの値を持つ可能性があるが、この式を評価した時に一遍に６つのペアに展開される訳ではない。まずどれかの組み合わせが出来てその先の式の評価に進む。もし式の評価が失敗するとここに戻って来る。

ambに値の候補が一つしか無いときはただの値と同じ。式の評価に失敗してここに戻って来ても他に候補は無いので更に前のambまで戻る事になる。

ambに値が無い状態は式の評価の失敗を意味する。つまり(amb)が評価された時点で直近のambで値を選んだ地点まで戻る事を意味する。

requireは述語をテストして失敗したら意図的に(amb)を評価してシステムに直近のambで値を選んだ地点まで逆戻りさせる。

（恐らく）ambはリストを引数に取れない（一つの値として扱ってしまう）。手続きではないのでapplyは使えない。なので、リストの中から候補を選ぶのにan-element-ofの様な手続きが必要になる。ambはまず(car items)を候補に選びその先の評価で失敗した場合には(an-element-of (cdr items))から候補を選ぶ。ambは構文なので引数は必ずしも直ぐには評価されず、ここで(an-element-of (cdr items))が評価されると思う。(cdr items)に候補が残っていればそこから値が選ばれるが、残っていなければrequireに失敗してもっと前方のamdの箇所まで戻る事になる。

an-integer-starting-fromはan-element-ofの(cdr items)の部分を(+ n 1)で毎回生成している状態。まずnを選び、失敗して戻って来たら(an-integer-starting-from (+ n 1))が呼ばれてn+1が選ばれる、と言う事を失敗して戻って来る度に繰り返す。an-integer-starting-fromと言う名前はストリームの時の様にn以降の全ての整数のリストの様に思えるが、n以降のどれか一つの値である。

amdが選択のポイントで、ここにプログラムが到達した時点で選択肢の数だけプロセス（かスレッド）をforkして（テキストはプロセッサの例で説明しているが）、それぞれのプロセスにひとつひとつの選択肢を割り当ててその後の計算を進める様にイメージしても良い。

あるいはamdに到達した時点で本当に適当に値を選んで評価を進める事も可能。だが、ここでは系統立てで候補を最初から順番に選んで、選んだ値がその先の評価で失敗した場合には選択したポイント（失敗した所から直近の選択ポイント）まで戻って（バックトラック）して残りの候補からまた選び直して成功するまで評価を続ける。ある選択ポイントに戻った時に候補が残っていなければ更に一つ前の選択ポイントまで戻る。この候補の探しかたは『深さ優先探索』（あるいはchronologycal backtrack：訳語は良く分からない）である。

これはforkしたプロセス達は取り敢えずサスペンドしておいて一つが失敗したら次のプロセスを進めるのと同じ事。メモリを共有するスレッドでは難しいがプロセスをforkするモデルは実装不可能ではないかも。システムのプロセス数の制限に引っ掛かるかもしれないけど。

Driver loop

amd評価器のdriver-loopは問題が与えられると成功した結果を表示する。ここでtry-againとタイプすると強制的に失敗した事にしてバックトラックして次の候補を試す。try-again以外をタイプすると前の問題は忘れて次の評価を始める。

ここで4.3.3節の実装を取り込む。実装の詳細は再び4.3.3節で検討する。4.1.7節のanalyzeを分離した実装をベースにするとの事だが、脚注にある様にletが実装されている事が前提なので、Exercise 4.22の結果をベーストする。

まずは動かしてみる。

;;; Amb-Eval input:
(amb 1 2 3)

;;; Starting a new problem ;;; Amb-Eval value:
1
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
2
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
3
;;; Amb-Eval input:
try-again
;;; There are no more values of
(amb 1 2 3)
;;; Amb-Eval input:
.

可変長引数をサポートしていないので、仕方が無いのでlistをプリミティブとして登録して。

;;; Amb-Eval input:
(list (amb 1 2 3) (amb 'a 'b))

;;; Starting a new problem ;;; Amb-Eval value:
(1 a)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(1 b)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(2 a)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(2 b)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(3 a)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(3 b)
;;; Amb-Eval input:
try-again
;;; There are no more values of
(list (amb 1 2 3) (amb 'a 'b))
;;; Amb-Eval input:
.

(amb 'a 'b)の方が後から評価されている事が分かる。
an-element-ofの動作確認。

;;; Amb-Eval input:
(define (require p)
  (if (not p) (amb)))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(an-element-of '(1 3 5 8))

;;; Starting a new problem ;;; Amb-Eval value:
1
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
3
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
5
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
8
;;; Amb-Eval input:
try-again
;;; There are no more values of
(an-element-of '(1 3 5 8))
;;; Amb-Eval input:
.

an-integer-starting-fromの動作確認。

;;; Amb-Eval input:
(an-integer-starting-from 10)

;;; Starting a new problem ;;; Amb-Eval value:
10
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
11
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
12
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
13
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
14
;;; Amb-Eval input:
.

比較演算子、not、remainderをプリミティブとして登録して。

;;; Amb-Eval input:
(define (square x)
   (* x x))
(define (divides? a b)
   (= (remainder b a) 0))
(define (find-divisor n test-divisor)
   (cond ((> (square test-divisor) n) n)
         ((divides? test-divisor n) test-divisor)
         (else (find-divisor n (+ test-divisor 1)))))
(define (smallest-divisor n)
   (find-divisor n 2))
(define (prime? n)
   (= n (smallest-divisor n)))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(define (require p)
  (if (not p) (amb)))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(define (prime-sum-pair list1 list2)
  (let ((a (an-element-of list1))
        (b (an-element-of list2)))
    (require (prime? (+ a b)))
    (list a b)))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(prime-sum-pair '(1 3 5 8) '(20 35 110))

;;; Starting a new problem ;;; Amb-Eval value:
(3 20)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(3 110)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(8 35)
;;; Amb-Eval input:
try-again
;;; There are no more values of
(prime-sum-pair '(1 3 5 8) '(20 35 110))
;;; Amb-Eval input:
(prime-sum-pair '(19 27 30) '(11 36 58))

;;; Starting a new problem ;;; Amb-Eval value:
(30 11)
;;; Amb-Eval input:
.

Exercise 4.35

(define (an-integer-between min max)
  (require (<= min max))
  (amb min (an-integer-between (+ min 1) max)))

requireで条件をつけてあげればOK。
動作確認。

;;; Amb-Eval input:
(define (an-integer-between min max)
  (require (<= min max))
  (amb min (an-integer-between (+ min 1) max)))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(an-integer-between 10 15)

;;; Starting a new problem ;;; Amb-Eval value:
10
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
11
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
12
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
13
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
14
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
15
;;; Amb-Eval input:
try-again
;;; There are no more values of
(an-integer-between 10 15)
;;; Amb-Eval input:

ピタゴラス数を探す。

;;; Amb-Eval input:
(define (a-pythagorean-triple-between low high)
  (let ((i (an-integer-between low high)))
    (let ((j (an-integer-between i high)))
      (let ((k (an-integer-between j high)))
        (require (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

;;; Starting a new problem ;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(a-pythagorean-triple-between 1 20)

;;; Starting a new problem ;;; Amb-Eval value:
(3 4 5)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(5 12 13)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(6 8 10)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(8 15 17)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(9 12 15)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(12 16 20)
;;; Amb-Eval input:
try-again
;;; There are no more values of
(a-pythagorean-triple-between 1 20)
;;; Amb-Eval input:
.

Exercise 4.36

組み合わせi、j、kを生成してrequireで失敗した時にはkを選び直す事になる。an-integer-betweenを使っている時にはkが上限に達するとjを選び直す。これを繰り返して更にjが上限に達するとiを選び直している。
ところがan-integer-starting-fromを使うとkを選び直す時に上限が無いので、kだけを更新してiとjは永久に更新されないので上手く動作しない。

requireを増やしてもバックトラックがkのambより前には戻らない。なのでiだけは上限無しにして、jとkはiに関連づけて上限を決める。
iとjは交換可なので1<=j<=iとする。kの最小値は√2iだがここではi<=k<=2iとする。

(define (a-pythagorean-triple)
  (let ((i (an-integer-starting-from 1)))
    (let ((j (an-integer-between 1 i)))
      (let ((k (an-integer-between i (* 2 i))))
        (require (= (+ (* i i) (* j j)) (* k k)))
        (list i j k)))))

実行結果

;;; Amb-Eval input:
(a-pythagorean-triple)

;;; Starting a new problem ;;; Amb-Eval value:
(4 3 5)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(8 6 10)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(12 5 13)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(12 9 15)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(15 8 17)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(16 12 20)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(20 15 25)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(21 20 29)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(24 7 25)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(24 10 26)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(24 18 30)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(28 21 35)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(30 16 34)
;;; Amb-Eval input:

Exercise 4.37

こちらの方が効率は良い筈。そもそも組み合わせとして二組の数しか扱っていないのでkを走査しない分、効率は良い。
実際の計算速度の観点で、最初のrequireで余計なkは生成しない様にして「フレームを作る」「平方根を取る」「integer?」の分だけ節約しているとも言えるが、その為に「hsqの計算」「ksqの計算」「require」が増えているのでこれに関しては微妙。

SICP 4.2.3 Streams as Lazy Lists

ノート

遅延リストとしてのストリーム。

3.5.1節で導入したストリームはdelay、cons-streamと言う構文を使ってストリームを作ったため、ストリームには普通のリスト用の手続きは使えず、ストリーム用の手続きを使う必要があった。
遅延評価のシステムではこれらを区別する必要は無い。
プリミティブからcons、car、cdrを除いて、（null?とnullは足して）実行してみる。

> (driver-loop)

;;; L-Eval input:
(define (cons x y)
  (lambda (m) (m x y)))
(define (car z)
  (z (lambda (p q) p)))
(define (cdr z)
  (z (lambda (p q) q)))
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
(define (list-ref items n)
  (if (= n 0)
      (car items)
      (list-ref (cdr items) (- n 1))))
(define (map proc items)
  (if (null? items)
      '()
      (cons (proc (car items))
            (map proc (cdr items)))))
(define (scale-list items factor)
  (map (lambda (x) (* x factor))
       items))
(define (add-lists list1 list2)
  (cond ((null? list1) list2)
        ((null? list2) list1)
        (else (cons (+ (car list1) (car list2))
                    (add-lists (cdr list1) (cdr list2))))))
(define ones (cons 1 ones))
(define integers (cons 1 (add-lists ones integers)))
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
(list-ref integers 17)
;;; L-Eval value:
18
;;; L-Eval input:
(define (integral integrand initial-value dt)
  (define int
    (cons initial-value
          (add-lists (scale-list integrand dt)
                    int)))
  int)
(define (solve f y0 dt)
  (define y (integral dy y0 dt))
  (define dy (map f y))
  y)
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
(list-ref (solve (lambda (x) x) 1 0.001) 1000)
;;; L-Eval value:
2.716923932235896
;;; L-Eval input:
.

(list-ref integers 17)の挙動を正確に把握するのはかなり難しい。
list-refはnが0になるまで再帰的に呼び出され、その結果は(car (cdr (cdr ... (cdr integers) ...)))となる。
ここで、(car integers)は1
(car (cdr integers)は(add-list ones integers)で、これは(+ (car ones) (car integers))
(car (cdr (cdr integers)は(car (cdr (add-lists ones inegers)))で、これは(car (add-lists (cdr ones) (cdr integers)))なので(+ (car (cdr ones)) (car (cdr integers)))
と言った具合なので、list-refの結果を評価するには最後の足し算のオペランド部分でonesとintegersのリストを一旦先頭に向かって辿り、足し算をしながらまた戻って来る。

Exercise 4.32

脚注41にある様に、3章のストリームよりも更にlazyなのはcarの部分も遅延している事であり、その利点はtreeの様にcar以下にも無限に延びるtreeが構築出来る事。

treeが例だからこれで良しとするか、実際に動くtreeを構築するか迷う所。

Exercise 4.33

エラーを再現する。

> (driver-loop)

;;; L-Eval input:
(define (cons x y)
  (lambda (m) (m x y)))
(define (car z)
  (z (lambda (p q) p)))
(define (cdr z)
  (z (lambda (p q) q)))
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
;;; L-Eval value:
ok
;;; L-Eval input:
(car '(a b c))
. . Unknown procedure type -- APPLY-PROC (a b c)
> 

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (eval-quotation exp env))
;…以下省略

(define (eval-quotation exp env)
  (let ((item (cadr exp)))
    (if (pair? item)
        (eval (list 'cons
                    (list 'quote (car item))
                    (list 'quote (cdr item)))
              env)
        item)))

cons、car、cdrをプリミティブではない手続きにしているのに、評価器がこれらの手続きに依存する事に非常に違和感を覚えるが、仕方ないのか？最低でもconsだけは遅延されるプリミティブとして最初から評価器に組み込まれていると考えれば良いのか。
動作確認

;;; L-Eval input:
'(a b c)
;;; L-Eval value:
(compound-procedure (m) ((m x y)) <procedure-env>)
;;; L-Eval input:
(car '(a b c))
;;; L-Eval value:
a
;;; L-Eval input:
(cdr '(a b c))
;;; L-Eval value:
(compound-procedure (m) ((m x y)) <procedure-env>)
;;; L-Eval input:
(car (cdr '(a b c)))
;;; L-Eval value:
b
;;; L-Eval input:
.

どうも引用符の扱いがややこしい。どうやら入力やら表示の段階でシステムが色々と変換してしまうので混乱している。'(a b c)と入力しても内部では(quote (a b c))と書き替わっている模様。でtext-of-quotationでexpを表示しても'(a b c)と表示される。入力に(quote (a b c))とタイプしてもtext-of-quotationでexpを表示すると'(a b c)と表示される。

Exercise 4.34

前の実行例にもあった様にconsペアはuser-printで少し整形されて手続きとして表示される。

;;; L-Eval input:
(cons 1 2)
;;; L-Eval value:
(compound-procedure (m) ((m x y)) <procedure-env>)
;;; L-Eval input:

つまり、consペアの場合はuser-printでcarとcdrのactual-valueを表示すると言う事。
その為には普通の手続きとconsペアの手続きの区別がつかなければならない。

ネットで調べた回答には、consに対してはlambdaではなくlist-lambdaと言う構文を使うと言うもの。これはprocedureの代わりにlist-procedureと言うタグを作る。compound-procedure?がどちらも手続きだと認識しさえすれば評価に関しての影響は少ない。表示させたいが為に新しい構文を導入するのはどうかと思う一方、consだけは遅延されるプリミティブとして扱うと言う事であればこれも有りかもしれない。
更にどうぜconsだけは遅延されるプリミティブとして特別扱いするのであれば、ネットでもう一つ見つけた回答の「表示させる時に手続きの本体が(lambda (m) (m x y))だったらconsとみなす」と言う回答もかなり強引だけどありだと思う。

全く同じ回答も芸がないので、the-global-environmentからconsを探して、それと一致した手続きをconsとみなす事にする。

apply-procを呼び出す時に評価から戻って来たconsは'procedureで始まるオブジェクトだがapply-procが期待しているのは対象Lispの式なのでこれをもう一度lambda式に戻してあげる必要が有る。そうしないとprocedureと言う手続きを呼び出そうとする。lambdaで始まるリストはevalでprocedureに変換されて、もういちどちゃんと評価される。

(eval '(define **max-print-depth** 5) the-global-environment)

(define (user-print object)
  (if (compound-procedure? object)
      (display (if (cons? object)
                   (cons->list object (lookup-variable-value '**max-print-depth** the-global-environment))
                   (list 'compound-procedure
                         (procedure-parameters object)
                         (procedure-body object)
                         '<procedure-env>)))
      (display object)))

(eval '(define (cons x y)
         (lambda (m) (m x y))) the-global-environment)
(eval '(define (car z)
         (z (lambda (p q) p))) the-global-environment)
(eval '(define (cdr z)
         (z (lambda (p q) q))) the-global-environment)

(define (cons? exp)
  (if (compound-procedure? exp)
      (let ((cons-def (car (procedure-body (lookup-variable-value 'cons the-global-environment)))))
        (and (equal? (procedure-parameters exp)
                     (procedure-parameters cons-def))
             (equal? (car (procedure-body exp))
                     (procedure-body cons-def))))
      #f))

(define (cons? exp)
  (if (compound-procedure? exp)
      (let ((cons-def (car (procedure-body (lookup-variable-value 'cons the-global-environment)))))
        (and (equal? (procedure-parameters exp)
                     (procedure-parameters cons-def))
             (equal? (car (procedure-body exp))
                     (procedure-body cons-def))))
      #f))
  
(define (cons->list object count)
  (define (evaluate proc operand)
    (force-it 
     (apply-proc (actual-value proc the-global-environment)
                 (list (make-lambda (procedure-parameters operand)
                                    (procedure-body operand)))
                 (procedure-environment operand))))
  (define (expand-cons x n)
    (if (cons? x)
        (if (eq? n 0)
            '(...)
            (cons->list x n))
        x))
  (cons (expand-cons (evaluate 'car object) (- count 1))
        (expand-cons (evaluate 'cdr object) (- count 1))))

表示する深さもthe-global-environmentに定義する事にした。
動作確認

;;; L-Eval input:
'(1 2)
;;; L-Eval value:
(1 2)
;;; L-Eval input:
(cons 1 2)
;;; L-Eval value:
(1 . 2)
;;; L-Eval input:
(define ones (cons 1 ones))
;;; L-Eval value:
ok
;;; L-Eval input:
ones
;;; L-Eval value:
(1 1 1 1 1 ...)
;;; L-Eval input:
(define (add-lists list1 list2)
  (cond ((null? list1) list2)
        ((null? list2) list1)
        (else (cons (+ (car list1) (car list2))
                    (add-lists (cdr list1) (cdr list2))))))
;;; L-Eval value:
ok
;;; L-Eval input:
(define integers (cons 1 (add-lists ones integers)))
;;; L-Eval value:
ok
;;; L-Eval input:
integers
;;; L-Eval value:
(1 2 3 4 5 ...)
;;; L-Eval input:
**max-print-depth**
;;; L-Eval value:
5
;;; L-Eval input:
(define **max-print-depth** 10)
;;; L-Eval value:
ok
;;; L-Eval input:
**max-print-depth**
;;; L-Eval value:
10
;;; L-Eval input:
integers
;;; L-Eval value:
(1 2 3 4 5 6 7 8 9 10 ...)
;;; L-Eval input:
.

こことSICP Exercise 4.34 | Weiqun Zhang's Blog
ここMentioned In Dispatches: SICP Section 4.2 Variations on a Scheme -- Lazy Evaluation
を参考にさせて戴きました。