felixm/SICP
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Contine to implement query within non-deterministc evaluator

Browse Source
This commit is contained in:
Felix Martin
2021-03-13 11:32:07 -05:00
parent 0d0fc72d8a
commit 1416e3c913
2 changed files with 158 additions and 140 deletions
Download Patch File Download Diff File Expand all files Collapse all files

250
ex-4_78-79.scm
View File

@@ -34,14 +34,14 @@
(newline)
(display output-prompt)
;; [extra newline at end] (announce-output output-prompt)
(display-stream
(stream-map
(display-list
(map
(lambda (frame)
(instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-stream '()))))
(qeval q (singleton-list '()))))
(query-driver-loop)))))
(define (instantiate exp frame unbound-var-handler)
@@ -60,69 +60,69 @@
;;;SECTION 4.4.4.2
;;;The Evaluator
(define (qeval query frame-stream)
(define (qeval query frame-list)
;; (display "QEVAL ") (display query) (newline)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))
(qproc (contents query) frame-list)
(simple-query query frame-list))))
;;;Simple queries
(define (simple-query query-pattern frame-stream)
(define (simple-query query-pattern frame-list)
;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
(stream-flatmap
(flatmap
(lambda (frame)
(stream-append-delayed
(append
(find-assertions query-pattern frame)
(delay (apply-rules query-pattern frame))))
frame-stream))
(apply-rules query-pattern frame)))
frame-list))
;;;Compound queries
(define (conjoin conjuncts frame-stream)
(define (conjoin conjuncts frame-list)
(if (empty-conjunction? conjuncts)
frame-stream
frame-list
(conjoin (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts)
frame-stream))))
frame-list))))
;;(put 'and 'qeval conjoin)
(define (disjoin disjuncts frame-stream)
(define (disjoin disjuncts frame-list)
(if (empty-disjunction? disjuncts)
the-empty-stream
(interleave-delayed
(qeval (first-disjunct disjuncts) frame-stream)
(delay (disjoin (rest-disjuncts disjuncts)
frame-stream)))))
'()
(interleave
(qeval (first-disjunct disjuncts) '())
(disjoin (rest-disjuncts disjuncts) frame-list))))
;;(put 'or 'qeval disjoin)
;;;Filters
(define (negate operands frame-stream)
(stream-flatmap
(define (negate operands frame-list)
(flatmap
(lambda (frame)
(if (stream-null? (qeval (negated-query operands)
(singleton-stream frame)))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(if (null? (qeval (negated-query operands)
(singleton-list frame)))
(singleton-list frame)
'()))
frame-list))
(define (uniquely-asserted query frame-stream)
(stream-flatmap
(define (uniquely-asserted query frame-list)
(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))
(let ((matches (qeval (car query) (singleton-list frame))))
(cond ((null? matches) matches)
((null? (cdr matches)) matches)
(else '()))))
frame-list))
;;(put 'not 'qeval negate)
(define (lisp-value call frame-stream)
(stream-flatmap
(define (lisp-value call frame-list)
(flatmap
(lambda (frame)
(if (execute
(instantiate
@@ -130,34 +130,33 @@
frame
(lambda (v f)
(error "Unknown pat var -- LISP-VALUE" v))))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(singleton-list frame)
'()))
frame-list))
;;(put 'lisp-value 'qeval lisp-value)
(define (execute exp)
(display "EXECUTE ") (display exp) (newline)
(apply (eval (predicate exp) user-initial-environment)
(args exp)))
(define (always-true ignore frame-stream) frame-stream)
(define (always-true ignore frame-list) frame-list)
;;(put 'always-true 'qeval always-true)
;;;SECTION 4.4.4.3
;;;Finding Assertions by Pattern Matching
(define (find-assertions pattern frame)
(stream-flatmap (lambda (datum)
(check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
;; (display "FIND-ASSERTIONS ") (display pattern) (newline)
(flatmap
(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)
the-empty-stream
(singleton-stream match-result))))
'()
(singleton-list match-result))))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
@@ -181,9 +180,9 @@
;;;Rules and Unification
(define (apply-rules pattern frame)
(stream-flatmap (lambda (rule)
(apply-a-rule rule pattern frame))
(fetch-rules pattern frame)))
(flatmap (lambda (rule)
(apply-a-rule rule pattern frame))
(fetch-rules pattern frame)))
(define (apply-a-rule rule query-pattern query-frame)
(let ((clean-rule (rename-variables-in rule)))
@@ -192,9 +191,9 @@
(conclusion clean-rule)
query-frame)))
(if (eq? unify-result 'failed)
the-empty-stream
'()
(qeval (rule-body clean-rule)
(singleton-stream unify-result))))))
(singleton-list unify-result))))))
(define (rename-variables-in rule)
(let ((rule-application-id (new-rule-application-id)))
@@ -253,9 +252,10 @@
;;;SECTION 4.4.4.5
;;;Maintaining the Data Base
(define THE-ASSERTIONS the-empty-stream)
(define THE-ASSERTIONS '())
(define (fetch-assertions pattern frame)
;; (display "FETCH-ASSERTIONS ") (display pattern) (newline)
(if (use-index? pattern)
(get-indexed-assertions pattern)
(get-all-assertions)))
@@ -267,9 +267,9 @@
(define (get-stream key1 key2)
(let ((s (get key1 key2)))
(if s s the-empty-stream)))
(if s s '())))
(define THE-RULES the-empty-stream)
(define THE-RULES '())
(define (fetch-rules pattern frame)
(if (use-index? pattern)
@@ -279,7 +279,7 @@
(define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern)
(stream-append
(append
(get-stream (index-key-of pattern) 'rule-stream)
(get-stream '? 'rule-stream)))
@@ -292,13 +292,13 @@
(store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS
(cons-stream assertion old-assertions))
(cons assertion old-assertions))
'ok))
(define (add-rule! rule)
(store-rule-in-index rule)
(let ((old-rules THE-RULES))
(set! THE-RULES (cons-stream rule old-rules))
(set! THE-RULES (stream rule old-rules))
'ok))
(define (store-assertion-in-index assertion)
@@ -308,8 +308,8 @@
(get-stream key 'assertion-stream)))
(put key
'assertion-stream
(cons-stream assertion
current-assertion-stream))))))
(cons assertion
current-assertion-stream))))))
(define (store-rule-in-index rule)
(let ((pattern (conclusion rule)))
@@ -319,8 +319,8 @@
(get-stream key 'rule-stream)))
(put key
'rule-stream
(cons-stream rule
current-rule-stream)))))))
(cons rule
current-rule-stream)))))))
(define (indexable? pat)
(or (constant-symbol? (car pat))
@@ -336,35 +336,34 @@
;;;SECTION 4.4.4.6
;;;Stream operations
(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1) delayed-s2))))
(define stream-null? null?)
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(interleave-delayed (force delayed-s2)
(delay (stream-cdr s1))))))
(define (interleave s1 s2)
(if (null? s1)
s2
(cons
(car s1)
(interleave s2 (cdr s1)))))
(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
(define (flatmap proc xs)
(flatten (map proc xs)))
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed
(stream-car stream)
(delay (flatten-stream (stream-cdr stream))))))
(define (map proc xs)
(if (null? xs)
'()
(cons (proc (car xs))
(map proc (cdr xs)))))
(define (singleton-stream x)
(cons-stream x the-empty-stream))
(define (flatten stream)
(if (null? stream)
'()
(interleave
(car stream)
(flatten (cdr stream)))))
(define (singleton-list x)
(cons x '()))
;;;SECTION 4.4.4.7
;;;Query syntax procedures
@@ -481,47 +480,14 @@
;;;;Stream support from Chapter 3
(define (display-list s)
(map display-line s))
(define (stream-map proc s)
(if (stream-null? s)
the-empty-stream
(cons-stream (proc (stream-car s))
(stream-map proc (stream-cdr s)))))
(define (stream-for-each proc s)
(if (stream-null? s)
'done
(begin (proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
(define (stream-filter pred stream)
(cond ((stream-null? stream) the-empty-stream)
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(display x)
(newline))
;;;;Table support from Chapter 3, Section 3.3.3 (local tables)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
@@ -561,8 +527,8 @@
(define (initialize-data-base rules-and-assertions)
(define (deal-out r-and-a rules assertions)
(cond ((null? r-and-a)
(set! THE-ASSERTIONS (list->stream assertions))
(set! THE-RULES (list->stream rules))
(set! THE-ASSERTIONS assertions)
(set! THE-RULES rules)
'done)
(else
(let ((s (query-syntax-process (car r-and-a))))
@@ -694,8 +660,32 @@
))
(define (rule-to-be-added? exp)
(eq? (car exp) 'rule))
(define (eval-query input)
(let ((q (query-syntax-process input)))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q)))
((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)
(eval-query
'(and (salary (Bitdiddle Ben) ?ben-amount)
(salary ?person ?amount)
(lisp-value > ?amount ?ben-amount)))
(display "[done]\n")
))
@@ -705,15 +695,5 @@
; evaluator. The next step is to implement analyze-or in the non-deterministic
; evaluator.
; Exercise 4.78. Redesign the query language as a nondeterministic program to
; be implemented using the evaluator of section 4.3, rather than as a stream
; process. In this approach, each query will produce a single answer (rather
; than the stream of all answers) and the user can type try-again to see more
; answers. You should find that much of the mechanism we built in this section
; is subsumed by nondeterministic search and backtracking. You will probably
; also find, however, that your new query language has subtle differences in
; behavior from the one implemented here. Can you find examples that illustrate
; this difference?
(display "\nex-4.79\n")