-
Notifications
You must be signed in to change notification settings - Fork 8
/
arules.lisp
372 lines (324 loc) · 11.8 KB
/
arules.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
;; -*- Mode: Lisp; -*-
;;; Tiny Rule Engine, ATMS interface: Rules module
;; Last edited: 1/29/93, KDF
;; Copyright (c) 1992, Kenneth D. Forbus, Northwestern
;; University, and Johan de Kleer, the Xerox Corporation
;; All rights reserved.
;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty. The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.
(in-package :COMMON-LISP-USER)
(proclaim '(special *atre* *rule-procedures* *bound-vars*
*in-nodes* *imp-nodes*))
(defvar *bound-vars* nil) ;; Tracks lexical environment
(defvar *rule-procedures* nil) ;; while defining rules
(defvar *in-nodes* nil) ;; Part of rule triggering
(defvar *imp-nodes* nil) ;; environment.
(defvar *file-counter* 0)
(defvar *file-prefix* "")
(defmacro Rule-File (prefix)
`(eval-when (compile load eval)
(setq *file-counter* 0)
(setq *file-prefix* ,prefix)))
;;;; Defining rules
;;; <condition> = :INTERN | :IN | :IMPLIED-BY
;;; If you want to mix trigger types, use nested calls to RULE.
;; Trigger syntax is
;; (<pattern1> . <options for pattern1>
;; <pattern2> <options for pattern2> ...)
;; and <options> can be empty, or
;; :TEST <code> and/or :VAR <var>, where <code> must be
;; non-nil for the match to succeed, and <var> will be
;; bound to the whole pattern.
;; e.g., ((Queen ?x1 ?y1) :VAR ?f1
;; (Queen ?x1 ?y2) :VAR ?f2 :TEST (not (= ?y1 ?y2)))
(defmacro rule (condition trigger-list &rest body)
(do-rule condition (parse-triggers trigger-list) body))
(defun parse-triggers (trigger-list)
(cond ((null trigger-list) nil)
(t (multiple-value-bind (var test new-triggers)
(parse-trigger-options (cdr trigger-list) nil nil)
(cons (list (car trigger-list) var test)
(parse-triggers new-triggers))))))
(defun parse-trigger-options (triggers var test)
(case (car triggers)
(:VAR (parse-trigger-options
(cddr triggers) (cadr triggers) test))
(:TEST (parse-trigger-options
(cddr triggers) var (cadr triggers)))
(t (values var test triggers))))
;;;; Orchestrating the rule expansion
(defun do-rule (condition triggers body)
(let ((*rule-procedures* nil)
(*bound-vars* nil)
(index-form nil))
(setq index-form
(build-rule
condition (car triggers)
(subst 'internal-rule 'rule
(make-nested-rule
condition (cdr triggers) body))))
`(progn ,@ *rule-procedures* ,index-form)))
(defmacro internal-rule (condition triggers-in &rest body)
(let ((triggers (parse-triggers triggers-in)))
`(add-internal-rule
,condition ,(car triggers)
,(make-nested-rule condition (cdr triggers) body))))
(defun make-nested-rule (condition triggers body)
(cond ((null triggers) body)
(t `((add-internal-rule ,condition
,(car triggers)
,(make-nested-rule
condition (cdr triggers) body))))))
(defmacro add-internal-rule (condition trigger body)
(build-rule condition trigger body))
;;;; Building rules
(defun build-rule (condition trigger body
&aux match-procedure
body-procedure)
(let ((pattern (car trigger))
(var (cadr trigger))
(test (caddr trigger)))
(setq match-procedure
(generate-match-procedure
pattern var test condition))
(setq body-procedure
(generate-body-procedure
pattern condition var body))
(push match-procedure *rule-procedures*)
(push body-procedure *rule-procedures*)
`(insert-rule
(get-dbclass ,(get-trigger-dbclass pattern))
;return form to index rule
,(if *bound-vars* ;the match function for rule
`(function (lambda (p)
(,(cadr match-procedure) p ,@ *bound-vars*)))
`(function ,(cadr match-procedure)))
(function ;;the body function for rule
,(if (or *bound-vars*
(not (eq condition :INTERN)))
(let ((tv (nreverse
(pattern-free-variables trigger))))
(unless (eq condition :INTERN)
(push 'TRIGGER-NODE tv))
`(lambda ,tv
(,(cadr body-procedure) ,@ tv
;(fn-name parameters)
,@ (scratchout tv *bound-vars*))))
(cadr body-procedure)))
*in-nodes*
*imp-nodes*)))
(defun get-trigger-dbclass (trigger)
(cond ((null trigger) (error "Null trigger in ATRE rule"))
((variable? trigger)
(if (member trigger *bound-vars*) trigger
(error "~%Trigger dbclass is unbound -- ~A."
trigger)))
((symbolp trigger) (list 'QUOTE trigger))
((listp trigger) (get-trigger-dbclass (car trigger)))
(t (error
"ATRE rule trigger must be symbol or list: ~A" trigger))))
;;;; Generating the body procedure
(defmacro with-pushed-variable-bindings (new-bindings
&rest body)
;; generate-body-procedure needs this
`(let ((*bound-vars* (append ,new-bindings
(scratchout ,new-bindings
*bound-vars*))))
,@ body))
(defun generate-body-procedure (pattern condition var body
&aux newly-bound env fname)
(setq newly-bound (pattern-free-variables pattern))
(if var (push var newly-bound))
(setq body (with-pushed-variable-bindings
newly-bound (fully-expand-body body)))
(setq env (append newly-bound
(scratchout newly-bound *bound-vars*)))
(unless (eq condition :INTERN) (push 'trigger-node env))
(setq fname (generate-rule-procedure-name pattern))
`(defun ,fname ,env
,@ (cond ((eq condition :INTERN) body) ;; Just do it
(t ;; Must check and see if the node's belief state
;; matches the rule's requirements
`((cond ((,(case condition
(:IN 'tms-node-label)
(:IMPLIED-BY 'tms-node-label)
(t (error "~A bad condition -- GBF"
condition)))
TRIGGER-NODE) ,@ body)
(t (push (list ',fname ,@ env)
(tms-node-rules TRIGGER-NODE)))))))))
(defun generate-match-procedure (pattern var test condition)
(multiple-value-bind (tests binding-specs)
(generate-match-body
pattern (pattern-free-variables pattern) test)
`(defun ,(generate-rule-procedure-name pattern)
(P ,@ *bound-vars*)
;;first arg, P, is the pattern
(if (and ,@ tests)
(values
T ,(if (and (null var) (null binding-specs)) nil
`(list ,@ (if var '(P))
,@ (reverse binding-specs)))
,condition)))))
(defun scratchout (l1 l2)
;non-destructive and order-preserving
(dolist (el1 l1 l2) (setq l2 (remove el1 l2))))
(defun generate-rule-procedure-name (pattern)
(intern (format nil "~A-~A-~A"
*file-prefix* pattern (incf *file-counter*))))
;;;; Recursive macroexpansion
(defvar *macros-to-expand*
'(rule internal-rule add-internal-rule with-pushed-variable-bindings
rlet rassert! rnogood! with-focus with-ATRE))
(defun fully-expand-body (body)
(cond ((null body) nil)
((not (listp body)) body)
((symbolp (car body))
(cond ((member (car body) *macros-to-expand*)
(fully-expand-body (macroexpand body)))
(t (cons (car body)
(fully-expand-body (cdr body))))))
(t (cons (fully-expand-body (car body))
(fully-expand-body (cdr body))))))
;;;; Running rules
(defun insert-rule (dbclass matcher body in-nodes imp-nodes
&aux rule atre)
(setq atre (dbclass-atre dbclass))
(setq rule (make-rule
:MATCHER matcher
:ATRE atre
:BODY body
:DBCLASS dbclass
:COUNTER (incf (atre-rule-counter atre))
:IN-NODES in-nodes
:IMP-NODES imp-nodes))
;; Index it
(push rule (atre-rules atre))
(push rule (dbclass-rules dbclass))
(dolist (candidate (dbclass-facts dbclass))
(try-rule-on rule candidate)))
(defun try-rules (datum)
(dolist (rule (dbclass-rules (datum-dbclass datum)))
(try-rule-on rule datum)))
(defun try-rule-on (rule datum &aux a)
(setq a (datum-atre datum))
(multiple-value-bind (okay? bindings condition)
(funcall (rule-matcher rule) (datum-lisp-form datum))
(when okay?
(when (or (eq condition :IN)
(eq condition :IMPLIED-BY))
(push (datum-tms-node datum) bindings))
(enqueue (list (rule-body rule) bindings
(case condition
(:IN (cons
(cons (datum-tms-node datum)
(rule-in-nodes rule))
(rule-imp-nodes rule)))
(:IMPLIED-BY
(cons (rule-in-nodes rule)
(cons (datum-tms-node datum)
(rule-imp-nodes rule))))
(:INTERN
(cons (rule-in-nodes rule)
(rule-imp-nodes rule)))))
a))))
(defun run-rules (&optional (*atre* *atre*))
(setf (atre-queue *atre*)
(nconc (atre-queue *atre*)
(atre-in-rules *atre*)))
(setf (atre-in-rules *atre*) nil)
(do ((form (dequeue *atre*) (dequeue *atre*))
(counter 0 (1+ counter)))
((null form)
(debugging-atre "~% ~A rules run." counter)
(values counter
(incf (atre-rules-run *atre*) counter)))
(execute-rule form *atre*)))
;;;; Executing rules, checking for appropriate conditions
(defun execute-rule (queued-rule atre)
;; Now is (<procedure> <arguments> <node list>)
;; Check the node list before executing, to make sure
;; all the belief conditions are satisifed.
(let ((*in-nodes* (car (third queued-rule)))
(*imp-nodes* (cdr (third queued-rule))))
(unless (in-triggers-ready? *in-nodes* atre)
;; Re-queue under ATRE for checking.
;; ****** Introduce temporary nodes? Cache rules
;; ****** on justifications?
(push queued-rule (atre-in-rules atre))
(return-from EXECUTE-RULE nil))
(unless (implied-by-triggers-ready? *imp-nodes* atre)
(push queued-rule (atre-imp-rules atre))
(return-from EXECUTE-RULE nil))
;; Let's do it
(apply (car queued-rule) (cadr queued-rule))))
(defun in-triggers-ready?
(nodes atre &optional (env (atms-empty-env
(atre-atms atre))))
(cond ((env-nogood? env) nil) ;; Combination was nogood
((null nodes) t) ;; Nothing else to combine
(t (dolist (new (tms-node-label (car nodes)))
(let ((u (union-env new env)))
(if (in-triggers-ready? (cdr nodes) atre u)
(return-from IN-TRIGGERS-READY? t)))))))
(defun implied-by-triggers-ready? (nodes atre)
(or (null nodes) ;; No triggers, no problem
(and (focus-okay? atre)
(every #'(lambda (n)
(in-node? n (atre-focus atre)))
nodes))))
(defun rules-waiting? (atre) (atre-queue atre))
(defun enqueue (new a) (push new (atre-queue a)))
(defun dequeue (atre)
(if (atre-queue atre) (pop (atre-queue atre))))
;;;; Display routines
(defun show-rules (&optional (atre *atre*)
(stream *standard-output*)
&aux counter dist inc imp in
queued)
(setq counter 0)
(dolist (dbclass (atre-dbclasses atre))
(setq inc (length (dbclass-rules dbclass)))
(when (> inc 0)
(push (cons (dbclass-name dbclass) inc) dist)
(incf counter inc)))
(setq in (length (atre-in-rules atre))
imp (length (atre-imp-rules atre))
contra 0 queued (length (atre-queue atre)))
(setq counter (+ in imp counter))
(format stream "~% ~A has ~D rules in all."
(atre-title atre) counter)
(format stream "~% ~A queued."
(if (> queued 0) queued "None"))
(if (> (+ in imp contra) 0)
(format stream " Pending: ~A in, ~A implied-by."
(if (> in 0) in "No") (if (> imp 0) imp "No"))
(format stream " None pending."))
(when dist
(format stream "~% Cached under dbclasses:")
(dolist (entry dist)
(format stream "~% ~A: ~D"
(car entry) (cdr entry))))
atre)
(defun print-rules (&optional (atre *atre*)
(stream *standard-output*)
&aux counter)
(setq counter 0)
(format t "~%The rules in ~A are:" (atre-title atre))
(dolist (rule (atre-rules atre))
(incf counter)
(print-rule rule stream))
counter)
(defun print-rule
(rule &optional (stream *standard-output*))
(format stream "~% ~A: ~A, ~A"
rule (rule-matcher rule) (rule-body rule)))
(defun test-rule-expansion ()
(pprint (macroexpand
'(rule :IN ((implies ?p ?q) :VAR ?f1 ?p)
(rassert! ?q (:CE ?f1 ?p))))))
(defun get-rule (num &optional (atre *atre*))
(dolist (rule (atre-rules atre))
(when (= (rule-counter rule) num)
(return-from GET-RULE rule))))