tracer/src/Menu.hs
2018-10-08 23:36:52 +02:00

76 lines
1.7 KiB
Haskell

module Menu where
import Affection as A
import qualified SDL
import NanoVG
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
import Control.Monad (when)
-- internal imports
import Types
loadMenu :: Affection UserData ()
loadMenu = do
ud <- getAffection
ad <- get
let (Subsystems _ m _ j _) = subsystems ud
uu1 <- partSubscribe j joystickConnect
uu2 <- partSubscribe j joyDisconnect
putAffection ud
{ uuid = [ uu1, uu2 ]
, state = Menu
}
joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect msg = do
ud <- getAffection
when (isNothing $ joystick ud) $ do
mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
putAffection ud
{ joystick = Just joy
, translation = defaultTranslation
}
) mjoy
joyDisconnect :: JoystickMessage -> Affection UserData ()
joyDisconnect msg = do
ud <- getAffection
maybe (return ()) (\joy -> do
njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected"
putAffection ud
{ joystick = Nothing
}
) (joystick ud)
updateMenu :: Double -> Affection UserData ()
updateMenu dt = return ()
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
liftIO $ do
let ctx = nano ud
controller = joystick ud
save ctx
beginPath ctx
paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
if isNothing controller
then IconContrBlue
else IconContrGreen
) 1
rect ctx 600 620 80 80
fillPaint ctx paint
fill ctx
restore ctx