import Control.Monad (filterM, foldM)
import Control.Monad.ST
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Array as A
import Data.Array.ST
import Data.Bifunctor (second)
import Data.List as L (find, uncons)
import Data.Maybe (fromJust)
import Data.Tuple as T (swap)
import Data.Vector.Mutable as V hiding (foldM, mapM_)
import Prelude
import Prelude as P (length)

data BucketQueue s a = BQ Int (V.MVector s [a])

instance Show (BucketQueue s a) where show (BQ top _) = show top

insert :: BucketQueue s a -> (Int,a) -> ST s (BucketQueue s a)
insert (BQ top buckets) (prio,x) =
  V.modify buckets (x:) prio >> return (BQ (min top prio) buckets)

view :: BucketQueue s a -> MaybeT (ST s) (a, BucketQueue s a)
view (BQ top buckets) = do
  (x, xs) <- V.read buckets top >>= hoistMaybe . L.uncons
  lift $ V.write buckets top xs
  top' <- lift $ findTop top buckets
  return (x, BQ top' buckets)
{-# SCC view #-}

findTop :: Int -> V.MVector s [a] -> ST s Int
findTop n v = do
  top <- V.read v n
  case top of
    [] -> if n < V.length v - 1 then findTop (n+1) v else return n
    _  -> return n

newBQ :: Int -> ST s (BucketQueue s a)
newBQ n = BQ n <$> V.replicate n []

next :: Direction -> (Int,Int) -> (Int,Int)
next North (x,y) = (x,y-1)
next South (x,y) = (x,y+1)
next West  (x,y) = (x-1,y)
next East  (x,y) = (x+1,y)

left :: Direction -> Direction
left North = West
left West  = South
left South = East
left East  = North

right :: Direction -> Direction
right North = East
right East  = South
right South = West
right West  = North

type Node = ((Int,Int), Direction)

type Frontier s = BucketQueue s Node

data Direction = North | South | East | West deriving (Eq,Ix,Ord,Show)

data Tile = Wall | Tile { untile :: [Direction] }

type Map = A.Array (Int,Int) Tile

type Costs s = STArray s Node (Maybe Int)

neighbours :: (Int,Int) -> [(Direction, (Int,Int))]
neighbours (x,y) = [ (North, (x,y-1))
                   , (South, (x,y+1))
                   , (West,  (x-1,y))
                   , (East,  (x+1,y))
                   ]

parseMap :: [String] -> Map
parseMap s =
  let w = P.length (head s) - 1
      h = P.length s - 1
      f p = case g p of
        '#' -> Wall
        _   -> Tile . map fst . filter ((/= '#') . g . snd) $ neighbours p
      g (x,y) = s !! y !! x
  in array ((0,0),(w,h)) [ ((x,y), f (x,y))
                         | x <- [0..w]
                         , y <- [0..h]
                         ]

findStart :: [String] -> (Int,Int)
findStart ls =
  let Just p = L.find ((== 'S') . snd) [ ((x,y), ls !! y !! x)
                                       | x <- [0..P.length (head ls) - 1]
                                       , y <- [0..P.length ls - 1]
                                       ]
  in fst p

findGoal :: [String] -> (Int,Int)
findGoal ls =
  let Just p = L.find ((== 'E') . snd) [ ((x,y), ls !! y !! x)
                                       | x <- [0..P.length (head ls) - 1]
                                       , y <- [0..P.length ls - 1]
                                       ]
  in fst p

distance :: (Int,Int) -> (Int,Int) -> Int
distance (x0,y0) (x1,y1) =
  let a = fromIntegral $ x0 - x1
      b = fromIntegral $ y0 - y1
  in floor $ sqrt (a^2 + b^2)

expand :: Map -> (Node, Maybe Int) -> [(Node,Maybe Int)]
expand m ((pos, dir), Just cost) =
  [((next dir pos, dir), Just $ cost + 1) | dir `elem` untile (m A.! pos)]
  ++ ((\x -> ((pos,x), Just $ cost + 1000)) <$> [left dir, right dir])

pathThrough :: Map -> (Node,Maybe Int) -> Node -> (Node,Maybe Int)
pathThrough m through dest =
  head . filter ((== dest) . fst) $ expand m through

betterPath :: Map
           -> (Node,Maybe Int)
           -> (Node,Maybe Int)
           -> (Node,Maybe Int)
betterPath m through dest@(node,oldCost) =
  let n@(_,newCost) = pathThrough m through node
  in if newCost < oldCost
     then n
     else dest

cost :: Costs s -> Node -> ST s (Node, Maybe Int)
cost costs node = (node,) <$> readArray costs node

data PathingResult s = Success Int | Fail | Working (Frontier s, Costs s)

heuristic :: (Int,Int) -> (Node,Int) -> (Node,Int)
heuristic goal (n@(p,_),f) = (n, f + distance goal p)

(///) :: (MArray a e m, Ix i, Show i, Show e) => a i e -> [(i,e)] -> m ()
a /// asss = mapM_ (uncurry (writeArray a)) asss

unvisited :: Costs s -> Node -> ST s Bool
unvisited costs node = (== Nothing) <$> readArray costs node

pathOnce :: Map
         -> (Int,Int)
         -> Frontier s
         -> Costs s
         -> ST s (PathingResult s)
pathOnce m goal frontier costs =
  runMaybeT (view frontier) >>= maybe (return Fail) continue
  where
    continue (current@(p,_), rest)
      | p == goal = Success . fromJust <$> readArray costs current
      | otherwise = do
          curCost <- cost costs current
          let nexts = expand m curCost
          frontier' <- filterM (unvisited costs . fst) nexts
            >>= foldM insert rest
            . map (T.swap . heuristic goal . second fromJust)
          costs /// map (betterPath m curCost) nexts
          return . Working $ (frontier', costs)

findPath :: Map -> (Int,Int) -> (Int,Int) -> ST s Int
findPath m start goal = do
    frontier <- {-# SCC "frontier" #-}
      let (_,(w,h)) = bounds m
      in newBQ (100*w*h) >>= flip insert (0,(start,East))

    costs <- let (lower,upper) = bounds m
             in newArray ((lower,North),(upper,West)) Nothing

    writeArray costs (start,East) (Just 0)

    loop frontier costs
      where
        loop :: Frontier s -> Costs s -> ST s Int
        loop frontier costs = do
          once <- pathOnce m goal frontier costs
          case once of
            Success x -> return x
            Fail -> error "no path"
            Working (frontier', costs') -> loop frontier' costs'

main :: IO ()
main = do
  input <- lines <$> getContents
  let m = parseMap input
  let start = findStart input
  let goal = findGoal input
  print (runST $ findPath m start goal :: Int)