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-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-not\n")

; Exercise 4.77.  In section 4.4.3 we saw that not and lisp-value can cause the
; query language to give ``wrong'' answers if these filtering operations are
; applied to frames in which variables are unbound. Devise a way to fix this
; shortcoming.

; One idea is to perform the filtering in a ``delayed'' manner by
; appending to the frame a ``promise'' to filter that is fulfilled only when
; enough variables have been bound to make the operation possible. We could
; wait to perform filtering until all other operations have been performed.
; However, for efficiency's sake, we would like to perform filtering as soon as
; possible so as to cut down on the number of intermediate frames generated.

(display "--")
(eval-query
  '(and (supervisor ?x ?y)
        (not (job ?x (computer programmer)))))
(display "\n--\n")

(display "--")
(eval-query
  '(and (not (job ?x (computer programmer)))
        (supervisor ?x ?y)))
(display "\n--\n")

(display "\nex-4.78\n")

(display "\nex-4.79\n")