aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJuan J. Martinez <jjm@usebox.net>2023-02-05 15:55:11 +0000
committerJuan J. Martinez <jjm@usebox.net>2023-02-05 15:55:11 +0000
commitd7a519f1aa04e489630c63318b200e89e164d280 (patch)
tree56dcd12c831b0ed0b0f00cadc7c0196b650fae30 /src
parentf8e1b62244f011c971763c1ec60d1ff99184fac7 (diff)
downloadspace-plat-hs-d7a519f1aa04e489630c63318b200e89e164d280.tar.gz
space-plat-hs-d7a519f1aa04e489630c63318b200e89e164d280.zip
Basic gamepad support
Diffstat (limited to 'src')
-rw-r--r--src/Game.hs4
-rw-r--r--src/Game/Controller.hs51
-rw-r--r--src/Game/Utils.hs15
3 files changed, 59 insertions, 11 deletions
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