big ?

app/BigFont.hs

@@ -19,6 +19,12 @@ letters = Map.fromList
    ,"   "
    ,"   "
    ,"   "]),
+  ('?',
+   ["██████ "
+   ,"     ██"
+   ,"  ▄███ "
+   ,"  ▀▀   "
+   ,"  ██   "]),
   ('A',
    [" █████ "
    ,"██   ██"

app/Model.hs

@@ -23,8 +23,8 @@ boxWalls :: World -> Box -> Array Coord Bool
 boxWalls world box =
     case boxType box of
         Original walls -> walls
-        Link c -> boxWalls world (worldBoxes world Map.! c)
+        Link c -> boxWalls world (boxIx world c)
-        Infinity c -> boxWalls world (worldBoxes world Map.! c)
+        Infinity c -> boxWalls world (boxIx world c)
         Epsilon _ walls -> walls
 
 data BoxType
@@ -50,9 +50,9 @@ data World = World {
 winCondition :: World -> Bool
 winCondition world =
   Set.isSubsetOf (worldButtons world) coverage &&
-  Just (worldHome world) == boxLocation (worldBoxes world Map.! worldMe world)
+  Just (worldHome world) == boxLocation (boxIx world (worldMe world))
   where
-    coverage = Set.fromList $ mapMaybe boxLocation $ Map.elems (worldBoxes world)
+    coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world)))
 
 
 boxSize :: World -> Box -> Int
@@ -72,8 +72,7 @@ move world dir =
           world { worldBoxes = Map.mergeWithKey (\_ a b -> Just (f a b)) id (const Map.empty) (worldBoxes world) changes}
 
 myLocation :: World -> Maybe Location
-myLocation world =
+myLocation world = boxLocation (boxIx world (worldMe world))
-  boxLocation (worldBoxes world Map.! worldMe world)
 
 isWall :: World -> Location -> Bool
 isWall world (Location n y x) =
@@ -140,7 +139,7 @@ moveBlock' world visited loc loc' dir name box enters offset =
 
         moveEpsilon =
          do epsilon <- findEpsilon world (locName loc')
-            let eBox = worldBoxes world Map.! epsilon
+            let eBox = boxIx world epsilon
             (locI, offset') <- enterLoc world epsilon eBox dir offset
             moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
 
@@ -177,6 +176,9 @@ boxAt :: World -> Location -> Maybe (Char, Box)
 boxAt world loc =
   listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == Just loc]
 
+boxIx :: World -> Char -> Box
+boxIx world name = worldBoxes world Map.! name
+
 invert :: Movement -> Movement
 invert (dy,dx) = (-dy, -dx)
 

app/Parser.hs

@@ -1,14 +1,14 @@
-{-# Language ViewPatterns #-}
+module Parser (parse) where
-module Parser where
 
-import Model
+import Control.Applicative
-import Graphics.Vty.Attributes
+import Control.Monad
 import Data.Array (Array, listArray)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
+import Graphics.Vty.Attributes
 import Text.ParserCombinators.ReadP hiding (many)
-import Control.Applicative
+
-import Control.Monad
+import Model
 
 parse :: String -> World
 parse str =
@@ -17,10 +17,7 @@ parse str =
     (((p,h,w),bs),_):_ ->
       do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
          World
-          (Map.fromList [
+          (Map.fromList [(n, b { boxLocation = head <$> Map.lookup n m }) | (n,b,_) <- bs])
-            (n, b { boxLocation = fmap head (Map.lookup n m)})
-            | (n,b,_) <- bs
-          ])
           p
           (Set.fromList (Map.findWithDefault [] '-' m))
           (head (m Map.! '='))
@@ -45,9 +42,9 @@ parseBoring :: ReadP Bool
 parseBoring =
  do t <- token
     case t of
-      "boring" -> pure True
+      "boring"      -> pure True
       "interesting" -> pure False
-      _ -> empty
+      _             -> empty
 
 parseBlock :: ReadP (Char, Box, [(Char, Location)])
 parseBlock =
@@ -68,13 +65,13 @@ parseBlock =
           [target] <- token
           color <- parseColor
           _ <- char '\n'
-          pure (name, Box undefined (Link target) color True, [])
+          pure (name, Box Nothing (Link target) color True, [])
       "infinity" ->
        do [name] <- token
           [target] <- token
           color <- parseColor
           _ <- char '\n'
-          pure (name, Box undefined (Infinity target) color True,[])
+          pure (name, Box Nothing (Infinity target) color True,[])
       "epsilon" ->
        do [name] <- token
           [target] <- token
@@ -83,7 +80,7 @@ parseBlock =
           _ <- char '\n'
           xs1 <- parseWalls
           let locs = findLocs name xs1
-          let b = Box undefined (Epsilon target (walls xs1)) color False
+          let b = Box Nothing (Epsilon target (walls xs1)) color False
           pure (name, b, locs)
       _ -> empty
 

app/Rendering.hs

@@ -7,6 +7,8 @@ import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.List (intersperse, group)
 import Graphics.Vty
+
+import BigFont
 import Model
 
 border :: Int
@@ -17,23 +19,20 @@ unit a h w c =
   vertCat (replicate h (string a (replicate w c)))
 
 drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image
-drawBox a 2 1 = string a "[]"
+drawBox a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
-drawBox a w 1 = string a ("[" ++ replicate (w-2) '-' ++ "]")
+drawBox a h w = vertCat $
-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 -> Int -> Image
-button a 1 2 = string a "[]"
+button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
-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 -> 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) '═' ++ "╗") :
@@ -41,53 +40,55 @@ home a h w  = vertCat $
   [string a ('╚' : replicate (w-2) '═' ++ "╝")]
 
 renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image
