pre-exit

app/Main.hs

@@ -39,18 +39,45 @@ renderBox world locMap box boxName =
   [
     horizCat
     [
-      if boxWalls box ! (y,x) then char myAttr '▓'
+      if boxWalls box ! (y,x) then unit myAttr '▓'
       else case Map.lookup (Location boxName y x) locMap of
-        Nothing -> char myAttr '░'
+        Nothing -> unit myAttr '░'
-        Just n -> char (boxColor (worldBoxes world Map.! n)) n
+        Just n -> unit (boxColor (worldBoxes world Map.! n)) n
       | x <- [xlo .. xhi]
     ]
 
     | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
     , let myAttr = boxColor box
     , y <- [ylo .. yhi]
+    , let unit a x = string a [x,x]
   ]
 
+renderBox' :: World -> Map Location Char -> Box -> Char -> ((Int,Int),(Int,Int)) -> Int -> Image
+renderBox' world locMap box boxName ((ylo,xlo),(yhi,xhi)) scale
+  | scale == 1 = renderBox world locMap box boxName
+  | otherwise =
+  vertCat
+  [
+    horizCat
+    [
+      if not (inRange (bounds (boxWalls box)) (y,x)) then unit defAttr '?' else
+      if boxWalls box ! (y,x) then unit myAttr '▓'
+      else case Map.lookup (Location boxName y x) locMap of
+        Nothing -> unit myAttr '░'
+        Just n -> renderBox' world locMap box' n (bounds (boxWalls box')) (scale `div` boxSize box)
+          where
+            box' = worldBoxes world Map.! n
+      | x <- [xlo .. xhi]
+    ]
+
+    | let myAttr = boxColor box
+    , y <- [ylo .. yhi]
+  ]
+  where
+    unit a x =
+      vertCat (replicate scale (string a (replicate (2*scale) x)))
+      
+
 makeWalls :: [String] -> Array Coord Bool
 makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
   where
@@ -61,6 +88,29 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
 
 mkRange n = (- (n-1)`div`2, n`div`2)
 
+boxSize :: Box -> Int
+boxSize box = yhi-ylo+1
+  where
+    ((ylo,_),(yhi,_)) = bounds (boxWalls box)
+
+drawNestedWorld :: World -> Image
+drawNestedWorld world = renderBox' world locMap box0 name0 bnds 49
+  where
+    locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
+    (bnds,name0) = go 2 0 0 (worldMe world)
+    box0 = worldBoxes world Map.! name0
+    
+    go 0 y x name = (((y-1,x-1),(y+1,x+1)), name)
+    go n y x name =
+      case Map.lookup name (worldBoxes world) of
+        Nothing -> (((y-1,x-1),(y+1,x+1)), name)
+        Just box -> go (n-1) y x name'
+          where
+            Location name' y x = boxLocation box
+
+
+
+
 drawWorld :: World -> Image
 drawWorld world =
   horizCat $
@@ -72,6 +122,8 @@ drawWorld world =
   where
     locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
 
+solid n = makeWalls (replicate n (replicate n 'x'))
+
 world0 :: World
 world0 = World {
   worldMe = 'b',
@@ -80,49 +132,43 @@ world0 = World {
       boxColor = withForeColor defAttr green,
       boxLocation = Location '1' (-1) 0,
       boxWalls = makeWalls [
-        "▓▓▓   ▓▓▓",
+        "▓▓   ▓▓",
-        "▓       ▓",
         "▓     ▓",
         "▓     ▓",
         "▓     ▓",
         "▓  ▓  ▓",
         "▓     ▓",
-        "▓       ▓",
+        "▓  ▓  ▓"
-        "▓▓▓ ▓ ▓▓▓"
         ]
     }),
     ('2', Box {
       boxColor = withForeColor defAttr cyan,
       boxLocation = Location '1' 1 1,
       boxWalls = makeWalls [
-        "▓▓▓▓ ▓▓▓▓",
+        "▓▓▓ ▓▓▓",
         "▓     ▓",
         "▓     ▓",
         "       ",
         "▓     ▓",
         "▓     ▓",
-        "▓▓▓▓ ▓▓▓▓"
+        "▓▓▓ ▓▓▓"
       ]
         
     }),
     ('b', Box {
         boxColor = withForeColor defAttr red,
         boxLocation = Location '1' 0 1,
-        boxWalls = makeWalls [
+        boxWalls = solid 7
-            "▓ ▓",
-            "   ",
-            "▓ ▓"
-          ]
     }),
     ('x', Box {
         boxColor = withForeColor defAttr yellow,
         boxLocation = Location '1' 0 (-1),
-        boxWalls = makeWalls ["▓"]
+        boxWalls = solid 7
     }),
     ('y', Box {
         boxColor = withForeColor defAttr magenta,
         boxLocation = Location '1' 0 (-2),
-        boxWalls = makeWalls ["▓"]
+        boxWalls = solid 7
     })
 
     ]
@@ -162,7 +208,7 @@ main =
 
 loop :: Vty -> NonEmpty World -> IO ()
 loop vty (world :| history) =
- do update vty (picForImage (drawWorld world))
+ do update vty (picForImage (drawNestedWorld world))
     ev <- nextEvent vty
     case ev of
       EvKey key _modifier ->
@@ -204,21 +250,24 @@ moveBlock world visited loc dir =
     -- moving a box
     (name,box):_ ->
      do loc' <- nextLoc world loc dir
-        guard (not (isWall loc' world))
         moveBlock' world visited loc loc' dir name box
 
 moveBlock' world visited loc loc' dir name box =
         msum [moveTo loc', moveInto loc', moveToEat loc']
       where
-        moveTo loc' = moveBlock world (addVisited loc loc' visited) loc' dir
+        moveTo loc' =
+         do guard (not (isWall loc' world))
+            moveBlock world (addVisited loc loc' visited) loc' dir
 
         moveInto loc' =
-         do (n,b) <- boxAt world loc'
+         do guard (not (isWall loc' world))
+            (n,b) <- boxAt world loc'
             let locI = enterLoc n b dir
             moveBlock world (addVisited loc locI visited) locI dir
         
         moveToEat loc' =
-         do let dir' = invert dir
+         do guard (not (isWall loc' world))
+            let dir' = invert dir
             let locE = enterLoc name box dir'
             (name', box') <- boxAt world loc' 
             moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box'