Exercise 4.75

Read Exercise 4.75 ~ Solution ~ Tests


After a long hiatus I’m back. Time to complete the book and quiet that annoying voice in the back of my mind.

First, create the procedure to check for uniqueness. To make it clearer I’ll use a predicate to check for singleton streams:

(define (singleton-stream? s)
  (and (not (stream-null? s))
       (stream-null? (stream-cdr s))))

(define (uniquely-asserted operands frame-stream)
  (stream-flatmap
   (lambda (frame)
     (let ((result-stream (qeval (negated-query operands)
                           (singleton-stream frame))))
       (if (singleton-stream? result-stream)
           result-stream
           the-empty-stream)))
   frame-stream))

Next, install the new procedure.

(put 'unique 'qeval uniquely-asserted)

Now, let’s see if it works with a unique match:

(run-query '(unique (job ?x (computer wizard))))

;; '((unique (job (Bitdiddle Ben) (computer wizard))))

Good. Multiple matches ought to give an empty stream:

(run-query '(unique (job ?x (computer programmer))))

;; '()

What about all the unique jobs in the company?

(run-query '(and (job ?x ?j) (unique (job ?anyone ?j))))

;; '((and (job (Aull DeWitt) (administration secretary))
;;        (unique (job (Aull DeWitt) (administration secretary))))
;;   (and (job (Cratchet Robert) (accounting scrivener))
;;        (unique (job (Cratchet Robert) (accounting scrivener))))
;;   (and (job (Scrooge Eben) (accounting chief accountant))
;;        (unique (job (Scrooge Eben) (accounting chief accountant))))
;;   (and (job (Warbucks Oliver) (administration big wheel))
;;        (unique (job (Warbucks Oliver) (administration big wheel))))
;;   (and (job (Reasoner Louis) (computer programmer trainee))
;;        (unique (job (Reasoner Louis) (computer programmer trainee))))
;;   (and (job (Tweakit Lem E) (computer technician))
;;        (unique (job (Tweakit Lem E) (computer technician))))
;;   (and (job (Bitdiddle Ben) (computer wizard))
;;        (unique (job (Bitdiddle Ben) (computer wizard)))))

It all seems to be working so who only supervises one other employee?

(run-query '(and (supervisor ?subordinate ?boss)
                 (unique (supervisor ?other ?boss))))

;; '((and (supervisor (Cratchet Robert) (Scrooge Eben))
;;        (unique (supervisor (Cratchet Robert) (Scrooge Eben))))
;;   (and (supervisor (Reasoner Louis) (Hacker Alyssa P))
;;        (unique (supervisor (Reasoner Louis) (Hacker Alyssa P)))))

Eben Scrooge and Alyssa P Hacker.

Advertisements

Exercise 4.74

Read Exercise 4.74 ~ Solution


a) simple-flatten‘s argument is a stream whose elements are either the empty stream or a singleton stream. We need to filter out elements that are the empty stream and then take the first element of each resulting stream.

(define (simple-flatten stream)
  (stream-map stream-car
              (stream-filter (λ (s)
                               (not (stream-null? s)))
                             stream)))

b) There is no difference in behaviour (as long as Alyssa’s assertions are correct.)

Exercise 4.71

Read Exercise 4.71 ~ Solution


(define (simple-query query-pattern frame-stream)
  (stream-flatmap
   (lambda (frame)
     (stream-append (find-assertions query-pattern frame)
                    (apply-rules query-pattern frame)))
   frame-stream))

Using the regular stream-append will evaluate both operands at call time. We’ve already seen the problems that rules can have in particular with rules that cause infinite loops, for example the rule for reverse in Exercise 4.68.
Using stream-append-delayed with the delayed second operand at least displays matching assertions and individual rule results as they are discovered while diving down the potentially infinite rabbit hole of rules. It’s not a 100% satisfactory but it’s better than the alternative.

Exercise 4.70

Read Exercise 4.70 ~ Solution


When we investigated streams we saw the constructor, cons-stream only evaluates the first item, not the second. That led to the surprising (at the time) infinite list of 1s (define ones (cons-stream 1 ones). To see why this is infinite look at the box and pointer diagrams.

infinite stream of ones
The dotted lines show how the value of ones will be evaluated once forced.
The exact same pattern and result is in the implementation of add-assertion! in this question.

(define (add-assertion! assertion)
  (store-assertion-in-index assertion)
  (set! THE-ASSERTIONS
        (cons-stream assertion THE-ASSERTIONS))
  'ok)

THE-ASSERTIONS becomes an infinite, self-referential stream.
Using let in add-assertion! and add-rules! forces their delayed values and avoids the infinite stream.
I’m glad we weren’t asked to implement these primitives. I’m not sure I would have spotted that problem and it could be a headache to find and fix.

Exercise 4.69

Read Exercise 4.69 ~ Solution


First, a relationship ends-in-grandson when it is grandson or it’s a list starting with a something ?greats followed by something that ends-in-grandson

(run-query
 ; base case
 '(assert!
   (rule (ends-in-grandson (grandson)))))
 ; other cases
(run-query
 '(assert!
   (rule (ends-in-grandson (?greats . ?rel))
         (ends-in-grandson ?rel))))

Note this doesn’t enforce that the relationship starts with great just that it starts with something
Some obvious tests:

(run-query '(ends-in-grandson (great great great son)))
; ==> '()
(run-query '(ends-in-grandson (great great great grandson)))
; ==> '((ends-in-grandson (great great great grandson)))

Next enforcing that a relationship starting with great ends in grandson

; great ... grandson x y
 ; x must be someone's son
 ; there must be a chain of relationships linking y and with x
(run-query
 '(assert!
   (rule ((great . ?rel) ?x ?y)
         (and (ends-in-grandson ?rel)
              (son ?x ?other)
              (?rel ?other ?y)))))

; Irad is Adam's grandson
(run-query
 '(assert!
   ((great grandson) Adam Irad)))

Finally the queries from the book and a couple of others

(run-query '((great grandson) ?g ?ggs))
; ==> '(((great grandson) Adam Irad))
(run-query '(?rel Adam Irad))
; ==> '(((great grandson) Adam Irad))

(run-query '(?rel Adam ?y))
; ==> '(((great grandson) Adam Irad)
;       (son Adam Cain))

(run-query '(?rel ?x Irad))
; ==> '(((great grandson) Adam Irad)
;       (son Enoch Irad))

Note: to avoid infinite loops we need to use the query evaluator that has the loop detector.