handle blocks having undefined location

This commit is contained in:
Eric Mertens 2022-12-07 13:37:02 -08:00
parent af5305cc24
commit 84f74366bb
9 changed files with 177 additions and 203 deletions

View File

@ -1,10 +1,10 @@
module Main (main) where
import Control.Exception ( bracket )
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Char (toUpper)
import Data.List (intersperse)
import Data.List (intersperse, sort)
import Data.Map (Map)
import Data.Map qualified as Map
import Graphics.Vty
@ -29,7 +29,7 @@ data GameMode
getWorldList :: IO (Map String FilePath)
getWorldList =
do paths <- listDirectory "levels"
do paths <- sort <$> listDirectory "levels"
pure (Map.fromList [(takeBaseName path, "levels" </> path) | path <- paths])
main :: IO ()
@ -57,17 +57,18 @@ loop vty game =
case gameMode game of
MenuMode ->
do worldList <- getWorldList
let (a,b) = Map.splitAt (gameSelect game) worldList
bnds <- displayBounds (outputIface vty)
update vty (picForImage (renderMenu bnds a b))
update vty (picForImage (renderMenu (gameSelect game) worldList bnds))
ev <- nextEvent vty
case ev of
EvKey key _modifier ->
case key of
KEsc -> pure ()
KUp | gameSelect game > 0 -> loop vty game{ gameSelect = gameSelect game - 1 }
KDown | gameSelect game + 1 < Map.size worldList -> loop vty game{ gameSelect = gameSelect game + 1 }
KEnter | Just (path,_) <- Map.minView b ->
KUp | gameSelect game > 0 ->
loop vty game{ gameSelect = gameSelect game - 1 }
KDown | gameSelect game + 1 < Map.size worldList ->
loop vty game{ gameSelect = gameSelect game + 1 }
KEnter | (_, path) <- Map.elemAt (gameSelect game) worldList ->
do world <- parse <$> readFile path
loop vty game{ gameMode = PlayMode (pure world) }
_ -> loop vty game
@ -79,11 +80,12 @@ loop vty game =
ev <- nextEvent vty
case ev of
EvKey key _modifier ->
let doMove m = game{ gameMode = PlayMode (move world m <| worlds) } in
case key of
KUp -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (-1,0)) worlds) }
KDown -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (1,0) ) worlds) }
KLeft -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,-1)) worlds) }
KRight -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,1) ) worlds) }
KUp -> loop vty (doMove (-1, 0))
KDown -> loop vty (doMove ( 1, 0))
KLeft -> loop vty (doMove ( 0,-1))
KRight -> loop vty (doMove ( 0, 1))
KChar 'm' -> loop vty game { gameMode = MenuMode }
KChar 'r' -> loop vty game{ gameMode = PlayMode (pure (NonEmpty.last worlds)) }
KChar 'z'
@ -95,25 +97,20 @@ loop vty game =
_ -> loop vty game
renderMenu :: DisplayRegion -> Map String a -> Map String a -> Image
renderMenu (w,h) before after =
pad ((w - imageWidth menu) `div` 2) 0 0 0 menu
renderMenu :: Int -> Map String a -> DisplayRegion -> Image
renderMenu sel list (w,h)
| hpad >= 0 = pad wpad hpad 0 0 menu
| otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu)
where
hpad = h`div`2 - sel*6
wpad = max 0 (w - imageWidth menu) `div` 2
menu =
case Map.minViewWithKey after of
Nothing -> bigString defAttr "empty menu"
Just ((k,_),after') ->
let len1 = (h-1)`div`2 `div` 6 in
pad 0 (max 0 (6 * (len1 - Map.size before))) 0 0 $
vertCat $
intersperse (char defAttr ' ') $
[ bigString defAttr x
| x <- drop (Map.size before - len1) (Map.keys before)
] ++
[bigString (defAttr `withBackColor` cyan `withForeColor` white) k] ++
[ bigString defAttr x
| x <- drop (Map.size after' - h`div`2) (Map.keys after')
]
vertCat $
intersperse (char defAttr ' ') $
[ bigString (if sel == i then defAttr `withBackColor` cyan `withForeColor` white
else defAttr) k
| (i,k) <- zip [0..] (Map.keys list)
]
bigString :: Attr -> String -> Image
bigString a = vertCat . map (string a) . bigText . map toUpper

View File

@ -12,7 +12,7 @@ import Data.Set (Set)
type Coord = (Int, Int)
data Box = Box {
boxLocation :: Location,
boxLocation :: Maybe Location,
boxType :: BoxType,
boxColor :: Attr,
boxBoring :: Bool
@ -50,9 +50,9 @@ data World = World {
winCondition :: World -> Bool
winCondition world =
Set.isSubsetOf (worldButtons world) coverage &&
worldHome world == boxLocation (worldBoxes world Map.! worldMe world)
Just (worldHome world) == boxLocation (worldBoxes world Map.! worldMe world)
where
coverage = Set.fromList $ map boxLocation $ Map.elems (worldBoxes world)
coverage = Set.fromList $ mapMaybe boxLocation $ Map.elems (worldBoxes world)
boxSize :: World -> Box -> Int
@ -62,13 +62,16 @@ boxSize world box = yhi-ylo+1
move :: World -> (Int,Int) -> World
move world dir =
case moveBlock world Map.empty (myLocation world) dir 0 of
case myLocation world of
Nothing -> world
Just changes ->
let f box = box { boxLocation = Map.findWithDefault (boxLocation box) (boxLocation box) changes } in
world { worldBoxes = fmap f (worldBoxes world)}
Just loc ->
case moveBlock world Map.empty loc dir 0 of
Nothing -> world
Just changes ->
let f box change = box { boxLocation = change } in
world { worldBoxes = Map.mergeWithKey (\_ a b -> Just (f a b)) id (const Map.empty) (worldBoxes world) changes}
myLocation :: World -> Location
myLocation :: World -> Maybe Location
myLocation world =
boxLocation (worldBoxes world Map.! worldMe world)
@ -82,11 +85,11 @@ type Movement = (Int, Int)
moveBlock ::
World ->
Map Location (Int, Location) ->
Map Location (Int, Char, Maybe Location) ->
Location ->
Movement ->
Rational {- ^ offset -} ->
Maybe (Map Location Location)
Maybe (Map Char (Maybe Location))
-- moving into a wall, not possible
moveBlock world _ loc _ _
@ -94,54 +97,58 @@ moveBlock world _ loc _ _
-- move introduced a loop, trim off the tail and report success
moveBlock _ visited loc _ _
| Just (n,_) <- Map.lookup loc visited
= Just (fmap snd (Map.filter (\(a,_)->a >= n) visited))
| Just (n,_,_) <- Map.lookup loc visited
= Just (Map.fromList [(c,l) | (a,c,l) <- Map.elems visited, a >= n])
moveBlock world visited loc dir offset =
case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == loc] of
case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of
-- moving an empty space, so we're done
[] -> Just (fmap snd visited)
[] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited])
-- moving a box
(name,box):_ ->
do (loc', offset') <- nextLoc world dir loc offset
--traceM (show "Next loc " ++ show loc' ++ " offset " ++ show offset')
guard (not (isWall world loc'))
moveBlock' world visited loc loc' dir name box Set.empty offset'
case nextLoc world dir loc offset of
Nothing -> Just (Map.fromList ((name, Nothing) : [(c,l) | (_,c,l) <- Map.elems visited]))
Just (loc', offset') ->
do guard (not (isWall world loc'))
moveBlock' world visited loc loc' dir name box Set.empty offset'
moveBlock' ::
World ->
Map Location (Int, Location) ->
Location ->
Location ->
Movement ->
Char ->
World ->
Map Location (Int, Char, Maybe Location) ->
Location ->
Location ->
Movement ->
Char ->
Box ->
Set Location ->
Rational {- ^ offset -} ->
Maybe (Map Location Location)
Maybe (Map Char (Maybe Location))
moveBlock' world visited loc loc' dir name box enters offset =
msum [moveTo, moveInto, moveToEat]
where
moveTo =
do moveBlock world (addVisited loc loc' visited) loc' dir 0
do moveBlock world (addVisited name loc (Just loc') visited) loc' dir 0
moveInto =
do (n,b) <- boxAt world loc'
(locI, offset') <- enterLoc world n b dir offset
if Set.member locI enters then do
epsilon <- findEpsilon world (locName loc')
let eBox = worldBoxes world Map.! epsilon
(locI, offset') <- enterLoc world epsilon eBox dir offset
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
if Set.member locI enters then
moveEpsilon
else
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
moveEpsilon =
do epsilon <- findEpsilon world (locName loc')
let eBox = worldBoxes world Map.! epsilon
(locI, offset') <- enterLoc world epsilon eBox dir offset
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset'
moveToEat =
do let dir' = invert dir
(locE, _) <- enterLoc world name box dir' 0
(name', box') <- boxAt world loc'
moveBlock' world (addVisited loc loc' visited) loc' locE dir' name' box' Set.empty 0
(name', box') <- boxAt world loc'
moveBlock' world (addVisited name loc (Just loc') visited) loc' locE dir' name' box' Set.empty 0
enterLoc :: World -> Char -> Box -> Movement -> Rational -> Maybe (Location, Rational)
enterLoc world name box dir@(dy,dx) offset =
@ -156,7 +163,7 @@ enterLoc world name box dir@(dy,dx) offset =
(Location name' y x,
fromIntegral(boxSize world box) * offset
- fromIntegral ((abs dy *x + abs dx*y)))
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
case dir of
@ -168,7 +175,7 @@ enterLoc world name box dir@(dy,dx) offset =
boxAt :: World -> Location -> Maybe (Char, Box)
boxAt world loc =
listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == loc]
listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == Just loc]
invert :: Movement -> Movement
invert (dy,dx) = (-dy, -dx)
@ -177,11 +184,12 @@ midpoint :: Int -> Int -> Rational -> Int
midpoint lo hi offset = round (offset * fromIntegral (hi-lo+1))
addVisited ::
Char {- ^ name -} ->
Location {- ^ start -} ->
Location {- ^ end -} ->
Map Location (Int, Location) ->
Map Location (Int, Location)
addVisited k v m = Map.insert k (Map.size m, v) m
Maybe Location {- ^ end -} ->
Map Location (Int, Char, Maybe Location) ->
Map Location (Int, Char, Maybe Location)
addVisited name k v m = Map.insert k (Map.size m, name, v) m
nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rational)
nextLoc world (dy, dx) = go Set.empty
@ -191,11 +199,12 @@ nextLoc world (dy, dx) = go Set.empty
| Just box <- Map.lookup b (worldBoxes world)
, inRange (bounds (boxWalls world box)) (y+dy, x+dx)
= Just (Location b (y+dy) (x+dx), offset)
go visited (Location b y x) offset
| Just box <- Map.lookup b (worldBoxes world)
, Set.notMember b visited
= go (Set.insert b visited) (boxLocation box)
, Just boxLoc <- boxLocation box
= go (Set.insert b visited) boxLoc
$ (offset + fromIntegral (abs dy*x+abs dx*y))
/ fromIntegral (boxSize world box)
@ -208,9 +217,10 @@ nextLoc world (dy, dx) = go Set.empty
findInfinity :: World -> Char -> Maybe Char
findInfinity world b =
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world), Infinity i <- [boxType box], i == b]
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
, Infinity i <- [boxType box], i == b]
findEpsilon :: World -> Char -> Maybe Char
findEpsilon world b =
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world), Epsilon i _ <- [boxType box], i == b]
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
, Epsilon i _ <- [boxType box], i == b]

