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

cleaner model

Browse Source
This commit is contained in:
Eric Mertens 2022-12-08 09:34:27 -08:00
parent a67bbea3cb
commit 2dbf578d33
4 changed files with 103 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
app/Model.hs
View File

@ -1,13 +1,14 @@
module Model where module Model where
import Data.Array import Data.Array.Unboxed
import Data.Map (Map) import Data.Map (Map)
import Data.Map qualified as Map import Data.Map qualified as Map
import Graphics.Vty import Graphics.Vty ( Attr )
import Control.Monad import Control.Monad ( guard, msum )
import Data.Maybe import Data.Maybe ( listToMaybe, mapMaybe, maybeToList )
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Set (Set) import Data.Set (Set)
import GHC.Stack (HasCallStack)
type Coord = (Int, Int) type Coord = (Int, Int)
@ -19,31 +20,37 @@ data Box = Box {
} }
deriving (Show, Read, Eq) deriving (Show, Read, Eq)
boxWalls :: World -> Box -> Array Coord Bool -- | Compute the height and width of a box.
boxSize :: World -> Box -> (Int, Int)
boxSize world box = (yhi-ylo+1, xhi-xlo+1)
where
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
-- | Find the array corresponding to the walls of a box.
boxWalls :: World -> Box -> UArray Coord Bool
boxWalls world box = boxWalls world box =
case boxType box of case boxType box of
Original walls -> walls Original walls -> walls
Link c -> boxWalls world (boxIx world c) Link c -> boxWalls world (boxIx world c)
Infinity c -> boxWalls world (boxIx world c) Infinity c -> boxWalls world (boxIx world c)
Epsilon _ walls -> walls Epsilon _ walls -> walls
data BoxType data BoxType
= Original (Array Coord Bool) = Original (UArray Coord Bool) -- ^ plain box
| Link Char | Link Char -- ^ entrance clone
| Infinity Char | Infinity Char -- ^ infinite exit
| Epsilon Char (Array Coord Bool) | Epsilon Char (UArray Coord Bool) -- ^ infinite enter
deriving (Show, Read, Eq) deriving (Show, Read, Eq)
data Location = Location { locName :: Char, locY :: Int, locX :: Int } data Location = Location { locName :: Char, locY :: Int, locX :: Int }
deriving (Read, Show, Ord, Eq) deriving (Read, Show, Ord, Eq)
data World = World { data World = World {
worldBoxes :: Map Char Box, worldBoxes :: Map Char Box,
worldMe :: Char, worldMe :: Char,
worldButtons :: Set Location, worldButtons :: Set Location,
worldHome :: Location, worldHome :: Location,
worldHeight :: Int, worldSize :: (Int, Int)
worldWidth :: Int
} }
deriving (Show, Read, Eq) deriving (Show, Read, Eq)
@ -54,18 +61,13 @@ winCondition world =
where where
coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world))) coverage = Set.fromList (mapMaybe boxLocation (Map.elems (worldBoxes world)))
boxSize :: World -> Box -> Int
boxSize world box = yhi-ylo+1
where
((ylo,_),(yhi,_)) = bounds (boxWalls world box)
move :: World -> (Int,Int) -> World move :: World -> (Int,Int) -> World
move world dir = move world dir =
case myLocation world of case myLocation world of
Nothing -> world Nothing -> world
Just loc -> Just loc ->
case moveBlock world Map.empty loc dir 0 of let locMap = worldLocations world in
case moveBlock world locMap Map.empty loc dir 0 of
Nothing -> world Nothing -> world
Just changes -> Just changes ->
let f box change = box { boxLocation = change } in let f box change = box { boxLocation = change } in
@ -84,6 +86,7 @@ type Movement = (Int, Int)
moveBlock :: moveBlock ::
World -> World ->
Map Location (Char, Box) ->
Map Location (Int, Char, Maybe Location) -> Map Location (Int, Char, Maybe Location) ->
Location -> Location ->
Movement -> Movement ->
@ -91,15 +94,15 @@ moveBlock ::
Maybe (Map Char (Maybe Location)) Maybe (Map Char (Maybe Location))
-- moving into a wall, not possible -- moving into a wall, not possible
moveBlock world _ loc _ _ moveBlock world _ _ loc _ _
| isWall world loc = 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 _ _
| Just (n,_,_) <- Map.lookup loc visited | Just (n,_,_) <- Map.lookup loc visited
= Just (Map.fromList [(c,l) | (a,c,l) <- Map.elems visited, a >= n]) = Just (Map.fromList [(c,l) | (a,c,l) <- Map.elems visited, a >= n])
moveBlock world visited loc dir offset = moveBlock world locMap visited loc dir offset =
case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of case [(n,box) | (n,box) <- Map.assocs (worldBoxes world), boxLocation box == Just loc] of
-- moving an empty space, so we're done -- moving an empty space, so we're done
[] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited]) [] -> Just (Map.fromList [(c,l) | (_,c,l) <- Map.elems visited])
@ -107,13 +110,16 @@ moveBlock world visited loc dir offset =
-- moving a box -- moving a box
(name,box):_ -> (name,box):_ ->
case nextLoc world dir loc offset of case nextLoc world dir loc offset of
-- block is exiting into the void; finish the move
Nothing -> Just (Map.fromList ((name, Nothing) : [(c,l) | (_,c,l) <- Map.elems visited])) Nothing -> Just (Map.fromList ((name, Nothing) : [(c,l) | (_,c,l) <- Map.elems visited]))
Just (loc', offset') -> Just (loc', offset') ->
do guard (not (isWall world loc')) do guard (not (isWall world loc'))
moveBlock' world visited loc loc' dir name box Set.empty offset' moveBlock' world locMap visited loc loc' dir name box Set.empty offset'
moveBlock' :: moveBlock' ::
World -> World ->
Map Location (Char, Box) ->
Map Location (Int, Char, Maybe Location) -> Map Location (Int, Char, Maybe Location) ->
Location -> Location ->
Location -> Location ->
@ -123,31 +129,31 @@ moveBlock' ::
Set Location -> Set Location ->
Rational {- ^ offset -} -> Rational {- ^ offset -} ->
Maybe (Map Char (Maybe Location)) Maybe (Map Char (Maybe Location))
moveBlock' world visited loc loc' dir name box enters offset = moveBlock' world locMap visited loc loc' dir name box enters offset =
msum [moveTo, moveInto, moveToEat] msum [moveTo, moveInto, moveToEat]
where where
moveTo = moveTo =
do moveBlock world (addVisited name loc (Just loc') visited) loc' dir 0 do moveBlock world locMap (addVisited name loc (Just loc') visited) loc' dir 0
moveInto = moveInto =
do (n,b) <- boxAt world loc' do (n,b) <- Map.lookup loc' locMap
(locI, offset') <- enterLoc world n b dir offset (locI, offset') <- enterLoc world n b dir offset
if Set.member locI enters then if Set.member locI enters then
moveEpsilon moveEpsilon
else else
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset' moveBlock' world locMap visited loc locI dir name box (Set.insert locI enters) offset'
moveEpsilon = moveEpsilon =
do epsilon <- findEpsilon world (locName loc') do epsilon <- findEpsilon world (locName loc')
let eBox = boxIx world epsilon let eBox = boxIx world epsilon
(locI, offset') <- enterLoc world epsilon eBox dir offset (locI, offset') <- enterLoc world epsilon eBox dir offset
moveBlock' world visited loc locI dir name box (Set.insert locI enters) offset' moveBlock' world locMap visited loc locI dir name box (Set.insert locI enters) offset'
moveToEat = moveToEat =
do let dir' = invert dir do let dir' = invert dir
(locE, _) <- enterLoc world name box dir' 0 (locE, _) <- enterLoc world name box dir' 0
(name', box') <- boxAt world loc' (name', box') <- Map.lookup loc' locMap
moveBlock' world (addVisited name loc (Just loc') visited) loc' locE dir' name' box' Set.empty 0 moveBlock' world locMap (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 -> Char -> Box -> Movement -> Rational -> Maybe (Location, Rational)
enterLoc world name box dir@(dy,dx) offset = enterLoc world name box dir@(dy,dx) offset =
@ -158,9 +164,14 @@ enterLoc world name box dir@(dy,dx) offset =
Infinity{} -> Nothing Infinity{} -> Nothing
Epsilon {} -> Just name Epsilon {} -> Just name
let go y x = Just let (bh, bw) = boxSize world box
-- moving on y axis crosses width face and vice versa
faceSize = abs dy * bw + abs dx * bh
go y x = Just
(Location name' y x, (Location name' y x,
fromIntegral(boxSize world box) * offset fromIntegral faceSize * offset
- fromIntegral ((abs dy *x + abs dx*y))) - fromIntegral ((abs dy *x + abs dx*y)))
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box) ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
@ -172,12 +183,11 @@ enterLoc world name box dir@(dy,dx) offset =
( 0, 1) -> go (midpoint ylo yhi offset) xlo ( 0, 1) -> go (midpoint ylo yhi offset) xlo
_ -> error "enterLoc: bad direction" _ -> error "enterLoc: bad direction"
boxAt :: World -> Location -> Maybe (Char, Box) boxIx :: HasCallStack => World -> Char -> Box
boxAt world loc = boxIx world name =
listToMaybe [(n,b) | (n,b) <- Map.assocs (worldBoxes world), boxLocation b == Just loc] case Map.lookup name (worldBoxes world) of
Nothing -> error ("No such box: " ++ [name])
boxIx :: World -> Char -> Box Just box -> box
boxIx world name = worldBoxes world Map.! name
invert :: Movement -> Movement invert :: Movement -> Movement
invert (dy,dx) = (-dy, -dx) invert (dy,dx) = (-dy, -dx)
@ -206,9 +216,11 @@ nextLoc world (dy, dx) = go Set.empty
| Just box <- Map.lookup b (worldBoxes world) | Just box <- Map.lookup b (worldBoxes world)
, Set.notMember b visited , Set.notMember b visited
, Just boxLoc <- boxLocation box , Just boxLoc <- boxLocation box
, let (bh,bw) = boxSize world box
, let faceSize = abs dy * bw + abs dx * bh
= go (Set.insert b visited) boxLoc = go (Set.insert b visited) boxLoc
$ (offset + fromIntegral (abs dy*x+abs dx*y)) $ (offset + fromIntegral (abs dy*x+abs dx*y))
/ fromIntegral (boxSize world box) / fromIntegral faceSize
go visited (Location b y x) offset go visited (Location b y x) offset
| Set.member b visited | Set.member b visited
@ -226,3 +238,10 @@ findEpsilon :: World -> Char -> Maybe Char
findEpsilon world b = findEpsilon world b =
listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world) listToMaybe [b' | (b', box) <- Map.assocs (worldBoxes world)
, Epsilon i _ <- [boxType box], i == b] , Epsilon i _ <- [boxType box], i == b]
worldLocations :: World -> Map Location (Char, Box)
worldLocations world =
Map.fromList
[(loc, (n,box))
| (n, box) <- Map.assocs (worldBoxes world)
, loc <- maybeToList (boxLocation box)]

