sicp-ex-4.77

  
  
  
 (define (filter? exp) 
   (or (list-value? exp) 
       (not? exp))) 
  
 (define (conjoin conjuncts frame-stream) 
   (conjoin-mix conjuncts '() frame-stream)) 
  
 (define (conjoin-mix conjs delayed-conjs frame-stream) 
   (if (null? conjs) 
       (if (null? delayed-conjs) 
           frame-stream          ; conjoin finish if both of conjuncts are empty 
           the-empty-stream)     ; no result return cause filters with unbound vars exist 
       (let ((first (first-conjunct conjs)) 
             (rest (rest-conjuncts conjs))) 
         (if (filter? first) 
             (let ((check-result 
                    (conjoin-check first delayed-conjs frame-stream))) 
               (conjoin-mix rest 
                            (car check-result) 
                            (cdr check-result))) 
             (let ((new-frame-stream (qeval first frame-stream))) 
               (let ((delayed-result 
                      (conjoin-delayed delayed-conjs '() new-frame-stream))) 
                 (conjoin-mix rest (car delayed-result) (cdr delayed-result)))))))) 
  
 (define (conjoin-delayed delayed-conjs rest-conjs frame-stream) 
   ; evaluate those conjuncts in delayed-conjs if there are 
   ; enough bindings for them. 
   (if (null? delayed-conjs) 
       (cons rest-conjs frame-stream) 
       (let ((check-result 
              (conjoin-check (first-conjunct delayed-conjs) 
                             rest-conjs frame-stream))) 
         (conjoin-delayed (cdr delayed-conjs) 
                          (car check-result) 
                          (cdr check-result))))) 
  
 (define (conjoin-check target conjs frame-stream) 
   ; Check if there are any unbound vars in target. 
   ; Delay it if there are unbound vars, or just evaluate it. 
   (if (has-unbound-var? (contents target) (stream-car frame-stream)) 
       (cons (cons target conjs) frame-stream) 
       (cons conjs (qeval target frame-stream)))) 
  
 (define (has-unbound-var? exp frame) 
   (define (tree-walk exp) 
     (cond ((var? exp) 
            (let ((binding (binding-in-frame exp frame))) 
              (if binding 
                  (tree-walk (binding-value binding)) 
                  true))) 
           ((pair? exp) 
            (or (tree-walk (car exp)) (tree-walk (cdr exp)))) 
           (else false))) 
   (tree-walk exp)) 

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.

No complicated mechanism is required.

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)