support sizes other than 9

app/Parser.hs

@@ -34,7 +34,7 @@ parseBlocks (x:xs) =
   case words x of
     ["block", [name], color, boring] ->
       do color_ <- parseColor color
-         let (xs1,xs2) = splitAt 9 xs
+         let (xs1,xs2) = splitWalls xs
          let locs = findLocs name xs1
          let b = Box undefined (Original (walls xs1)) color_ (boring == "boring")
          bs <- parseBlocks xs2
@@ -49,13 +49,17 @@ parseBlocks (x: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 (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)
@@ -68,11 +72,23 @@ 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))
+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)
-    | (y, row) <- zip [-4..] xs
-    , (x, c  ) <- zip [-4..] row
-  ]
+    | let (ylo, yhi) = mkRange (length xs)
+    , (y, row) <- zip [ylo .. yhi] xs
+    , let (xlo,xhi) = mkRange (length row)
+    , (x, c  ) <- zip [xlo..xhi] row
+  ]

app/Rendering.hs

@@ -4,52 +4,55 @@ import Data.Array
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
-import Data.List (intersperse)
+import Data.List (intersperse, group)
 import Graphics.Vty
-
 import Model
 
 border :: Int
 border = 20
 
-unit :: Attr -> Int -> Char -> Image
-unit a scale x =
-    vertCat (replicate scale (string a (replicate (2*scale) x)))
+unit :: Attr -> Int -> Int -> Char -> Image
+unit a h w c =
+  vertCat (replicate h (string a (replicate w c)))
 
 drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image
-drawBox a _ 1 = string a "[]"
+drawBox a 2 1 = string a "[]"
+drawBox a w 1 = string a ("[" ++ replicate (w-2) '-' ++ "]")
 drawBox a w h = vertCat $
   string a ('┌' : replicate (w-2) '─' ++ "┐") :
   replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++
   [string a ('└' : replicate (w-2) '─' ++ "┘")]
 
-button :: Attr -> Int -> Image
-button a 1 = string a "[]"
-button a n = vertCat $
-  string a ('┌' : replicate (2*n-2) '─' ++ "┐") :
-  replicate (n-2) (string a ('│' : replicate (2*n-2) '░' ++ "│")) ++
-  [string a ('└' : replicate (2*n-2) '─' ++ "┘")]
+button :: Attr -> Int -> Int -> Image
+button a 1 2 = string a "[]"
+button a 1 n = string a ("[" ++ replicate (n-2) '-' ++ "]")
+button a h w = vertCat $
+  string a ('┌' : replicate (w-2) '─' ++ "┐") :
+  replicate (h-2) (string a ('│' : replicate (w-2) '░' ++ "│")) ++
+  [string a ('└' : replicate (w-2) '─' ++ "┘")]
 
-home :: Attr -> Int -> Image
-home a 1 = string a "<>"
-home a n = vertCat $
-  string a ('╔' : replicate (2*n-2) '═' ++ "╗") :
-  replicate (n-2) (string a ('║' : replicate (2*n-2) '░' ++ "║")) ++
-  [string a ('╚' : replicate (2*n-2) '═' ++ "╝")]
+home :: Attr -> Int -> Int -> Image
+home a 1 2 = string a "<>"
+home a 1 w = string a ("<" ++ replicate (w-2) '=' ++ ">")
+home a h w  = vertCat $
+  string a ('╔' : replicate (w-2) '═' ++ "╗") :
+  replicate (h-2) (string a ('║' : replicate (w-2) '░' ++ "║")) ++
+  [string a ('╚' : replicate (w-2) '═' ++ "╝")]
 
-renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
-renderCell world locMap name box y x scale =
-    if boxWalls world box ! (y,x) then unit (boxColor box) scale wallChar
+renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image
+renderCell world locMap name box y x h w =
+    if boxWalls world box ! (y,x) then unit (boxColor box) h w wallChar
       else case Map.lookup (Location name' y x) locMap of
         Just n ->
-            if scale < 9
-                then unit (boxColor (worldBoxes world Map.! n)) scale n 
-                else renderBox world locMap (worldBoxes world Map.! n) n
-                        (scale `div` boxSize world box)
+          let box' = worldBoxes world Map.! n
+          in if h < boxSize world box'
+              then unit (boxColor box') h w n 
+              else renderBox world locMap box' n
+                        h w
         Nothing
-          | Set.member loc (worldButtons world) -> button (boxColor box) scale
-          | loc == worldHome world -> home (boxColor box) scale
-          | otherwise -> unit (boxColor box) scale floorChar
+          | Set.member loc (worldButtons world) -> button (boxColor box) h w
+          | loc == worldHome world -> home (boxColor box) h w
+          | otherwise -> unit (boxColor box) h w floorChar
     where
       loc = Location name' y x
       name' = contentName world name box
@@ -74,16 +77,19 @@ contentName world name box =
     Infinity c -> contentName world c (worldBoxes world Map.! c)
     Epsilon{} -> name
 
-renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image
-renderBox world locMap box name scale =
+renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image
+renderBox world locMap box name h w =
   vertCat [
     horizCat [
-      renderCell world locMap name box y x scale
-      | x <- [xlo .. xhi]
+      renderCell world locMap name box y x h w
+      | (x,w) <- zip [xlo .. xhi] (divisions boxWidth w)
     ]
-    | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
-    , y <- [ylo .. yhi]
+    | (y,h) <- zip [ylo .. yhi] (divisions boxHeight h)
   ]
+  where
+    ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
+    boxWidth = xhi - xlo + 1
+    boxHeight = yhi - ylo + 1
 
 render ::
   Bool {- ^ show flat overlay -} ->
@@ -115,7 +121,7 @@ renderFlat locMap world =
       pad 2 1 2 1 $
       horizCat $
       intersperse (char borderAttr ' ')
-      [renderBox world locMap b n 2
+      [renderBox world locMap b n 18 36
       | (n,b) <- Map.assocs (worldBoxes world)
       , not (boxBoring b)]
 
@@ -133,10 +139,10 @@ drawNestedWorld locMap world =
         intersperse (char defAttr ' ')
          [
             case stackedLoc world locMap (Location name1 y_ x_) of
-                Nothing -> unit (withForeColor defAttr black) 81 '?'
+                Nothing -> unit (withForeColor defAttr black) 81 162 '?'
                 Just (Location n y x) ->
                     let box = worldBoxes world Map.! n in
-                    renderCell world locMap n box y x 81
+                    renderCell world locMap n box y x 81 (81*2)
         | x_ <- [x1-1 .. x1+1]
         ]
         | y_ <- [y1-1 .. y1+1]
@@ -192,4 +198,16 @@ fixup1 :: Int -> Int -> Int -> Int -> Int
 fixup1 _ _ 0 i = i
 fixup1 _ hi (-1) _ = hi
 fixup1 lo _ 1 _ = lo
-fixup1 _ _ _ _ = error "fixup1: bad delta"
+fixup1 _ _ _ _ = error "fixup1: bad delta"
+
+divisions :: Int -> Int -> [Int]
+divisions divs size =
+  map length $ group
+  [ round (
+    (fromIntegral i + 1 / 2)
+    / fromIntegral size
+    * fromIntegral divs
+    - 1/2
+  )
+  | i <- [0 ..size-1]
+  ]