parabox/app/Parser.hs

module Parser (parse) where

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

import Model

parse :: String -> Either String World
parse str =
  case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of
    [] -> Left "world parsing failed"
    (((p,h,w),bs),_):_ ->
      do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]

         home <-
           case Map.lookup '=' m of
             Nothing -> Left "no home location defined"
             Just [home] -> Right home
             Just _      -> Left "ambiguous home defined"

         boxes <- sequence $
           Map.fromList
             [(n, case Map.lookup n m of
                    Nothing -> Right b {boxLocation = Nothing}
                    Just [l] -> Right b {boxLocation = Just l}
                    Just _   -> Left ("ambiguous location for: " ++ [n])
              ) | (n,b,_) <- bs]

         Right World {
          worldBoxes   = boxes,
          worldMe      = p,
          worldButtons = Set.fromList (Map.findWithDefault [] '-' m),
          worldHome    = home,
          worldSize    = (h, w)
          }

parseHeader :: ReadP (Char,Int,Int)
parseHeader =
 do "player" <- token
    [p] <- token
    h <- option 81
          do "height" <- token
             integer
    w <- option (h*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

parseHeight :: ReadP (Maybe Int)
parseHeight = option Nothing $
 do "height" <- token
    Just <$> integer


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

parseWalls :: Maybe Int -> ReadP [String]
parseWalls height =
 do row0 <- munch1 ('\n' /=) <* char '\n'
    let h = maybe (length row0 - 1) (subtract 1) height
    rows <- replicateM h (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] -> UArray Coord Bool
walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows))
  where
    width = case rows of x:_ -> length x; [] -> 0
    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
  ]