{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}

module Twirl.Inputs (
  InputState
  , ControllerAxis (..)
  , ControllerButton (..)
  , MouseButton (..)
  , updateInputs
  , closeControllers
  , emptyInputState
  , numControllers
  , isControllerButtonDown
  , controllerAxis
  , isKeyDown
  , isMouseDown
  , mousePosition
) where

import Control.Monad.IO.Class (MonadIO)
import Data.Foldable (foldlM)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word8)
import Foreign.C.Types (CInt)
import GHC.Int (Int16, Int32)
import SDL (
  ControllerAxisEventData (..)
  , ControllerButtonEventData (..)
  , ControllerDeviceEventData (..)
  , Event (..)
  , EventPayload (ControllerAxisEvent, ControllerButtonEvent, ControllerDeviceEvent, KeyboardEvent, QuitEvent)
  , InputMotion (Pressed, Released)
  , KeyboardEventData (..)
  , Keycode
  , Keysym (..)
  , MouseButton (..)
  , Point (..)
  , V2 (..)
  , getAbsoluteMouseLocation
  , getMouseButtons
  , keyboardEventKeyMotion
  , pollEvents
 )
import SDL.Input.GameController (
  ControllerButton (..)
  , ControllerButtonState (..)
  , ControllerDeviceConnection (..)
 )
import SDL.Raw.Event (gameControllerClose, gameControllerFromInstanceID, gameControllerGetJoystick, gameControllerOpen, joystickInstanceID)
import SDL.Raw.Types (GameController)
import Twirl.Graphics

data ControllerAxis = ControllerAxisLeftX | ControllerAxisLeftY | ControllerAxisRightX | ControllerAxisRightY | ControllerAxisTriggerLeft | ControllerAxisTriggerRight

data ControllerAxes = ControllerAxes
  { ControllerAxes -> Int16
controllerAxisLeftX :: Int16
  , ControllerAxes -> Int16
controllerAxisLeftY :: Int16
  , ControllerAxes -> Int16
controllerAxisRightX :: Int16
  , ControllerAxes -> Int16
controllerAxisRightY :: Int16
  , ControllerAxes -> Int16
controllerAxisTriggerLeft :: Int16
  , ControllerAxes -> Int16
controllerAxisTriggerRight :: Int16
  }
  deriving (Int -> ControllerAxes -> ShowS
[ControllerAxes] -> ShowS
ControllerAxes -> String
(Int -> ControllerAxes -> ShowS)
-> (ControllerAxes -> String)
-> ([ControllerAxes] -> ShowS)
-> Show ControllerAxes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControllerAxes] -> ShowS
$cshowList :: [ControllerAxes] -> ShowS
show :: ControllerAxes -> String
$cshow :: ControllerAxes -> String
showsPrec :: Int -> ControllerAxes -> ShowS
$cshowsPrec :: Int -> ControllerAxes -> ShowS
Show)

data ControllerState = ControllerState
  { ControllerState -> Set ControllerButton
controllerStateButtons :: Set ControllerButton
  , ControllerState -> ControllerAxes
controllerStateAxes :: ControllerAxes
  }
  deriving (Int -> ControllerState -> ShowS
[ControllerState] -> ShowS
ControllerState -> String
(Int -> ControllerState -> ShowS)
-> (ControllerState -> String)
-> ([ControllerState] -> ShowS)
-> Show ControllerState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControllerState] -> ShowS
$cshowList :: [ControllerState] -> ShowS
show :: ControllerState -> String
$cshow :: ControllerState -> String
showsPrec :: Int -> ControllerState -> ShowS
$cshowsPrec :: Int -> ControllerState -> ShowS
Show)

emptyControllerState :: ControllerState
emptyControllerState :: ControllerState
emptyControllerState =
  ControllerState
    { controllerStateButtons :: Set ControllerButton
controllerStateButtons = Set ControllerButton
forall a. Set a
Set.empty
    , controllerStateAxes :: ControllerAxes
controllerStateAxes =
        ControllerAxes
          { controllerAxisLeftX :: Int16
controllerAxisLeftX = Int16
0
          , controllerAxisLeftY :: Int16
controllerAxisLeftY = Int16
0
          , controllerAxisRightX :: Int16
controllerAxisRightX = Int16
0
          , controllerAxisRightY :: Int16
controllerAxisRightY = Int16
0
          , controllerAxisTriggerLeft :: Int16
controllerAxisTriggerLeft = Int16
0
          , controllerAxisTriggerRight :: Int16
controllerAxisTriggerRight = Int16
0
          }
    }

