2 665c255d 2023-08-04 jrmu ;; dispatch table
4 665c255d 2023-08-04 jrmu (define (make-table)
5 665c255d 2023-08-04 jrmu (define (assoc key records)
6 665c255d 2023-08-04 jrmu (cond ((null? records) false)
7 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
8 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
9 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
10 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
11 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
12 665c255d 2023-08-04 jrmu (if subtable
13 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
15 665c255d 2023-08-04 jrmu (cdr record)
18 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
19 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
20 665c255d 2023-08-04 jrmu (if subtable
21 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
23 665c255d 2023-08-04 jrmu (set-cdr! record value)
24 665c255d 2023-08-04 jrmu (set-cdr! subtable
25 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
26 665c255d 2023-08-04 jrmu (cdr subtable)))))
27 665c255d 2023-08-04 jrmu (set-cdr! local-table
28 665c255d 2023-08-04 jrmu (cons (list key-1
29 665c255d 2023-08-04 jrmu (cons key-2 value))
30 665c255d 2023-08-04 jrmu (cdr local-table)))))
32 665c255d 2023-08-04 jrmu (define (dispatch m)
33 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
34 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
35 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
37 665c255d 2023-08-04 jrmu (define operation-table (make-table))
38 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
39 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
41 665c255d 2023-08-04 jrmu ;; streams/delayed-evaluation
43 665c255d 2023-08-04 jrmu (define (memo-proc proc)
44 665c255d 2023-08-04 jrmu (let ((already-run? false) (result false))
46 665c255d 2023-08-04 jrmu (if already-run?
48 665c255d 2023-08-04 jrmu (begin (set! already-run? true)
49 665c255d 2023-08-04 jrmu (set! result (proc))
51 665c255d 2023-08-04 jrmu (define-syntax mydelay
52 665c255d 2023-08-04 jrmu (rsc-macro-transformer
54 665c255d 2023-08-04 jrmu (lambda (exp)
55 665c255d 2023-08-04 jrmu `(memo-proc (lambda () ,exp)))))
56 665c255d 2023-08-04 jrmu (lambda (e r)
57 665c255d 2023-08-04 jrmu (apply xfmr (cdr e))))))
58 665c255d 2023-08-04 jrmu (define (myforce delayed-object)
59 665c255d 2023-08-04 jrmu (delayed-object))
60 665c255d 2023-08-04 jrmu (define-syntax cons-stream
61 665c255d 2023-08-04 jrmu (rsc-macro-transformer
62 665c255d 2023-08-04 jrmu (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
63 665c255d 2023-08-04 jrmu (lambda (e r)
64 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))
87 665c255d 2023-08-04 jrmu (define (display-streams n . streams)
89 665c255d 2023-08-04 jrmu (begin (newline)
92 665c255d 2023-08-04 jrmu (display (stream-car s))
95 665c255d 2023-08-04 jrmu (apply display-streams
96 665c255d 2023-08-04 jrmu (cons (- n 1) (map stream-cdr streams))))))
97 665c255d 2023-08-04 jrmu (define (list->stream list)
98 665c255d 2023-08-04 jrmu (if (null? list)
99 665c255d 2023-08-04 jrmu the-empty-stream
100 665c255d 2023-08-04 jrmu (cons-stream (car list)
101 665c255d 2023-08-04 jrmu (list->stream (cdr list)))))
102 665c255d 2023-08-04 jrmu (define (stream-fold-left op initial sequence)
103 665c255d 2023-08-04 jrmu (define (iter result rest)
104 665c255d 2023-08-04 jrmu (if (null? rest)
106 665c255d 2023-08-04 jrmu (iter (op result (stream-car rest))
107 665c255d 2023-08-04 jrmu (stream-cdr rest))))
108 665c255d 2023-08-04 jrmu (iter initial sequence))
110 665c255d 2023-08-04 jrmu ;; query-driver-loop
112 665c255d 2023-08-04 jrmu (define input-prompt ";;; Query input:")
113 665c255d 2023-08-04 jrmu (define output-prompt ";;; Query results:")
114 665c255d 2023-08-04 jrmu (define (query-driver-loop)
115 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
116 665c255d 2023-08-04 jrmu (let ((q (query-syntax-process (read))))
117 665c255d 2023-08-04 jrmu (cond ((assertion-to-be-added? q)
118 665c255d 2023-08-04 jrmu (add-rule-or-assertion! (add-assertion-body q))
120 665c255d 2023-08-04 jrmu (display "Assertion added to data base.")
121 665c255d 2023-08-04 jrmu (query-driver-loop))
124 665c255d 2023-08-04 jrmu (display output-prompt)
125 665c255d 2023-08-04 jrmu (display-stream
126 665c255d 2023-08-04 jrmu (stream-map
127 665c255d 2023-08-04 jrmu (lambda (frame)
128 665c255d 2023-08-04 jrmu (instantiate q
130 665c255d 2023-08-04 jrmu (lambda (v f)
131 665c255d 2023-08-04 jrmu (contract-question-mark v))))
132 665c255d 2023-08-04 jrmu (qeval q (singleton-stream '()))))
133 665c255d 2023-08-04 jrmu (query-driver-loop)))))
134 665c255d 2023-08-04 jrmu (define (instantiate exp frame unbound-var-handler)
135 665c255d 2023-08-04 jrmu (define (copy exp)
136 665c255d 2023-08-04 jrmu (cond ((var? exp)
137 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame exp frame)))
138 665c255d 2023-08-04 jrmu (if binding
139 665c255d 2023-08-04 jrmu (copy (binding-value binding))
140 665c255d 2023-08-04 jrmu (unbound-var-handler exp frame))))
141 665c255d 2023-08-04 jrmu ((pair? exp)
142 665c255d 2023-08-04 jrmu (cons (copy (car exp)) (copy (cdr exp))))
143 665c255d 2023-08-04 jrmu (else exp)))
144 665c255d 2023-08-04 jrmu (copy exp))
145 665c255d 2023-08-04 jrmu (define (qeval query frame-stream)
146 665c255d 2023-08-04 jrmu (let ((qproc (get (type query) 'qeval)))
148 665c255d 2023-08-04 jrmu (qproc (contents query) frame-stream)
149 665c255d 2023-08-04 jrmu (simple-query query frame-stream))))
150 665c255d 2023-08-04 jrmu (define (simple-query query-pattern frame-stream)
151 665c255d 2023-08-04 jrmu (stream-flatmap
152 665c255d 2023-08-04 jrmu (lambda (frame)
153 665c255d 2023-08-04 jrmu (stream-append-delayed
154 665c255d 2023-08-04 jrmu (find-assertions query-pattern frame)
155 665c255d 2023-08-04 jrmu (delay (apply-rules query-pattern frame))))
156 665c255d 2023-08-04 jrmu frame-stream))
157 665c255d 2023-08-04 jrmu (define (conjoin conjuncts frame-stream)
158 665c255d 2023-08-04 jrmu (if (empty-conjunction? conjuncts)
159 665c255d 2023-08-04 jrmu frame-stream
160 665c255d 2023-08-04 jrmu (conjoin (rest-conjuncts conjuncts)
161 665c255d 2023-08-04 jrmu (qeval (first-conjunct conjuncts)
162 665c255d 2023-08-04 jrmu frame-stream))))
163 665c255d 2023-08-04 jrmu (put 'and 'qeval conjoin)
164 665c255d 2023-08-04 jrmu (define (disjoin disjuncts frame-stream)
165 665c255d 2023-08-04 jrmu (if (empty-disjunction? disjuncts)
166 665c255d 2023-08-04 jrmu the-empty-stream
167 665c255d 2023-08-04 jrmu (interleave-delayed
168 665c255d 2023-08-04 jrmu (qeval (first-disjunct disjuncts) frame-stream)
169 665c255d 2023-08-04 jrmu (delay (disjoin (rest-disjuncts disjuncts)
170 665c255d 2023-08-04 jrmu frame-stream)))))
171 665c255d 2023-08-04 jrmu (put 'or 'qeval disjoin)
172 665c255d 2023-08-04 jrmu (define (negate operands frame-stream)
173 665c255d 2023-08-04 jrmu (stream-flatmap
174 665c255d 2023-08-04 jrmu (lambda (frame)
175 665c255d 2023-08-04 jrmu (if (stream-null? (qeval (negated-query operands)
176 665c255d 2023-08-04 jrmu (singleton-stream frame)))
177 665c255d 2023-08-04 jrmu (singleton-stream frame)
178 665c255d 2023-08-04 jrmu the-empty-stream))
179 665c255d 2023-08-04 jrmu frame-stream))
180 665c255d 2023-08-04 jrmu (put 'not 'qeval negate)
181 665c255d 2023-08-04 jrmu (define (lisp-value call frame-stream)
182 665c255d 2023-08-04 jrmu (stream-flatmap
183 665c255d 2023-08-04 jrmu (lambda (frame)
184 665c255d 2023-08-04 jrmu (if (execute
185 665c255d 2023-08-04 jrmu (instantiate
188 665c255d 2023-08-04 jrmu (lambda (v f)
189 665c255d 2023-08-04 jrmu (error "Unknown pat var -- LISP-VALUE" v))))
190 665c255d 2023-08-04 jrmu (singleton-stream frame)
191 665c255d 2023-08-04 jrmu the-empty-stream))
192 665c255d 2023-08-04 jrmu frame-stream))
193 665c255d 2023-08-04 jrmu (put 'lisp-value 'qeval lisp-value)
194 665c255d 2023-08-04 jrmu (define (execute exp)
195 665c255d 2023-08-04 jrmu (apply (eval (predicate exp) user-initial-environment)
196 665c255d 2023-08-04 jrmu (args exp)))
197 665c255d 2023-08-04 jrmu (define (always-true ignore frame-stream) frame-stream)
198 665c255d 2023-08-04 jrmu (put 'always-true 'qeval always-true)
199 665c255d 2023-08-04 jrmu (define (find-assertions pattern frame)
200 665c255d 2023-08-04 jrmu (stream-flatmap (lambda (datum)
201 665c255d 2023-08-04 jrmu (check-an-assertion datum pattern frame))
202 665c255d 2023-08-04 jrmu (fetch-assertions pattern frame)))
203 665c255d 2023-08-04 jrmu (define (check-an-assertion assertion query-pat query-frame)
204 665c255d 2023-08-04 jrmu (let ((match-result
205 665c255d 2023-08-04 jrmu (pattern-match query-pat assertion query-frame)))
206 665c255d 2023-08-04 jrmu (if (eq? match-result 'failed)
207 665c255d 2023-08-04 jrmu the-empty-stream
208 665c255d 2023-08-04 jrmu (singleton-stream match-result))))
209 665c255d 2023-08-04 jrmu (define (pattern-match pat dat frame)
210 665c255d 2023-08-04 jrmu (cond ((eq? frame 'failed) 'failed)
211 665c255d 2023-08-04 jrmu ((equal? pat dat) frame)
212 665c255d 2023-08-04 jrmu ((var? pat) (extend-if-consistent pat dat frame))
213 665c255d 2023-08-04 jrmu ((and (pair? pat) (pair? dat))
214 665c255d 2023-08-04 jrmu (pattern-match (cdr pat)
216 665c255d 2023-08-04 jrmu (pattern-match (car pat)
219 665c255d 2023-08-04 jrmu (else 'failed)))
220 665c255d 2023-08-04 jrmu (define (extend-if-consistent var dat frame)
221 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame var frame)))
222 665c255d 2023-08-04 jrmu (if binding
223 665c255d 2023-08-04 jrmu (pattern-match (binding-value binding) dat frame)
224 665c255d 2023-08-04 jrmu (extend var dat frame))))
225 665c255d 2023-08-04 jrmu (define (apply-rules pattern frame)
226 665c255d 2023-08-04 jrmu (stream-flatmap (lambda (rule)
227 665c255d 2023-08-04 jrmu (apply-a-rule rule pattern frame))
228 665c255d 2023-08-04 jrmu (fetch-rules pattern frame)))
229 665c255d 2023-08-04 jrmu (define (apply-a-rule rule query-pattern query-frame)
230 665c255d 2023-08-04 jrmu (let ((clean-rule (rename-variables-in rule)))
231 665c255d 2023-08-04 jrmu (let ((unify-result
232 665c255d 2023-08-04 jrmu (unify-match query-pattern
233 665c255d 2023-08-04 jrmu (conclusion clean-rule)
234 665c255d 2023-08-04 jrmu query-frame)))
235 665c255d 2023-08-04 jrmu (if (eq? unify-result 'failed)
236 665c255d 2023-08-04 jrmu the-empty-stream
237 665c255d 2023-08-04 jrmu (qeval (rule-body clean-rule)
238 665c255d 2023-08-04 jrmu (singleton-stream unify-result))))))
239 665c255d 2023-08-04 jrmu (define (rename-variables-in rule)
240 665c255d 2023-08-04 jrmu (let ((rule-application-id (new-rule-application-id)))
241 665c255d 2023-08-04 jrmu (define (tree-walk exp)
242 665c255d 2023-08-04 jrmu (cond ((var? exp)
243 665c255d 2023-08-04 jrmu (make-new-variable exp rule-application-id))
244 665c255d 2023-08-04 jrmu ((pair? exp)
245 665c255d 2023-08-04 jrmu (cons (tree-walk (car exp))
246 665c255d 2023-08-04 jrmu (tree-walk (cdr exp))))
247 665c255d 2023-08-04 jrmu (else exp)))
248 665c255d 2023-08-04 jrmu (tree-walk rule)))
249 665c255d 2023-08-04 jrmu (define (unify-match p1 p2 frame)
250 665c255d 2023-08-04 jrmu (cond ((eq? frame 'failed) 'failed)
251 665c255d 2023-08-04 jrmu ((equal? p1 p2) frame)
252 665c255d 2023-08-04 jrmu ((var? p1) (extend-if-possible p1 p2 frame))
253 665c255d 2023-08-04 jrmu ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
254 665c255d 2023-08-04 jrmu ((and (pair? p1) (pair? p2))
255 665c255d 2023-08-04 jrmu (unify-match (cdr p1)
257 665c255d 2023-08-04 jrmu (unify-match (car p1)
260 665c255d 2023-08-04 jrmu (else 'failed)))
261 665c255d 2023-08-04 jrmu (define (extend-if-possible var val frame)
262 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame var frame)))
263 665c255d 2023-08-04 jrmu (cond (binding
264 665c255d 2023-08-04 jrmu (unify-match
265 665c255d 2023-08-04 jrmu (binding-value binding) val frame))
266 665c255d 2023-08-04 jrmu ((var? val) ; ***
267 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame val frame)))
268 665c255d 2023-08-04 jrmu (if binding
269 665c255d 2023-08-04 jrmu (unify-match
270 665c255d 2023-08-04 jrmu var (binding-value binding) frame)
271 665c255d 2023-08-04 jrmu (extend var val frame))))
272 665c255d 2023-08-04 jrmu ((depends-on? val var frame) ; ***
274 665c255d 2023-08-04 jrmu (else (extend var val frame)))))
275 665c255d 2023-08-04 jrmu (define (depends-on? exp var frame)
276 665c255d 2023-08-04 jrmu (define (tree-walk e)
277 665c255d 2023-08-04 jrmu (cond ((var? e)
278 665c255d 2023-08-04 jrmu (if (equal? var e)
280 665c255d 2023-08-04 jrmu (let ((b (binding-in-frame e frame)))
282 665c255d 2023-08-04 jrmu (tree-walk (binding-value b))
285 665c255d 2023-08-04 jrmu (or (tree-walk (car e))
286 665c255d 2023-08-04 jrmu (tree-walk (cdr e))))
287 665c255d 2023-08-04 jrmu (else false)))
288 665c255d 2023-08-04 jrmu (tree-walk exp))
289 665c255d 2023-08-04 jrmu (define THE-ASSERTIONS the-empty-stream)
290 665c255d 2023-08-04 jrmu (define (fetch-assertions pattern frame)
291 665c255d 2023-08-04 jrmu (if (use-index? pattern)
292 665c255d 2023-08-04 jrmu (get-indexed-assertions pattern)
293 665c255d 2023-08-04 jrmu (get-all-assertions)))
294 665c255d 2023-08-04 jrmu (define (get-all-assertions) THE-ASSERTIONS)
295 665c255d 2023-08-04 jrmu (define (get-indexed-assertions pattern)
296 665c255d 2023-08-04 jrmu (get-stream (index-key-of pattern) 'assertion-stream))
297 665c255d 2023-08-04 jrmu (define (get-stream key1 key2)
298 665c255d 2023-08-04 jrmu (let ((s (get key1 key2)))
299 665c255d 2023-08-04 jrmu (if s s the-empty-stream)))
300 665c255d 2023-08-04 jrmu (define THE-RULES the-empty-stream)
301 665c255d 2023-08-04 jrmu (define (fetch-rules pattern frame)
302 665c255d 2023-08-04 jrmu (if (use-index? pattern)
303 665c255d 2023-08-04 jrmu (get-indexed-rules pattern)
304 665c255d 2023-08-04 jrmu (get-all-rules)))
305 665c255d 2023-08-04 jrmu (define (get-all-rules) THE-RULES)
306 665c255d 2023-08-04 jrmu (define (get-indexed-rules pattern)
307 665c255d 2023-08-04 jrmu (stream-append
308 665c255d 2023-08-04 jrmu (get-stream (index-key-of pattern) 'rule-stream)
309 665c255d 2023-08-04 jrmu (get-stream '? 'rule-stream)))
310 665c255d 2023-08-04 jrmu (define (add-rule-or-assertion! assertion)
311 665c255d 2023-08-04 jrmu (if (rule? assertion)
312 665c255d 2023-08-04 jrmu (add-rule! assertion)
313 665c255d 2023-08-04 jrmu (add-assertion! assertion)))
314 665c255d 2023-08-04 jrmu (define (add-assertion! assertion)
315 665c255d 2023-08-04 jrmu (store-assertion-in-index assertion)
316 665c255d 2023-08-04 jrmu (let ((old-assertions THE-ASSERTIONS))
317 665c255d 2023-08-04 jrmu (set! THE-ASSERTIONS
318 665c255d 2023-08-04 jrmu (cons-stream assertion old-assertions))
320 665c255d 2023-08-04 jrmu (define (add-rule! rule)
321 665c255d 2023-08-04 jrmu (store-rule-in-index rule)
322 665c255d 2023-08-04 jrmu (let ((old-rules THE-RULES))
323 665c255d 2023-08-04 jrmu (set! THE-RULES (cons-stream rule old-rules))
325 665c255d 2023-08-04 jrmu (define (store-assertion-in-index assertion)
326 665c255d 2023-08-04 jrmu (if (indexable? assertion)
327 665c255d 2023-08-04 jrmu (let ((key (index-key-of assertion)))
328 665c255d 2023-08-04 jrmu (let ((current-assertion-stream
329 665c255d 2023-08-04 jrmu (get-stream key 'assertion-stream)))
331 665c255d 2023-08-04 jrmu 'assertion-stream
332 665c255d 2023-08-04 jrmu (cons-stream assertion
333 665c255d 2023-08-04 jrmu current-assertion-stream))))))
334 665c255d 2023-08-04 jrmu (define (store-rule-in-index rule)
335 665c255d 2023-08-04 jrmu (let ((pattern (conclusion rule)))
336 665c255d 2023-08-04 jrmu (if (indexable? pattern)
337 665c255d 2023-08-04 jrmu (let ((key (index-key-of pattern)))
338 665c255d 2023-08-04 jrmu (let ((current-rule-stream
339 665c255d 2023-08-04 jrmu (get-stream key 'rule-stream)))
341 665c255d 2023-08-04 jrmu 'rule-stream
342 665c255d 2023-08-04 jrmu (cons-stream rule
343 665c255d 2023-08-04 jrmu current-rule-stream)))))))
344 665c255d 2023-08-04 jrmu (define (indexable? pat)
345 665c255d 2023-08-04 jrmu (or (constant-symbol? (car pat))
346 665c255d 2023-08-04 jrmu (var? (car pat))))
347 665c255d 2023-08-04 jrmu (define (index-key-of pat)
348 665c255d 2023-08-04 jrmu (let ((key (car pat)))
349 665c255d 2023-08-04 jrmu (if (var? key) '? key)))
350 665c255d 2023-08-04 jrmu (define (use-index? pat)
351 665c255d 2023-08-04 jrmu (constant-symbol? (car pat)))
352 665c255d 2023-08-04 jrmu (define (stream-append s1 s2)
353 665c255d 2023-08-04 jrmu (if (stream-null? s1)
355 665c255d 2023-08-04 jrmu (cons-stream (stream-car s1)
356 665c255d 2023-08-04 jrmu (stream-append (stream-cdr s1) s2))))
357 665c255d 2023-08-04 jrmu (define (stream-append-delayed s1 delayed-s2)
358 665c255d 2023-08-04 jrmu (if (stream-null? s1)
359 665c255d 2023-08-04 jrmu (force delayed-s2)
360 665c255d 2023-08-04 jrmu (cons-stream
361 665c255d 2023-08-04 jrmu (stream-car s1)
362 665c255d 2023-08-04 jrmu (stream-append-delayed (stream-cdr s1) delayed-s2))))
363 665c255d 2023-08-04 jrmu (define (interleave-delayed s1 delayed-s2)
364 665c255d 2023-08-04 jrmu (if (stream-null? s1)
365 665c255d 2023-08-04 jrmu (force delayed-s2)
366 665c255d 2023-08-04 jrmu (cons-stream
367 665c255d 2023-08-04 jrmu (stream-car s1)
368 665c255d 2023-08-04 jrmu (interleave-delayed (force delayed-s2)
369 665c255d 2023-08-04 jrmu (delay (stream-cdr s1))))))
370 665c255d 2023-08-04 jrmu (define (stream-flatmap proc s)
371 665c255d 2023-08-04 jrmu (flatten-stream (stream-map proc s)))
372 665c255d 2023-08-04 jrmu (define (flatten-stream stream)
373 665c255d 2023-08-04 jrmu (if (stream-null? stream)
374 665c255d 2023-08-04 jrmu the-empty-stream
375 665c255d 2023-08-04 jrmu (interleave-delayed
376 665c255d 2023-08-04 jrmu (stream-car stream)
377 665c255d 2023-08-04 jrmu (delay (flatten-stream (stream-cdr stream))))))
378 665c255d 2023-08-04 jrmu (define (singleton-stream x)
379 665c255d 2023-08-04 jrmu (cons-stream x the-empty-stream))
380 665c255d 2023-08-04 jrmu (define (type exp)
381 665c255d 2023-08-04 jrmu (if (pair? exp)
383 665c255d 2023-08-04 jrmu (error "Unknown expression TYPE" exp)))
384 665c255d 2023-08-04 jrmu (define (contents exp)
385 665c255d 2023-08-04 jrmu (if (pair? exp)
387 665c255d 2023-08-04 jrmu (error "Unknown expression CONTENTS" exp)))
388 665c255d 2023-08-04 jrmu (define (assertion-to-be-added? exp)
389 665c255d 2023-08-04 jrmu (eq? (type exp) 'assert!))
390 665c255d 2023-08-04 jrmu (define (add-assertion-body exp)
391 665c255d 2023-08-04 jrmu (car (contents exp)))
392 665c255d 2023-08-04 jrmu (define (empty-conjunction? exps) (null? exps))
393 665c255d 2023-08-04 jrmu (define (first-conjunct exps) (car exps))
394 665c255d 2023-08-04 jrmu (define (rest-conjuncts exps) (cdr exps))
395 665c255d 2023-08-04 jrmu (define (empty-disjunction? exps) (null? exps))
396 665c255d 2023-08-04 jrmu (define (first-disjunct exps) (car exps))
397 665c255d 2023-08-04 jrmu (define (rest-disjuncts exps) (cdr exps))
398 665c255d 2023-08-04 jrmu (define (negated-query exps) (car exps))
399 665c255d 2023-08-04 jrmu (define (predicate exps) (car exps))
400 665c255d 2023-08-04 jrmu (define (args exps) (cdr exps))
401 665c255d 2023-08-04 jrmu (define (rule? statement)
402 665c255d 2023-08-04 jrmu (tagged-list? statement 'rule))
403 665c255d 2023-08-04 jrmu (define (conclusion rule) (cadr rule))
404 665c255d 2023-08-04 jrmu (define (rule-body rule)
405 665c255d 2023-08-04 jrmu (if (null? (cddr rule))
406 665c255d 2023-08-04 jrmu '(always-true)
407 665c255d 2023-08-04 jrmu (caddr rule)))
408 665c255d 2023-08-04 jrmu (define (query-syntax-process exp)
409 665c255d 2023-08-04 jrmu (map-over-symbols expand-question-mark exp))
410 665c255d 2023-08-04 jrmu (define (map-over-symbols proc exp)
411 665c255d 2023-08-04 jrmu (cond ((pair? exp)
412 665c255d 2023-08-04 jrmu (cons (map-over-symbols proc (car exp))
413 665c255d 2023-08-04 jrmu (map-over-symbols proc (cdr exp))))
414 665c255d 2023-08-04 jrmu ((symbol? exp) (proc exp))
415 665c255d 2023-08-04 jrmu (else exp)))
416 665c255d 2023-08-04 jrmu (define (expand-question-mark symbol)
417 665c255d 2023-08-04 jrmu (let ((chars (symbol->string symbol)))
418 665c255d 2023-08-04 jrmu (if (string=? (substring chars 0 1) "?")
420 665c255d 2023-08-04 jrmu (string->symbol
421 665c255d 2023-08-04 jrmu (substring chars 1 (string-length chars))))
423 665c255d 2023-08-04 jrmu (define (var? exp)
424 665c255d 2023-08-04 jrmu (tagged-list? exp '?))
425 665c255d 2023-08-04 jrmu (define (constant-symbol? exp) (symbol? exp))
426 665c255d 2023-08-04 jrmu (define rule-counter 0)
427 665c255d 2023-08-04 jrmu (define (new-rule-application-id)
428 665c255d 2023-08-04 jrmu (set! rule-counter (+ 1 rule-counter))
429 665c255d 2023-08-04 jrmu rule-counter)
430 665c255d 2023-08-04 jrmu (define (make-new-variable var rule-application-id)
431 665c255d 2023-08-04 jrmu (cons '? (cons rule-application-id (cdr var))))
432 665c255d 2023-08-04 jrmu (define (contract-question-mark variable)
433 665c255d 2023-08-04 jrmu (string->symbol
434 665c255d 2023-08-04 jrmu (string-append "?"
435 665c255d 2023-08-04 jrmu (if (number? (cadr variable))
436 665c255d 2023-08-04 jrmu (string-append (symbol->string (caddr variable))
438 665c255d 2023-08-04 jrmu (number->string (cadr variable)))
439 665c255d 2023-08-04 jrmu (symbol->string (cadr variable))))))
440 665c255d 2023-08-04 jrmu (define (make-binding variable value)
441 665c255d 2023-08-04 jrmu (cons variable value))
442 665c255d 2023-08-04 jrmu (define (binding-variable binding)
443 665c255d 2023-08-04 jrmu (car binding))
444 665c255d 2023-08-04 jrmu (define (binding-value binding)
445 665c255d 2023-08-04 jrmu (cdr binding))
446 665c255d 2023-08-04 jrmu (define (binding-in-frame variable frame)
447 665c255d 2023-08-04 jrmu (assoc variable frame))
448 665c255d 2023-08-04 jrmu (define (extend variable value frame)
449 665c255d 2023-08-04 jrmu (cons (make-binding variable value) frame))
450 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
451 665c255d 2023-08-04 jrmu (and (pair? exp) (eq? (car exp) tag)))
453 665c255d 2023-08-04 jrmu ;; test procedures
455 665c255d 2023-08-04 jrmu (define (eval-queries queries)
456 665c255d 2023-08-04 jrmu (if (null? queries)
458 665c255d 2023-08-04 jrmu (begin (eval-query (car queries))
459 665c255d 2023-08-04 jrmu (eval-queries (cdr queries)))))
460 665c255d 2023-08-04 jrmu (define (eval-query query)
461 665c255d 2023-08-04 jrmu (let ((q (query-syntax-process query)))
462 665c255d 2023-08-04 jrmu (if (assertion-to-be-added? q)
463 665c255d 2023-08-04 jrmu (add-rule-or-assertion! (add-assertion-body q))
464 665c255d 2023-08-04 jrmu (stream-map
465 665c255d 2023-08-04 jrmu (lambda (frame)
466 665c255d 2023-08-04 jrmu (instantiate q
468 665c255d 2023-08-04 jrmu (lambda (v f)
469 665c255d 2023-08-04 jrmu (contract-question-mark v))))
470 665c255d 2023-08-04 jrmu (qeval q (singleton-stream '()))))))
471 665c255d 2023-08-04 jrmu (define (eval-display-query q)
472 665c255d 2023-08-04 jrmu (display-stream (eval-query q)))
473 665c255d 2023-08-04 jrmu (define (test-case actual expected)
475 665c255d 2023-08-04 jrmu (display "Actual: ")
476 665c255d 2023-08-04 jrmu (display actual)
478 665c255d 2023-08-04 jrmu (display "Expected: ")
479 665c255d 2023-08-04 jrmu (display expected)
481 665c255d 2023-08-04 jrmu (define (test-query query . expected)
482 665c255d 2023-08-04 jrmu (if (null? expected)
483 665c255d 2023-08-04 jrmu (let ((result (eval-query query)))
484 665c255d 2023-08-04 jrmu (if (symbol? result)
485 665c255d 2023-08-04 jrmu (begin (display "Assertion added") (newline))
486 665c255d 2023-08-04 jrmu (display-stream (eval-query query))))
487 665c255d 2023-08-04 jrmu (let ((list (car expected)))
488 665c255d 2023-08-04 jrmu (let ((result
489 665c255d 2023-08-04 jrmu (stream-fold-left
490 665c255d 2023-08-04 jrmu (lambda (x y)
493 665c255d 2023-08-04 jrmu (stream-map
494 665c255d 2023-08-04 jrmu (lambda (e1 e2)
495 665c255d 2023-08-04 jrmu (equal? e1 e2))
496 665c255d 2023-08-04 jrmu (eval-query query)
497 665c255d 2023-08-04 jrmu (list->stream list)))))
499 665c255d 2023-08-04 jrmu (display "Passed -- ")
500 665c255d 2023-08-04 jrmu (display "Failed! -- "))
501 665c255d 2023-08-04 jrmu (display query)
502 665c255d 2023-08-04 jrmu (newline)))))
504 665c255d 2023-08-04 jrmu ;; (let ((result (eval-query query)))
505 665c255d 2023-08-04 jrmu ;; (if (pair? result)
506 665c255d 2023-08-04 jrmu ;; (display-stream (eval-query query))
507 665c255d 2023-08-04 jrmu ;; result))
509 665c255d 2023-08-04 jrmu ;;I suspect that (eval-query query) is 'ok and that we are trying to print it as a steam
511 665c255d 2023-08-04 jrmu ;; (display-streams
512 665c255d 2023-08-04 jrmu ;; (length list)
513 665c255d 2023-08-04 jrmu ;; (eval-query query)
514 665c255d 2023-08-04 jrmu ;; (list->stream list)))))
516 665c255d 2023-08-04 jrmu ;; (display-stream
517 665c255d 2023-08-04 jrmu ;; (stream-map
518 665c255d 2023-08-04 jrmu ;; (lambda (e1 e2)
519 665c255d 2023-08-04 jrmu ;; (equal? e1 e2))
520 665c255d 2023-08-04 jrmu ;; (eval-query query)
521 665c255d 2023-08-04 jrmu ;; (list->stream list))))))
522 665c255d 2023-08-04 jrmu ;; test-suite
525 665c255d 2023-08-04 jrmu (eval-queries
526 665c255d 2023-08-04 jrmu '((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
527 665c255d 2023-08-04 jrmu (assert! (job (Bitdiddle Ben) (computer wizard)))
528 665c255d 2023-08-04 jrmu (assert! (salary (Bitdiddle Ben) 60000))
529 665c255d 2023-08-04 jrmu (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
530 665c255d 2023-08-04 jrmu (assert! (job (Hacker Alyssa P) (computer programmer)))
531 665c255d 2023-08-04 jrmu (assert! (salary (Hacker Alyssa P) 40000))
532 665c255d 2023-08-04 jrmu (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
533 665c255d 2023-08-04 jrmu (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
534 665c255d 2023-08-04 jrmu (assert! (job (Fect Cy D) (computer programmer)))
535 665c255d 2023-08-04 jrmu (assert! (salary (Fect Cy D) 35000))
536 665c255d 2023-08-04 jrmu (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
537 665c255d 2023-08-04 jrmu (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
538 665c255d 2023-08-04 jrmu (assert! (job (Tweakit Lem E) (computer technician)))
539 665c255d 2023-08-04 jrmu (assert! (salary (Tweakit Lem E) 25000))
540 665c255d 2023-08-04 jrmu (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
541 665c255d 2023-08-04 jrmu (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
542 665c255d 2023-08-04 jrmu (assert! (job (Reasoner Louis) (computer programmer trainee)))
543 665c255d 2023-08-04 jrmu (assert! (salary (Reasoner Louis) 30000))
544 665c255d 2023-08-04 jrmu (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
545 665c255d 2023-08-04 jrmu (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
546 665c255d 2023-08-04 jrmu (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
547 665c255d 2023-08-04 jrmu (assert! (job (Warbucks Oliver) (administration big wheel)))
548 665c255d 2023-08-04 jrmu (assert! (salary (Warbucks Oliver) 150000))
549 665c255d 2023-08-04 jrmu (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
550 665c255d 2023-08-04 jrmu (assert! (job (Scrooge Eben) (accounting chief accountant)))
551 665c255d 2023-08-04 jrmu (assert! (salary (Scrooge Eben) 75000))
552 665c255d 2023-08-04 jrmu (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
553 665c255d 2023-08-04 jrmu (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
554 665c255d 2023-08-04 jrmu (assert! (job (Cratchet Robert) (accounting scrivener)))
555 665c255d 2023-08-04 jrmu (assert! (salary (Cratchet Robert) 18000))
556 665c255d 2023-08-04 jrmu (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
557 665c255d 2023-08-04 jrmu (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
558 665c255d 2023-08-04 jrmu (assert! (job (Aull DeWitt) (administration secretary)))
559 665c255d 2023-08-04 jrmu (assert! (salary (Aull DeWitt) 25000))
560 665c255d 2023-08-04 jrmu (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
561 665c255d 2023-08-04 jrmu (assert! (can-do-job (computer wizard) (computer programmer)))
562 665c255d 2023-08-04 jrmu (assert! (can-do-job (computer wizard) (computer technician)))
563 665c255d 2023-08-04 jrmu (assert! (can-do-job (computer programmer)
564 665c255d 2023-08-04 jrmu (computer programmer trainee)))
565 665c255d 2023-08-04 jrmu (assert! (can-do-job (administration secretary)
566 665c255d 2023-08-04 jrmu (administration big wheel)))))
568 665c255d 2023-08-04 jrmu (eval-query
569 665c255d 2023-08-04 jrmu '(assert! (rule (same ?x ?x))))
572 665c255d 2023-08-04 jrmu (test-query
573 665c255d 2023-08-04 jrmu '(supervisor ?employee (Bitdiddle Ben))
574 665c255d 2023-08-04 jrmu '((supervisor (tweakit lem e) (bitdiddle ben))
575 665c255d 2023-08-04 jrmu (supervisor (fect cy d) (bitdiddle ben))
576 665c255d 2023-08-04 jrmu (supervisor (hacker alyssa p) (bitdiddle ben))))
577 665c255d 2023-08-04 jrmu (test-query
578 665c255d 2023-08-04 jrmu '(job ?x (accounting . ?title))
579 665c255d 2023-08-04 jrmu '((job (cratchet robert) (accounting scrivener))
580 665c255d 2023-08-04 jrmu (job (scrooge eben) (accounting chief accountant))))
581 665c255d 2023-08-04 jrmu (test-query
582 665c255d 2023-08-04 jrmu '(address ?person (Slumerville . ?rest))
583 665c255d 2023-08-04 jrmu '((address (aull dewitt) (slumerville (onion square) 5))
584 665c255d 2023-08-04 jrmu (address (reasoner louis) (slumerville (pine tree road) 80))
585 665c255d 2023-08-04 jrmu (address (bitdiddle ben) (slumerville (ridge road) 10))))
586 665c255d 2023-08-04 jrmu (test-query
587 665c255d 2023-08-04 jrmu '(and (supervisor ?x (Bitdiddle Ben))
588 665c255d 2023-08-04 jrmu (address ?x ?address))
589 665c255d 2023-08-04 jrmu '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
590 665c255d 2023-08-04 jrmu (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
591 665c255d 2023-08-04 jrmu (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
592 665c255d 2023-08-04 jrmu (test-query
593 665c255d 2023-08-04 jrmu '(and (salary (Bitdiddle Ben) ?ben-salary)
594 665c255d 2023-08-04 jrmu (salary ?x ?x-salary)
595 665c255d 2023-08-04 jrmu (lisp-value < ?x-salary ?ben-salary))
596 665c255d 2023-08-04 jrmu '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
597 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
598 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
599 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
600 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
601 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
602 665c255d 2023-08-04 jrmu (test-query
603 665c255d 2023-08-04 jrmu '(and (supervisor ?employee ?supervisor)
604 665c255d 2023-08-04 jrmu (job ?supervisor ?job)
605 665c255d 2023-08-04 jrmu (not (job ?supervisor (computer . ?title))))
606 665c255d 2023-08-04 jrmu '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
607 665c255d 2023-08-04 jrmu (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
608 665c255d 2023-08-04 jrmu (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
609 665c255d 2023-08-04 jrmu (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
611 665c255d 2023-08-04 jrmu (eval-query
612 665c255d 2023-08-04 jrmu '(assert! (rule (can-replace? ?p1 ?p2)
613 665c255d 2023-08-04 jrmu (and (or (and (job ?p1 ?job)
614 665c255d 2023-08-04 jrmu (job ?p2 ?job))
615 665c255d 2023-08-04 jrmu (and (job ?p1 ?j1)
616 665c255d 2023-08-04 jrmu (job ?p2 ?j2)
617 665c255d 2023-08-04 jrmu (can-do-job ?j1 ?j2)))
618 665c255d 2023-08-04 jrmu (not (same ?p1 ?p2))))))
619 665c255d 2023-08-04 jrmu (test-query
620 665c255d 2023-08-04 jrmu '(can-replace? ?x (Fect Cy D))
621 665c255d 2023-08-04 jrmu '((can-replace? (bitdiddle ben) (fect cy d))
622 665c255d 2023-08-04 jrmu (can-replace? (hacker alyssa p) (fect cy d))))
623 665c255d 2023-08-04 jrmu (test-query
624 665c255d 2023-08-04 jrmu '(and (salary ?low ?low-salary)
625 665c255d 2023-08-04 jrmu (salary ?high ?high-salary)
626 665c255d 2023-08-04 jrmu (can-replace? ?low ?high)
627 665c255d 2023-08-04 jrmu (lisp-value < ?low-salary ?high-salary))
628 665c255d 2023-08-04 jrmu '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
629 665c255d 2023-08-04 jrmu (and (salary (fect cy d) 35000) (salary (hacker alyssa p) 40000) (can-replace? (fect cy d) (hacker alyssa p)) (lisp-value < 35000 40000))))
630 665c255d 2023-08-04 jrmu (eval-query
631 665c255d 2023-08-04 jrmu '(assert! (rule (big-shot ?bigshot)
632 665c255d 2023-08-04 jrmu (and (job ?bigshot (?dept . ?job-title))
633 665c255d 2023-08-04 jrmu (or (not (supervisor ?bigshot ?boss))
634 665c255d 2023-08-04 jrmu (and (supervisor ?bigshot ?boss)
635 665c255d 2023-08-04 jrmu (not (job ?boss (?dept . ?boss-title)))))))))
636 665c255d 2023-08-04 jrmu (test-query
637 665c255d 2023-08-04 jrmu '(big-shot ?x)
638 665c255d 2023-08-04 jrmu '((big-shot (warbucks oliver))
639 665c255d 2023-08-04 jrmu (big-shot (scrooge eben))
640 665c255d 2023-08-04 jrmu (big-shot (bitdiddle ben))))
642 665c255d 2023-08-04 jrmu ;; Exercise 4.59. Ben Bitdiddle has missed one meeting too many. Fearing that his habit of forgetting meetings could cost him his job, Ben decides to do something about it. He adds all the weekly meetings of the firm to the Microshaft data base by asserting the following:
644 665c255d 2023-08-04 jrmu (eval-queries
645 665c255d 2023-08-04 jrmu '((assert! (meeting accounting (Monday 9am)))
646 665c255d 2023-08-04 jrmu (assert! (meeting administration (Monday 10am)))
647 665c255d 2023-08-04 jrmu (assert! (meeting computer (Wednesday 3pm)))
648 665c255d 2023-08-04 jrmu (assert! (meeting administration (Friday 1pm)))
649 665c255d 2023-08-04 jrmu (assert! (meeting whole-company (Wednesday 4pm)))))
651 665c255d 2023-08-04 jrmu ;; Each of the above assertions is for a meeting of an entire division. Ben also adds an entry for the company-wide meeting that spans all the divisions. All of the company's employees attend this meeting.
653 665c255d 2023-08-04 jrmu ;; a. On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use?
655 665c255d 2023-08-04 jrmu (test-query '(meeting ?div (Friday ?time))
656 665c255d 2023-08-04 jrmu '((meeting administration (friday 1pm))))
658 665c255d 2023-08-04 jrmu ;; b. Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all whole-company meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule.
660 665c255d 2023-08-04 jrmu (eval-query
661 665c255d 2023-08-04 jrmu '(assert! (rule (meeting-time ?person ?day-and-time)
662 665c255d 2023-08-04 jrmu (or (and (job ?person (?dept . ?title))
663 665c255d 2023-08-04 jrmu (meeting ?dept ?day-and-time))
664 665c255d 2023-08-04 jrmu (meeting whole-company ?day-and-time)))))
666 665c255d 2023-08-04 jrmu ;; c. Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out?
668 665c255d 2023-08-04 jrmu (test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
669 665c255d 2023-08-04 jrmu '((meeting-time (hacker alyssa p) (wednesday 3pm))
670 665c255d 2023-08-04 jrmu (meeting-time (hacker alyssa p) (wednesday 4pm))))
