{-# LANGUAGE LambdaCase #-}
module Lab12a where
import Control.Applicative
import Data.Char (isDigit)
import Data.Functor

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

data Maze = M [[Block]]

mazeExample :: Maze   -- a testing maze
mazeExample = 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 (M rows) = unlines $ fmap (fmap displayCell) rows
    where displayCell Wall = '#'
          displayCell Free = ' '
          displayCell Star = '*'

-- X, Y
type Pos = (Int, Int)
type Path = [Pos]

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

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

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
             (c:cs) -> Just (c, cs))

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

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

string :: String -> Parser String
string "" = pure ""
string (c:cs) = do
  char c
  string cs
  pure (c:cs)

digit :: Parser Char
digit = sat isDigit

toInt :: String -> Int
toInt = read

number :: Parser Int
number = fmap toInt (some digit)

separator :: Parser String
separator = many (char ' ')

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

pos :: Parser Pos
-- pos = char '(' *> ((,) <$> (token number <* char ',') <*> (token number)) <* char ')'
pos = do
  char '('
  first <- token number
  char ','
  second <- token number
  char ')'
  pure (first, second)

declaration :: String -> Parser a -> Parser a
declaration name p = string name *> token (char '=') *> p <* char '\n'

start :: Parser Pos
start = declaration "start" pos

goal :: Parser Pos
goal = declaration "goal" pos

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

row :: Parser [Block]
row = many (wall <|> freeSpace) <* char '\n'

wall :: Parser Block
wall = char '#' $> Wall

freeSpace :: Parser Block
freeSpace = char ' ' $> Free

task :: Parser Task
task = (,,) <$> start <*> goal <*> maze

processInput :: String -> String
processInput inp = case parse task inp of
  Nothing -> "Syntax error in task"
  Just (t, "") -> "Read task " ++ show t
  Just (_, rest) -> "Syntax error: additional input " ++ rest

main :: IO ()
main = interact processInput