data InputState = InputState
  { InputState -> Map Int ControllerState
controllers :: Map Int ControllerState
  , InputState -> Set Keycode
keyDownSet :: Set Keycode
  , InputState -> Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
  , InputState -> MouseButton -> Bool
mouseButtons :: (MouseButton -> Bool)
  , InputState -> (Int, Int)
mousePos :: (Int, Int)
  }
  deriving (Int -> InputState -> ShowS
[InputState] -> ShowS
InputState -> String
(Int -> InputState -> ShowS)
-> (InputState -> String)
-> ([InputState] -> ShowS)
-> Show InputState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputState] -> ShowS
$cshowList :: [InputState] -> ShowS
show :: InputState -> String
$cshow :: InputState -> String
showsPrec :: Int -> InputState -> ShowS
$cshowsPrec :: Int -> InputState -> ShowS
Show)

instance Show (MouseButton -> Bool) where
  show :: (MouseButton -> Bool) -> String
show MouseButton -> Bool
_ = String
"<mouseButtonFunction>"

updateInputs :: MonadIO m => InputState -> m (InputState, Bool)
updateInputs :: forall (m :: * -> *).
MonadIO m =>
InputState -> m (InputState, Bool)
updateInputs InputState
inputState = do
  [Event]
events <- m [Event]
forall (m :: * -> *). MonadIO m => m [Event]
pollEvents
  MouseButton -> Bool
mouseInputFn <- m (MouseButton -> Bool)
forall (m :: * -> *). MonadIO m => m (MouseButton -> Bool)
getMouseButtons
  Point V2 CInt
mouseLocation <- m (Point V2 CInt)
forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
getAbsoluteMouseLocation
  let quitApp :: Bool
quitApp = (Event -> Bool) -> [Event] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((EventPayload -> EventPayload -> Bool
forall a. Eq a => a -> a -> Bool
== EventPayload
QuitEvent) (EventPayload -> Bool) -> (Event -> EventPayload) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> EventPayload
eventPayload) [Event]
events
  InputState
updatedInputs <- [Event] -> InputState -> m InputState
forall (m :: * -> *).
MonadIO m =>
[Event] -> InputState -> m InputState
handleEvents [Event]
events InputState
inputState{mouseButtons :: MouseButton -> Bool
mouseButtons = MouseButton -> Bool
mouseInputFn, mousePos :: (Int, Int)
mousePos = Point V2 CInt -> (Int, Int)
toMousePos Point V2 CInt
mouseLocation}
  (InputState, Bool) -> m (InputState, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InputState
updatedInputs, Bool
quitApp)

toMousePos :: Point V2 CInt -> (Int, Int)
toMousePos :: Point V2 CInt -> (Int, Int)
toMousePos (P (V2 CInt
x CInt
y)) = (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y)

emptyInputState :: InputState
emptyInputState :: InputState
emptyInputState = InputState{controllers :: Map Int ControllerState
controllers = Map Int ControllerState
forall k a. Map k a
Map.empty, keyDownSet :: Set Keycode
keyDownSet = Set Keycode
forall a. Set a
Set.empty, instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo = Map Int32 Int
forall k a. Map k a
Map.empty, mouseButtons :: MouseButton -> Bool
mouseButtons = Bool -> MouseButton -> Bool
forall a b. a -> b -> a
const Bool
False, mousePos :: (Int, Int)
mousePos = (Int
0, Int
0)}