-renderCell world locMap name box y x h w =
+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
+  | boxWalls world box ! (y,x) = unit (boxColor box) h w wallChar
-        Just n ->
+
-          let box' = worldBoxes world Map.! n
+  | Just n <- Map.lookup (Location name' y x) locMap
-          in if h < boxSize world box'
+  , let box' = boxIx world n
-              then unit (boxColor box') h w n
+  = if h < boxSize world box'
-              else renderBox world locMap box' n
+      then unit (boxColor box') h w n
-                        h w
+      else renderBox world locMap box' n h w
-        Nothing
+
-          | Set.member loc (worldButtons world) -> button (boxColor box) h w
+  | 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
+  | 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
       wallChar =
           case boxType box of
-              Original{} -> '▓'
+              Original {} -> '▓'
-              Link{} -> '▒'
+              Link     {} -> '▒'
               Infinity {} -> '▓'
-              Epsilon {} -> '▓'
+              Epsilon  {} -> '▓'
       floorChar =
           case boxType box of
-              Original{} -> '░'
+              Original {} -> '░'
-              Link{} -> '·'
+              Link     {} -> '·'
               Infinity {} -> '∞'
-              Epsilon {} -> 'ε'
+              Epsilon  {} -> 'ε'
 
 contentName :: World -> Char -> Box -> Char
 contentName world name box =
   case boxType box of
     Original{} -> name
-    Link c -> c
+    Epsilon{}  -> name
-    Infinity c -> contentName world c (worldBoxes world Map.! c)
+    Link     c -> c
-    Epsilon{} -> name
+    Infinity c -> contentName world c (boxIx world c)
 
 renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image
 renderBox world locMap box name boxh boxw =
   vertCat [
     horizCat [
       renderCell world locMap name box y x cellh cellw
-      | (x,cellw) <- zip [xlo .. xhi] (divisions boxWidth boxw)
+      | (x,cellw) <- zip [xlo .. xhi] xdivs ]
-    ]
+    | (y,cellh) <- zip [ylo .. yhi] ydivs ]
-    | (y,cellh) <- zip [ylo .. yhi] (divisions boxHeight boxh)
-  ]
   where
+    ydivs = divisions boxHeight boxh
+    xdivs = divisions boxWidth boxw
     ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
     boxWidth = xhi - xlo + 1
     boxHeight = yhi - ylo + 1
@@ -105,15 +106,19 @@ render flat world = picForLayers $
     string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║  ██║" <->
     string defAttr " ╚══╝╚══╝ ╚═╝╚═╝  ╚═══╝╚═╝  ╚═══╝╚══════╝╚═╝  ╚═╝"
   | winCondition world ] ++
