pre-exit
This commit is contained in:
Eric Mertens
parent
48af4f917c
commit
4dec7e103d
111
app/Main.hs
111
app/Main.hs
|
|
@ -39,18 +39,45 @@ renderBox world locMap box boxName =
|
|||
[
|
||||
horizCat
|
||||
[
|
||||
if boxWalls box ! (y,x) then char myAttr '▓'
|
||||
if boxWalls box ! (y,x) then unit myAttr '▓'
|
||||
else case Map.lookup (Location boxName y x) locMap of
|
||||
Nothing -> char myAttr '░'
|
||||
Just n -> char (boxColor (worldBoxes world Map.! n)) n
|
||||
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
|
||||
[
|
||||
if not (inRange (bounds (boxWalls box)) (y,x)) then unit defAttr '?' else
|
||||
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
|
||||
| x <- [xlo .. xhi]
|
||||
]
|
||||
|
||||
| let myAttr = boxColor box
|
||||
, y <- [ylo .. yhi]
|
||||
]
|
||||
where
|
||||
unit a x =
|
||||
vertCat (replicate scale (string a (replicate (2*scale) x)))
|
||||
|
||||
|
||||
makeWalls :: [String] -> Array Coord Bool
|
||||
makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
|
||||
where
|
||||
|
|
@ -61,6 +88,29 @@ makeWalls rows = listArray ((ylo,xlo),(yhi,xhi)) (map (' '/=) (concat rows))
|
|||
|
||||
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 $
|
||||
|
|
@ -72,6 +122,8 @@ drawWorld 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 {
|
||||
worldMe = 'b',
|
||||
|
|
@ -80,49 +132,43 @@ world0 = World {
|
|||
boxColor = withForeColor defAttr green,
|
||||
boxLocation = Location '1' (-1) 0,
|
||||
boxWalls = makeWalls [
|
||||
"▓▓▓ ▓▓▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓▓▓ ▓ ▓▓▓"
|
||||
"▓▓ ▓▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓ ▓"
|
||||
]
|
||||
}),
|
||||
('2', Box {
|
||||
boxColor = withForeColor defAttr cyan,
|
||||
boxLocation = Location '1' 1 1,
|
||||
boxWalls = makeWalls [
|
||||
"▓▓▓▓ ▓▓▓▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
" ",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓▓▓▓ ▓▓▓▓"
|
||||
"▓▓▓ ▓▓▓",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
" ",
|
||||
"▓ ▓",
|
||||
"▓ ▓",
|
||||
"▓▓▓ ▓▓▓"
|
||||
]
|
||||
|
||||
}),
|
||||
('b', Box {
|
||||
boxColor = withForeColor defAttr red,
|
||||
boxLocation = Location '1' 0 1,
|
||||
boxWalls = makeWalls [
|
||||
"▓ ▓",
|
||||
" ",
|
||||
"▓ ▓"
|
||||
]
|
||||
boxWalls = solid 7
|
||||
}),
|
||||
('x', Box {
|
||||
boxColor = withForeColor defAttr yellow,
|
||||
boxLocation = Location '1' 0 (-1),
|
||||
boxWalls = makeWalls ["▓"]
|
||||
boxWalls = solid 7
|
||||
}),
|
||||
('y', Box {
|
||||
boxColor = withForeColor defAttr magenta,
|
||||
boxLocation = Location '1' 0 (-2),
|
||||
boxWalls = makeWalls ["▓"]
|
||||
boxWalls = solid 7
|
||||
})
|
||||
|
||||
]
|
||||
|
|
@ -162,7 +208,7 @@ main =
|
|||
|
||||
loop :: Vty -> NonEmpty World -> IO ()
|
||||
loop vty (world :| history) =
|
||||
do update vty (picForImage (drawWorld world))
|
||||
do update vty (picForImage (drawNestedWorld world))
|
||||
ev <- nextEvent vty
|
||||
case ev of
|
||||
EvKey key _modifier ->
|
||||
|
|
@ -204,21 +250,24 @@ moveBlock world visited loc dir =
|
|||
-- 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' = moveBlock world (addVisited loc loc' visited) loc' dir
|
||||
moveTo loc' =
|
||||
do guard (not (isWall loc' world))
|
||||
moveBlock world (addVisited loc loc' visited) loc' dir
|
||||
|
||||
moveInto loc' =
|
||||
do (n,b) <- boxAt world loc'
|
||||
do guard (not (isWall loc' world))
|
||||
(n,b) <- boxAt world loc'
|
||||
let locI = enterLoc n b dir
|
||||
moveBlock world (addVisited loc locI visited) locI dir
|
||||
|
||||
moveToEat loc' =
|
||||
do let dir' = invert dir
|
||||
do guard (not (isWall loc' world))
|
||||
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'
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user