From b9353d40500dc27812a435d115fe9eaaed8a7cdc Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Fri, 3 Mar 2023 21:57:13 +0000 Subject: Better Gamepad support handling connection/disconnection --- src/Game.hs | 11 +++--- src/Game/Controller.hs | 103 ++++++++++++++++++++++++++++++++----------------- src/Game/Utils.hs | 24 +----------- 3 files changed, 74 insertions(+), 64 deletions(-) diff --git a/src/Game.hs b/src/Game.hs index 1d93065..e93269e 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -13,8 +13,7 @@ import qualified Game.Hud as H import qualified Game.Map as M import qualified Game.Sprites as S import qualified Game.State as GS -import qualified Game.Utils as U -import SDL (($=), ($~)) +import SDL (($=)) import qualified SDL import qualified SDL.Image import SDL.Vect (V2 (..)) @@ -89,7 +88,7 @@ main = do map' <- M.load "data/map.json" tsTexture sprites <- S.load "data/sprites.json" ssTexture font <- BF.load "data/font.json" bfTexture - controls <- newIORef =<< C.init + controls <- newIORef C.init entities <- E.mkEntities sprites map' controls hud <- H.mkHud sprites gameLoop @@ -136,7 +135,7 @@ gameLoop e = do events <- map SDL.eventPayload <$> SDL.pollEvents -- F11 for fullscreen / windowed - env <- if fromMaybe False $ U.isPressed SDL.KeycodeF11 events then toggleFullscreen e else pure e + env <- if fromMaybe False $ C.isPressed SDL.KeycodeF11 events then toggleFullscreen e else pure e let renderer = env.renderer canvas = env.canvas @@ -145,10 +144,10 @@ gameLoop e = do state = env.state -- ESC or close the window to quit - let quit = fromMaybe False (U.isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events + let quit = fromMaybe False (C.isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events unless quit $ do -- update controls - controls $~ flip C.update events + writeIORef controls =<< (`C.update` events) =<< readIORef controls SDL.rendererRenderTarget renderer $= Just canvas SDL.clear renderer diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs index 77039ac..47698f9 100644 --- a/src/Game/Controller.hs +++ b/src/Game/Controller.hs @@ -1,8 +1,9 @@ -module Game.Controller (Controls (..), init, update) where +module Game.Controller (Controls (..), init, update, isPressed) where -import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Vector ((!?)) -import Game.Utils (isPressed, isPressedGamepad) +import Control.Monad +import Data.Int (Int32) +import Data.Maybe (fromMaybe, isNothing) +import Foreign.C (peekCAString) import qualified SDL import qualified SDL.Input.GameController as SDL import qualified SDL.Raw @@ -16,40 +17,48 @@ data Controls = Controls a :: Bool, b :: Bool, menu :: Bool, - joy :: Maybe SDL.Raw.Joystick + joyId :: Maybe Int32, + gc :: Maybe SDL.Raw.GameController } deriving (Show) -getJoystick :: IO (Maybe SDL.Raw.Joystick) -getJoystick = do - joys <- SDL.availableJoysticks - case joys !? 0 of - Nothing -> pure Nothing - Just x -> - Just <$> do - -- XXX: are we sure this is a gamepad? - putStrLn ("gamepad: " ++ show x) - let joyId = SDL.joystickDeviceId x - g <- SDL.Raw.gameControllerOpen joyId - SDL.Raw.gameControllerGetJoystick g +processControllerEvents :: Controls -> [SDL.EventPayload] -> IO Controls +processControllerEvents controls (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceAdded joyId) : t) = do + if isNothing controls.joyId + then do + joyName <- peekCAString =<< SDL.Raw.gameControllerNameForIndex (fromIntegral joyId) + putStrLn $ "Connected gamepad: " ++ show joyName + gc <- SDL.Raw.gameControllerOpen (fromIntegral joyId) + processControllerEvents controls {joyId = Just joyId, gc = Just gc} t + else processControllerEvents controls t +processControllerEvents controls (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceRemoved joyId) : t) = do + c <- + if Just joyId == controls.joyId + then do + forM_ (controls.gc) SDL.Raw.gameControllerClose + putStrLn "Disconnected gamepad" + pure controls {joyId = Nothing, gc = Nothing} + else pure controls + processControllerEvents c t +processControllerEvents controls (_ : t) = processControllerEvents controls t +processControllerEvents controls [] = pure controls -init :: IO Controls -init = do - Controls False False False False False False False <$> getJoystick +init :: Controls +init = Controls False False False False False False False Nothing Nothing updateGamepad :: Controls -> [SDL.EventPayload] -> Controls -updateGamepad controls events - | isNothing $ controls.joy = controls - -- XXX: deal with disconnection/reconnection - | otherwise = +updateGamepad controls events = + case controls.joyId of + Nothing -> controls + Just joyId -> controls - { up = fromMaybe controls.up $ isPressedGamepad SDL.ControllerButtonDpadUp events, - down = fromMaybe controls.down $ isPressedGamepad SDL.ControllerButtonDpadDown events, - left = fromMaybe controls.left $ isPressedGamepad SDL.ControllerButtonDpadLeft events, - right = fromMaybe controls.right $ isPressedGamepad SDL.ControllerButtonDpadRight events, - a = fromMaybe False $ isPressedGamepad SDL.ControllerButtonA events, - b = fromMaybe False $ isPressedGamepad SDL.ControllerButtonB events, - menu = fromMaybe False $ isPressedGamepad SDL.ControllerButtonStart events + { up = fromMaybe controls.up $ isPressedGamepad joyId SDL.ControllerButtonDpadUp events, + down = fromMaybe controls.down $ isPressedGamepad joyId SDL.ControllerButtonDpadDown events, + left = fromMaybe controls.left $ isPressedGamepad joyId SDL.ControllerButtonDpadLeft events, + right = fromMaybe controls.right $ isPressedGamepad joyId SDL.ControllerButtonDpadRight events, + a = fromMaybe False $ isPressedGamepad joyId SDL.ControllerButtonA events, + b = fromMaybe False $ isPressedGamepad joyId SDL.ControllerButtonB events, + menu = fromMaybe False $ isPressedGamepad joyId SDL.ControllerButtonStart events } updateKeyboard :: Controls -> [SDL.EventPayload] -> Controls @@ -64,7 +73,31 @@ updateKeyboard controls events = menu = fromMaybe False $ isPressed SDL.KeycodeReturn events } -update :: Controls -> [SDL.EventPayload] -> Controls -update controls - | isJust controls.joy = updateGamepad controls - | otherwise = updateKeyboard controls +update :: Controls -> [SDL.EventPayload] -> IO Controls +update controls events = do + updated <- processControllerEvents controls events + pure $ case updated.joyId of + Just _ -> updateGamepad updated events + _ -> updateKeyboard updated events + +isPressed :: SDL.Keycode -> [SDL.EventPayload] -> Maybe Bool +isPressed code events + | any (isEventKey SDL.Pressed code) events = Just True + | any (isEventKey SDL.Released code) events = Just False + | otherwise = Nothing + where + isEventKey :: SDL.InputMotion -> SDL.Keycode -> SDL.EventPayload -> Bool + isEventKey expected keycode (SDL.KeyboardEvent (SDL.KeyboardEventData _ motion False ksym)) = expected == motion && SDL.keysymKeycode ksym == keycode + isEventKey _ _ _ = False + +isPressedGamepad :: Int32 -> SDL.ControllerButton -> [SDL.EventPayload] -> Maybe Bool +isPressedGamepad joyId button events + | any (isEventButton SDL.ControllerButtonPressed button) events = Just True + | any (isEventButton SDL.ControllerButtonReleased button) events = Just False + | otherwise = Nothing + where + isEventButton :: SDL.ControllerButtonState -> SDL.ControllerButton -> SDL.EventPayload -> Bool + isEventButton expected bu (SDL.ControllerButtonEvent (SDL.ControllerButtonEventData i b state)) + | i == joyId = expected == state && bu == b + | otherwise = False + isEventButton _ _ _ = False diff --git a/src/Game/Utils.hs b/src/Game/Utils.hs index e2b320a..d4dae94 100644 --- a/src/Game/Utils.hs +++ b/src/Game/Utils.hs @@ -1,30 +1,8 @@ -module Game.Utils (rect, isPressed, isPressedGamepad) where +module Game.Utils (rect) where import Foreign.C.Types (CInt) import qualified SDL -import qualified SDL.Input.GameController as SDL import SDL.Vect (V2 (..)) rect :: Int -> Int -> Int -> Int -> SDL.Rectangle CInt rect x y w h = SDL.Rectangle (SDL.P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (fromIntegral w) (fromIntegral h)) - -isPressed :: SDL.Keycode -> [SDL.EventPayload] -> Maybe Bool -isPressed code events - | any (isEventKey SDL.Pressed code) events = Just True - | any (isEventKey SDL.Released code) events = Just False - | otherwise = Nothing - where - isEventKey :: SDL.InputMotion -> SDL.Keycode -> SDL.EventPayload -> Bool - isEventKey expected keycode (SDL.KeyboardEvent (SDL.KeyboardEventData _ motion False ksym)) = expected == motion && SDL.keysymKeycode ksym == keycode - isEventKey _ _ _ = False - -isPressedGamepad :: SDL.ControllerButton -> [SDL.EventPayload] -> Maybe Bool -isPressedGamepad button events - | any (isEventButton SDL.ControllerButtonPressed button) events = Just True - | any (isEventButton SDL.ControllerButtonReleased button) events = Just False - | otherwise = Nothing - where - isEventButton :: SDL.ControllerButtonState -> SDL.ControllerButton -> SDL.EventPayload -> Bool - -- FIXME: may be don't hardcode it to joystick 0 - isEventButton expected bu (SDL.ControllerButtonEvent (SDL.ControllerButtonEventData 0 b state)) = expected == state && bu == b - isEventButton _ _ _ = False -- cgit v1.2.3