Code for parsing derived predicates

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)

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

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

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