configurable sizes

2022-12-07 10:11:06 -08:00 · 2022-12-07 10:11:06 -08:00 · babd42f838
commit babd42f838
parent 2912fb9488
8 changed files with 154 additions and 134 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -3,6 +3,8 @@ module Main (main) where
 import Control.Exception ( bracket )
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.NonEmpty qualified as NonEmpty
+import Data.Char (toUpper)
+import Data.List (intersperse)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Graphics.Vty
@ -13,6 +15,7 @@ import System.FilePath ( (</>), takeBaseName )
 import Model
 import Rendering ( render )
 import Parser (parse)
+import BigFont

 data Game = Game {
  gameFlat :: Bool,
@ -98,16 +101,19 @@ renderMenu (w,h) before after =
  where
    menu =
      case Map.minViewWithKey after of
-        Nothing -> string defAttr "empty menu"
+        Nothing -> bigString defAttr "empty menu"
        Just ((k,_),after') ->
-          let len1 = (h-1)`div`2 in
-          pad 0 (len1 - Map.size before) 0 0 (vertCat
-            [ string defAttr x
+          let len1 = (h-1)`div`2 `div` 6 in
+          pad 0 (max 0 (6 * (len1 - Map.size before))) 0 0 $
+          vertCat $
+          intersperse (char defAttr ' ') $
+            [ bigString defAttr x
              | x <- drop (Map.size before - len1) (Map.keys before)
-            ]) <->
-            string (defAttr `withBackColor` cyan `withForeColor` white) k
-            <->
-            vertCat
-            [ string defAttr x
+            ] ++
+            [bigString (defAttr `withBackColor` cyan `withForeColor` white) k] ++
+            [ bigString defAttr x
              | x <- drop (Map.size after' - h`div`2) (Map.keys after')
            ]
+
+bigString :: Attr -> String -> Image
+bigString a = vertCat . map (string a) . bigText . map toUpper
--- a/app/Model.hs
+++ b/app/Model.hs
@ -41,7 +41,9 @@ data World = World {
  worldBoxes :: Map Char Box,
  worldMe :: Char,
  worldButtons :: Set Location,
-  worldHome :: Location
+  worldHome :: Location,
+  worldHeight :: Int,
+  worldWidth :: Int
 }
  deriving (Show, Read, Eq)

--- a/app/Parser.hs
+++ b/app/Parser.hs
@ -6,70 +6,109 @@ 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 = 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
+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 = head (m Map.! n)})
            | (n,b,_) <- bs
          ])
-          h
+          p
          (Set.fromList (Map.findWithDefault [] '-' m))
          (head (m Map.! '='))
-    [] -> Left "empty input"
+          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)

-parseHeader :: String -> Either String Char
-parseHeader (words -> ["player", [p]]) = Right p
-parseHeader _ = Left "bad header"
+integer :: ReadP Int
+integer = readS_to_P reads

-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"
+parseBoring :: ReadP Bool
+parseBoring =
+ do t <- token
+    case t of
+      "boring" -> pure True
+      "interesting" -> pure False
+      _ -> empty

-splitWalls (x:xs) =
-  case splitAt (length x - 1) xs of
-    (a,b) -> (x:a, b)
+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 undefined (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

-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)
+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))
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -116,7 +116,7 @@ renderFlat locMap world =
  ]
  where
    borderAttr = defAttr `withForeColor` white `withBackColor` black
-    offset = max 0 ( (2*(81+2*border)+2 - imageWidth baseImage) `div` 2)
+    offset = max 0 ( (worldWidth world + 2*(2*border)+2 - imageWidth baseImage) `div` 2)
    baseImage =
      pad 2 1 2 1 $
      horizCat $
@ -127,11 +127,10 @@ renderFlat locMap world =

 drawNestedWorld :: Map Location Char -> World -> Image
 drawNestedWorld locMap world =
