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

Contine to implement query within non-deterministc evaluator

main
Felix Martin 2021-03-13 11:32:07 -05:00
parent 0d0fc72d8a
commit 1416e3c913
2 changed files with 158 additions and 140 deletions
Show Stats 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")

48
misc/sicp-ambeval.scm
View File

@ -394,21 +394,27 @@
((if-fail? exp) (analyze-if-fail exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((apply? exp) (analyze-apply (cdr exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp))) ;**
((amb? exp) (analyze-amb exp)) ;**
((ramb? exp) (analyze-ramb exp)) ;**
((lamb? exp) (analyze-lamb exp)) ;**
((or? exp) (analyze-or exp))
((or? exp) (analyze-or (clauses exp)))
((and? exp) (analyze-and (clauses exp)))
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(define (apply? exp) (tagged-list? exp 'apply))
(define (analyze-apply exp)
(display "ANALYZE-APPLY ") (newline)
(display exp)
(lambda (env succeed fail) (succeed #t fail)))
(define (ambeval exp env succeed fail)
((analyze exp) env succeed fail))
;;;Simple expressions
(define (analyze-self-evaluating exp)
(lambda (env succeed fail)
(succeed exp fail)))
@ -431,11 +437,39 @@
fail))))
(define (or? exp) (tagged-list? exp 'or))
(define (and? exp) (tagged-list? exp 'and))
(define (clauses exp) (cdr exp))
(define (no-clauses? exp) (null? exp))
(define (first-clause exp) (car exp))
(define (rest-clauses exp) (cdr exp))
; TODO: (define (analyze-or exp) ...)
(define (analyze-or exp)
(if (no-clauses? exp)
(lambda (env succeed fail) (succeed #f fail))
(let ((cproc (analyze (first-clause exp))))
(lambda (env succeed fail)
(cproc
env
;; success continuation for clause value
(lambda (clause-value fail2)
(if (true? clause-value)
(succeed #t fail2)
((analyze-or (rest-clauses exp)) env succeed fail2)))
fail)))))
(define (analyze-and exp)
(if (no-clauses? exp)
(lambda (env succeed fail) (succeed #t fail))
(let ((cproc (analyze (first-clause exp))))
(lambda (env succeed fail)
(cproc
env
;; success continuation for clause value
(lambda (clause-value fail2)
(if (true? clause-value)
((analyze-and (rest-clauses exp)) env succeed fail2)
(succeed #f fail2)))
fail)))))
;;;Conditionals and sequences
(define (analyze-if exp)
@ -647,10 +681,13 @@
(list '>= >=)
(list 'abs abs)
(list 'assoc assoc)
(list 'append append)
(list 'cadr cadr)
(list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'display display)
(list 'equal? equal?)
(list 'eq? eq?)
(list 'integer? integer?)
(list 'list list)
@ -664,11 +701,12 @@
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'sqrt sqrt)
(list 'string->symbol string->symbol)
(list 'string-length string-length)
(list 'string=? string=?)
(list 'substring substring)
(list 'symbol->string symbol->string)
(list 'symbol? symbol?)
(list 'the-empty-stream the-empty-stream)
))
'AMB-EVALUATOR-LOADED