Implement till 4.75

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