1 query-driver-loop
2 (define input-prompt ";;; Query Input: ")
3 (define output-prompt ";;; Query Output: ")
4 (define (query-driver-loop)
5   (print-output input-prompt)
6   (let ((q (query-syntax-process (read))))
7     (cond ((assertion-to-be-added? q)
8 	   (add-assertion-or-rule! (add-assertion-body q))
9 	   (newline)
10 	   (display "Assertion added to data base.")
11 	   (query-driver-loop))
12 	  (else	
13 	   (print-output output-prompt)
14 	   (newline)
15 	   (display-stream
16 	    (stream-map
17 	     (lambda (frame)
18 	       (instantiate 
19 		   q
20 		   frame
21 		 (lambda (v f)
22 		   (contract-question-mark v))))
23 	     (qeval q (singleton-stream the-empty-frame))))
24 	   (query-driver-loop)))))
25 
26 (define (query-syntax-process exp)
27   (map-over-symbols expand-question-mark exp))
28 (define (map-over-symbols proc exp)
29   (cond ((symbol? exp) (proc exp))
30 	((pair? exp)
31 	 (cons (map-over-symbols proc (car exp))
32 	       (map-over-symbols proc (cdr exp))))
33 	(else exp)))
34 (define (expand-question-mark exp)
35   (let ((chars (symbol->string exp)))
36     (if (string=? (substring chars 0 1) "?")
37 	(list '?
38 	      (string->symbol
39 	       (substring chars 1 (string-length chars))))
40 	exp)))
41 (define (contract-question-mark exp)
42   (string->symbol
43    (string-append
44     "?"
45     (if (number? (cadr exp))
46 	(string-append
47 	 (symbol->string (caddr exp))
48 	 "-"
49 	 (number->string (cadr exp)))
50 	(symbol->string (cadr exp))))))
51 
52 (define (instantiate pat frame unbound-var-handler)
53   (define (copy exp)
54     (cond ((var? exp)
55 	   (let ((binding (binding-in-frame exp frame)))
56 	     (if binding
57 		 (copy (binding-value binding))
58 		 (unbound-var-handler exp frame))))
59 	  ((pair? exp)
60 	   (cons (copy (car exp))
61 		 (copy (cdr exp))))
62 	  (else exp)))
63   (copy pat))
64 
65 (define (assertion-to-be-added? exp)
66   (eq? (type exp) 'assert!))
67 (define (add-assertion-body exp)
68   (car (contents exp)))
69 (define (type exp)
70   (if (pair? exp)
71       (car exp)
72       (error "Unknown expression -- TYPE" exp)))
73 (define (contents exp)
74   (if (pair? exp)
75       (cdr exp)
76       (error "Unknown expression -- CONTENTS" exp)))
77 (define (add-assertion-or-rule! assertion)
78   (if (rule? assertion)
79       (add-rule! assertion)
80       (add-assertion! assertion)))
81 (define (rule? statement)
82   (tagged-list? statement 'rule))
83 (define (add-rule! rule)
84   (store-rule-in-index rule)
85   (let ((old-rules THE-RULES))
86     (set! THE-RULES
87 	  (cons-stream rule old-rules))
88     'ok))
89 (define (store-rule-in-index rule)
90   (let ((pattern (conclusion rule)))
91     (if (indexable? pattern)
92 	(let* ((key (index-key-of pattern))
93 	       (current-rule-stream
94 		(get-stream key 'rule-stream)))
95 	  (put key
96 	       'rule-stream
97 	       (cons-stream rule current-rule-stream))))))
98 (define (add-assertion! assertion)
99   (store-assertion-in-index assertion)
100   (let ((old-assertions THE-ASSERTIONS))
101     (set! THE-ASSERTIONS
102 	  (cons-stream assertion old-assertions))
103     'ok))
104 (define (store-assertion-in-index assertion)
105   (if (indexable? assertion)
106       (let* ((key (index-key-of assertion))
107 	     (current-assertion-stream
108 	      (get-stream key 'assertion-stream)))
109 	(put key
110 	     'assertion-stream
111 	     (cons-stream assertion current-assertion-stream)))))
112 (define (get-stream key1 key2)
113   (let ((s (get key1 key2)))
114     (if s s the-empty-stream)))
115 (define (index-key-of pattern)
116   (let ((key (car pattern)))
117     (if (var? key) '? key)))
118 (define (indexable? pattern)
119   (or (constant-symbol? (car pattern))
120       (var? (car pattern))))
121 (define (var? exp)
122   (tagged-list? exp '?))
123 (define (constant-symbol? exp)
124   (symbol? exp))
125 (define THE-ASSERTIONS the-empty-stream)
126 (define (singleton-stream x)
127   (cons-stream x the-empty-stream))
128 (define (make-binding var val)
129   (cons var val))
130 (define (extend var val frame)
131   (cons (make-binding var val) frame))
132 (define (binding-in-frame var frame)
133   (assoc var frame))
134 (define the-empty-frame '())
135 (define (conclusion rule)
136   (cadr rule))
137 (define (rule-body rule)
138   (if (null? (cddr rule))
139       '(always-true)
140       (caddr rule)))
141 (define (qeval query frame-stream)
142   (let ((qproc (get (type query) 'qeval)))
143     (if qproc
144 	(qproc (contents query) frame-stream)
145 	(simple-query query frame-stream))))
146 (define (conjoin conjuncts frame-stream)
147   (if (empty-conjuncts? conjuncts)
148       frame-stream
149       (conjoin (rest-conjuncts conjuncts)
150 	       (qeval (first-conjunct conjuncts) frame-stream))))
151 (define (disjoin disjuncts frame-stream)
152   (if (empty-disjuncts? disjuncts)
153       the-empty-stream
154       (interleave-delayed
155        (qeval (first-disjunct disjuncts) frame-stream)
156        (delay (disjoin (rest-disjuncts disjuncts) frame-stream)))))
157 (define (negate operands frame-stream)
158   (stream-flatmap
159    (lambda (frame)
160      (if (stream-null? 
161 	  (qeval (negated-query operands)
162 		 (singleton-stream frame)))
163 	 (singleton-stream frame)
164 	 the-empty-stream))
165    frame-stream))
166 (define (lisp-value call frame-stream)
167   (stream-flatmap
168    (lambda (frame)
169      (if (execute
170 	  (instantiate
171 	      call
172 	      frame
173 	    (lambda (v f)
174 	      (error "Unknown pat var -- LISP-VALUE" v))))
175 	 (singleton-stream frame)
176 	 the-empty-stream))
177    frame-stream))
178 (define (execute exp)
179   (apply (eval (predicate exp) user-initial-environment)
180 	 (args exp)))
181 (define (always-true ignore frame-stream) frame-stream)
182 (put 'and 'qeval conjoin)
183 (put 'or 'qeval disjoin)
184 (put 'not 'qeval negate)
185 (put 'lisp-value 'qeval lisp-value)
186 (put 'always-true 'qeval always-true)
187 
188 (define (empty-conjuncts? exps) (null? exps))
189 (define (first-conjunct exps) (car exps))
190 (define (rest-conjuncts exps) (cdr exps))
191 (define (empty-disjuncts? exps) (null? exps))
192 (define (first-disjunct exps) (car exps))
193 (define (rest-disjuncts exps) (cdr exps))
194 (define (negated-query exps) (car exps))
195 (define (predicate exps) (car exps))
196 (define (args exps) (cdr exps))
197 
198 (define (interleave-delayed s1 delayed-s2)
199   (if (stream-null? s1)
200       (force delayed-s2)
201       (cons-stream
202        (stream-car s1)
203        (interleave-delayed
204 	(force delayed-s2)
205 	(delay (stream-cdr s1))))))
206 (define (stream-append-delayed s1 delayed-s2)
207   (if (stream-null? s1)
208       (force delayed-s2)
209       (cons-stream
210        (stream-car s1)
211        (stream-append-delayed
212 	(stream-cdr s1)
213 	delayed-s2))))
214 (define (stream-flatmap proc s)
215   (flatten-stream (stream-map proc s)))
216 (define (flatten-stream s)
217   (if (stream-null? s)
218       the-empty-stream
219       (interleave-delayed
220        (stream-car s)
221        (delay (flatten-stream (stream-cdr s))))))
222 
223 (define (simple-query query frame-stream)
224   (stream-flatmap
225    (lambda (frame)
226      (stream-append-delayed
227       (find-assertions query frame)
228       (delay (apply-rules query frame))))
229    frame-stream))
230 
231 (define (find-assertions pattern frame)
232   (stream-flatmap
233    (lambda (datum)
234      (check-an-assertion datum pattern frame))
235    (fetch-assertions pattern frame)))
236 (define (check-an-assertion dat pat frame)
237   (let ((match-result 
238 	 (pattern-match dat pat frame)))
239     (if (eq? match-result 'failed)
240 	the-empty-stream
241 	(singleton-stream match-result))))
242 (define (pattern-match pat dat frame)
243   (cond ((eq? frame 'failed) 'failed)
244 	((equal? pat dat) frame)
245 	((var? pat) (extend-if-consistent pat dat frame))
246 	((and (pair? pat) (pair? dat))
247 	 (pattern-match (cdr pat)
248 			(cdr dat)
249 			(pattern-match (car pat)
250 				       (car dat)
251 				       frame)))
252 	(else 'failed)))
253 
254 (define (extend-if-consistent var val frame)
255   (let ((binding (binding-in-frame var frame)))
256     (if binding
257 	(pattern-match (binding-value binding) val frame)
258 	(extend var val frame))))
259 (define (fetch-assertions pattern frame)
260   (if (use-index? pattern)
261       (get-indexed-assertions pattern)
262       (get-all-assertions)))
263 (define (get-all-assertions) THE-ASSERTIONS)
264 (define (get-indexed-assertions pattern)
265   (get-stream (index-key-of pattern) 'assertion-stream))
266 (define (use-index? pattern)
267   (constant-symbol? (car pattern)))
268 (define (fetch-rules pattern frame)
269   (if (use-index? pattern)
270       (get-indexed-rules pattern)
271       (get-all-rules)))
272 (define (get-all-rules) THE-RULES)
273 (define (get-indexed-rules pattern)
274   (stream-append 
275    (get-stream (index-key-of pattern) 'rule-stream)
276    (get-stream '? 'rule-stream)))
277 
278 (define (apply-rules pattern frame)
279   (stream-flatmap
280    (lambda (rule)
281      (apply-a-rule rule pattern frame))
282    (fetch-rules pattern frame)))
283 (define (apply-a-rule rule pattern frame)
284   (let* ((clean-rule (rename-variables-in rule))
285 	 (unify-result
286 	  (unify-match pattern
287 		       (conclusion clean-rule)
288 		       frame)))
289     (if (eq? unify-result 'failed)
290 	the-empty-stream
291 	(qeval (rule-body clean-rule)
292 	       (singleton-stream unify-result)))))
293     
294 ;; review code here
295 (define (unify-match p1 p2 frame)
296   (cond ((eq? frame 'failed) 'failed)
297 	((equal? p1 p2) frame)
298 	((var? p1) (extend-if-possible p1 p2 frame))
299 	((var? p2) (extend-if-possible p2 p1 frame))
300 	((and (pair? p1) (pair? p2))
301 	 (unify-match (cdr p1)
302 		      (cdr p2)
303 		      (unify-match (car p1)
304 				   (car p2)
305 				   frame)))
306 	(else 'failed)))
307 (define (extend-if-possible var val frame)
308   ...)
309 (define (depends-on? exp var frame)
310   ...)
311 (define (rename-variables-in rule)
312   ...)
313 
314 (? x) <-> (? 3 x)