143 lines
4.8 KiB
Haskell
143 lines
4.8 KiB
Haskell
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.Map (Map)
|
|
import Data.Map qualified as Map
|
|
import Graphics.Vty
|
|
import Graphics.Vty.CrossPlatform
|
|
import Data.Ord (clamp)
|
|
import System.Directory (listDirectory)
|
|
import System.Environment (getArgs)
|
|
import System.FilePath ((</>), takeBaseName, takeExtension)
|
|
|
|
import BigFont (bigText)
|
|
import Model
|
|
import Parser (parse)
|
|
import Rendering (render, wrapBox)
|
|
|
|
data Game = Game {
|
|
gameFlat :: Bool,
|
|
gameMode :: GameMode,
|
|
gameSelect :: Int,
|
|
gameError :: String
|
|
}
|
|
|
|
data GameMode
|
|
= MenuMode
|
|
| PlayMode (NonEmpty World)
|
|
|
|
getWorldList :: IO (Map String FilePath)
|
|
getWorldList =
|
|
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
|
|
worldList <- getWorldList
|
|
bracket (mkVty =<< userConfig) shutdown \vty ->
|
|
case args of
|
|
x:_ | Just path <- Map.lookup x worldList ->
|
|
loadLevelFile vty defaultGame path
|
|
_ -> loop vty defaultGame
|
|
|
|
loop :: Vty -> Game -> IO ()
|
|
loop vty game = do
|
|
bnds <- displayBounds (outputIface vty)
|
|
case gameMode game of
|
|
MenuMode ->
|
|
do worldList <- getWorldList
|
|
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 -> 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 bnds (gameFlat game) (NonEmpty.head worlds))
|
|
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 (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'
|
|
| Just worlds' <- NonEmpty.nonEmpty (NonEmpty.tail worlds) ->
|
|
loop vty game{ gameMode = PlayMode worlds' }
|
|
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 = "" }
|
|
|
|
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
|
|
hpad = h`div`2 - sel*6
|
|
wpad = max 0 (w - imageWidth menu) `div` 2
|
|
menu =
|
|
vertCat $
|
|
intersperse (char defAttr ' ') $
|
|
[ bigString (if sel == i then defAttr `withBackColor` cyan `withForeColor` white
|
|
else defAttr) k
|
|
| (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
|