import Control.Arrow

import Data.Map (Map)
import Data.Set (Set)
import Data.Array.ST (STArray)
import Data.Array (Array)
import Control.Monad.ST (ST, runST)

import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Array.ST as MutableArray
import qualified Data.Array as Array
import qualified Data.Maybe as Maybe

data Direction = East | West | South | North
        deriving (Show, Eq, Ord)
data MazeTile = Start | End | Wall | Unknown | Explored (Map Direction ExplorationScore)
        deriving Eq

--      instance Show MazeTile where
--              show Wall = "#"
--              show Start = "S"
--              show End = "E"
--              show Unknown = "."
--              show (Explored (East, _))  = ">"
--              show (Explored (South, _)) = "v"
--              show (Explored (West, _))  = "<"
--              show (Explored (North, _)) = "^"

type Position = (Int, Int)
type ExplorationScore = Int

translate '#' = Wall
translate '.' = Unknown
translate 'S' = Start
translate 'E' = End

parse :: String -> Array (Int, Int) MazeTile
parse s = Array.listArray ((1, 1), (height - 1, width)) . map translate . filter (/= '\n') $ s
        where
                width = length . takeWhile (/= '\n') $ s
                height = length . filter (== '\n') $ s

(a1, b1) .+. (a2, b2) = (a1+a2, b1+b2)
(a1, b1) .-. (a2, b2) = (a1-a2, b1-b2)

directions = [East, West, South, North]
directionVector East  = (0,  1)
directionVector West  = (0, -1)
directionVector North = (-1, 0)
directionVector South = ( 1, 0)

turnRight East  = South
turnRight South = West
turnRight West  = North
turnRight North = East

walkableNeighbors a p = do
        let neighbors = List.map ((.+. p) . directionVector) directions
        tiles <- mapM (MutableArray.readArray a) neighbors
        let neighborPosition = List.map fst . List.filter ((/= Wall). snd) . zip neighbors $ tiles
        return $ neighborPosition


findDeadEnds a = Array.assocs
        >>> List.filter (snd >>> (== Unknown))
        >>> List.map (fst)
        >>> List.filter (isDeadEnd a)
        $ a
isDeadEnd a p = List.map directionVector
        >>> List.map (.+. p)
        >>> List.map (a Array.!)
        >>> List.filter (/= Wall)
        >>> List.length
        >>> (== 1)
        $ directions

fillDeadEnds :: Array (Int, Int) MazeTile -> ST s (Array (Int, Int) MazeTile)
fillDeadEnds a = do
        ma <- MutableArray.thaw a
        let deadEnds = findDeadEnds a
        mapM_ (fillDeadEnd ma) deadEnds
        MutableArray.freeze ma

fillDeadEnd :: STArray s (Int, Int) MazeTile -> Position -> ST s ()
fillDeadEnd a p = do
        MutableArray.writeArray a p Wall
        p' <- walkableNeighbors a p >>= return . head
        t <- MutableArray.readArray a p'
        n <- walkableNeighbors a p' >>= return . List.length
        if n == 1 && t == Unknown then fillDeadEnd a p' else return ()

thawArray :: Array (Int, Int) MazeTile -> ST s (STArray s (Int, Int) MazeTile)
thawArray a = do
        a' <- MutableArray.thaw a
        return a'

solveMaze a = do
        a' <- fillDeadEnds a
        a'' <- thawArray a'
        let s = Array.assocs
                >>> List.filter ((== Start) . snd)
                >>> Maybe.listToMaybe
                >>> Maybe.maybe (error "Start not in map") fst
                $ a
        let e = Array.assocs
                >>> List.filter ((== End) . snd)
                >>> Maybe.listToMaybe
                >>> Maybe.maybe (error "End not in map") fst
                $ a
        MutableArray.writeArray a'' s $ Explored (Map.singleton East 0)
        MutableArray.writeArray a'' e $ Unknown
        solveMaze' (s, East) a''
        fa <- MutableArray.freeze a''
        t <- MutableArray.readArray a'' e
        case t of
                Wall  -> error "Unreachable code"
                Start -> error "Unreachable code"
                End   -> error "Unreachable code"
                Unknown -> error "End was not explored yet"
                Explored m -> return (List.minimum . List.map snd . Map.toList $ m, countTiles fa s e)

countTiles a s p = Set.size . countTiles' a s p $ South

countTiles' :: Array (Int, Int) MazeTile -> Position -> Position -> Direction -> Set Position
countTiles' a s p d
        | p == s    = Set.singleton p
        | otherwise = Set.unions 
                . List.map (Set.insert p) 
                . List.map (uncurry (countTiles' a s)) 
                $ (zip minCostNeighbors minCostDirections)
        where
                minCostNeighbors   = List.map ((p .-.) . directionVector) minCostDirections
                minCostDirections  = List.map fst . List.filter ((== minCost) . snd) . Map.toList $ visits
                visits = case a Array.! p of
                        Explored m -> Map.adjust (+ (-1000)) d m
                minCost = List.minimum . List.map snd . Map.toList $ visits

maybeExplore c p d a = do
        t <- MutableArray.readArray a p
        case t of
                Wall     -> return ()
                Start    -> error "Unreachable code"
                End      -> error "Unreachable code"
                Unknown  -> do
                        MutableArray.writeArray a p $ Explored (Map.singleton d c)
                        solveMaze' (p, d) a
                Explored m -> do
                        let c' = Maybe.maybe c id (m Map.!? d)
                        if c <= c' then do
                                let m' = Map.insert d c m
                                MutableArray.writeArray a p (Explored m')
                                solveMaze' (p, d) a
                        else
                                return ()

solveMaze' :: (Position, Direction) -> STArray s (Int, Int) MazeTile -> ST s ()
solveMaze' s@(p, d) a = do
        t <- MutableArray.readArray a p
        case t of
                Wall -> return ()
                Start -> error "Unreachable code"
                End -> error "Unreachable code"
                Unknown -> error "Starting on unexplored field"
                Explored m -> do
                        let c = m Map.! d
                        maybeExplore (c+1)    (p .+. directionVector d)  d a
                        let d' = turnRight d
                        maybeExplore (c+1001) (p .+. directionVector d') d' a
                        let d'' = turnRight d'
                        maybeExplore (c+1001) (p .+. directionVector d'') d'' a
                        let d''' = turnRight d''
                        maybeExplore (c+1001) (p .+. directionVector d''') d''' a

part1 a = runST (solveMaze a)

main = getContents
        >>= print
        . part1
        . parse