getControllerAxis :: ControllerAxis -> ControllerState -> Int16
getControllerAxis :: ControllerAxis -> ControllerState -> Int16
getControllerAxis ControllerAxis
ControllerAxisLeftX ControllerState
controllerState = ControllerAxes -> Int16
controllerAxisLeftX (ControllerAxes -> Int16) -> ControllerAxes -> Int16
forall a b. (a -> b) -> a -> b
$ ControllerState -> ControllerAxes
controllerStateAxes ControllerState
controllerState
getControllerAxis ControllerAxis
ControllerAxisLeftY ControllerState
controllerState = ControllerAxes -> Int16
controllerAxisLeftY (ControllerAxes -> Int16) -> ControllerAxes -> Int16
forall a b. (a -> b) -> a -> b
$ ControllerState -> ControllerAxes
controllerStateAxes ControllerState
controllerState
getControllerAxis ControllerAxis
ControllerAxisRightX ControllerState
controllerState = ControllerAxes -> Int16
controllerAxisRightX (ControllerAxes -> Int16) -> ControllerAxes -> Int16
forall a b. (a -> b) -> a -> b
$ ControllerState -> ControllerAxes
controllerStateAxes ControllerState
controllerState
getControllerAxis ControllerAxis
ControllerAxisRightY ControllerState
controllerState = ControllerAxes -> Int16
controllerAxisRightY (ControllerAxes -> Int16) -> ControllerAxes -> Int16
forall a b. (a -> b) -> a -> b
$ ControllerState -> ControllerAxes
controllerStateAxes ControllerState
controllerState
getControllerAxis ControllerAxis
ControllerAxisTriggerLeft ControllerState
controllerState = ControllerAxes -> Int16
controllerAxisTriggerLeft (ControllerAxes -> Int16) -> ControllerAxes -> Int16
forall a b. (a -> b) -> a -> b
$ ControllerState -> ControllerAxes
controllerStateAxes ControllerState
controllerState
getControllerAxis ControllerAxis
ControllerAxisTriggerRight ControllerState
controllerState = ControllerAxes -> Int16
controllerAxisTriggerRight (ControllerAxes -> Int16) -> ControllerAxes -> Int16
forall a b. (a -> b) -> a -> b
$ ControllerState -> ControllerAxes
controllerStateAxes ControllerState
controllerState

-- | Get number of controllers
--
-- Returns the maximum number of controllers that have been connected simultaneously. This means that if
-- you connect four controllers and unplug one, this function will return 4.
numControllers :: InputState -> Int
numControllers :: InputState -> Int
numControllers InputState{Map Int ControllerState
controllers :: Map Int ControllerState
controllers :: InputState -> Map Int ControllerState
controllers} = ([ControllerState] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ControllerState] -> Int)
-> (Map Int ControllerState -> [ControllerState])
-> Map Int ControllerState
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int ControllerState -> [ControllerState]
forall k a. Map k a -> [a]
Map.elems) Map Int ControllerState
controllers

-- | Query the state of controller buttons
--
-- Returns True if the queried button is down on the queried controller. Returns False if the controller is disconnected or doesn't exist
-- (e.g. you query controller number 4 but there are only 2 controllers).
isControllerButtonDown ::
  InputState ->
  -- | Controller number to be queried
  Int ->
  -- | The Controller button to be queried
  ControllerButton ->
  Bool
isControllerButtonDown :: InputState -> Int -> ControllerButton -> Bool
isControllerButtonDown InputState{Map Int ControllerState
controllers :: Map Int ControllerState
controllers :: InputState -> Map Int ControllerState
controllers} Int
controllerNumber ControllerButton
button =
  case Int -> Map Int ControllerState -> Maybe ControllerState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
controllerNumber Map Int ControllerState
controllers of
    Maybe ControllerState
Nothing -> Bool
False
    Just ControllerState
controllerState -> ControllerButton -> Set ControllerButton -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ControllerButton
button (ControllerState -> Set ControllerButton
controllerStateButtons ControllerState
controllerState)

-- | Query axes of controllers
--
-- For the stick axes, the returned value is between -1.0 and 1.0, where 0.0 is the neutral position.
-- For triggers the value is between 0.0 and 1.0 where 0.0 is the neutral position. Bear in mind that
-- usually the level of quality of controller sticks is so low that the sticks don't return exactly to
-- the 0.0 position, so you have to ignore some values which are too close to zero.
controllerAxis ::
  InputState ->
  -- | Controller number
  Int ->
  -- | The queried axis
  ControllerAxis ->
  Double
controllerAxis :: InputState -> Int -> ControllerAxis -> Double
controllerAxis InputState{Map Int ControllerState
controllers :: Map Int ControllerState
controllers :: InputState -> Map Int ControllerState
controllers} Int
controllerNumber ControllerAxis
axis =
  case Int -> Map Int ControllerState -> Maybe ControllerState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
