From 523d951a670d99c7f778084919265b76cf174a66 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Fri, 2 Dec 2022 15:28:05 -0800 Subject: [PATCH] symlinks --- app/Main.hs | 48 ++++++++++++++++++++++++++------------------ app/Model.hs | 52 ++++++++++++++++++++++++++++++------------------ app/Rendering.hs | 19 +++++++++++++----- 3 files changed, 76 insertions(+), 43 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 4da724f..4bad497 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,20 +16,20 @@ world0 = World { [('1', Box { boxColor = withForeColor defAttr green, boxLocation = Location '1' (-1) 0, - boxWalls = makeWalls [ + boxType = Original $ makeWalls [ "▓▓ ▓▓", "▓ ▓", "▓ ▓", "▓ ▓", "▓ ▓ ▓", "▓ ▓", - "▓ ▓ ▓" + "▓ ▓▓▓ ▓" ] }), ('2', Box { boxColor = withForeColor defAttr cyan, boxLocation = Location '1' 1 1, - boxWalls = makeWalls [ + boxType = Original $ makeWalls [ "▓ ▓ ▓ ▓", " ", "▓ ▓", @@ -39,23 +39,28 @@ world0 = World { "▓ ▓ ▓ ▓" ] }), + ('₂', Box { + boxColor = withForeColor defAttr cyan, + boxLocation = Location '1' 2 (-1), + boxType = Link '2' + }), ('3', Box { boxColor = withForeColor defAttr blue, boxLocation = Location '2' 1 1, - boxWalls = makeWalls [ - "▓▓ ▓▓", - "▓ ▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", - "▓ ▓", + boxType = Original $ makeWalls [ + "▓▓▓▓▓▓▓", + "▓ ▓▓▓", + "▓ ▓▓▓", + "▓▓▓ ▓▓▓", + "▓ ▓▓▓", + "▓ ▓▓▓", "▓▓▓ ▓▓▓" ] }), ('4', Box { boxColor = withForeColor defAttr black, boxLocation = Location '3' (-3) 0, - boxWalls = makeWalls [ + boxType = Original $ makeWalls [ "▓▓ ▓▓", "▓ ▓ ▓", "▓ ▓", @@ -68,10 +73,10 @@ world0 = World { ('b', Box { boxColor = withForeColor defAttr red, boxLocation = Location '1' 0 1, - boxWalls = makeWalls [ + boxType = Original $ makeWalls [ "▓▓▓▓▓▓▓", "▓ ▓", - "▓ ▓ ▓ ▓", + "▓ ▓", " ", "▓ ▓▓", "▓ ▓", @@ -81,32 +86,37 @@ world0 = World { ('x', Box { boxColor = withForeColor defAttr yellow, boxLocation = Location '1' 0 (-1), - boxWalls = solid 7 + boxType = Original $ solid 7 }), ('y', Box { boxColor = withForeColor defAttr magenta, boxLocation = Location '1' 0 (-2), - boxWalls = solid 7 + boxType = Original $ solid 7 }), ('i', Box { boxColor = withForeColor defAttr black, boxLocation = Location 'b' 0 (-2), - boxWalls = solid 7 + boxType = Original $ solid 7 }), ('j', Box { boxColor = withForeColor defAttr black, boxLocation = Location 'b' 0 (-1), - boxWalls = solid 7 + boxType = Original $ solid 7 }), ('k', Box { boxColor = withForeColor defAttr black, boxLocation = Location 'b' 0 0, - boxWalls = solid 7 + boxType = Original $ solid 7 }), ('l', Box { boxColor = withForeColor defAttr black, boxLocation = Location 'b' 0 1, - boxWalls = solid 7 + boxType = Original $ solid 7 + }), + ('₁', Box { + boxColor = withForeColor defAttr green, + boxLocation = Location '1' 2 1, + boxType = Link '1' }) ] } diff --git a/app/Model.hs b/app/Model.hs index 495d201..6baadaf 100644 --- a/app/Model.hs +++ b/app/Model.hs @@ -12,11 +12,22 @@ type Coord = (Int, Int) data Box = Box { boxLocation :: Location, - boxWalls :: Array Coord Bool, + boxType :: BoxType, boxColor :: Attr } deriving (Show, Read, Eq) +boxWalls :: World -> Box -> Array Coord Bool +boxWalls world box = + case boxType box of + Original walls -> walls + Link c -> boxWalls world (worldBoxes world Map.! c) + +data BoxType + = Original (Array Coord Bool) + | Link Char + deriving (Show, Read, Eq) + data Location = Location Char Int Int deriving (Read, Show, Ord, Eq) @@ -37,10 +48,10 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows)) mkRange :: Int -> (Int,Int) mkRange n = (- (n-1)`div`2, n`div`2) -boxSize :: Box -> Int -boxSize box = yhi-ylo+1 +boxSize :: World -> Box -> Int +boxSize world box = yhi-ylo+1 where - ((ylo,_),(yhi,_)) = bounds (boxWalls box) + ((ylo,_),(yhi,_)) = bounds (boxWalls world box) solid :: Int -> Array Coord Bool @@ -65,11 +76,11 @@ myLocation :: World -> Location myLocation world = boxLocation (worldBoxes world Map.! worldMe world) -isWall :: Location -> World -> Bool -isWall (Location n y x) world = +isWall :: World -> Location -> Bool +isWall world (Location n y x) = case Map.lookup n (worldBoxes world) of Nothing -> True - Just box -> boxWalls box ! (y,x) + Just box -> boxWalls world box ! (y,x) type Movement = (Int, Int) @@ -82,7 +93,7 @@ moveBlock :: -- moving into a wall, not possible moveBlock world _ loc _ - | isWall loc world = Nothing + | isWall world loc = Nothing -- move introduced a loop, trim off the tail and report success moveBlock _ visited loc _ @@ -97,7 +108,7 @@ moveBlock world visited loc dir = -- moving a box (name,box):_ -> do loc' <- nextLoc world loc dir - guard (not (isWall loc' world)) + guard (not (isWall world loc')) moveBlock' world visited loc loc' dir name box moveBlock' :: @@ -117,25 +128,28 @@ moveBlock' world visited loc loc' dir name box = moveInto = do (n,b) <- boxAt world loc' - let locI = enterLoc n b dir + let locI = enterLoc world n b dir moveBlock' world visited loc locI dir name box -- beware epsilon! moveToEat = do let dir' = invert dir - let locE = enterLoc name box dir' + let locE = enterLoc world 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 = +enterLoc :: World -> Char -> Box -> Movement -> Location +enterLoc world 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 + (-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) + name' = case boxType box of + Link c -> c + Original{} -> name + ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) boxAt :: World -> Location -> Maybe (Char, Box) boxAt world loc = @@ -160,7 +174,7 @@ nextLoc world loc (dy, dx) = go Set.empty loc go _ (Location b y x) | Just box <- Map.lookup b (worldBoxes world) - , inRange (bounds (boxWalls box)) (y+dy, x+dx) + , inRange (bounds (boxWalls world box)) (y+dy, x+dx) = Just (Location b (y+dy) (x+dx)) go visited (Location b _ _) diff --git a/app/Rendering.hs b/app/Rendering.hs index e156419..73b7b4b 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -14,14 +14,23 @@ unit a 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 + if boxWalls world box ! (y,x) then unit (boxColor box) scale wallChar + 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) + (scale `div` boxSize world box) + where + name' = + case boxType box of + Original{} -> name + Link c -> c + wallChar = + case boxType box of + Original{} -> '▓' + Link{} -> '▒' renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Image renderBox world locMap box name scale = @@ -32,7 +41,7 @@ renderBox world locMap box name scale = renderCell world locMap name box y x scale | x <- [xlo .. xhi] ] - | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box) + | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) , y <- [ylo .. yhi] ] @@ -72,7 +81,7 @@ stackedLoc world = go Set.empty go visited loc@(Location b y x) = do box <- Map.lookup b (worldBoxes world) - let bnds@((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box) + let bnds@((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) if inRange bnds (y, x) then Just loc else