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