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)
164 (define (disjoin disjuncts frame-stream)
165 (if (empty-disjunction? disjuncts)
168 (qeval (first-disjunct disjuncts) frame-stream)
169 (delay (disjoin (rest-disjuncts disjuncts)
171 (put 'or 'qeval disjoin)
172 (define (negate operands frame-stream)
175 (if (stream-null? (qeval (negated-query operands)
176 (singleton-stream frame)))
177 (singleton-stream frame)
180 (put 'not 'qeval negate)
181 (define (lisp-value call frame-stream)
189 (error "Unknown pat var -- LISP-VALUE" v))))
190 (singleton-stream frame)
193 (put 'lisp-value 'qeval lisp-value)
194 (define (execute exp)
195 (apply (eval (predicate exp) user-initial-environment)
197 (define (always-true ignore frame-stream) frame-stream)
198 (put 'always-true 'qeval always-true)
199 (define (find-assertions pattern frame)
200 (stream-flatmap (lambda (datum)
201 (check-an-assertion datum pattern frame))
202 (fetch-assertions pattern frame)))
203 (define (check-an-assertion assertion query-pat query-frame)
205 (pattern-match query-pat assertion query-frame)))
206 (if (eq? match-result 'failed)
208 (singleton-stream match-result))))
209 (define (pattern-match pat dat frame)
210 (cond ((eq? frame 'failed) 'failed)
211 ((equal? pat dat) frame)
212 ((var? pat) (extend-if-consistent pat dat frame))
213 ((and (pair? pat) (pair? dat))
214 (pattern-match (cdr pat)
216 (pattern-match (car pat)
220 (define (extend-if-consistent var dat frame)
221 (let ((binding (binding-in-frame var frame)))
223 (pattern-match (binding-value binding) dat frame)
224 (extend var dat frame))))
225 (define (apply-rules pattern frame)
226 (stream-flatmap (lambda (rule)
227 (apply-a-rule rule pattern frame))
228 (fetch-rules pattern frame)))
229 (define (apply-a-rule rule query-pattern query-frame)
230 (let ((clean-rule (rename-variables-in rule)))
232 (unify-match query-pattern
233 (conclusion clean-rule)
235 (if (eq? unify-result 'failed)
237 (qeval (rule-body clean-rule)
238 (singleton-stream unify-result))))))
239 (define (rename-variables-in rule)
240 (let ((rule-application-id (new-rule-application-id)))
241 (define (tree-walk exp)
243 (make-new-variable exp rule-application-id))
245 (cons (tree-walk (car exp))
246 (tree-walk (cdr exp))))
249 (define (unify-match p1 p2 frame)
250 (cond ((eq? frame 'failed) 'failed)
251 ((equal? p1 p2) frame)
252 ((var? p1) (extend-if-possible p1 p2 frame))
253 ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
254 ((and (pair? p1) (pair? p2))
255 (unify-match (cdr p1)
257 (unify-match (car p1)
261 (define (extend-if-possible var val frame)
262 (let ((binding (binding-in-frame var frame)))
265 (binding-value binding) val frame))
267 (let ((binding (binding-in-frame val frame)))
270 var (binding-value binding) frame)
271 (extend var val frame))))
272 ((depends-on? val var frame) ; ***
274 (else (extend var val frame)))))
275 (define (depends-on? exp var frame)
276 (define (tree-walk e)
280 (let ((b (binding-in-frame e frame)))
282 (tree-walk (binding-value b))
285 (or (tree-walk (car e))
286 (tree-walk (cdr e))))
289 (define THE-ASSERTIONS the-empty-stream)
290 (define (fetch-assertions pattern frame)
291 (if (use-index? pattern)
292 (get-indexed-assertions pattern)
293 (get-all-assertions)))
294 (define (get-all-assertions) THE-ASSERTIONS)
295 (define (get-indexed-assertions pattern)
296 (get-stream (index-key-of pattern) 'assertion-stream))
297 (define (get-stream key1 key2)
298 (let ((s (get key1 key2)))
299 (if s s the-empty-stream)))
300 (define THE-RULES the-empty-stream)
301 (define (fetch-rules pattern frame)
302 (if (use-index? pattern)
303 (get-indexed-rules pattern)
305 (define (get-all-rules) THE-RULES)
306 (define (get-indexed-rules pattern)
308 (get-stream (index-key-of pattern) 'rule-stream)
309 (get-stream '? 'rule-stream)))
310 (define (add-rule-or-assertion! assertion)
311 (if (rule? assertion)
312 (add-rule! assertion)
313 (add-assertion! assertion)))
314 (define (add-assertion! assertion)
315 (store-assertion-in-index assertion)
316 (let ((old-assertions THE-ASSERTIONS))
318 (cons-stream assertion old-assertions))
320 (define (add-rule! rule)
321 (store-rule-in-index rule)
322 (let ((old-rules THE-RULES))
323 (set! THE-RULES (cons-stream rule old-rules))
325 (define (store-assertion-in-index assertion)
326 (if (indexable? assertion)
327 (let ((key (index-key-of assertion)))
328 (let ((current-assertion-stream
329 (get-stream key 'assertion-stream)))
332 (cons-stream assertion
333 current-assertion-stream))))))
334 (define (store-rule-in-index rule)
335 (let ((pattern (conclusion rule)))
336 (if (indexable? pattern)
337 (let ((key (index-key-of pattern)))
338 (let ((current-rule-stream
339 (get-stream key 'rule-stream)))
343 current-rule-stream)))))))
344 (define (indexable? pat)
345 (or (constant-symbol? (car pat))
347 (define (index-key-of pat)
348 (let ((key (car pat)))
349 (if (var? key) '? key)))
350 (define (use-index? pat)
351 (constant-symbol? (car pat)))
352 (define (stream-append s1 s2)
353 (if (stream-null? s1)
355 (cons-stream (stream-car s1)
356 (stream-append (stream-cdr s1) s2))))
357 (define (stream-append-delayed s1 delayed-s2)
358 (if (stream-null? s1)
362 (stream-append-delayed (stream-cdr s1) delayed-s2))))
363 (define (interleave-delayed s1 delayed-s2)
364 (if (stream-null? s1)
368 (interleave-delayed (force delayed-s2)
369 (delay (stream-cdr s1))))))
370 (define (stream-flatmap proc s)
371 (flatten-stream (stream-map proc s)))
372 (define (flatten-stream stream)
373 (if (stream-null? stream)
377 (delay (flatten-stream (stream-cdr stream))))))
378 (define (singleton-stream x)
379 (cons-stream x the-empty-stream))
383 (error "Unknown expression TYPE" exp)))
384 (define (contents exp)
387 (error "Unknown expression CONTENTS" exp)))
388 (define (assertion-to-be-added? exp)
389 (eq? (type exp) 'assert!))
390 (define (add-assertion-body exp)
391 (car (contents exp)))
392 (define (empty-conjunction? exps) (null? exps))
393 (define (first-conjunct exps) (car exps))
394 (define (rest-conjuncts exps) (cdr exps))
395 (define (empty-disjunction? exps) (null? exps))
396 (define (first-disjunct exps) (car exps))
397 (define (rest-disjuncts exps) (cdr exps))
398 (define (negated-query exps) (car exps))
399 (define (predicate exps) (car exps))
400 (define (args exps) (cdr exps))
401 (define (rule? statement)
402 (tagged-list? statement 'rule))
403 (define (conclusion rule) (cadr rule))
404 (define (rule-body rule)
405 (if (null? (cddr rule))
408 (define (query-syntax-process exp)
409 (map-over-symbols expand-question-mark exp))
410 (define (map-over-symbols proc exp)
412 (cons (map-over-symbols proc (car exp))
413 (map-over-symbols proc (cdr exp))))
414 ((symbol? exp) (proc exp))
416 (define (expand-question-mark symbol)
417 (let ((chars (symbol->string symbol)))
418 (if (string=? (substring chars 0 1) "?")
421 (substring chars 1 (string-length chars))))
424 (tagged-list? exp '?))
425 (define (constant-symbol? exp) (symbol? exp))
426 (define rule-counter 0)
427 (define (new-rule-application-id)
428 (set! rule-counter (+ 1 rule-counter))
430 (define (make-new-variable var rule-application-id)
431 (cons '? (cons rule-application-id (cdr var))))
432 (define (contract-question-mark variable)
435 (if (number? (cadr variable))
436 (string-append (symbol->string (caddr variable))
438 (number->string (cadr variable)))
439 (symbol->string (cadr variable))))))
440 (define (make-binding variable value)
441 (cons variable value))
442 (define (binding-variable binding)
444 (define (binding-value binding)
446 (define (binding-in-frame variable frame)
447 (assoc variable frame))
448 (define (extend variable value frame)
449 (cons (make-binding variable value) frame))
450 (define (tagged-list? exp tag)
451 (and (pair? exp) (eq? (car exp) tag)))
455 (define (eval-queries queries)
458 (begin (eval-query (car queries))
459 (eval-queries (cdr queries)))))
460 (define (eval-query query)
461 (let ((q (query-syntax-process query)))
462 (if (assertion-to-be-added? q)
463 (add-rule-or-assertion! (add-assertion-body q))
469 (contract-question-mark v))))
470 (qeval q (singleton-stream '()))))))
471 (define (eval-display-query q)
472 (display-stream (eval-query q)))
473 (define (test-case actual expected)
478 (display "Expected: ")
481 (define (test-query query . expected)
483 (let ((result (eval-query query)))
485 (begin (display "Assertion added") (newline))
486 (display-stream (eval-query query))))
487 (let ((list (car expected)))
497 (list->stream list)))))
499 (display "Passed -- ")
500 (display "Failed! -- "))
504 ;; (let ((result (eval-query query)))
505 ;; (if (pair? result)
506 ;; (display-stream (eval-query query))
509 ;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
513 ;; (eval-query query)
514 ;; (list->stream list)))))
520 ;; (eval-query query)
521 ;; (list->stream list))))))
526 '((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
527 (assert! (job (Bitdiddle Ben) (computer wizard)))
528 (assert! (salary (Bitdiddle Ben) 60000))
529 (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
530 (assert! (job (Hacker Alyssa P) (computer programmer)))
531 (assert! (salary (Hacker Alyssa P) 40000))
532 (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
533 (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
534 (assert! (job (Fect Cy D) (computer programmer)))
535 (assert! (salary (Fect Cy D) 35000))
536 (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
537 (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
538 (assert! (job (Tweakit Lem E) (computer technician)))
539 (assert! (salary (Tweakit Lem E) 25000))
540 (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
541 (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
542 (assert! (job (Reasoner Louis) (computer programmer trainee)))
543 (assert! (salary (Reasoner Louis) 30000))
544 (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
545 (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
546 (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
547 (assert! (job (Warbucks Oliver) (administration big wheel)))
548 (assert! (salary (Warbucks Oliver) 150000))
549 (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
550 (assert! (job (Scrooge Eben) (accounting chief accountant)))
551 (assert! (salary (Scrooge Eben) 75000))
552 (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
553 (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
554 (assert! (job (Cratchet Robert) (accounting scrivener)))
555 (assert! (salary (Cratchet Robert) 18000))
556 (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
557 (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
558 (assert! (job (Aull DeWitt) (administration secretary)))
559 (assert! (salary (Aull DeWitt) 25000))
560 (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
561 (assert! (can-do-job (computer wizard) (computer programmer)))
562 (assert! (can-do-job (computer wizard) (computer technician)))
563 (assert! (can-do-job (computer programmer)
564 (computer programmer trainee)))
565 (assert! (can-do-job (administration secretary)
566 (administration big wheel)))))
569 '(assert! (rule (same ?x ?x))))
573 '(supervisor ?employee (Bitdiddle Ben))
574 '((supervisor (tweakit lem e) (bitdiddle ben))
575 (supervisor (fect cy d) (bitdiddle ben))
576 (supervisor (hacker alyssa p) (bitdiddle ben))))
578 '(job ?x (accounting . ?title))
579 '((job (cratchet robert) (accounting scrivener))
580 (job (scrooge eben) (accounting chief accountant))))
582 '(address ?person (Slumerville . ?rest))
583 '((address (aull dewitt) (slumerville (onion square) 5))
584 (address (reasoner louis) (slumerville (pine tree road) 80))
585 (address (bitdiddle ben) (slumerville (ridge road) 10))))
587 '(and (supervisor ?x (Bitdiddle Ben))
588 (address ?x ?address))
589 '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
590 (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
591 (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
593 '(and (salary (Bitdiddle Ben) ?ben-salary)
594 (salary ?x ?x-salary)
595 (lisp-value < ?x-salary ?ben-salary))
596 '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
597 (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
598 (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
599 (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
600 (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
601 (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
603 '(and (supervisor ?employee ?supervisor)
604 (job ?supervisor ?job)
605 (not (job ?supervisor (computer . ?title))))
606 '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
607 (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
608 (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
609 (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
612 '(assert! (rule (can-replace? ?p1 ?p2)
613 (and (or (and (job ?p1 ?job)
617 (can-do-job ?j1 ?j2)))
618 (not (same ?p1 ?p2))))))
620 '(can-replace? ?x (Fect Cy D))
621 '((can-replace? (bitdiddle ben) (fect cy d))
622 (can-replace? (hacker alyssa p) (fect cy d))))
624 '(and (salary ?low ?low-salary)
625 (salary ?high ?high-salary)
626 (can-replace? ?low ?high)
627 (lisp-value < ?low-salary ?high-salary))
628 '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
629 (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
631 '(assert! (rule (big-shot ?bigshot)
632 (and (job ?bigshot (?dept . ?job-title))
633 (or (not (supervisor ?bigshot ?boss))
634 (and (supervisor ?bigshot ?boss)
635 (not (job ?boss (?dept . ?boss-title)))))))))
638 '((big-shot (warbucks oliver))
639 (big-shot (scrooge eben))
640 (big-shot (bitdiddle ben))))
642 '((assert! (meeting accounting (Monday 9am)))
643 (assert! (meeting administration (Monday 10am)))
644 (assert! (meeting computer (Wednesday 3pm)))
645 (assert! (meeting administration (Friday 1pm)))
646 (assert! (meeting whole-company (Wednesday 4pm)))))
647 (test-query '(meeting ?div (Friday ?time))
648 '((meeting administration (friday 1pm))))
650 '(assert! (rule (meeting-time ?person ?day-and-time)
651 (or (and (job ?person (?dept . ?title))
652 (meeting ?dept ?day-and-time))
653 (meeting whole-company ?day-and-time)))))
655 (test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
656 '((meeting-time (hacker alyssa p) (wednesday 3pm))
657 (meeting-time (hacker alyssa p) (wednesday 4pm))))
659 ;; Exercise 4.60. By giving the query
661 ;; (rule (lives-near ?person (Hacker Alyssa P)))))
663 ;; Alyssa P. Hacker is able to find people who live near her, with whom she can ride to work. On the other hand, when she tries to find all pairs of people who live near each other by querying
665 ;; (lives-near ?person-1 ?person-2)
667 ;; she notices that each pair of people who live near each other is listed twice; for example,
669 ;; (lives-near (Hacker Alyssa P) (Fect Cy D))
670 ;; (lives-near (Fect Cy D) (Hacker Alyssa P))
672 ;; Why does this happen? Is there a way to find a list of people who live near each other, in which each pair appears only once? Explain.
674 (define (name<? name1 name2)
675 (let ((str1 (fold-left
677 (string-append str (symbol->string sym)))
682 (string-append str (symbol->string sym)))
685 (string<? str1 str2)))
687 (eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
688 (and (address ?person-1 (?town . ?rest-1))
689 (address ?person-2 (?town . ?rest-2))
690 (not (same ?person-1 ?person-2))
691 (lisp-value name<? ?person-1 ?person-2)))))
693 (test-query '(lives-near ?person-1 ?person-2)
694 '((lives-near (aull dewitt) (reasoner louis))
695 (lives-near (aull dewitt) (bitdiddle ben))
696 (lives-near (fect cy d) (hacker alyssa p))
697 (lives-near (bitdiddle ben) (reasoner louis))))