diff --git a/utils/commons.lisp b/utils/commons.lisp index e25b193..7ffcd1b 100644 --- a/utils/commons.lisp +++ b/utils/commons.lisp @@ -82,13 +82,14 @@ ;; makers (defun make-domain (name &key (requirements +DEFAULT-REQUIREMENTS+ requirements-supplied-p) - constants predicates + constants predicates derived functions actions types) (unless requirements-supplied-p (cerror "defaulting to ~s" "requirements flags for domain not supplied" +DEFAULT-REQUIREMENTS+)) (let ((constants (pddlify-tree constants)) (predicates (pddlify-tree predicates)) + (derived (pddlify-tree derived)) (actions (pddlify-tree actions)) (types (pddlify-tree types)) (functions (cond @@ -109,6 +110,7 @@ (:types ,@types) (:constants ,@constants) (:predicates ,@predicates) + ,@derived ,@(when functions `((:functions ,@functions))) ,@actions))) @@ -118,24 +120,26 @@ (unless (has-element-p old-domain :requirements) (error "No requirements in domain. Don't know how to handle it.")) (domain-element old-domain :requirements))) - (types - (when (has-element-p old-domain :types) - (domain-types old-domain))) - (predicates - (when (has-element-p old-domain :predicates) - (domain-predicates old-domain))) + (types + (when (has-element-p old-domain :types) + (domain-types old-domain))) + (predicates + (when (has-element-p old-domain :predicates) + (domain-predicates old-domain))) + (derived (domain-derived-predicates old-domain)) (functions (when (has-element-p old-domain :functions) (domain-functions old-domain))) - (constants - (when (has-element-p old-domain :constants) - (domain-constants old-domain))) - (actions (domain-actions old-domain))) + (constants + (when (has-element-p old-domain :constants) + (domain-constants old-domain))) + (actions (domain-actions old-domain))) (make-domain (domain-name old-domain) :requirements requirements :types types :constants constants :predicates predicates + :derived derived :functions functions :actions actions))) @@ -178,6 +182,9 @@ arguments. Unless COMPLETE-P is NIL, will check for mandatory components." ;;; misc utility (defun pddlify (sym &optional (package *pddl-package*)) + "Return a symbol with the same name as SYM, but that is +interned in PACKAGE (defaults to current binding of +*PDDL-PACKAGE*)." (cond ((eq (symbol-package sym) (find-package package)) sym) ((eq (symbol-package sym) (find-package :keyword)) @@ -387,6 +394,53 @@ arguments. Unless COMPLETE-P is NIL, will check for mandatory components." (alexandria:appendf (cddr ,domain) ,action-list))) +(defun domain-derived-predicates (domain) + (assert (domain-p domain)) + (remove-if-not #'(lambda (x) (eq x :derived)) + (cddr domain) :key 'first)) + +(defsetf domain-derived-predicates (domain) (derived-list) + `(progn + (check-type ,domain domain) + ;; remove all the old derived predicates + (setf (cddr ,domain) + (remove :derived (cddr ,domain) + :key #'first)) + (alexandria:appendf (cddr ,domain) + ,derived-list))) + +(defun derived-predicate-name (derived-predicate) + (assert (eq (first derived-predicate) :derived)) + (first (second derived-predicate))) + +(defsetf derived-predicate-name (derived-predicate) (name) + `(progn + (assert (eq (first ,derived-predicate) :derived)) + (setf (first (second ,derived-predicate)) (pddlify ,name)))) + +(defun derived-predicate-params (derived-predicate) + (assert (eq (first derived-predicate) :derived)) + (rest (second derived-predicate))) + +(defsetf derived-predicate-params (derived-predicate) (params) + `(progn + (assert (eq (first ,derived-predicate) :derived)) + (setf + (rest (second ,derived-predicate)) + (pddlify-tree ,params)))) + +(defun derived-predicate-def (derived-predicate) + "Return the logical expression that gives the truth value of a +DERIVED-PREDICATE, which is the third element of the derived predicate +s-expression." + (assert (eq (first derived-predicate) :derived)) + (third derived-predicate)) + +(defsetf derived-predicate-def (derived-predicate) (defn) + `(progn + (assert (eq (first ,derived-predicate) :derived)) + (setf (third ,derived-predicate) (pddlify-tree ,defn)))) + (defun domain-action (domain name &key (error-p t)) (assert (domain-p domain)) (let ((all-actions (domain-actions domain))) @@ -554,9 +608,9 @@ dispense with quotes and keyword arguments." pddl-domain2)))) (parent-type-table (make-hash-table :test #'eql)) all-types new-typed-list) - + (setf all-types (all-types typed-list)) - (loop + (loop with start = 0 with lst = typed-list for pos = (position '- lst) diff --git a/utils/package.lisp b/utils/package.lisp index 2c29493..665075d 100644 --- a/utils/package.lisp +++ b/utils/package.lisp @@ -43,21 +43,25 @@ #:domain-element ;; specific accessors - #:domain-name - #:problem-name - #:problem-domain - #:problem-objects - #:problem-state - #:problem-goal - #:problem-requirements - #:domain-predicates - #:domain-reqs - #:domain-requirements - #:domain-types - #:domain-functions - #:domain-actions - #:domain-action - #:domain-constants + #:domain-name + #:problem-name + #:problem-domain + #:problem-objects + #:problem-state + #:problem-goal + #:problem-requirements + #:domain-predicates + #:domain-reqs + #:domain-requirements + #:domain-types + #:domain-functions + #:domain-actions + #:domain-action + #:domain-constants + #:domain-derived-predicates + #:derived-predicate-name + #:derived-predicate-params + #:derived-predicate-def ;; #:action-precondition diff --git a/utils/tests/domain-test.lisp b/utils/tests/domain-test.lisp index f9e3c18..b52e992 100644 --- a/utils/tests/domain-test.lisp +++ b/utils/tests/domain-test.lisp @@ -288,3 +288,65 @@ (pprint-pddl domain str) :close-stream (is-true (probe-file pn))))) + +(test psr-large-derived-predicates-domain-load + (let ((domain (read-planning-input + (merge-pathnames "psr-large-derived-predicates-adl-domain.pddl" + *tests-dir*)))) + (is-true domain) + (let ((derived-predicates (domain-derived-predicates domain))) + (is (= (length derived-predicates) 4)) + (is (equal + (pddlify-tree (sort '(unsafe upstream affected fed) #'string-lessp)) + (sort (mapcar #'derived-predicate-name derived-predicates) #'string-lessp))) + (let ((sorted-preds (sort (copy-list derived-predicates) #'string-lessp :key 'derived-predicate-name))) + (is (equalp + (pddlify-tree '((?x - device) ; AFFECTED + (?l - line) ; FED + (?x - device ?sx - side) ; UNSAFE + (?x - DEVICE ?sx - SIDE ?y - DEVICE ?sy - SIDE))) ; UPSTREAM + (mapcar #'derived-predicate-params sorted-preds))) + (is (equalp + (pddlify-tree '((and (breaker ?x) + (exists (?sx - SIDE) (unsafe ?x ?sx))) ; AFFECTED + (exists (?x - DEVICE) + (and (closed ?x) + (or (and (ext ?l ?x side1) + (or (breaker ?x) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (breaker ?y) + (upstream ?y ?sy ?x side2)))))) + (and (ext ?l ?x side2) + (or (breaker ?x) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (breaker ?y) + (upstream ?y ?sy ?x side1))))))))) ; FED + (and (closed ?x) + (or (and (= ?sx side1) + (exists (?l - LINE) + (and (ext ?l ?x side2) + (or (faulty ?l) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (con ?x side2 ?y ?sy) + (unsafe ?y ?sy)))))))) + (and (= ?sx side2) + (exists (?l - LINE) + (and (ext ?l ?x side1) + (or (faulty ?l) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (con ?x side1 ?y ?sy) + (unsafe ?y ?sy)))))))))) ; UNSAFE + (and (closed ?x) + (or (and (= ?sx side1) (con ?x side2 ?y ?sy)) + (and (= ?sx side2) (con ?x side1 ?y ?sy)) + (exists (?z - DEVICE) + (and (closed ?z) + (or (and (con ?z side1 ?y ?sy) + (upstream ?x ?sx ?z side2)) + (and (con ?z side2 ?y ?sy) + (upstream ?x ?sx ?z side1))))))))) ; UPSTREAM + (mapcar #'derived-predicate-def sorted-preds))))))) diff --git a/utils/tests/psr-large-derived-predicates-adl-domain.pddl b/utils/tests/psr-large-derived-predicates-adl-domain.pddl new file mode 100644 index 0000000..0201518 --- /dev/null +++ b/utils/tests/psr-large-derived-predicates-adl-domain.pddl @@ -0,0 +1,86 @@ +(define (domain psr) + (:requirements :adl :derived-predicates) + (:types DEVICE SIDE LINE) + (:constants side1 side2 - SIDE earth - DEVICE) + (:predicates (ext ?l - LINE ?x - DEVICE ?s - SIDE) + (breaker ?x - DEVICE) + (closed ?x - DEVICE) + (faulty ?l - LINE) + (con ?x - DEVICE ?sx - SIDE ?y - DEVICE ?sy - SIDE) + + (upstream ?x - DEVICE ?sx - SIDE ?y - DEVICE ?sy - SIDE) + (unsafe ?x - DEVICE ?sx - SIDE) + (affected ?x - DEVICE) + (fed ?l - LINE)) + + (:derived (upstream ?x - DEVICE ?sx - SIDE ?y - DEVICE ?sy - SIDE) + (and (closed ?x) + (or (and (= ?sx side1) (con ?x side2 ?y ?sy)) + (and (= ?sx side2) (con ?x side1 ?y ?sy)) + (exists (?z - DEVICE) + (and (closed ?z) + (or (and (con ?z side1 ?y ?sy) + (upstream ?x ?sx ?z side2)) + (and (con ?z side2 ?y ?sy) + (upstream ?x ?sx ?z side1)))))))) + + + (:derived (unsafe ?x - DEVICE ?sx - SIDE) + (and (closed ?x) + (or (and (= ?sx side1) + (exists (?l - LINE) + (and (ext ?l ?x side2) + (or (faulty ?l) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (con ?x side2 ?y ?sy) + (unsafe ?y ?sy)))))))) + (and (= ?sx side2) + (exists (?l - LINE) + (and (ext ?l ?x side1) + (or (faulty ?l) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (con ?x side1 ?y ?sy) + (unsafe ?y ?sy))))))))))) + + (:derived (affected ?x - DEVICE) + (and (breaker ?x) + (exists (?sx - SIDE) (unsafe ?x ?sx)))) + + (:derived (fed ?l - LINE) + (exists (?x - DEVICE) + (and (closed ?x) + (or (and (ext ?l ?x side1) + (or (breaker ?x) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (breaker ?y) + (upstream ?y ?sy ?x side2)))))) + (and (ext ?l ?x side2) + (or (breaker ?x) + (exists (?y - DEVICE) + (exists (?sy - SIDE) + (and (breaker ?y) + (upstream ?y ?sy ?x side1)))))))))) + + (:action open + :parameters (?x - DEVICE) + :precondition (and (not (= ?x earth)) + (closed ?x) + (forall (?b - DEVICE) (not (affected ?b)))) + :effect (not (closed ?x))) + + (:action close + :parameters (?x - DEVICE) + :precondition (and (not (= ?x earth)) + (not (closed ?x)) + (forall (?b - DEVICE) (not (affected ?b)))) + :effect (closed ?x)) + + (:action wait + :parameters () + :precondition (exists (?b - DEVICE) (affected ?b)) + :effect (forall (?b - DEVICE) (when (affected ?b) (not (closed ?b))))) + +)