95 lines
3.1 KiB
Haskell
95 lines
3.1 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
|
|
|
|
parse :: String -> World
|
|
parse str = either error id $
|
|
case lines str of
|
|
x:xs ->
|
|
do h <- parseHeader x
|
|
bs <- parseBlocks xs
|
|
let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
|
|
pure $ World
|
|
(Map.fromList [
|
|
(n, b { boxLocation = head (m Map.! n)})
|
|
| (n,b,_) <- bs
|
|
])
|
|
h
|
|
(Set.fromList (Map.findWithDefault [] '-' m))
|
|
(head (m Map.! '='))
|
|
[] -> Left "empty input"
|
|
|
|
parseHeader :: String -> Either String Char
|
|
parseHeader (words -> ["player", [p]]) = Right p
|
|
parseHeader _ = Left "bad header"
|
|
|
|
parseBlocks :: [String] -> Either String [(Char, Box, [(Char, Location)])]
|
|
parseBlocks [] = Right []
|
|
parseBlocks (x:xs) =
|
|
case words x of
|
|
["block", [name], color, boring] ->
|
|
do color_ <- parseColor color
|
|
let (xs1,xs2) = splitWalls xs
|
|
let locs = findLocs name xs1
|
|
let b = Box undefined (Original (walls xs1)) color_ (boring == "boring")
|
|
bs <- parseBlocks xs2
|
|
pure ((name, b, locs):bs)
|
|
["link", [name], [target], color] ->
|
|
do color_ <- parseColor color
|
|
bs <- parseBlocks xs
|
|
pure ((name, Box undefined (Link target) color_ True, []):bs)
|
|
["infinity", [name], [target], color] ->
|
|
do color_ <- parseColor color
|
|
bs <- parseBlocks xs
|
|
pure ((name, Box undefined (Infinity target) color_ True,[]):bs)
|
|
["epsilon", [name], [target], color] ->
|
|
do color_ <- parseColor color
|
|
let (xs1,xs2) = splitWalls xs
|
|
let locs = findLocs name xs1
|
|
let b = Box undefined (Epsilon target (walls xs1)) color_ False
|
|
bs <- parseBlocks xs2
|
|
pure ((name, b, locs):bs)
|
|
_ -> Left "bad block"
|
|
|
|
splitWalls (x:xs) =
|
|
case splitAt (length x - 1) xs of
|
|
(a,b) -> (x:a, b)
|
|
|
|
parseColor :: String -> Either String Attr
|
|
parseColor "white" = Right (withForeColor defAttr white)
|
|
parseColor "cyan" = Right (withForeColor defAttr cyan)
|
|
parseColor "blue" = Right (withForeColor defAttr blue)
|
|
parseColor "red" = Right (withForeColor defAttr red)
|
|
parseColor "yellow" = Right (withForeColor defAttr yellow)
|
|
parseColor "magenta" = Right (withForeColor defAttr magenta)
|
|
parseColor "black" = Right (withForeColor defAttr black)
|
|
parseColor "green" = Right (withForeColor defAttr green)
|
|
parseColor x = Left ("bad color " ++ x)
|
|
|
|
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
|
|
]
|