ACCELERATING PARTIAL-ORDER PLANNERS: SOME TECHNIQUES FOR
EFFECTIVE SEARCH CONTROL AND PRUNING
ON-LINE APPENDIX 1
Alfonso Gerevini and Lenhart K. Schubert
The first part of this file contains the documentation and the CommonLisp
code implementing the ZLIFO flaw-selection strategy. The second part
contains the documentation and the CommonLisp code implementing the
algorithm find-paramater-domains for precomputing parameter domains.
PART I: THE ZLIFO FLAW-SELECTION STRATEGY
---------------------------------
The next flaw to repair is chosen according to the following preferences:
1. a definite threat (*d-sep* is on), using LIFO to pick among these;
2. an open condition that cannot be established in any way;
3. an open condition that can be resolved in only one way,
preferring open conditions that can be established by introducing
a new action to those that can be established by using *start*;
4. an open condition, using LIFO to pick among these.
Note: in our experiments the sub-preference in 3. gave improvements in
the context of Russell's tire changing domain (in particular with 'fix3),
without significant deterioration in performance with the other domains.
* PSEUDOCODE FOR STEPS 2-4
The following is the pseudocode for implementing the selection of
the open conditions (steps 2-4 of the general strategy):
0. Z-OC := nil; L-OC: nil; I-MATCHES:=0; S-MATCHES:=0 O-MATCHES:=0;
{Z-OC and L-OC are variables that will be used to store selected
open conditions. In particular, Z-OC contains an open condition
such that when this condition is processed it generates a
zero-commitment refinement; L-OC contains an open condition
selected using the LIFO strategy. The variables I-MATCHES,
S-MATCHES, O-MATCHES, will be used to count the number of
different ways of resolving an open condition};
1. FOR EACH open cond. OC taken in LIFO-order from the list of flaws DO
BEGIN
2. I-MATCHES := number of (positive) conditions in the initial
state which match OC given the current set of binding constraints
{if OC is a negated condition and it can be established by using
the closed world assumption, then count 1 match};
3. S-MATCHES := number of effects of steps in the current plan
(excluding *start*) which match OC given the current set of
binding constraints, and which can possibly be before the
step of OC;
4. O-MATCHES := number of effects of operators matching OC
{Note that when S-MATCHES=1, S-MATCHES <= O-MATCHES}
5. TOT-MATCHES := I-MATCHES + S-MATCHES + O-MATCHES;
6. IF TOT-MATCHES = 0 THEN RETURN OC
{we have found an open condition with zero matches, i.e. that
cannot be established in any way. When this (zero-commitment)
open condition is handled, the corresponding plan is pruned
from the plan queue};
7. IF TOP-MATCHES = 1 THEN
8. IF Z-OC = nil THEN Z-OC := OC
{we have found a zero-commitment open condition but we don't
immediately return it because we could still find another
better condition (i.e., a condition with zero matches)}
9. ELSE {sub-preference among open conds with only one match}
10. IF Z-OC is an open condition that can be established
only by the initial state (initial action *start*),
and OC can be established only by using an operator
(introducing a new action into the current plan)
THEN Z-OC := OC;
11. ELSE {OC is not zero-commitment (TOT-MATCHES > 1)}
12. IF L-OC = nil THEN L-OC := OC
{L-OC is bound to the open condition in the list
of the flaws satisfying the LIFO ordering}
END{FOR}
13. IF Z-OC = nil THEN RETURN L-OC ELSE RETURN Z-OC.
{if we have found an OC with only one possible way of being
resolved, then this is returned; otherwise an open condition
taken in LIFO order from the flaw list is returned.}
* OPTIMIZATION NOTES AND EXTENSIONS
The current implementation of ZLIFO can be improved in some ways. In
particular, there is no need to count all the initial conditions matching
the open condition (I-MATCHES). When we have found two matching initial
conditions, we can stop because we already know that the current OC is not
a zero-commitment choice. Furthermore, there is no need to compute
S-MATCHES (steps 3) and O-MATCHES (step 4).
Moreover, we need to find at most 1 matching effect of steps in the plan
(S-MATCHES). In fact, if S-MATCHES = 1, TOT-MATCHES is greater than 1, since
O-MATCHES >= S-MATCHES. So, step 2 (S-MATCHES) needs to be computed only
if I-MATCHES < 2, and step 4 (O-MATCHES) needs to be computed only if
I-MATCHES < 2 and S-MATCHES = 0.
These refinements of the current implementation of ZLIFO will reduce the
computational overhead for flaw selection, yielding better performance in
terms of CPU time.
* COMMON LISP CODE FOR STEPS 2-4 OF ZLIFO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Lisp functions implementing the selection of open conditions in the
;; ZLIFO flaw-selection strategy.
;;
;; THIS SOURCE CODE IS SUPPLIED "AS IS" WITHOUT WARRANTY OF ANY KIND, AND
;; ITS AUTHORS AND THE JOURNAL OF ARTIFICIAL INTELLIGENCE RESEARCH (JAIR)
;; AND JAIR'S PUBLISHERS AND DISTRIBUTORS, DISCLAIM ANY AND ALL WARRANTIES,
;; INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES OF MERCHANTABILITY
;; AND FITNESS FOR A PARTICULAR PURPOSE, AND ANY WARRANTIES OR NON
;; INFRINGEMENT. THE USER ASSUMES ALL LIABILITY AND RESPONSIBILITY FOR USE
;; OF THIS SOURCE CODE, AND NEITHER THE AUTHORS NOR JAIR, NOR JAIR'S
;; PUBLISHERS AND DISTRIBUTORS WILL BE LIABLE FOR DAMAGES OF ANY KIND
;; RESULTING FROM ITS USE. Without limiting the generality of the foregoing,
;; neither the authors, nor JAIR, nor JAIR's publishers and distributors,
;; warrant that the Source Code will be error-free, will operate without
;; interruption, or will meet the needs of the user.
;;
;; HOW TO INTEGRATE ZLIFO INTO UCPOP2.0:
;; Add the following functions to the file ucpop.lisp. Note that
;; the UCPOP functions GET-OPEN and NEW-PLANS should be replaced
;; with the new ones.
;;
;; WARNING
;; The current implementation of ZLIFO has NOT been tested with
;; domains containing axioms and operators with universally quantified
;; variables. The code is not optimized.
(setq *d-sep* t)
(defun GET-OPEN (plan)
"Returns a list (OC M), where OC is the open condition of the
input plan [plan], and M is the number of ways in which OC can
be resolved (i.e., the numeber of refined plans that will be
generated)"
(do* ((open-cond-list (plan-flaws plan) (cdr open-cond-list))
(open-cond (car open-cond-list) (car open-cond-list))
(cond-found nil)
(num-matches nil)
(num-matches-or nil)
(ret1 nil)
(ret2 nil)
(ret2-1 nil)
(ret3 nil))
((or (null open-cond-list) cond-found)
(cond (cond-found
(list ret1 0))
(t
(if (and (null ret1) (null ret2) (null ret2-1) (null ret3)) nil
(cond ((not (null ret1))
(list ret1 1))
((not (null ret2))
(list ret2 1))
((not (null ret2-1))
(list ret2-1 1))
(t (list ret3 num-matches)))))))
(cond ((openc-p open-cond)
(cond ((eq (car (openc-condition open-cond)) :or)
;; open cond is a disjunctive goal
(setq num-matches-or
(OR-MATCHES (openc-condition open-cond) plan))
(cond ((zerop num-matches-or)
(setq cond-found t)
(setq num-matches 0)
(setq ret1 open-cond))
((eql num-matches-or 1)
(when (null ret2)
(setq num-matches 1)
(setq ret2 open-cond)))
(t
(when (null ret3)
(setq num-matches num-matches-or)
(setq ret3 open-cond)))))
(t
;; open cond is not a disjunctive goal
(let ((can-start (I-MATCHES open-cond plan))
(can-steps (S-MATCHES open-cond plan))
(can-opers (O-MATCHES
(openc-condition open-cond) plan)))
(cond ((and (zerop can-opers)
(zerop can-steps)
(zerop can-start))
(setq num-matches 0)
(setq ret1 open-cond)
(setq cond-found t))
((and (eql can-opers 1)
(zerop can-steps)
(zerop can-start))
(when (null ret1)
(setq ret1 open-cond)))
((and (eql can-start 1)
(zerop can-opers)
(zerop can-steps))
(when (null ret2)
(setq ret2 open-cond)))
(t
(when (null ret3)
(setq num-matches
(+ can-opers can-steps can-start))
(setq ret3 open-cond))))))))
((fact-p open-cond)
(setf (fact-bindings open-cond)
(apply (fact-function open-cond)
(mapcar
#'(lambda (x)
(bind-variable x (plan-bindings plan)))
(cdr (fact-condition open-cond)))))
(unless (eq :no-match-attempted (fact-bindings open-cond))
(cond ((zerop (length (fact-bindings open-cond)))
(setq cond-found t)
(setq ret1 open-cond))
((eql (length (fact-bindings open-cond)) 1)
(when (null ret2-1)
(setq ret2-1 open-cond)))
(t
(when (null ret3)
(setq num-matches
(length (fact-bindings open-cond)))
(setq ret3 open-cond)))))))))
#|
;; ZLIFO without the sub-preference among OCs which can be achieved
;; in a unique way
(defun GET-OPEN (plan)
(do* ((open-cond-list (plan-flaws plan) (cdr open-cond-list))
(open-cond (car open-cond-list) (car open-cond-list))
(cond-found nil)
(num-matches nil)
(num-matches-or nil)
(ret1 nil)
(ret2 nil)
(ret3 nil))
((or (null open-cond-list) cond-found)
(cond (cond-found
(list ret1 num-matches))
(t
(if (and (null ret1) (null ret2) (null ret3)) nil
(cond ((not (null ret1))
(list ret1 num-matches))
((not (null ret2))
(list ret2 num-matches))
(t (list ret3 num-matches)))))))
(cond ((openc-p open-cond)
(cond ((eq (car (openc-condition open-cond)) :or)
;; open cond is a disjunctive goal
(setq num-matches-or
(OR-MATCHES (openc-condition open-cond) plan))
(cond ((zerop num-matches-or)
(setq cond-found t)
(setq num-matches 0)
(setq ret1 open-cond))
((eql num-matches-or 1)
(when (null ret1)
(setq num-matches 1)
(setq ret1 open-cond)))
(t
(when (and (null ret2) (null ret1))
(setq num-matches num-matches-or)
(setq ret2 open-cond)))))
(t
;; open cond is not a disjunctive goal
(let ((can-start (I-MATCHES open-cond plan))
(can-steps (S-MATCHES open-cond plan))
(can-opers (O-MATCHES
(openc-condition open-cond) plan)))
(cond ((and (zerop can-opers)
(zerop can-steps)
(zerop can-start))
(setq ret1 open-cond)
(setq num-matches 0)
(setq cond-found t))
((eql (+ can-opers can-steps can-start) 1)
(cond ((null ret1)
(setq num-matches 1)
(setq ret1 open-cond))
(t nil)))
(t
(when (and (null ret2) (null ret1))
(setq ret2 open-cond)
(setq num-matches
(+ can-opers can-steps can-start)))))))))
((fact-p open-cond)
(setf (fact-bindings open-cond)
(apply (fact-function open-cond)
(mapcar
#'(lambda (x)
(bind-variable x (plan-bindings plan)))
(cdr (fact-condition open-cond)))))
(unless (eq :no-match-attempted (fact-bindings open-cond))
(cond ((zerop (length (fact-bindings open-cond)))
(setq cond-found t)
(setq num-matches 0)
(setq ret1 open-cond))
((eql (length (fact-bindings open-cond)) 1)
(when (null ret1)
(setq num-matches 1)
(setq ret1 open-cond)))
(t (when (null ret2)
(setq num-matches
(length (fact-bindings open-cond)))
(setq ret2 open-cond)))))))))
|#
(defun I-MATCHES (ocond plan)
"Returns the number of (positive) conditions in initial state
matching the open condition [ocond], given the set of bindings
of the current plan [plan]"
(let* ((condition (openc-condition ocond))
(step (find 0 (plan-steps plan) :key #'p-step-id))
(binds nil)
(num-matches 0))
(if (eql (car condition) :not)
(let ((effect (car (p-step-add step))))
(setq binds (ACHIEVE-COND-CWA ocond
(plan-bindings plan)
effect))
(when (listp binds)
(setq num-matches (+ 1 num-matches))))
(dolist (effect (p-step-add step))
(dolist (add-cond (effect-add effect))
(setq binds (unify add-cond
condition
(plan-bindings plan)))
(when binds
(setq num-matches (+ 1 num-matches))))))
num-matches))
(defun S-MATCHES (open-cond plan)
"Returns the number of effects of steps in the current plan [plan]
matching the open condition [open-cond], given the set of bindings
of the current plan"
(do* ((id (openc-id open-cond))
(steps (possibly-prior id plan) (cdr steps))
(reuse (ACHIEVE open-cond (car steps) plan)
(if (null steps) nil
(ACHIEVE open-cond (car steps) plan)))
(num-reuse (if (not reuse) 0 reuse)
(if (not reuse) num-reuse (+ reuse num-reuse))))
((null steps) num-reuse)))
(defun O-MATCHES (condition plan)
"Returns the number of effects of operators matching the open
condition [condition], given the set of bindings of the current
plan [plan]"
(let ((num-opers 0))
(dolist (templ *templates*)
(dolist (e (p-step-add templ) nil)
(dolist (add-cond (effect-add e))
(when (UNIFY-EFFECT add-cond condition
(plan-bindings plan) templ plan)
(setq num-opers (+ 1 num-opers))))))
num-opers))
(defun UNIFY-EFFECT (cond-st cond bs oper plan)
(if (not (unify cond-st cond bs)) nil
(let ((eq-neqs nil)
(precs nil)
(bs-copy bs)
(new-bs nil))
(setq precs (if (listp (car (p-step-precond oper)))
(LIST-PRECS (p-step-precond oper))
(list (p-step-precond oper))))
(dolist (p precs)
(case (car p)
(:eq (push (cons (cadr p) (caddr p)) eq-neqs))
(:neq (push `(:not ,(cadr p) . ,(caddr p)) eq-neqs))))
(setf new-bs (add-bind eq-neqs bs-copy))
(setf (plan-bindings plan) bs)
new-bs)))
(defun LIST-PRECS (p)
(if (eq (car p) :and)
(list-precs (cdr p))
p))
(defun OR-MATCHES (disjunctive-oc plan)
"Compute the number of ways of achieving a disjunctive OCs in
terms of the sum of its disjuncts which are not eq/neq constrains,
plus the eq/neq disjuncts which are individually consistent with
the current set of binding constraints."
(let ((copy-b (plan-bindings plan))
(eq-neqs nil)
(b nil)
(n 0)
(list-ocs (cdr disjunctive-oc)))
(dolist (p list-ocs)
(case (car p)
(:eq (setq b (list (cons (cadr p) (caddr p))))
(when (null (add-bind eq-neqs copy-b))
(setq n (+ 1 n))
(setq copy-b (plan-bindings plan))))
(:neq (setq b (list `(:not ,(cadr p) . ,(caddr p))))
(when (null (add-bind eq-neqs copy-b))
(setq n (+ 1 n))
(setq copy-b (plan-bindings plan))))
(otherwise
(setq n (+ 1 n)))))
n))
(defun ACHIEVE (open-cond st plan)
"Check whether an open condition [open-cond] can be achieved
by a step [st] in the current plan [plan]"
(if (eql st 0) nil
(let* ((condition (openc-condition open-cond))
(step (find st (plan-steps plan) :key #'p-step-id))
(can-achieve 0)
(binds nil))
(dolist (effect (p-step-add step))
(dolist (add-cond (effect-add effect))
(setq binds (unify add-cond
condition
(plan-bindings plan)))
(when binds (setq can-achieve (+ 1 can-achieve)))))
(if (zerop can-achieve) nil can-achieve))))
(defun ACHIEVE-COND-CWA (open-cond binds init-state)
"Test whether a negative open condition [open-cond] matches the
initial state [init-state]"
(let* ((condition (openc-condition open-cond))
(bind-goals nil))
(dolist (e (effect-add init-state))
(let ((b (unify (cadr condition) e binds)))
(when b
(setf b (car b))
(unless b (return-from ACHIEVE-COND-CWA nil))
(push (if (= 1 (length b))
`(:neq ,(caar b) ,(cdar b))
`(:or ,@(mapcar #'(lambda (x)
`(:neq ,(car x) ,(cdr x)))
(car b))))
bind-goals))))
(list bind-goals)))
(defun NEW-PLANS (plan f)
"Given the flaw generate the one-step refinements"
(if (null f) nil
(let* ((isfact? (if (listp f)
(if (fact-p (car f)) t nil) nil))
(kids (cond (isfact?
;; (car f) is a fact
(handle-fact (car f) plan))
((unsafe-p f) (handle-unsafe f plan))
((and (listp f) (not isfact?))
;; (car f) is an open cond
(if (not (null (car f)))
(handle-open (car f) plan)))
(t (error "incomplete plan has no flaws")))))
;; (when (find-package 'clim) (vcr-add-frame plan f kids))
kids)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Plan ranking functions for implementing S+OC+F
;
;(defun RANK3 (plan)
; (+ (length (plan-steps plan))
; (num-openc plan)))
;
;(defun NUM-OPENC (plan)
; (let ((n 0))
; (dolist (c (plan-flaws plan))
; (when (or (openc-p c) (fact-p c))
; (if (openc-p c)
; (setq n (+ n 1)))))
; n))
==========================================================================
PART II: DOCUMENTATION AND COMMON LISP CODE OF FIND-PARAMETER-DOMAINS
------------------------------------------------------------
* PRELIMINARIES AND NOTATIONS
The first step of the algorithm for computing parameter domains is to form
standardized versions of the given operators. A standardized operator has
unique parameter names (with pointers back to the original parameter names)
and has fields
:name name of original operator
:pars list of standardized parameters (without type constraints)
:whens list of names of when-clauses, corresponding to the primary
when-clause and successive secondary when-clauses.
Each of the when-clauses w of a standardized operator has fields
:op name of the (standard) operator to which w belongs
:preconds list of names of positive, atomic preconditions (including
type constraints) specific to w
:eqs list of names of EQ-preconditions of w
:neqs list of names of NEQ-preconditions of w
:effects list of names of positive, atomic effects specific to w
:npre number of unmatched conditions in preconds(w)
:ndom number of parameters with a null intersected domain in w
Note that negative preconditions of operators (except NEQ-conditions) are
ignored. The initial conditions are represented as a *start* operator
(with no preconditions) and the goals as an *end* operator (with no
effects).
In the pseudocode for the algorithm the notation I(v,p) refers to the
individual domain of parameter $v$ relative to the precondition named $p$;
i(v,w) refers to the intersected domain of $v$ relative to the when-clause
named $w$; and new(i(v,p)) is true if the last time i(v,p) was updated no
new elements were added to it, otherwise it is false. (The $I$ and $i$ are
mnemonic for the fact that individual domains are generally larger than
intersected domains.)
Standardized operators, when-clauses, atomic preconditions, and atomic
effects are uniquely named, and named preconditions and effects belong to
unique when-clauses, which in turn belong to unique operators.
Consequently, we can use the notation wh(p) to denote the when-clause to
which precondition or effect $p$ belongs, and op(w) to denote the operator
to which the when-clause $w$ belongs.
Other notations such as whens(op), preconds(w), and npre(w) refer to the
contents of specific fields of specific data objects (in this case the
whens field of operator op, the preconds field of when-clause $w$, and the
npre field of when-clause $w$). Further useful notations are w' for the
primary when-clause corresponding to when-clause $w$ (where possibly
w' = w), and preconds'(w) for preconds(w) augmented with preconds(w').
Our presentation of the algorithm omits BEGIN ... END notation in favor of
indentation.
* PSEUDOCODE OF FIND-PARAMETER-DOMAINS
ALGORITHM: FIND-PARAMETER-DOMAINS
INPUT: a list, operators, of names of UCPOP operators,
a list, inits, of initial conditions (positive ground predications),
and a (possibly null) list, goals, of goals (positive or negative
predications, possibly containing variables, regarded as existentially
quantified)
OUTPUT: a list of sublists, where each sublist is headed by the name of one
of the given UCPOP operators and is followed by a sequence of parameter
domain specifications. Where several successive sublists are headed
by the same operator name, they correspond to successive when-clauses
of the UCPOP operator, starting with the "primary" when-clause.
An example of a parameter domain specification is (?x A B TABLE),
indicating that ?x is restricted to values A, B, or TABLE in the
relevant when-clause of the relevant operator. Unreachable preconditions
(or goals), if any, are listed after parameter domain specifications.
1. ops := standardize(operators,inits,goals);
2. FOR EACH op in ops DO {set universal intersected domains to T}
3. FOR EACH w in whens(op) DO
4. FOR EACH v in pars(op) DO
5. IF v does not occur in preconds'(w) THEN i(v,w) := T;
6. {Initialize when-clauses whose effects will be propagated}
ww := list of all when-clauses w of all operators s.t. preconds'(w) = nil;
7. FOR EACH op in ops DO
8. FOR EACH w in whens(op) DO
9. {initialize count of unmatched preconditions}
npre(w) := length(preconds(w));
10. {initialize count of parameters with a null intersected domain}
ndom(w) := number of distinct paramters occurring in preconds(w);
11. REPEAT UNTIL ww = nil {Propagate effects of when-clauses ww}
12. FOR EACH w in ww DO mark op(w) as "propagated";
{Note: we permanently mark operators "propagated" once any of their
effects (hence the primary ones) have been propagated}
{Form list of effects to be propagated}
13. ee := concatenation of all effects(w), for all w in ww;
14. FOR EACH e in ee DO {propagate effect e}
15. pp := list of all preconditions whose predicate is the same as
the predicate in e, occurring in any list preconds(w) of
any when-clause w of any operator in ops; {by table look-up}
16. FOR EACH p in pp DO
{Form an asymmetric unifier, where a variable v on the right
is always unifiable with a term u "propagating" from the left,
but a variable u on the left unifies with a constant v only if
that constant is already in its intersected domain, i(u,wh(e))}
17. uni := left-unifier(e,p);
18. IF uni =/= nil {successful unification} THEN
19. IF p is not yet flagged as "matched" THEN
20. flag p as "matched";
21. decrement npre(wh(p)) by 1;
22. FOR each pair (u,v) in uni DO
{u is a term from e and v is a variable from p}
23. IF u is a constant THEN I(v,p) := union(I(v,p),{u})
24. ELSE {u is a var.} IF new(i(u,w)) THEN
25. I(v,p) := union(I(v,p),i(u,w));
26. IF npre(wh(p)) = npre(wh(p)') = 0 THEN
27. flag wh(p) as a "propagation-candidate";
28. FOR EACH op in ops DO
29. IF first(whens(op)) is flagged as "propagation-candidate" THEN
30. FOR EACH w in rest(whens(op)) DO
31. IF npre(w) = 0 THEN flag w as "propagation-candidate";
{Form the new list ww of when-clauses whose effects are to be prop-
agated, starting with when-clauses flagged as "propagation-candidate"}
32. ww := nil;
33. FOR EACH op in ops DO
34. FOR EACH w in whens(op) flagged as "propagation-candidate" DO
35. remove the "propagation-candidate" flag;
36. augmented := nil;
37. FOR EACH x in pars(op) DO
38. olddom := i(x,w);
39. pp := preconds'(w), but discarding those not involving x;
40. newdom := intersection{I(x,p)|p in pp};
41. IF newdom - olddom = {} THEN
42. new(i(x,w)) := false ELSE new(i(x,w)) := true;
43. IF olddom =/= newdom THEN
44. i(x,w) := newdom;
45. IF olddom = nil and x occurs in preconds(w) THEN
46. decrement ndom(w) by 1;
47. augmented := T;
48. IF augmented = T or op is not flagged as "propagated" THEN
49. IF ndom(w) = ndom(w') = 0 THEN add w to ww;
50. IF ww = nil THEN {further restrict intersected domains using EQ-
preconditions; then construct and return the output}
51. FOR EACH op in ops DO
52. FOR EACH w in whens(op) DO
53. FOR each equation (EQ u v) in eqs(w) DO
54. newdom := T;
55. FOR EACH x in {u,v} DO
56. IF x is a variable THEN
57. newdom := intersection(newdom,i(x,w))
58. ELSE newdom := intersection(newdom,{x});
59. FOR EACH x in {u,v} DO
60. IF x is a variable THEN
61. i(x,w) := newdom;
62. IF w = w' THEN
63. FOR EACH w2 in rest(preconds(op)) DO
64. i(x,w2) := intersection(i(x,w2),newdom);
65. results := nil;
66. FOR EACH op in ops DO
67. FOR EACH w in whens(op) DO
68. entry := (op (y1 C11 C12 ...) (y2 C21 C22 ...) ...
... (yn Cn1 Cn2 ...)), where x1, ..., xn are the
parameters of op; y1, ..., yn are their original
names; and {Ci1, Ci2, ...} is the intersected
domain i(xi,w);
69. append elements of preconds(w) not flagged as "matched" to
entry, after substituting original names of variables;
70. append entry to results;
71. RETURN results
* COMMON LISP CODE FOR FIND-PARAMETER-DOMAINS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Commonlisp code for finding parameter (variable) domains of UCPOP
;; planning operators, given the specifications of the operators, the
;; initial conditions, and optionally, the goal conditions.
;;
;; THIS SOURCE CODE IS SUPPLIED "AS IS" WITHOUT WARRANTY OF ANY KIND, AND
;; ITS AUTHORS AND THE JOURNAL OF ARTIFICIAL INTELLIGENCE RESEARCH (JAIR)
;; AND JAIR'S PUBLISHERS AND DISTRIBUTORS, DISCLAIM ANY AND ALL WARRANTIES,
;; INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES OF MERCHANTABILITY
;; AND FITNESS FOR A PARTICULAR PURPOSE, AND ANY WARRANTIES OR NON
;; INFRINGMENT. THE USER ASSUMES ALL LIABILITY AND RESPONSABILITY FOR USE
;; OF THIS SOURCE CODE, AND NEITHER THE AUTORS NOR JAIR, NOR JAIR'S
;; PUBLISHERS AND DISTRIBUTORS WILL BE LIABLE FOR DAMAGES OF ANY KIND
;; RESULTING FROM ITS USE. Without limiting the generality of the foregoing,
;; neither the authors, nor JAIR, nor JAIR's publishers and distributors,
;; warrant that the Source Code will be error-free, will operate without
;; interruption, or will meet the needs of the user.
;;
;=======================================================================
; SOME BASIC UTILITIES AND DEFINITIONS
(defun put (atm indic val) (setf (get atm indic) val))
(defun *member (x y) ; allows for universal set T
(if (equal y T) T (member x y)) )
; NB: In commonlisp, (member '(father-of John) '((mother-of John)
; (father-of John))) is nil! (Because the two occurrences of
; the same complex expression correspond to different storage
; locations). So *member as defined here works properly only
; for sets of atoms. To generalize it to complex terms, the
; occurrence of "(member x y)" should be replaced by
; "(member x y :test #'equal)". Similar remarks apply to the
; remaining "starred" functions.
(defun *subsetp (x y) ; allows for universal set T
(if (equal y T) T (if (equal x T) nil (subsetp x y))) )
(defun *union (x y) ; allows for universal set T
(if (equal x T) T (if (equal y T) T (union x y))) )
(defun *intersection (x y) ; allows for universal set T
(if (equal x T) y (if (equal y T) x (intersection x y))) )
(defstruct operator ; this is the non-standardized (input) format
parameters ; variables, possibly typed, e.g., (?x (place ?y))
precondition ; literal, or conjunction of literals headed by 'and
effect ; literal, or conjunction of literals (and/or "when"-
; clauses) headed by 'and
); end of operator
(defstruct op ; this is the standardized form used by
; find-parameter-domains
name ; the name of the original (unstandardized) operator
pars ; new variables corresponding to all variables
; originally given as parameters, as well as atoms
; starting with "?" found within the preconditions
; and effects of the operator
whens ; a list of names of "when"s, where the primary "when"
; corresponds to the main preconditions and effects of
; the operator, and the remaining, secondary "when"s
; correspond to the when-conditions included among
; the effects of the original operator.
); end of op
(defparameter *start* nil); this is set to an operator in initialize1
(defparameter *end* nil); this is set to an operator in initialize1
(defmacro define (type-and-name &rest fields)
;
; This is intended to be used only with (define (operator op-name) ...)
; forms of the type used in UCPOP. The operators are assumed to use
; eq, neq, and, or, not, rather than :eq, :neq, :and, :or, :not. The
; result is a setq-form, setting the name given as second element of
; type-and-name to a structure, using MAKE-... (e.g., MAKE-OPERATOR,
; if the first element of type-and-name is OPERATOR).
(list 'setq (cadr type-and-name)
(cons (intern (concatenate 'string "MAKE-" (string (car type-and-name))))
(mapcar #'(lambda (x)
(if (and x (atom x) (equal (char (string x) 0) #\:))
x (list 'quote x) ))
fields ))))
;======================================================================
; MAIN PROGRAM AND SUBROUTINES
(defun find-parameter-domains (operators inits goals)
;
; PURPOSE: To find sets of constants (or possibly functional ground
; terms) to which each variable of the given operators and goals
; is restricted, for the given initial conditions. "goals" may be
; nil, i.e., the goals may be omitted.
; operators: a list of operator names, where these are names of structures
; with the following fields:
; parameters (variables, possibly type-restricted, e.g., (block ?x))
; precondition (preconditions that must always be met ; there may
; be a single precond or a conjunction (and ...)))
; effect (effects conditional only on the general preconds,
; and "when"s, i.e., effects with further preconditions;
; again there may be one effect or a conjunction of them)
; All explicit parameters as well as atomic arguments starting with
; "?" occurring in preconditions or effects (possibly not listed as
; parameters) are recognized as variables. Preconditions and effects
; may be positive or negative (also in whens). However, only positive
; preconditions and effects are considered in the domain computation.
; inits: a list of initial conditions (positive ground atoms only, and no
; EQ-atoms or NEQ-atoms)
; goals: a list of goal conditions. They may contain variables (interpreted
; as existentially quantified), but must be atomic formulas or negations
; of atomic formulas.
; FORM OF OUTPUT:
; ((op1 var-dom11 ... var-dom1k) ... (opm var-domm1 ... var-dommn)
; (goals var-dom1 ... var-doml)),
; where each opi is an operator name and (except under certain
; abnormal circumstances - see below) each var-domij is a list headed
; by a variable and followed by a sequence of ground terms (usually
; constants), e.g., (?x B1 B2 B3 Table). There will be such a list
; for each variable that occurs as parameter or in a precondition
; or effect of opi. If opi has no variables, the list for opi will
; be (opi) (under otherwise normal conditions).
;
; Under abnormal circumstances where opi failed to have some (+ve)
; precondition matched, the cdr of the list for opi will contain
; that precondition, e.g., (opi (?x A B) (on ?x ?y)). (The precond-
; dition will be recognizable as such since its car is not a variable.)
; In such a case opi cannot possibly be used (with the assurance that
; it will have the specified effects) for the given initial conditions.
; (Or if opi = *end*, the listed goals cannot be (provably) achieved.)
;
; For operators with "when"s, this needs to be slightly generalized.
; If an operator opi has w "when"s, we will have w+1 tuples beginning
; with (opi ...), i.e., an initial one for the general preconditions
; and effects of opi (not within the scope of any "when"), and one
; for each of the "when"s. The variables for which domains are suppl-
; ied will be identical in each "when" (even if a variable doesn't
; occur within that "when"), though the domains will of course be
; different in general. Since both the general preconditions and
; the conditions particular to a "when" must be established to guar-
; antee the particular effects of that "when", the domains for a
; "when" are based on the conjunction of general preconditions and
; the particular preconditions of the "when". (N.B.: To properly
; exploit these domains in a planner, if we reuse an operator
; instance so as to employ the effects of multiple "when"s, we
; should use the intersections of domains for those "when"s.)
;
; When a nil domain is reported for a variable (e.g., (?x)), this
; means that the variable occurs in the positive preconditions of
; the operator in question, and either no constants at all were found
; to "propagate" through matching) to those preconditions, or the
; ones that did propagate to the preconditions intersected out. In
; either case the operator (or the "when" in which the nil domain
; occurs) cannot possibly be instantiated (with the assurance that
; it will have the specified effects) for the given initial conditions.
; If the operator is *end* (i.e., we are considering domain constraints
; in the goal conditions), the goals cannot be jointly achieved.
;
; If a variable doesn't occur in any positive preconditions (only
; in the parameter list and/or in effects and/or in negative precond-
; itions) its domain will be set to T (e.g., (?x . T)). This signals
; that the variable can be arbitrarily instantiated (modulo negative
; preconditions), in establishing the effects associated with those
; preconditions. (This statement should be interpreted as applying
; separately to the general preconditions/ effects not embedded within
; "when"s, and those within each "when". Within a "when", we will get
; a T-domain only if the variable in question occurs neither in the
; general positive preconditions nor in the positive preconditions
; of that "when".) Note that in computing domain intersections,
; special provision must be made to ensure (intersection list T) =
; list, for any list. This program uses "starred" functions *subsetp,
; *union, and *intersection for this purpose.
;
; METHOD: The idea is that in any completed plan, each precondition of each
; action must be instantiated by an effect of some earlier action. So
; the values of the variables of the action can only be values that can
; be "produced" by earlier actions, starting with the initial "action",
; *start*. Moreover, where a variable occurs in more than one precond-
; ition of a given action, only those values are possible which can
; be produced by instantiation of ALL these preconditions. Thus we
; compute INTERSECTED variable domains, based on the individual domains
; associated with individual (positive) preconditions. We iteratively
; propagate the intersected variable domains forward, matching an
; effect of one action to a precondition of another. For each such
; effect-precondition match, we add the intersected variable domains
; relevant to the effect to the individual variable domains relevant
; to the precondition. Subsequently intersected domains of operators
; whose preconditions were matched can be updated. Effects may be
; particular to a "when", and in that case the domains for that
; "when" are propagated. Similarly preconditions that we match
; against may be particular to a "when", and in that case we update
; the individual domains (and subsequently the intersected domains)
; particular to that "when". We iterate until all the intersected
; domains stabilize. (At that point no new value can propagate, so
; we're done.)
;
; We propagate intersected domains of an operator only when we have
; matched each of its general positive preconditions (including type
; constraints) at least once in the propagation process, and all the
; intersected domains are nonempty as well. (Again this statement
; applies separately to the general preconds/effects and to the
; specific preconds/effects within each "when".) This keeps domain
; updating monotone increasing (domains never shrink), and also
; ensures that if an operator (or a "when" within an operator) can't
; be instantiated at all because it has an unmatchable precondition
; or a variable with an empty domain, none of its domains will be
; propagated.
;
(prog (ops op w1 ww ee pp wff1 wff2 uni we wp u r v augmented preconds
olddom newdom update entry results)
;
; Create standardized versions of the operators, for use in the
; domain calculations. In particular, ensure that all variables
; appearing in preconditions (as well as effects) are parameters;
; standardize apart variable names in operators, recording the
; original variable names under a 'var indicator for new variables.
; This also serves to mark the new variables AS variables.
; Separate out and NAME all "when"s, treating the general precond-
; itions and general effects of the operator as the primary "when";
; (for the named "when"s, put the name of the operator under indic-
; ator 'op); separate out and NAME all POSITIVE preconditions,
; including parameter type constraints and particular preconditions
; within "when"s; store the names of the +ve, non-EQ preconditions
; in which each variable occurs under indicator 'preconds of the
; variable; separate out and NAME all POSITIVE effects, including
; particular effects within "when"s; (for the named preconditions
; and effects, put the name of the "when" they belong to under
; indicator 'when); also encode "inits" as *start* operator and
; "goals", if non-nil, as *end* operator. So, the operators we
; get will be of form
; name (name of the original operator)
; pars (list of standardized variable names)
; whens (list of names of "when"s)
; The standardized operator itself will have a name consisting of
; the name of the original operator, plus a "gensym"ed suffix.
; Each named "when" will have indicator 'preconds giving a list of
; names of its non-EQ/NEQ preconditions, indicator 'eqs giving a list
; of names of its EQ-preconditions, indicator 'neqs giving a list
; of names of its NEQ-preconditions, and indicator 'effects giving
; a list of names of effects. The reason for separating out EQ/NEQ-
; preconditions is that they do not participate in the propagation
; process, but are only used to form final domain intersections.
; Each precondition and effect name will in turn have indicator
; 'wff for the (atomic) formula itself. In addition, in the
; processing of positive preconditions each predicate (other than
; EQ) is given an indicator 'occurrences listing the names of
; preconditions in which the predicate occurs. This facilitates
; the matching process in forward propagation.
;
(setq ops (standardize1 operators inits goals)) ; operator NAMES
; Set intersected domains of variables which do not occur in any
; positive (non-EQ) preconditions to T. (Also remove 'propagated
; flags that may be left over from previous runs.)
;
(dolist (o ops)
(remprop o 'propagated)
(setq op (eval o))
(setq w1 (car (op-whens op))) ; NB: primary "when" assumed to be 1st!
(dolist (w (op-whens op))
(dolist (x (op-pars op))
(if (and (not (occurs-in x (get w 'preconds)))
(or (equal w w1) ; primary when?
(equal T (get w1 x)) ))
(put w x T) ))))
; Initialize the list ww of "when"s whose effects are to be propaga-
; ted (thus potentially modifying individual domains of preconditions
; successfully matched). Typically this will just be the primary
; "when" of *start* (unless there are other operators that have
; no positive preconditions).
;
(dolist (o ops)
(setq op (eval o))
; if op has no primary preconds, include its initial "when"
; and any additional whens lacking (positive) preconds
(when (null (get (car (op-whens op)) 'preconds))
(push (car (op-whens op)) ww)
(dolist (w (cdr (op-whens op)))
(if (null (get w 'preconds))
(push w ww) ))))
; For each "when", initialize the count of unmatched preconditions
; under indicator 'npre
;
(dolist (o ops)
(setq op (eval o))
(dolist (w (op-whens op))
(put w 'npre (length (get w 'preconds))) ))
; For each "when", initialize the count of variables with a nil
; intersected domain under indicator 'ndom, making use of the
; list of preconditions each variable occurs in, stored under its
; indicator 'preconds:
;
(dolist (o ops)
(setq op (eval o))
(dolist (w (op-whens op))
(put w 'ndom 0)
(dolist (x (op-pars op))
(when (*intersection (get x 'preconds) (get w 'preconds))
; if x occurs in the preconditions of the "when", w,
(put w 'ndom (+ (get w 'ndom) 1)) ))))
(loop
; Mark the operators involved in the "when"s ww as 'propagated.
; This flag stays on for the remainder of the processing, and
; prevents repeated propagation in the absence of changes in
; intersected domains.
;
(dolist (w ww) (put (get w 'op) 'propagated T))
; Form the list ee of effects of the "when"s in ww
;
(setq ee nil)
(dolist (w ww) (setq ee (append (get w 'effects) ee)))
; Match each effect e in ee to all possible (+ve) preconditions
; (including preconditions of "when"s), except for EQ-atoms. We
; find match candidates via the 'occurrences property of predicates.
; If a matched precond is not yet marked as matched, mark it as
; matched and decrement the unmatched-precondition count npre for
; the "when" by 1. If the precondition contains variables, update
; the individual domains for those variables in that precondition.
; If the matched precondition belongs to a "when" whose count of
; unmatched preconditions 'npre is (now) zero (and the count of
; unmatched preconditions in the corresponding primary "when" is
; also zero), flag the "when" as a "propagation-candidate".
;
(dolist (e ee) ; iterate over names of effects to be propagated
(setq wff1 (get e 'wff))
(setq pp (get (car wff1) 'occurrences))
(dolist (p pp) ; iterate over names of candidate preconditions
(setq wff2 (get p 'wff))
(setq uni
(left-unifier e wff1 wff2)) ; a list (T (r . v) (r'. v')...)
; where r is a term from wff1
; and v a corresponding variable
; from wff2; failure: uni = nil
(when uni ; successfully matched?
(setq we (get e 'when)
wp (get p 'when) )
(when (not (get p 'matched))
(put p 'matched T)
(put wp 'npre (- (get wp 'npre) 1)) )
(dolist (rv (cdr uni))
(setq r (car rv)
v (cdr rv) )
(if (ground r)
(if (not (*member r (get p v))) ; Note: (get p v) =
; ind. domain of v
(setf (get p v) (cons r (get p v))) )
; r is non-ground:
(when (and (atom r)
(get r 'var)
(not (*subsetp (get we r) ; intersected domain;
(get p v) ))) ; indiv. domain
(put p v (*union (get we r) (get p v))) ))
) ; the "starred" set operators work
; for sets = T (universal set);
; *union is nonrepetitive if the
; input sets are nonrepetitive
(if (and (zerop (get wp 'npre))
(zerop (get (car (op-whens (eval (get wp 'op))))
'npre ))) ; primary 'npre zero also?
(put wp 'propagation-candidate T) ) )))
; Whenever a *primary* "when" is a propagation candidate, flag any
; additional "when"s all of whose preconditions have been matched
; as propagation candidates as well. (This is necessary since a
; match with a primary precondition, resulting in an augmentation of
; an individual variable domain, may lead to an augmented intersected
; domain not only in the primary "when" but also in additional ones.)
;
(dolist (o ops)
(setq op (eval o))
(if (get (car (op-whens op)) 'propagation-candidate)
(dolist (w (cdr (op-whens op)))
(if (zerop (get w 'npre))
(put w 'propagation-candidate T) ))))
; Now form the new list ww of "when"s to be propagated, resetting
; the propagation-candidate flags to nil. For each variable of
; each candidate "when", save its old intersected domain and
; compute its new one. (This first requires collecting the set of
; preconditions relevant to that variable from the current "when"
; and the primary "when".) If some intersected domain of a "when"
; thus becomes augmented or the operator embedding that "when" was
; never previously propagated, and if all intersected domains for
; the "when" as well as for the primary "when" are (now) non-nil,
; add the "when" to ww.
;
(setq ww nil)
(dolist (o ops)
(setq op (eval o))
(setq w1 (car (op-whens op))) ; primary "when"
(dolist (w (op-whens op))
(when (get w 'propagation-candidate)
(remprop w 'propagation-candidate)
(setq augmented nil)
(dolist (x (op-pars op))
(setq olddom (get w x))
(setq preconds ; preconds of w and primary "when"
(if (equal w w1) ; primary "when"?
(get w 'preconds)
(union (get w 'preconds) (get w1 'preconds)) ))
(setq preconds ; filter out preconds not involving x
(intersection preconds (get x 'preconds)) )
(setq newdom
(if preconds
(reduce #'*intersection ; intersect indiv. domains
(mapcar #'(lambda (p) (get p x)) preconds) )
T )) ; if no preconds, domain remains T
(when (not (*subsetp newdom olddom))
(put w x newdom)
(if (and (null olddom) ; first augmentation?
(intersection ; x occurs in w-preconds?
(get x 'preconds)
(get w 'preconds) ))
(put w 'ndom (- (get w 'ndom) 1)) )
(setq augmented T) ))
(if (or augmented (not (get o 'propagated)))
(if (and (zerop (get w 'ndom))
(zerop (get w1 'ndom)) )
(push w ww) )))))
; If the list ww of "when"s to be propagated is nil, construct
; the output list (after further restricting intersected domains
; using EQ-preconditions) and return it.
;
(when (null ww)
; In each "when", examine each EQ-condition. If it
; equates two variables u, v, replace the intersected
; domains of u and v by their intersection. If this is
; the primary "when", also use the new domain to filter
; u and v domains in other "when"s of the operator. If
; the EQ-condition equates a variable and a ground term,
; eliminate terms not equal to that ground term from the
; intersected domain of the variable. Again, if this is
; the primary "when", also use the new (singleton or nil)
; domain to filter the corresponding domains in other "when"s.
(dolist (o ops)
(setq op (eval o))
(setq w1 (car (op-whens op)))
(dolist (w (op-whens op))
(dolist (e (get w 'eqs))
(setq update T)
(setq wff1 (get e 'wff)
u (cadr wff1)
v (caddr wff1) )
(if (and (atom u) (get u 'var))
(setq newdom (get w u))
(if (ground u) (setq newdom (list u))
(setq update nil) ))
(if update
(if (and (atom v) (get v 'var))
(setq newdom (*intersection newdom (get w v)))
(if (ground v)
(setq newdom (*intersection newdom (list v)))
(setq update nil) )))
(when update
(when (and (atom u) (get u 'var))
(put w u newdom)
(if (equal w w1)
(dolist (w2 (op-whens op))
(put w2 u
(*intersection (get w2 u) newdom) ))))
(when (and (atom v) (get v 'var))
(put w v newdom)
(if (equal w w1)
(dolist (w2 (op-whens op))
(put w2 v
(*intersection (get w2 v) newdom) ))))
))))
; ** Note: it would be possible also to deal with inequations
; of form (NEQ variable constant), and even some cases
; of (NEQ variable variable), where one variable has a
; singleton domain at the end of the above processing
; Now construct and return the output list
(dolist (o ops)
(setq op (eval o))
(dolist (w (op-whens op))
(setq entry (list (op-name op)))
(dolist (x (op-pars op))
(push (cons (get x 'var) (get w x)) entry) )
(dolist (p (get w 'preconds))
(if (not (get p 'matched)) ; add unmatched preconds
; to the entry
(push (insert-new-vars (get p 'wff)) entry) ))
(push (reverse entry) results) ))
(return-from find-parameter-domains (reverse results)) )
)
)) ; end of find-parameter-domains
(defun standardize1 (operators inits goals)
;
; PURPOSE: To create standardized versions of the operators, for use
; in the domain calculations; return the list of names of the
; standardized operators (the names are gensym'ed using the
; names of the input operators as initial strings)
; operators: a list of operator names (whose values are operators)
; inits: a list of non-negative ground wffs supplying initial conditions
; goals: if non-nil, a list of wffs possibly containing variables
; (whose names start with "?") supplying the planning goals
; METHOD: Ensure that all variables appearing in preconditions (as
; well as effects) are parameters; standardize apart variable
; names in operators, recording the original variable names
; under a 'var indicator for new variables. This also serves
; to mark the new variables AS variables. Separate out and NAME
; all "when"s, treating the general preconditions and general
; effects of the operator as the primary "when"; (for the named
; "when"s, put the name of the operator under indicator 'op);
; separate out and NAME all POSITIVE preconditions, including
; parameter type constraints and particular preconditions within
; "when"s; store the names of the +ve, non-EQ preconditions in
; which each variable occurs under indicator 'preconds of the
; variable; separate out and NAME all POSITIVE effects,
; including particular effects within "when"s; (for the named
; preconditions and effects, put the name of the "when" they
; belong to under indicator 'when); also encode "inits" as
; *start* operator and "goals", if non-nil, as *end* operator.
; So, the operators we get will be of form
; name (name of the original operator)
; pars (list of standardized variable names)
; whens (list of names of "when"s)
; The standardized operator itself will have a name consisting
; of the name of the original operator, plus a "gensym"ed suffix.
; Each named "when" will have indicator 'preconds giving a list
; of names of its non-EQ preconditions, indicator 'eqs giving
; a list of names of its EQ-preconditions, and indicator 'effects
; giving a list of names of effects. The reason for separating
; out EQ-preconditions is that they do not participate in the
; propagation process, but are only used to form final domain
; intersections. Each precondition and effect name will in turn
; have indicator 'wff for the (atomic) formula itself. In
; addition, in the processing of positive preconditions each
; predicate (other than EQ) is given an indicator 'occurrences
; listing the names of preconditions in which the predicate
; occurs. This facilitates the matching process in forward
; propagation.
;
(prog (ops op newo newop newops vars pre post preconds eqs neqs effs
w1 ww terms wnames wname pred whens)
; Configure inits as an operator, *start*
(setq *start*
(make-operator :parameters nil
:precondition nil
:effect (cons 'and inits) ))
; Configure goals as an operator *end*, if non-nil
(when goals
; Find vars, i.e., goal arguments that start with "?"
(dolist (g goals)
(dolist (x (cdr g)) ; iterate through the terms of each goal
(if (atom x)
(if (char-equal #\? (char (string x) 0))
(when (not (get x 'var)) ; to avoid repetition
(put x 'var T)
(push x vars) )))))
(setq *end*
(make-operator :parameters (reverse vars)
:precondition (cons 'and goals)
:effect nil )))
; Form complete operator list
(setq ops (cons '*start* operators))
(if goals (setq ops (append ops (list '*end*))))
; Standardize each operator (standardizing apart variables, etc.)
(dolist (o ops)
; Initialize the standardized version of the operator
(setq op (eval o))
(setq newo (gensym (string o)))
(push newo newops)
(set newo
(make-op :name o
:pars nil
:whens nil ))
(setq newop (eval newo))
; Initialize the list of variables by taking parameters
; out of type constraints; also use the type constraints to
; initialize the list of preconditions. At this point we
; still keep the old variable names in place.
;
(setq vars nil preconds nil)
(dolist (x (operator-parameters op))
(cond ((atom x) (push x vars))
(T (push (cadr x) vars)
(push x preconds) )))
; Add given positive preconditions, EQs, and NEQs to preconds,
; eqs, or neqs as appropriate
;
(setq pre (separate-wffs (operator-precondition op))
preconds (append (car pre) preconds)
eqs (cadr pre)
neqs (caddr pre) )
; Add simple positive effects and "when"s to effs and whens
; respectively
;
(setq effs nil whens nil)
(dolist (e (if (equal (car (operator-effect op)) 'and)
(cdr (operator-effect op))
(list (operator-effect op)) ))
(cond ((equal (car e) 'WHEN) (push e whens))
((not (equal (car e) 'NOT)) (push e effs)) ))
; Combine preconditions and effects (without whens) into a
; 4-tuple w1 (to be used for the primary "when"). (Reverse
; each of the 4-tuples, to restore the original order of
; occurrence of conditions in the operator.)
;
(setq w1 (mapcar #'reverse (list preconds eqs neqs effs)))
; Form a list ww of 4-tuples, each corresponding to a "when"
; on list whens (where a "when" is of form (WHEN wff wff),
; where the two wffs don't contain any WHEN-subformulas).
;
(setq ww nil)
(dolist (w whens)
(setq pre (separate-wffs (cadr w))
post (separate-wffs (caddr w)) )
(push (mapcar #'reverse
(list (car pre) (cadr pre) (caddr pre) (car post)) )
ww ))
(push w1 ww)
; The 4-tuples in ww are now in the same order as the originally
; given when-clauses (with w1 first). This is convenient below
; for obtaining any extra variables in the "when"s in their
; "natural" order of occurrence in the input. (And ultimately,
; it ensures that outputs of find-parameter-domains will be
; in the proper order for correct interpretation.)
; Add variables occurring in ww to vars, if not present yet
; on that list. Do this by forming a list of all terms occurring
; in preconditions and effects, setting the 'var property of
; all the atomic terms on that list as well as in vars to nil,
; then setting the 'var property of atoms on vars to new
; (gensym'd) names, then checking for additional ?-variables
; among the terms, also setting their 'var property to new
; names and adding them to vars. Conversely, set the 'var
; property of the new variables to the old variables, thus
; flagging the new variables as such (and allowing recovery of
; the old names for output purposes). In the end, reverse vars.
;
(setq terms
(remove-if-not #'atom ; guard against functional expressions
(apply #'append
(mapcar #'cdr (apply #'append (apply #'append ww))) )))
(dolist (x vars) (remprop x 'var))
(dolist (x terms) (remprop x 'var))
(dolist (x vars) (put x 'var (gensym (string x))))
(dolist (x terms)
(when (and (not (get x 'var))
(char-equal (char (string x) 0) #\?) )
(put x 'var (gensym (string x)))
(push x vars) ))
(dolist (x vars) (put (get x 'var) 'var x))
(setq vars (reverse vars))
; Convert vars to the list of new variables, storing these
; as the value of (op-pars newop)
;
(setf (op-pars newop)
(mapcar #'(lambda (x) (get x 'var)) vars) )
; Create names for the whens (currently represented as tuples
; in ww), putting 'op, 'preconds, 'eqs, 'neqs, and 'effects
; on their property lists, with appropriate values (in particular,
; with wffs altered so as to use the renamed variables), and store
; the list of names as wnames
;
(setq wnames nil)
(dolist (w ww)
(setq wname (gensym "WHEN"))
(put wname 'op newo)
(name-and-put-wffs wname 'preconds "PRE" (car w))
(name-and-put-wffs wname 'eqs "EQ" (cadr w))
(name-and-put-wffs wname 'neqs "NEQ" (caddr w))
(name-and-put-wffs wname 'effects "EFF" (cadddr w))
(push wname wnames) )
; Store the list of names of "when"s in the whens field of newop:
;
(setf (op-whens newop) (reverse wnames)) ) ; end of (dolist (o ops)..)
; Set up 'occurrences indicators on predicate names, giving names
; of preconds in which each predicate occurs. (Begin by setting the
; indicators to nil, since the same predicates may occur in different
; runs of standardize1. This "slate-cleaning" has to be done not
; only for precond predicates but also for effect predicates, since
; the propagation process looks for preconditions matching given
; effects, and should not find any pointers from effect predicates
; to stale preconditions!) At the same time, set up 'preconds indicators
; on variables, supplying all the preconds in which each variable
; occurs.
;
(dolist (o newops)
(setq op (eval o))
(dolist (w (op-whens op))
(dolist (p (append (get w 'preconds) (get w 'effects)))
(setq pred (car (get p 'wff)))
(put pred 'occurrences nil) )))
(dolist (o newops)
(setq op (eval o))
(dolist (w (op-whens op))
(dolist (p (get w 'preconds))
(setq pred (car (get p 'wff)))
(put pred 'occurrences (cons p (get pred 'occurrences)))
(dolist (x (cdr (get p 'wff))) ; iterate over terms
(when (get x 'var)
(put x 'preconds (cons p (get x 'preconds))) )))))
(return (reverse newops))
)) ; end of standardize1
(defun separate-wffs (big-wff)
;
; big-wff is either a single literal (positive or negated) or an
; AND-conjunction of literals. Form 4 lists of literals as output:
; positive non-EQ, non-NEQ wffs, positive EQ-wffs, positive NEQ-wffs,
; and (NOT (...))-literals. (Convert any occurrences of (NOT (EQ ...))
; to (NEQ ...) and (NOT (NEQ ...)) to (EQ ...).) The original order
; of occurrence of subformulas will be reversed within each of the
; four sublists.
;
(if (atom big-wff)
(cond (big-wff (terpri) (princ "*** Bracket-less atomic formula ")
(princ big-wff) (princ " violates predication syntax")
(terpri))
(t '(nil nil nil nil)) )
(prog (preds eqs neqs nots)
(dolist (w (if (equal (car big-wff) 'and)
(cdr big-wff)
(list big-wff) ))
(cond ((equal (car w) 'EQ) (push w eqs))
((equal (car w) 'NEQ) (push w neqs))
((equal (car w) 'NOT)
(if (equal (caadr w) 'EQ) ; allow for "(NOT (EQ ...))"
(push (cons 'NEQ (cdadr w)) neqs)
(if (equal (caadr w) 'NEQ) ; allow for "(NOT (NEQ ...))"
(push (cons 'EQ (cdadr w)) eqs)
(push w nots) )))
(T (push w preds)) ))
(return (list preds eqs neqs nots))
))) ; end of separate-wffs
(defun name-and-put-wffs (atm indic name-start wffs)
;
; On the property list of the "when" named atm, under indicator indic,
; store a list of names starting with the string name-start, where each
; name has one of the wffs stored on its property list under indicator
; 'wff, and also has atm stored under indicator 'when. Rather than
; storing the input wffs, store versions that use the 'var property
; of the variables in the input wffs as new names of those variables.
;
(prog (fname fnames)
(dolist (f wffs)
(setq fname (gensym name-start))
(put fname 'wff (insert-new-vars f))
(put fname 'when atm)
(push fname fnames) )
(put atm indic fnames) ))
(defun insert-new-vars (wff)
; Replace variables in wff by the 'var-value found on their
; property lists; return the modified wff
(if (atom wff)
(if (or (null wff) (null (get wff 'var)))
wff
(get wff 'var) )
(cons (insert-new-vars (car wff)) (insert-new-vars (cdr wff))) ))
(defun ground (wff)
;
; Does the wff (or functional expression) contain only ground atoms
; in a term-position? (Variable atoms are assumed to have a non-nil
; value under indicator 'var)
(if (atom wff)
(if wff (not (get wff 'var)) T)
(dolist (term (cdr wff) T)
(when (not (ground term))
(return-from ground nil)) )))
(defun occurs-in (var precond-names)
;
; PURPOSE: To check whether variable "var" occurs in the preconditions
; on the property lists of the given list of precondition names,
; "precond-names". Since preconditions in operator specifications
; generated by "standardize1" are positive, we need only check
; whether var occurs in the cdr of any of the preconditions.
;
(dolist (n precond-names)
(when (member var (cdr (get n 'wff)))
(return-from occurs-in T) ) ; dolist returns nil by default
)) ; end of occurs-in
(defun left-unifier (eff wff1 wff2)
;
; An asymmetric unifier function for variable domain propagation.
; wff1 is the wff for the operator effect named eff, and wff2
; is a precondition formula of some operator to which we are
; propagating domains.
;
; wff1 and wff2 are atomic formulas, presumed to have no variables
; in common (otherwise erroneous unifiers may result). The unifier
; (if not nil - failure) is of form (T (r . v) (r'. v') ..), where
; r is a variable or term from wff1 and v is a variable from wff2.
; A variable on the right is always unifiable with a term "propag-
; ating" from the left; but a variable on the left unifies only with
; terms on the right that are already included in its intersected domain.
; E.g., (left-unifier 'eff1 '(on x A) '(on y z)) = (T (x . y) (A . z));
; (left-unifier 'eff1 '(on A B) '(on A B)) = (T) ;
; (left-unifier 'eff1 '(on A B) '(on B x)) = nil.
; (left-unifier 'eff1 '(on x B) '(on A B)) may be (T) or nil,
; depending on whether or not the intersected domain for x
; (within the "when" to which eff1 belongs) contains A
; A variable x is expected to have a non-nil value for (get x 'var).
(when (and (equal (car wff1) (car wff2)) (equal (length wff1) (length wff2)))
(do ((w1 (cdr wff1)) (w2 (cdr wff2)) (uni '(T)))
((null w1) (reverse uni))
(if (and (atom (car w2)) (get (car w2) 'var))
(push (cons (car w1) (car w2)) uni)
; The matched precond argument (in wff2) is not a variable:
(if (and (atom (car w1)) (get (car w1) 'var)
(*member (car w2) (get (get eff 'when) (car w1))) )
T ; do nothing - the match propagates no domain elements
; ***But this assumes no variable occurs more than once
; in wff1 -- otherwise, the specific binding (car w1)
; should receive here (in place of its intersected
; domain) should constrain matching of any OTHER
; occurrences of (car w1)! One way to handle this
; would be with a temporary property put on variables
; of wff1, initially holding their intersected domain,
; and updated to hold a constant binding, if any; or,
; replace the remainder of wff1 in such a case with
; the appropriate substitution instance.
(when (not (equal (car w1) (car w2)))
(return-from left-unifier nil) )))
(setq w1 (cdr w1) w2 (cdr w2)) ))) ; end of left-unifier