View File

@ -18,14 +18,14 @@ parse str =
do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
World
(Map.fromList [
(n, b { boxLocation = head (m Map.! n)})
(n, b { boxLocation = fmap head (Map.lookup n m)})
| (n,b,_) <- bs
])
p
(Set.fromList (Map.findWithDefault [] '-' m))
(head (m Map.! '='))
h w
parseHeader :: ReadP (Char,Int,Int)
parseHeader =
do "player" <- token
@ -61,7 +61,7 @@ parseBlock =
_ <- char '\n'
xs1 <- parseWalls
let locs = findLocs name xs1
let b = Box undefined (Original (walls xs1)) color boring
let b = Box Nothing (Original (walls xs1)) color boring
pure (name, b, locs)
"link" ->
do [name] <- token

View File

@ -1,6 +1,7 @@
module Rendering where
import Data.Array
import Data.Maybe
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set qualified as Set
@ -46,7 +47,7 @@ renderCell world locMap name box y x h w =
Just n ->
let box' = worldBoxes world Map.! n
in if h < boxSize world box'
then unit (boxColor box') h w n
then unit (boxColor box') h w n
else renderBox world locMap box' n
h w
Nothing
@ -78,13 +79,13 @@ contentName world name box =
Epsilon{} -> name
renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image
renderBox world locMap box name h w =
renderBox world locMap box name boxh boxw =
vertCat [
horizCat [
renderCell world locMap name box y x h w
| (x,w) <- zip [xlo .. xhi] (divisions boxWidth w)
renderCell world locMap name box y x cellh cellw
| (x,cellw) <- zip [xlo .. xhi] (divisions boxWidth boxw)
]
| (y,h) <- zip [ylo .. yhi] (divisions boxHeight h)
| (y,cellh) <- zip [ylo .. yhi] (divisions boxHeight boxh)
]
where
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
@ -107,7 +108,7 @@ render flat world = picForLayers $
(if flat then renderFlat locMap world else []) ++
[drawNestedWorld locMap world]
where
locMap = Map.fromList [(boxLocation loc, n) | (n, loc) <- Map.toList (worldBoxes world)]
locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world), loc <- maybeToList (boxLocation box)]
renderFlat :: Map Location Char -> World -> [Image]
renderFlat locMap world =
@ -137,22 +138,29 @@ drawNestedWorld locMap world =
horizCat $
intersperse (char defAttr ' ')
[
case stackedLoc world locMap (Location name1 y_ x_) of
Nothing -> unit (withForeColor defAttr black) h w '?'
Just (Location n y x) ->
let box = worldBoxes world Map.! n in
renderCell world locMap n box y x h w
| x_ <- [x1-1 .. x1+1]
case myLocation world of
Nothing
| dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! worldMe world) (worldMe world) h w
| otherwise -> infinityImage
Just (Location name0 _ _) ->
case boxLocation (worldBoxes world Map.! name0) of
Nothing
| dx==0 && dy==0 -> renderBox world locMap (worldBoxes world Map.! name0) name0 h w
| otherwise -> infinityImage
Just (Location name1 y1 x1) ->
case stackedLoc world locMap (Location name1 (y1+dy) (x1+dx)) of
Nothing -> infinityImage
Just (Location n y x) ->
let box = worldBoxes world Map.! n in
renderCell world locMap n box y x h w
| dx <- [-1 .. 1]
]
| y_ <- [y1-1 .. y1+1]
| dy <- [-1 .. 1]
]
where
infinityImage = unit (withForeColor defAttr black) h w '?'
h = worldHeight world
w = worldWidth world
-- name1 is the box the player is standing in
Location name0 _ _ = myLocation world
Location name1 y1 x1 = boxLocation (worldBoxes world Map.! name0)
stackedLoc :: World -> Map Location Char -> Location -> Maybe Location
stackedLoc world locMap = go Set.empty
@ -167,12 +175,11 @@ stackedLoc world locMap = go Set.empty
let bnds@((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
if inRange bnds (y, x)
then Just loc
else
let dx = overflow (xlo,xhi) x
else
do let dx = overflow (xlo,xhi) x
dy = overflow (ylo,yhi) y
Location parent py px = boxLocation box
in fixup world locMap dy dx y x <$> go (Set.insert loc visited) (Location parent (py+dy) (px+dx))
Location parent py px <- boxLocation box
fixup world locMap dy dx y x <$> go (Set.insert loc visited) (Location parent (py+dy) (px+dx))
overflow :: (Int, Int) -> Int -> Int
overflow (lo,hi) x
@ -208,7 +215,7 @@ divisions divs size =
(fromIntegral i + 1 / 2)
/ fromIntegral size
* fromIntegral divs
- 1/2
)
- 1/2 :: Rational
) :: Int
| i <- [0 ..size-1]
]

