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 ;; Exercise 4.59. Ben Bitdiddle has missed one meeting too many. Fearing that his habit of forgetting meetings could cost him his job, Ben decides to do something about it. He adds all the weekly meetings of the firm to the Microshaft data base by asserting the following:
645 '((assert! (meeting accounting (Monday 9am)))
646 (assert! (meeting administration (Monday 10am)))
647 (assert! (meeting computer (Wednesday 3pm)))
648 (assert! (meeting administration (Friday 1pm)))
649 (assert! (meeting whole-company (Wednesday 4pm)))))
651 ;; Each of the above assertions is for a meeting of an entire division. Ben also adds an entry for the company-wide meeting that spans all the divisions. All of the company's employees attend this meeting.
653 ;; a. On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use?
655 (test-query '(meeting ?div (Friday ?time))
656 '((meeting administration (friday 1pm))))
658 ;; b. Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all whole-company meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule.
661 '(assert! (rule (meeting-time ?person ?day-and-time)
662 (or (and (job ?person (?dept . ?title))
663 (meeting ?dept ?day-and-time))
664 (meeting whole-company ?day-and-time)))))
666 ;; c. Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out?
668 (test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
669 '((meeting-time (hacker alyssa p) (wednesday 3pm))
670 (meeting-time (hacker alyssa p) (wednesday 4pm))))