Finish 4.78 and skip 4.79

ex-4_78-79.scm

@@ -19,30 +19,8 @@
 
 (amball '(begin
 
-(define input-prompt ";;; Query input:")
+(define (require p)
-(define output-prompt ";;; Query results:")
+  (if (null? p) (amb)))
-
-(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 (instantiate exp frame unbound-var-handler)
   (define (copy exp)
@@ -56,59 +34,42 @@
           (else exp)))
   (copy exp))
 
-
+(define (qeval query frame)
-;;;SECTION 4.4.4.2
-;;;The Evaluator
-
-(define (qeval query frame-list)
-  ;; (display "QEVAL ") (display query) (newline)
   (let ((qproc (get (type query) 'qeval)))
     (if qproc
-        (qproc (contents query) frame-list)
+        (qproc (contents query) frame)
-        (simple-query query frame-list))))
+        (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)
+(define (conjoin conjuncts frame)
-  ;; (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)
   (if (empty-conjunction? conjuncts)
-      frame-list
+      frame
       (conjoin (rest-conjuncts conjuncts)
-               (qeval (first-conjunct conjuncts)
+               (qeval (first-conjunct conjuncts) frame))))
-                      frame-list))))
 
-;;(put 'and 'qeval conjoin)
+(define (disjoin disjuncts frame)
-
-
-(define (disjoin disjuncts frame-list)
   (if (empty-disjunction? disjuncts)
-      '()
+      (amb)
-      (interleave
+      (let ((r1 (qeval (first-disjunct disjuncts) frame)))
-       (qeval (first-disjunct disjuncts) '())
+        (if (null? r1)
-       (disjoin (rest-disjuncts disjuncts) frame-list))))
+          (disjoin (rest-disjuncts disjuncts) frame)
+          (amb r1 (disjoin (rest-disjuncts disjuncts) frame))))))
 
 ;;(put 'or 'qeval disjoin)
 
 ;;;Filters
 
-(define (negate operands frame-list)
+(define (negate operands frame)
-  (flatmap
+  (if (null? (qeval (negated-query operands) frame))
-   (lambda (frame)
+    frame
-     (if (null? (qeval (negated-query operands)
+    (amb)))
-                       (singleton-list frame)))
-         (singleton-list frame)
-         '()))
-   frame-list))
 
 (define (uniquely-asserted query frame-list)
   (flatmap
@@ -121,19 +82,15 @@
 
 ;;(put 'not 'qeval negate)
 
-(define (lisp-value call frame-list)
+(define (lisp-value call frame)
-  (flatmap
-   (lambda (frame)
    (if (execute
          (instantiate
          call
          frame
          (lambda (v f)
            (error "Unknown pat var -- LISP-VALUE" v))))
-         (singleton-list frame)
+         frame
-         '()))
+         (amb)))
-   frame-list))
-
 ;;(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
+  (define (check xs)
-    (lambda (datum) (check-an-assertion datum pattern frame))
+    (if (null? xs)
-    (fetch-assertions pattern frame)))
+      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
+            (instantiate
-            (map
+              q
-             (lambda (frame)
+             (qeval q '())
-               (instantiate q
+             (lambda (v f) (contract-question-mark v)))))))
-                            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.
 
 (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
+;(eval-query '(supervisor ?x (bitdiddle ben)))
-; amb.
 
-(eval-query
+;(eval-query
-  '(rule (big-shot ?p)
+;  '(and (supervisor ?person (Bitdiddle Ben))
-    (and (job ?p (?div1 . ?rest1))
+;        (address ?person  ?address)))
-         (supervisor ?p ?boss)
+
-         (job ?boss (?div2 . ?rest2))
+;(eval-query
-         (not (same ?div1 ?div2)))))
+;  '(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.

ex-5_01-xx.scm

@@ -0,0 +1,3 @@
+(load "util.scm")
+
+(display "\nex-5.1\n")

misc/sicp-ambeval.scm

@@ -363,23 +363,25 @@
 
 
 ;;;Code from SECTION 4.3.3, modified as needed to run it
-
 (define (amb? exp) (tagged-list? exp 'amb))
 (define (amb-choices exp) (cdr exp))
 
 (define (ramb? exp) (tagged-list? exp 'ramb))
 (define (ramb-choices exp) (cdr exp))
 
-; The lamb statement takes a single list and treats each item as a value. So
+;; lamb takes a list and treats each element as a separate amb-value
-; its the equivalent of (apply amb list) in Scheme.  Since our evaluator does
-; not support that expression we use lamb. Analyze-lamb calls analyze-amb.
 (define (lamb? exp) (tagged-list? exp 'lamb))
-(define (lamb-choices exp) (cdr exp))
+(define (lamb-arg exp) (cadr exp))
 (define (analyze-lamb exp)
-  (analyze-amb (cons (car exp) (cadr exp))))
+  (let ((p (analyze (lamb-arg exp))))
+    (lambda (env succeed fail)
+      (define (try-options options fail2)
+        (if (null? options)
+          (fail)
+          (succeed (car options) (lambda () (try-options (cdr options) fail2)))))
+      (p env try-options fail))))
 
-;; analyze from 4.1.6, with clause from 4.3.3 added
+;; analyze from 4.1.6, with clause from 4.3.3 added and also support for let
-;; and also support for Let
 (define (analyze exp)
   (cond ((self-evaluating? exp)
          (analyze-self-evaluating exp))
@@ -666,13 +668,14 @@
   (list (list '* *)
         (list '+ +)
         (list '- -)
+        (list '< <)
         (list '<= <=)
         (list '= =)
         (list '> >)
         (list '>= >=)
         (list 'abs abs)
-        (list 'assoc assoc)
         (list 'append append)
+        (list 'assoc assoc)
         (list 'caddr caddr)
         (list 'cadr cadr)
         (list 'car car)
@@ -680,8 +683,8 @@
         (list 'cdr cdr)
         (list 'cons cons)
         (list 'display display)
-        (list 'equal? equal?)
         (list 'eq? eq?)
+        (list 'equal? equal?)
         (list 'integer? integer?)
         (list 'list list)
         (list 'member member)
@@ -689,12 +692,14 @@
         (list 'newline newline)
         (list 'not not)
         (list 'null? null?)
+        (list 'number? number?)
         (list 'pair? pair?)
         (list 'remainder remainder)
         (list 'set-car! set-car!)
         (list 'set-cdr! set-cdr!)
         (list 'sqrt sqrt)
         (list 'string->symbol string->symbol)
+        (list 'string-append string-append)
         (list 'string-length string-length)
         (list 'string=? string=?)
         (list 'substring substring)