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