Skip to content

Commit 7810818

Browse files
rpgoldmanrpgoldman
authored
Merge pull request #16 from rpgoldman/hddl-plan-grapher
HDDL plan grapher.
2 parents 1737cde + c763877 commit 7810818

6 files changed

+228
-0
lines changed

‎hddl-plan-grapher.asd

+35
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
;;; -------------------------------------------------------------------------
2+
;;; Copyright 2024, SIFT, LLC, Robert P. Goldman, and Ugur Kuter
3+
;;; Available under the BSD 3-clause license, see license.txt
4+
;;;---------------------------------------------------------------------------
5+
6+
(defpackage :sift-hddl-plan-grapher-asd
7+
(:use :common-lisp :asdf))
8+
9+
(in-package :sift-hddl-plan-grapher-asd)
10+
11+
(defsystem :hddl-plan-grapher
12+
:name "SIFT-HDDL-UTILS"
13+
:license "BSD 3-clause (see license.txt)"
14+
:version (:read-file-form "version.lisp-expr")
15+
:depends-on (hddl-utils hddl pddl-utils cl-dot)
16+
;; :in-order-to ((test-op (test-op hddl-utils/tests)))
17+
:pathname "hddl-plan-grapher/"
18+
:serial t
19+
:components ((:file "package") ; Package definition.
20+
(:file "decls")
21+
(:file "plan-grapher")
22+
))
23+
24+
#|
25+
(defsystem :hddl-plan-grapher/tests
26+
:depends-on (pddl-utils fiveam)
27+
:defsystem-depends-on (fiveam-asdf)
28+
:version (:read-file-form "version.lisp-expr")
29+
:serial t
30+
:class :fiveam-tester-system
31+
:test-names ((#:hddl-tests . :hddl-plan-grapher-tests))
32+
:pathname "hddl-plan-grapher/tests/"
33+
:components ((:file "hddl-data")
34+
(:file "tests")))
35+
|#

‎hddl-plan-grapher/decls.lisp

+35
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
(in-package #:hddl-plan-grapher)
2+
3+
(defclass hddl-plan-tree-graph ()
4+
((node-lookup-table
5+
:initform (make-hash-table :test 'eql) ; node keys are integers.
6+
:reader node-lookup-table
7+
))
8+
(:documentation "A null class that the user may subclass to
9+
tailor display of HDDL plan trees."))
10+
11+
(defclass has-task ()
12+
((task ; s-expression
13+
:initarg :task
14+
:reader task
15+
)))
16+
17+
(defclass action (has-task)
18+
()
19+
)
20+
21+
(defclass decomposition (has-task)
22+
((method-name
23+
:initarg :method-name
24+
:reader method-name
25+
)
26+
(children ; list of integers
27+
:initarg :children
28+
:reader children
29+
))
30+
)
31+
32+
33+
34+
(defgeneric graph-plan-tree (plan-tree &key attributes
35+
graph-object))

‎hddl-plan-grapher/package.lisp

+6
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
(in-package #:common-lisp-user)
2+
3+
(defpackage hddl-plan-grapher
4+
(:use common-lisp iterate)
5+
(:export #:hddl-plan-tree-graph
6+
#:graph-plan-tree))

‎hddl-plan-grapher/plan-grapher.lisp

+71
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,71 @@
1+
(in-package #:hddl-plan-grapher)
2+
3+
(defmethod graph-plan-tree ((plan-tree-file string)
4+
&key (attributes nil)
5+
(graph-object (make-instance 'hddl-plan-tree-graph)))
6+
(let ((pathname (merge-pathnames (parse-namestring plan-tree-file)
7+
(make-pathname :type "hddl"))))
8+
(graph-plan-tree pathname
9+
:attributes attributes
10+
:graph-object graph-object)))
11+
12+
(defmethod graph-plan-tree ((plan-tree-file pathname)
13+
&key (attributes nil)
14+
(graph-object (make-instance 'hddl-plan-tree-graph)))
15+
(let ((plan-tree (hddl-io:read-hddl-plan-file plan-tree-file)))
16+
(unless (eq (first plan-tree) ':hddl-plan)
17+
(error 'type-error :datum plan-tree :expected-type 'hddl-plan))
18+
(graph-plan-tree plan-tree
19+
:attributes attributes
20+
:graph-object graph-object)))
21+
22+
(defmethod graph-plan-tree (plan-tree &key (attributes nil)
23+
(graph-object (make-instance 'hddl-plan-tree-graph)))
24+
"Takes a SHOP plan forest (PLAN-FOREST) as input, and returns a CL-DOT graph object."
25+
(let ((roots (getf (rest plan-tree) :roots))
26+
(actions (getf (rest plan-tree) :actions))
27+
(decompositions (getf (rest plan-tree) :decompositions)))
28+
(build-lookup-table graph-object actions decompositions)
29+
(cl-dot:generate-graph-from-roots graph-object roots attributes)))
30+
31+
(defmethod build-lookup-table ((graph-object hddl-plan-tree-graph) actions decompositions)
32+
(iter (for (index . task) in actions)
33+
(setf (gethash index (node-lookup-table graph-object))
34+
(make-instance 'action :task task)))
35+
(iter (for (index task method-name . children) in decompositions)
36+
(setf (gethash index (node-lookup-table graph-object))
37+
(make-instance 'decomposition :task task
38+
:method-name method-name
39+
:children children))))
40+
41+
(defmethod lookup ((g hddl-plan-tree-graph) (index integer))
42+
(or (gethash index (node-lookup-table g))
43+
(error "No graph node with index ~d" index)))
44+
45+
(defmethod cl-dot:graph-object-node ((g hddl-plan-tree-graph) (index integer))
46+
(cl-dot:graph-object-node g (lookup g index)))
47+
48+
(defmethod cl-dot:graph-object-node ((g hddl-plan-tree-graph) (obj action))
49+
(declare (ignorable g))
50+
(make-instance 'cl-dot:node
51+
:attributes `(:label ,(format nil "~A" (task obj))
52+
:shape :box)))
53+
54+
(defmethod cl-dot:graph-object-node ((g hddl-plan-tree-graph) (obj decomposition))
55+
(declare (ignorable g))
56+
(make-instance 'cl-dot:node
57+
:attributes `(:label ,(format nil "~A" (task obj))
58+
:style :rounded
59+
:shape :box)))
60+
61+
(defmethod cl-dot:graph-object-points-to ((g hddl-plan-tree-graph) (index integer))
62+
(cl-dot:graph-object-points-to g (lookup g index)))
63+
64+
(defmethod cl-dot:graph-object-points-to ((g hddl-plan-tree-graph)(obj action))
65+
(declare (ignorable g obj))
66+
nil)
67+
68+
69+
(defmethod cl-dot:graph-object-points-to ((g hddl-plan-tree-graph)(obj decomposition))
70+
(declare (ignorable g))
71+
(children obj))

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

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

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

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

0 commit comments

Comments
 (0)