From d7a519f1aa04e489630c63318b200e89e164d280 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Sun, 5 Feb 2023 15:55:11 +0000 Subject: Basic gamepad support --- game.cabal | 1 + src/Game.hs | 4 ++-- src/Game/Controller.hs | 51 +++++++++++++++++++++++++++++++++++++++++++------- src/Game/Utils.hs | 15 +++++++++++++-- 4 files changed, 60 insertions(+), 11 deletions(-) diff --git a/game.cabal b/game.cabal index 513a37e..3c09e3f 100644 --- a/game.cabal +++ b/game.cabal @@ -25,6 +25,7 @@ library base , mtl , text >= 1.1.0.0 && < 2.1 + , vector>=0.10.9.0 && <0.14 , sdl2 , sdl2-image , json diff --git a/src/Game.hs b/src/Game.hs index 0d5ae45..3121ddf 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -47,7 +47,7 @@ defaultRenderRect = SDL.Rectangle (SDL.P $ V2 0 0) (V2 windowWidth windowHeight) main :: IO () main = do - SDL.initialize [SDL.InitVideo] + SDL.initialize [SDL.InitVideo, SDL.InitGameController] window <- SDL.createWindow (pack $ name ++ " " ++ version) @@ -66,7 +66,7 @@ main = do renderRect <- newIORef defaultRenderRect tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png" ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png" - controls <- newIORef C.init + controls <- newIORef =<< C.init map' <- M.load "data/map.json" tsTexture sprites <- S.load "data/sprites.json" ssTexture entities <- newIORef ([] :: [E.Entity]) diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs index 3ec7e4c..ec1cdf3 100644 --- a/src/Game/Controller.hs +++ b/src/Game/Controller.hs @@ -1,8 +1,11 @@ module Game.Controller (Controls (..), init, update) where -import Data.Maybe (fromMaybe) -import Game.Utils (isPressed) +import Data.Maybe (fromMaybe, isNothing) +import Data.Vector ((!?)) +import Game.Utils (isPressed, isPressedGamepad) import qualified SDL +import qualified SDL.Input.GameController as SDL +import qualified SDL.Raw import Prelude hiding (init) data Controls = Controls @@ -12,15 +15,45 @@ data Controls = Controls cRight :: Bool, cA :: Bool, cB :: Bool, - cMenu :: Bool + cMenu :: Bool, + cJoy :: Maybe SDL.Raw.Joystick } deriving (Show) -init :: Controls -init = Controls False False False False False False False +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 -update :: [SDL.EventPayload] -> Controls -> Controls -update events controls = +init :: IO Controls +init = do + Controls False False False False False False False <$> getJoystick + +updateGamepad :: [SDL.EventPayload] -> Controls -> Controls +updateGamepad events controls + | isNothing $ cJoy controls = controls + -- XXX: deal with disconnection/reconnection + | otherwise = + controls + { cUp = fromMaybe (cUp controls) $ isPressedGamepad SDL.ControllerButtonDpadUp events, + cDown = fromMaybe (cDown controls) $ isPressedGamepad SDL.ControllerButtonDpadDown events, + cLeft = fromMaybe (cLeft controls) $ isPressedGamepad SDL.ControllerButtonDpadLeft events, + cRight = fromMaybe (cRight controls) $ isPressedGamepad SDL.ControllerButtonDpadRight events, + cA = fromMaybe (cA controls) $ isPressedGamepad SDL.ControllerButtonA events, + cB = fromMaybe (cB controls) $ isPressedGamepad SDL.ControllerButtonB events, + cMenu = fromMaybe (cMenu controls) $ isPressedGamepad SDL.ControllerButtonStart events + } + +updateKeyboard :: [SDL.EventPayload] -> Controls -> Controls +updateKeyboard events controls = controls { cUp = fromMaybe (cUp controls) $ isPressed SDL.KeycodeUp events, cDown = fromMaybe (cDown controls) $ isPressed SDL.KeycodeDown events, @@ -30,3 +63,7 @@ update events controls = cB = fromMaybe (cB controls) $ isPressed SDL.KeycodeX events, cMenu = fromMaybe (cMenu controls) $ isPressed SDL.KeycodeReturn events } + +update :: [SDL.EventPayload] -> Controls -> Controls +update events controls = do + updateGamepad events $ updateKeyboard events controls diff --git a/src/Game/Utils.hs b/src/Game/Utils.hs index acfab6f..e2b320a 100644 --- a/src/Game/Utils.hs +++ b/src/Game/Utils.hs @@ -1,7 +1,8 @@ -module Game.Utils (rect, isPressed) where +module Game.Utils (rect, isPressed, isPressedGamepad) 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 @@ -9,7 +10,6 @@ rect x y w h = SDL.Rectangle (SDL.P $ V2 (fromIntegral x) (fromIntegral y)) (V2 isPressed :: SDL.Keycode -> [SDL.EventPayload] -> Maybe Bool isPressed code events - -- TODO: gamepad support | any (isEventKey SDL.Pressed code) events = Just True | any (isEventKey SDL.Released code) events = Just False | otherwise = Nothing @@ -17,3 +17,14 @@ isPressed code events 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