From c42aebcb18fd2629ab25fe8a96b9a6c7aa2b8423 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Fri, 9 Aug 2024 10:03:20 -0500
Subject: [PATCH 01/13] Extensions to HDDL plan translation.

The HDDL domains that are generated in plan repair for rewrite
sometimes violate the normal constraint that all nodes be ground.

Note: This should probably be fixed, but might happen only at the cost
of making the resulting domains much less efficient to plan.

Changes here allow this normal constraint to be overridden, but note
that if we do, the resulting HDDL plans might count as ill-formed to a
verifier.

Also add a new `find-all-tree-nodes-if` to the PLAN-TREE (enhanced
plan tree) package.
---
 shop3/explicit-stack-search/plan-tree.lisp | 15 +++++++++++++
 shop3/hddl/hddl-plan.lisp                  | 25 +++++++++++++---------
 shop3/package.lisp                         |  1 +
 3 files changed, 31 insertions(+), 10 deletions(-)

diff --git a/shop3/explicit-stack-search/plan-tree.lisp b/shop3/explicit-stack-search/plan-tree.lisp
index 18eb1224..fdb8b051 100644
--- a/shop3/explicit-stack-search/plan-tree.lisp
+++ b/shop3/explicit-stack-search/plan-tree.lisp
@@ -347,6 +347,7 @@ Particularly useful for structures, but could be generally applicable."
           (t (error "Must pass either hash-table or plan-tree to FIND-TASK-IN-TREE.")))))
 
 (defun find-tree-node-if (function plan-tree)
+  "Find the first node in PLAN-TREE that satisfies FUNCTION, or NIL."
   (labels ((tree-search (plan-tree)
              (if (funcall function plan-tree)
                  plan-tree
@@ -358,6 +359,20 @@ Particularly useful for structures, but could be generally applicable."
                       (when result (return-from find-tree-node-if result))))))))
     (tree-search plan-tree)))
 
