{-# LANGUAGE LambdaCase #-}
module Lab12b where

import Data.Functor
import Data.Char
import Control.Applicative

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

data Maze = M [[Block]]

instance Show Maze where
  show (M rows) = unlines $ showRow <$> rows
    where
      showRow blocks = showBlock <$> blocks
      showBlock Wall = '#'
      showBlock Free = ' '
      showBlock Star = '*'

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]
    ]

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

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

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

-- | X, Y
type Pos = (Int, Int)

type Path = [Pos]

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


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 s@(c:cs) = do
  char c
  string cs
  pure s

digit :: Parser Char
digit = sat isDigit

numberS :: Parser String
numberS = some digit

toInt :: String -> Int
toInt = read

number :: Parser Int
number = toInt <$> numberS

separator :: Parser Char
separator = char ' '

spaces :: Parser String
spaces = many separator

token :: Parser a -> Parser a
token' p = do
  spaces
  output <- p
  spaces
  pure output

token p = spaces *> p <* spaces

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

pos = char '(' *>
        ((,)
          <$> (token number <* char ',')
          <*> (token number))
      <* char ')'

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

block :: Parser Block
block = wall <|> freeSpace

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

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

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

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

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

processInput :: String -> String
processInput input = case parse task input of
  Nothing -> "Syntax error in input"
  Just (t, "") -> "Searching path"
  Just (_, rest) -> "Syntax error, unexpected characters: " ++ rest

main :: IO ()
main = interact processInput