117 lines
3.8 KiB
Haskell
117 lines
3.8 KiB
Haskell
module Main (main) where
|
|
|
|
import Control.Exception ( bracket )
|
|
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 Model
|
|
import Rendering ( render )
|
|
import Parser (parse)
|
|
import BigFont
|
|
|
|
data Game = Game {
|
|
gameFlat :: Bool,
|
|
gameMode :: GameMode,
|
|
gameSelect :: Int
|
|
}
|
|
|
|
data GameMode
|
|
= MenuMode
|
|
| PlayMode (NonEmpty World)
|
|
|
|
getWorldList :: IO (Map String FilePath)
|
|
getWorldList =
|
|
do paths <- sort <$> listDirectory "levels"
|
|
pure (Map.fromList [(takeBaseName path, "levels" </> path) | path <- paths])
|
|
|
|
main :: IO ()
|
|
main =
|
|
do args <- getArgs
|
|
worldList <- getWorldList
|
|
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
|
|
}
|
|
|
|
loop :: Vty -> Game -> IO ()
|
|
loop vty game =
|
|
case gameMode game of
|
|
MenuMode ->
|
|
do worldList <- getWorldList
|
|
bnds <- displayBounds (outputIface vty)
|
|
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 | (_, path) <- Map.elemAt (gameSelect game) worldList ->
|
|
do world <- parse <$> readFile path
|
|
loop vty game{ gameMode = PlayMode (pure world) }
|
|
_ -> loop vty game
|
|
_ -> loop vty game
|
|
|
|
PlayMode worlds ->
|
|
do let world = NonEmpty.head worlds
|
|
update vty (render (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 -> pure ()
|
|
KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) }
|
|
_ -> loop vty game
|
|
_ -> loop vty game
|
|
|
|
|
|
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 =
|
|
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
|