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
|
module Game.Controller (Controls (..), init, update, isPressed) 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
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
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
|
