oink.scheme

oink.scheme

 (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)) 
  
 (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) 

(qeval q (singleton-stream '(list '() '())))))


(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))


(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))))


(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))))

(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)