From fde8d6b9b1eab9329aa07c12b6ca98fa4ecdcd6f Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 10 Apr 2020 12:08:04 -0500 Subject: [PATCH] Add support for :fluents requirement. Parse the :functions section of a domain appropriately if the :fluents requirement is present. Add simple test. --- pddl-utils.asd | 2 +- utils/commons.lisp | 63 ++++++++--- utils/decls.lisp | 4 + utils/package.lisp | 24 +---- utils/tests/metric-fluents-tests.lisp | 38 +++++++ utils/tests/numerical-rover-pfile01.pddl | 69 ++++++++++++ utils/tests/numerical-rover.pddl | 129 +++++++++++++++++++++++ 7 files changed, 292 insertions(+), 37 deletions(-) create mode 100644 utils/tests/metric-fluents-tests.lisp create mode 100644 utils/tests/numerical-rover-pfile01.pddl create mode 100644 utils/tests/numerical-rover.pddl diff --git a/pddl-utils.asd b/pddl-utils.asd index b37254e..59440be 100644 --- a/pddl-utils.asd +++ b/pddl-utils.asd @@ -1,5 +1,5 @@ ;;; ------------------------------------------------------------------------- -;;; Copyright 2011-2016, SIFT, LLC, Robert P. Goldman, and Ugur Kuter +;;; Copyright 2011-2020, SIFT, LLC, Robert P. Goldman, and Ugur Kuter ;;; Available under the BSD 3-clause license, see license.txt ;;;--------------------------------------------------------------------------- diff --git a/utils/commons.lisp b/utils/commons.lisp index 4a560ce..3bb819d 100644 --- a/utils/commons.lisp +++ b/utils/commons.lisp @@ -1,5 +1,5 @@ ;;; ------------------------------------------------------------------------- -;;; Copyright 2011-2016, SIFT, LLC, Robert P. Goldman, and Ugur Kuter +;;; Copyright 2011-2020, SIFT, LLC, Robert P. Goldman, and Ugur Kuter ;;; Available under the BSD 3-clause license, see license.txt ;;;--------------------------------------------------------------------------- @@ -63,14 +63,26 @@ domain-expr)) ;; makers -(defun make-domain (name &key (requirements '(:adl)) constants predicates actions - types) +(defun make-domain (name &key (requirements +DEFAULT-REQUIREMENTS+ requirements-supplied-p) + constants predicates + 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)) (actions (pddlify-tree actions)) (types (pddlify-tree types)) - (functions (when (member :action-costs requirements) - (pddlify-tree '((total-cost) - number))))) + (functions (cond + ((member :action-costs requirements) + (pddlify-tree '((total-cost) - number))) + (functions + (unless (member :fluents requirements) + (cerror + "Continue and add :fluents to requirements" + "Functions provided, but :fluents requirement not specified.") + (push :functions requirements)) + (pddlify-tree functions))))) (if (member :durative-actions requirements) (assert (every #'durative-action-sexp-p actions)) (assert (every #'action-sexp-p actions))) @@ -83,7 +95,7 @@ ,@actions))) (defun canonicalize-domain (old-domain) - (let ((requirements + (let* ((requirements (progn (unless (has-element-p old-domain :requirements) (error "No requirements in domain. Don't know how to handle it.")) @@ -94,6 +106,9 @@ (predicates (when (has-element-p old-domain :predicates) (domain-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))) @@ -103,10 +118,11 @@ :types types :constants constants :predicates predicates + :functions functions :actions actions))) (defun make-problem (name &key requirements domain objects init goal - (complete-p t)) + (complete-p t)) "Make a new PDDL problem s-expression initialized as per the keyword arguments. Unless COMPLETE-P is NIL, will check for mandatory components." (when complete-p @@ -117,6 +133,8 @@ arguments. Unless COMPLETE-P is NIL, will check for mandatory components." (objects (pddlify-tree objects)) (init (pddlify-tree init)) (goal (pddlify-tree goal))) + ;; these two fixers should be tweaked going forward, to permit both + ;; the repair actions and just leaving the domain as it is. (when (some #'negated init) (cerror "Remove negated initial facts." "Negated facts in :init are unnecessary and may break some planners.") @@ -126,12 +144,12 @@ arguments. Unless COMPLETE-P is NIL, will check for mandatory components." "Some duplicated facts in init. This is known to break some planners.") (setf init (remove-duplicates init :test 'equal))) `(,(pddl-symbol 'pddl:define) (,(pddl-symbol 'pddl:problem) ,(pddlify name)) - (:domain ,domain) - ,@(when requirements - `((:requirements ,@requirements))) - (:objects ,@objects) - (:init ,@init) - (:goal ,goal))))) + (:domain ,domain) + ,@(when requirements + `((:requirements ,@requirements))) + (:objects ,@objects) + (:init ,@init) + (:goal ,goal))))) (defmethod copy-domain ((domain list)) (copy-tree domain)) @@ -310,6 +328,12 @@ arguments. Unless COMPLETE-P is NIL, will check for mandatory components." (remove-if-not #'(lambda (x) (eq x :action)) (cddr domain) :key 'first)) +(defun domain-action (domain name) + (assert (domain-p domain)) + (let ((all-actions (domain-actions domain))) + (or (find name all-actions :key 'second) + (error "No such action ~a in domain ~a" name (domain-name domain))))) + (defun remove-domain-actions (domain) (assert (domain-p domain)) `(,(pddl-symbol 'pddl:define) ,(second domain) @@ -451,6 +475,13 @@ dispense with quotes and keyword arguments." (domain-reqs pddl-domain2)) :test #'equal)) +(defun all-types (typed-list) + (union '(pddl:object) + (remove-duplicates + (iter (for type in typed-list) + (unless (eq type '-) + (collecting type)))))) + (defun merge-domain-types (pddl-domain1 pddl-domain2) (let ((typed-list (append (pddl-pprinter::canonicalize-types (domain-types pddl-domain1)) @@ -459,9 +490,7 @@ dispense with quotes and keyword arguments." (parent-type-table (make-hash-table :test #'eql)) all-types new-typed-list) - (setf all-types (loop for type in typed-list - unless (eql type '-) - collect type)) + (setf all-types (all-types typed-list)) (loop with start = 0 with lst = typed-list @@ -557,4 +586,4 @@ their typing information removed." Translates to (constant . type) alist." (iterate (for (constant dash type . nil) on typed-list by 'cdddr) (assert (eq dash '-)) - (collecting (cons constant type)))) \ No newline at end of file + (collecting (cons constant type)))) diff --git a/utils/decls.lisp b/utils/decls.lisp index 3563c3c..13e4362 100644 --- a/utils/decls.lisp +++ b/utils/decls.lisp @@ -5,6 +5,10 @@ (in-package :pddl-utils) +(defparameter +DEFAULT-REQUIREMENTS+ '(:adl :typing) + "The default set of requirements: will be assumed if domain requirements +are not explicitly supplied.") + (defun pddl-interned (sym) (eq (symbol-package sym) (find-package :pddl))) diff --git a/utils/package.lisp b/utils/package.lisp index 369826b..a861c1e 100644 --- a/utils/package.lisp +++ b/utils/package.lisp @@ -1,27 +1,10 @@ ;;;--------------------------------------------------------------------- -;;; Copyright (c) 2009-2016 Smart Information Flow Technologies, +;;; Copyright (c) 2009-2020 Smart Information Flow Technologies, ;;; d/b/a SIFT, LLC. ;;; ;;; This code made available according to the BSD 3-clause license (see ;;; license.txt) ;;; -;;; GOVERNMENT PURPOSE RIGHTS -;;; -;;; Contract No. FA8650-06-C-7606, -;;; Contractor Name Smart Information Flow Technologies, LLC -;;; d/b/a SIFT, LLC -;;; Contractor Address 211 N 1st Street, Suite 300 -;;; Minneapolis, MN 55401 -;;; Expiration Date 5/2/2011 -;;; -;;; The Government's rights to use, modify, reproduce, release, -;;; perform, display, or disclose this software are restricted by -;;; paragraph (b)(2) of the Rights in Noncommercial Computer Software -;;; and Noncommercial Computer Software Documentation clause contained -;;; in the above identified contract. No restrictions apply after the -;;; expiration date shown above. Any reproduction of the software or -;;; portions thereof marked with this legend must also reproduce the -;;; markings. ;;;--------------------------------------------------------------------- ;;; File Description: ;;; @@ -70,9 +53,12 @@ #:domain-types #:domain-functions #:domain-actions + #:domain-action #:domain-constants + + ;; #:action-precondition - #:action-effects + #:action-effect #:action-name #:action-params diff --git a/utils/tests/metric-fluents-tests.lisp b/utils/tests/metric-fluents-tests.lisp new file mode 100644 index 0000000..ba5f845 --- /dev/null +++ b/utils/tests/metric-fluents-tests.lisp @@ -0,0 +1,38 @@ +(in-package :pddl-utils-tests) + +(def-fixture rover-domain () + (let ((domain (read-pddl-file (asdf:system-relative-pathname "pddl-utils" "utils/tests/numerical-rover.pddl")))) + (&body))) + +(def-fixture navigate-action () + (let ((act (domain-action domain 'pddl::navigate))) + (&body))) + +(def-fixture rover-problem () + (let ((problem (read-pddl-file (asdf:system-relative-pathname "pddl-utils" "utils/tests/numerical-rover-pfile01.pddl")))) + (&body))) + +(test check-numerical-domain-items + (with-fixture rover-domain () + (is (alexandria:set-equal + '(sift-pddl::rover sift-pddl::waypoint sift-pddl::store + sift-pddl::camera sift-pddl::mode sift-pddl::lander + sift-pddl::objective sift-pddl:object) + (pddl-utils::all-types (domain-types domain)))) + (is (alexandria:set-equal + 'sift-pddl::(energy recharges) + (mapcar #'first (domain-functions domain)))) + ;; check some metric preconditions and effects... + (with-fixture navigate-action () + (is (eq 'and (first (action-precondition act)))) + (is (member 'pddl::(>= (energy ?x) 8) (rest (action-precondition act)) + :test 'equalp)) + (is (eq 'and (first (action-effect act)))) + (is (member 'pddl::(decrease (energy ?x) 8) (rest (action-effect act)) + :test 'equalp))))) + + +(test check-numerical-problem-items + (with-fixture rover-problem () + (is (member 'pddl::(= (recharges) 0) (problem-state problem) :test 'equalp)) + (is (member 'pddl::(= (energy rover0) 0) (problem-state problem) :test 'equalp)))) diff --git a/utils/tests/numerical-rover-pfile01.pddl b/utils/tests/numerical-rover-pfile01.pddl new file mode 100644 index 0000000..821f8e2 --- /dev/null +++ b/utils/tests/numerical-rover-pfile01.pddl @@ -0,0 +1,69 @@ +(define (problem roverprob01) (:domain rover) + (:objects + general - lander + colour high_res low_res - mode + rover0 - rover + rover0store - store + waypoint0 waypoint1 waypoint2 waypoint3 - waypoint + camera0 - camera + objective0 objective1 - objective + ) + (:init + (visible waypoint1 waypoint0) + (visible waypoint0 waypoint1) + (visible waypoint2 waypoint0) + (visible waypoint0 waypoint2) + (visible waypoint2 waypoint1) + (visible waypoint1 waypoint2) + (visible waypoint3 waypoint0) + (visible waypoint0 waypoint3) + (visible waypoint3 waypoint1) + (visible waypoint1 waypoint3) + (visible waypoint3 waypoint2) + (visible waypoint2 waypoint3) + (= (recharges) 0) + (at_soil_sample waypoint0) + (in_sun waypoint0) + (at_rock_sample waypoint1) + (at_soil_sample waypoint2) + (at_rock_sample waypoint2) + (at_soil_sample waypoint3) + (at_rock_sample waypoint3) + (at_lander general waypoint0) + (channel_free general) + (= (energy rover0) 50) + (in rover0 waypoint3) + (available rover0) + (store_of rover0store rover0) + (empty rover0store) + (equipped_for_soil_analysis rover0) + (equipped_for_rock_analysis rover0) + (equipped_for_imaging rover0) + (can_traverse rover0 waypoint3 waypoint0) + (can_traverse rover0 waypoint0 waypoint3) + (can_traverse rover0 waypoint3 waypoint1) + (can_traverse rover0 waypoint1 waypoint3) + (can_traverse rover0 waypoint1 waypoint2) + (can_traverse rover0 waypoint2 waypoint1) + (on_board camera0 rover0) + (calibration_target camera0 objective1) + (supports camera0 colour) + (supports camera0 high_res) + (visible_from objective0 waypoint0) + (visible_from objective0 waypoint1) + (visible_from objective0 waypoint2) + (visible_from objective0 waypoint3) + (visible_from objective1 waypoint0) + (visible_from objective1 waypoint1) + (visible_from objective1 waypoint2) + (visible_from objective1 waypoint3) + ) + + (:goal (and + (communicated_soil_data waypoint2) + (communicated_rock_data waypoint3) + (communicated_image_data objective1 high_res) + ) + ) + + ) \ No newline at end of file diff --git a/utils/tests/numerical-rover.pddl b/utils/tests/numerical-rover.pddl new file mode 100644 index 0000000..dbf9969 --- /dev/null +++ b/utils/tests/numerical-rover.pddl @@ -0,0 +1,129 @@ +;; Enrico Scala (enricos83@gmail.com) and Miquel Ramirez (miquel.ramirez@gmail.com) +(define (domain rover) + (:requirements :typing :fluents) + (:types rover - object waypoint - object store - object camera - object mode - object + lander - object objective - object) + (:predicates (in ?x - rover ?y - waypoint) + (at_lander ?x - lander ?y - waypoint) + (can_traverse ?r - rover ?x - waypoint ?y - waypoint) + (equipped_for_soil_analysis ?r - rover) + (equipped_for_rock_analysis ?r - rover) + (equipped_for_imaging ?r - rover) + (empty ?s - store) + (have_rock_analysis ?r - rover ?w - waypoint) + (have_soil_analysis ?r - rover ?w - waypoint) + (full ?s - store) + (calibrated ?c - camera ?r - rover) + (supports ?c - camera ?m - mode) + (available ?r - rover) + (visible ?w - waypoint ?p - waypoint) + (have_image ?r - rover ?o - objective ?m - mode) + (communicated_soil_data ?w - waypoint) + (communicated_rock_data ?w - waypoint) + (communicated_image_data ?o - objective ?m - mode) + (at_soil_sample ?w - waypoint) + (at_rock_sample ?w - waypoint) + (visible_from ?o - objective ?w - waypoint) + (store_of ?s - store ?r - rover) + (calibration_target ?i - camera ?o - objective) + (on_board ?i - camera ?r - rover) + (channel_free ?l - lander) + (in_sun ?w - waypoint) + + ) + + (:functions (energy ?r - rover) (recharges) ) + + (:action navigate + :parameters (?x - rover ?y - waypoint ?z - waypoint) + :precondition (and (can_traverse ?x ?y ?z) (available ?x) (in ?x ?y) + (visible ?y ?z) (>= (energy ?x) 8) + ) + :effect (and (decrease (energy ?x) 8) (not (in ?x ?y)) (in ?x ?z) + ) + ) + + (:action recharge + :parameters (?x - rover ?w - waypoint) + :precondition (and (in ?x ?w) (in_sun ?w) (<= (energy ?x) 80)) + :effect (and (increase (energy ?x) 20) (increase (recharges) 1)) + ) + + (:action sample_soil + :parameters (?x - rover ?s - store ?p - waypoint) + :precondition (and (in ?x ?p)(>= (energy ?x) 3) (at_soil_sample ?p) (equipped_for_soil_analysis ?x) (store_of ?s ?x) (empty ?s) + ) + :effect (and (not (empty ?s)) (full ?s) (decrease (energy ?x) 3) (have_soil_analysis ?x ?p) (not (at_soil_sample ?p)) + ) + ) + + (:action sample_rock + :parameters (?x - rover ?s - store ?p - waypoint) + :precondition (and (in ?x ?p) (>= (energy ?x) 5)(at_rock_sample ?p) (equipped_for_rock_analysis ?x) (store_of ?s ?x)(empty ?s) + ) + :effect (and (not (empty ?s)) (full ?s) (decrease (energy ?x) 5) (have_rock_analysis ?x ?p) (not (at_rock_sample ?p)) + ) + ) + + (:action drop + :parameters (?x - rover ?y - store) + :precondition (and (store_of ?y ?x) (full ?y) + ) + :effect (and (not (full ?y)) (empty ?y) + ) + ) + + (:action calibrate + :parameters (?r - rover ?i - camera ?t - objective ?w - waypoint) + :precondition (and (equipped_for_imaging ?r) (>= (energy ?r) 2)(calibration_target ?i ?t) (in ?r ?w) (visible_from ?t ?w)(on_board ?i ?r) + ) + :effect (and (decrease (energy ?r) 2)(calibrated ?i ?r) ) + ) + + + + + (:action take_image + :parameters (?r - rover ?p - waypoint ?o - objective ?i - camera ?m - mode) + :precondition (and (calibrated ?i ?r) + (on_board ?i ?r) + (equipped_for_imaging ?r) + (supports ?i ?m) + (visible_from ?o ?p) + (in ?r ?p) + (>= (energy ?r) 1) + ) + :effect (and (have_image ?r ?o ?m)(not (calibrated ?i ?r))(decrease (energy ?r) 1) + ) + ) + + (:action communicate_soil_data + :parameters (?r - rover ?l - lander ?p - waypoint ?x - waypoint ?y - waypoint) + :precondition (and (in ?r ?x)(at_lander ?l ?y)(have_soil_analysis ?r ?p) + (visible ?x ?y)(available ?r)(channel_free ?l)(>= (energy ?r) 4) + ) + :effect (and (communicated_soil_data ?p)(available ?r)(decrease (energy ?r) 4) + ) + ) + + (:action communicate_rock_data + :parameters (?r - rover ?l - lander ?p - waypoint ?x - waypoint ?y - waypoint) + :precondition (and (in ?r ?x)(at_lander ?l ?y)(have_rock_analysis ?r ?p)(>= (energy ?r) 4) + (visible ?x ?y)(available ?r)(channel_free ?l) + ) + :effect (and + (communicated_rock_data ?p)(available ?r)(decrease (energy ?r) 4) + ) + ) + + + (:action communicate_image_data + :parameters (?r - rover ?l - lander ?o - objective ?m - mode ?x - waypoint ?y - waypoint) + :precondition (and (in ?r ?x)(at_lander ?l ?y)(have_image ?r ?o ?m)(visible ?x ?y)(available ?r)(channel_free ?l)(>= (energy ?r) 6) + ) + :effect (and + (communicated_image_data ?o ?m)(available ?r)(decrease (energy ?r) 6) + ) + ) + + )