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