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

improvements

Browse Source
This commit is contained in:
Eric Mertens 2022-12-08 18:58:07 -08:00
parent e4ee9d39b7
commit a105ceabab
4 changed files with 128 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
app/Main.hs
View File

@ -1,26 +1,28 @@
module Main (main) where module Main (main) where
import Control.Exception ( bracket ) import Control.Exception ( bracket )
import Data.Char (toUpper)
import Data.List (intersperse, isPrefixOf, sort)
import Data.List.NonEmpty (NonEmpty(..), (<|)) import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.List.NonEmpty qualified as NonEmpty import Data.List.NonEmpty qualified as NonEmpty
import Data.Char (toUpper)
import Data.List (intersperse, sort)
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
import System.Environment ( getArgs ) import Data.Ord (clamp)
import System.Directory ( listDirectory ) import System.Directory (listDirectory)
import System.FilePath ( (</>), takeBaseName ) import System.Environment (getArgs)
import System.FilePath ((</>), takeBaseName, takeExtension)
import BigFont (bigText)
import Model import Model
import Rendering ( render )
import Parser (parse) import Parser (parse)
import BigFont import Rendering (render, wrapBox)
data Game = Game { data Game = Game {
gameFlat :: Bool, gameFlat :: Bool,
gameMode :: GameMode, gameMode :: GameMode,
gameSelect :: Int gameSelect :: Int,
gameError :: String
} }
data GameMode data GameMode
@ -29,9 +31,20 @@ data GameMode
getWorldList :: IO (Map String FilePath) getWorldList :: IO (Map String FilePath)
getWorldList = getWorldList =
do paths <- sort <$> listDirectory "levels" do paths <- sort . filter isLevelName <$> listDirectory "levels"
pure (Map.fromList [(takeBaseName path, "levels" </> path) | path <- paths]) pure (Map.fromList [(takeBaseName path, "levels" </> path) | path <- paths])
isLevelName :: FilePath -> Bool
isLevelName path = not ("." `isPrefixOf` path) && ".txt" == takeExtension path
defaultGame :: Game
defaultGame = Game {
gameMode = MenuMode,
gameFlat = True,
gameSelect = 0,
gameError = ""
}
main :: IO () main :: IO ()
main = main =
do args <- getArgs do args <- getArgs
@ -39,44 +52,37 @@ main =
bracket (mkVty =<< userConfig) shutdown \vty -> bracket (mkVty =<< userConfig) shutdown \vty ->
case args of case args of
x:_ | Just path <- Map.lookup x worldList -> x:_ | Just path <- Map.lookup x worldList ->
do w <- parse <$> readFile path loadLevelFile vty defaultGame path
loop vty Game { _ -> loop vty defaultGame
gameMode = PlayMode (pure w),
gameFlat = True,
gameSelect = Map.findIndex x worldList
}
_ ->
loop vty Game {
gameMode = MenuMode,
gameFlat = True,
gameSelect = 0
}
loop :: Vty -> Game -> IO () loop :: Vty -> Game -> IO ()
loop vty game = loop vty game = do
bnds <- displayBounds (outputIface vty)
case gameMode game of case gameMode game of
MenuMode -> MenuMode ->
do worldList <- getWorldList do worldList <- getWorldList
bnds <- displayBounds (outputIface vty) update vty (picForLayers $
update vty (picForImage (renderMenu (gameSelect game) worldList bnds)) [errorImage (gameError game) | not (null (gameError game))] ++
[renderMenu bnds (gameSelect game) worldList])
ev <- nextEvent vty ev <- nextEvent vty
case ev of case ev of
EvKey key _modifier -> EvKey key _modifier ->
case key of case key of
KEsc -> pure () KEsc -> escape vty game
KUp | gameSelect game > 0 -> KUp -> loop vty game{ gameSelect = max 0 (gameSelect game - 1) }
loop vty game{ gameSelect = gameSelect game - 1 } KPageUp -> loop vty game{ gameSelect = max 0 (gameSelect game - 10) }
KDown | gameSelect game + 1 < Map.size worldList -> KDown -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game + 1) }
loop vty game{ gameSelect = gameSelect game + 1 } KPageDown -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game + 10) }
KEnter | (_, path) <- Map.elemAt (gameSelect game) worldList -> KEnter
do world <- parse <$> readFile path | 0 <= gameSelect game, gameSelect game < Map.size worldList
loop vty game{ gameMode = PlayMode (pure world) } , (_, path) <- Map.elemAt (gameSelect game) worldList ->
loadLevelFile vty game path
_ -> loop vty game _ -> loop vty game
_ -> loop vty game _ -> loop vty game
PlayMode worlds -> PlayMode worlds ->
do let world = NonEmpty.head worlds do let world = NonEmpty.head worlds
update vty (render (gameFlat game) (NonEmpty.head worlds)) update vty (render bnds (gameFlat game) (NonEmpty.head worlds))
ev <- nextEvent vty ev <- nextEvent vty
case ev of case ev of
EvKey key _modifier -> EvKey key _modifier ->
@ -91,14 +97,28 @@ loop vty game =
KChar 'z' KChar 'z'
| Just worlds' <- NonEmpty.nonEmpty (NonEmpty.tail worlds) -> | Just worlds' <- NonEmpty.nonEmpty (NonEmpty.tail worlds) ->
loop vty game{ gameMode = PlayMode worlds' } loop vty game{ gameMode = PlayMode worlds' }
KEsc -> pure () KEsc -> escape vty game
KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) } KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) }
_ -> loop vty game _ -> loop vty game
_ -> loop vty game _ -> loop vty game
escape :: Vty -> Game -> IO ()
escape vty game
| null (gameError game) = pure ()
| otherwise = loop vty game{ gameError = "" }
renderMenu :: Int -> Map String a -> DisplayRegion -> Image loadLevelFile :: Vty -> Game -> FilePath -> IO ()
renderMenu sel list (w,h) loadLevelFile vty game path =
do file <- readFile path
case parse file of
Left errorMessage -> loop vty game{ gameError = errorMessage }
Right world -> loop vty game{
gameMode = PlayMode (pure world),
gameError = ""
}
renderMenu :: DisplayRegion -> Int -> Map String a -> Image
renderMenu (w,h) sel list
| hpad >= 0 = pad wpad hpad 0 0 menu | hpad >= 0 = pad wpad hpad 0 0 menu
| otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu) | otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu)
where where
@ -112,5 +132,10 @@ renderMenu sel list (w,h)
| (i,k) <- zip [0..] (Map.keys list) | (i,k) <- zip [0..] (Map.keys list)
] ]
errorImage :: String -> Image
errorImage str = wrapBox a (bigString a str)
where
a = defAttr `withForeColor` red
bigString :: Attr -> String -> Image bigString :: Attr -> String -> Image
bigString a = vertCat . map (string a) . bigText . map toUpper bigString a = vertCat . map (string a) . bigText . map toUpper

