diff --git a/app/Model.hs b/app/Model.hs index 3aa0fea..495d201 100644 --- a/app/Model.hs +++ b/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) diff --git a/app/Rendering.hs b/app/Rendering.hs index e4b78c3..e156419 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -5,52 +5,36 @@ 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 = +unit :: Attr -> Int -> Char -> Image +unit a scale 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 [ - 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 + renderCell world locMap name box y x scale | 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 @@ -62,26 +46,17 @@ drawNestedWorld world = cropRight (2*(2*49 + border)) $ vertCat [ horizCat [ - case stackedLoc world (Location name1 y x) of - Nothing -> unit (withForeColor defAttr black) '?' + case stackedLoc world (Location name1 y_ x_) of + Nothing -> unit (withForeColor defAttr black) 49 '?' 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] + let box = worldBoxes world Map.! n in + renderCell world locMap n box y x 49 + | 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