Google Code Jam/Always Turn Left

import Data.Map hiding (map,null) import Data.List import Control.Arrow type Pos = (Int,Int) data Dir = N | S | O | E deriving (Enum,Eq,Ord) data Step = W | R | T | L deriving (Read,Enum) chdir :: Dir -> Step -> Dir chdir y k = head . drop (fromEnum k) . dropWhile (/= y) $ cycle [N,E,S,O] step :: Dir -> Pos -> Pos step N (x,y) = (x,y -1) step S (x,y) = (x,y +1) step O (x,y) = (x-1,y) step E (x,y) = (x+1,y) type Move = (Pos,Dir) walker :: [Step] -> Move -> (Move,[Move]) walker xs (p,d) = second tail $ walker' xs p d where walker' [] p d = ((p,chdir d T),[]) walker' (x:xs) p d = second ((p,d'):) $ walker' xs (step d' p) d' where d' = chdir d x biwalker :: DeMaze -> [Move] biwalker (go,back) = let (l,ys) = walker go ((0,0),S) in ys ++ snd (walker back l) descr :: [Move] -> [String] descr xs = let zs = mapKeys (\(x,y) -> (y,x)) . fromListWith (++) . map (second return) $ xs (minx,maxx) = (minimum &&& maximum) . map snd $ keys zs split k = unfoldr (\x -> if null x then Nothing else Just $ splitAt k x) in split (maxx - minx + 1) $ map convert (elems zs) convert :: [Dir] -> Char convert xs = "0123456789abcdef" !! number xs where number [] = 0 number (x:xs) = 2 ^ fromEnum x + number xs rewrite ::[Step] -> [Step] rewrite = unfoldr (\xs -> if null xs then Nothing else Just (rule xs)) where rule (R:R:W:xs) = (T,xs) rule (R:W:xs) = (R,xs) rule (L:W:xs) = (L,xs) rule (W:xs) = (W,xs) type DeMaze = ([Step],[Step]) parseMaze :: String -> DeMaze parseMaze s = let [go,back] = words s parse = map $ read . return in (parse go, parse back) parseCases :: String -> [DeMaze] parseCases x = let (n:ts) = lines x in take (read n) $ map parseMaze ts main = do ts <- parseCases `fmap` getContents flip mapM_ (zip [1..] ts) $ \(i,t) -> do putStrLn $ "Case #" ++ show i ++ ": " mapM_ putStrLn $ descr . biwalker . (rewrite *** rewrite) $ t