├── README.md ├── aux.lsp ├── compile-with-ecl ├── dump.py ├── fdr3.lsp ├── inval-main.lsp ├── inval.lsp ├── itt.lsp ├── nyat-main.lsp ├── pddl3.lsp ├── rsk-main.lsp ├── rsk.lsp ├── run-val-test-ipc4.lsp ├── simplify-main.lsp ├── simplify.lsp ├── tests ├── README.md ├── axioms │ ├── blocker-adl.pddl │ ├── blocker-strips-12.pddl │ ├── blocker-strips-12.soln │ ├── blocker-strips-small.pddl │ ├── blocker-strips-small.soln │ ├── blocker-strips.pddl │ ├── bmgen.py │ ├── bw-axioms-THN.pddl │ ├── bw-axioms-small.pddl │ ├── bw-axioms-small.soln │ ├── disjunction.pddl │ ├── disjunction1-plan.soln │ ├── disjunction1.pddl │ ├── disjunction2.pddl │ ├── iago-1.pddl │ ├── iago-1.soln │ ├── iago-2.pddl │ ├── mst.pddl │ ├── mst1.pddl │ ├── mst1.soln │ ├── mst2.pddl │ ├── mst2.soln │ └── social.pddl ├── fs │ ├── buckets-3.pddl │ ├── buckets.pddl │ ├── fs-blocks-v1.pddl │ ├── fs-blocks-v2.pddl │ ├── fs-hanoi-v2.pddl │ ├── fs-hanoi.pddl │ ├── fs-logistics-v2.pddl │ ├── fs-logistics.pddl │ ├── fs-puzzle.pddl │ └── lists.pddl ├── mo │ ├── bw-5-plan-1.soln │ ├── bw-5-plan-2.soln │ ├── bw-5-plan-3.soln │ ├── bw-5.pddl │ └── bw3o.pddl ├── ppddl │ ├── mk31.pol │ ├── mk31a.pddl │ └── mk31b.pddl └── typing │ ├── domain-1.pddl │ ├── domain-2.pddl │ ├── domain-3.pddl │ ├── plan-1+2.soln │ ├── plan-3.soln │ ├── problem-1+2.pddl │ └── problem-3.pddl ├── tools.lsp ├── translate-main.lsp ├── val-test-util.lsp ├── vapo-main.lsp ├── vapo.lsp └── vis.lsp /README.md: -------------------------------------------------------------------------------- 1 | 2 | # INVAL 3 | 4 | INVAL is the Independent PDDL plan Validator. 5 | 6 | The Planning Domain Definition Language (PDDL) is a modelling 7 | language for expressing AI planning problems, and used as the 8 | input language of a large number of general-purpose AI planning 9 | systems. 10 | The role of a plan validator is to check if a plan (generated by 11 | an AI planner or manually written) is valid, according to the 12 | domain and problem specification. A validator is a very useful 13 | tool for debugging a domain/problem specification, a planner 14 | implementation, and indeed the specification of PDDL itself. 15 | 16 | The existing PDDL plan validator, [VAL](https://github.com/KCL-Planning/VAL), 17 | created by Derek Long et al., is a great tool, but, like all software, 18 | it does have bugs. INVAL is meant to complement VAL, not to replace it. 19 | The aim of INVAL is to have a simple (rather than capable and efficient) 20 | implementation of the PDDL semantics as they are defined in the literature. 21 | When both validators agree, you can have greater confidence that they are 22 | right; when they disagree, this points to either a flaw in one of them or 23 | an ambiguity in the language specification. 24 | 25 | Compared to VAL, INVAL has some limitations. Most importantly, 26 | it does not handle temporal plans. It should, however, handle numeric 27 | and object-valued fluents, and derived predicates. And it's not 28 | efficient. 29 | 30 | ## Compilation and usage 31 | 32 | INVAL is written in LISP. For instructions on how to run it, see 33 | comments at the beginning of the main file ("inval.lsp"). 34 | 35 | ## Other PDDL tools 36 | 37 | This package also includes a set of other PDDL tools: 38 | 39 | * `rsk` is a domain/problem compiler that removes object fluents (PDDL 40 | version 3.1). It can either compile them away completely (producing 41 | standard ADL-like PDDL) or compile away only nested fluents (producing 42 | something analogous to SAS+). 43 | 44 | * `simplify` is a domain/problem simplifier. It outputs "simple ADL", 45 | which may still have conditional effects but no quantifiers or 46 | disjunction. 47 | 48 | * `nyat` converts PDDL into FastDownward's internal SAS+ format. In other 49 | words, it is a drop-in replacement for the FastDownward translator. 50 | Compared to the FD translator, it is _much less efficient_, and it does 51 | not automatically generate finite-domain variables from the propositional 52 | PDDL representation. Instead (and unlike the FD translator), it preserves 53 | any object fluents (i.e., SAS+ variables) in the PDDL input. This means 54 | that it gives you full control over the generated SAS+ representation. 55 | 56 | * `vapo` is a validator for fully-observable probabilistic planning 57 | policies. It checks if the policy is executable and proper, and if so, 58 | computes its expected reward/cost. It can also generate a graph (in dot 59 | format) of the state space reachable under a policy, with nodes (states) 60 | labelled by the policy action, or an abstracted view of this graph. 61 | -------------------------------------------------------------------------------- /aux.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;;;; 3 | ;; Auxiliary (mostly domain-specific) functions 4 | 5 | (defun next-state (state action) 6 | (let ((res (execute-plan (list (list action)) (cons '(= (reward) 0) state) 7 | *actions* (stratify *axioms*) *types* *objects*))) 8 | (when (not (first res)) 9 | (error "error executing ~a in~%~a~%" action state)) 10 | (remove-if #'(lambda (atom) 11 | (and (eq (car atom) '=) (equal (second atom) '(reward)))) 12 | (cdr res)))) 13 | 14 | (defun catan-dice-abs-fun (state aseq) 15 | (cond 16 | ((endp aseq) nil) 17 | ((eq (caar aseq) 'reroll) 18 | (let ((kept 19 | (remove-if #'(lambda (count) (eq (second count) 'zero)) 20 | (mapcar #'(lambda (res) 21 | (cons res 22 | (first (find-predicate-arguments 23 | 'available '(2) '(1) (list res) state)))) 24 | '(ore grain wool timber brick gold))))) 25 | (if kept 26 | (cons (cons 'keep kept) 27 | (catan-dice-abs-fun (next-state state (car aseq)) (cdr aseq))) 28 | (catan-dice-abs-fun (next-state state (car aseq)) (cdr aseq))))) 29 | ((eq (caar aseq) 'finish-build) 30 | (cons (car aseq) 31 | (catan-dice-abs-fun (next-state state (car aseq)) (cdr aseq)))) 32 | (t (catan-dice-abs-fun (next-state state (car aseq)) (cdr aseq))) 33 | )) 34 | -------------------------------------------------------------------------------- /compile-with-ecl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/ecl -shell 2 | 3 | ;; A simple make system 4 | 5 | (require 'cmp) 6 | 7 | (defun make-compile-file (source-file-list object-file) 8 | (compile-file (first source-file-list) :system-p t)) 9 | 10 | (defun make-link-executable (object-file-list exec-file) 11 | (c:build-program exec-file :lisp-files object-file-list)) 12 | 13 | (defun make-static-library (object-file-list lib-file) 14 | (c:build-static-library lib-file 15 | :lisp-files object-file-list 16 | :init-name "init_library")) 17 | 18 | (defvar *dependencies* 19 | (list (list "inval" '("inval.o" "vis.o" "inval-main.o") 20 | #'make-link-executable) 21 | (list "inval.a" '("inval.o" "vis.o" "inval-main.o") 22 | #'make-static-library) 23 | (list "rsk" '("inval.o" "rsk.o" "rsk-main.o") #'make-link-executable) 24 | (list "simplify" '("inval.o" "rsk.o" "simplify.o" "simplify-main.o") #'make-link-executable) 25 | (list "translate" '("inval.o" "translate-main.o") #'make-link-executable) 26 | (list "nyat" '("inval.o" "rsk.o" "tools.o" "simplify.o" "fdr3.o" "nyat-main.o") 27 | #'make-link-executable) 28 | (list "vapo" '("inval.o" "vapo.o" "simplify.o" "vis.o" "aux.o" "vapo-main.o") 29 | #'make-link-executable) 30 | (list "run-val-test-ipc4" 31 | '("inval.o" "val-test-util.o" "run-val-test-ipc4.o") 32 | #'make-link-executable) 33 | (list "inval.o" '("inval.lsp") #'make-compile-file) 34 | (list "vapo.o" '("vapo.lsp") #'make-compile-file) 35 | (list "vis.o" '("vis.lsp") #'make-compile-file) 36 | (list "aux.o" '("aux.lsp") #'make-compile-file) 37 | (list "rsk.o" '("rsk.lsp") #'make-compile-file) 38 | (list "tools.o" '("tools.lsp") #'make-compile-file) 39 | (list "simplify.o" '("simplify.lsp") #'make-compile-file) 40 | (list "fdr3.o" '("fdr3.lsp") #'make-compile-file) 41 | (list "inval-main.o" '("inval-main.lsp") #'make-compile-file) 42 | (list "translate-main.o" '("translate-main.lsp") #'make-compile-file) 43 | (list "rsk-main.o" '("rsk-main.lsp") #'make-compile-file) 44 | (list "simplify-main.o" '("simplify-main.lsp") #'make-compile-file) 45 | (list "nyat-main.o" '("nyat-main.lsp") #'make-compile-file) 46 | (list "vapo-main.o" '("vapo-main.lsp") #'make-compile-file) 47 | (list "val-test-util.o" '("val-test-util.lsp") 48 | #'make-compile-file) 49 | (list "run-val-test-ipc4.o" '("run-val-test-ipc4.lsp") 50 | #'make-compile-file) 51 | )) 52 | 53 | (defun file-newer-than (file1 file2) 54 | (= (ext:system (concatenate 'string "test " file1 " -nt " file2)) 0)) 55 | 56 | (defun file-exists (file) 57 | (= (ext:system (concatenate 'string "test -f " file)) 0)) 58 | 59 | (defun need-to-make (target deps) 60 | (or (not (file-exists target)) 61 | (some #'(lambda (pred-file) (file-newer-than pred-file target)) deps))) 62 | 63 | (defun make (target) 64 | (let ((rule (assoc target *dependencies* :test #'equal))) 65 | (cond (rule 66 | (dolist (pred (second rule)) 67 | (if (assoc pred *dependencies* :test #'equal) 68 | (make pred))) 69 | (cond ((need-to-make (first rule) (second rule)) 70 | (format t "~&making ~a...~%" (first rule)) 71 | (let ((retval 72 | (funcall (third rule) (second rule) (first rule)))) 73 | (cond ((not retval) 74 | (format t "~&exiting because of errors...~%") 75 | (quit)) 76 | (t retval)))) 77 | (t (format t "~&~a is up to date~%" target)))) 78 | (t (format t "~&no rule to make ~a~%" target)) 79 | ))) 80 | 81 | 82 | (make "inval") 83 | (make "rsk") 84 | (make "simplify") 85 | ;; (make "translate") 86 | (make "nyat") 87 | (make "vapo") 88 | 89 | (make "run-val-test-ipc4") 90 | 91 | (terpri) 92 | -------------------------------------------------------------------------------- /dump.py: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env python 2 | # -*- coding: utf-8 -*- 3 | 4 | from __future__ import print_function 5 | 6 | import sys 7 | 8 | def python_version_supported(): 9 | major, minor = sys.version_info[:2] 10 | return (major == 2 and minor >= 7) or (major, minor) >= (3, 2) 11 | 12 | if not python_version_supported(): 13 | sys.exit("Error: Translator only supports Python >= 2.7 and Python >= 3.2.") 14 | 15 | 16 | import axiom_rules 17 | import fact_groups 18 | import instantiate 19 | import normalize 20 | import pddl 21 | import pddl_parser 22 | 23 | def print_atom(atom, destination=sys.stdout, indent=0, end='\n'): 24 | print((" " * indent) + "(" + atom.predicate, file=destination, end='') 25 | for arg in atom.args: 26 | print(" " + arg, file=destination, end='') 27 | print(")", file=destination, end=end) 28 | 29 | def print_mutex_group(group, destination=sys.stdout, indent=0, end='\n'): 30 | print((" " * indent) + "(", file=destination, end='') 31 | for i in range(len(group)): 32 | if i > 0: 33 | print(" ", file=destination, end='') 34 | print_atom(group[i], destination=destination, indent=0, end='') 35 | print(")", file=destination, end=end) 36 | 37 | def dump(task, destination=sys.stdout): 38 | 39 | (goal_relaxed_reachable, atoms, actions, axioms, 40 | reachable_action_params) = instantiate.explore(task) 41 | (groups, mutex_groups, tk) = fact_groups.compute_groups( 42 | task, atoms, reachable_action_params, 43 | partial_encoding=True) 44 | 45 | print("(:atoms", file=destination) 46 | for atom in atoms: 47 | print_atom(atom, destination=destination, indent=2) 48 | print(" )", file=destination) 49 | 50 | print("(:actions", file=destination) 51 | for act in actions: 52 | print(" " + act.name, file=destination); 53 | print(" )", file=destination) 54 | 55 | print("(:mutex-groups", file=destination) 56 | for group in mutex_groups: 57 | if len(group) > 1: 58 | print_mutex_group(group, destination=destination, indent=2) 59 | print(" )", file=destination) 60 | 61 | 62 | if __name__ == '__main__': 63 | 64 | if len(sys.argv) < 3: 65 | print(sys.argv[0] + " ") 66 | sys.exit(0) 67 | 68 | task = pddl_parser.open(task_filename=sys.argv[2], 69 | domain_filename=sys.argv[1]) 70 | 71 | if len(sys.argv) > 3: 72 | dumpfile = open(sys.argv[3], "w") 73 | dump(task, destination=dumpfile) 74 | dumpfile.close() 75 | else: 76 | dump(task) 77 | -------------------------------------------------------------------------------- /fdr3.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;; Name variables by fluent/atom name (instead of the usual "varNN"): 3 | (defvar *name-FDR-variable-by-atom-name* t) 4 | 5 | ;; Force translator to output a problem with/without metric spec; if 6 | ;; neither option is in effect, the output problem will be metric iff 7 | ;; a :metric is specified. Note: forcing a non-metric problem to be 8 | ;; metric will result in all actions having zero cost. 9 | (defvar *force-metric* nil) 10 | (defvar *force-non-metric* nil) 11 | 12 | ;; Filter out actions with inconsistent effects. Returns the reduced 13 | ;; list of actions. 14 | 15 | (defun filter-sas-actions (actions) 16 | (remove-if #'(lambda (act) 17 | (let ((prec (normalise-simple-formula 18 | (assoc-val ':precondition (cdr act)))) 19 | (effs (normalise-simple-formula 20 | (assoc-val ':effect (cdr act))))) 21 | (or (not (consistent-assignment prec)) 22 | (not (consistent-assignment effs))))) 23 | actions)) 24 | 25 | (defun consistent-assignment (alist) 26 | (cond ((endp alist) t) 27 | ((eq (caar alist) 'when) (consistent-assignment (cdr alist))) 28 | ((some #'(lambda (acond) 29 | (and (not (eq (car acond) 'when)) 30 | (equal (car acond) (caar alist)) 31 | (not (equal (cdr acond) (cdar alist))))) 32 | (cdr alist)) 33 | nil) 34 | (t (consistent-assignment (cdr alist))) 35 | )) 36 | 37 | ;; Write a grounded and simplified problem in Fast Downward's FDR format 38 | ;; version 3 (i.e., the "output.sas" file). 39 | ;; stream - output stream to write to; 40 | ;; fluents - list of pairs (ground fluent . domain); 41 | ;; atoms - list of ground atoms; 42 | ;; stratified-dps - stratified list of derived predicate names, i.e., 43 | ;; second value returned by (stratify *axioms*); 44 | ;; simple-actions - list of simplified ground actions; 45 | ;; simple-axioms - list of simplified ground axioms. 46 | ;; For both fluents and atoms it is assumed that no fluents/atoms not 47 | ;; in the lists are mentioned in actions, axioms, init or goal. 48 | 49 | (defun output-FDR-v3 50 | (stream fluents atoms stratified-dps simple-actions simple-axioms init goal) 51 | (let ((var-index (make-variable-index fluents atoms)) 52 | ;; metric will be either the metric expression or nil 53 | ;; (to indicate a non-metric problem). 54 | (metric (cond (*force-non-metric* nil) 55 | (*metric* *metric*) 56 | (*force-metric* 0) 57 | (t nil)))) 58 | (when (>= *verbosity* 2) 59 | (format t "variable index:~%") 60 | (dolist (var var-index) 61 | (format t " ~a~%" var))) 62 | ;; version section 63 | (format stream "begin_version~%~a~%end_version~%" 3) 64 | ;; metric section 65 | (format stream "begin_metric~%~a~%end_metric~%" (if metric 1 0)) 66 | ;; variables section 67 | (format stream "~a~%" (length var-index)) 68 | (dolist (var var-index) 69 | (let* ((var-name (caar var)) 70 | (var-num (cdr var)) 71 | (var-domain (cdar var)) 72 | (var-layer (find-stratum (car var-name) stratified-dps))) 73 | ;; * The first line is "begin_variable". 74 | (format stream "begin_variable~%") 75 | ;; * The second line contains the name of the variable 76 | (cond (*name-FDR-variable-by-atom-name* 77 | (format stream "~a" (car var-name)) 78 | (dolist (term (cdr var-name)) 79 | (format stream "_~a" term)) 80 | (format stream "~%")) 81 | (t (format stream "var~a~%" var-num))) 82 | ;; * The third line specifies the axiom layer of the variable. 83 | (format stream "~a~%" var-layer) 84 | ;; * The fourth line specifies variable's range 85 | (format stream "~a~%" (length var-domain)) 86 | ;; * The following range lines specify the symoblic names for 87 | ;; each of the range values, one at a time. 88 | (dolist (val var-domain) 89 | (format stream "~a~%" (car val))) 90 | ;; * The final line is "end_variable". 91 | (format stream "end_variable~%") 92 | )) 93 | ;; mutex section (no additional information) 94 | (format stream "0~%") 95 | ;; init state section 96 | (format stream "begin_state~%") 97 | (dolist (var var-index) 98 | (format stream "~a~%" 99 | (cond 100 | ;; if the variable is a derived predicate, it's default 101 | ;; value is 0 (false) 102 | ((>= (find-stratum (caaar var) stratified-dps) 0) 0) 103 | ;; if it is an object fluent, it's value should be 104 | ;; defined in the initial state 105 | ((find-fluent-value (caar var) init) 106 | (translate-value (find-fluent-value (caar var) init) var)) 107 | ;; else, it's a predicate: true if present in init: 108 | ((find (caar var) init :test #'equal) 1) 109 | ;; otherwise false (0): 110 | (t 0)))) 111 | (format stream "end_state~%") 112 | ;; goal section 113 | (let ((goal-list (normalise-simple-formula goal))) 114 | (format stream "begin_goal~%~a~%" (length goal-list)) 115 | (dolist (atomic-goal goal-list) 116 | (multiple-value-call #'format stream "~a ~a~%" 117 | (translate-atomic-condition 118 | atomic-goal var-index))) 119 | (format stream "end_goal~%")) 120 | ;; operator section 121 | (format stream "~a~%" (length simple-actions)) 122 | (dolist (act simple-actions) 123 | (when (>= *verbosity* 2) 124 | (format t "action: ~w~%" act)) 125 | (output-FDR3-action stream act var-index metric init)) 126 | ;; axiom section 127 | (format stream "~a~%" (length simple-axioms)) 128 | (dolist (axiom simple-axioms) 129 | (when (>= *verbosity* 2) 130 | (format t "axiom: ~w~%" axiom)) 131 | (format stream "begin_rule~%") 132 | (let ((head (cons (car (second axiom)) 133 | (mapcar #'car (parse-typed-list 134 | nil (cdr (second axiom)) 'object)))) 135 | (body (normalise-simple-formula (third axiom)))) 136 | (format stream "~a~%" (length body)) 137 | (dolist (acond body) 138 | (multiple-value-bind (var val) 139 | (translate-atomic-condition acond var-index) 140 | (format stream "~a ~a~%" var val))) 141 | (format stream "~a 0 1~%" (translate-atom head var-index))) 142 | (format stream "end_rule~%")) 143 | )) 144 | 145 | (defun output-FDR3-action (stream act var-index metric init) 146 | ;; * The first line is "begin_operator". 147 | ;; * The second line contains the name of the operator. 148 | (format stream "begin_operator~%~a" (caar act)) 149 | (dolist (arg (cdar act)) 150 | (format stream " ~a" arg)) 151 | (format stream "~%") 152 | (let* ((prec (normalise-simple-formula 153 | (assoc-val ':precondition (cdr act)))) 154 | (effs (normalise-simple-formula 155 | (assoc-val ':effect (cdr act)))) 156 | (prevail (remove-if 157 | #'(lambda (acond) 158 | (find (car acond) effs :key #'car :test #'equal)) 159 | prec))) 160 | ;; prevails 161 | (format stream "~a~%" (length prevail)) 162 | (dolist (acond prevail) 163 | (multiple-value-bind (var val) 164 | (translate-atomic-condition acond var-index) 165 | (format stream "~a ~a~%" var val))) 166 | ;; effects 167 | (format stream "~a~%" (length effs)) 168 | (dolist (eff effs) 169 | (let* ((post-acond (if (eq (car eff) 'when) (third eff) eff)) 170 | (pre-val (find-value-in-condition (car post-acond) prec))) 171 | (cond ((eq (car eff) 'when) 172 | (let ((econd (second eff))) 173 | (format stream "~a" (length econd)) 174 | (dolist (acond econd) 175 | (multiple-value-bind (var val) 176 | (translate-atomic-condition acond var-index) 177 | (format stream " ~a ~a" var val))))) 178 | (t (format stream "0"))) 179 | (multiple-value-bind (var val) 180 | (translate-atomic-condition post-acond var-index) 181 | (format stream " ~a ~a ~a~%" 182 | var (if pre-val (multiple-value-bind (dummy val1) 183 | (translate-atomic-condition 184 | (cons (car post-acond) pre-val) 185 | var-index) val1) 186 | -1) val)))) 187 | ;; action cost 188 | (format stream "~a~%" 189 | (if metric (metric-net-effect metric 190 | (cdr (assoc ':effect (cdr act))) 191 | init) 192 | 1) 193 | ;; (cond (metric 194 | ;; (let ((cost (find-if 195 | ;; #'(lambda (eff) 196 | ;; (and (listp eff) 197 | ;; (eq (car eff) 'increase) 198 | ;; (equal (cadr eff) '(total-cost)))) 199 | ;; (cdr (assoc ':effect (cdr act)))))) 200 | ;; (cond (cost (static-eval (caddr cost) init)) (t 0)))) 201 | ;; (t 1)) 202 | ) 203 | ) ; end of let 204 | (format stream "end_operator~%") 205 | ) 206 | 207 | (defun metric-net-effect (exp eff init) 208 | (cond 209 | ((numberp exp) exp) 210 | ((assoc (car exp) *builtin-numeric-functions*) 211 | (let ((args (mapcar #'(lambda (term) 212 | (metric-net-effect term eff init)) 213 | (cdr exp))) 214 | (fun (assoc (car exp) *builtin-numeric-functions*))) 215 | (when (or (< (length args) (second fun)) 216 | (and (third fun) (> (length args) (third fun)))) 217 | (error "incorrect arguments ~a for ~a~%" args fun)) 218 | (when (some #'(lambda (arg) (not (numberp arg))) args) 219 | (error "non-numeric argument ~a for ~a~%" args fun)) 220 | (funcall (fourth fun) args))) 221 | ;; otherwise, it's a (ground) fluent term; now recurse on eff 222 | ((null eff) 0) 223 | ((eq (car eff) 'and) 224 | (reduce #'+ (mapcar #'(lambda (e1) 225 | (metric-net-effect exp e1 init)) 226 | (cdr eff)))) 227 | ((eq (car eff) 'when) 228 | (let ((delta (metric-net-effect exp (third eff) init))) 229 | (if (eq delta 0) 0 230 | (error "cannot compute net effect of ~a on ~a~%" eff exp)))) 231 | ((eq (car eff) 'increase) 232 | (if (equal (second eff) exp) (static-eval (third eff) init) 0)) 233 | ((eq (car eff) 'decrease) 234 | (if (equal (second eff) exp) (* -1 (static-eval (third eff) init)) 0)) 235 | ((eq (car eff) 'assign) 236 | (if (not (equal (second eff) exp)) 0 237 | (error "cannot compute net effect of ~a on ~a~%" eff exp))) 238 | (t 0))) 239 | 240 | (defun static-eval (exp init) 241 | (let ((val (eval-term exp nil init :report-errors nil))) 242 | (when (null (car val)) 243 | (error "metric expression ~a is undefined" exp)) 244 | (when (not (numberp (car val))) 245 | (error "metric expression ~a is not numeric (~a)" exp val)) 246 | (car val))) 247 | 248 | 249 | ;; The variable index is a list of pairs (fd-pair . index), where fd-pair 250 | ;; is (variable-name . indexed-variable-domain), and indexed-variable-domain 251 | ;; is a list of pair (value-name . index). 252 | (defun make-variable-index (fluents atoms) 253 | (number-list 254 | (mapcar #'(lambda (fd-pair) 255 | (cons (car fd-pair) (number-list (cdr fd-pair) 0))) 256 | (append fluents 257 | (mapcar #'(lambda (atom) (cons atom '(false true))) 258 | atoms))) 259 | 0)) 260 | 261 | (defun find-stratum (predicate stratified-dps &optional (index 0)) 262 | (cond ((endp stratified-dps) -1) 263 | ((member predicate (car stratified-dps)) index) 264 | (t (find-stratum predicate (cdr stratified-dps) (+ index 1))))) 265 | 266 | (defun normalise-simple-formula (form) 267 | (cond ((null form) nil) 268 | ((eq (car form) 'when) 269 | (when (not (= (length form) 3)) (error "ill-formed effect: ~a" form)) 270 | (let ((tr-econd (normalise-simple-formula (second form))) 271 | (tr-eff (normalise-simple-formula (third form)))) 272 | (mapcar #'(lambda (single-eff) (list 'when tr-econd single-eff)) 273 | tr-eff))) 274 | ((eq (car form) 'and) 275 | (mapflat #'normalise-simple-formula (cdr form))) 276 | ((member (car form) '(increase decrease < <= > >=)) nil) 277 | ((member (car form) '(= assign)) 278 | (list (cons (second form) (third form)))) 279 | ((eq (car form) 'not) 280 | (list (cons (second form) 'false))) 281 | (t (list (cons form 'true))) 282 | )) 283 | 284 | ;; An "atomic condition" is a pair (fluent-name . fluent-value). 285 | ;; The fluent-name may be an atom (ground predicate), in which case 286 | ;; the value should be 'false or 'true. 287 | ;; The translation function looks up the variable and value in the 288 | ;; var-index, and returns the corresponding numbers by multiple-value. 289 | 290 | (defun translate-atomic-condition (acond var-index) 291 | (let ((var (assoc (car acond) var-index :key #'car :test #'equal))) 292 | (when (null var) (error "error: undefined variable in ~s~%" acond)) 293 | (let ((val (assoc (cdr acond) (cdar var) :test #'equal))) 294 | (when (null val) (error "error: undefined value in ~s~%" acond)) 295 | (values (cdr var) (cdr val))))) 296 | 297 | (defun translate-value (value-sym var) 298 | (let ((val (assoc value-sym (cdar var) :test #'equal))) 299 | (when (null val) (error "error: undefined value in ~s~%" acond)) 300 | (cdr val))) 301 | 302 | (defun translate-atom (atom var-index) 303 | (let ((var (assoc atom var-index :key #'car :test #'equal))) 304 | (if (null var) (error "error: undefined binary variable ~s~%" atom)) 305 | (cdr var))) 306 | 307 | ;; var-name is a ground variable name; aclist is a list of atomic 308 | ;; conditions. 309 | (defun find-value-in-condition (var-name aclist) 310 | (assoc-val var-name aclist :test #'equal)) 311 | -------------------------------------------------------------------------------- /inval-main.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;; To run as script using ECL: 3 | ;; 4 | ;; Make the following the first line of this file: 5 | ;; 6 | ;; #!/usr/local/bin/ecl -shell 7 | ;; 8 | ;; Uncomment the following: 9 | ;; 10 | ;; (load "inval.lsp") 11 | ;; (load "vis.lsp") 12 | ;; (defun get-commandline-args () 13 | ;; (cdr ext:*unprocessed-ecl-command-args*)) 14 | 15 | ;; To run as script using GCL 16 | ;; 17 | ;; Make the following the first line of this file: 18 | ;; 19 | ;; #!/usr/lib/gcl-2.6.8/unixport/saved_gcl -f 20 | ;; 21 | ;; Uncomment the following: 22 | ;; 23 | ;; (load "inval.lsp") 24 | ;; (load "vis.lsp") 25 | ;; (defun get-commandline-args () 26 | ;; (cdr si::*command-args*)) 27 | 28 | ;; To compile a stand-alone executable using ECL: 29 | ;; 30 | ;; Uncomment the following: 31 | (defun get-commandline-args () 32 | (cdr (ext:command-args))) 33 | 34 | 35 | ;; Defs below are unchanged. 36 | 37 | (setq *typecheck* nil) 38 | (setq *linearise* nil) 39 | (setq *force-metric-total-time* nil) 40 | (setq *visualisation* nil) 41 | (setq *visualisation-document-type* nil) 42 | (setq *visualisation-file* nil) 43 | (setq *translation-rules* nil) 44 | (setq *causal-link-analysis* nil) 45 | (setq *causal-link-bounded-cost* t) 46 | (setq *dddl* nil) 47 | 48 | (setq *visualisations* 49 | (list (list 'strips-sliding-tile #'visualise-sliding-tile-puzzle 'latex) 50 | (list 'blocksworld #'visualise-bw3 'latex) 51 | (list 'genome-edit-distance #'visualise-ged 'latex) 52 | (list 'sokoban-sequential #'visualise-sokoban-IPC6 'latex) 53 | (list 'sokoban-strips #'visualise-sokoban-IPC6 'latex) 54 | (list 'openstacks-sequencedstrips-ADL #'visualise-openstacks 'latex) 55 | (list 'openstacks-sequencedstrips-nonADL-nonNegated 56 | #'visualise-openstacks 'latex) 57 | (list 'parking-game #'visualise-rush-hour 'latex) 58 | (list 'hydraulic_blocks_world #'visualise-numeric-hbw 'html) 59 | (list 'html-table #'visualise-html-table 'html) 60 | )) 61 | 62 | (defun visualisation-preamble (doctype) 63 | (cond ((eq doctype 'latex) 64 | '("\\documentclass[10pt,a4paper]{article}" 65 | "\\usepackage{pgf}" 66 | "\\usepackage{tikz}" 67 | "\\usetikzlibrary{patterns}" 68 | "\\begin{document}")) 69 | ((eq doctype 'html) 70 | '("" 71 | "Plan Validation Result" 72 | "")) 73 | (t (error "unknown document type: ~a" doctype)) 74 | )) 75 | 76 | (defun visualisation-postamble (doctype) 77 | (cond ((eq doctype 'latex) 78 | '("\\end{document}")) 79 | ((eq doctype 'html) 80 | '("" 81 | "")) 82 | (t (error "unknown document type: ~a" doctype)) 83 | )) 84 | 85 | (defun latex-escape-string (str) 86 | (with-output-to-string 87 | (result) 88 | (dotimes (i (length str)) 89 | (cond ((eq (elt str i) #\_) (format result "\\_")) 90 | ((eq (elt str i) #\#) (format result "\\#")) 91 | (t (format result "~c" (elt str i))) 92 | )))) 93 | 94 | (defun visualise-plan-header (doctype plan-name plan-valid plan-value) 95 | (cond ((eq doctype 'latex) 96 | (with-output-to-string 97 | (result) 98 | (format result "\\section*{~a}~%" (latex-escape-string plan-name)) 99 | (format result "Valid: ~a\\\\~%" (if plan-valid "Yes" "No")) 100 | (format result "Metric: ~a~%~%\\noindent" plan-value) 101 | )) 102 | ((eq doctype 'html) 103 | (with-output-to-string 104 | (result) 105 | (format result "

