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
115
116
117
118
119
|
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 Game.Toaster qualified as T
import SDL qualified
import SDL.Input.GameController qualified as SDL
import SDL.Raw qualified
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 -> T.Toaster -> [SDL.EventPayload] -> IO (Controls, T.Toaster)
processControllerEvents controls toaster ev =
case ev of
(SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceAdded joyIndex) : t) ->
if isNothing controls.joyId
then do
joyName <- peekCAString =<< SDL.Raw.gameControllerNameForIndex (fromIntegral joyIndex)
let toaster' = T.add toaster $ "Connected " ++ 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} toaster' t
else processControllerEvents controls toaster t
(SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData SDL.ControllerDeviceRemoved joyId) : t) -> do
(c, toaster') <-
if Just joyId == controls.joyId
then do
forM_ controls.gc SDL.Raw.gameControllerClose
pure (controls {joyId = Nothing, gc = Nothing}, T.add toaster "Gamepad disconnected")
else pure (controls, toaster)
processControllerEvents c toaster' t
(_ : t) -> processControllerEvents controls toaster t
[] -> pure (controls, toaster)
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 -> T.Toaster -> [SDL.EventPayload] -> IO (Controls, T.Toaster)
update controls toaster events = do
(updated, toaster') <- processControllerEvents controls toaster events
pure
( case updated.joyId of
Just _ -> updateGamepad updated events
_ -> updateKeyboard updated events,
toaster'
)
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
|
