SICP/ex-4_70-79.scm

(load "util.scm")
(load "misc/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 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)
    (display "UNIFY-FRAME-STREAMS\n")
    (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 (unify-frame-stream-list frame-stream-list)
    (if (null? (cdr frame-stream-list))
      (car frame-stream-list)
      (let ((frame-stream (unify-frame-streams (car frame-stream-list)
                                               (cadr frame-stream-list))))
        (display frame-stream) (newline)
        (unify-frame-stream-list (cons frame-stream (cddr frame-stream-list))))))

  (define (qeval-conjunction conjunction)
    (qeval conjunction frame-stream))

  (let ((frame-stream-list (map qeval-conjunction conjuncts)))
    (unify-frame-stream-list frame-stream-list)))

(put 'and 'qeval conjoin)

(eval-query
  '(rule (big-shot ?p)
    (and (job ?p (?div1 . ?rest1))
         (supervisor ?p ?boss)
         (job ?boss (?div2 . ?rest2))
         (not (same ?div1 ?div2)))))

(eval-query '(big-shot ?x))
(newline)

(eval-query

(display "\nex-4.77\n")

;(display "\nex-4.78\n")
;(display "\nex-4.79\n")