~a

~%" plan-name) 106 | (format result "

Valid: ~a

~%" (if plan-valid "Yes" "No")) 107 | (format result "

Metric: ~a

~%" plan-value) 108 | )) 109 | (t (error "unknown document type: ~a" doctype)) 110 | )) 111 | 112 | (defun print-visualisation-list () 113 | (format t "~&Defined visualisations (name / format):~%") 114 | (dolist (vis *visualisations*) 115 | (format t " ~a / ~a~%" (first vis) (third vis)))) 116 | 117 | (defun print-visualisation (stream val-res-list) 118 | (dolist 119 | (ln (visualisation-preamble *visualisation-document-type*)) 120 | (format stream "~&~a~%" ln)) 121 | (dolist (val-res val-res-list) 122 | (format stream "~&~a~%" 123 | (visualise-plan-header 124 | *visualisation-document-type* 125 | (first (first val-res)) 126 | (second val-res) 127 | (third val-res))) 128 | (format stream "~&~a~%" (fourth val-res))) 129 | (dolist 130 | (ln (visualisation-postamble *visualisation-document-type*)) 131 | (format stream "~&~a~%" ln)) 132 | ) 133 | 134 | ;; apply pre-validation processing (as specified by global options) to 135 | ;; input plan (plan only - no name). 136 | (defun preprocess (plan) 137 | (cond (*translation-rules* 138 | (translate-plan plan *translation-rules*)) 139 | (*linearise* 140 | (linearise plan)) 141 | (t plan) 142 | )) 143 | 144 | ;; returns a sorted assoc list from (numeric) metric values of valid plans 145 | ;; to list of plan names. input is the list of validation results, each a 146 | ;; list (name valid value [vis-output]); visualisation output is ignored. 147 | (defun group-by-values (val-res-list) 148 | (let ((mvlist nil)) 149 | (dolist (val-res val-res-list) 150 | (when (and (second val-res) (numberp (third val-res))) 151 | (let ((current (assoc (third val-res) mvlist))) 152 | (setq mvlist (reassoc-in-order 153 | (third val-res) 154 | (if current 155 | (cons (first (first val-res)) (cdr current)) 156 | (list (first (first val-res)))) 157 | mvlist :order #'<))))) 158 | mvlist)) 159 | 160 | (defun average-value (mvlist) 161 | (/ (reduce #'+ (mapcar #'(lambda (entry) 162 | (* (car entry) (length (cdr entry)))) 163 | mvlist) 164 | :initial-value 0) 165 | (reduce #'+ (mapcar #'(lambda (entry) 166 | (length (cdr entry))) 167 | mvlist) 168 | :initial-value 0))) 169 | 170 | (defun print-help () 171 | (format t "~&inval [option | file]*~%") 172 | (format t "~&Options:~%") 173 | (format t "~& -v : Increase verbosity by +1~%") 174 | (format t "~& -q : Set verbosity to 0~%") 175 | (format t "~& -c : Type-check before validation, abort if check fails.~%") 176 | (format t "~& -m : Force metric to be (total-time).~%") 177 | (format t "~& -l : Linearise plans prior to validation.~%") 178 | (format t "~&Plan visualisation:~%") 179 | (format t "~& -z : Domain-specific visualisation.~%") 180 | (format t "~& -Z : Select a generic visualisation.~%") 181 | (format t "~& -o : Save visualisation to .~%") 182 | (print-visualisation-list) 183 | (format t "~&Exerimental options:~%") 184 | (format t "~& -tx : Don't check argument types against action parameters.") 185 | (format t "~& -te : (either ..) in declarations is disjunctive.") 186 | (format t "~& -ignore : Ignore excess arguments and undefined actions.~%") 187 | (format t "~& -f : Use fast axiom fixpoint computation.~%") 188 | (format t "~& -s : Use maximal axiom stratification.~%") 189 | (format t "~& -cl : Causal link analysis.~%") 190 | (format t "~&Any non-option argument is assumed to be an input file.~%") 191 | (quit) 192 | ) 193 | 194 | (defun inval-main () 195 | ;; Process command line arguments and read input files. 196 | ;; undocumented options: 197 | ;; -dddl : Special option to validate plans against domains 198 | ;; compiled from a DDDL spec. Sets the metric to multi-set 199 | ;; of faults. 200 | (if (endp (get-commandline-args)) (print-help)) 201 | (do ((rem-arg-list (get-commandline-args) (cdr rem-arg-list))) 202 | ((endp rem-arg-list) t) 203 | (let ((arg (car rem-arg-list))) 204 | (cond ((equal arg "-v") 205 | (setq *verbosity* (+ *verbosity* 1))) 206 | ((equal arg "-q") 207 | (setq *verbosity* 0)) 208 | ((equal arg "-c") 209 | (setq *typecheck* t)) 210 | ((equal arg "-m") 211 | (setq *force-metric-total-time* t)) 212 | ((equal arg "-z") 213 | (let ((vfun (assoc *domain-name* *visualisations*))) 214 | (cond (vfun 215 | (setq *visualisation* (second vfun)) 216 | (setq *visualisation-document-type* (third vfun))) 217 | (t (format t "~&no visualisation defined for domain ~s~%" 218 | *domain-name*) 219 | (print-visualisation-list) 220 | (quit))))) 221 | ((equal arg "-Z") 222 | (when (endp (cdr rem-arg-list)) 223 | (format t "~&option -Z requires an argument (visualisation name)~%") 224 | (print-visualisation-list) 225 | (quit)) 226 | (let ((vname (read-from-string (car (cdr rem-arg-list))))) 227 | (setq rem-arg-list (cdr rem-arg-list)) 228 | (let ((vfun (assoc vname *visualisations*))) 229 | (cond (vfun 230 | (setq *visualisation* (second vfun)) 231 | (setq *visualisation-document-type* (third vfun))) 232 | (t (format t "~&no visualisation named ~s~%" vname) 233 | (print-visualisation-list) 234 | (quit)))))) 235 | ((equal arg "-o") 236 | (when (endp (cdr rem-arg-list)) 237 | (format t "~&option -o requires an argument~%") 238 | (quit)) 239 | (setq *visualisation-file* (car (cdr rem-arg-list))) 240 | (setq rem-arg-list (cdr rem-arg-list))) 241 | ((equal arg "-T") 242 | (when (endp (cdr rem-arg-list)) 243 | (format t "~&option -T requires an argument~%") 244 | (quit)) 245 | (setq *translation-rules* (read-file (car (cdr rem-arg-list)))) 246 | (setq rem-arg-list (cdr rem-arg-list))) 247 | ((equal arg "-l") 248 | (setq *linearise* t)) 249 | ((equal arg "-tx") 250 | (setq *action-parameter-types-are-preconditions* nil)) 251 | ((equal arg "-te") 252 | (setq *either-in-declarations-means-and* nil)) 253 | ((equal arg "-ignore") 254 | (setq *ignore-excess-arguments* t) 255 | (setq *ignore-undefined-actions* t)) 256 | ((equal arg "-f") 257 | (setq *fast-axiom-fixpoint* t)) 258 | ((equal arg "-s") 259 | (setq *stratify-axioms-maximally* t)) 260 | ((equal arg "-cl") 261 | (setq *causal-link-analysis* t)) 262 | ((equal arg "-clu") 263 | (setq *causal-link-analysis* t) 264 | (setq *causal-link-bounded-cost* nil)) 265 | ((equal arg "-dddl") 266 | (setq *quoted-argument-predicates* '(fault observe)) 267 | (setq *duplicated-predicates* '(fault)) 268 | (setq *dddl* t) 269 | (setq *metric* #'collect-faults)) 270 | ((equal arg "-mo") 271 | (setq *multi-objective* t)) 272 | (t 273 | (format t "~&reading ~a...~%" arg) 274 | (let ((contents (read-file arg))) 275 | (parse-file arg contents)))))) 276 | (when (or (null *metric*) *force-metric-total-time*) 277 | (setq *metric* (if *multi-objective* '((total-time)) '(total-time))) 278 | (setq *metric-type* (if *multi-objective* '(minimize) 'minimize))) 279 | ;; Type-checking: 280 | (cond (*typecheck* 281 | (setq *axioms* 282 | (mapcar #'(lambda (axiom) 283 | (type-enhance-axiom axiom *predicates* *types*)) 284 | *axioms*)) 285 | (if (not (type-check)) (quit) 286 | (format t "~&domain/problem type check ok~%")))) 287 | ;; Stratify domain axioms (if any): 288 | (let* ((stratified-axioms (stratify *axioms*)) 289 | ;; Validate each plan... 290 | (val-res-list 291 | (mapcar 292 | #'(lambda (plan) 293 | (cons (list (car plan) 294 | (reduce #'+ (cdr plan) :key #'length) 295 | (length (cdr plan))) 296 | (validate-plan 297 | (car plan) (preprocess (cdr plan)) 298 | *init* *goal* *constraints* *metric* 299 | *actions* stratified-axioms *types* *objects* 300 | :visualisation *visualisation*))) 301 | *plans*)) 302 | (metric-value-list (group-by-values val-res-list))) 303 | ;; ...and print a nice summary. 304 | (dolist (val-res val-res-list t) 305 | (format t "~&plan ~a: ~a, value: ~a (~a actions, ~a steps)~%" 306 | (first (first val-res)) 307 | (if (second val-res) "valid" "not valid") 308 | (if (numberp (third val-res)) (third val-res) '-) 309 | (second (first val-res)) 310 | (third (first val-res))) 311 | ) 312 | ;; If metric-value-list is non-empty, print some stats 313 | (when metric-value-list 314 | (format t "~&distribution of metric values:~%") 315 | (dolist (entry metric-value-list) 316 | (format t " ~a : ~a~%" (car entry) (length (cdr entry)))) 317 | (format t "~&average value: ~a~%" (average-value metric-value-list)) 318 | (format t "~&min value: ~a~%" (car (car metric-value-list)))) 319 | ;; If causal link analysis is on, and we have at least two different 320 | ;; metric values... 321 | (when (and *causal-link-analysis* 322 | (> (length metric-value-list) 1)) 323 | (let ((cl-opt (extract-causal-links-from-plan-set 324 | (mapcar #'(lambda (pn) (assoc-val pn *plans*)) 325 | (cdr (first metric-value-list))) 326 | *init* *actions* stratified-axioms *types* *objects* 327 | nil)) 328 | (threats (collect-threats *actions*)) 329 | (cl-rej nil)) 330 | (when (> *verbosity* 0) 331 | (format t "~&found ~a good causal links...~%" (length cl-opt))) 332 | (dolist (entry (rest metric-value-list)) 333 | (setq cl-rej (extract-causal-links-from-plan-set 334 | (mapcar #'(lambda (pn) (assoc-val pn *plans*)) 335 | (cdr entry)) 336 | *init* *actions* stratified-axioms *types* *objects* 337 | cl-rej 338 | :filter #'(lambda (p c a pc cc) 339 | (cl-reject-filter 340 | p c a pc cc 341 | (car (first metric-value-list)) 342 | cl-opt)))) 343 | (when (> *verbosity* 0) 344 | (format t "~&now ~a bad causal links...~%" (length cl-rej))) 345 | ) 346 | (format t "~&REJECT LIST:~%") 347 | (dolist (cl cl-rej) 348 | (format t "~&~a [~a] => ~a [~a] ; ~a [~a]~%" 349 | (first cl) (fourth cl) (second cl) (fifth cl) (third cl) 350 | (let ((atom-threats (assoc (first (third cl)) threats))) 351 | (if atom-threats (length (cdr atom-threats)) 0)) 352 | )) 353 | )) 354 | ;; If visualisation is on, print the vresult for each plan: 355 | (cond ((and *visualisation* *visualisation-file*) 356 | (with-open-file 357 | (vs *visualisation-file* :direction :output) 358 | (print-visualisation vs val-res-list))) 359 | (*visualisation* 360 | (print-visualisation t val-res-list)) 361 | ) 362 | ;; If option dddl or mo is set, print a dominance graph: 363 | (cond (*dddl* 364 | (print-dominance-graph val-res-list #'dddl-strictly-preferred)) 365 | (*multi-objective* 366 | (print-dominance-graph 367 | val-res-list #'(lambda (v1 v2) 368 | (mo-strictly-preferred *metric-type* v1 v2)))) 369 | ) 370 | )) 371 | 372 | ;; supporting functions for causal link analysis: 373 | 374 | ;; note: filter function should return true (non-nil) for links that 375 | ;; we want to KEEP. 376 | ;; (defun cl-reject-filter (producer consumer atom pcost ccost opt-cost opt-cl) 377 | ;; (and (if (and *causal-link-bounded-cost* (numberp ccost)) 378 | ;; (<= ccost opt-cost) t) 379 | ;; (not (find-if #'(lambda (cl) 380 | ;; (and (equal (first cl) producer) 381 | ;; (equal (second cl) consumer) 382 | ;; (equal (third cl) atom))) 383 | ;; opt-cl)))) 384 | 385 | (defun cl-reject-filter (producer consumer atom pcost ccost opt-cost opt-cl) 386 | (cond ((and *causal-link-bounded-cost* (numberp ccost) (> ccost opt-cost)) 387 | (when (> *verbosity* 1) 388 | (format t "~&discarding (~a ~a ~a) because ~a > ~a~%" 389 | producer consumer atom ccost opt-cost)) 390 | nil) 391 | ((find-if #'(lambda (cl) 392 | (and (equal (first cl) producer) 393 | (equal (second cl) consumer) 394 | (equal (third cl) atom))) 395 | opt-cl) 396 | (when (> *verbosity* 1) 397 | (format t "~&discarding (~a ~a ~a) because it is a good link~%" 398 | producer consumer atom)) 399 | nil) 400 | (t t))) 401 | 402 | (defun collect-deleted-predicates (form dels) 403 | (cond ((eq (car form) 'and) 404 | (dolist (f1 (cdr form)) 405 | (setq dels (collect-deleted-predicates f1 dels))) 406 | dels) 407 | ((eq (car form) 'forall) 408 | (collect-deleted-predicates (third form) dels)) 409 | ((eq (car form) 'when) 410 | (collect-deleted-predicates (third form) dels)) 411 | ((eq (car form) 'not) 412 | (if (not (member (first (second form)) dels)) 413 | (cons (first (second form)) dels) 414 | dels)) 415 | (t dels))) 416 | 417 | (defun collect-threats (actions) 418 | (let ((threat-map nil)) 419 | (dolist (act actions) 420 | (let ((dels (collect-deleted-predicates 421 | (assoc-val ':effect (cdr act)) nil))) 422 | (dolist (pred dels) 423 | (setq threat-map (add-to-set-map pred (car act) threat-map))))) 424 | threat-map)) 425 | 426 | ;; print-dominance-graph is used both for MO and DDDL validation 427 | 428 | (defun print-dominance-graph (val-res-list pref-fun) 429 | (format t "~&digraph dominance {~%") 430 | (dolist (val-res val-res-list t) 431 | (cond ((second val-res) 432 | (format t "~& ~a [label=\"~a\"];~%" 433 | (first (first val-res)) 434 | (first (first val-res)))))) 435 | (dolist (val-res-1 val-res-list t) 436 | (dolist (val-res-2 val-res-list t) 437 | (cond ((and (second val-res-1) 438 | (second val-res-2) 439 | (funcall pref-fun (third val-res-1) (third val-res-2))) 440 | (format t "~& ~a -> ~a;~%" 441 | (first (first val-res-1)) 442 | (first (first val-res-2))))))) 443 | (format t "~&}~%") 444 | ) 445 | 446 | (defun mo-strictly-preferred (dirs v1 v2) 447 | (when (or (not (= (length v1) (length v2))) 448 | (not (= (length dirs) (length v1)))) 449 | (error "objective vectors ~s, ~s and ~s cannot be compared!" dirs v1 v2)) 450 | (and (every #'(lambda (d a b) 451 | (if (eq d 'maximize) (>= a b) (<= a b))) 452 | dirs v1 v2) 453 | (some #'(lambda (d a b) 454 | (if (eq d 'maximize) (> a b) (< a b))) 455 | dirs v1 v2))) 456 | 457 | ;; custom DDDL stuff: 458 | 459 | (defun collect-faults (state) 460 | (let ((fault-count nil)) 461 | (dolist (atom state) 462 | (cond ((eq (car atom) 'fault) 463 | (let ((cur (assoc (cadr atom) fault-count :test #'equal))) 464 | (cond (cur (rplacd cur (+ (cdr cur) 1))) 465 | (t (setq fault-count 466 | (cons (cons (cadr atom) 1) fault-count))) 467 | ))))) 468 | fault-count)) 469 | 470 | (defun dddl-preferred (hyp1 hyp2) 471 | (every #'(lambda (fc1) 472 | (let ((fc2 (assoc (car fc1) hyp2 :test #'equal))) 473 | (cond (fc2 (>= (cdr fc2) (cdr fc1))) 474 | (t nil)))) 475 | hyp1)) 476 | 477 | (defun dddl-strictly-preferred (hyp1 hyp2) 478 | (and (dddl-preferred hyp1 hyp2) (not (dddl-preferred hyp2 hyp1)))) 479 | 480 | 481 | ;; Call main function inside an error handler. 482 | 483 | (handler-bind 484 | ((condition #'(lambda (erc) 485 | (format *error-output* "~&~A~&" erc) 486 | (quit)))) 487 | (inval-main)) 488 | (quit) 489 | -------------------------------------------------------------------------------- /itt.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;;;; 3 | ;; Invariant Testing Tools (experimental). 4 | 5 | ;; Example (from sokoban-ae.pddl): 6 | ;; (invariant-test-1 '((?x . object) (?y . object)) 7 | ;; '(imply (and (man ?x) (man ?y)) (= ?x ?y)) 8 | ;; (cdr (first *actions*))) 9 | 10 | (defun invariant-test-1 (fvars form actdef) 11 | (let* ((avars (cdr (assoc ':parameters actdef))) 12 | (vmap (rename-variables avars fvars)) 13 | (rn-def (sublis vmap actdef))) 14 | (list 'forall 15 | (unparse-typed-list (append fvars (sublis vmap avars))) 16 | (list 'imply 17 | (merge-conjunctions form (cdr (assoc ':precondition rn-def))) 18 | (regress-formula form rn-def))) 19 | )) 20 | 21 | (defun print-otter (stream form) 22 | (cond ((and (eq (first form) 'and) (rest form)) 23 | (format stream "(") 24 | (print-otter stream (first (rest form))) 25 | (dolist (c (rest (rest form))) 26 | (format stream " & ") 27 | (print-otter stream c)) 28 | (format stream ")")) 29 | ((and (eq (first form) 'or) (rest form)) 30 | (format stream "(") 31 | (print-otter stream (first (rest form))) 32 | (dolist (c (rest (rest form))) 33 | (format stream " | ") 34 | (print-otter stream c)) 35 | (format stream ")")) 36 | ((eq (first form) 'imply) 37 | (format stream "(") 38 | (print-otter stream (second form)) 39 | (format stream " -> ") 40 | (print-otter stream (third form)) 41 | (format stream ")")) 42 | ((eq (first form) 'not) 43 | (format stream "-") 44 | (print-otter stream (second form))) 45 | ((eq (first form) 'forall) 46 | (format stream "(all") 47 | (dolist (v (parse-typed-list nil (second form) 'object)) 48 | (format stream " ~a" (variable-name (car v)))) 49 | (format stream " ") 50 | (print-otter stream (third form)) 51 | (format stream ")")) 52 | ((eq (first form) 'exists) 53 | (format stream "(exists") 54 | (dolist (v (parse-typed-list nil (second form) 'object)) 55 | (format stream " ~a" (variable-name (car v)))) 56 | (format stream " ") 57 | (print-otter stream (third form)) 58 | (format stream ")")) 59 | ((and (eq (first form) '=) 60 | (variable-p (second form)) 61 | (variable-p (third form))) 62 | (format stream "(~a = ~a)" 63 | (variable-name (second form)) 64 | (variable-name (third form)))) 65 | ((and (listp form) (every #'variable-p (rest form))) 66 | (format stream "~a(" (first form)) 67 | (cond ((rest form) 68 | (format stream "~a" (variable-name (first (rest form)))) 69 | (dolist (a (rest (rest form))) 70 | (format stream ",~a" (variable-name a))))) 71 | (format stream ")")) 72 | (t (error "can't print ~s" form)) 73 | )) 74 | 75 | (defun invariant-vars (inv) 76 | (parse-typed-list nil (cdr (assoc ':vars inv)) 'object)) 77 | 78 | (defun invariant-formula (inv) 79 | (let ((fo (assoc ':formula inv)) 80 | (sc (assoc ':set-constraint inv))) 81 | (cond (fo (cdr fo)) 82 | (sc (set-constraint-formula (cdr sc))) 83 | (t nil) 84 | ))) 85 | 86 | ;; (defun invariant-formula (inv) 87 | ;; (let ((qv (assoc ':vars inv)) 88 | ;; (fo (assoc ':formula inv)) 89 | ;; (sc (assoc ':set-constraint inv))) 90 | ;; (cond (fo (cond (qv (list 'forall qv (cdr fo))) 91 | ;; (t (cdr fo)))) 92 | ;; (sc (set-constraint-formula (cdr sc) qv)) 93 | ;; (t nil) 94 | ;; ))) 95 | 96 | ;; (defun set-constraint-formula (sc vars) 97 | ;; (if (not (eq (second sc) 1)) 98 | ;; (error "can't translate set constraint ~s" sc)) 99 | ;; (cond ((eq (first sc) 'at-most-n) 100 | ;; (at-most-one-formula (rest (rest sc)) vars)) 101 | ;; ((eq (first sc) 'at-least-n) 102 | ;; (at-least-one-formula (rest (rest sc)) vars)) 103 | ;; ((eq (first sc) 'exactly-n) 104 | ;; (merge-conjunctions 105 | ;; (at-most-one-formula (rest (rest sc)) vars) 106 | ;; (at-least-one-formula (rest (rest sc)) vars))) 107 | ;; (t (error "ill-formed set constraint: ~s" sc)) 108 | ;; )) 109 | 110 | ;; (defun enumerate-disjunctions (atoms neg vars) 111 | ;; (cond ((endp atoms) nil) 112 | ;; ((eq (first (first atoms)) 'setof) 113 | ;; (cons (...) 114 | ;; (mapcar #'(lambda (a) 115 | ;; (make-disjunction (first atoms) a neg vars)) 116 | ;; (rest atoms)))) 117 | ;; (t (mapcar #'(lambda (a) 118 | ;; (make-disjunction (first atoms) a neg vars)) 119 | ;; (rest atoms))) 120 | ;; )) 121 | 122 | ;; (defun make-disjunction (atom1 atom2 neg vars) 123 | ;; (cond ((and (eq (first atom1) 'setof) 124 | ;; (eq (first atom2) 'setof)) 125 | ;; (let ((lvars 126 | ;; (append 127 | ;; (parse-typed-list nil vars 'object) 128 | ;; (parse-typed-list nil (cdr (assoc ':vars atom1)) 'object) 129 | ;; (parse-typed-list nil (cdr (assoc ':vars atom2)) 'object))) 130 | ;; (d1 (merge-conjunctions (cdr (assoc ':context atom1)) 131 | ;; (first (last atom1)))) 132 | ;; (d2 (merge-conjunctions (cdr (assoc ':context atom2)) 133 | ;; (first (last atom2))))) 134 | ;; (list 'forall (unparse-typed-list lvars) 135 | ;; (list 'or (if neg (list 'not d1) d1) 136 | ;; (if neg (list 'not d2) d2))))) 137 | ;; ((eq (first atom1) 'setof) 138 | ;; (let ((lvars 139 | ;; (append 140 | ;; (parse-typed-list nil vars 'object) 141 | ;; (parse-typed-list nil (cdr (assoc ':vars atom1)) 'object))) 142 | ;; (d1 (merge-conjunctions (cdr (assoc ':context atom1)) 143 | ;; (first (last atom1))))) 144 | ;; (list 'forall (unparse-typed-list lvars) 145 | ;; (list 'or (if neg (list 'not d1) d1) 146 | ;; (if neg (list 'not atom2) atom2))))) 147 | ;; ((eq (first atom2) 'setof) 148 | ;; (make-disjunction atom2 atom1 neg vars)) 149 | ;; (vars 150 | ;; (list 'forall vars 151 | ;; (list 'or (if neg (list 'not atom1) atom1) 152 | ;; (if neg (list 'not atom2) atom2)))) 153 | ;; (t (list 'or (if neg (list 'not atom1) atom1) 154 | ;; (if neg (list 'not atom2) atom2))) 155 | ;; )) 156 | 157 | 158 | (defun regress-formula (form actdef) 159 | (cond 160 | ((null form) ':true) 161 | ((member (car form) '(and or not imply)) 162 | (cons (car form) 163 | (mapcar #'(lambda (f1) (regress-formula f1 actdef)) (cdr form)))) 164 | ((member (car form) '(forall exists)) 165 | (if (not (= (length form) 3)) (error "ill-formed formula: ~s" form)) 166 | (list (car form) (second form) (regress-formula (third form) actdef))) 167 | ((eq (car form) '=) form) 168 | ((assoc (car form) *builtin-numeric-predicates*) form) 169 | ;; note: this implements DBA semantics; if an action makes the atom 170 | ;; true, it doesn't have to avoid making it false. 171 | (t (let ((ctrue (make-atom-true form actdef))) 172 | (cond (ctrue 173 | (list 'or ctrue 174 | (merge-conjunctions 175 | form (not-make-atom-false form actdef)))) 176 | (t (merge-conjunctions 177 | form (not-make-atom-false form actdef)))))) 178 | )) 179 | 180 | (defun make-atom-true (atom actdef) 181 | (let ((adds (collect-adds (cdr (assoc ':effect actdef))))) 182 | (reduce #'merge-disjunctions 183 | (mapcar #'(lambda (add) 184 | (let ((binds (unify atom (first add)))) 185 | (if binds 186 | (let ((econd 187 | (make-effect-condition 188 | (first binds) (second add) (third add)))) 189 | (if econd econd ':true)) 190 | nil))) 191 | adds) 192 | :initial-value nil))) 193 | 194 | (defun not-make-atom-false (atom actdef) 195 | (let ((dels (collect-dels (cdr (assoc ':effect actdef))))) 196 | (reduce #'merge-conjunctions 197 | (mapcar #'(lambda (del) 198 | (let ((binds (unify atom (first del)))) 199 | (if binds 200 | (let ((econd 201 | (make-effect-condition 202 | (first binds) (second del) (third del)))) 203 | (if econd (list 'not econd) ':false)) 204 | nil))) 205 | dels) 206 | :initial-value nil))) 207 | 208 | (defun unify (e1 e2) 209 | (cond ((and (consp e1) (consp e2)) 210 | (let ((b1 (unify (car e1) (car e2)))) 211 | (if b1 (let ((b2 (unify (cdr e1) (cdr e2)))) 212 | (if b2 (list (append (car b1) (car b2))) nil)) 213 | nil))) 214 | ((variable-p e2) 215 | (list (list (cons e1 e2)))) 216 | ((variable-p e1) 217 | (list (list (cons e1 e2)))) 218 | ((equal e1 e2) (list nil)) 219 | (t nil))) 220 | 221 | (defun make-effect-condition (binds econd qvars) 222 | (cond ((endp binds) econd) 223 | (t (let ((qv (assoc (cdr (first binds)) qvars))) 224 | (cond (qv 225 | (cond ((not (eq (cdr qv) 'object)) 226 | (merge-conjunctions 227 | (list (cdr qv) (car (first binds))) 228 | (sublis (list (cons (cdr (first binds)) 229 | (car (first binds)))) 230 | (make-effect-condition 231 | (rest binds) econd qvars)))) 232 | (t (sublis (list (cons (cdr (first binds)) 233 | (car (first binds)))) 234 | (make-effect-condition 235 | (rest binds) econd qvars))) 236 | )) 237 | (t (merge-conjunctions 238 | (list '= (car (first binds)) (cdr (first binds))) 239 | (make-effect-condition (rest binds) econd qvars))) 240 | ))) 241 | )) 242 | 243 | (defun collect-adds (eff) 244 | (cond 245 | ((null eff) nil) 246 | ((eq (car eff) 'not) nil) 247 | ((member (car eff) '(increase decrease assign)) nil) 248 | ((eq (car eff) 'and) 249 | (mapflat #'(lambda (e1) (collect-adds e1)) (rest eff))) 250 | ((eq (car eff) 'when) 251 | (mapcar #'(lambda (c1) 252 | (list (first c1) 253 | (merge-conjunctions (second eff) (second c1)) 254 | (third c1))) 255 | (collect-adds (third eff)))) 256 | ((eq (car eff) 'forall) 257 | (let ((vars (parse-typed-list nil (second eff) 'object))) 258 | (mapcar #'(lambda (c1) 259 | (list (first c1) (second c1) vars)) 260 | (collect-adds (third eff))))) 261 | (t (list (list eff nil nil))) 262 | )) 263 | 264 | (defun collect-dels (eff) 265 | (cond 266 | ((null eff) nil) 267 | ((eq (car eff) 'not) 268 | (list (list (second eff) nil nil))) 269 | ((member (car eff) '(increase decrease assign)) nil) 270 | ((eq (car eff) 'and) 271 | (mapflat #'(lambda (e1) (collect-dels e1)) (rest eff))) 272 | ((eq (car eff) 'when) 273 | (mapcar #'(lambda (c1) 274 | (list (first c1) 275 | (merge-conjunctions (second eff) (second c1)) 276 | (third c1))) 277 | (collect-dels (third eff)))) 278 | ((eq (car eff) 'forall) 279 | (let ((vars (parse-typed-list nil (second eff) 'object))) 280 | (mapcar #'(lambda (c1) 281 | (list (first c1) (second c1) vars)) 282 | (collect-dels (third eff))))) 283 | (t nil) 284 | )) 285 | -------------------------------------------------------------------------------- /nyat-main.lsp: -------------------------------------------------------------------------------- 1 | ;; #!/usr/local/bin/ecl -shell 2 | 3 | ;; (load "inval.lsp") 4 | ;; (load "rsk.lsp") 5 | ;; (load "simplify.lsp") 6 | ;; (load "fdr3.lsp") 7 | 8 | ;; GCL version 9 | ;; (defun get-commandline-args () 10 | ;; (cdr si::*command-args*)) 11 | 12 | ;; ECL version 13 | (defun get-commandline-args () 14 | (cdr (ext:command-args))) 15 | 16 | ;; set config options 17 | (setq *verbosity* 0) 18 | (setq *typecheck* t) 19 | 20 | ;; increase memory limit to 2Gb 21 | ;; (ext:set-limit 'ext:heap-size (* 2 1024 1024 1024)) 22 | ;; (let ((heap-lim (ext:get-limit 'ext:heap-size))) 23 | ;; (format t "heap size limit: ~a~%" heap-lim)) 24 | 25 | (defun new-yat-main () 26 | ;; read/parse input files 27 | (do ((rem-arg-list (get-commandline-args) (cdr rem-arg-list))) 28 | ((endp rem-arg-list) t) 29 | (let ((arg (car rem-arg-list))) 30 | (cond ((string= arg "-v") 31 | (setq *verbosity* (+ *verbosity* 1))) 32 | ((string= arg "-m") 33 | (if (endp (cdr rem-arg-list)) 34 | (error "option -m requires an argument (heap size in Mb)")) 35 | (let ((new-lim (read-from-string (cadr rem-arg-list)))) 36 | (if (not (numberp new-lim)) 37 | (error "argument to -m must be a number!")) 38 | (ext:set-limit 'ext:heap-size (* new-lim 1024 1024)) 39 | (let ((heap-lim (ext:get-limit 'ext:heap-size))) 40 | (format t "heap size limit: ~a~%" heap-lim)) 41 | (setq rem-arg-list (cdr rem-arg-list)))) 42 | ((string= arg "-enum-names") 43 | (setq *name-FDR-variable-by-atom-name* nil)) 44 | ((string= arg "-no-cost") 45 | (setq *force-non-metric* t)) 46 | ((string= arg "-no-type-check") 47 | (setq *typecheck* nil)) 48 | (t (format t "~&reading ~a...~%" arg) 49 | (let ((contents (read-file arg))) 50 | (parse-file arg contents)))))) 51 | ;; Type-checking: 52 | (cond (*typecheck* 53 | (setq *axioms* 54 | (mapcar #'(lambda (axiom) 55 | (type-enhance-axiom axiom *predicates* *types*)) 56 | *axioms*)) 57 | (if (not (type-check)) (quit) 58 | (format t "~&domain/problem type check ok~%")))) 59 | (when (>= *verbosity* 1) (format t "~&rsk to SAS...~%")) 60 | (let ((sfun (collect-static-functions *functions* *actions*))) 61 | (when (>= *verbosity* 1) (format t "~&static functions: ~a~%" sfun)) 62 | (rsk-internal :target 'sas 63 | :static-fun sfun)) 64 | (when (>= *verbosity* 1) (format t "~&grounding...~%")) 65 | (multiple-value-bind (fluents atoms ground-actions ground-axioms) 66 | (simple-ground *predicates* *functions* *actions* *axioms* 67 | *init* *goal* *types* *objects*) 68 | (multiple-value-bind 69 | (axiom-strata dp-strata) (stratify *axioms*) 70 | (format t "~&writing output.sas...~%") 71 | (with-open-file 72 | (stream "output.sas" :direction :output) 73 | (output-FDR-v3 stream fluents atoms dp-strata 74 | (filter-sas-actions ground-actions) 75 | ground-axioms *init* *goal*) 76 | )))) 77 | 78 | ;; call main with a print-and-quit handler for all error conditions 79 | (handler-bind 80 | ((condition #'(lambda (erc) 81 | (format *error-output* "~&~A~&" erc) 82 | (quit)))) 83 | (new-yat-main)) 84 | (quit) 85 | -------------------------------------------------------------------------------- /pddl3.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;(load "inval.lsp") 3 | ;(load "itt.lsp") 4 | 5 | 6 | ;;;; 7 | ;; PDDL3 plan constraint compilation (destructive). 8 | 9 | (defvar *eok-counter* 0) 10 | 11 | ;; Compile constraint (sometime alpha), where alpha is atomic, into 12 | ;; the domain & problem. 13 | 14 | (defun compile-sometime (atom) 15 | (let ((ok-pred (symnumcat 'e-ok (setq *eok-counter* (+ *eok-counter* 1))))) 16 | (setq *predicates* (cons (list ok-pred) *predicates*)) 17 | (setq *goal* (merge-conjunctions (list ok-pred) *goal*)) 18 | (dolist (act *actions*) 19 | (let ((addcond (make-atom-true atom (cdr act)))) 20 | (cond ((eq addcond ':true) 21 | (rplacd act 22 | (reassoc ':effect 23 | (merge-conjunctions 24 | (list ok-pred) 25 | (assoc-val ':effect (cdr act))) 26 | (cdr act)))) 27 | (addcond 28 | (rplacd act 29 | (reassoc ':effect 30 | (merge-conjunctions 31 | (list 'when addcond (list ok-pred)) 32 | (assoc-val ':effect (cdr act))) 33 | (cdr act)))) 34 | ))) 35 | ok-pred)) 36 | 37 | ;; Compile constraint (sometime-before alpha beta), where alpha and beta 38 | ;; are both atomic, into the domain & problem. 39 | 40 | (defun compile-sometime-before (alpha beta) 41 | (let ((ok-pred (compile-sometime beta))) 42 | (dolist (act *actions*) 43 | (let ((addcond (make-atom-true alpha (cdr act)))) 44 | (cond ((eq addcond ':true) 45 | (rplacd act 46 | (reassoc ':precondition 47 | (merge-conjunctions 48 | (list ok-pred) 49 | (assoc-val ':precondition (cdr act))) 50 | (cdr act)))) 51 | (addcond 52 | (rplacd act 53 | (reassoc ':precondition 54 | (merge-conjunctions 55 | (list 'imply addcond (list ok-pred)) 56 | (assoc-val ':effect (cdr act))) 57 | (cdr act)))) 58 | ))))) 59 | 60 | ;; Compile in tracking of a specific action sequence (destructive). 61 | ;; The compiled domain will have conditional effects. 62 | ;; plan is a plan (list of happenings), as in *plans* but must be 63 | ;; sequential (exactly one action per happening) 64 | ;; plan-id is a symbol that will be used to prefix tracking predicates. 65 | ;; Returns: A list of two atoms ((plan-id-done) (plan-id-div)); on 66 | ;; execution of any plan in the compiled domain, (plan-done) will hold 67 | ;; in the final state if it matches the tracked action sequence (exactly); 68 | ;; if it does not, the condition (or (not (plan-done)) (plan-div)) will 69 | ;; hold. 70 | 71 | (defun track-action-sequence (plan plan-id) 72 | (let ((splan (mapcar #'(lambda (step) 73 | (when (> (length step) 1) 74 | (error "~&plan is not a sequence: ~s~%" step)) 75 | (first step)) 76 | plan)) 77 | (step-preds nil) 78 | (done-pred (list (symnumcat plan-id '-done))) 79 | (div-pred (list (symnumcat plan-id '-div))) 80 | ) 81 | ;; create list of step predicates 82 | (dotimes (step-num (length splan)) 83 | (setq step-preds 84 | (nconc step-preds 85 | (list (list (symnumcat plan-id '-step- step-num)))))) 86 | (setq step-preds (nconc step-preds (list done-pred))) 87 | (setq step-preds (nconc step-preds (list div-pred))) 88 | ;; for each action 89 | (dolist (act *actions*) 90 | (let ((matches (find-indices splan (car act) :key #'first)) 91 | (new-effects nil)) 92 | (dolist (index matches) 93 | (when (not (eq (length (cdr (nth index splan))) 94 | (length (assoc-val ':parameters (cdr act))))) 95 | (error "~&step ~a : ~a does not match parameters of action:~%~a~%" 96 | index (nth index splan) act)) 97 | (let* ((param-constraints 98 | (mapcar #'(lambda (par arg) (list '= (car par) arg)) 99 | (assoc-val ':parameters (cdr act)) 100 | (cdr (nth index splan)))) 101 | (effcond (append (list 'and (nth index step-preds)) 102 | param-constraints)) 103 | (ce (list 'when effcond 104 | (list 'and (nth (+ index 1) step-preds) 105 | (list 'not (nth index step-preds)))))) 106 | (push ce new-effects))) 107 | (cond 108 | ((null new-effects) (push div-pred new-effects)) 109 | (t (let ((div-cond 110 | (transform-to-nnf 111 | (cons 'and (mapcar #'(lambda (ce) (list 'not (second ce))) 112 | new-effects)) 113 | nil))) 114 | (push (list 'when div-cond div-pred) new-effects)))) 115 | (rplacd act 116 | (reassoc ':effect 117 | (merge-conjunctions 118 | (cons 'and new-effects) 119 | (assoc-val ':effect (cdr act))) 120 | (cdr act))) 121 | )) 122 | (setq *predicates* (nconc *predicates* step-preds)) 123 | (setq *init* (cons (first step-preds) *init*)) 124 | (list done-pred div-pred) 125 | )) 126 | 127 | (defun find-indices (seq element &key (key #'identity)) 128 | (let ((indices nil)) 129 | (dotimes (i (length seq)) 130 | (when (eq (funcall key (nth i seq)) element) 131 | (push i indices))) 132 | (reverse indices))) 133 | 134 | ;;;; 135 | ;; Plan set analysis 136 | 137 | ;; Find a set of constraints that hold in all *plans*. 138 | ;; Constraints returned are of the forms: 139 | ;; (sometime phi) where phi is an atom or a disjunction of atoms 140 | ;; (sometime-before alpha beta), where alpha and beta are atoms 141 | 142 | (defun find-satisfied-constraints 143 | (&key (clean t) (static-pred nil) (limit nil)) 144 | (let ((seqs (get-state-sequences :clean clean :static-pred static-pred))) 145 | (append 146 | (mapcar #'(lambda (atom-set) 147 | (list 'always 148 | (if (> (length atom-set) 1) (cons 'or atom-set) 149 | (first atom-set)))) 150 | (find-common-always seqs '(()) :limit limit)) 151 | (mapflat #'(lambda (pair) 152 | (mapcar #'(lambda (atom) 153 | (list 'sometime-before (car pair) atom)) 154 | (cdr pair))) 155 | (find-common-sb seqs nil)) 156 | ;; extraction of sometime-after constraints is not correct, so exclude 157 | ;; it for now. 158 | ;; (mapflat #'(lambda (pair) 159 | ;; (mapcar #'(lambda (atom) 160 | ;; (list 'sometime-after (car pair) atom)) 161 | ;; (cdr pair))) 162 | ;; (find-common-sa seqs nil)) 163 | ))) 164 | 165 | (defun find-violated-constraints 166 | (&key (clean t) (static-pred nil) (limit nil)) 167 | (let ((seqs (get-state-sequences :clean clean :static-pred static-pred))) 168 | (append 169 | (mapcar #'(lambda (atom-set) 170 | (list 'sometime 171 | (if (> (length atom-set) 1) 172 | (cons 'and (mapcar #'(lambda (atom) 173 | (list 'not atom)) 174 | atom-set)) 175 | (list 'not (first atom-set))))) 176 | (find-common-always seqs '(()) :limit limit)) 177 | (mapflat #'(lambda (pair) 178 | (mapcar #'(lambda (atom) 179 | (list 'sometime-before atom (car pair))) 180 | (cdr pair))) 181 | (find-common-sb seqs nil)) 182 | (mapflat #'(lambda (pair) 183 | (mapcar #'(lambda (atom) 184 | (list 'sometime-after atom (car pair))) 185 | (cdr pair))) 186 | (find-common-sa seqs nil)) 187 | ))) 188 | 189 | ;; get state sequences for valid plans, and optionally clean them 190 | 191 | (defun get-state-sequences (&key (clean t) (static-pred nil)) 192 | (mapcar #'third 193 | (remove nil 194 | (mapcar 195 | #'(lambda (plan) 196 | (validate-plan 197 | (car plan) (cdr plan) *init* *goal* *constraints* nil 198 | *actions* (stratify *axioms*) *types* *objects* 199 | :visualisation 200 | #'(lambda (p s) 201 | (if clean 202 | (clean-state-seq s :static-pred static-pred) 203 | s)))) 204 | *plans*) 205 | :key #'first))) 206 | 207 | ;; remove fluent assignments and (optionally) static facts from each 208 | ;; state in a sequence. 209 | 210 | (defun clean-state-seq (seq &key (static-pred nil)) 211 | (mapcar #'(lambda (state) 212 | (remove-if #'(lambda (atom) 213 | (or (eq (car atom) '=) 214 | (member (car atom) static-pred))) 215 | state)) 216 | seq)) 217 | 218 | (defun save-satisfied-constraints 219 | (filename &key (clean t) (static-pred nil) (limit nil)) 220 | (with-open-file 221 | (stream filename :direction :output) 222 | (format stream "(define (problem satisifed)~%") 223 | (format stream " (:constraints~%") 224 | (format stream " (and~%") 225 | (dolist (con (find-satisfied-constraints 226 | :clean clean :static-pred static-pred :limit limit)) 227 | (format stream " ~a~%" con)) 228 | (format stream " )))~%") 229 | )) 230 | 231 | 232 | ;; Returns a list of sets of ground atoms such that the disjunction over 233 | ;; each set holds in every state in every sequence. 234 | 235 | (defun find-common-always (seqs cands &key (limit nil)) 236 | (if (endp seqs) cands 237 | (find-common-always (rest seqs) 238 | (find-always (first seqs) cands :limit limit) 239 | :limit limit))) 240 | 241 | (defun find-always (seq cands &key (limit nil)) 242 | (if (endp seq) cands 243 | (find-always (rest seq) 244 | (check-always-candidates cands (first seq) nil :limit limit) 245 | :limit limit))) 246 | 247 | (defun check-always-candidates 248 | (cands state new-cands &key (limit nil)) 249 | (cond ((endp cands) new-cands) 250 | ((find-any (first cands) state :test #'equal) 251 | (check-always-candidates 252 | (rest cands) state (cons (first cands) new-cands) 253 | :limit limit)) 254 | ((and (numberp limit) (>= (length (first cands)) limit)) 255 | (check-always-candidates 256 | (rest cands) state new-cands :limit limit)) 257 | (t (check-always-candidates 258 | (rest cands) state 259 | (extend-always-candidate 260 | (first cands) state new-cands (rest cands)) 261 | :limit limit)) 262 | )) 263 | 264 | (defun extend-always-candidate (cand state new-cands cands) 265 | (if (endp state) new-cands 266 | (let ((ecand (cons (first state) cand))) 267 | (if (or (some #'(lambda (x) (subsetp x ecand :test #'equal)) new-cands) 268 | (some #'(lambda (x) (subsetp x ecand :test #'equal)) cands)) 269 | (extend-always-candidate cand (rest state) new-cands cands) 270 | (extend-always-candidate 271 | cand (rest state) (cons ecand new-cands) cands))))) 272 | 273 | (defun find-any (lista listb &key (test #'eq)) 274 | (some #'(lambda (el) (find el listb :test test)) lista)) 275 | 276 | 277 | ;; Returns an assoc list of entries (atom . prev-atoms) such that each 278 | ;; atom in the list prev-atoms is true sometime (strictly) before the 279 | ;; first occurrence of 'atom in each state sequence. 280 | 281 | (defun find-common-sb (seqs cands) 282 | (if (endp seqs) cands 283 | (find-common-sb 284 | (rest seqs) (combine-sb-candidates 285 | (find-sb (first seqs) nil nil) cands)))) 286 | 287 | ;; NOT CORRECT: We can find common _strict_ sa's by doing sb's on the 288 | ;; reversed seqeunces. 289 | ;; The problem is that common sb's can include constraints that are 290 | ;; satisfied on some sequences because the trigger is never true; this 291 | ;; makes the reversed sa constraint unsatisfied. 292 | (defun find-common-sa (seqs cands) 293 | (find-common-sb (mapcar #'reverse seqs) cands)) 294 | 295 | (defun find-sb (seq prev cands) 296 | (if (endp seq) cands 297 | (let ((new-facts (set-difference (first seq) prev :test #'equal))) 298 | (find-sb (rest seq) (union prev new-facts :test #'equal) 299 | (if prev (append (mapcar #'(lambda (f) (cons f prev)) 300 | new-facts) 301 | cands) 302 | cands))))) 303 | 304 | ;; For each entry (atom . list) in clist{1,2}: if there is an entry 305 | ;; with the same atom in the other clist, then assoc the atom with the 306 | ;; intersection of the two lists; else keep the entry as is. 307 | 308 | (defun combine-sb-candidates (clist1 clist2) 309 | (append 310 | (remove nil 311 | (mapcar #'(lambda (ent1) 312 | (let ((ent2 (assoc (car ent1) clist2 :test #'equal))) 313 | (if (null ent2) ent1 314 | (let ((iset (intersection 315 | (cdr ent1) (cdr ent2) :test #'equal))) 316 | (if iset (cons (car ent1) iset) nil))))) 317 | clist1)) 318 | (set-difference clist2 clist1 :key #'car :test #'equal))) 319 | -------------------------------------------------------------------------------- /rsk-main.lsp: -------------------------------------------------------------------------------- 1 | ;;#!/usr/lib/gcl-2.6.8/unixport/saved_gcl -f 2 | 3 | ;; Note: Load is only requried when running as a script. 4 | ;;(load "inval.lsp") 5 | ;;(load "rsk.lsp") 6 | 7 | ;; GCL version 8 | ;; (defun get-commandline-args () 9 | ;; (cdr si::*command-args*)) 10 | 11 | ;; ECL version 12 | (defun get-commandline-args () 13 | (cdr (ext:command-args))) 14 | 15 | ;; note: when running as a script with ECL, use: 16 | ;; (defun get-commandline-args () 17 | ;; ext:*unprocessed-ecl-command-args*) 18 | 19 | 20 | (setq *typecheck* nil) 21 | (setq *target* 'strips) 22 | (setq *declare-constants* t) 23 | 24 | (defun print-help () 25 | (format t "~&rsk [option | file]*~%") 26 | (format t "~&options:~%") 27 | (format t "~& -c : Type-check before compilation, abort if check fails.~%") 28 | (format t "~& -f : Flatten only (output PDDL3.1 without nested fluent terms).~%") 29 | (format t "~& -s : Compile to \"sas\" (output flat PDDL3.1 with atomic rhs's).~%") 30 | (format t "~& Default output is PDDL without object fluents.~%") 31 | (format t "~& -n : Do not use :constants declaration in domain.~%") 32 | (format t "~& -r ~%") 33 | (format t "~& -D ~%") 34 | (format t "~& -P ~%") 35 | (format t "~&Any non-option argument is assumed to be an input file.~%") 36 | (quit)) 37 | 38 | (defun rsk-main () 39 | (let ((requirements '(:adl :typing :equality :fluents)) 40 | (domain-file-name "rsk-domain.pddl") 41 | (problem-file-name "rsk-problem.pddl")) 42 | (if (endp (get-commandline-args)) (print-help)) 43 | (do ((rem-arg-list (get-commandline-args) (cdr rem-arg-list))) 44 | ((endp rem-arg-list) t) 45 | (let ((arg (car rem-arg-list))) 46 | (cond ((equal arg "-c") 47 | (setq *typecheck* t)) 48 | ((equal arg "-s") 49 | (setq *target* 'sas)) 50 | ((equal arg "-f") 51 | (setq *target* nil)) 52 | ((equal arg "-n") 53 | (setq *declare-constants* nil)) 54 | ((equal arg "-r") 55 | (if (endp (cdr rem-arg-list)) 56 | (format t "~&option -r requires an argument (requirements list)~%") 57 | (setq requirements 58 | (read-from-string (car (cdr rem-arg-list)))))) 59 | ((equal arg "-D") 60 | (if (endp (cdr rem-arg-list)) 61 | (format t "~&option -D requires an argument (domain file name)~%") 62 | (setq domain-file-name (car (cdr rem-arg-list))))) 63 | ((equal arg "-P") 64 | (if (endp (cdr rem-arg-list)) 65 | (format t "~&option -P requires an argument (problem file name)~%") 66 | (setq problem-file-name (car (cdr rem-arg-list))))) 67 | (t (format t "~&reading ~a...~%" arg) 68 | (let ((contents (read-file arg))) 69 | (parse-file arg contents)))))) 70 | ;; Type-checking: 71 | (when *typecheck* 72 | (cond ((type-check) 73 | (format t "~&~s/~s type check ok~%" *domain-name* *problem-name*)) 74 | (t (quit)))) 75 | (multiple-value-bind 76 | (new-domain declared-constants) 77 | (rsk-domain *domain-name* *requirements* *objects* *types* 78 | *predicates* *functions* *axioms* *actions* 79 | :target *target* :declare-constants *declare-constants*) 80 | (let ((new-problem 81 | (rsk-problem *problem-name* *domain-name* *objects* *types* 82 | *functions* *init* *goal* *metric-type* *metric* 83 | declared-constants :target *target*))) 84 | (format t "~&writing domain to ~a...~%" domain-file-name) 85 | (write-PDDL domain-file-name new-domain) 86 | (format t "~&writing problem to ~a...~%" problem-file-name) 87 | (write-PDDL problem-file-name new-problem) 88 | )))) 89 | 90 | ;; Call main function inside an error handler. 91 | 92 | (handler-bind 93 | ((condition #'(lambda (erc) 94 | (format *error-output* "~&~A~&" erc) 95 | (quit)))) 96 | (rsk-main)) 97 | (quit) 98 | -------------------------------------------------------------------------------- /run-val-test-ipc4.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;; Running as a script 3 | ;;;; 4 | ;; 5 | ;; #!/usr/local/bin/ecl -shell 6 | ;; 7 | ;; (load "inval.lsp") 8 | ;; (load "val-test-util.lsp") 9 | ;; 10 | ;; (defun get-commandline-args () 11 | ;; (cdr ext:*unprocessed-ecl-command-args*)) 12 | ;; 13 | ;;;; 14 | 15 | (setq *max-tests-per-domain* 2) 16 | 17 | (handler-bind 18 | ((condition #'(lambda (erc) 19 | (format *error-output* "~&~A~&" erc) 20 | (quit)))) 21 | 22 | ;; Airport 23 | 24 | (format t "~&~%=== Airport/ADL ===~%~%") 25 | (do-test-all 26 | "domain" "../domains/ipc4/airport/adl/p??_airport*.pddl" 27 | :plan-loc "../domains/ipc4/RESULTS/airport/nontemporal/adl/*/" 28 | :max-n *max-tests-per-domain*) 29 | 30 | (format t "~&~%=== Airport/STRIPS ===~%~%") 31 | (do-test-all 32 | nil "../domains/ipc4/airport/strips/p??_airport*.pddl" 33 | :plan-loc "../domains/ipc4/RESULTS/airport/nontemporal/strips/*/" 34 | :max-n *max-tests-per-domain*) 35 | 36 | ;; Pipesworld 37 | 38 | (format t "~&~%=== Pipesworld-Notankage/STRIPS ===~%~%") 39 | (do-test-all 40 | "domain" 41 | "../domains/ipc4/pipesworld/notankage-nontemporal/strips/p??_net*.pddl" 42 | :max-n *max-tests-per-domain*) 43 | 44 | (format t "~&~%=== Pipesworld-Tankage/STRIPS ===~%~%") 45 | (do-test-all 46 | "domain" 47 | "../domains/ipc4/pipesworld/tankage-nontemporal/strips/p??_net*.pddl" 48 | :max-n *max-tests-per-domain*) 49 | 50 | ;; Promela (Philosophers) 51 | 52 | ;; Philosophers non-numeric ADL formulations all declare a type with name 53 | ;; 'number' which is not allowed by recent versions of VAL; all tests in 54 | ;; these domain formulations fail. 55 | 56 | ;; (format t "~&~%=== Philosophers/ADL ===~%~%") 57 | ;; (do-test-all 58 | ;; "domain" "../domains/ipc4/promela/philosophers/adl/p??_*.pddl" 59 | ;; "../domains/ipc4/RESULTS/promela/philosophers/adl/*/") 60 | 61 | (format t "~&~%=== Philosophers/STRIPS ===~%~%") 62 | (do-test-all 63 | nil "../domains/ipc4/promela/philosophers/strips/p0?.pddl" 64 | :plan-loc "../domains/ipc4/RESULTS/promela/philosophers/strips/*/" 65 | :max-n *max-tests-per-domain*) 66 | 67 | ;; (format t "~&~%=== Philosophers-DerivedPred/ADL-DerivedPred ===~%~%") 68 | ;; (do-test-all 69 | ;; "domain" 70 | ;; "../domains/ipc4/promela/philosophers_derivedpredicates/adl_derivedpredicates/p0?_phil*.pddl" 71 | ;; "../domains/ipc4/RESULTS/promela/philosophers_derivedpredicates/adl_derivedpredicates/*/") 72 | 73 | (format t "~&~%=== Philosophers-DerivedPred/STRIPS-DerivedPred ===~%~%") 74 | (do-test-all 75 | nil 76 | "../domains/ipc4/promela/philosophers_derivedpredicates/strips_derivedpredicates/p0?_phil*.pddl" 77 | :plan-loc "../domains/ipc4/RESULTS/promela/philosophers_derivedpredicates/strips_derivedpredicates/*/" 78 | :max-n *max-tests-per-domain*) 79 | 80 | (format t "~&~%=== Philosophers-Fluents/ADL-Fluents ===~%~%") 81 | (do-test-all 82 | "domain" 83 | "../domains/ipc4/promela/philosophers_fluents/adl_fluents/p0?_phil*.pddl" 84 | :plan-loc "../domains/ipc4/RESULTS/promela/philosophers_fluents/adl_fluents/*/" 85 | :max-n *max-tests-per-domain*) 86 | 87 | (format t "~&~%=== Philosophers-Fluents-DerivedPred/ADL-Fluents-DerivedPred ===~%~%") 88 | (do-test-all 89 | "domain" 90 | "../domains/ipc4/promela/philosophers_fluents_derivedpre/adl_fluents_derivedpredicates/p0?_phil*.pddl" 91 | :plan-loc "../domains/ipc4/RESULTS/promela/philosophers_fluents_derivedpre/adl_fluents_derivedpredicates/*/" 92 | :max-n *max-tests-per-domain*) 93 | 94 | ;; PSR 95 | 96 | ;; Use fast fixpoint computation for the ADL versions of this domain. 97 | ;; In the STRIPS version, axioms are grounded, so it does not improve. 98 | ;; (setq *fast-axiom-compute-fixpoint* t) 99 | 100 | ;; (format t "~&~%=== PSR-Middle/ADL-DerivedPred ===~%~%") 101 | ;; (do-test-all 102 | ;; "domain" 103 | ;; "../domains/ipc4/psr/middle/adl_derivedpredicates/p*.pddl" 104 | ;; :plan-loc "../domains/ipc4/RESULTS/psr/middle/adl_derivedpredicates/*/" 105 | ;; :max-n *max-tests-per-domain*) 106 | 107 | ;; (format t "~&~%=== PSR-Middle/SimpleADL-DerivedPred ===~%~%") 108 | ;; (do-test-all 109 | ;; nil 110 | ;; "../domains/ipc4/psr/middle/simpleadl_derivedpredicates/p??_s*.pddl" 111 | ;; :plan-loc "../domains/ipc4/RESULTS/psr/middle/simpleadl_derivedpredicates/*/" 112 | ;; :max-n *max-tests-per-domain*) 113 | 114 | ;; (setq *fast-axiom-compute-fixpoint* nil) 115 | 116 | ;; (format t "~&~%=== PSR-Middle/STRIPS-DerivedPred ===~%~%") 117 | ;; (do-test-all 118 | ;; nil 119 | ;; "../domains/ipc4/psr/middle/strips_derivedpredicates/p0?_s*.pddl" 120 | ;; :plan-loc "../domains/ipc4/RESULTS/psr/middle/strips_derivedpredicates/*/" 121 | ;; :max-n *max-tests-per-domain*) 122 | 123 | (format t "~&~%=== PSR-Small/STRIPS ===~%~%") 124 | (do-test-all 125 | nil 126 | "../domains/ipc4/psr/small/strips/p??.pddl" 127 | :plan-loc "../domains/ipc4/RESULTS/psr/small/strips/*/" 128 | :max-n *max-tests-per-domain*) 129 | 130 | ;; Satellite 131 | 132 | (format t "~&~%=== Satellite-STRIPS/STRIPS ===~%~%") 133 | (do-test-all 134 | "domain" 135 | "../domains/ipc4/satellite/strips/strips/p*.pddl" 136 | :plan-loc "../domains/ipc4/RESULTS/satellite/strips/strips/*/" 137 | :max-n *max-tests-per-domain*) 138 | 139 | (format t "~&~%=== Satellite-Numeric/STRIPS-Fluents ===~%~%") 140 | (do-test-all 141 | "domain" 142 | "../domains/ipc4/satellite/numeric/strips_fluents/p*.pddl" 143 | :plan-loc "../domains/ipc4/RESULTS/satellite/numeric/strips_fluents/*/" 144 | :max-n *max-tests-per-domain*) 145 | 146 | ;; Settlers 147 | 148 | (format t "~&~%=== Settlers/STRIPS-Fluents ===~%~%") 149 | (do-test-all 150 | "domain" 151 | "../domains/ipc4/settlers/strips_fluents/p*.pddl" 152 | :plan-loc "../domains/ipc4/RESULTS/settlers/ipc_3/strips_fluents/*/" 153 | :max-n *max-tests-per-domain*) 154 | 155 | ) ; end of handler-bind 156 | 157 | (quit) 158 | -------------------------------------------------------------------------------- /simplify-main.lsp: -------------------------------------------------------------------------------- 1 | ;;#!/usr/local/bin/ecl -shell 2 | 3 | ;; Note: Load is only requried when used interactively or as a script. 4 | ;; (load "inval.lsp") 5 | ;; (load "rsk.lsp") 6 | ;; (load "simplify.lsp") 7 | 8 | ;; GCL version 9 | ;; (defun get-commandline-args () 10 | ;; (cdr si::*command-args*)) 11 | 12 | ;; ECL version 13 | (defun get-commandline-args () 14 | (cdr (ext:command-args))) 15 | 16 | ;; Note: When running as a script with ECL, use: 17 | ;; (defun get-commandline-args () 18 | ;; ext:*unprocessed-ecl-command-args*) 19 | 20 | 21 | (setq *typecheck* nil) 22 | (setq *declare-constants* t) 23 | (setq *simplify* t) 24 | (setq *ground* nil) 25 | (setq *simplify-effect-rhs* nil) 26 | (setq *detype* nil) 27 | (setq *output-types* nil) 28 | (setq *compile-disjunctive-goal* t) 29 | (setq *force-print-problem* nil) 30 | (setq *input-files* nil) 31 | (setq *domain-name-prefix* "domain-") 32 | (setq *problem-name-prefix* "simplified-") 33 | (setq *single-output-file* nil) 34 | 35 | (setq *multi-objective* t) ;; simply pass MO problems through 36 | 37 | (defun print-help () 38 | (format t "~&simplify [options] ~%") 39 | (format t "~& -c : Type-check before simplifying~%") 40 | (format t "~& -n : Do not use :constants declaration in domain.~%") 41 | (format t "~& -d : Leave disjunctive goal formula uncompiled.~%") 42 | (format t "~& -a : Leave all ADL constructs uncompiled.~%") 43 | (format t "~& -t : Convert types to predicates.~%") 44 | (format t "~& -T : Convert types to predicates and force typed output.~%") 45 | (format t "~& -D : Set compiled domain name prefix.~%") 46 | (format t "~& -P : Set compiled problem name prefix.~%") 47 | (quit)) 48 | 49 | (defun simplify-main () 50 | (do ((rem-arg-list (get-commandline-args) (cdr rem-arg-list))) 51 | ((endp rem-arg-list) t) 52 | (let ((arg (car rem-arg-list))) 53 | (cond ((equal arg "-c") 54 | (setq *typecheck* t)) 55 | ((equal arg "-n") 56 | (setq *declare-constants* nil)) 57 | ((equal arg "-d") 58 | (setq *compile-disjunctive-goal* nil)) 59 | ((equal arg "-p") 60 | (setq *force-print-problem* t)) 61 | ((equal arg "-a") 62 | (setq *simplify* nil)) 63 | ((equal arg "-g") 64 | (setq *ground* t)) 65 | ((equal arg "-rhs") 66 | (setq *simplify-effect-rhs* t)) 67 | ((equal arg "-t") 68 | (setq *detype* t)) 69 | ((equal arg "-T") 70 | (setq *detype* t) 71 | (setq *output-types* 'force)) 72 | ((equal arg "-D") 73 | (when (endp (cdr rem-arg-list)) 74 | (format t "~&option -D requires an argument~%") 75 | (quit)) 76 | (setq *domain-name-prefix* (car (cdr rem-arg-list))) 77 | (setq rem-arg-list (cdr rem-arg-list))) 78 | ((equal arg "-P") 79 | (when (endp (cdr rem-arg-list)) 80 | (format t "~&option -P requires an argument~%") 81 | (quit)) 82 | (setq *problem-name-prefix* (car (cdr rem-arg-list))) 83 | (setq rem-arg-list (cdr rem-arg-list))) 84 | ((equal arg "-1") 85 | (setq *single-output-file* t)) 86 | (t (setq *input-files* (append *input-files* (list arg)))) 87 | ))) 88 | (when (endp *input-files*) (print-help)) 89 | ;; read input 90 | (dolist (fname *input-files*) 91 | (format t "~&reading ~a...~%" fname) 92 | (let ((contents (read-file fname))) 93 | (parse-file fname contents))) 94 | ;; type-checking: 95 | (when *typecheck* 96 | (cond ((type-check) 97 | (format t "~&~s/~s type check ok~%" *domain-name* *problem-name*)) 98 | (t (quit)))) 99 | ;; simplify and write output 100 | (multiple-value-bind 101 | (new-domain new-problem) 102 | (if *simplify* 103 | (simplify *domain-name* *problem-name* '(:adl :typing :equality) 104 | *predicates* *functions* *actions* *axioms* *init* *goal* 105 | *metric-type* *metric* *types* *objects* 106 | :declare-constants *declare-constants* 107 | :compile-disjunctive-goal *compile-disjunctive-goal* 108 | :with-types *output-types* 109 | :simplify-effect-rhs *simplify-effect-rhs* 110 | :ground-all-parameters *ground*) 111 | (let ((constants nil)) 112 | (when *declare-constants* 113 | (dolist (act *actions*) 114 | (dolist (cname (constants-in-expression 115 | (cdr (assoc ':precondition (cdr act))))) 116 | (pushnew cname constants)) 117 | (dolist (cname (constants-in-expression 118 | (cdr (assoc ':effect (cdr act))))) 119 | (pushnew cname constants)))) 120 | (values 121 | (make-domain-definition 122 | *domain-name* '(:adl :typing :equality) *types* *objects* 123 | constants *predicates* *functions* *axioms* *actions* 124 | :with-types *output-types*) 125 | (make-problem-definition 126 | *problem-name* *domain-name* 127 | (remove-if #'(lambda (od) (find (car od) constants)) *objects*) 128 | *init* *goal* *metric-type* *metric* 129 | :with-types *output-types*)))) 130 | (when (and (null new-problem) (or *force-print-problem* *detype*)) 131 | (setq new-problem 132 | (make-problem-definition *problem-name* *domain-name* 133 | *objects* *init* *goal* 134 | *metric-type* *metric* 135 | :with-types *output-types*))) 136 | (when *detype* 137 | (clear-definitions) 138 | (parse-definition "new domain" new-domain) 139 | (parse-definition "new problem" new-problem) 140 | (multiple-value-setq (new-domain new-problem) 141 | (detype '(:adl :equality) :with-types *output-types*))) 142 | (let ((new-domain-file 143 | (concatenate 'string "domain-" 144 | (pathname-name (nth (- (length *input-files*) 1) 145 | *input-files*)) ".pddl")) 146 | (new-problem-file 147 | (concatenate 'string "simplified-" 148 | (pathname-name (nth (- (length *input-files*) 1) 149 | *input-files*)) ".pddl"))) 150 | (cond 151 | (*single-output-file* 152 | (format t "~&writing domain and problem to ~a...~%" new-problem-file) 153 | (write-PDDL new-problem-file new-domain new-problem)) 154 | (t 155 | (format t "~&writing domain to ~a...~%" new-domain-file) 156 | (write-PDDL new-domain-file new-domain) 157 | (when new-problem 158 | (format t "~&writing problem to ~a...~%" new-problem-file) 159 | (write-PDDL new-problem-file new-problem))) 160 | )))) 161 | 162 | ;; Call main function inside an error handler. 163 | 164 | (handler-bind 165 | ((condition #'(lambda (erc) 166 | (format *error-output* "~&~A~&" erc) 167 | (quit)))) 168 | (simplify-main)) 169 | (quit) 170 | -------------------------------------------------------------------------------- /tests/README.md: -------------------------------------------------------------------------------- 1 | 2 | # Test cases for plan validation, type checking and RSK. 3 | 4 | 5 | ## Directory `axioms/` 6 | 7 | Examples of problems with derived predicates (axioms). 8 | 9 | `bw-axioms-THN.pddl`: Formulation of Blocksworld with derived predicates 10 | by Thiebaux, Hoffmann and Nebel (from the AIJ 2005 paper). The domain 11 | includes the definition of a recursive axiom ("above") but which is 12 | not used. `bw-axioms-small.pddl` is a small sample instance and 13 | `bw-axioms-small.soln` is a valid plan. 14 | 15 | `disjunction.pddl`: An illustration of how reasoning about the values 16 | of derived predicates may require reasoning about the true/false 17 | disjunction over basic state variables. `disjunction{1,2}.pddl` are 18 | sample problems, one unsolvable and the other solvable. 19 | 20 | `mst.pddl`: Minimum spanning tree problem. Uses several strata of 21 | axioms. `mst{1,2}.pddl` are sample instances. 22 | 23 | `blocker-{adl,strips}.pddl`: The blocking game ("chat noir"). 24 | `blocker-strips-{small,12}.pddl` are sample problems; `bmgen.py` is 25 | an instance generator for a particular class of instances. The ADL 26 | formulation of the domain moves the cat as a (conditional) side-effect 27 | of the blocking aciton. It should work with the same problem files as 28 | the STRIPS formulation. 29 | 30 | `social.pddl`, `iago-{1,2}.pddl`: Domain and two sample instances for 31 | "social planning with a theory of mind". These are based loosely on 32 | the example of Shakespear's play Othello, used in "Simulation-Based 33 | Story Generation with a Theory of Mind" (AIIDE 2008), by Hsueh-Min 34 | Chang and Von-Wun Soo. The PDDL encoding was written entirely by 35 | me. Chang and Soo did not formulate the full model in PDDL, and did 36 | not make their partial model publicly available. 37 | 38 | Some axioms in this domain use repeated variables in the axiom head 39 | as implicit equality constraints. 40 | 41 | ## Directory `fs/` 42 | 43 | Examples from Hector Geffner's Functional Strips paper, encoded in 44 | PDDL3.1, i.e., using object fluents. Also an additional example 45 | (`lists.pddl`), making more complicated use of object fluents. 46 | 47 | These tests are mainly intended for the `rsk` (reverse Skolemisation) 48 | transformation. 49 | 50 | ## Directory `mo/` 51 | 52 | Examples of multi-objective planning. Problem files in this set define 53 | more than one :metric, but are otherwise standard (the metrics defined 54 | are also the same as in standard PDDL). Running inval with option -mo 55 | enables validation of multi-objective problems. 56 | 57 | ## Directory `ppddl/` 58 | 59 | Examples of probabilistic planning (PPDDL) problems, and policies. 60 | 61 | `mk31{a,b}.pddl` are the two examples in Figure 3.1a and 3.1b, 62 | respectively, of Mausam and Kolobov's book ("Planning with Markov 63 | Decision Processes", Morgan & Claypool 2012). The same policy, 64 | `mk31.pol`, works for both examples. 65 | 66 | ## Directory `typing/` 67 | 68 | Example problems to illustrate some areas of confusion over the 69 | semantics of typing in PDDL. 70 | 71 | `domain-{1,2}.pddl`, `problem-1+2.pddl` and `plan-1+2.soln`: Use of 72 | `(either ...)` in type declarations. If `(either ...)` types in 73 | declarations are interpreted as conjunctive, the plan is accepted with 74 | both domain definitions (VAL does this, as does INVAL with default 75 | settings). If they are interpreted as disjunctions 76 | (`*either-in-declarations-means-and*` set to `nil` in INVAL), the plan 77 | is invalid using `domain-1.pddl` 78 | 79 | `domain-3.pddl`, `problem-3.pddl` and `plan-3.soln`: Malte Helmert's 80 | example, illustrating how the disjunctive interpretation of `(either ...)` 81 | types in declarations can be used to encode an incomplete (disjunctive) 82 | initial state. 83 | -------------------------------------------------------------------------------- /tests/axioms/blocker-adl.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain blocker-adl) 3 | (:requirements :adl :derived-predicates) 4 | 5 | (:predicates 6 | ;; primary predicates: 7 | (cat ?x) 8 | (blocked ?x) 9 | ;; static predicates: 10 | (exit ?x) 11 | (edge ?x ?y) 12 | (is-zero ?x) 13 | (next ?x ?y) 14 | ;; predicates not used in ADL formulation: 15 | (blockers-turn) 16 | (cats-turn) 17 | ;; derived predicates: 18 | (prefer ?x ?y ?b) 19 | (cat-next-pos ?x ?b) 20 | (distance-to-exit-2 ?x ?n) 21 | (distance-to-exit-3 ?x ?n ?b) 22 | (closer-or-equal-to-exit ?x ?y ?b) 23 | (closer-to-exit ?x ?y ?b) 24 | (less ?x ?y) 25 | (trapped) 26 | ) 27 | 28 | ;; (distance-to-exit ?x ?n ?b) holds if we can reach an exit node 29 | ;; from ?x in ?n steps or less, given the current set of blocked 30 | ;; nodes including ?b. 31 | (:derived (distance-to-exit-3 ?x ?z ?b) 32 | (and (exit ?x) (is-zero ?z))) 33 | 34 | (:derived (distance-to-exit-3 ?x ?k ?b) 35 | (exists (?y ?j) 36 | (and (edge ?x ?y) 37 | (next ?j ?k) 38 | (not (blocked ?y)) 39 | (not (= ?y ?b)) 40 | (distance-to-exit-3 ?y ?j ?b)))) 41 | 42 | (:derived (distance-to-exit-3 ?x ?k ?b) 43 | (exists (?j) 44 | (and (next ?j ?k) 45 | (distance-to-exit-3 ?x ?j ?b)))) 46 | 47 | (:derived (distance-to-exit-2 ?x ?z) 48 | (and (exit ?x) (is-zero ?z))) 49 | 50 | (:derived (distance-to-exit-2 ?x ?k) 51 | (exists (?y ?j) 52 | (and (edge ?x ?y) 53 | (next ?j ?k) 54 | (not (blocked ?y)) 55 | (distance-to-exit-2 ?y ?j)))) 56 | 57 | (:derived (distance-to-exit-2 ?x ?k) 58 | (exists (?j) 59 | (and (next ?j ?k) 60 | (distance-to-exit-2 ?x ?j)))) 61 | 62 | ;; (closer-to-exit ?x ?y ?b) holds if the shortest distance to an 63 | ;; exit from ?x is stricly smaller than the shortest distance to an 64 | ;; exit from ?y. 65 | (:derived (closer-to-exit ?x ?y ?b) 66 | (exists (?k) 67 | (and (distance-to-exit-3 ?x ?k ?b) 68 | (not (distance-to-exit-3 ?y ?k ?b))))) 69 | 70 | ;; (closer-or-equal-to-exit ?x ?y ?b) holds if the shortest distance 71 | ;; to an exit from ?x is less than or equal to the shortest distance 72 | ;; to an exit from ?y. 73 | (:derived (closer-or-equal-to-exit ?x ?y ?b) 74 | (not (closer-to-exit ?y ?x ?b))) 75 | 76 | ;; (less ?x ?y) iff ?x is strictly less than ?y. 77 | (:derived (less ?x ?y) 78 | (or (next ?x ?y) 79 | (exists (?z) (and (next ?x ?z) (less ?z ?y))))) 80 | 81 | ;; (trapped) is true iff the cat is trapped; that is, distance-to-exit 82 | ;; is false for every value from the cat's current position. 83 | (:derived (trapped) 84 | (exists (?x) 85 | (and (cat ?x) 86 | (forall (?n) (not (distance-to-exit-2 ?x ?n)))))) 87 | 88 | ;; (prefer ?x ?y) iff cat prefers moving to ?x over ?y (only 89 | ;; relevant if ?x and ?y are both neighbours of the cat's current 90 | ;; position, but this is not tested for here). This is true if ?y 91 | ;; is blocked; ?x is strictly closer to an exit than ?y; or ?x and 92 | ;; ?y are at the same distance to exit but ?x is less than ?y (i.e., 93 | ;; numeric order of the nodes is used as the final tie-breaker). 94 | (:derived (prefer ?x ?y ?b) 95 | (or (blocked ?y) 96 | (= ?y ?b) 97 | (closer-to-exit ?x ?y ?b) 98 | (and (closer-or-equal-to-exit ?x ?y ?b) 99 | (less ?x ?y)))) 100 | 101 | ;; (cat-next-pos ?x ?b) iff ?x is the node that the cat will move to 102 | ;; assuming ?b is the node blocked this move. If the cat is already 103 | ;; trapped, this predicate is false for all destinations. 104 | (:derived (cat-next-pos ?x ?b) 105 | (exists (?y) 106 | (and (cat ?y) 107 | (edge ?y ?x) 108 | (not (blocked ?x)) 109 | (not (= ?x ?b)) 110 | (not (trapped)) 111 | (forall (?alt) 112 | (or (= ?x ?alt) 113 | (not (edge ?y ?alt)) 114 | (prefer ?x ?alt ?b)))))) 115 | 116 | (:action block 117 | :parameters (?b) 118 | :precondition (not (cat ?b)) 119 | :effect (and (blocked ?b) 120 | (forall (?x) 121 | (and (when (not (cat-next-pos ?x ?b)) (not (cat ?x))) 122 | (when (cat-next-pos ?x ?b) (cat ?x))))) 123 | ) 124 | 125 | ) 126 | -------------------------------------------------------------------------------- /tests/axioms/blocker-strips-12.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (problem twelve) 3 | (:domain blocker-strips) 4 | 5 | (:objects n0 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11) 6 | 7 | (:init (exit n6) 8 | (exit n7) 9 | (exit n8) 10 | (exit n9) 11 | (exit n11) 12 | (edge n0 n1) 13 | (edge n0 n2) 14 | (edge n0 n10) 15 | (edge n1 n0) 16 | (edge n1 n3) 17 | (edge n1 n4) 18 | (edge n1 n5) 19 | (edge n2 n0) 20 | (edge n2 n3) 21 | (edge n2 n4) 22 | (edge n2 n5) 23 | (edge n3 n1) 24 | (edge n3 n2) 25 | (edge n3 n6) 26 | (edge n3 n7) 27 | (edge n3 n8) 28 | (edge n3 n9) 29 | (edge n4 n1) 30 | (edge n4 n2) 31 | (edge n4 n6) 32 | (edge n4 n7) 33 | (edge n4 n8) 34 | (edge n4 n9) 35 | (edge n5 n1) 36 | (edge n5 n2) 37 | (edge n5 n6) 38 | (edge n5 n7) 39 | (edge n5 n8) 40 | (edge n5 n9) 41 | (edge n6 n3) 42 | (edge n6 n4) 43 | (edge n6 n5) 44 | (edge n7 n3) 45 | (edge n7 n4) 46 | (edge n7 n5) 47 | (edge n8 n3) 48 | (edge n8 n4) 49 | (edge n8 n5) 50 | (edge n9 n3) 51 | (edge n9 n4) 52 | (edge n9 n5) 53 | (edge n10 n0) 54 | (edge n10 n11) 55 | (edge n11 n10) 56 | (is-zero n0) 57 | (next n0 n1) 58 | (next n1 n2) 59 | (next n2 n3) 60 | (next n3 n4) 61 | (next n4 n5) 62 | (next n5 n6) 63 | (next n6 n7) 64 | (next n7 n8) 65 | (next n8 n9) 66 | (next n9 n10) 67 | (next n10 n11) 68 | (cat n0) 69 | (blockers-turn) 70 | ) 71 | 72 | (:goal (trapped)) 73 | 74 | ) 75 | -------------------------------------------------------------------------------- /tests/axioms/blocker-strips-12.soln: -------------------------------------------------------------------------------- 1 | (block n1) 2 | (move n0 n10) 3 | (block n11) 4 | (move n10 n0) 5 | (block n2) 6 | -------------------------------------------------------------------------------- /tests/axioms/blocker-strips-small.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; (0) 3 | ;; / | 4 | ;; [1]-(2) 5 | ;; | 6 | ;; [3] 7 | 8 | (define (problem four) 9 | (:domain blocker-strips) 10 | 11 | (:objects n0 n1 n2 n3) 12 | 13 | (:init (exit n1) 14 | (exit n3) 15 | (edge n0 n1) 16 | (edge n0 n2) 17 | (edge n1 n0) 18 | (edge n1 n2) 19 | (edge n2 n0) 20 | (edge n2 n1) 21 | (edge n2 n3) 22 | (edge n3 n2) 23 | (is-zero n0) 24 | (next n0 n1) 25 | (next n1 n2) 26 | (next n2 n3) 27 | (cat n0) 28 | (blockers-turn) 29 | ) 30 | 31 | (:goal (trapped)) 32 | 33 | ) 34 | -------------------------------------------------------------------------------- /tests/axioms/blocker-strips-small.soln: -------------------------------------------------------------------------------- 1 | (block n1) 2 | (move n0 n2) 3 | (block n3) 4 | -------------------------------------------------------------------------------- /tests/axioms/blocker-strips.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain blocker-strips) 3 | (:requirements :strips :derived-predicates) 4 | 5 | ;; The set of objects are the numbers from 0 to N-1, where N is the 6 | ;; number of nodes in the graph. These are used both to represent the 7 | ;; nodes in the graph and distances (because distances in the graph 8 | ;; will never be greater than the number of nodes minus one). 9 | 10 | (:predicates 11 | ;; primary predicates: 12 | (cat ?x) 13 | (blocked ?x) 14 | (blockers-turn) 15 | (cats-turn) 16 | ;; static predicates: 17 | (exit ?x) 18 | (edge ?x ?y) 19 | (is-zero ?x) 20 | (next ?x ?y) 21 | ;; derived predicates: 22 | (prefer ?x ?y) 23 | (cat-moves ?from ?to) 24 | (distance-to-exit ?x ?n) 25 | (closer-or-equal-to-exit ?x ?y) 26 | (closer-to-exit ?x ?y) 27 | (less ?x ?y) 28 | (trapped) 29 | ) 30 | 31 | ;; (distance-to-exit ?x ?n) holds if we can reach an exit node from 32 | ;; ?x in ?n steps or less, given the current set of blocked nodes. 33 | (:derived (distance-to-exit ?x ?z) 34 | (and (exit ?x) (is-zero ?z))) 35 | 36 | (:derived (distance-to-exit ?x ?k) 37 | (exists (?y ?j) 38 | (and (edge ?x ?y) 39 | (next ?j ?k) 40 | (not (blocked ?y)) 41 | (distance-to-exit ?y ?j)))) 42 | 43 | (:derived (distance-to-exit ?x ?k) 44 | (exists (?j) 45 | (and (next ?j ?k) 46 | (distance-to-exit ?x ?j)))) 47 | 48 | 49 | ;; (closer-to-exit ?x ?y) holds if the shortest distance to an exit 50 | ;; from ?x is stricly smaller than the shortest distance to an exit 51 | ;; from ?y. 52 | (:derived (closer-to-exit ?x ?y) 53 | (exists (?k) 54 | (and (distance-to-exit ?x ?k) 55 | (not (distance-to-exit ?y ?k))))) 56 | 57 | ;; (closer-or-equal-to-exit ?x ?y) holds if the shortest distance to 58 | ;; an exit from ?x is less than or equal to the shortest distance to 59 | ;; an exit from ?y. 60 | (:derived (closer-or-equal-to-exit ?x ?y) 61 | (not (closer-to-exit ?y ?x))) 62 | 63 | ;; (less ?x ?y) iff ?x is strictly less than ?y. 64 | (:derived (less ?x ?y) 65 | (or (next ?x ?y) 66 | (exists (?z) (and (next ?x ?z) (less ?z ?y))))) 67 | 68 | ;; (trapped) is true iff the cat is trapped; that is, distance-to-exit 69 | ;; is false for every value from the cat's current position. 70 | (:derived (trapped) 71 | (exists (?x) 72 | (and (cat ?x) 73 | (forall (?n) (not (distance-to-exit ?x ?n)))))) 74 | 75 | ;; (prefer ?x ?y) iff cat prefers moving to ?x over ?y (only 76 | ;; relevant if ?x and ?y are both neighbours of the cat's current 77 | ;; position, but this is not tested for here). This is true if ?y 78 | ;; is blocked; ?x is strictly closer to an exit than ?y; or ?x and 79 | ;; ?y are at the same distance to exit but ?x is less than ?y (i.e., 80 | ;; numeric order of the nodes is used as the final tie-breaker). 81 | (:derived (prefer ?x ?y) 82 | (or (blocked ?y) 83 | (closer-to-exit ?x ?y) 84 | (and (closer-or-equal-to-exit ?x ?y) 85 | (less ?x ?y)))) 86 | 87 | ;; (cat-moves ?from ?to) iff ?to is the node that the cat will move to 88 | ;; from ?from. This is the node that is closest to an exit, or least 89 | ;; among the nodes the minimum distance to exit. If the cat is already 90 | ;; trapped, this predicate is false for all destinations. 91 | (:derived (cat-moves ?from ?to) 92 | (and (edge ?from ?to) 93 | (not (blocked ?to)) 94 | (not (trapped)) 95 | (forall (?alt) 96 | (or (= ?to ?alt) 97 | (not (edge ?from ?alt)) 98 | (prefer ?to ?alt))))) 99 | 100 | 101 | ;; In the strips formulation, the blocker's and cat's actions alternate. 102 | 103 | ;; Blocker's action: 104 | (:action block 105 | :parameters (?b) 106 | :precondition (and (blockers-turn) 107 | (not (cat ?b))) 108 | :effect (and (blocked ?b) 109 | (not (blockers-turn)) 110 | (cats-turn)) 111 | ) 112 | 113 | ;; Cat's action: 114 | (:action move 115 | :parameters (?from ?to) 116 | :precondition (and (cats-turn) 117 | (cat ?from) 118 | (not (exit ?from)) 119 | (cat-moves ?from ?to)) 120 | :effect (and (not (cat ?from)) 121 | (cat ?to) 122 | (not (cats-turn)) 123 | (blockers-turn)) 124 | ) 125 | 126 | ) 127 | -------------------------------------------------------------------------------- /tests/axioms/bmgen.py: -------------------------------------------------------------------------------- 1 | 2 | ## Generator of "binary maze" instances for the blocker-strips domain. 3 | ## Note: Instance size is approx O(2^depth). 4 | 5 | import sys 6 | import random 7 | 8 | if len(sys.argv) < 2: 9 | print(sys.argv[0] + ": ") 10 | sys.exit(0) 11 | 12 | depth = int(sys.argv[1]) 13 | assert depth > 1 14 | 15 | levels = [ list(range(2**d)) for d in range(0, depth) ] 16 | levels.append(levels[depth - 1][:]) 17 | 18 | n = 0 19 | for i in list(range(depth + 1))[::-1]: 20 | for j in range(len(levels[i])): 21 | levels[i][j] = n 22 | n += 1 23 | random.shuffle(levels[i]) 24 | 25 | #print(levels) 26 | #print(n) 27 | 28 | print("(define (problem binary-maze-" + str(depth) + ")") 29 | print(" (:domain blocker-strips)") 30 | print(" (:objects", end="") 31 | for k in range(n): 32 | print(" n" + str(k), end="") 33 | print(")") # end :objects 34 | print(" (:init") 35 | print(" (is-zero n0)") 36 | for k in range(n - 1): 37 | print(" (next n" + str(k) + " n" + str(k + 1) + ")") 38 | for k in levels[depth]: 39 | print(" (exit n" + str(k) + ")") 40 | # edges 41 | for i in range(len(levels[depth])): 42 | print(" (edge n" + str(levels[depth][i]) + 43 | " n" + str(levels[depth - 1][i]) + ")") 44 | print(" (edge n" + str(levels[depth - 1][i]) + 45 | " n" + str(levels[depth][i]) + ")") 46 | if i > 0: 47 | print(" (edge n" + str(levels[depth][i - 1]) + 48 | " n" + str(levels[depth - 1][i]) + ")") 49 | print(" (edge n" + str(levels[depth - 1][i]) + 50 | " n" + str(levels[depth][i - 1]) + ")") 51 | 52 | for j in range(depth - 1): 53 | for i in range(len(levels[j])): 54 | # levels[j][i] -> levels[j+1][2*i] 55 | print(" (edge n" + str(levels[j][i]) + 56 | " n" + str(levels[j + 1][2*i]) + ")") 57 | print(" (edge n" + str(levels[j + 1][2*i]) + 58 | " n" + str(levels[j][i]) + ")") 59 | # levels[j][i] -> levels[j+1][(2*i)+1] 60 | print(" (edge n" + str(levels[j][i]) + 61 | " n" + str(levels[j + 1][(2*i) + 1]) + ")") 62 | print(" (edge n" + str(levels[j + 1][(2*i) + 1]) + 63 | " n" + str(levels[j][i]) + ")") 64 | 65 | print(" (cat n" + str(n - 1) + ")") 66 | print(" (blockers-turn)") 67 | 68 | print(" )") # end :init 69 | 70 | print(" (:goal (trapped))") 71 | print(" )") 72 | -------------------------------------------------------------------------------- /tests/axioms/bw-axioms-THN.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; Blocksworld with axioms (from Thiebaux, Hoffmann & Nebel AIJ'05). 3 | ;; Typing has been added (though it's somewhat pointless, since there's 4 | ;; only one type), and some names changed, to enable using problems and 5 | ;; plans from the IPC2 set with this domain. 6 | 7 | (define (domain blocksworld-with-axioms) 8 | 9 | (:requirements :strips :typing) 10 | 11 | (:types block) 12 | 13 | (:predicates 14 | ;; basic predicates 15 | (ontable ?x - block) 16 | (on ?x - block ?y - block) 17 | ;; derived predicates 18 | (holding ?x - block) 19 | (above ?x - block ?y - block) 20 | (clear ?x - block) 21 | (handempty)) 22 | 23 | (:derived (holding ?x - block) 24 | (and (not (ontable ?x)) 25 | (not (exists (?y - block) 26 | (on ?x ?y))))) 27 | 28 | (:derived (above ?x - block ?y - block) 29 | (or (on ?x ?y) 30 | (exists (?z - block) 31 | (and (on ?x ?z) (above ?z ?y))))) 32 | 33 | (:derived (clear ?x - block) 34 | (and (not (holding ?x)) 35 | (not (exists (?y - block) (on ?y ?x))))) 36 | 37 | (:derived (handempty) 38 | (forall (?x - block) 39 | (not (holding ?x)))) 40 | 41 | (:action pick-up 42 | :parameters (?ob - block) 43 | :precondition (and (clear ?ob) (ontable ?ob) (handempty)) 44 | :effect (not (ontable ?ob)) 45 | ) 46 | 47 | (:action put-down 48 | :parameters (?ob - block) 49 | :precondition (holding ?ob) 50 | :effect (ontable ?ob) 51 | ) 52 | 53 | (:action stack 54 | :parameters (?ob - block ?underob - block) 55 | :precondition (and (clear ?underob) (holding ?ob)) 56 | :effect (on ?ob ?underob) 57 | ) 58 | 59 | (:action unstack 60 | :parameters (?ob - block ?underob - block) 61 | :precondition (and (on ?ob ?underob) (clear ?ob) (handempty)) 62 | :effect (not (on ?ob ?underob)) 63 | ) 64 | 65 | ) 66 | -------------------------------------------------------------------------------- /tests/axioms/bw-axioms-small.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (problem size-five) 3 | (:domain blocksworld-with-axioms) 4 | (:objects A B C D E - block) 5 | (:init (ontable A) (on B A) (on C B) (ontable D) (on E D)) 6 | (:goal (and (on A D) (on C B))) 7 | ) 8 | -------------------------------------------------------------------------------- /tests/axioms/bw-axioms-small.soln: -------------------------------------------------------------------------------- 1 | (unstack E D) 2 | (put-down E) 3 | (unstack C B) 4 | (put-down C) 5 | (unstack B A) 6 | (put-down B) 7 | (pick-up C) 8 | (stack C B) 9 | (pick-up A) 10 | (stack A D) 11 | -------------------------------------------------------------------------------- /tests/axioms/disjunction.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; This is an (artificial) example domain to illustrate how disjunctions 3 | ;; can arise among derived predicates by using negations of non-derived 4 | ;; (primary) predicates. 5 | 6 | (define (domain disjunction-via-axioms) 7 | (:requirements :strips :derived-predicates :negative-preconditions) 8 | 9 | (:predicates 10 | ;; predicates are named "primary", "secondary" and "static" just to 11 | ;; show the role they play in the domain. 12 | (primary-p ?x) 13 | (secondary-q ?x) 14 | (static-a ?x ?y) 15 | (static-b ?x ?y) 16 | (static-e ?x ?y) 17 | (static-c ?x) 18 | ) 19 | 20 | ;; (secondary-q ?x) propagates along "edges" defined by static-e 21 | (:derived (secondary-q ?x) 22 | (exists (?y) (and (static-e ?x ?y) (secondary-q ?y)))) 23 | 24 | ;; (primary-p ?y) implies (secondary-q ?x) iff (static-a ?x ?y) 25 | (:derived (secondary-q ?x) 26 | (exists (?y) (and (static-a ?x ?y) (primary-p ?y)))) 27 | 28 | ;; (not (primary-p ?y)) implies (secondary-q ?x) iff (static-b ?x ?y) 29 | (:derived (secondary-q ?x) 30 | (exists (?y) (and (static-b ?x ?y) (not (primary-p ?y))))) 31 | 32 | (:action set-p 33 | :parameters (?x) 34 | :precondition (static-c ?x) 35 | :effect (primary-p ?x) 36 | ) 37 | 38 | ;; (:action dummy-op 39 | ;; :parameters (?x ?y) 40 | ;; :precondition (and (static-c ?x) (secondary-q ?y)) 41 | ;; :effect (primary-p ?x) 42 | ;; ) 43 | 44 | ) ;; end domain def 45 | -------------------------------------------------------------------------------- /tests/axioms/disjunction1-plan.soln: -------------------------------------------------------------------------------- 1 | 2 | ;; This is not a "plan", since the problem has no solution. It's just 3 | ;; an action sequence (with one action) to test validators with. 4 | 5 | (set-p bottom) 6 | -------------------------------------------------------------------------------- /tests/axioms/disjunction1.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; An unsolvable problem for the "disjunction-via-axioms" domain. 3 | 4 | (define (problem unsolvable) 5 | (:domain disjunction-via-axioms) 6 | 7 | ;; Four elements connected in a "diamond" shape: "top" has 8 | ;; (bi-directional) edges (static-e) to left and right; left has 9 | ;; static-a to bottom, and right has static-b to bottom; bottom is 10 | ;; "controllable" (static-c). 11 | (:objects top bottom left right) 12 | 13 | (:init 14 | (static-e top left) 15 | (static-e top right) 16 | (static-e left top) 17 | (static-e right top) 18 | 19 | (static-a left bottom) 20 | (static-b right bottom) 21 | (static-c bottom) 22 | ) 23 | 24 | ;; The goal is unreachable: Whatever the value of (primary-p bottom), 25 | ;; at least one of (secondary-q left) and (secondary-q right) will 26 | ;; be true, and this will make (secondary-q top) true. 27 | (:goal (not (secondary-q top))) 28 | ) 29 | -------------------------------------------------------------------------------- /tests/axioms/disjunction2.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; A solvable variant of the "disjunction-via-axioms" problem. 3 | 4 | (define (problem unsolvable) 5 | (:domain disjunction-via-axioms) 6 | 7 | ;; Four elements connected in a "diamond" shape: "top" has 8 | ;; (bi-directional) edges (static-e) to left and right; left and 9 | ;; right both have static-b to bottom; bottom is "controllable" 10 | ;; (static-c). 11 | (:objects top bottom left right) 12 | 13 | (:init 14 | (static-e top left) 15 | (static-e top right) 16 | (static-e left top) 17 | (static-e right top) 18 | 19 | (static-b left bottom) 20 | (static-b right bottom) 21 | (static-c bottom) 22 | ) 23 | 24 | ;; The goal should be reachable by a single action, (set-p bottom). 25 | (:goal (not (secondary-q top))) 26 | ) 27 | -------------------------------------------------------------------------------- /tests/axioms/iago-1.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; An instance of the social planning domain, based on Iago's problem: 3 | ;; How to make Othello kill Desdemona? 4 | 5 | (define (problem Iago-1) 6 | (:domain social-planning) 7 | 8 | (:objects 9 | Iago Othello Emilia Desdemona Cassio - character 10 | handkerchief - item 11 | garden bedroom residence palace - place 12 | ) 13 | 14 | (:init 15 | (man Iago) 16 | (man Othello) 17 | (woman Emilia) 18 | (woman Desdemona) 19 | (man Cassio) 20 | (married Iago Emilia) 21 | (married Emilia Iago) 22 | (married Othello Desdemona) 23 | (married Desdemona Othello) 24 | (friend-of Cassio Iago) 25 | (friend-of Othello Iago) 26 | (friend-of Desdemona Emilia) 27 | (precious handkerchief) 28 | (loves Emilia Iago) 29 | (loves Othello Desdemona) 30 | (loves Desdemona Othello) 31 | (is-curious Othello) 32 | (is-jealous Othello) 33 | (is-suspicious Othello) 34 | (is-wrathful Othello) 35 | (is-curious Cassio) 36 | (is-greedy Cassio) 37 | (is-lustful Cassio) 38 | (is-wrathful Cassio) 39 | (is-obedient Emilia) 40 | (is-vain Emilia) 41 | (is-curious Desdemona) 42 | (is-obedient Desdemona) 43 | (is-evil Iago) ;; MUHAHAHAHA!! 44 | (main-character Iago) 45 | (alive Iago) 46 | (alive Othello) 47 | (alive Emilia) 48 | (alive Desdemona) 49 | (alive Cassio) 50 | (at Iago garden) 51 | (at Othello palace) 52 | (at Desdemona bedroom) 53 | (at Emilia garden) 54 | (at Cassio residence) 55 | (at handkerchief bedroom) 56 | (gift Othello Desdemona handkerchief) 57 | ) 58 | 59 | (:goal (killed Othello Desdemona)) 60 | 61 | ) 62 | -------------------------------------------------------------------------------- /tests/axioms/iago-1.soln: -------------------------------------------------------------------------------- 1 | ;; an invalid plan (follows, more or less, the script of the play) 2 | 3 | (request-has Iago Iago handkerchief) 4 | (goto Emilia bedroom garden) 5 | (take Emilia handkerchief bedroom) 6 | (goto Emilia garden bedroom) 7 | (give Emilia Iago handkerchief garden) 8 | (goto Iago residence garden) 9 | (drop Iago handkerchief residence) 10 | (goto Iago palace residence) 11 | (take Cassio handkerchief residence) 12 | (request-at Iago Othello residence) 13 | (goto Othello residence palace) 14 | (adopt-belief-loves Othello Desdemona Cassio) 15 | (goto Othello bedroom residence) 16 | (kill Othello Desdemona bedroom) 17 | -------------------------------------------------------------------------------- /tests/axioms/iago-2.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; An instance of the social planning domain, based on Iago's problem: 3 | ;; How to make Othello kill Desdemona and then die? 4 | 5 | (define (problem Iago-2) 6 | (:domain social-planning) 7 | 8 | (:objects 9 | Iago Othello Emilia Desdemona Cassio - character 10 | handkerchief - item 11 | garden bedroom residence palace - place 12 | ) 13 | 14 | (:init 15 | (man Iago) 16 | (man Othello) 17 | (woman Emilia) 18 | (woman Desdemona) 19 | (man Cassio) 20 | (married Iago Emilia) 21 | (married Emilia Iago) 22 | (married Othello Desdemona) 23 | (married Desdemona Othello) 24 | (friend-of Cassio Iago) 25 | (friend-of Othello Iago) 26 | (friend-of Desdemona Emilia) 27 | (precious handkerchief) 28 | (loves Emilia Iago) 29 | (loves Othello Desdemona) 30 | (loves Desdemona Othello) 31 | (is-curious Othello) 32 | (is-jealous Othello) 33 | (is-suspicious Othello) 34 | (is-wrathful Othello) 35 | (is-curious Cassio) 36 | (is-greedy Cassio) 37 | (is-lustful Cassio) 38 | (is-wrathful Cassio) 39 | (is-obedient Emilia) 40 | (is-vain Emilia) 41 | (is-curious Desdemona) 42 | (is-obedient Desdemona) 43 | (is-evil Iago) ;; MUHAHAHAHA!! 44 | (main-character Iago) 45 | (alive Iago) 46 | (alive Othello) 47 | (alive Emilia) 48 | (alive Desdemona) 49 | (alive Cassio) 50 | (at Iago garden) 51 | (at Othello palace) 52 | (at Desdemona bedroom) 53 | (at Emilia garden) 54 | (at Cassio residence) 55 | (at handkerchief bedroom) 56 | (gift Othello Desdemona handkerchief) 57 | ) 58 | 59 | (:goal (and (killed Othello Desdemona) 60 | (dead Othello))) 61 | 62 | ) 63 | -------------------------------------------------------------------------------- /tests/axioms/mst.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; Problem of making a spanning tree out of an initial graph, by 3 | ;; adding edges (to connect disconnected components) and removing 4 | ;; edges (to reduce it to a tree). 5 | 6 | (define (domain make-spanning-tree) 7 | (:requirements :adl :derived-predicates) 8 | 9 | (:predicates 10 | ;; The edge predicate is directed (?x to ?y) but we will treat 11 | ;; it as undirected; all actions that add/remove an edge add/del 12 | ;; both atoms. 13 | (edge ?x ?y) 14 | ;; Transitive and reflexive closure of edge: 15 | (path ?x ?y) 16 | ;; negation of path: 17 | (no-path ?x ?y) 18 | ;; Path from ?x to ?y not passing through node ?w: 19 | (path-not-through ?x ?y ?w) 20 | ;; Path from ?x to ?y not through an edge from ?x to ?y: 21 | (indirect-path ?x ?y) 22 | (marked ?x) 23 | (marked-aux ?x ?y ?z) 24 | (is-a-forest) 25 | (is-connected) 26 | ) 27 | 28 | (:derived (path ?x ?y) (= ?x ?y)) 29 | (:derived (path ?x ?y) (exists (?z) (and (edge ?x ?z) (path ?z ?y)))) 30 | 31 | (:derived (no-path ?x ?y) (not (path ?x ?y))) 32 | 33 | (:derived (path-not-through ?x ?y ?w) 34 | (and (= ?x ?y) (not (= ?x ?w)))) 35 | (:derived (path-not-through ?x ?y ?w) 36 | (and (not (= ?x ?w)) 37 | (exists (?z) 38 | (and (edge ?x ?z) (path-not-through ?z ?y ?w))))) 39 | 40 | ;; A different way to check if we have a forest: A node is "marked" 41 | ;; if it has at most one unmarked neighbour. This means leafs in the 42 | ;; tree get marked first, then their parents, and so on. If, after 43 | ;; this is done, all nodes have been marked, then there are no 44 | ;; cycles. 45 | (:derived (marked ?x) 46 | (forall (?y ?z) (marked-aux ?x ?y ?z))) 47 | 48 | (:derived (marked-aux ?x ?y ?z) 49 | (or (= ?y ?z) 50 | (not (edge ?x ?y)) 51 | (not (edge ?x ?z)) 52 | (marked ?y) 53 | (marked ?z))) 54 | 55 | (:derived (is-a-forest) (forall (?x) (marked ?x))) 56 | 57 | (:derived (is-connected) (forall (?x ?y) (path ?x ?y))) 58 | 59 | ;; we have a forest iff 60 | ;; (:derived (is-a-forest) 61 | ;; ;; for every pair of nodes: 62 | ;; (forall (?x ?y) 63 | ;; ;; if they are distinct and not neighbours: 64 | ;; (or (= ?x ?y) 65 | ;; (edge ?x ?y) 66 | ;; (forall (?z) 67 | ;; ;; then for every neighbour ?z of ?x: 68 | ;; (or (not (edge ?x ?z)) 69 | ;; ;; there is no path from ?x to ?y 70 | ;; ;; not passing through ?z, or no 71 | ;; ;; path from ?z to ?y not passing 72 | ;; ;; through ?x: 73 | ;; (not (path-not-through ?x ?y ?z)) 74 | ;; (not (path-not-through ?z ?y ?x)) 75 | ;; ))))) 76 | 77 | ;; an indirect path exists iff... 78 | (:derived (indirect-path ?x ?y) 79 | ;; there is a node ?x 80 | (exists (?z) 81 | ;; neighbour of ?x 82 | (and (edge ?x ?z) 83 | ;; not equal to ?y 84 | (not (= ?z ?y)) 85 | ;; such that there is a path from ?z to ?y that 86 | ;; does not pass through ?x. 87 | (path-not-through ?z ?y ?x)))) 88 | 89 | 90 | (:action add 91 | :parameters (?x ?y) 92 | :precondition (no-path ?x ?y) 93 | :effect (and (edge ?x ?y) (edge ?y ?x)) 94 | ) 95 | 96 | (:action remove 97 | :parameters (?x ?y) 98 | :precondition (indirect-path ?x ?y) 99 | :effect (and (not (edge ?x ?y)) (not (edge ?y ?x))) 100 | ) 101 | 102 | ) 103 | -------------------------------------------------------------------------------- /tests/axioms/mst1.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; Example problem 1: Start out with a dense, connected graph 3 | ;; (which happens to be the mainland australian states and their 4 | ;; borders-on relation) and shrink it to a spanning tree by 5 | ;; removing edges. 6 | 7 | (define (problem shrink-to-mst) 8 | (:domain make-spanning-tree) 9 | 10 | (:objects qld nsw vic sa nt wa) 11 | 12 | (:init 13 | (edge qld nsw) 14 | (edge qld nt) 15 | (edge qld sa) 16 | (edge nsw qld) 17 | (edge nsw sa) 18 | (edge nsw vic) 19 | (edge vic nsw) 20 | (edge vic sa) 21 | (edge nt qld) 22 | (edge nt sa) 23 | (edge nt wa) 24 | (edge sa qld) 25 | (edge sa nsw) 26 | (edge sa vic) 27 | (edge sa nt) 28 | (edge sa wa) 29 | (edge wa nt) 30 | (edge wa sa) 31 | ) 32 | 33 | (:goal (is-a-forest)) 34 | 35 | ) 36 | -------------------------------------------------------------------------------- /tests/axioms/mst1.soln: -------------------------------------------------------------------------------- 1 | 2 | (remove qld nt) 3 | (remove qld sa) 4 | (remove vic sa) 5 | (remove wa nt) 6 | -------------------------------------------------------------------------------- /tests/axioms/mst2.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; Example problem 2: Start out with a graph that has several 3 | ;; disconnected components, some of which are not trees. The 4 | ;; plan must contain both add and remove actions. 5 | 6 | (define (problem grow-and-shrink-to-mst) 7 | (:domain make-spanning-tree) 8 | 9 | (:objects qld nsw vic sa nt wa) 10 | 11 | (:init 12 | (edge qld nsw) 13 | (edge qld sa) 14 | (edge nsw qld) 15 | (edge nsw sa) 16 | (edge nsw vic) 17 | (edge vic nsw) 18 | (edge vic sa) 19 | (edge nt wa) 20 | (edge sa qld) 21 | (edge sa nsw) 22 | (edge sa vic) 23 | (edge wa nt) 24 | ) 25 | 26 | (:goal (and (is-connected) 27 | (is-a-forest))) 28 | 29 | ) 30 | -------------------------------------------------------------------------------- /tests/axioms/mst2.soln: -------------------------------------------------------------------------------- 1 | 2 | (remove qld sa) 3 | (add qld nt) 4 | (remove vic sa) 5 | -------------------------------------------------------------------------------- /tests/axioms/social.pddl: -------------------------------------------------------------------------------- 1 | 2 | ;; Social planning with a theory of mind. 3 | ;; 4 | ;; Based loosely on "Planning-Based Narrative Generation in Simulated 5 | ;; Game Universes" (IEEE Trans. on Computational Intelligence and AI 6 | ;; in Games, 2009) and "Simulation-Based Story Generation with a Theory 7 | ;; of Mind" (AIIDE 2008), both by Hsueh-Min Chang and Von-Wun Soo. 8 | ;; 9 | ;; This PDDL encoding was written entirely by Patrik Haslum. Chang and 10 | ;; Soo did not formulate the full model in PDDL, and did not make their 11 | ;; partial model publicly available. 12 | 13 | (define (domain social-planning) 14 | (:requirements :adl :typing :derived-predicates) 15 | 16 | (:types locatable place - object 17 | character item - locatable) 18 | 19 | (:predicates 20 | ;; static properties/relations: 21 | (man ?c - character) 22 | (woman ?c - character) 23 | (married ?a - character ?b - character) 24 | (friend-of ?a - character ?b - character) 25 | (precious ?i - item) 26 | (main-character ?c - character) 27 | ;; character traits (also static): 28 | (is-greedy ?c - character) 29 | (is-curious ?c - character) 30 | (is-pursuing ?c - character) 31 | (is-obedient ?c - character) 32 | (is-suspicious ?c - character) 33 | (is-jealous ?c - character) 34 | (is-vain ?c - character) 35 | (is-lustful ?c - character) 36 | (is-wrathful ?c - character) 37 | (is-evil ?c - character) 38 | 39 | ;; state of the world: 40 | (alive ?c - character) 41 | (dead ?c - character) 42 | (at ?l - locatable ?p - place) 43 | (has ?c - character ?i - item) 44 | ;; state of mind: 45 | (loves ?c - character ?d - character) 46 | (believes-loves ?a - character ?c - character ?d - character) 47 | ;; records of passed actions: 48 | (requested-at ?a - character ?c - character ?p - place) 49 | (requested-has ?a - character ?c - character ?i - item) 50 | (gift ?from - character ?to - character ?i - item) 51 | (killed ?a - character ?c - character) 52 | 53 | ;; derived predicates: 54 | (can-see ?c - character ?l - locatable) 55 | (alone-at ?c - character ?p - place) 56 | (motive-for-has ?a - character ?c - character ?i - item) 57 | (motive-for-at ?a - character ?l - locatable ?p - place) 58 | (motive-for-dead ?a - character ?c - character) 59 | (reason-to-believe-loves ?a - character ?c - character ?d - character) 60 | (reason-to-love ?a - character ?c - character) 61 | ) 62 | 63 | (:derived (can-see ?c - character ?l - locatable) 64 | (exists (?p - place) 65 | (and (at ?c ?p) 66 | (at ?l ?p)))) 67 | 68 | (:derived (alone-at ?c - character ?p - place) 69 | (forall (?d - character) 70 | (or (not (at ?d ?p)) 71 | (= ?d ?c)))) 72 | 73 | ;; ?a has motive for (has ?a ?i) if ?a is greedy and ?i is precious: 74 | (:derived (motive-for-has ?a - character ?a - character ?i - item) 75 | (and (is-greedy ?a) 76 | (precious ?i) 77 | (can-see ?a ?i))) 78 | 79 | ;; ?a has motive for (at ?a ?p) if ?a is curiuous and a friend of 80 | ;; ?a has asked ?a to be at ?p: 81 | (:derived (motive-for-at ?a - character ?a - character ?p - place) 82 | (and (is-curious ?a) 83 | (exists (?f - character) 84 | (and (friend-of ?a ?f) 85 | (requested-at ?f ?a ?p))))) 86 | 87 | ;; ?a has motive for (has ?c ?i) if ?a is "pursuing", in love 88 | ;; with ?c, and ?i is precious: 89 | (:derived (motive-for-has ?a - character ?c - character ?i - item) 90 | (and (is-pursuing ?a) 91 | (loves ?a ?c) 92 | (precious ?i))) 93 | 94 | ;; ?a has motive for (has ?c ?i) if ?a is obedient, loves ?c, 95 | ;; and ?c has requested to have ?i 96 | (:derived (motive-for-has ?a - character ?c - character ?i - item) 97 | (and (is-obedient ?a) 98 | (loves ?a ?c) 99 | (requested-has ?c ?c ?i))) 100 | 101 | ;; ?a has motive for (has ?a ?i) if ?a has motive for (has ?c ?i): 102 | (:derived (motive-for-has ?a - character ?a - character ?i - item) 103 | (exists (?c - character) 104 | (motive-for-has ?a ?c ?i))) 105 | 106 | ;; ?a has motive for (at ?a ?p) if ?a has motive for (has ?c ?i) 107 | ;; ?a has ?i, and ?c is at ?p: 108 | (:derived (motive-for-at ?a - character ?a - character ?p - place) 109 | (exists (?c - character ?i - item) 110 | (and (motive-for-has ?a ?c ?i) 111 | (has ?a ?i) 112 | (at ?c ?p)))) 113 | 114 | ;; ?a has motive for (at ?a ?p) if ?a has motive for (has ?a ?i) 115 | ;; and ?i is at ?p: 116 | (:derived (motive-for-at ?a - character ?a - character ?p - place) 117 | (exists (?i - item) 118 | (and (motive-for-has ?a ?a ?i) 119 | (at ?i ?p)))) 120 | 121 | ;; ?a has motive for (at ?c ?p) if ?a has motive for (has ?a ?i) 122 | ;; and ?c is at ?q and ?i is at ?q and ?p != ?q (i.e., ?a is 123 | ;; planning to steal ?i at ?p): 124 | (:derived (motive-for-at ?a - character ?c - character ?p - place) 125 | (exists (?i - item ?q - place) 126 | (and (motive-for-has ?a ?a ?i) 127 | (at ?i ?q) 128 | (at ?c ?q)))) 129 | 130 | ;; ?a has motive for (dead ?c) if ?a is jealous, ?c is the spouse of ?a, 131 | ;; and ?a believes ?c loves ?d: 132 | (:derived (motive-for-dead ?a - character ?c - character) 133 | (and (is-jealous ?a) 134 | (not (= ?c ?a)) 135 | (exists (?d - character) 136 | (and (married ?a ?c) 137 | (believes-loves ?a ?c ?d))))) 138 | 139 | ;; ?a has motive for (dead ?d) if ?a is jealous, ?c is the spouse of ?a, 140 | ;; and ?a believes ?c loves ?d: 141 | (:derived (motive-for-dead ?a - character ?d - character) 142 | (and (is-jealous ?a) 143 | (not (= ?d ?a)) 144 | (exists (?c - character) 145 | (and (married ?a ?c) 146 | (believes-loves ?a ?c ?d))))) 147 | 148 | ;; ?a has motive for (dead ?c) if ?a is wrathful, ?a loves ?d, and 149 | ;; ?c has killed ?d: 150 | (:derived (motive-for-dead ?a - character ?c - character) 151 | (and (is-wrathful ?a) 152 | (not (= ?c ?a)) 153 | (exists (?d - character) 154 | (and (loves ?a ?d) 155 | (killed ?c ?d))))) 156 | 157 | ;; ?a has motive for (at ?a ?p) if ?a has motive for (dead ?c) 158 | ;; and ?c is at ?p: 159 | (:derived (motive-for-at ?a - character ?a - character ?p - place) 160 | (exists (?c - character) 161 | (and (motive-for-dead ?a ?c) 162 | (at ?c ?p)))) 163 | 164 | ;; Belief revision rules: 165 | 166 | ;; ?a may (believe-loves ?a ?c ?d) if ?a is suspicious, and ?a observes 167 | ;; (has ?d ?i) for an ?i that was a gift from ?a to ?c 168 | (:derived (reason-to-believe-loves 169 | ?a - character ?c - character ?d - character) 170 | (and (is-suspicious ?a) 171 | (not (= ?c ?d)) 172 | (not (= ?a ?c)) 173 | (not (= ?a ?d)) 174 | (exists (?i - item) 175 | (and (gift ?a ?c ?i) 176 | (has ?d ?i) 177 | (can-see ?a ?d))))) 178 | 179 | ;; ?a may fall in love with ?c if ?a is a woman, ?a is vain, 180 | ;; ?c is a man, and ?c has given ?a something precious: 181 | (:derived (reason-to-love ?a - character ?c - character) 182 | (and (woman ?a) 183 | (is-vain ?a) 184 | (man ?c) 185 | (exists (?i - item) 186 | (and (gift ?c ?a ?i) 187 | (precious ?i))))) 188 | 189 | ;; ?a may fall in love with ?c if ?a is a man, ?a is "lustful", 190 | ;; ?c is a woman, and ?c is wearing ("has") something precious: 191 | (:derived (reason-to-love ?a - character ?c - character) 192 | (and (man ?a) 193 | (is-lustful ?a) 194 | (woman ?c) 195 | (can-see ?a ?c) 196 | (exists (?i - item) 197 | (and (has ?c ?i) 198 | (precious ?i))))) 199 | 200 | ;; Belief revision actions: 201 | ;; Beliefs can persist beyond the current state, so we need to have 202 | ;; actions that allow characters to adopt beliefs. 203 | 204 | (:action adopt-belief-loves 205 | :parameters (?a - character ?c - character ?d - character) 206 | :precondition (and (reason-to-believe-loves ?a ?c ?d) 207 | (alive ?a) 208 | (alive ?c)) 209 | :effect (believes-loves ?a ?c ?d) 210 | ) 211 | 212 | (:action fall-in-love 213 | :parameters (?a - character ?c - character) 214 | :precondition (and (reason-to-love ?a ?c) 215 | (not (= ?a ?c)) 216 | (alive ?a) 217 | (alive ?c)) 218 | :effect (loves ?a ?c) 219 | ) 220 | 221 | ;; Character actions: 222 | 223 | (:action take 224 | :parameters (?a - character ?i - item ?p - place) 225 | :precondition (and (or (main-character ?a) 226 | (motive-for-has ?a ?a ?i)) 227 | (alive ?a) 228 | (at ?i ?p) 229 | (at ?a ?p) 230 | (alone-at ?a ?p)) 231 | :effect (and (not (at ?i ?p)) 232 | (has ?a ?i)) 233 | ) 234 | 235 | (:action drop 236 | :parameters (?a - character ?i - item ?p - place) 237 | :precondition (and (or (main-character ?a) 238 | (motive-for-at ?a ?i ?p)) 239 | (alive ?a) 240 | (has ?a ?i) 241 | (at ?a ?p)) 242 | :effect (and (not (has ?a ?i)) 243 | (at ?i ?p)) 244 | ) 245 | 246 | (:action give 247 | :parameters (?a - character ?c - character ?i - item ?p - place) 248 | :precondition (and (or (main-character ?a) 249 | (motive-for-has ?a ?c ?i)) 250 | (alive ?a) 251 | (alive ?c) 252 | (has ?a ?i) 253 | (at ?a ?p) 254 | (at ?c ?p)) 255 | :effect (and (not (has ?a ?i)) 256 | (has ?c ?i) 257 | (gift ?a ?c ?i)) 258 | ) 259 | 260 | (:action goto 261 | :parameters (?a - character ?p - place ?from - place) 262 | :precondition (and (or (main-character ?a) 263 | (motive-for-at ?a ?a ?p)) 264 | (alive ?a) 265 | (at ?a ?from) 266 | (not (= ?p ?from))) 267 | :effect (and (not (at ?a ?from)) 268 | (at ?a ?p)) 269 | ) 270 | 271 | ;; Although he is evil, Iago is too cautious to kill other 272 | ;; characters himself... 273 | (:action kill 274 | :parameters (?a - character ?c - character ?p - place) 275 | :precondition (and (motive-for-dead ?a ?c) 276 | (alive ?a) 277 | (alive ?c) 278 | (at ?a ?p) 279 | (at ?c ?p)) 280 | :effect (and (not (alive ?c)) 281 | (dead ?c) 282 | (killed ?a ?c)) 283 | ) 284 | 285 | ;; Communicative actions. Note that requests (as modelled here) are 286 | ;; not made to a specific character. 287 | 288 | (:action request-at 289 | :parameters (?a - character ?c - character ?p - place) 290 | :precondition (and (or (main-character ?a) 291 | (motive-for-at ?a ?c ?p)) 292 | (alive ?a) 293 | (alive ?c)) 294 | :effect (requested-at ?a ?c ?p) 295 | ) 296 | 297 | (:action request-has 298 | :parameters (?a - character ?c - character ?i - item) 299 | :precondition (and (or (main-character ?a) 300 | (motive-for-has ?a ?c ?i)) 301 | (alive ?a) 302 | (alive ?c)) 303 | :effect (requested-has ?a ?c ?i) 304 | ) 305 | 306 | ) 307 | -------------------------------------------------------------------------------- /tests/fs/buckets-3.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (problem three) 3 | (:domain buckets) 4 | 5 | (:objects b8 b5 b3 - bucket 6 | one two three four five six seven eight - quantity) 7 | 8 | (:init 9 | (= (in b8) eight) 10 | (= (in b5) zero) 11 | (= (in b3) zero) 12 | 13 | (= (capacity b8) eight) 14 | (= (capacity b5) five) 15 | (= (capacity b3) three) 16 | 17 | (less-or-equal zero zero) 18 | (less-or-equal zero one) 19 | (less-or-equal zero two) 20 | (less-or-equal zero three) 21 | (less-or-equal zero four) 22 | (less-or-equal zero five) 23 | (less-or-equal zero six) 24 | (less-or-equal zero seven) 25 | (less-or-equal zero eight) 26 | (less-or-equal one one) 27 | (less-or-equal one two) 28 | (less-or-equal one three) 29 | (less-or-equal one four) 30 | (less-or-equal one five) 31 | (less-or-equal one six) 32 | (less-or-equal one seven) 33 | (less-or-equal one eight) 34 | (less-or-equal two two) 35 | (less-or-equal two three) 36 | (less-or-equal two four) 37 | (less-or-equal two five) 38 | (less-or-equal two six) 39 | (less-or-equal two seven) 40 | (less-or-equal two eight) 41 | (less-or-equal three three) 42 | (less-or-equal three four) 43 | (less-or-equal three five) 44 | (less-or-equal three six) 45 | (less-or-equal three seven) 46 | (less-or-equal three eight) 47 | (less-or-equal four four) 48 | (less-or-equal four five) 49 | (less-or-equal four six) 50 | (less-or-equal four seven) 51 | (less-or-equal four eight) 52 | (less-or-equal five five) 53 | (less-or-equal five six) 54 | (less-or-equal five seven) 55 | (less-or-equal five eight) 56 | (less-or-equal six six) 57 | (less-or-equal six seven) 58 | (less-or-equal six eight) 59 | (less-or-equal seven seven) 60 | (less-or-equal seven eight) 61 | (less-or-equal eight eight) 62 | 63 | (= (sum zero zero) zero) 64 | (= (sum zero one) one) 65 | (= (sum zero two) two) 66 | (= (sum zero three) three) 67 | (= (sum zero four) four) 68 | (= (sum zero five) five) 69 | (= (sum zero six) six) 70 | (= (sum zero seven) seven) 71 | (= (sum zero eight) eight) 72 | (= (sum one zero) one) 73 | (= (sum one one) two) 74 | (= (sum one two) three) 75 | (= (sum one three) four) 76 | (= (sum one four) five) 77 | (= (sum one five) six) 78 | (= (sum one six) seven) 79 | (= (sum one seven) eight) 80 | (= (sum two zero) two) 81 | (= (sum two one) three) 82 | (= (sum two two) four) 83 | (= (sum two three) five) 84 | (= (sum two four) six) 85 | (= (sum two five) seven) 86 | (= (sum two six) eight) 87 | (= (sum three zero) three) 88 | (= (sum three one) four) 89 | (= (sum three two) five) 90 | (= (sum three three) six) 91 | (= (sum three four) seven) 92 | (= (sum three five) eight) 93 | (= (sum four zero) four) 94 | (= (sum four one) five) 95 | (= (sum four two) six) 96 | (= (sum four three) seven) 97 | (= (sum four four) eight) 98 | (= (sum five zero) five) 99 | (= (sum five one) six) 100 | (= (sum five two) seven) 101 | (= (sum five three) eight) 102 | (= (sum six zero) six) 103 | (= (sum six one) seven) 104 | (= (sum six two) eight) 105 | (= (sum seven zero) seven) 106 | (= (sum seven one) eight) 107 | (= (sum eight zero) eight) 108 | 109 | (= (diff eight zero) eight) 110 | (= (diff eight one) seven) 111 | (= (diff eight two) six) 112 | (= (diff eight three) five) 113 | (= (diff eight four) four) 114 | (= (diff eight five) three) 115 | (= (diff eight six) two) 116 | (= (diff eight seven) one) 117 | (= (diff eight eight) zero) 118 | (= (diff seven zero) seven) 119 | (= (diff seven one) six) 120 | (= (diff seven two) five) 121 | (= (diff seven three) four) 122 | (= (diff seven four) three) 123 | (= (diff seven five) two) 124 | (= (diff seven six) one) 125 | (= (diff seven seven) zero) 126 | (= (diff six zero) six) 127 | (= (diff six one) five) 128 | (= (diff six two) four) 129 | (= (diff six three) three) 130 | (= (diff six four) two) 131 | (= (diff six five) one) 132 | (= (diff six six) zero) 133 | (= (diff five zero) five) 134 | (= (diff five one) four) 135 | (= (diff five two) three) 136 | (= (diff five three) two) 137 | (= (diff five four) one) 138 | (= (diff five five) zero) 139 | (= (diff four zero) four) 140 | (= (diff four one) three) 141 | (= (diff four two) two) 142 | (= (diff four three) one) 143 | (= (diff four four) zero) 144 | (= (diff three zero) three) 145 | (= (diff three one) two) 146 | (= (diff three two) one) 147 | (= (diff three three) zero) 148 | (= (diff two zero) two) 149 | (= (diff two one) one) 150 | (= (diff two two) zero) 151 | (= (diff one zero) one) 152 | (= (diff one one) zero) 153 | (= (diff zero zero) zero) 154 | 155 | ) 156 | 157 | (:goal (and (= (in b8) four) (= (in b5) four))) 158 | 159 | ) 160 | -------------------------------------------------------------------------------- /tests/fs/buckets.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain buckets) 3 | (:requirements :strips :typing :equality :fluents) 4 | 5 | (:types bucket quantity) 6 | 7 | (:constants zero - quantity) 8 | 9 | (:predicates 10 | (less-or-equal ?a ?b - quantity) ;; ?a <= ?b 11 | ) 12 | 13 | (:functions 14 | (in ?b - bucket) - quantity ;; amount currently in ?b 15 | (capacity ?b - bucket) - quantity ;; capacity of ?b 16 | (sum ?a ?b - quantity) - quantity ;; ?a + ?b 17 | (diff ?a ?b - quantity) - quantity ;; ?a - ?b 18 | ) 19 | 20 | ;; all of ?bfrom fits in ?bto: 21 | (:action empty-into 22 | :parameters (?bfrom ?bto - bucket) 23 | :precondition (and (not (= ?bfrom ?bto)) 24 | (less-or-equal (sum (in ?bfrom) (in ?bto)) 25 | (capacity ?bto))) 26 | :effect (and (assign (in ?bto) (sum (in ?bfrom) (in ?bto))) 27 | (assign (in ?bfrom) zero)) 28 | ) 29 | 30 | ;; pour from ?bfrom until ?bto full: 31 | (:action fill-from 32 | :parameters (?bfrom ?bto - bucket) 33 | :precondition (and (not (= ?bfrom ?bto)) 34 | (less-or-equal (diff (capacity ?bto) (in ?bto)) 35 | (in ?bfrom))) 36 | :effect (and (assign (in ?bto) (capacity ?bto)) 37 | (assign (in ?bfrom) 38 | (diff (in ?bfrom) (diff (capacity ?bto) (in ?bto))))) 39 | ) 40 | 41 | ) 42 | -------------------------------------------------------------------------------- /tests/fs/fs-blocks-v1.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain blocksworld-FS) 3 | 4 | (:types block - place) 5 | 6 | (:constants table - place) 7 | 8 | (:functions 9 | (loc ?b - block) - place 10 | ) 11 | 12 | ;; Hector's formulation has clear as a fluent with a boolean domain. 13 | ;; I've made it a predicate instead. Hector's formulation has the 14 | ;; assignment (assign (clear ?to) (= ?to table)) in the move action, 15 | ;; which of course cannot be done with clear a predicate, so I've 16 | ;; made that a conditional effect instead (with static condition). 17 | ;; The conditional effect can be removed by splitting the action into 18 | ;; two cases (one that has the ?to argument typed as 'block, one that 19 | ;; moves only to the table; see fs-blocks-v2.pddl). 20 | ;; 21 | ;; Another alternative would be to define 'boolean as a type, declare 22 | ;; contants 'true and 'false, make clear a fluent with boolean type, 23 | ;; and define a static fluent (is-equal-to-table ?p - place), which 24 | ;; could then be used in the effect. The static fluent, however, must 25 | ;; be given a value for every argument (all blocks plus the table) 26 | ;; by the initial state. 27 | 28 | (:predicates 29 | (clear ?p - place) 30 | ) 31 | 32 | ;; Note that the move action requires the destination to be clear, 33 | ;; even if the destination is the table. Thus, (clear table) must 34 | ;; be present in the initial state. (It will never be deleted.) 35 | 36 | (:action move 37 | :parameters (?b - block ?to - place) 38 | :precondition (and (clear ?b) 39 | (clear ?to) 40 | (not (= ?b ?to))) 41 | :effect (and (clear (loc ?b)) 42 | (assign (loc ?b) ?to) 43 | (when (not (= ?to table)) 44 | (not (clear ?to)))) 45 | ) 46 | 47 | ) 48 | 49 | (define (problem sussman) 50 | (:domain blocksworld-FS) 51 | 52 | (:objects a b c - block) 53 | 54 | (:init 55 | (= (loc a) table) 56 | (= (loc b) table) 57 | (= (loc c) a) 58 | (clear c) 59 | (clear b) 60 | (clear table) 61 | ) 62 | 63 | (:goal (and (= (loc a) b) (= (loc b) c))) 64 | 65 | ) 66 | 67 | (:plan 68 | (move c table) 69 | (move b c) 70 | (move a b) 71 | ) 72 | -------------------------------------------------------------------------------- /tests/fs/fs-blocks-v2.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain blocksworld-FS) 3 | 4 | (:types block - place) 5 | 6 | (:constants table - place) 7 | 8 | (:functions 9 | (loc ?b - block) - place 10 | ) 11 | 12 | (:predicates 13 | (clear ?p - place) 14 | ) 15 | 16 | (:action move-to-block 17 | :parameters (?b - block ?to - block) 18 | :precondition (and (clear ?b) 19 | (clear ?to) 20 | (not (= ?b ?to))) 21 | :effect (and (clear (loc ?b)) 22 | (assign (loc ?b) ?to) 23 | (not (clear ?to))) 24 | ) 25 | 26 | (:action move-to-table 27 | :parameters (?b - block) 28 | :precondition (clear ?b) 29 | :effect (and (clear (loc ?b)) 30 | (assign (loc ?b) table)) 31 | ) 32 | 33 | ) 34 | 35 | (define (problem sussman) 36 | (:domain blocksworld-FS) 37 | 38 | (:objects a b c - block) 39 | 40 | (:init 41 | (= (loc a) table) 42 | (= (loc b) table) 43 | (= (loc c) a) 44 | (clear c) 45 | (clear b) 46 | (clear table) 47 | ) 48 | 49 | (:goal (and (= (loc a) b) (= (loc b) c))) 50 | 51 | ) 52 | 53 | (:plan 54 | (move-to-table c) 55 | (move-to-block b c) 56 | (move-to-block a b) 57 | ) 58 | -------------------------------------------------------------------------------- /tests/fs/fs-hanoi-v2.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain hanoi-FS) 3 | 4 | (:types disk peg) 5 | 6 | ;; an untyped constant, to represent the bottom of a peg 7 | (:constants bottom) 8 | 9 | (:functions 10 | ;; here, we allow a union type to mention not only atomic types but 11 | ;; also named constants; in other words, each constant is also a type 12 | ;; (with itself as the only element) 13 | (top ?p - peg) - (either disk bottom) 14 | (below ?disk - disk) - (either disk bottom) 15 | (size ?ds - (either disk bottom)) - number 16 | ) 17 | 18 | ;; As in the original formulation of version 1, this action will 19 | ;; fail to type check because (top ?pi) has type (either disk bottom) 20 | ;; and the argument to below must be of type disk; however, since 21 | ;; we know that the range of top consists of only disks plus the 22 | ;; constant bottom, and we explicitly rule out (top ?pi) = bottom 23 | ;; in the precondition, a clever type checker should be able to 24 | ;; tell that the assignment is ok. 25 | (:action move 26 | :parameters (?pi ?pj - peg) 27 | :precondition (and (not (= (top ?pi) bottom)) 28 | (< (size (top ?pi)) (size (top ?pj)))) 29 | :effect (and (assign (top ?pi) (below (top ?pi))) 30 | (assign (below (top ?pi)) (top ?pj)) 31 | (assign (top ?pj) (top ?pi))) 32 | ) 33 | 34 | ) 35 | 36 | (define (problem hanoi-4) 37 | (:domain hanoi-FS) 38 | 39 | (:objects 40 | p1 p2 p3 - peg 41 | d1 d2 d3 d4 - disk 42 | ) 43 | 44 | (:init 45 | (= (below d4) bottom) 46 | (= (below d3) d4) 47 | (= (below d2) d3) 48 | (= (below d1) d2) 49 | (= (top p1) d1) 50 | (= (top p2) bottom) 51 | (= (top p3) bottom) 52 | (= (size d1) 1) 53 | (= (size d2) 2) 54 | (= (size d3) 3) 55 | (= (size d4) 4) 56 | (= (size bottom) 4) 57 | ) 58 | 59 | (:goal (and (= (below d4) bottom) 60 | (= (below d3) d4) 61 | (= (below d2) d3) 62 | (= (below d1) d2) 63 | (= (top p3) d1))) 64 | ) 65 | -------------------------------------------------------------------------------- /tests/fs/fs-hanoi.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain hanoi-FS) 3 | 4 | (:types 5 | disk - disk* 6 | peg) 7 | 8 | ;; In Hector's formulation, the type of the argument ?d of the 'loc' 9 | ;; function has type disk, not disk*. That makes the move action fail 10 | ;; to type check, because it assigns (loc (top ?pi)), and (top ?pi) 11 | ;; has type disk*. 12 | 13 | ;; The fact that (top ?pi) is explicitly constrained to not equal the 14 | ;; constant 'bottom and that 'bottom is the only element of type disk* 15 | ;; that is not also of type disk of course means that the assignment 16 | ;; is, for any applicable instance of the action, type safe, but this 17 | ;; is not discovered by static analysis (in fact, cannot be discovered 18 | ;; by analysis of the domain alone). 19 | 20 | (:functions 21 | (top ?p - peg) - disk* 22 | (loc ?ds - disk*) - disk* 23 | (size ?ds - disk*) - number 24 | ) 25 | 26 | (:constants 27 | bottom - disk* 28 | ) 29 | 30 | (:action move 31 | :parameters (?pi ?pj - peg) 32 | :precondition (and (not (= (top ?pi) bottom)) 33 | (< (size (top ?pi)) (size (top ?pj)))) 34 | :effect (and (assign (top ?pi) (loc (top ?pi))) 35 | (assign (loc (top ?pi)) (top ?pj)) 36 | (assign (top ?pj) (top ?pi))) 37 | ) 38 | 39 | ) 40 | 41 | (define (problem hanoi-4) 42 | (:domain hanoi-FS) 43 | 44 | (:objects 45 | p1 p2 p3 - peg 46 | d1 d2 d3 d4 - disk 47 | ) 48 | 49 | (:init 50 | (= (loc d4) bottom) 51 | (= (loc d3) d4) 52 | (= (loc d2) d3) 53 | (= (loc d1) d2) 54 | (= (top p1) d1) 55 | (= (top p2) bottom) 56 | (= (top p3) bottom) 57 | (= (size d1) 1) 58 | (= (size d2) 2) 59 | (= (size d3) 3) 60 | (= (size d4) 4) 61 | (= (size bottom) 5) 62 | ) 63 | 64 | (:goal (and (= (loc d4) bottom) 65 | (= (loc d3) d4) 66 | (= (loc d2) d3) 67 | (= (loc d1) d2) 68 | (= (top p3) d1))) 69 | ) 70 | 71 | (:plan 72 | (move p1 p2) ; d1 73 | (move p1 p3) ; d2 74 | (move p2 p3) ; d1 75 | (move p1 p2) ; d3 76 | (move p3 p1) ; d1 77 | (move p3 p2) ; d2 78 | (move p1 p2) ; d1 79 | (move p1 p3) ; d4 80 | (move p2 p3) ; d1 81 | (move p2 p1) ; d2 82 | (move p3 p1) ; d1 83 | (move p2 p3) ; d3 84 | (move p1 p2) ; d1 85 | (move p1 p3) ; d2 86 | (move p2 p3) ; d1 87 | ) 88 | -------------------------------------------------------------------------------- /tests/fs/fs-logistics-v2.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain logistics-FS) 3 | 4 | (:types 5 | package - object 6 | airplane truck - vehicle 7 | airport - location 8 | location - object 9 | city - object 10 | ) 11 | 12 | ;; In Hector's formulation, there is only one 'loc' function, for 13 | ;; both vehicles and package; this causes a type error in the 14 | ;; drive action, just as in logistics-domain-new. 15 | 16 | (:functions 17 | (vehicle-loc ?v - vehicle) - location 18 | (package-loc ?p - package) - (either location vehicle) 19 | (city-of ?l - location) - city 20 | ) 21 | 22 | (:action load 23 | :parameters (?p - package ?v - vehicle) 24 | ;; Note that the equality predicate is implicitly declared as 25 | ;; (= ?o1 ?o2 - object), i.e., it accepts any argument types. 26 | :precondition (= (package-loc ?p) (vehicle-loc ?v)) 27 | :effect (assign (package-loc ?p) ?v) 28 | ) 29 | 30 | ;; Hector's formulation has an unload action with only one parameter, 31 | ;; the package being unloaded. This causes a type error in the 32 | ;; assignment, since the type of package-loc is (either location 33 | ;; vehicle), but vehicle-loc can only take a vehicle as argument. 34 | ;; 35 | ;; That could be "fixed" by assuming a more clever type checking 36 | ;; mechanism, which infers from the precondition that for any 37 | ;; applicable instance of the action, the value of (package-loc ?p) 38 | ;; in the assignment is of type vehicle. But that requires specifying 39 | ;; exactly what kind of inference the type checker should do. (And, 40 | ;; imho, that inference should be polynomial.) 41 | ;; 42 | ;; In the absence of such a smart type checker, we have to supply 43 | ;; the vehicle as an explicit argument. 44 | 45 | (:action unload 46 | :parameters (?p - package ?v - vehicle) 47 | :precondition (= (package-loc ?p) ?v) 48 | :effect (assign (package-loc ?p) (vehicle-loc ?v)) 49 | ) 50 | 51 | (:action drive 52 | :parameters (?t - truck ?to - location) 53 | :precondition (= (city-of (vehicle-loc ?t)) (city-of ?to)) 54 | :effect (assign (vehicle-loc ?t) ?to) 55 | ) 56 | 57 | ;; Hector's formulation has an explicit type test on ?to in 58 | ;; the precondition, but that is redundant; thus, we're left 59 | ;; with no precondition. 60 | 61 | (:action fly 62 | :parameters (?a - airplane ?to - airport) 63 | :effect (assign (vehicle-loc ?a) ?to) 64 | ) 65 | 66 | ) 67 | 68 | (define (problem logistics) 69 | (:domain logistics-FS) 70 | 71 | (:objects 72 | barcelona basel canberra - city 73 | BCN BSL CBR - airport 74 | UPF UniBas ANU - location 75 | tbar tbas tcan - truck 76 | airplane-one - airplane 77 | pkg1 pkg2 - package 78 | ) 79 | 80 | (:init 81 | (= (vehicle-loc tbar) UPF) 82 | (= (vehicle-loc tcan) ANU) 83 | (= (vehicle-loc tbas) BSL) 84 | (= (vehicle-loc airplane-one) BCN) 85 | (= (package-loc pkg1) UniBas) 86 | (= (package-loc pkg2) ANU) 87 | (= (city-of UPF) barcelona) 88 | (= (city-of BCN) barcelona) 89 | (= (city-of ANU) canberra) 90 | (= (city-of CBR) canberra) 91 | (= (city-of UniBas) basel) 92 | (= (city-of BSL) basel) 93 | ) 94 | 95 | (:goal (and (= (package-loc pkg1) ANU) 96 | (= (package-loc pkg2) UPF))) 97 | 98 | ) 99 | -------------------------------------------------------------------------------- /tests/fs/fs-logistics.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain logistics-FS) 3 | 4 | (:types 5 | package - object 6 | airplane truck - vehicle 7 | vehicle - object 8 | airport - location 9 | location - object 10 | city - object 11 | ) 12 | 13 | (:functions 14 | (loc ?x - (either package vehicle)) - (either location vehicle) 15 | (city-of ?l - location) - city 16 | ) 17 | 18 | (:action load 19 | :parameters (?p - package ?v - vehicle) 20 | :precondition (= (loc ?p) (loc ?v)) 21 | :effect (assign (loc ?p) ?v) 22 | ) 23 | 24 | ;; The unload action is not type correct, because of the term 25 | ;; (loc (loc ?p)) in the assignment. The expression (loc ?p) is 26 | ;; of type (either location vehicle), but loc expects as argument 27 | ;; the type (either package vehicle), which is not a subtype of 28 | ;; the former. 29 | 30 | ;; Note that this action must use a "type test" (type name used 31 | ;; as static unary predicate) in the precondition. 32 | 33 | ;; One way to avoid the type safety problem here is to extend the 34 | ;; argument type of loc to (either package vehicle location). Since 35 | ;; (loc ) is not specified in the initial state for any location 36 | ;; (and not set by any action), the action becomes inapplicable 37 | ;; in any state where package ?p is not in a vehicle (because in such 38 | ;; a state the value of the right hand side of the assignment is 39 | ;; undefined, which is an execution error), and thus this eliminates 40 | ;; the need for an explicit type test in the precondition. 41 | 42 | (:action unload 43 | :parameters (?p - package) 44 | :precondition (vehicle (loc ?p)) 45 | :effect (assign (loc ?p) (loc (loc ?p))) 46 | ) 47 | 48 | ;; The drive action is also not type correct, because of the term 49 | ;; (city-of (loc ?t)) in the precondition. Again, this is because 50 | ;; the type of (loc ?t) is (either location vehicle), but city-of 51 | ;; expects as argument only the type location. Also as above, the 52 | ;; problem can be "fixed" by widening the parameter type of city-of 53 | ;; to (either location vehicle) but leaving the function undefined 54 | ;; for all non-location arguments. 55 | 56 | (:action drive 57 | :parameters (?t - truck ?to - location) 58 | :precondition (= (city-of (loc ?t)) (city-of ?to)) 59 | :effect (assign (loc ?t) ?to) 60 | ) 61 | 62 | ;; Hector's formulation has an explicit type test on ?to in the 63 | ;; precondition, but that is redundant; thus, we're left with no 64 | ;; precondition. 65 | 66 | (:action fly 67 | :parameters (?a - airplane ?to - airport) 68 | :effect (assign (loc ?a) ?to) 69 | ) 70 | 71 | ) 72 | 73 | (define (problem logistics) 74 | (:domain logistics-FS) 75 | 76 | (:objects 77 | barcelona basel canberra - city 78 | BCN BSL CBR - airport 79 | UPF UniBas ANU - location 80 | tbar tbas tcan - truck 81 | airplane-one - airplane 82 | pkg1 pkg2 - package 83 | ) 84 | 85 | (:init 86 | (= (loc tbar) UPF) 87 | (= (loc tcan) ANU) 88 | (= (loc tbas) BSL) 89 | (= (loc airplane-one) BCN) 90 | (= (loc pkg1) UniBas) 91 | (= (loc pkg2) ANU) 92 | (= (city-of UPF) barcelona) 93 | (= (city-of BCN) barcelona) 94 | (= (city-of ANU) canberra) 95 | (= (city-of CBR) canberra) 96 | (= (city-of UniBas) basel) 97 | (= (city-of BSL) basel) 98 | ) 99 | 100 | (:goal (and (= (loc pkg1) ANU) 101 | (= (loc pkg2) UPF))) 102 | 103 | ) 104 | -------------------------------------------------------------------------------- /tests/fs/fs-puzzle.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain puzzle-FS) 3 | 4 | (:types 5 | pos - pos* 6 | direction 7 | tile 8 | ) 9 | 10 | (:constants 11 | nowhere - pos* 12 | up down left right - direction 13 | ) 14 | 15 | ;; Similarly to the hanoi domain, Hector's formulation has the 16 | ;; tile-at function's parameter typed as pos, not pos*, which 17 | ;; makes the expression (tile-at (next ?d (blank))) in the effect 18 | ;; of the move action type incorrect. 19 | 20 | (:functions 21 | (tile-at ?p - pos*) - tile 22 | (blank) - pos 23 | (next ?d - direction ?p - pos) - pos* 24 | ) 25 | 26 | (:action move 27 | :parameters (?d - direction) 28 | :precondition (not (= (next ?d (blank)) nowhere)) 29 | :effect (and (assign (blank) (next ?d (blank))) 30 | (assign (tile-at (blank)) (tile-at (next ?d (blank)))) 31 | (assign (tile-at (next ?d (blank))) undefined)) 32 | ) 33 | 34 | ) 35 | 36 | (define (problem eight31a) 37 | (:domain puzzle-FS) 38 | 39 | (:objects 40 | tl tm tr ml mm mr bl bm br - pos 41 | t1 t2 t3 t4 t5 t6 t7 t8 - tile 42 | ) 43 | 44 | (:init 45 | ;; the static 'next' function (of course we would prefer to have 46 | ;; this as part of the domain definition, but what can you do?) 47 | (= (next up tl) nowhere) 48 | (= (next up tm) nowhere) 49 | (= (next up tr) nowhere) 50 | (= (next up ml) tl) 51 | (= (next up mm) tm) 52 | (= (next up mr) tr) 53 | (= (next up bl) ml) 54 | (= (next up bm) mm) 55 | (= (next up br) mr) 56 | (= (next down tl) ml) 57 | (= (next down tm) mm) 58 | (= (next down tr) mr) 59 | (= (next down ml) bl) 60 | (= (next down mm) bm) 61 | (= (next down mr) br) 62 | (= (next down bl) nowhere) 63 | (= (next down bm) nowhere) 64 | (= (next down br) nowhere) 65 | (= (next left tl) nowhere) 66 | (= (next left tm) tl) 67 | (= (next left tr) tm) 68 | (= (next left ml) nowhere) 69 | (= (next left mm) ml) 70 | (= (next left mr) mm) 71 | (= (next left bl) nowhere) 72 | (= (next left bm) bl) 73 | (= (next left br) bm) 74 | (= (next right tl) tm) 75 | (= (next right tm) tr) 76 | (= (next right tr) nowhere) 77 | (= (next right ml) mm) 78 | (= (next right mm) mr) 79 | (= (next right mr) nowhere) 80 | (= (next right bl) bm) 81 | (= (next right bm) br) 82 | (= (next right br) nowhere) 83 | 84 | ;; the actual initial state 85 | (= (blank) tl) 86 | (= (tile-at tm) t1) 87 | (= (tile-at tr) t2) 88 | (= (tile-at ml) t3) 89 | (= (tile-at mm) t4) 90 | (= (tile-at mr) t5) 91 | (= (tile-at bl) t6) 92 | (= (tile-at bm) t7) 93 | (= (tile-at br) t8) 94 | ) 95 | 96 | (:goal (and (= (tile-at tl) t8) 97 | (= (tile-at tm) t7) 98 | (= (tile-at tr) t6) 99 | (= (tile-at mm) t4) 100 | (= (tile-at mr) t1) 101 | (= (tile-at bl) t2) 102 | (= (tile-at bm) t5) 103 | (= (tile-at br) t3))) 104 | 105 | ) 106 | -------------------------------------------------------------------------------- /tests/fs/lists.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain lists) 3 | (:constants null) 4 | 5 | (:predicates 6 | (in-list ?e) 7 | (follows ?e1 ?e2) 8 | ) 9 | 10 | (:functions 11 | (prev ?e) - object 12 | (next ?e) - object 13 | (first) - object 14 | (last) - object 15 | ) 16 | 17 | (:derived (follows ?e (next ?e)) 18 | (and (in-list ?e) (in-list (next ?e)))) 19 | 20 | (:derived (follows ?e1 ?e2) 21 | (and (in-list ?e1) 22 | (in-list ?e2) 23 | (follows (next ?e1) ?e2))) 24 | 25 | 26 | (:action make-list 27 | :parameters (?e) 28 | :precondition (forall (?x) (not (in-list ?x))) 29 | :effect (and (in-list ?e) 30 | (assign (prev ?e) null) 31 | (assign (next ?e) null) 32 | (assign (first) ?e) 33 | (assign (last) ?e)) 34 | ) 35 | 36 | (:action insert-before 37 | :parameters (?e ?p) 38 | :precondition (and (in-list ?p) 39 | (not (in-list ?e))) 40 | :effect (and (assign (next ?e) ?p) 41 | (assign (prev ?e) (prev ?p)) 42 | (assign (prev ?p) ?e) 43 | (assign (next (prev ?p)) ?e) 44 | (when (= (first) ?p) (assign (first) ?e)) 45 | (in-list ?e)) 46 | ) 47 | 48 | (:action insert-after 49 | :parameters (?e ?p) 50 | :precondition (and (in-list ?p) 51 | (not (in-list ?e))) 52 | :effect (and (assign (prev ?e) ?p) 53 | (assign (next ?e) (next ?p)) 54 | (assign (next ?p) ?e) 55 | (assign (prev (next ?p)) ?e) 56 | (when (= (last) ?p) (assign (last) ?e)) 57 | (in-list ?e)) 58 | ) 59 | 60 | (:action delete 61 | :parameters (?e) 62 | :precondition (in-list ?e) 63 | :effect (and (assign (next (prev ?e)) (next ?e)) 64 | (assign (prev (next ?e)) (prev ?e)) 65 | (assign (prev ?e) undefined) 66 | (assign (next ?e) undefined) 67 | (when (= (first) ?e) (assign (first) (next ?e))) 68 | (when (= (last) ?e) (assign (last) (prev ?e))) 69 | (not (in-list ?e))) 70 | ) 71 | 72 | (:action reverse 73 | :effect (and (assign (first) (last)) 74 | (assign (last) (first)) 75 | (forall (?e) 76 | (when (in-list ?e) 77 | (and (assign (prev ?e) (next ?e)) 78 | (assign (next ?e) (prev ?e)))))) 79 | ) 80 | 81 | ) 82 | 83 | (define (problem test) 84 | (:domain lists) 85 | 86 | (:objects a b c d) 87 | 88 | (:init ) ;) 89 | 90 | (:goal (and (= (first) d) 91 | (= (next d) c) 92 | (= (next c) b) 93 | (= (next b) a))) 94 | ) 95 | 96 | (:plan 97 | (make-list b) 98 | (insert-before a b) 99 | (insert-after d b) 100 | (insert-before c d) 101 | (reverse) 102 | ) 103 | -------------------------------------------------------------------------------- /tests/mo/bw-5-plan-1.soln: -------------------------------------------------------------------------------- 1 | (movetotable b2 b1) 2 | (movetotable b4 b3) 3 | (movefromtable b3 b2) 4 | (movefromtable b5 b1) 5 | (movefromtable b4 b3) 6 | -------------------------------------------------------------------------------- /tests/mo/bw-5-plan-2.soln: -------------------------------------------------------------------------------- 1 | (movetotable b4 b3) 2 | (movefromtable b3 b4) 3 | (movetoblock b2 b1 b3) 4 | (movefromtable b5 b1) 5 | (movetoblock b2 b3 b5) 6 | (movetoblock b3 b4 b2) 7 | (movefromtable b4 b3) 8 | -------------------------------------------------------------------------------- /tests/mo/bw-5-plan-3.soln: -------------------------------------------------------------------------------- 1 | (movetotable b2 b1) 2 | (movefromtable b5 b1) 3 | (movetoblock b4 b3 b5) 4 | (movefromtable b3 b2) 5 | (movetoblock b4 b5 b3) 6 | -------------------------------------------------------------------------------- /tests/mo/bw-5.pddl: -------------------------------------------------------------------------------- 1 | (define (problem block-5-1) 2 | (:domain blocksworld) 3 | 4 | (:objects B1 B2 B3 B4 B5) 5 | 6 | (:init (on-table B1) 7 | (on B2 B1) 8 | (on-table B3) 9 | (on B4 B3) 10 | (on-table B5) 11 | (clear B2) 12 | (clear B4) 13 | (clear B5) 14 | (= (moves-to-table) 0) 15 | (= (moves-to-block) 0) 16 | (= (total-moves) 0) 17 | ) 18 | 19 | (:goal (and (on B3 B2) (on B4 B3) (on B5 B1))) 20 | 21 | ;; simplified syntax (all metrics must have the same direction) 22 | (:metric minimize (moves-to-table) (moves-to-block) (total-moves)) 23 | 24 | ;; general syntax (can mix minimize and maximize) 25 | ;; (:metric minimize (moves-to-table)) 26 | ;; (:metric minimize (moves-to-block)) 27 | ;; (:metric minimize (total-moves)) 28 | ) 29 | -------------------------------------------------------------------------------- /tests/mo/bw3o.pddl: -------------------------------------------------------------------------------- 1 | (define (domain blocksworld) 2 | (:requirements :strips :equality) 3 | (:predicates (on-table ?x) (on ?x ?y) (clear ?x)) 4 | (:functions (moves-to-table) (moves-to-block) (total-moves)) 5 | 6 | (:action movetotable 7 | :parameters (?x ?y) 8 | :precondition (and (clear ?x) (on ?x ?y) (not (= ?x ?y))) 9 | :effect (and (clear ?y) (on-table ?x) (not (on ?x ?y)) 10 | (increase (moves-to-table) 1) 11 | (increase (total-moves) 1)) 12 | ) 13 | 14 | (:action movetoblock 15 | :parameters (?x ?y ?z) 16 | :precondition (and (clear ?x) (clear ?z) (on ?x ?y) (not (= ?x ?z)) 17 | (not (= ?y ?z))) 18 | :effect (and (clear ?y) (on ?x ?z) (not (clear ?z)) (not (on ?x ?y)) 19 | (increase (moves-to-block) 1) 20 | (increase (total-moves) 1)) 21 | ) 22 | 23 | (:action movefromtable 24 | :parameters (?x ?y) 25 | :precondition (and (clear ?x) (clear ?y) (on-table ?x) (not (= ?x ?y))) 26 | :effect (and (on ?x ?y) (not (clear ?y)) (not (on-table ?x)) 27 | (increase (moves-to-block) 1) 28 | (increase (total-moves) 1)) 29 | ) 30 | ) 31 | -------------------------------------------------------------------------------- /tests/ppddl/mk31.pol: -------------------------------------------------------------------------------- 1 | 2 | ;; same policy applies in both examples (only effects of a2 differ) 3 | 4 | (((s0)) (a0)) ;; in s0, take a0 5 | (((s1)) (a1)) ;; in s1, take a1 6 | (((s2)) (a2)) ;; in s2, take a2 7 | -------------------------------------------------------------------------------- /tests/ppddl/mk31a.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain mausam-kolobov-ex31a) 3 | (:predicates (s0) (s1) (s2) (sg)) 4 | 5 | (:action a0 6 | :precondition (s0) 7 | :effect (and (not (s0)) 8 | (probabilistic 9 | 6/10 (and (s1) (decrease (reward) 4)) 10 | 4/10 (and (s2) (decrease (reward) 1)))) 11 | ) 12 | 13 | (:action a1 14 | :precondition (s1) 15 | :effect (and (not (s1)) (sg) (decrease (reward) 0)) 16 | ) 17 | 18 | (:action a2 19 | :precondition (s2) 20 | :effect (and (not (s2)) (sg) (decrease (reward) 3)) 21 | ) 22 | ) 23 | 24 | (define (problem ex31a) 25 | (:init (s0)) 26 | (:goal (sg)) 27 | ) 28 | -------------------------------------------------------------------------------- /tests/ppddl/mk31b.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain mausam-kolobov-ex31b) 3 | (:predicates (s0) (s1) (s2) (sg)) 4 | 5 | (:action a0 6 | :precondition (s0) 7 | :effect (and (not (s0)) 8 | (probabilistic 9 | 6/10 (and (s1) (decrease (reward) 4)) 10 | 4/10 (and (s2) (decrease (reward) 1)))) 11 | ) 12 | 13 | (:action a1 14 | :precondition (s1) 15 | :effect (and (not (s1)) (sg) (decrease (reward) 0)) 16 | ) 17 | 18 | (:action a2 19 | :precondition (s2) 20 | :effect (and (not (s2)) 21 | (probabilistic 22 | 7/10 (and (sg) (decrease (reward) 3)) 23 | 3/10 (and (s0) (decrease (reward) 2)))) 24 | ) 25 | ) 26 | 27 | (define (problem ex31a) 28 | (:init (s0)) 29 | (:goal (sg)) 30 | ) 31 | -------------------------------------------------------------------------------- /tests/typing/domain-1.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain dummy) 3 | (:requirements :typing) 4 | 5 | (:types typeA typeB - object 6 | typeC - (either typeA typeB) 7 | ) 8 | 9 | (:predicates (p ?x - typeA) (q ?x - typeB) (static-true)) 10 | 11 | (:action do-p 12 | :parameters (?x - typeA) 13 | :precondition (static-true) 14 | :effect (p ?x) 15 | ) 16 | 17 | (:action do-q 18 | :parameters (?x - typeB) 19 | :precondition (static-true) 20 | :effect (q ?x) 21 | ) 22 | ) 23 | -------------------------------------------------------------------------------- /tests/typing/domain-2.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain dummy) 3 | (:requirements :typing) 4 | 5 | (:types typeA typeB - object 6 | typeC - typeA 7 | typeC - typeB 8 | ) 9 | 10 | (:predicates (p ?x - typeA) (q ?x - typeB) (static-true)) 11 | 12 | (:action do-p 13 | :parameters (?x - typeA) 14 | :precondition (static-true) 15 | :effect (p ?x) 16 | ) 17 | 18 | (:action do-q 19 | :parameters (?x - typeB) 20 | :precondition (static-true) 21 | :effect (q ?x) 22 | ) 23 | ) 24 | -------------------------------------------------------------------------------- /tests/typing/domain-3.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (domain dummy) 3 | (:requirements :typing :adl) 4 | 5 | (:types typeA typeB - object 6 | typeC - (either typeA typeB) 7 | ) 8 | 9 | (:predicates (p ?x - typeA) (q ?x - typeB) (static-true)) 10 | 11 | (:action do-it 12 | :parameters (?x - object) 13 | :precondition (static-true) 14 | :effect (and (when (typeA ?x) (p ?x)) 15 | (when (typeB ?x) (q ?x))) 16 | ) 17 | 18 | ) 19 | -------------------------------------------------------------------------------- /tests/typing/plan-1+2.soln: -------------------------------------------------------------------------------- 1 | 2 | (do-p ob1) 3 | (do-q ob1) 4 | -------------------------------------------------------------------------------- /tests/typing/plan-3.soln: -------------------------------------------------------------------------------- 1 | 2 | (do-it obA) 3 | (do-it obB) 4 | (do-it obC) 5 | -------------------------------------------------------------------------------- /tests/typing/problem-1+2.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (problem foo) 3 | (:domain test) 4 | 5 | (:objects ob1 - typeC) 6 | 7 | (:init (static-true) ) 8 | 9 | (:goal (and (p ob1) (q ob1))) 10 | ) 11 | -------------------------------------------------------------------------------- /tests/typing/problem-3.pddl: -------------------------------------------------------------------------------- 1 | 2 | (define (problem test) 3 | (:domain dummy) 4 | 5 | (:objects obA - typeA) 6 | (:objects obB - typeB) 7 | (:objects obC - typeC) 8 | 9 | (:init (static-true) ) 10 | 11 | (:goal (and (p obA) 12 | (q obB) 13 | (or (p obC) (q obC)) 14 | )) 15 | ) 16 | -------------------------------------------------------------------------------- /tools.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;;;; 3 | ;; Interface to FD's translator. Used to generate lists of ground atoms, 4 | ;; actions, axioms and mutex groups. 5 | 6 | (defvar *path-to-python* "python3") 7 | (defvar *path-to-FD-dump.py* "dump.py") 8 | 9 | (defun call-fd-dump (domain-path problem-path) 10 | (multiple-value-bind 11 | (stream code process) 12 | (si:run-program *path-to-python* 13 | (list *path-to-FD-dump.py* 14 | domain-path 15 | problem-path 16 | "fddump") 17 | :wait t :input nil :output t) 18 | (when (not (eq code 0)) (error "~a running dump.py" code)) 19 | (let ((content (read-file "fddump")) 20 | (atoms nil) 21 | (ground-action-names nil) 22 | (ground-axioms nil) 23 | (mutex-groups nil)) 24 | (dolist (item content) 25 | (cond ((eq (car item) 'atoms) 26 | (setq atoms (cdr item))) 27 | ((eq (car item) 'actions) 28 | (setq ground-action-names (cdr item))) 29 | ((eq (car item) 'axioms) 30 | (setq ground-axioms (cdr item))) 31 | ((eq (car item) 'mutex-groups) 32 | (setq mutex-groups (cdr item))) 33 | )) 34 | (list atoms ground-action-names ground-axioms mutex-groups)))) 35 | 36 | (defun make-mutex-map (atoms mutex-groups) 37 | (let ((mmap (mapcar #'list atoms))) 38 | (dolist (group mutex-groups) 39 | (dolist (atom1 group) 40 | (dolist (atom2 group) 41 | (when (not (equal atom1 atom2)) 42 | (setq mmap (add-to-set-map atom1 atom2 mmap :test #'equal)) 43 | )))) 44 | mmap)) 45 | 46 | ;; Check if a list contains nil as an element. 47 | ;; (This function appears to be unused.) 48 | ;; (defun find-nil (lst) 49 | ;; (cond ((endp lst) nil) 50 | ;; ((eq (car lst) nil) t) 51 | ;; (t (find-nil (cdr lst))))) 52 | 53 | 54 | ;; Make an assoc list from 'lst', by associng elements with a series 55 | ;; of consecutive numbers, starting from 'num'. 56 | 57 | (defun number-list (lst num) 58 | (cond ((endp lst) nil) 59 | (t (cons (cons (car lst) num) 60 | (number-list (cdr lst) (+ num 1)))))) 61 | 62 | ;;;; 63 | ;; Grounding tools. 64 | 65 | ;; A very basic implementation of grounding. 66 | ;; Returns (by multiple-value): 67 | ;; - list of ground fluents, on the form (fluent . domain); 68 | ;; the domain includes the value 'undefined; 69 | ;; - list of ground atoms; 70 | ;; - list of simplified ground actions 71 | ;; - list of simplified (split) ground axioms. 72 | 73 | (defun simple-ground 74 | (predicates functions actions axioms init goal types objects) 75 | (let* ((static-pred 76 | (let ((tmp (collect-static-predicates predicates actions axioms 77 | :include-static-derived t))) 78 | (when (>= *verbosity* 1) 79 | (format t "~&static predicates: ~s~%" tmp)) 80 | tmp)) 81 | (init2 (apply-static-axioms init static-pred axioms types objects)) 82 | (static-fun 83 | (collect-static-functions functions actions)) 84 | (state-pred 85 | (remove-if #'(lambda (preddef) 86 | (member (car preddef) static-pred)) 87 | predicates)) 88 | (state-fun 89 | (remove-if #'(lambda (fundef) 90 | (or (eq (cdr fundef) 'number) 91 | (member (caar fundef) static-fun))) 92 | functions)) 93 | (ground-actions 94 | (mapflat #'(lambda (act) 95 | (when (>= *verbosity* 1) 96 | (format t "~&grounding ~a ~a...~%" (car act) 97 | (assoc-val ':parameters (cdr act)))) 98 | (simplify-action act static-pred static-fun init2 99 | types objects 100 | :ground-all-parameters t :rename nil)) 101 | actions)) 102 | (ground-axioms 103 | (mapflat #'(lambda (axiom) 104 | (when (>= *verbosity* 1) 105 | (format t "~&grounding ~a...~%" axiom)) 106 | (simplify-axiom axiom static-pred static-fun init2 107 | types objects 108 | :ground-all-parameters t)) 109 | (remove-if #'(lambda (axiom) 110 | (axiom-predicate-in-list axiom static-pred)) 111 | axioms))) 112 | (atoms 113 | (mapflat #'(lambda (preddef) 114 | (instantiate (cons (car preddef) 115 | (mapcar #'car (cdr preddef))) 116 | nil (cdr preddef) types objects 117 | :insfun #'sublis)) 118 | state-pred)) 119 | (fluents 120 | (mapflat #'(lambda (fundef) 121 | (instantiate-object-fluent fundef types objects)) 122 | state-fun))) 123 | (values fluents atoms ground-actions ground-axioms))) 124 | 125 | (defun apply-static-axioms (state static-pred axioms types objects) 126 | (let ((static-axioms 127 | (remove-if #'(lambda (axiom) 128 | (not (axiom-predicate-in-list axiom static-pred))) 129 | axioms))) 130 | (cond (static-axioms 131 | (multiple-value-bind 132 | (stratified-axioms stratified-dps) (stratify static-axioms) 133 | (extend-state state stratified-axioms types objects))) 134 | (t state)))) 135 | 136 | ;; Generate all instances of an object-valued fluent, and return them 137 | ;; paired with the value domain. Returns nil if the value domain is 138 | ;; empty. 139 | 140 | (defun instantiate-object-fluent (fun types objects) 141 | (let ((value-domain (objects-of-type (cdr fun) types objects))) 142 | (if value-domain 143 | (mapcar #'(lambda (gfun) (cons gfun (cons 'undefined value-domain))) 144 | (instantiate (cons (caar fun) (mapcar #'car (cdar fun))) 145 | nil (cdar fun) *types* *objects* 146 | :insfun #'sublis)) 147 | nil))) 148 | 149 | ;; Instantiate variables in an expression, returning the list of instances 150 | ;; only where the guard formula evaluates to true (and well-defined) over 151 | ;; given facts. 152 | 153 | (defun instantiate-with-guard 154 | (exp guard facts binds vars types objects 155 | &key (insfun #'instantiate-1) (insfun-returns-list nil)) 156 | (instantiate 157 | exp binds vars types objects 158 | :insfun #'(lambda (binds exp) 159 | (let* ((g-guard (instantiate-1 binds guard)) 160 | (val (eval-formula g-guard nil facts types objects))) 161 | (if (and (car val) (cadr val)) 162 | (let ((g-exp (funcall insfun binds exp))) 163 | (if insfun-returns-list g-exp (list g-exp))) 164 | nil))) 165 | :insfun-returns-list t)) 166 | 167 | ;; Ground an invariant (either set-constraint or formula). 168 | 169 | (defun ground-invariant (inv facts types objects) 170 | (cond ((assoc-val ':set-constraint inv) 171 | (instantiate-with-guard 172 | (assoc-val ':set-constraint inv) (assoc-val ':context inv) 173 | facts nil (parse-typed-list '() (assoc-val ':vars inv) 'object) 174 | types objects 175 | :insfun #'(lambda (binds sc) 176 | (ground-set-constraint 177 | binds sc facts types objects)))) 178 | ((assoc-val ':formula inv) 179 | (instantiate-with-guard 180 | (assoc-val ':formula inv) (assoc-val ':context inv) 181 | facts nil (parse-typed-list '() (assoc-val ':vars inv) 'object) 182 | types objects)) 183 | (t (error "ill-formed invariant: ~a" inv)) 184 | )) 185 | 186 | ;; Internal function for grounding the elements of a set-constraint. 187 | 188 | (defun ground-set-constraint (binds sc facts types objects) 189 | (cons (car sc) 190 | (cons (cadr sc) 191 | (mapflat #'(lambda (sc-item) 192 | (cond 193 | ((not (listp sc-item)) 194 | (error "ill-formed set-constraint: ~a" sc)) 195 | ((eq (car sc-item) 'setof) 196 | (ground-setof binds sc-item facts types objects)) 197 | (t (list (sublis binds sc-item))))) 198 | (cddr sc))))) 199 | 200 | (defun ground-setof (binds setof facts types objects) 201 | (let ((pso (parse-struct (cdr setof) :last ':atom))) 202 | (if (null (assoc-val ':atom pso)) 203 | (error "ill-formed setof: ~a" setof) 204 | (instantiate-with-guard 205 | (assoc-val ':atom pso) (assoc-val ':context pso) 206 | facts binds (parse-typed-list nil (assoc-val ':vars pso) 'object) 207 | types objects)))) 208 | 209 | ;;;; 210 | ;; Printing tools 211 | 212 | (defun print-timed-plan (plan &key (stream t)) 213 | (dolist (item (cdr plan)) 214 | (let ((timestamp (car item)) 215 | (actions (cdr item))) 216 | (dolist (act actions) 217 | (format stream "~&~a : ~a~%" timestamp act) 218 | )))) 219 | 220 | (defun save-timed-plan (filename plan) 221 | (with-open-file 222 | (stream filename :direction :output) 223 | ;; (make-format-PDDL-friendly) 224 | (let ((*print-pretty* t)) 225 | (print-timed-plan plan :stream stream)) 226 | ;; (make-format-default) 227 | ) 228 | nil) 229 | -------------------------------------------------------------------------------- /translate-main.lsp: -------------------------------------------------------------------------------- 1 | (defun get-commandline-args () 2 | (cdr (ext:command-args))) 3 | 4 | (defun print-help () 5 | (format t "~&translate *~%") 6 | (quit) 7 | ) 8 | 9 | (defun translate-main () 10 | (if (< (length (get-commandline-args)) 2) (print-help)) 11 | (setq *rules* (read-file (first (get-commandline-args)))) 12 | (dolist (planfile (rest (get-commandline-args))) 13 | (let ((contents (read-file planfile))) 14 | (parse-file planfile contents))) 15 | (dolist (plan *plans*) 16 | (format t "~&;; plan ~a:~%" (car plan)) 17 | (dolist (step (translate-plan (cdr plan) *rules*)) 18 | (dolist (act step) 19 | (format t "~&~s~%" act)))) 20 | ) 21 | 22 | ;; Call main function inside an error handler. 23 | 24 | (handler-bind 25 | ((condition #'(lambda (erc) 26 | (format *error-output* "~&~A~&" erc) 27 | (quit)))) 28 | (translate-main)) 29 | (quit) 30 | -------------------------------------------------------------------------------- /val-test-util.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;; Utilities for comparing VAL and INVAL on sets of problems and plans. 3 | ;;;; 4 | 5 | ;; Run INVAL and VAL on domain + problem + file and compare their 6 | ;; output. domain-file, problem-file and plan-file can be either 7 | ;; pathnames or strings (designating files). Returns T iff both 8 | ;; validators are in agreement, nil otherwise. Also prints the test 9 | ;; (files) and the outcome. 10 | ;; 11 | ;; The metric value output for a plan can sometimes differ because 12 | ;; of decimal printing precision. The variable *precision-threshold* 13 | ;; determines how large a difference is accepted as a "precision 14 | ;; issue", rather than a true disagreement between the validators. 15 | ;; Precision mismatches still count as failed tests, but they are 16 | ;; printed differently. 17 | 18 | (defvar *precision-threshold* 0.001) 19 | 20 | (defun do-test (domain-file problem-file plan-file) 21 | (format t "~&test: ~a ~a ~a~%" domain-file problem-file plan-file) 22 | (setq *verbosity* 0) 23 | (clear-definitions) 24 | (parse-file domain-file (read-file domain-file)) 25 | (parse-file problem-file (read-file problem-file)) 26 | (let ((the-plan (parse-plan plan-file (read-file plan-file)))) 27 | (let ((inval-res 28 | (cond ((type-check) 29 | (validate-plan (car the-plan) (cdr the-plan) *init* *goal* 30 | *constraints* *metric* *actions* 31 | (stratify *axioms*) *types* *objects*)) 32 | (t nil))) 33 | (val-res (run-val domain-file problem-file plan-file))) 34 | (cond ((not (eq (null inval-res) (null val-res))) 35 | (format t "mismatch: ~s ~s~%" inval-res val-res) 36 | nil) 37 | ((not (eq (null (car inval-res)) (null (car val-res)))) 38 | (format t "mismatch: ~s ~s~%" inval-res val-res) 39 | nil) 40 | ((and *metric* (car inval-res) 41 | (not (equal (cadr inval-res) (cadr val-res)))) 42 | (if (< (abs (- (cadr inval-res) (cadr val-res))) 43 | *precision-threshold*) 44 | (format t "precision: ~s ~s~%" inval-res val-res) 45 | (format t "mismatch: ~s ~s~%" inval-res val-res)) 46 | nil) 47 | (t (format t "ok~%" inval-res val-res) 48 | t) 49 | )))) 50 | 51 | 52 | ;; Run INVAL vs. VAL test on a collection of problems and plans. 53 | ;; domain-file: Name of the domain file, without .pddl extension. 54 | ;; The domain file is assumed to reside in the same directory 55 | ;; as problem files. To search for per-problem domain files, 56 | ;; pass nil as this argument. 57 | ;; problem-file-pattern: a pattern (pathname with wildcards) for 58 | ;; the set of problem files to test on. 59 | ;; plan-dir: Directory where to search for plan files. May contain 60 | ;; wildcards (to search directory subtree). Must have trailing slash. 61 | ;; If nil, defaults to the same directory as problem files. Plan files 62 | ;; are assumed to to have the same name (or same first three letters) 63 | ;; as the problem file, and extension [.].soln[.], 64 | ;; in place of .pddl if the problem file has that extension. 65 | ;; Returns a two-element list with the number of successful and 66 | ;; failed tests. Each test run also prints the status of that test. 67 | 68 | (defun do-test-all (domain-file problem-file-pattern 69 | &key (plan-loc nil) (dry-run nil) (max-n nil)) 70 | (let ((pflist (sort (directory problem-file-pattern) 71 | #'string< :key #'namestring)) 72 | (n-ok 0) 73 | (n-failed 0)) 74 | (dolist (problem-file (if max-n (list-first-n pflist max-n) pflist)) 75 | (let ((checked-df (find-domain-for-problem domain-file problem-file))) 76 | (cond (checked-df 77 | (dolist (plan-file (plan-file-list-for-problem 78 | problem-file plan-loc)) 79 | (cond 80 | (dry-run 81 | (format t "found: ~a ~a ~a~%" 82 | checked-df problem-file plan-file)) 83 | (t 84 | (if (do-test checked-df problem-file plan-file) 85 | (incf n-ok) (incf n-failed))) 86 | ))) 87 | (t (format t "~&no domain file found for problem ~a~%" 88 | problem-file))))) 89 | (list n-ok n-failed))) 90 | 91 | (defun list-first-n (lst n) 92 | (if (> (length lst) n) (butlast lst (- (length lst) n)) lst)) 93 | 94 | (defun find-domain-for-problem (domain-file problem-pname) 95 | (if domain-file (probe-file 96 | (make-pathname 97 | :directory (pathname-directory problem-pname) 98 | :name domain-file :type "pddl")) 99 | (let ((f1 (probe-file 100 | (make-pathname 101 | :directory (pathname-directory problem-pname) 102 | :name (concatenate 'string (pathname-name problem-pname) 103 | "-domain") 104 | :type "pddl"))) 105 | (f2 (probe-file 106 | (make-pathname 107 | :directory (pathname-directory problem-pname) 108 | :name (concatenate 'string "domain_" 109 | (pathname-name problem-pname)) 110 | :type "pddl"))) 111 | (f3 (probe-file 112 | (make-pathname 113 | :directory (pathname-directory problem-pname) 114 | :name (concatenate 'string 115 | (subseq (pathname-name problem-pname) 0 3) 116 | "_domain") 117 | :type "pddl")))) 118 | (if f1 f1 119 | (if f2 f2 120 | f3))))) 121 | 122 | (defun plan-file-list-for-problem (problem-pname plan-loc) 123 | (cond 124 | (plan-loc 125 | (nconc 126 | (directory (concatenate 'string plan-loc 127 | (pathname-name problem-pname) 128 | "*.soln")) 129 | (directory (concatenate 'string plan-loc 130 | (subseq (pathname-name problem-pname) 0 3) 131 | "*.soln")) 132 | (directory (concatenate 'string plan-loc 133 | (pathname-name problem-pname) 134 | "*.soln.*")) 135 | )) 136 | (t (nconc 137 | (directory 138 | (namestring 139 | (make-pathname :directory (pathname-directory problem-pname) 140 | :name (pathname-name problem-pname) 141 | :type "*.soln"))) 142 | (directory 143 | (namestring 144 | (make-pathname :directory (pathname-directory problem-pname) 145 | :name (subseq (pathname-name problem-pname) 0 3) 146 | :type "*.soln"))) 147 | (directory 148 | (namestring 149 | (make-pathname :directory (pathname-directory problem-pname) 150 | :name (pathname-name problem-pname) 151 | :type "*.soln.*"))) 152 | )) 153 | )) 154 | 155 | 156 | ;; Run VAL on domain-file, problem-file and plan-file, which can be 157 | ;; either pathnames or strings (designating files). Returns a list 158 | ;; (ok value), where 'ok' (T/NIL) indicates the validation outcome 159 | ;; and 'value' the plan value, or NIL if VAL fails to parse or type 160 | ;; check any of the inputs. 161 | 162 | (defun run-val (domain-file problem-file plan-file &key (program "validate")) 163 | (let ((stream (ext:run-program 164 | program (list "-S" (path-as-string domain-file) 165 | (path-as-string problem-file) 166 | (path-as-string plan-file)) 167 | :input NIL :output :stream :error :output))) 168 | (if (null stream) 169 | (error "failed to run VAL executable (~s)" program)) 170 | (let ((res (let ((*readtable* *pddl-readtable*)) 171 | (read stream nil nil)))) 172 | (cond ((numberp res) (list t res)) 173 | ((eq res 'failed) (list nil nil)) 174 | (t nil))))) 175 | 176 | (defun path-as-string (pathname-or-string) 177 | (cond ((pathnamep pathname-or-string) 178 | (namestring pathname-or-string)) 179 | (t pathname-or-string))) 180 | 181 | 182 | 183 | ;; force update of symbol completion table on load 184 | ;; (if (find-package "ECL-READLINE") 185 | ;; (setq ecl-readline::*current-package* nil)) 186 | -------------------------------------------------------------------------------- /vapo-main.lsp: -------------------------------------------------------------------------------- 1 | ;;#!/usr/local/bin/ecl -shell 2 | 3 | ;; Note: load is only requried when used interactively or as a script. 4 | ;; (load "inval.lsp") 5 | ;; (load "vapo.lsp") 6 | ;; (load "simplify.lsp") 7 | 8 | ;; GCL version 9 | ;; (defun get-commandline-args () 10 | ;; (cdr si::*command-args*)) 11 | 12 | ;; ECL version 13 | (defun get-commandline-args () 14 | (cdr (ext:command-args))) 15 | 16 | ;; Note: When running as a script with ECL, use: 17 | ;; (defun get-commandline-args () 18 | ;; ext:*unprocessed-ecl-command-args*) 19 | 20 | (defun print-state-graph (sgraph) 21 | (format t "~&state graph~%") 22 | ;; print nodes 23 | (dotimes (index (length sgraph)) 24 | (let ((state (first (nth index sgraph))) 25 | (action (second (nth index sgraph))) 26 | (trans (third (nth index sgraph))) 27 | (is-goal (fourth (nth index sgraph))) 28 | (value (fifth (nth index sgraph))) 29 | ) 30 | (format t "~&S~a state: ~a~% goal? ~a~% action: ~a~% transitions: ~a~% expected reward: ~a~%" 31 | index state is-goal action trans value) 32 | ))) 33 | 34 | 35 | (defun is-action (exp) 36 | (and (listp exp) (symbolp (car exp)))) 37 | 38 | (defun is-action-list (exp) 39 | (and (listp exp) (is-action (car exp)))) 40 | 41 | ;; (defun print-executed-policy (sgraph &key (predicates-to-ignore nil) 42 | ;; (select-actions nil) 43 | ;; (to-stream t)) 44 | ;; (dolist (item sgraph) 45 | ;; ;; ... 46 | ;; (let ((rstate 47 | ;; (remove-if #'(lambda (atom) 48 | ;; (if (eq (car atom) '=) 49 | ;; (find (car (cadr atom)) predicates-to-ignore) 50 | ;; (find (car atom) predicates-to-ignore))) 51 | ;; (first item)))) 52 | ;; (format to-stream "~&(~s~% ~s)~%" rstate (second item)) 53 | ;; ))) 54 | 55 | (defun print-DOT-state (index state action is-goal value &key (label-states t) (state-dec nil)) 56 | (if label-states 57 | (format t " S~a [shape=rectangle,peripheries=~a,label=\"S~a~a~a (~a)\"];~%" 58 | index (if is-goal 2 1) index 59 | (if state-dec ": " "") 60 | (cond ((equal state-dec "action") action) 61 | ((equal state-dec "state") state) 62 | (t "")) 63 | value) 64 | (format t " S~a [shape=circle,peripheries=~a,label=\"\"];~%" 65 | index (if is-goal 2 1)))) 66 | 67 | 68 | (defun print-DOT (sgraph &key (dot-label t) (state-dec nil)) 69 | (format t "~&digraph policy {~%") 70 | ;; print nodes 71 | (dotimes (index (length sgraph)) 72 | (let ((state (first (nth index sgraph))) 73 | (action (second (nth index sgraph))) 74 | (trans (third (nth index sgraph))) 75 | (is-goal (fourth (nth index sgraph))) 76 | (value (fifth (nth index sgraph))) 77 | ) 78 | (print-DOT-state index state action is-goal value 79 | :label-states dot-label :state-dec state-dec) 80 | )) 81 | ;; print edges 82 | (dotimes (index (length sgraph)) 83 | (let ((state (first (nth index sgraph))) 84 | (action (second (nth index sgraph))) 85 | (translist (third (nth index sgraph))) 86 | (is-goal (fourth (nth index sgraph)))) 87 | (dolist (trans translist) 88 | (if (and (not (eql (first trans) 1)) dot-label) 89 | (format t " S~a -> S~a [label=\"~a\\n~a\"];~%" 90 | index (second trans) (first trans) (third trans)) 91 | (format t " S~a -> S~a [label=\"~a\"];~%" 92 | index (second trans) (third trans))) 93 | ))) 94 | (format t "~&}~%") 95 | ) 96 | 97 | (defun count-test-actions (sgel) 98 | (let ((action (second sgel))) 99 | (if action 100 | (if (and (> (length (symbol-name (car action))) 8) 101 | (string-equal (subseq (symbol-name (car action)) 0 8) "DO_TEST_")) 1 0) 102 | 0))) 103 | 104 | (defun count-exp (sgraph index stack cfun) 105 | (let ((val (funcall cfun (elt sgraph index))) 106 | (child-val-list nil)) 107 | (if (fourth (elt sgraph index)) 0 108 | (progn 109 | (dolist (pair (third (elt sgraph index))) 110 | (when (not (find (second pair) stack)) 111 | (let ((chv (count-exp 112 | sgraph (second pair) (cons (second pair) stack) cfun))) 113 | (when chv 114 | (setq child-val-list 115 | (cons (list (first pair) chv) 116 | child-val-list)))))) 117 | ;;(format t "~&S~a child values list: ~s~%" index child-val-list) 118 | (if child-val-list 119 | (let ((tp (reduce #'+ (mapcar #'first child-val-list)))) 120 | (+ (reduce #'+ (mapcar #'(lambda (pair) 121 | (* (/ (first pair) tp) (second pair))) 122 | child-val-list)) 123 | val)) 124 | nil))))) 125 | 126 | (defun vapo-main () 127 | ;; Process command line arguments and read input files. 128 | (if (endp (get-commandline-args)) (print-help)) 129 | (let ((*policy* nil) 130 | (*ambiguous-policy-resolver* nil) 131 | (*reward-exp* '(reward)) 132 | (*expand-goal-states* nil) 133 | (*exact-policy-match* nil) 134 | (*write-executed-policy* nil) 135 | (*ignore-static-predicates* nil) 136 | (*abstract-state-graph* nil) 137 | (*print-state-graph* nil) 138 | (*dot-state-decorate* nil) 139 | (*dot-state-labels* t) 140 | (*print-dot* nil) 141 | (*count-test-actions* nil) 142 | ) 143 | ;; parse arguments 144 | (do ((rem-arg-list (get-commandline-args) (cdr rem-arg-list))) 145 | ((endp rem-arg-list) t) 146 | (let ((arg (car rem-arg-list))) 147 | (cond ((equal arg "-v") 148 | (setq *verbosity* (+ *verbosity* 1))) 149 | ((equal arg "-q") 150 | (setq *verbosity* 0)) 151 | ((equal arg "-xgs") 152 | (setq *expand-goal-states* t)) 153 | ((equal arg "-epm") 154 | (setq *exact-policy-match* t)) 155 | ((equal arg "-isp") 156 | (setq *ignore-static-predicates* t)) 157 | ((equal arg "-aok") 158 | (setq *ambiguous-policy-resolver* #'first)) 159 | ((equal arg "-asg") 160 | (when (null (cdr rem-arg-list)) 161 | (format t "~&-asg requires an argument~%") 162 | (quit)) 163 | (setq *abstract-state-graph* 164 | (symbol-function (read-from-string (cadr rem-arg-list)))) 165 | (setq rem-arg-list (cdr rem-arg-list))) 166 | ((equal arg "-psg") 167 | (setq *print-state-graph* t)) 168 | ((equal arg "-wep") 169 | (setq *write-executed-policy* t)) 170 | ((equal arg "-rno") 171 | (setq *reward-exp* nil)) 172 | ((equal arg "-rca") 173 | (setq *reward-exp* '(- (reward) 1))) 174 | ((equal arg "-count-tests") 175 | (setq *count-test-actions* t)) 176 | ((equal arg "-dot") 177 | (setq *print-dot* t) 178 | (format t "~&/*~%")) 179 | ((equal arg "-dnl") 180 | (setq *dot-state-labels* nil)) 181 | ((equal arg "-dsd") 182 | (when (null (cdr rem-arg-list)) 183 | (format t "~&-dsd requires an argument (action, state)~%") 184 | (quit)) 185 | (setq *dot-state-decorate* (cadr rem-arg-list)) 186 | (setq rem-arg-list (cdr rem-arg-list))) 187 | ((equal arg "-tram") 188 | (setq *policy* (cons 'tram #'tram-policy-fn))) 189 | ((equal arg "-rand") 190 | (setq *policy* (cons 'random #'random-policy-fn))) 191 | ((and (= (length rem-arg-list) 1) ;; last arg is policy file 192 | (null *policy*)) 193 | (format t "~&reading policy from ~a...~%" arg) 194 | (let ((contents (read-file arg))) 195 | (setq *policy* 196 | (cond 197 | ;; if last exp in policy file is a lambda, 198 | ((eq (caar (last contents)) 'lambda) 199 | ;; eval all exps but the last... 200 | (do () ((= (length contents) 1)) 201 | (eval (car contents)) 202 | (setq contents (cdr contents))) 203 | ;; and return the last as the policy fun 204 | (cons arg (eval (car contents)))) 205 | ;; else, parse as a rule-based policy 206 | (t (parse-policy arg contents))) 207 | ))) 208 | (t 209 | (format t "~&reading ~a...~%" arg) 210 | (let ((contents (read-file arg))) 211 | (parse-file arg contents)))))) 212 | (when (null *policy*) 213 | (format t "~&a policy file (last argument) is required~%") 214 | (quit)) 215 | ;; main 216 | (format t "~&validating policy ~a...~%" (car *policy*)) 217 | (let ((result (validate-policy (cdr *policy*) *init* *goal* 218 | *actions* *types* *objects* *reward-exp* 219 | :reward-fluents (if (null *reward-exp*) '((reward)) nil) 220 | :ambiguous-policy-resolver *ambiguous-policy-resolver* 221 | :expand-goal-states *expand-goal-states* 222 | :exact *exact-policy-match* 223 | :predicates-to-ignore 224 | (if *ignore-static-predicates* 225 | (append 226 | (collect-static-predicates 227 | *predicates* *actions* *axioms*) 228 | (collect-static-functions 229 | *functions* *actions*)) 230 | nil) 231 | ))) 232 | (format t "~&policy is ~a~%expected reward = ~a (~a)~%" 233 | (if (first result) "executable and proper" 234 | "not valid or not proper") 235 | (second result) (float (second result))) 236 | (when *matched* 237 | (format t "~&~a of ~a rules matched in some state~%" 238 | (length *matched*) (length (cdr *policy*))) 239 | (when (and (< (length *matched*) (length (cdr *policy*))) 240 | (>= *verbosity* 1)) 241 | (format t "~&unmatched rules:~%") 242 | (dolist (rule (cdr *policy*)) 243 | (when (not (member rule *matched*)) 244 | (format t "~&~a~%" rule))) 245 | )) 246 | (when *abstract-state-graph* 247 | (when *print-state-graph* 248 | (format t "~&BEFORE ABSTRACTION~%") 249 | (print-state-graph (third result))) 250 | (setf (third result) 251 | (reduce-state-graph (third result) 252 | :abs-action-fn *abstract-state-graph*)) 253 | (format t "~&AFTER ABSTRACTION~%")) 254 | (when *print-state-graph* 255 | (print-state-graph (third result))) 256 | (when *count-test-actions* 257 | (let ((count (count-exp (third result) 0 nil #'count-test-actions))) 258 | (format t "~&expected number of test actions: ~a~%" count))) 259 | (when *print-dot* 260 | (format t "~&*/~%") 261 | (print-DOT (third result) 262 | :dot-label *dot-state-labels* 263 | :state-dec *dot-state-decorate*)) 264 | ;; (when *write-executed-policy* 265 | ;; (with-open-file 266 | ;; (stream "exec.pol" :direction :output) 267 | ;; (print-executed-policy 268 | ;; (third result) 269 | ;; :predicates-to-ignore (if *ignore-static-predicates* 270 | ;; (append 271 | ;; (collect-static-predicates 272 | ;; *predicates* *actions* *axioms*) 273 | ;; (collect-static-functions 274 | ;; *functions* *actions*)) 275 | ;; nil) 276 | ;; :to-stream stream))) 277 | ))) 278 | 279 | ;; Call main function inside an error handler. 280 | 281 | (handler-bind 282 | ((condition #'(lambda (erc) 283 | (format *error-output* "~&~A~&" erc) 284 | (quit)))) 285 | (vapo-main)) 286 | (quit) 287 | -------------------------------------------------------------------------------- /vapo.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;;;; 3 | ;; Validation of state-action policy for probabilistic domains (experimental). 4 | 5 | ;; policy can be either: 6 | ;; - A function of one argument. 7 | ;; It will be called with a state (list of literals) and is expected 8 | ;; to return a list of candidate ((...) (action)) pairs (rules). The 9 | ;; first component of the rule is intended to be a partial state (as 10 | ;; in an explicit rule-list policy, below) but nothing, other than 11 | ;; possibly the ambiguous-policy-resolver (see below) depends on this. 12 | ;; - A list of ((partial state) (action)) pairs (rules). 13 | ;; The rule antecedent (partial state) is a list of literals, which 14 | ;; may be positive or negative; fluent expressions are limited to 15 | ;; equalities or negated equalities. 16 | ;; The extraction of candidate rules for a given state depends on the 17 | ;; keyword argument 'exact: 18 | ;; - if 'exact is non-nil, candidate rules are whose antecendent 19 | ;; (partial state) match the state exactly, after all instances of 20 | ;; predicates (and functions) in 'predicates-to-ignore have been 21 | ;; removed from the state; 22 | ;; - if 'exact is nil, candidate rules are those whose antecedent is 23 | ;; matched (i.e., implied) by the state and that are most specific; 24 | ;; a partial state p is more specific than p' if p' is a strict 25 | ;; subset of p. 26 | ;; 27 | ;; A policy (of any type) is said to be ambiguous iff it returns more 28 | ;; than one candidate rule for any state encountered in its exectution. 29 | ;; If the keyword parameter ambiguous-policy-resolver is nil, then ambiguity 30 | ;; is treated as an execution error. Otherwise, ambiguous-policy-resolver 31 | ;; is expected to be a function that takes the list of candidate rules 32 | ;; and returns one of them. To pick an arbitrary element from the list, 33 | ;; set the parameter to #'first. 34 | ;; 35 | ;; init, goal, actions, type and objects are as in validate-plan. 36 | ;; 37 | ;; reward-exp is a (numeric) term, or nil. 38 | ;; 39 | ;; Returns a list (ok expected-reward state-graph), where: 40 | ;; ok: is t iff the policy is valid (executes without error), and is 41 | ;; proper 42 | ;; exepcted-reward: is the expected reward (negative cost); this value 43 | ;; may not be meaningful if the policy is not valid or not proper 44 | ;; state-graph: is the policy-reachable sub-graph of the state space 45 | ;; (as returned by build-state-graph). 46 | 47 | (defun validate-policy (policy init goal actions types objects reward-exp 48 | &key (exact nil) 49 | (predicates-to-ignore nil) 50 | (ambiguous-policy-resolver nil) 51 | (expand-goal-states nil) 52 | (reward-fluents nil)) 53 | (declare (special policy)) 54 | (when (not (member 'probabilistic *quoted-argument-predicates*)) 55 | (setq *quoted-argument-predicates* 56 | (cons 'probabilistic *quoted-argument-predicates*))) 57 | (let* ((policy-fn 58 | (cond 59 | ((functionp policy) 60 | (format t "~&using provided policy function~%") 61 | policy) 62 | (exact 63 | (format t "~&using exact policy match,~%ignoring predicates ~a~%" 64 | predicates-to-ignore) 65 | (lambda (state) 66 | (apply-exact-policy-to-state 67 | (remove-if #'(lambda (atom) 68 | (if (eq (car atom) '=) 69 | (find (car (cadr atom)) predicates-to-ignore) 70 | (find (car atom) predicates-to-ignore))) 71 | state) 72 | policy))) 73 | (t 74 | (format t "~&using most specific policy match~%") 75 | (lambda (state) 76 | (apply-most-specific-policy-to-state state policy))) 77 | )) 78 | (sg ;; list (ok graph) 79 | (build-state-graph policy-fn init goal actions types objects 80 | reward-exp 81 | (if (null reward-fluents) 82 | (fluents-in-term reward-exp) 83 | reward-fluents) 84 | :ambiguous-policy-resolver ambiguous-policy-resolver 85 | :expand-goal-states expand-goal-states))) 86 | (if (first sg) ;; policy executed without error 87 | (list (check-is-proper (second sg)) 88 | (if reward-exp (compute-expected-reward (second sg)) 0) 89 | (second sg)) 90 | (list nil 0 (second sg))) 91 | )) 92 | 93 | (defun fluents-in-term (term) 94 | (if (null term) nil 95 | (let ((res (eval-term term nil nil :report-errors nil))) 96 | (second res)))) 97 | 98 | ;; Check if a policy is proper. sgraph is the policy-reachable state graph 99 | ;; (as returned by build-state-graph). Returns t iff every terminal component 100 | ;; of the state graph is a goal state. 101 | 102 | (defun check-is-proper (sgraph) 103 | (let* ((outgoing (state-graph-edges sgraph)) 104 | (incoming (reverse-edges outgoing)) 105 | (comps (scc (length sgraph) outgoing incoming))) 106 | (when (>= *verbosity* 2) (format t "~&state graph SCCs:~%~a~%" comps)) 107 | (dolist (comp comps t) 108 | (when (is-terminal-component comp sgraph) 109 | (when (not (every #'(lambda (sg-index) (fourth (elt sgraph sg-index))) 110 | comp)) 111 | (when (>= *verbosity* 1) 112 | (format t "~&policy is NOT proper:~%component ~a is terminal but not a goal state~%" comp) 113 | (return nil)))) 114 | ))) 115 | 116 | ;; comp is a list of state-graph indices: return non-nil iff this is a 117 | ;; terminal component (no transition to any state outside of it). 118 | (defun is-terminal-component (comp sgraph) 119 | (dolist (sg-index comp t) 120 | (when (not (subsetp (mapcar #'second (third (elt sgraph sg-index))) comp)) 121 | (return nil)) 122 | )) 123 | 124 | (defun state-graph-edges (sgraph) 125 | (let ((outgoing nil)) 126 | (dotimes (index (length sgraph)) 127 | (let ((translist (third (elt sgraph index)))) 128 | (setq outgoing 129 | (cons (cons index (mapcar #'second translist)) outgoing)))) 130 | outgoing)) 131 | 132 | (defun reverse-edges (emap) 133 | (let ((rmap nil)) 134 | (dolist (entry emap) 135 | (dolist (tnode (rest entry)) 136 | (setq rmap (add-to-set-map tnode (first entry) rmap)))) 137 | rmap)) 138 | 139 | (defun compute-expected-reward (sgraph) 140 | (let ((m (make-array (list (length sgraph) (+ (length sgraph) 1)) 141 | :element-type 'rational :initial-element 0))) 142 | ;; make coefficient matrix 143 | (dotimes (index (length sgraph)) 144 | (let ((sg-node (elt sgraph index)) 145 | (rhs 0)) 146 | (cond 147 | ((fourth sg-node) ;; is a goal state 148 | (setf (aref m index index) 1)) 149 | (t ;; not a goal state 150 | (setf (aref m index index) 1) 151 | (dolist (trans (third sg-node)) 152 | (setf (aref m index (second trans)) 153 | (+ (aref m index (second trans)) (* -1 (first trans)))) 154 | (setq rhs (+ rhs (* (first trans) (third trans))))) 155 | (setf (aref m index (length sgraph)) rhs)) 156 | ))) 157 | ;; solve it 158 | (solve m) 159 | ;; set value (expected reward) for each state 160 | (dotimes (index (length sgraph)) 161 | (let ((sg-node (elt sgraph index))) 162 | (setf (fifth sg-node) (aref m index (length sgraph))))) 163 | ;; return value of S0 164 | (aref m 0 (length sgraph)) 165 | )) 166 | 167 | (defun solve (m) 168 | ;;(format t "~&input matrix:~%~a~%" m) 169 | ;; for each row from 0 .. n-1 170 | (dotimes (i (- (array-dimension m 0) 1)) 171 | ;; m[i,i] should be non-zero 172 | (assert (not (= (aref m i i) 0)) () "~&m[~a,~a] is ~a" (aref m i i) i i) 173 | ;; for each row from i+1 to n 174 | (dotimes (j (- (array-dimension m 0) (+ i 1))) 175 | (add-to-row m (+ i j 1) (* -1 (/ (aref m (+ i j 1) i) (aref m i i))) i)) 176 | ) 177 | ;;(format t "~&triangular matrix:~%~a~%" m) 178 | ;; back substitution 179 | (do ((i (- (array-dimension m 0) 2) (- i 1))) ((< i 0)) 180 | ;; v[i+1] = m[i+1,n] 181 | ;; for each row j in 0..i, subtract m[j,i+1] * v[i+1] from m[j,n], 182 | ;; and set m[j,i+1] to 0 183 | (dotimes (j (+ i 1)) 184 | (setf (aref m j (- (array-dimension m 1) 1)) 185 | (- (aref m j (- (array-dimension m 1) 1)) 186 | (* (aref m j (+ i 1)) 187 | (aref m (+ i 1) (- (array-dimension m 1) 1))))) 188 | (setf (aref m j (+ i 1)) 0)) 189 | ;; then set m[i,n] to m[i,n] / m[i,i] and m[i,i] to 1 190 | (setf (aref m i (- (array-dimension m 1) 1)) 191 | (/ (aref m i (- (array-dimension m 1) 1)) (aref m i i))) 192 | (setf (aref m i i) 1)) 193 | ;;(format t "~&matrix after substitution:~%~a~%" m) 194 | ) 195 | 196 | ;; add f * m[q,:] to m[r,:] 197 | (defun add-to-row (m r f q) 198 | (dotimes (k (array-dimension m 1)) 199 | (setf (aref m r k) (+ (aref m r k) (* f (aref m q k)))) 200 | )) 201 | 202 | ;; Build the policy-reachable state graph from init. 203 | ;; policy-fn is a function that takes a state and returns a list of 204 | ;; ((state) (action)) pairs 205 | ;; Returns: a list (ok graph), where ok is non-nil iff the policy 206 | ;; executes without error, and the the state graph is a list of 207 | ;; (state action transitions is-goal expected-reward) lists; 208 | ;; transitions is a list of (probability index reward) lists. 209 | 210 | (defun sg-node-state (sgnode) (first sgnode)) 211 | (defun sg-node-actions (sgnode) (second sgnode)) 212 | (defun sg-node-transitions (sgnode) (third sgnode)) 213 | (defun sg-node-isgoal (sgnode) (fourth sgnode)) 214 | (defun sg-node-reward (sgnode) (fifth sgnode)) 215 | 216 | (defun build-state-graph (policy-fn init goal actions types objects 217 | reward-exp reward-fluents 218 | &key (ambiguous-policy-resolver nil) 219 | (expand-goal-states nil)) 220 | (do ((sgraph (list (list init nil nil nil nil))) 221 | (queue (list 0)) 222 | (ok t) 223 | ) 224 | ((or (endp queue) (not ok)) (list ok sgraph)) 225 | (when (>= *verbosity* 2) 226 | (format t "~&expanding state ~s of ~s, |queue| = ~s~%" 227 | (car queue) (length sgraph) (length queue))) 228 | (let* ((next-state (first (nth (car queue) sgraph))) 229 | (goal-eval (eval-formula goal nil next-state types objects)) 230 | (result 231 | (if (and (first goal-eval) (second goal-eval) 232 | (not expand-goal-states)) nil 233 | (expand-state next-state policy-fn ambiguous-policy-resolver 234 | actions types objects reward-exp reward-fluents 235 | goal))) 236 | (exp-ok 237 | (if (and (first goal-eval) (second goal-eval) 238 | (not expand-goal-states)) t 239 | (first result))) 240 | (exp-action 241 | (if (and (first goal-eval) (second goal-eval) 242 | (not expand-goal-states)) nil 243 | (second result))) 244 | (exp-succs 245 | (if (and (first goal-eval) (second goal-eval) 246 | (not expand-goal-states)) nil 247 | (third result))) 248 | (trans nil)) 249 | (when (>= *verbosity* 3) 250 | (format t "~&goal: ~a~%result: ~a~%" goal-eval result)) 251 | ;; update graph with result of expansion, even if it failed 252 | (dolist (ps exp-succs) 253 | (let ((index (find-state-in-graph (second ps) sgraph))) 254 | (when (null index) 255 | ;; state is new 256 | (setq sgraph 257 | (nconc sgraph (list (list (second ps) nil nil nil nil)))) 258 | (setq index (- (length sgraph) 1)) 259 | (setq queue (nconc queue (list index)))) 260 | (setq trans (nconc trans (list (list (first ps) index (third ps))))))) 261 | (setf (second (nth (car queue) sgraph)) exp-action) 262 | (setf (third (nth (car queue) sgraph)) trans) 263 | (setf (fourth (nth (car queue) sgraph)) 264 | (and (first goal-eval) (second goal-eval))) 265 | (setq queue (cdr queue)) 266 | (when (not exp-ok) 267 | (when (>= *verbosity* 1) 268 | (format t "~&expanding state:~%~s~%failed~%" next-state)) 269 | (setq ok nil)) ;; break loop 270 | (when (not (second goal-eval)) 271 | (when (>= *verbosity* 1) 272 | (format t "~&goal formula ~s undefined in state~%~s~%" 273 | goal next-state)) 274 | (setq ok nil)) ;; break loop 275 | ))) 276 | 277 | (defun find-state-in-graph (state sgraph) 278 | (let ((index 0)) 279 | (loop 280 | (when (endp sgraph) (return nil)) 281 | (when (state-equals state (first (car sgraph))) 282 | (return index)) 283 | (setq index (+ index 1)) 284 | (setq sgraph (cdr sgraph)) 285 | ))) 286 | 287 | ;; Returns the list of ((state) (action)) pairs from the policy 288 | ;; that match the given state, using either exact or most specific 289 | ;; partial state matching. 290 | 291 | (defun apply-policy-to-state 292 | (state policy &key (exact nil) (predicates-to-ignore nil)) 293 | (cond 294 | (exact 295 | (apply-exact-policy-to-state 296 | (remove-if #'(lambda (atom) 297 | (find (car atom) predicates-to-ignore)) 298 | state) 299 | policy)) 300 | (t 301 | (apply-most-specific-policy-to-state state policy)) 302 | )) 303 | 304 | ;; Returns a list of the ((state) (action)) pairs from policy 305 | ;; where the state component matches the given state exactly. 306 | 307 | (defun apply-exact-policy-to-state (state policy) 308 | (let ((cands nil)) 309 | (dolist (item policy) 310 | (if (state-equals state (first item)) 311 | (setq cands (cons item cands)))) 312 | cands)) 313 | 314 | ;; Returns a list of the most specific ((partial state) (action)) 315 | ;; pairs applicable to state. 316 | 317 | (defvar *matched* nil) 318 | 319 | (defun apply-most-specific-policy-to-state (state policy) 320 | (let ((cands nil)) 321 | (dolist (item policy) 322 | (if (state-implies-partial-state state (first item)) 323 | (if (not (some #'(lambda (citem) 324 | (more-specific (first citem) (first item))) 325 | cands)) 326 | (setq cands 327 | (cons item 328 | (remove-if #'(lambda (citem) 329 | (more-specific (first item) (first citem))) 330 | cands)))))) 331 | (setq *matched* (union *matched* cands)) 332 | cands)) 333 | 334 | 335 | ;; Expand a state using a policy. 336 | ;; Returns a list (ok action successors), where successors is a list 337 | ;; of lists (probability state reward). Probabilities should sum to one. 338 | ;; If *macro-expand-deterministic* is non-nil, the successor state is 339 | ;; recursively expanded if the action is deterministic (i.e., there is 340 | ;; only one successor), and not a goal state. In this case, the second 341 | ;; item of the returned list is a list (sequence) of actions. 342 | 343 | (defvar *macro-expand-deterministic* t) 344 | 345 | (defun expand-state (state policy-fn ambiguous-policy-resolver actions types objects reward-exp reward-fluents goal) 346 | ;; (declare (special policy)) 347 | (let ((cands (funcall policy-fn state))) 348 | (cond 349 | ((endp cands) 350 | (when (>= *verbosity* 1) 351 | (format t "~&policy has no action for state ~s~%" state) 352 | ;; (let ((acands (apply-most-specific-policy-to-state state policy))) 353 | ;; (format t "~&alternative policy:~%~a~%" acands)) 354 | ) 355 | (list t nil nil)) 356 | ((> (length cands) 1) 357 | (when (>= *verbosity* 1) 358 | (format t "~&policy is ambiguous for state~% ~s~%" state) 359 | (dolist (item cands) 360 | (format t "~% ~s -> ~s matches~%" (first item) (second item)))) 361 | (if ambiguous-policy-resolver 362 | (let ((chosen (funcall ambiguous-policy-resolver cands))) 363 | (if chosen 364 | (if *macro-expand-deterministic* 365 | (expand-state-rec (second chosen) state policy-fn ambiguous-policy-resolver actions types objects reward-exp reward-fluents goal) 366 | (expand-state-with-action state (second chosen) actions 367 | types objects reward-exp 368 | reward-fluents)) 369 | ;; if resolver returns nil, return failure 370 | (list nil (mapcar #'second cands) nil))) 371 | ;; if resolver is nil (not set), return a failure 372 | (list nil (mapcar #'second cands) nil))) 373 | (t ;; exactly one policy rule applies 374 | (if *macro-expand-deterministic* 375 | (expand-state-rec (second (first cands)) state policy-fn ambiguous-policy-resolver actions types objects reward-exp reward-fluents goal) 376 | (expand-state-with-action state (second (first cands)) actions 377 | types objects reward-exp reward-fluents)) 378 | ) 379 | ))) 380 | 381 | (defun expand-state-rec (selected-action state policy-fn ambiguous-policy-resolver actions types objects reward-exp reward-fluents goal) 382 | (let ((res (expand-state-with-action state selected-action actions types objects reward-exp reward-fluents))) 383 | ;; (format t "~&res = ~a~%" res) 384 | (if (not (first res)) res 385 | (if (= (length (third res)) 1) 386 | (let ((goal-eval (eval-formula goal nil (second (first (third res))) types objects))) 387 | ;; if goal is undefined or satisfied, break 388 | (if (or (not (second goal-eval)) (first goal-eval)) 389 | (list (first res) (list (second res)) (third res)) 390 | ;; else expand recursively 391 | (let ((cres (expand-state (second (first (third res))) policy-fn ambiguous-policy-resolver actions types objects reward-exp reward-fluents goal))) 392 | (list (first cres) (cons selected-action (second cres)) 393 | (mapcar #'(lambda (oc) 394 | (list (first oc) (second oc) 395 | (if (and (third (first (third res))) (third oc)) 396 | (+ (third (first (third res))) (third oc)) 397 | nil))) 398 | (third cres)))) 399 | )) 400 | (list (first res) (list (second res)) (third res)) 401 | )) 402 | )) 403 | 404 | (defun expand-state-with-action (state action actions types objects reward-exp reward-fluents) 405 | (when (>= *verbosity* 2) 406 | (format t "~&applying action ~s~%" action)) 407 | (let ((ea (check-action action state actions types objects))) 408 | (cond 409 | ((not (first ea)) 410 | (when (>= *verbosity* 1) 411 | (format t "~&action ~s is undefined or inapplicable in state:~%~s~%" action state)) 412 | (list nil action nil)) 413 | (t (list t action 414 | (apply-probabilistic-action (cons action ea) state 415 | reward-exp reward-fluents)))) 416 | )) 417 | 418 | 419 | ;; Apply the effects of a probabilistic action to a state 420 | ;; ea is the list (action ok read add del abs rel); probabilistic 421 | ;; effects appear in add. 422 | ;; reward-exp is the reward expression (a term) 423 | ;; reward-fluents is a list of ground fluents that appear in the reward 424 | ;; expressions; these are not updated by relative effects (increase/decrease), 425 | ;; since their effect is applied only to the reward expression. 426 | ;; Returns a list of (probability state reward) lists. 427 | 428 | (defun apply-probabilistic-action (ea state reward-exp reward-fluents) 429 | (mapcar #'(lambda (oc) 430 | (list (first oc) 431 | (apply-effects 432 | (list (list (first ea) t nil (second oc) (third oc) 433 | (fourth oc) 434 | (remove-if #'(lambda (rel-eff) 435 | (member (second rel-eff) 436 | reward-fluents 437 | :test #'equal)) 438 | (fifth oc)) 439 | nil)) 440 | state) 441 | ;; compute transition reward 442 | (if reward-exp 443 | (eval-delta reward-exp reward-fluents (fifth oc) state) 444 | nil) 445 | )) 446 | (let ((oc (outcomes (fourth ea) nil (fifth ea) (sixth ea) (seventh ea)))) 447 | (when (>= *verbosity* 3) 448 | (format t "~&effect translated into outcomes:~%~a~%" oc)) 449 | oc) 450 | )) 451 | 452 | ;; Evaluate the effect of a set of fluent relative effects on a numeric term. 453 | ;; term is a (numeric) term 454 | ;; fluents is the list of fluents appearing in term 455 | ;; frels is a list of fluent relative effects (increase/decrease) 456 | ;; state is the state. 457 | (defun eval-delta (term fluents frels state) 458 | (let ((rstate (eval-relative-effects fluents frels state))) 459 | (if (first rstate) 460 | (let ((val (eval-term term nil (second rstate)))) 461 | ;; (format t "~&frels: ~a, rstate: ~a, term: ~a, value: ~a~%" frels rstate term val) 462 | (first val)) 463 | nil))) 464 | 465 | (defun eval-relative-effects (fluent-list frels state) 466 | (let ((rstate (mapcar #'(lambda (fluent) (list '= fluent 0)) fluent-list))) 467 | (dolist (fre frels (list t rstate)) 468 | (when (member (second fre) fluent-list :test #'equal) 469 | (when (not (member (first fre) '(increase decrease))) 470 | (format t "~&invalid fluent relative effect: ~a~%" fre) 471 | (return (list nil nil))) 472 | (let ((cfa (find-fluent-assignment (second fre) rstate)) 473 | (v1 (eval-term (third fre) nil state))) 474 | (when (not (first v1)) (return (list nil nil))) 475 | ;; (format t "~&update ~a with ~a~%" cfa v1) 476 | (setf (third cfa) 477 | (if (eq (car fre) 'increase) (+ (third cfa) (first v1)) 478 | (- (third cfa) (first v1)))))) 479 | ))) 480 | 481 | ;; Compute outcomes of a list 482 | ;; adds-and-prob is a list that may contain probabilistic and atomic 483 | ;; add effects. It is assumed that the effects contained in probabilistic 484 | ;; cases are non-conditional and non-quantified (though they may be 485 | ;; conjunctive). 486 | ;; adds is a list of atomic (unconditional) add effects. 487 | ;; dels is a list of atomic delete effects. 488 | ;; fabs is a list of absolute fluent effects (assignments). 489 | ;; dels is a list of relative fluent effects (increase/decrease) 490 | ;; Returns a list of outcomes (probability add del fabs frel), where add, 491 | ;; del, fabs frel are lists of atomic add/delete effects and fluent 492 | ;; assignment and relative effects. 493 | 494 | (defun outcomes (adds-and-prob adds dels fabs frel) 495 | (cond ((endp adds-and-prob) 496 | (list (list 1 adds dels fabs frel))) 497 | ((eq (caar adds-and-prob) 'probabilistic) 498 | (do ((cases (cdar adds-and-prob) (cddr cases)) 499 | (ocs nil) 500 | (ptotal 0)) 501 | ((endp cases) 502 | (if (< ptotal 1) 503 | (let ((no-case-ocs 504 | (outcomes (cdr adds-and-prob) adds dels fabs frel))) 505 | (append ocs (mapcar #'(lambda (oc) 506 | (cons (* (- 1 ptotal) (car oc)) 507 | (cdr oc))) 508 | no-case-ocs))) 509 | ocs)) 510 | (let* ((prob (car cases)) 511 | ;; collect-effects returns (ok read add del abs rel) 512 | (peff (collect-effects 513 | (cadr cases) t nil nil nil nil nil nil nil nil)) 514 | (case-ocs (outcomes (cdr adds-and-prob) 515 | (append (third peff) adds) 516 | (append (fourth peff) dels) 517 | (append (fifth peff) fabs) 518 | (append (sixth peff) frel) 519 | )) 520 | ) 521 | (setq ocs 522 | (append ocs (mapcar #'(lambda (oc) 523 | (cons (* prob (car oc)) (cdr oc))) 524 | case-ocs))) 525 | (setq ptotal (+ ptotal prob)) 526 | ))) 527 | (t (outcomes (cdr adds-and-prob) 528 | (cons (car adds-and-prob) adds) 529 | dels fabs frel)) 530 | )) 531 | 532 | 533 | ;; Trivial implementation of (partial) state implication (non-strict). 534 | 535 | (defun state-implies-partial-state (state pstate) 536 | (cond ((endp pstate) t) 537 | ((eq (caar pstate) 'not) 538 | (when (not (= (length (car pstate)) 2)) 539 | (error "ill-formed formula: ~s" (car (pstate)))) 540 | (if (not (find (second (car pstate)) state :test #'equal)) 541 | (state-implies-partial-state state (cdr pstate)) nil)) 542 | ((find (car pstate) state :test #'equal) 543 | (state-implies-partial-state state (cdr pstate))) 544 | (t nil))) 545 | 546 | ;; t iff more-spec-pstate is a more specific partial state than 547 | ;; less-spec-pstate. 548 | (defun more-specific (more-spec-pstate less-spec-pstate) 549 | (and (partial-state-contains more-spec-pstate less-spec-pstate) 550 | (> (length more-spec-pstate) (length less-spec-pstate)))) 551 | 552 | ;; t iff state-a contains state-b and they have the same size 553 | ;; (this assumes no duplicates!) 554 | (defun state-equals (state-a state-b) 555 | (and (= (length state-a) (length state-b)) 556 | (partial-state-contains state-a state-b))) 557 | 558 | 559 | (defun partial-state-contains (super-pstate sub-pstate) 560 | (cond ((endp sub-pstate) t) 561 | ((find (car sub-pstate) super-pstate :test #'equal) 562 | (partial-state-contains super-pstate (cdr sub-pstate))) 563 | (t nil))) 564 | 565 | ;; List applicable actions 566 | 567 | (defun tram-policy-fn (state) 568 | (let ((app (list-applicable-actions state *actions* *types* *objects*))) 569 | (if (= (length app) 1) (list (list state (car app))) nil))) 570 | 571 | (defun random-policy-fn (state) 572 | (let ((app (list-applicable-actions state *actions* *types* *objects*))) 573 | (if (null app) nil 574 | (list (list state (nth (random (length app)) app)))))) 575 | 576 | (defun list-applicable-actions (state actions types objects) 577 | (let ((facts (make-trie-from-list (remove-if #'(lambda (atom) (eq (car atom) '=)) state)))) 578 | (mapflat #'(lambda (action) 579 | (list-applicable-instances-of-action 580 | facts (car action) (cdr action) types objects)) 581 | actions))) 582 | 583 | (defun list-applicable-instances-of-action (facts aname adef types objects) 584 | (let ((param (assoc-val ':parameters adef)) 585 | (prec (assoc-val ':precondition adef))) 586 | (mapcar 587 | #'(lambda (binds) 588 | (cons aname 589 | (mapcar #'(lambda (pt) 590 | (if (assoc (car pt) binds) 591 | (cdr (assoc (car pt) binds)) pt)) 592 | param))) 593 | (satisfying-bindings prec facts nil param types objects)))) 594 | 595 | ;; Reduce a state graph by bisimilarity 596 | 597 | (defun abstract-sequence-match (acts1 acts2 distinguished) 598 | (cond ((and (endp acts1) (endp acts2)) t) 599 | ((endp acts1) ;; only acts1 empty 600 | (if (member (caar acts2) distinguished) nil 601 | (abstract-sequence-match acts1 (cdr acts2) distinguished))) 602 | ((endp acts2) ;; only acts2 empty 603 | (if (member (caar acts1) distinguished) nil 604 | (abstract-sequence-match (cdr acts1) acts2 distinguished))) 605 | ((member (caar acts1) distinguished) ;; first in acts1 is dist. 606 | (if (not (equal (car acts1) (car acts2))) ;; not eq first in acts2 607 | (if (member (caar acts2) distinguished) nil 608 | (abstract-sequence-match acts1 (cdr acts2) distinguished)) 609 | (abstract-sequence-match (cdr acts1) (cdr acts2) distinguished))) 610 | (t 611 | (abstract-sequence-match (cdr acts1) acts2 distinguished)) 612 | )) 613 | 614 | (defun abstract-all-actions (state aseq) nil) 615 | 616 | (defun reduce-state-graph (sgraph &key (abs-action-fn #'abstact-all-actions)) 617 | (let 618 | ;; make an array of the sgraph nodes for quicker indexing 619 | ((v (make-array (length sgraph) :initial-contents sgraph)) 620 | ;; 2-d bool array for state bisimilarity 621 | (m (make-array (list (length sgraph) (length sgraph)) 622 | :element-type 'cons :initial-element nil)) 623 | ;; 1-d index array to represent mftree set 624 | (s (make-array (length sgraph) 625 | :element-type 'integer :initial-element 0)) 626 | (q nil)) 627 | ;; mark pairs of goal states 628 | (dotimes (i (length sgraph)) 629 | (setf (aref m i i) t) ;; every state is bisim with itself 630 | (dotimes (j (- (length sgraph) i)) 631 | (when (and (sg-node-isgoal (aref v i)) 632 | (sg-node-isgoal (aref v (+ i j)))) 633 | (format t "~&~a and ~a are both goal states~%" i (+ i j)) 634 | (setf (aref m i (+ i j)) t) 635 | ))) 636 | ;; loop until no change 637 | (do ((done nil)) ;; declare a loop var 638 | (done nil) ;; exit when done is t 639 | (setq done t) 640 | ;; check all non-bisim pairs 641 | ;; (format t "~&begin iteration...~%") 642 | (dotimes (i (length sgraph)) 643 | (dotimes (j (length sgraph)) 644 | ;; (format t "~&~a, ~a: ~a ~a ~a~%~a~%~a~%" i j 645 | ;; (not (aref m i j)) 646 | ;; (abstract-sequence-match (sg-node-actions (aref v i)) 647 | ;; (sg-node-actions (aref v j)) 648 | ;; key-actions) 649 | ;; (mapcar #'(lambda (t1 t2) 650 | ;; (format t "~&t1 = ~a, t2 = ~a: ~a, ~a, ~a~%" 651 | ;; t1 t2 652 | ;; (eql (first t1) (first t2)) 653 | ;; (eql (third t1) (third t2)) 654 | ;; (aref m (second t1) (second t2))) 655 | ;; (and (eql (first t1) (first t2)) 656 | ;; (eql (third t1) (third t2)) 657 | ;; (aref m (second t1) (second t2)))) 658 | ;; (sg-node-transitions (aref v i)) 659 | ;; (sg-node-transitions (aref v j))) 660 | ;; (sg-node-transitions (aref v i)) 661 | ;; (sg-node-transitions (aref v j)) 662 | ;; ) 663 | (when (and 664 | (> j i) 665 | ;; not already marked 666 | (not (aref m i j)) 667 | ;; matching number of outcomes 668 | (eql (length (sg-node-transitions (aref v i))) 669 | (length (sg-node-transitions (aref v j)))) 670 | ;; matching actions 671 | (equal 672 | (funcall abs-action-fn 673 | (sg-node-state (aref v i)) 674 | (sg-node-actions (aref v i))) 675 | (funcall abs-action-fn 676 | (sg-node-state (aref v j)) 677 | (sg-node-actions (aref v j))) 678 | ) 679 | ;; transition probabilities and rewards match, and 680 | ;; resulting states are bisim 681 | (every #'(lambda (t1 t2) 682 | (and (eql (first t1) (first t2)) 683 | (eql (third t1) (third t2)) 684 | (aref m (second t1) (second t2)))) 685 | (sg-node-transitions (aref v i)) 686 | (sg-node-transitions (aref v j)))) 687 | (format t "~&~a and ~a are bisimilar~%" i j) 688 | (setf (aref m i j) t) 689 | (setq done nil)) 690 | )) 691 | (format t "~&end iteration, done = ~a...~%" done) 692 | ) ;; end loop 693 | (build-abstract-graph sgraph m abs-action-fn) 694 | )) 695 | 696 | ;; Find equivalence classes of sim relation (an nxn bool array); returns 697 | ;; an assoc list mapping class representatives to lists of eq class members. 698 | (defun eq-classes (sim) 699 | (let ((s (make-array (array-dimension sim 0) 700 | :element-type 'integer :initial-element 0)) 701 | (cls nil)) 702 | ;; init mftree 703 | (dotimes (i (array-dimension sim 0)) 704 | (setf (aref s i) i)) 705 | ;; build mftree of equivalence classes 706 | (dotimes (i (array-dimension sim 0)) 707 | (dotimes (j (- (array-dimension sim 0) i)) 708 | (when (aref sim i (+ i j)) 709 | (setf (aref s (find-root s (+ i j))) (find-root s i))))) 710 | ;; extract classes 711 | (dotimes (i (array-dimension sim 0)) 712 | (setq cls (add-to-set-map (find-root s i) i cls))) 713 | (values s cls))) 714 | 715 | ;; find the root (representative) of index in mftree 716 | (defun find-root (mftree index) 717 | (if (eql (aref mftree index) index) index 718 | (find-root mftree (aref mftree index)))) 719 | 720 | (defun find-class-index (classes index) 721 | (dotimes (i (length classes)) 722 | (when (member index (cdr (elt classes i))) 723 | (return-from find-class-index i))) 724 | (error "~&invalid index ~s for~%~s~%" index classes)) 725 | 726 | (defun compose-abstract-transitions (si-list sgraph classes) 727 | (let ((ats nil)) ;; abstract transitions 728 | (dolist (si si-list) 729 | (let ((sg-node (elt sgraph si))) 730 | ;; (format t "~&~a: ~a~%" si (sg-node-transitions sg-node)) 731 | (dolist (trans (sg-node-transitions sg-node)) 732 | (let ((atrans (list (find-class-index classes (second trans)) 733 | (third trans)))) 734 | (setq ats 735 | (reassoc 736 | atrans 737 | (+ (if (assoc-val atrans ats) (assoc-val atrans ats) 0) 738 | (/ (first trans) (length si-list))) 739 | ats)))) 740 | ;; (format t "~&~a: ~a~%" si ats) 741 | )) 742 | (mapcar #'(lambda (atrans) 743 | (cons (cdr atrans) (car atrans))) 744 | ats))) 745 | 746 | ;; Returns the abstract state graph built from sgraph and bisimilarity 747 | ;; relation. 748 | (defun build-abstract-graph (sgraph bisim abs-action-fn) 749 | (multiple-value-bind 750 | (mftree classes) (eq-classes bisim) 751 | (format t "~&~a equivalence classes~%" (length classes)) 752 | (mapcar 753 | #'(lambda (cls) 754 | (list 755 | (cdr cls) 756 | (funcall abs-action-fn 757 | (sg-node-state (elt sgraph (car cls))) 758 | (sg-node-actions (elt sgraph (car cls)))) 759 | (compose-abstract-transitions (cdr cls) sgraph classes) 760 | (sg-node-isgoal (elt sgraph (car cls))) 761 | (sg-node-reward (elt sgraph (car cls))) 762 | )) 763 | classes))) 764 | --------------------------------------------------------------------------------