-    -- (3*81) + 81 + (3*81)
-    cropTop   (81 + 2*border) $
-    cropLeft  (2*(81 + 2*border)) $
-    cropBottom (2*81 + border) $
-    cropRight  (2*(2*81 + border)) $
+    cropTop   (h + 2*border) $
+    cropLeft  (w + 4*border) $
+    cropBottom (2*h + border) $
+    cropRight  (2*(w + border)) $
    vertCat $
    intersperse (char defAttr ' ')
    [
@ -139,15 +138,17 @@ drawNestedWorld locMap world =
        intersperse (char defAttr ' ')
         [
            case stackedLoc world locMap (Location name1 y_ x_) of
-                Nothing -> unit (withForeColor defAttr black) 81 162 '?'
+                Nothing -> unit (withForeColor defAttr black) h w '?'
                Just (Location n y x) ->
                    let box = worldBoxes world Map.! n in
-                    renderCell world locMap n box y x 81 (81*2)
+                    renderCell world locMap n box y x h w
        | x_ <- [x1-1 .. x1+1]
        ]
        | y_ <- [y1-1 .. y1+1]
    ]
  where
+    h = worldHeight world
+    w = worldWidth world
    -- name1 is the box the player is standing in
    Location name0 _ _ = myLocation world
    Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)
--- a/levels/center8.txt
+++ b/levels/center8.txt
@ -1,14 +1,10 @@
 player p
 block t white boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓t▓a▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓▓▓
+▓▓▓▓▓
+▓t▓a▓
+▓▓▓▓▓
+▓▓▓▓▓
 block a white interesting
 ▓▓▓▓▓▓▓▓▓
 ▓▓▓▓▓▓▓▓▓
@ -22,14 +18,14 @@ block a white interesting
 block g green interesting
  x ▓
  ▓▓▓
-         
-         
-         
+     
+     
+     
 block x yellow boring
 ▓
 block p magenta boring
-▓▓▓▓▓▓
-▓ ▓▓ ▓
-▓▓▓▓▓▓
-▓▓▓▓▓▓
-▓▓▓▓▓▓
+▓▓▓▓▓
+▓ ▓ ▓
+▓▓▓▓▓
+▓▓▓▓▓
+▓▓▓▓▓
--- a/levels/eat11.txt
+++ b/levels/eat11.txt
@ -1,4 +1,4 @@
-player p
+player p height 75 width 150
 block t red boring
 ▓▓▓▓▓
 ▓▓▓▓▓
@ -6,15 +6,11 @@ block t red boring
 ▓▓▓▓▓
 ▓▓▓▓▓
 block r red interesting
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓     ▓▓
-▓▓ p y ▓▓
-▓▓     ▓▓
-▓▓ b g ▓▓
-▓▓=   -▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+     
+ p y 
+     
+ b g 
+=   -
 block p magenta boring
 ▓▓▓▓▓
 ▓ ▓ ▓
--- a/levels/infiniteExit15.txt
+++ b/levels/infiniteExit15.txt
@ -1,14 +1,10 @@
 player m
 block t cyan boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓t▓a▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓▓▓
+▓▓▓▓▓
+▓t▓a▓
+▓▓▓▓▓
+▓▓▓▓▓
 block a cyan interesting
 ▓▓▓G▓▓▓▓▓
     ▓▓▓▓
@ -20,35 +16,19 @@ block a cyan interesting
     ▓▓▓▓
 ▓▓▓▓▓▓▓▓▓
 block m magenta boring
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓ ▓▓▓ ▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
-▓▓▓▓▓▓▓▓▓
+▓▓▓▓▓
+▓ ▓ ▓
+▓▓▓▓▓
+▓▓▓▓▓
+▓▓▓▓▓
 block g green interesting
-         
-         
-         
-         
-         
-         
-         
-         
-         
+   
+   
+   
 block p red interesting
-         
-         
-         
-         
-         
-         
-         
-         
-         
+   
+   
+   
 link G g green
 link P p red
 infinity Γ g green
--- a/parabox.cabal
+++ b/parabox.cabal
@ -19,7 +19,7 @@ common warnings
 executable parabox
    import:           warnings
    main-is:          Main.hs
-    other-modules:    Rendering, Model, Parser
+    other-modules:    Rendering, Model, Parser, BigFont
    -- other-modules:
    default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase