aboutsummaryrefslogtreecommitdiff
path: root/src/Game/Controller.hs
blob: f2cd5cd87a7402d89a5dfa67ed8726997a67dc4a (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
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