nicer level parser

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 =

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
+  ]

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