134 lines
3.7 KiB
Haskell
134 lines
3.7 KiB
Haskell
{-# 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 = fmap head (Map.lookup n m)})
|
|
| (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 Nothing (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
|
|
]
|