Merge pull request #16 from rpgoldman/hddl-plan-grapher

HDDL plan grapher.

hddl-plan-grapher.asd

@@ -0,0 +1,35 @@
+;;; -------------------------------------------------------------------------
+;;; Copyright 2024, SIFT, LLC, Robert P. Goldman, and Ugur Kuter
+;;; Available under the BSD 3-clause license, see license.txt
+;;;---------------------------------------------------------------------------
+
+(defpackage :sift-hddl-plan-grapher-asd
+  (:use :common-lisp :asdf))
+
+(in-package :sift-hddl-plan-grapher-asd)
+
+(defsystem :hddl-plan-grapher
+    :name "SIFT-HDDL-UTILS"
+    :license "BSD 3-clause (see license.txt)"
+    :version (:read-file-form "version.lisp-expr")
+    :depends-on (hddl-utils hddl pddl-utils cl-dot)
+    ;; :in-order-to ((test-op (test-op hddl-utils/tests)))
+    :pathname "hddl-plan-grapher/"
+    :serial t
+    :components ((:file "package")      ; Package definition.
+                 (:file "decls")
+                 (:file "plan-grapher")
+                 ))
+
+#|
+(defsystem :hddl-plan-grapher/tests
+  :depends-on (pddl-utils fiveam)
+  :defsystem-depends-on (fiveam-asdf)
+  :version (:read-file-form "version.lisp-expr")
+  :serial t
+  :class :fiveam-tester-system
+  :test-names ((#:hddl-tests . :hddl-plan-grapher-tests))
+  :pathname "hddl-plan-grapher/tests/"
+  :components ((:file "hddl-data")
+               (:file "tests")))
+|#

hddl-plan-grapher/decls.lisp

@@ -0,0 +1,35 @@
+(in-package #:hddl-plan-grapher)
+
+(defclass hddl-plan-tree-graph ()
+  ((node-lookup-table
+    :initform (make-hash-table :test 'eql) ; node keys are integers.
+    :reader node-lookup-table
+    ))
+  (:documentation "A null class that the user may subclass to
+tailor display of HDDL plan trees."))
+
+(defclass has-task ()
+  ((task                                ; s-expression
+    :initarg :task
+    :reader task
+    )))
+
+(defclass action (has-task)
+  ()
+  )
+
+(defclass decomposition (has-task)
+  ((method-name
+    :initarg :method-name
+    :reader method-name
+    )
+   (children                            ; list of integers
+    :initarg :children
+    :reader children
+    ))
+  )
+
+
+
+(defgeneric graph-plan-tree (plan-tree &key attributes
+                                         graph-object))

hddl-plan-grapher/package.lisp

@@ -0,0 +1,6 @@
+(in-package #:common-lisp-user)
+
+(defpackage hddl-plan-grapher
+  (:use common-lisp iterate)
+  (:export #:hddl-plan-tree-graph
+           #:graph-plan-tree))

hddl-plan-grapher/plan-grapher.lisp

@@ -0,0 +1,71 @@
+(in-package #:hddl-plan-grapher)
+
+(defmethod graph-plan-tree ((plan-tree-file string)
+                            &key (attributes nil)
+                              (graph-object (make-instance 'hddl-plan-tree-graph)))
+  (let ((pathname (merge-pathnames (parse-namestring plan-tree-file)
+                                   (make-pathname :type "hddl"))))
+    (graph-plan-tree pathname
+                     :attributes attributes
+                     :graph-object graph-object)))
+
+(defmethod graph-plan-tree ((plan-tree-file pathname)
+                            &key (attributes nil)
+                                  (graph-object (make-instance 'hddl-plan-tree-graph)))
+  (let ((plan-tree (hddl-io:read-hddl-plan-file plan-tree-file)))
+    (unless (eq (first plan-tree) ':hddl-plan)
+      (error 'type-error :datum plan-tree :expected-type 'hddl-plan))
+    (graph-plan-tree plan-tree
+                     :attributes attributes
+                     :graph-object graph-object)))
+
+(defmethod graph-plan-tree (plan-tree &key (attributes nil)
+                                        (graph-object (make-instance 'hddl-plan-tree-graph)))
+  "Takes a SHOP plan forest (PLAN-FOREST) as input, and returns a CL-DOT graph object."
+  (let ((roots (getf (rest plan-tree) :roots))
+        (actions (getf (rest plan-tree) :actions))
+        (decompositions (getf (rest plan-tree) :decompositions)))
+    (build-lookup-table graph-object actions decompositions)
+    (cl-dot:generate-graph-from-roots graph-object roots attributes)))
+
+(defmethod build-lookup-table ((graph-object hddl-plan-tree-graph) actions decompositions)
+  (iter (for (index . task) in actions)
+    (setf (gethash index (node-lookup-table graph-object))
+          (make-instance 'action :task task)))
+  (iter (for (index task method-name . children) in decompositions)
+    (setf (gethash index (node-lookup-table graph-object))
+          (make-instance 'decomposition :task task
+                         :method-name method-name
+                         :children children))))
+
+(defmethod lookup ((g hddl-plan-tree-graph) (index integer))
+  (or (gethash index (node-lookup-table g))
+      (error "No graph node with index ~d" index)))
+
+(defmethod cl-dot:graph-object-node ((g hddl-plan-tree-graph) (index integer))
+  (cl-dot:graph-object-node g (lookup g index)))
+
+(defmethod cl-dot:graph-object-node ((g hddl-plan-tree-graph) (obj action))
+  (declare (ignorable g))
+  (make-instance 'cl-dot:node
+    :attributes `(:label ,(format nil "~A" (task obj))
+                         :shape :box)))
+
+(defmethod cl-dot:graph-object-node ((g hddl-plan-tree-graph) (obj decomposition))
+  (declare (ignorable g))
+  (make-instance 'cl-dot:node
+    :attributes `(:label ,(format nil "~A" (task obj))
+                  :style :rounded
+                  :shape :box)))
+
+(defmethod cl-dot:graph-object-points-to ((g hddl-plan-tree-graph) (index integer))
+  (cl-dot:graph-object-points-to g (lookup g index)))
+
+(defmethod cl-dot:graph-object-points-to ((g hddl-plan-tree-graph)(obj action))
+  (declare (ignorable g obj))
+  nil)
+
+
+(defmethod cl-dot:graph-object-points-to ((g hddl-plan-tree-graph)(obj decomposition))
+  (declare (ignorable g))
+  (children obj))

hddl-plan-grapher/test-data/rover-p03-original-plan.hddl

@@ -0,0 +1,41 @@
+==>
+1 (navigate rover1 waypoint3 waypoint2)
+2 (sample_soil rover1 rover1store waypoint2)
+3 (communicate_soil_data rover1 general waypoint2 waypoint2 waypoint0)
+4 (navigate rover0 waypoint1 waypoint0)
+5 (sample_rock rover0 rover0store waypoint0)
+6 (navigate rover0 waypoint0 waypoint1)
+7 (communicate_rock_data rover0 general waypoint0 waypoint1 waypoint0)
+8 (navigate rover1 waypoint2 waypoint3)
+9 (navigate rover1 waypoint3 waypoint0)
+10 (calibrate rover1 camera1 objective0 waypoint0)
+11 (take_image rover1 waypoint0 objective0 camera1 colour)
+12 (navigate rover1 waypoint0 waypoint1)
+13 (communicate_image_data rover1 general objective0 colour waypoint1 waypoint0)
+root 14
+14 (achieve-goals) -> communicate-one-soil-data 15 16
+15 (communicate-soil-data waypoint2 rover1) -> achieve-communicated-soil-data 17 18 2 19
+16 (achieve-goals) -> communicate-one-rock-data 20 21
+17 (move-to rover1 waypoint2) -> go-there 1 22
+18 (empty-store rover1store rover1) -> already-empty
+19 (transmit-soil waypoint2 waypoint2 rover1) -> have-line-of-sight-for-soil 3
+20 (communicate-rock-data waypoint0 rover0) -> achieve-communicated-rock-data 23 24 5 25
+21 (achieve-goals) -> communicate-one-image-data 26 27
+22 (move-to rover1 waypoint2) -> already-there
+23 (move-to rover0 waypoint0) -> go-there 4 28
+24 (empty-store rover0store rover0) -> already-empty
+25 (transmit-rock waypoint0 waypoint0 rover0) -> go-to-line-of-sight-for-rock 29 7
+26 (communicate-image-data objective0 colour rover1) -> achieve-communicated-image-data 30 31 11 32
+27 (achieve-goals) -> check-for-all-goals-done
+28 (move-to rover0 waypoint0) -> already-there
+29 (move-to rover0 waypoint1) -> go-there 6 33
+30 (calibrate-camera rover1 camera1) -> calibrate-the-camera 34 10
+31 (get-line-of-sight rover1 objective0 waypoint0) -> have-line-of-sight-for-photo
+32 (communicate-image waypoint0 waypoint0 rover1 objective0 colour) -> relocate-then-communicate-image 35 13
+33 (move-to rover0 waypoint1) -> already-there
+34 (move-to rover1 waypoint0) -> go-there 8 36
+35 (move-to rover1 waypoint1) -> go-there 12 37
+36 (move-to rover1 waypoint0) -> go-there 9 38
+37 (move-to rover1 waypoint1) -> already-there
+38 (move-to rover1 waypoint0) -> already-there
+<==

hddl-plan-grapher/test-data/rover-p03-repaired-plan.hddl

@@ -0,0 +1,40 @@
+==>
+1 (navigate rover1 waypoint3 waypoint2)
+2 (sample_soil rover1 rover1store waypoint2)
+3 (communicate_soil_data rover1 general waypoint2 waypoint2 waypoint0)
+4 (navigate rover0 waypoint1 waypoint0)
+5 (sample_rock rover0 rover0store waypoint0)
+6 (navigate rover0 waypoint0 waypoint1)
+7 (communicate_rock_data rover0 general waypoint0 waypoint1 waypoint0)
+8 (navigate rover1 waypoint2 waypoint3)
+9 (navigate rover1 waypoint3 waypoint0)
+10 (calibrate rover1 camera1 objective0 waypoint0)
+11 (calibrate rover1 camera1 objective0 waypoint0)
+12 (take_image rover1 waypoint0 objective0 camera1 colour)
+13 (navigate rover1 waypoint0 waypoint1)
+14 (communicate_image_data rover1 general objective0 colour waypoint1 waypoint0)
+root 15
+15 (achieve-goals) -> communicate-one-soil-data 16 17
+16 (communicate-soil-data waypoint2 rover1) -> achieve-communicated-soil-data 18 19 2 20
+17 (achieve-goals) -> communicate-one-rock-data 21 22
+18 (move-to rover1 waypoint2) -> go-there 1 23
+19 (empty-store rover1store rover1) -> already-empty
+20 (transmit-soil waypoint2 waypoint2 rover1) -> have-line-of-sight-for-soil 3
+21 (communicate-rock-data waypoint0 rover0) -> achieve-communicated-rock-data 24 25 5 26
+22 (achieve-goals) -> communicate-one-image-data 27 28
+23 (move-to rover1 waypoint2) -> already-there
+24 (move-to rover0 waypoint0) -> go-there 4 29
+25 (empty-store rover0store rover0) -> already-empty
+26 (transmit-rock waypoint0 waypoint0 rover0) -> go-to-line-of-sight-for-rock 30 7
+27 (communicate-image-data objective0 colour rover1) -> achieve-communicated-image-data 31 32 12 33
+28 (achieve-goals) -> check-for-all-goals-done
+29 (move-to rover0 waypoint0) -> already-there
+30 (move-to rover0 waypoint1) -> go-there 6 34
+31 (calibrate-camera rover1 camera1) -> calibrate-the-camera 35 11
+32 (get-line-of-sight rover1 objective0 waypoint0) -> have-line-of-sight-for-photo
+33 (communicate-image waypoint0 waypoint0 rover1 objective0 colour) -> relocate-then-communicate-image 36 14
+34 (move-to rover0 waypoint1) -> already-there
+35 (move-to rover1 waypoint0) -> already-there
+36 (move-to rover1 waypoint1) -> go-there 13 37
+37 (move-to rover1 waypoint1) -> already-there
+<==