From 0497c9747501d33cfc7fe2b7c67fb95014f26caa Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 11 Feb 2019 16:11:27 +0100 Subject: [PATCH] retrofitting --- src/Init.hs | 2 +- src/Load.hs | 14 +++++++-- src/Menu/Connect.hs | 66 +++++++++++++++++++++++++++---------------- src/Types/ImgId.hs | 2 ++ src/Types/UserData.hs | 4 +-- src/Util.hs | 4 +-- 6 files changed, 60 insertions(+), 32 deletions(-) diff --git a/src/Init.hs b/src/Init.hs index 0a97706..4abd4c1 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -46,7 +46,7 @@ init = do , uuid = [] , stateData = None , threadContext = Nothing - , joystick = Nothing + , controls = NoController , translation = defaultTranslation , joyCache = [] } diff --git a/src/Load.hs b/src/Load.hs index 44213b7..bafea43 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -73,12 +73,22 @@ loadFork ws win glc nvg future progress = do mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0 modifyMVar_ progress (return . (\(p, _) -> ( p + increment - , "Loading icon \"conntroller_green\"" + , "Loading icon \"controller_blue\"" ))) mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0 modifyMVar_ progress (return . (\(p, _) -> ( p + increment - , "Loading icon \"arrow\"" + , "Loading icon \"controller_green\"" + ))) + mcontrblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0 + modifyMVar_ progress (return . (\(p, _) -> + ( p + increment + , "Loading icon \"keyboard_blue\"" + ))) + mcontrgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0 + modifyMVar_ progress (return . (\(p, _) -> + ( p + increment + , "Loading icon \"keyboard_green\"" ))) marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0 modifyMVar_ progress (return . (\(p, _) -> diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs index eab15e1..35c9d3b 100644 --- a/src/Menu/Connect.hs +++ b/src/Menu/Connect.hs @@ -31,7 +31,7 @@ loadMenu = do uu3 <- partSubscribe j emitJoyActionMessage uu4 <- partSubscribe t handleActionMessages uu5 <- partSubscribe m handleClicks - uu6 <- partSubscribe k emitKbdActionMessage + -- uu6 <- partSubscribe k emitKbdActionMessage partUnSubscribe j (joyUUID ud) putAffection ud { uuid = [ uu1, uu2, uu3, uu4, uu5 ] @@ -44,27 +44,28 @@ loadMenu = do joystickConnect :: JoystickMessage -> Affection UserData () joystickConnect msg = do ud <- getAffection - when (isNothing $ joystick ud) $ do + when (controls ud == NoController) $ do mjoy <- joystickAutoConnect msg maybe (return ()) (\joy -> do ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident putAffection ud - { controls = Joystick + { controls = Joystick joy } ) mjoy joystickDisconnect :: JoystickMessage -> Affection UserData () joystickDisconnect msg = do ud <- getAffection - maybe (return ()) (\joy -> do - njoys <- joystickAutoDisconnect [joy] msg - when (null njoys) $ do - liftIO $ logIO A.Debug $ "Joystick disconnected" - putAffection ud - { Controls = None - } - ) (joystick ud) + case controls ud of + Joystick joy -> do + njoys <- joystickAutoDisconnect [joy] msg + when (null njoys) $ do + liftIO $ logIO A.Debug $ "Joystick disconnected" + putAffection ud + { controls = None + } + _ -> return () handleActionMessages :: ActionMessage -> Affection UserData () handleActionMessages (ActionMessage Activate _) = do @@ -100,12 +101,16 @@ handleActionMessages (ActionMessage (LeftRight f) _) = do handleClicks :: MouseMessage -> Affection UserData () handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do - rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) - when (arrowUp rels || arrowDown rels) (adjustUpDown rels) - when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels) - when (buttonActivate rels) (adjustActivate) - when (buttonSwitchMap rels) (adjustSwitchMap) - when (buttonPlay rels) (enterGame) + ud <- getAffection + case controls ud of + Joystick -> do + rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) + when (arrowUp rels || arrowDown rels) (adjustUpDown rels) + when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels) + when (buttonActivate rels) (adjustActivate) + when (buttonSwitchMap rels) (adjustSwitchMap) + when (buttonPlay rels) (enterGame) + _ -> return () where adjustUpDown rels = do if arrowUp rels @@ -172,15 +177,26 @@ drawMenu = do controller = controls ud save ctx beginPath ctx - paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.! - if isNothing controller - then IconContrBlue - else IconContrGreen + cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.! + case controller of + Joystick -> IconContrGreen + _ -> IconContrBlue ) 1 rect ctx 600 620 80 80 - fillPaint ctx paint + fillPaint ctx cpaint + endPath ctx fill ctx - when (controller /= None) $ do + beginPath ctx + cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.! + case controller of + Keyboard -> IconKbdGreen + _ -> IconKbdBlue + ) 1 + rect ctx 600 620 80 80 + fillPaint ctx cpaint + endPath ctx + fill ctx + when (controller /= NoController) $ do let V2 vx vy = velocity $ stateData ud beginPath ctx roundedRect ctx 140 110 1000 500 25 @@ -264,9 +280,9 @@ drawMenu = do _ -> return () beginPath ctx - paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1 + apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1 rect ctx 0 0 100 100 - fillPaint ctx paint + fillPaint ctx apaint closePath ctx fill ctx restore ctx diff --git a/src/Types/ImgId.hs b/src/Types/ImgId.hs index e720d69..206f9df 100644 --- a/src/Types/ImgId.hs +++ b/src/Types/ImgId.hs @@ -3,6 +3,8 @@ module Types.ImgId where data IconId = IconContrBlue | IconContrGreen + | IconKbdBlue + | IconKbdGreen | IconArrow deriving (Show, Eq, Ord, Enum) diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index d0430d4..433891b 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -48,9 +48,9 @@ data UserData = UserData } data Controller - = None + = NoController | Keyboard - | Joystick + | Joystick SDL.Joystick deriving (Eq, Show) data State diff --git a/src/Util.hs b/src/Util.hs index c2644d4..9cd61fe 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -304,8 +304,8 @@ cacheJoypad msg = do { joyCache = msg : joyCache ud } -emitActionMessage :: JoystickMessage -> Affection UserData () -emitActionMessage (MsgJoystickAxis time _ axis val) = do +emitJoyActionMessage :: JoystickMessage -> Affection UserData () +emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do ud <- getAffection let Subsystems _ _ _ _ t = subsystems ud case (translation ud) Map.!? (AxisAction axis) of