this will help 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
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
which keeps track of states we have already explored to avoid exploring them again.
code :
import Data.Array
type Board = Array (Int, Int) Char
board :: Board
board = listArray ((1,1),(3,4)) ("AAAA" ++ "ACCB" ++ "ADEF")
import Data.Maybe
(!?) :: Ix i => Array i a > i > Maybe a
a !? i = if inRange (bounds a) i then Just (a ! i) else Nothing
data State = State {position :: (Int, Int), direction :: (Int, Int)}
deriving (Eq, Ord, Show)
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)
import Prelude hiding (Right, Left)
data Move = Left  Right  Forward  Jump
deriving (Show)
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
data Tree a = Node {
rootLabel :: a,  ^ label value
subForest :: Forest a  ^ zero or more child trees
}
type Forest a = [Tree a]
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)
limit :: Int > Tree a > Tree a
limit n (Node a ts)
 n <= 0 = Node a []
 otherwise = Node a (map (limit (n1)) ts)
(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')
import Data.Sequence (viewl, ViewL (..), (><))
import qualified Data.Sequence as Seq
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
solve :: Char > Board > State > Maybe [Move]
solve goal board = fmap (map fst) . breadthFirstSearch ((== goal) . (board !) . position . snd) . explore board
> solve 'F' board (State (4, 1) (1, 0))
AB
AC
*
smallBoard :: Board
smallBoard = listArray ((1,1),(2,2)) ("AB" ++ "AC")
> solve 'C' smallBoard (State (3, 1) (1, 0))
Just [Forward,Forward,Right,Jump,Right,Jump]
import qualified Data.Set as Set
breadthFirstSearchUnseen:: Ord r => (a > r) > (a > Bool) > [Tree a] > Maybe [a]
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
solve :: Char > Board > State > Maybe [Move]
solve goal board = fmap (map fst) . breadthFirstSearchUnseen snd ((== goal) . (board !) . position . snd) . explore board
> 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]