Implement till 4.75

ex-4_70-79.scm

@@ -42,11 +42,49 @@
 
 (display "[answered]\n")
 
-(display "\nex-4.74\n")
+(display "\nex-4.74 - simple-stream-flatmap\n")
+
+(define (simple-stream-flatmap proc s)
+  (simple-flatten (stream-map proc s)))
+
+(define (stream-not-null? x)
+  (not (stream-null? x)))
+
+(define (simple-flatten stream)
+  (stream-map stream-car
+              (stream-filter stream-not-null? stream)))
+
+(eval-query
+  '(and (salary (Bitdiddle Ben) ?ben-amount)
+        (salary ?person ?amount)
+        (lisp-value > ?amount ?ben-amount)))
+(newline)
+
+; The query system's behavior does not change because interleaving does not
+; have an effect for empty and singleton streams.
+
+(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)
+
+(display "\nex-4.76\n")
+
+(display "\nex-4.77\n")
 
-;(display "\nex-4.75\n")
-;(display "\nex-4.76\n")
-;(display "\nex-4.77\n")
 ;(display "\nex-4.78\n")
 ;(display "\nex-4.79\n")
 

misc/sicp-query.scm

@@ -66,6 +66,7 @@
 ;;;Simple queries
 
 (define (simple-query query-pattern frame-stream)
+  ;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
   (stream-flatmap
    (lambda (frame)
      (stream-append-delayed
@@ -106,6 +107,15 @@
          the-empty-stream))
    frame-stream))
 
+(define (uniquely-asserted query frame-stream)
+  (stream-flatmap
+    (lambda (frame)
+      (let ((matches (qeval (car query) (singleton-stream frame))))
+        (cond ((stream-null? matches) matches)
+              ((stream-null? (stream-cdr matches)) matches)
+              (else the-empty-stream))))
+    frame-stream))
+
 ;;(put 'not 'qeval negate)
 
 (define (lisp-value call frame-stream)
@@ -539,7 +549,7 @@
             ((eq? m 'insert-proc!) insert!)
             (else (error "Unknown operation -- TABLE" m))))
     dispatch))
-
+
 ;;;; From instructor's manual
 
 (define get '())
@@ -570,6 +580,7 @@
   (put 'and 'qeval conjoin)
   (put 'or 'qeval disjoin)
   (put 'not 'qeval negate)
+  (put 'unique 'qeval uniquely-asserted)
   (put 'lisp-value 'qeval lisp-value)
   (put 'always-true 'qeval always-true)
   (deal-out rules-and-assertions '() '()))