4
app/Model.hs
View File

@ -207,11 +207,13 @@ nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rationa
nextLoc world (dy, dx) = go Set.empty nextLoc world (dy, dx) = go Set.empty
where where
-- Step fits within current box, success
go _ (Location b y x) offset go _ (Location b y x) offset
| Just box <- Map.lookup b (worldBoxes world) | Just box <- Map.lookup b (worldBoxes world)
, inRange (bounds (boxWalls world box)) (y+dy, x+dx) , inRange (bounds (boxWalls world box)) (y+dy, x+dx)
= Just (Location b (y+dy) (x+dx), offset) = Just (Location b (y+dy) (x+dx), offset)
-- Step takes us off the edge of the box, exit to parent
go visited (Location b y x) offset go visited (Location b y x) offset
| Just box <- Map.lookup b (worldBoxes world) | Just box <- Map.lookup b (worldBoxes world)
, Set.notMember b visited , Set.notMember b visited
@ -222,11 +224,13 @@ nextLoc world (dy, dx) = go Set.empty
$ (offset + fromIntegral (abs dy*x+abs dx*y)) $ (offset + fromIntegral (abs dy*x+abs dx*y))
/ fromIntegral faceSize / fromIntegral faceSize
-- exiting has cycled, exit from next infinity box
go visited (Location b y x) offset go visited (Location b y x) offset
| Set.member b visited | Set.member b visited
, Just b' <- findInfinity world b , Just b' <- findInfinity world b
= go visited (Location b' y x) offset = go visited (Location b' y x) offset
-- infinity boxes exhausted, exit to void
go _ _ _ = Nothing go _ _ _ = Nothing
findInfinity :: World -> Char -> Maybe Char findInfinity :: World -> Char -> Maybe Char

