Basic gamepad support

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