{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
module Play.Engine.Input where
import Data.Maybe
import Data.Word (Word8)
import Data.Tuple
import qualified SDL
import qualified Play.Engine.MySDL.MySDL as MySDL
import Play.Engine.Types
import qualified Data.Map as M
import GHC.Generics
import Control.DeepSeq
data Input
= Input
{ inputKeys :: !Keys
, responses :: ![MySDL.Response]
}
type Keys = M.Map Key Action
data Action
= Idle
| Release
| Hold
| Click
deriving (Show, Eq, Ord, Generic, NFData)
data Key
= KeyUp
| KeyDown
| KeyLeft
| KeyRight
| KeyA
| KeyB
| KeyC
| KeyD
| KeyM
| KeyP
| KeyScale
| KeyStart
| KeyQuit
deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic, NFData)
empty :: Input
empty = Input mempty mempty
initKeyStats :: Keys
initKeyStats = M.fromList $ zip [minBound..maxBound] (cycle [Idle])
defKeyMap :: [(Key, SDL.Scancode)]
defKeyMap = map swap
[ (SDL.ScancodeW, KeyUp)
, (SDL.ScancodeS, KeyDown)
, (SDL.ScancodeA, KeyLeft)
, (SDL.ScancodeD, KeyRight)
, (SDL.ScancodeUp, KeyUp)
, (SDL.ScancodeDown, KeyDown)
, (SDL.ScancodeLeft, KeyLeft)
, (SDL.ScancodeRight, KeyRight)
, (SDL.ScancodeReturn, KeyStart)
, (SDL.ScancodeEscape, KeyQuit)
, (SDL.ScancodeQ, KeyQuit)
, (SDL.ScancodeZ, KeyA)
, (SDL.ScancodeX, KeyB)
, (SDL.ScancodeR, KeyC)
, (SDL.ScancodeV, KeyD)
, (SDL.ScancodeM, KeyM)
, (SDL.ScancodeP, KeyP)
, (SDL.ScancodeF12, KeyScale)
]
defControllerButtonMap :: [(Key, Word8)]
defControllerButtonMap = map swap
[ (13, KeyUp)
, (14, KeyDown)
, (11, KeyLeft)
, (12, KeyRight)
, (0, KeyB)
, (5, KeyA)
, (3, KeyC)
, (7, KeyStart)
]
keepState :: Maybe Action -> Bool
keepState state
| state == Just Click = True
| state == Just Hold = True
| state == Just Release = False
| state == Just Idle = False
| otherwise = False
checkControllerEvent :: Word8 -> SDL.EventPayload -> Maybe Bool
checkControllerEvent btn = \case
SDL.JoyButtonEvent (SDL.JoyButtonEventData _ btn' SDL.JoyButtonPressed)
| btn == btn' -> pure True
SDL.JoyButtonEvent (SDL.JoyButtonEventData _ btn' SDL.JoyButtonReleased)
| btn == btn' -> pure False
SDL.JoyAxisEvent (SDL.JoyAxisEventData _ btn' _)
| btn == btn' -> pure True
_ -> Nothing
makeEvents
:: Keys
-> Keys
-> [SDL.EventPayload]
-> (SDL.Scancode -> Bool) -> [(Key, SDL.Scancode)]
-> (Keys, Keys)
makeEvents !current !joycurrent payload !isKeyPressed keyboardKeys =
let
keyboard =
fmap (fmap isKeyPressed)
controller =
fmap
(\(key, btn) ->
( key
,
let
es = mapMaybe (checkControllerEvent btn) payload
in
if null es
then keepState (M.lookup key joycurrent)
else any id es
)
)
$ defControllerButtonMap
in
( updateKeys current
. M.fromListWith max
. keyboard
$ keyboardKeys
, updateKeys joycurrent
. M.fromListWith max
$ controller
)
updateKeys :: Keys -> M.Map Key Bool -> Keys
updateKeys !keys !newStates =
flip M.mapWithKey keys $ \k s ->
case (s, testKey k newStates) of
(Idle, True) -> Click
(Click, True) -> Hold
(Hold, True) -> Hold
(Release, True) -> Click
(Idle, False) -> Idle
(Click, False) -> Release
(Hold, False) -> Release
(Release, False) -> Idle
testKey :: Key -> M.Map Key Bool -> Bool
testKey key = maybe False id . M.lookup key
keyReleased :: Key -> Input -> Bool
keyReleased key = keyReleased' key . inputKeys
keyClicked :: Key -> Input -> Bool
keyClicked key = keyClicked' key . inputKeys
keyPressed :: Key -> Input -> Bool
keyPressed key = keyPressed' key . inputKeys
keyIdle :: Key -> Input -> Bool
keyIdle key = keyIdle' key . inputKeys
keyReleased' :: Key -> Keys -> Bool
keyReleased' key = maybe False (== Release) . M.lookup key
keyClicked' :: Key -> Keys -> Bool
keyClicked' key = maybe False (== Click) . M.lookup key
keyPressed' :: Key -> Keys -> Bool
keyPressed' key = maybe False (/= Idle) . M.lookup key
keyIdle' :: Key -> Keys -> Bool
keyIdle' key = maybe False (== Idle) . M.lookup key
keysToMovement :: Float -> Input -> FPoint
keysToMovement speed keys =
let
singleMove k1 k2
| keyPressed k1 keys && not (keyPressed k2 keys) = -speed
| keyPressed k2 keys && not (keyPressed k1 keys) = speed
| otherwise = 0
hori = singleMove KeyUp KeyDown
vert = singleMove KeyLeft KeyRight
in Point vert hori