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)
166 665c255d 2023-08-04 jrmu ;; Exercise 4.76. Our implementation of and as a series combination of queries (figure 4.5) is elegant, but it is inefficient because in processing the second query of the and we must scan the data base for each frame produced by the first query. If the data base has N elements, and a typical query produces a number of output frames proportional to N (say N/k), then scanning the data base for each frame produced by the first query will require N2/k calls to the pattern matcher. Another approach would be to process the two clauses of the and separately, then look for all pairs of output frames that are compatible. If each query produces N/k output frames, then this means that we must perform N2/k2 compatibility checks -- a factor of k fewer than the number of matches required in our current method.
168 665c255d 2023-08-04 jrmu ;; Devise an implementation of and that uses this strategy. You must implement a procedure that takes two frames as inputs, checks whether the bindings in the frames are compatible, and, if so, produces a frame that merges the two sets of bindings. This operation is similar to unification.
170 665c255d 2023-08-04 jrmu ;; returns merged frame or 'failed
171 665c255d 2023-08-04 jrmu (define (merge-frame frame1 frame2)
172 665c255d 2023-08-04 jrmu (if (null? frame1)
174 665c255d 2023-08-04 jrmu (let* ((binding (first-binding frame1))
175 665c255d 2023-08-04 jrmu (var (binding-variable binding))
176 665c255d 2023-08-04 jrmu (val (binding-value binding))
177 665c255d 2023-08-04 jrmu (merged-result (extend-if-possible var val frame2)))
178 665c255d 2023-08-04 jrmu (if (eq? merged-result 'failed)
180 665c255d 2023-08-04 jrmu (merge-frame (rest-bindings frame1) frame2)))))
182 665c255d 2023-08-04 jrmu ;; returns stream of frames that can be merged
183 665c255d 2023-08-04 jrmu (define (merge-streams s1 s2)
184 665c255d 2023-08-04 jrmu (stream-flatmap
185 665c255d 2023-08-04 jrmu (lambda (f1)
186 665c255d 2023-08-04 jrmu (stream-flatmap
187 665c255d 2023-08-04 jrmu (lambda (f2)
188 665c255d 2023-08-04 jrmu (let ((merged-frame (merge-frame f1 f2)))
189 665c255d 2023-08-04 jrmu (if (eq? merged-frame 'failed)
190 665c255d 2023-08-04 jrmu the-empty-stream
191 665c255d 2023-08-04 jrmu (singleton-stream merged-frame))))
194 665c255d 2023-08-04 jrmu ;; (define (conjoin conjuncts frame-stream)
195 665c255d 2023-08-04 jrmu ;; (if (empty-conjunction? conjuncts)
196 665c255d 2023-08-04 jrmu ;; frame-stream
197 665c255d 2023-08-04 jrmu ;; (merge-streams
198 665c255d 2023-08-04 jrmu ;; (qeval (first-conjunct conjuncts) frame-stream)
199 665c255d 2023-08-04 jrmu ;; (conjoin (rest-conjuncts conjuncts) frame-stream))))
201 665c255d 2023-08-04 jrmu (define (first-binding frame)
202 665c255d 2023-08-04 jrmu (car frame))
203 665c255d 2023-08-04 jrmu (define (rest-bindings frame)
204 665c255d 2023-08-04 jrmu (cdr frame))
205 665c255d 2023-08-04 jrmu (define (make-binding variable value)
206 665c255d 2023-08-04 jrmu (cons variable value))
207 665c255d 2023-08-04 jrmu (define (binding-variable binding)
208 665c255d 2023-08-04 jrmu (car binding))
209 665c255d 2023-08-04 jrmu (define (binding-value binding)
210 665c255d 2023-08-04 jrmu (cdr binding))
211 665c255d 2023-08-04 jrmu (define (binding-in-frame variable frame)
212 665c255d 2023-08-04 jrmu (assoc variable frame))
213 665c255d 2023-08-04 jrmu (define (extend variable value frame)
214 665c255d 2023-08-04 jrmu (cons (make-binding variable value) frame))
217 665c255d 2023-08-04 jrmu (define (disjoin disjuncts frame-stream)
218 665c255d 2023-08-04 jrmu (if (empty-disjunction? disjuncts)
219 665c255d 2023-08-04 jrmu the-empty-stream
220 665c255d 2023-08-04 jrmu (interleave-delayed
221 665c255d 2023-08-04 jrmu (qeval (first-disjunct disjuncts) frame-stream)
222 665c255d 2023-08-04 jrmu (delay (disjoin (rest-disjuncts disjuncts)
223 665c255d 2023-08-04 jrmu frame-stream)))))
224 665c255d 2023-08-04 jrmu (put 'or 'qeval disjoin)
225 665c255d 2023-08-04 jrmu (define (negate operands frame-stream)
226 665c255d 2023-08-04 jrmu (stream-flatmap
227 665c255d 2023-08-04 jrmu (lambda (frame)
228 665c255d 2023-08-04 jrmu (if (stream-null? (qeval (negated-query operands)
229 665c255d 2023-08-04 jrmu (singleton-stream frame)))
230 665c255d 2023-08-04 jrmu (singleton-stream frame)
231 665c255d 2023-08-04 jrmu the-empty-stream))
232 665c255d 2023-08-04 jrmu frame-stream))
233 665c255d 2023-08-04 jrmu (put 'not 'qeval negate)
234 665c255d 2023-08-04 jrmu (define (lisp-value call frame-stream)
235 665c255d 2023-08-04 jrmu (stream-flatmap
236 665c255d 2023-08-04 jrmu (lambda (frame)
237 665c255d 2023-08-04 jrmu (if (execute
238 665c255d 2023-08-04 jrmu (instantiate
241 665c255d 2023-08-04 jrmu (lambda (v f)
242 665c255d 2023-08-04 jrmu (error "Unknown pat var -- LISP-VALUE" v))))
243 665c255d 2023-08-04 jrmu (singleton-stream frame)
244 665c255d 2023-08-04 jrmu the-empty-stream))
245 665c255d 2023-08-04 jrmu frame-stream))
246 665c255d 2023-08-04 jrmu (put 'lisp-value 'qeval lisp-value)
247 665c255d 2023-08-04 jrmu (define (execute exp)
248 665c255d 2023-08-04 jrmu (apply (eval (predicate exp) user-initial-environment)
249 665c255d 2023-08-04 jrmu (args exp)))
250 665c255d 2023-08-04 jrmu (define (always-true ignore frame-stream) frame-stream)
251 665c255d 2023-08-04 jrmu (put 'always-true 'qeval always-true)
252 665c255d 2023-08-04 jrmu (define (find-assertions pattern frame)
253 665c255d 2023-08-04 jrmu (stream-flatmap (lambda (datum)
254 665c255d 2023-08-04 jrmu (check-an-assertion datum pattern frame))
255 665c255d 2023-08-04 jrmu (fetch-assertions pattern frame)))
256 665c255d 2023-08-04 jrmu (define (check-an-assertion assertion query-pat query-frame)
257 665c255d 2023-08-04 jrmu (let ((match-result
258 665c255d 2023-08-04 jrmu (pattern-match query-pat assertion query-frame)))
259 665c255d 2023-08-04 jrmu (if (eq? match-result 'failed)
260 665c255d 2023-08-04 jrmu the-empty-stream
261 665c255d 2023-08-04 jrmu (singleton-stream match-result))))
262 665c255d 2023-08-04 jrmu (define (pattern-match pat dat frame)
263 665c255d 2023-08-04 jrmu (cond ((eq? frame 'failed) 'failed)
264 665c255d 2023-08-04 jrmu ((equal? pat dat) frame)
265 665c255d 2023-08-04 jrmu ((var? pat) (extend-if-consistent pat dat frame))
266 665c255d 2023-08-04 jrmu ((and (pair? pat) (pair? dat))
267 665c255d 2023-08-04 jrmu (pattern-match (cdr pat)
269 665c255d 2023-08-04 jrmu (pattern-match (car pat)
272 665c255d 2023-08-04 jrmu (else 'failed)))
273 665c255d 2023-08-04 jrmu (define (extend-if-consistent var dat frame)
274 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame var frame)))
275 665c255d 2023-08-04 jrmu (if binding
276 665c255d 2023-08-04 jrmu (pattern-match (binding-value binding) dat frame)
277 665c255d 2023-08-04 jrmu (extend var dat frame))))
278 665c255d 2023-08-04 jrmu (define (apply-rules pattern frame)
279 665c255d 2023-08-04 jrmu (stream-flatmap (lambda (rule)
280 665c255d 2023-08-04 jrmu (apply-a-rule rule pattern frame))
281 665c255d 2023-08-04 jrmu (fetch-rules pattern frame)))
282 665c255d 2023-08-04 jrmu (define (apply-a-rule rule query-pattern query-frame)
283 665c255d 2023-08-04 jrmu (let ((clean-rule (rename-variables-in rule)))
284 665c255d 2023-08-04 jrmu (let ((unify-result
285 665c255d 2023-08-04 jrmu (unify-match query-pattern
286 665c255d 2023-08-04 jrmu (conclusion clean-rule)
287 665c255d 2023-08-04 jrmu query-frame)))
288 665c255d 2023-08-04 jrmu (if (eq? unify-result 'failed)
289 665c255d 2023-08-04 jrmu the-empty-stream
290 665c255d 2023-08-04 jrmu (qeval (rule-body clean-rule)
291 665c255d 2023-08-04 jrmu (singleton-stream unify-result))))))
292 665c255d 2023-08-04 jrmu (define (rename-variables-in rule)
293 665c255d 2023-08-04 jrmu (let ((rule-application-id (new-rule-application-id)))
294 665c255d 2023-08-04 jrmu (define (tree-walk exp)
295 665c255d 2023-08-04 jrmu (cond ((var? exp)
296 665c255d 2023-08-04 jrmu (make-new-variable exp rule-application-id))
297 665c255d 2023-08-04 jrmu ((pair? exp)
298 665c255d 2023-08-04 jrmu (cons (tree-walk (car exp))
299 665c255d 2023-08-04 jrmu (tree-walk (cdr exp))))
300 665c255d 2023-08-04 jrmu (else exp)))
301 665c255d 2023-08-04 jrmu (tree-walk rule)))
302 665c255d 2023-08-04 jrmu (define (unify-match p1 p2 frame)
303 665c255d 2023-08-04 jrmu (cond ((eq? frame 'failed) 'failed)
304 665c255d 2023-08-04 jrmu ((equal? p1 p2) frame)
305 665c255d 2023-08-04 jrmu ((var? p1) (extend-if-possible p1 p2 frame))
306 665c255d 2023-08-04 jrmu ((var? p2) (extend-if-possible p2 p1 frame)) ; ***
307 665c255d 2023-08-04 jrmu ((and (pair? p1) (pair? p2))
308 665c255d 2023-08-04 jrmu (unify-match (cdr p1)
310 665c255d 2023-08-04 jrmu (unify-match (car p1)
313 665c255d 2023-08-04 jrmu (else 'failed)))
314 665c255d 2023-08-04 jrmu (define (extend-if-possible var val frame)
315 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame var frame)))
316 665c255d 2023-08-04 jrmu (cond (binding
317 665c255d 2023-08-04 jrmu (unify-match
318 665c255d 2023-08-04 jrmu (binding-value binding) val frame))
319 665c255d 2023-08-04 jrmu ((var? val) ; ***
320 665c255d 2023-08-04 jrmu (let ((binding (binding-in-frame val frame)))
321 665c255d 2023-08-04 jrmu (if binding
322 665c255d 2023-08-04 jrmu (unify-match
323 665c255d 2023-08-04 jrmu var (binding-value binding) frame)
324 665c255d 2023-08-04 jrmu (extend var val frame))))
325 665c255d 2023-08-04 jrmu ((depends-on? val var frame) ; ***
327 665c255d 2023-08-04 jrmu (else (extend var val frame)))))
328 665c255d 2023-08-04 jrmu (define (depends-on? exp var frame)
329 665c255d 2023-08-04 jrmu (define (tree-walk e)
330 665c255d 2023-08-04 jrmu (cond ((var? e)
331 665c255d 2023-08-04 jrmu (if (equal? var e)
333 665c255d 2023-08-04 jrmu (let ((b (binding-in-frame e frame)))
335 665c255d 2023-08-04 jrmu (tree-walk (binding-value b))
338 665c255d 2023-08-04 jrmu (or (tree-walk (car e))
339 665c255d 2023-08-04 jrmu (tree-walk (cdr e))))
340 665c255d 2023-08-04 jrmu (else false)))
341 665c255d 2023-08-04 jrmu (tree-walk exp))
342 665c255d 2023-08-04 jrmu (define THE-ASSERTIONS the-empty-stream)
343 665c255d 2023-08-04 jrmu (define (fetch-assertions pattern frame)
344 665c255d 2023-08-04 jrmu (if (use-index? pattern)
345 665c255d 2023-08-04 jrmu (get-indexed-assertions pattern)
346 665c255d 2023-08-04 jrmu (get-all-assertions)))
347 665c255d 2023-08-04 jrmu (define (get-all-assertions) THE-ASSERTIONS)
348 665c255d 2023-08-04 jrmu (define (get-indexed-assertions pattern)
349 665c255d 2023-08-04 jrmu (get-stream (index-key-of pattern) 'assertion-stream))
350 665c255d 2023-08-04 jrmu (define (get-stream key1 key2)
351 665c255d 2023-08-04 jrmu (let ((s (get key1 key2)))
352 665c255d 2023-08-04 jrmu (if s s the-empty-stream)))
353 665c255d 2023-08-04 jrmu (define THE-RULES the-empty-stream)
354 665c255d 2023-08-04 jrmu (define (fetch-rules pattern frame)
355 665c255d 2023-08-04 jrmu (if (use-index? pattern)
356 665c255d 2023-08-04 jrmu (get-indexed-rules pattern)
357 665c255d 2023-08-04 jrmu (get-all-rules)))
358 665c255d 2023-08-04 jrmu (define (get-all-rules) THE-RULES)
359 665c255d 2023-08-04 jrmu (define (get-indexed-rules pattern)
360 665c255d 2023-08-04 jrmu (stream-append
361 665c255d 2023-08-04 jrmu (get-stream (index-key-of pattern) 'rule-stream)
362 665c255d 2023-08-04 jrmu (get-stream '? 'rule-stream)))
363 665c255d 2023-08-04 jrmu (define (add-rule-or-assertion! assertion)
364 665c255d 2023-08-04 jrmu (if (rule? assertion)
365 665c255d 2023-08-04 jrmu (add-rule! assertion)
366 665c255d 2023-08-04 jrmu (add-assertion! assertion)))
367 665c255d 2023-08-04 jrmu (define (add-assertion! assertion)
368 665c255d 2023-08-04 jrmu (store-assertion-in-index assertion)
369 665c255d 2023-08-04 jrmu (let ((old-assertions THE-ASSERTIONS))
370 665c255d 2023-08-04 jrmu (set! THE-ASSERTIONS
371 665c255d 2023-08-04 jrmu (cons-stream assertion old-assertions))
373 665c255d 2023-08-04 jrmu (define (add-rule! rule)
374 665c255d 2023-08-04 jrmu (store-rule-in-index rule)
375 665c255d 2023-08-04 jrmu (let ((old-rules THE-RULES))
376 665c255d 2023-08-04 jrmu (set! THE-RULES (cons-stream rule old-rules))
378 665c255d 2023-08-04 jrmu (define (store-assertion-in-index assertion)
379 665c255d 2023-08-04 jrmu (if (indexable? assertion)
380 665c255d 2023-08-04 jrmu (let ((key (index-key-of assertion)))
381 665c255d 2023-08-04 jrmu (let ((current-assertion-stream
382 665c255d 2023-08-04 jrmu (get-stream key 'assertion-stream)))
384 665c255d 2023-08-04 jrmu 'assertion-stream
385 665c255d 2023-08-04 jrmu (cons-stream assertion
386 665c255d 2023-08-04 jrmu current-assertion-stream))))))
387 665c255d 2023-08-04 jrmu (define (store-rule-in-index rule)
388 665c255d 2023-08-04 jrmu (let ((pattern (conclusion rule)))
389 665c255d 2023-08-04 jrmu (if (indexable? pattern)
390 665c255d 2023-08-04 jrmu (let ((key (index-key-of pattern)))
391 665c255d 2023-08-04 jrmu (let ((current-rule-stream
392 665c255d 2023-08-04 jrmu (get-stream key 'rule-stream)))
394 665c255d 2023-08-04 jrmu 'rule-stream
395 665c255d 2023-08-04 jrmu (cons-stream rule
396 665c255d 2023-08-04 jrmu current-rule-stream)))))))
397 665c255d 2023-08-04 jrmu (define (indexable? pat)
398 665c255d 2023-08-04 jrmu (or (constant-symbol? (car pat))
399 665c255d 2023-08-04 jrmu (var? (car pat))))
400 665c255d 2023-08-04 jrmu (define (index-key-of pat)
401 665c255d 2023-08-04 jrmu (let ((key (car pat)))
402 665c255d 2023-08-04 jrmu (if (var? key) '? key)))
403 665c255d 2023-08-04 jrmu (define (use-index? pat)
404 665c255d 2023-08-04 jrmu (constant-symbol? (car pat)))
405 665c255d 2023-08-04 jrmu (define (stream-append s1 s2)
406 665c255d 2023-08-04 jrmu (if (stream-null? s1)
408 665c255d 2023-08-04 jrmu (cons-stream (stream-car s1)
409 665c255d 2023-08-04 jrmu (stream-append (stream-cdr s1) s2))))
410 665c255d 2023-08-04 jrmu (define (stream-append-delayed s1 delayed-s2)
411 665c255d 2023-08-04 jrmu (if (stream-null? s1)
412 665c255d 2023-08-04 jrmu (force delayed-s2)
413 665c255d 2023-08-04 jrmu (cons-stream
414 665c255d 2023-08-04 jrmu (stream-car s1)
415 665c255d 2023-08-04 jrmu (stream-append-delayed (stream-cdr s1) delayed-s2))))
416 665c255d 2023-08-04 jrmu (define (interleave-delayed s1 delayed-s2)
417 665c255d 2023-08-04 jrmu (if (stream-null? s1)
418 665c255d 2023-08-04 jrmu (force delayed-s2)
419 665c255d 2023-08-04 jrmu (cons-stream
420 665c255d 2023-08-04 jrmu (stream-car s1)
421 665c255d 2023-08-04 jrmu (interleave-delayed (force delayed-s2)
422 665c255d 2023-08-04 jrmu (delay (stream-cdr s1))))))
423 665c255d 2023-08-04 jrmu (define (stream-flatmap proc s)
424 665c255d 2023-08-04 jrmu (flatten-stream (stream-map proc s)))
425 665c255d 2023-08-04 jrmu (define (flatten-stream stream)
426 665c255d 2023-08-04 jrmu (if (stream-null? stream)
427 665c255d 2023-08-04 jrmu the-empty-stream
428 665c255d 2023-08-04 jrmu (interleave-delayed
429 665c255d 2023-08-04 jrmu (stream-car stream)
430 665c255d 2023-08-04 jrmu (delay (flatten-stream (stream-cdr stream))))))
431 665c255d 2023-08-04 jrmu (define (singleton-stream x)
432 665c255d 2023-08-04 jrmu (cons-stream x the-empty-stream))
433 665c255d 2023-08-04 jrmu (define (type exp)
434 665c255d 2023-08-04 jrmu (if (pair? exp)
436 665c255d 2023-08-04 jrmu (error "Unknown expression TYPE" exp)))
437 665c255d 2023-08-04 jrmu (define (contents exp)
438 665c255d 2023-08-04 jrmu (if (pair? exp)
440 665c255d 2023-08-04 jrmu (error "Unknown expression CONTENTS" exp)))
441 665c255d 2023-08-04 jrmu (define (assertion-to-be-added? exp)
442 665c255d 2023-08-04 jrmu (eq? (type exp) 'assert!))
443 665c255d 2023-08-04 jrmu (define (add-assertion-body exp)
444 665c255d 2023-08-04 jrmu (car (contents exp)))
445 665c255d 2023-08-04 jrmu (define (empty-conjunction? exps) (null? exps))
446 665c255d 2023-08-04 jrmu (define (first-conjunct exps) (car exps))
447 665c255d 2023-08-04 jrmu (define (rest-conjuncts exps) (cdr exps))
448 665c255d 2023-08-04 jrmu (define (empty-disjunction? exps) (null? exps))
449 665c255d 2023-08-04 jrmu (define (first-disjunct exps) (car exps))
450 665c255d 2023-08-04 jrmu (define (rest-disjuncts exps) (cdr exps))
451 665c255d 2023-08-04 jrmu (define (negated-query exps) (car exps))
452 665c255d 2023-08-04 jrmu (define (predicate exps) (car exps))
453 665c255d 2023-08-04 jrmu (define (args exps) (cdr exps))
454 665c255d 2023-08-04 jrmu (define (rule? statement)
455 665c255d 2023-08-04 jrmu (tagged-list? statement 'rule))
456 665c255d 2023-08-04 jrmu (define (conclusion rule) (cadr rule))
457 665c255d 2023-08-04 jrmu (define (rule-body rule)
458 665c255d 2023-08-04 jrmu (if (null? (cddr rule))
459 665c255d 2023-08-04 jrmu '(always-true)
460 665c255d 2023-08-04 jrmu (caddr rule)))
461 665c255d 2023-08-04 jrmu (define (query-syntax-process exp)
462 665c255d 2023-08-04 jrmu (map-over-symbols expand-question-mark exp))
463 665c255d 2023-08-04 jrmu (define (map-over-symbols proc exp)
464 665c255d 2023-08-04 jrmu (cond ((pair? exp)
465 665c255d 2023-08-04 jrmu (cons (map-over-symbols proc (car exp))
466 665c255d 2023-08-04 jrmu (map-over-symbols proc (cdr exp))))
467 665c255d 2023-08-04 jrmu ((symbol? exp) (proc exp))
468 665c255d 2023-08-04 jrmu (else exp)))
469 665c255d 2023-08-04 jrmu (define (expand-question-mark symbol)
470 665c255d 2023-08-04 jrmu (let ((chars (symbol->string symbol)))
471 665c255d 2023-08-04 jrmu (if (string=? (substring chars 0 1) "?")
473 665c255d 2023-08-04 jrmu (string->symbol
474 665c255d 2023-08-04 jrmu (substring chars 1 (string-length chars))))
476 665c255d 2023-08-04 jrmu (define (var? exp)
477 665c255d 2023-08-04 jrmu (tagged-list? exp '?))
478 665c255d 2023-08-04 jrmu (define (constant-symbol? exp) (symbol? exp))
479 665c255d 2023-08-04 jrmu (define rule-counter 0)
480 665c255d 2023-08-04 jrmu (define (new-rule-application-id)
481 665c255d 2023-08-04 jrmu (set! rule-counter (+ 1 rule-counter))
482 665c255d 2023-08-04 jrmu rule-counter)
483 665c255d 2023-08-04 jrmu (define (make-new-variable var rule-application-id)
484 665c255d 2023-08-04 jrmu (cons '? (cons rule-application-id (cdr var))))
485 665c255d 2023-08-04 jrmu (define (contract-question-mark variable)
486 665c255d 2023-08-04 jrmu (string->symbol
487 665c255d 2023-08-04 jrmu (string-append "?"
488 665c255d 2023-08-04 jrmu (if (number? (cadr variable))
489 665c255d 2023-08-04 jrmu (string-append (symbol->string (caddr variable))
491 665c255d 2023-08-04 jrmu (number->string (cadr variable)))
492 665c255d 2023-08-04 jrmu (symbol->string (cadr variable))))))
493 665c255d 2023-08-04 jrmu (define (make-binding variable value)
494 665c255d 2023-08-04 jrmu (cons variable value))
495 665c255d 2023-08-04 jrmu (define (binding-variable binding)
496 665c255d 2023-08-04 jrmu (car binding))
497 665c255d 2023-08-04 jrmu (define (binding-value binding)
498 665c255d 2023-08-04 jrmu (cdr binding))
499 665c255d 2023-08-04 jrmu (define (binding-in-frame variable frame)
500 665c255d 2023-08-04 jrmu (assoc variable frame))
501 665c255d 2023-08-04 jrmu (define (extend variable value frame)
502 665c255d 2023-08-04 jrmu (cons (make-binding variable value) frame))
503 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
504 665c255d 2023-08-04 jrmu (and (pair? exp) (eq? (car exp) tag)))
506 665c255d 2023-08-04 jrmu ;; test procedures
508 665c255d 2023-08-04 jrmu (define (eval-queries queries)
509 665c255d 2023-08-04 jrmu (if (null? queries)
511 665c255d 2023-08-04 jrmu (begin (eval-query (car queries))
512 665c255d 2023-08-04 jrmu (eval-queries (cdr queries)))))
513 665c255d 2023-08-04 jrmu (define (eval-query query)
514 665c255d 2023-08-04 jrmu (let ((q (query-syntax-process query)))
515 665c255d 2023-08-04 jrmu (if (assertion-to-be-added? q)
516 665c255d 2023-08-04 jrmu (add-rule-or-assertion! (add-assertion-body q))
517 665c255d 2023-08-04 jrmu (stream-map
518 665c255d 2023-08-04 jrmu (lambda (frame)
519 665c255d 2023-08-04 jrmu (instantiate q
521 665c255d 2023-08-04 jrmu (lambda (v f)
522 665c255d 2023-08-04 jrmu (contract-question-mark v))))
523 665c255d 2023-08-04 jrmu (qeval q (singleton-stream '()))))))
524 665c255d 2023-08-04 jrmu (define (eval-display-query q)
525 665c255d 2023-08-04 jrmu (display-stream (eval-query q)))
526 665c255d 2023-08-04 jrmu (define (test-case actual expected)
528 665c255d 2023-08-04 jrmu (display "Actual: ")
529 665c255d 2023-08-04 jrmu (display actual)
531 665c255d 2023-08-04 jrmu (display "Expected: ")
532 665c255d 2023-08-04 jrmu (display expected)
534 665c255d 2023-08-04 jrmu (define (test-query query . expected)
535 665c255d 2023-08-04 jrmu (if (null? expected)
536 665c255d 2023-08-04 jrmu (let ((result (eval-query query)))
537 665c255d 2023-08-04 jrmu (if (symbol? result)
538 665c255d 2023-08-04 jrmu (begin (display "Assertion added") (newline))
539 665c255d 2023-08-04 jrmu (display-stream (eval-query query))))
540 665c255d 2023-08-04 jrmu (let ((list (car expected)))
541 665c255d 2023-08-04 jrmu (display-streams
542 665c255d 2023-08-04 jrmu (length list)
543 665c255d 2023-08-04 jrmu (eval-query query)
544 665c255d 2023-08-04 jrmu (list->stream list)))))
546 665c255d 2023-08-04 jrmu ;; (let ((list (car expected)))
547 665c255d 2023-08-04 jrmu ;; (let ((result
548 665c255d 2023-08-04 jrmu ;; (stream-fold-left
549 665c255d 2023-08-04 jrmu ;; (lambda (x y)
550 665c255d 2023-08-04 jrmu ;; (and x y))
552 665c255d 2023-08-04 jrmu ;; (stream-map
553 665c255d 2023-08-04 jrmu ;; (lambda (e1 e2)
554 665c255d 2023-08-04 jrmu ;; (equal? e1 e2))
555 665c255d 2023-08-04 jrmu ;; (eval-query query)
556 665c255d 2023-08-04 jrmu ;; (list->stream list)))))
557 665c255d 2023-08-04 jrmu ;; (if result
558 665c255d 2023-08-04 jrmu ;; (display "Passed -- ")
559 665c255d 2023-08-04 jrmu ;; (display "Failed! -- "))
560 665c255d 2023-08-04 jrmu ;; (display query)
561 665c255d 2023-08-04 jrmu ;; (newline)))))
563 665c255d 2023-08-04 jrmu ;; test-suite
566 665c255d 2023-08-04 jrmu (eval-queries
567 665c255d 2023-08-04 jrmu '((assert! (address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)))
568 665c255d 2023-08-04 jrmu (assert! (job (Bitdiddle Ben) (computer wizard)))
569 665c255d 2023-08-04 jrmu (assert! (salary (Bitdiddle Ben) 60000))
570 665c255d 2023-08-04 jrmu (assert! (address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
571 665c255d 2023-08-04 jrmu (assert! (job (Hacker Alyssa P) (computer programmer)))
572 665c255d 2023-08-04 jrmu (assert! (salary (Hacker Alyssa P) 40000))
573 665c255d 2023-08-04 jrmu (assert! (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
574 665c255d 2023-08-04 jrmu (assert! (address (Fect Cy D) (Cambridge (Ames Street) 3)))
575 665c255d 2023-08-04 jrmu (assert! (job (Fect Cy D) (computer programmer)))
576 665c255d 2023-08-04 jrmu (assert! (salary (Fect Cy D) 35000))
577 665c255d 2023-08-04 jrmu (assert! (supervisor (Fect Cy D) (Bitdiddle Ben)))
578 665c255d 2023-08-04 jrmu (assert! (address (Tweakit Lem E) (Boston (Bay State Road) 22)))
579 665c255d 2023-08-04 jrmu (assert! (job (Tweakit Lem E) (computer technician)))
580 665c255d 2023-08-04 jrmu (assert! (salary (Tweakit Lem E) 25000))
581 665c255d 2023-08-04 jrmu (assert! (supervisor (Tweakit Lem E) (Bitdiddle Ben)))
582 665c255d 2023-08-04 jrmu (assert! (address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)))
583 665c255d 2023-08-04 jrmu (assert! (job (Reasoner Louis) (computer programmer trainee)))
584 665c255d 2023-08-04 jrmu (assert! (salary (Reasoner Louis) 30000))
585 665c255d 2023-08-04 jrmu (assert! (supervisor (Reasoner Louis) (Hacker Alyssa P)))
586 665c255d 2023-08-04 jrmu (assert! (supervisor (Bitdiddle Ben) (Warbucks Oliver)))
587 665c255d 2023-08-04 jrmu (assert! (address (Warbucks Oliver) (Swellesley (Top Heap Road))))
588 665c255d 2023-08-04 jrmu (assert! (job (Warbucks Oliver) (administration big wheel)))
589 665c255d 2023-08-04 jrmu (assert! (salary (Warbucks Oliver) 150000))
590 665c255d 2023-08-04 jrmu (assert! (address (Scrooge Eben) (Weston (Shady Lane) 10)))
591 665c255d 2023-08-04 jrmu (assert! (job (Scrooge Eben) (accounting chief accountant)))
592 665c255d 2023-08-04 jrmu (assert! (salary (Scrooge Eben) 75000))
593 665c255d 2023-08-04 jrmu (assert! (supervisor (Scrooge Eben) (Warbucks Oliver)))
594 665c255d 2023-08-04 jrmu (assert! (address (Cratchet Robert) (Allston (N Harvard Street) 16)))
595 665c255d 2023-08-04 jrmu (assert! (job (Cratchet Robert) (accounting scrivener)))
596 665c255d 2023-08-04 jrmu (assert! (salary (Cratchet Robert) 18000))
597 665c255d 2023-08-04 jrmu (assert! (supervisor (Cratchet Robert) (Scrooge Eben)))
598 665c255d 2023-08-04 jrmu (assert! (address (Aull DeWitt) (Slumerville (Onion Square) 5)))
599 665c255d 2023-08-04 jrmu (assert! (job (Aull DeWitt) (administration secretary)))
600 665c255d 2023-08-04 jrmu (assert! (salary (Aull DeWitt) 25000))
601 665c255d 2023-08-04 jrmu (assert! (supervisor (Aull DeWitt) (Warbucks Oliver)))
602 665c255d 2023-08-04 jrmu (assert! (can-do-job (computer wizard) (computer programmer)))
603 665c255d 2023-08-04 jrmu (assert! (can-do-job (computer wizard) (computer technician)))
604 665c255d 2023-08-04 jrmu (assert! (can-do-job (computer programmer)
605 665c255d 2023-08-04 jrmu (computer programmer trainee)))
606 665c255d 2023-08-04 jrmu (assert! (can-do-job (administration secretary)
607 665c255d 2023-08-04 jrmu (administration big wheel)))))
609 665c255d 2023-08-04 jrmu (eval-query
610 665c255d 2023-08-04 jrmu '(assert! (rule (same ?x ?x))))
613 665c255d 2023-08-04 jrmu (test-query
614 665c255d 2023-08-04 jrmu '(supervisor ?employee (Bitdiddle Ben))
615 665c255d 2023-08-04 jrmu '((supervisor (tweakit lem e) (bitdiddle ben))
616 665c255d 2023-08-04 jrmu (supervisor (fect cy d) (bitdiddle ben))
617 665c255d 2023-08-04 jrmu (supervisor (hacker alyssa p) (bitdiddle ben))))
618 665c255d 2023-08-04 jrmu (test-query
619 665c255d 2023-08-04 jrmu '(job ?x (accounting . ?title))
620 665c255d 2023-08-04 jrmu '((job (cratchet robert) (accounting scrivener))
621 665c255d 2023-08-04 jrmu (job (scrooge eben) (accounting chief accountant))))
622 665c255d 2023-08-04 jrmu (test-query
623 665c255d 2023-08-04 jrmu '(address ?person (Slumerville . ?rest))
624 665c255d 2023-08-04 jrmu '((address (aull dewitt) (slumerville (onion square) 5))
625 665c255d 2023-08-04 jrmu (address (reasoner louis) (slumerville (pine tree road) 80))
626 665c255d 2023-08-04 jrmu (address (bitdiddle ben) (slumerville (ridge road) 10))))
627 665c255d 2023-08-04 jrmu (test-query
628 665c255d 2023-08-04 jrmu '(and (supervisor ?x (Bitdiddle Ben))
629 665c255d 2023-08-04 jrmu (address ?x ?address))
630 665c255d 2023-08-04 jrmu '((and (supervisor (tweakit lem e) (bitdiddle ben)) (address (tweakit lem e) (boston (bay state road) 22)))
631 665c255d 2023-08-04 jrmu (and (supervisor (fect cy d) (bitdiddle ben)) (address (fect cy d) (cambridge (ames street) 3)))
632 665c255d 2023-08-04 jrmu (and (supervisor (hacker alyssa p) (bitdiddle ben)) (address (hacker alyssa p) (cambridge (mass ave) 78)))))
633 665c255d 2023-08-04 jrmu (test-query
634 665c255d 2023-08-04 jrmu '(and (salary (Bitdiddle Ben) ?ben-salary)
635 665c255d 2023-08-04 jrmu (salary ?x ?x-salary)
636 665c255d 2023-08-04 jrmu (lisp-value < ?x-salary ?ben-salary))
637 665c255d 2023-08-04 jrmu '((and (salary (bitdiddle ben) 60000) (salary (aull dewitt) 25000) (lisp-value < 25000 60000))
638 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (cratchet robert) 18000) (lisp-value < 18000 60000))
639 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (reasoner louis) 30000) (lisp-value < 30000 60000))
640 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (tweakit lem e) 25000) (lisp-value < 25000 60000))
641 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (fect cy d) 35000) (lisp-value < 35000 60000))
642 665c255d 2023-08-04 jrmu (and (salary (bitdiddle ben) 60000) (salary (hacker alyssa p) 40000) (lisp-value < 40000 60000))))
643 665c255d 2023-08-04 jrmu (test-query
644 665c255d 2023-08-04 jrmu '(and (supervisor ?employee ?supervisor)
645 665c255d 2023-08-04 jrmu (job ?supervisor ?job)
646 665c255d 2023-08-04 jrmu (not (job ?supervisor (computer . ?title))))
647 665c255d 2023-08-04 jrmu '((and (supervisor (aull dewitt) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
648 665c255d 2023-08-04 jrmu (and (supervisor (cratchet robert) (scrooge eben)) (job (scrooge eben) (accounting chief accountant)) (not (job (scrooge eben) (computer . ?title))))
649 665c255d 2023-08-04 jrmu (and (supervisor (scrooge eben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))
650 665c255d 2023-08-04 jrmu (and (supervisor (bitdiddle ben) (warbucks oliver)) (job (warbucks oliver) (administration big wheel)) (not (job (warbucks oliver) (computer . ?title))))))
652 665c255d 2023-08-04 jrmu (eval-query
653 665c255d 2023-08-04 jrmu '(assert! (rule (can-replace? ?p1 ?p2)
654 665c255d 2023-08-04 jrmu (and (or (and (job ?p1 ?job)
655 665c255d 2023-08-04 jrmu (job ?p2 ?job))
656 665c255d 2023-08-04 jrmu (and (job ?p1 ?j1)
657 665c255d 2023-08-04 jrmu (job ?p2 ?j2)
658 665c255d 2023-08-04 jrmu (can-do-job ?j1 ?j2)))
659 665c255d 2023-08-04 jrmu (not (same ?p1 ?p2))))))
660 665c255d 2023-08-04 jrmu (test-query
661 665c255d 2023-08-04 jrmu '(can-replace? ?x (Fect Cy D))
662 665c255d 2023-08-04 jrmu '((can-replace? (bitdiddle ben) (fect cy d))
663 665c255d 2023-08-04 jrmu (can-replace? (hacker alyssa p) (fect cy d))))
664 665c255d 2023-08-04 jrmu (test-query
665 665c255d 2023-08-04 jrmu '(and (salary ?low ?low-salary)
666 665c255d 2023-08-04 jrmu (salary ?high ?high-salary)
667 665c255d 2023-08-04 jrmu (can-replace? ?low ?high)
668 665c255d 2023-08-04 jrmu (lisp-value < ?low-salary ?high-salary))
669 665c255d 2023-08-04 jrmu '((and (salary (aull dewitt) 25000) (salary (warbucks oliver) 150000) (can-replace? (aull dewitt) (warbucks oliver)) (lisp-value < 25000 150000))
670 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))))
671 665c255d 2023-08-04 jrmu (eval-query
672 665c255d 2023-08-04 jrmu '(assert! (rule (big-shot ?bigshot)
673 665c255d 2023-08-04 jrmu (and (job ?bigshot (?dept . ?job-title))
674 665c255d 2023-08-04 jrmu (or (not (supervisor ?bigshot ?boss))
675 665c255d 2023-08-04 jrmu (and (supervisor ?bigshot ?boss)
676 665c255d 2023-08-04 jrmu (not (job ?boss (?dept . ?boss-title)))))))))
677 665c255d 2023-08-04 jrmu (test-query
678 665c255d 2023-08-04 jrmu '(big-shot ?x)
679 665c255d 2023-08-04 jrmu '((big-shot (warbucks oliver))
680 665c255d 2023-08-04 jrmu (big-shot (scrooge eben))
681 665c255d 2023-08-04 jrmu (big-shot (bitdiddle ben))))
682 665c255d 2023-08-04 jrmu (eval-queries
683 665c255d 2023-08-04 jrmu '((assert! (meeting accounting (Monday 9am)))
684 665c255d 2023-08-04 jrmu (assert! (meeting administration (Monday 10am)))
685 665c255d 2023-08-04 jrmu (assert! (meeting computer (Wednesday 3pm)))
686 665c255d 2023-08-04 jrmu (assert! (meeting administration (Friday 1pm)))
687 665c255d 2023-08-04 jrmu (assert! (meeting whole-company (Wednesday 4pm)))))
688 665c255d 2023-08-04 jrmu (test-query '(meeting ?div (Friday ?time))
689 665c255d 2023-08-04 jrmu '((meeting administration (friday 1pm))))
690 665c255d 2023-08-04 jrmu (eval-query
691 665c255d 2023-08-04 jrmu '(assert! (rule (meeting-time ?person ?day-and-time)
692 665c255d 2023-08-04 jrmu (or (and (job ?person (?dept . ?title))
693 665c255d 2023-08-04 jrmu (meeting ?dept ?day-and-time))
694 665c255d 2023-08-04 jrmu (meeting whole-company ?day-and-time)))))
696 665c255d 2023-08-04 jrmu (test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
697 665c255d 2023-08-04 jrmu '((meeting-time (hacker alyssa p) (wednesday 3pm))
698 665c255d 2023-08-04 jrmu (meeting-time (hacker alyssa p) (wednesday 4pm))))
700 665c255d 2023-08-04 jrmu (define (name<? name1 name2)
701 665c255d 2023-08-04 jrmu (let ((str1 (fold-left
702 665c255d 2023-08-04 jrmu (lambda (str sym)
703 665c255d 2023-08-04 jrmu (string-append str (symbol->string sym)))
706 665c255d 2023-08-04 jrmu (str2 (fold-left
707 665c255d 2023-08-04 jrmu (lambda (str sym)
708 665c255d 2023-08-04 jrmu (string-append str (symbol->string sym)))
711 665c255d 2023-08-04 jrmu (string<? str1 str2)))
713 665c255d 2023-08-04 jrmu (eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
714 665c255d 2023-08-04 jrmu (and (address ?person-1 (?town . ?rest-1))
715 665c255d 2023-08-04 jrmu (address ?person-2 (?town . ?rest-2))
716 665c255d 2023-08-04 jrmu (not (same ?person-1 ?person-2))
717 665c255d 2023-08-04 jrmu (lisp-value name<? ?person-1 ?person-2)))))
719 665c255d 2023-08-04 jrmu (test-query '(lives-near ?person-1 ?person-2)
720 665c255d 2023-08-04 jrmu '((lives-near (aull dewitt) (reasoner louis))
721 665c255d 2023-08-04 jrmu (lives-near (aull dewitt) (bitdiddle ben))
722 665c255d 2023-08-04 jrmu (lives-near (fect cy d) (hacker alyssa p))
723 665c255d 2023-08-04 jrmu (lives-near (bitdiddle ben) (reasoner louis))))
724 665c255d 2023-08-04 jrmu (eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
725 665c255d 2023-08-04 jrmu (eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
726 665c255d 2023-08-04 jrmu (?x next-to ?y in ?z))))
727 665c255d 2023-08-04 jrmu (test-query '(?x next-to ?y in (1 (2 3) 4))
728 665c255d 2023-08-04 jrmu '(((2 3) next-to 4 in (1 (2 3) 4))
729 665c255d 2023-08-04 jrmu (1 next-to (2 3) in (1 (2 3) 4))))
730 665c255d 2023-08-04 jrmu (test-query '(?x next-to 1 in (2 1 3 1))
731 665c255d 2023-08-04 jrmu '((3 next-to 1 in (2 1 3 1))
732 665c255d 2023-08-04 jrmu (2 next-to 1 in (2 1 3 1))))
733 665c255d 2023-08-04 jrmu (eval-queries
734 665c255d 2023-08-04 jrmu '((assert! (rule (last-pair (?x) (?x))))
735 665c255d 2023-08-04 jrmu (assert! (rule (last-pair (?x . ?y) (?z))
736 665c255d 2023-08-04 jrmu (last-pair ?y (?z))))))
737 665c255d 2023-08-04 jrmu (test-query '(last-pair (3) ?x)
738 665c255d 2023-08-04 jrmu '((last-pair (3) (3))))
739 665c255d 2023-08-04 jrmu (test-query '(last-pair (1 2 3))
740 665c255d 2023-08-04 jrmu '((last-pair (1 2 3) (3))))
741 665c255d 2023-08-04 jrmu (test-query '(last-pair (2 ?x) (3))
742 665c255d 2023-08-04 jrmu '((last-pair (2 3) (3))))
743 665c255d 2023-08-04 jrmu (eval-queries
744 665c255d 2023-08-04 jrmu '((assert! (son Adam Cain))
745 665c255d 2023-08-04 jrmu (assert! (son Cain Enoch))
746 665c255d 2023-08-04 jrmu (assert! (son Enoch Irad))
747 665c255d 2023-08-04 jrmu (assert! (son Irad Mehujael))
748 665c255d 2023-08-04 jrmu (assert! (son Mehujael Methushael))
749 665c255d 2023-08-04 jrmu (assert! (son Methushael Lamech))
750 665c255d 2023-08-04 jrmu (assert! (wife Lamech Ada))
751 665c255d 2023-08-04 jrmu (assert! (son Ada Jabal))
752 665c255d 2023-08-04 jrmu (assert! (son Ada Jubal))))
753 665c255d 2023-08-04 jrmu (eval-queries
754 665c255d 2023-08-04 jrmu '((assert! (rule (grandson ?g ?s)
755 665c255d 2023-08-04 jrmu (and (son ?g ?f)
756 665c255d 2023-08-04 jrmu (son ?f ?s))))
757 665c255d 2023-08-04 jrmu (assert! (rule (son ?f ?s)
758 665c255d 2023-08-04 jrmu (and (wife ?f ?m)
759 665c255d 2023-08-04 jrmu (son ?m ?s))))))
760 665c255d 2023-08-04 jrmu (test-query
761 665c255d 2023-08-04 jrmu '(grandson Cain ?grandson)
762 665c255d 2023-08-04 jrmu '((grandson cain irad)))
763 665c255d 2023-08-04 jrmu (test-query
764 665c255d 2023-08-04 jrmu '(son Lamech ?son)
765 665c255d 2023-08-04 jrmu '((son lamech jubal)
766 665c255d 2023-08-04 jrmu (son lamech jabal)))
767 665c255d 2023-08-04 jrmu (test-query
768 665c255d 2023-08-04 jrmu '(grandson Methushael ?grandson)
769 665c255d 2023-08-04 jrmu '((grandson methushael jubal)
770 665c255d 2023-08-04 jrmu (grandson methushael jabal)))
772 665c255d 2023-08-04 jrmu (eval-queries
773 665c255d 2023-08-04 jrmu '((assert! (rule (append-to-form () ?y ?y)))
774 665c255d 2023-08-04 jrmu (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
775 665c255d 2023-08-04 jrmu (append-to-form ?v ?y ?z)))
776 665c255d 2023-08-04 jrmu (assert! (rule (reverse () ())))
777 665c255d 2023-08-04 jrmu (assert! (rule (reverse (?x . ?y) ?rev)
778 665c255d 2023-08-04 jrmu (and (reverse ?y ?rev-y)
779 665c255d 2023-08-04 jrmu (append-to-form ?rev-y (?x) ?rev))))))
780 665c255d 2023-08-04 jrmu (test-query '(reverse (1 2 3) ?x)
781 665c255d 2023-08-04 jrmu '((reverse (1 2 3) (3 2 1))))
783 665c255d 2023-08-04 jrmu ;; 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).
785 665c255d 2023-08-04 jrmu (eval-queries
786 665c255d 2023-08-04 jrmu '((assert! (rule (ends-in-grandson? (grandson))))
787 665c255d 2023-08-04 jrmu (assert! (rule (ends-in-grandson? (?x . ?y))
788 665c255d 2023-08-04 jrmu (ends-in-grandson? ?y)))))
789 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (father)))
790 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (son mother father)))
791 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (grandson)))
792 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (father son grandson mother)))
793 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
795 665c255d 2023-08-04 jrmu (eval-queries
796 665c255d 2023-08-04 jrmu '((assert! (rule ((great . ?rel) ?x ?y)
797 665c255d 2023-08-04 jrmu (and (ends-in-grandson? ?rel)
798 665c255d 2023-08-04 jrmu (son ?x ?z)
799 665c255d 2023-08-04 jrmu (?rel ?z ?y))))
800 665c255d 2023-08-04 jrmu (assert! (rule ((grandson) ?x ?y)
801 665c255d 2023-08-04 jrmu (grandson ?x ?y)))))
803 665c255d 2023-08-04 jrmu ;; ((great great great grandson) Adam ?somebody)
804 665c255d 2023-08-04 jrmu ;; ((great . ?rel) ?x ?y)
806 665c255d 2023-08-04 jrmu ;; ?rel -> (great great grandson)
807 665c255d 2023-08-04 jrmu ;; ?x -> Adam
808 665c255d 2023-08-04 jrmu ;; ?somebody -> ?y
810 665c255d 2023-08-04 jrmu ;; (and (ends-in-grandson? ?rel)
811 665c255d 2023-08-04 jrmu ;; (son ?x ?z)
812 665c255d 2023-08-04 jrmu ;; (?rel ?z ?y))
813 665c255d 2023-08-04 jrmu ;; (and (son Adam ?z)
814 665c255d 2023-08-04 jrmu ;; ((great great grandson) ?z ?y))
816 665c255d 2023-08-04 jrmu ;; (son Adam ?z)
817 665c255d 2023-08-04 jrmu ;; (son Adam Cain)
818 665c255d 2023-08-04 jrmu ;; ?z -> Cain
820 665c255d 2023-08-04 jrmu ;; ((great great grandson) Cain ?y)
821 665c255d 2023-08-04 jrmu ;; ((great . ?rel1) ?x1 ?y1)
822 665c255d 2023-08-04 jrmu ;; ?rel1 -> (great grandson)
823 665c255d 2023-08-04 jrmu ;; ?x1 -> Cain
824 665c255d 2023-08-04 jrmu ;; ?y -> ?y1
825 665c255d 2023-08-04 jrmu ;; (and (son Cain ?z1)
826 665c255d 2023-08-04 jrmu ;; ((great grandson) ?z1 ?y1))
827 665c255d 2023-08-04 jrmu ;; ?z1 -> Enoch
828 665c255d 2023-08-04 jrmu ;; ((great grandson) Enoch ?y1)
829 665c255d 2023-08-04 jrmu ;; ((great . ?rel2) ?x2 ?y2)
830 665c255d 2023-08-04 jrmu ;; ?rel2 -> (grandson)
831 665c255d 2023-08-04 jrmu ;; ?x2 -> Enoch
832 665c255d 2023-08-04 jrmu ;; ?y1 -> ?y2
833 665c255d 2023-08-04 jrmu ;; (and (son Enoch ?z2)
834 665c255d 2023-08-04 jrmu ;; ((grandson) ?z2 ?y2))
835 665c255d 2023-08-04 jrmu ;; ?z2 -> Irad
836 665c255d 2023-08-04 jrmu ;; ((grandson) Irad ?y2)
838 665c255d 2023-08-04 jrmu ;; (assert! (son Adam Cain))
839 665c255d 2023-08-04 jrmu ;; (assert! (son Cain Enoch))
840 665c255d 2023-08-04 jrmu ;; (assert! (son Enoch Irad))
841 665c255d 2023-08-04 jrmu ;; (assert! (son Irad Mehujael))
842 665c255d 2023-08-04 jrmu ;; (assert! (son Mehujael Methushael))
843 665c255d 2023-08-04 jrmu ;; (assert! (son Methushael Lamech))
844 665c255d 2023-08-04 jrmu ;; (assert! (wife Lamech Ada))
845 665c255d 2023-08-04 jrmu ;; (assert! (son Ada Jabal))
846 665c255d 2023-08-04 jrmu ;; (assert! (son Ada Jubal))
848 665c255d 2023-08-04 jrmu (test-query '((great grandson) ?great-grandfather Irad)
849 665c255d 2023-08-04 jrmu '(((great grandson) Adam Irad)))
850 665c255d 2023-08-04 jrmu (test-query '((great great great great great grandson) Adam ?x)
851 665c255d 2023-08-04 jrmu '(((great great great great great grandson) Adam Jubal)
852 665c255d 2023-08-04 jrmu ((great great great great great grandson) Adam Jabal)))
854 665c255d 2023-08-04 jrmu (test-query '((great grandson) ?g ?ggs)
855 665c255d 2023-08-04 jrmu '(((great grandson) mehujael jubal)
856 665c255d 2023-08-04 jrmu ((great grandson) irad lamech)
857 665c255d 2023-08-04 jrmu ((great grandson) mehujael jabal)
858 665c255d 2023-08-04 jrmu ((great grandson) enoch methushael)
859 665c255d 2023-08-04 jrmu ((great grandson) cain mehujael)
860 665c255d 2023-08-04 jrmu ((great grandson) adam irad)))
862 665c255d 2023-08-04 jrmu ;; (test-query '(?relationship Adam Irad))
863 665c255d 2023-08-04 jrmu ;; this goes into an infinite loop
864 665c255d 2023-08-04 jrmu (define (simple-stream-flatmap proc s)
865 665c255d 2023-08-04 jrmu (simple-flatten (stream-map proc s)))
867 665c255d 2023-08-04 jrmu (define (simple-flatten stream)
868 665c255d 2023-08-04 jrmu (stream-map stream-car
869 665c255d 2023-08-04 jrmu (stream-filter (lambda (x) (not (stream-null? x))) stream)))
872 665c255d 2023-08-04 jrmu ;; 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,
874 665c255d 2023-08-04 jrmu (define (uniquely-asserted operands frame-stream)
875 665c255d 2023-08-04 jrmu (stream-flatmap
876 665c255d 2023-08-04 jrmu (lambda (frame)
877 665c255d 2023-08-04 jrmu (let ((results-stream
878 665c255d 2023-08-04 jrmu (qeval (unique-query operands)
879 665c255d 2023-08-04 jrmu (singleton-stream frame))))
880 665c255d 2023-08-04 jrmu (if (singleton-stream? results-stream)
881 665c255d 2023-08-04 jrmu results-stream
882 665c255d 2023-08-04 jrmu the-empty-stream)))
883 665c255d 2023-08-04 jrmu frame-stream))
884 665c255d 2023-08-04 jrmu (define (unique-query operands)
885 665c255d 2023-08-04 jrmu (car operands))
886 665c255d 2023-08-04 jrmu (define (singleton-stream? s)
887 665c255d 2023-08-04 jrmu (and (not (stream-null? s))
888 665c255d 2023-08-04 jrmu (stream-null? (stream-cdr s))))
889 665c255d 2023-08-04 jrmu (put 'unique 'qeval uniquely-asserted)
891 665c255d 2023-08-04 jrmu (test-query '(unique (job ?x (computer wizard)))
892 665c255d 2023-08-04 jrmu '((unique (job (Bitdiddle Ben) (computer wizard)))))
893 665c255d 2023-08-04 jrmu (test-query '(unique (job ?x (computer programmer)))
895 665c255d 2023-08-04 jrmu (test-query '(and (job ?x ?j)
896 665c255d 2023-08-04 jrmu (unique (job ?anyone ?j)))
897 665c255d 2023-08-04 jrmu '((and (job (aull dewitt) (administration secretary)) (unique (job (aull dewitt) (administration secretary))))
898 665c255d 2023-08-04 jrmu (and (job (cratchet robert) (accounting scrivener)) (unique (job (cratchet robert) (accounting scrivener))))
899 665c255d 2023-08-04 jrmu (and (job (scrooge eben) (accounting chief accountant)) (unique (job (scrooge eben) (accounting chief accountant))))
900 665c255d 2023-08-04 jrmu (and (job (warbucks oliver) (administration big wheel)) (unique (job (warbucks oliver) (administration big wheel))))
901 665c255d 2023-08-04 jrmu (and (job (reasoner louis) (computer programmer trainee)) (unique (job (reasoner louis) (computer programmer trainee))))
902 665c255d 2023-08-04 jrmu (and (job (tweakit lem e) (computer technician)) (unique (job (tweakit lem e) (computer technician))))
903 665c255d 2023-08-04 jrmu (and (job (bitdiddle ben) (computer wizard)) (unique (job (bitdiddle ben) (computer wizard))))))
904 665c255d 2023-08-04 jrmu (test-query '(and (supervisor ?sub ?sup)
905 665c255d 2023-08-04 jrmu (unique (supervisor ?anyone ?sup)))
906 665c255d 2023-08-04 jrmu '((and (supervisor (cratchet robert) (scrooge eben)) (unique (supervisor (cratchet robert) (scrooge eben))))
907 665c255d 2023-08-04 jrmu (and (supervisor (reasoner louis) (hacker alyssa p)) (unique (supervisor (reasoner louis) (hacker alyssa p))))))
