212 lines
6.8 KiB
Scheme
212 lines
6.8 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/sicp-query.scm")
|
|
|
|
(initialize-data-base microshaft-data-base)
|
|
|
|
(display "\nex-4.70 let-in-add-assertion\n")
|
|
|
|
; If we assigned to THE-ASSERTIONS directly then the new stream would reference
|
|
; itself and we would get an endless stream of the current assertion.
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.71 - simpler-simple-query\n")
|
|
|
|
; Using delay for the rule part can help to print at least some results before
|
|
; a potential endless loop.
|
|
|
|
; (eval-query '(rule (married ?x ?y)
|
|
; (married ?y ?x)))
|
|
|
|
; (eval-query '(married Minnie ?x))
|
|
|
|
(display "[answered]\n")
|
|
|
|
; I got this solution from SICP solutions because I could not think of a good
|
|
; example. It would be better to implement the loop-avoidance algorithm than
|
|
; relying on delayed evaluation to get some results, in my opinion.
|
|
|
|
(display "\nex-4.72 - stream-interleave\n")
|
|
|
|
; If only one of the disjuncts produces a result and the others create an
|
|
; endless-loop, interleaving guarantess that we get some results for the valid
|
|
; disjuncts.
|
|
|
|
(display "[answered]\n")
|
|
|
|
|
|
(display "\nex-4.73 - explicit-delay\n")
|
|
|
|
; The second argument to interleave must be delayed explicitly because
|
|
; MIT-Scheme's applicative-order-evaluation would evaluate the complete stream,
|
|
; otherwise. That would make the use of streams pointless.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.74 - simple-stream-flatmap\n")
|
|
|
|
(define (simple-stream-flatmap proc s)
|
|
(simple-flatten (stream-map proc s)))
|
|
|
|
(define (stream-not-null? x)
|
|
(not (stream-null? x)))
|
|
|
|
(define (simple-flatten stream)
|
|
(stream-map stream-car
|
|
(stream-filter stream-not-null? stream)))
|
|
|
|
(eval-query
|
|
'(and (salary (Bitdiddle Ben) ?ben-amount)
|
|
(salary ?person ?amount)
|
|
(lisp-value > ?amount ?ben-amount)))
|
|
(newline)
|
|
|
|
; The query system's behavior does not change because interleaving does not
|
|
; have an effect for empty and singleton streams.
|
|
|
|
(display "\nex-4.75 - unique\n")
|
|
|
|
;(eval-query
|
|
; '(unique (job ?x (computer wizard))))
|
|
;(newline)
|
|
;
|
|
;(eval-query
|
|
; '(unique (job ?x (computer programmer))))
|
|
;(newline)
|
|
;
|
|
;(eval-query
|
|
; '(and (job ?x ?j) (unique (job ?anyone ?j))))
|
|
;(newline)
|
|
;
|
|
;(eval-query
|
|
; '(and (job ?p ?j) (unique (supervisor ?s ?p))))
|
|
;(newline)
|
|
|
|
; Implementation of uniquely-asserted in sicp-query.
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.76 - more-efficient-and\n")
|
|
|
|
; Exercise 4.76. Our implementation of and as a series combination of queries
|
|
; (figure 4.5) is elegant, but it is inefficient because in processing the
|
|
; second query of the and we must scan the data base for each frame produced by
|
|
; the first query. If the data base has N elements, and a typical query
|
|
; produces a number of output frames proportional to N (say N/k), then scanning
|
|
; the data base for each frame produced by the first query will require N2/k
|
|
; calls to the pattern matcher. Another approach would be to process the two
|
|
; clauses of the and separately, then look for all pairs of output frames that
|
|
; are compatible. If each query produces N/k output frames, then this means
|
|
; that we must perform N2/k2 compatibility checks -- a factor of k fewer than
|
|
; the number of matches required in our current method.
|
|
|
|
; Devise an implementation of and that uses this strategy. You must implement a
|
|
; procedure that takes two frames as inputs, checks whether the bindings in the
|
|
; frames are compatible, and, if so, produces a frame that merges the two sets
|
|
; of bindings. This operation is similar to unification.
|
|
|
|
(define (stream-combinations s1 s2)
|
|
(stream-flatmap
|
|
(lambda (x1) (stream-map (lambda (x2) (append x1 x2)) s2))
|
|
s1))
|
|
|
|
(define (conjoin-efficient conjuncts frame-stream)
|
|
(define (unify-bindings bindings)
|
|
(define (go-unify bindings frame)
|
|
(if (null? bindings)
|
|
frame
|
|
(let* ((binding (car bindings))
|
|
(var (predicate binding))
|
|
(val (args binding)))
|
|
(go-unify (cdr bindings) (unify-match var val frame)))))
|
|
(go-unify bindings '()))
|
|
|
|
(define (unify-frame-streams frame-stream-1 frame-stream-2)
|
|
(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 (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 (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))))
|
|
|
|
(conjoin-inner conjuncts frame-stream))
|
|
|
|
(put 'and2 'qeval conjoin-efficient)
|
|
|
|
(eval-query
|
|
'(rule (big-shot ?p)
|
|
(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-filter\n")
|
|
|
|
; I am simply putting conjucts with unbound-variables to the end. We could do
|
|
; better by inserting the conjunct after the next conjunct that has all
|
|
; variables binded, but this implementation works well enough.
|
|
|
|
(define (conjoin3 conjuncts frame-stream)
|
|
(if (empty-conjunction? conjuncts)
|
|
frame-stream
|
|
(let ((first (first-conjunct conjuncts))
|
|
(rest (rest-conjuncts conjuncts)))
|
|
(if (filter-with-unbound-var? first frame-stream)
|
|
(conjoin3 (append rest (list first)) frame-stream)
|
|
(conjoin3 rest (qeval first frame-stream))))))
|
|
|
|
(define (filter-with-unbound-var? operands frame-stream)
|
|
(and (or (tagged-list? operands 'not)
|
|
(tagged-list? operands 'lisp-value))
|
|
(unbound-variables? operands frame-stream)))
|
|
|
|
(define (unbound-variables? operands frame-stream)
|
|
(define (tree-walk e)
|
|
(cond ((var? e) (list e))
|
|
((pair? e) (append (tree-walk (car e))
|
|
(tree-walk (cdr e))))
|
|
(else '())))
|
|
(let ((vars (tree-walk operands))
|
|
(frame (stream-car frame-stream)))
|
|
(define (iter vars)
|
|
(cond ((null? vars) #f)
|
|
((binding-in-frame (car vars) frame) (iter (cdr vars)))
|
|
(else #t)))
|
|
(iter vars)))
|
|
|
|
(put 'and3 'qeval conjoin3)
|
|
|
|
;(eval-query
|
|
; '(and3 (supervisor ?x ?y)
|
|
; (not (job ?x (computer programmer)))))
|
|
;
|
|
;(eval-query
|
|
; '(and3 (not (job ?x (computer programmer)))
|
|
; (supervisor ?x ?y)))
|
|
|
|
(eval-query
|
|
'(rule (can-replace ?p1 ?p2)
|
|
(and (or (and (job ?p1 ?j) (job ?p2 ?j))
|
|
(and (job ?p1 ?j1)
|
|
(job ?p2 ?j2)
|
|
(can-do-job ?j1 ?j2)))
|
|
(not (same ?p1 ?p2)))))
|
|
(eval-query
|
|
'(and3 (lisp-value < ?s1 ?s2)
|
|
(can-replace ?p1 ?p2)
|
|
(salary ?p1 ?s1)
|
|
(salary ?p2 ?s2)))
|
|
(newline)
|