+(defun find-all-tree-nodes-if (function plan-tree)
+  "Find and return a list of nodes in PLAN-TREE that satisfy FUNCTION."
+  (let (results)
+    (labels ((tree-search (plan-tree)
+               (when (funcall function plan-tree)
+                 (push plan-tree results))
+               (etypecase plan-tree
+                 (primitive-tree-node nil)
+                 (complex-tree-node
+                  (iter (for tree-node in (complex-tree-node-children plan-tree))
+                    (tree-search tree-node))))))
+      (tree-search plan-tree)
+      results)))
+
 (defun all-primitive-nodes (plan-tree)
   (let (retval)
     (labels ((tree-search (plan-tree)
diff --git a/shop3/hddl/hddl-plan.lisp b/shop3/hddl/hddl-plan.lisp
index 34127af7..30fece75 100644
--- a/shop3/hddl/hddl-plan.lisp
+++ b/shop3/hddl/hddl-plan.lisp
@@ -49,7 +49,7 @@
 ;;; hard to support HDDL output from classic SHOP.
 ;;;---------------------------------------------------------------------------
 
-(defun tree-node-task (node)
+(defun tree-node-task (node &key (if-not-ground :error))
   (cond ((typep node 'shop:primitive-node)
          (shop:primitive-node-task node))
         ((typep node 'shop:complex-node)
@@ -61,7 +61,9 @@
                   expanded-task)
                  ((shop:groundp task)
                   task)
-                 (t (error "Task for tree node ~a is not ground." node)))))
+                 (t (unless (eq if-not-ground :ignore)
+                      (funcall (if (eq if-not-ground :error) #'error #'warn)
+                               "Task for tree node ~a is not ground." node))))))
         (t (error 'type-error :expected-type '(or shop:primitive-node shop:complex-node plan-tree:tree-node)
                               :datum node))))
 
@@ -159,7 +161,7 @@ return its children instead.  Needed for ESS plan trees.
 (defun node-index (node)
   (task-index (tree-node-task node)))
 
-(defun hddl-plan (plan tree &key orphans-ok (verbose 0))
+(defun hddl-plan (plan tree &key orphans-ok (if-not-ground :error) (verbose 0))
   "Take a SHOP PLAN and TREE (really a forest) as input and produce an
 HDDL plan encoded as an s-expression.  Note that currently only the extended
 plan trees produced by `find-plans-stack` can be used with this function.
@@ -175,14 +177,15 @@ Classic SHOP plans do not contain all the required information."
             (iter (for root in root-tasks)
               (as i = (task-index root))
               (collecting i)))
-      (setf decompositions (plan-tree->decompositions tree :orphans-ok orphans-ok :verbose verbose))
+      (setf decompositions (plan-tree->decompositions tree :orphans-ok orphans-ok :verbose verbose
+                                                      :if-not-ground if-not-ground))
       `(:hddl-plan
         :actions ,indexed-plan
         :roots ,roots
         :decompositions ,decompositions
         ))))
 
-(defun plan-tree->decompositions (tree &key orphans-ok (verbose 0))
+(defun plan-tree->decompositions (tree &key (if-not-ground :error) orphans-ok (verbose 0))
   (declare (optimize debug))
   (let* ((open (etypecase tree
                  (list tree)
@@ -196,11 +199,12 @@ Classic SHOP plans do not contain all the required information."
     (iter
       (while open)
       (as node = (pop open))
+      (as task = (tree-node-task node :if-not-ground if-not-ground))
       (with found)
       ;; Don't index internal operators
       (unless (shop::internal-operator-p
-               (shop:task-name (tree-node-task node)))
-        (setf found (nth-value 1 (task-index (tree-node-task node))))
+               (shop:task-name task))
+        (setf found (nth-value 1 (task-index task)))
         (cond ((primitive-node-p node)
                (unless found
                  (error "Found new primitive node: all primitive nodes should be indexed already.")))
@@ -227,7 +231,8 @@ Classic SHOP plans do not contain all the required information."
         (while open)
         (as node = (pop open))
         (with id) (with found)
-        (multiple-value-setq (id found) (task-index (tree-node-task node)))
+        (as task = (tree-node-task node :if-not-ground if-not-ground))
+        (multiple-value-setq (id found) (task-index task))
         (unless found
           (error "All nodes should have been indexed before the pass to construct the decomposition records."))
         (set-visited id)   ; convert 1-based to 0
@@ -238,7 +243,7 @@ Classic SHOP plans do not contain all the required information."
             (iter (for child in children)
               (with cindex) (with found)
               (unless (shop::internal-operator-p
-                       (shop:task-name (tree-node-task child)))
+                       (shop:task-name (tree-node-task child :if-not-ground :ignore)))
                 (multiple-value-setq (cindex found)
                   (node-index child))
                 (unless found
@@ -251,7 +256,7 @@ Classic SHOP plans do not contain all the required information."
                 (collecting cindex into child-indices))
               (finally
                (push (make-decomposition-record :node-id id
-                                                :task (tree-node-task node)
+                                                :task task
                                                 :method-name (complex-node-reduction-label node)
                                                 :children child-indices)
                      retval))))))
diff --git a/shop3/package.lisp b/shop3/package.lisp
index c1b36efb..e77c5b0a 100644
--- a/shop3/package.lisp
+++ b/shop3/package.lisp
@@ -358,6 +358,7 @@
            #:find-plan-step
            #:find-task-in-tree
            #:find-tree-node-if
+           #:find-all-tree-nodes-if
 
            #:copy-plan-tree
            #:plan-tree->sexp

From 781687afff0e66620b6bfead102862da69c374ba Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Fri, 9 Aug 2024 10:06:32 -0500
Subject: [PATCH 02/13] Update loading of rovers example.

Now we load all the problems and insert them into a single problem set
after loading.

Did this to support testing the enhanced plan tree (and additional
modifications in the current feature branch).
---
 shop3/examples/rovers/strips/domain.lisp | 61 ++++++++++++++----------
 shop3/shop-version.lisp-expr             |  4 +-
 shop3/shop3.asd                          | 38 ++++++++++++++-
 3 files changed, 74 insertions(+), 29 deletions(-)

diff --git a/shop3/examples/rovers/strips/domain.lisp b/shop3/examples/rovers/strips/domain.lisp
index 7553063f..b688b673 100644
--- a/shop3/examples/rovers/strips/domain.lisp
+++ b/shop3/examples/rovers/strips/domain.lisp
@@ -9,7 +9,16 @@
    ;; rewrite for goals
    #:communicate_image_data
    #:communicate_rock_data
-   #:communicate_soil_data))
+   #:communicate_soil_data
+   )
+  (:export #:roverprob01 #:roverprob02 #:roverprob03
+           #:roverprob04 #:roverprob05 #:roverprob06
+           #:roverprob07 #:roverprob08 #:roverprob09
+           #:roverprob10 #:roverprob11 #:roverprob12
+           #:roverprob13 #:roverprob14 #:roverprob15
+           #:roverprob16 #:roverprob17 #:roverprob19
+           #:roverprob20
+           #:rovers-problems))
 (in-package :shop3-rovers)
 
 (defclass pure-pddl-domain (pure-logic-domain-mixin pddl-domain)
@@ -29,7 +38,7 @@
       store_of
       on_board)
      (:types rover waypoint store camera mode lander objective)
-     (:predicates (at ?x - rover ?y - waypoint) 
+     (:predicates (at ?x - rover ?y - waypoint)
                   (at_lander ?x - lander ?y - waypoint)
                   (can_traverse ?r - rover ?x - waypoint ?y - waypoint)
                   (equipped_for_soil_analysis ?r - rover)
@@ -39,7 +48,7 @@
                   (have_rock_analysis ?r - rover ?w - waypoint)
                   (have_soil_analysis ?r - rover ?w - waypoint)
                   (full ?s - store)
-                  (calibrated ?c - camera ?r - rover) 
+                  (calibrated ?c - camera ?r - rover)
                   (supports ?c - camera ?m - mode)
                   (available ?r - rover)
                   (visible ?w - waypoint ?p - waypoint)
@@ -55,16 +64,16 @@
                   (on_board ?i - camera ?r - rover)
                   (channel_free ?l - lander)
                   )
-     
+
      (:action navigate
-      :parameters (?x - rover ?y - waypoint ?z - waypoint) 
-      :precondition (and (can_traverse ?x ?y ?z) (available ?x) (at ?x ?y) 
+      :parameters (?x - rover ?y - waypoint ?z - waypoint)
+      :precondition (and (can_traverse ?x ?y ?z) (available ?x) (at ?x ?y)
                          (visible ?y ?z)
                          )
       :effect (and (not (at ?x ?y)) (at ?x ?z)
                    )
               )
-     
+
      (:action sample_soil
       :parameters (?x - rover ?s - store ?p - waypoint)
       :precondition (and (at ?x ?p) (at_soil_sample ?p)
@@ -73,7 +82,7 @@
       :effect (and (not (empty ?s)) (full ?s) (have_soil_analysis ?x ?p) (not (at_soil_sample ?p))
                    )
               )
-     
+
      (:action sample_rock
       :parameters (?x - rover ?s - store ?p - waypoint)
       :precondition (and (at ?x ?p) (at_rock_sample ?p) (equipped_for_rock_analysis ?x) (store_of ?s ?x)(empty ?s)
@@ -81,7 +90,7 @@
       :effect (and (not (empty ?s)) (full ?s) (have_rock_analysis ?x ?p) (not (at_rock_sample ?p))
                    )
               )
-     
+
      (:action drop
       :parameters (?x - rover ?y - store)
       :precondition (and (store_of ?y ?x) (full ?y)
@@ -89,14 +98,14 @@
       :effect (and (not (full ?y)) (empty ?y)
                    )
               )
-     
+
      (:action calibrate
       :parameters (?r - rover ?i - camera ?t - objective ?w - waypoint)
       :precondition (and (equipped_for_imaging ?r) (calibration_target ?i ?t) (at ?r ?w) (visible_from ?t ?w)(on_board ?i ?r)
                          )
-      :effect (calibrated ?i ?r) 
+      :effect (calibrated ?i ?r)
               )
-     
+
      (:action take_image
       :parameters (?r - rover ?p - waypoint ?o - objective ?i - camera ?m - mode)
       :precondition (and (calibrated ?i ?r)
@@ -109,7 +118,7 @@
       :effect (and (have_image ?r ?o ?m)(not (calibrated ?i ?r))
                    )
               )
-     
+
      (:action communicate_soil_data
       :parameters (?r - rover ?l - lander
                       ;; the location from which ?r took the soil data
@@ -120,7 +129,7 @@
                       ?y - waypoint)
       :precondition (and (at ?r ?x)
                          (at_lander ?l ?y)
-                         (have_soil_analysis ?r ?p) 
+                         (have_soil_analysis ?r ?p)
                          (visible ?x ?y)
                          (available ?r)
                          (channel_free ?l)
@@ -132,7 +141,7 @@
                    (available ?r)
                    )
               )
-     
+
      (:action communicate_rock_data
       :parameters (?r - rover ?l - lander ?p - waypoint ?x - waypoint ?y - waypoint)
       :precondition (and (at ?r ?x)(at_lander ?l ?y)(have_rock_analysis ?r ?p)
@@ -141,7 +150,7 @@
       :effect (and (not (available ?r))(not (channel_free ?l))(channel_free ?l)(communicated_rock_data ?p)(available ?r)
                    )
               )
-     
+
      (:action communicate_image_data
       :parameters (?r - rover ?l - lander ?o - objective ?m - mode
                       ;; rover position
@@ -197,12 +206,12 @@
        already-empty
        ((empty ?s))
        ())
-       
+
      (:method (empty-store ?s ?rover)
        drop-to-empty
        ((not (empty ?s)))
        ((!drop ?rover ?s)))
-     
+
      (:method (navigate ?rover ?to)
        already-there
        ((at ?rover ?to))
@@ -232,7 +241,7 @@
        achieve-communicated-soil-data
        ((store_of ?s ?rover))
        ((navigate ?rover ?goal-loc)
-        (:immediate empty-store ?s ?rover) 
+        (:immediate empty-store ?s ?rover)
         (:immediate !sample_soil ?rover ?s ?goal-loc)
         ;; FIXME: shouldn't there be a protection of the store until the communication is done?
         (:immediate communicate soil ?goal-loc ?_rover-loc ?rover)
@@ -241,8 +250,8 @@
      (:method (communicated_rock_data ?goal-loc ?rover)
        achieve-communicated-rock-data
        ((store_of ?s ?rover))
-       ((navigate ?rover ?goal-loc) 
-        (:immediate empty-store ?s ?rover) 
+       ((navigate ?rover ?goal-loc)
+        (:immediate empty-store ?s ?rover)
         (:immediate !sample_rock ?rover ?s ?goal-loc)
         (:immediate communicate ROCK ?goal-loc ?_rover-loc ?rover)
         (:immediate !!retract ((COMMUNICATE_ROCK_DATA ?goal-loc)))))
@@ -372,7 +381,7 @@
         (visible ?new-loc ?lander-loc)
         (different ?loc ?new-loc))
 
-       ((navigate ?rover ?new-loc) 
+       ((navigate ?rover ?new-loc)
         (!communicate_image_data ?rover ?l ?obj ?mode ?new-loc
                                  ?lander-loc)))
 
@@ -382,17 +391,17 @@
      ;; State axioms
      (:- (same ?x ?x) nil)
      (:- (different ?x ?y) ((not (same ?x ?y))))
-     
-     
+
+
      ;; This is a simple implementation that looks for an existence of a
      ;; path, not necessarily a shortest or best path.
      (:- (path ?_rover ?from ?from nil ?_visited)
          nil)
-     
+
      (:- (path ?rover ?from ?to (?to . nil) ?_visited)
          ((not (same ?from ?to))
           (can_traverse ?rover ?from ?to)))
-     
+
      (:- (path ?rover ?from ?to (?to1 . ?path1) ?visited)
          ((not (same ?from ?to))
           (not (can_traverse ?rover ?from ?to))
diff --git a/shop3/shop-version.lisp-expr b/shop3/shop-version.lisp-expr
index 5411ed34..a75fb8e9 100644
--- a/shop3/shop-version.lisp-expr
+++ b/shop3/shop-version.lisp-expr
@@ -1,2 +1,4 @@
-"3.12.0" ; 3.11 introduces command-line applications and HDDL plan output
+"3.13.0"
+; 3.11 introduces command-line applications and HDDL plan output
 ; 3.12 introduces the use of random-state for repeatability
+; 3.13 introduces enhancements needed for the plan repair experiments
\ No newline at end of file
diff --git a/shop3/shop3.asd b/shop3/shop3.asd
index ac61478b..19a43208 100644
--- a/shop3/shop3.asd
+++ b/shop3/shop3.asd
@@ -213,9 +213,43 @@ minimal affected subtree."
 (defsystem shop3/rovers
     :depends-on (:shop3)
   :serial t
+  :perform (load-op :after (o c)
+                    (declare (ignorable o c))
+                    (values)
+                    (uiop:symbol-call :shop3 '#:make-problem-set
+                                      (uiop:intern* '#:rovers-problems '#:shop3-rovers)
+                                      (mapcar #'(lambda (x)
+                                                  (uiop:intern* x '#:shop3-rovers))
+                                              '(#:roverprob01 #:roverprob02 #:roverprob03
+                                                #:roverprob04 #:roverprob05 #:roverprob06
+                                                #:roverprob07 #:roverprob08 #:roverprob09
+                                                #:roverprob10 #:roverprob11 #:roverprob12
+                                                #:roverprob13 #:roverprob14 #:roverprob15
+                                                #:roverprob16 #:roverprob17 #:roverprob19
+                                                #:roverprob20))))
   :pathname "examples/rovers/strips/"
-  :components ((:file "domain")))
-
+  :components ((:file "domain")
+               (:file "p01")
+               (:file "p02")
+               (:file "p03")
+               (:file "p04")
+               (:file "p05")
+               (:file "p06")
+               (:file "p07")
+               (:file "p08")
+               (:file "p09")
+               (:file "p10")
+               (:file "p11")
+               (:file "p12")
+               (:file "p13")
+               (:file "p14")
+               (:file "p15")
+               (:file "p16")
+               (:file "p17")
+               (:file "p18")
+               (:file "p19")
+               (:file "p20")
+               ))
 
 (defsystem shop3/test
     :defsystem-depends-on ((:version "fiveam-asdf" "2"))

From 7233f8142951b89c53d530242575b5154a08a424 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Mon, 12 Aug 2024 15:21:41 -0500
Subject: [PATCH 03/13] Multiple fixes to MAKE-LOAD-FORM.

Have been using this as a crude way to copy trees and plans (for HDDL
generation) and found it was quite badly buggy.
---
 shop3/explicit-stack-search/plan-tree.lisp | 178 ++++++++++++++++++---
 1 file changed, 159 insertions(+), 19 deletions(-)

diff --git a/shop3/explicit-stack-search/plan-tree.lisp b/shop3/explicit-stack-search/plan-tree.lisp
index fdb8b051..9cc4bcf2 100644
--- a/shop3/explicit-stack-search/plan-tree.lisp
+++ b/shop3/explicit-stack-search/plan-tree.lisp
@@ -1,5 +1,38 @@
 (in-package :plan-tree)
 
+(defpackage plan-tree-vars)
+
+(defstruct tree-and-plan
+  tree
+  plan)
+
+(defmethod make-load-form ((obj tree-and-plan) &optional environment)
+  (declare (ignorable environment))
+  (let* ((*table-for-load-form* (make-hash-table :test #'eq))
+         (*node-list* nil)
+         (orig-plan (tree-and-plan-plan obj))
+         (orig-tree (tree-and-plan-tree obj))
+         (has-costs-p (numberp (second orig-plan))))
+    (declare (special *table-for-load-form* *node-list*))
+    (make-table-entries orig-tree)
+    `(let* ,(obj-bindings *table-for-load-form*)
+       ,@(make-cross-links *table-for-load-form*)
+       (make-tree-and-plan
+        :tree
+        ,(gethash orig-tree *table-for-load-form*)
+        :plan
+        ,(if has-costs-p
+             `(list
+               ,@(loop :for (task cost . nil) :on orig-plan :by #'cddr
+                       :collect (gethash task *table-for-load-form*)
+                       :collect cost))
+             `(list
+               ,@(loop :for task :in orig-plan
+                       :collect (gethash task *table-for-load-form*))))))))
+
+
+
+
 
 ;;;---------------------------------------------------------------------------
 ;;; Helpers for MAKE-LOAD-FORM for the plan tree.
@@ -7,6 +40,14 @@
 
 (defvar *table-for-load-form*)
 (defvar *node-list*)
+(setf (documentation '*table-for-load-form* 'variable)
+      "Table of temporary variables and values used to reconstitute
+a plan tree.")
+
+(defun file-prefix ()
+  "Returns an s-expression that goes in the head of a
+file before the load form for a plan tree or a "
+  )
 
 (defgeneric make-instantiator (obj)
   (:documentation "Return an s-expression instantiating a copy of OBJ.
@@ -31,7 +72,7 @@ cross-links for VAL using information in TABLE."))
   (:method (obj)
     (error "No method for computing slot fillers for object ~s" obj)))
 
-;;;---------------------------------------------------------------------------
+;;;-------------------------------------`<--------------------------------------
 ;;; DEPENDENCY structures
 ;;;---------------------------------------------------------------------------
 
@@ -66,7 +107,9 @@ cross-links for VAL using information in TABLE."))
   `((setf (tree-node-dependencies ,var-name)
           (list
            ,@(mapcar #'(lambda (x) (slot-value-translator x table))
-                     (tree-node-dependencies obj))))))
+                     (tree-node-dependencies obj)))
+          (tree-node-parent ,var-name)
+          ,(slot-value-translator (tree-node-parent obj)))))
 
 (defstruct (primitive-tree-node (:include tree-node))
   )
