Begin chapter 4 part 4

1 files changed, 748 insertions, 0 deletions

diff --git a/chap4/part4.rkt b/chap4/part4.rkt
new file mode 100644
index 0000000..779437e
--- /dev/null
+++ b/chap4/part4.rkt
@@ -0,0 +1,748 @@
+#lang sicp
+(#%require (only racket/base print-as-expression print-mpair-curly-braces make-base-namespace))
+(print-as-expression #f)
+(print-mpair-curly-braces #f)
+
+;; Chapter 4
+;; Metalinguistic Abstraction
+
+;; 4.4
+;; Logic Programming
+
+;; Deductive Information Retrieval
+
+(#%provide personel-defs)
+(define personel-defs
+  '((address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
+    (job (Bitdiddle Ben) (computer wizard))
+    (salary (Bitdiddle Ben) 60000)
+    (supervisor (Bitdiddle Ben) (Warbucks Oliver))
+
+    (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
+    (job (Hacker Alyssa P) (computer programmer))
+    (salary (Hacker Alyssa P) 40000)
+    (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
+
+    (address (Fect Cy D) (Cambridge (Ames Street) 3))
+    (job (Fect Cy D) (computer programmer))
+    (salary (Fect Cy D) 35000)
+    (supervisor (Fect Cy D) (Bitdiddle Ben))
+
+    (address (Tweakit Lem E) (Boston (Bay State Road) 22))
+    (job (Tweakit Lem E) (computer technician))
+    (salary (Tweakit Lem E) 25000)
+    (supervisor (Tweakit Lem E) (Bitdiddle Ben))
+
+    (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
+    (job (Reasoner Louis) (computer programmer trainee))
+    (salary (Reasoner Louis) 30000)
+    (supervisor (Reasoner Louis) (Hacker Alyssa P))
+
+    (address (Warbucks Oliver) (Swellesly (Top Heap Road)))
+    (job (Warbucks Oliver) (administration big wheel))
+    (salary (Warbucks Oliver) 150000)
+
+    (address (Scrooge Eben) (Weston (Shady Lane) 10))
+    (job (Scrooge Eben) (accounting chief accountant))
+    (salary (Scrooge Eben) 75000)
+    (supervisor (Scrooge Eben) (Warbucks Oliver))
+
+    (address (Cratchet Robert) (Allston (N Harvard Street) 16))
+    (job (Cratchet Robert) (accounting scrivener))
+    (salary (Cratchet Robert) 18000)
+    (supervisor (Cratchet Robert) (Scrooge Eben))
+
+    (address (Aull DeWitt) (Slumerville (Onion Square) 5))
+    (job (Aull DeWitt) (administration secretary))
+    (salary (Aull DeWitt) 25000)
+    (supervisor (Aull DeWitt) (Warbucks Oliver))
+
+    (can-do-job (computer wizard) (computer programmer))
+    (can-do-job (computer wizard) (computer technician))
+    (can-do-job (computer programmer) (computer trainee))
+    (can-do-job (administration secretary) (administration big wheel))
+
+    ))
+
+(define example-queries
+  '((job ?x (computer programmer))
+    (address ?x ?y)
+    (supervisor ?x ?x)
+    (job ?x (computer ?type))
+    (job ?x (computer . ?type))
+    ))
+
+#| 4.55 |#
+
+(define simple-queries
+  '((supervisor ?x (Bitdiddle Ben))
+    (job ?x (accounting . ?type))
+    (address ?x (Slumerville . ?addr))))
+
+#| 4.56 |#
+
+(define compund-queries
+  '((and
+      (supervisor ?person (Bitdiddle Ben))
+      (address ?person ?where))
+    (and
+      (salary (Bitdiddle Ben) ?ben-salary)
+      (salary ?person ?amount)
+      (lisp-value < ?amount ?ben-salary))
+    (and
+      (supervisor ?name ?sup)
+      (not (job ?sup (computer . ?type))))))
+
+(#%provide rule-defs)
+(define rule-defs
+  '((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))))
+    (rule (same ?x ?x))
+    (rule (wheel ?person)
+      (and
+        (supervisor ?middle-manager ?person)
+        (supervisor ?x ?middle-manager)))
+    (rule (outranked-by ?staff-person ?boss)
+      (or
+        (supervisor ?staff-person ?boss)
+        (and
+          (supervisor ?staff-person ?middle-manager)
+          (outranked-by ?middle-manager ?boss))))))
+
+(define (make-assertion x) (list 'assert! x))
+
+(#%provide q-defs)
+(define q-defs
+  (map
+    make-assertion
+    (append personel-defs rule-defs)))
+
+#| 4.57 |#
+
+(define can-replace-def
+  '(rule (can-replace ?p1 ?p2)
+    (and
+      (job ?p1 ?p1-job)
+      (job ?p2 ?p2-job) 
+      (or
+        (same ?p1-job ?p2-job)
+        (can-do-job ?p1-job ?p2-job))
+      (not (same ?p1 ?p2)))))
+
+(define can-replace-example-1
+  '(can-replace ?x (Fect Cy D)))
+
+(define can-replace-example-2
+  '(and
+    (can-replace ?x ?y)
+    (salary ?x ?x-salary)
+    (salary ?y ?y-salary)
+    (lisp-value < ?x-salary ?y-salary)))
+
+#| 4.58 |#
+
+(define big-shot-def
+  '(rule (big-shot ?x)
+    (and
+      (job ?x (?div . ?rest))
+      (not
+        (and
+          (supervisor ?x ?sup)
+          (job ?sup (?div . ?rest-2))))))
+
+#| 4.59 |#
+
+(define meeting-defs
+  '((meeting accounting (Monday 9am))
+    (meeting administration (Monday 10am))
+    (meeting computer (Wednesday 3pm))
+    (meeting administration (Friday 1pm))
+    (meeting whole-company (Wednesday 4pm))))
+
+(define meeting-query
+  '(meeting ?div (Friday . ?time)))
+
+(define meeting-time-def
+  '(rule (meeting-time ?person ?day-and-time)
+    (or
+      (and
+        (job ?person (?div . ?rest))
+        (meeting ?div ?day-and-time))
+      (meeting whole-company ?day-and-time))))
+
+(define meeting-time-query
+  '(meeting-time (Hacker Alyssa P) (Wednesday . ?time)))
+
+(rule (append-to-form () ?y ?y))
+(rule (append-to-form () (?u . ?v) ?y (?u . ?z))
+  (append-to-form ?v ?y ?z))
+
+#| 4.61 |#
+#| 4.62 |#
+#| 4.63 |#
+
+;; How the Query System Works
+
+;; Is Logic Programming Mathematical Logic
+
+#| 4.64 |#
+#| 4.65 |#
+#| 4.66 |#
+#| 4.67 |#
+#| 4.68 |#
+#| 4.69 |#
+
+;; Implementing the Query System
+
+(define (stream-car stream) (car stream))
+
+(define (stream-cdr stream) (force (cdr stream)))
+
+(#%provide stream-map)
+(define (stream-map proc s)
+  (if (stream-null? s)
+    the-empty-stream
+    (cons-stream
+      (proc (stream-car s))
+      (stream-map proc (stream-cdr s)))))
+
+(define (stream-for-each proc s)
+  (if (stream-null? s)
+    'done
+    (begin
+      (proc (stream-car s))
+      (stream-for-each proc (stream-cdr s)))))
+
+(define (display-stream s)
+  (stream-for-each display-line s))
+
+(define (display-line x)
+  (newline)
+  (display x))
+
+(define (stream-append s1 s2)
+  (if (stream-null? s1)
+    s2
+    (cons-stream
+      (stream-car s1)
+      (stream-append (stream-cdr s1) s2))))
+
+(define (prompt-for-input string)
+  (newline)
+  (newline)
+  (display string)
+  (newline))
+
+(define input-prompt ";;; Query input:")
+(define output-prompt ";;; Query results:")
+
+(#%provide query-driver-loop-init)
+(define (query-driver-loop-init facts)
+  (if (null? facts)
+    (query-driver-loop)
+    (let ((q (query-syntax-process (car facts))))
+      (cond
+        ((assertion-to-be-added? q)
+         (add-rule-or-assertion! (add-assertion-body q))
+         (newline)
+         (display "Assertion added to data base.")
+         (query-driver-loop-init (cdr facts)))
+        (else
+          (query-driver-loop-init (cdr facts)))))))
+
+(#%provide query-driver-loop)
+(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
+        (newline)
+        (display output-prompt)
+        (display-stream
+          (stream-map
+            (lambda (frame)
+              (instantiate
+                q
+                frame
+                (lambda (v f)
+                  (contract-question-mark v))))
+            (qeval q (singleton-stream '()))))
+        (query-driver-loop)))))
+
+(define (instantiate exp frame unbound-var-handler)
+  (define (copy exp)
+    (cond
+      ((var? exp)
+       (let ((binding (binding-in-frame exp frame)))
+         (if binding
+           (copy (binding-value binding))
+           (unbound-var-handler exp frame))))
+      ((pair? exp)
+       (cons (copy (car exp)) (copy (cdr exp))))
+      (else exp)))
+  (copy exp))
+
+(define (make-table-object)
+  (let
+    ((local-table (list '*table*)))
+    (define (lookup key-1 key-2)
+      (let
+        ((subtable (assoc key-1 (cdr local-table))))
+        (if subtable
+          (let
+            ((record (assoc key-2 (cdr subtable))))
+            (if record
+              (cdr record)
+              false))
+          false)))
+    (define (insert! key-1 key-2 value)
+      (let
+        ((subtable (assoc key-1 (cdr local-table))))
+        (if subtable
+          (let
+            ((record (assoc key-2 (cdr subtable))))
+            (if record
+              (set-cdr! record value)
+              (set-cdr!
+                subtable
+                (cons
+                  (cons key-2 value)
+                  (cdr subtable)))))
+          (set-cdr!
+            local-table
+            (cons
+              (list key-1 (cons key-2 value))
+              (cdr local-table)))))
+      'ok)
+    (define (dispatch m)
+      (cond
+        ((eq? m 'lookup-proc) lookup)
+        ((eq? m 'insert-proc!) insert!)
+        (else (error "Unknown operation -- TABLE" m))))
+    dispatch))
+
+(define operation-table (make-table-object))
+
+(define get (operation-table 'lookup-proc))
+
+(define put (operation-table 'insert-proc!))
+
+(define (qeval query frame-stream)
+  (let ((qproc (get (type query) 'qeval)))
+    (if qproc
+      (qproc (contents query) frame-stream)
+      (simple-query query frame-stream))))
+
+(define (simple-query query-pattern frame-stream)
+  (stream-flatmap
+    (lambda (frame)
+      (stream-append-delayed
+        (find-assertions query-pattern frame)
+        (delay (apply-rules query-pattern frame))))
+    frame-stream))
+
+(define (conjoin conjuncts frame-stream)
+  (if (empty-conjunction? conjuncts)
+    frame-stream
+    (conjoin
+      (rest-conjuncts conjuncts)
+      (qeval (first-conjunct conjuncts) frame-stream))))
+
+(put 'and 'qeval conjoin)
+
+(define (disjoin disjuncts frame-stream)
+  (if (empty-disjunction? disjuncts)
+    the-empty-stream
+    (interleave-delayed
+      (qeval (first-disjunct disjuncts) frame-stream)
+      (delay (disjoin (rest-disjuncts disjuncts) frame-stream)))))
+
+(put 'or 'qeval disjoin)
+
+(define (negate operands frame-stream)
+  (stream-flatmap
+    (lambda (frame)
+      (if
+        (stream-null?
+          (qeval
+            (negated-query operands)
+            (singleton-stream frame)))
+        (singleton-stream frame)
+        the-empty-stream))
+    frame-stream))
+
+(put 'not 'qeval negate)
+
+(define (lisp-value call frame-stream)
+  (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))
+
+(put 'lisp-value 'qeval lisp-value)
+
+(define ns (make-base-namespace))
+
+(define (execute exp)
+  (apply
+    (eval (predicate exp) ns)
+    (args exp)))
+
+(define (always-true ignore frame-stream) frame-stream)
+
+(put 'always-true 'qeval always-true)
+
+(define (find-assertions pattern frame)
+  (stream-flatmap
+    (lambda (datum)
+      (check-an-assertion datum pattern frame))
+    (fetch-assertions pattern frame)))
+
+(define (check-an-assertion assertion query-pat query-frame)
+  (let
+    ((match-result (pattern-match query-pat assertion query-frame)))
+    (if (eq? match-result 'failed)
+      the-empty-stream
+      (singleton-stream match-result))))
+
+(define (pattern-match pat dat frame)
+  (cond
+    ((eq? frame 'failed) 'failed)
+    ((equal? pat dat) frame)
+    ((var? pat) (extend-if-consistent pat dat frame))
+    ((and (pair? pat) (pair? dat))
+     (pattern-match
+       (cdr pat)
+       (cdr dat)
+       (pattern-match (car pat) (car dat) frame)))
+    (else 'failed)))
+
+(define (extend-if-consistent var dat frame)
+  (let ((binding (binding-in-frame var frame)))
+    (if binding
+      (pattern-match (binding-value binding) dat frame)
+      (extend var dat frame))))
+
+(define (apply-rules pattern frame)
+  (stream-flatmap
+    (lambda (rule)
+      (apply-a-rule rule pattern frame))
+    (fetch-rules pattern 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)
+        the-empty-stream
+        (qeval
+          (rule-body clean-rule)
+          (singleton-stream unify-result))))))
+
+(define (rename-variables-in rule)
+  (let ((rule-application-id (new-rule-application-id)))
+    (define (tree-walk exp)
+      (cond
+        ((var? exp)
+         (make-new-variable exp rule-application-id))
+        ((pair? exp)
+         (cons
+           (tree-walk (car exp))
+           (tree-walk (cdr exp))))
+        (else exp)))
+    (tree-walk rule)))
+
+(define (unify-match p1 p2 frame)
+  (cond
+    ((eq? frame 'failed) 'failed)
+    ((equal? p1 p2) frame)
+    ((var? p1) (extend-if-possible p1 p2 frame))
+    ((var? p2) (extend-if-possible p2 p1 frame))
+    ((and (pair? p1) (pair? p2))
+     (unify-match
+       (cdr p1)
+       (cdr p2)
+       (unify-match (car p1) (car p2) frame)))
+    (else 'failed)))
+
+(define (extend-if-possible var val frame)
+  (let ((binding (binding-in-frame var frame)))
+    (cond
+      (binding
+       (unify-match (binding-value binding) val frame))
+      ((var? val)
+       (let ((binding (binding-in-frame val frame)))
+         (if binding
+           (unify-match var (binding-value binding) frame)
+           (extend var val frame))))
+      ((depends-on? val var frame) 'failed)
+      (else (extend var val frame)))))
+
+(define (depends-on? exp var frame)
+  (define (tree-walk e)
+    (cond
+      ((var? e)
+       (if (equal? var e)
+         true
+         (let ((b (binding-in-frame e frame)))
+           (if b
+             (tree-walk (binding-value b))
+             false))))
+      ((pair? e)
+       (or (tree-walk (car e)) (tree-walk (cdr e))))
+      (else false)))
+  (tree-walk exp))
+
+(define THE-ASSERTIONS the-empty-stream)
+
+(define (fetch-assertions pattern frame)
+  (if (use-index? pattern)
+    (get-indexed-assertions pattern)
+    (get-all-assertions)))
+
+(define (get-all-assertions) THE-ASSERTIONS)
+
+(define (get-indexed-assertions pattern)
+  (get-stream (index-key-of pattern) 'assertion-stream))
+
+(define (get-stream key1 key2)
+  (let ((s (get key1 key2)))
+    (if s s the-empty-stream)))
+
+(define THE-RULES the-empty-stream)
+
+(define (fetch-rules pattern frame)
+  (if (use-index? pattern)
+    (get-indexed-rules pattern)
+    (get-all-rules)))
+
+(define (get-all-rules) THE-RULES)
+
+(define (get-indexed-rules pattern)
+  (stream-append
+    (get-stream (index-key-of pattern) 'rule-stream)
+
+    (get-stream '? 'rule-stream)))
+
+(define (add-rule-or-assertion! assertion)
+  (if (rule? assertion)
+    (add-rule! assertion)
+    (add-assertion! assertion)))
+
+(define (add-assertion! assertion)
+  (store-assertion-in-index assertion)
+  (let ((old-assertions THE-ASSERTIONS))
+    (set! THE-ASSERTIONS
+      (cons-stream assertion old-assertions))
+    'ok))
+
+(define (add-rule! rule)
+  (store-rule-in-index rule)
+  (let ((old-rules THE-RULES))
+    (set! THE-RULES (cons-stream rule old-rules))
+    'ok))
+
+(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))))))
+
+(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)))))))
+
+(define (indexable? pat)
+  (or
+    (constant-symbol? (car pat))
+    (var? (car pat))))
+
+(define (index-key-of pat)
+  (let ((key (car pat)))
+    (if (var? key) '? key)))
+
+(define (use-index? pat) (constant-symbol? (car pat)))
+
+(define (stream-append-delayed s1 delayed-s2)
+  (if (stream-null? s1)
+    (force delayed-s2)
+    (cons-stream
+      (stream-car s1)
+      (stream-append-delayed
+        (stream-cdr s1)
+        delayed-s2))))
+
+(define (interleave-delayed s1 delayed-s2)
+  (if (stream-null? s1)
+    (force delayed-s2)
+    (cons-stream
+      (stream-car s1)
+      (interleave-delayed
+        (force delayed-s2)
+        (delay (stream-cdr s1))))))
+
+(define (stream-flatmap proc s)
+  (flatten-stream (stream-map proc s)))
+
+(define (flatten-stream stream)
+  (if (stream-null? stream)
+    the-empty-stream
+    (interleave-delayed
+      (stream-car stream)
+      (delay (flatten-stream (stream-cdr stream))))))
+
+(define (singleton-stream x)
+  (cons-stream x the-empty-stream))
+
+(define (type exp)
+  (if (pair? exp)
+    (car exp)
+    (error "Unknown expression TYPE" exp)))
+
+(define (contents exp)
+  (if (pair? exp)
+    (cdr exp)
+    (error "Unknown expression CONTENTS" exp)))
+
+(define (assertion-to-be-added? exp)
+  (eq? (type exp) 'assert!))
+
+(define (add-assertion-body exp) (car (contents exp)))
+
+(define (empty-conjunction? exps) (null? exps))
+
+(define (first-conjunct exps) (car exps))
+
+(define (rest-conjuncts exps) (cdr exps))
+
+(define (empty-disjunction? exps) (null? exps))
+
+(define (first-disjunct exps) (car exps))
+
+(define (rest-disjuncts exps) (cdr exps))
+
+(define (negated-query exps) (car exps))
+
+(define (predicate exps) (car exps))
+
+(define (args exps) (cdr exps))
+
+(define (rule? statement)
+  (tagged-list? statement 'rule))
+
+(define (conclusion rule) (cadr rule))
+
+(define (rule-body rule)
+  (if (null? (cddr rule)) '(always-true) (caddr rule)))
+
+(define (query-syntax-process exp)
+  (map-over-symbols expand-question-mark exp))
+
+(define (map-over-symbols proc exp)
+  (cond
+    ((pair? exp)
+     (cons
+       (map-over-symbols proc (car exp))
+       (map-over-symbols proc (cdr exp))))
+    ((symbol? exp) (proc exp))
+    (else exp)))
+
+(define (expand-question-mark symbol)
+  (let ((chars (symbol->string symbol)))
+    (if (string=? (substring chars 0 1) "?")
+      (list
+        '?
+        (string->symbol
+          (substring chars 1 (string-length chars))))
+      symbol)))
+
+(define (var? exp) (tagged-list? exp '?))
+
+(define (constant-symbol? exp) (symbol? exp))
+
+(define rule-counter 0)
+
+(define (new-rule-application-id)
+  (set! rule-counter (+ 1 rule-counter))
+  rule-counter)
+
+(define (make-new-variable var rule-application-id)
+  (cons '? (cons rule-application-id (cdr var))))
+
+(define (contract-question-mark variable)
+  (string->symbol
+    (string-append
+      "?"
+      (if (number? (cadr variable))
+        (string-append
+          (symbol->string (caddr variable))
+          "-"
+          (number->string (cadr variable)))
+        (symbol->string (cadr variable))))))
+
+(define (make-binding variable value)
+  (cons variable value))
+
+(define (binding-variable binding) (car binding))
+
+(define (binding-value binding) (cdr binding))
+
+(define (binding-in-frame variable frame)
+  (assoc variable frame))
+
+(define (extend variable value frame)
+  (cons (make-binding variable value) frame))
+
+(define (tagged-list? exp tag)
+  (if (pair? exp)
+    (eq? (car exp) tag)
+    false))
+
+#| 4.70 |#
+
+#| 4.71 |#
+#| 4.72 |#
+#| 4.73 |#
+#| 4.74 |#
+#| 4.75 |#
+#| 4.76 |#
+#| 4.77 |#
+#| 4.78 |#
+#| 4.79 |#