From c7638772d9c5f2dbdfc8db3997a41a8120c33849 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 31 May 2024 16:17:50 -0500 Subject: [PATCH] First complete HDDL plan grapher. --- hddl-plan-grapher.asd | 35 +++++++++ hddl-plan-grapher/decls.lisp | 35 +++++++++ hddl-plan-grapher/package.lisp | 6 ++ hddl-plan-grapher/plan-grapher.lisp | 71 +++++++++++++++++++ .../test-data/rover-p03-original-plan.hddl | 41 +++++++++++ .../test-data/rover-p03-repaired-plan.hddl | 40 +++++++++++ 6 files changed, 228 insertions(+) create mode 100644 hddl-plan-grapher.asd create mode 100644 hddl-plan-grapher/decls.lisp create mode 100644 hddl-plan-grapher/package.lisp create mode 100644 hddl-plan-grapher/plan-grapher.lisp create mode 100644 hddl-plan-grapher/test-data/rover-p03-original-plan.hddl create mode 100644 hddl-plan-grapher/test-data/rover-p03-repaired-plan.hddl diff --git a/hddl-plan-grapher.asd b/hddl-plan-grapher.asd new file mode 100644 index 0000000..24e9d46 --- /dev/null +++ b/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"))) +|# diff --git a/hddl-plan-grapher/decls.lisp b/hddl-plan-grapher/decls.lisp new file mode 100644 index 0000000..451b58a --- /dev/null +++ b/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)) diff --git a/hddl-plan-grapher/package.lisp b/hddl-plan-grapher/package.lisp new file mode 100644 index 0000000..4b6570e --- /dev/null +++ b/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)) diff --git a/hddl-plan-grapher/plan-grapher.lisp b/hddl-plan-grapher/plan-grapher.lisp new file mode 100644 index 0000000..7a6d10e --- /dev/null +++ b/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)) diff --git a/hddl-plan-grapher/test-data/rover-p03-original-plan.hddl b/hddl-plan-grapher/test-data/rover-p03-original-plan.hddl new file mode 100644 index 0000000..7fd39cc --- /dev/null +++ b/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 +<== diff --git a/hddl-plan-grapher/test-data/rover-p03-repaired-plan.hddl b/hddl-plan-grapher/test-data/rover-p03-repaired-plan.hddl new file mode 100644 index 0000000..2f05736 --- /dev/null +++ b/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 +<==