Arrow Maze solutions in Haskell

arrow.hs

--
-- Solution to "Arrow Maze" Daily Programmer Problem:
--   https://www.reddit.com/r/dailyprogrammer/comments/6rb98p/20170803_challenge_325_intermediate_arrow_maze/
--
-- Use the fgl library constructing a graph whose nodes are (cell, arrow).
-- An edge represents a move from a cell to an adjacent cell.
--
import Data.Graph.Inductive
import Data.Graph.Inductive.Query
import Data.Graph.Inductive.PatriciaTree
import Data.Array
import Data.Ix
import Data.List
import Control.Monad

-- Nodes = Cell x Direction
-- edge from (cell x,d) to (cell x+d, d)
--                      to (cell x+d', d')

type Arrow = (Int,Int)
type Maze = Array (Int,Int) Arrow
type Cell = (Int,Int)

toNode :: Cell -> Arrow -> Int
toNode (x, y) (dx, dy) = (dx+1) + 3*(dy+1) + 100*(x*100 + y)

allArrows = [ (dx, dy) | dx <- [-1..1], dy <- [-1..1], dx /= 0 || dy /= 0 ]

move :: Cell -> Arrow -> Cell
move (x,y) (dx,dy) = (x+dx, y+dy)

inMaze :: Maze -> Cell -> Bool
inMaze maze cell = inRange (bounds maze) cell

makeEdge :: Maze -> Cell -> Arrow -> [ Edge ]
makeEdge maze cell (0,0) = error "oops!"
makeEdge maze cell arrow =
  ( if inMaze maze c1 then [ (node, toNode c1 arrow) ] else [] )
  ++ 
  ( if inMaze maze c2 && marrow /= (0,0) && arrow /= marrow
           then [ (node, toNode c2 marrow) ]
           else [] )
  where 
    node = toNode cell arrow
    marrow = maze ! cell
    c1 = move cell arrow
    c2 = move cell marrow

foo maze cell =
  (do arrow <- allArrows  
      makeEdge maze cell arrow)

makeEdges :: Maze -> [ Edge ]
makeEdges maze = 
  (do cell <- indices maze
      arrow <- allArrows  
      makeEdge maze cell arrow)
  ++
  (do cell <- indices maze
      if maze!cell == (0,0)
         then [ ( toNode cell a, -1 ) | a <- allArrows ]
         else []
  )

usedNodes :: [ Edge ] -> [ Node ]
usedNodes edges = nub (map fst edges ++ map snd edges)

-- makeGraph :: Maze -> Graph Gr
makeGraph maze = mkGraph nodes ledges
  where nodes = [ (a, 0::Int) | a <- usedNodes edges ]
        edges = makeEdges maze
        ledges = [ (a, b, 1::Int) | (a,b) <- edges ]

readArrow :: String -> Arrow
readArrow "w"  = ( -1,  0)
readArrow "e"  = (  1,  0)
readArrow "s"  = (  0,  1)
readArrow "n"  = (  0, -1)
readArrow "se" = (  1,  1)
readArrow "ne" = (  1, -1)
readArrow "sw" = ( -1,  1)
readArrow "nw" = ( -1, -1)
readArrow _    = (0,0)

readMaze :: String -> Maze
readMaze str = 
  let arrows = transpose $ map (map readArrow . words) (lines str)
      nrows = length arrows
      ncols = length (head arrows)
  in listArray ((0,0), (nrows-1,ncols-1)) (concat arrows)

maze1 = unlines 
          [ "e  se se sw  s"
          , " s nw nw  n  w"
          , "ne  s  h  e sw"
          , "se  n  w ne sw"
          , "ne nw nw  n  n"
          ]

explainNode a = show x ++ "," ++ show y ++ " " ++ explainArrow (dx,dy)
  where (x,r1) = quotRem a (100*100)
        (y,r2) = quotRem r1 100
        (dy',dx') = quotRem r2 3
        dy = dy'-1
        dx = dx'-1

explainArrow ( -1,  0) = "w"
explainArrow (  1,  0) = "e"
explainArrow (  0,  1) = "s"
explainArrow (  0, -1) = "n"
explainArrow (  1,  1) = "se"
explainArrow (  1, -1) = "ne"
explainArrow ( -1,  1) = "sw"
explainArrow ( -1, -1) = "nw"
explainArrow x = show x

explainEdge (a,b) = explainNode a ++ " -> " ++ explainNode b

test1 =
  let maze = readMaze maze1
      gr   = makeGraph maze :: Gr Int Int
      cell0 = (2,0)
      home  = (2,2)
      arrow = maze!cell0
      start = move cell0 arrow
  in (cell0, start, arrow)

test1' = do
  let maze = readMaze maze1
  forM_ (foo maze (4,2)) $ \e -> do
    putStrLn $ explainEdge e

test2 = do
  let maze = readMaze maze1
      gr   = makeGraph maze :: Gr Int Int
      cell0 = (2,0)
      home  = (2,2)
      arrow = maze!cell0
      start = move cell0 arrow
      path  = sp (toNode start arrow) (-1) gr
  forM_ path $ putStrLn . explainNode

test3 = do
  let maze = readMaze "e s h"
      gr   = makeGraph maze :: Gr Int Int
      start = (0,0)
      arrow = readArrow "e"
      path  = sp (toNode start arrow) (-1) gr
  print $ makeEdges maze
  putStrLn $ "start: " ++ show start
  putStrLn $ "arrow: " ++ show arrow
  putStrLn $ "toNode: " ++ show (toNode start arrow)
  putStrLn $ "path:   " ++ show (sp (toNode start arrow) (-1) gr)

