 
 
 
-(deftype WarehouseEnv [init goal] :as this
+(deftype WarehouseEnv [init goal topright] :as this
  env/Env
   (initial-state [] init)
   (actions-fn []

           [cx cy] tops
           :let [c (env/get-var state ['blockat cx cy])]
           :when (and (< cy h) (not (= b c)))]
       [(make-move-block-hla env nav-context
                             b bx by (env/get-var state ['blockat bx (dec by)]) c cx cy)
        (MoveBlocksHLA env goal-fn context nav-context b)]))))

(deftype WarehouseTLA [env context] :as this
    env/Action                (action-name [] '[top])
                              (primitive? [] false)
    env/ContextualAction      (precondition-context [s] context)
    hierarchy/HighLevelAction (immediate-refinements- [s] 
                                 (let [goal-fn (env/goal-fn env)
                                       [w h] (get (env/get-var s :const) '[topright])]
                                   (possible-move-refinements env goal-fn context 
                                     (set (cons '[at] (for [x (range 1 (inc w)) y (range 2 (inc h))] ['someblockat x y]))) nil s)))
                              (cycle-level- [s] nil))

 

(defn make-warehouse-tla [env]
  (WarehouseTLA env (util/keyset (dissoc (env/initial-state env) :const))))

(defn simple-warehouse-hierarchy [#^WarehouseEnv env]
  (hierarchy/SimpleHierarchicalEnv env [(make-warehouse-tla env)]))

;; TODO: heuristic
;; TODO: missing precond handling && preconds ? 

                           (contains? #{nil b} (env/get-var s ['blockat gx2 gy2])))]
            (concat
             (when (not (util/truth= fr? fr1))
               (conj (nav-factory gx1 h) (make-specific-turn [gx1 h] fr?)))
             (nav-factory gx1 gy1)
             [(make-specific-get b a fr1 gx1 gy1)]
             (when (not (util/truth= fr1 fr2))
               (conj (nav-factory gx2 h) (make-specific-turn [gx2 h] fr1)))
             (nav-factory gx2 gy2)
             [(make-specific-put b c fr2 gx2 gy2)]))))
      (cycle-level- [s] nil))

(defn make-move-block-hla [env nav-context nav-factory b bx by a c cx cy]
  (MoveBlockHLA env ['move-block b c]
                (into nav-context
                      ['[facingright] ['on a] ['on c] '[holding]
                       ['blockat bx by] ['blockat cx (inc cy)]]) 
                nav-factory b bx by a c cx cy))


(declare possible-move-refinements)

(deftype MoveBlocksHLA [env goal-fn context nav-context nav-factory block-off-limits] :as this
    env/Action                (action-name [] ['move-blocks block-off-limits ])
                              (primitive? [] false)
    env/ContextualAction      (precondition-context [s] context)
    hierarchy/HighLevelAction (immediate-refinements- [s] 
                                 (possible-move-refinements env goal-fn context nav-context 
                                                            nav-factory block-off-limits s))
                              (cycle-level- [s] 2))

; Note: differs from previous (strips) version in use of goal test.
;; TODO: should allow self-moves? 
(defn possible-move-refinements [env goal-fn context nav-context nav-factory block-off-limits state]
  (let [[w h] (get (env/get-var state :const) '[topright])
        tops  (for [x (range 1 (inc w))] 
                [x (last (take-while #(and (<= % h) (env/get-var state ['someblockat x %])) (range 1 (inc h))))])]
