Merge pull request #13 from rpgoldman/fix-flatten-conjunction

Fix corner cases in FLATTEN-CONJUNCTION

hddl-utils/commons.lisp

@@ -73,7 +73,8 @@
 arguments.  Unless COMPLETE-P is NIL, will check for mandatory components."
   (when complete-p
     (unless domain (error "DOMAIN argument is mandatory."))
-    (unless goal (error "GOAL argument is mandatory.")))
+    ;; (unless goal (error "GOAL argument is mandatory."))
+    )
   (flet ((negated (fact) (eq (first fact) 'not)))
     (let ((domain (hddl-symbol domain))
           (objects (hddlify-tree objects))
@@ -157,7 +158,7 @@ arguments.  Unless COMPLETE-P is NIL, will check for mandatory components."
   `(:method ,method-name :parameters ,(copy-tree params)
      :task ,task-sexpr
      :precondition ,(copy-tree precond)
-     :ordered-subtasks (and ,@(copy-tree tasks))))
+     :ordered-subtasks ,(flatten-conjunction (copy-tree tasks) nil)))
 
 (defun method-subtasks (method)
   (cond ((find :ordered-subtasks method)
@@ -169,7 +170,8 @@ arguments.  Unless COMPLETE-P is NIL, will check for mandatory components."
         (t (error "Unable to find subtasks in method definition:~%~s" method))))
 
 (defsetf method-subtasks (method) (subtasks)
-  `(let ((subtasks (hddlify-tree ,subtasks)))
+  `(let ((subtasks (when subtasks       ; nil is just nil...
+                     (flatten-conjunction (hddlify-tree ,subtasks) nil))))
      (cond ((getf ,method :ordered-subtasks nil)
             (setf (getf ,method :ordered-subtasks) subtasks))
            ((getf ,method :tasks nil)

utils/commons.lisp

@@ -618,7 +618,10 @@ removed).
   Special cases:
   1. NIL should yield (AND)
   2. Simple proposition (<pred> <arg>*) should be wrapped in AND as
-     (AND (<pred> <arg>*))"
+     (AND (<pred> <arg>*))
+  3. Implicit conjunction ((<pred> <arg>*)+) should be turned into
+a standard (explicit) conjunction.
+  If STRICT is non-NIL, then cases 2 and 3 should raise an error."
   (labels ((flatten-conj-list (cl)
              (alexandria:mappend #'flatten-1 cl))
            (flatten-1 (conj)
@@ -640,8 +643,9 @@ removed).
            (if strict
                (error "FLATTEN-CONJUNCTION expects a conjunction, but got a proposition: ~s" conj)
                `(and ,conj)))
-          (strict (error "FLATTEN-CONJUNCTION expects a conjunction as input, not an implicit conjunction."))
+          (strict
+           (error "FLATTEN-CONJUNCTION expects a conjunction, but got an IMPLICIT conjunction (list of conjuncts):~%~s" conj))
           (t
            ;; in this case we have an implicit conjunction with no initial 'and
-           ;; supply one.
+           ;; and this is *not* strict-mode.  supply an 'and.
            `(and ,@(flatten-conj-list conj))))))

utils/tests/domain-test.lisp

@@ -221,18 +221,20 @@
 
 
 (test flatten-conjunction
-      (is
-       (equalp *conjunction*
-               (flatten-conjunction *conjunction*)))
-      (is
-       (equalp *flattened-nested-conjunction*
-               (flatten-conjunction *nested-conjunction*)))
-      (is (equalp *conjunction*
-                  (flatten-conjunction (rest *conjunction*) nil)))
-      (is (equalp '(and) (flatten-conjunction nil nil)))
-      (is (equalp '(and (hunt snark))
-                  (flatten-conjunction '(hunt snark) nil)))
-      ;; check strict mode
-      (signals error (flatten-conjunction '(hunt snark) t))
-      (signals error (flatten-conjunction (rest *conjunction*) t))
-      )
+  (is
+   (equalp *conjunction*
+           (flatten-conjunction *conjunction*)))
+  (is
+   (equalp *flattened-nested-conjunction*
+           (flatten-conjunction *nested-conjunction*)))
+  (is (equalp *conjunction*
+              (flatten-conjunction (rest *conjunction*) nil)))
+  (is (equalp '(and) (flatten-conjunction nil nil)))
+  (is (equalp '(and (hunt snark))
+              (flatten-conjunction '(hunt snark) nil)))
+  (is (equalp *explicitified-conjuction*
+              (flatten-conjunction *implicit-conjuction* nil)))
+  ;; check strict mode
+  (signals error (flatten-conjunction '(hunt snark) t))
+  (signals error (flatten-conjunction (rest *conjunction*) t))
+  (signals error (flatten-conjunction *implicit-conjuction*) t))

utils/tests/pddl-data.lisp

@@ -5,14 +5,14 @@
      (pddlify-tree ',sexp)))
 
 (def-pddl-data pddl-utils-tests::*pddl-keywords*
-  (:adl :strips 
-    :typing 
+  (:adl :strips
+    :typing
     :negative-preconditions
     :disjunctive-preconditions
     :equality
     :existential-preconditions
     :universal-preconditions
-    :quantified-preconditions 
+    :quantified-preconditions
     :existential-preconditions
     :universal-preconditions
     :conditional-effects
@@ -377,3 +377,14 @@
     (not (toll-area ?l1))
     (road ?l1 ?l2)
     (l10-0)))
+
+(def-pddl-data *implicit-conjuction*
+  ((foo bar)
+   (baz bletch bongle)
+   (bill fred)))
+
+(def-pddl-data *explicitified-conjuction*
+  (and
+   (foo bar)
+   (baz bletch bongle)
+   (bill fred)))

version.lisp-expr

@@ -1 +1 @@
-"3.2.1"
+"3.2.2"