SICP exercises

Read Exercise 4.76 ~ Solution ~ Tests

---

conjoin doesn’t change much:

(define (conjoin conjuncts frame-stream)
  (if (empty-conjunction? conjuncts)
      frame-stream
      (merge-streams (qeval (first-conjunct conjuncts) frame-stream)
                     (conjoin (rest-conjuncts conjuncts) frame-stream))))

We’ve had plenty of practice handling streams so merge-streams is fairly easy. The idea is to map a new procedure merge-frames over the frames in the second stream for each frame in the first stream. Since at any point we could generate a ‘failed frame – they need to be filtered out of the resulting merged, flattened stream.

(define (merge-streams left right)
  (stream-flatmap
   (λ (left-frame)
     (stream-filter
      succeeded?
      (stream-map
       (λ (right-frame)
         (merge-frames left-frame right-frame))
       right)))
   left))

(define (succeeded? frame)
  (not (failed? frame)))

(define (failed? frame)
  (eq? 'failed frame))

merge-frames should iterate through the variable bindings in the first frame and using extend-if-possible with that binding to extend the second frame. I didn’t use map/filter so it can bail out early since a 'failed frame can result at any stage and we’re trying to improve the complexity.

(define (merge-frames left right)
  (cond ((or (failed? left)
             (failed? right))  'failed)
        ((empty-frame? left) right)
        (else (let* ((binding (first-binding left))
                     (var (binding-variable binding))
                     (val (binding-value binding))
                     (extension (extend-if-possible var val right)))
                (if (failed? extension)
                    'failed
                    (merge-frames (rest-bindings left) extension))))))

I added a few helper procedures for frame bindings.

(define empty-frame? null?)
(define first-binding mcar)
(define rest-bindings mcdr)

Now for a test spin. The first compound query.

(run-query '(and (job ?person (computer programmer))
                 (address ?person ?where)))

;; '((and (job (Fect Cy D) (computer programmer))
;;        (address (Fect Cy D) (Cambridge (Ames Street) 3)))
;;   (and (job (Hacker Alyssa P) (computer programmer))
;;        (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))))

More complex.

(run-query '(and (job ?x ?j)
                 (supervisor ?x (Bitdiddle Ben))))

;; '((and (job (Tweakit Lem E) (computer technician))
;;        (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
;;   (and (job (Fect Cy D) (computer programmer))
;;        (supervisor (Fect Cy D) (Bitdiddle Ben)))
;;   (and (job (Hacker Alyssa P) (computer programmer))
;;        (supervisor (Hacker Alyssa P) (Bitdiddle Ben))))

(run-query '(and (job ?x ?j)
                 (supervisor ?x (Bitdiddle Ben))
                 (salary ?x ?amount)))

;; '((and (job (Tweakit Lem E) (computer technician))
;;        (supervisor (Tweakit Lem E) (Bitdiddle Ben))
;;        (salary (Tweakit Lem E) 25000))
;;   (and (job (Fect Cy D) (computer programmer))
;;        (supervisor (Fect Cy D) (Bitdiddle Ben))
;;        (salary (Fect Cy D) 35000))
;;   (and (job (Hacker Alyssa P) (computer programmer))
;;        (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;        (salary (Hacker Alyssa P) 40000)))

(run-query '(and (job ?x ?j)
                 (supervisor ?x (Bitdiddle Ben))
                 (salary ?x 40000)))

;; '((and (job (Hacker Alyssa P) (computer programmer))
;;        (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;        (salary (Hacker Alyssa P) 40000)))

Looks good, but reviewing Exercise 4.56.
a) the names of all people who are supervised by Ben Bitdiddle, together with their addresses;

(run-query '(and (supervisor ?name (Bitdiddle Ben))
                 (address ?name ?address)))

;; '((and (supervisor (Tweakit Lem E) (Bitdiddle Ben))
;;        (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
;;   (and (supervisor (Fect Cy D) (Bitdiddle Ben))
;;        (address (Fect Cy D) (Cambridge (Ames Street) 3)))
;;   (and (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
;;        (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))))

b. the names of all people who are supervised by Ben Bitdiddle, together with their addresses;

(run-query '(and (salary (Bitdiddle Ben) ?ben-salary)
                 (salary ?name ?salary)
                 (lisp-value < ?salary ?ben-salary)))
; Unknown pat var -- LISP-VALUE (? salary)

Hmmm. For each conjunct qeval is called with the isolated clause using the initial stream of frames passed into conjoin. If we try to evaluate (run-query '(lisp-value < ?salary ?ben-salary))) at the top level i.e. against (singleton-stream '()) of course ?salary is definitely not bound. We were warned about this in 4.4.3 Is Logic Programming Mathematical Logic? in particular infinite loops and the “Problems with not” caused by the ordering of the conjuncts.