controllerNumber Map Int ControllerState
controllers of
    Maybe ControllerState
Nothing -> Double
0
    Just ControllerState
controllerState -> (Int16 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Double) -> Int16 -> Double
forall a b. (a -> b) -> a -> b
$ ControllerAxis -> ControllerState -> Int16
getControllerAxis ControllerAxis
axis ControllerState
controllerState) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
32767

-- | Query keyboard state
isKeyDown :: InputState -> Keycode -> Bool
isKeyDown :: InputState -> Keycode -> Bool
isKeyDown InputState{Set Keycode
keyDownSet :: Set Keycode
keyDownSet :: InputState -> Set Keycode
keyDownSet} Keycode
keycode = Keycode -> Set Keycode -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Keycode
keycode Set Keycode
keyDownSet

-- | Query mouse button state
isMouseDown :: InputState -> MouseButton -> Bool
isMouseDown :: InputState -> MouseButton -> Bool
isMouseDown InputState{MouseButton -> Bool
mouseButtons :: MouseButton -> Bool
mouseButtons :: InputState -> MouseButton -> Bool
mouseButtons} = MouseButton -> Bool
mouseButtons

-- | Get mouse position on screen
mousePosition :: InputState -> (Int, Int)
mousePosition :: InputState -> (Int, Int)
mousePosition InputState{(Int, Int)
mousePos :: (Int, Int)
mousePos :: InputState -> (Int, Int)
mousePos} = (Int, Int)
mousePos

handleEvents :: MonadIO m => [Event] -> InputState -> m InputState
handleEvents :: forall (m :: * -> *).
MonadIO m =>
[Event] -> InputState -> m InputState
handleEvents [Event]
events InputState
keySet =
  (InputState -> Event -> m InputState)
-> InputState -> [Event] -> m InputState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
    InputState -> Event -> m InputState
forall (m :: * -> *).
MonadIO m =>
InputState -> Event -> m InputState
handleEvent
    InputState
keySet
    [Event]
events

handleEvent :: MonadIO m => InputState -> Event -> m InputState
handleEvent :: forall (m :: * -> *).
MonadIO m =>
InputState -> Event -> m InputState
handleEvent InputState
inputState Event
event =
  case Event -> EventPayload
eventPayload Event
event of
    KeyboardEvent KeyboardEventData
keyboardEvent ->
      case KeyboardEventData -> InputMotion
keyboardEventKeyMotion KeyboardEventData
keyboardEvent of
        InputMotion
Pressed -> InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
inputState{keyDownSet :: Set Keycode
keyDownSet = Keycode -> Set Keycode -> Set Keycode
forall a. Ord a => a -> Set a -> Set a
Set.insert (Keysym -> Keycode
keysymKeycode (Keysym -> Keycode) -> Keysym -> Keycode
forall a b. (a -> b) -> a -> b
$ KeyboardEventData -> Keysym
keyboardEventKeysym KeyboardEventData
keyboardEvent) (InputState -> Set Keycode
keyDownSet InputState
inputState)}
        InputMotion
