From 884ea15e6c8fe94b4aeaa0a4dc0f0dbadbbad642 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sun, 4 Dec 2022 16:45:15 -0800 Subject: [PATCH] nicer level parser --- app/Main.hs | 130 +++++++++++++++++++++++++++++++------------------- app/Parser.hs | 78 ++++++++++++++++++++++++++++++ parabox.cabal | 2 +- 3 files changed, 159 insertions(+), 51 deletions(-) create mode 100644 app/Parser.hs diff --git a/app/Main.hs b/app/Main.hs index 25eb5ef..311c967 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,7 @@ import System.Environment ( getArgs ) import Model import Rendering ( render ) +import Parser (parse) data Game = Game { gameWorlds :: NonEmpty World, @@ -72,6 +73,7 @@ worldList = Map.fromList , ("infiniteEnter17", infiniteEnter17) , ("infiniteEnter19", infiniteEnter19) , ("infiniteEnter20", infiniteEnter20) + , ("multiInfinite5", multiInfinite5) , ("multiInfinite8", multiInfinite8) ] @@ -174,56 +176,58 @@ center8 = (Location 'a' 3 2) center13 :: World -center13 = - World - (Map.fromList - [('a', - Box (Location 'a' 3 (-3)) - (Original (makeWalls [ - "▓▓▓▓▓▓▓▓▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓▓▓ ▓▓", - "▓ ▓ ▓ ▓▓", - "▓ ▓▓ ▓", - "▓▓▓▓▓▓▓▓▓" - ])) - (withForeColor defAttr cyan) - False), - ('1', - Box - (Location 'a' (-1) 1) - (Original (makeWalls [ - " ", - " ▓▓▓▓▓▓▓ ", - " ▓▓▓▓▓▓▓ ", - " ▓▓▓▓▓▓▓ ", - " ▓▓▓▓▓▓▓ ", - " ▓▓▓▓▓▓▓ ", - " ▓▓▓▓▓▓▓ ", - " ▓▓▓▓▓▓▓ ", - " " - ])) - (withForeColor defAttr green) - False), - ('2', - Box - (Location 'a' (-1) (-1)) - (Original (solid 9)) - (withForeColor defAttr yellow) - True), - ('b', - Box - (Location 'a' (-3) 0) - (Original (solid 9)) - (withForeColor defAttr red) - True) - ]) 'b' - Set.empty - (Location 'a' 2 0) - +center13 = parse + "player p\n\ + \block t cyan boring\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓t▓a▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \block a cyan interesting\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓ p =▓\n\ + \▓ ▓\n\ + \▓ x g ▓\n\ + \▓ ▓\n\ + \▓ ▓▓▓ ▓▓\n\ + \▓ ▓-▓ ▓▓\n\ + \▓ ▓ ▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \block g green interesting\n\ + \ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ ▓▓▓▓▓▓▓ \n\ + \ \n\ + \block x yellow boring\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \block p magenta boring\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓ ▓▓▓ ▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n" clone11 :: World clone11 = @@ -1234,6 +1238,32 @@ infiniteEnter20 = Set.empty (Location 'w' (-3) 3) +multiInfinite5 :: World +multiInfinite5 = parse + "player p\n\ + \block b blue interesting\n\ + \▓▓▓ ▓\n\ + \▓▓▓ ▓\n\ + \▓▓▓ b 1 ▓\n\ + \▓=▓ p ▓\n\ + \▓-▓ 3 2 ▓\n\ + \▓-▓ ▓\n\ + \▓-▓ ▓\n\ + \▓ ▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \block p magenta boring\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓ ▓▓▓ ▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \▓▓▓▓▓▓▓▓▓\n\ + \infinity 1 b blue\n\ + \infinity 2 b blue\n\ + \infinity 3 b blue\n" multiInfinite8 :: World multiInfinite8 = diff --git a/app/Parser.hs b/app/Parser.hs new file mode 100644 index 0000000..cb72e99 --- /dev/null +++ b/app/Parser.hs @@ -0,0 +1,78 @@ +{-# 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_ False,[]):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 + ] \ No newline at end of file diff --git a/parabox.cabal b/parabox.cabal index 0033832..bacdfa0 100644 --- a/parabox.cabal +++ b/parabox.cabal @@ -19,7 +19,7 @@ common warnings executable parabox import: warnings main-is: Main.hs - other-modules: Rendering, Model + other-modules: Rendering, Model, Parser -- other-modules: default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase