content: -- Maze generator and solver in Haskell
  -- Joe Wingbermuehle
  -- 20070602 <> 20140815
  
  module Main where
  
  import Control.Monad
  import Control.Monad.State
  import Control.Monad.Reader
  import Data.Map
  import System.Random
  
  data ElementType = Space | Wall | Marked | Visited | Door
      deriving (Eq)
  
  data Direction = DLeft | DRight | DUp | DDown
      deriving (Enum)
  
  data MazeData = MazeData {
      width :: Int,
      height :: Int,
      gen :: StdGen,
      maze :: Map (Int, Int) ElementType
  }
  
  instance Show ElementType where
      show Space = "  "
      show Wall = "[]"
      show Marked = "++"
      show Visited = show Space
      show Door = show Space
  
  instance Show MazeData where
      show = showMaze 0 0
          where
              showMaze x y md =
                  if x == (width md) then
                      if y + 1 == (height md) then ""
                      else "\n" ++ (showMaze 0 (y + 1) md)
                  else
                      let e = findWithDefault Wall (x, y) (maze md) in
                      (show e) ++ (showMaze (x + 1) y md)
  
  type MazeState a = ReaderT (Int, Int) (State MazeData) a
  
  -- Initialize an uncarved maze.
  initMaze :: Int -> Int -> Int -> MazeData
  initMaze w h s =
      let xs = [0 .. w - 1] in
      let ys = [0 .. h - 1] in
      let top = [(x, 0) | x <- xs] in
      let bottom = [(x, h - 1) | x <- xs] in
      let left = [(0, y) | y <- ys] in
      let right = [(w - 1, y) | y <- ys] in
      let start = [(2, 2)] in
      let spaces = Prelude.foldl (++) [] [top, bottom, left, right, start] in
      let m1 = fromList [(p, Space) | p <- spaces] in
      let doors = [(2, 2), (2, 1), (w - 3, h - 2)] in
      let m2 = fromList [(p, Door) | p <- doors] in
      MazeData {
          width = w, height = h, gen = mkStdGen s,
          maze = union m1 m2
      }
  
  -- Get the next position in the specified direction.
  getPosition :: (Int, Int) -> Direction -> (Int, Int)
  getPosition (x, y) DLeft = (x - 1, y)
  getPosition (x, y) DRight = (x + 1, y)
  getPosition (x, y) DUp = (x, y - 1)
  getPosition (x, y) DDown = (x, y + 1)
  
  -- Move in the specified direction.
  move :: ElementType -> Direction -> MazeState (Int, Int)
  move fill d = do
      pos <- ask; st <- get
      let mid = getPosition pos d
      let m = insert mid fill $ maze st
      let next = getPosition mid d
      put $ st { maze = insert next fill m }
      return next
  
  -- Determine if we can carve in the specified direction.
  canMove :: ElementType -> Direction -> MazeState Bool
  canMove match d = do
      pos <- ask; st <- get
      let mid = getPosition pos d
      let e1 = findWithDefault Wall mid $ maze st
      let next = getPosition mid d
      let e2 = findWithDefault Wall next $ maze st
      return $ e1 == match && e2 == match
  
  -- Carve the maze starting at the speciified position.
  carve :: MazeState ()
  carve = do
      st <- get
      let (start, g') = randomR (0, 3) $ gen st
      put $ st { gen = g' }
      mapM_ tryCarve [toEnum ((start + i) `mod` 4) | i <- [0 .. 3]]
      where
          tryCarve d = do
              cm <- canMove Wall d
              when cm (move Space d >>= (\n -> local (const n) carve))
  
  -- Find a path from the current position to the end position.
  solveTo :: (Int, Int) -> MazeState Bool
  solveTo stop = do
      pos <- ask
      if pos == stop then
          return True
      else do
          st <- get; pos <- ask
          put $ st { maze = insert pos Marked (maze st) }
          foldM trySolve False [toEnum i | i <- [0 .. 3]]
      where
          trySolve result d
              | result = return True
              | otherwise = do
                  cm <- canMove Space d
                  if cm then do
                      next <- move Marked d
                      found <- local (const next) $ solveTo stop
                      if found then return True
                      else (move Visited d >> return False)
                  else return False
  
  -- Generate a random maze.
  generate :: Int -> Int -> Int -> MazeData
  generate w h s = execState (runReaderT carve (2, 2)) (initMaze w h s)
  
  -- Solve a maze.
  solve :: MazeData -> MazeData
  solve md =
      let start = (2, 2) in
      let stop = ((width md) - 3, (height md - 3)) in
      execState (runReaderT (solveTo stop) start) md
  
  -- Generate and display a solved random maze.
  main :: IO ()
  main = do
      let maze = generate 39 23 5
      let solved = solve maze
      putStrLn $ show maze
      putStrLn $ show solved
  