問題4.55-4.57

sicp

論理型プログラミングの例として質問言語を作ります。先に実装しておきました。
なお、実装の時の注意点で、execute手続きを作るときに使うuser-initial-environmentは処理系依存(MIT Schemeにある)みたいです。ググって他の方のを参考にするとinteraction-environmentを使っているみたいで、僕の処理系にもあったのでこれを使います。user-initial-environmentは変数ですがinteraction-environmentは無引数手続きみたいなので注意。

規則や表明を毎回書くのはたるいので、こんなのを用意しておきます。

(define (pre-add-rule-or-assertion! exp)
  (let ((q (query-syntax-process exp)))
    (add-rule-or-assertion! q)))
(define (pre-add-rules-or-assertions! lst)
  (map pre-add-rule-or-assertion! lst)
  'ok)

これで、

(pre-add-rules-or-assertions!
 '((rule (append () ?y ?y))
   (rule (append (?u . ?v) ?y (?u . ?z))
         (append ?v ?y ?z))))

こんな風にまとめて書けます。
あと、query-driver-loopをこんな風にしておきます。

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

これで、eofを入れると基盤SchemeのREPLに戻ることができます。

4.55

a.
;;; Query input:
(supervisor ?who (Bitdiddle Ben))
;;; Query results:
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
b.
;;; Query input:
(job ?name (accounting . ?type))
;;; Query results:
(job (Cratchet Robert) (accounting scrivener))
(job (Scrooge Eben) (accounting chief accountant))
c.
;;; Query input:
(address ?name (Slumerville . ?rest))
;;; Query results:
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))

4.56

a.
;;; Query input:
(and (supervisor ?x (Bitdiddle Ben))
     (address ?x ?addr))
;;; Query results:
(and (supervisor (Tweakit Lem E) (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 (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
b.
;;; Query input:
(and (salary (Bitdiddle Ben) ?amount)
     (salary ?person ?amounts)
     (lisp-value < ?amounts ?amount))
;;; Query results:
(and (salary (Bitdiddle Ben) 60000) (salary (Aull DeWitt) 25000) (lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Cratchet Robert) 18000) (lisp-value < 18000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Reasoner Louis) 30000) (lisp-value < 30000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Tweakit Lem E) 25000) (lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Fect Cy D) 35000) (lisp-value < 35000 60000))
(and (salary (Bitdiddle Ben) 60000) (salary (Hacker Alyssa P) 40000) (lisp-value < 40000 60000))
c.
;;; Query input:
(and (supervisor ?someone ?p)
     (job ?p ?t)
     (not (job ?p (computer . ?r))))
;;; Query results:
(and (supervisor (Aull DeWitt) (Warbucks Oliver)) (job (Warbucks Oliver) (administration big wheel)) (not (job (Warbucks Oliver) (computer . ?r))))
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (job (Scrooge Eben) (accounting chief accountant)) (not (job (Scrooge Eben) (computer . ?r))))
(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (job (Warbucks Oliver) (administration big wheel)) (not (job (Warbucks Oliver) (computer . ?r))))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (job (Warbucks Oliver) (administration big wheel)) (not (job (Warbucks Oliver) (computer . ?r))))

この辺は楽ですね。

4.57

たぶんこんな感じじゃないかな。しかしもうちょっと日本語をわかりやすく書いてほしいところ。

(rule (replace ?person-1 ?person-2)
      (and (job ?person-1 ?j1)
           (job ?person-2 ?j2)
           (not (same ?person-1 ?person-2))
           (or (same ?j1 ?j2)
               (can-do-job ?j1 ?j2))))
a.
;;; Query input:
(replace ?someone (Fect Cy D))
;;; Query results:
(replace (Hacker Alyssa P) (Fect Cy D))
(replace (Bitdiddle Ben) (Fect Cy D))

computer programmerに代われるのは自分以外のcomputer programmerかcomputer wizardだけなのでたぶん合ってますね。computer wizardかっこいい。

b.
;;; Query input:
(and (replace ?p1 ?p2)
     (salary ?p1 ?s1)
     (salary ?p2 ?s2)
     (lisp-value < ?s1 ?s2))
;;; Query results:
(and (replace (Fect Cy D) (Hacker Alyssa P)) (salary (Fect Cy D) 35000) (salary (Hacker Alyssa P) 40000) (lisp-value < 35000 40000))
(and (replace (Aull DeWitt) (Warbucks Oliver)) (salary (Aull DeWitt) 25000) (salary (Warbucks Oliver) 150000) (lisp-value < 25000 150000))

p1の人にとってはp2の人が少し羨ましいと思う。同じ仕事だったら能力の関係があるかもしれないけど、違う仕事だったらp1はp2の人より恐らく能力があるのに給料低いとか。などと思いました。あと秘書強い。


出かけるのでとりあえずここまで。