Haskell - Calculating the shortest path using trees - haskell

Question

i am trying to write a code in haskell, that goes from point A, to point F, on a board game, that is essentially a Matrix, following the shortest path.
This is the board:
AAAA
ACCB
ADEF
*
0 0 N
The robot enters on the letter A, on the bottom (where it is the * ), and must reach F, on the bottom of the board are the coordinates, x=0, y=0, and pointing towards North. F coordinate is (3,0)
The trick is, it can't jump more than one letter, it can go from A to B, B to C, etc. and it can walk through the letters of the type (A to A, B to B, etc)
It can only move forward and make turns (Left, right) so the path to let me go to F would be
Forward, Forward, Right, Forward ,Forward, Forward, Right, Jump, Right, Jump, Forward, Left, Jump, Left, Forward, Forward
Once it reaches F, it's done.
I want to try this approach, using a Tree
A
/ \
A D
/ \
/ \
A C
/ \ / \
/ \ D C
A
/ \
/ \
A
/
/
A
/ \
B A
/ \
C F
After that i would only need to validate the correct path and shortest right?
Problem is , i don't have that much experience using trees.
Would you indicate any other way to get the best path?
Thank you very much .

Answer 1

We're going to solve this problem by searching a tree in three parts. First we will build a Tree representing the paths through the problem, with branches for each state. We'd like to find the shortest path to get to a state with a certain criteria, so we will write a breadth first search for searching any Tree. This won't be fast enough for the example problem you provided, so we will improve on the breadth first search with a transposition table which keeps track of states we have already explored to avoid exploring them again.
Building a Tree
We'll assume that your playing board is represented in an 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 doesn't provide a default easy way to make sure indexes that we look up values for with ! are actually in the bounds of the Array. For convenience, we'll provide a safe version that returns Just v if the value is in the Array or Nothing otherwise.
import Data.Maybe
(!?) :: Ix i => Array i a -> i -> Maybe a
a !? i = if inRange (bounds a) i then Just (a ! i) else Nothing
The State of the puzzle can be represented by the combination of a position of the robot and the direction that the robot is facing.
data State = State {position :: (Int, Int), direction :: (Int, Int)}
deriving (Eq, Ord, Show)
The direction is a unit vector that can be added to the 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 explore a board, we will need to be able to determine from a state what moves are legal. To do this it'd be useful to name the moves, so we'll make a data type to represent the possible moves.
import Prelude hiding (Right, Left)
data Move = Left | Right | Forward | Jump
deriving (Show)
To determine what moves are legal on a board we need to know which Board we are using and the State of the robot. This suggests the type moves :: Board -> State -> Move, but we re going to be computing the new state after each move just to decide if the move 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're on the board, we can turn Left and Right; the restriction that we be on the board guarantees all the States returned by moves have positions that are on the board. If the value held at the nextPos, next position matches what is Just here we can go Forward to it (if we're off the board, we assume what is here is 'A'). If next is Just the successor of what is here we can Jump to it. If next is off the board it is Nothing and can't match either Just here or Just (succ here).
Up until this point, we've just provided the description of the problem and haven't touched on answering the question with tree. We are going to use the rose tree 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 of a Tree a holds a single value a and a list of branches which are each a Tree a.
We are going to build a list of Trees in a straightforward manner from our moves function. We are going to make each result of moves the rootLabel of a Node and make the branches be the list of Trees we get when we explore the 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 point, our trees are infinite; nothing keeps the robot from endlessly spinning in place.. We can't draw one, but we could if we could limit the tree to just 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'll display just the first couple levels of the tree when we start off the bottom left corner facing towards 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')
Breadth First Search
Breadth first search explores all the possibilities at one level (across the "breadth" of what is being searched) before descending into the next level (into the "depth" of what is being searched). Breadth first search finds the shortest path to a goal. For our trees, this means exploring everything at one layer before exploring any of what's in the inner layers. We'll accomplish this by making a queue of nodes to explore adding the nodes we discover in the next layer to the end of the queue. The queue will always hold nodes from the current layer followed by nodes from the next layer. It will never hold any nodes from the layer past that because we won't discover those nodes until we have moved on to the next layer.
To implement that, we need an efficient queue, so we'll use a sequence from Data.Sequence/
import Data.Sequence (viewl, ViewL (..), (><))
import qualified Data.Sequence as Seq
We start with an empty queue Seq.empty of nodes to explore and an empty path [] into the Trees. We add the initial possibilities to the end of the queue with >< (concatenation of sequences) and go. We look at the start of the queue. If there's nothing left, EmptyL, we didn't find a path to the goal and return Nothing. If there is something there, and it matches the goal p, we return the path we have accumulate backwards. If the first thing in the queue doesn't match the goal we add it as the most recent part of the path and add all of its branches to the remainder of what was 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 p a
then Just . reverse $ a:ancestors
else combine queued (a:ancestors) bs
This lets us write our first solve for Boards. It's convenient here that all of the 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 finishes! Well, eventually it will, but my back of a napkin calculation suggests it will take about 40 million steps. The path to the end of the maze is 16 steps long and the robot is frequently 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 like
AB
AC
*
Which we can represent the board for this puzzle with
smallBoard :: Board
smallBoard = listArray ((1,1),(2,2)) ("AB" ++ "AC")
We solve it looking for 'C' starting in row 3 column 1 looking towards lower numbered rows.
> solve 'C' smallBoard (State (3, 1) (-1, 0))
Just [Forward,Forward,Right,Jump,Right,Jump]
Transposition Table
Certainly this problem must be easier to solve than exploring 40 million possible paths. Most of those paths consist of spinning in place or randomly meandering back and forth. The degenerate paths all share one property, they keep visiting states they have already visited. In the breadthFirstSeach code, those paths keep adding the same nodes to the queue. We can get rid of all of this extra work just by remembering the nodes that we've already seen.
We'll remember the set of nodes we've already seen with a Set from Data.Set.
import qualified Data.Set as Set
To the signature of breadthFirstSearch we'll add a function from the label for a node to a representation for the branches of that node. The representation should be equal whenever all the branches out of the node are the same. In order to quickly compare the representations in O(log n) time with a Set we require that the representation have an Ord instance instead of just equality. The Ord instance allows Set to check for membership with binary search.
breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> [Tree a] -> Maybe [a]
In addition to keeping track of the queue, breadthFirstSearchUnseen keeps track of the set of representations that have been seen, starting with Set.empty. Each time we add branches to the queue with combine we also add the representations to seen. We only add the unseen branches whose representations are not in the set of branches we've 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 p a
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 of the branches from a node are determined by the State - the Move label that got to that state is irrelevant - so we only use the snd part of the (Move, State) tuple as the representation for a 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 the 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]