1 (define (make-table)
2   (define (assoc key records)
3     (cond ((null? records) false)
4 	  ((equal? key (caar records)) (car records))
5 	  (else (assoc key (cdr records)))))
6   (let ((local-table (list '*table*)))
7     (define (lookup key-1 key-2)
8       (let ((subtable (assoc key-1 (cdr local-table))))
9 	(if subtable
10 	    (let ((record (assoc key-2 (cdr subtable))))
11 	      (if record
12 		  (cdr record)
13 		  false))
14 	    false)))
15     (define (insert! key-1 key-2 value)
16       (let ((subtable (assoc key-1 (cdr local-table))))
17 	(if subtable
18 	    (let ((record (assoc key-2 (cdr subtable))))
19 	      (if record
20 		  (set-cdr! record value)
21 		  (set-cdr! subtable
22 			    (cons (cons key-2 value)
23 				  (cdr subtable)))))
24 	    (set-cdr! local-table
25 		      (cons (list key-1
26 				  (cons key-2 value))
27 			    (cdr local-table)))))
28       'ok)
29     (define (dispatch m)
30       (cond ((eq? m 'lookup-proc) lookup)
31 	    ((eq? m 'insert-proc!) insert!)
32 	    (else (error "Unknown operation -- TABLE" m))))
33     dispatch))
34 
35 (define operation-table (make-table))
36 (define get (operation-table 'lookup-proc))
37 (define put (operation-table 'insert-proc!))
38 
39 (define (memo-proc proc)
40   (let ((already-run? false) (result false))
41     (lambda ()
42       (if already-run?
43 	  result
44 	  (begin (set! already-run? true)
45 		 (set! result (proc))
46 		 result)))))
47 
48 (define-syntax mydelay
49   (rsc-macro-transformer
50    (let ((xfmr
51 	  (lambda (exp)
52 	    `(memo-proc (lambda () ,exp)))))
53      (lambda (e r)
54        (apply xfmr (cdr e))))))
55 
56 (define (myforce delayed-object)
57   (delayed-object))
58 
59 (define-syntax cons-stream
60   (rsc-macro-transformer
61    (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
62      (lambda (e r)
63        (apply xfmr (cdr e))))))
64 
65 (define (stream-car s)
66   (car s))
67 (define (stream-cdr s)
68   (myforce (cdr s)))
69 (define stream-null? null?)
70 (define the-empty-stream '())
71 (define (stream-map proc . argstreams)
72   (if (stream-null? (car argstreams))
73       the-empty-stream
74       (cons-stream
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)
80   (if (stream-null? s)
81       'done
82       (begin (proc (stream-car s))
83 	     (stream-for-each proc (stream-cdr s)))))
84 (define (display-line x)
85   (newline)
86   (display x))
87 
88 (define (test-case actual expected)
89   (newline)
90   (display "Actual:   ")
91   (display actual)
92   (newline)
93   (display "Expected: ")
94   (display expected)
95   (newline))
96 (define (display-streams n . streams)
97   (if (> n 0)
98       (begin (newline) 
99 	     (for-each 
100 	      (lambda (s)
101 		(display (stream-car s))
102 		(display " -- "))
103 	      streams)
104 	     (apply display-streams
105 		    (cons (- n 1) (map stream-cdr streams))))))
106 (define (list->stream list)
107   (if (null? list)
108       the-empty-stream
109       (cons-stream (car list)
110 		   (list->stream (cdr list)))))
111 
112 
113 (define (eval-queries queries)
114   (if (null? queries)
115       'done
116       (begin (eval-query (car queries))
117 	     (eval-queries (cdr queries)))))
118 (define (eval-query query)
119   (let ((q (query-syntax-process query)))
120     (if (assertion-to-be-added? q)
121 	(add-rule-or-assertion! (add-assertion-body q))
122 	(stream-map
123 	 (lambda (frame)
124 	   (instantiate q
125 	       frame
126 	     (lambda (v f)
127 	       (contract-question-mark v))))
128 	 (qeval q (singleton-stream '()))))))
129 (define (eval-display-query q)
130   (display-stream (eval-query q)))
131 
132 
133 (define input-prompt ";;; Query input:")
134 (define output-prompt ";;; Query results:")
135 (define (query-driver-loop)
136   (prompt-for-input input-prompt)
137   (let ((q (query-syntax-process (read))))
138     (cond ((assertion-to-be-added? q)
139            (add-rule-or-assertion! (add-assertion-body q))
140            (newline)
141            (display "Assertion added to data base.")
142            (query-driver-loop))
143           (else
144            (newline)
145            (display output-prompt)
146            (display-stream
147             (stream-map
148              (lambda (frame)
149                (instantiate q
150                             frame
151                             (lambda (v f)
152                               (contract-question-mark v))))
153              (qeval q (singleton-stream '()))))
154            (query-driver-loop)))))
155 (define (instantiate exp frame unbound-var-handler)
156   (define (copy exp)
157     (cond ((var? exp)
158            (let ((binding (binding-in-frame exp frame)))
159              (if binding
160                  (copy (binding-value binding))
161                  (unbound-var-handler exp frame))))
162           ((pair? exp)
163            (cons (copy (car exp)) (copy (cdr exp))))
164           (else exp)))
165   (copy exp))
166 (define (qeval query frame-stream)
167   (let ((qproc (get (type query) 'qeval)))
168     (if qproc
169         (qproc (contents query) frame-stream)
170         (simple-query query frame-stream))))
171 (define (simple-query query-pattern frame-stream)
172   (stream-flatmap
173    (lambda (frame)
174      (stream-append-delayed
175       (find-assertions query-pattern frame)
176       (delay (apply-rules query-pattern frame))))
177    frame-stream))
178 (define (conjoin conjuncts frame-stream)
179   (if (empty-conjunction? conjuncts)
180       frame-stream
181       (conjoin (rest-conjuncts conjuncts)
182                (qeval (first-conjunct conjuncts)
183                       frame-stream))))
184 (put 'and 'qeval conjoin)
185 (define (disjoin disjuncts frame-stream)
186   (if (empty-disjunction? disjuncts)
187       the-empty-stream
188       (interleave-delayed
189        (qeval (first-disjunct disjuncts) frame-stream)
190        (delay (disjoin (rest-disjuncts disjuncts)
191                        frame-stream)))))
192 (put 'or 'qeval disjoin)
193 (define (negate operands frame-stream)
194   (stream-flatmap
195    (lambda (frame)
196      (if (stream-null? (qeval (negated-query operands)
197                               (singleton-stream frame)))
198          (singleton-stream frame)
199          the-empty-stream))
200    frame-stream))
201 (put 'not 'qeval negate)
202 (define (lisp-value call frame-stream)
203   (stream-flatmap
204    (lambda (frame)
205      (if (execute
206           (instantiate
207            call
208            frame
209            (lambda (v f)
210              (error "Unknown pat var -- LISP-VALUE" v))))
211          (singleton-stream frame)
212          the-empty-stream))
213    frame-stream))
214 (put 'lisp-value 'qeval lisp-value)
215 (define (execute exp)
216   (apply (eval (predicate exp) user-initial-environment)
217          (args exp)))
218 (define (always-true ignore frame-stream) frame-stream)
219 (put 'always-true 'qeval always-true)
220 (define (find-assertions pattern frame)
221   (stream-flatmap (lambda (datum)
222                     (check-an-assertion datum pattern frame))
223                   (fetch-assertions pattern frame)))
224 (define (check-an-assertion assertion query-pat query-frame)
225   (let ((match-result
226          (pattern-match query-pat assertion query-frame)))
227     (if (eq? match-result 'failed)
228         the-empty-stream
229         (singleton-stream match-result))))
230 (define (pattern-match pat dat frame)
231   (cond ((eq? frame 'failed) 'failed)
232         ((equal? pat dat) frame)
233         ((var? pat) (extend-if-consistent pat dat frame))
234         ((and (pair? pat) (pair? dat))
235          (pattern-match (cdr pat)
236                         (cdr dat)
237                         (pattern-match (car pat)
238                                        (car dat)
239                                        frame)))
240         (else 'failed)))
241 (define (extend-if-consistent var dat frame)
242   (let ((binding (binding-in-frame var frame)))
243     (if binding
244         (pattern-match (binding-value binding) dat frame)
245         (extend var dat frame))))
246 (define (apply-rules pattern frame)
247   (stream-flatmap (lambda (rule)
248                     (apply-a-rule rule pattern frame))
249                   (fetch-rules pattern frame)))
250 (define (apply-a-rule rule query-pattern query-frame)
251   (let ((clean-rule (rename-variables-in rule)))
252     (let ((unify-result
253            (unify-match query-pattern
254                         (conclusion clean-rule)
255                         query-frame)))
256       (if (eq? unify-result 'failed)
257           the-empty-stream
258           (qeval (rule-body clean-rule)
259                  (singleton-stream unify-result))))))
260 (define (rename-variables-in rule)
261   (let ((rule-application-id (new-rule-application-id)))
262     (define (tree-walk exp)
263       (cond ((var? exp)
264              (make-new-variable exp rule-application-id))
265             ((pair? exp)
266              (cons (tree-walk (car exp))
267                    (tree-walk (cdr exp))))
268             (else exp)))
269     (tree-walk rule)))
270 (define (unify-match p1 p2 frame)
271   (cond ((eq? frame 'failed) 'failed)
272         ((equal? p1 p2) frame)
273         ((var? p1) (extend-if-possible p1 p2 frame))
274         ((var? p2) (extend-if-possible p2 p1 frame))  ; ***
275         ((and (pair? p1) (pair? p2))
276          (unify-match (cdr p1)
277                       (cdr p2)
278                       (unify-match (car p1)
279                                    (car p2)
280                                    frame)))
281         (else 'failed)))
282 (define (extend-if-possible var val frame)
283   (let ((binding (binding-in-frame var frame)))
284     (cond (binding
285            (unify-match
286             (binding-value binding) val frame))
287           ((var? val)                      ; ***
288            (let ((binding (binding-in-frame val frame)))
289              (if binding
290                  (unify-match
291                   var (binding-value binding) frame)
292                  (extend var val frame))))
293           ((depends-on? val var frame)     ; ***
294            'failed)
295           (else (extend var val frame)))))
296 (define (depends-on? exp var frame)
297   (define (tree-walk e)
298     (cond ((var? e)
299            (if (equal? var e)
300                true
301                (let ((b (binding-in-frame e frame)))
302                  (if b
303                      (tree-walk (binding-value b))
304                      false))))
305           ((pair? e)
306            (or (tree-walk (car e))
307                (tree-walk (cdr e))))
308           (else false)))
309   (tree-walk exp))
310 (define THE-ASSERTIONS the-empty-stream)
311 (define (fetch-assertions pattern frame)
312   (if (use-index? pattern)
313       (get-indexed-assertions pattern)
314       (get-all-assertions)))
315 (define (get-all-assertions) THE-ASSERTIONS)
316 (define (get-indexed-assertions pattern)
317   (get-stream (index-key-of pattern) 'assertion-stream))
318 (define (get-stream key1 key2)
319   (let ((s (get key1 key2)))
320     (if s s the-empty-stream)))
321 (define THE-RULES the-empty-stream)
322 (define (fetch-rules pattern frame)
323   (if (use-index? pattern)
324       (get-indexed-rules pattern)
325       (get-all-rules)))
326 (define (get-all-rules) THE-RULES)
327 (define (get-indexed-rules pattern)
328   (stream-append
329    (get-stream (index-key-of pattern) 'rule-stream)
330    (get-stream '? 'rule-stream)))
331 (define (add-rule-or-assertion! assertion)
332   (if (rule? assertion)
333       (add-rule! assertion)
334       (add-assertion! assertion)))
335 (define (add-assertion! assertion)
336   (store-assertion-in-index assertion)
337   (let ((old-assertions THE-ASSERTIONS))
338     (set! THE-ASSERTIONS
339           (cons-stream assertion old-assertions))
340     'ok))
341 (define (add-rule! rule)
342   (store-rule-in-index rule)
343   (let ((old-rules THE-RULES))
344     (set! THE-RULES (cons-stream rule old-rules))
345     'ok))
346 (define (store-assertion-in-index assertion)
347   (if (indexable? assertion)
348       (let ((key (index-key-of assertion)))
349         (let ((current-assertion-stream
350                (get-stream key 'assertion-stream)))
351           (put key
352                'assertion-stream
353                (cons-stream assertion
354                             current-assertion-stream))))))
355 (define (store-rule-in-index rule)
356   (let ((pattern (conclusion rule)))
357     (if (indexable? pattern)
358         (let ((key (index-key-of pattern)))
359           (let ((current-rule-stream
360                  (get-stream key 'rule-stream)))
361             (put key
362                  'rule-stream
363                  (cons-stream rule
364                               current-rule-stream)))))))
365 (define (indexable? pat)
366   (or (constant-symbol? (car pat))
367       (var? (car pat))))
368 (define (index-key-of pat)
369   (let ((key (car pat)))
370     (if (var? key) '? key)))
371 (define (use-index? pat)
372   (constant-symbol? (car pat)))
373 (define (stream-append-delayed s1 delayed-s2)
374   (if (stream-null? s1)
375       (force delayed-s2)
376       (cons-stream
377        (stream-car s1)
378        (stream-append-delayed (stream-cdr s1) delayed-s2))))
379 (define (interleave-delayed s1 delayed-s2)
380   (if (stream-null? s1)
381       (force delayed-s2)
382       (cons-stream
383        (stream-car s1)
384        (interleave-delayed (force delayed-s2)
385                            (delay (stream-cdr s1))))))
386 (define (stream-flatmap proc s)
387   (flatten-stream (stream-map proc s)))
388 (define (flatten-stream stream)
389   (if (stream-null? stream)
390       the-empty-stream
391       (interleave-delayed
392        (stream-car stream)
393        (delay (flatten-stream (stream-cdr stream))))))
394 (define (singleton-stream x)
395   (cons-stream x the-empty-stream))
396 (define (type exp)
397   (if (pair? exp)
398       (car exp)
399       (error "Unknown expression TYPE" exp)))
400 (define (contents exp)
401   (if (pair? exp)
402       (cdr exp)
403       (error "Unknown expression CONTENTS" exp)))
404 (define (assertion-to-be-added? exp)
405   (eq? (type exp) 'assert!))
406 (define (add-assertion-body exp)
407   (car (contents exp)))
408 (define (empty-conjunction? exps) (null? exps))
409 (define (first-conjunct exps) (car exps))
410 (define (rest-conjuncts exps) (cdr exps))
411 (define (empty-disjunction? exps) (null? exps))
412 (define (first-disjunct exps) (car exps))
413 (define (rest-disjuncts exps) (cdr exps))
414 (define (negated-query exps) (car exps))
415 (define (predicate exps) (car exps))
416 (define (args exps) (cdr exps))
417 (define (rule? statement)
418   (tagged-list? statement 'rule))
419 (define (conclusion rule) (cadr rule))
420 (define (rule-body rule)
421   (if (null? (cddr rule))
422       '(always-true)
423       (caddr rule)))
424 (define (query-syntax-process exp)
425   (map-over-symbols expand-question-mark exp))
426 (define (map-over-symbols proc exp)
427   (cond ((pair? exp)
428          (cons (map-over-symbols proc (car exp))
429                (map-over-symbols proc (cdr exp))))
430         ((symbol? exp) (proc exp))
431         (else exp)))
432 (define (expand-question-mark symbol)
433   (let ((chars (symbol->string symbol)))
434     (if (string=? (substring chars 0 1) "?")
435         (list '?
436               (string->symbol
437                (substring chars 1 (string-length chars))))
438         symbol)))
439 (define (var? exp)
440   (tagged-list? exp '?))
441 (define (constant-symbol? exp) (symbol? exp))
442 (define rule-counter 0)
443 (define (new-rule-application-id)
444   (set! rule-counter (+ 1 rule-counter))
445   rule-counter)
446 (define (make-new-variable var rule-application-id)
447   (cons '? (cons rule-application-id (cdr var))))
448 (define (contract-question-mark variable)
449   (string->symbol
450    (string-append "?" 
451      (if (number? (cadr variable))
452          (string-append (symbol->string (caddr variable))
453                         "-"
454                         (number->string (cadr variable)))
455          (symbol->string (cadr variable))))))
456 (define (make-binding variable value)
457   (cons variable value))
458 (define (binding-variable binding)
459   (car binding))
460 (define (binding-value binding)
461   (cdr binding))
462 (define (binding-in-frame variable frame)
463   (assoc variable frame))
464 (define (extend variable value frame)
465   (cons (make-binding variable value) frame))
466 (define (tagged-list? exp tag)
467   (and (pair? exp) (eq? (car exp) tag)))
468 
469 (eval-queries
470 '((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
471   (assert! (job (Bitdiddle Ben) (computer wizard)))
472   (assert! (salary (Bitdiddle Ben) 60000))
473   (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
474   (assert! (job (Hacker Alyssa P) (computer programmer)))
475   (assert! (salary (Hacker Alyssa P) 40000))
476   (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
477   (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
478   (assert! (job (Fect Cy D) (computer programmer)))
479   (assert! (salary (Fect Cy D) 35000))
480   (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
481   (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
482   (assert! (job (Tweakit Lem E) (computer technician)))
483   (assert! (salary (Tweakit Lem E) 25000))
484   (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
485   (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
486   (assert! (job (Reasoner Louis) (computer programmer trainee)))
487   (assert! (salary (Reasoner Louis) 30000))
488   (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
489   (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
490   (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
491   (assert! (job (Warbucks Oliver) (administration big wheel)))
492   (assert! (salary (Warbucks Oliver) 150000))
493   (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
494   (assert! (job (Scrooge Eben) (accounting chief accountant)))
495   (assert! (salary (Scrooge Eben) 75000))
496   (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
497   (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
498   (assert! (job (Cratchet Robert) (accounting scrivener)))
499   (assert! (salary (Cratchet Robert) 18000))
500   (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
501   (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
502   (assert! (job (Aull DeWitt) (administration secretary)))
503   (assert! (salary (Aull DeWitt) 25000))
504   (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
505   (assert! (can-do-job (computer wizard) (computer programmer)))
506   (assert! (can-do-job (computer wizard) (computer technician)))
507   (assert! (can-do-job (computer programmer)
508 		       (computer programmer trainee)))
509   (assert! (can-do-job (administration secretary)
510 		       (administration big wheel)))))
511 
512 ;; Exercise 4.55.  Give simple queries that retrieve the following information from the data base:
513 
514 ;; a. all people supervised by Ben Bitdiddle;
515 
516 (eval-display-query '(supervisor ?employee (Bitdiddle Ben)))
517 
518 ;;b. the names and jobs of all people in the accounting division;
519 
520 (eval-display-query '(job ?x (accounting . ?title)))
521 
522 ;;c. the names and addresses of all people who live in Slumerville. 
523 
524 (eval-display-query '(address ?person (Slumerville . ?rest)))