proper rendered borders

app/Main.hs

@@ -1,130 +1,13 @@
-{-# Language ImportQualifiedPost, BlockArguments, LambdaCase #-}
 module Main where
 
-import Data.Array
-import Data.Map (Map)
 import Data.Map qualified as Map
 import Graphics.Vty
 import Control.Exception
-import Data.List (intersperse)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.NonEmpty qualified as NonEmpty
-import Debug.Trace
-import Control.Monad
-import Data.Maybe
-import Data.Set (Set)
-import Data.Set qualified as Set
 
-type Coord = (Int, Int)
+import Model
-
+import Rendering
-data Box = Box {
-  boxLocation :: Location,
-  boxWalls    :: Array Coord Bool,
-  boxColor    :: Attr
-}
-   deriving (Show, Read, Eq)
-
-data Location = Location Char Int Int
-  deriving (Read, Show, Ord, Eq)
-
-data World = World {
-  worldBoxes :: Map Char Box,
-  worldMe :: Char
-}
-  deriving (Show, Read, Eq)
-
-renderBox :: World -> Map Location Char -> Box -> Char -> Image
-renderBox world locMap box boxName =
-  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,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
-    [
-      drawAt boxName box y x | x <- [xlo .. xhi]
-    ]
-    | y <- [ylo .. yhi]
-  ]
-  where
-    unit a x =
-      vertCat (replicate scale (string a (replicate (2*scale) x)))
-    drawAt boxName box y x
-      | let goodCoord = inRange (bounds (boxWalls box))
-      , not (goodCoord (y,x))
-      = unit defAttr '?'
-      | otherwise
-      , let myAttr = boxColor box =
-        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
-
-makeWalls :: [String] -> Array Coord Bool
-makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
-  where
-    h = length rows
-    w = length (head rows)
-    (xlo,xhi) = mkRange w
-    (ylo,yhi) = mkRange h
-
-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 $
-  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)]
-
-solid n = makeWalls (replicate n (replicate n 'x'))
 
 world0 :: World
 world0 = World {
@@ -201,31 +84,6 @@ world0 = World {
     ]
   }
 
--- Move an object
--- 1. remove it from the world
--- 2. compute where it would move to
--- 3. a. that spot is empty
---    b. try to move that object forward
---    c. try to move that object backward into me
-
-move :: World -> (Int,Int) -> World
-move world dir =
-  case moveBlock world Map.empty (myLocation world) dir of
-    Nothing -> world
-    Just changes ->
-      let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in
-      world { worldBoxes = fmap f (worldBoxes world)}
-
-myLocation :: World -> Location
-myLocation world =
-  boxLocation (worldBoxes world Map.! worldMe world)
-
-isWall :: Location -> World -> Bool
-isWall (Location n y x) world =
-  case Map.lookup n (worldBoxes world) of
-    Nothing -> True
-    Just box -> boxWalls box ! (y,x)
-
 main :: IO ()
 main =
   bracket (mkVty =<< userConfig) shutdown \vty ->
@@ -250,86 +108,3 @@ loop vty (world :| history) =
           KEsc -> pure ()
           _ -> loop vty (world :| history)
       _ -> loop vty (world :| history)
-
-type Movement = (Int, Int)
-
-moveBlock ::
-  World ->
-  Map Location (Int, Location) ->
-  Location ->
-  Movement ->
-  Maybe (Map Location Location)
-
--- moving into a wall, not possible
-moveBlock world visited loc _
-  | isWall loc world = Nothing
-
--- move introduced a loop, trim off the tail and report success
-moveBlock world visited loc _
-  | Just (n,_) <- Map.lookup loc visited
-  = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))
-
-moveBlock world visited loc dir =
-  case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of
-    -- moving an empty space, so we're done
-    [] -> Just (fmap snd visited)
-
-    -- 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' =
-         do moveBlock world (addVisited loc loc' visited) loc' dir
-
-        moveInto loc' =
-         do (n,b) <- boxAt world loc'
-            let locI = enterLoc n b dir
-            moveBlock' world visited loc locI dir name box -- beware epsilon!
-        
-        moveToEat loc' =
-         do 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' 
-
-enterLoc :: Char -> Box -> Movement -> Location
-enterLoc name box dir =
-  case dir of
-    (-1, 0) -> Location name yhi (midpoint xlo xhi)
-    ( 1, 0) -> Location name ylo (midpoint xlo xhi)
-    ( 0,-1) -> Location name (midpoint ylo yhi) xhi
-    ( 0, 1) -> Location name (midpoint ylo yhi) xlo
-    _ -> error "enterLoc: bad direction"
-  where
-    ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
-
-boxAt :: World -> Location -> Maybe (Char, Box)
-boxAt world loc =
-  listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]
-
-invert (dy,dx) = (-dy, -dx)
-
-midpoint lo hi = (hi+lo)`div`2
-
-addVisited k v m = Map.insert k (Map.size m, v) m
-
-nextLoc world loc (dy, dx) = go Set.empty loc
-  where
-    
-  go visited (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)
-    | Just box <- Map.lookup b (worldBoxes world)
-    , Set.notMember b visited
-    = go (Set.insert b visited) (boxLocation box)
-
-  go _ _ = Nothing
-

app/Model.hs

