<< Previous exercise (4.76) | Index | Next exercise (4.78) >>
we can simply rearrange the order of clauses of compound queries by putting all filters at the end, which is an efficient and trivial method. In order to accomplish this, we will normalize the non-normalized compound queries during the parse phase of qeval.
;;; Exercise 4.77 (define compound-table '()) (define (put-compound combinator) (set! compound-table (cons combinator compound-table))) (define (compound? query) (memq (type query) compound-table)) (define filter-table '()) (define (put-filter operator) (set! filter-table (cons operator filter-table))) (define (filter? query) (memq (type query) filter-table)) (define (normalize clauses) (let ((filters (filter filter? clauses)) (non-filters (filter (lambda (x) (not (filter? x))) clauses))) (append non-filters filters))) (define (qeval query frame-stream) (let ((qproc (get (type query) 'qeval))) (cond ((compound? query) (qproc (normalize (contents query)) frame-stream)) (qproc (qproc (contents query) frame-stream)) (else (simple-query query frame-stream))))) (put-compound 'and) (put-filter 'not) (put-filter 'lisp-value) (put-filter 'unique)
First of all, having used this site as a reference for most exercises until 4.77, I am glad to contribute my 2 cents!
The easiest path would have been to push all the filters to the end, but the question explicitly states that it is inefficient (as per my understanding, it is stating that even if one variable is available out of all those required by the filter, it is better to perform a partial filter in the hope that the frame count will decrease).
So as directed by the book, I am appending promises to frames. The word promise is used in quotes, so I interpreted it as not an intention to use literal promises, but one that is conceptually an agreement to check. For this, the structure of frame is changed into a list of 2 elements - one for bindings, the other for promises (the following line is the entry point):
(qeval q (singleton-stream '(list '() '())))))
The following is the new negate function:
(define (negate operands frame-stream)
(simple-stream-flatmap
(lambda (frame)
(let ((replaced (instantiate (negated-query operands) frame (lambda (v f) v)))
(check (has-unbound-variables? (negated-query operands) frame)))
(if (stream-null?
(qeval (negated-query operands)
(singleton-stream frame)))
(if check
(singleton-stream (add-promise (list 'not replaced) frame))
(singleton-stream frame))
(if check
(singleton-stream (add-promise (list 'not replaced) frame))
the-empty-stream))))
frame-stream))
Negate sends back the empty stream only in the case where the filter fails AND there are no unbound variables. Note what is being added in the promise; the instantiated query is being added, so that the next time this filter is checked, any variables that were found will already be there.
find-assertions is where the promise handling is done:
(define (find-assertions pattern frame)
(simple-stream-flatmap
(lambda (datum)
(let ((check-result (check-an-assertion datum pattern frame)))
(if (stream-null? check-result)
check-result
(handle-promises (stream-car check-result)))))
(fetch-assertions pattern frame)))
(define (handle-promises frame)
(define (iter promises frame)
(if (null? promises)
(singleton-stream frame)
(let ((result (qeval (car promises) (singleton-stream frame))))
(if (stream-null? result)
the-empty-stream
(iter (cdr promises) (stream-car result))))))
(let ((current-promises (get-promises frame)))
(iter current-promises (remove-promises frame))))
The result of check-an-assertion isn't sent directly; instead, this new frame stream is examined for promises. In handle-promises, I iterate over the current existing promises and remove the frame's promises entirely. The idea is that when qeval is called inside again, and some promises still aren't satisfied due to unbound variables still remaining, then they will get re-inserted into the frame again.
Here are the frame operations:
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding) (car binding))
(define (binding-value binding) (cdr binding))
(define (binding-in-frame variable frame)
(assoc variable (car frame)))
(define (extend variable value frame)
(list (cons (make-binding variable value) (car frame))
(cadr frame)))
(define (add-promise promise frame)
(list (car frame)
(cons promise (cadr frame))))
(define (get-promises frame) (cadr frame))
(define (remove-promises frame) (list (car frame) '()frame))
And the helper function:
(define (has-unbound-variables? pattern frame)
(cond ((null? pattern) #f)
((var? (car pattern))
(let ((b (binding-in-frame (car pattern) frame)))
(if b
(has-unbound-variables? (cdr pattern) frame)
#t)))
(else (has-unbound-variables? (cdr pattern) frame))))
I built this structure around negation first, and then modifying lisp-value was trivial:
(define (lisp-value call frame-stream)
(simple-stream-flatmap
(lambda (frame)
(let ((replaced (instantiate call frame (lambda (v f) v)))
(check (has-unbound-variables? call frame)))
(if (not check)
(if (execute replaced)
(singleton-stream frame)
the-empty-stream)
(singleton-stream (add-promise (cons 'lisp-value replaced) frame)))))
frame-stream))
(put 'lisp-value 'qeval lisp-value)
Note that in adding promise here, cons is used to combine 'lisp-value instead of list as in negate.
unique is also sort of filter, but won't work with this because the contents of unique usually contain at least one variable that is not relevant with other variables.