SICP 読書ノート#64 - 4.4 論理型プログラミング (pp.261-269)

いよいよ4章の最後のセクション「論理型プログラミング」に入りました。

ここでのキーワードは「一方向性計算から多方向性計算へ」と「ユニフィケーション」のようです。

また、本文のappendの定義について

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))

に対し、

この手続きは, 次の二つの規則をLispに翻訳したものと考えられる. 第一の規則は, 第一のリストが空の場合を扱い, 第二は二つの部分のconsである, 空ではないリストの場合を扱う:

• 任意のリストyについて, 空リストとyをappendするとyになる.

• 任意のu, v, yとzについて, vとyをappendしてzになるなら, (cons u v)とyをappendすると, (cons u z)になる

を公理的定義というようですが、後から出てくるのでひとまず置いておきます。

質問システムを動かす

まずは質問システム(query system)を動かしてみます。

ソースコードはGitHubに置いています。

https://github.com/uents/sicp/tree/master/ch4.4-query-system

1. SICP本家からサンプルコードを取得

% curl -O https://mitpress.mit.edu/sicp/code/ch4-query.scm

2. Racket処理系で解釈できるようにいくつか修正

ファイルの先頭に#lang racketのシェバンを追加
evalの引数user-initial-environmentを削除

@@ -124,8 +126,8 @@
 ;;(put 'lisp-value 'qeval lisp-value)
 
 (define (execute exp)
-  (apply (eval (predicate exp) user-initial-environment)
-         (args exp)))
+  (apply (eval (predicate exp))
+        (args exp)))
 
 (define (always-true ignore frame-stream) frame-stream)

ifでalternative節がないものに便宜的にfalseを追加
- Racketはalternatie節の省略を許さない

@@ -296,7 +298,8 @@
           (put key
                'assertion-stream
                (cons-stream assertion
-                            current-assertion-stream))))))
+                            current-assertion-stream))))
+     false))
 
 (define (store-rule-in-index rule)
   (let ((pattern (conclusion rule)))
@@ -307,7 +310,8 @@
             (put key
                  'rule-stream
                  (cons-stream rule
-                              current-rule-stream)))))))
+                              current-rule-stream))))
+       false)))

stream support と table support は別ファイルに分ける
- 別ファイルに分けておくとDrRacketのステップ実行で入り込まなくて済むので、個人的には都合がいい
- tables.scmではmutable pairsを使うので(require r5rs)を追加

;;;;Stream support from Chapter 3
(require "streams.scm")

;;;;Table support from Chapter 3, Section 3.3.3 (local tables)
(require "tables.scm")

ファイルの最後に以下を追加

+;;; run driver loop
+(initialize-data-base microshaft-data-base)

3. 質問システムを起動

ch4-query.scmをロードしquery-driver-loopを呼び出すと質問システムのREPLが起きて入力プロンプトが表示される。

racket@> ,enter "ch4-query.scm"
'done
racket@ch4-query.scm> (query-driver-loop)

;;; Query input:

単純質問

テキストの例を写経。

プログラマを全て見つける

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

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

全ての社員の住所をリストアップ

;;; 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:
(job ?who (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:
(job ?who (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))

問題 4.55

a. Ben Bitdiddleに監督されている人すべて

;;; 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. 経理部門 [accounting division] のすべての人の名前と担当

;;; Query input:
(job ?who (accounting . ?type))

;;; Query results:
(job (Cratchet Robert) (accounting scrivener))
(job (Scrooge Eben) (accounting chief accountant))

c. Slumerville に住む人すべての名前と住所

;;; Query input:
(address ?who (Slumerville . ?where))

;;; 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:
(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)))

Ben Bitdiddle か Alyssa P. Hacker が監督するすべての従業員

;;; Query input:
(or (supervisor ?who (Bitdiddle Ben))
    (supervisor ?who (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)))

Ben Bitdiddleが監督し、計算機プログラマでない人すべて

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

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

給料が30,000ドルより多い人すべて

;;; 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))

問題 4.56

a. Ben Bitdiddleが監督している人すべての名前とその住所

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

;;; 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. 給料がBen Bitdiddleのそれより少ない人のすべてと、その人たちの給料と、Ben Bitdiddleの給料

;;; Query input:
(and (salary (Bitdiddle Ben) ?ben-amount)
     (and (salary ?person ?amount)
          (lisp-value < ?amount ?ben-amount)))

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

c. 計算機部門にいない人が監督している人すべてと、その監督者の名前と担当

;;; Query input:
(and (supervisor ?staff-person ?boss)
     (not (job ?boss (computer . ?type)))
     (job ?boss ?job))

;;; Query results:
(and (supervisor (Aull DeWitt) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?type))) (job (Warbucks Oliver) (administration big wheel)))
(and (supervisor (Cratchet Robert) (Scrooge Eben)) (not (job (Scrooge Eben) (computer . ?type))) (job (Scrooge Eben) (accounting chief accountant)))
(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?type))) (job (Warbucks Oliver) (administration big wheel)))
(and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (not (job (Warbucks Oliver) (computer . ?type))) (job (Warbucks Oliver) (administration big wheel)))

見づらいのでまとめると、

計算機部門にいない人が監督している人	監督者の名前	監督者の担当
Aull DeWitt	Warbucks Oliver	administration big wheel
Cratchet Robert	Scrooge Even	accounting chief accountant
Scrooge Eben	Warbucks Oliver	同上
Bitdiddle Ben	Warbucks Oliver	同上

