symlinks
This commit is contained in:
Eric Mertens
parent
77a31583f4
commit
523d951a67
46
app/Main.hs
46
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'
|
||||
})
|
||||
]
|
||||
}
|
||||
|
|
|
|||
52
app/Model.hs
52
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 _ _)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user