bootstrap
view genesis/church/prolog/prolog-interpreter.church @ 616:723871f2f056
comment out more debug statements
fix up interpreter-test
fix up interpreter-test
| author | John Leuner <jewel@subvert-the-dominant-paradigm.net> |
|---|---|
| date | Sun Nov 22 12:55:44 2009 +0200 (2009-11-22) |
| parents | 1f65b82d6607 |
| children | 86100ecc2c5b |
line source
1 extern o-fail
3 class prolog-parser extends ometa
5 global prolog-fail = nil
6 global prolog-unbound = nil
7 global prolog-no-bindings = nil
9 global prolog-rules-map = nil
11 global occurs-check? = nil
13 init-prolog
14 prolog-fail = cons 'prolog-fail nil
15 prolog-unbound = cons 'prolog-unbound nil
16 prolog-no-bindings = list (cons true true)
18 clause-body clause
19 third clause
21 clause-head clause
22 second clause
24 class prolog-interpreter
25 with-slots
26 rules-map
27 init
28 self.rules-map = new 'native-dictionary
29 create self.rules-map 10
30 add-rule rule
31 head = second rule
32 body = third rule
33 name = first head
34 ; print "add-rule"
35 ; print rule
36 lookup = get self.rules-map name nil
37 if (null? lookup)
38 put self.rules-map name (list rule)
39 else
40 append! lookup (list rule)
41 dump-rules
42 keys = keys self.rules-map
43 print keys
44 loop
45 for key in keys
46 do
47 print "rule"
48 print (get-clauses self key)
50 get-clauses pred-name
51 get self.rules-map pred-name nil
52 run-query-with-file query prolog-file-name result-fn
53 parsed-forms = ometa-parse-array (read-file prolog-file-name) 'prolog-parser 'prolog-top-levels
54 ; print "parsed-forms"
55 ; print parsed-forms
56 loop
57 for form in parsed-forms
58 do
59 if (eq? (first form) 'rule)
60 add-rule self (normalize self form)
62 ; (dump-rules self)
63 apply result-fn (prove self (list 'and query) prolog-no-bindings)
64 normalize form
65 typecase form
66 cons
67 case (first form)
68 rule `[rule ,(second form) ,(normalize self (third form))]
69 or (simplify-conditional `[or ,[(normalize self f) for f in (second form)]])
70 and (simplify-conditional `[and ,[(normalize self f) for f in (second form)]])
71 implies `[implies ,(normalize self (second form)) ,(second (normalize self (third form)))]
72 else
73 cons (normalize self (first form)) (normalize self (rest form))
74 nil nil
75 else
76 form
78 simplify-conditional form
79 case (first form)
80 or
81 if (eq? (length (second form)) 1)
82 (simplify-conditional (first (second form)))
83 else
84 `[or ,[(simplify-conditional x) for x in (second form)]]
85 and
86 if (eq? (length (second form)) 1)
87 (simplify-conditional (first (second form)))
88 else
89 `[and ,[(simplify-conditional x) for x in (second form)]]
90 else
91 form
93 variable-symbol? var
94 and (symbol? var) (uppercase-letter? (char-at (coerce var 'string) 0))
96 unify x y bindings
97 ; print "unify "
98 ; print bindings
99 ; print x
100 ; print y
101 cond
102 (eq? bindings prolog-fail) prolog-fail
103 (eq? x y) bindings
104 (eq? x '_) bindings
105 (eq? y '_) bindings
106 (variable-symbol? x) (unify-variable x y bindings)
107 (variable-symbol? y) (unify-variable y x bindings)
108 (and (cons? x) (cons? y)) (unify (rest x) (rest y) (unify (first x) (first y) bindings))
109 true prolog-fail
112 unify-variable var x bindings
113 ; print "unify-variable "
114 ; print var
115 ; print x
116 cond
117 (get-binding var bindings) (unify (lookup var bindings) x bindings)
118 (and (variable-symbol? x) (get-binding x bindings)) (unify var (lookup x bindings) bindings)
119 (and occurs-check? (occurs-check var x bindings)) prolog-fail
120 true (extend-bindings var x bindings)
122 occurs-check var x bindings
123 cond
124 (eq? var x) true
125 (and (variable-symbol? x) (get-binding x bindings)) (occurs-check var (lookup x bindings) bindings)
126 (cons? x) (or (occurs-check var (first x) bindings) (occurs-check var (rest x) bindings))
127 true nil
129 extend-bindings var val bindings
130 cons (cons var val) (if (eq? bindings prolog-no-bindings) nil bindings)
132 subst-bindings bindings x
133 cond
134 (eq? bindings prolog-fail) prolog-fail
135 (eq? bindings prolog-no-bindings) x
136 (and (variable-symbol? x) (get-binding x bindings)) (subst-bindings bindings (lookup x bindings))
137 (not (cons? x)) x
138 true (reuse-cons (subst-bindings bindings (first x)) (subst-bindings bindings (rest x)) x)
140 reuse-cons x y x-y
141 if (and (eq? (first x-y) x) (eq? (rest x-y) y))
142 x-y
143 else
144 cons x y
146 binding-val binding
147 cdr binding
149 lookup var bindings
150 binding-val (get-binding var bindings)
152 get-binding var bindings
153 assoc var bindings
155 ; interpreter
157 prove-or pi:prolog-interpreter form bindings
158 assert (eq? (first form) 'or) "bad or"
159 mapcan (fn clause
160 prove pi clause bindings
161 ) (second form)
163 prove pi:prolog-interpreter goals bindings
164 ; print "prove"
165 ; print goals
166 ; print bindings
167 cond
168 (eq? bindings prolog-fail) nil
169 (null? goals) (list bindings)
170 true
171 case (first goals)
172 or
173 prove-or pi goals bindings
174 and
175 prove-all pi (second goals) bindings
176 implies
177 prove-implies pi goals bindings
178 else
179 if (eq? (first goals) 'not)
180 result = prove pi (second goals) bindings
181 ; print "not result"
182 ; print result
183 ; print bindings
184 if (null? result)
185 list bindings
186 else
187 nil
188 else
189 mapcan (fn clause
190 new-clause = rename-variables clause
191 ; print "new clause"
192 ; print new-clause
193 prove pi (clause-body new-clause) (unify goals (clause-head new-clause) bindings)
194 ) (get-clauses pi (first goals))
197 prove-implies pi:prolog-interpreter goal bindings
198 result = prove pi (second goal) bindings
199 ; print "prove-implies result"
200 ; print result
201 consequent = first (third goal)
202 alternate = second (third goal)
203 if (null? result)
204 prove pi alternate bindings
205 else
206 mapcan (fn goal1-solution
207 prove-all pi (rest result) goal1-solution
208 ) (prove pi consequent (first result))
210 prove-all pi:prolog-interpreter goals bindings
211 ; print "prove-all"
212 ; print goals
213 ; print bindings
214 cond
215 (eq? bindings prolog-fail) nil
216 (null? goals) (list bindings)
217 true
218 mapcan (fn goal1-solution
219 prove-all pi (rest goals) goal1-solution
220 ) (prove pi (first goals) bindings)
222 rename-variables x
223 sublis (mapcar (fn var -- cons var (gensym (coerce var 'string))) (variables-in x)) x
225 unique-find-anywhere-if predicate tree found-so-far
226 if (cons? tree)
227 unique-find-anywhere-if predicate (first tree) (unique-find-anywhere-if predicate (rest tree) found-so-far)
228 else
229 if (apply predicate tree)
230 push-new tree found-so-far
231 else
232 found-so-far
234 variables-in exp
235 unique-find-anywhere-if (fn x -- variable-symbol? x) exp nil
237 top-level-prove pi:prolog-interpreter goals
238 show-prolog-solutions (variables-in goals) (prove pi (list 'and goals) prolog-no-bindings)
240 show-prolog-solutions vars solutions
241 if (null? solutions)
242 print "No. "
243 else
244 loop
245 for sol in solutions
246 do
247 show-prolog-vars vars sol
249 nil
251 show-prolog-vars vars bindings
252 if (null? vars)
253 print "Yes"
254 else
255 loop
256 for v in vars
257 do
258 out v
259 out " = "
260 print (subst-bindings bindings v)
262 print ";"