From dc91005deed93f66ef9e35fa6e340c9c64f4901d Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 12 Oct 2018 21:40:16 +0200 Subject: [PATCH] implement controller adjustments --- src/Menu/Adjust.hs | 86 ++++++++++++++++++++++++++++++++++ src/Menu/Connect.hs | 104 ++++++++++++++++++++++++++++++------------ src/StateMachine.hs | 20 +++----- src/Types/UserData.hs | 10 ++-- src/Util.hs | 20 +++++++- tracer-game.cabal | 1 + 6 files changed, 191 insertions(+), 50 deletions(-) create mode 100644 src/Menu/Adjust.hs diff --git a/src/Menu/Adjust.hs b/src/Menu/Adjust.hs new file mode 100644 index 0000000..9ae9cd6 --- /dev/null +++ b/src/Menu/Adjust.hs @@ -0,0 +1,86 @@ +module Menu.Adjust where + +import Affection as A + +import qualified SDL + +import NanoVG + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.List (find) +import Data.Maybe (fromJust, isJust) + +-- internal imports + +import Types +import Util + +loadAdjust :: Action -> Affection UserData () -> Affection UserData () +loadAdjust sub switchBack = do + ud <- getAffection + let Subsystems w m k j t = subsystems ud + uu1 <- partSubscribe j (listener switchBack) + putAffection ud + { state = Menu (Adjust sub) + , uuid = [ uu1 ] + } + +listener :: Affection UserData () -> JoystickMessage -> Affection UserData () +listener switchBack (MsgJoystickAxis _ _ axis val) = do + ud <- getAffection + liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis) + case state ud of + Menu (Adjust (UpDown s)) -> do + let k = fst <$> find (\(_, v) -> v == UpDown 1 || v == UpDown (-1)) (M.assocs $ translation ud) + putAffection ud + { translation = + M.insert (AxisAction $ fromIntegral axis) (UpDown (fromIntegral $ -signum val)) $ + if isJust k then M.delete (fromJust k) (translation ud) else translation ud + } + Menu (Adjust (LeftRight s)) -> do + let k = fst <$> find (\(_, v) -> v == LeftRight 1 || v == LeftRight (-1)) (M.assocs $ translation ud) + putAffection ud + { translation = + M.insert (AxisAction $ fromIntegral axis) (LeftRight (fromIntegral $ signum val)) $ + if isJust k then M.delete (fromJust k) (translation ud) else translation ud + } + fullClean + switchBack +listener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do + ud <- getAffection + case state ud of + Menu (Adjust (Activate)) -> do + let k = fst <$> find (\(_, v) -> case v of + Activate -> True + _ -> False + ) (M.assocs $ translation ud) + putAffection ud + { translation = + M.insert (ButtonAction but SDL.JoyButtonPressed) Activate $ + if isJust k then M.delete (fromJust k) (translation ud) else translation ud + } + fullClean + switchBack +listener _ _ = return () + +drawAdjust :: Affection UserData () +drawAdjust = do + ud <- getAffection + liftIO $ do + let ctx = nano ud + save ctx + beginPath ctx + roundedRect ctx 440 310 400 100 10 + strokeWidth ctx 5 + strokeColor ctx (rgb 255 255 255) + fillColor ctx (rgb 255 255 255) + closePath ctx + stroke ctx + fill ctx + fontSize ctx 50 + fontFace ctx "bedstead" + textAlign ctx (S.fromList [AlignCenter, AlignTop]) + fillColor ctx (rgb 0 0 0) + textBox ctx 440 310 400 "Enter new movement ..." + restore ctx diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs index 280ff06..9d28b5b 100644 --- a/src/Menu/Connect.hs +++ b/src/Menu/Connect.hs @@ -18,6 +18,7 @@ import Control.Monad import Types import Util +import Menu.Adjust loadMenu :: Affection UserData () loadMenu = do @@ -31,7 +32,7 @@ loadMenu = do uu5 <- partSubscribe m handleClicks partUnSubscribe j (joyUUID ud) putAffection ud - { uuid = [ uu1, uu2, uu3, uu4 ] + { uuid = [ uu1, uu2, uu3, uu4, uu5 ] , state = Menu Connect , stateData = MenuData (V2 0 0) S 0 , joyCache = [] @@ -91,11 +92,39 @@ 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) adjustUpDown + when (arrowUp rels || arrowDown rels) (adjustUpDown rels) + when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels) + when (buttonActivate rels) (adjustActivate) where - adjustUpDown = liftIO $ logIO A.Debug "TODO: adjustUpDown" + adjustUpDown rels = do + if arrowUp rels + then do + fullClean + loadAdjust (UpDown 1) loadMenu + else do + fullClean + loadAdjust (UpDown (-1)) loadMenu + adjustLeftRight rels = do + if arrowLeft rels + then do + fullClean + loadAdjust (LeftRight 1) loadMenu + else do + fullClean + loadAdjust (LeftRight (-1)) loadMenu + adjustActivate = do + fullClean + loadAdjust Activate loadMenu arrowUp (V2 rx ry) = rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720 + arrowDown (V2 rx ry) = + rx > 310 / 1280 && rx < 410 / 1280 && ry > 430 / 720 && ry < 530 / 720 + arrowLeft (V2 rx ry) = + rx > 190 / 1280 && rx < 290 / 1280 && ry > 310 / 720 && ry < 410 / 720 + arrowRight (V2 rx ry) = + rx > 430 / 1280 && rx < 530 / 1280 && ry > 310 / 720 && ry < 410 / 720 + buttonActivate (V2 rx ry) = + rx > 650 / 1280 && rx < 800 / 1280 && ry > 160 / 720 && ry < 210 / 720 handleClicks _ = return () updateMenu :: Double -> Affection UserData () @@ -129,8 +158,8 @@ drawMenu = do beginPath ctx roundedRect ctx 140 110 1000 500 25 strokeWidth ctx 5 - fillColor ctx (rgba 255 255 255 128) - strokeColor ctx (rgba 255 255 255 255) + fillColor ctx (rgba 255 255 255 64) + strokeColor ctx (rgb 255 255 255) stroke ctx fill ctx mapM_ (\deg -> do @@ -143,56 +172,64 @@ drawMenu = do rotate ctx (dtor deg) translate ctx (-50) (-50) case deg of - 0 -> when (vx < 0) $ do - beginPath ctx - fillColor ctx (rgb 255 128 0) - roundedRect ctx 0 0 100 100 10 - closePath ctx - fill ctx + 0 -> do + when (vy < 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx case state ud of Menu (Adjust (UpDown _)) -> do + beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx _ -> return () - 90 -> when (vy > 0) $ do - beginPath ctx - fillColor ctx (rgb 255 128 0) - roundedRect ctx 0 0 100 100 10 - closePath ctx - fill ctx + 90 -> do + when (vx > 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx case state ud of Menu (Adjust (LeftRight _)) -> do + beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx _ -> return () - 180 -> when (vx > 0) $ do - beginPath ctx - fillColor ctx (rgb 255 128 0) - roundedRect ctx 0 0 100 100 10 - closePath ctx - fill ctx + 180 -> do + when (vy > 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx case state ud of Menu (Adjust (UpDown _)) -> do + beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx _ -> return () - 270 -> when (vy < 0) $ do - beginPath ctx - fillColor ctx (rgb 255 128 0) - roundedRect ctx 0 0 100 100 10 - closePath ctx - fill ctx + 270 -> do + when (vx < 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx case state ud of Menu (Adjust (LeftRight _)) -> do + beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 closePath ctx @@ -212,6 +249,15 @@ drawMenu = do fillColor ctx (rgb 255 128 0) roundedRect ctx 650 160 150 50 10 fill ctx + case state ud of + Menu (Adjust Activate) -> do + beginPath ctx + fillColor ctx (rgb 0 255 0) + roundedRect ctx 650 160 150 50 10 + closePath ctx + fill ctx + _ -> + return () roundedRect ctx 650 160 150 50 10 strokeWidth ctx 2 stroke ctx diff --git a/src/StateMachine.hs b/src/StateMachine.hs index aae0684..55ae2d8 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -8,21 +8,26 @@ import Types import Load import Menu.Connect +import Menu.Adjust import MainGame.WorldMap import MainGame.MindMap +import Util instance StateMachine State UserData where smLoad Load = loadLoad smLoad (Menu Connect) = loadMenu + -- smLoad (Menu (Adjust _)) = loadAdjust smLoad (Main _) = loadMap smUpdate Load = updateLoad smUpdate (Menu Connect) = updateMenu + smUpdate (Menu (Adjust _)) = const (return ()) smUpdate (Main WorldMap) = updateMap smUpdate (Main MindMap) = updateMind smDraw Load = drawLoad smDraw (Menu Connect) = drawMenu + smDraw (Menu (Adjust _)) = drawMenu >> drawAdjust smDraw (Main WorldMap) = drawMap smDraw (Main MindMap) = drawMind @@ -34,17 +39,4 @@ instance StateMachine State UserData where consumeSDLEvents m evs return () - smClean _ = do - ud <- getAffection - let Subsystems w m k j t = subsystems ud - toClean = uuid ud - mapM_ (\u -> do - partUnSubscribe w u - partUnSubscribe m u - partUnSubscribe k u - partUnSubscribe j u - partUnSubscribe t u - ) toClean - putAffection ud - { uuid = [] - } + smClean _ = fullClean diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 06990d3..f9ab08a 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -51,23 +51,23 @@ data State = Load | Menu SubMenu | Main SubMain - deriving (Eq) + deriving (Eq, Show) data SubMain = WorldMap | MindMap - deriving (Eq) + deriving (Eq, Show) data SubMenu = Connect | Adjust Action - deriving (Eq) + deriving (Eq, Show) defaultTranslation :: M.Map GamepadAction Action defaultTranslation = M.fromList [ (ButtonAction 0 SDL.JoyButtonPressed, Activate) - , (AxisAction 0, UpDown 0) - , (AxisAction 1, LeftRight 0) + , (AxisAction 1, UpDown 1) + , (AxisAction 0, LeftRight 1) ] data Action diff --git a/src/Util.hs b/src/Util.hs index ddd4e47..7e37c3c 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -295,8 +295,8 @@ emitActionMessage (MsgJoystickAxis time _ axis val) = do ud <- getAffection let Subsystems _ _ _ _ t = subsystems ud case (translation ud) Map.!? (AxisAction axis) of - Just (UpDown _) -> partEmit t (ActionMessage (UpDown (fromIntegral val)) time) - Just (LeftRight _) -> partEmit t (ActionMessage (LeftRight (fromIntegral val)) time) + Just (UpDown s) -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time) + Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time) _ -> return () emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do ud <- getAffection @@ -305,3 +305,19 @@ emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do Just Activate -> partEmit t (ActionMessage Activate time) _ -> return () emitActionMessage _ = return () + +fullClean :: Affection UserData () +fullClean = do + ud <- getAffection + let Subsystems w m k j t = subsystems ud + toClean = uuid ud + mapM_ (\u -> do + partUnSubscribe w u + partUnSubscribe m u + partUnSubscribe k u + partUnSubscribe j u + partUnSubscribe t u + ) toClean + putAffection ud + { uuid = [] + } diff --git a/tracer-game.cabal b/tracer-game.cabal index 4d7dc6f..6ed2a0a 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -41,6 +41,7 @@ executable tracer-game , Init , Load , Menu.Connect + , Menu.Adjust , MainGame.WorldMap , MainGame.MindMap , Navigation