+  [ pad 94 7 0 0 $
+    vertCat (map (string defAttr) (bigText "VOIDED"))
+  | isNothing (boxLocation (boxIx world (worldMe world))) ] ++
   (if flat then renderFlat locMap world else []) ++
   [drawNestedWorld locMap world]
   where
-    locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world), loc <- maybeToList (boxLocation box)]
+    locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world)
+                                    , loc <- maybeToList (boxLocation box)]
 
 renderFlat :: Map Location Char -> World -> [Image]
 renderFlat locMap world =
   [ pad offset 0 0 0 baseImage
-  , pad offset 0 0 0 $ drawBox borderAttr (imageWidth baseImage) (imageHeight baseImage)
+  , pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage)
   ]
   where
     borderAttr = defAttr `withForeColor` white `withBackColor` black
@@ -140,28 +145,47 @@ drawNestedWorld locMap world =
          [
             case myLocation world of
               Nothing
-                | dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! worldMe world) (worldMe world) h w
+                | dx==0 && dy==0 -> renderBox world locMap (boxIx world (worldMe world)) (worldMe world) h w
                 | otherwise -> infinityImage
               Just (Location name0 _ _) ->
-                case boxLocation (worldBoxes world Map.! name0) of
+                case boxLocation (boxIx world name0) of
                   Nothing
-                    | dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! name0) name0 h w
+                    | dx==0 && dy==0 -> renderBox world locMap (boxIx world name0) name0 h w
                     | otherwise -> infinityImage
                   Just (Location name1 y1 x1) ->
                     case stackedLoc world locMap (Location name1 (y1+dy) (x1+dx)) of
                         Nothing -> infinityImage
                         Just (Location n y x) ->
-                            let box = worldBoxes world Map.! n in
+                            renderCell world locMap n (boxIx world n) y x h w
-                            renderCell world locMap n box y x h w
         | dx <- [-1 .. 1]
         ]
         | dy <- [-1 .. 1]
     ]
   where
-    infinityImage = unit (withForeColor defAttr black) h w '?'
+    infinityImage = makeInfinity h w
     h = worldHeight world
     w = worldWidth world
 
+makeInfinity :: Int -> Int -> Image
+makeInfinity h w = result
+  where
+    attr = defAttr `withForeColor` black
+    single = vertCat (map (string attr) (bigText "?"))
+
+    rowN = (w+1) `div` (imageWidth single + 1)
+    rowTotalGap = w - rowN * imageWidth single
+    rowGaps = divisions (rowN-1) rowTotalGap
+
+    row = foldr mkRow single rowGaps
+    mkRow gap rest = single <|> charFill attr ' ' gap 1 <|> rest
+
+    colN = (h+1) `div` (imageHeight single + 1)
+    colTotalGap = h - colN * imageHeight single
+    colGaps = divisions (colN-1) colTotalGap
+
+    result = foldr mkCol row colGaps
+    mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest
+
 stackedLoc :: World -> Map Location Char -> Location -> Maybe Location
 stackedLoc world locMap = go Set.empty
   where
@@ -200,7 +224,7 @@ fixup world locMap dy dx py px loc =
     Nothing -> loc
     Just name -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px)
       where
-        ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (worldBoxes world Map.! name))
+        ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (boxIx world name))
 
 fixup1 :: Int -> Int -> Int -> Int -> Int
 fixup1 _ _ 0 i = i
@@ -208,7 +232,10 @@ fixup1 _ hi (-1) _ = hi
 fixup1 lo _ 1 _ = lo
 fixup1 _ _ _ _ = error "fixup1: bad delta"
 
-divisions :: Int -> Int -> [Int]
+divisions ::
+  Int {- ^ result length -} ->
+  Int {- ^ result sum -} ->
+  [Int]
 divisions divs size =
   map length $ group
   [ round (

levels/player19.txt

@@ -1,16 +1,14 @@
-player p
+player p height 80 width 160
 block p magenta interesting
      
-       
+ ▓ ▓ 
-  p ▓  
+  p  
-       
+ 1 2 
-  1 2  
-       
 c    
 block c green interesting
 ▓▓▓
- =▓
+▓=▓
-▓▓▓
+▓ ▓
 block 1 blue boring
 ▓
 block 2 blue boring