{-# LANGUAGE LambdaCase #-}
module Lab12 where

import           Control.Applicative
import           Data.Char
import           Data.Functor                   ( ($>) )
import           Data.Maybe                     ( fromMaybe )

import           Prelude                 hiding ( map )

data Block = Wall | Free | Star deriving (Eq, Show)

newtype Maze = M { getMaze :: [[Block]] }

maze :: Maze
maze = M
    [ [Wall, Wall, Wall, Wall, Wall]
    , [Wall, Free, Wall, Free, Wall]
    , [Wall, Free, Wall, Wall, Wall]
    , [Wall, Free, Free, Free, Wall]
    , [Wall, Wall, Wall, Wall, Wall]
    ]

instance Show Maze where
    show = unlines . fmap (fmap fmtCell) . getMaze
      where
        fmtCell :: Block -> Char
        fmtCell Wall = '#'
        fmtCell Free = ' '
        fmtCell Star = '*'


-- | Position in the maze
type Pos = (Int, Int)

-- | Path represented as a sequence of points
type Path = [Pos]

-- | Start, Goal, in Maze
type Task = (Pos, Pos, Maze)

safePut :: Int -> a -> [a] -> Maybe [a]
safePut n x xs
    | 0 <= n && n < length xs = Just $ take n xs ++ (x : drop (n + 1) xs)
    | otherwise               = Nothing

safeGet :: Int -> [a] -> Maybe a
safeGet n xs | 0 <= n && n < length xs = Just $ xs !! n
             | otherwise               = Nothing

getBlock :: Pos -> Maze -> Maybe Block
getBlock (x, y) (M m) = do
    row <- safeGet y m
    safeGet x row

setBlock :: Block -> Pos -> Maze -> Maybe Maze
setBlock b (x, y) (M m) = do
    row     <- safeGet y m
    newRow  <- safePut x b row
    newMaze <- safePut y newRow m
    pure (M newMaze)

setPath :: Block -> Path -> Maze -> Maybe Maze
setPath _ []            m = Just m
setPath b (pos : path') m = do
    m' <- setBlock b pos m
    setPath b path' m'

drawSolution :: Path -> Maze -> Maze
drawSolution solution m = fromMaybe m (setPath Star solution m)

neighbors :: Pos -> [Pos]
neighbors (x, y) =
    [ (x + dx, y + dy)
    | dx <- [-1 .. 1]
    , dy <- [-1 .. 1]
    , not (dx == 0 && dy == 0)
    ]

nextPosition :: Pos -> Maze -> [Pos]
nextPosition p m = [ n | n <- neighbors p, getBlock n m == Just Free ]

extend :: Path -> Maze -> [Path]
extend []           _ = []
extend path@(p : _) m = (: path) <$> nextPosition p m

bfs
    :: [Pos] -- ^ Visited positions
    -> [Path] -- ^ Path queue
    -> Pos -- ^ Objective
    -> Maze
    -> Maybe Path
bfs _ [] _ _ = Nothing
bfs visited (path@(p : _) : paths) target m
    | p == target      = Just $ reverse path
    | p `elem` visited = bfs visited paths target m
    | otherwise        = bfs (p : visited) (paths ++ extend path m) target m

solve :: Task -> Maybe Path
solve (start, target, m) = bfs [] [[start]] target m

newtype Parser a = P { parse :: String -> Maybe (a, String) }

instance Functor Parser where
    -- fmap :: (a -> b) -> Parser a -> Parser b
    fmap f p = P
        (\inp -> case parse p inp of
            Nothing       -> Nothing
            Just (v, out) -> Just (f v, out)
        )

instance Applicative Parser where
    -- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
    pg <*> px = P
        (\inp -> case parse pg inp of
            Nothing       -> Nothing
            Just (g, out) -> parse (fmap g px) out
        )
    pure v = P (\inp -> Just (v, inp))

instance Monad Parser where
    -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
    p >>= f = P
        (\inp -> case parse p inp of
            Nothing       -> Nothing
            Just (v, out) -> parse (f v) out
        )

instance Alternative Parser where
    -- empty :: Parser a
    empty = P (const Nothing)
    -- (<|>) :: Parser a -> Parser a -> Parser a
    p <|> q = P
        (\inp -> case parse p inp of
            Nothing       -> parse q inp
            Just (v, out) -> Just (v, out)
        )

item :: Parser Char
item = P
    (\case
        ""       -> Nothing
        (x : xs) -> Just (x, xs)
    )

sat :: (Char -> Bool) -> Parser Char
sat pred = item >>= (\c -> if pred c then pure c else empty)

digit :: Parser Char
digit = sat isDigit

char :: Char -> Parser Char
char c = sat (== c)

string :: String -> Parser String
string ""         = pure ""
string s@(c : cs) = (char c *> string cs) $> s

space :: Parser ()
space = many (sat isSpace) $> ()

token :: Parser a -> Parser a
token p = space *> p <* space

pos :: Parser Pos
pos =
    char '('
        *> (   (\strX strY -> (read strX, read strY))
           <$> (token (some digit))
           <*> (char ',' *> token (some digit))
           )
        <* char ')'

block :: Parser Block
block = item >>= \case
    '#' -> pure Wall
    ' ' -> pure Free
    _   -> empty

row :: Parser [Block]
row = many block <* char '\n'

map :: Parser Maze
map = M <$> many row

start :: Parser Pos
start = string "start" *> token (char '=') *> pos <* char '\n'

goal :: Parser Pos
goal = string "goal" *> token (char '=') *> pos <* char '\n'

file :: Parser Task
file = (,,) <$> start <*> goal <*> map

solveTask :: Task -> String
solveTask t@(_, _, m) = case solve t of
    Nothing   -> "No solution exists"
    Just path -> show $ drawSolution path m

processInput :: String -> String
processInput input = case parse file input of
    Nothing        -> "File has syntax error"
    Just (t, ""  ) -> solveTask t
    Just (_, rest) -> "Unused input: " ++ rest

main :: IO ()
main = interact processInput