(require (lib "compat.ss"))

(define (instantiate expr frame variable-handler)
  (define (copy expr)
    (cond ((var? expr)
           (let ((binding (assoc expr frame)))
	      (if binding (copy (cdr binding)) (variable-handler expr frame))))
          ((pair? expr) (cons (copy (car expr)) (copy (cdr expr))))
          (else expr)))
  (copy expr))

(define (query-r-e-p)
  (newline)
  (display ";;; Query input:")
  (let ((q (change-variable-representation (read))))
    (cond ((and (pair? q) (eq? (car q) 'assert))
           (add-rule-or-assertion! (cadr q))
	   (newline)
	   (display "Assertion added to data base.")
	   (query-r-e-p))
          (else
	    (newline)
	    (display ";;; Query results:")
	    (display-stream
	      (stream-map
	        (lambda (frame)
		  (instantiate q frame (lambda (v f) (contract-question-mark v))))
	        (qeval q (singleton-stream ()))))
	    (query-r-e-p)))))

(define (qeval query frame-stream)
  (let ((qproc (getprop (car query) 'qeval)))
    (if qproc
        (qproc (cdr query) frame-stream)
	(answer-query query frame-stream))))

(define (answer-query query frame-stream)
  (stream-flatmap
    (lambda (frame)
      (stream-append-delayed
        (find-assertions query frame)
	(delay (apply-rules query frame))))
    frame-stream))

(define (conjoin conjuncts frame-stream)
  (if (null? conjuncts)
      frame-stream
      (conjoin (cdr conjuncts) (qeval (car conjuncts) frame-stream))))

(putprop 'and 'qeval conjoin)

(define (disjoin disjuncts frame-stream)
  (if (null? disjuncts)
    the-empty-stream
    (interleave-delayed
      (qeval (car disjuncts) frame-stream)
      (delay (disjoin (cdr disjuncts) frame-stream)))))

(putprop 'or 'qeval disjoin)

(define (negate args frame-stream)
  (stream-flatmap
    (lambda (frame)
      (if (stream-null? (qeval (car args) (singleton-stream frame)))
          (singleton-stream frame)
	  the-empty-stream))
    frame-stream))

(putprop 'not 'qeval negate)

(define (lisp-value call frame-stream)
  (stream-flatmap
    (lambda (frame)
      (if (execute
            (instantiate  call
	                  frame
			  (lambda (v f) (error "unknown var in lisp-value" v))))
          (singleton-stream frame)
	  the-empty-stream))
    frame-stream))

(putprop 'lisp-value 'qeval lisp-value)

(define (execute expr) (apply (eval (car expr)) (cdr expr)))

(define (always-true query frame-stream) frame-stream)

(putprop 'always-true 'qeval always-true)

(define (find-assertions query frame)
  (stream-flatmap (lambda (fact) (check-an-assertion fact query frame))
	          (fetch-assertions query frame)))

(define (check-an-assertion fact query frame)
  (let ((result (unify query fact frame)))
       (if (eq? result 'failed) the-empty-stream (singleton-stream result))))

(define (apply-rules query frame)
  (stream-flatmap (lambda (rule) (apply-a-rule rule query frame))
                  (fetch-rules query frame)))

(define (apply-a-rule rule query frame)
  (let ((clean-rule (rename-variables-in rule)))
    (let ((result (unify query (cadr clean-rule) frame)))
      (if (eq? result 'failed)
          the-empty-stream
	  (qeval (if (null? (cddr clean-rule))
		     '(always-true)
		     (caddr clean-rule))
	         (singleton-stream result))))))

(define (rename-variables-in rule)
  (let ((rule-application-id (new-number)))
    (define (tree-walk expr)
      (cond ((var? expr) (list '? (cadr expr) rule-application-id))
            ((pair? expr)
	     (cons (tree-walk (car expr)) (tree-walk (cdr expr))))
            (else expr)))
    (tree-walk rule)))

(define (unify p1 p2 frame)
  (cond ((eq? frame 'failed) 'failed)
        ((equal? p1 p2) frame)
	((var? p1) (extend-if-possible p1 p2 frame))
	((var? p2) (extend-if-possible p2 p1 frame))
	((and (pair? p1) (pair? p2))
	  (unify (cdr p1) (cdr p2) (unify (car p1) (car p2) frame)))
        (else 'failed)))

(define (extend-if-possible var val frame)
  (let ((binding (assoc var frame)))
    (cond (binding
           (unify (cdr binding) val frame))
          ((var? val)
	   (let ((binding (assoc val frame)))
	     (if binding
	         (unify var (cdr binding) frame)
		 (cons (cons var val) frame))))
	  ((depends-on? val var frame) 'failed)
          (else (cons (cons var val) frame)))))

(define (depends-on? expr var frame)
  (define (tree-walk e)
    (cond ((var? e)
           (if (equal? var e)
	       #t
	       (let ((b (assoc e frame)))
	         (if b (tree-walk (cdr b)) #f))))
          ((pair? e)
	   (or (tree-walk (car e)) (tree-walk (cdr e))))
          (else #f)))
  (tree-walk expr))

(define (get-stream key1 key2)
   (let ((stream (getprop key1 key2)))
        (if stream stream the-empty-stream)))

(define (fetch-assertions query frame)
  (get-stream (car query) 'assertion-stream))

(define (fetch-rules query frame)
  (get-stream (car query) 'rule-stream))

(define (add-rule-or-assertion! expr)
  (if (eq? (car expr) 'rule)
      (add-rule! expr)
      (add-assertion! expr)))

(define-syntax cons-stream
  (syntax-rules () ((cons-stream val expr) (cons val (delay expr)))))


(define (add-assertion! assertion)
  (let ((key (car assertion)))
    (let ((current (get-stream key 'assertion-stream)))
         (putprop key
                  'assertion-stream
		  (cons-stream assertion current)))))

(define (add-rule! rule)
  (let ((key (caadr rule)))
    (let ((current (get-stream key 'rule-stream)))
         (putprop key
	          'rule-stream
		  (cons-stream rule current)))))

; stream operations

(define (stream-append-delayed s1 s2-delayed)
  (if (stream-null? s1)
      (force s2-delayed)
      (cons-stream (stream-car s1)
                    (stream-append-delayed (stream-cdr s1) s2-delayed))))

(define (interleave-delayed s1 s2-delayed)
  (if (stream-null? s1)
      (force s2-delayed)
      (cons-stream (stream-car s1)
                   (interleave-delayed (force s2-delayed)
		                       (delay (stream-cdr s1))))))

(define (stream-flatmap proc stream) (flatten-stream (stream-map proc stream)))

(define (flatten-stream stream)
  (if (stream-null? stream)
      the-empty-stream
      (interleave-delayed (stream-car stream)
                          (delay (flatten-stream (stream-cdr stream))))))

(define (singleton-stream x) (cons-stream x the-empty-stream))

(define the-empty-stream ())

(define (stream-null? x) (null? x))

(define (stream-car stream) (car stream))

(define (stream-cdr stream) (force (cdr stream)))

(define (stream-map proc stream)
  (if (stream-null? stream)
      the-empty-stream
      (cons-stream (proc (stream-car stream))
                   (stream-map proc (stream-cdr stream)))))

(define (display-stream stream)
  (stream-for-each (lambda (x) (newline) (display x)) stream))

(define (stream-for-each proc stream)
  (if (stream-null? stream)
      'done
      (begin (proc (stream-car stream))
             (stream-for-each proc (stream-cdr stream)))))

; implementation of variables

(define (change-variable-representation expr)
  (cond ((pair? expr)
         (cons (change-variable-representation (car expr))
	       (change-variable-representation (cdr expr))))
        ((symbol? expr) (expand-question-mark expr))
	(else expr)))

(define (expand-question-mark symbol)
  (let ((chars (symbol->string symbol)))
    (if (string=? (substring chars 0 1) "?")
        (list '? symbol)
	symbol)))

(define (var? expr) (and (pair? expr) (eq? (car expr) '?)))

(define rule-number 0)

(define (new-number)
  (set! rule-number (+ rule-number 1))
  rule-number)

(define (contract-question-mark var)
  (if (null? (cddr var))
      (cadr var)
      (string->symbol (string-append (symbol->string (cadr var))
                                     "-"
				     (number->string (caddr var))))))