78 lines
2.7 KiB
Haskell
78 lines
2.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
|
|
|
|
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) = splitAt 9 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) = splitAt 9 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"
|
|
|
|
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 ((-4,-4),(4,4)) (map ('▓'==) (concat rows))
|
|
|
|
findLocs :: Char -> [[Char]] -> [(Char, Location)]
|
|
findLocs name xs =
|
|
[ (c, Location name y x)
|
|
| (y, row) <- zip [-4..] xs
|
|
, (x, c ) <- zip [-4..] row
|
|
] |