View File

@ -1,4 +1,4 @@
player p
player p height 98 width 196
block t white boring
▓▓▓▓▓
▓▓▓▓▓
@ -6,15 +6,13 @@ block t white boring
▓▓▓▓▓
▓▓▓▓▓
block w white interesting
▓▓▓▓▓▓▓▓▓
▓▓ ▓▓
▓▓ g G ▓▓
▓▓ ▓▓
▓▓ = p ▓▓
▓▓ ▓▓
▓▓▓▓▓▓ ▓▓
▓▓▓ε▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓ ▓
▓ g G ▓
▓ ▓
▓ = p ▓
▓ ▓
▓▓▓▓▓ ▓
▓▓ε▓▓▓▓
link G g green
link H g green
block g green interesting

View File

@ -1,63 +1,35 @@
player p
block t black boring
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓t▓▓▓w▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓ε▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block w white interesting
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓ p ▓▓
▓▓ G H ▓▓
▓▓ = ▓▓
▓▓ -▓▓
▓▓▓▓g▓=▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓
▓ p ▓
▓ G H ▓
▓ ▓
▓ -▓
▓▓▓g▓=▓
▓▓▓▓▓▓▓
link G g green
link H g green
block g green interesting
▓▓
▓▓
epsilon ε g green
b
b
block p magenta boring
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓ ▓▓▓ ▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓
▓ ▓ ▓
▓▓▓▓▓
▓▓▓▓▓
▓▓▓▓▓
block b blue interesting
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓
▓▓▓
▓▓▓
▓▓▓ ▓▓▓
▓▓▓ ▓▓▓
▓▓▓ ▓▓▓
▓▓▓
▓ ▓

View File

@ -10,15 +10,9 @@ block t white boring
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block a white interesting
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓p ▓▓▓
▓▓▓ ∞▓▓▓
▓▓▓ P▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
p
P▓
link P p magenta
infinity ∞ p magenta
block p magenta interesting
@ -32,32 +26,10 @@ block p magenta interesting
▓ c
block c green interesting
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓
= ▓▓▓
▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓
=▓
▓▓▓
block 1 blue boring
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block 2 blue boring
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓

17
levels/player19.txt Normal file
View File

@ -0,0 +1,17 @@
player p
block p magenta interesting
p ▓
1 2
c
block c green interesting
▓▓▓
=▓
▓▓▓
block 1 blue boring
block 2 blue boring

View File

@ -17,14 +17,15 @@ block g green interesting
block y yellow interesting
▓ ▓
▓ ▓
▓ ▓
▓ ▓
block p magenta boring
▓▓▓▓▓
▓ ▓ ▓
▓▓▓▓▓
▓▓▓▓▓
▓▓▓▓▓