147 lines
4.2 KiB
Haskell
147 lines
4.2 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
|
|
|
|
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 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
|
|
skipMany (satisfy (' '==))
|
|
_ <- char '\n'
|
|
xs1 <- parseWalls
|
|
let locs = findLocs name xs1
|
|
let b = Box Nothing (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] -> 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
|
|
]
|