From c9dd91927e4954e610d2853e815e338d1f24787a Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Feb 2019 00:11:53 +0100 Subject: [PATCH] keyboard controls finished --- src/Init.hs | 2 +- src/Load.hs | 6 +- src/MainGame/WorldMap.hs | 186 +++++++++++++++++++++++++-------------- src/Menu/Adjust.hs | 92 ++++++++++++------- src/Menu/Connect.hs | 149 +++++++++++++++++++++---------- src/StateMachine.hs | 4 +- src/Types/UserData.hs | 50 +++++++---- src/Util.hs | 50 ++++++++--- 8 files changed, 362 insertions(+), 177 deletions(-) diff --git a/src/Init.hs b/src/Init.hs index 4abd4c1..c5181d3 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -47,7 +47,7 @@ init = do , stateData = None , threadContext = Nothing , controls = NoController - , translation = defaultTranslation + , translation = NoTranslation , joyCache = [] } diff --git a/src/Load.hs b/src/Load.hs index bafea43..881fcd8 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -80,12 +80,12 @@ loadFork ws win glc nvg future progress = do ( p + increment , "Loading icon \"controller_green\"" ))) - mcontrblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0 + mkbdblue <- 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 + mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0 modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Loading icon \"keyboard_green\"" @@ -267,7 +267,7 @@ loadFork ws win glc nvg future progress = do ))) mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0 let micons = - [ mcontrblue, mcontrgreen, marrow + [ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow ] when (any isNothing micons) $ do liftIO $logIO Error "Failed to load icon assets" diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index b3f4249..0c6ee37 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -46,19 +46,17 @@ loadMap = do ud <- getAffection ad <- get let (Subsystems _ m k j t) = subsystems ud - uu1 <- partSubscribe m movePlayer - uu2 <- partSubscribe k changeMaps - uu3 <- partSubscribe m playerInteract - uu4 <- partSubscribe j emitActionMessage - uu5 <- partSubscribe t movePlayer2 - uu6 <- partSubscribe t playerInteract2 - uu7 <- partSubscribe t changeMaps2 + uu0 <- partSubscribe k emitKbdActionMessage + uu1 <- partSubscribe j emitJoyActionMessage + uu2 <- partSubscribe t movePlayer2 + uu3 <- partSubscribe t playerInteract2 + uu4 <- partSubscribe t changeMaps2 future <- liftIO newEmptyMVar progress <- liftIO $ newMVar (0, "Ohai!") _ <- liftIO $ forkIO $ loadMapFork ud ad future progress putAffection ud { stateData = None - , uuid = [ uu1, uu2, uu3, uu4, uu5, uu6, uu7 ] + , uuid = [ uu0, uu1, uu2, uu3, uu4 ] , stateMVar = future , stateProgress = progress , state = Main WorldMap @@ -67,20 +65,22 @@ loadMap = do changeMaps :: KeyboardMessage -> Affection UserData () changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF1 = do - ud <- getAffection - putAffection ud - { state = Main WorldMap - } - | SDL.keysymKeycode sym == SDL.KeycodeF2 = do - ud <- getAffection - putAffection ud - { state = Main MindMap - } + ud <- getAffection + case state ud of + Main MindMap -> + putAffection ud + { state = Main WorldMap + } + Main WorldMap -> + putAffection ud + { state = Main MindMap + } + _ -> return () | otherwise = return () changeMaps _ = return () changeMaps2 :: ActionMessage -> Affection UserData () -changeMaps2 (ActionMessage SwitchMap _) = do +changeMaps2 (ActionMessage ActSwitchMap _) = do ud <- getAffection case state ud of Main MindMap -> @@ -272,60 +272,116 @@ loadMapFork ud ad future progress = do , roomGraph = gr }) -mouseToPlayer :: V2 Int32 -> Affection UserData () -mouseToPlayer mv2 = do - ud <- getAffection - (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 - (nws, _) <- yieldSystemT (worldState ud) $ - emap allEnts $ do - with player - return $ unchanged - { xyvel = Set $ V2 rx ry - } - putAffection ud - { worldState = nws - } +-- mouseToPlayer :: V2 Int32 -> Affection UserData () +-- mouseToPlayer mv2 = do +-- ud <- getAffection +-- (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 +-- (nws, _) <- yieldSystemT (worldState ud) $ +-- emap allEnts $ do +-- with player +-- return $ unchanged +-- { xyvel = Set $ V2 rx ry +-- } +-- putAffection ud +-- { worldState = nws +-- } +-- +-- movePlayer :: MouseMessage -> Affection UserData () +-- movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m +-- movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = +-- mouseToPlayer m +-- movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do +-- ud <- getAffection +-- (nws, _) <- yieldSystemT (worldState ud) $ +-- emap allEnts $ do +-- with player +-- return $ unchanged +-- { xyvel = Set $ V2 0 0 +-- } +-- putAffection ud +-- { worldState = nws +-- } +-- movePlayer _ = return () -movePlayer :: MouseMessage -> Affection UserData () -movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m -movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = - mouseToPlayer m -movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ - emap allEnts $ do - with player - return $ unchanged - { xyvel = Set $ V2 0 0 - } - putAffection ud - { worldState = nws - } -movePlayer _ = return () +movePlayerKbd :: KeyboardMessage -> Affection UserData () +movePlayerKbd (MsgKeyboardEvent _ _ press False sym) + | SDL.keysymKeycode sym == SDL.KeycodeW = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ + emap allEnts $ do + with player + (V2 vx _) <- query xyvel + let ry = if (press == SDL.Pressed) + then 1 + else 0 + return $ unchanged + { xyvel = Set $ V2 vx ry + } + putAffection ud + { worldState = nws + } + | SDL.keysymKeycode sym == SDL.KeycodeS = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ + emap allEnts $ do + with player + (V2 vx _) <- query xyvel + let ry = if (press == SDL.Pressed) + then -1 + else 0 + return $ unchanged + { xyvel = Set $ V2 vx ry + } + putAffection ud + { worldState = nws + } + | SDL.keysymKeycode sym == SDL.KeycodeA = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ + emap allEnts $ do + with player + (V2 _ vy) <- query xyvel + let rx = if (press == SDL.Pressed) + then -1 + else 0 + return $ unchanged + { xyvel = Set $ V2 rx vy + } + putAffection ud + { worldState = nws + } + | SDL.keysymKeycode sym == SDL.KeycodeD = do + ud <- getAffection + (nws, _) <- yieldSystemT (worldState ud) $ + emap allEnts $ do + with player + (V2 _ vy) <- query xyvel + let rx = if (press == SDL.Pressed) + then 1 + else 0 + return $ unchanged + { xyvel = Set $ V2 rx vy + } + putAffection ud + { worldState = nws + } + | otherwise = return () +movePlayerKbd _ = return () movePlayer2 :: ActionMessage -> Affection UserData () -movePlayer2 (ActionMessage (UpDown f) _) = do +movePlayer2 (ActionMessage mov _) = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ emap allEnts $ do with player - V2 vx _ <- query xyvel - let ry = fromIntegral f / if f < 0 then 32768 :: Double else 32767 :: Double + V2 vx vy <- query xyvel return $ unchanged - { xyvel = Set $ V2 vx ry - } - putAffection ud - { worldState = nws - } -movePlayer2 (ActionMessage (LeftRight f) _) = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ - emap allEnts $ do - with player - V2 _ vy <- query xyvel - let rx = fromIntegral f / if f < 0 then 32768 :: Double else 32767 :: Double - return $ unchanged - { xyvel = Set $ V2 rx vy + { xyvel = Set $ case mov of + ActUp f -> V2 vx (-f) + ActDown f -> V2 vx f + ActLeft f -> V2 (-f) vy + ActRight f -> V2 f vy + _ -> V2 vx vy } putAffection ud { worldState = nws @@ -384,7 +440,7 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do playerInteract _ = return () playerInteract2 :: ActionMessage -> Affection UserData () -playerInteract2 (ActionMessage Activate _) = do +playerInteract2 (ActionMessage ActActivate _) = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ do pdata <- efor allEnts $ do diff --git a/src/Menu/Adjust.hs b/src/Menu/Adjust.hs index 6d1f394..97e52ed 100644 --- a/src/Menu/Adjust.hs +++ b/src/Menu/Adjust.hs @@ -16,13 +16,13 @@ import Data.Maybe (fromJust, isJust) import Types import Util -loadAdjust :: Action -> Affection UserData () -> Affection UserData () -loadAdjust sub switchBack = do +loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData () +loadAdjust sub contr switchBack = do ud <- getAffection let Subsystems w m k j t = subsystems ud uu1 <- partSubscribe j (joyListener switchBack) putAffection ud - { state = Menu (Adjust sub) + { state = Menu (Adjust sub contr) , uuid = [ uu1 ] } @@ -30,38 +30,64 @@ joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData () joyListener 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 + let trans = translation ud + align + | val > 0 = AxisPositive + | val < 0 = AxisNegative + | otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*") + case trans of + JoyTranslation tmap -> do + case state ud of + Menu (Adjust (ActUp s) (Joystick _)) -> do + let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap) + putAffection ud + { translation = JoyTranslation $ + M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $ + if isJust k then M.delete (fromJust k) (tmap) else tmap + } + Menu (Adjust (ActDown s) (Joystick _)) -> do + let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap) + putAffection ud + { translation = JoyTranslation $ + M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $ + if isJust k then M.delete (fromJust k) (tmap) else tmap + } + Menu (Adjust (ActLeft s) (Joystick _)) -> do + let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap) + putAffection ud + { translation = JoyTranslation $ + M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $ + if isJust k then M.delete (fromJust k) (tmap) else tmap + } + Menu (Adjust (ActRight s) (Joystick _)) -> do + let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap) + putAffection ud + { translation = JoyTranslation $ + M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $ + if isJust k then M.delete (fromJust k) (tmap) else tmap + } + fullClean + switchBack + _ -> return () joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do ud <- getAffection - case state ud of - Menu (Adjust (UpDown s)) -> return () - Menu (Adjust (LeftRight s)) -> return () - Menu (Adjust (act)) -> do - let k = fst <$> find (\(_, v) -> v == act) (M.assocs $ translation ud) - putAffection ud - { translation = - M.insert (ButtonAction but SDL.JoyButtonPressed) act $ - if isJust k then M.delete (fromJust k) (translation ud) else translation ud - } - _ -> return () - fullClean - switchBack + case translation ud of + JoyTranslation tmap -> do + case state ud of + Menu (Adjust (ActUp _) (Joystick _)) -> return () + Menu (Adjust (ActDown _) (Joystick _)) -> return () + Menu (Adjust (ActLeft _) (Joystick _)) -> return () + Menu (Adjust (ActRight _) (Joystick _)) -> return () + Menu (Adjust (act) (Joystick _)) -> do + let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap) + putAffection ud + { translation = JoyTranslation $ + M.insert (ButtonAction but SDL.JoyButtonPressed) act $ + if isJust k then M.delete (fromJust k) tmap else tmap + } + _ -> return () + fullClean + switchBack joyListener _ _ = return () drawAdjust :: Affection UserData () diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs index 35c9d3b..57a8d16 100644 --- a/src/Menu/Connect.hs +++ b/src/Menu/Connect.hs @@ -6,7 +6,7 @@ import qualified SDL hiding (V2) import NanoVG hiding (V2) -import Linear hiding (rotate) +import Linear hiding (rotate, translation) import qualified Data.Set as S import qualified Data.Map.Strict as M @@ -29,12 +29,13 @@ loadMenu = do uu1 <- partSubscribe j joystickConnect uu2 <- partSubscribe j joystickDisconnect uu3 <- partSubscribe j emitJoyActionMessage - uu4 <- partSubscribe t handleActionMessages - uu5 <- partSubscribe m handleClicks + uu4 <- partSubscribe k emitKbdActionMessage + uu5 <- partSubscribe t handleActionMessages + uu6 <- partSubscribe m handleClicks -- uu6 <- partSubscribe k emitKbdActionMessage partUnSubscribe j (joyUUID ud) putAffection ud - { uuid = [ uu1, uu2, uu3, uu4, uu5 ] + { uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ] , state = Menu Connect , stateData = MenuData (V2 0 0) S 0 0 , joyCache = [] @@ -51,6 +52,7 @@ joystickConnect msg = do liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident putAffection ud { controls = Joystick joy + , translation = JoyTranslation defaultJoyTranslation } ) mjoy @@ -63,77 +65,104 @@ joystickDisconnect msg = do when (null njoys) $ do liftIO $ logIO A.Debug $ "Joystick disconnected" putAffection ud - { controls = None + { controls = NoController + , translation = NoTranslation } _ -> return () handleActionMessages :: ActionMessage -> Affection UserData () -handleActionMessages (ActionMessage Activate _) = do +handleActionMessages (ActionMessage ActActivate _) = do ud <- getAffection putAffection ud { stateData = (stateData ud) { activate = 0.5 } } -handleActionMessages (ActionMessage SwitchMap _) = do +handleActionMessages (ActionMessage ActSwitchMap _) = do ud <- getAffection putAffection ud { stateData = (stateData ud) { switchMap = 0.5 } } -handleActionMessages (ActionMessage (UpDown f) _) = do +handleActionMessages (ActionMessage (ActUp f) _) = do ud <- getAffection let V2 vx _ = velocity $ stateData ud putAffection ud { stateData = (stateData ud) - { velocity = (V2 vx (fromIntegral f / 32768)) + { velocity = (V2 vx (-f)) } } -handleActionMessages (ActionMessage (LeftRight f) _) = do +handleActionMessages (ActionMessage (ActDown f) _) = do + ud <- getAffection + let V2 vx _ = velocity $ stateData ud + putAffection ud + { stateData = (stateData ud) + { velocity = (V2 vx f) + } + } +handleActionMessages (ActionMessage (ActLeft f) _) = do ud <- getAffection let V2 _ vy = velocity $ stateData ud putAffection ud { stateData = (stateData ud) - { velocity = (V2 (fromIntegral f / 32768) vy) + { velocity = (V2 (-f) vy) + } + } +handleActionMessages (ActionMessage (ActRight f) _) = do + ud <- getAffection + let V2 _ vy = velocity $ stateData ud + putAffection ud + { stateData = (stateData ud) + { velocity = (V2 f vy) } } handleClicks :: MouseMessage -> Affection UserData () handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do ud <- getAffection + rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) 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 () + Joystick _ -> do + when (arrowUp rels) adjustKbdUp + when (arrowDown rels) adjustKbdDown + when (arrowLeft rels) adjustKbdLeft + when (arrowRight rels) adjustKbdRight + when (buttonActivate rels) adjustKbdActivate + when (buttonSwitchMap rels) adjustKbdSwitchMap + when (buttonPlay rels) enterGame + NoController -> do + when (kbdIcon rels) $ + putAffection ud + { controls = Keyboard + , translation = KbdTranslation defaultKbdTranslation + } + Keyboard -> do + when (kbdIcon rels) $ + putAffection ud + { controls = NoController + , translation = NoTranslation + } + when (buttonPlay rels) enterGame where - adjustUpDown rels = do - if arrowUp rels - then do + adjustKbdUp = do fullClean - loadAdjust (UpDown 1) loadMenu - else do + loadAdjust (ActUp 1) Keyboard loadMenu + adjustKbdDown = do fullClean - loadAdjust (UpDown (-1)) loadMenu - adjustLeftRight rels = do - if arrowLeft rels - then do + loadAdjust (ActDown 1) Keyboard loadMenu + adjustKbdLeft = do fullClean - loadAdjust (LeftRight 1) loadMenu - else do + loadAdjust (ActLeft 1) Keyboard loadMenu + adjustKbdRight = do fullClean - loadAdjust (LeftRight (-1)) loadMenu - adjustActivate = do + loadAdjust (ActRight 1) Keyboard loadMenu + adjustKbdActivate = do fullClean - loadAdjust Activate loadMenu - adjustSwitchMap = do + loadAdjust ActActivate Keyboard loadMenu + adjustKbdSwitchMap = do fullClean - loadAdjust SwitchMap loadMenu + loadAdjust ActSwitchMap Keyboard loadMenu enterGame = do fullClean loadMap @@ -151,6 +180,8 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720 buttonPlay (V2 rx ry) = rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720 + kbdIcon (V2 rx ry) = + rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720 handleClicks _ = return () updateMenu :: Double -> Affection UserData () @@ -179,12 +210,12 @@ drawMenu = do beginPath ctx cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.! case controller of - Joystick -> IconContrGreen - _ -> IconContrBlue + Joystick _ -> IconContrGreen + _ -> IconContrBlue ) 1 - rect ctx 600 620 80 80 + rect ctx 550 620 80 80 fillPaint ctx cpaint - endPath ctx + closePath ctx fill ctx beginPath ctx cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.! @@ -192,9 +223,9 @@ drawMenu = do Keyboard -> IconKbdGreen _ -> IconKbdBlue ) 1 - rect ctx 600 620 80 80 + rect ctx 650 620 80 80 fillPaint ctx cpaint - endPath ctx + closePath ctx fill ctx when (controller /= NoController) $ do let V2 vx vy = velocity $ stateData ud @@ -223,7 +254,13 @@ drawMenu = do closePath ctx fill ctx case state ud of - Menu (Adjust (UpDown _)) -> do + Menu (Adjust (ActUp _) _) -> do + beginPath ctx + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + Menu (Adjust (ActDown _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 @@ -239,7 +276,13 @@ drawMenu = do closePath ctx fill ctx case state ud of - Menu (Adjust (LeftRight _)) -> do + Menu (Adjust (ActLeft _) _) -> do + beginPath ctx + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + Menu (Adjust (ActRight _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 @@ -255,7 +298,13 @@ drawMenu = do closePath ctx fill ctx case state ud of - Menu (Adjust (UpDown _)) -> do + Menu (Adjust (ActUp _) _) -> do + beginPath ctx + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + Menu (Adjust (ActDown _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 @@ -271,7 +320,13 @@ drawMenu = do closePath ctx fill ctx case state ud of - Menu (Adjust (LeftRight _)) -> do + Menu (Adjust (ActLeft _) _) -> do + beginPath ctx + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + Menu (Adjust (ActRight _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 0 0 100 100 10 @@ -294,7 +349,7 @@ drawMenu = do fill ctx closePath ctx case state ud of - Menu (Adjust Activate) -> do + Menu (Adjust ActActivate _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 650 160 150 50 10 @@ -319,7 +374,7 @@ drawMenu = do fill ctx closePath ctx case state ud of - Menu (Adjust SwitchMap) -> do + Menu (Adjust ActSwitchMap _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) roundedRect ctx 650 220 150 50 10 diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 55ae2d8..d9e62c9 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -21,13 +21,13 @@ instance StateMachine State UserData where smUpdate Load = updateLoad smUpdate (Menu Connect) = updateMenu - smUpdate (Menu (Adjust _)) = const (return ()) + 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 (Menu (Adjust _ _)) = drawMenu >> drawAdjust smDraw (Main WorldMap) = drawMap smDraw (Main MindMap) = drawMind diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 433891b..4d86b51 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -31,7 +31,7 @@ data UserData = UserData , assetFonts :: M.Map FontId T.Text , assetAnimations :: M.Map AnimId Animation , controls :: Controller -- Maybe SDL.Joystick - , translation :: M.Map GamepadAction Action + , translation :: Translation , nano :: Context , uuid :: [UUID] , worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO) @@ -66,27 +66,47 @@ data SubMain data SubMenu = Connect - | Adjust Action + | Adjust Action Controller deriving (Eq, Show) -defaultTranslation :: M.Map GamepadAction Action -defaultTranslation = M.fromList - [ (ButtonAction 0 SDL.JoyButtonPressed, Activate) - , (ButtonAction 7 SDL.JoyButtonPressed, SwitchMap) - , (AxisAction 1, UpDown 1) - , (AxisAction 0, LeftRight 1) +defaultJoyTranslation :: M.Map JoypadAction Action +defaultJoyTranslation = M.fromList + [ (ButtonAction 0 SDL.JoyButtonPressed, ActActivate) + , (ButtonAction 7 SDL.JoyButtonPressed, ActSwitchMap) + , (AxisAction 1 AxisNegative, ActUp 1) + , (AxisAction 1 AxisPositive, ActDown 1) + , (AxisAction 0 AxisNegative, ActLeft 1) + , (AxisAction 0 AxisPositive, ActRight 1) ] -data Action - = Activate - | SwitchMap - | UpDown Int - | LeftRight Int +defaultKbdTranslation :: M.Map SDL.Keycode Action +defaultKbdTranslation = M.fromList + [ (SDL.KeycodeSpace, ActActivate) + , (SDL.KeycodeF1, ActSwitchMap) + , (SDL.KeycodeW, ActUp 1) + , (SDL.KeycodeS, ActDown 1) + , (SDL.KeycodeA, ActLeft 1) + , (SDL.KeycodeD, ActRight 1) + ] + +data Translation + = JoyTranslation (M.Map JoypadAction Action) + | KbdTranslation (M.Map SDL.Keycode Action) + | NoTranslation deriving (Show, Eq) -data GamepadAction +data Action + = ActActivate + | ActSwitchMap + | ActUp Double + | ActDown Double + | ActLeft Double + | ActRight Double + deriving (Show, Eq) + +data JoypadAction = ButtonAction Word8 SDL.JoyButtonState - | AxisAction Word8 + | AxisAction Word8 AxisAlign -- | HatAction Word SDL.JoyHatPosition deriving (Show, Eq, Ord) diff --git a/src/Util.hs b/src/Util.hs index 9cd61fe..79c5fb8 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -11,7 +11,7 @@ import Data.Graph.AStar import Data.Maybe import qualified Data.Text as T -import Control.Monad (join) +import Control.Monad (join, when) import qualified SDL import qualified Graphics.Rendering.OpenGL as GL hiding (get) @@ -307,18 +307,46 @@ cacheJoypad msg = 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 - 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 + case translation ud of + JoyTranslation tmap -> do + let Subsystems _ _ _ _ t = subsystems ud + vnormal = fromIntegral val / 32768 + sigvnormal = abs vnormal + align + | signum vnormal >= 0 = AxisPositive + | signum vnormal < 0 = AxisNegative + case tmap Map.!? (AxisAction axis align) of + Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time) + Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time) + Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time) + Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time) + _ -> return () + _ -> return () +emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do ud <- getAffection let Subsystems _ _ _ _ t = subsystems ud - case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of - Just act -> partEmit t (ActionMessage act time) - _ -> return () -emitActionMessage _ = return () + case (translation ud) of + JoyTranslation tmap -> do + case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of + Just act -> partEmit t (ActionMessage act time) + _ -> return () +emitJoyActionMessage _ = return () + +emitKbdActionMessage :: KeyboardMessage -> Affection UserData () +emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do + ud <- getAffection + let Subsystems _ _ _ _ t = subsystems ud + val = if press == SDL.Pressed then 1 else 0 + case (translation ud) of + KbdTranslation tmap -> do + case tmap Map.!? SDL.keysymKeycode sym of + Just (ActUp _) -> partEmit t (ActionMessage (ActUp val) time) + Just (ActDown _) -> partEmit t (ActionMessage (ActDown val) time) + Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft val) time) + Just (ActRight _) -> partEmit t (ActionMessage (ActRight val) time) + Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time)) + _ -> return () +emitKbdActionMessage _ = return () fullClean :: Affection UserData () fullClean = do