70 lines
2.2 KiB
Haskell
70 lines
2.2 KiB
Haskell
module Menu where
|
|
|
|
import Affection as A
|
|
import qualified SDL
|
|
|
|
import qualified Data.Set as S
|
|
|
|
import Control.Monad
|
|
|
|
import Control.Concurrent.MVar
|
|
|
|
import NanoVG
|
|
|
|
-- internal imports
|
|
|
|
import Types
|
|
import Commons
|
|
|
|
loadMenu :: Affection () -> UserData -> Affection ()
|
|
loadMenu stateChange ud = do
|
|
liftIO $ logIO A.Debug "Loading Menu"
|
|
hs <- newHaskelloids (haskImage ud)
|
|
kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
|
|
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
|
|
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
|
SDL.KeycodeEscape -> do
|
|
liftIO $ logIO A.Debug "seeya"
|
|
void $ liftIO $ swapMVar (doNextStep ud) False
|
|
SDL.KeycodeSpace -> do
|
|
liftIO $ logIO A.Debug "Leaving Menu to Game"
|
|
stateChange
|
|
_ -> return ()
|
|
)
|
|
void $ liftIO $ swapMVar (haskelloids ud) hs
|
|
void $ liftIO $ swapMVar (fade ud) (FadeIn 1)
|
|
void $ liftIO $ swapMVar (state ud) Menu
|
|
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kbdUUID])
|
|
|
|
updateMenu :: UserData -> Double -> Affection ()
|
|
updateMenu ud sec = do
|
|
nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar (haskelloids ud))
|
|
void $ liftIO $ swapMVar (haskelloids ud) nhs
|
|
fadeState <- liftIO (readMVar $ fade ud)
|
|
case fadeState of
|
|
FadeIn ttl ->
|
|
void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1)
|
|
FadeOut ttl ->
|
|
void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1)
|
|
|
|
drawMenu :: UserData -> Affection ()
|
|
drawMenu ud = do
|
|
hasks <- liftIO $ readMVar (haskelloids ud)
|
|
mapM_ (drawHaskelloid (nano ud)) hasks
|
|
liftIO $ do
|
|
let ctx = nano ud
|
|
alpha fio = case fio of
|
|
FadeIn d -> floor (255 * (1 - d))
|
|
FadeOut d -> floor (255 * d)
|
|
save ctx
|
|
fontSize ctx 120
|
|
fontFace ctx "modulo"
|
|
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
|
fillColor ctx (rgba 255 255 255 255)
|
|
textBox ctx 0 200 800 "HASKELLOIDS"
|
|
fadeState <- readMVar (fade ud)
|
|
fillColor ctx (rgba 0 128 255 (alpha $ fadeState))
|
|
fontSize ctx 40
|
|
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
|
|
restore ctx
|