haskelloids/src/Menu.hs
2017-12-21 00:56:16 +01:00

87 lines
2.2 KiB
Haskell

module Menu where
import Affection as A
import qualified SDL
import Debug.Trace
import Data.Maybe
import qualified Data.Set as S
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import NanoVG hiding (V2(..), V4(..))
import Linear
import Foreign.C.Types
-- internal imports
import Types
import Commons
loadMenu :: (Affection UserData ()) -> Affection UserData ()
loadMenu stateChange = do
liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection
hs <- newHaskelloids
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"
quit
SDL.KeycodeSpace -> do
liftIO $ logIO A.Debug "Leaving Menu to Game"
stateChange
_ -> return ()
)
putAffection ud
{ haskelloids = hs
, fade = FadeIn 1
, state = Menu
, stateUUIDs = UUIDClean [] [kbdUUID]
-- , shots = (shots ud)
-- { partSysParts = ParticleStorage Nothing [] }
}
updateMenu :: Double -> Affection UserData ()
updateMenu sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
case fade ud of
FadeIn ttl -> do
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
FadeOut ttl -> do
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
}
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
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"
fillColor ctx (rgba 0 128 255 (alpha $ fade ud))
fontSize ctx 40
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
restore ctx