5 (define (assoc key records)
6 (cond ((null? records) false)
7 ((equal? key (caar records)) (car records))
8 (else (assoc key (cdr records)))))
9 (let ((local-table (list '*table*)))
10 (define (lookup key-1 key-2)
11 (let ((subtable (assoc key-1 (cdr local-table))))
13 (let ((record (assoc key-2 (cdr subtable))))
18 (define (insert! key-1 key-2 value)
19 (let ((subtable (assoc key-1 (cdr local-table))))
21 (let ((record (assoc key-2 (cdr subtable))))
23 (set-cdr! record value)
25 (cons (cons key-2 value)
33 (cond ((eq? m 'lookup-proc) lookup)
34 ((eq? m 'insert-proc!) insert!)
35 (else (error "Unknown operation -- TABLE" m))))
37 (define operation-table (make-table))
38 (define get (operation-table 'lookup-proc))
39 (define put (operation-table 'insert-proc!))
41 ;; streams/delayed-evaluation
43 (define (memo-proc proc)
44 (let ((already-run? false) (result false))
48 (begin (set! already-run? true)
51 (define-syntax mydelay
52 (rsc-macro-transformer
55 `(memo-proc (lambda () ,exp)))))
57 (apply xfmr (cdr e))))))
58 (define (myforce delayed-object)
60 (define-syntax cons-stream
61 (rsc-macro-transformer
62 (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
64 (apply xfmr (cdr e))))))
65 (define (stream-car s)
67 (define (stream-cdr s)
69 (define stream-null? null?)
70 (define the-empty-stream '())
71 (define (stream-map proc . argstreams)
72 (if (stream-null? (car argstreams))
75 (apply proc (map stream-car argstreams))
76 (apply stream-map (cons proc (map stream-cdr argstreams))))))
77 (define (display-stream s)
78 (stream-for-each display-line s))
79 (define (stream-for-each proc s)
82 (begin (proc (stream-car s))
83 (stream-for-each proc (stream-cdr s)))))
84 (define (display-line x)
87 (define (display-streams n . streams)
92 (display (stream-car s))
95 (apply display-streams
96 (cons (- n 1) (map stream-cdr streams))))))
97 (define (list->stream list)
100 (cons-stream (car list)
101 (list->stream (cdr list)))))
102 (define (stream-fold-left op initial sequence)
103 (define (iter result rest)
106 (iter (op result (stream-car rest))
108 (iter initial sequence))
112 (define input-prompt ";;; Query input:")
113 (define output-prompt ";;; Query results:")
114 (define (query-driver-loop)
115 (prompt-for-input input-prompt)
116 (let ((q (query-syntax-process (read))))
117 (cond ((assertion-to-be-added? q)
118 (add-rule-or-assertion! (add-assertion-body q))
120 (display "Assertion added to data base.")
124 (display output-prompt)
131 (contract-question-mark v))))
132 (qeval q (singleton-stream '()))))
133 (query-driver-loop)))))
134 (define (instantiate exp frame unbound-var-handler)
137 (let ((binding (binding-in-frame exp frame)))
139 (copy (binding-value binding))
140 (unbound-var-handler exp frame))))
142 (cons (copy (car exp)) (copy (cdr exp))))
145 (define (qeval query frame-stream)
146 (let ((qproc (get (type query) 'qeval)))
148 (qproc (contents query) frame-stream)
149 (simple-query query frame-stream))))
150 (define (simple-query query-pattern frame-stream)
153 (stream-append-delayed
154 (find-assertions query-pattern frame)
155 (delay (apply-rules query-pattern frame))))
157 (define (conjoin conjuncts frame-stream)
158 (if (empty-conjunction? conjuncts)
160 (conjoin (rest-conjuncts conjuncts)
161 (qeval (first-conjunct conjuncts)
163 (put 'and 'qeval conjoin)
166 ;; 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.
168 ;; 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.
170 ;; returns merged frame or 'failed
171 (define (merge-frame frame1 frame2)
174 (let* ((binding (first-binding frame1))
175 (var (binding-variable binding))
176 (val (binding-value binding))
177 (merged-result (extend-if-possible var val frame2)))
178 (if (eq? merged-result 'failed)
180 (merge-frame (rest-bindings frame1) frame2)))))
182 ;; returns stream of frames that can be merged
183 (define (merge-streams s1 s2)
188 (let ((merged-frame (merge-frame f1 f2)))
189 (if (eq? merged-frame 'failed)
191 (singleton-stream merged-frame))))
194 ;; (define (conjoin conjuncts frame-stream)
195 ;; (if (empty-conjunction? conjuncts)
198 ;; (qeval (first-conjunct conjuncts) frame-stream)
199 ;; (conjoin (rest-conjuncts conjuncts) frame-stream))))
201 (define (first-binding frame)
203 (define (rest-bindings frame)
205 (define (make-binding variable value)
206 (cons variable value))
207 (define (binding-variable binding)
209 (define (binding-value binding)
211 (define (binding-in-frame variable frame)
212 (assoc variable frame))
213 (define (extend variable value frame)
214 (cons (make-binding variable value) frame))
217 (define (disjoin disjuncts frame-stream)
218 (if (empty-disjunction? disjuncts)
221 (qeval (first-disjunct disjuncts) frame-stream)
222 (delay (disjoin (rest-disjuncts disjuncts)
224 (put 'or 'qeval disjoin)
225 (define (negate operands frame-stream)
228 (if (stream-null? (qeval (negated-query operands)
229 (singleton-stream frame)))
230 (singleton-stream frame)
233 (put 'not 'qeval negate)
234 (define (lisp-value call frame-stream)
242 (error "Unknown pat var -- LISP-VALUE" v))))
243 (singleton-stream frame)
246 (put 'lisp-value 'qeval lisp-value)
247 (define (execute exp)
248 (apply (eval (predicate exp) user-initial-environment)
250 (define (always-true ignore frame-stream) frame-stream)
251 (put 'always-true 'qeval always-true)
252 (define (find-assertions pattern frame)
253 (stream-flatmap (lambda (datum)
254 (check-an-assertion datum pattern frame))
255 (fetch-assertions pattern frame)))
256 (define (check-an-assertion assertion query-pat query-frame)
258 (pattern-match query-pat assertion query-frame)))
259 (if (eq? match-result 'failed)
261 (singleton-stream match-result))))
262 (define (pattern-match pat dat frame)
263 (cond ((eq? frame 'failed) 'failed)
264 ((equal? pat dat) frame)
265 ((var? pat) (extend-if-consistent pat dat frame))
266 ((and (pair? pat) (pair? dat))
267 (pattern-match (cdr pat)
269 (pattern-match (car pat)
273 (define (extend-if-consistent var dat frame)
274 (let ((binding (binding-in-frame var frame)))
276 (pattern-match (binding-value binding) dat frame)
277 (extend var dat frame))))
278 (define (apply-rules pattern frame)
279 (stream-flatmap (lambda (rule)
280 (apply-a-rule rule pattern frame))
281 (fetch-rules pattern frame)))
282 (define (apply-a-rule rule query-pattern query-frame)
283 (let ((clean-rule (rename-variables-in rule)))
285 (unify-match query-pattern
286 (conclusion clean-rule)
288 (if (eq? unify-result 'failed)
290 (qeval (rule-body clean-rule)
291 (singleton-stream unify-result))))))
292 (define (rename-variables-in rule)
293 (let ((rule-application-id (new-rule-application-id)))
294 (define (tree-walk exp)
296 (make-new-variable exp rule-application-id))
298 (cons (tree-walk (car exp))
299 (tree-walk (cdr exp))))
302 (define (unify-match p1 p2 frame)
303 (cond ((eq? frame 'failed) 'failed)
304 ((equal? p1 p2) frame)
305 ((var? p1) (extend-if-possible p1 p2 frame))
306 ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
307 ((and (pair? p1) (pair? p2))
308 (unify-match (cdr p1)
310 (unify-match (car p1)
314 (define (extend-if-possible var val frame)
315 (let ((binding (binding-in-frame var frame)))
318 (binding-value binding) val frame))
320 (let ((binding (binding-in-frame val frame)))
323 var (binding-value binding) frame)
324 (extend var val frame))))
325 ((depends-on? val var frame) ; ***
327 (else (extend var val frame)))))
328 (define (depends-on? exp var frame)
329 (define (tree-walk e)
333 (let ((b (binding-in-frame e frame)))
335 (tree-walk (binding-value b))
338 (or (tree-walk (car e))
339 (tree-walk (cdr e))))
342 (define THE-ASSERTIONS the-empty-stream)
343 (define (fetch-assertions pattern frame)
344 (if (use-index? pattern)
345 (get-indexed-assertions pattern)
346 (get-all-assertions)))
347 (define (get-all-assertions) THE-ASSERTIONS)
348 (define (get-indexed-assertions pattern)
349 (get-stream (index-key-of pattern) 'assertion-stream))
350 (define (get-stream key1 key2)
351 (let ((s (get key1 key2)))
352 (if s s the-empty-stream)))
353 (define THE-RULES the-empty-stream)
354 (define (fetch-rules pattern frame)
355 (if (use-index? pattern)
356 (get-indexed-rules pattern)
358 (define (get-all-rules) THE-RULES)
359 (define (get-indexed-rules pattern)
361 (get-stream (index-key-of pattern) 'rule-stream)
362 (get-stream '? 'rule-stream)))
363 (define (add-rule-or-assertion! assertion)
364 (if (rule? assertion)
365 (add-rule! assertion)
366 (add-assertion! assertion)))
367 (define (add-assertion! assertion)
368 (store-assertion-in-index assertion)
369 (let ((old-assertions THE-ASSERTIONS))
371 (cons-stream assertion old-assertions))
373 (define (add-rule! rule)
374 (store-rule-in-index rule)
375 (let ((old-rules THE-RULES))
376 (set! THE-RULES (cons-stream rule old-rules))
378 (define (store-assertion-in-index assertion)
379 (if (indexable? assertion)
380 (let ((key (index-key-of assertion)))
381 (let ((current-assertion-stream
382 (get-stream key 'assertion-stream)))
385 (cons-stream assertion
386 current-assertion-stream))))))
387 (define (store-rule-in-index rule)
388 (let ((pattern (conclusion rule)))
389 (if (indexable? pattern)
390 (let ((key (index-key-of pattern)))
391 (let ((current-rule-stream
392 (get-stream key 'rule-stream)))
396 current-rule-stream)))))))
397 (define (indexable? pat)
398 (or (constant-symbol? (car pat))
400 (define (index-key-of pat)
401 (let ((key (car pat)))
402 (if (var? key) '? key)))
403 (define (use-index? pat)
404 (constant-symbol? (car pat)))
405 (define (stream-append s1 s2)
406 (if (stream-null? s1)
408 (cons-stream (stream-car s1)
409 (stream-append (stream-cdr s1) s2))))
410 (define (stream-append-delayed s1 delayed-s2)
411 (if (stream-null? s1)
415 (stream-append-delayed (stream-cdr s1) delayed-s2))))
416 (define (interleave-delayed s1 delayed-s2)
417 (if (stream-null? s1)
421 (interleave-delayed (force delayed-s2)
422 (delay (stream-cdr s1))))))
423 (define (stream-flatmap proc s)
424 (flatten-stream (stream-map proc s)))
425 (define (flatten-stream stream)
426 (if (stream-null? stream)
430 (delay (flatten-stream (stream-cdr stream))))))
431 (define (singleton-stream x)
432 (cons-stream x the-empty-stream))
436 (error "Unknown expression TYPE" exp)))
437 (define (contents exp)
440 (error "Unknown expression CONTENTS" exp)))
441 (define (assertion-to-be-added? exp)
442 (eq? (type exp) 'assert!))
443 (define (add-assertion-body exp)
444 (car (contents exp)))
445 (define (empty-conjunction? exps) (null? exps))
446 (define (first-conjunct exps) (car exps))
447 (define (rest-conjuncts exps) (cdr exps))
448 (define (empty-disjunction? exps) (null? exps))
449 (define (first-disjunct exps) (car exps))
450 (define (rest-disjuncts exps) (cdr exps))
451 (define (negated-query exps) (car exps))
452 (define (predicate exps) (car exps))
453 (define (args exps) (cdr exps))
454 (define (rule? statement)
455 (tagged-list? statement 'rule))
456 (define (conclusion rule) (cadr rule))
457 (define (rule-body rule)
458 (if (null? (cddr rule))
461 (define (query-syntax-process exp)
462 (map-over-symbols expand-question-mark exp))
463 (define (map-over-symbols proc exp)
465 (cons (map-over-symbols proc (car exp))
466 (map-over-symbols proc (cdr exp))))
467 ((symbol? exp) (proc exp))
469 (define (expand-question-mark symbol)
470 (let ((chars (symbol->string symbol)))
471 (if (string=? (substring chars 0 1) "?")
474 (substring chars 1 (string-length chars))))
477 (tagged-list? exp '?))
478 (define (constant-symbol? exp) (symbol? exp))
479 (define rule-counter 0)
480 (define (new-rule-application-id)
481 (set! rule-counter (+ 1 rule-counter))
483 (define (make-new-variable var rule-application-id)
484 (cons '? (cons rule-application-id (cdr var))))
485 (define (contract-question-mark variable)
488 (if (number? (cadr variable))
489 (string-append (symbol->string (caddr variable))
491 (number->string (cadr variable)))
492 (symbol->string (cadr variable))))))
493 (define (make-binding variable value)
494 (cons variable value))
495 (define (binding-variable binding)
497 (define (binding-value binding)
499 (define (binding-in-frame variable frame)
500 (assoc variable frame))
501 (define (extend variable value frame)
502 (cons (make-binding variable value) frame))
503 (define (tagged-list? exp tag)
504 (and (pair? exp) (eq? (car exp) tag)))
508 (define (eval-queries queries)
511 (begin (eval-query (car queries))
512 (eval-queries (cdr queries)))))
513 (define (eval-query query)
514 (let ((q (query-syntax-process query)))
515 (if (assertion-to-be-added? q)
516 (add-rule-or-assertion! (add-assertion-body q))
522 (contract-question-mark v))))
523 (qeval q (singleton-stream '()))))))
524 (define (eval-display-query q)
525 (display-stream (eval-query q)))
526 (define (test-case actual expected)
531 (display "Expected: ")
534 (define (test-query query . expected)
536 (let ((result (eval-query query)))
538 (begin (display "Assertion added") (newline))
539 (display-stream (eval-query query))))
540 (let ((list (car expected)))
544 (list->stream list)))))
546 ;; (let ((list (car expected)))
555 ;; (eval-query query)
556 ;; (list->stream list)))))
558 ;; (display "Passed -- ")
559 ;; (display "Failed! -- "))
567 '((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
568 (assert! (job (Bitdiddle Ben) (computer wizard)))
569 (assert! (salary (Bitdiddle Ben) 60000))
570 (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
571 (assert! (job (Hacker Alyssa P) (computer programmer)))
572 (assert! (salary (Hacker Alyssa P) 40000))
573 (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
574 (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
575 (assert! (job (Fect Cy D) (computer programmer)))
576 (assert! (salary (Fect Cy D) 35000))
577 (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
578 (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
579 (assert! (job (Tweakit Lem E) (computer technician)))
580 (assert! (salary (Tweakit Lem E) 25000))
581 (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
582 (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
583 (assert! (job (Reasoner Louis) (computer programmer trainee)))
584 (assert! (salary (Reasoner Louis) 30000))
585 (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
586 (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
587 (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
588 (assert! (job (Warbucks Oliver) (administration big wheel)))
589 (assert! (salary (Warbucks Oliver) 150000))
590 (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
591 (assert! (job (Scrooge Eben) (accounting chief accountant)))
592 (assert! (salary (Scrooge Eben) 75000))
593 (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
594 (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
595 (assert! (job (Cratchet Robert) (accounting scrivener)))
596 (assert! (salary (Cratchet Robert) 18000))
597 (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
598 (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
599 (assert! (job (Aull DeWitt) (administration secretary)))
600 (assert! (salary (Aull DeWitt) 25000))
601 (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
602 (assert! (can-do-job (computer wizard) (computer programmer)))
603 (assert! (can-do-job (computer wizard) (computer technician)))
604 (assert! (can-do-job (computer programmer)
605 (computer programmer trainee)))
606 (assert! (can-do-job (administration secretary)
607 (administration big wheel)))))
610 '(assert! (rule (same ?x ?x))))
614 '(supervisor ?employee (Bitdiddle Ben))
615 '((supervisor (tweakit lem e) (bitdiddle ben))
616 (supervisor (fect cy d) (bitdiddle ben))
617 (supervisor (hacker alyssa p) (bitdiddle ben))))
619 '(job ?x (accounting . ?title))
620 '((job (cratchet robert) (accounting scrivener))
621 (job (scrooge eben) (accounting chief accountant))))
623 '(address ?person (Slumerville . ?rest))
624 '((address (aull dewitt) (slumerville (onion square) 5))
625 (address (reasoner louis) (slumerville (pine tree road) 80))
626 (address (bitdiddle ben) (slumerville (ridge road) 10))))
628 '(and (supervisor ?x (Bitdiddle Ben))
629 (address ?x ?address))
630 '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
631 (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
632 (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
634 '(and (salary (Bitdiddle Ben) ?ben-salary)
635 (salary ?x ?x-salary)
636 (lisp-value < ?x-salary ?ben-salary))
637 '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
638 (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
639 (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
640 (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
641 (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
642 (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
644 '(and (supervisor ?employee ?supervisor)
645 (job ?supervisor ?job)
646 (not (job ?supervisor (computer . ?title))))
647 '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
648 (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
649 (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
650 (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
653 '(assert! (rule (can-replace? ?p1 ?p2)
654 (and (or (and (job ?p1 ?job)
658 (can-do-job ?j1 ?j2)))
659 (not (same ?p1 ?p2))))))
661 '(can-replace? ?x (Fect Cy D))
662 '((can-replace? (bitdiddle ben) (fect cy d))
663 (can-replace? (hacker alyssa p) (fect cy d))))
665 '(and (salary ?low ?low-salary)
666 (salary ?high ?high-salary)
667 (can-replace? ?low ?high)
668 (lisp-value < ?low-salary ?high-salary))
669 '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
670 (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
672 '(assert! (rule (big-shot ?bigshot)
673 (and (job ?bigshot (?dept . ?job-title))
674 (or (not (supervisor ?bigshot ?boss))
675 (and (supervisor ?bigshot ?boss)
676 (not (job ?boss (?dept . ?boss-title)))))))))
679 '((big-shot (warbucks oliver))
680 (big-shot (scrooge eben))
681 (big-shot (bitdiddle ben))))
683 '((assert! (meeting accounting (Monday 9am)))
684 (assert! (meeting administration (Monday 10am)))
685 (assert! (meeting computer (Wednesday 3pm)))
686 (assert! (meeting administration (Friday 1pm)))
687 (assert! (meeting whole-company (Wednesday 4pm)))))
688 (test-query '(meeting ?div (Friday ?time))
689 '((meeting administration (friday 1pm))))
691 '(assert! (rule (meeting-time ?person ?day-and-time)
692 (or (and (job ?person (?dept . ?title))
693 (meeting ?dept ?day-and-time))
694 (meeting whole-company ?day-and-time)))))
696 (test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
697 '((meeting-time (hacker alyssa p) (wednesday 3pm))
698 (meeting-time (hacker alyssa p) (wednesday 4pm))))
700 (define (name<? name1 name2)
701 (let ((str1 (fold-left
703 (string-append str (symbol->string sym)))
708 (string-append str (symbol->string sym)))
711 (string<? str1 str2)))
713 (eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
714 (and (address ?person-1 (?town . ?rest-1))
715 (address ?person-2 (?town . ?rest-2))
716 (not (same ?person-1 ?person-2))
717 (lisp-value name<? ?person-1 ?person-2)))))
719 (test-query '(lives-near ?person-1 ?person-2)
720 '((lives-near (aull dewitt) (reasoner louis))
721 (lives-near (aull dewitt) (bitdiddle ben))
722 (lives-near (fect cy d) (hacker alyssa p))
723 (lives-near (bitdiddle ben) (reasoner louis))))
724 (eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
725 (eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
726 (?x next-to ?y in ?z))))
727 (test-query '(?x next-to ?y in (1 (2 3) 4))
728 '(((2 3) next-to 4 in (1 (2 3) 4))
729 (1 next-to (2 3) in (1 (2 3) 4))))
730 (test-query '(?x next-to 1 in (2 1 3 1))
731 '((3 next-to 1 in (2 1 3 1))
732 (2 next-to 1 in (2 1 3 1))))
734 '((assert! (rule (last-pair (?x) (?x))))
735 (assert! (rule (last-pair (?x . ?y) (?z))
736 (last-pair ?y (?z))))))
737 (test-query '(last-pair (3) ?x)
738 '((last-pair (3) (3))))
739 (test-query '(last-pair (1 2 3))
740 '((last-pair (1 2 3) (3))))
741 (test-query '(last-pair (2 ?x) (3))
742 '((last-pair (2 3) (3))))
744 '((assert! (son Adam Cain))
745 (assert! (son Cain Enoch))
746 (assert! (son Enoch Irad))
747 (assert! (son Irad Mehujael))
748 (assert! (son Mehujael Methushael))
749 (assert! (son Methushael Lamech))
750 (assert! (wife Lamech Ada))
751 (assert! (son Ada Jabal))
752 (assert! (son Ada Jubal))))
754 '((assert! (rule (grandson ?g ?s)
757 (assert! (rule (son ?f ?s)
761 '(grandson Cain ?grandson)
762 '((grandson cain irad)))
768 '(grandson Methushael ?grandson)
769 '((grandson methushael jubal)
770 (grandson methushael jabal)))
773 '((assert! (rule (append-to-form () ?y ?y)))
774 (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
775 (append-to-form ?v ?y ?z)))
776 (assert! (rule (reverse () ())))
777 (assert! (rule (reverse (?x . ?y) ?rev)
778 (and (reverse ?y ?rev-y)
779 (append-to-form ?rev-y (?x) ?rev))))))
780 (test-query '(reverse (1 2 3) ?x)
781 '((reverse (1 2 3) (3 2 1))))
783 ;; Exercise 4.69. Beginning with the data base and the rules you formulated in exercise 4.63, devise a rule for adding ``greats'' to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
786 '((assert! (rule (ends-in-grandson? (grandson))))
787 (assert! (rule (ends-in-grandson? (?x . ?y))
788 (ends-in-grandson? ?y)))))
789 ;; (test-query '(ends-in-grandson? (father)))
790 ;; (test-query '(ends-in-grandson? (son mother father)))
791 ;; (test-query '(ends-in-grandson? (grandson)))
792 ;; (test-query '(ends-in-grandson? (father son grandson mother)))
793 ;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
796 '((assert! (rule ((great . ?rel) ?x ?y)
797 (and (ends-in-grandson? ?rel)
800 (assert! (rule ((grandson) ?x ?y)
803 ;; ((great great great grandson) Adam ?somebody)
804 ;; ((great . ?rel) ?x ?y)
806 ;; ?rel -> (great great grandson)
810 ;; (and (ends-in-grandson? ?rel)
813 ;; (and (son Adam ?z)
814 ;; ((great great grandson) ?z ?y))
820 ;; ((great great grandson) Cain ?y)
821 ;; ((great . ?rel1) ?x1 ?y1)
822 ;; ?rel1 -> (great grandson)
825 ;; (and (son Cain ?z1)
826 ;; ((great grandson) ?z1 ?y1))
828 ;; ((great grandson) Enoch ?y1)
829 ;; ((great . ?rel2) ?x2 ?y2)
830 ;; ?rel2 -> (grandson)
833 ;; (and (son Enoch ?z2)
834 ;; ((grandson) ?z2 ?y2))
836 ;; ((grandson) Irad ?y2)
838 ;; (assert! (son Adam Cain))
839 ;; (assert! (son Cain Enoch))
840 ;; (assert! (son Enoch Irad))
841 ;; (assert! (son Irad Mehujael))
842 ;; (assert! (son Mehujael Methushael))
843 ;; (assert! (son Methushael Lamech))
844 ;; (assert! (wife Lamech Ada))
845 ;; (assert! (son Ada Jabal))
846 ;; (assert! (son Ada Jubal))
848 (test-query '((great grandson) ?great-grandfather Irad)
849 '(((great grandson) Adam Irad)))
850 (test-query '((great great great great great grandson) Adam ?x)
851 '(((great great great great great grandson) Adam Jubal)
852 ((great great great great great grandson) Adam Jabal)))
854 (test-query '((great grandson) ?g ?ggs)
855 '(((great grandson) mehujael jubal)
856 ((great grandson) irad lamech)
857 ((great grandson) mehujael jabal)
858 ((great grandson) enoch methushael)
859 ((great grandson) cain mehujael)
860 ((great grandson) adam irad)))
862 ;; (test-query '(?relationship Adam Irad))
863 ;; this goes into an infinite loop
864 (define (simple-stream-flatmap proc s)
865 (simple-flatten (stream-map proc s)))
867 (define (simple-flatten stream)
868 (stream-map stream-car
869 (stream-filter (lambda (x) (not (stream-null? x))) stream)))
872 ;; Exercise 4.75. Implement for the query language a new special form called unique. Unique should succeed if there is precisely one item in the data base satisfying a specified query. For example,
874 (define (uniquely-asserted operands frame-stream)
877 (let ((results-stream
878 (qeval (unique-query operands)
879 (singleton-stream frame))))
880 (if (singleton-stream? results-stream)
884 (define (unique-query operands)
886 (define (singleton-stream? s)
887 (and (not (stream-null? s))
888 (stream-null? (stream-cdr s))))
889 (put 'unique 'qeval uniquely-asserted)
891 (test-query '(unique (job ?x (computer wizard)))
892 '((unique (job (Bitdiddle Ben) (computer wizard)))))
893 (test-query '(unique (job ?x (computer programmer)))
895 (test-query '(and (job ?x ?j)
896 (unique (job ?anyone ?j)))
897 '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
898 (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
899 (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
900 (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
901 (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
902 (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
903 (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
904 (test-query '(and (supervisor ?sub ?sup)
905 (unique (supervisor ?anyone ?sup)))
906 '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
907 (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
