We are going to solve this problem by doing a tree search in three parts. First we build a Tree representing the paths through the problem, with branches for each state. We would like to find the shortest way to get to the state with certain criteria, so we will write the width of the first search to search for any Tree . This will not be fast enough for an example of the problem you have provided, so we will improve the first width search using the transpose table which tracks which we have already studied so as not to examine them again.
Building a tree
Suppose your game panel is represented in Array from Data.Array
import Data.Array type Board = Array (Int, Int) Char board :: Board board = listArray ((1,1),(3,4)) ("AAAA" ++ "ACCB" ++ "ADEF")
Data.Array does not provide an easy, default easy way to make sure the indexes we are viewing with ! are actually within the Array . For convenience, we will provide a safe version that returns Just v if the value is in Array or Nothing otherwise.
import Data.Maybe (!?) :: Ix i => Array ia -> i -> Maybe a a !? i = if inRange (bounds a) i then Just (a ! i) else Nothing
State puzzles can be represented by a combination of a position robot and direction that the robot encounters.
data State = State {position :: (Int, Int), direction :: (Int, Int)} deriving (Eq, Ord, Show)
direction is a single vector that can be added to position to get a new position . We can rotate the direction vector left or right and moveTowards it.
right :: Num a => (a, a) -> (a, a) right (down, across) = (across, -down) left :: Num a => (a, a) -> (a, a) left (down, across) = (-across, down) moveTowards :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b) moveTowards (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
To examine the board, we will need to determine from which state the actions are legal. To do this, it would be useful to name the moves, so we will create a data type to represent possible moves.
import Prelude hiding (Right, Left) data Move = Left | Right | Forward | Jump deriving (Show)
To determine which actions are legal on the board, we need to know which Board we use and the State robot. This assumes the type moves :: Board -> State -> Move , but we are going to calculate a new state after each step to decide if the movement was legal, so we will also return the new state for convenience.
moves :: Board -> State -> [(Move, State)] moves board (State pos dir) = (if inRange (bounds board) pos then [(Right, State pos (right dir)), (Left, State pos (left dir))] else []) ++ (if next == Just here then [(Forward, State nextPos dir)] else []) ++ (if next == Just (succ here) then [(Jump, State nextPos dir)] else []) where here = fromMaybe 'A' (board !? pos) nextPos = moveTowards dir pos next = board !? nextPos
If we are on the board, we can turn left and right ; the restriction that we are on board ensures that all State returned moves have position that are on the board. If the value in the position nextPos , next matches what Just here , we can go Forward to it (if we are not with the board, we assume that here is 'A' ). If next is Just successor of what is here , we can Jump to it. If next is out of the board, it is Nothing and cannot match either Just here or Just (succ here) .
Up to this point, we simply provided a description of the problem and did not address the issue of the tree. We are going to use the rosewood Tree defined in Data.Tree .
data Tree a = Node { rootLabel :: a, -- ^ label value subForest :: Forest a -- ^ zero or more child trees } type Forest a = [Tree a]
Each node for Tree a contains a single value a and a list of branches, each of which is Tree a .
We are going to build the Tree list in a simple way from our moves function. We are going to make each result moves rootLabel a Node and make the branches a list of Tree , which we will get when we explore new state.
import Data.Tree explore :: Board -> State -> [Tree (Move, State)] explore board = map go . moves board where go (label, state) = Node (label, state) (explore board state)
At this moment, our trees are endless; nothing allows the robot to rotate endlessly in place. We cannot draw it, but we could, if we could limit tree by a few steps.
limit :: Int -> Tree a -> Tree a limit n (Node a ts) | n <= 0 = Node a [] | otherwise = Node a (map (limit (n-1)) ts)
We will only show the first pairs of tree levels when we start from the lower left corner facing the board in State (4, 1) (-1, 0) .
(putStrLn . drawForest . map (fmap (\(m, s) -> show (m, board ! position s)) . limit 2) . explore board $ State (4, 1) (-1, 0)) (Forward,'A') | +- (Right,'A') | | | +- (Right,'A') | | | `- (Left,'A') | +- (Left,'A') | | | +- (Right,'A') | | | `- (Left,'A') | `- (Forward,'A') | +- (Right,'A') | +- (Left,'A') | `- (Forward,'A')
First width search
The first breadth-first search explores all possibilities at one level (through the "width" of what is being viewed) before going down to the next level (into the "depth" of the search). The first breadth search finds the shortest path to the goal. For our trees, this means exploring all on one layer before exploring any of the inner layers. We accomplish this by creating a node queue to examine the addition of nodes that we discover at the next level until the end of the queue. Nodes from the current layer will always be held in the queue, followed by nodes from the next layer. He will never hold any nodes from this layer, because we will not open these nodes until we move to the next layer.
To implement this, we need an efficient queue, so we will use the sequence from Data.Sequence /
import Data.Sequence (viewl, ViewL (..), (><)) import qualified Data.Sequence as Seq
Let's start with the empty queue Seq.empty the nodes under investigation and the empty path [] in Tree s. Add the original features to the end of the queue using >< (sequence concatenation) and go . We look at the beginning of the queue . If there is nothing left, EmptyL , we did not find the path to the target and return Nothing . If there is something there, and it corresponds to the goal p , we return the path that we accumulate back. If the first one in the queue does not match the goal, we add it as the last part of the path and add all its branches to the remaining part of the queued .
breadthFirstSearch :: (a -> Bool) -> [Tree a] -> Maybe [a] breadthFirstSearch p = combine Seq.empty [] where combine queue ancestors branches = go (queue >< (Seq.fromList . map ((,) ancestors) $ branches)) go queue = case viewl queue of EmptyL -> Nothing (ancestors, Node a bs) :< queued -> if pa then Just . reverse $ a:ancestors else combine queued (a:ancestors) bs
This allows us to write our first solve for Board s. It is convenient here that all positions returned from moves are on the board.
solve :: Char -> Board -> State -> Maybe [Move] solve goal board = fmap (map fst) . breadthFirstSearch ((== goal) . (board !) . position . snd) . explore board
If we run this for our board, it never ends! Well, in the end, this will happen, but my napkin spin calculation suggests that it will take about 40 million steps. The path to the end of the maze lasts 16 steps, and the robot is often presented with 3 options for what to do at each step.
> solve 'F' board (State (4, 1) (-1, 0))
We can solve much smaller puzzles, for example
AB AC *
What can we imagine for this puzzle with
smallBoard :: Board smallBoard = listArray ((1,1),(2,2)) ("AB" ++ "AC")
We solve looking for 'C' , starting at column 3 1 in row 3 , looking at the rows with the lower number.
> solve 'C' smallBoard (State (3, 1) (-1, 0)) Just [Forward,Forward,Right,Jump,Right,Jump]
Transpose table
Of course, this problem needs to be solved easier than exploring 40 million possible paths. Most of these paths consist of spinning in place or randomly wriggling back and forth. All degenerate paths have one property, they continue to visit the states that they have already visited. In the breadthFirstSeach code breadthFirstSeach these paths continue to add the same nodes to the queue. We can get rid of all this extra work by simply remembering the nodes that we have already seen.
We recall the set of nodes that we have already seen with the Set from the Data.Set .
import qualified Data.Set as Set
To the breadthFirstSearch signature breadthFirstSearch we add a function from the label for the node to the view for the branches of this node. The view should be the same if all branches from node match. To quickly compare views in O(log n) time with Set , we require that the view has an Ord instance instead of a simple equality. An Ord instance allows Set to verify membership with a binary search .
breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> [Tree a] -> Maybe [a]
In addition to tracking breadthFirstSearchUnseen , breadthFirstSearchUnseen keeps track of the set of views that have been seen since Set.empty . Each time we add branches to the queue with combine , we also add views to the seen . We add unseen branches whose views are not in the set of branches that we have already seen .
breadthFirstSearchUnseen repr p = combine Set.empty Seq.empty [] where combine seen queued ancestors unseen = go (seen `Set.union` (Set.fromList . map (repr . rootLabel) $ unseen)) (queued >< (Seq.fromList . map ((,) ancestors ) $ unseen)) go seen queue = case viewl queue of EmptyL -> Nothing (ancestors, Node a bs) :< queued -> if pa then Just . reverse $ ancestors' else combine seen queued ancestors' unseen where ancestors' = a:ancestors unseen = filter (flip Set.notMember seen . repr . rootLabel) bs
Now we can improve our solve function to use breadthFirstSearchUnseen . All branches from a node are defined by the State - Move label, which fell into this state, it does not matter - therefore, we use only the snd part of the tuple (Move, State) as a representation for the node.
solve :: Char -> Board -> State -> Maybe [Move] solve goal board = fmap (map fst) . breadthFirstSearchUnseen snd ((== goal) . (board !) . position . snd) . explore board
We can now solve original puzzle very quickly.
> solve 'F' board (State (4, 1) (-1, 0)) Just [Forward,Forward,Forward,Right,Forward,Forward,Forward,Right,Jump,Right,Jump,Forward,Left,Jump,Left,Jump,Jump]