規則

規則(rule)は質問(query)そのものを抽象化する手段を提供します。

同じ町に住む人を見つける規則 lives-near

(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))))

同じかどうかをチェックする規則 same

(rule (same ?x ?x))

監督者を監督する人を見つける wheel

(rule (wheel ?person)
      (and (supervisor ?middle-manager ?person)
           (supervisor ?x ?middle-manager)))

スタッフとボスの関係を表す outranked-by。再帰的に表現することもできる

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

これらの規則を使って質問を投げかけてみる。

近くに住んでいる規則の規定と、Ben Bitdiddleの近くに住む人は誰か？

;;; Query input:
(lives-near ?who (Bitdiddle Ben))

;;; Query results:
(lives-near (Aull DeWitt) (Bitdiddle Ben))
(lives-near (Reasoner Louis) (Bitdiddle Ben))

Benの近くに住む計算機プログラマは？

;;; Query input:
(and (job ?x (computer . ?type))
     (lives-near ?x (Bitdiddle Ben)))

;;; Query results:
(and (job (Reasoner Louis) (computer programmer trainee)) (lives-near (Reasoner Louis) (Bitdiddle Ben)))

問題 4.57

マイクロシャフト社のデータベース microshaft-data-base に以下の規則を追加する。

(rule (replace ?person-1 ?person-2)
      (and (job ?person-1 ?job-1)
           (job ?person-2 ?job-2)
           (or (same ?job-1 ?job-2)
               (can-do-job ?job-1 ?job-2))
           (not (same ?person-1 ?person-2))))

a. Cy D. Fectに代われる人すべて

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

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

b. 誰かに代われて、その誰かのほうが多くの給料をもらっている人全てと両者の給料

;;; Query input:
(and (replace ?person-1 ?person-2)
     (salary ?person-1 ?salary-1)
     (salary ?person-2 ?salary-2)
     (lisp-value > ?salary-1 ?salary-2))

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

問題 4.58

microshaft-data-baseに以下の規則を追加する。

(rule (big-shot ?person)
      (and (supervisor ?person ?boss)
           (not (replace ?boss ?person))))

テスト。

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

;;; Query results:
(big-shot (Aull DeWitt))
(big-shot (Cratchet Robert))
(big-shot (Scrooge Eben))
(big-shot (Bitdiddle Ben))

問題 4.59

microshaft-data-baseに以下を追加する。

(meeting accounting (Monday 9am))
(meeting administration (Monday 10am))
(meeting computer (Wednesday 3pm))
(meeting administration (Friday 1pm))
(meeting whole-company (Wednesday 4pm))

a. 金曜にあるすべてのミーティング

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

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

b. `(rule (metting-time ?person ?day-and-time) <rule-body>)` を実装

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

c. Alyssaが出席すべき水曜のミーティング

;;; 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))

問題 4.60

理由は、規則lives-nearが重複チェックを(not (same ?person-1 ?person-2))でしかしていないため
重複チェックとしてさらに名前の比較チェックを追加すればよい。実装はパス

次回は「プログラムとしての論理」から。

@uents blog

Code wins arguments.

SICP 読書ノート#64 - 4.4 論理型プログラミング (pp.261-269)

質問システムを動かす

1. SICP本家からサンプルコードを取得

2. Racket処理系で解釈できるようにいくつか修正

3. 質問システムを起動

単純質問

問題 4.55

a. Ben Bitdiddleに監督されている人すべて

b. 経理部門 [accounting division] のすべての人の名前と担当

c. Slumerville に住む人すべての名前と住所

合成質問

問題 4.56

a. Ben Bitdiddleが監督している人すべての名前とその住所

b. 給料がBen Bitdiddleのそれより少ない人のすべてと、その人たちの給料と、Ben Bitdiddleの給料

c. 計算機部門にいない人が監督している人すべてと、その監督者の名前と担当

規則

問題 4.57

a. Cy D. Fectに代われる人すべて

b. 誰かに代われて、その誰かのほうが多くの給料をもらっている人全てと両者の給料

問題 4.58

問題 4.59

a. 金曜にあるすべてのミーティング

b. `(rule (metting-time ?person ?day-and-time) <rule-body>)` を実装

c. Alyssaが出席すべき水曜のミーティング

問題 4.60

質問システムを動かす

1. SICP本家からサンプルコードを取得

2. Racket処理系で解釈できるようにいくつか修正

3. 質問システムを起動

単純質問

問題 4.55

a. Ben Bitdiddleに監督されている人すべて

b. 経理部門 [accounting division] のすべての人の名前と担当

c. Slumerville に住む人すべての名前と住所

合成質問

問題 4.56

a. Ben Bitdiddleが監督している人すべての名前とその住所

b. 給料がBen Bitdiddleのそれより少ない人のすべてと、その人たちの給料と、Ben Bitdiddleの給料

c. 計算機部門にいない人が監督している人すべてと、その監督者の名前と担当

規則

問題 4.57

a. Cy D. Fectに代われる人すべて

b. 誰かに代われて、その誰かのほうが多くの給料をもらっている人全てと両者の給料

問題 4.58

問題 4.59

a. 金曜にあるすべてのミーティング

b. (rule (metting-time ?person ?day-and-time) <rule-body>) を実装

c. Alyssaが出席すべき水曜のミーティング

問題 4.60

b. `(rule (metting-time ?person ?day-and-time) <rule-body>)` を実装