It’s possible to keep the results of qeval against the first conjunct and then merge that with the stream of recursively calling conjoin with the remaining conjunct and the new stream (but that’s basically the same as the original version of conjoin with the added overhead of merging streams!)

(define (conjoin conjuncts frame-stream)
  (if (empty-conjunction? conjuncts)
      frame-stream
      (let ((first-result (qeval (first-conjunct conjuncts)
                                 frame-stream)))
        (merge-streams first-result
                       (conjoin (rest-conjuncts conjuncts) first-result)))))

I ran a few queries counting the combined calls made to pattern-match and unify-match using the 3 conjoin versions:

1. conjoin1 – the original
2. conjoin2 – using merge-streams with both streams generated from the same initial stream.
3. conjoin3 – using merge-streams but the second stream is derived from the the first result stream.

Three queries

query 1: (and (job ?x ?j)
              (outranked-by ?x (Bitdiddle Ben)))

query 2: (and (job ?x ?j)
             (outranked-by ?x (Bitdiddle Ben))
             (salary ?x ?amount))

query 3: (and (job ?x ?j)
              (outranked-by ?x (Bitdiddle Ben))
              (lives-near ?x ?who))

Calls made:

query/procedure	query 1	query 2	query 3
conjoin1	3322	3610	4142
conjoin2	675	1040	660 (but gives the wrong result)
conjoin3	3665	4023	5020

Despite being more efficient this version of conjoin results in a lot of previous exercises raising errors due to unbound variables. Still the language semantics have shifted out from under our feet and I think the authors knew all too well we’d run into problems.

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.

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

Read Exercise 4.73 ~ Solution

---

The same reason we used it for stream-append-delayed in Exercise 4.71, because of dealing with infinite streams. I think we get it by now, be wary of infinite streams.

Read Exercise 4.72 ~ Solution

---

As the question says, it’s the same reason we used interleave instead of stream-append to generate pairs of integers in Exercise 3.66. The simple answer is to allow values from both streams to be displayed if the first stream is infinite.

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.

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.

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.

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.

Read Exercise 4.68 ~ Solution

---

;; from the book
(run-query '(assert! (rule (append-to-form () ?y ?y))))
(run-query '(assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
                           (append-to-form ?v ?y ?z))))

;; base case an empty list
(run-query '(assert! (rule (reverse () ()))))
; reverse a list
; a list, L,  has a head and tail, H . T
; reversing the list is (reverse T) . H
(run-query '(assert! (rule (reverse (?h . ?t) ?y)
                           (and (reverse ?t ?reversed-t)
                                (append-to-form ?reversed-t (?h) ?y)))))