@@ -0,0 +1,153 @@
+module Model where
+
+import Data.Array
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Graphics.Vty
+import Control.Monad
+import Data.Maybe
+import Data.Set qualified as Set
+
+type Coord = (Int, Int)
+
+data Box = Box {
+  boxLocation :: Location,
+  boxWalls    :: Array Coord Bool,
+  boxColor    :: Attr
+}
+   deriving (Show, Read, Eq)
+
+data Location = Location Char Int Int
+  deriving (Read, Show, Ord, Eq)
+
+data World = World {
+  worldBoxes :: Map Char Box,
+  worldMe :: Char
+}
+  deriving (Show, Read, Eq)
+
+makeWalls :: [String] -> Array Coord Bool
+makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
+  where
+    h = length rows
+    w = length (head rows)
+    (xlo,xhi) = mkRange w
+    (ylo,yhi) = mkRange h
+
+mkRange n = (- (n-1)`div`2, n`div`2)
+
+boxSize :: Box -> Int
+boxSize box = yhi-ylo+1
+  where
+    ((ylo,_),(yhi,_)) = bounds (boxWalls box)
+
+
+solid n = makeWalls (replicate n (replicate n 'x'))
+
+-- Move an object
+-- 1. remove it from the world
+-- 2. compute where it would move to
+-- 3. a. that spot is empty
+--    b. try to move that object forward
+--    c. try to move that object backward into me
+
+move :: World -> (Int,Int) -> World
+move world dir =
+  case moveBlock world Map.empty (myLocation world) dir of
+    Nothing -> world
+    Just changes ->
+      let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in
+      world { worldBoxes = fmap f (worldBoxes world)}
+
+myLocation :: World -> Location
+myLocation world =
+  boxLocation (worldBoxes world Map.! worldMe world)
+
+isWall :: Location -> World -> Bool
+isWall (Location n y x) world =
+  case Map.lookup n (worldBoxes world) of
+    Nothing -> True
+    Just box -> boxWalls box ! (y,x)
+
+type Movement = (Int, Int)
+
+moveBlock ::
+  World ->
+  Map Location (Int, Location) ->
+  Location ->
+  Movement ->
+  Maybe (Map Location Location)
+
+-- moving into a wall, not possible
+moveBlock world visited loc _
+  | isWall loc world = Nothing
+
+-- move introduced a loop, trim off the tail and report success
+moveBlock world visited loc _
+  | Just (n,_) <- Map.lookup loc visited
+  = Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))
+
+moveBlock world visited loc dir =
+  case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of
+    -- moving an empty space, so we're done
+    [] -> Just (fmap snd visited)
+
+    -- 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' =
+         do moveBlock world (addVisited loc loc' visited) loc' dir
+
+        moveInto loc' =
+         do (n,b) <- boxAt world loc'
+            let locI = enterLoc n b dir
+            moveBlock' world visited loc locI dir name box -- beware epsilon!
+        
+        moveToEat loc' =
+         do 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' 
+
+enterLoc :: Char -> Box -> Movement -> Location
+enterLoc name box dir =
+  case dir of
+    (-1, 0) -> Location name yhi (midpoint xlo xhi)
+    ( 1, 0) -> Location name ylo (midpoint xlo xhi)
+    ( 0,-1) -> Location name (midpoint ylo yhi) xhi
+    ( 0, 1) -> Location name (midpoint ylo yhi) xlo
+    _ -> error "enterLoc: bad direction"
+  where
+    ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
+
+boxAt :: World -> Location -> Maybe (Char, Box)
+boxAt world loc =
+  listToMaybe  [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]
+
+invert (dy,dx) = (-dy, -dx)
+
+midpoint lo hi = (hi+lo)`div`2
+
+addVisited k v m = Map.insert k (Map.size m, v) m
+
+nextLoc world loc (dy, dx) = go Set.empty loc
+  where
+    
+  go visited (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)
+    | Just box <- Map.lookup b (worldBoxes world)
+    , Set.notMember b visited
+    = go (Set.insert b visited) (boxLocation box)
+
+  go _ _ = Nothing
+

app/Rendering.hs

@@ -0,0 +1,125 @@
+module Rendering where
+
+import Data.Array
+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
+renderBox world locMap box boxName =
+  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)))
+        
+
+drawNestedWorld :: World -> Image
+drawNestedWorld world =
+    -- (3*49) + 49 + (3*49)
+    cropTop   (49 + 2*border) $
+    cropLeft  (2*(49 + 2*border)) $
+    cropBottom (2*49 + border) $
+    cropRight  (2*(2*49 + border)) $
+    vertCat [
+        horizCat [
+            case stackedLoc world (Location name1 y x) of
+                Nothing -> unit (withForeColor defAttr black) '?'
+                Just (Location n y x) ->
+                    let box = worldBoxes world Map.! n
+                        myAttr = boxColor box in
+                    if boxWalls box ! (y,x) then unit myAttr '▓'
+                    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]
+    ]
+    
+  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
+    Location name0 _ _ = boxLocation (worldBoxes world Map.! worldMe 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
+  where
+  go visited loc | Set.member loc visited = Nothing
+
+  go visited loc@(Location b y x) =
+   do box <- Map.lookup b (worldBoxes world)
+      let bnds@((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box)
+      if inRange bnds (y, x)
+        then Just loc
+        else 
+            let dx = overflow (xlo,xhi) x
+                dy = overflow (ylo,yhi) y
+                Location parent py px = boxLocation box
+            in go (Set.insert loc visited) (Location parent (py+dy) (px+dx))
+
+
+overflow :: (Int, Int) -> Int -> Int
+overflow (lo,hi) x
+  | x < lo = x - lo
+  | x > hi = x - hi
+  | otherwise = 0

parabox.cabal

@@ -19,8 +19,10 @@ common warnings
 executable parabox
     import:           warnings
     main-is:          Main.hs
+    other-modules:    Rendering, Model
     -- other-modules:
-    -- other-extensions:
+    default-extensions: ImportQualifiedPost, BlockArguments, LambdaCase
+
     ghc-options:      -threaded
     build-depends:    base ^>=4.17.0.0, array, containers, vty
     hs-source-dirs:   app