;; PROGRAMS FOR PLANNING AND ACTING IN GRIDWORLD ;;============================================== ; Some of the programs allow for equality/inequality literals ; of form (EQ t1 t2) or (NEQ t1 t2), but don't try to use this here. ; ;; SOME GLOBAL ENTITIES ;; ==================== (defvar *plan* nil); shows the currently best sequence of future actions ;~~~~~~~~~~~~~~~~~~ (defvar *states* nil); sequence of states, starting at present, ;~~~~~~~~~~~~~~~~~~~~; corresponding to *plan*; (defvar *occluded-predicates* nil); predicates for local facts that are ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; not immediately known to ME (unless ; the 1st (subject) argument is ME) (defvar *inference-limit* 2) ; depth of forward inference; ;~~~~~~~~~~~~~~~~~~~~~~~~~~ (defvar *history* nil) ; the sequence of actions (with parameter values) ;~~~~~~~~~~~~~~~~~~~~~ ; taken so far; (defvar *operators* nil) ; names of the available operators; ; must be set by the user (defvar *search-beam* nil) ; list of items, each of form (i . op-names), ;~~~~~~~~~~~~~~~~~~~~~~~~~ ; where i > 0 and op-names lists the op. names ; (to be set by the user) ;; SOME BASIC UTILITIES ;; ==================== (defun put (atm indic val) (setf (get atm indic) val)) ;~~~~~~~~~~~~~~~~~~~~~~~~~ (defun unionf (x y) (union x y :test #'equal)) ;~~~~~~~~~~~~~~~~~~ (defun memberf (x y) (member x y :test #'equal)) ;~~~~~~~~~~~~~~~~~~ (defun intersectionf (x y) (intersection x y :test #'equal)) ;~~~~~~~~~~~~~~~~~~~~~~~~~ (defun set-differencef (x y) (set-difference x y :test #'equal)) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~ (defun var (x) ; is x a variable, i.e., an atom with first character"?" ;~~~~~~~~~~~~~ (if (and x (symbolp x)) (char= (nth 0 (coerce (string x) 'list)) #\?) nil )) (defun *append (u v); append 2 lists where one or both may be T, ;~~~~~~~~~~~~~~~~~~~; interpreted here as trivial unifier, hence, ; like the empty list (if (equal u T) v (if (equal v T) u (append u v))) ) (defun first-n (x n) ;~~~~~~~~~~~~~~~~~~~~ ; Return the length-n prefix of x (if (atom x) x (butlast x (max 0 (- (length x) n)))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; ROUTINES FOR FINDING THE BINDINGS THAT MATCH GOALS TO A STATE ;; ;; ============================================================= ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun all-bindings-of-goals-to-facts (goals facts); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Find all unifiers of the variables occurring in goals (a set ; of +ve & -ve literals, possibly containing variables) obtainable ; by matching the goals to the facts (a set of +ve ground literals); ; ; Method: Here we just reorder the goals and extract all terms ; occurring in 'facts', and then call the recursive routine ; (all-bindings-of-goals-to-facts1 goals facts terms) -- see ; this for further explanation. ; (let ((gg goals) (ff facts) (terms (collect-terms facts))) ; Reorder goals so that positive goals come before negative ; goals, and for same-sign goals, goals with more variables ; precede ones with fewer variables, and for same-sign, same- ; number-of-variables goals, goals with more arguments precede ; ones with fewer arguments; this is to minimize work in matching; ; (setq gg (sort (copy-list gg) #'> :key #'rank-for-goal-sorting)) (setq ff (sort (copy-list ff) #'> :key #'length)) (all-bindings-of-goals-to-facts1 gg ff terms) )); end of all-bindings-of-goals-to-facts (defun rank-for-goal-sorting (goal) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Assign a rank to 'goal' so that all positive goals have a higher ; rank than all negative goals, and among goals of the same sign, ; goals with fewer variables always have a higher rank than goals ; with more variables, and among goals of the same sign with the ; same number of variables, goals with more terms always have ; higher rank than goals with fewer terms. Assume that a predicate ; can have no more than 10 arguments (o/w ranks won't be exactly ; as stated). The idea is to give highest ranks to goals that will ; tend to cut down the search space most quickly (i.e., have few ; matches). ; (let ((rank (if (poslit goal) 200 0)) (var-count (length (remove-duplicates (vars goal)))) (term-count+1 (if (poslit goal) (length goal) (length (second goal))))) (decf rank (* 10 var-count)) (incf rank term-count+1) rank )); end of rank-for-goal-sorting (defun all-bindings-of-goals-to-facts1 (goals facts terms); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Find all unifiers of the variables occurring in goals (a set ; of +ve & -ve literals, possibly containing variables) obtainable ; by matching the goals to the facts (a set of +ve ground literals), ; using 'terms' as the names of all possible individuals (these ; are just the *distinct* terms occurring in 'facts', precomputed ; for convenience); ; Method: ; 1. results := nil; {initialization} ; 2. uu := all-bindings-of-goal-to-facts(first(gg),facts,terms); ; 3. if rest(gg) = nil then return uu; ; 4. if uu = (t) (first goal matched exactly) ; then return all-bindings-of-goals-to-facts1 ; (rest(gg), facts, terms); ; 5. For each u in uu: ; i. vv := all-bindings-of-goals-to-facts1 ; (rest(gg)_u, facts, terms), ; where subscript _u indicates substitution using u; ; ii. if vv = nil then continue with next u in uu; ; iii. append to 'results' all the unifiers obtained by ; grafting u into the unifiers in vv; ; 6. return results. ; (prog ((gg goals) g results uu vv) (setq g (pop gg)) (setq uu (all-bindings-of-goal-to-facts g facts terms)) (if (null gg) (return uu)) (if (equal uu '(t)) (return (all-bindings-of-goals-to-facts1 gg facts terms)) ) (dolist (u (reverse uu)); just to end up with original order (setq vv (all-bindings-of-goals-to-facts1 (subst-unifier-in-wffs u gg) facts terms) ) (when vv (setq vv (mapcar #'(lambda (v) (*append u v)) vv)) (setq results (append vv results)) )) (return results) )); end of all-bindings-of-goals-to-facts1 (defun all-bindings-of-goal-to-facts (g ff terms) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (if (poslit g) (all-bindings-of-posgoal-to-facts g ff) (all-bindings-of-neggoal-to-facts g ff terms) )) (defun all-bindings-of-posgoal-to-facts (g ff) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (remove-if #'null (mapcar #'(lambda (f) (unifier g f)) ff)) ) (defun all-bindings-of-neggoal-to-facts (g ff terms) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (complement-unifiers (all-bindings-of-posgoal-to-facts (second g) ff ) (vars g) terms )) (defun alphabetically-order (uu); alphabetically order variables in ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~; the unifiers listed in uu; tested (mapcar #'(lambda (u) (if (eq u t) t (sort (copy-list u) #'string< :key #'(lambda (x) (string (car x))) ))) uu )) (defun complement-unifiers (uu vars terms); tested ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Find the bindings of 'vars', with elements of 'terms' as possible ; binders, that DON'T coincide with any bindings in 'uu'. ; ; Method in the general case: subtract uu from the set of all bindings ; (where we're sure the subtraction works because the order of variables ; in unifiers is first made uniform). ; ; The elements of uu are generally of form ((var1 . val1) ... ; (vark . valk)), where the var1, ..., vark are the same (and in the ; same order) in all cases. However, it is possible that uu is nil ; while the given 'vars' are nonempty, in which case all possible ; bindings of the 'vars' should be returned -- that's why the 'vars' ; are separately supplied. Also uu might be (t) (indicating that the ; positive form of a negative ground literal was matched to a state), ; in which case the result should be nil. ; (if (null vars); then uu must be nil or '(t) (return-from complement-unifiers (if (null uu) '(t) nil)) ) (if (null terms); unexpected condition (return-from complement-unifiers nil) ) (let (ordered-vars ordered-uu vv) ; we keep variables in lexicographic order, so that set- ; differencing will work (e.g., the set-difference between ; (((?x . a) (?y . b))) & (((?y . b) (?x . a))) should be nil) (setq ordered-vars (sort (copy-list vars) #'string< :key #'(lambda (x) (string x)) )) (setq ordered-uu (alphabetically-order uu)) (setq vv (all-bindings ordered-vars terms)) ; `all-bindings' keeps the variables in the given order in ; the list of unifiers produced as output; (reverse (set-differencef vv ordered-uu)) )); end of complement-unifiers (defun all-bindings (vars terms); cons each var with each term ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (let (vv ww) (cond ((and vars terms) (setq vv (mapcar #'(lambda (x) (cons (car vars) x)) terms)) (setq ww (all-bindings (cdr vars) terms)) (combine-sets-of-unifiers (mapcar #'list vv) ww) ) (t nil) ))); end of all-bindings (defun combine-sets-of-unifiers (uu vv); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; concatenate each unifier in uu with each unifier in vv; ; the variables in uu will precede those in vv; (if (null uu) (return-from combine-sets-of-unifiers vv)) (if (null vv) (return-from combine-sets-of-unifiers uu)) (let (result) (dolist (u (reverse uu)) (setq result (append (mapcar #'(lambda (v) (*append u v)) vv) result) )) result )); end of combine-sets-of-unifiers ;; The following two programs ignore the possibility of EQ, NEQ ;; literals for the time being.. (defun poslits (lits); all positive lits among 'lits' ;~~~~~~~~~~~~~~~~~~~~~ (remove-if-not #'poslit lits)) (defun neglits (lits); all negatively embedded atoms among 'lits' ;~~~~~~~~~~~~~~~~~~~~~ (mapcar #'second ; drop "not"s (remove-if-not #'neglit lits))) (defun poslit (lit) (not (neglit lit))) ;~~~~~~~~~~~~~~~~~~ (defun neglit (lit) (and (listp lit) (eq (car lit) 'not))) ;~~~~~~~~~~~~~~~~~~ (defun collect-terms (lits); all terms occurring in literals 'lits' ;~~~~~~~~~~~~~~~~~~~~~~~~~~~ (remove-duplicates (apply #'append (mapcar #'args lits)) :test #'equal )) (defun vars (lit); bag of variables occurring in literal 'lit' ;~~~~~~~~~~~~~~~~~ (if (atom lit) nil (remove-if-not #'var (args lit)))) ;; NOT USED AT PRESENT (defun collect-vars (lits); set of vars occurring in literals 'lits' ;~~~~~~~~~~~~~~~~~~~ (remove-duplicates (apply #'append (mapcar #'vars lits)))) (defun args (lit); return list of args occurring in literal 'lit' ;~~~~~~~~~~~~~~~~~~~ (cond ((atom lit) nil) ((eq (car lit) 'not) (cdr (second lit))) (t (cdr lit)) )) ;; NOT USED AT PRESENT (defun find-all-positive-bindings (poslits db); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Find all sets of bindings of the variables occurring in poslits (a ; set of positive literals) obtainable by matching poslits to the db ; (a set of positive ground literals); ; (prog (results phi u remlits vv) (if poslits (setq phi (car poslits)) (return '(T)) ); T is the trivial unifier (dolist (phi1 (if (equal (car phi) 'EQ) (equalities db) db )) (setq u (unifier phi phi1)) (when u (setq remlits (mapcar #'(lambda (x) (subst-unifier u x)) (cdr poslits) )) (setq vv (find-all-positive-bindings remlits db)) (if vv (setq results (unionf results (mapcar #'(lambda (v) (*append u v)) vv) ))))) (return results) )); end of find-all-positive-bindings ;; NOT USED AT PRESENT (defun equalities (db); ;~~~~~~~~~~~~~~~~~~~~~~ ; Find all equalities of form (EQ c c) where c is some constant appearing ; in db (a set of positive, function-free ground literals). (let ((constants (remove-duplicates (reduce #'append (mapcar #'cdr db))))) (mapcar #'(lambda (x) (list 'EQ x x)) constants) )) (defun unifier (lit1 lit2); ;~~~~~~~~~~~~~~~~~~~~~~~~~ ; Unify two literals (where `lit2', contains only ground terms) ; if possible, returning the unifier if it exists and nil otherwise. ; For equal ground literals, the unifier is T, else it is a list ; ((var1 . term1) ... (vark . termk)). Variables are NOT renamed, ; i.e., a variable occurring in both lit1 and lit2 will be uniformly ; bound to a unique term. Variables are expected to be Lisp symbols ; starting with `?'. Substitution for variables of lit1 is preferred ; to substitution for variables of lit2. (if (not (equal (car lit1) (car lit2))) nil (if (equal (cdr lit1) (cdr lit2)) T ; trivial unifier (if (equal (car lit1) 'not) (unifier (second lit1) (second lit2)) (if (not (equal (length lit1) (length lit2))) nil ((lambda (x) (if (null x) T; a null arglist unifier ; implies (trivial) success (if (member nil x) nil x) )); a null ; element indicates a ; failed substitution (arglist-unifier (cdr lit1) (cdr lit2)) )))))) (defun subst-unifier (uni wff); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Substitute for variables of wff as specified by unifier uni. ; uni may be T (trivial unifier, for which we return wff) or of form ; ((var1 . term1) ... (vark . termk)) (prog ((wff-out wff)) (if (equal uni t) (return wff)) (dolist (pair uni) (setq wff-out (subst (cdr pair) (car pair) wff-out)) ) (return wff-out) )) (defun subst-unifier-in-wffs (uni wffs); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (mapcar #'(lambda (wff) (subst-unifier uni wff)) wffs)) (defun arglist-unifier (list1 list2); tested ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Unify equal-length lists of (perhaps functional) terms where the ; terms in `list1' may be, or may contain, variables (Lisp symbols ; with initial character `?'). Here result nil indicates trivial ; success, & (nil) indicates failure. (if (null list1) nil (if (equal (car list1) (car list2)) (arglist-unifier (cdr list1) (cdr list2)) (if (var (car list1)) (cons (cons (car list1) (car list2)) (arglist-unifier (subst (car list2) (car list1) (cdr list1)) (subst (car list2) (car list1) (cdr list2)) )) ; initial complex terms? (if (and (listp (car list1)) (listp (car list2)) (= (length (car list1)) (length (car list2))) ) (let ((uni (arglist-unifier (car list1) (car list2)))) (append uni (arglist-unifier (subst-unifier uni (cdr list1)) (cdr list2) ))) '(nil) ))) ; nil in unifier list signals failure )); end of arglist-unifier ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; ROUTINES FOR DEFINING AND INSTANTIATING ACTION OPERATORS ;; ;; ======================================================== ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct op ; an operator (type of action), or instance of it ;~~~~~~~~~~~~~ name ; name of the action type (even for an instance) instance ; name of this instance (or nil, for an operator), ; whose value (under eval) is this operator instance; pars ; variables, starting with "?" (e.g., ?x, ?y, ...), ; or specific values (ground terms), for instances; preconds ; a list of positive or negative literals, often ; containing parameters as (or in) arguments; effects ; a list of literals, same syntax as for preconds; time-required ; estimated time required, which should be numerical ; or a lisp expression that can be evaluated if all ; parameters therein (if any) are replaced by ; specific values; value ; the inherent reward (or cost) of the operator, ; which could be numerical or a lisp expression ; which can be evaluated if all parameters therein ; (if any) are replaced by specific values; ); end of op (defun instantiate-op (op uni) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Form an instance of action type 'op', returning a (generated) ; name of the instance, as a variant of the name of 'op' ; The procedure is formulated in such a way that it could be ; used equally well for partial instantiation as for full ; instantiation of an operator. ; (if (null uni) (return-from instantiate-op nil)) (let* ((name (op-name op)) (instance (gensym (string name))) (pars (op-pars op)) (preconds (op-preconds op)) (effects (op-effects op)) (time-required (op-time-required op)) (value (op-value op)) ) (when (not (eq uni t)); not the trivial unifier (dolist (u uni) (setq pars (subst (cdr u) (car u) pars)) ) (dolist (u uni) (setq preconds (subst (cdr u) (car u) preconds)) ) (dolist (u uni) (setq effects (subst (cdr u) (car u) effects)) ) (dolist (u uni) (setq time-required (subst (cdr u) (car u) time-required)) ) (setq time-required (simplify-value time-required)) (dolist (u uni) (setq value (subst (cdr u) (car u) value)) ) (setq value (simplify-value value)) ) (set instance (make-op :name name :instance instance :pars pars :preconds preconds :effects effects :value value )) instance ; return name of instance )); end of instantiate-op (defun simplify-value (expr) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Evaluate or simplify Lisp expression expr (generally expected ; to be an arithmetic expression (though it may also involve ; user-defined functions), possibly containing variables (which ; are atoms starting with "?"). A functional (sub)expression is ; evaluated, and thus simplified, only if ALL its arguments are ; variable-free. For example, an expression (+ 1 1 ?x) is not ; further simplified, and (+ 1 (* 2 3) ?x) is simplified just ; to (+ 1 6 ?x). ; (cond ((var expr) expr) ((atom expr) (eval expr)) ((not (contains-var expr)) (eval expr)) ((atom (car expr)) (cons (car expr) (mapcar #'simplify (cdr expr))) ) (t expr) ; unexpected condition: nonatomic functor )); end of simplify (defun contains-var (expr) ;~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Does Lisp expression 'expr' contain a variable (atom starting ; with "?") at any structural level? ; (cond ((var expr) t) ((atom expr) nil) ((find-if #'contains-var expr) t) (t nil) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; ROUTINES FOR FORWARD CHAINING AND PLAN SELECTION/EXECUTION ;; ;; ========================================================== ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct state-node ; a node in a tree of states generated ; by forward search; name ; a (generated) atomic name, whose value ; (via eval) is this state-tree node wffs ; a list of ground atomic wffs defining ; the state (though the ground requirement, ; and prohibition of negations may ; eventually be relaxed); children ; a list ((action-name_1 . state-node-name_1) ; ... (action-name_k . state-node-name_k)) ; pairs, where each action-name_i is the name ; of an action instance and state-node-name_i ; is the name of the corresponding successor ; state; some of these children might have no ; successors at a given time, others might ; have successors to various depths; operators ; list of the names of the operators that ; were used so far in generating children; ; more might yet be added, generating further ; children; parent ; the (action-name . state-node-name) pair ; which generated this state. For the very ; first state in Gridworld, this is nil; local-value ; a numerical value for the "desirability" ; (reward) of that state, presumably ; computed by taking the initial state to ; have 0 value, and then computing changes ; in state-value based on the effects of ; each action taken since that initial state ; (these values are in general estimates, ; because states are in general predicated ; rather than real); forward-value ; the estimated cumulative value of the best ; plan starting at this state (not counting ; the local-value at the present state); ; this counts both the inherent values of ; the actions of the best plan and the states ; generated by that plan. ); end of state-node (defun chain-forward (state-node search-beams) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Chain forward from the given state (set of +ve ground wffs), ; conducting a beam search using the operators and beam widths ; specified in 'search-beams', and return the forest of plans, ; attached to 'state-node' with the best plan first (i.e., ; following leftmost branches in the leftmost tree). The idea ; is to call this program, and then actually execute the first ; step of the best plan, and then iterate. If we stick to the ; same beam-width after executing the first step, and the beam- ; widths for successive steps are decreasing, then after each ; step the forward search just adds some more branches to the ; plan-tree, rather than starting from scratch. ; ; The actions formed as children of the given state-node are ; provided as output (along with their values), but the "real" ; output consists of the changes made to the planning tree ; emanating from the given state-node (whose leftmost, i.e., ; seemingly best, action sequence also becomes available as ; the value of *plan*, and whose corresponding leftmost state ; sequence becomes available as *states*). ; ; state-node: a structured state node, from which we are ; to chain forward (in general, adding to children that ; are already present); ; search-beams: a list ((n_1 . ops_1) ... (n_k . ops_k)), where the ; n_i are numerical upper bounds on the number of distinct ; successor actions to be searched further from, when adding ; the ith step of any plan obtained in the forward-chaining, ; and each ops_i is a list of operators (specified by name) ; to be considered (in addition to ones that may have been ; considered in a previous iteration) when adding possible ; ith steps to any plan. ; (if (null search-beams) (return-from chain-forward nil)) (let* ((state-node-name (state-node-name state-node)) (wffs (state-node-wffs state-node)) (children (state-node-children state-node)) (operators (state-node-operators state-node)) (parent (state-node-parent state-node)) (local-value (state-node-local-value state-node)) (beam (car search-beams)) (nbest (car beam)) ; a numerical beam width (ops (cdr beam)) ; a list of operator names (extra-ops (set-difference ops operators)) action-state-pairs ) ; METHOD from this point on: ; ; if extra-ops is non-nil, then we need to generate all ; children using them, adding them to children and evaluating ; them, and merge-sorting them into the preexisting children; ; find the nbest children generated by the preexisting and newly ; given ops, and recursively chain forward from each of them ; using (cdr search-beams); ; re-order the children in order of highest (forward-value ; + action value + local-value of successor state), say = max; ; reset the children of the current state-node; ; reset the forward-value of state-node to max. ; ; Note that this correctly resets forward-values for all children ; generated by ops, and their successors (for the operators ; specified in 'search-beams'); ; (when extra-ops (setf (state-node-operators state-node) (append extra-ops operators) ) (setq action-state-pairs (apply #'append (mapcar #'(lambda (o) (all-instances-of-operator o state-node-name) ) extra-ops ))) (setq action-state-pairs ; sort them (sort action-state-pairs #'> :key #'inclusive-value) ) (setq children ; merge new actions into them (merge 'list action-state-pairs children #'> :key #'inclusive-value ))) ; Recursively chain forward from the nbest children -- i.e., ; the ones earliest in the list: (setq action-state-pairs (first-n children nbest)) (dolist (pair action-state-pairs); search forward recursively (chain-forward (eval (cdr pair)) (cdr search-beams)) ) ; reorder recursion-pairs, since they now have new back- ; propagated values: (setq action-state-pairs (sort action-state-pairs #'> :key #'inclusive-value) ) ; Merge them back into 'children': (setq children ; merge new actions into them (merge 'list action-state-pairs (nthcdr nbest children) #'> :key #'inclusive-value )) ; reset the children of the current state-node: (setf (state-node-children state-node) children) ; reset forward-value of state-node (=> back-propagation) (when children (setf (state-node-forward-value state-node) (inclusive-value (car children)) ); seemingly best child ; reset *plan* (setq *plan* (leftmost-action-sequence (car children))) (setq *states* (leftmost-state-sequence (car children))) ) (show-actions-and-forward-values children) ; return actions with ; their parameters, and the inclusive-values of the actions. )); end of chain-forward (defun leftmost-action-sequence (action-state-pair) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Starting with the action in the given action-state-pair, ; continue tracing leftmost successors till a state with no ; children is reached. Return the sequence of actions. ; (prog ((pair action-state-pair) action-name state-node-name plan children ) (if (null pair) (return nil)) next (setq action-name (car pair) state-node-name (cdr pair)) (push (action-type action-name) plan) (setq children (state-node-children (eval state-node-name))) (if (null children) (return (reverse plan))) (setq pair (car children)) (go next) )); end of leftmost-action-sequence (defun leftmost-state-sequence (action-state-pair) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Starting with the parent state of the given action-state-pair, ; continue tracing leftmost successor states till a state ; with no children is reached. Return the sequence of states. ; (prog ((pair action-state-pair) (parent (state-node-parent (eval (cdr action-state-pair)))) action-name state-node-name states children ) (if (null pair) (return nil)) (if parent (setq states (list (state-node-wffs (eval (cdr parent)))) )) next (setq action-name (car pair) state-node-name (cdr pair)) (push (state-node-wffs (eval state-node-name)) states) (setq children (state-node-children (eval state-node-name))) (if (null children) (return (reverse states))) (setq pair (car children)) (go next) )); end of leftmost-state-sequence (defun action-type (action-name) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Show the name of the action together with its parameters ; (cons (op-name (eval action-name)) (op-pars (eval action-name)) )) (defun show-actions-and-forward-values (action-state-pairs) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Show each action type & the corresponding arguments, postfixed ; with the inclusive value (the value of the action, plus the ; local-value of the state, plus its forward-value) ; (mapcar #'(lambda (pair) (cons (action-type (car pair)) (inclusive-value pair) )) action-state-pairs )) (defun inclusive-value (action-state-pair) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; 'action-state-pair' is of form (action-name . state-node-name). ; Its 'inclusive-value' is the sum of: the value of the action ; named by 'action-name', the local-value of the state implicit ; in 'state-node-name', and the 'forward-value' of that state. ; (+ (op-value (eval (car action-state-pair))) (state-node-local-value (eval (cdr action-state-pair))) (state-node-forward-value (eval (cdr action-state-pair))) )) (defun all-instances-of-operator (op-name state-node-name) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Return all instances of the operator named by 'op-name', ; paired with the names of the resulting state-nodess, that can ; be formed by binding the preconds of the operator to the wffs ; in the state with name 'state-node-name'. So the output list ; consists of pairs (action-name . state-node-name), where the ; values of these (new) names are an operator instance and a ; state-node respectively. Use 'all-bindings-of-goals-to-facts', ; and 'instantiate-op'. ; (let* ((op (eval op-name)) (state-node (eval state-node-name)) (preconds (op-preconds op)) (wffs (state-node-wffs state-node)) bindings instances state-nodes ) (setq bindings (all-bindings-of-goals-to-facts preconds wffs) ) ; filter out bindings that contain the same values ; for different variables: (setq bindings (remove-if #'degenerate-binding bindings) ) ; generate an instance for each binding (setq instances (mapcar #'(lambda (u) (instantiate-op op u)) bindings )) ; This list of instance names now needs to be augmented ; with names of resulting states; for this we need to ; apply the effects of each operator instance to the ; wffs of state-node: (setq state-nodes (mapcar #'(lambda (i) (generate-state i state-node-name) ) instances )) (mapcar #'cons instances state-nodes); return pairs )); end of all-instances-of-operator (defun degenerate-binding (u) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; A unifier that assigns the same value to different variables; ; We assume that such bindings are not allowed for the operators ; under consideration. For example, transferring an object ?x from ; ?y to ?z only makes sense when ?x, ?y, ?z are all distinct. ; (if (atom u) nil (> (length u) (length (remove-duplicates (mapcar #'cdr u) :test #'equal) )))) (defun generate-state (action-name state-node-name) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Generate a named state-node as child of the given state-node, ; generated by applying the effects of the given action to ; the given state. ; (let* ((action (eval action-name)) (effects (op-effects action)) (deletions (neglits effects)) (additions (poslits effects)) (state-node (eval state-node-name)) (wffs (state-node-wffs state-node)) (local-value (state-node-local-value state-node)) (new-state-node-name (gensym "STATE-NODE")) new-local-value new-forward-value ) ; Remove deletions that are the same as additions: (setq deletions (set-differencef deletions additions)) ; Remove additions that are the same as existing wffs: (setq additions (set-differencef additions wffs)) ; Thus only real changes are counted in 'new-local-value': (setq new-local-value ; inherent value of the new state (state-value wffs additions deletions local-value) ) (setq new-forward-value ; expected future rewards/costs, for (expected-rewards wffs) ); action sequences (& their effects) ; starting at the new state; this seems ; like a candidate for learning, based ; on experience in starting from similar ; states; but we'll have to settle for ; some sort of heuristic guess for now -- ; maybe the same value for all states ; (with an "optimistic" bias); later this ; value gets replaced by back-propagated ; values, based on action sequences ; generated from the new state; ; Update the set of wffs to reflect the new state: (setq wffs (append additions (set-differencef wffs deletions))) ; ### At this point we should insert forward inferencing (in case ; ### there are inference rules associated with dynamic properties) ; ### This will use `all-inferences', as in `initialize-state'. (set new-state-node-name (make-state-node :name new-state-node-name :wffs wffs :children nil :operators nil :parent (cons action-name state-node-name) :local-value new-local-value :forward-value new-forward-value )) (state-node-wffs (eval new-state-node-name)); debugging new-state-node-name )); end of generate-state (defun initialize-state ( ) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; This sets *curr-state* to a state-node, using `make-state-node'. ; Most importantly, it sets the `wffs' field of that state-node ; so as to cover the *roadmap-knowledge* (we should perhaps consider ; whether to just use facts about nearby roads/points?), plus the ; "non-occluded" facts (that should be evident to the ME agent) ; about entities located at *here* (the point at which the ME agent ; has been placed by the user), plus expansions of those facts ; obtained by the implicative formulas in *general-knowledge*. ; The `local-value' of the initial state is set to 0 -- this ; is just an arbitrary reference value, and the `forward-value' ; is set by default to, say, 2 (larger values would mean greater ; "optimism about what the future may bring"). ; (let ((road-facts *roadmap-knowledge*) (local-facts (get *here* 'facts)) implied-facts (new-state-node-name (gensym "STATE-NODE")) ) ; Check for predefined roadmap knowledge (if (null road-facts) (return-from initialize-state "** You need to do a def-roadmap before initializing")) ; Check for presence of ME *here*: (if (null (find-location 'ME local-facts)) (return-from initialize-state "** You need to do a place-object for ME before initializing")) (setq local-facts (append local-facts road-facts) ) (setq implied-facts (all-inferences local-facts *general-knowledge* *inference-limit*) ) ; {at most *inference-limit* levels of iteration} (set new-state-node-name (make-state-node :name new-state-node-name ; we exclude implied and local facts that are ; "occluded" in the sense of not being manifestly ; true for ME, given ME's presence at *here*: :wffs (remove-if #'occluded-fact (append implied-facts local-facts) ) :local-value 0 :forward-value 2 )); NB: :parent is nil by default (setq *curr-state* (eval new-state-node-name)) )); end of initialize-state (defun occluded-fact (wff) ;~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Return non-nil result if the predicate of the wff is occluded ; and the first ("subject") argument is not `ME'. Examples of ; occluded facts might be (hungry Grunt) (but not (hungry ME)), ; (is_hidden_in Key2 Box3), or (knows_that Grunt (has ME banana3)). ; (cond ((atom wff) (member wff *occluded-predicates*)); unexpectd (t (and (member (car wff) *occluded-predicates*) (or (null (second wff)) (eq (second wff) 'ME)) )))) (defun all-inferences (ground-facts general-facts limit) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Make all inferences enabled by the `general-facts' based on ; the `ground-facts'. Iterate, up to `limit' times, for any new ; inferences. ; ; ground-facts: ground atomic wffs; ; general-facts: Horn wffs of form (phi => psi), i.e., phi ; is either an atomic wff (possibly containing variables) or ; a conjunction (and phi_1 ... phi_k) where the phi_i are ; atomic, and psi is atomic. ; METHOD: ; {We refer to the wffs in `general-facts' as "rules" here, ; for clarity of exposition} ; 1. Let rule-packets := a list where each element is of form ; (rule), where `rule' is one of the rules (general-facts); ; 2. Let facts: = ground-facts; ; 3. Repeat steps a-b at most `limit' times, stopping if facts ; = nil: ; a. Let (facts . rule-packets) := ; new-inferences(facts, rule-packets); ; {This gives (i) the new inferences derivable in one ; step (one full rule instantiation of a rule in some ; rule packet) from the `facts' along with facts ; included in the rule packets (initially none), and ; (ii) new rule-packets in which wffs from the given ; `facts' that match the rule packet have been added to ; each packet.} ; b. results := append(facts,results); ; 4. Return `results'. ; (let ((rule-packets (mapcar #'list general-facts)) (facts ground-facts) facts-and-packets results ) (dotimes (i limit) (if (null facts) (return-from all-inferences results) ) (setq facts-and-packets (new-inferences facts rule-packets) ) (setq facts (car facts-and-packets) rule-packets (cdr facts-and-packets) ) (setq results (append facts results)) ) results )); end of all-inferences (defun new-inferences (facts rule-packets) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Generate new inferences, and new rule packets, based on the ; given (unprocessed) `facts' and the rule plus facts to be ; found in each rule packet. Generate only 1-step inferences, ; i.e., obtainable by matching all antecdents of a rule, ; without feeding new consequences back into the facts. ; Return the list of inferences cons'd into the list of ; rule packets (the latter augmented with antecedent-matching ; facts from those in the input). ; ; facts: ground atomic wffs; ; rule-packets: a list with elements of form (rule fact_1 ... ; fact_n) where each rule is of form (phi => psi), with phi ; either an atomic wff (in general, with variables) or of ; form (and phi_1 ... phi_k), where ph_i and psi are atomic ; wffs. Facts are ground atomic wffs. ; ; METHOD: ; 1. Let double-packets := a list with each element of form ; (rule ( ) f_1 ... f_k) where (rule f_1 ... f_k) was one ; of the elements of `rule-packets'; ; 2. For each fact in `facts', and each double-packet, if the ; fact unifies with some antecedent literal of the rule in the ; double packet, then graft the fact into the list occupying ; second position (i.e., right after the rule) in the double ; packet, provided that it isn't in that list, or in the cddr ; of the double packet yet (use function `graft-into-packet'); ; 3. For each double-packet with a non-nil 2nd element: ; a. Find all 1-step inferences (based on full instantiation ; of the variables in the rule) that use at least one ; fact from the list of facts which is the 2nd element ; of the double packet, and any number of pre-existing ; facts in the packet (use the function `shake-packet'); ; b. Concatenate these inferences with `inferences'; ; 4. For each packet (rule (g_1 ... g_m) f_1 ... f_k) form ; (rule g_1 ... g_m f_1 ... f_k); call the result ; new-packets; ; 5 Return (cons inferences new-packets). ; (let ((double-packets (mapcar #'(lambda (x) (cons (car x) (cons nil (cdr x)))) rule-packets )) inferences new-packets ) (dolist (wff facts) (setq double-packets (mapcar #'(lambda (p) (graft-into-packet wff p)) double-packets ))) (dolist (augm-packet double-packets) (when (second augm-packet) (setq inferences (append (shake-packet augm-packet) inferences) ))) (setq new-packets (mapcar #'(lambda (x) (append (list (car x)) (second x) (cddr x)) ) double-packets )) (cons inferences new-packets) )); new-inferences (defun graft-into-packet (wff augm-packet) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; `wff' is a ground atomic formula; ; `augm-packet' is of form (rule (g_1 ... g_m) f_1 ... f_n) ; (for further details see `new-inferences' or `shake-packet'.) ; ; If wff does not appear among g_1 ... g_m or f_1 ... f_n, ; then if wff unifies with some antecedent literal of the rule ; in the augm-packet, then graft the fact into the list occupying ; second position (i.e., right after the rule) in the double ; packet, provided that it isn't in that list, or in the cddr ; of the double packet yet; return the (possibly) altered ; packet; ; (let* ((rule (car augm-packet)) (goals (goals-of-rule rule)) ) (if (and (not (memberf wff (second augm-packet))) (not (memberf wff (cddr augm-packet))) (find-if #'(lambda (g) (unifier g wff)) goals) ) (cons rule (cons (cons wff (second augm-packet)) (cddr augm-packet) )) augm-packet ))); end of graft-into-packet (defun goals-of-rule (rule) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Return the goal-list (antecedents) of `rule' (see e.g., ; `shake-packet' for forms of rules -- essentially Horn clauses, ; written as (antecedent => consequent)). Allow for either single- ; literal or AND'ed antecedent, and allow a literal in principle ; to be an atom like `HUNGRY or a literal with 0 arguments, such ; as ; (HUNGRY), even though these are advised against. We also ; allow omission of AND for an AND'ed antecedent, though this ; is unexpected. ; (let ((goals (car rule))) (cond ((null goals) nil); unexpected ((atom goals) (list goals)); unexpected ((eq (car goals) 'and) (cdr goals)) ((listp (car goals)) goals); missing `and' (t (list goals)) ); single goal )); end of goals-of-rule (defun shake-packet (augm-packet) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; `augm-packet' is of form (rule (g_1 ... g_m) f_1 ... f_n), ; where rule is form (phi => psi), with phi either an atomic wff ; (in general, with variables) or of form (and phi_1 ... phi_k), ; where ph_i and psi are atomic wffs; and the g_i and f_j are ; atomic ground wffs. ; ; Find all 1-step inferences (based on full instantiation of ; the variables in the rule) that use at least one fact from ; the list (g_1 ... g_m), and any number of facts from the ; list (f_1 ... f_n). ; ; Method: ; 1. rule := first(augm-packet); ; new-facts := second(augm-packet); ; old-facts := cddr(augm-packet); ; all-facts := append(new-facts,old-facts) ; 2. if new-facts =/= nil, then ; a. goals := antecedents of `rule'; ; b. find all bindings of each goal in `goals' to new-facts, ; and let `bindings' := the concatenation of the sets ; of bindings found; ; c. apply each binding u in `bindings' to `goals', ; remove the resulting (variable-free) goals ; that coincide with some facts in new-facts, find ; bindings2 := all bindings of the remaining goals ; (if any) to all-facts, and combine the binding u ; with each of the ones in bindings2; apply the ; resultant bindings to the rule consequent, and ; push the resulting wff onto `inferences' ; 3. Return `inferences'. ; (let* ((rule (car augm-packet)) (new-facts (second augm-packet)) (old-facts (cddr augm-packet)) (all-facts (append new-facts old-facts)) goals goals2 bindings bindings2 inferences ) (setq goals (goals-of-rule rule)) (setq bindings (apply #'append (mapcar #'(lambda (g) (all-bindings-of-posgoal-to-facts g new-facts) ) goals ))) (dolist (u bindings) (setq goals2 (subst-unifier-in-wffs u goals)) (setq goals2 (set-differencef goals2 new-facts)) (setq bindings2 (find-all-positive-bindings goals2 all-facts) ) (setq bindings2 (mapcar #'(lambda (u2) (*append u u2)) bindings2) ) (dolist (u2 bindings2) (push (subst-unifier u2 (third rule)) inferences) ) ) inferences )); end of shake-packet (defun go! ( ) ;~~~~~~~~~~~~~ ; This function chains forward from the *curr-state*, using ; some fixed (or user-tweaked) search beam; it reports the ; seemingly best plan (*plan*) and corresponding state ; sequence (*states*); then it executes the first step of that ; best plan, adds the action type paired with the value of ; *now* to *history* (e.g., it might add ((eat ME Banana3) . 7) ; to the *history* list), updates *now*, *curr-state*, *plan* ; and *states*, and reports the contents (as a set of wffs) of ; the expected new current state and the actual new current ; state -- the latter after gathering new facts that may be ; available after the action taken; (the assumption is that ; some facts associated with objects at a particular point ; won't become known to the agent till it gets to that point, ; and so the new state will in general be richer in facts ; that the anticipated state.) ; (let (poss-actions step new-state) (setq poss-actions (chain-forward *curr-state* *search-beam*)) (format t "~%~%POSSIBLE ACTIONS & VALUES: ~a" poss-actions) (format t "~%SEEMINGLY BEST PLAN: ~a" *plan*) (format t "~%CORRESPONDING STATES: ~% ~a" *states*) (if (null poss-actions) (return-from go! "NO MORE ACTIONS POSSIBLE!") ) (push (cons (car *plan*) *now*) *history*) (setq *curr-state* ; reset to first (leftmost) successor (eval (cdar (state-node-children *curr-state*))) ) (setq step (pop *plan*)) (format t "~%~%STEP TO BE TAKEN: ~a" step) (format t "~%EXPECTED STATE; ~% ~a" (second *states*)) (incf *now*) (pop *plan*) (pop *states*) ; Reset the "successor actions already explored" to nil, ; because otherwise we won't take account of possibilities ; engendered by newly discovered local facts: (setf (state-node-operators *curr-state*) nil) (setq new-state (update-local-facts *curr-state*) ) (setq *states* (cons new-state (cdr *states*))) (format t "~%~%ACTUAL NEW STATE: ~a" new-state) )); end of go (defun update-local-facts (state-node) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Add any new facts to the wffs in `state-node' that are apparent ; to ME at the current location of ME -- i.e., non-occluded properties ; of the entities co-located with ME. We could skip the update if ME ; hasn't changed location or has been at this location before, but ; we want to allow in principle (though not, for now, in practice) ; for the possibility that there are spontaneous ("exogenous") changes ; in the world, whenever the time counter *now* is incremented. So ; we check non-occluded properties of present entities every time. ; ; After updating the wffs in the given state-node, return that ; updated list of wffs. ; ; NOTE: This update strategy only allows for (partial) ignorance of ; local facts, not ignorance about the effects of actions taken. ; For the latter, we would have to have two separate versions of ; each operator: the "physical" version (in the simulated gridworld), ; and the agent's *model* of the physical action, which it uses ; for planning but which may not fully predict the effects of the ; physical action. ; (let* ((wffs (state-node-wffs state-node)) (action-name (car (state-node-parent state-node))) (action (eval action-name)) ; We need to apply the effects (effects (op-effects action)) ; of the operator that yielded (deletions (neglits effects)) ; the given state to the `local (additions (poslits effects)) ; facts' (here (find-location 'ME wffs)) (local-facts (get here 'facts)) implied-facts ) (setq local-facts (remove-if #'occluded-fact local-facts)) (setq local-facts (set-differencef local-facts deletions)) (setq local-facts (unionf additions local-facts)) (setq local-facts (set-differencef local-facts wffs)) (when local-facts ; add local-facts & inferences to wffs (setq wffs (append local-facts wffs)) (setq implied-facts (all-inferences wffs *general-knowledge* *inference-limit*) ) (setq implied-facts (set-differencef implied-facts wffs)) (if implied-facts (setq wffs (append implied-facts wffs)) ) ; reset wffs-field of state-node to the expanded set (setf (state-node-wffs state-node) wffs) ) (setf (get here 'facts) wffs) (setq *here* here) wffs ; return the (possibly) expanded set of wffs from the ; updated state-node. )); end of include-local-facts (defun find-location (obj wffs) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; find the first wff in `wffs' of form (is_at obj x), and return x ; (or nil, if there is no such wff). `obj' is a ground term, and `wffs' ; are positive ground predications. ; (third (car (member-if #'(lambda (w) (and (listp w) (eq (car w) 'is_at) (equal (second w) obj) )) wffs )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; TO BE REPLACED BY USER-SUPPLIED FUNCTIONS ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun state-value (wffs additions deletions prior-local-value) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Allocate +ve points for addition of desirable properties, and ; subtract away that number of points for deletions of those ; properties; analogously for addition of undesirable properties; ; the additions and subtractions are made using 'prior-local-value' ; as starting value; ; ; Just as an example, let's suppose the agent ME likes knowing ; things, likes being liked, and likes having things, and ; dislikes being hungry. So we reward addition of wffs of form ; (know-whether ME ...), (know-that ME ...), (likes ... ME), ; (has ME ...); and we reward removal of (hungry ME). Also ; we punish (correspondingly) removal of (likes ... ME) and ; (has ME ...), and addition of (hungry ME). ; (let ((local-value prior-local-value) pred incr) (dolist (wff additions) (when (listp wff) (setq pred (car wff)) (setq incr (case pred ((know-whether know-that has) (if (eq (second wff) 'ME) 1 0) ) (likes (if (eq (third wff) 'ME) 1 0) ) (hungry (if (eq (second wff) 'ME) -1 0) ) (t 0) )) (incf local-value incr) )) (dolist (wff deletions) (when (listp wff) (setq pred (car wff)) (setq incr (case pred (likes (if (eq (third wff) 'ME) -1 0) ) (hungry (if (eq (second wff) 'ME) 1 0) ) (t 0) )) (incf local-value incr) )) local-value )); end of state-value (defun expected-rewards (wffs) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; For the time being, this is a stub, returning a fixed value. ; 2 )