34
app/Parser.hs
View File

@ -10,18 +10,34 @@ import Text.ParserCombinators.ReadP hiding (many)
import Model import Model
parse :: String -> World parse :: String -> Either String World
parse str = parse str =
case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of
[] -> error "world parsing failed" [] -> Left "world parsing failed"
(((p,h,w),bs),_):_ -> (((p,h,w),bs),_):_ ->
do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs] do let m = Map.fromListWith (++) [(k,[v]) | (_,_,kvs) <- bs, (k,v) <- kvs]
World
(Map.fromList [(n, b { boxLocation = head <$> Map.lookup n m }) | (n,b,_) <- bs]) home <-
p case Map.lookup '=' m of
(Set.fromList (Map.findWithDefault [] '-' m)) Nothing -> Left "no home location defined"
(head (m Map.! '=')) Just [home] -> Right home
(h, w) Just _ -> Left "ambiguous home defined"
boxes <- sequence $
Map.fromList
[(n, case Map.lookup n m of
Nothing -> Right b {boxLocation = Nothing}
Just [l] -> Right b {boxLocation = Just l}
Just _ -> Left ("ambiguous location for: " ++ [n])
) | (n,b,_) <- bs]
Right World {
worldBoxes = boxes,
worldMe = p,
worldButtons = Set.fromList (Map.findWithDefault [] '-' m),
worldHome = home,
worldSize = (h, w)
}
parseHeader :: ReadP (Char,Int,Int) parseHeader :: ReadP (Char,Int,Int)
parseHeader = parseHeader =
@ -30,7 +46,7 @@ parseHeader =
h <- option 81 h <- option 81
do "height" <- token do "height" <- token
integer integer
w <- option (81*2) w <- option (h*2)
do "width" <- token do "width" <- token
integer integer
pure (p,h,w) pure (p,h,w)

70
app/Rendering.hs
View File