@@ -103,14 +146,16 @@ cross-links for VAL using information in TABLE."))
 
 
 (defmethod make-instantiator ((obj complex-tree-node))
-  `(make-complex-tree-node ,@ (slot-fillers obj)))
+  `(make-complex-tree-node ,@(slot-fillers obj)))
 
 (defmethod cross-links-for ((var-name symbol) (obj complex-tree-node) (table hash-table))
   (append (call-next-method)
           `((setf (complex-tree-node-children ,var-name)
                   (list
                    ,@(mapcar #'(lambda (x) (slot-value-translator x table))
-                           (complex-tree-node-children obj)))))))
+                           (complex-tree-node-children obj)))
+                  (complex-tree-node-method-name ,var-name)
+                  ',(complex-tree-node-method-name obj)))))
 
 
 (defstruct (top-node (:include complex-tree-node))
@@ -159,12 +204,12 @@ and building a toplogically sorted list of nodes."))
     (unless (gethash obj table nil)
       (setf (gethash obj table)
             (cond ((typep obj 'tree-node)
-                   (gensym "NODE"))
+                   (gentemp "NODE" :plan-tree-vars))
                   ((typep obj 'dependency)
-                   (gensym "DEP"))
+                   (gentemp "DEP" :plan-tree-vars))
                   ((listp obj)
-                   (gensym "PROP"))
-                  (t (gensym "OTHER")))))))
+                   (gentemp "PROP" :plan-tree-vars))
+                  (t (gentemp "OTHER" :plan-tree-vars)))))))
 
 (defmethod make-table-entries ((obj tree-node))
   (push obj *node-list*)
@@ -194,16 +239,26 @@ and building a toplogically sorted list of nodes."))
   (call-next-method)
   (mapc #'make-table-entries (complex-tree-node-children obj)))
 
-;; FIXME: likely this should be a pseudo-node
 (defstruct (pseudo-node (:include complex-tree-node)))
 
+(defmethod make-instantiator ((obj pseudo-node))
+  (error "This PSEUDO-NODE doesn't have a MAKE-INSTANTIATOR defined."))
+
+
 ;;; maybe should revise this and have complex-tree-node as mixin, since
 ;;; ordered-tree-node and unordered-tree-node have neither TASK nor
 ;;; DEPENDENCIES.
 (defstruct (ordered-tree-node (:include pseudo-node)))
 
+(defmethod make-instantiator ((obj ordered-tree-node))
+  `(make-ordered-tree-node ,@(slot-fillers obj)))
+
 (defstruct (unordered-tree-node (:include pseudo-node)))
 
+(defmethod make-instantiator ((obj unordered-tree-node))
+  `(make-unordered-tree-node ,@(slot-fillers obj)))
+
+
 ;;; FIXME: this could probably be expanded to also emit the
 ;;; PRINT-OBJECT method header, instead of just the code that goes in
 ;;; it.
@@ -346,18 +401,35 @@ Particularly useful for structures, but could be generally applicable."
               (error "No plan tree node for task ~S" task))))
           (t (error "Must pass either hash-table or plan-tree to FIND-TASK-IN-TREE.")))))
 
+(defun map-tree (function plan-tree)
+  "Apply FUNCTION to each node in PLAN-TREE. Returns nothing; must be done for side-effects."
+  (labels ((tree-search (plan-tree)
+             (funcall function plan-tree)
+             (etypecase plan-tree
+               (primitive-tree-node nil)
+               (complex-tree-node
+                (mapc #'tree-search (complex-tree-node-children plan-tree))))))
+    (tree-search plan-tree)
+    (values)))
+
+#-allegro
+(declaim (ftype (function ((function (tree-node) t) tree-node)
+                          (only-value (or tree-node null)))
+                find-tree-node-if))
 (defun find-tree-node-if (function plan-tree)
   "Find the first node in PLAN-TREE that satisfies FUNCTION, or NIL."
-  (labels ((tree-search (plan-tree)
-             (if (funcall function plan-tree)
-                 plan-tree
-                 (etypecase plan-tree
-                   (primitive-tree-node nil)
-                   (complex-tree-node
-                    (iter (for tree-node in (complex-tree-node-children plan-tree))
-                      (as result = (tree-search tree-node))
-                      (when result (return-from find-tree-node-if result))))))))
-    (tree-search plan-tree)))
+  (catch 'find-tree-node-if
+   (labels ((tree-search (plan-tree)
+              (if (funcall function plan-tree)
+                  plan-tree
+                  (etypecase plan-tree
+                    (primitive-tree-node nil)
+                    (complex-tree-node
+                     (iter (for tree-node in (complex-tree-node-children plan-tree))
+                       (as result = (tree-search tree-node))
+                       (when result (throw 'find-tree-node-if result))))))))
+     (tree-search plan-tree)
+     nil)))
 
 (defun find-all-tree-nodes-if (function plan-tree)
   "Find and return a list of nodes in PLAN-TREE that satisfy FUNCTION."
@@ -457,3 +529,71 @@ tasks."
         (assert new-root)
         (setf (top-node-lookup-table new-root) new-lookup-table)
         (values new-root new-lookup-table)))))
+
+
+;;;---------------------------------------------------------------------------
+;;; Comparison functions for debugging
+;;;---------------------------------------------------------------------------
+(defun compare-dependencies (n1 n2)
+  (if (tree-node-dependencies n1)
+      (and (tree-node-dependencies n2)
+           (= (length (tree-node-dependencies n1))
+              (length (tree-node-dependencies n2)))
+           (alexandria:set-equal
+            (mapcar #'prop
+                    (tree-node-dependencies n1))
+            (mapcar #'prop
+                    (tree-node-dependencies n2))
+            :test #'equalp)
+           (iter (for d1 in (tree-node-dependencies n1))
+             (as prop = (prop d1))
+             (as d2 = (find prop (tree-node-dependencies n2)
+                            :key #'prop :test #'equalp))
+             (unless
+                 (and d2
+                      (cond ((eq (establisher d1) :init)
+                             (eq (establisher d2) :init))
+                            (t (equalp (tree-node-task
+                                        (establisher d1))
+                                       (tree-node-task
+                                        (establisher d2))))))
+               (return nil))
+             (finally (return t))))
+      (not (tree-node-dependencies n2))))
+
+(defun compare-trees (t1 t2)
+  (let ((open (list (cons t1 t2))))
+    (labels ((compare-node (n1 n2)
+               (and (eq (type-of n1) (type-of n2))
+                    (equalp (tree-node-task n1)
+                            (tree-node-task n2))
+                    (if (tree-node-parent n1)
+                        (and (tree-node-parent n2)
+                             (equalp (tree-node-task
+                                      (tree-node-parent n1))
+                                     (tree-node-task (tree-node-parent n2))))
+                        (not (tree-node-parent n2)))
+                    (compare-dependencies n1 n2)
+                    (if (complex-tree-node-p n1)
+                        (and
+                         (= (length (complex-tree-node-children n1))
+                            (length (complex-tree-node-children n1)))
+                         (if (complex-tree-node-method-name n1)
+                             (and (complex-tree-node-method-name n2)
+                                  (eq
+                                   (complex-tree-node-method-name n1)
+                                   (complex-tree-node-method-name n2)))
+                             (not (complex-tree-node-method-name n2)))
+                         (progn (mapc #'(lambda (x y) (push (cons x y)
+                                                            open))
+                                      (complex-tree-node-children n1)
+                                      (complex-tree-node-children n2))
+                                t))
+                        t))))
+      (iter (while open)
+        (destructuring-bind (n1 . n2)
+            (pop open)
+          (or (compare-node n1 n2)
+              (return-from compare-trees
+                (values nil (list n1 n2))))))
+      t)))

From da9e4ed8b8549398596ba36954fd8a1a547238e6 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Mon, 12 Aug 2024 15:22:27 -0500
Subject: [PATCH 04/13] Fix the domain for variable binding.

There were some cases where parameters were not properly bound top-down.
---
 shop3/examples/rovers/strips/domain.lisp | 90 +++++++++++++-----------
 1 file changed, 50 insertions(+), 40 deletions(-)

diff --git a/shop3/examples/rovers/strips/domain.lisp b/shop3/examples/rovers/strips/domain.lisp
index b688b673..6a721f8f 100644
--- a/shop3/examples/rovers/strips/domain.lisp
+++ b/shop3/examples/rovers/strips/domain.lisp
@@ -1,6 +1,6 @@
 (defpackage :shop3-rovers
   (:use common-lisp shop3)
-  (:nicknames #:shop2-rovers)
+  (:nicknames #:shop2-rovers #:shop-rovers)
   (:intern
    #:communicated_image_data
    #:communicated_rock_data
@@ -19,7 +19,7 @@
            #:roverprob16 #:roverprob17 #:roverprob19
            #:roverprob20
            #:rovers-problems))
-(in-package :shop3-rovers)
+(in-package :shop-rovers)
 
 (defclass pure-pddl-domain (pure-logic-domain-mixin pddl-domain)
   ())
@@ -147,9 +147,11 @@
       :precondition (and (at ?r ?x)(at_lander ?l ?y)(have_rock_analysis ?r ?p)
                          (visible ?x ?y)(available ?r)(channel_free ?l)
                          )
-      :effect (and (not (available ?r))(not (channel_free ?l))(channel_free ?l)(communicated_rock_data ?p)(available ?r)
-                   )
-              )
+      :effect (and (not (available ?r))
+                   (not (channel_free ?l))
+                   (channel_free ?l)
+                   (communicated_rock_data ?p)
+                   (available ?r)))
 
      (:action communicate_image_data
       :parameters (?r - rover ?l - lander ?o - objective ?m - mode
@@ -176,21 +178,21 @@
        communicate-one-soil-data
        (communicate_soil_data ?goal-loc)
        (:ordered
-        (communicated_soil_data ?goal-loc ?_rover)
+        (communicated_soil_data ?goal-loc)
         (achieve-goals)))
 
      (:pddl-method (achieve-goals)
        communicate-one-rock-data
        (communicate_rock_data ?goal-loc)
        (:ordered
-        (communicated_rock_data ?goal-loc ?_rover)
+        (communicated_rock_data ?goal-loc)
         (achieve-goals)))
 
      (:method (achieve-goals)
        communicate-one-image-data
        (communicate_image_data ?obj ?mode)
        (:ordered
-        (communicated_image_data ?obj ?mode ?_rover)
+        (communicated_image_data ?obj ?mode)
         (achieve-goals)))
 
      (:pddl-method (achieve-goals)
@@ -237,37 +239,58 @@
        ((!navigate ?rover ?from ?first)
         (move ?rover ?first ?rest)))
 
-     (:method (communicated_soil_data ?goal-loc ?rover)
+     (:method (communicated_soil_data ?goal-loc)
        achieve-communicated-soil-data
-       ((store_of ?s ?rover))
+       ((rover ?rover)
+        (store_of ?s ?rover))
        ((navigate ?rover ?goal-loc)
         (:immediate empty-store ?s ?rover)
         (:immediate !sample_soil ?rover ?s ?goal-loc)
         ;; FIXME: shouldn't there be a protection of the store until the communication is done?
-        (:immediate communicate soil ?goal-loc ?_rover-loc ?rover)
+        (:immediate communicate soil ?goal-loc ?rover)
         (:immediate !!retract ((COMMUNICATE_SOIL_DATA ?goal-loc)))))
 
-     (:method (communicated_rock_data ?goal-loc ?rover)
+     (:method (communicated_rock_data ?goal-loc)
        achieve-communicated-rock-data
-       ((store_of ?s ?rover))
+       ((rover ?rover)
+        (store_of ?s ?rover))
        ((navigate ?rover ?goal-loc)
         (:immediate empty-store ?s ?rover)
         (:immediate !sample_rock ?rover ?s ?goal-loc)
-        (:immediate communicate ROCK ?goal-loc ?_rover-loc ?rover)
+        (:immediate communicate ROCK ?goal-loc ?rover)
         (:immediate !!retract ((COMMUNICATE_ROCK_DATA ?goal-loc)))))
 
-     (:method (communicated_image_data ?obj ?mode ?rover)
+     (:method (communicated_image_data ?obj ?mode)
        achieve-communicated-image-data
        ((on_board ?camera ?rover)
-        (supports ?camera ?mode)
-        (at_lander ?_lander ?lander-loc))
+        (supports ?camera ?mode))
        ((calibrate-camera ?rover ?camera)
-        (get-line-of-sight ?rover ?obj ?photo-loc)
-        (!take_image ?rover ?photo-loc ?obj ?camera ?mode)
-        ;; navigate to a transmission location and transmit
-        (communicate-image ?photo-loc ?lander-loc ?rover ?obj ?mode)
+        ;; move to a photo location, take the image, then move to
+        ;; a position that has line of sight to a lander and communicate
+        ;; the image.
+        (get-image ?rover ?obj ?camera ?mode)
         (:immediate !!retract ((COMMUNICATE_IMAGE_DATA ?obj ?mode)))))
 
+     (:method (get-image ?rover ?obj ?camera ?mode)
+       have-line-of-sight-for-photo
+       ((at ?rover ?photo-loc)
+        (visible_from ?obj ?photo-loc)
+        (at_lander ?_lander ?lander-loc))
+       ((!take_image ?rover ?photo-loc ?obj ?camera ?mode)
+        ;; navigate to a transmission location and transmit
+        (communicate-image ?photo-loc ?lander-loc ?rover ?obj ?mode)))
+
+     (:method (get-image ?rover ?obj ?camera ?mode)
+       need-line-of-sight
+       ((at ?rover ?rover-loc)
+        (not (visible_from ?obj ?rover-loc))
+        (visible_from ?obj ?photo-loc)
+        (at_lander ?_lander ?lander-loc))
+       (:ordered (navigate ?rover ?photo-loc)
+                 (!take_image ?rover ?photo-loc ?obj ?camera ?mode)
+                 ;; navigate to a transmission location and transmit
+                 (communicate-image ?photo-loc ?lander-loc ?rover ?obj ?mode)))
+
      (:method (calibrate-camera ?rover ?camera)
        camera-already-calibrated
        ((calibrated ?camera ?rover))
@@ -281,24 +304,11 @@
        (:ordered (navigate ?rover ?calibration-loc)
                  (!calibrate ?rover ?camera ?calibration-obj ?calibration-loc)))
 
-     (:method (get-line-of-sight ?rover ?obj ?photo-loc)
-       have-line-of-sight-for-photo
-       ((at ?rover ?photo-loc)
-        (visible_from ?obj ?photo-loc))
-       ())
-
-     (:method (get-line-of-sight ?rover ?obj ?photo-loc)
-       need-line-of-sight
-       ((at ?rover ?rover-loc)
-        (not (visible_from ?obj ?rover-loc))
-        (visible_from ?obj ?photo-loc))
-       (:ordered (navigate ?rover ?photo-loc)))
-
 
      ;; HELPERS
      ;; the following shows a need for some higher-order method constructs
 
-     (:method (communicate soil ?analysis-loc ?rover-loc ?rover)
+     (:method (communicate soil ?analysis-loc ?rover)
             have-line-of-sight-for-soil
        ((at ?rover ?rover-loc)
         (at_lander ?l ?lander-loc)
@@ -307,7 +317,7 @@
                                 ?lander-loc)))
 
 
-     (:method (communicate soil ?analysis-loc ?rover-loc ?rover)
+     (:method (communicate soil ?analysis-loc ?rover)
        go-to-line-of-sight-for-soil
        ;; Otherwise, go somewhere where the lander is visible
        ((at ?rover ?rover-loc)
@@ -319,7 +329,7 @@
         (!communicate_soil_data ?rover ?l ?analysis-loc ?new-loc
                                 ?lander-loc)))
 
-     (:method (communicate rock ?analysis-loc ?rover-loc ?rover)
+     (:method (communicate rock ?analysis-loc ?rover)
        have-line-of-sight-for-rock
        ((at ?rover ?rover-loc)
         (at_lander ?l ?lander-loc)
@@ -327,7 +337,7 @@
        ((!communicate_rock_data ?rover ?l ?analysis-loc ?rover-loc
                                 ?lander-loc)))
 
-     (:method (communicate rock ?analysis-loc ?rover-loc ?rover)
+     (:method (communicate rock ?analysis-loc ?rover)
        go-to-line-of-sight-for-rock
        ;; Otherwise, go somewhere where the lander is visible
        ((at ?rover ?rover-loc)
@@ -339,7 +349,7 @@
         (!communicate_rock_data ?rover ?l ?analysis-loc ?new-loc
                                 ?lander-loc)))
 
-     (:method (communicate image ?analysis-loc ?rover-loc ?rover)
+     (:method (communicate image ?analysis-loc ?rover)
        have-line-of-sight-for-image
        ((at ?rover ?rover-loc)
         (at_lander ?l ?lander-loc)
@@ -347,7 +357,7 @@
        ((!communicate_image_data ?rover ?l ?analysis-loc ?rover-loc
                                 ?lander-loc)))
 
-     (:method (communicate image ?analysis-loc ?rover-loc ?rover)
+     (:method (communicate image ?analysis-loc ?rover)
        go-to-line-of-sight-for-image
        ;; Otherwise, go somewhere where the lander is visible
        ((at ?rover ?rover-loc)

From cf0a3e3b6e0e760b49c87125c526bace3d95eb36 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Mon, 12 Aug 2024 15:23:36 -0500
Subject: [PATCH 05/13] Substantial clean-up in debugging.

Pulled a large number of loops, etc. out of too-large functions for
more understandable code.
---
 shop3/hddl/hddl-plan.lisp | 161 ++++++++++++++++++++++++--------------
 1 file changed, 101 insertions(+), 60 deletions(-)

diff --git a/shop3/hddl/hddl-plan.lisp b/shop3/hddl/hddl-plan.lisp
index 30fece75..94228a54 100644
--- a/shop3/hddl/hddl-plan.lisp
+++ b/shop3/hddl/hddl-plan.lisp
@@ -36,6 +36,9 @@
 (deftype only-value (value-spec)
   `(values ,value-spec &optional))
 
+(deftype complex-node ()
+  `(or shop::complex-node plan-tree:complex-tree-node))
+
 (defstruct decomposition-record
   (node-id -1 :type fixnum)
   task
@@ -55,18 +58,30 @@
         ((typep node 'shop:complex-node)
          (shop:complex-node-task node))
         ((plan-tree:tree-node-p node)
-         (let ((task (plan-tree:tree-node-task node))
-               (expanded-task (plan-tree:tree-node-expanded-task node)))
-           (cond ((shop:groundp expanded-task)
-                  expanded-task)
-                 ((shop:groundp task)
-                  task)
-                 (t (unless (eq if-not-ground :ignore)
-                      (funcall (if (eq if-not-ground :error) #'error #'warn)
-                               "Task for tree node ~a is not ground." node))))))
+         (grounded-tree-node-task node if-not-ground))
         (t (error 'type-error :expected-type '(or shop:primitive-node shop:complex-node plan-tree:tree-node)
                               :datum node))))
 
+;;; Return the grounded task from NODE, if available, consulting both the
+;;; node's task and expanded-task.  Handle the case where no grounded task
+;;; is found according to IF-NOT-GROUND
+(declaim (ftype (function (plan-tree:tree-node (member :error :warn :ignore)))
+                grounded-tree-node-task))
+(defun grounded-tree-node-task (node if-not-ground)
+  (let ((task (plan-tree:tree-node-task node))
+        (expanded-task (plan-tree:tree-node-expanded-task node)))
+    (cond ((shop:groundp expanded-task)
+           expanded-task)
+          ((shop:groundp task)
+           task)
+          (t (unless (eq if-not-ground :ignore)
+               (funcall (if (eq if-not-ground :error) #'error #'warn)
+                        "Task for tree node ~a is not ground." node))))))
+
+#-allegro
+(declaim (ftype (function (complex-node)
+                          (only-values (or symbol list)))
+                complex-node-task))
 (defun complex-node-task (node)
   (cond ((or (shop:complex-node-p node)
              (typep node 'plan-tree:complex-tree-node))
@@ -115,6 +130,9 @@
 
 
 (defun resolve-extended-plan-tree-children (children)
+  "Return a list of \"true\" children from CHILDREN, where true children
+are a list of tree nodes with unordered-tree-nodes and ordered-tree-nodes
+\"resolved\" to their \"true\" children (complex and primitive tree nodes)."
   (alexandria:mappend #'resolve-extended-plan-tree-child children))
 
 
@@ -169,26 +187,38 @@ Classic SHOP plans do not contain all the required information."
   ;; set up tables for indexing
   (let ((*next-index* 1)
         (*task-indices* (make-hash-table :test 'eq)))
-    (let ((indexed-plan (index-shop-plan (shop:shorter-plan plan)))
-          (root-tasks (forest-roots tree))
-          roots decompositions)
-      ;; (format t "~&*next-index* = ~d~%Root tasks are: ~S~%" *next-index* root-tasks)
-      (setf roots
-            (iter (for root in root-tasks)
-              (as i = (task-index root))
-              (collecting i)))
-      (setf decompositions (plan-tree->decompositions tree :orphans-ok orphans-ok :verbose verbose
-                                                      :if-not-ground if-not-ground))
+    (let* ((indexed-plan (index-shop-plan (shop:shorter-plan plan)))
+           (root-tasks (forest-roots tree))
+           (roots
+             (iter (for root in root-tasks)
+               (as i = (task-index root))
+               (collecting i)))
+           (decompositions (plan-tree->decompositions tree :orphans-ok orphans-ok :verbose verbose
+                                                           :if-not-ground if-not-ground)))
       `(:hddl-plan
         :actions ,indexed-plan
         :roots ,roots
-        :decompositions ,decompositions
-        ))))
+        :decompositions ,decompositions))))
 
 (defun plan-tree->decompositions (tree &key (if-not-ground :error) orphans-ok (verbose 0))
+  "Traverses TREE and returns a sorted (by integer id) list of DECOMPOSITION-RECORDs."
   (declare (optimize debug))
+  (index-plan-tree tree if-not-ground)
+  (generate-decompositions tree if-not-ground orphans-ok verbose))
+
+(defvar *trace-indexer* nil)
+
+;;; Helper function for PLAN-TREE->DECOMPOSITIONS.
+;;; Traverses the plan tree and populates the *TASK-INDICES* using
+;;; TASK-INDEX. Returns nothing.
+(defun index-plan-tree (tree if-not-ground)
+  (declare (optimize debug))
+  (format t "~&INDEXER: *trace-indexer* is ~a~%"
+          *trace-indexer*)
   (let* ((open (etypecase tree
-                 (list tree)
+                 (list
+                  ;; tree
+                  (error "HDDL plan tree construction only works on enhanced plan trees."))
                  (plan-tree:top-node (resolve-extended-plan-tree-child tree))))
          (top-nodes (copy-list open)))
     ;; (format t "~&Starting to compute decompositions:~%")
@@ -200,29 +230,42 @@ Classic SHOP plans do not contain all the required information."
       (while open)
       (as node = (pop open))
       (as task = (tree-node-task node :if-not-ground if-not-ground))
-      (with found)
+      ;; so there aren't duplicates here -- must be that we are calling TASK-INDEX
+      ;; twice on the same node.
+      ;; FIXME: delete this check once the duplicate indexing has been found.
+      (assert (equalp (length (remove-duplicates open)) (length open)))
       ;; Don't index internal operators
       (unless (shop::internal-operator-p
                (shop:task-name task))
-        (setf found (nth-value 1 (task-index task)))
-        (cond ((primitive-node-p node)
-               (unless found
-                 (error "Found new primitive node: all primitive nodes should be indexed already.")))
-              ((typep node 'plan-tree:pseudo-node)
-               (error "Tried to index a pseudo-node."))
-              ((complex-node-p node)
-               (when (and found (not (find node top-nodes :test 'eq)))
-                 (error "Found a previously indexed complex node ~A in indexing pass." node))
-               (let* ((children (complex-node-children node))
-                      (cc (remove-if #'primitive-node-p children)))
-                 (appendf open cc)))))))
-
+        ;; index the task when it's popped off the open list
+        (let ((found (nth-value 1 (task-index task))))
+          (when *trace-indexer*
+            (format t "~&INDEXER: node is ~a ~:[NOT FOUND~;FOUND~]~%"
+                    node found)
+            (force-output t))
+          (cond ((primitive-node-p node)
+                 (unless found
+                   (error "Found new primitive node: all primitive nodes should be indexed already.")))
+                ((typep node 'plan-tree:pseudo-node)
+                 (error "Tried to index a pseudo-node."))
+                ((complex-node-p node)
+                 (when (and found (not (find node top-nodes :test 'eq)))
+                   (error "Found a previously indexed complex node ~A in indexing pass." node))
+                 (let* ((children (complex-node-children node))
+                        (cc (remove-if #'primitive-node-p children)))
+                   (appendf open cc)))))))))
+
+;;; Helper function for PLAN-TREE->DECOMPOSITIONS.
+;;; Traverses the TREE and returns a sorted list of decomposition records.
+(defun generate-decompositions (tree if-not-ground orphans-ok verbose)
+  (declare (optimize debug))
   (let ((open (etypecase tree
                 (list tree)
                 (plan-tree:top-node (resolve-extended-plan-tree-child tree))))
         ;; note that visited is 0-indexed and the indices have 1 as their origin.
         (visited (make-array (1- *next-index*) :element-type 'boolean :initial-element nil))
         retval)
+
     (flet ((set-visited (i)
              (setf (aref visited (1- i)) t))
            (arr-index->index (i)
@@ -230,30 +273,28 @@ Classic SHOP plans do not contain all the required information."
       (iter
         (while open)
         (as node = (pop open))
-        (with id) (with found)
         (as task = (tree-node-task node :if-not-ground if-not-ground))
-        (multiple-value-setq (id found) (task-index task))
-        (unless found
-          (error "All nodes should have been indexed before the pass to construct the decomposition records."))
-        (set-visited id)   ; convert 1-based to 0
-        (when (complex-node-p node)
-          ;; children here have been resolved so that pseudo-nodes
-          ;; have been skipped
-          (let ((children (complex-node-children node)))
-            (iter (for child in children)
-              (with cindex) (with found)
+        (multiple-value-bind (id found)
+            (task-index task)
+          (unless found
+            (error "All nodes should have been indexed before the pass to construct the decomposition records."))
+          (set-visited id)                ; convert 1-based to 0
+          (when (complex-node-p node)
+            ;; children here have been resolved so that pseudo-nodes
+            ;; have been skipped
+            (iter (for child in (complex-node-children node))
               (unless (shop::internal-operator-p
                        (shop:task-name (tree-node-task child :if-not-ground :ignore)))
-                (multiple-value-setq (cindex found)
-                  (node-index child))
-                (unless found
-                  (error "Unable to find an index for node ~a child of ~a"
-                         child node))
-                (if (complex-node-p child)
-                    (push child open)
-                    ;; must mark primitive nodes here
-                    (set-visited cindex))
-                (collecting cindex into child-indices))
+                (multiple-value-bind (cindex found)
+                    (node-index child)
+                  (unless found
+                    (error "Unable to find an index for node ~a child of ~a"
+                           child node))
+                  (if (complex-node-p child)
+                      (push child open)
+                      ;; must mark primitive nodes here
+                      (set-visited cindex))
+                  (collecting cindex into child-indices)))
               (finally
                (push (make-decomposition-record :node-id id
                                                 :task task
@@ -266,9 +307,9 @@ Classic SHOP plans do not contain all the required information."
                              (unless x (collecting (arr-index->index i)))))) ; correct zero-based to 1-based
             (if orphans-ok
                 (format t ";;; PLAN-TREE->DECOMPOSITIONS: Some tree node~p ~:[was~;were~] not visited when building the decomposition records: ~{~d~^,~}"
-                   (length unvisited)
-                   (> (length unvisited) 1)
-                   unvisited)
+                        (length unvisited)
+                        (> (length unvisited) 1)
+                        unvisited)
                 (error "Some tree node~p ~:[was~;were~] not visited when building the decomposition records: ~{~d~^,~}"
                        (length unvisited)
                        (> (length unvisited) 1)

From d6fc504484eff4b1448a8aa2363b1258a7be195f Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Mon, 12 Aug 2024 15:24:55 -0500
Subject: [PATCH 06/13] Add tests for HDDL tree generation.

---
 shop3/tests/new-plan-tree-tests.lisp | 96 ++++++++++++++++++++++++++++
 1 file changed, 96 insertions(+)
 create mode 100644 shop3/tests/new-plan-tree-tests.lisp

diff --git a/shop3/tests/new-plan-tree-tests.lisp b/shop3/tests/new-plan-tree-tests.lisp
new file mode 100644
index 00000000..a9c96f02
--- /dev/null
+++ b/shop3/tests/new-plan-tree-tests.lisp
@@ -0,0 +1,96 @@
+;;;---------------------------------------------------------------------------
+;;; Tests for the new SHOP plan tree -- the one created by explicit stack
+;;; search and used for plan repair. [2024/08/09:rpg]
+;;;---------------------------------------------------------------------------
+(defpackage :new-plan-tree-tests
+  (:use :common-lisp :fiveam)
+  (:import-from #:shop
+                #:find-plans-stack)
+  (:import-from #:plan-tree
+                #:make-tree-and-plan
+                #:tree-node-task
+                #:tree-and-plan-tree
+                #:tree-and-plan-plan
+                #:map-tree
+                #:compare-trees
+                ))
+
+
+(in-package :new-plan-tree-tests)
+
+(def-suite* new-plan-tree-tests)
+
+(defun all-tree-tasks (tree)
+  (let (tasks)
+    (map-tree #'(lambda (x)
+                  (let ((task (tree-node-task x)))
+                    (if (symbolp task)
+                        (unless (or (null task)
+                                    (equalp (symbol-name task)
+                                            (symbol-name '#:top)))
+                          (error "Unexpected node task: ~s" task))
+                        (push (tree-node-task x) tasks))))
+              tree)
+    (sort tasks #'shop:prop-sorter)))
+
+(defvar *good-tasks* nil)
+(defvar *bad-tasks* nil)
+
+(test test-hddl-tree
+  (let* ((pr (first (find-plans-stack 'shop3-rovers:roverprob01 :unpack-returns nil :plan-tree t)))
+         (pt (make-tree-and-plan :tree (shop:tree pr) :plan (shop:plan pr)))
+         (pt2 (eval (make-load-form pt)))
+         (tree1 (shop-hddl:hddl-plan (shop:plan pr) (shop:tree pr)))
+         (tree2 (shop-hddl:hddl-plan (tree-and-plan-plan pt) (tree-and-plan-tree pt))))
+    (is
+     (equalp tree1 tree2))
+    (is (equalp (all-tree-tasks (shop:tree pr)) (all-tree-tasks (tree-and-plan-tree pt))))
+    (is (equalp (all-tree-tasks (tree-and-plan-tree pt))
+                (all-tree-tasks (tree-and-plan-tree pt2))))
+    (let ((*trace-output* *standard-output*)
+          (hddl-translator::*trace-indexer* t))
+      (declare (special hddl-translator::*trace-indexer*))
+      (trace hddl-translator::task-index)
+      (format t "~&Good tasks:~%")
+      (pprint (setf *good-tasks* (all-tree-tasks (tree-and-plan-tree pt))))
+      (format t "~&Bad tasks:~%")
+      (pprint (setf *bad-tasks* (all-tree-tasks (tree-and-plan-tree pt2)))))
+    (untrace hddl-translator::task-index)
+    (let ((tree3 (shop-hddl:hddl-plan (tree-and-plan-plan pt2) (tree-and-plan-tree pt2)
+                                      :if-not-ground :ignore)))
+      (is (equalp tree1 tree3)))))
+
+(defmacro compare-tree-helper (expr1 expr2)
+  `(multiple-value-bind (matchp mismatch)
+                   (compare-trees ,expr1 ,expr2)
+               (or matchp
+                   (progn
+                     (let ((*print-length* 80))
+                      (format t "~&Tree mismatch b/w ~s and ~s at nodes:~%~t~a~%~t~a~%"
+                              ',expr1 ',expr2
+                              (first mismatch) (second mismatch)))
+                     (format t "~s:~%" ',expr1)
+                     (describe (first mismatch))
+                     (format t "~s:~%" ',expr2)
+                     (describe (second mismatch))
+                     (error
+                      ;; format t
+                      "~&Tree mismatch b/w pr and pt at nodes: ~a ~a~%"
+                      (first mismatch) (second mismatch))))))
+
+
+(test test-make-load-form
+  (let* ((pr (first (find-plans-stack 'shop3-rovers:roverprob01 :unpack-returns nil :plan-tree t)))
+         (pt (make-tree-and-plan :tree (shop:tree pr) :plan (shop:plan pr)))
+         (pt2 (eval (make-load-form pt))))
+    (is
+     (equalp (shop:plan pr) (tree-and-plan-plan pt)))
+    (is
+     (equalp (tree-and-plan-plan pt) (tree-and-plan-plan pt2)))
+    (is (equalp (all-tree-tasks (shop:tree pr))
+                (all-tree-tasks (tree-and-plan-tree pt))))
+    (is (equalp (all-tree-tasks (tree-and-plan-tree pt))
+                (all-tree-tasks (tree-and-plan-tree pt2))))
+    (is (eq (shop:tree pr) (tree-and-plan-tree pt)))
+    (is-true (compare-tree-helper (shop:tree pr) (tree-and-plan-tree pt)))
+    (is-true (compare-tree-helper (shop:tree pr) (tree-and-plan-tree pt2)))))

From 7e6a25ff8faa1ae148a7e3d4769db6e9d626338a Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Tue, 13 Aug 2024 14:21:59 -0500
Subject: [PATCH 07/13] Version with extensive debugging.

Many print statements, etc. Saving before I remove them.
---
 shop3/hddl/hddl-plan.lisp            |  19 ++--
 shop3/tests/new-plan-tree-tests.lisp | 159 +++++++++++++++++++++------
 2 files changed, 138 insertions(+), 40 deletions(-)

diff --git a/shop3/hddl/hddl-plan.lisp b/shop3/hddl/hddl-plan.lisp
index 94228a54..823cbea5 100644
--- a/shop3/hddl/hddl-plan.lisp
+++ b/shop3/hddl/hddl-plan.lisp
@@ -57,16 +57,19 @@
          (shop:primitive-node-task node))
         ((typep node 'shop:complex-node)
          (shop:complex-node-task node))
+        ;; from the new plan tree, we want a grounded task, and we prefer
+        ;; the TREE-NODE-EXPANDED-TASK.
         ((plan-tree:tree-node-p node)
          (grounded-tree-node-task node if-not-ground))
         (t (error 'type-error :expected-type '(or shop:primitive-node shop:complex-node plan-tree:tree-node)
                               :datum node))))
 
 ;;; Return the grounded task from NODE, if available, consulting both the
-;;; node's task and expanded-task.  Handle the case where no grounded task
-;;; is found according to IF-NOT-GROUND
+;;; node's task and expanded-task (preferring the latter).
+;;; Handle the case where no grounded task is found according to IF-NOT-GROUND
+#-allegro
 (declaim (ftype (function (plan-tree:tree-node (member :error :warn :ignore)))
-                grounded-tree-node-task))
+                (only-value grounded-tree-node-task)))
 (defun grounded-tree-node-task (node if-not-ground)
   (let ((task (plan-tree:tree-node-task node))
         (expanded-task (plan-tree:tree-node-expanded-task node)))
@@ -164,8 +167,7 @@ return its children instead.  Needed for ESS plan trees.
 (declaim (ftype (function (list) #-allegro (only-values fixnum boolean)
                                  #+allegro (values fixnum boolean))
                 task-index)
-         ;; FIXME: could give better type for parameter below
-         (ftype (function (t) #-allegro (only-values fixnum boolean)
+         (ftype (function (plan-tree:tree-node) #-allegro (only-values fixnum boolean)
                               #+allegro (values fixnum boolean))
                 node-index))
 (defun task-index (task)
@@ -177,7 +179,7 @@ return its children instead.  Needed for ESS plan trees.
       (values index nil))))
 
 (defun node-index (node)
-  (task-index (tree-node-task node)))
+  (task-index (plan-tree:tree-node-expanded-task node)))
 
 (defun hddl-plan (plan tree &key orphans-ok (if-not-ground :error) (verbose 0))
   "Take a SHOP PLAN and TREE (really a forest) as input and produce an
@@ -253,6 +255,9 @@ Classic SHOP plans do not contain all the required information."
                    (error "Found a previously indexed complex node ~A in indexing pass." node))
                  (let* ((children (complex-node-children node))
                         (cc (remove-if #'primitive-node-p children)))
+                   (when *trace-indexer*
+                     (format t "~&INDEXER: Adding ~d children:~%~{~T~a~%~}"
+                             (length cc) cc))
                    (appendf open cc)))))))))
 
 ;;; Helper function for PLAN-TREE->DECOMPOSITIONS.
@@ -275,7 +280,7 @@ Classic SHOP plans do not contain all the required information."
         (as node = (pop open))
         (as task = (tree-node-task node :if-not-ground if-not-ground))
         (multiple-value-bind (id found)
-            (task-index task)
+            (node-index task)
           (unless found
             (error "All nodes should have been indexed before the pass to construct the decomposition records."))
           (set-visited id)                ; convert 1-based to 0
diff --git a/shop3/tests/new-plan-tree-tests.lisp b/shop3/tests/new-plan-tree-tests.lisp
index a9c96f02..1953fc36 100644
--- a/shop3/tests/new-plan-tree-tests.lisp
+++ b/shop3/tests/new-plan-tree-tests.lisp
@@ -5,7 +5,10 @@
 (defpackage :new-plan-tree-tests
   (:use :common-lisp :fiveam)
   (:import-from #:shop
-                #:find-plans-stack)
+                #:find-plans-stack
+                #:shorter-plan
+                #:task-name
+                #:internal-operator-p)
   (:import-from #:plan-tree
                 #:make-tree-and-plan
                 #:tree-node-task
@@ -13,7 +16,13 @@
                 #:tree-and-plan-plan
                 #:map-tree
                 #:compare-trees
-                ))
+                #:tree-node-expanded-task
+                #:primitive-tree-node-p
+                )
+  (:import-from #:hddl-translator
+                #:*task-indices*
+                #:*next-index*
+   ))
 
 
 (in-package :new-plan-tree-tests)
@@ -23,42 +32,83 @@
 (defun all-tree-tasks (tree)
   (let (tasks)
     (map-tree #'(lambda (x)
-                  (let ((task (tree-node-task x)))
-                    (if (symbolp task)
-                        (unless (or (null task)
-                                    (equalp (symbol-name task)
-                                            (symbol-name '#:top)))
-                          (error "Unexpected node task: ~s" task))
-                        (push (tree-node-task x) tasks))))
+                  (let ((task (tree-node-expanded-task x)))
+                    (cond
+                      ((symbolp task)
+                       (unless (or (null task)
+                                   (equalp (symbol-name task)
+                                           (symbol-name '#:top)))
+                         (error "Unexpected node task: ~s" task)))
+                      ((primitive-tree-node-p x)
+                       (push (tree-node-expanded-task x) tasks)))))
               tree)
     (sort tasks #'shop:prop-sorter)))
 
 (defvar *good-tasks* nil)
 (defvar *bad-tasks* nil)
 
-(test test-hddl-tree
+(test test-hddl-plan-indexing           ; 5 checks
   (let* ((pr (first (find-plans-stack 'shop3-rovers:roverprob01 :unpack-returns nil :plan-tree t)))
-         (pt (make-tree-and-plan :tree (shop:tree pr) :plan (shop:plan pr)))
-         (pt2 (eval (make-load-form pt)))
-         (tree1 (shop-hddl:hddl-plan (shop:plan pr) (shop:tree pr)))
-         (tree2 (shop-hddl:hddl-plan (tree-and-plan-plan pt) (tree-and-plan-tree pt))))
-    (is
-     (equalp tree1 tree2))
-    (is (equalp (all-tree-tasks (shop:tree pr)) (all-tree-tasks (tree-and-plan-tree pt))))
-    (is (equalp (all-tree-tasks (tree-and-plan-tree pt))
-                (all-tree-tasks (tree-and-plan-tree pt2))))
-    (let ((*trace-output* *standard-output*)
-          (hddl-translator::*trace-indexer* t))
-      (declare (special hddl-translator::*trace-indexer*))
-      (trace hddl-translator::task-index)
-      (format t "~&Good tasks:~%")
-      (pprint (setf *good-tasks* (all-tree-tasks (tree-and-plan-tree pt))))
-      (format t "~&Bad tasks:~%")
-      (pprint (setf *bad-tasks* (all-tree-tasks (tree-and-plan-tree pt2)))))
-    (untrace hddl-translator::task-index)
-    (let ((tree3 (shop-hddl:hddl-plan (tree-and-plan-plan pt2) (tree-and-plan-tree pt2)
-                                      :if-not-ground :ignore)))
-      (is (equalp tree1 tree3)))))
+         (plan (shop:plan pr))
+         (shorter (shorter-plan plan))
+         (tree (shop:tree pr))
+         (*next-index* 1)
+         (*task-indices* (make-hash-table :test 'eq))
+         (indexed-plan (hddl-translator::index-shop-plan shorter))
+         (root-tasks (hddl-translator::forest-roots tree))
+         (all-tasks (all-tree-tasks tree)))
+    (flet ((is-indexed (x)
+             (or (shop:internal-operator-p (task-name x))
+                 (gethash x *task-indices*)))
+           (primitive-task-p (x)
+             (shop::primitivep
+              (task-name x)))
+           (internal-task-p (x)
+             (internal-operator-p
+              (task-name x))))
+    (is (equalp (alexandria:iota (length shorter) :start 1)
+                (mapcar #'car indexed-plan)))
+    (is (equalp shorter
+                (mapcar #'cdr indexed-plan)))
+    (is (= (length shorter)
+           (length
+            (remove-if #'internal-task-p (remove-if-not #'primitive-task-p all-tasks))))
+        ;; "Number of primitive tasks in tree (~d) not equal to number of actions in plan (~d).~%Plan:~%~{~t~s~%~}~%Tree tasks:~%~{~t~s~%~}"
+        ;; (length
+        ;;     (remove-if-not #'primitive-task-p all-tasks))
+        ;; (length shorter)
+        ;; (sort (copy-list shorter) #'shop3cmn::prop-sorter)
+        ;; (sort (remove-if-not #'primitive-task-p all-tasks) #'shop3cmn::prop-sorter)
+        )
+    (is (equalp '((shop-rovers::achieve-goals))
+                root-tasks))
+    (let ((root-indices (mapcar #'hddl-translator::task-index root-tasks)))
+      (is (= 1 (length root-indices))))
+    (hddl-translator::index-plan-tree tree :error)
+      (let* ((unindexed (remove-if #'is-indexed
+                                  (all-tree-tasks tree)))
+             (unindexed-primitives (remove-if-not #'(lambda (x)
+                                                      (and
+                                                       (primitive-task-p x)
+                                                       (not (internal-task-p x))))
+                                                  unindexed)))
+        ;; (format t "~&UN-indexed tasks:~%")
+        ;; (pprint unindexed)
+        ;; (format t "~&~d unindexed primitive tasks.~%"
+        ;;         (length unindexed-primitives))
+        ;; (format t "Not in plan:~%~{~t~s~%~}"
+        ;;         (remove-if #'(lambda (x) (member x shorter))
+        ;;                    unindexed-primitives))
+        ;; (format t "Not in plan by equality:~%~{~t~s~%~}"
+        ;;         (remove-if #'(lambda (x) (member x shorter :test #'equalp))
+        ;;                    unindexed-primitives))
+        )
+      (is-true (every #'is-indexed
+                      (all-tree-tasks tree))))
+    ;; (hddl-translator::generate-decompositions tree :error nil 0)
+    ))
+
+
 
 (defmacro compare-tree-helper (expr1 expr2)
   `(multiple-value-bind (matchp mismatch)
@@ -78,8 +128,7 @@
                       "~&Tree mismatch b/w pr and pt at nodes: ~a ~a~%"
                       (first mismatch) (second mismatch))))))
 
-
-(test test-make-load-form
+(test test-make-load-form ; 7 checks
   (let* ((pr (first (find-plans-stack 'shop3-rovers:roverprob01 :unpack-returns nil :plan-tree t)))
          (pt (make-tree-and-plan :tree (shop:tree pr) :plan (shop:plan pr)))
          (pt2 (eval (make-load-form pt))))
@@ -94,3 +143,47 @@
     (is (eq (shop:tree pr) (tree-and-plan-tree pt)))
     (is-true (compare-tree-helper (shop:tree pr) (tree-and-plan-tree pt)))
     (is-true (compare-tree-helper (shop:tree pr) (tree-and-plan-tree pt2)))))
+
+(test test-expanded-tasks ; 5 checks
+  ;; Verify that the expanded tasks are the correct tasks to use.
+  (let* ((pr (first (find-plans-stack 'shop3-rovers:roverprob01 :unpack-returns nil :plan-tree t)))
+         (tree (shop:tree pr))
+         (plan (shop:plan pr))
+         (primitive-nodes (plan-tree:find-all-tree-nodes-if #'plan-tree::primitive-tree-node-p tree))
+         (real-complex-nodes (plan-tree:find-all-tree-nodes-if #'(lambda (x)
+                                                                   (and (plan-tree::complex-tree-node-p x)
+                                                                        (not (plan-tree::pseudo-node-p x))
+                                                                        (not (plan-tree::top-node-p x))))
+                                                               tree)))
+    (is-true (every #'(lambda (x) (tree-node-expanded-task x)) primitive-nodes))
+    (is-false (some #'(lambda (x) (eq (plan-tree:tree-node-task x) (tree-node-expanded-task x))) primitive-nodes))
+    (is-true (every #'(lambda (x) (tree-node-expanded-task x)) real-complex-nodes))
+    (is-false (some #'(lambda (x) (eq (plan-tree:tree-node-task x) (tree-node-expanded-task x))) real-complex-nodes))
+    (is-true (alexandria:set-equal (shorter-plan plan)
+                                   (mapcar #'(lambda (x) (tree-node-expanded-task x))
+                                           (remove-if #'(lambda (n) (internal-operator-p (task-name (tree-node-expanded-task n))))
+                                                      primitive-nodes))))))
+
+(test test-hddl-tree ; 4 checks
+  (let* ((pr (first (find-plans-stack 'shop3-rovers:roverprob01 :unpack-returns nil :plan-tree t)))
+         (pt (make-tree-and-plan :tree (shop:tree pr) :plan (shop:plan pr)))
+         (pt2 (eval (make-load-form pt)))
+         (tree1 (shop-hddl:hddl-plan (shop:plan pr) (shop:tree pr)))
+         (tree2 (shop-hddl:hddl-plan (tree-and-plan-plan pt) (tree-and-plan-tree pt))))
+    (is
+     (equalp tree1 tree2))
+    (is (equalp (all-tree-tasks (shop:tree pr)) (all-tree-tasks (tree-and-plan-tree pt))))
+    (is (equalp (all-tree-tasks (tree-and-plan-tree pt))
+                (all-tree-tasks (tree-and-plan-tree pt2))))
+    ;; (let ((*trace-output* *standard-output*)
+    ;;       (hddl-translator::*trace-indexer* t))
+    ;;   (declare (special hddl-translator::*trace-indexer*))
+    ;;   (trace hddl-translator::task-index)
+    ;;   (format t "~&Good tasks:~%")
+    ;;   (pprint (setf *good-tasks* (all-tree-tasks (tree-and-plan-tree pt))))
+    ;;   (format t "~&Bad tasks:~%")
+    ;;   (pprint (setf *bad-tasks* (all-tree-tasks (tree-and-plan-tree pt2)))))
+    ;; (untrace hddl-translator::task-index)
+    (let ((tree3 (shop-hddl:hddl-plan (tree-and-plan-plan pt2) (tree-and-plan-tree pt2)
+                                      :if-not-ground :ignore)))
+      (is (equalp tree1 tree3)))))

From 3cebde65e89c36fecc1024b0a98d94b5d21a5b5c Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Tue, 13 Aug 2024 14:24:04 -0500
Subject: [PATCH 08/13] Fix bug in plan tree duplication.

---
 shop3/explicit-stack-search/plan-tree.lisp | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/shop3/explicit-stack-search/plan-tree.lisp b/shop3/explicit-stack-search/plan-tree.lisp
index 9cc4bcf2..916a26c5 100644
--- a/shop3/explicit-stack-search/plan-tree.lisp
+++ b/shop3/explicit-stack-search/plan-tree.lisp
@@ -3,6 +3,9 @@
 (defpackage plan-tree-vars)
 
 (defstruct tree-and-plan
+  "Structure that pairs a plan tree and a plan sequence,
+required to be together for duplication because they share
+structure."
   tree
   plan)
 
@@ -97,8 +100,7 @@ cross-links for VAL using information in TABLE."))
 ;;; only subclasses should be instantiated.
 (defstruct tree-node
   task
-  expanded-task                         ; the substituted method head.
-                                        ; should always be NIL for primitive tasks.
+  expanded-task                         ; the substituted task (method head for complex tasks).
   dependencies ;; what does this tree node depend on -- dependencies IN
   parent
   )
@@ -126,7 +128,7 @@ cross-links for VAL using information in TABLE."))
   `(:task
     ,(slot-value-translator (tree-node-task obj))
     :expanded-task
-    ,(slot-value-translator (tree-node-task obj))))
+    ,(slot-value-translator (tree-node-expanded-task obj))))
 
 (defun make-cross-links (&optional (table *table-for-load-form*))
   (iter (for (val var) in-hashtable table)
@@ -135,7 +137,7 @@ cross-links for VAL using information in TABLE."))
       (cross-links-for var val table)))))
 
 (defmethod make-instantiator ((obj primitive-tree-node))
-  `(make-primitive-tree-node ,@ (slot-fillers obj)))
+  `(make-primitive-tree-node ,@(slot-fillers obj)))
 
 (defstruct (complex-tree-node (:include tree-node))
   (children nil :type list)
@@ -468,12 +470,14 @@ Particularly useful for structures, but could be generally applicable."
     (copy-complex-tree-node node)))
 
 
+#|
 (declaim
  (ftype
   (function (top-node hash-table hash-table)
             (values top-node hash-table &optional))
   copy-plan-tree))
 
+;;; this appears to be incomplete!
 (defun copy-plan-tree (plan-tree lookup-table translation-table)
   "Make a new copy of PLAN-TREE (indexed by LOOKUP-TABLE), and using the
 input TRANSLATION-TABLE, which translates old primitive tasks to new primitive
@@ -529,6 +533,7 @@ tasks."
         (assert new-root)
         (setf (top-node-lookup-table new-root) new-lookup-table)
         (values new-root new-lookup-table)))))
+|#
 
 
 ;;;---------------------------------------------------------------------------

From 93cb2f75002dfa4807d5e10719c239df9a9241e8 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Tue, 13 Aug 2024 14:28:00 -0500
Subject: [PATCH 09/13] Add new plan tree tests.

---
 shop3/shop3.asd                      | 10 +++++---
 shop3/tests/new-plan-tree-tests.lisp | 35 +++-------------------------
 2 files changed, 10 insertions(+), 35 deletions(-)

diff --git a/shop3/shop3.asd b/shop3/shop3.asd
index 19a43208..036cbf86 100644
--- a/shop3/shop3.asd
+++ b/shop3/shop3.asd
@@ -278,11 +278,13 @@ minimal affected subtree."
                  (plan-tree-tests . :plan-tree-tests)  ; 40
                  (search-tests . :search-tests) ; 9
                  (plan-num-limit-tests . :plan-num-limit-tests) ; 25
+                 (new-plan-tree-tests . :new-plan-tree-tests) ; 21
                  )
-    :num-checks 1101
+    :num-checks 1122
     :depends-on ((:version "shop3" (:read-file-form "shop-version.lisp-expr"))
                  "shop3/openstacks"
                  "shop3/pddl-helpers"
+                 "shop3/rovers"         ; for new plan tree tests
                  "pddl-utils")
     :version (:read-file-form "shop-version.lisp-expr")
     :components ((:module "shop-test-helper"
@@ -392,8 +394,10 @@ minimal affected subtree."
                                                                    "Log_ran_problems_50"
                                                                    "Log_ran_problems_55"
                                                                    "Log_ran_problems_60"))))
-                 (:file "replan-tests" :pathname "tests/replan-tests")
-                 (:file "hddl-tests" :pathname "tests/hddl-tests")))
+                 (:file "replan-tests" :pathname "tests/replan-tests/")
+                 (:file "hddl-tests" :pathname "tests/hddl-tests/")
+                 (:file "new-plan-tree-tests" :pathname "tests/") ; 21 checks
+                 ))
 
 
 (defsystem shop3/test-satellite
diff --git a/shop3/tests/new-plan-tree-tests.lisp b/shop3/tests/new-plan-tree-tests.lisp
index 1953fc36..e6c98a12 100644
--- a/shop3/tests/new-plan-tree-tests.lisp
+++ b/shop3/tests/new-plan-tree-tests.lisp
@@ -72,14 +72,7 @@
                 (mapcar #'cdr indexed-plan)))
     (is (= (length shorter)
            (length
-            (remove-if #'internal-task-p (remove-if-not #'primitive-task-p all-tasks))))
-        ;; "Number of primitive tasks in tree (~d) not equal to number of actions in plan (~d).~%Plan:~%~{~t~s~%~}~%Tree tasks:~%~{~t~s~%~}"
-        ;; (length
-        ;;     (remove-if-not #'primitive-task-p all-tasks))
-        ;; (length shorter)
-        ;; (sort (copy-list shorter) #'shop3cmn::prop-sorter)
-        ;; (sort (remove-if-not #'primitive-task-p all-tasks) #'shop3cmn::prop-sorter)
-        )
+            (remove-if #'internal-task-p (remove-if-not #'primitive-task-p all-tasks)))))
     (is (equalp '((shop-rovers::achieve-goals))
                 root-tasks))
     (let ((root-indices (mapcar #'hddl-translator::task-index root-tasks)))
@@ -91,22 +84,9 @@
                                                       (and
                                                        (primitive-task-p x)
                                                        (not (internal-task-p x))))
-                                                  unindexed)))
-        ;; (format t "~&UN-indexed tasks:~%")
-        ;; (pprint unindexed)
-        ;; (format t "~&~d unindexed primitive tasks.~%"
-        ;;         (length unindexed-primitives))
-        ;; (format t "Not in plan:~%~{~t~s~%~}"
-        ;;         (remove-if #'(lambda (x) (member x shorter))
-        ;;                    unindexed-primitives))
-        ;; (format t "Not in plan by equality:~%~{~t~s~%~}"
-        ;;         (remove-if #'(lambda (x) (member x shorter :test #'equalp))
-        ;;                    unindexed-primitives))
-        )
+                                                  unindexed))))
       (is-true (every #'is-indexed
-                      (all-tree-tasks tree))))
-    ;; (hddl-translator::generate-decompositions tree :error nil 0)
-    ))
+                      (all-tree-tasks tree))))))
 
 
 
@@ -175,15 +155,6 @@
     (is (equalp (all-tree-tasks (shop:tree pr)) (all-tree-tasks (tree-and-plan-tree pt))))
     (is (equalp (all-tree-tasks (tree-and-plan-tree pt))
                 (all-tree-tasks (tree-and-plan-tree pt2))))
-    ;; (let ((*trace-output* *standard-output*)
-    ;;       (hddl-translator::*trace-indexer* t))
-    ;;   (declare (special hddl-translator::*trace-indexer*))
-    ;;   (trace hddl-translator::task-index)
-    ;;   (format t "~&Good tasks:~%")
-    ;;   (pprint (setf *good-tasks* (all-tree-tasks (tree-and-plan-tree pt))))
-    ;;   (format t "~&Bad tasks:~%")
-    ;;   (pprint (setf *bad-tasks* (all-tree-tasks (tree-and-plan-tree pt2)))))
-    ;; (untrace hddl-translator::task-index)
     (let ((tree3 (shop-hddl:hddl-plan (tree-and-plan-plan pt2) (tree-and-plan-tree pt2)
                                       :if-not-ground :ignore)))
       (is (equalp tree1 tree3)))))

From d315cc773b1298ce0f9e7b087efb23f3338ad198 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Tue, 13 Aug 2024 14:43:37 -0500
Subject: [PATCH 10/13] Fixes for SBCL.

---
 shop3/explicit-stack-search/plan-tree.lisp | 13 +++++++++++++
 shop3/hddl/hddl-plan.lisp                  | 10 ++++++++--
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/shop3/explicit-stack-search/plan-tree.lisp b/shop3/explicit-stack-search/plan-tree.lisp
index 916a26c5..eeb0d730 100644
--- a/shop3/explicit-stack-search/plan-tree.lisp
+++ b/shop3/explicit-stack-search/plan-tree.lisp
@@ -2,6 +2,19 @@
 
 (defpackage plan-tree-vars)
 
+;;;---------------------------------------------------------------------------
+;;; Type declarations for specifying function return values that make
+;;; SBCL happy.
+;;;---------------------------------------------------------------------------
+
+(deftype only-values (&rest value-spec)
+  `(values ,@value-spec &optional))
+
+(deftype only-value (value-spec)
+  `(values ,value-spec &optional))
+
+;;; End of DEFTYPEs
+
 (defstruct tree-and-plan
   "Structure that pairs a plan tree and a plan sequence,
 required to be together for duplication because they share
diff --git a/shop3/hddl/hddl-plan.lisp b/shop3/hddl/hddl-plan.lisp
index 823cbea5..7df7d6d3 100644
--- a/shop3/hddl/hddl-plan.lisp
+++ b/shop3/hddl/hddl-plan.lisp
@@ -36,6 +36,11 @@
 (deftype only-value (value-spec)
   `(values ,value-spec &optional))
 
+;;;---------------------------------------------------------------------------
+;;; Type declarations
+;;;---------------------------------------------------------------------------
+
+
 (deftype complex-node ()
   `(or shop::complex-node plan-tree:complex-tree-node))
 
@@ -68,8 +73,9 @@
 ;;; node's task and expanded-task (preferring the latter).
 ;;; Handle the case where no grounded task is found according to IF-NOT-GROUND
 #-allegro
-(declaim (ftype (function (plan-tree:tree-node (member :error :warn :ignore)))
-                (only-value grounded-tree-node-task)))
+(declaim (ftype (function (plan-tree:tree-node (member :error :warn :ignore))
+                          (only-value list))
+                grounded-tree-node-task))
 (defun grounded-tree-node-task (node if-not-ground)
   (let ((task (plan-tree:tree-node-task node))
         (expanded-task (plan-tree:tree-node-expanded-task node)))

From 81ec53ea2d41c2b66070dd213d711f6bbaa9d570 Mon Sep 17 00:00:00 2001
From: Robert Goldman <rpgoldman@sift.net>
Date: Tue, 13 Aug 2024 16:01:28 -0500
Subject: [PATCH 11/13] Fix indexing bug.

---
 shop3/hddl/hddl-plan.lisp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/shop3/hddl/hddl-plan.lisp b/shop3/hddl/hddl-plan.lisp
index 7df7d6d3..75f83a43 100644
--- a/shop3/hddl/hddl-plan.lisp
+++ b/shop3/hddl/hddl-plan.lisp
@@ -286,7 +286,7 @@ Classic SHOP plans do not contain all the required information."
         (as node = (pop open))
         (as task = (tree-node-task node :if-not-ground if-not-ground))
         (multiple-value-bind (id found)
-            (node-index task)
+            (node-index node)
           (unless found
             (error "All nodes should have been indexed before the pass to construct the decomposition records."))
           (set-visited id)                ; convert 1-based to 0

From d006823189686fa309ad688f2d7f99785d1d8a3b Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Thu, 15 Aug 2024 22:10:17 -0500
Subject: [PATCH 12/13] Fix grounded-tree-node-task.

Did not return the proper value when the task was not ground and
handled by `:warn` or `:ignore`.
---
 shop3/hddl/hddl-plan.lisp | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/shop3/hddl/hddl-plan.lisp b/shop3/hddl/hddl-plan.lisp
index 75f83a43..8e21331e 100644
--- a/shop3/hddl/hddl-plan.lisp
+++ b/shop3/hddl/hddl-plan.lisp
@@ -85,7 +85,8 @@
            task)
           (t (unless (eq if-not-ground :ignore)
                (funcall (if (eq if-not-ground :error) #'error #'warn)
-                        "Task for tree node ~a is not ground." node))))))
+                        "Task for tree node ~a is not ground." node))
+             expanded-task))))
 
 #-allegro
 (declaim (ftype (function (complex-node)

From bd1612e91af4d8044e1208e3601d7c4a5a0d093e Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Fri, 16 Aug 2024 15:53:15 -0500
Subject: [PATCH 13/13] Fix test suite.

---
 shop3/shop3.asd                      | 11 ++++++-----
 shop3/tests/hddl-tests.lisp          |  3 ++-
 shop3/tests/new-plan-tree-tests.lisp |  7 ++++---
 3 files changed, 12 insertions(+), 9 deletions(-)

diff --git a/shop3/shop3.asd b/shop3/shop3.asd
index 036cbf86..905323ea 100644
--- a/shop3/shop3.asd
+++ b/shop3/shop3.asd
@@ -278,9 +278,10 @@ minimal affected subtree."
                  (plan-tree-tests . :plan-tree-tests)  ; 40
                  (search-tests . :search-tests) ; 9
                  (plan-num-limit-tests . :plan-num-limit-tests) ; 25
-                 (new-plan-tree-tests . :new-plan-tree-tests) ; 21
+                 (hddl-plan-tests . :shop-hddl-tests) ; 7
+                 (new-plan-tree-tests . :new-plan-tree-tests) ; 22
                  )
-    :num-checks 1122
+    :num-checks 1131
     :depends-on ((:version "shop3" (:read-file-form "shop-version.lisp-expr"))
                  "shop3/openstacks"
                  "shop3/pddl-helpers"
@@ -394,9 +395,9 @@ minimal affected subtree."
                                                                    "Log_ran_problems_50"
                                                                    "Log_ran_problems_55"
                                                                    "Log_ran_problems_60"))))
-                 (:file "replan-tests" :pathname "tests/replan-tests/")
-                 (:file "hddl-tests" :pathname "tests/hddl-tests/")
-                 (:file "new-plan-tree-tests" :pathname "tests/") ; 21 checks
+                 (:file "replan-tests" :pathname "tests/replan-tests")
+                 (:file "hddl-tests" :pathname "tests/hddl-tests")
+                 (:file "new-plan-tree-tests" :pathname "tests/new-plan-tree-tests")
                  ))
 
 
diff --git a/shop3/tests/hddl-tests.lisp b/shop3/tests/hddl-tests.lisp
index e80ecbd4..a029e180 100644
--- a/shop3/tests/hddl-tests.lisp
+++ b/shop3/tests/hddl-tests.lisp
@@ -58,7 +58,8 @@
 (test plan-test-ess
   (load-log-problem)
   (with-plan-and-tree (plan tree :ess t)
-      (is (equalp expected-plan plan))
+    (declare (ignorable tree))
+    (is (equalp expected-plan plan))
     ;; (is (equalp expected-tree tree))
     ))
 
diff --git a/shop3/tests/new-plan-tree-tests.lisp b/shop3/tests/new-plan-tree-tests.lisp
index e6c98a12..6883b700 100644
--- a/shop3/tests/new-plan-tree-tests.lisp
+++ b/shop3/tests/new-plan-tree-tests.lisp
@@ -84,9 +84,10 @@
                                                       (and
                                                        (primitive-task-p x)
                                                        (not (internal-task-p x))))
-                                                  unindexed))))
-      (is-true (every #'is-indexed
-                      (all-tree-tasks tree))))))
+                                                  unindexed)))
+        (is-true (every #'is-indexed
+                        (all-tree-tasks tree)))
+        (is-false unindexed-primitives)))))