Minor fix to FLATTEN-CONJUNCTION and its tests.

Author: rpgoldman

hddl-utils/hddl-checker.lisp

@@ -220,15 +220,15 @@ including :task, :method, :action, :type, :predicate, :object"
     (unless (eq hyphen '-)
       (error "Ill-formed constant definition: ~a" `(,name ,hyphen ,type)))
     (set-name-type (domain-info name "constant definitions") :object)
-    (verify-type-name domain-info type "constant definitions"))))
+    (verify-type-name domain-info type "constant definitions")))
 
 (defun check-objects (domain-info objects)
   (iter (for (name hyphen type . rest) on objects by 'cdddr)
     (declare (ignorable rest))
     (unless (eq hyphen '-)
       (error "Ill-formed constant definition: ~a" `(,name ,hyphen ,type)))
     (set-name-type (domain-info name "problem object definitions") :object)
-    (verify-type-name domain-info type "problem object definitions"))))
+    (verify-type-name domain-info type "problem object definitions")))
 
 (defun check-initial-state (domain-info facts)
   (iter (for fact in facts)
@@ -277,7 +277,9 @@ Return the arity of the parameter list."
     (assert (eq keyword :method))
     (verify-task-name domain-info task-name (format nil "method task for definition of method ~a" name))
     (set-name-type (domain-info name (format nil "method definition of method named ~a" name)) :method)
-    (check-method-subtasks domain-info (rest (flatten-conjunction (method-subtasks method)))
+    (check-method-subtasks domain-info
+                           ;; this way puts subtasks in flattened-conj form and then takes the list of subtasks
+                           (rest (flatten-conjunction (method-subtasks method) nil))
                            (format nil "Subtasks of method ~a" name))))
 
 (defun check-method-subtasks (domain-info subtasks &optional context)

pddl-utils.asd

@@ -30,12 +30,7 @@
   :version (:read-file-form "version.lisp-expr")
   :serial t
   :class :fiveam-tester-system
-  :test-names ((#:problem-acc . :pddl-utils-tests)
-               (#:domain-acc . :pddl-utils-tests)
-               (#:domain-well-defined-p . :pddl-utils-tests)
-               (#:predicate-definitions-correct-p . :pddl-utils-tests)
-               (#:predicate-DONE-member-p . :pddl-utils-tests)
-               (#:types-correct-p . :pddl-utils-tests)
+  :test-names ((#:pddl-utils-tests . :pddl-utils-tests)
                )
   :pathname "utils/tests/"
   :components ((:file "package")

utils/commons.lisp

@@ -611,9 +611,10 @@ Translates to (constant . type) alist."
            (member (first sexp) predicates)
            t)))
 
-(defun flatten-conjunction (conj)
-  "Take an s-expression and, if it is a multilayer conjunction,
-make it a single-layer conjunction (intermediate AND's removed)."
+(defun flatten-conjunction (conj &optional (strict t))
+  "Take an s-expression and, if it is a multilayer conjunction.
+Returns a single-layer conjunction (intermediate AND's, if any,
+removed)."
   (labels ((flatten-conj-list (cl)
              (alexandria:mappend #'flatten-1 cl))
            (flatten-1 (conj)
@@ -628,6 +629,10 @@ make it a single-layer conjunction (intermediate AND's removed)."
                     (error "Cannot handle negations other than negated literals in flatten-conjunction: ~s"
                            conj)))
                (otherwise (list conj)))))
-    (if (eq (first conj) 'and)
-        `(and ,@ (flatten-conj-list (rest conj)))
-        (flatten-1 conj))))
+    (cond ((eq (first conj) 'and)
+           `(and ,@(flatten-conj-list (rest conj))))
+          (strict (error "FLATTEN-CONJUNCTION expects a conjunction as input, not an implicit conjunction."))
+          (t
+           ;; in this case we have an implicit conjunction with no initial 'and
+           ;; supply one.
+           `(and ,@(flatten-conj-list conj))))))

utils/tests/domain-test.lisp

@@ -1,5 +1,7 @@
 (in-package :pddl-utils-tests)
 
+(def-suite* pddl-utils-tests)
+
 (defparameter *tests-dir*
   (namestring
    (translate-logical-pathname
@@ -16,10 +18,10 @@
       (if (and (not (= pos 0))
                (eql (nth (1- pos) typed-list) '-))
         ;; then the TYPE-EL is a parent type itself.
-        ;; Skip this occurrence of the symbol in the TYPED-LIST. 
+        ;; Skip this occurrence of the symbol in the TYPED-LIST.
         (problem-free-p type-el (subseq typed-list (1+ pos)))
         ;; Otherwise, TYPE-EL is a subtype so look for if we have its
-        ;; parent. 
+        ;; parent.
         (let ((next-parent-type
                (position '- (subseq typed-list (1+ pos)))))
           (if (null next-parent-type)
@@ -32,7 +34,7 @@
               (return-from problem-free-p nil))
             ;; Else there is a parent type. That's ok, but check if this
             ;; TYPE-EL belongs to another parent now...
-            (problem-free-p type-el 
+            (problem-free-p type-el
                             (subseq typed-list (1+
                                                 next-parent-type)))))))
     t))
@@ -79,14 +81,14 @@
           (read-planning-input
            (merge-pathnames "airport-nontemporal-adl-domain.pddl"
                             *tests-dir*))))
-    (setf (domain-predicates domain) 
+    (setf (domain-predicates domain)
           (append (domain-predicates domain)
                   (list '(DONE))))
     (&body)))
 
 
 (test types-correct-p
-      (with-fixture 
+      (with-fixture
           well-defined-pddl-objects ()
           ;; Check for simple subtyping -- every
           ;; type should have a parent type, except the type
@@ -95,13 +97,13 @@
                          (problem-free-p element
                                          (copy-tree (domain-types domain))))
                      (domain-types domain)))))
-                           
+
 (test predicate-definitions-correct-p
       (with-fixture
           well-defined-pddl-objects ()
           ;; Check for duplicates...
           (is (every #'(lambda (element)
-                         (let ((element-trail 
+                         (let ((element-trail
                                 (member element (domain-predicates
                                                  domain)
                                         :test #'equal)))
@@ -116,10 +118,10 @@
                       :test #'equal))))
 
 (test domain-well-defined-p
-  (with-fixture 
+  (with-fixture
       well-defined-pddl-objects ()
       (is (every #'keywordp (domain-reqs domain)))
-      (is (every #'(lambda (el) 
+      (is (every #'(lambda (el)
                      (member el *pddl-keywords* :test #'eql))
                  (domain-reqs domain)))))
 
@@ -224,4 +226,8 @@
            (flatten-conjunction *conjunction*)))
   (is
    (equalp *flattened-nested-conjunction*
-           (flatten-conjunction *nested-conjunction*))))
+           (flatten-conjunction *nested-conjunction*)))
+  (is (equalp *conjunction*
+              (flatten-conjunction (rest *conjunction*) nil)))
+  ;; check strict mode
+  (signals error (flatten-conjunction (rest *conjunction*) t)))

utils/tests/package.lisp

@@ -4,9 +4,11 @@
   (:use common-lisp pddl-utils)
   (:import-from :pddl-utils #:flatten-conjunction)
   (:import-from fiveam
+                #:def-suite*
                 #:def-fixture
                 #:with-fixture
                 #:is
                 #:test
+                #:signals
                 #:run!
                 #:*on-error*))