Released -> InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
inputState{keyDownSet :: Set Keycode
keyDownSet = Keycode -> Set Keycode -> Set Keycode
forall a. Ord a => a -> Set a -> Set a
Set.delete (Keysym -> Keycode
keysymKeycode (Keysym -> Keycode) -> Keysym -> Keycode
forall a b. (a -> b) -> a -> b
$ KeyboardEventData -> Keysym
keyboardEventKeysym KeyboardEventData
keyboardEvent) (InputState -> Set Keycode
keyDownSet InputState
inputState)}
    ControllerDeviceEvent (ControllerDeviceEventData{ControllerDeviceConnection
controllerDeviceEventConnection :: ControllerDeviceEventData -> ControllerDeviceConnection
controllerDeviceEventConnection :: ControllerDeviceConnection
controllerDeviceEventConnection, Int32
controllerDeviceEventWhich :: ControllerDeviceEventData -> Int32
controllerDeviceEventWhich :: Int32
controllerDeviceEventWhich}) -> case ControllerDeviceConnection
controllerDeviceEventConnection of
      -- Type cast is necessary because SDL returns either device index or instance id
      -- (https://wiki.libsdl.org/SDL_ControllerDeviceEvent) depending on whether the
      -- controller was added or removed, but Haskell bindings always report to return
      -- instance id (which must be wrong since added but unopened controllers don't have
      -- an instance id yet)
      ControllerDeviceConnection
ControllerDeviceAdded -> CInt -> m GameController
forall (m :: * -> *). MonadIO m => CInt -> m GameController
gameControllerOpen (Int32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
controllerDeviceEventWhich) m GameController
-> (GameController -> m InputState) -> m InputState
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputState -> GameController -> m InputState
forall (m :: * -> *).
MonadIO m =>
InputState -> GameController -> m InputState
addControllerMapping InputState
inputState
      ControllerDeviceConnection
ControllerDeviceRemoved -> do
        GameController
controllerPtr <- Int32 -> m GameController
forall (m :: * -> *). MonadIO m => Int32 -> m GameController
gameControllerFromInstanceID Int32
controllerDeviceEventWhich
        InputState
updatedInputs <- InputState -> GameController -> m InputState
forall (m :: * -> *).
MonadIO m =>
InputState -> GameController -> m InputState
removeControllerMapping InputState
inputState GameController
controllerPtr
        GameController -> m ()
forall (m :: * -> *). MonadIO m => GameController -> m ()
gameControllerClose GameController
controllerPtr
        InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
updatedInputs
      ControllerDeviceConnection
_ -> InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
inputState
    ControllerButtonEvent ControllerButtonEventData
e -> do
      let updatedState :: InputState
updatedState = ControllerButtonEventData -> InputState -> InputState
updateInputStateController ControllerButtonEventData
e InputState
inputState
      InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
updatedState
    ControllerAxisEvent ControllerAxisEventData
e -> do
      let updatedState :: InputState
updatedState = ControllerAxisEventData -> InputState -> InputState
updateInputStateControllerAxis ControllerAxisEventData
e InputState
inputState
      InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
updatedState
    EventPayload
_ -> InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
inputState

addControllerMapping :: MonadIO m => InputState -> GameController -> m InputState
addControllerMapping :: forall (m :: * -> *).
MonadIO m =>
InputState -> GameController -> m InputState
addControllerMapping inputState :: InputState
inputState@InputState{Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo :: InputState -> Map Int32 Int
instanceIdToControllerNo} GameController
controller = do
  Int32
instanceId <- GameController -> m GameController
forall (m :: * -> *).
MonadIO m =>
GameController -> m GameController
gameControllerGetJoystick GameController
controller m GameController -> (GameController -> m Int32) -> m Int32
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GameController -> m Int32
forall (m :: * -> *). MonadIO m => GameController -> m Int32
joystickInstanceID
  let controllerNo :: Int
controllerNo = InputState -> Int
nextFreeController InputState
inputState
  InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
inputState{instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo = Int32 -> Int -> Map Int32 Int -> Map Int32 Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int32
instanceId Int
controllerNo Map Int32 Int
instanceIdToControllerNo}

nextFreeController :: InputState -> Int
nextFreeController :: InputState -> Int
nextFreeController InputState{Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo :: InputState -> Map Int32 Int
instanceIdToControllerNo} =
  let mappedControllers :: Set Int
mappedControllers = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int) -> [Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ Map Int32 Int -> [Int]
forall k a. Map k a -> [a]
Map.elems Map Int32 Int
instanceIdToControllerNo
   in Set Int -> Int
findSmallestNaturalNotInSet Set Int
mappedControllers
 where
  findSmallestNaturalNotInSet :: Set Int -> Int
  findSmallestNaturalNotInSet :: Set Int -> Int
findSmallestNaturalNotInSet Set Int
set =
    let go :: Int -> Int
go Int
n = if Bool -> Bool
not (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Int
n Set Int
set) then Int
n else Int -> Int
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
     in Int -> Int
go Int
0

removeControllerMapping :: MonadIO m => InputState -> GameController -> m InputState
removeControllerMapping :: forall (m :: * -> *).
MonadIO m =>
InputState -> GameController -> m InputState
removeControllerMapping inputState :: InputState
inputState@InputState{Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo :: InputState -> Map Int32 Int
instanceIdToControllerNo} GameController
controller = do
  Int32
instanceId <- GameController -> m GameController
forall (m :: * -> *).
MonadIO m =>
GameController -> m GameController
gameControllerGetJoystick GameController
controller m GameController -> (GameController -> m Int32) -> m Int32
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GameController -> m Int32
forall (m :: * -> *). MonadIO m => GameController -> m Int32
joystickInstanceID
  InputState -> m InputState
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputState
inputState{instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo = Int32 -> Map Int32 Int -> Map Int32 Int
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int32
instanceId Map Int32 Int
instanceIdToControllerNo}

closeControllers :: InputState -> TwirlMonad ()
closeControllers :: InputState -> TwirlMonad ()
closeControllers InputState{Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo :: InputState -> Map Int32 Int
instanceIdToControllerNo} = do
  let controllerIds :: [Int32]
controllerIds = Map Int32 Int -> [Int32]
forall k a. Map k a -> [k]
Map.keys Map Int32 Int
instanceIdToControllerNo
  [GameController]
controllerPtrs <- (Int32 -> TwirlMonad GameController)
-> [Int32] -> TwirlMonad [GameController]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int32 -> TwirlMonad GameController
forall (m :: * -> *). MonadIO m => Int32 -> m GameController
gameControllerFromInstanceID [Int32]
controllerIds
  (GameController -> TwirlMonad ())
-> [GameController] -> TwirlMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GameController -> TwirlMonad ()
forall (m :: * -> *). MonadIO m => GameController -> m ()
gameControllerClose [GameController]
controllerPtrs

updateInputStateController :: ControllerButtonEventData -> InputState -> InputState
updateInputStateController :: ControllerButtonEventData -> InputState -> InputState
updateInputStateController ControllerButtonEventData{Int32
controllerButtonEventWhich :: ControllerButtonEventData -> Int32
controllerButtonEventWhich :: Int32
controllerButtonEventWhich, ControllerButtonState
controllerButtonEventState :: ControllerButtonEventData -> ControllerButtonState
controllerButtonEventState :: ControllerButtonState
controllerButtonEventState, ControllerButton
controllerButtonEventButton :: ControllerButtonEventData -> ControllerButton
controllerButtonEventButton :: ControllerButton
controllerButtonEventButton} inputState :: InputState
inputState@InputState{Map Int ControllerState
controllers :: Map Int ControllerState
controllers :: InputState -> Map Int ControllerState
controllers, Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo :: InputState -> Map Int32 Int
instanceIdToControllerNo} =
  let controller :: Int
controller = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (InputState -> Int
nextFreeController InputState
inputState) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Map Int32 Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int32
controllerButtonEventWhich Map Int32 Int
instanceIdToControllerNo
   in InputState
inputState{controllers :: Map Int ControllerState
controllers = (Maybe ControllerState -> Maybe ControllerState)
-> Int -> Map Int ControllerState -> Map Int ControllerState
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (ControllerButtonState
-> ControllerButton
-> Maybe ControllerState
-> Maybe ControllerState
updateControllerState ControllerButtonState
controllerButtonEventState ControllerButton
controllerButtonEventButton) Int
controller Map Int ControllerState
controllers}

updateControllerState :: ControllerButtonState -> ControllerButton -> Maybe ControllerState -> Maybe ControllerState
updateControllerState :: ControllerButtonState
-> ControllerButton
-> Maybe ControllerState
-> Maybe ControllerState
updateControllerState ControllerButtonState
stateChange ControllerButton
button Maybe ControllerState
maybeState =
  let state :: ControllerState
state = ControllerState -> Maybe ControllerState -> ControllerState
forall a. a -> Maybe a -> a
fromMaybe ControllerState
emptyControllerState Maybe ControllerState
maybeState
      action :: ControllerButton -> Set ControllerButton -> Set ControllerButton
action = case ControllerButtonState
stateChange of
        ControllerButtonState
ControllerButtonPressed -> ControllerButton -> Set ControllerButton -> Set ControllerButton
forall a. Ord a => a -> Set a -> Set a
Set.insert
        ControllerButtonState
ControllerButtonReleased -> ControllerButton -> Set ControllerButton -> Set ControllerButton
forall a. Ord a => a -> Set a -> Set a
Set.delete
        ControllerButtonState
_ -> (Set ControllerButton -> ControllerButton -> Set ControllerButton)
-> ControllerButton -> Set ControllerButton -> Set ControllerButton
forall a b c. (a -> b -> c) -> b -> a -> c
flip Set ControllerButton -> ControllerButton -> Set ControllerButton
forall a b. a -> b -> a
const
   in ControllerState -> Maybe ControllerState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControllerState
state{controllerStateButtons :: Set ControllerButton
controllerStateButtons = ControllerButton -> Set ControllerButton -> Set ControllerButton
action ControllerButton
button (ControllerState -> Set ControllerButton
controllerStateButtons ControllerState
state)}

updateInputStateControllerAxis :: ControllerAxisEventData -> InputState -> InputState
updateInputStateControllerAxis :: ControllerAxisEventData -> InputState -> InputState
updateInputStateControllerAxis ControllerAxisEventData{Int32
controllerAxisEventWhich :: ControllerAxisEventData -> Int32
controllerAxisEventWhich :: Int32
controllerAxisEventWhich, Int16
controllerAxisEventValue :: ControllerAxisEventData -> Int16
controllerAxisEventValue :: Int16
controllerAxisEventValue, Word8
controllerAxisEventAxis :: ControllerAxisEventData -> Word8
controllerAxisEventAxis :: Word8
controllerAxisEventAxis} inputState :: InputState
inputState@InputState{Map Int ControllerState
controllers :: Map Int ControllerState
controllers :: InputState -> Map Int ControllerState
controllers, Map Int32 Int
instanceIdToControllerNo :: Map Int32 Int
instanceIdToControllerNo :: InputState -> Map Int32 Int
instanceIdToControllerNo} =
  let controller :: Int
controller = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (InputState -> Int
nextFreeController InputState
inputState) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Map Int32 Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int32
controllerAxisEventWhich Map Int32 Int
instanceIdToControllerNo
   in InputState
inputState{controllers :: Map Int ControllerState
controllers = (Maybe ControllerState -> Maybe ControllerState)
-> Int -> Map Int ControllerState -> Map Int ControllerState
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Int16 -> Word8 -> Maybe ControllerState -> Maybe ControllerState
updateControllerStateAxis Int16
controllerAxisEventValue Word8
controllerAxisEventAxis) Int
controller Map Int ControllerState
controllers}

