parabox/app/Parser.hs

156 lines
4.5 KiB
Haskell

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
]