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

240
ex-4_78-79.scm
View File

@@ -34,14 +34,14 @@
(newline) (newline)
(display output-prompt) (display output-prompt)
;; [extra newline at end] (announce-output output-prompt) ;; [extra newline at end] (announce-output output-prompt)
(display-stream (display-list
(stream-map (map
(lambda (frame) (lambda (frame)
(instantiate q (instantiate q
frame frame
(lambda (v f) (lambda (v f)
(contract-question-mark v)))) (contract-question-mark v))))
(qeval q (singleton-stream '())))) (qeval q (singleton-list '()))))
(query-driver-loop))))) (query-driver-loop)))))
(define (instantiate exp frame unbound-var-handler) (define (instantiate exp frame unbound-var-handler)
@@ -60,69 +60,69 @@
;;;SECTION 4.4.4.2 ;;;SECTION 4.4.4.2
;;;The Evaluator ;;;The Evaluator
(define (qeval query frame-stream) (define (qeval query frame-list)
;; (display "QEVAL ") (display query) (newline)
(let ((qproc (get (type query) 'qeval))) (let ((qproc (get (type query) 'qeval)))
(if qproc (if qproc
(qproc (contents query) frame-stream) (qproc (contents query) frame-list)
(simple-query query frame-stream)))) (simple-query query frame-list))))
;;;Simple queries ;;;Simple queries
(define (simple-query query-pattern frame-stream) (define (simple-query query-pattern frame-list)
;; (display "SIMPLE-QUERY ") (display query-pattern) (newline) ;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
(stream-flatmap (flatmap
(lambda (frame) (lambda (frame)
(stream-append-delayed (append
(find-assertions query-pattern frame) (find-assertions query-pattern frame)
(delay (apply-rules query-pattern frame)))) (apply-rules query-pattern frame)))
frame-stream)) frame-list))
;;;Compound queries ;;;Compound queries
(define (conjoin conjuncts frame-stream) (define (conjoin conjuncts frame-list)
(if (empty-conjunction? conjuncts) (if (empty-conjunction? conjuncts)
frame-stream frame-list
(conjoin (rest-conjuncts conjuncts) (conjoin (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts) (qeval (first-conjunct conjuncts)
frame-stream)))) frame-list))))
;;(put 'and 'qeval conjoin) ;;(put 'and 'qeval conjoin)
(define (disjoin disjuncts frame-stream) (define (disjoin disjuncts frame-list)
(if (empty-disjunction? disjuncts) (if (empty-disjunction? disjuncts)
the-empty-stream '()
(interleave-delayed (interleave
(qeval (first-disjunct disjuncts) frame-stream) (qeval (first-disjunct disjuncts) '())
(delay (disjoin (rest-disjuncts disjuncts) (disjoin (rest-disjuncts disjuncts) frame-list))))
frame-stream)))))
;;(put 'or 'qeval disjoin) ;;(put 'or 'qeval disjoin)
;;;Filters ;;;Filters
(define (negate operands frame-stream) (define (negate operands frame-list)
(stream-flatmap (flatmap
(lambda (frame) (lambda (frame)
(if (stream-null? (qeval (negated-query operands) (if (null? (qeval (negated-query operands)
(singleton-stream frame))) (singleton-list frame)))
(singleton-stream frame) (singleton-list frame)
the-empty-stream)) '()))
frame-stream)) frame-list))
(define (uniquely-asserted query frame-stream) (define (uniquely-asserted query frame-list)
(stream-flatmap (flatmap
(lambda (frame) (lambda (frame)
(let ((matches (qeval (car query) (singleton-stream frame)))) (let ((matches (qeval (car query) (singleton-list frame))))
(cond ((stream-null? matches) matches) (cond ((null? matches) matches)
((stream-null? (stream-cdr matches)) matches) ((null? (cdr matches)) matches)
(else the-empty-stream)))) (else '()))))
frame-stream)) frame-list))
;;(put 'not 'qeval negate) ;;(put 'not 'qeval negate)
(define (lisp-value call frame-stream) (define (lisp-value call frame-list)
(stream-flatmap (flatmap
(lambda (frame) (lambda (frame)
(if (execute (if (execute
(instantiate (instantiate
@@ -130,34 +130,33 @@
frame frame
(lambda (v f) (lambda (v f)
(error "Unknown pat var -- LISP-VALUE" v)))) (error "Unknown pat var -- LISP-VALUE" v))))
(singleton-stream frame) (singleton-list frame)
the-empty-stream)) '()))
frame-stream)) frame-list))
;;(put 'lisp-value 'qeval lisp-value) ;;(put 'lisp-value 'qeval lisp-value)
(define (execute exp) (define (execute exp)
(display "EXECUTE ") (display exp) (newline)
(apply (eval (predicate exp) user-initial-environment) (apply (eval (predicate exp) user-initial-environment)
(args exp))) (args exp)))
(define (always-true ignore frame-stream) frame-stream) (define (always-true ignore frame-list) frame-list)
;;(put 'always-true 'qeval always-true) ;;(put 'always-true 'qeval always-true)
;;;SECTION 4.4.4.3
;;;Finding Assertions by Pattern Matching
(define (find-assertions pattern frame) (define (find-assertions pattern frame)
(stream-flatmap (lambda (datum) ;; (display "FIND-ASSERTIONS ") (display pattern) (newline)
(check-an-assertion datum pattern frame)) (flatmap
(lambda (datum) (check-an-assertion datum pattern frame))
(fetch-assertions pattern frame))) (fetch-assertions pattern frame)))
(define (check-an-assertion assertion query-pat query-frame) (define (check-an-assertion assertion query-pat query-frame)
(let ((match-result (let ((match-result
(pattern-match query-pat assertion query-frame))) (pattern-match query-pat assertion query-frame)))
(if (eq? match-result 'failed) (if (eq? match-result 'failed)
the-empty-stream '()
(singleton-stream match-result)))) (singleton-list match-result))))
(define (pattern-match pat dat frame) (define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed) (cond ((eq? frame 'failed) 'failed)
@@ -181,7 +180,7 @@
;;;Rules and Unification ;;;Rules and Unification
(define (apply-rules pattern frame) (define (apply-rules pattern frame)
(stream-flatmap (lambda (rule) (flatmap (lambda (rule)
(apply-a-rule rule pattern frame)) (apply-a-rule rule pattern frame))
(fetch-rules pattern frame))) (fetch-rules pattern frame)))
@@ -192,9 +191,9 @@
(conclusion clean-rule) (conclusion clean-rule)
query-frame))) query-frame)))
(if (eq? unify-result 'failed) (if (eq? unify-result 'failed)
the-empty-stream '()
(qeval (rule-body clean-rule) (qeval (rule-body clean-rule)
(singleton-stream unify-result)))))) (singleton-list unify-result))))))
(define (rename-variables-in rule) (define (rename-variables-in rule)
(let ((rule-application-id (new-rule-application-id))) (let ((rule-application-id (new-rule-application-id)))
@@ -253,9 +252,10 @@
;;;SECTION 4.4.4.5 ;;;SECTION 4.4.4.5
;;;Maintaining the Data Base ;;;Maintaining the Data Base
(define THE-ASSERTIONS the-empty-stream) (define THE-ASSERTIONS '())
(define (fetch-assertions pattern frame) (define (fetch-assertions pattern frame)
;; (display "FETCH-ASSERTIONS ") (display pattern) (newline)
(if (use-index? pattern) (if (use-index? pattern)
(get-indexed-assertions pattern) (get-indexed-assertions pattern)
(get-all-assertions))) (get-all-assertions)))
@@ -267,9 +267,9 @@
(define (get-stream key1 key2) (define (get-stream key1 key2)
(let ((s (get 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) (define (fetch-rules pattern frame)
(if (use-index? pattern) (if (use-index? pattern)
@@ -279,7 +279,7 @@
(define (get-all-rules) THE-RULES) (define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern) (define (get-indexed-rules pattern)
(stream-append (append
(get-stream (index-key-of pattern) 'rule-stream) (get-stream (index-key-of pattern) 'rule-stream)
(get-stream '? 'rule-stream))) (get-stream '? 'rule-stream)))
@@ -292,13 +292,13 @@
(store-assertion-in-index assertion) (store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS)) (let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS (set! THE-ASSERTIONS
(cons-stream assertion old-assertions)) (cons assertion old-assertions))
'ok)) 'ok))
(define (add-rule! rule) (define (add-rule! rule)
(store-rule-in-index rule) (store-rule-in-index rule)
(let ((old-rules THE-RULES)) (let ((old-rules THE-RULES))
(set! THE-RULES (cons-stream rule old-rules)) (set! THE-RULES (stream rule old-rules))
'ok)) 'ok))
(define (store-assertion-in-index assertion) (define (store-assertion-in-index assertion)
@@ -308,7 +308,7 @@
(get-stream key 'assertion-stream))) (get-stream key 'assertion-stream)))
(put key (put key
'assertion-stream 'assertion-stream
(cons-stream assertion (cons assertion
current-assertion-stream)))))) current-assertion-stream))))))
(define (store-rule-in-index rule) (define (store-rule-in-index rule)
@@ -319,7 +319,7 @@
(get-stream key 'rule-stream))) (get-stream key 'rule-stream)))
(put key (put key
'rule-stream 'rule-stream
(cons-stream rule (cons rule
current-rule-stream))))))) current-rule-stream)))))))
(define (indexable? pat) (define (indexable? pat)
@@ -336,35 +336,34 @@
;;;SECTION 4.4.4.6 ;;;SECTION 4.4.4.6
;;;Stream operations ;;;Stream operations
(define (stream-append-delayed s1 delayed-s2) (define stream-null? null?)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1) delayed-s2))))
(define (interleave-delayed s1 delayed-s2) (define (interleave s1 s2)
(if (stream-null? s1) (if (null? s1)
(force delayed-s2) s2
(cons-stream (cons
(stream-car s1) (car s1)
(interleave-delayed (force delayed-s2) (interleave s2 (cdr s1)))))
(delay (stream-cdr s1))))))
(define (stream-flatmap proc s) (define (flatmap proc xs)
(flatten-stream (stream-map proc s))) (flatten (map proc xs)))
(define (flatten-stream stream) (define (map proc xs)
(if (stream-null? stream) (if (null? xs)
the-empty-stream '()
(interleave-delayed (cons (proc (car xs))
(stream-car stream) (map proc (cdr xs)))))
(delay (flatten-stream (stream-cdr stream))))))
(define (singleton-stream x) (define (flatten stream)
(cons-stream x the-empty-stream)) (if (null? stream)
'()
(interleave
(car stream)
(flatten (cdr stream)))))
(define (singleton-list x)
(cons x '()))
;;;SECTION 4.4.4.7 ;;;SECTION 4.4.4.7
;;;Query syntax procedures ;;;Query syntax procedures
@@ -481,47 +480,14 @@
;;;;Stream support from Chapter 3 ;;;;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) (define (display-line x)
(newline) (display x)
(display x)) (newline))
(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)))))
;;;;Table support from Chapter 3, Section 3.3.3 (local tables) ;;;;Table support from Chapter 3, Section 3.3.3 (local tables)
(define (make-table) (define (make-table)
(let ((local-table (list '*table*))) (let ((local-table (list '*table*)))
(define (lookup key-1 key-2) (define (lookup key-1 key-2)
@@ -561,8 +527,8 @@
(define (initialize-data-base rules-and-assertions) (define (initialize-data-base rules-and-assertions)
(define (deal-out r-and-a rules assertions) (define (deal-out r-and-a rules assertions)
(cond ((null? r-and-a) (cond ((null? r-and-a)
(set! THE-ASSERTIONS (list->stream assertions)) (set! THE-ASSERTIONS assertions)
(set! THE-RULES (list->stream rules)) (set! THE-RULES rules)
'done) 'done)
(else (else
(let ((s (query-syntax-process (car r-and-a)))) (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) (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") (display "[done]\n")
)) ))
@@ -705,15 +695,5 @@
; evaluator. The next step is to implement analyze-or in the non-deterministic ; evaluator. The next step is to implement analyze-or in the non-deterministic
; evaluator. ; 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") (display "\nex-4.79\n")

48
misc/sicp-ambeval.scm
View File

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