updateControllerStateAxis :: Int16 -> Word8 -> Maybe ControllerState -> Maybe ControllerState
updateControllerStateAxis :: Int16 -> Word8 -> Maybe ControllerState -> Maybe ControllerState
updateControllerStateAxis Int16
value Word8
axis Maybe ControllerState
maybeState =
  let state :: ControllerState
state = ControllerState -> Maybe ControllerState -> ControllerState
forall a. a -> Maybe a -> a
fromMaybe ControllerState
emptyControllerState Maybe ControllerState
maybeState
   in ControllerState -> Maybe ControllerState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ControllerState
state{controllerStateAxes :: ControllerAxes
controllerStateAxes = ControllerAxes -> Int16 -> Word8 -> ControllerAxes
updateControllerAxis (ControllerState -> ControllerAxes
controllerStateAxes ControllerState
state) Int16
value Word8
axis}

updateControllerAxis :: ControllerAxes -> Int16 -> Word8 -> ControllerAxes
updateControllerAxis :: ControllerAxes -> Int16 -> Word8 -> ControllerAxes
updateControllerAxis ControllerAxes
axes Int16
value Word8
axis = case Word8
axis of
  Word8
0 -> ControllerAxes
axes{controllerAxisLeftX :: Int16
controllerAxisLeftX = Int16
value}
  Word8
1 -> ControllerAxes
axes{controllerAxisLeftY :: Int16
controllerAxisLeftY = Int16
value}
  Word8
2 -> ControllerAxes
axes{controllerAxisRightX :: Int16
controllerAxisRightX = Int16
value}
  Word8
3 -> ControllerAxes
axes{controllerAxisRightY :: Int16
controllerAxisRightY = Int16
value}
  Word8
4 -> ControllerAxes
axes{controllerAxisTriggerLeft :: Int16
controllerAxisTriggerLeft = Int16
value}
  Word8
_ -> ControllerAxes
axes{controllerAxisTriggerRight :: Int16
controllerAxisTriggerRight = Int16
value}