aboutsummaryrefslogtreecommitdiff
path: root/src/Game/Controller.hs
blob: d47963e1d2fc44a8522ed04948b9ebc823d02a3e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
module Game.Controller (Controls (..), init, update, isPressed, isModKey, altMod) where

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
import Prelude hiding (init)

data Controls = Controls
  { up :: Bool,
    down :: Bool,
    left :: Bool,
    right :: Bool,
    a :: Bool,
    b :: Bool,
    menu :: Bool,
    joyId :: Maybe Int32,
    gc :: Maybe SDL.Raw.GameController
  }
  deriving (Show)

processControllerEvents :: Controls -> [SDL.EventPayload] -> IO Controls
processControllerEvents controls (SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceAdded joyIndex) : t) = do
  if isNothing controls.joyId
    then do
      joyName <- peekCAString =<< SDL.Raw.gameControllerNameForIndex (fromIntegral joyIndex)
      putStrLn $ "Connected gamepad: " ++ show joyName
      gc <- SDL.Raw.gameControllerOpen (fromIntegral joyIndex)
      joy <- SDL.Raw.gameControllerGetJoystick gc
      joyId <- SDL.Raw.joystickInstanceID joy
      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 :: Controls
init = Controls False False False False False False False Nothing Nothing

altMod :: SDL.KeyModifier
altMod = SDL.KeyModifier False False False False True False False False False False False

updateGamepad :: Controls -> [SDL.EventPayload] -> Controls
updateGamepad controls events =
  case controls.joyId of
    Nothing -> controls
    Just joyId ->
      controls
        { 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
updateKeyboard controls events =
  controls
    { up = fromMaybe controls.up $ isPressed SDL.KeycodeUp events,
      down = fromMaybe controls.down $ isPressed SDL.KeycodeDown events,
      left = fromMaybe controls.left $ isPressed SDL.KeycodeLeft events,
      right = fromMaybe controls.right $ isPressed SDL.KeycodeRight events,
      a = fromMaybe False $ isPressed SDL.KeycodeZ events,
      b = fromMaybe False $ isPressed SDL.KeycodeX events,
      menu = fromMaybe False $ isPressed SDL.KeycodeReturn events
    }

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

isModKey :: SDL.KeyModifier -> [SDL.EventPayload] -> Bool
isModKey kmod = any (isModKeyOne kmod)
  where
    isModKeyOne m (SDL.KeyboardEvent (SDL.KeyboardEventData _ _ _ ksym)) = SDL.keysymModifier ksym == m
    isModKeyOne _ _ = 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