{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
module Device.Nintendo.Switch.Output where
import Control.Exception (Exception, throwIO)
import Control.Monad (join, when)
import Data.Bits ((.|.), (.&.), shiftL, shiftR)
import Data.IORef (IORef, readIORef, writeIORef)
import Data.Word (Word8, Word32)
import qualified Data.ByteString as BS
import System.HIDAPI (Device, write)
import Device.Nintendo.Switch.Controller (Controller(..), ControllerType(..))
import Device.Nintendo.Switch.Utils (clamp, combine, discretize, pairs)
class HasHomeLight t
instance HasHomeLight 'RightJoyCon
instance HasHomeLight 'ProController
class HasLeftRumble t
instance HasLeftRumble 'LeftJoyCon
instance HasLeftRumble 'ProController
class HasRightRumble t
instance HasRightRumble 'RightJoyCon
instance HasRightRumble 'ProController
class HasPlayerLights t
instance HasPlayerLights 'LeftJoyCon
instance HasPlayerLights 'RightJoyCon
instance HasPlayerLights 'ProController
class HasInputMode t
instance HasInputMode 'LeftJoyCon
instance HasInputMode 'RightJoyCon
data OutputException = WriteException
instance Exception OutputException
instance Show OutputException where
show :: OutputException -> String
show OutputException
WriteException = String
"Could not send all data to the controller device."
type BaseDuration = Word8
type Intensity = Word8
type FadeFactor = Word8
type LightFactor = Word8
type CycleConfig = (Intensity, FadeFactor, LightFactor)
data RepeatBehaviour
= Forever
| Times Word8
deriving (RepeatBehaviour -> RepeatBehaviour -> Bool
(RepeatBehaviour -> RepeatBehaviour -> Bool)
-> (RepeatBehaviour -> RepeatBehaviour -> Bool)
-> Eq RepeatBehaviour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RepeatBehaviour -> RepeatBehaviour -> Bool
$c/= :: RepeatBehaviour -> RepeatBehaviour -> Bool
== :: RepeatBehaviour -> RepeatBehaviour -> Bool
$c== :: RepeatBehaviour -> RepeatBehaviour -> Bool
Eq, ReadPrec [RepeatBehaviour]
ReadPrec RepeatBehaviour
Int -> ReadS RepeatBehaviour
ReadS [RepeatBehaviour]
(Int -> ReadS RepeatBehaviour)
-> ReadS [RepeatBehaviour]
-> ReadPrec RepeatBehaviour
-> ReadPrec [RepeatBehaviour]
-> Read RepeatBehaviour
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RepeatBehaviour]
$creadListPrec :: ReadPrec [RepeatBehaviour]
readPrec :: ReadPrec RepeatBehaviour
$creadPrec :: ReadPrec RepeatBehaviour
readList :: ReadS [RepeatBehaviour]
$creadList :: ReadS [RepeatBehaviour]
readsPrec :: Int -> ReadS RepeatBehaviour
$creadsPrec :: Int -> ReadS RepeatBehaviour
Read, Int -> RepeatBehaviour -> ShowS
[RepeatBehaviour] -> ShowS
RepeatBehaviour -> String
(Int -> RepeatBehaviour -> ShowS)
-> (RepeatBehaviour -> String)
-> ([RepeatBehaviour] -> ShowS)
-> Show RepeatBehaviour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepeatBehaviour] -> ShowS
$cshowList :: [RepeatBehaviour] -> ShowS
show :: RepeatBehaviour -> String
$cshow :: RepeatBehaviour -> String
showsPrec :: Int -> RepeatBehaviour -> ShowS
$cshowsPrec :: Int -> RepeatBehaviour -> ShowS
Show)
data HomeLightConfig
= Off
| Once BaseDuration Intensity CycleConfig
| Cyclic BaseDuration Intensity [CycleConfig] RepeatBehaviour
deriving (HomeLightConfig -> HomeLightConfig -> Bool
(HomeLightConfig -> HomeLightConfig -> Bool)
-> (HomeLightConfig -> HomeLightConfig -> Bool)
-> Eq HomeLightConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HomeLightConfig -> HomeLightConfig -> Bool
$c/= :: HomeLightConfig -> HomeLightConfig -> Bool
== :: HomeLightConfig -> HomeLightConfig -> Bool
$c== :: HomeLightConfig -> HomeLightConfig -> Bool
Eq, ReadPrec [HomeLightConfig]
ReadPrec HomeLightConfig
Int -> ReadS HomeLightConfig
ReadS [HomeLightConfig]
(Int -> ReadS HomeLightConfig)
-> ReadS [HomeLightConfig]
-> ReadPrec HomeLightConfig
-> ReadPrec [HomeLightConfig]
-> Read HomeLightConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HomeLightConfig]
$creadListPrec :: ReadPrec [HomeLightConfig]
readPrec :: ReadPrec HomeLightConfig
$creadPrec :: ReadPrec HomeLightConfig
readList :: ReadS [HomeLightConfig]
$creadList :: ReadS [HomeLightConfig]
readsPrec :: Int -> ReadS HomeLightConfig
$creadsPrec :: Int -> ReadS HomeLightConfig
Read, Int -> HomeLightConfig -> ShowS
[HomeLightConfig] -> ShowS
HomeLightConfig -> String
(Int -> HomeLightConfig -> ShowS)
-> (HomeLightConfig -> String)
-> ([HomeLightConfig] -> ShowS)
-> Show HomeLightConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HomeLightConfig] -> ShowS
$cshowList :: [HomeLightConfig] -> ShowS
show :: HomeLightConfig -> String
$cshow :: HomeLightConfig -> String
showsPrec :: Int -> HomeLightConfig -> ShowS
$cshowsPrec :: Int -> HomeLightConfig -> ShowS
Show)
lightConfigCommand :: HomeLightConfig -> [Word8]
lightConfigCommand :: HomeLightConfig -> [Word8]
lightConfigCommand = \case
HomeLightConfig
Off ->
Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
25 Word8
0x00
Once Word8
dur Word8
int (Word8
cycInt, Word8
fade, Word8
cycDur) ->
let
byte0 :: Word8
byte0 = Word8 -> Word8
scaleDuration Word8
dur
byte1 :: Word8
byte1 = Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Word8
scaleIntensity Word8
int) Int
4
byte2 :: Word8
byte2 = Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
shiftL (Word8 -> Word8
scaleIntensity Word8
cycInt) Int
4
byte3H :: Word8
byte3H = Word8 -> Word8
clampMultiplier Word8
fade
byte3L :: Word8
byte3L = Word8 -> Word8
clampMultiplier Word8
cycDur
in
Word8
byte0 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
byte1 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
byte2 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8 -> Word8 -> Word8
combine Word8
byte3H Word8
byte3L Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
45 Word8
0x00
Cyclic Word8
dur Word8
int [(Word8, Word8, Word8)]
cfgs RepeatBehaviour
rep ->
let
cycles :: [(Word8, Word8, Word8)]
cycles = Int -> [(Word8, Word8, Word8)] -> [(Word8, Word8, Word8)]
forall a. Int -> [a] -> [a]
take Int
15 [(Word8, Word8, Word8)]
cfgs
byte0H :: Int
byte0H = [(Word8, Word8, Word8)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Word8, Word8, Word8)]
cycles
byte0L :: Word8
byte0L = Word8 -> Word8
scaleDuration Word8
dur
byte1H :: Word8
byte1H = Word8 -> Word8
scaleIntensity Word8
int
byte1L :: Word8
byte1L = case RepeatBehaviour
rep of
RepeatBehaviour
Forever -> Word8
0x0
Times Word8
n -> Word8 -> Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a -> a
clamp Word8
1 Word8
15 Word8
n
padded :: [(Word8, Word8, Word8)]
padded = [(Word8, Word8, Word8)]
cycles [(Word8, Word8, Word8)]
-> [(Word8, Word8, Word8)] -> [(Word8, Word8, Word8)]
forall a. [a] -> [a] -> [a]
++ Int -> (Word8, Word8, Word8) -> [(Word8, Word8, Word8)]
forall a. Int -> a -> [a]
replicate (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
byte0H) (Word8
0,Word8
0,Word8
0)
pairBytes :: [[Word8]]
pairBytes = (((Word8, Word8, Word8), (Word8, Word8, Word8)) -> [Word8])
-> [((Word8, Word8, Word8), (Word8, Word8, Word8))] -> [[Word8]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Word8, Word8, Word8) -> (Word8, Word8, Word8) -> [Word8])
-> ((Word8, Word8, Word8), (Word8, Word8, Word8)) -> [Word8]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Word8, Word8, Word8) -> (Word8, Word8, Word8) -> [Word8]
pairCommand) ([((Word8, Word8, Word8), (Word8, Word8, Word8))] -> [[Word8]])
-> [((Word8, Word8, Word8), (Word8, Word8, Word8))] -> [[Word8]]
forall a b. (a -> b) -> a -> b
$ [(Word8, Word8, Word8)]
-> [((Word8, Word8, Word8), (Word8, Word8, Word8))]
forall a. [a] -> [(a, a)]
pairs [(Word8, Word8, Word8)]
padded
in
Word8 -> Word8 -> Word8
combine (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
byte0H) Word8
byte0L
Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8 -> Word8 -> Word8
combine Word8
byte1H Word8
byte1L
Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [[Word8]] -> [Word8]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[Word8]]
pairBytes
[Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
23 Word8
0x00
where
scaleIntensity :: Word8 -> Word8
scaleIntensity = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8
forall a b. (Real a, Integral b) => a -> a -> b -> b -> a -> b
discretize Word8
0 Word8
100 Word8
0 Word8
15
scaleDuration :: Word8 -> Word8
scaleDuration = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8
forall a b. (Real a, Integral b) => a -> a -> b -> b -> a -> b
discretize Word8
8 Word8
175 Word8
0 Word8
15
clampMultiplier :: Word8 -> Word8
clampMultiplier = Word8 -> Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a -> a
clamp Word8
0 Word8
15
pairCommand :: CycleConfig -> CycleConfig -> [Word8]
pairCommand :: (Word8, Word8, Word8) -> (Word8, Word8, Word8) -> [Word8]
pairCommand (Word8
int1, Word8
fade1, Word8
dur1) (Word8
int2, Word8
fade2, Word8
dur2) =
let
byte0H :: Word8
byte0H = Word8 -> Word8
scaleIntensity Word8
int1
byte0L :: Word8
byte0L = Word8 -> Word8
scaleIntensity Word8
int2
byte1H :: Word8
byte1H = Word8 -> Word8
clampMultiplier Word8
fade1
byte1L :: Word8
byte1L = Word8 -> Word8
clampMultiplier Word8
dur1
byte2H :: Word8
byte2H = Word8 -> Word8
clampMultiplier Word8
fade2
byte2L :: Word8
byte2L = Word8 -> Word8
clampMultiplier Word8
dur2
in
[Word8 -> Word8 -> Word8
combine Word8
byte0H Word8
byte0L, Word8 -> Word8 -> Word8
combine Word8
byte1H Word8
byte1L, Word8 -> Word8 -> Word8
combine Word8
byte2H Word8
byte2L]
endlessPulse :: HomeLightConfig
endlessPulse :: HomeLightConfig
endlessPulse =
Word8
-> Word8
-> [(Word8, Word8, Word8)]
-> RepeatBehaviour
-> HomeLightConfig
Cyclic
( Word8
100 )
( Word8
0 )
[ (Word8
100, Word8
5, Word8
1), (Word8
0, Word8
5, Word8
1) ]
( RepeatBehaviour
Forever )
setHomeLight :: HasHomeLight t => HomeLightConfig -> Controller t -> IO ()
setHomeLight :: HomeLightConfig -> Controller t -> IO ()
setHomeLight HomeLightConfig
cfg Controller t
controller =
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x38 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
HomeLightConfig -> [Word8]
lightConfigCommand HomeLightConfig
cfg
setInertialMeasurement :: Bool -> Controller t -> IO ()
setInertialMeasurement :: Bool -> Controller t -> IO ()
setInertialMeasurement Bool
on Controller t
controller =
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x40 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
(if Bool
on then Word8
0x01 else Word8
0x00) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
48 Word8
0x00
data InputMode
= Standard
| Simple
deriving (InputMode -> InputMode -> Bool
(InputMode -> InputMode -> Bool)
-> (InputMode -> InputMode -> Bool) -> Eq InputMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputMode -> InputMode -> Bool
$c/= :: InputMode -> InputMode -> Bool
== :: InputMode -> InputMode -> Bool
$c== :: InputMode -> InputMode -> Bool
Eq, ReadPrec [InputMode]
ReadPrec InputMode
Int -> ReadS InputMode
ReadS [InputMode]
(Int -> ReadS InputMode)
-> ReadS [InputMode]
-> ReadPrec InputMode
-> ReadPrec [InputMode]
-> Read InputMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [InputMode]
$creadListPrec :: ReadPrec [InputMode]
readPrec :: ReadPrec InputMode
$creadPrec :: ReadPrec InputMode
readList :: ReadS [InputMode]
$creadList :: ReadS [InputMode]
readsPrec :: Int -> ReadS InputMode
$creadsPrec :: Int -> ReadS InputMode
Read, Int -> InputMode -> ShowS
[InputMode] -> ShowS
InputMode -> String
(Int -> InputMode -> ShowS)
-> (InputMode -> String)
-> ([InputMode] -> ShowS)
-> Show InputMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputMode] -> ShowS
$cshowList :: [InputMode] -> ShowS
show :: InputMode -> String
$cshow :: InputMode -> String
showsPrec :: Int -> InputMode -> ShowS
$cshowsPrec :: Int -> InputMode -> ShowS
Show)
setInputMode :: HasInputMode t => InputMode -> Controller t -> IO ()
setInputMode :: InputMode -> Controller t -> IO ()
setInputMode = InputMode -> Controller t -> IO ()
forall (t :: ControllerType). InputMode -> Controller t -> IO ()
setInputModeInternal
setInputModeInternal :: InputMode -> Controller t -> IO ()
setInputModeInternal :: InputMode -> Controller t -> IO ()
setInputModeInternal InputMode
mode Controller t
controller =
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x03 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
InputMode -> Word8
toByte InputMode
mode Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
48 Word8
0x00
where
toByte :: InputMode -> Word8
toByte = \case
InputMode
Standard -> Word8
0x30
InputMode
Simple -> Word8
0x3F
neutralPartRumble :: [Word8]
neutralPartRumble :: [Word8]
neutralPartRumble = [Word8
0x00, Word8
0x01, Word8
0x40, Word8
0x40]
neutralRumble :: [Word8]
neutralRumble :: [Word8]
neutralRumble = [Word8]
neutralPartRumble [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8]
neutralPartRumble
sendCommand :: Device -> Word8 -> [Word8] -> IO ()
sendCommand :: Device -> Word8 -> [Word8] -> IO ()
sendCommand Device
dev Word8
cmdID [Word8]
cmdData = do
Int
size <- Device -> ByteString -> IO Int
write Device
dev (ByteString -> IO Int) -> ByteString -> IO Int
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack (Word8
cmdID Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
cmdData)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ OutputException -> IO ()
forall e a. Exception e => e -> IO a
throwIO OutputException
WriteException
sendRawSubcommand :: Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand :: Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand Device
dev IORef Word8
ref Word8
cmdID Word8
subID [Word8]
subData = do
Word8
count <- IORef Word8 -> IO Word8
forall a. IORef a -> IO a
readIORef IORef Word8
ref
Device -> Word8 -> [Word8] -> IO ()
sendCommand Device
dev Word8
cmdID ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8
count Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
neutralRumble [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Word8
subID Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
subData
IORef Word8 -> Word8 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Word8
ref (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8
0x0F Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8 -> Word8
forall a. Enum a => a -> a
succ Word8
count
sendSubcommand :: Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand :: Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller =
Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand
( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
( Controller t -> IORef Word8
forall (t :: ControllerType). Controller t -> IORef Word8
counter Controller t
controller )
encodeHF :: (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeHF :: a -> (Word8, Word8)
encodeHF a
freq = (Word8
hfH, Word8
hfL)
where clamped :: a
clamped = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
81.75177 a
1252.572266 a
freq
base :: Int
base = a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
2 (a
clamped a -> a -> a
forall a. Num a => a -> a -> a
* a
0.1) a -> a -> a
forall a. Num a => a -> a -> a
* a
32
hf :: Int
hf = (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x60) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 :: Int
hfH :: Word8
hfH = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
hf Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFF
hfL :: Word8
hfL = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
hf Int
8 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFF
encodeLF :: (Floating a, RealFrac a) => a -> Word8
encodeLF :: a -> Word8
encodeLF a
freq = Word8
base Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0x40
where clamped :: a
clamped = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
40.875885 a
626.286133 a
freq
base :: Word8
base = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
2 (a
clamped a -> a -> a
forall a. Num a => a -> a -> a
* a
0.1) a -> a -> a
forall a. Num a => a -> a -> a
* a
32
encodeHA :: (Floating a, RealFrac a) => a -> Word8
encodeHA :: a -> Word8
encodeHA a
amp | a
clamped a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0.117 = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ (a
base a -> a -> a
forall a. Num a => a -> a -> a
- a
0x60) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
5 a -> a -> a
forall a. Num a => a -> a -> a
- (a
2 a -> a -> a
forall a. Floating a => a -> a -> a
** a
clamped)) a -> a -> a
forall a. Num a => a -> a -> a
- a
1
| a
clamped a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0.23 = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ (a
base a -> a -> a
forall a. Num a => a -> a -> a
- a
0x60) a -> a -> a
forall a. Num a => a -> a -> a
* a
2 a -> a -> a
forall a. Num a => a -> a -> a
- a
0xF6
| Bool
otherwise = a -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
base a -> a -> a
forall a. Num a => a -> a -> a
- a
0xBC
where clamped :: a
clamped = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
0.0 a
1.0 a
amp
base :: a
base = a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
2 (a
clamped a -> a -> a
forall a. Num a => a -> a -> a
* a
1000) a -> a -> a
forall a. Num a => a -> a -> a
* a
32
encodeLA :: (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeLA :: a -> (Word8, Word8)
encodeLA a
amp = (Word8
laH, Word8
laL)
where encoded :: Word8
encoded = a -> Word8
forall a. (Floating a, RealFrac a) => a -> Word8
encodeHA a
amp Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
2
isOdd :: Bool
isOdd = Word8 -> Bool
forall a. Integral a => a -> Bool
odd Word8
encoded
laH :: Word8
laH = if Bool
isOdd then Word8
0x80 else Word8
0x00
laL :: Word8
laL = Word8
0x40 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (if Bool
isOdd then Word8
encoded Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1 else Word8
encoded) Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
2
rumblePartCommand :: RumbleConfig -> [Word8]
rumblePartCommand :: RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
cfg = let
(Word8
hfH, Word8
hfL) = Double -> (Word8, Word8)
forall a. (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeHF (Double -> (Word8, Word8)) -> Double -> (Word8, Word8)
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
highFrequency RumbleConfig
cfg
ha :: Word8
ha = Double -> Word8
forall a. (Floating a, RealFrac a) => a -> Word8
encodeHA (Double -> Word8) -> Double -> Word8
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
highAmplitude RumbleConfig
cfg
lf :: Word8
lf = Double -> Word8
forall a. (Floating a, RealFrac a) => a -> Word8
encodeLF (Double -> Word8) -> Double -> Word8
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
lowFrequency RumbleConfig
cfg
(Word8
laH, Word8
laL) = Double -> (Word8, Word8)
forall a. (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeLA (Double -> (Word8, Word8)) -> Double -> (Word8, Word8)
forall a b. (a -> b) -> a -> b
$ RumbleConfig -> Double
lowAmplitude RumbleConfig
cfg
in [Word8
hfH, Word8
ha Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
hfL, Word8
lf Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
laH, Word8
laL]
data RumbleConfig =
RumbleConfig
{ RumbleConfig -> Double
highFrequency :: Double
, RumbleConfig -> Double
highAmplitude :: Double
, RumbleConfig -> Double
lowFrequency :: Double
, RumbleConfig -> Double
lowAmplitude :: Double
}
deriving (RumbleConfig -> RumbleConfig -> Bool
(RumbleConfig -> RumbleConfig -> Bool)
-> (RumbleConfig -> RumbleConfig -> Bool) -> Eq RumbleConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RumbleConfig -> RumbleConfig -> Bool
$c/= :: RumbleConfig -> RumbleConfig -> Bool
== :: RumbleConfig -> RumbleConfig -> Bool
$c== :: RumbleConfig -> RumbleConfig -> Bool
Eq, ReadPrec [RumbleConfig]
ReadPrec RumbleConfig
Int -> ReadS RumbleConfig
ReadS [RumbleConfig]
(Int -> ReadS RumbleConfig)
-> ReadS [RumbleConfig]
-> ReadPrec RumbleConfig
-> ReadPrec [RumbleConfig]
-> Read RumbleConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RumbleConfig]
$creadListPrec :: ReadPrec [RumbleConfig]
readPrec :: ReadPrec RumbleConfig
$creadPrec :: ReadPrec RumbleConfig
readList :: ReadS [RumbleConfig]
$creadList :: ReadS [RumbleConfig]
readsPrec :: Int -> ReadS RumbleConfig
$creadsPrec :: Int -> ReadS RumbleConfig
Read, Int -> RumbleConfig -> ShowS
[RumbleConfig] -> ShowS
RumbleConfig -> String
(Int -> RumbleConfig -> ShowS)
-> (RumbleConfig -> String)
-> ([RumbleConfig] -> ShowS)
-> Show RumbleConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RumbleConfig] -> ShowS
$cshowList :: [RumbleConfig] -> ShowS
show :: RumbleConfig -> String
$cshow :: RumbleConfig -> String
showsPrec :: Int -> RumbleConfig -> ShowS
$cshowsPrec :: Int -> RumbleConfig -> ShowS
Show)
normalRumble :: RumbleConfig
normalRumble :: RumbleConfig
normalRumble =
RumbleConfig :: Double -> Double -> Double -> Double -> RumbleConfig
RumbleConfig
{ highFrequency :: Double
highFrequency = Double
800
, highAmplitude :: Double
highAmplitude = Double
0.5
, lowFrequency :: Double
lowFrequency = Double
330
, lowAmplitude :: Double
lowAmplitude = Double
0.75
}
noRumble :: RumbleConfig
noRumble :: RumbleConfig
noRumble =
RumbleConfig :: Double -> Double -> Double -> Double -> RumbleConfig
RumbleConfig
{ highFrequency :: Double
highFrequency = Double
320
, highAmplitude :: Double
highAmplitude = Double
0
, lowFrequency :: Double
lowFrequency = Double
160
, lowAmplitude :: Double
lowAmplitude = Double
0
}
setVibration :: Bool -> Controller t -> IO ()
setVibration :: Bool -> Controller t -> IO ()
setVibration Bool
on Controller t
controller =
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x48 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
(if Bool
on then Word8
0x01 else Word8
0x00) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
48 Word8
0x00
setLeftRumble :: HasLeftRumble t => RumbleConfig -> Controller t -> IO ()
setLeftRumble :: RumbleConfig -> Controller t -> IO ()
setLeftRumble RumbleConfig
cfg Controller t
controller =
Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand
( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
cfg )
( [Word8]
neutralPartRumble )
setRightRumble :: HasRightRumble t => RumbleConfig -> Controller t -> IO ()
setRightRumble :: RumbleConfig -> Controller t -> IO ()
setRightRumble RumbleConfig
cfg Controller t
controller =
Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand
( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
( [Word8]
neutralPartRumble )
( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
cfg )
setRumble
:: (HasLeftRumble t, HasRightRumble t)
=> RumbleConfig
-> RumbleConfig
-> Controller t
-> IO ()
setRumble :: RumbleConfig -> RumbleConfig -> Controller t -> IO ()
setRumble RumbleConfig
leftCfg RumbleConfig
rightCfg Controller t
controller =
Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand
( Controller t -> Device
forall (t :: ControllerType). Controller t -> Device
handle Controller t
controller )
( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
leftCfg )
( RumbleConfig -> [Word8]
rumblePartCommand RumbleConfig
rightCfg )
sendRawRumbleCommand :: Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand :: Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand Device
dev [Word8]
left [Word8]
right =
Device -> Word8 -> [Word8] -> IO ()
sendCommand Device
dev Word8
0x10 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8
0x00 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
left [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ [Word8]
right [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
40 Word8
0x00
requestRawSPI :: Device -> IORef Word8 -> Word32 -> Word8 -> IO ()
requestRawSPI :: Device -> IORef Word8 -> Word32 -> Word8 -> IO ()
requestRawSPI Device
dev IORef Word8
ref Word32
start Word8
len =
let
byte0 :: Word8
byte0 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x000000FF
byte1 :: Word8
byte1 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x0000FF00) Int
8
byte2 :: Word8
byte2 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x00FF0000) Int
16
byte3 :: Word8
byte3 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Word32
start Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF000000) Int
24
in
Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand Device
dev IORef Word8
ref Word8
0x01 Word8
0x10 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
[Word8
byte0, Word8
byte1, Word8
byte2, Word8
byte3, Word8 -> Word8 -> Word8 -> Word8
forall a. Ord a => a -> a -> a -> a
clamp Word8
0x00 Word8
0x1D Word8
len] [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
44 Word8
0x00
data PlayerLightsConfig =
PlayerLightsConfig
{ PlayerLightsConfig -> LightMode
led0 :: LightMode
, PlayerLightsConfig -> LightMode
led1 :: LightMode
, PlayerLightsConfig -> LightMode
led2 :: LightMode
, PlayerLightsConfig -> LightMode
led3 :: LightMode
}
deriving (PlayerLightsConfig -> PlayerLightsConfig -> Bool
(PlayerLightsConfig -> PlayerLightsConfig -> Bool)
-> (PlayerLightsConfig -> PlayerLightsConfig -> Bool)
-> Eq PlayerLightsConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
$c/= :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
== :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
$c== :: PlayerLightsConfig -> PlayerLightsConfig -> Bool
Eq, ReadPrec [PlayerLightsConfig]
ReadPrec PlayerLightsConfig
Int -> ReadS PlayerLightsConfig
ReadS [PlayerLightsConfig]
(Int -> ReadS PlayerLightsConfig)
-> ReadS [PlayerLightsConfig]
-> ReadPrec PlayerLightsConfig
-> ReadPrec [PlayerLightsConfig]
-> Read PlayerLightsConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PlayerLightsConfig]
$creadListPrec :: ReadPrec [PlayerLightsConfig]
readPrec :: ReadPrec PlayerLightsConfig
$creadPrec :: ReadPrec PlayerLightsConfig
readList :: ReadS [PlayerLightsConfig]
$creadList :: ReadS [PlayerLightsConfig]
readsPrec :: Int -> ReadS PlayerLightsConfig
$creadsPrec :: Int -> ReadS PlayerLightsConfig
Read, Int -> PlayerLightsConfig -> ShowS
[PlayerLightsConfig] -> ShowS
PlayerLightsConfig -> String
(Int -> PlayerLightsConfig -> ShowS)
-> (PlayerLightsConfig -> String)
-> ([PlayerLightsConfig] -> ShowS)
-> Show PlayerLightsConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayerLightsConfig] -> ShowS
$cshowList :: [PlayerLightsConfig] -> ShowS
show :: PlayerLightsConfig -> String
$cshow :: PlayerLightsConfig -> String
showsPrec :: Int -> PlayerLightsConfig -> ShowS
$cshowsPrec :: Int -> PlayerLightsConfig -> ShowS
Show)
data LightMode
= LightOn
| LightOff
| Flashing
deriving (LightMode -> LightMode -> Bool
(LightMode -> LightMode -> Bool)
-> (LightMode -> LightMode -> Bool) -> Eq LightMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LightMode -> LightMode -> Bool
$c/= :: LightMode -> LightMode -> Bool
== :: LightMode -> LightMode -> Bool
$c== :: LightMode -> LightMode -> Bool
Eq, ReadPrec [LightMode]
ReadPrec LightMode
Int -> ReadS LightMode
ReadS [LightMode]
(Int -> ReadS LightMode)
-> ReadS [LightMode]
-> ReadPrec LightMode
-> ReadPrec [LightMode]
-> Read LightMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LightMode]
$creadListPrec :: ReadPrec [LightMode]
readPrec :: ReadPrec LightMode
$creadPrec :: ReadPrec LightMode
readList :: ReadS [LightMode]
$creadList :: ReadS [LightMode]
readsPrec :: Int -> ReadS LightMode
$creadsPrec :: Int -> ReadS LightMode
Read, Int -> LightMode -> ShowS
[LightMode] -> ShowS
LightMode -> String
(Int -> LightMode -> ShowS)
-> (LightMode -> String)
-> ([LightMode] -> ShowS)
-> Show LightMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LightMode] -> ShowS
$cshowList :: [LightMode] -> ShowS
show :: LightMode -> String
$cshow :: LightMode -> String
showsPrec :: Int -> LightMode -> ShowS
$cshowsPrec :: Int -> LightMode -> ShowS
Show)
noPlayerLights :: PlayerLightsConfig
noPlayerLights :: PlayerLightsConfig
noPlayerLights =
PlayerLightsConfig :: LightMode
-> LightMode -> LightMode -> LightMode -> PlayerLightsConfig
PlayerLightsConfig
{ led0 :: LightMode
led0 = LightMode
LightOff
, led1 :: LightMode
led1 = LightMode
LightOff
, led2 :: LightMode
led2 = LightMode
LightOff
, led3 :: LightMode
led3 = LightMode
LightOff
}
playerOne :: PlayerLightsConfig
playerOne :: PlayerLightsConfig
playerOne = PlayerLightsConfig
noPlayerLights { led0 :: LightMode
led0 = LightMode
LightOn }
playerTwo :: PlayerLightsConfig
playerTwo :: PlayerLightsConfig
playerTwo = PlayerLightsConfig
noPlayerLights { led1 :: LightMode
led1 = LightMode
LightOn }
playerThree :: PlayerLightsConfig
playerThree :: PlayerLightsConfig
playerThree = PlayerLightsConfig
noPlayerLights { led2 :: LightMode
led2 = LightMode
LightOn }
playerFour :: PlayerLightsConfig
playerFour :: PlayerLightsConfig
playerFour = PlayerLightsConfig
noPlayerLights { led3 :: LightMode
led3 = LightMode
LightOn }
flashAll :: PlayerLightsConfig
flashAll :: PlayerLightsConfig
flashAll =
PlayerLightsConfig :: LightMode
-> LightMode -> LightMode -> LightMode -> PlayerLightsConfig
PlayerLightsConfig
{ led0 :: LightMode
led0 = LightMode
Flashing
, led1 :: LightMode
led1 = LightMode
Flashing
, led2 :: LightMode
led2 = LightMode
Flashing
, led3 :: LightMode
led3 = LightMode
Flashing
}
setPlayerLights :: HasPlayerLights t => PlayerLightsConfig -> Controller t -> IO ()
setPlayerLights :: PlayerLightsConfig -> Controller t -> IO ()
setPlayerLights PlayerLightsConfig
config Controller t
controller =
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
forall (t :: ControllerType).
Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand Controller t
controller Word8
0x01 Word8
0x30 ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$
[ (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led0 Word8
0x01
(Word8 -> Word8) -> (Word8 -> Word8) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led1 Word8
0x02
(Word8 -> Word8) -> (Word8 -> Word8) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led2 Word8
0x04
(Word8 -> Word8) -> (Word8 -> Word8) -> Word8 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlayerLightsConfig -> LightMode) -> Word8 -> Word8 -> Word8
forall a.
Bits a =>
(PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
led3 Word8
0x08
(Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ Word8
0x00
]
where
setBit :: (PlayerLightsConfig -> LightMode) -> a -> a -> a
setBit PlayerLightsConfig -> LightMode
f a
position =
case PlayerLightsConfig -> LightMode
f PlayerLightsConfig
config of
LightMode
LightOn -> (a
position a -> a -> a
forall a. Bits a => a -> a -> a
.|.)
LightMode
LightOff -> a -> a
forall a. a -> a
id
LightMode
Flashing -> (a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftL a
position Int
4 a -> a -> a
forall a. Bits a => a -> a -> a
.|.)