BatBunker.hs

module BatBunker where

import Data.List (findIndices, delete, (\\))
import Data.Ratio 

data Cell = Empty | Wall | Bat | AlphaBat deriving (Show, Eq)
type Map = [[Cell]]
type Coord = (Int, Int)
type Vertex = (Cell, Coord)

processMap :: [String] -> Map
processMap = map (map parse)
    where   parse '-' = Empty
            parse 'W' = Wall
            parse 'B' = Bat
            parse 'A' = AlphaBat

crossBlock :: Coord -> Coord -> [Coord]
crossBlock a@(x0, y0) b@(x1, y1)
    | y1 == y0 = zip (enumFromTo (x0 `min` x1) (x0 `max` x1)) (repeat y0)
    | x1 >  x0 = markBlock (crossLine a b)
    | x1 == x0 = zip (repeat x0) (enumFromTo (y0 `min` y1) (y0 `max` y1))
    | x1 <  x0 = markBlock (crossLine b a)

crossLine :: Coord -> Coord -> [(Int, Ratio Int)]
crossLine (x0, y0) (x1, y1) = (x0, y0') : (map cross points) ++ [(x1, y1')]
    where   slope = (y1 - y0) % (x1 - x0)
            points = [1, 3 .. (x1-x0)*2]
            y0' = (y0*2 + 1) % 2
            y1' = (y1*2 + 1) % 2
            cross n = (x0 + (n) `div` 2, y0' + (n % 2 * slope))

markBlock :: [(Int, Ratio Int)] -> [Coord]
markBlock [] = []
markBlock [x] = []
markBlock ((x0, y0):(x1, y1):xs) = zip (repeat x1) (enumFromTo lo hi) ++ markBlock ((x1, y1):xs)
    where   lo = floor'   (y0 `min` y1)
            hi = ceiling' (y0 `max` y1)
            floor' n   | denominator n == 1 = floor n - 1
                       | otherwise          = floor n
            ceiling' n | denominator n == 1 = ceiling n
                       | otherwise          = ceiling n - 1

examine :: Map -> Coord -> Cell
examine m (x, y) = (m !! y) !! x

reachable :: Map -> Coord -> Coord -> Bool
reachable m a b = all ((/=) Wall . examine m) (crossBlock a b)

findBat :: Map -> [Vertex]
findBat m = zip3 (repeat 0) [0 .. length m] m >>= find
    where   find (x, y,          []) = []
            find (x, y, AlphaBat:cs) = (AlphaBat, (x, y)) : find (x+1, y, cs)
            find (x, y, Bat     :cs) = (Bat     , (x, y)) : find (x+1, y, cs)
            find (x, y, c       :cs) =                      find (x+1, y, cs)

data Status = Status Map [Vertex] Vertex [Vertex] deriving Eq

walk :: Status -> [Status]
walk (Status m all x@(AlphaBat, c) visited) = [Status m all x visited]
walk (Status m all x@(_, c) visited) = map (\next -> Status m all next (x:visited)) nextStep
    where   nextStep = filter (reachable m c . snd) (x `delete` (all \\ visited))

walkAll :: [Status] -> [Status]
walkAll old = if old == new then new else walkAll new
    where   new = old >>= walk

mileage :: Status -> Float 
mileage (Status _ _ c visited) = mileage' (map snd (c:visited))
    where   mileage' [] = 0
            mileage' [x] = 0
            mileage' (x:y:xs) = x `distance` y + mileage' (y:xs)
            distance (x0, y0) (x1, y1) = sqrt . fromIntegral $ (x1 - x0) ^ 2 + (y1 - y0) ^ 2

search :: [String] -> Float
search m = minimum . map mileage $ walkAll [Status m' (findBat m') (Bat, (0, 0)) []]
    where m' = processMap m

main :: IO ()
main = getContents >>= print . search . read