This is the second of three posts showing how to use Hhop to do HTN planning in a blocks world. The first post showed how to specify the world and the primitive actions that can be performed. This one shows how to specify domain knowledge. a set of compound tasks, and methods for accomplishing them.
The contents of this post are generated (unedited) from the source of the Hhop.Blocks.Tasks module.
> module Hhop.Blocks.Tasks where > import Hhop.Plan > import Hhop.Util > import Hhop.Blocks.World > import Data.Map (Map, (!)) > import qualified Data.Map as M
A goal is a mapping from blocks to desired positions. We assume that the goal positions are either on the table or another block (i.e., not in the hand). The representation only includes those blocks whose goal position is another block; if left out of the map, the goal position is the table.
> type BlocksGoal b = Map b b
It’s convenient to be able to easily convert from a
Maybe b (as returned by the Map’s
lookup method) to the
BlockPos b data type.
> asPos :: Eq b => Maybe b -> BlockPos b > asPos = maybe OnTable OnBlock
A goal is satisified if all blocks are in their desired positions.
> satisfied :: > (Bounded b, Enum b, Eq b, Ord b) => > BlocksWorld b -> BlocksGoal b -> Bool > satisfied w goal = all satisfy1 allBlocks > where satisfy1 b = w!b == asPos (M.lookup b goal)
A single block is at its goal if:
- Its goal is the table, and it is on the table, or
- Its goal is another block, it is on that block, and that block is at its goal.
We could, but did not, define
satisfied in terms of
atGoal; the current implementation is much more efficient.
> atGoal :: > (Bounded b, Enum b, Eq b, Ord b) => > BlocksWorld b -> BlocksGoal b -> b -> Bool > atGoal w goal b = > (w!b == asPos g) && > (maybe True (atGoal w goal) g) > where g = M.lookup b goal
We specify a set of four compound tasks.
> data BlocksTask b = > Move (BlocksGoal b) | > MoveToGoalBlock (BlocksGoal b) b | > MoveToTable b | > Get b > deriving Show
> blocksMethods :: > (Bounded b, Enum b, Eq b, Ord b, Show b) => > Methods (BlocksPrim b) (BlocksTask b) (BlocksWorld b)
Move task is the top-level task, and takes a goal as argument. If the goal is already satisfied, then there is nothing to do (an empty plan). Otherwise, we pick a block that is movable, and not yet at its goal, and try to either move it to its goal block (if any) or to the table.
This approach relies heavily on backtracking search: we don’t specify any way to pick which block to move, we just look through all of them, potentially generating many alternate plans. Haskell’s list monad uses lazy evaluation throughout, so we won’t actually try and compute all of those plans unless they are requested.
> blocksMethods (Move goal) w > | satisfied w goal = return done > | otherwise = do > b <- allBlocks > move1 <- [MoveToGoalBlock goal, MoveToTable] > when ((clear w b) && (not $ atGoal w goal b)) > (move1 b .> Move goal .> done)
We will try to move a block onto its goal block if it has a goal block, the goal block is clear, and the goal block is already at its own goal. That last condition means that we won’t do this unless we’re sure the goal block won’t need to move in the future, which avoids getting stuck.
> blocksMethods (MoveToGoalBlock goal b) w = > case M.lookup b goal of > Nothing ->  > Just g -> > when ((clear w g) && (atGoal w goal g)) $ > (Get b .> Stack b g .> done)
We are willing to move any block to the table, as long as it’s not already there; This check prevents us from repeatedly picking up and putting down the same block.
> blocksMethods (MoveToTable b) w = > when (w!b /= OnTable) > (Get b .> PutDown b .> done)
Get task moves a block to the hand, and has methods that choose an appropriate primitive task (
> blocksMethods (Get b) w = > when (clear w b) $ case w!b of > OnTable -> (PickUp b .> done) > OnBlock c -> (UnStack b c .> done) > InHand -> done
These four tasks, together with the primitive tasks defined in the
World module, define a blocks world domain.
> blocksDomain :: > (Bounded b, Enum b, Eq b, Ord b, Show b) => > Domain (BlocksPrim b)(BlocksTask b) (BlocksWorld b) > blocksDomain = Domain blockPerform blocksMethods