add a simple level select menu
This commit is contained in:
parent
14c8d62646
commit
997c624465
319
app/Main.hs
319
app/Main.hs
@ -7,52 +7,101 @@ import Data.List.NonEmpty (NonEmpty(..))
|
|||||||
import Data.List.NonEmpty qualified as NonEmpty
|
import Data.List.NonEmpty qualified as NonEmpty
|
||||||
import Data.Set qualified as Set
|
import Data.Set qualified as Set
|
||||||
import System.Environment ( getArgs )
|
import System.Environment ( getArgs )
|
||||||
|
import Data.Map (Map)
|
||||||
|
import Data.Map qualified as Map
|
||||||
|
|
||||||
import Model
|
import Model
|
||||||
import Rendering ( render )
|
import Rendering ( render )
|
||||||
import Parser (parse)
|
import Parser (parse)
|
||||||
|
|
||||||
data Game = Game {
|
data Game = Game {
|
||||||
gameWorlds :: NonEmpty World,
|
gameFlat :: Bool,
|
||||||
gameFlat :: Bool
|
gameMode :: GameMode,
|
||||||
|
gameSelect :: Int
|
||||||
}
|
}
|
||||||
|
|
||||||
|
data GameMode
|
||||||
|
= MenuMode
|
||||||
|
| PlayMode (NonEmpty World)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main =
|
main =
|
||||||
do args <- getArgs
|
do args <- getArgs
|
||||||
case args of
|
bracket (mkVty =<< userConfig) shutdown \vty ->
|
||||||
x:_ | Just w <- Map.lookup x worldList ->
|
case args of
|
||||||
bracket (mkVty =<< userConfig) shutdown \vty ->
|
x:_ | Just w <- Map.lookup x worldList ->
|
||||||
loop vty Game {
|
loop vty Game {
|
||||||
gameWorlds = pure w,
|
gameMode = PlayMode (pure w),
|
||||||
gameFlat = True
|
gameFlat = True,
|
||||||
|
gameSelect = Map.findIndex x worldList
|
||||||
|
|
||||||
}
|
}
|
||||||
_ ->
|
_ ->
|
||||||
do putStrLn "Usage: parabox <worldname>"
|
loop vty Game {
|
||||||
putStrLn ""
|
gameMode = MenuMode,
|
||||||
putStrLn "Available worlds:"
|
gameFlat = True,
|
||||||
mapM_ putStrLn (Map.keys worldList)
|
gameSelect = 0
|
||||||
|
}
|
||||||
|
|
||||||
loop :: Vty -> Game -> IO ()
|
loop :: Vty -> Game -> IO ()
|
||||||
loop vty game =
|
loop vty game =
|
||||||
do let world = NonEmpty.head (gameWorlds game)
|
case gameMode game of
|
||||||
update vty (render (gameFlat game) (NonEmpty.head (gameWorlds game)))
|
MenuMode ->
|
||||||
ev <- nextEvent vty
|
do let (a,b) = Map.splitAt (gameSelect game) worldList
|
||||||
case ev of
|
bnds <- displayBounds (outputIface vty)
|
||||||
EvKey key _modifier ->
|
update vty (picForImage (renderMenu bnds a b))
|
||||||
case key of
|
ev <- nextEvent vty
|
||||||
KUp -> loop vty game{ gameWorlds = NonEmpty.cons (move world (-1,0)) (gameWorlds game) }
|
case ev of
|
||||||
KDown -> loop vty game{ gameWorlds = NonEmpty.cons (move world (1,0) ) (gameWorlds game) }
|
EvKey key _modifier ->
|
||||||
KLeft -> loop vty game{ gameWorlds = NonEmpty.cons (move world (0,-1)) (gameWorlds game) }
|
case key of
|
||||||
KRight -> loop vty game{ gameWorlds = NonEmpty.cons (move world (0,1) ) (gameWorlds game) }
|
KEsc -> pure ()
|
||||||
KChar 'r' -> loop vty game{ gameWorlds = pure (NonEmpty.last (gameWorlds game)) }
|
KUp | gameSelect game > 0 -> loop vty game{ gameSelect = gameSelect game - 1 }
|
||||||
KChar 'z'
|
KDown | gameSelect game + 1 < Map.size worldList -> loop vty game{ gameSelect = gameSelect game + 1 }
|
||||||
| Just worlds <- NonEmpty.nonEmpty (NonEmpty.tail (gameWorlds game)) ->
|
KEnter | Just (world,_) <- Map.minView b -> loop vty game{ gameMode = PlayMode (pure world) }
|
||||||
loop vty game{ gameWorlds = worlds }
|
_ -> loop vty game
|
||||||
KEsc -> pure ()
|
|
||||||
KChar 'f' -> loop vty game{ gameFlat = not (gameFlat game) }
|
|
||||||
_ -> loop vty game
|
_ -> 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 ->
|
||||||
|
case key of
|
||||||
|
KUp -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (-1,0)) worlds) }
|
||||||
|
KDown -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (1,0) ) worlds) }
|
||||||
|
KLeft -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,-1)) worlds) }
|
||||||
|
KRight -> loop vty game{ gameMode = PlayMode (NonEmpty.cons (move world (0,1) ) worlds) }
|
||||||
|
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 :: DisplayRegion -> Map String World -> Map String World -> Image
|
||||||
|
renderMenu (w,h) before after =
|
||||||
|
pad ((w - imageWidth menu) `div` 2) 0 0 0 menu
|
||||||
|
where
|
||||||
|
menu =
|
||||||
|
case Map.minViewWithKey after of
|
||||||
|
Nothing -> string defAttr "empty menu"
|
||||||
|
Just ((k,_),after') ->
|
||||||
|
let len1 = (h-1)`div`2 in
|
||||||
|
pad 0 (len1 - Map.size before) 0 0 (vertCat
|
||||||
|
[ string defAttr x
|
||||||
|
| x <- drop (Map.size before - len1) (Map.keys before)
|
||||||
|
]) <->
|
||||||
|
string (defAttr `withBackColor` cyan `withForeColor` white) k
|
||||||
|
<->
|
||||||
|
vertCat
|
||||||
|
[ string defAttr x
|
||||||
|
| x <- drop (Map.size after' - h`div`2) (Map.keys after')
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
worldList :: Map.Map String World
|
worldList :: Map.Map String World
|
||||||
@ -63,6 +112,9 @@ worldList = Map.fromList
|
|||||||
, ("center13", center13)
|
, ("center13", center13)
|
||||||
, ("clone11", clone11)
|
, ("clone11", clone11)
|
||||||
, ("transfer14", transfer14)
|
, ("transfer14", transfer14)
|
||||||
|
, ("transfer20", transfer20)
|
||||||
|
, ("transfer26", transfer26)
|
||||||
|
, ("transfer27", transfer27)
|
||||||
, ("open4", open4)
|
, ("open4", open4)
|
||||||
, ("cycle10", cycle10)
|
, ("cycle10", cycle10)
|
||||||
, ("player10", player10)
|
, ("player10", player10)
|
||||||
@ -1267,4 +1319,213 @@ multiInfinite8 = parse
|
|||||||
\▓▓▓▓▓▓▓▓▓\n\
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
\▓▓▓▓▓▓▓▓▓\n\
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
\▓▓▓▓▓▓▓▓▓\n\
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n"
|
||||||
|
|
||||||
|
|
||||||
|
transfer20 :: World
|
||||||
|
transfer20 = parse
|
||||||
|
"player p\n\
|
||||||
|
\block t blue boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓t▓a▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block a blue interesting\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓ ▓ ▓\n\
|
||||||
|
\▓ ▓\n\
|
||||||
|
\▓ ABC ▓\n\
|
||||||
|
\▓ p ▓\n\
|
||||||
|
\▓ XYZ ▓\n\
|
||||||
|
\▓ ▓\n\
|
||||||
|
\▓ ▓ ▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\link A C cyan\n\
|
||||||
|
\link B C cyan\n\
|
||||||
|
\block C cyan interesting\n\
|
||||||
|
\▓▓▓▓▓ ▓ ▓\n\
|
||||||
|
\▓▓▓▓▓ ▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\ ▓▓▓▓▓▓▓\n\
|
||||||
|
\▓ ▓▓▓▓▓▓▓\n\
|
||||||
|
\▓ ▓▓▓▓▓▓▓\n\
|
||||||
|
\▓ ▓▓▓▓▓=▓\n\
|
||||||
|
\▓ ▓▓▓▓▓ ▓\n\
|
||||||
|
\link X Z green\n\
|
||||||
|
\link Y Z green\n\
|
||||||
|
\block Z green interesting\n\
|
||||||
|
\▓ ▓ ▓▓▓▓▓\n\
|
||||||
|
\▓ ▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓ ▓▓▓\n\
|
||||||
|
\▓▓▓ ▓ ▓▓▓\n\
|
||||||
|
\block p magenta boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓ ▓▓▓ ▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n"
|
||||||
|
|
||||||
|
transfer26 :: World
|
||||||
|
transfer26 = parse
|
||||||
|
"player p\n\
|
||||||
|
\block t blue boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓t▓a▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block a blue interesting\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓ ▓▓\n\
|
||||||
|
\▓ ▓\n\
|
||||||
|
\▓ T x 1 ▓\n\
|
||||||
|
\▓ ▓\n\
|
||||||
|
\▓ p 3 2 ▓\n\
|
||||||
|
\▓ ▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block x yellow boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block 1 cyan interesting\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓ ▓▓\n\
|
||||||
|
\ ▓▓ ▓▓\n\
|
||||||
|
\ ▓▓ ▓▓\n\
|
||||||
|
\ ▓▓ ▓▓\n\
|
||||||
|
\▓▓▓▓▓▓ ▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block 2 cyan interesting\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓ ▓\n\
|
||||||
|
\ ▓▓▓ ▓\n\
|
||||||
|
\ ▓▓▓ ▓\n\
|
||||||
|
\ ▓▓ ▓▓\n\
|
||||||
|
\▓▓▓▓▓▓ ▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block 3 cyan interesting\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓ ▓▓▓▓▓▓\n\
|
||||||
|
\▓▓ ▓▓ \n\
|
||||||
|
\▓ ▓▓ \n\
|
||||||
|
\▓▓ ▓▓ \n\
|
||||||
|
\▓ ▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block T green interesting\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\ \n\
|
||||||
|
\▓▓▓ = ▓▓▓\n\
|
||||||
|
\▓▓▓ ▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block p magenta boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓ ▓▓▓ ▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n"
|
||||||
|
|
||||||
|
transfer27 :: World
|
||||||
|
transfer27 = parse
|
||||||
|
"player p\n\
|
||||||
|
\block t white boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓t▓ab▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\link A a blue\n\
|
||||||
|
\block a blue interesting\n\
|
||||||
|
\▓▓ y \n\
|
||||||
|
\▓▓ \n\
|
||||||
|
\▓▓ \n\
|
||||||
|
\▓ \n\
|
||||||
|
\▓B p \n\
|
||||||
|
\▓ \n\
|
||||||
|
\▓▓ \n\
|
||||||
|
\▓▓ \n\
|
||||||
|
\▓▓ x \n\
|
||||||
|
\link B b red\n\
|
||||||
|
\block b red interesting\n\
|
||||||
|
\ ▓▓\n\
|
||||||
|
\ ▓▓\n\
|
||||||
|
\ ▓▓\n\
|
||||||
|
\ ▓\n\
|
||||||
|
\ =-- A▓\n\
|
||||||
|
\ ▓\n\
|
||||||
|
\ ▓▓\n\
|
||||||
|
\ ▓▓\n\
|
||||||
|
\ ▓▓\n\
|
||||||
|
\block x yellow boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block y yellow boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\block p magenta boring\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓ ▓▓▓ ▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
|
\▓▓▓▓▓▓▓▓▓\n\
|
||||||
\▓▓▓▓▓▓▓▓▓\n"
|
\▓▓▓▓▓▓▓▓▓\n"
|
||||||
Loading…
Reference in New Issue
Block a user