@ -18,12 +18,11 @@ unit :: Attr -> Int -> Int -> Char -> Image
unit a h w c = unit a h w c =
vertCat (replicate h (string a (replicate w c))) vertCat (replicate h (string a (replicate w c)))
drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image wrapBox :: Attr -> Image -> Image
drawBox a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]") wrapBox a body =
drawBox a h w = vertCat $ char a '┌' <|> charFill a '─' (imageWidth body) 1 <|> char a '┐' <->
string a ('┌' : replicate (w-2) '─' ++ "┐") : charFill a '│' 1 (imageHeight body) <|> body <|> charFill a '│' 1 (imageHeight body) <->
replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++ char a '└' <|> charFill a '─' (imageWidth body) 1 <|> char a '┘'
[string a ('└' : replicate (w-2) '─' ++ "┘")]
button :: Attr -> Int -> Int -> Image button :: Attr -> Int -> Int -> Image
button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]") button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
@ -93,48 +92,53 @@ renderBox world locMap box name boxh boxw =
boxHeight = yhi - ylo + 1 boxHeight = yhi - ylo + 1
render :: render ::
DisplayRegion ->
Bool {- ^ show flat overlay -} -> Bool {- ^ show flat overlay -} ->
World -> World ->
Picture Picture
render flat world = picForLayers $ render bnds flat world = picForLayers $
[ pad 98 12 0 0 $ [ center bnds $
string defAttr "██╗ ██╗██╗███╗ ██╗███╗ ██╗███████╗██████╗ " <-> pad 0 12 0 0 $
string defAttr "██║ ██║██║████╗ ██║████╗ ██║██╔════╝██╔══██╗" <-> wrapBox winAttr $
string defAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗ ██████╔╝" <-> string winAttr "██╗ ██╗██╗███╗ ██╗███╗ ██╗███████╗██████╗ " <->
string defAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝ ██╔══██╗" <-> string winAttr "██║ ██║██║████╗ ██║████╗ ██║██╔════╝██╔══██╗" <->
string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <-> string winAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗ ██████╔╝" <->
string defAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝" string winAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝ ██╔══██╗" <->
| winCondition world ] ++ string winAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <->
[ pad 94 7 0 0 $ string winAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝"
| let winAttr = defAttr `withForeColor` yellow
, winCondition world ] ++
[ center bnds $
vertCat (map (string defAttr) (bigText "VOIDED")) vertCat (map (string defAttr) (bigText "VOIDED"))
| isNothing (boxLocation (boxIx world (worldMe world))) ] ++ | isNothing (boxLocation (boxIx world (worldMe world))) ] ++
(if flat then renderFlat locMap world else []) ++ (if flat then map (center bnds) (renderFlat locMap world) else []) ++
[drawNestedWorld locMap world] [center bnds (drawNestedWorld bnds locMap world)]
where where
locMap = worldLocations world locMap = worldLocations world
-- | Center an image horizontally within the display region.
-- If the image is wider than the region, left-align it.
center :: DisplayRegion -> Image -> Image
center (w,_) image =
pad (max 0 (w - imageWidth image) `div` 2) 0 0 0 image
renderFlat :: Map Location (Char, Box) -> World -> [Image] renderFlat :: Map Location (Char, Box) -> World -> [Image]
renderFlat locMap world = renderFlat locMap world =
[ pad offset 0 0 0 baseImage [wrapBox borderAttr baseImage | not (null components)]
, 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 ( (snd (worldSize world) + 2*(2*border)+2 - imageWidth baseImage) `div` 2) baseImage = horizCat components
baseImage = components =
pad 2 1 2 1 $
horizCat $
intersperse (char borderAttr ' ')
[renderBox world locMap b n 18 36 [renderBox world locMap b n 18 36
| (n,b) <- Map.assocs (worldBoxes world) | (n,b) <- Map.assocs (worldBoxes world)
, not (boxBoring b)] , not (boxBoring b)]
drawNestedWorld :: Map Location (Char, Box) -> World -> Image drawNestedWorld :: DisplayRegion -> Map Location (Char, Box) -> World -> Image
drawNestedWorld locMap world = drawNestedWorld (drW, drH) locMap world =
cropTop (h + 2*border) $ cropTop (h + 2 + 2*edgeH) $
cropLeft (w + 4*border) $ cropLeft (w + 2 + 2*edgeW) $
cropBottom (2*h + border) $ cropBottom (2*h + 2 + edgeH) $
cropRight (2*(w + border)) $ cropRight (2*w + 2 + edgeW) $
vertCat $ vertCat $
intersperse (char defAttr ' ') intersperse (char defAttr ' ')
[ [
@ -160,6 +164,8 @@ drawNestedWorld locMap world =
| dy <- [-1 .. 1] | dy <- [-1 .. 1]
] ]
where where
edgeW = max 0 (drW - w) `div` 2
edgeH = max 0 (drH - h) `div` 2
infinityImage = makeInfinity h w infinityImage = makeInfinity h w
(h, w) = worldSize world (h, w) = worldSize world