プログラミング再入門

プログラミングをもう一度ちゃんと勉強する読書ノート

SICP 4.4.4 Implementing the Query System

LISP Scheme

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:エラー処理を呼び出し側に任せるのは例外処理に似ている？