test4 mazeStr = do
  let maze = readMaze mazeStr
      gr   = makeGraph maze :: Gr Int Int
      start = (0,0)
      arrow = readArrow "e"
      path  = sp (toNode start arrow) (-1) gr
  print path

arrow2.hs

--
-- Another solution using fgl where an edge represents a move from a node
-- to another node in the direction of the arrow at that node.
--
import Data.Graph.Inductive
import Data.Graph.Inductive.Query
import Data.Graph.Inductive.PatriciaTree
import Data.Array
import Data.Ix
import Data.List
import Control.Monad

type Arrow = (Int,Int)
type Maze = Array (Int,Int) Arrow
type Cell = (Int,Int)

toNode :: Cell -> Int
toNode (x,y) = x*100+y

fromNode :: Int -> Cell
fromNode n = quotRem n 100

move :: Cell -> Arrow -> Cell
move (x,y) (dx,dy) = (x+dx, y+dy)

inMaze :: Maze -> Cell -> Bool
inMaze maze cell = inRange (bounds maze) cell

makeEdge :: Maze -> Cell -> [ Edge ]
makeEdge maze cell = 
  if arrow == (0,0)
    then [ (toNode cell, -1) ]
    else do c <- takeWhile (inMaze maze) $ drop 1 $ iterate (\c -> move c arrow) cell
            return $ (toNode cell, toNode c)
  where arrow = maze ! cell

makeEdges :: Maze -> [ Edge ]
makeEdges maze = concatMap (makeEdge maze) (indices maze)

usedNodes :: [ Edge ] -> [ Node ]
usedNodes edges = nub (map fst edges ++ map snd edges)

makeGraph maze = mkGraph nodes ledges
  where nodes = [ (a, 0::Int) | a <- usedNodes edges ]
        edges = makeEdges maze
        ledges = [ (a, b, 1::Int) | (a,b) <- edges ]

readArrow :: String -> Arrow
readArrow "w"  = ( -1,  0)
readArrow "e"  = (  1,  0)
readArrow "s"  = (  0,  1)
readArrow "n"  = (  0, -1)
readArrow "se" = (  1,  1)
readArrow "ne" = (  1, -1)
readArrow "sw" = ( -1,  1)
readArrow "nw" = ( -1, -1)
readArrow _    = (  0,  0)

readMaze :: String -> Maze
readMaze str = 
  let arrows = transpose $ map (map readArrow . words) (lines str)
      nrows = length arrows
      ncols = length (head arrows)
  in listArray ((0,0), (nrows-1,ncols-1)) (concat arrows)

maze1 = unlines 
          [ "e  se se sw  s"
          , " s nw nw  n  w"
          , "ne  s  h  e sw"
          , "se  n  w ne sw"
          , "ne nw nw  n  n"
          ]

main = do
  let maze = readMaze maze1
      gr   = makeGraph maze :: Gr Int Int
      start = (2,0)
      path  = sp (toNode start) (-1) gr
  mapM_ print $ map fromNode path

arrow3.hs

-- Third solution just using a simple DFS traversal.

import Data.List hiding (map)
import Data.Maybe
import Data.Array
import Data.Ix
import Control.Monad

type Cell = (Int,Int)
type Maze = Array (Int,Int) Arrow
type Arrow = (Int,Int)

arrows = 
  [ ( "w", ( -1,  0) ) , ( "e", (  1,  0) ) , ( "s", (  0,  1) ) , ( "n", (  0, -1) )
  , ( "se",(  1,  1) ) , ( "ne",(  1, -1) ) , ( "sw",( -1,  1) ) , ( "nw",( -1, -1) )
  ]

readArrow :: String -> (Int,Int)
readArrow x = fromMaybe (0,0) (lookup x arrows)

readMaze :: String -> Maze
readMaze str =
  let arrows = transpose $ map (map readArrow . words) (lines str)
      nrows = length arrows
      ncols = length (head arrows)
  in listArray ((0,0), (nrows-1,ncols-1)) (concat arrows)

move (dx,dy) (x,y) = (x+dx,y+dy)
inMaze maze (x,y) = inRange (bounds maze) (x,y)

makeEdges :: Maze -> [ (Cell, [Cell]) ]
makeEdges maze = do
  cell <- indices maze
  let arrow = maze ! cell
  guard $ arrow /= (0,0)
  let nbrs = takeWhile (inMaze maze) $ drop 1 $ iterate (move arrow) cell 
  return $ (cell, nbrs)

dfs :: [ (Cell, [Cell]) ] -> Cell -> Cell -> [ Cell ] -> [ [Cell] ]
dfs edges goal node path =
  if goal == node
    then [ path ]
    else do next <- (fromMaybe [] (lookup node edges)) \\ path
            dfs edges goal next (next:path)

maze1 = unlines
          [ "e  se se sw  s"
          , " s nw nw  n  w"
          , "ne  s  h  e sw"
          , "se  n  w ne sw"
          , "ne nw nw  n  n"
          ]

main = do
  let maze  = readMaze maze1
      start = (2,0)
      home  = head [ xy | xy <- indices maze, maze!xy == (0,0) ]
      edges = makeEdges maze
      paths = dfs edges home start [start]
  forM_ paths $ \p -> putStrLn $ show (length p) ++ " " ++ show (reverse p)