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))))
641 665c255d 2023-08-04 jrmu (eval-queries
642 665c255d 2023-08-04 jrmu '((assert! (meeting accounting (Monday 9am)))
643 665c255d 2023-08-04 jrmu (assert! (meeting administration (Monday 10am)))
644 665c255d 2023-08-04 jrmu (assert! (meeting computer (Wednesday 3pm)))
645 665c255d 2023-08-04 jrmu (assert! (meeting administration (Friday 1pm)))
646 665c255d 2023-08-04 jrmu (assert! (meeting whole-company (Wednesday 4pm)))))
647 665c255d 2023-08-04 jrmu (test-query '(meeting ?div (Friday ?time))
648 665c255d 2023-08-04 jrmu '((meeting administration (friday 1pm))))
649 665c255d 2023-08-04 jrmu (eval-query
650 665c255d 2023-08-04 jrmu '(assert! (rule (meeting-time ?person ?day-and-time)
651 665c255d 2023-08-04 jrmu (or (and (job ?person (?dept . ?title))
652 665c255d 2023-08-04 jrmu (meeting ?dept ?day-and-time))
653 665c255d 2023-08-04 jrmu (meeting whole-company ?day-and-time)))))
655 665c255d 2023-08-04 jrmu (test-query '(meeting-time (Hacker Alyssa P) (Wednesday ?time))
656 665c255d 2023-08-04 jrmu '((meeting-time (hacker alyssa p) (wednesday 3pm))
657 665c255d 2023-08-04 jrmu (meeting-time (hacker alyssa p) (wednesday 4pm))))
659 665c255d 2023-08-04 jrmu (define (name<? name1 name2)
660 665c255d 2023-08-04 jrmu (let ((str1 (fold-left
661 665c255d 2023-08-04 jrmu (lambda (str sym)
662 665c255d 2023-08-04 jrmu (string-append str (symbol->string sym)))
665 665c255d 2023-08-04 jrmu (str2 (fold-left
666 665c255d 2023-08-04 jrmu (lambda (str sym)
667 665c255d 2023-08-04 jrmu (string-append str (symbol->string sym)))
670 665c255d 2023-08-04 jrmu (string<? str1 str2)))
672 665c255d 2023-08-04 jrmu (eval-query '(assert! (rule (lives-near ?person-1 ?person-2)
673 665c255d 2023-08-04 jrmu (and (address ?person-1 (?town . ?rest-1))
674 665c255d 2023-08-04 jrmu (address ?person-2 (?town . ?rest-2))
675 665c255d 2023-08-04 jrmu (not (same ?person-1 ?person-2))
676 665c255d 2023-08-04 jrmu (lisp-value name<? ?person-1 ?person-2)))))
678 665c255d 2023-08-04 jrmu (test-query '(lives-near ?person-1 ?person-2)
679 665c255d 2023-08-04 jrmu '((lives-near (aull dewitt) (reasoner louis))
680 665c255d 2023-08-04 jrmu (lives-near (aull dewitt) (bitdiddle ben))
681 665c255d 2023-08-04 jrmu (lives-near (fect cy d) (hacker alyssa p))
682 665c255d 2023-08-04 jrmu (lives-near (bitdiddle ben) (reasoner louis))))
683 665c255d 2023-08-04 jrmu (eval-query '(assert! (rule (?x next-to ?y in (?x ?y . ?u)))))
684 665c255d 2023-08-04 jrmu (eval-query '(assert! (rule (?x next-to ?y in (?v . ?z))
685 665c255d 2023-08-04 jrmu (?x next-to ?y in ?z))))
686 665c255d 2023-08-04 jrmu (test-query '(?x next-to ?y in (1 (2 3) 4))
687 665c255d 2023-08-04 jrmu '(((2 3) next-to 4 in (1 (2 3) 4))
688 665c255d 2023-08-04 jrmu (1 next-to (2 3) in (1 (2 3) 4))))
689 665c255d 2023-08-04 jrmu (test-query '(?x next-to 1 in (2 1 3 1))
690 665c255d 2023-08-04 jrmu '((3 next-to 1 in (2 1 3 1))
691 665c255d 2023-08-04 jrmu (2 next-to 1 in (2 1 3 1))))
692 665c255d 2023-08-04 jrmu (eval-queries
693 665c255d 2023-08-04 jrmu '((assert! (rule (last-pair (?x) (?x))))
694 665c255d 2023-08-04 jrmu (assert! (rule (last-pair (?x . ?y) (?z))
695 665c255d 2023-08-04 jrmu (last-pair ?y (?z))))))
696 665c255d 2023-08-04 jrmu (test-query '(last-pair (3) ?x)
697 665c255d 2023-08-04 jrmu '((last-pair (3) (3))))
698 665c255d 2023-08-04 jrmu (test-query '(last-pair (1 2 3))
699 665c255d 2023-08-04 jrmu '((last-pair (1 2 3) (3))))
700 665c255d 2023-08-04 jrmu (test-query '(last-pair (2 ?x) (3))
701 665c255d 2023-08-04 jrmu '((last-pair (2 3) (3))))
702 665c255d 2023-08-04 jrmu (eval-queries
703 665c255d 2023-08-04 jrmu '((assert! (son Adam Cain))
704 665c255d 2023-08-04 jrmu (assert! (son Cain Enoch))
705 665c255d 2023-08-04 jrmu (assert! (son Enoch Irad))
706 665c255d 2023-08-04 jrmu (assert! (son Irad Mehujael))
707 665c255d 2023-08-04 jrmu (assert! (son Mehujael Methushael))
708 665c255d 2023-08-04 jrmu (assert! (son Methushael Lamech))
709 665c255d 2023-08-04 jrmu (assert! (wife Lamech Ada))
710 665c255d 2023-08-04 jrmu (assert! (son Ada Jabal))
711 665c255d 2023-08-04 jrmu (assert! (son Ada Jubal))))
712 665c255d 2023-08-04 jrmu (eval-queries
713 665c255d 2023-08-04 jrmu '((assert! (rule (grandson ?g ?s)
714 665c255d 2023-08-04 jrmu (and (son ?g ?f)
715 665c255d 2023-08-04 jrmu (son ?f ?s))))
716 665c255d 2023-08-04 jrmu (assert! (rule (son ?f ?s)
717 665c255d 2023-08-04 jrmu (and (wife ?f ?m)
718 665c255d 2023-08-04 jrmu (son ?m ?s))))))
719 665c255d 2023-08-04 jrmu (test-query
720 665c255d 2023-08-04 jrmu '(grandson Cain ?grandson)
721 665c255d 2023-08-04 jrmu '((grandson cain irad)))
722 665c255d 2023-08-04 jrmu (test-query
723 665c255d 2023-08-04 jrmu '(son Lamech ?son)
724 665c255d 2023-08-04 jrmu '((son lamech jubal)
725 665c255d 2023-08-04 jrmu (son lamech jabal)))
726 665c255d 2023-08-04 jrmu (test-query
727 665c255d 2023-08-04 jrmu '(grandson Methushael ?grandson)
728 665c255d 2023-08-04 jrmu '((grandson methushael jubal)
729 665c255d 2023-08-04 jrmu (grandson methushael jabal)))
731 665c255d 2023-08-04 jrmu (eval-queries
732 665c255d 2023-08-04 jrmu '((assert! (rule (append-to-form () ?y ?y)))
733 665c255d 2023-08-04 jrmu (assert! (rule (append-to-form (?u . ?v) ?y (?u . ?z))
734 665c255d 2023-08-04 jrmu (append-to-form ?v ?y ?z)))
735 665c255d 2023-08-04 jrmu (assert! (rule (reverse () ())))
736 665c255d 2023-08-04 jrmu (assert! (rule (reverse (?x . ?y) ?rev)
737 665c255d 2023-08-04 jrmu (and (reverse ?y ?rev-y)
738 665c255d 2023-08-04 jrmu (append-to-form ?rev-y (?x) ?rev))))))
739 665c255d 2023-08-04 jrmu (test-query '(reverse (1 2 3) ?x)
740 665c255d 2023-08-04 jrmu '((reverse (1 2 3) (3 2 1))))
742 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).
744 665c255d 2023-08-04 jrmu (eval-queries
745 665c255d 2023-08-04 jrmu '((assert! (rule (ends-in-grandson? (grandson))))
746 665c255d 2023-08-04 jrmu (assert! (rule (ends-in-grandson? (?x . ?y))
747 665c255d 2023-08-04 jrmu (ends-in-grandson? ?y)))))
748 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (father)))
749 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (son mother father)))
750 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (grandson)))
751 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (father son grandson mother)))
752 665c255d 2023-08-04 jrmu ;; (test-query '(ends-in-grandson? (father mother brother sister grandson)))
754 665c255d 2023-08-04 jrmu (eval-query
755 665c255d 2023-08-04 jrmu '(assert! (rule ((great . ?rel) ?x ?y)
756 665c255d 2023-08-04 jrmu (and (ends-in-grandson? ?rel)
757 665c255d 2023-08-04 jrmu (son ?x ?z)
758 665c255d 2023-08-04 jrmu (?rel ?z ?y)))))
760 665c255d 2023-08-04 jrmu ;; ((great great great grandson) Adam ?somebody)
761 665c255d 2023-08-04 jrmu ;; ((great . ?rel) ?x ?y)
763 665c255d 2023-08-04 jrmu ;; ?rel -> (great great grandson)
764 665c255d 2023-08-04 jrmu ;; ?x -> Adam
765 665c255d 2023-08-04 jrmu ;; ?somebody -> ?y
767 665c255d 2023-08-04 jrmu ;; (and (ends-in-grandson? ?rel)
768 665c255d 2023-08-04 jrmu ;; (son ?x ?z)
769 665c255d 2023-08-04 jrmu ;; (?rel ?z ?y))
770 665c255d 2023-08-04 jrmu ;; (and (son Adam ?z)
771 665c255d 2023-08-04 jrmu ;; ((great great grandson) ?z ?y))
773 665c255d 2023-08-04 jrmu ;; (son Adam ?z)
774 665c255d 2023-08-04 jrmu ;; (son Adam Cain)
775 665c255d 2023-08-04 jrmu ;; ?z -> Cain
777 665c255d 2023-08-04 jrmu ;; ((great great grandson) Cain ?y)
778 665c255d 2023-08-04 jrmu ;; ((great . ?rel1) ?x1 ?y1)
779 665c255d 2023-08-04 jrmu ;; ?rel1 -> (great grandson)
780 665c255d 2023-08-04 jrmu ;; ?x1 -> Cain
781 665c255d 2023-08-04 jrmu ;; ?y -> ?y1
782 665c255d 2023-08-04 jrmu ;; (and (son Cain ?z1)
783 665c255d 2023-08-04 jrmu ;; ((great grandson) ?z1 ?y1))
784 665c255d 2023-08-04 jrmu ;; ?z1 -> Enoch
785 665c255d 2023-08-04 jrmu ;; ((great grandson) Enoch ?y1)
786 665c255d 2023-08-04 jrmu ;; ((great . ?rel2) ?x2 ?y2)
787 665c255d 2023-08-04 jrmu ;; ?rel2 -> (grandson)
788 665c255d 2023-08-04 jrmu ;; ?x2 -> Enoch
789 665c255d 2023-08-04 jrmu ;; ?y1 -> ?y2
790 665c255d 2023-08-04 jrmu ;; (and (son Enoch ?z2)
791 665c255d 2023-08-04 jrmu ;; ((grandson) ?z2 ?y2))
792 665c255d 2023-08-04 jrmu ;; ?z2 -> Irad
793 665c255d 2023-08-04 jrmu ;; ((grandson) Irad ?y2)
795 665c255d 2023-08-04 jrmu ;; (assert! (son Adam Cain))
796 665c255d 2023-08-04 jrmu ;; (assert! (son Cain Enoch))
797 665c255d 2023-08-04 jrmu ;; (assert! (son Enoch Irad))
798 665c255d 2023-08-04 jrmu ;; (assert! (son Irad Mehujael))
799 665c255d 2023-08-04 jrmu ;; (assert! (son Mehujael Methushael))
800 665c255d 2023-08-04 jrmu ;; (assert! (son Methushael Lamech))
801 665c255d 2023-08-04 jrmu ;; (assert! (wife Lamech Ada))
802 665c255d 2023-08-04 jrmu ;; (assert! (son Ada Jabal))
803 665c255d 2023-08-04 jrmu ;; (assert! (son Ada Jubal))
805 665c255d 2023-08-04 jrmu (test-query '((great grandson) ?great-grandfather Irad)
806 665c255d 2023-08-04 jrmu '(((great grandson) Adam Irad)))
807 665c255d 2023-08-04 jrmu (test-query '((great great great great great grandson) Adam ?x)
808 665c255d 2023-08-04 jrmu '(((great great great great great grandson) Adam Jabal)
809 665c255d 2023-08-04 jrmu ((great great great great great grandson) Adam Jubal)))
810 665c255d 2023-08-04 jrmu ;; ((great great grandson
811 665c255d 2023-08-04 jrmu (test-query '((great grandson) ?g ?ggs))
812 665c255d 2023-08-04 jrmu (test-query '(?relationship Adam Irad))
813 665c255d 2023-08-04 jrmu ;; (test-query '((great grandson))
