Add support for metric fluents.

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
 ;;;---------------------------------------------------------------------------
 

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))))
+    (collecting (cons constant type))))

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)))
 

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
 

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))))

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)
+          )
+         )
+
+  )