Working on 4.76

ex-4_70-79.scm

@@ -65,23 +65,94 @@
 
 (display "\nex-4.75 - unique\n")
 
+;(eval-query
+;  '(unique (job ?x (computer wizard))))
+;(newline)
+;
+;(eval-query
+;  '(unique (job ?x (computer programmer))))
+;(newline)
+;
+;(eval-query
+;  '(and (job ?x ?j) (unique (job ?anyone ?j))))
+;(newline)
+;
+;(eval-query
+;  '(and (job ?p ?j) (unique (supervisor ?s ?p))))
+;(newline)
+
+; Implementation of uniquely-asserted in sicp-query.
+(display "[answered]\n")
+
+(display "\nex-4.76 - more-efficient-and\n")
+
+; Exercise 4.76.  Our implementation of and as a series combination of queries
+; (figure 4.5) is elegant, but it is inefficient because in processing the
+; second query of the and we must scan the data base for each frame produced by
+; the first query. If the data base has N elements, and a typical query
+; produces a number of output frames proportional to N (say N/k), then scanning
+; the data base for each frame produced by the first query will require N2/k
+; calls to the pattern matcher. Another approach would be to process the two
+; clauses of the and separately, then look for all pairs of output frames that
+; are compatible. If each query produces N/k output frames, then this means
+; that we must perform N2/k2 compatibility checks -- a factor of k fewer than
+; the number of matches required in our current method.
+
+; Devise an implementation of and that uses this strategy. You must implement a
+; procedure that takes two frames as inputs, checks whether the bindings in the
+; frames are compatible, and, if so, produces a frame that merges the two sets
+; of bindings. This operation is similar to unification.
+
+(define (stream-combinations s1 s2)
+  (stream-flatmap
+    (lambda (x1) (stream-map (lambda (x2) (append x1 x2)) s2))
+    s1))
+
+(define (conjoin conjuncts frame-stream)
+  (define (unify-bindings bindings)
+    (define (go-unify bindings frame)
+      (if (null? bindings)
+        frame
+        (let* ((binding (car bindings))
+               (var (predicate binding))
+               (val (args binding)))
+          (go-unify (cdr bindings) (unify-match var val frame)))))
+    (go-unify bindings '()))
+
+  (define (unify-frame-streams frame-stream-1 frame-stream-2)
+    (display "UNIFY-FRAME-STREAMS\n")
+    (let ((potential-bindings (stream-combinations frame-stream-1 frame-stream-2)))
+      (stream-filter
+        (lambda (f) (not (eq? f 'failed)))
+        (stream-map unify-bindings potential-bindings))))
+
+  (define (unify-frame-stream-list frame-stream-list)
+    (if (null? (cdr frame-stream-list))
+      (car frame-stream-list)
+      (let ((frame-stream (unify-frame-streams (car frame-stream-list)
+                                               (cadr frame-stream-list))))
+        (display frame-stream) (newline)
+        (unify-frame-stream-list (cons frame-stream (cddr frame-stream-list))))))
+
+  (define (qeval-conjunction conjunction)
+    (qeval conjunction frame-stream))
+
+  (let ((frame-stream-list (map qeval-conjunction conjuncts)))
+    (unify-frame-stream-list frame-stream-list)))
+
+(put 'and 'qeval conjoin)
+
 (eval-query
-  '(unique (job ?x (computer wizard))))
+  '(rule (big-shot ?p)
+    (and (job ?p (?div1 . ?rest1))
+         (supervisor ?p ?boss)
+         (job ?boss (?div2 . ?rest2))
+         (not (same ?div1 ?div2)))))
+
+(eval-query '(big-shot ?x))
 (newline)
 
 (eval-query
-  '(unique (job ?x (computer programmer))))
-(newline)
-
-(eval-query
-  '(and (job ?x ?j) (unique (job ?anyone ?j))))
-(newline)
-
-(eval-query
-  '(and (job ?p ?j) (unique (supervisor ?s ?p))))
-(newline)
-
-(display "\nex-4.76\n")
 
 (display "\nex-4.77\n")
 

misc/sicp-query.scm

@@ -465,7 +465,6 @@
 
 (define (extend variable value frame)
   (cons (make-binding variable value) frame))
-
 
 ;;;;From Section 4.1