Finish 4.78 and skip 4.79

ex-4_78-79.scm

@@ -19,30 +19,8 @@
 
 (amball '(begin
 
-(define input-prompt ";;; Query input:")
-(define output-prompt ";;; Query results:")
-
-(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)
-           ;; [extra newline at end] (announce-output output-prompt)
-           (display-list
-            (map
-             (lambda (frame)
-               (instantiate q
-                            frame
-                            (lambda (v f)
-                              (contract-question-mark v))))
-             (qeval q (singleton-list '()))))
-           (query-driver-loop)))))
+(define (require p)
+  (if (null? p) (amb)))
 
 (define (instantiate exp frame unbound-var-handler)
   (define (copy exp)
@@ -56,59 +34,42 @@
           (else exp)))
   (copy exp))
 
-
-;;;SECTION 4.4.4.2
-;;;The Evaluator
-
-(define (qeval query frame-list)
-  ;; (display "QEVAL ") (display query) (newline)
+(define (qeval query frame)
   (let ((qproc (get (type query) 'qeval)))
     (if qproc
-        (qproc (contents query) frame-list)
-        (simple-query query frame-list))))
+        (qproc (contents query) frame)
+        (simple-query query frame))))
 
-;;;Simple queries
+(define (simple-query query-pattern frame)
+  ;;(display "SIMPLE-QUERY ") (display query-pattern) (newline)
+  (let ((r (apply-rules query-pattern frame)))
+    (let ((a (find-assertions query-pattern frame)))
+      (let ((result (append a r)))
+        (require result)
+        result))))
 
-(define (simple-query query-pattern frame-list)
-  ;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
-  (flatmap
-   (lambda (frame)
-     (append
-      (find-assertions query-pattern frame)
-      (apply-rules query-pattern frame)))
-   frame-list))
-
-;;;Compound queries
-
-(define (conjoin conjuncts frame-list)
+(define (conjoin conjuncts frame)
   (if (empty-conjunction? conjuncts)
-      frame-list
+      frame
       (conjoin (rest-conjuncts conjuncts)
-               (qeval (first-conjunct conjuncts)
-                      frame-list))))
+               (qeval (first-conjunct conjuncts) frame))))
 
-;;(put 'and 'qeval conjoin)
-
-
-(define (disjoin disjuncts frame-list)
+(define (disjoin disjuncts frame)
   (if (empty-disjunction? disjuncts)
-      '()
-      (interleave
-       (qeval (first-disjunct disjuncts) '())
-       (disjoin (rest-disjuncts disjuncts) frame-list))))
+      (amb)
+      (let ((r1 (qeval (first-disjunct disjuncts) frame)))
+        (if (null? r1)
+          (disjoin (rest-disjuncts disjuncts) frame)
+          (amb r1 (disjoin (rest-disjuncts disjuncts) frame))))))
 
 ;;(put 'or 'qeval disjoin)
 
 ;;;Filters
 
-(define (negate operands frame-list)
-  (flatmap
-   (lambda (frame)
-     (if (null? (qeval (negated-query operands)
-                       (singleton-list frame)))
-         (singleton-list frame)
-         '()))
-   frame-list))
+(define (negate operands frame)
+  (if (null? (qeval (negated-query operands) frame))
+    frame
+    (amb)))
 
 (define (uniquely-asserted query frame-list)
   (flatmap
@@ -121,19 +82,15 @@
 
 ;;(put 'not 'qeval negate)
 
-(define (lisp-value call frame-list)
-  (flatmap
-   (lambda (frame)
-     (if (execute
-          (instantiate
-           call
-           frame
-           (lambda (v f)
-             (error "Unknown pat var -- LISP-VALUE" v))))
-         (singleton-list frame)
-         '()))
-   frame-list))
-
+(define (lisp-value call frame)
+   (if (execute
+         (instantiate
+         call
+         frame
+         (lambda (v f)
+           (error "Unknown pat var -- LISP-VALUE" v))))
+         frame
+         (amb)))
 ;;(put 'lisp-value 'qeval lisp-value)
 
 (define (execute exp)
@@ -153,16 +110,23 @@
 
 (define (find-assertions pattern frame)
   ;; (display "FIND-ASSERTIONS ") (display pattern) (newline)
-  (flatmap
-    (lambda (datum) (check-an-assertion datum pattern frame))
-    (fetch-assertions pattern frame)))
+  (define (check xs)
+    (if (null? xs)
+      xs
+      (if (null? (car xs))
+        (check (cdr xs))
+        (cons (car xs) (check (cdr xs))))))
+
+  (lamb ;(check
+          (map (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)
         '()
-        (singleton-list match-result))))
+        match-result)))
 
 (define (pattern-match pat dat frame)
   (cond ((eq? frame 'failed) 'failed)
@@ -676,41 +640,54 @@
           ((rule-to-be-added? q)
            (add-rule-or-assertion! q))
           (else
-           (display-list
-            (map
-             (lambda (frame)
-               (instantiate q
-                            frame
-                            (lambda (v f)
-                              (contract-question-mark v))))
-             (qeval q (singleton-list '()))))))))
-
-(initialize-data-base microshaft-data-base)
-
-;; We are insided the non-deterministic evaluator here.
+            (instantiate
+              q
+             (qeval q '())
+             (lambda (v f) (contract-question-mark v)))))))
 
 (display "\nex-4.78 - non-deterministic-query\n")
 (display "[installed-query-system]\n")
+(initialize-data-base microshaft-data-base)
+(display "[installed-microshaft-data-base]\n")
 
-; Query is working within non-deterministic evaluator. Now we can switch to
-; amb.
+;(eval-query '(supervisor ?x (bitdiddle ben)))
 
-(eval-query
-  '(rule (big-shot ?p)
-    (and (job ?p (?div1 . ?rest1))
-         (supervisor ?p ?boss)
-         (job ?boss (?div2 . ?rest2))
-         (not (same ?div1 ?div2)))))
+;(eval-query
+;  '(and (supervisor ?person (Bitdiddle Ben))
+;        (address ?person  ?address)))
+
+;(eval-query
+;  '(rule (big-shot ?p)
+;    (and (job ?p (?div1 . ?rest1))
+;         (supervisor ?p ?boss)
+;         (job ?boss (?div2 . ?rest2))
+;         (not (same ?div1 ?div2)))))
 
 (eval-query
   '(and (salary (Bitdiddle Ben) ?ben-amount)
         (salary ?person ?amount)
         (lisp-value > ?amount ?ben-amount)))
 
-(eval-query '(big-shot ?x))
-(newline)
-))
+
+;(eval-query '(big-shot ?x))
+
+)) ;; Enf of non-deterministic evaluator
+
+(define (display-line x)
+  (display x)
+  (newline))
+(map display-line result)
+
+; Regular queries work, but rules don't. I have to admit that this exercise is
+; at the limit of my current capabilities and I have already spent a
+; significantly longer time than I need for a regular exercise. I move on for
+; now. Honestly, I am pretty proud that I was able to set up the query language
+; within the non-deterministic evaluator. To make further progress I would need
+; to understand the query-rule application better.
 
 (display "\nex-4.79\n")
 
+(display "[skipped]\n")
 
+; I throw the towel on this one. 4.78 was challenging enough and I want to move
+; on.