glguy/parabox
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

symlinks

Browse Source
This commit is contained in:
Eric Mertens 2022-12-02 15:28:05 -08:00
parent 77a31583f4
commit 523d951a67
3 changed files with 76 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
app/Main.hs
View File

@ -16,20 +16,20 @@ world0 = World {
[('1', Box { [('1', Box {
boxColor = withForeColor defAttr green, boxColor = withForeColor defAttr green,
boxLocation = Location '1' (-1) 0, boxLocation = Location '1' (-1) 0,
boxWalls = makeWalls [ boxType = Original $ makeWalls [
"▓▓ ▓▓", "▓▓ ▓▓",
"▓ ▓", "▓ ▓",
"▓ ▓", "▓ ▓",
"▓ ▓", "▓ ▓",
"▓ ▓ ▓", "▓ ▓ ▓",
"▓ ▓", "▓ ▓",
"▓ ▓ ▓" "▓ ▓▓▓ ▓"
] ]
}), }),
('2', Box { ('2', Box {
boxColor = withForeColor defAttr cyan, boxColor = withForeColor defAttr cyan,
boxLocation = Location '1' 1 1, 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 { ('3', Box {
boxColor = withForeColor defAttr blue, boxColor = withForeColor defAttr blue,
boxLocation = Location '2' 1 1, boxLocation = Location '2' 1 1,
boxWalls = makeWalls [ boxType = Original $ makeWalls [
"▓▓▓▓▓▓▓",
"▓ ▓▓▓",
"▓ ▓▓▓",
"▓▓▓ ▓▓▓",
"▓ ▓▓▓",
"▓ ▓▓▓", "▓ ▓▓▓",
"▓ ▓ ▓",
"▓ ▓",
"▓ ▓",
"▓ ▓",
"▓ ▓",
"▓▓▓ ▓▓▓" "▓▓▓ ▓▓▓"
] ]
}), }),
('4', Box { ('4', Box {
boxColor = withForeColor defAttr black, boxColor = withForeColor defAttr black,
boxLocation = Location '3' (-3) 0, boxLocation = Location '3' (-3) 0,
boxWalls = makeWalls [ boxType = Original $ makeWalls [
"▓▓ ▓▓", "▓▓ ▓▓",
"▓ ▓ ▓", "▓ ▓ ▓",
"▓ ▓", "▓ ▓",
@ -68,10 +73,10 @@ world0 = World {
('b', Box { ('b', Box {
boxColor = withForeColor defAttr red, boxColor = withForeColor defAttr red,
boxLocation = Location '1' 0 1, boxLocation = Location '1' 0 1,
boxWalls = makeWalls [ boxType = Original $ makeWalls [
"▓▓▓▓▓▓▓", "▓▓▓▓▓▓▓",
"▓ ▓", "▓ ▓",
"▓ ▓ ▓ ▓", "▓ ▓",
" ", " ",
"▓ ▓▓", "▓ ▓▓",
"▓ ▓", "▓ ▓",
@ -81,32 +86,37 @@ world0 = World {
('x', Box { ('x', Box {
boxColor = withForeColor defAttr yellow, boxColor = withForeColor defAttr yellow,
boxLocation = Location '1' 0 (-1), boxLocation = Location '1' 0 (-1),
boxWalls = solid 7 boxType = Original $ solid 7
}), }),
('y', Box { ('y', Box {
boxColor = withForeColor defAttr magenta, boxColor = withForeColor defAttr magenta,
boxLocation = Location '1' 0 (-2), boxLocation = Location '1' 0 (-2),
boxWalls = solid 7 boxType = Original $ solid 7
}), }),
('i', Box { ('i', Box {
boxColor = withForeColor defAttr black, boxColor = withForeColor defAttr black,
boxLocation = Location 'b' 0 (-2), boxLocation = Location 'b' 0 (-2),
boxWalls = solid 7 boxType = Original $ solid 7
}), }),
('j', Box { ('j', Box {
boxColor = withForeColor defAttr black, boxColor = withForeColor defAttr black,
boxLocation = Location 'b' 0 (-1), boxLocation = Location 'b' 0 (-1),
boxWalls = solid 7 boxType = Original $ solid 7
}), }),
('k', Box { ('k', Box {
boxColor = withForeColor defAttr black, boxColor = withForeColor defAttr black,
boxLocation = Location 'b' 0 0, boxLocation = Location 'b' 0 0,
boxWalls = solid 7 boxType = Original $ solid 7
}), }),
('l', Box { ('l', Box {
boxColor = withForeColor defAttr black, boxColor = withForeColor defAttr black,
boxLocation = Location 'b' 0 1, 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'
}) })
] ]
} }

52
app/Model.hs
View File

@ -12,11 +12,22 @@ type Coord = (Int, Int)
data Box = Box { data Box = Box {
boxLocation :: Location, boxLocation :: Location,
boxWalls :: Array Coord Bool, boxType :: BoxType,
boxColor :: Attr boxColor :: Attr
} }
deriving (Show, Read, Eq) 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 data Location = Location Char Int Int
deriving (Read, Show, Ord, Eq) deriving (Read, Show, Ord, Eq)
@ -37,10 +48,10 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
mkRange :: Int -> (Int,Int) mkRange :: Int -> (Int,Int)
mkRange n = (- (n-1)`div`2, n`div`2) mkRange n = (- (n-1)`div`2, n`div`2)
boxSize :: Box -> Int boxSize :: World -> Box -> Int
boxSize box = yhi-ylo+1 boxSize world box = yhi-ylo+1
where where
((ylo,_),(yhi,_)) = bounds (boxWalls box) ((ylo,_),(yhi,_)) = bounds (boxWalls world box)
solid :: Int -> Array Coord Bool solid :: Int -> Array Coord Bool
@ -65,11 +76,11 @@ myLocation :: World -> Location
myLocation world = myLocation world =
boxLocation (worldBoxes world Map.! worldMe world) boxLocation (worldBoxes world Map.! worldMe world)
isWall :: Location -> World -> Bool isWall :: World -> Location -> Bool
isWall (Location n y x) world = isWall world (Location n y x) =
case Map.lookup n (worldBoxes world) of case Map.lookup n (worldBoxes world) of
Nothing -> True Nothing -> True
Just box -> boxWalls box ! (y,x) Just box -> boxWalls world box ! (y,x)
type Movement = (Int, Int) type Movement = (Int, Int)
@ -82,7 +93,7 @@ moveBlock ::
-- moving into a wall, not possible -- moving into a wall, not possible
moveBlock world _ loc _ moveBlock world _ loc _
| isWall loc world = Nothing | isWall world loc = Nothing
-- move introduced a loop, trim off the tail and report success -- move introduced a loop, trim off the tail and report success
moveBlock _ visited loc _ moveBlock _ visited loc _
@ -97,7 +108,7 @@ moveBlock world visited loc dir =
-- moving a box -- moving a box
(name,box):_ -> (name,box):_ ->
do loc' <- nextLoc world loc dir 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' world visited loc loc' dir name box
moveBlock' :: moveBlock' ::
@ -117,25 +128,28 @@ moveBlock' world visited loc loc' dir name box =
moveInto = moveInto =
do (n,b) <- boxAt world loc' 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! moveBlock' world visited loc locI dir name box -- beware epsilon!
moveToEat = moveToEat =
do let dir' = invert dir do let dir' = invert dir
let locE = enterLoc name box dir' let locE = enterLoc world name box dir'
(name', box') <- boxAt world loc' (name', box') <- boxAt world loc'
moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box' moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box'
enterLoc :: Char -> Box -> Movement -> Location enterLoc :: World -> Char -> Box -> Movement -> Location
enterLoc name box dir = enterLoc world name box dir =
case dir of case dir of
(-1, 0) -> Location name yhi (midpoint xlo xhi) (-1, 0) -> Location name' yhi (midpoint xlo xhi)
( 1, 0) -> Location name ylo (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) xhi
( 0, 1) -> Location name (midpoint ylo yhi) xlo ( 0, 1) -> Location name' (midpoint ylo yhi) xlo
_ -> error "enterLoc: bad direction" _ -> error "enterLoc: bad direction"
where 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 -> Location -> Maybe (Char, Box)
boxAt world loc = boxAt world loc =
@ -160,7 +174,7 @@ nextLoc world loc (dy, dx) = go Set.empty loc
go _ (Location b y x) go _ (Location b y x)
| Just box <- Map.lookup b (worldBoxes world) | 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)) = Just (Location b (y+dy) (x+dx))
go visited (Location b _ _) go visited (Location b _ _)

19
app/Rendering.hs
View File

@ -14,14 +14,23 @@ unit a scale x =
renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Image
renderCell world locMap name box y x scale = renderCell world locMap name box y x scale =
if boxWalls box ! (y,x) then unit (boxColor box) scale '▓' if boxWalls world box ! (y,x) then unit (boxColor box) scale wallChar
else case Map.lookup (Location name y x) locMap of else case Map.lookup (Location name' y x) locMap of
Nothing -> unit (boxColor box) scale '░' Nothing -> unit (boxColor box) scale '░'
Just n -> Just n ->
if scale == 1 if scale == 1
then unit (boxColor (worldBoxes world Map.! n)) scale n then unit (boxColor (worldBoxes world Map.! n)) scale n
else renderBox world locMap (worldBoxes world Map.! n) 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 -> Map Location Char -> Box -> Char -> Int -> Image
renderBox world locMap box name scale = renderBox world locMap box name scale =
@ -32,7 +41,7 @@ renderBox world locMap box name scale =
renderCell world locMap name box y x scale renderCell world locMap name box y x scale
| x <- [xlo .. xhi] | x <- [xlo .. xhi]
] ]
| let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls box) | let ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
, y <- [ylo .. yhi] , y <- [ylo .. yhi]
] ]
@ -72,7 +81,7 @@ stackedLoc world = go Set.empty
go visited loc@(Location b y x) = go visited loc@(Location b y x) =
do box <- Map.lookup b (worldBoxes world) 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) if inRange bnds (y, x)
then Just loc then Just loc
else else