6
app/Parser.hs
View File

@ -2,7 +2,7 @@ module Parser (parse) where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Data.Array (Array, listArray) import Data.Array.Unboxed (UArray, listArray)
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Set qualified as Set import Data.Set qualified as Set
import Graphics.Vty.Attributes import Graphics.Vty.Attributes
@ -21,7 +21,7 @@ parse str =
p p
(Set.fromList (Map.findWithDefault [] '-' m)) (Set.fromList (Map.findWithDefault [] '-' m))
(head (m Map.! '=')) (head (m Map.! '='))
h w (h, w)
parseHeader :: ReadP (Char,Int,Int) parseHeader :: ReadP (Char,Int,Int)
parseHeader = parseHeader =
@ -107,7 +107,7 @@ parseColor =
"green" -> pure (withForeColor defAttr green) "green" -> pure (withForeColor defAttr green)
_ -> empty _ -> empty
walls :: [String] -> Array Coord Bool walls :: [String] -> UArray Coord Bool
walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows)) walls rows = listArray ((ylo,xlo),(yhi,xhi)) (map ('▓'==) (concat rows))
where where
width = length (head rows) width = length (head rows)

37
app/Rendering.hs
View File

@ -1,6 +1,6 @@
module Rendering where module Rendering where
import Data.Array import Data.Array.Unboxed
import Data.Maybe import Data.Maybe
import Data.Map (Map) import Data.Map (Map)
import Data.Map qualified as Map import Data.Map qualified as Map
@ -8,7 +8,7 @@ import Data.Set qualified as Set
import Data.List (intersperse, group) import Data.List (intersperse, group)
import Graphics.Vty import Graphics.Vty
import BigFont import BigFont ( bigText )
import Model import Model
border :: Int border :: Int
@ -39,14 +39,13 @@ home a h w = vertCat $
replicate (h-2) (string a ('║' : replicate (w-2) '░' ++ "║")) ++ replicate (h-2) (string a ('║' : replicate (w-2) '░' ++ "║")) ++
[string a ('╚' : replicate (w-2) '═' ++ "╝")] [string a ('╚' : replicate (w-2) '═' ++ "╝")]
renderCell :: World -> Map Location Char -> Char -> Box -> Int -> Int -> Int -> Int -> Image renderCell :: World -> Map Location (Char, Box) -> Char -> Box -> Int -> Int -> Int -> Int -> Image
renderCell world locMap name box y x h w renderCell world locMap name box y x h w
| boxWalls world box ! (y,x) = unit (boxColor box) h w wallChar | boxWalls world box ! (y,x) = unit (boxColor box) h w wallChar
| Just n <- Map.lookup (Location name' y x) locMap | Just (n, box') <- Map.lookup (Location name' y x) locMap
, let box' = boxIx world n = if h < fst (boxSize world box')
= 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 else renderBox world locMap box' n h w
@ -79,7 +78,7 @@ contentName world name box =
Link c -> c Link c -> c
Infinity c -> contentName world c (boxIx world c) Infinity c -> contentName world c (boxIx world c)
renderBox :: World -> Map Location Char -> Box -> Char -> Int -> Int -> Image renderBox :: World -> Map Location (Char, Box) -> Box -> Char -> Int -> Int -> Image
renderBox world locMap box name boxh boxw = renderBox world locMap box name boxh boxw =
vertCat [ vertCat [
horizCat [ horizCat [
@ -112,17 +111,16 @@ render flat world = picForLayers $
(if flat then renderFlat locMap world else []) ++ (if flat then renderFlat locMap world else []) ++
[drawNestedWorld locMap world] [drawNestedWorld locMap world]
where where
locMap = Map.fromList [(loc, n) | (n, box) <- Map.toList (worldBoxes world) locMap = worldLocations world
, loc <- maybeToList (boxLocation box)]
renderFlat :: Map Location Char -> World -> [Image] renderFlat :: Map Location (Char, Box) -> World -> [Image]
renderFlat locMap world = renderFlat locMap world =
[ pad offset 0 0 0 baseImage [ pad offset 0 0 0 baseImage
, pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage) , pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage)
] ]
where where
borderAttr = defAttr `withForeColor` white `withBackColor` black borderAttr = defAttr `withForeColor` white `withBackColor` black
offset = max 0 ( (worldWidth world + 2*(2*border)+2 - imageWidth baseImage) `div` 2) offset = max 0 ( (snd (worldSize world) + 2*(2*border)+2 - imageWidth baseImage) `div` 2)
baseImage = baseImage =
pad 2 1 2 1 $ pad 2 1 2 1 $
horizCat $ horizCat $
@ -131,7 +129,7 @@ renderFlat locMap world =
| (n,b) <- Map.assocs (worldBoxes world) | (n,b) <- Map.assocs (worldBoxes world)
, not (boxBoring b)] , not (boxBoring b)]
drawNestedWorld :: Map Location Char -> World -> Image drawNestedWorld :: Map Location (Char, Box) -> World -> Image
drawNestedWorld locMap world = drawNestedWorld locMap world =
cropTop (h + 2*border) $ cropTop (h + 2*border) $
cropLeft (w + 4*border) $ cropLeft (w + 4*border) $
@ -163,8 +161,7 @@ drawNestedWorld locMap world =
] ]
where where
infinityImage = makeInfinity h w infinityImage = makeInfinity h w
h = worldHeight world (h, w) = worldSize world
w = worldWidth world
makeInfinity :: Int -> Int -> Image makeInfinity :: Int -> Int -> Image
makeInfinity h w = result makeInfinity h w = result
@ -186,7 +183,9 @@ makeInfinity h w = result
result = foldr mkCol row colGaps result = foldr mkCol row colGaps
mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest mkCol gap rest = row <-> charFill attr ' ' 1 gap <-> rest
stackedLoc :: World -> Map Location Char -> Location -> Maybe Location -- | Covert a location on a block that might overflow into a location
-- following block exits.
stackedLoc :: World -> Map Location (Char, Box) -> Location -> Maybe Location
stackedLoc world locMap = go Set.empty stackedLoc world locMap = go Set.empty
where where
go visited loc@(Location b y x) go visited loc@(Location b y x)
@ -212,7 +211,7 @@ overflow (lo,hi) x
| otherwise = 0 | otherwise = 0
fixup :: World -> fixup :: World ->
Map Location Char -> Map Location (Char, Box) ->
Int -> Int ->
Int -> Int ->
Int -> Int ->
@ -222,12 +221,12 @@ fixup :: World ->
fixup world locMap dy dx py px loc = fixup world locMap dy dx py px loc =
case Map.lookup loc locMap of case Map.lookup loc locMap of
Nothing -> loc Nothing -> loc
Just name -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px) Just (name, box) -> Location name (fixup1 ylo yhi dy py) (fixup1 xlo xhi dx px)
where where
((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world (boxIx world name)) ((ylo,xlo),(yhi,xhi)) = bounds (boxWalls world box)
fixup1 :: Int -> Int -> Int -> Int -> Int fixup1 :: Int -> Int -> Int -> Int -> Int
fixup1 _ _ 0 i = i fixup1 lo hi 0 i = min hi (max lo i)
fixup1 _ hi (-1) _ = hi fixup1 _ hi (-1) _ = hi
fixup1 lo _ 1 _ = lo fixup1 lo _ 1 _ = lo
fixup1 _ _ _ _ = error "fixup1: bad delta" fixup1 _ _ _ _ = error "fixup1: bad delta"

64
levels/player18.txt
View File

@ -1,51 +1,23 @@
player u player u height 98 width 196
block c yellow interesting block c yellow interesting
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓ ▓ ▓
▓▓ ▓▓ ▓ c 1 ▓
▓▓ c 1 ▓▓ ▓ u
▓▓ u ▓ 2 3 ▓
▓▓ 2 3 ▓▓ ▓ ▓
▓▓ ▓▓ ▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block u magenta interesting block u magenta interesting
▓▓▓▓ ▓▓▓▓ ▓▓▓ ▓▓▓
▓▓▓▓ ▓▓▓▓ ▓▓▓ ▓▓▓
▓▓▓▓ ▓▓▓▓ ▓▓▓ ▓▓▓
▓▓ -▓▓ ▓ -▓
▓▓ ▓▓ ▓ ▓
▓▓= ▓▓ ▓= ▓
▓▓▓▓▓▓▓▓▓ ▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block 1 blue boring block 1 blue boring
▓▓▓▓▓▓▓▓▓ ▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓ ▓▓▓▓
▓▓▓▓ ▓▓▓▓
▓▓▓▓ ▓▓▓▓
▓▓▓▓ ▓▓▓▓
▓▓▓▓ ▓▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block 2 blue boring block 2 blue boring
▓▓▓▓▓▓▓▓▓ ▓
▓▓▓▓▓▓▓▓▓
▓▓▓ ▓▓▓▓
▓▓▓▓▓ ▓▓▓
▓▓▓▓ ▓▓▓▓
▓▓▓ ▓▓▓▓▓
▓▓▓ ▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓
block 3 blue boring block 3 blue boring
▓▓▓▓▓▓▓▓▓ ▓
▓▓▓▓▓▓▓▓▓
▓▓▓ ▓▓▓
▓▓▓▓▓ ▓▓▓
▓▓▓▓ ▓▓▓
▓▓▓▓▓ ▓▓▓
▓▓▓ ▓▓▓
▓▓▓▓▓▓▓▓▓
▓▓▓▓▓▓▓▓▓