(run-query '(reverse (1 2 3) ?x))
;; ==> (reverse (1 2 3) (3 2 1))

So (reverse (1 2 3) ?x) works as expected, but (reverse ?x (1 2 3)) won’t.
To see why let’s look at the behaviour of reverse.

(reverse ?x (1 2 3))
(reverse (?hx . ?tx) y?)
(and (reverse ?tx ?reversed-tx)
     (append-to-form ?reversed-tx (?hx) ?y))
; but since ?x isn't bound
(reverse ?tx ?reversed-tx)
(reverse (?htx . ?ttx) ?reversed-tx)
(and (reverse ?htx ?reversed-htx)
     (append-to-form ?reversed-htx (?htx) ?reversed-tx))
; but since ?tx isn't bound
(reverse ?htx ?reversed-htx)
...
...
...

UPDATE:
However, using the evaluator with the loop detector results in an empty-stream of results.
Once the rule has been applied to all the frames, the duplicate query patterns all result in the empty-stream, and no recursive call is made to query-eval.
As soon as the reverse rule been applied to the possible frames, it will end.

Read Exercise 4.67 ~ Solution ~ Some tests

---

I’ll come back to this after section 4.4.4
UPDATE: I’ve finally solved the elusive 4.67 loop detector.

Since we need to prevent rules being applied to the same query pattern it makes sense to add a query pattern history. To do this, we instantiate the query pattern and any duplicates result in an empty stream of frames in response.

Add history management to the query evaluator using a hash table. The key is the queries with a canonical name for each variable. A canonical name is used because as query evaluation evolves new frames use numbers to distinguish identical variable names.

Update: Add history-remove! (see Grisha’s comment about why queries need to be removed from history after the rule body has been evaluated.)

;;; Loop detection history
(define history (make-hash))
(define (reset-history!)
  (set! history (make-hash)))
(define (history-ref key)
  (hash-ref history key #f))
(define (history-add! key)
  (hash-set! history key #t))
(define (history-remove! key)
  (hash-remove! history key))
;; Get the canonical name for a variable
;; when rules are applied new variables are generated - see:
;;    apply-a-rule -> rename-variable-in -> make-new-variable
;; so ?who becomes the variable (? who) which becomes (? 1 who) then (? 2 who) ...
;; the canonical name is (? who)
(define (canonical-name var)
  (if (number? (mcadr var))
      (mlist (mcar var) (mcaddr var))
      var))

Change apply-a-rule:

• Unify the rule’s conclusion.
• Create a new instance of the query using the new frames created unifying the conclusion.
• Save the new query instance in the history to avoid looping when evaluating the rule’s body.
• Recursively evaluate the rule’s body and save the result.
• Remove the new query instance from history.
• Return the result of the evaluated rule’s body.

(define (apply-a-rule rule query-pattern query-frame)
  (let* [(clean-rule (rename-variables-in rule))
         (unify-result (unify-match query-pattern
                                    (conclusion clean-rule)
                                    query-frame))]
      (if (eq? unify-result 'failed)
          the-empty-stream
          (let ([instance (instantiate query-pattern
                            query-frame
                            (lambda (var frame)
                              (canonical-name var)))])
            (if (history-ref instance)
                (loop-detected instance)
                (begin
                  (history-add! instance)
                  (let ((evaluated-rule
                         (qeval (rule-body clean-rule)
                                (singleton-stream unify-result))))
                    (history-remove! instance)
                    evaluated-rule)))))))

Also add a call to reset the query pattern history to the driver loop.
I added a convenient interpret-query method to save typing into the driver loop which needs the call too.

(define (interpret-query query)
  (reset-history!)
  (let ((q (query-syntax-process query)))
    (cond ((assertion-to-be-added? q)
           (add-rule-or-assertion! (add-assertion-body q))
           (newline)
           (display "Assertion added to data base."))
          (else
           (newline)
           (stream->list
            (stream-map
             (lambda (frame)
               (mlist->exp (instantiate q
                             frame
                             (lambda (v f)
                               (contract-question-mark v)))))
             (qeval q (singleton-stream '()))))))))

Time to test outranked-by and Louis’ version outranked-by-loop

(run-query
   '(outranked-by ?person ?who))

'((outranked-by (Aull DeWitt) (Warbucks Oliver))
  (outranked-by (Cratchet Robert) (Warbucks Oliver))
  (outranked-by (Cratchet Robert) (Scrooge Eben))
  (outranked-by (Reasoner Louis) (Bitdiddle Ben))
  (outranked-by (Scrooge Eben) (Warbucks Oliver))
  (outranked-by (Reasoner Louis) (Warbucks Oliver))
  (outranked-by (Bitdiddle Ben) (Warbucks Oliver))
  (outranked-by (Reasoner Louis) (Hacker Alyssa P))
  (outranked-by (Tweakit Lem E) (Bitdiddle Ben))
  (outranked-by (Fect Cy D) (Bitdiddle Ben))
  (outranked-by (Hacker Alyssa P) (Bitdiddle Ben)))

;; Louis Reasoner version which couldn't be run without the loop detector.
(run-query
 '(assert!
   (rule (outranked-by-loop ?staff-person ?boss)
         (or (supervisor ?staff-person ?boss)
             (and (outranked-by-loop ?middle-manager ?boss)
                  (supervisor ?staff-person ?middle-manager))))))

'((outranked-by-loop (Aull DeWitt) (Warbucks Oliver))
  (outranked-by-loop (Cratchet Robert) (Warbucks Oliver))
  (outranked-by-loop (Cratchet Robert) (Scrooge Eben))
  (outranked-by-loop (Tweakit Lem E) (Warbucks Oliver))
  (outranked-by-loop (Scrooge Eben) (Warbucks Oliver))
  (outranked-by-loop (Reasoner Louis) (Bitdiddle Ben))
  (outranked-by-loop (Bitdiddle Ben) (Warbucks Oliver))
  (outranked-by-loop (Fect Cy D) (Warbucks Oliver))
  (outranked-by-loop (Reasoner Louis) (Hacker Alyssa P))
  (outranked-by-loop (Hacker Alyssa P) (Warbucks Oliver))
  (outranked-by-loop (Tweakit Lem E) (Bitdiddle Ben))
  (outranked-by-loop (Fect Cy D) (Bitdiddle Ben))
  (outranked-by-loop (Hacker Alyssa P) (Bitdiddle Ben)))

Finally what about Mickey?

(run-query
 '(assert! (married Minnie Mickey)))
(run-query
 '(assert! (rule (married ?x ?y)
                 (married ?y ?x))))

(run-query '(married Mickey ?who))
'((married Mickey Minnie) (married Mickey Minnie))