improvements
This commit is contained in:
Eric Mertens
parent
e4ee9d39b7
commit
a105ceabab
97
app/Main.hs
97
app/Main.hs
@ -1,26 +1,28 @@
|
||||
module Main (main) where
|
||||
|
||||
import Control.Exception ( bracket )
|
||||
import Data.Char (toUpper)
|
||||
import Data.List (intersperse, isPrefixOf, sort)
|
||||
import Data.List.NonEmpty (NonEmpty(..), (<|))
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
import Data.Char (toUpper)
|
||||
import Data.List (intersperse, sort)
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Graphics.Vty
|
||||
import System.Environment ( getArgs )
|
||||
import System.Directory ( listDirectory )
|
||||
import System.FilePath ( (</>), takeBaseName )
|
||||
import Data.Ord (clamp)
|
||||
import System.Directory (listDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.FilePath ((</>), takeBaseName, takeExtension)
|
||||
|
||||
import BigFont (bigText)
|
||||
import Model
|
||||
import Rendering ( render )
|
||||
import Parser (parse)
|
||||
import BigFont
|
||||
import Rendering (render, wrapBox)
|
||||
|
||||
data Game = Game {
|
||||
gameFlat :: Bool,
|
||||
gameMode :: GameMode,
|
||||
gameSelect :: Int
|
||||
gameSelect :: Int,
|
||||
gameError :: String
|
||||
}
|
||||
|
||||
data GameMode
|
||||
@ -29,9 +31,20 @@ data GameMode
|
||||
|
||||
getWorldList :: IO (Map String FilePath)
|
||||
getWorldList =
|
||||
do paths <- sort <$> listDirectory "levels"
|
||||
do paths <- sort . filter isLevelName <$> listDirectory "levels"
|
||||
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 =
|
||||
do args <- getArgs
|
||||
@ -39,44 +52,37 @@ main =
|
||||
bracket (mkVty =<< userConfig) shutdown \vty ->
|
||||
case args of
|
||||
x:_ | Just path <- Map.lookup x worldList ->
|
||||
do w <- parse <$> readFile path
|
||||
loop vty Game {
|
||||
gameMode = PlayMode (pure w),
|
||||
gameFlat = True,
|
||||
gameSelect = Map.findIndex x worldList
|
||||
}
|
||||
_ ->
|
||||
loop vty Game {
|
||||
gameMode = MenuMode,
|
||||
gameFlat = True,
|
||||
gameSelect = 0
|
||||
}
|
||||
loadLevelFile vty defaultGame path
|
||||
_ -> loop vty defaultGame
|
||||
|
||||
loop :: Vty -> Game -> IO ()
|
||||
loop vty game =
|
||||
loop vty game = do
|
||||
bnds <- displayBounds (outputIface vty)
|
||||
case gameMode game of
|
||||
MenuMode ->
|
||||
do worldList <- getWorldList
|
||||
bnds <- displayBounds (outputIface vty)
|
||||
update vty (picForImage (renderMenu (gameSelect game) worldList bnds))
|
||||
update vty (picForLayers $
|
||||
[errorImage (gameError game) | not (null (gameError game))] ++
|
||||
[renderMenu bnds (gameSelect game) worldList])
|
||||
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 | (_, path) <- Map.elemAt (gameSelect game) worldList ->
|
||||
do world <- parse <$> readFile path
|
||||
loop vty game{ gameMode = PlayMode (pure world) }
|
||||
KEsc -> escape vty game
|
||||
KUp -> loop vty game{ gameSelect = max 0 (gameSelect game - 1) }
|
||||
KPageUp -> loop vty game{ gameSelect = max 0 (gameSelect game - 10) }
|
||||
KDown -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game + 1) }
|
||||
KPageDown -> loop vty game{ gameSelect = clamp (0, Map.size worldList - 1) (gameSelect game + 10) }
|
||||
KEnter
|
||||
| 0 <= gameSelect game, gameSelect game < Map.size worldList
|
||||
, (_, path) <- Map.elemAt (gameSelect game) worldList ->
|
||||
loadLevelFile vty game path
|
||||
_ -> loop vty game
|
||||
_ -> loop vty game
|
||||
|
||||
PlayMode 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
|
||||
case ev of
|
||||
EvKey key _modifier ->
|
||||
@ -91,14 +97,28 @@ loop vty game =
|
||||
KChar 'z'
|
||||
| Just worlds' <- NonEmpty.nonEmpty (NonEmpty.tail worlds) ->
|
||||
loop vty game{ gameMode = PlayMode worlds' }
|
||||
KEsc -> pure ()
|
||||
KEsc -> escape vty game
|
||||
KChar 'f' -> loop vty game{ gameFlat = not (gameFlat 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
|
||||
renderMenu sel list (w,h)
|
||||
loadLevelFile :: Vty -> Game -> FilePath -> IO ()
|
||||
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
|
||||
| otherwise = pad wpad 0 0 0 (cropTop (imageHeight menu + hpad) menu)
|
||||
where
|
||||
@ -112,5 +132,10 @@ renderMenu sel list (w,h)
|
||||
| (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 a = vertCat . map (string a) . bigText . map toUpper
|
||||
|
||||
@ -207,11 +207,13 @@ nextLoc :: World -> Movement -> Location -> Rational -> Maybe (Location, Rationa
|
||||
nextLoc world (dy, dx) = go Set.empty
|
||||
where
|
||||
|
||||
-- Step fits within current box, success
|
||||
go _ (Location b y x) offset
|
||||
| Just box <- Map.lookup b (worldBoxes world)
|
||||
, inRange (bounds (boxWalls world box)) (y+dy, x+dx)
|
||||
= 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
|
||||
| Just box <- Map.lookup b (worldBoxes world)
|
||||
, Set.notMember b visited
|
||||
@ -222,11 +224,13 @@ nextLoc world (dy, dx) = go Set.empty
|
||||
$ (offset + fromIntegral (abs dy*x+abs dx*y))
|
||||
/ fromIntegral faceSize
|
||||
|
||||
-- exiting has cycled, exit from next infinity box
|
||||
go visited (Location b y x) offset
|
||||
| Set.member b visited
|
||||
, Just b' <- findInfinity world b
|
||||
= go visited (Location b' y x) offset
|
||||
|
||||
-- infinity boxes exhausted, exit to void
|
||||
go _ _ _ = Nothing
|
||||
|
||||
findInfinity :: World -> Char -> Maybe Char
|
||||
|
||||
@ -10,18 +10,34 @@ import Text.ParserCombinators.ReadP hiding (many)
|
||||
|
||||
import Model
|
||||
|
||||
parse :: String -> World
|
||||
parse :: String -> Either String World
|
||||
parse str =
|
||||
case readP_to_S ((,) <$> parseHeader <*> many parseBlock <* eof) str of
|
||||
[] -> error "world parsing failed"
|
||||
[] -> Left "world parsing failed"
|
||||
(((p,h,w),bs),_):_ ->
|
||||
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])
|
||||
p
|
||||
(Set.fromList (Map.findWithDefault [] '-' m))
|
||||
(head (m Map.! '='))
|
||||
(h, w)
|
||||
|
||||
home <-
|
||||
case Map.lookup '=' m of
|
||||
Nothing -> Left "no home location defined"
|
||||
Just [home] -> Right home
|
||||
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 =
|
||||
@ -30,7 +46,7 @@ parseHeader =
|
||||
h <- option 81
|
||||
do "height" <- token
|
||||
integer
|
||||
w <- option (81*2)
|
||||
w <- option (h*2)
|
||||
do "width" <- token
|
||||
integer
|
||||
pure (p,h,w)
|
||||
|
||||
@ -18,12 +18,11 @@ unit :: Attr -> Int -> Int -> Char -> Image
|
||||
unit a h w c =
|
||||
vertCat (replicate h (string a (replicate w c)))
|
||||
|
||||
drawBox :: Attr -> Int {- ^ width -} -> Int {- ^ height -} -> Image
|
||||
drawBox a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
|
||||
drawBox a h w = vertCat $
|
||||
string a ('┌' : replicate (w-2) '─' ++ "┐") :
|
||||
replicate (h-2) (string a ('│' : replicate (w-2) ' ' ++ "│")) ++
|
||||
[string a ('└' : replicate (w-2) '─' ++ "┘")]
|
||||
wrapBox :: Attr -> Image -> Image
|
||||
wrapBox a body =
|
||||
char a '┌' <|> charFill a '─' (imageWidth body) 1 <|> char a '┐' <->
|
||||
charFill a '│' 1 (imageHeight body) <|> body <|> charFill a '│' 1 (imageHeight body) <->
|
||||
char a '└' <|> charFill a '─' (imageWidth body) 1 <|> char a '┘'
|
||||
|
||||
button :: Attr -> Int -> Int -> Image
|
||||
button a 1 w = string a ("[" ++ replicate (w-2) '-' ++ "]")
|
||||
@ -93,48 +92,53 @@ renderBox world locMap box name boxh boxw =
|
||||
boxHeight = yhi - ylo + 1
|
||||
|
||||
render ::
|
||||
DisplayRegion ->
|
||||
Bool {- ^ show flat overlay -} ->
|
||||
World ->
|
||||
Picture
|
||||
render flat world = picForLayers $
|
||||
[ pad 98 12 0 0 $
|
||||
string defAttr "██╗ ██╗██╗███╗ ██╗███╗ ██╗███████╗██████╗ " <->
|
||||
string defAttr "██║ ██║██║████╗ ██║████╗ ██║██╔════╝██╔══██╗" <->
|
||||
string defAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗ ██████╔╝" <->
|
||||
string defAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝ ██╔══██╗" <->
|
||||
string defAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <->
|
||||
string defAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝"
|
||||
| winCondition world ] ++
|
||||
[ pad 94 7 0 0 $
|
||||
render bnds flat world = picForLayers $
|
||||
[ center bnds $
|
||||
pad 0 12 0 0 $
|
||||
wrapBox winAttr $
|
||||
string winAttr "██╗ ██╗██╗███╗ ██╗███╗ ██╗███████╗██████╗ " <->
|
||||
string winAttr "██║ ██║██║████╗ ██║████╗ ██║██╔════╝██╔══██╗" <->
|
||||
string winAttr "██║ █╗ ██║██║██╔██╗ ██║██╔██╗ ██║█████╗ ██████╔╝" <->
|
||||
string winAttr "██║███╗██║██║██║╚██╗██║██║╚██╗██║██╔══╝ ██╔══██╗" <->
|
||||
string winAttr "╚███╔███╔╝██║██║ ╚████║██║ ╚████║███████╗██║ ██║" <->
|
||||
string winAttr " ╚══╝╚══╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═══╝╚══════╝╚═╝ ╚═╝"
|
||||
| let winAttr = defAttr `withForeColor` yellow
|
||||
, winCondition world ] ++
|
||||
[ center bnds $
|
||||
vertCat (map (string defAttr) (bigText "VOIDED"))
|
||||
| isNothing (boxLocation (boxIx world (worldMe world))) ] ++
|
||||
(if flat then renderFlat locMap world else []) ++
|
||||
[drawNestedWorld locMap world]
|
||||
(if flat then map (center bnds) (renderFlat locMap world) else []) ++
|
||||
[center bnds (drawNestedWorld bnds locMap world)]
|
||||
where
|
||||
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 locMap world =
|
||||
[ pad offset 0 0 0 baseImage
|
||||
, pad offset 0 0 0 $ drawBox borderAttr (imageHeight baseImage) (imageWidth baseImage)
|
||||
]
|
||||
[wrapBox borderAttr baseImage | not (null components)]
|
||||
where
|
||||
borderAttr = defAttr `withForeColor` white `withBackColor` black
|
||||
offset = max 0 ( (snd (worldSize world) + 2*(2*border)+2 - imageWidth baseImage) `div` 2)
|
||||
baseImage =
|
||||
pad 2 1 2 1 $
|
||||
horizCat $
|
||||
intersperse (char borderAttr ' ')
|
||||
baseImage = horizCat components
|
||||
components =
|
||||
[renderBox world locMap b n 18 36
|
||||
| (n,b) <- Map.assocs (worldBoxes world)
|
||||
, not (boxBoring b)]
|
||||
|
||||
drawNestedWorld :: Map Location (Char, Box) -> World -> Image
|
||||
drawNestedWorld locMap world =
|
||||
cropTop (h + 2*border) $
|
||||
cropLeft (w + 4*border) $
|
||||
cropBottom (2*h + border) $
|
||||
cropRight (2*(w + border)) $
|
||||
drawNestedWorld :: DisplayRegion -> Map Location (Char, Box) -> World -> Image
|
||||
drawNestedWorld (drW, drH) locMap world =
|
||||
cropTop (h + 2 + 2*edgeH) $
|
||||
cropLeft (w + 2 + 2*edgeW) $
|
||||
cropBottom (2*h + 2 + edgeH) $
|
||||
cropRight (2*w + 2 + edgeW) $
|
||||
vertCat $
|
||||
intersperse (char defAttr ' ')
|
||||
[
|
||||
@ -160,6 +164,8 @@ drawNestedWorld locMap world =
|
||||
| dy <- [-1 .. 1]
|
||||
]
|
||||
where
|
||||
edgeW = max 0 (drW - w) `div` 2
|
||||
edgeH = max 0 (drH - h) `div` 2
|
||||
infinityImage = makeInfinity h w
|
||||
(h, w) = worldSize world
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user