theseus.hs

import Data.List
-- import Debug.Trace
data Node a = DeadEnd a
            | Passage a (Node a)
            | Fork    a (Node a) (Node a)
instance (Show a) => Show (Node a) where
    show (DeadEnd a) = "DeadEnd " ++ show a
    show (Passage a _) = "Passage " ++ show a
    show (Fork a _ _)  = "Fork " ++ show a

data Branch a = KeepStraightOn a
              | TurnLeft  a (Node a)
              | TurnRight a (Node a)
type Thread a = [Branch a]

type Zipper a = (Thread a, Node a)

get :: Zipper a -> a
get (_, DeadEnd a  ) = a
get (_, Passage a _) = a
get (_, Fork a _ _ ) = a

put :: a -> Zipper a -> Zipper a
put v (t, DeadEnd oldV     ) = (t, DeadEnd v)
put v (t, Passage oldV dest) = (t, Passage v dest)
put v (t, Fork oldV a b    ) = (t, Fork v a b)
update :: (a -> a) -> Zipper a -> Zipper a
update x n = put (x $ get n) n


turnRight :: Zipper a -> Maybe (Zipper a)
turnRight (t, Fork x l r) = Just (TurnRight x l : t, r)
turnRight _               = Nothing
turnLeft :: Zipper a -> Maybe (Zipper a)
turnLeft (t, Fork x l r)  = Just (TurnLeft  x r : t, l)
turnLeft _                = Nothing

keepStraightOn :: Zipper a -> Maybe (Zipper a)
keepStraightOn (t, Passage x n) = Just (KeepStraightOn x : t, n)
keepStraightOn _                = Nothing

back :: Zipper a -> Maybe (Zipper a)
back ([]                   , _) = Nothing
back (KeepStraightOn x : t , n) = Just (t, Passage x n)
back (TurnLeft  x r    : t , l) = Just (t, Fork x l r)
back (TurnRight x l    : t , r) = Just (t, Fork x l r)

maze :: Node (Int, Int)
maze = Fork (0, 2) 
    (Passage (2, 0)
        (Fork (1, 0) (DeadEnd (0, -1)) $ Passage (0, 1) $ DeadEnd (0, 0)))
    (Fork (-2, 0) (DeadEnd (-1, 0)) (DeadEnd (0, -2)))


getDrawCoord :: Node (Int, Int) -> (Int, Int)
getDrawCoord (DeadEnd (x,y)  ) = (x*4, y*4)
getDrawCoord (Passage (x,y) _) = (x*4, y*4)
getDrawCoord (Fork (x,y) _ _ ) = (x*4, y*4)

getBranchDrawCoord :: Branch (Int, Int) -> (Int, Int)
getBranchDrawCoord (KeepStraightOn (x,y)) = (x*4,y*4)
getBranchDrawCoord (TurnLeft  (x,y) _)    = (x*4,y*4)
getBranchDrawCoord (TurnRight (x,y) _)    = (x*4,y*4)
data Drawable = DrawNode (Int, Int)
              | Connection Char (Int, Int)
              deriving Show
getCoord (DrawNode p) = p
getCoord (Connection _ p) = p
drawConnection :: (Int, Int) -> (Int, Int) -> [Drawable]
drawConnection a@(ax, ay) b@(bx, by)
    | a == b    = []
    | otherwise = Connection (direction a b) a : drawConnection (closer ax bx, closer ay by) b where
        direction a@(ax, ay) b@(bx, by)
            | ax == bx = '|'
            | ay == by = '-'
            -- slope
            | (ax - bx) `div` (ay - by) > 0 = '/'
            | otherwise                     = '\\'
        closer a b = a + (signum $ b - a)

expandConnection :: (Int, Int) -> (Int, Int) -> [Drawable]
expandConnection (ax, ay) (bx, by) = drawConnection (ax', ay') (bx, by) where
    ax' = ax + (signum $ bx - ax)
    ay' = ay + (signum $ by - ay)
expandNodeConnection a b = expandConnection (getDrawCoord a) (getDrawCoord b)
drawNode = DrawNode . getDrawCoord

expandNode :: Node (Int, Int) -> [Drawable]
expandNode x@(DeadEnd _  ) = [drawNode x]
expandNode x@(Passage _ n) = (drawNode x):
                             (expandNodeConnection x n) ++ expandNode n
expandNode x@(Fork _  a b) = (drawNode x):
    expandNodeConnection x a ++ expandNodeConnection x b ++ expandNode a ++ expandNode b

expandZipper :: Zipper (Int, Int) -> [Drawable]
expandZipper ([], n) = [drawNode n]
expandZipper (thread@(x:_), n) = (drawNode n) :
                            expandConnection (getDrawCoord n) (getBranchDrawCoord x) ++
                            expandThread thread where
                                expandThread (x:y:xs) = (DrawNode $ getBranchDrawCoord x) :
                                    expandConnection (getBranchDrawCoord x) (getBranchDrawCoord y) ++
                                    expandThread (y:xs)
                                expandThread (x:[])   = [DrawNode $ getBranchDrawCoord x]
                                expandThread [] = []

sortCoord :: [Drawable] -> [Drawable]
sortCoord = sortBy (\ a b -> compare (sortCoord a) (sortCoord b)) where
    sortCoord (DrawNode (x, y))     = (-y, x)
    sortCoord (Connection _ (x, y)) = (-y, x)
bold x = "\ESC[1m" ++ x ++"\ESC[0m"

renderMaze :: (Int, Int) -> (Int, Int) -> [Drawable] -> (Int, Int) -> String
renderMaze s@(sx, sy) curpos nodes pos@(px, py)
    | (x:xs) <- nodes
    , getCoord x == pos
    =  case x of
        (DrawNode     _) -> if curpos == pos then bold ['*'] else ['*']
        (Connection x _) ->  [x]
        ++ renderMaze s curpos xs (px + 1, py)
    | px > sx    = '\n' : renderMaze s curpos nodes (-sx, py - 1)
    | py < (-sy) = ""
    | otherwise  = ' ' : renderMaze s curpos nodes (px + 1, py)

drawMaze :: (Int, Int) -> Zipper (Int, Int) -> String
drawMaze size@(sx, sy) pos@(_, maze) = renderMaze size (getDrawCoord maze) (sortCoord $ expandZipper pos) (-sx, sy)
drawFullMaze size@(sx, sy) pos@(_, maze) = renderMaze size (getDrawCoord maze) (sortCoord $ expandNode maze) (-sx, sy)

clearScreen = putStr "\ESC[2J"

ambiance (_, DeadEnd _)   = "there's a wall in front of you. (back)"
ambiance (_, Passage _ _) = "you're in a corridor, it makes a sharp turn here (continue, back)"
ambiance (_, Fork _ _ _)  = "there are two ways to go here (left, right, back)"

executeCommand :: String -> Zipper a -> Maybe (Zipper a)
executeCommand cmd = case cmd of
    "left"  -> turnLeft
    "right" -> turnRight
    "back"  -> back
    "continue" -> keepStraightOn
    _ -> \ _ -> Nothing

doMaze pos = do
    putStrLn $ drawMaze (8, 8) pos
    putStrLn $ ambiance pos
    input <- getLine
    clearScreen
    let newpos = executeCommand input pos
    case newpos of
        Nothing -> do
            putStrLn "that was not a way you could go"
            doMaze pos
        Just p  -> doMaze p


main = do 
    putStrLn "You try to memorize the map"
    putStrLn $ drawFullMaze (8, 8) ([], maze)
    doMaze ([], maze)