Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 710 lines (624 sloc) 29.318 kB
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
1 ; Maruseac Mihai, 341C3
2
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ; README - TODO
5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ; GLOBAL AUXILIARY FUNCS
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26d6890 @mihaimaruseac N-am chef de comments
authored
10
11 ; first, convert to Haskel-ish notations
7f88a15 @mihaimaruseac Apply
authored
12 (require srfi/1)
13 (define (oldtake l n) (take l n))
14 (define (olddrop l n) (drop l n))
26d6890 @mihaimaruseac N-am chef de comments
authored
15
16 ; some auxiliary functions, used below
7f88a15 @mihaimaruseac Apply
authored
17 (define (nub-aux l seen) (if (null? l) seen (if (elem? (car l) seen) (nub-aux (cdr l) seen) (nub-aux (cdr l) (cons (car l) seen)))))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
18 (define (stringCompare s1 s2) (string<? s1 s2))
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
19 (define (listCompare l1 l2) (if (null? l1) #t (if (= (car l1) (car l2)) (listCompare (cdr l1) (cdr l2)) (< (car l1) (car l2)))))
608d18d @mihaimaruseac Instantiation of all ops
authored
20
21 ; and and or with list arguments
22 (define (andList l) (foldl (lambda (x y) (and x y)) #t l))
23 (define (orList l) (foldl (lambda (x y) (or x y)) #f l))
24
25 ; Haskell-ish take and drop
7f88a15 @mihaimaruseac Apply
authored
26 (define (take n l) (oldtake l n))
27 (define (drop n l) (olddrop l n))
608d18d @mihaimaruseac Instantiation of all ops
authored
28
29 ; safe call of car -> returns '() if there's no answer
7f88a15 @mihaimaruseac Apply
authored
30 (define (head l) (if (null? l) '() (car l)))
608d18d @mihaimaruseac Instantiation of all ops
authored
31
32 ; nubify = remove duplicates
7f88a15 @mihaimaruseac Apply
authored
33 (define (nub l) (reverse (nub-aux l '())))
608d18d @mihaimaruseac Instantiation of all ops
authored
34
35 ; repeat
36 (define (repeat x n) (if (>= 0 n) '() (cons x (repeat x (- n 1)))))
37
38 ; Haskell-ish append, used below to implement set addition
0a3585e @mihaimaruseac Apply of a simple test plan
authored
39 (define ++ (lambda l (apply append l)))
40 (define +++ (lambda l (nub (apply ++ l))))
608d18d @mihaimaruseac Instantiation of all ops
authored
41
42 ; Set removal
7f88a15 @mihaimaruseac Apply
authored
43 (define (-- l1 l2) (filter (lambda (x) (not (elem? x l2))) l1))
608d18d @mihaimaruseac Instantiation of all ops
authored
44
6db68fa @mihaimaruseac Eval at OR nodes
authored
45 ; Interesction
46 (define (^ l1 l2) (filter (lambda (x) (elem? x l2)) l1))
47
608d18d @mihaimaruseac Instantiation of all ops
authored
48 ; Cartesian products and multiple-list applications
49 (define (cAp2 f x l2) (map f (repeat x (length l2)) l2))
50 (define (cAp f l1 l2) (if (null? l1) '() (append (cAp2 f (car l1) l2) (cAp f (cdr l1) l2))))
51 (define (**2 l1 l2) (cAp (lambda (x y) (if (list? y) (cons x y) (cons x (list y)))) l1 l2))
52 (define (** l) (if (< (length l) 2) '() (if (= (length l) 2) (**2 (car l) (cadr l)) (**2 (car l) (** (cdr l))))))
53
54 ; Set predicates
7f88a15 @mihaimaruseac Apply
authored
55 (define (elem? x l) (if (null? l) #f (if (equal? x (car l)) #t (elem? x (cdr l)))))
56 (define (in? l1 l2) (andList (map (lambda (x) (elem? x l2)) l1)))
608d18d @mihaimaruseac Instantiation of all ops
authored
57 (define (== l1 l2) (and (in? l1 l2) (in? l2 l1)))
7f88a15 @mihaimaruseac Apply
authored
58
8155666 @mihaimaruseac Fix handling unobtainable preconditions
authored
59 ; Not null (stupid syntax for filter)
60 (define (notnull? l) (not (null? l)))
61
608d18d @mihaimaruseac Instantiation of all ops
authored
62 ; test if symbol is variable
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
63 (define (variable? s) (char-upper-case? (first (string->list (symbol->string s)))))
608d18d @mihaimaruseac Instantiation of all ops
authored
64
65 ; substitution rule and unifications
0a3585e @mihaimaruseac Apply of a simple test plan
authored
66 (define (substTerm x bindName bindValue) (if (equal? x bindName) bindValue x))
608d18d @mihaimaruseac Instantiation of all ops
authored
67 (define (unify vals vars) (if (= (length vals) (length vars)) (unify-aux vals vars) '()))
e33db2b @mihaimaruseac Opr
authored
68
608d18d @mihaimaruseac Instantiation of all ops
authored
69 (define (unify-aux vals vars)
70 (if (null? vals) '()
71 (if (variable? (car vars)) (cons (cons (car vars) (car vals)) (unify-aux (cdr vals) (cdr vars)))
72 (cons (cons (car vars) (car vars)) (unify-aux (cdr vals) (cdr vars)))))
73 )
0a3585e @mihaimaruseac Apply of a simple test plan
authored
74
608d18d @mihaimaruseac Instantiation of all ops
authored
75 ; transform one list of predicates (state) to a canonicalStateForm
0a3585e @mihaimaruseac Apply of a simple test plan
authored
76 (define (canonicalStateForm state) (sort state (lambda (p1 p2) (stringCompare (symbol->string (predName p1)) (symbol->string (predName p2))))))
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
77
608d18d @mihaimaruseac Instantiation of all ops
authored
78 ; define OO constant and undefined constant
79 (define OO 'OO)
80 (define UN '?)
81
b104f04 @mihaimaruseac new tests
authored
82 ; more cadddr goodies
83 (define (caddddr l) (car (cddddr l)))
84
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86 ; OPERATOR AUXILIARY FUNCS
87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
608d18d @mihaimaruseac Instantiation of all ops
authored
88
89 ; record accesors
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
90 (define (opName op) (caar op))
91 (define (opVars op) (cdar op))
92 (define (opPred op) (cadr op))
93 (define (opAdd op) (cadddr op))
94 (define (opDel op) (caddr op))
95
608d18d @mihaimaruseac Instantiation of all ops
authored
96 ; locators
7f88a15 @mihaimaruseac Apply
authored
97 (define (opFindName name opList) (head (filter (lambda (x) (equal? (opName x) name)) opList)))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
98 (define (opFindNameArg name vars opList) (head (filter (lambda (x) (and (equal? (opName x) name) (equal? (opVars x) vars))) opList)))
884f09e @mihaimaruseac Op ins
authored
99 (define (opFindResult pred opList) (if (null? opList) '() (+++ (getAllInstantiations pred (car opList)) (opFindResult pred (cdr opList)))))
100 (define (opFullInstance ops goal world) (opFullWorld world (opFullGoal goal ops)))
6db68fa @mihaimaruseac Eval at OR nodes
authored
101 (define (opExists? pred opList) (if (null? (opFindResult pred opList)) #f #t))
7f88a15 @mihaimaruseac Apply
authored
102
60ad3f9 @mihaimaruseac Obtain of ops
authored
103 (define (opObtainable? op init opList)
104 (let*
105 (
106 (needSet (opPred op))
107 (notGiven (-- needSet init))
108 )
109 (andList (map (lambda (x) (opExists? x opList)) notGiven))
110 )
111 )
112
a4ce80f @mihaimaruseac Hanoi solved
authored
113 (define (opValid? op)
114 (let*
115 (
116 (needSet (opPred op))
117 (addSet (opAdd op))
118 (delSet (opDel op))
119 (disjunctAddDel? (null? (^ addSet delSet)))
120 (unknownDel? (null? (-- delSet needSet)))
121 )
122 (and disjunctAddDel? unknownDel?)
123 )
124 )
125
608d18d @mihaimaruseac Instantiation of all ops
authored
126 ; applications
7f88a15 @mihaimaruseac Apply
authored
127 (define (opApply op state) (predList+ (predList- state (opDel op)) (opAdd op)))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
128 (define (opApplicable? op state) (and (opInstantiated? op) (in? (opPred op) state)))
129
608d18d @mihaimaruseac Instantiation of all ops
authored
130 ; instantiations and bindings
131 (define (opInstantiated? op) (not (orList (map variable? (opVars op)))))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
132 (define (opInstance op bindings) (foldl opBindVarVal op bindings))
e33db2b @mihaimaruseac Opr
authored
133
0a3585e @mihaimaruseac Apply of a simple test plan
authored
134 (define (opBindVarVal bind op)
135 (let*
136 (
137 (oldName (opName op))
138 (oldVars (opVars op))
139 (bindName (car bind))
140 (bindValue (cdr bind))
141 (oldPred (opPred op))
142 (oldAdd (opAdd op))
143 (oldDel (opDel op))
144 (newVars (map (lambda (x) (substTerm x bindName bindValue)) oldVars))
608d18d @mihaimaruseac Instantiation of all ops
authored
145 (newPred (map (lambda (x) (predSubst x bindName bindValue)) oldPred))
146 (newAdd (map (lambda (x) (predSubst x bindName bindValue)) oldAdd))
147 (newDel (map (lambda (x) (predSubst x bindName bindValue)) oldDel))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
148 )
149 (list (cons oldName newVars) newPred newDel newAdd)
150 )
151 )
e33db2b @mihaimaruseac Opr
authored
152
608d18d @mihaimaruseac Instantiation of all ops
authored
153 (define (getAllInstantiations pred op)
154 (let*
155 (
156 (results (opAdd op))
157 (pName (predName pred))
158 (relevantResults (filter (lambda (p) (equal? pName (predName p))) results))
159 (relevantBindings (map (lambda (R) (unify (predArgs pred) (predArgs R))) relevantResults))
160 (obtainedOps (map (lambda (b) (opInstance op b)) relevantBindings))
161 )
162 obtainedOps
163 )
164 )
e33db2b @mihaimaruseac Opr
authored
165
884f09e @mihaimaruseac Op ins
authored
166 (define (opFullGoal goal l) (apply +++ (map (lambda (x) (opFullInstancesGoal x goal)) l)))
e33db2b @mihaimaruseac Opr
authored
167
608d18d @mihaimaruseac Instantiation of all ops
authored
168 (define (opFullInstancesGoal op goal)
5f61440 @mihaimaruseac Started BW
authored
169 ; (display "\nMMMMM\n")
170 ; (opPrint op)
171 ; (display (opInstantiated? op))
172 ; (newline)
173 ; (display "\nMMMMM\n")
174 (if (opInstantiated? op) (list op)
608d18d @mihaimaruseac Instantiation of all ops
authored
175 (let
176 (
177 (firstUnInstPred (head (filter (lambda (p) (not (predInstantiated? p))) (opAdd op))))
178 )
5f61440 @mihaimaruseac Started BW
authored
179 ; (display "\nMMMMM\n")
180 ; (display "X")
181 ; (newline)
182 ; (display "\nMMMMM\n")
183 (if (null? firstUnInstPred) (list op)
608d18d @mihaimaruseac Instantiation of all ops
authored
184 (let*
185 (
186 (fUIPName (predName firstUnInstPred))
187 (instancesInGoal (filter (lambda (p) (equal? (predName p) fUIPName)) goal))
188 (relevantBindings (map (lambda (R) (unify (predArgs R) (predArgs firstUnInstPred))) instancesInGoal))
189 (results (map (lambda (b) (opInstance op b)) relevantBindings))
190 )
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
191 (if (null? instancesInGoal) (list op)
192 (map (lambda (o) (opFullInstancesGoal o goal)) results)
193 ))))
608d18d @mihaimaruseac Instantiation of all ops
authored
194 )
195 )
e33db2b @mihaimaruseac Opr
authored
196
a4ce80f @mihaimaruseac Hanoi solved
authored
197 (define (opFullWorld world l) (filter opValid? (apply +++ (map (lambda (x) (opFullInstancesWorld x world)) l))))
e33db2b @mihaimaruseac Opr
authored
198
884f09e @mihaimaruseac Op ins
authored
199 ; the following function should return quickly in a normal implementation
e33db2b @mihaimaruseac Opr
authored
200 (define (opFullInstancesWorld op world) (if (opInstantiated? op) (list op) (map (lambda (b) (opInstance op b)) (getAllBindings (opVars op) world))))
201 (define (getAllBindings args world) (let ((lists (map (lambda (v) (if (variable? v) (map (lambda (x) (cons v x)) world) (list (cons v v)))) args))) (** lists)))
608d18d @mihaimaruseac Instantiation of all ops
authored
202
203 ; printing
204 (define (opPrint op)
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
205 (display (opName op))(display ": ")
206 (display (opVars op))(newline)
207 (display (opPred op))(newline)
208 (display (opDel op))(newline)
209 (display (opAdd op))(newline)
210 op
211 )
212
608d18d @mihaimaruseac Instantiation of all ops
authored
213 ; test
214 (define opTest '(
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
215 (move A B C)
216 ((disc A) (clear A) (on A B) (smaller A C) (clear C))
217 ((on A B) (clear C))
7f88a15 @mihaimaruseac Apply
authored
218 ((on A C) (clear B))
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
219 ))
220
221 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
222 ; PREDICATE AUXILIARY FUNCS
223 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
608d18d @mihaimaruseac Instantiation of all ops
authored
224
225 ; record accessors
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
226 (define (predName pred) (car pred))
227 (define (predArgs pred) (cdr pred))
228
608d18d @mihaimaruseac Instantiation of all ops
authored
229 ; add and removal from state
0a3585e @mihaimaruseac Apply of a simple test plan
authored
230 (define (predList+ l1 l2) (+++ l1 l2))
7f88a15 @mihaimaruseac Apply
authored
231 (define (predList- l1 l2) (-- l1 l2))
232
608d18d @mihaimaruseac Instantiation of all ops
authored
233 ; substitutions
234 (define (predInstantiated? p) (not (orList (map variable? (predArgs p)))))
235 (define (predSubst pred bindName bindValue) (map (lambda (x) (substTerm x bindName bindValue)) pred))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
236
608d18d @mihaimaruseac Instantiation of all ops
authored
237 ; printing
238 (define (predPrint pred)
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
239 (display (predName pred))(display ": ")
240 (display (predArgs pred))(newline)
241 pred
242 )
243
608d18d @mihaimaruseac Instantiation of all ops
authored
244 ; test
245 (define predTest '(smaller d2 p1))
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
246
247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
248 ; ACTION AUXILIARY FUNCS
249 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
608d18d @mihaimaruseac Instantiation of all ops
authored
250
251 ; record accessors
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
252 (define (actName act) (car act))
253 (define (actArgs act) (cdr act))
254
608d18d @mihaimaruseac Instantiation of all ops
authored
255 ; applications
7f88a15 @mihaimaruseac Apply
authored
256 (define (actApply act state opList)
257 (let*
258 (
259 (name (actName act))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
260 (arg (actArgs act))
261 (op (opFindNameArg name arg opList))
7f88a15 @mihaimaruseac Apply
authored
262 )
0a3585e @mihaimaruseac Apply of a simple test plan
authored
263 (if (null? op)
264 (begin (display "### Trying to apply unknown/non-instantiated op: ")(newline)
608d18d @mihaimaruseac Instantiation of all ops
authored
265 (actPrint act)(display "=> (ACT IGNORED)")(newline)
0a3585e @mihaimaruseac Apply of a simple test plan
authored
266 state)
267 (if (opApplicable? op state) (opApply op state)
268 (begin (display "### Error on applying op: ")(newline)
608d18d @mihaimaruseac Instantiation of all ops
authored
269 (opPrint op)(display "=> (OP IGNORED)")(newline)
0a3585e @mihaimaruseac Apply of a simple test plan
authored
270 state)))
7f88a15 @mihaimaruseac Apply
authored
271 )
272 )
273
608d18d @mihaimaruseac Instantiation of all ops
authored
274 ; printing
275 (define (actPrint act)
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
276 (display (actName act))(display ": ")
277 (display (actArgs act))(newline)
278 act
279 )
280
608d18d @mihaimaruseac Instantiation of all ops
authored
281 ; test
282 (define actTest '(move d1 d2 p3))
0a3585e @mihaimaruseac Apply of a simple test plan
authored
283 (define testInitState '((disc d1) (disc d2)
284 (smaller d2 p1) (smaller d2 p2) (smaller d2 p3) (smaller d1 d2) (smaller d1 p1) (smaller d1 p2) (smaller d1 p3)
285 (clear d1) (clear p2) (clear p3)
286 (on d1 d2) (on d2 p1)))
287 (define testBindings1 '((A . a)))
288 (define testBindings2 '((A . a) (B . b) (C . c)))
289 (define testBindings3 '((A . d1) (B . d2) (C . p3)))
290
291 ; test for first day of work: Test if all functions needed for plan application are succesful.
292 (display "Test plan apply ")
608d18d @mihaimaruseac Instantiation of all ops
authored
293 (if (== (canonicalStateForm (actApply actTest testInitState
294 (list (opInstance opTest testBindings1) (opInstance opTest testBindings2) (opInstance opTest testBindings3))))
295 '(
296 (clear d1) (clear p2) (clear d2)
297 (disc d1) (disc d2)
298 (on d2 p1) (on d1 p3)
299 (smaller d2 p1) (smaller d2 p2) (smaller d2 p3) (smaller d1 d2) (smaller d1 p1) (smaller d1 p2) (smaller d1 p3)
300 )
301 )
0a3585e @mihaimaruseac Apply of a simple test plan
authored
302 (display "passed") (display "failed"))
303 (newline)
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
304
305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
608d18d @mihaimaruseac Instantiation of all ops
authored
306 ; AND NODE AUXILIARY FUNCS
307 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
308
309 ; Each AND node is a list of predicates
310
311 ; expanding: create OR nodes with empty desirability slot
456e3e0 @mihaimaruseac AND exp
authored
312 (define (andExpand n opList init world) (apply +++ (map (lambda(x) (andExpandOPR x opList n init world)) n)))
313
314 (define (andExpandOPR n opList goal init world)
315 (let*
316 (
317 (ornode (cons desEmpty (list n)))
318 (expansion (orExpand ornode opList goal init world))
319 )
320 expansion
321 )
322 )
608d18d @mihaimaruseac Instantiation of all ops
authored
323
324 ; printing
325 (define (andPrint n)
326 (display "AND node: ")(newline)
327 (map predPrint n)
328 (display "END AND node")(newline)
329 n
330 )
331
332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 ; OR NODE AUXILIARY FUNCS
334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335
336 ; each OR node contains one predicate and one desirability slot
337 (define (orPred n) (cadr n))
338 (define (orDes n) (car n))
339
340 ; expanding: create OPR nodes with empty desirability slot
6db68fa @mihaimaruseac Eval at OR nodes
authored
341 (define (orExpand n opList goal init worldObjects)
e33db2b @mihaimaruseac Opr
authored
342 (let*
343 (
344 (ops (opFullInstance (opFindResult (orPred n) opList) goal worldObjects))
60ad3f9 @mihaimaruseac Obtain of ops
authored
345 (goodOps (filter (lambda (x) (opObtainable? x init opList)) ops))
346 (l (length goodOps))
6db68fa @mihaimaruseac Eval at OR nodes
authored
347 )
60ad3f9 @mihaimaruseac Obtain of ops
authored
348 (map (lambda (o) (makeOPR o goal init opList l)) goodOps)
6db68fa @mihaimaruseac Eval at OR nodes
authored
349 )
350 )
351
352 (define (makeOPR op goal init opList l)
353 (let*
354 (
355 (killSet (^ (opDel op) goal))
356 (kv (length killSet))
357 (genSet (^ (opAdd op) goal))
358 (gv (length genSet))
359 (needSet (opPred op))
360 (inGoal (^ needSet goal))
361 (czv (length inGoal))
362 (given (^ needSet init))
363 (ifcv (length given))
e33db2b @mihaimaruseac Opr
authored
364 )
60ad3f9 @mihaimaruseac Obtain of ops
authored
365 (cons (list l kv gv czv ifcv) (list op))
e33db2b @mihaimaruseac Opr
authored
366 )
367 )
608d18d @mihaimaruseac Instantiation of all ops
authored
368
369 ; printing
370 (define (orPrint n)
371 (display "OR node: ")(display (orPred n))(display " ")(desPrint (orDes n))(newline)
372 n
373 )
374
375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
376 ; OPR NODE AUXILIARY FUNCS
377 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
378
379 ; record accessors
e33db2b @mihaimaruseac Opr
authored
380 (define (oprOp opr) (cadr opr))
381 (define (oprDes opr) (car opr))
382
383 ; printing
384 (define (oprPrint opr)
385 (display "OPR node: ")(desPrint (oprDes opr))(newline)(opPrint (oprOp opr))(newline)
386 opr
387 )
608d18d @mihaimaruseac Instantiation of all ops
authored
388
389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
390 ; DESIRABILITY AUXILIARY FUNCS
391 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
392
393 ; record accessors
394 (define (desOp d) (car d))
b104f04 @mihaimaruseac new tests
authored
395 (define (desKill d) (cadr d))
396 (define (desGen d) (caddr d))
397 (define (desCz d) (cadddr d))
398 (define (desIFc d) (caddddr d))
608d18d @mihaimaruseac Instantiation of all ops
authored
399
6db68fa @mihaimaruseac Eval at OR nodes
authored
400 ; setters
401 (define (desSetOp d v) (++ (take 0 d) (list v) (drop 1 d)))
402 (define (desSetKill d v) (++ (take 1 d) (list v) (drop 2 d)))
403 (define (desSetGen d v) (++ (take 2 d) (list v) (drop 3 d)))
404 (define (desSetCz d v) (++ (take 3 d) (list v) (drop 4 d)))
405 (define (desSetIFc d v) (++ (take 4 d) (list v) (drop 5 d)))
406 (define (desSetORLevel d opv) (desSetOp d opv))
407 (define (desSetOPRLevel d killv genv) (desSetKill (desSetGen d genv) killv))
408 (define (desSetANDLevel d czv ifcv) (desSetCz (desSetIFc d ifcv) czv))
409 (define (desSetOPRANDLevel d killv genv czv ifcv) (desSetANDLevel (desSetOPRLevel d killv genv) czv ifcv))
410
608d18d @mihaimaruseac Instantiation of all ops
authored
411 ; construct empty slot
b104f04 @mihaimaruseac new tests
authored
412 (define desEmpty (list UN UN UN UN UN))
608d18d @mihaimaruseac Instantiation of all ops
authored
413
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
414 ; get heuristic value / compare
608d18d @mihaimaruseac Instantiation of all ops
authored
415 (define (desEval d) OO)
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
416 (define (desSort d1 d2)
417 (let*
418 (
419 (dO1 (desOp d1))
420 (dK1 (desKill d1))
421 (dG1 (desGen d1))
422 (dC1 (desCz d1))
423 (dI1 (desIFc d1))
424 (dO2 (desOp d2))
425 (dK2 (desKill d2))
426 (dG2 (desGen d2))
427 (dC2 (desCz d2))
428 (dI2 (desIFc d2))
429 )
430 (listCompare (list dO1 dC1 dI2) (list dO2 dC2 dI1))
431 )
432 )
608d18d @mihaimaruseac Instantiation of all ops
authored
433
434 ; printing
435 (define (desPrint d)
436 (display "op = ")(display (desOp d))(display "; ")
b104f04 @mihaimaruseac new tests
authored
437 (display "kill = ")(display (desKill d))(display "; ")
438 (display "gen = ")(display (desGen d))(display "; ")
439 (display "cz = ")(display (desCz d))(display "; ")
440 (display "IFc = ")(display (desIFc d))(display "; ")
608d18d @mihaimaruseac Instantiation of all ops
authored
441 d
442 )
443
444 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
445 ; IMPLEMENTATION FUNCTIONS
446 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447
448 ; main func - call the defined funcs
3d1e183 @mihaimaruseac Hanoi tweaked
authored
449 (define (solve opList init scope) (solveTF opList init scope #t))
450
451 (define (solveTF opList init scope tryAgain?)
452 (if (null? (-- scope init))
453 '() ; no plan if all is given
454 (let
455 (
456 (return (solveGoal scope opList init (worldObjects init scope)))
457 )
458 (if (null? return)
459 '() ; no plan if goal impossible to achieve
460 (let
461 (
462 (oplist (car return))
463 (state (cadr return))
464 )
465 (display "MAIN:\n")(display scope)(newline)
466 (display oplist)(newline)
467 (display state)
468 (display "\nSOLUTION:")
469 (if tryAgain?
ad82846 @mihaimaruseac Hanoi tweaked 2
authored
470 (append oplist (solveTF opList state (-- scope state) #f))
3d1e183 @mihaimaruseac Hanoi tweaked
authored
471 oplist
472 )
473 )
474 )
475 )
476 )
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
477 )
478
a4ce80f @mihaimaruseac Hanoi solved
authored
479 ; return list of operators needed to solve a goal paired with the new state
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
480 (define (solveGoal g opList given world)
a4ce80f @mihaimaruseac Hanoi solved
authored
481 (newline)(newline)
482 (display "solveGoal called with ")(newline)
483 (display "g:")(display g)(newline)
484 (display "given:")(display given)(newline)
485 (newline)(newline)
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
486 (let*
487 (
488 (exp (andExpand g opList given world))
489 (sortedExp (sort exp altSort))
a4ce80f @mihaimaruseac Hanoi solved
authored
490 (result (tryExpansion sortedExp opList g given world))
491 (expansionSuccessful? (car result))
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
492 )
a4ce80f @mihaimaruseac Hanoi solved
authored
493 (display ">>>>>>>>>>>>>\n")(display result)(display "<<<<<<<<<<\n")
494 (if expansionSuccessful?
495 ; if we have a result, check if we have more subgoals
496 (let*
497 (
498 (returnedData (cdr result))
499 (oplist (car returnedData))
500 (newState (cadr returnedData))
501 (stillToSolve (-- g newState))
502 )
503 (display "sTS")(display stillToSolve)(newline)
504 (if (null? stillToSolve)
505 ; if completely solved, return result
506 (cdr result)
507 ; else, search again, new goal, other state
508 (let*
509 (
510 (nextResult (solveGoal stillToSolve opList newState world))
511 (ret_oplist (car nextResult))
512 (ret_newState (cadr nextResult))
513 (now_op (car returnedData))
514 )
515 (display"\n.......................\n")
516 (display nextResult)(newline)
517 (display ret_oplist)(newline)
518 (display ret_newState)(newline)
519 (display now_op)(newline)
520 (display"\n.......................\n")
521 (list (++ now_op ret_oplist) ret_newState)
522 )
523 )
524 )
3d1e183 @mihaimaruseac Hanoi tweaked
authored
525 '() ; return empty list if failed to solve
a4ce80f @mihaimaruseac Hanoi solved
authored
526 )
c9b2d18 @mihaimaruseac Aux functions from EBNF syntax
authored
527 )
528 )
608d18d @mihaimaruseac Instantiation of all ops
authored
529
a4ce80f @mihaimaruseac Hanoi solved
authored
530 ; return list (#t/#f oplist new_state)
531 (define (tryExpansion alternatives opList g given world)
532 (newline)(newline)
533 (display "tryExpansion called with ")(newline)
534 (display "alternatives:")(display alternatives)(newline)
535 (display "given:")(display given)(newline)
536 (newline)(newline)
3d1e183 @mihaimaruseac Hanoi tweaked
authored
537 (if (null? alternatives)
538 (list #f '() '())
539 (let*
540 (
541 (best (car alternatives))
542 (op (oprOp best))
543 (preCond (opPred op))
544 (Add (opAdd op))
545 (stillToProve (-- preCond given))
546 )
547 (display stillToProve)(display "<---- stillToProve\n")
548 (if (null? stillToProve)
549 ; if successful, return (#t (list op) newstate)
550 (list #t (list (car op)) (opApply op given))
551 ; if unknown, try to expand one more level
552 (let*
553 (
554 (nextLevel (solveGoal stillToProve opList given world))
555 )
556 ; (display sortedExp)(newline)
557 (if (null? nextLevel)
ad82846 @mihaimaruseac Hanoi tweaked 2
authored
558 (if (null? (cdr alternatives))
559 (list #f '() '())
560 (tryExpansion (cdr alternatives) opList g given world)
561 )
3d1e183 @mihaimaruseac Hanoi tweaked
authored
562 (let*
563 (
564 )
565 (display"\n@@@@@@@@@@@@@@@@@@@\n")
566 (display op)(newline)
567 (display (list #t (++ (car nextLevel) (list (car op))) (opApply op (cadr nextLevel))))
568 (display"\n@@@@@@@@@@@@@@@@@@@\n")
569 (list #t (++ (car nextLevel) (list (car op))) (opApply op (cadr nextLevel)))
570 )
571 )
a4ce80f @mihaimaruseac Hanoi solved
authored
572 )
3d1e183 @mihaimaruseac Hanoi tweaked
authored
573 )
a4ce80f @mihaimaruseac Hanoi solved
authored
574 )
3d1e183 @mihaimaruseac Hanoi tweaked
authored
575 )
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
576 )
577
578 (define (altSort a1 a2) (desSort (oprDes a1) (oprDes a2)))
608d18d @mihaimaruseac Instantiation of all ops
authored
579
580 ; get world objects
581 (define (worldObjects init scopes) (apply +++ (+++ (map predArgs init) (map predArgs scopes))))
582
5f61440 @mihaimaruseac Started BW
authored
583 ; testing Blocks world problem
584 (define BWOps '((
585 (pickup X)
586 ((ontable X) (clear X) (armempty))
587 ((ontable X) (clear X) (armempty))
588 ((hold X))
589 )
590 (
591 (putdown X)
592 ((hold X))
593 ((hold X))
594 ((ontable X) (clear X) (armempty))
595 )
596 (
597 (unstack X Y)
598 ((on X Y) (clear X) (armempty))
599 ((on X Y) (clear X) (armempty))
600 ((hold X) (clear Y))
601 )
602 (
603 (stack X Y)
604 ((hold X) (clear Y))
605 ((hold X) (clear Y))
606 ((on X Y) (clear X) (armempty))
607 )))
608
609 (define BWState '((ontable a) (on b a) (on c b) (clear c) (armempty)))
610
611 (define BWGoal '((clear c) (ontable b) (on c b) (armempty)))
612
613 (define BWWorld (worldObjects BWState BWGoal))
614
608d18d @mihaimaruseac Instantiation of all ops
authored
615 ; testing Hanoi problem
616 (define HanoiOps '((
b104f04 @mihaimaruseac new tests
authored
617 (move A B C)
608d18d @mihaimaruseac Instantiation of all ops
authored
618 ((disc A) (clear A) (on A B) (smaller A C) (clear C))
b104f04 @mihaimaruseac new tests
authored
619 ((on A B) (clear C))
608d18d @mihaimaruseac Instantiation of all ops
authored
620 ((on A C) (clear B))
621 )))
622 (define HanoiState '((disc d1) (disc d2)
623 (smaller d2 p1) (smaller d2 p2) (smaller d2 p3) (smaller d1 d2) (smaller d1 p1) (smaller d1 p2) (smaller d1 p3)
624 (clear d1) (clear p2) (clear p3)
625 (on d1 d2) (on d2 p1)))
626 (define HanoiGoal '((clear p1) (clear d1) (on d1 d2) (on d2 p2) (clear p3)))
a4ce80f @mihaimaruseac Hanoi solved
authored
627 (define HanoiGoal1 '((clear d2) (on d1 p3) (on d2 p2)))
3d1e183 @mihaimaruseac Hanoi tweaked
authored
628 (define HanoiGoal2 '((on d1 p3) (on d1 p2)))
884f09e @mihaimaruseac Op ins
authored
629
be56837 @mihaimaruseac Fixed handling no goal helpers
authored
630 (define HanoiWorld (worldObjects HanoiState HanoiGoal))
631
b104f04 @mihaimaruseac new tests
authored
632 ; tests for second day of work
5f61440 @mihaimaruseac Started BW
authored
633 ;(display "Test op instantiation1 ")
634 ;(define HanoiOps1 '((
635 ; (move A B C D)
636 ; ((disc A) (clear A) (on A B) (smaller A C) (clear C))
637 ; ((on A B) (clear C))
638 ; ((on A C) (clear B))
639 ; )))
640 ;(if (== (opFullInstance (opFindResult '(on d1 d2) HanoiOps1) HanoiGoal (worldObjects HanoiState HanoiGoal))
641 ; '(((move d1 p1 d2 d1) ((disc d1) (clear d1) (on d1 p1) (smaller d1 d2) (clear d2)) ((on d1 p1) (clear d2)) ((on d1 d2) (clear p1)))
642 ; ((move d1 p1 d2 d2) ((disc d1) (clear d1) (on d1 p1) (smaller d1 d2) (clear d2)) ((on d1 p1) (clear d2)) ((on d1 d2) (clear p1)))
643 ; ((move d1 p1 d2 p1) ((disc d1) (clear d1) (on d1 p1) (smaller d1 d2) (clear d2)) ((on d1 p1) (clear d2)) ((on d1 d2) (clear p1)))
644 ; ((move d1 p1 d2 p2) ((disc d1) (clear d1) (on d1 p1) (smaller d1 d2) (clear d2)) ((on d1 p1) (clear d2)) ((on d1 d2) (clear p1)))
645 ; ((move d1 p1 d2 p3) ((disc d1) (clear d1) (on d1 p1) (smaller d1 d2) (clear d2)) ((on d1 p1) (clear d2)) ((on d1 d2) (clear p1)))
646 ; ((move d1 d1 d2 d1) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
647 ; ((move d1 d1 d2 d2) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
648 ; ((move d1 d1 d2 p1) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
649 ; ((move d1 d1 d2 p2) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
650 ; ((move d1 d1 d2 p3) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
651 ; ((move d1 p3 d2 d1) ((disc d1) (clear d1) (on d1 p3) (smaller d1 d2) (clear d2)) ((on d1 p3) (clear d2)) ((on d1 d2) (clear p3)))
652 ; ((move d1 p3 d2 d2) ((disc d1) (clear d1) (on d1 p3) (smaller d1 d2) (clear d2)) ((on d1 p3) (clear d2)) ((on d1 d2) (clear p3)))
653 ; ((move d1 p3 d2 p1) ((disc d1) (clear d1) (on d1 p3) (smaller d1 d2) (clear d2)) ((on d1 p3) (clear d2)) ((on d1 d2) (clear p3)))
654 ; ((move d1 p3 d2 p2) ((disc d1) (clear d1) (on d1 p3) (smaller d1 d2) (clear d2)) ((on d1 p3) (clear d2)) ((on d1 d2) (clear p3)))
655 ; ((move d1 p3 d2 p3) ((disc d1) (clear d1) (on d1 p3) (smaller d1 d2) (clear d2)) ((on d1 p3) (clear d2)) ((on d1 d2) (clear p3)))))
656 ; (display "passed") (display "failed"))
657 ;(newline)
658 ;(display "Test op instantiation2 ")
659 ;(if (== (opFullInstance (opFindResult '(on d1 d2) HanoiOps) HanoiGoal (worldObjects HanoiState HanoiGoal))
660 ; '(((move d1 p1 d2) ((disc d1) (clear d1) (on d1 p1) (smaller d1 d2) (clear d2)) ((on d1 p1) (clear d2)) ((on d1 d2) (clear p1)))
661 ; ((move d1 d1 d2) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
662 ; ((move d1 p3 d2) ((disc d1) (clear d1) (on d1 p3) (smaller d1 d2) (clear d2)) ((on d1 p3) (clear d2)) ((on d1 d2) (clear p3)))))
663 ; (display "passed") (display "failed"))
664 ;(newline)
665
666
667 ; DBG TESTS
668 (display ">>>> tests for opFindResult:")
669 (display "\nHanoi: ")(display (== (opFindResult '(clear d1) HanoiOps) '(((move A d1 C) ((disc A) (clear A) (on A d1) (smaller A C) (clear C)) ((on A d1) (clear C)) ((on A C) (clear d1))))))
670 (display "\nBW: ")(display (== (opFindResult '(clear c) BWOps) '(((putdown c) ((hold c)) ((hold c)) ((ontable c) (clear c) (armempty)))
671 ((unstack X c) ((on X c) (clear X) (armempty)) ((on X c) (clear X) (armempty)) ((hold X) (clear c)))
672 ((stack c Y) ((hold c) (clear Y)) ((hold c) (clear Y)) ((on c Y) (clear c) (armempty))))))
b104f04 @mihaimaruseac new tests
authored
673 (newline)
5f61440 @mihaimaruseac Started BW
authored
674
675 (display ">>>> tests for opFullGoal:")
676 (display "\nHanoi partial: ")(display (== (opFullGoal '((clear d1)) (opFindResult '(clear d1) HanoiOps)) '(((move A d1 C) ((disc A) (clear A) (on A d1) (smaller A C) (clear C)) ((on A d1) (clear C)) ((on A C) (clear d1))))))
677 (display "\nHanoi total: ")(display (== (opFullGoal '((on d1 p3) (clear d1)) (opFindResult '(clear d1) HanoiOps)) '((((move d1 d1 p3) ((disc d1) (clear d1) (on d1 d1) (smaller d1 p3) (clear p3)) ((on d1 d1) (clear p3)) ((on d1 p3) (clear d1)))))))
678 (display "\nBW partial: ")(display (== (opFullGoal '((clear a)) (opFindResult '(clear a) BWOps)) '(((putdown a) ((hold a)) ((hold a)) ((ontable a) (clear a) (armempty)))
679 ((unstack X a) ((on X a) (clear X) (armempty)) ((on X a) (clear X) (armempty)) ((hold X) (clear a)))
680 ((stack a Y) ((hold a) (clear Y)) ((hold a) (clear Y)) ((on a Y) (clear a) (armempty))))))
681 (display "\nBW total: ")(display (== (opFullGoal '((clear a) (on a b)) (opFindResult '(clear a) BWOps)) '(((putdown a) ((hold a)) ((hold a)) ((ontable a) (clear a) (armempty)))
682 ((unstack X a) ((on X a) (clear X) (armempty)) ((on X a) (clear X) (armempty)) ((hold X) (clear a)))
683 (((stack a b) ((hold a) (clear b)) ((hold a) (clear b)) ((on a b) (clear a) (armempty)))))))
684 (newline)
685
686 (display ">>>> tests for opFullWorld:")
687 (display "\nHanoi 1: ")(display (== (opFullWorld HanoiWorld (opFullGoal '((clear d1)) (opFindResult '(clear d1) HanoiOps)))
688 '(((move d1 d1 d2) ((disc d1) (clear d1) (on d1 d1) (smaller d1 d2) (clear d2)) ((on d1 d1) (clear d2)) ((on d1 d2) (clear d1)))
689 ((move d1 d1 p1) ((disc d1) (clear d1) (on d1 d1) (smaller d1 p1) (clear p1)) ((on d1 d1) (clear p1)) ((on d1 p1) (clear d1)))
690 ((move d1 d1 p2) ((disc d1) (clear d1) (on d1 d1) (smaller d1 p2) (clear p2)) ((on d1 d1) (clear p2)) ((on d1 p2) (clear d1)))
691 ((move d1 d1 p3) ((disc d1) (clear d1) (on d1 d1) (smaller d1 p3) (clear p3)) ((on d1 d1) (clear p3)) ((on d1 p3) (clear d1)))
692 ((move d2 d1 d2) ((disc d2) (clear d2) (on d2 d1) (smaller d2 d2) (clear d2)) ((on d2 d1) (clear d2)) ((on d2 d2) (clear d1)))
693 ((move d2 d1 p1) ((disc d2) (clear d2) (on d2 d1) (smaller d2 p1) (clear p1)) ((on d2 d1) (clear p1)) ((on d2 p1) (clear d1)))
694 ((move d2 d1 p2) ((disc d2) (clear d2) (on d2 d1) (smaller d2 p2) (clear p2)) ((on d2 d1) (clear p2)) ((on d2 p2) (clear d1)))
695 ((move d2 d1 p3) ((disc d2) (clear d2) (on d2 d1) (smaller d2 p3) (clear p3)) ((on d2 d1) (clear p3)) ((on d2 p3) (clear d1)))
696 ((move p1 d1 d2) ((disc p1) (clear p1) (on p1 d1) (smaller p1 d2) (clear d2)) ((on p1 d1) (clear d2)) ((on p1 d2) (clear d1)))
697 ((move p1 d1 p1) ((disc p1) (clear p1) (on p1 d1) (smaller p1 p1) (clear p1)) ((on p1 d1) (clear p1)) ((on p1 p1) (clear d1)))
698 ((move p1 d1 p2) ((disc p1) (clear p1) (on p1 d1) (smaller p1 p2) (clear p2)) ((on p1 d1) (clear p2)) ((on p1 p2) (clear d1)))
699 ((move p1 d1 p3) ((disc p1) (clear p1) (on p1 d1) (smaller p1 p3) (clear p3)) ((on p1 d1) (clear p3)) ((on p1 p3) (clear d1)))
700 ((move p2 d1 d2) ((disc p2) (clear p2) (on p2 d1) (smaller p2 d2) (clear d2)) ((on p2 d1) (clear d2)) ((on p2 d2) (clear d1)))
701 ((move p2 d1 p1) ((disc p2) (clear p2) (on p2 d1) (smaller p2 p1) (clear p1)) ((on p2 d1) (clear p1)) ((on p2 p1) (clear d1)))
702 ((move p2 d1 p2) ((disc p2) (clear p2) (on p2 d1) (smaller p2 p2) (clear p2)) ((on p2 d1) (clear p2)) ((on p2 p2) (clear d1)))
703 ((move p2 d1 p3) ((disc p2) (clear p2) (on p2 d1) (smaller p2 p3) (clear p3)) ((on p2 d1) (clear p3)) ((on p2 p3) (clear d1)))
704 ((move p3 d1 d2) ((disc p3) (clear p3) (on p3 d1) (smaller p3 d2) (clear d2)) ((on p3 d1) (clear d2)) ((on p3 d2) (clear d1)))
705 ((move p3 d1 p1) ((disc p3) (clear p3) (on p3 d1) (smaller p3 p1) (clear p1)) ((on p3 d1) (clear p1)) ((on p3 p1) (clear d1)))
706 ((move p3 d1 p2) ((disc p3) (clear p3) (on p3 d1) (smaller p3 p2) (clear p2)) ((on p3 d1) (clear p2)) ((on p3 p2) (clear d1)))
707 ((move p3 d1 p3) ((disc p3) (clear p3) (on p3 d1) (smaller p3 p3) (clear p3)) ((on p3 d1) (clear p3)) ((on p3 p3) (clear d1))))))
9947b76 @mihaimaruseac new tests
authored
708 (newline)
5f61440 @mihaimaruseac Started BW
authored
709 ; END
Something went wrong with that request. Please try again.