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

Implement 4.76

main
Felix Martin 2021-03-07 11:28:36 -05:00
parent 751e20229c
commit 66726a21f8
1 changed files with 44 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
ex-4_70-79.scm
View File

@ -108,7 +108,7 @@
(lambda (x1) (stream-map (lambda (x2) (append x1 x2)) s2))
s1))
(define (conjoin conjuncts frame-stream)
(define (conjoin-efficient conjuncts frame-stream)
(define (unify-bindings bindings)
(define (go-unify bindings frame)
(if (null? bindings)
@ -120,42 +120,65 @@
(go-unify bindings '()))
(define (unify-frame-streams frame-stream-1 frame-stream-2)
(display "UNIFY-FRAME-STREAMS\n")
(let ((potential-bindings (stream-combinations frame-stream-1 frame-stream-2)))
(stream-filter
(lambda (f) (not (eq? f 'failed)))
(stream-map unify-bindings potential-bindings))))
(define (unify-frame-stream-list frame-stream-list)
(if (null? (cdr frame-stream-list))
(car frame-stream-list)
(let ((frame-stream (unify-frame-streams (car frame-stream-list)
(cadr frame-stream-list))))
(display frame-stream) (newline)
(unify-frame-stream-list (cons frame-stream (cddr frame-stream-list))))))
(define (conjoin-single conjunct frame-stream-1)
(if (not (tagged-list? conjunct 'not))
(unify-frame-streams
frame-stream-1
(qeval conjunct frame-stream)) ; process separately
(qeval conjunct frame-stream-1))) ; cannot process not separately
(define (qeval-conjunction conjunction)
(qeval conjunction frame-stream))
(define (conjoin-inner conjuncts frame-stream)
(if (null? conjuncts)
frame-stream
(let ((new-frame-stream (conjoin-single (car conjuncts) frame-stream)))
(conjoin-inner (cdr conjuncts) new-frame-stream))))
(let ((frame-stream-list (map qeval-conjunction conjuncts)))
(unify-frame-stream-list frame-stream-list)))
(conjoin-inner conjuncts frame-stream))
(put 'and 'qeval conjoin)
(put 'and2 'qeval conjoin-efficient)
(eval-query
'(rule (big-shot ?p)
(and (job ?p (?div1 . ?rest1))
(supervisor ?p ?boss)
(job ?boss (?div2 . ?rest2))
(not (same ?div1 ?div2)))))
(and2 (job ?p (?div1 . ?rest1))
(supervisor ?p ?boss)
(job ?boss (?div2 . ?rest2))
(not (same ?div1 ?div2)))))
(eval-query '(big-shot ?x))
(newline)
(display "\nex-4.77 - improved-not\n")
; Exercise 4.77. In section 4.4.3 we saw that not and lisp-value can cause the
; query language to give ``wrong'' answers if these filtering operations are
; applied to frames in which variables are unbound. Devise a way to fix this
; shortcoming.
; One idea is to perform the filtering in a ``delayed'' manner by
; appending to the frame a ``promise'' to filter that is fulfilled only when
; enough variables have been bound to make the operation possible. We could
; wait to perform filtering until all other operations have been performed.
; However, for efficiency's sake, we would like to perform filtering as soon as
; possible so as to cut down on the number of intermediate frames generated.
(display "--")
(eval-query
'(and (supervisor ?x ?y)
(not (job ?x (computer programmer)))))
(display "\n--\n")
(display "\nex-4.77\n")
(display "--")
(eval-query
'(and (not (job ?x (computer programmer)))
(supervisor ?x ?y)))
(display "\n--\n")
;(display "\nex-4.78\n")
;(display "\nex-4.79\n")
(display "\nex-4.78\n")
(display "\nex-4.79\n")