1 
2 ;; dispatch table
3 
4 (define (make-table)
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))))
12 	(if subtable
13 	    (let ((record (assoc key-2 (cdr subtable))))
14 	      (if record
15 		  (cdr record)
16 		  false))
17 	    false)))
18     (define (insert! key-1 key-2 value)
19       (let ((subtable (assoc key-1 (cdr local-table))))
20 	(if subtable
21 	    (let ((record (assoc key-2 (cdr subtable))))
22 	      (if record
23 		  (set-cdr! record value)
24 		  (set-cdr! subtable
25 			    (cons (cons key-2 value)
26 				  (cdr subtable)))))
27 	    (set-cdr! local-table
28 		      (cons (list key-1
29 				  (cons key-2 value))
30 			    (cdr local-table)))))
31       'ok)
32     (define (dispatch m)
33       (cond ((eq? m 'lookup-proc) lookup)
34 	    ((eq? m 'insert-proc!) insert!)
35 	    (else (error "Unknown operation -- TABLE" m))))
36     dispatch))
37 (define operation-table (make-table))
38 (define get (operation-table 'lookup-proc))
39 (define put (operation-table 'insert-proc!))
40 
41 ;; streams/delayed-evaluation
42 
43 (define (memo-proc proc)
44   (let ((already-run? false) (result false))
45     (lambda ()
46       (if already-run?
47 	  result
48 	  (begin (set! already-run? true)
49 		 (set! result (proc))
50 		 result)))))
51 (define-syntax mydelay
52   (rsc-macro-transformer
53    (let ((xfmr
54 	  (lambda (exp)
55 	    `(memo-proc (lambda () ,exp)))))
56      (lambda (e r)
57        (apply xfmr (cdr e))))))
58 (define (myforce delayed-object)
59   (delayed-object))
60 (define-syntax cons-stream
61   (rsc-macro-transformer
62    (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
63      (lambda (e r)
64        (apply xfmr (cdr e))))))
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 (define (display-streams n . streams)
88   (if (> n 0)
89       (begin (newline) 
90 	     (for-each 
91 	      (lambda (s)
92 		(display (stream-car s))
93 		(newline))
94 	      streams)
95 	     (apply display-streams
96 		    (cons (- n 1) (map stream-cdr streams))))))
97 (define (list->stream list)
98   (if (null? list)
99       the-empty-stream
100       (cons-stream (car list)
101 		   (list->stream (cdr list)))))
102 (define (stream-fold-left op initial sequence)
103   (define (iter result rest)
104     (if (null? rest)
105 	result
106 	(iter (op result (stream-car rest))
107 	      (stream-cdr rest))))
108   (iter initial sequence))
109 
110 ;; query-driver-loop
111 
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))
119            (newline)
120            (display "Assertion added to data base.")
121            (query-driver-loop))
122           (else
123            (newline)
124            (display output-prompt)
125            (display-stream
126             (stream-map
127              (lambda (frame)
128                (instantiate q
129                             frame
130                             (lambda (v f)
131                               (contract-question-mark v))))
132              (qeval q (singleton-stream '()))))
133            (query-driver-loop)))))
134 (define (instantiate exp frame unbound-var-handler)
135   (define (copy exp)
136     (cond ((var? exp)
137            (let ((binding (binding-in-frame exp frame)))
138              (if binding
139                  (copy (binding-value binding))
140                  (unbound-var-handler exp frame))))
141           ((pair? exp)
142            (cons (copy (car exp)) (copy (cdr exp))))
143           (else exp)))
144   (copy exp))
145 (define (qeval query frame-stream)
146   (let ((qproc (get (type query) 'qeval)))
147     (if qproc
148         (qproc (contents query) frame-stream)
149         (simple-query query frame-stream))))
150 (define (simple-query query-pattern frame-stream)
151   (stream-flatmap
152    (lambda (frame)
153      (stream-append-delayed
154       (find-assertions query-pattern frame)
155       (delay (apply-rules query-pattern frame))))
156    frame-stream))
157 (define (conjoin conjuncts frame-stream)
158   (if (empty-conjunction? conjuncts)
159       frame-stream
160       (conjoin (rest-conjuncts conjuncts)
161                (qeval (first-conjunct conjuncts)
162                       frame-stream))))
163 (put 'and 'qeval conjoin)
164 (define (disjoin disjuncts frame-stream)
165   (if (empty-disjunction? disjuncts)
166       the-empty-stream
167       (interleave-delayed
168        (qeval (first-disjunct disjuncts) frame-stream)
169        (delay (disjoin (rest-disjuncts disjuncts)
170                        frame-stream)))))
171 (put 'or 'qeval disjoin)
172 (define (negate operands frame-stream)
173   (stream-flatmap
174    (lambda (frame)
175      (if (stream-null? (qeval (negated-query operands)
176                               (singleton-stream frame)))
177          (singleton-stream frame)
178          the-empty-stream))
179    frame-stream))
180 (put 'not 'qeval negate)
181 (define (lisp-value call frame-stream)
182   (stream-flatmap
183    (lambda (frame)
184      (if (execute
185           (instantiate
186            call
187            frame
188            (lambda (v f)
189              (error "Unknown pat var -- LISP-VALUE" v))))
190          (singleton-stream frame)
191          the-empty-stream))
192    frame-stream))
193 (put 'lisp-value 'qeval lisp-value)
194 (define (execute exp)
195   (apply (eval (predicate exp) user-initial-environment)
196          (args exp)))
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)
204   (let ((match-result
205          (pattern-match query-pat assertion query-frame)))
206     (if (eq? match-result 'failed)
207         the-empty-stream
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)
215                         (cdr dat)
216                         (pattern-match (car pat)
217                                        (car dat)
218                                        frame)))
219         (else 'failed)))
220 (define (extend-if-consistent var dat frame)
221   (let ((binding (binding-in-frame var frame)))
222     (if binding
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)))
231     (let ((unify-result
232            (unify-match query-pattern
233                         (conclusion clean-rule)
234                         query-frame)))
235       (if (eq? unify-result 'failed)
236           the-empty-stream
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)
242       (cond ((var? exp)
243              (make-new-variable exp rule-application-id))
244             ((pair? exp)
245              (cons (tree-walk (car exp))
246                    (tree-walk (cdr exp))))
247             (else exp)))
248     (tree-walk rule)))
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)
256                       (cdr p2)
257                       (unify-match (car p1)
258                                    (car p2)
259                                    frame)))
260         (else 'failed)))
261 (define (extend-if-possible var val frame)
262   (let ((binding (binding-in-frame var frame)))
263     (cond (binding
264            (unify-match
265             (binding-value binding) val frame))
266           ((var? val)                      ; ***
267            (let ((binding (binding-in-frame val frame)))
268              (if binding
269                  (unify-match
270                   var (binding-value binding) frame)
271                  (extend var val frame))))
272           ((depends-on? val var frame)     ; ***
273            'failed)
274           (else (extend var val frame)))))
275 (define (depends-on? exp var frame)
276   (define (tree-walk e)
277     (cond ((var? e)
278            (if (equal? var e)
279                true
280                (let ((b (binding-in-frame e frame)))
281                  (if b
282                      (tree-walk (binding-value b))
283                      false))))
284           ((pair? e)
285            (or (tree-walk (car e))
286                (tree-walk (cdr e))))
287           (else false)))
288   (tree-walk exp))
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)
304       (get-all-rules)))
305 (define (get-all-rules) THE-RULES)
306 (define (get-indexed-rules pattern)
307   (stream-append
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))
317     (set! THE-ASSERTIONS
318           (cons-stream assertion old-assertions))
319     'ok))
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))
324     'ok))
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)))
330           (put key
331                '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)))
340             (put key
341                  'rule-stream
342                  (cons-stream rule
343                               current-rule-stream)))))))
344 (define (indexable? pat)
345   (or (constant-symbol? (car pat))
346       (var? (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)
354       s2
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)
359       (force delayed-s2)
360       (cons-stream
361        (stream-car s1)
362        (stream-append-delayed (stream-cdr s1) delayed-s2))))
363 (define (interleave-delayed s1 delayed-s2)
364   (if (stream-null? s1)
365       (force delayed-s2)
366       (cons-stream
367        (stream-car 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)
374       the-empty-stream
375       (interleave-delayed
376        (stream-car stream)
377        (delay (flatten-stream (stream-cdr stream))))))
378 (define (singleton-stream x)
379   (cons-stream x the-empty-stream))
380 (define (type exp)
381   (if (pair? exp)
382       (car exp)
383       (error "Unknown expression TYPE" exp)))
384 (define (contents exp)
385   (if (pair? exp)
386       (cdr 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))
406       '(always-true)
407       (caddr rule)))
408 (define (query-syntax-process exp)
409   (map-over-symbols expand-question-mark exp))
410 (define (map-over-symbols proc exp)
411   (cond ((pair? exp)
412          (cons (map-over-symbols proc (car exp))
413                (map-over-symbols proc (cdr exp))))
414         ((symbol? exp) (proc exp))
415         (else exp)))
416 (define (expand-question-mark symbol)
417   (let ((chars (symbol->string symbol)))
418     (if (string=? (substring chars 0 1) "?")
419         (list '?
420               (string->symbol
421                (substring chars 1 (string-length chars))))
422         symbol)))
423 (define (var? exp)
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))
429   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)
433   (string->symbol
434    (string-append "?" 
435      (if (number? (cadr variable))
436          (string-append (symbol->string (caddr variable))
437                         "-"
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)
443   (car binding))
444 (define (binding-value binding)
445   (cdr 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)))
452 
453 ;; test procedures
454 
455 (define (eval-queries queries)
456   (if (null? queries)
457       'done
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))
464 	(stream-map
465 	 (lambda (frame)
466 	   (instantiate q
467 	       frame
468 	     (lambda (v f)
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)
474   (newline)
475   (display "Actual:   ")
476   (display actual)
477   (newline)
478   (display "Expected: ")
479   (display expected)
480   (newline))
481 (define (test-query query . expected)
482   (if (null? expected)
483       (let ((result (eval-query query)))
484 	(if (symbol? result)
485 	    (begin (display "Assertion added") (newline))
486 	    (display-stream (eval-query query))))
487       (let ((list (car expected)))
488 	(let ((result
489 	       (stream-fold-left 
490 		(lambda (x y)
491 		  (and x y))
492 		#t
493 		(stream-map 
494 		 (lambda (e1 e2)
495 		   (equal? e1 e2))
496 		 (eval-query query)
497 		 (list->stream list)))))
498 	  (if result
499 	      (display "Passed -- ")
500 	      (display "Failed! -- "))
501 	  (display query)
502 	  (newline)))))
503 
504       ;; (let ((result (eval-query query)))
505       ;; 	(if (pair? result)
506       ;; 	    (display-stream (eval-query query))
507       ;; 	    result))
508 
509 ;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
510 
511 	;; (display-streams 
512 	;;  (length list)
513 	;;  (eval-query query)
514 	;;  (list->stream list)))))
515 
516 	;; (display-stream
517 	;;  (stream-map 
518 	;;   (lambda (e1 e2)
519 	;;     (equal? e1 e2))
520 	;;   (eval-query query)
521 	;;   (list->stream list))))))
522 ;; test-suite
523 
524 
525 (eval-queries
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)))))
567 
568 (eval-query
569  '(assert! (rule (same ?x ?x))))
570 
571 (newline)
572 (test-query
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))))
577 (test-query 
578  '(job ?x (accounting . ?title))
579  '((job (cratchet robert) (accounting scrivener))
580    (job (scrooge eben) (accounting chief accountant))))
581 (test-query
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))))
586 (test-query 
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)))))
592 (test-query
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))))
602 (test-query
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))))))
610 
611 (eval-query
612  '(assert! (rule (can-replace? ?p1 ?p2)
613 		 (and (or (and (job ?p1 ?job)
614 			       (job ?p2 ?job))
615 			  (and (job ?p1 ?j1)
616 			       (job ?p2 ?j2)
617 			       (can-do-job ?j1 ?j2)))
618 		      (not (same ?p1 ?p2))))))
619 (test-query 
620  '(can-replace? ?x (Fect Cy D))
621  '((can-replace? (bitdiddle ben) (fect cy d))
622    (can-replace? (hacker alyssa p) (fect cy d))))
623 (test-query 
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))))
630 (eval-query
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)))))))))
636 (test-query 
637  '(big-shot ?x)
638  '((big-shot (warbucks oliver))
639    (big-shot (scrooge eben))
640    (big-shot (bitdiddle ben))))
641 (eval-queries
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))))
649 (eval-query
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)))))
654 
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))))
658 
659 (define (name<? name1 name2)
660   (let ((str1 (fold-left 
661 	       (lambda (str sym)
662 		 (string-append str (symbol->string sym)))
663 	       ""
664 	       name1))
665 	(str2 (fold-left 
666 	       (lambda (str sym)
667 		 (string-append str (symbol->string sym)))
668 	       ""
669 	       name2)))
670     (string<? str1 str2)))
671 
672 (eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
673 			    (and (address ?person-1 (?town . ?rest-1))
674 				 (address ?person-2 (?town . ?rest-2))
675 				 (not (same ?person-1 ?person-2))
676 				 (lisp-value name<? ?person-1 ?person-2)))))
677 
678 (test-query '(lives-near ?person-1 ?person-2)
679 	    '((lives-near (aull dewitt) (reasoner louis))
680 	      (lives-near (aull dewitt) (bitdiddle ben))
681 	      (lives-near (fect cy d) (hacker alyssa p))
682 	      (lives-near (bitdiddle ben) (reasoner louis))))
683 (eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
684 (eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
685 			    (?x next-to ?y in ?z))))
686 (test-query '(?x next-to ?y in (1 (2 3) 4))
687 	    '(((2 3) next-to 4 in (1 (2 3) 4))
688 	      (1 next-to (2 3) in (1 (2 3) 4))))
689 (test-query '(?x next-to 1 in (2 1 3 1))
690 	    '((3 next-to 1 in (2 1 3 1))
691 	      (2 next-to 1 in (2 1 3 1))))
692 (eval-queries
693  '((assert! (rule (last-pair (?x) (?x))))
694    (assert! (rule (last-pair (?x . ?y) (?z))
695 		  (last-pair ?y (?z))))))
696 (test-query '(last-pair (3) ?x)
697 	    '((last-pair (3) (3))))
698 (test-query '(last-pair (1 2 3))
699 	    '((last-pair (1 2 3) (3))))
700 (test-query '(last-pair (2 ?x) (3))
701 	    '((last-pair (2 3) (3))))
702 (eval-queries
703  '((assert! (son Adam Cain))
704    (assert! (son Cain Enoch))
705    (assert! (son Enoch Irad))
706    (assert! (son Irad Mehujael))
707    (assert! (son Mehujael Methushael))
708    (assert! (son Methushael Lamech))
709    (assert! (wife Lamech Ada))
710    (assert! (son Ada Jabal))
711    (assert! (son Ada Jubal))))
712 (eval-queries
713  '((assert! (rule (grandson ?g ?s)
714 		 (and (son ?g ?f)
715 		      (son ?f ?s))))
716    (assert! (rule (son ?f ?s)
717 		  (and (wife ?f ?m)
718 		       (son ?m ?s))))))
719 (test-query 
720  '(grandson Cain ?grandson)
721  '((grandson cain irad)))
722 (test-query 
723  '(son Lamech ?son)
724  '((son lamech jubal)
725    (son lamech jabal)))
726 (test-query 
727  '(grandson Methushael ?grandson)
728  '((grandson methushael jubal)
729    (grandson methushael jabal)))
730 
731 (eval-queries
732  '((assert! (rule (append-to-form () ?y ?y)))
733    (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
734 		  (append-to-form ?v ?y ?z)))
735    (assert! (rule (reverse () ())))
736    (assert! (rule (reverse (?x . ?y) ?rev)
737 		  (and (reverse ?y ?rev-y)
738 		       (append-to-form ?rev-y (?x) ?rev))))))
739 (test-query '(reverse (1 2 3) ?x)
740 	    '((reverse (1 2 3) (3 2 1))))
741 
742  ;; 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). 
743 
744 (eval-queries
745  '((assert! (rule (ends-in-grandson? (grandson))))
746    (assert! (rule (ends-in-grandson? (?x . ?y))
747 		  (ends-in-grandson? ?y)))))
748 ;; (test-query '(ends-in-grandson? (father)))
749 ;; (test-query '(ends-in-grandson? (son mother father)))
750 ;; (test-query '(ends-in-grandson? (grandson)))
751 ;; (test-query '(ends-in-grandson? (father son grandson mother)))
752 ;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))      
753 
754 (eval-queries
755  '((assert! (rule ((great . ?rel) ?x ?y)
756 		  (and (ends-in-grandson? ?rel)
757 		       (son ?x ?z)
758 		       (?rel ?z ?y))))
759    (assert! (rule ((grandson) ?x ?y)
760 		  (grandson ?x ?y)))))
761 
762 ;; ((great great great grandson) Adam ?somebody)
763 ;; ((great . ?rel) ?x ?y)
764 
765 ;; ?rel -> (great great grandson)
766 ;; ?x -> Adam
767 ;; ?somebody -> ?y	   
768 
769 ;; (and (ends-in-grandson? ?rel)
770 ;;      (son ?x ?z)
771 ;;      (?rel ?z ?y))
772 ;; (and (son Adam ?z)
773 ;;      ((great great grandson) ?z ?y))
774 
775 ;; (son Adam ?z)
776 ;; (son Adam Cain)
777 ;; ?z -> Cain
778 
779 ;; ((great great grandson) Cain ?y)
780 ;; ((great . ?rel1) ?x1 ?y1)
781 ;; ?rel1 -> (great grandson)
782 ;; ?x1 -> Cain
783 ;; ?y -> ?y1
784 ;; (and (son Cain ?z1)
785 ;;      ((great grandson) ?z1 ?y1))
786 ;; ?z1 -> Enoch
787 ;; ((great grandson) Enoch ?y1)
788 ;; ((great . ?rel2) ?x2 ?y2)
789 ;; ?rel2 -> (grandson)
790 ;; ?x2 -> Enoch
791 ;; ?y1 -> ?y2
792 ;; (and (son Enoch ?z2)
793 ;;      ((grandson) ?z2 ?y2))
794 ;; ?z2 -> Irad
795 ;; ((grandson) Irad ?y2)
796 
797 ;; (assert! (son Adam Cain))
798 ;;    (assert! (son Cain Enoch))
799 ;;    (assert! (son Enoch Irad))
800 ;;    (assert! (son Irad Mehujael))
801 ;;    (assert! (son Mehujael Methushael))
802 ;;    (assert! (son Methushael Lamech))
803 ;;    (assert! (wife Lamech Ada))
804 ;;    (assert! (son Ada Jabal))
805 ;;    (assert! (son Ada Jubal))
806 
807 (test-query '((great grandson) ?great-grandfather Irad)
808 	    '(((great grandson) Adam Irad)))
809 (test-query '((great great great great great grandson) Adam ?x)
810 	    '(((great great great great great grandson) Adam Jubal)
811 	      ((great great great great great grandson) Adam Jabal)))
812 
813 (test-query '((great grandson) ?g ?ggs)
814 	    '(((great grandson) mehujael jubal)
815 	      ((great grandson) irad lamech)
816 	      ((great grandson) mehujael jabal)
817 	      ((great grandson) enoch methushael)
818 	      ((great grandson) cain mehujael)
819 	      ((great grandson) adam irad))) 
820 
821 ;; (test-query '(?relationship Adam Irad))
822 ;; this goes into an infinite loop
823 (define (simple-stream-flatmap proc s)
824   (simple-flatten (stream-map proc s)))
825 
826 (define (simple-flatten stream)
827   (stream-map stream-car
828               (stream-filter (lambda (x) (not (stream-null? x))) stream)))
829 
830 
831  ;; 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,
832 
833 (define (uniquely-asserted operands frame-stream)
834   (stream-flatmap
835    (lambda (frame)
836      (let ((results-stream 
837 	    (qeval (unique-query operands)
838 		   (singleton-stream frame))))
839        (if (singleton-stream? results-stream)
840 	   results-stream
841 	   the-empty-stream)))
842    frame-stream))
843 (define (unique-query operands)
844   (car operands))
845 (define (singleton-stream? s)
846   (and (not (stream-null? s))
847        (stream-null? (stream-cdr s))))
848 (put 'unique 'qeval uniquely-asserted)
849 
850 
851 
852 (test-query '(unique (job ?x (computer wizard)))
853 	    '((unique (job (Bitdiddle Ben) (computer wizard)))))
854 
855 ;; should print the one-item stream
856 ;; since Ben is the only computer wizard, and
857 
858 (test-query '(unique (job ?x (computer programmer)))
859 	    '())
860 
861 ;; should print the empty stream, since there is more than one computer programmer. Moreover,
862 
863 (test-query '(and (job ?x ?j)
864 		  (unique (job ?anyone ?j)))
865 	    '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
866 	      (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
867 	      (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
868 	      (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
869 	      (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
870 	      (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
871 	      (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
872 
873 ;; should list all the jobs that are filled by only one person, and the people who fill them.
874 
875 ;; There are two parts to implementing unique. The first is to write a procedure that handles this special form, and the second is to make qeval dispatch to that procedure. The second part is trivial, since qeval does its dispatching in a data-directed way. If your procedure is called uniquely-asserted, all you need to do is
876 
877 
878 ;; and qeval will dispatch to this procedure for every query whose type (car) is the symbol unique.
879 
880 ;; The real problem is to write the procedure uniquely-asserted. This should take as input the contents (cdr) of the unique query, together with a stream of frames. For each frame in the stream, it should use qeval to find the stream of all extensions to the frame that satisfy the given query. Any stream that does not have exactly one item in it should be eliminated. The remaining streams should be passed back to be accumulated into one big stream that is the result of the unique query. This is similar to the implementation of the not special form.
881 
882 ;; Test your implementation by forming a query that lists all people who supervise precisely one person. 
883 
884 (test-query '(and (supervisor ?sub ?sup) 
885 		  (unique (supervisor ?anyone ?sup)))
886 	    '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
887 	      (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))