{-# Language ViewPatterns #-}
module Parser where

import Model
import Graphics.Vty.Attributes
import Data.Array (Array, listArray)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Text.ParserCombinators.ReadP hiding (many)
import Control.Applicative
import Control.Monad

parse :: String -> World
parse str =
  case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of
    [] -> error "world parsing failed"
    (((p,h,w),bs),_):_ ->
      do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
         World
          (Map.fromList [
            (n, b { boxLocation = head (m Map.! n)})
            | (n,b,_) <- bs
          ])
          p
          (Set.fromList (Map.findWithDefault [] '-' m))
          (head (m Map.! '='))
          h w
    
parseHeader :: ReadP (Char,Int,Int)
parseHeader =
 do "player" <- token
    [p] <- token
    h <- option 81
          do "height" <- token
             integer
    w <- option (81*2)
          do "width" <- token
             integer
    pure (p,h,w)

integer :: ReadP Int
integer = readS_to_P reads

parseBoring :: ReadP Bool
parseBoring =
 do t <- token
    case t of
      "boring" -> pure True
      "interesting" -> pure False
      _ -> empty

parseBlock :: ReadP (Char, Box, [(Char, Location)])
parseBlock =
 do cmd <- token
    case cmd of
      "block" ->
       do [name] <- token
          color <- parseColor
          boring <- parseBoring
          skipMany (satisfy (' '==))
          _ <- char '\n'
          xs1 <- parseWalls
          let locs = findLocs name xs1
          let b = Box undefined (Original (walls xs1)) color boring
          pure (name, b, locs)
      "link" ->
       do [name] <- token
          [target] <- token
          color <- parseColor
          _ <- char '\n'
          pure (name, Box undefined (Link target) color True, [])
      "infinity" ->
       do [name] <- token
          [target] <- token
          color <- parseColor
          _ <- char '\n'
          pure (name, Box undefined (Infinity target) color True,[])
      "epsilon" ->
       do [name] <- token
          [target] <- token
          color <- parseColor
          skipMany (satisfy (' '==))
          _ <- char '\n'
          xs1 <- parseWalls
          let locs = findLocs name xs1
          let b = Box undefined (Epsilon target (walls xs1)) color False
          pure (name, b, locs)
      _ -> empty

parseWalls :: ReadP [String]
parseWalls =
 do row0 <- munch1 ('\n' /=) <* char '\n'
    rows <- replicateM (length row0 - 1) (munch1 ('\n' /=) <* char '\n')
    pure (row0:rows)

token :: ReadP String
token = readS_to_P lex

parseColor :: ReadP Attr
parseColor =
 do t <- token
    case t of
      "white" -> pure (withForeColor defAttr white)
      "cyan" -> pure (withForeColor defAttr cyan)
      "blue" -> pure (withForeColor defAttr blue)
      "red" -> pure (withForeColor defAttr red)
      "yellow" -> pure (withForeColor defAttr yellow)
      "magenta" -> pure (withForeColor defAttr magenta)
      "black" -> pure (withForeColor defAttr black)
      "green" -> pure (withForeColor defAttr green)
      _ -> empty

walls :: [String] -> Array Coord Bool
walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows))
  where
    width = length (head rows)
    height = length rows
    ylo = - ((height - 1) `div` 2)
    yhi = height `div` 2
    xlo = - ((width - 1) `div` 2)
    xhi = width `div` 2

mkRange :: Int -> (Int, Int)
mkRange n = (-(n-1)`div`2, n`div`2)

findLocs :: Char -> [[Char]] -> [(Char, Location)]
findLocs name xs =
  [ (c, Location name y x)
    | let (ylo, yhi) = mkRange (length xs)
    , (y, row) <- zip [ylo .. yhi] xs
    , let (xlo,xhi) = mkRange (length row)
    , (x, c  ) <- zip [xlo..xhi] row
  ]