refactor rendering

app/Model.hs

@@ -34,6 +34,7 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
     (xlo,xhi) = mkRange w
     (ylo,yhi) = mkRange h
 
+mkRange :: Int -> (Int,Int)
 mkRange n = (- (n-1)`div`2, n`div`2)
 
 boxSize :: Box -> Int
@@ -42,6 +43,7 @@ boxSize box = yhi-ylo+1
     ((ylo,_),(yhi,_)) = bounds (boxWalls box)
 
 
+solid :: Int -> Array Coord Bool
 solid n = makeWalls (replicate n (replicate n 'x'))
 
 -- Move an object
@@ -79,11 +81,11 @@ moveBlock ::
   Maybe (Map Location Location)
 
 -- moving into a wall, not possible
-moveBlock world visited loc _
+moveBlock world _ loc _
   | isWall loc world = Nothing
 
 -- move introduced a loop, trim off the tail and report success
-moveBlock world visited loc _
+moveBlock _ visited loc _
   | Just (n,_) <- Map.lookup loc visited
   = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))
 
@@ -98,18 +100,27 @@ moveBlock world visited loc dir =
         guard (not (isWall loc' world))
         moveBlock' world visited loc loc' dir name box
 
+moveBlock' ::
+    World -> 
+    Map Location (Int, Location) -> 
+    Location -> 
+    Location -> 
+    Movement -> 
+    Char -> 
+    Box -> 
+    Maybe (Map Location Location)
 moveBlock' world visited loc loc' dir name box =
-        msum [moveTo loc', moveInto loc', moveToEat loc']
+        msum [moveTo, moveInto, moveToEat]
       where
-        moveTo loc' =
+        moveTo =
          do moveBlock world (addVisited loc loc' visited) loc' dir
 
-        moveInto loc' =
+        moveInto =
          do (n,b) <- boxAt world loc'
             let locI = enterLoc n b dir
             moveBlock' world visited loc locI dir name box -- beware epsilon!
         
-        moveToEat loc' =
+        moveToEat =
          do let dir' = invert dir
             let locE = enterLoc name box dir'
             (name', box') <- boxAt world loc' 
@@ -130,21 +141,29 @@ boxAt :: World -> Location -> Maybe (Char, Box)
 boxAt world loc =
   listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]
 
+invert :: Movement -> Movement
 invert (dy,dx) = (-dy, -dx)
 
+midpoint :: Int -> Int -> Int
 midpoint lo hi = (hi+lo)`div`2
 
+addVisited ::
+    Location {- ^ start -} ->
+    Location {- ^ end   -} ->
+    Map Location (Int, Location) ->
+    Map Location (Int, Location)
 addVisited k v m = Map.insert k (Map.size m, v) m
 
+nextLoc :: World -> Location -> (Int, Int) -> Maybe Location
 nextLoc world loc (dy, dx) = go Set.empty loc
   where
     
-  go visited (Location b y x)
+  go _ (Location b y x)
     | Just box <- Map.lookup b (worldBoxes world)
     , inRange (bounds (boxWalls box)) (y+dy, x+dx)
     = Just (Location b (y+dy) (x+dx))
   
-  go visited (Location b y x)
+  go visited (Location b _ _)
     | Just box <- Map.lookup b (worldBoxes world)
     , Set.notMember b visited
     = go (Set.insert b visited) (boxLocation box)

app/Rendering.hs

@@ -5,53 +5,37 @@ import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Graphics.Vty
-import Data.List (intersperse)
 
 import Model
 
-renderBox :: World -> Map Location Char -> Box -> Char -> Image
+unit :: Attr -> Int -> Char -> Image
-renderBox world locMap box boxName =
+unit a scale x =
-  vertCat
-  [
-    horizCat
-    [
-      if boxWalls box ! (y,x) then unit myAttr '▓'
-      else case Map.lookup (Location boxName y x) locMap of
-        Nothing -> unit myAttr '░'
-        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 -> Image
-renderBox' world locMap box boxName scale
-  | scale == 1 = renderBox world locMap box boxName
-  | otherwise =
-  vertCat
-  [
-    horizCat
-    [
-        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 (scale `div` boxSize box)
-            where
-              box' = worldBoxes world Map.! n
-        | x <- [xlo .. xhi]
-    ]
-    | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
-    , let myAttr = boxColor box
-    , y <- [ylo .. yhi]
-  ]
-  where
-    unit a x =
     vertCat (replicate scale (string a (replicate (2*scale) x)))
 
+renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
+renderCell world locMap name box y x scale =
+    if boxWalls box ! (y,x) then unit (boxColor box) scale '▓'
+      else case Map.lookup (Location name y x) locMap of
+        Nothing -> unit (boxColor box) scale '░'
+        Just n ->
+            if scale == 1
+                then unit (boxColor (worldBoxes world Map.! n)) scale n 
+                else renderBox world locMap (worldBoxes world Map.! n) n
+                        (scale `div` boxSize box)
+
+renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image
+renderBox world locMap box name scale =
+  vertCat
+  [
+    horizCat
+    [
+        renderCell world locMap name box y x scale
+        | x <- [xlo .. xhi]
+    ]
+    | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
+    , y <- [ylo .. yhi]
+  ]
+        
 
 drawNestedWorld :: World -> Image
 drawNestedWorld world =
@@ -62,26 +46,17 @@ drawNestedWorld world =
     cropRight  (2*(2*49 + border)) $
     vertCat [
         horizCat [
-            case stackedLoc world (Location name1 y x) of
+            case stackedLoc world (Location name1 y_ x_) of
-                Nothing -> unit (withForeColor defAttr black) '?'
+                Nothing -> unit (withForeColor defAttr black) 49 '?'
                 Just (Location n y x) ->
-                    let box = worldBoxes world Map.! n
+                    let box = worldBoxes world Map.! n in
-                        myAttr = boxColor box in
+                    renderCell world locMap n box y x 49
-                    if boxWalls box ! (y,x) then unit myAttr '▓'
+        | x_ <- [x1-1 .. x1+1]
-                    else case Map.lookup (Location n y x) locMap of
-                    Nothing -> unit myAttr '░'
-                    Just n -> renderBox' world locMap box' n (49 `div` boxSize box)
-                        where
-                        box' = worldBoxes world Map.! n
-        | x <- [x1-1 .. x1+1]
         ]
-        | y <- [y1-1 .. y1+1]
+        | y_ <- [y1-1 .. y1+1]
     ]
-    
   where
     border = 20
-    unit a x =
-      vertCat (replicate 49 (string a (replicate (2*49) x)))
     locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
 
     -- name1 is the box the player is standing in
@@ -89,17 +64,6 @@ drawNestedWorld world =
 
     Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)
 
-drawWorld :: World -> Image
-drawWorld world =
-  horizCat $
-  intersperse (char defAttr ' ')
-  [
-    renderBox world locMap box boxName
-    | (boxName, box) <- Map.toList (worldBoxes world)
-  ]
-  where
-    locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
-
 
 stackedLoc :: World -> Location -> Maybe Location
 stackedLoc world = go Set.empty