Merge pull request #10 from rpgoldman/hddl-to-json-fixes

Multiple fixes to the HDDL-to-JSON functions and application.

hddl-to-json-entrypoint.lisp

@@ -1,5 +1,43 @@
 (in-package :common-lisp-user)
 
+(defun usage (program-name)
+  (format *error-output* "~a [input-file [output-file]]~%" program-name)
+  (format *error-output* "Translate input HDDL into output JSON.~%")
+  (format *error-output* "If no command line arguments are present, reads from stdin and writes to stdout.~%")
+  (format *error-output* "If one command line argument is present, reads from argument file and writes to the same name, but with \".json\" extension.~%")
+  (format *error-output* "If two command line arguments are present, reads from first argument file and writes to second argument file.~%")
+  (finish-output *error-output*))
+
 (defun main (argv)
-  (declare (ignore argv))
-  (hddl-json:hddl-to-json *standard-input* *standard-output*))
+  (let (output-name
+        (tmpfile (unless (= (length argv) 1)
+                   (uiop:with-temporary-file (:pathname pn)
+                     pn))))
+    (case (length argv)
+      (1                                ; just the program name
+       (hddl-json:hddl-to-json *standard-input* *standard-output*))
+      (2                                ; just the input file name
+       (let* ((filename (second argv))
+              (pathname (parse-namestring filename))
+              (outfile (merge-pathnames (make-pathname :type "json")
+                                        pathname)))
+         (unless (probe-file filename)
+           (uiop:die 1 "Unable to open input HDDL file ~a" filename))
+         (uiop:with-input-file (in pathname :if-does-not-exist :error)
+           (uiop:with-output-file (out tmpfile :if-exists :supersede)
+             (hddl-json:hddl-to-json in out)))
+         (setf output-name outfile)))
+      (3
+       (let ((filename (second argv))
+             (outfile (third argv)))
+         (unless (probe-file filename)
+           (uiop:die 1 "Unable to open input HDDL file ~a" filename))
+         (uiop:with-input-file (in filename :if-does-not-exist :error)
+           (uiop:with-output-file (out tmpfile :if-exists :supersede)
+             (hddl-json:hddl-to-json in out)))
+         (setf output-name outfile)))
+      (otherwise
+       (usage (first argv))
+       (uiop:die 1 "Incorrect invocation: ~a requires 0, 1 or 2 arguments.")))
+    (when output-name (uiop:with-output-file (str output-name :if-exists :supersede)
+                        (uiop:run-program `("jq" "." ,(namestring tmpfile)) :output (list str :linewise t))))))

hddl-utils/commons.lisp

@@ -54,7 +54,8 @@
              :actions actions)))
 
 (defun make-problem (name &key requirements domain objects init goal
-                     (complete-p t))
+                            htn
+                            (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
@@ -63,6 +64,7 @@ arguments.  Unless COMPLETE-P is NIL, will check for mandatory components."
   (flet ((negated (fact) (eq (first fact) 'not)))
     (let ((domain (hddl-symbol domain))
           (objects (hddlify-tree objects))
+          (htn (hddlify-tree htn))
           (init (hddlify-tree init))
           (goal (hddlify-tree goal)))
       (when (some #'negated init)
@@ -74,12 +76,22 @@ 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) ,(hddl-symbol name))
-           (:domain ,domain)
-         ,@(when requirements
-                `((:requirements ,@requirements)))
-         (:objects ,@objects)
-         (:init ,@init)
-         (:goal ,goal)))))
+        (:domain ,domain)
+        ,@(when requirements
+            `((:requirements ,@requirements)))
+        (:objects ,@objects)
+        (:init ,@init)
+        (:htn ,@htn)
+        (:goal ,goal)))))
+
+(defun canonicalize-problem (problem)
+  (make-problem (problem-name problem)
+                :requirements (problem-requirements problem)
+                :domain (problem-domain problem)
+                :objects (problem-objects problem)
+                :init (problem-state problem)
+                :goal (problem-goal problem)
+                :htn (problem-htn problem)))
 
 
 ;;; misc utility
@@ -192,6 +204,13 @@ arguments.  Unless COMPLETE-P is NIL, will check for mandatory components."
 (defun problem-htn (problem)
   (problem-element problem :htn))
 
+(defsetf problem-htn (problem) (&rest htn)
+  `(let ((*pddl-package* hddl-io::*hddl-package*))
+
+     (setf (pddl-utils:problem-element ,problem :htn)
+           (hddlify-tree ,htn))))
+
+
 (defun domain-tasks (domain)
   (check-type domain domain)
   (remove-if-not #'(lambda (x) (eq x :task))

hddl-utils/package.lisp

@@ -93,5 +93,6 @@
    #:hddl-plan-to-pddl-plan
    #:hddl-domain-to-pddl-domain
    #:hddl-problem-to-pddl-problem
+   #:canonicalize-problem
    )
 )

utils/commons.lisp

@@ -48,6 +48,18 @@
                        problem)))
     (rest head)))
 
+(defsetf problem-element (problem pddl-keyword) (new-element)
+  (let ((cell-var (gensym)))
+    `(progn
+       (assert (problem-p ,problem))
+       (alexandria:if-let ((,cell-var (find-if #'(lambda(e)
+                                     (and (listp e) (eq (car e) ,pddl-keyword)))
+                                 ,problem)))
+         (setf (cdr ,cell-var) ,new-element)
+         (nconc ,problem (quote ((,pddl-keyword ,@new-element))))
+         ,new-element))))
+
+
 ;; Getter/setter functions for PDDL expressions:
 (defun domain-element (domain-expr pddl-keyword)
   (assert (domain-p domain-expr))