Output.hs

{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds  #-}
module Device.Nintendo.Switch.Output where

-- base
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)

-- bytestring
import qualified Data.ByteString as BS

-- hidapi
import System.HIDAPI (Device, write)

-- switch
import Device.Nintendo.Switch.Controller (Controller(..), ControllerType(..))
import Device.Nintendo.Switch.Utils      (clamp, combine, discretize, pairs)

-- | A constraint which indicates that a Nintendo Switch controller has a home
-- light (see 'setHomeLight').
class HasHomeLight t

instance HasHomeLight 'RightJoyCon
instance HasHomeLight 'ProController

-- | A constraint which indicates that a Nintendo Switch controller has a left-side
-- rumble unit (see 'setLeftRumble').
class HasLeftRumble t

instance HasLeftRumble 'LeftJoyCon
instance HasLeftRumble 'ProController

-- | A constraint which indicates that a Nintendo Switch controller has a right-side
-- rumble unit (see 'setRightRumble').
class HasRightRumble t

instance HasRightRumble 'RightJoyCon
instance HasRightRumble 'ProController

-- | A constraint which indicates that a Nintendo Switch controller has player lights
-- (i.e., the four LEDs which represent the player number; see 'setPlayerLights').
class HasPlayerLights t

instance HasPlayerLights 'LeftJoyCon
instance HasPlayerLights 'RightJoyCon
instance HasPlayerLights 'ProController

-- | A constraint which indicates that a Nintendo Switch controller supports multiple
-- input modes (see 'setInputMode').
class HasInputMode t

instance HasInputMode 'LeftJoyCon
instance HasInputMode 'RightJoyCon

-- | An 'OutputException' is thrown if something goes wrong when sending commands to
-- a Nintendo Switch controller.
data OutputException = WriteException

instance Exception OutputException
instance Show OutputException where
  show WriteException = "Could not send all data to the controller device."

-- | The base duration of a home light configuration in milliseconds. It will
-- always be limited to an interval between 8ms and 175ms. It is called base
-- duration because it will be multiplied with other factors in order to obtain
-- the overall durations of fadings within home light configurations.
type BaseDuration = Word8

-- | The LED intensity of the home light. It will always be limited to an interval
-- between 0 and 100.
type Intensity = Word8

-- | The fade duration factor of the home light. It will always be limited to an
-- interval between 0 and 15 and is multiplied with the 'BaseDuration' to obtain
-- the overall fade duration in milliseconds.
type FadeFactor = Word8

-- | The light duration factor of the home light. It will always be limited to an
-- interval between 0 and 15 and is multiplied with the 'BaseDuration' to obtain
-- the overall light duration in milliseconds.
type LightFactor = Word8

-- | A home light cycle consists of a target LED intensity, a fade factor which
-- controls the time needed to reach that LED intensity, and a light factor which
-- controls how long to keep the target LED intensity up.
type CycleConfig = (Intensity, FadeFactor, LightFactor)

-- | Defines the repeat behaviour after all the home light configuration cycles
-- have ended.
data RepeatBehaviour
  = Forever
    -- ^ Repeat the configured home light configuration cycles forever.
  | Times Word8
    -- ^ Repeat the configured home light configuration cycles a specific amount
    -- of times. It will always be limited to an interval between 1 and 15.
  deriving (Eq, Read, Show)

-- | The home light of a Nintendo Switch Controller can be controlled using repeatable
-- configuration cycles. See 'endlessPulse' for an example configuration.
data HomeLightConfig
  = Off
    -- ^ Turn off the home light.
  | Once BaseDuration Intensity CycleConfig
    -- ^ Given a start intensity of the home light LED, fade to a target LED
    -- intensity in a given time, and then keep this LED intensity up for a given
    -- amount of time.
    --
    -- The fade duration in milliseconds is calculated by multiplying the 'BaseDuration'
    -- with the 'FadeFactor' of the 'CycleConfig'. The light upkeep duration in
    -- milliseconds is calculated by multiplying the 'BaseDuration' with the 'LightFactor'
    -- of the 'CycleConfig'.
    --
    -- Example - fade from a switched off LED (@0@) to a fully bright LED (@100@) in 500ms
    -- (@50@ms * @10@), stay there for one second (@50@ms * @20@), then turn it off:
    --
    -- @
    --     'Once' 50 0 (100, 10, 20)
    -- @
  | Cyclic BaseDuration Intensity [CycleConfig] RepeatBehaviour
    -- ^ Given a start intensity of the home light LED, repeatedly fade to a
    -- target LED intensity in a given time, and then keep this LED intensity up
    -- for a given amount of time. The fade durations and light upkeep durations
    -- are calculated per cycle configuration as described for 'Once'. See
    -- 'endlessPulse' for a cyclic configuration example.
  deriving (Eq, Read, Show)

lightConfigCommand :: HomeLightConfig -> [Word8]
lightConfigCommand = \case
  Off ->
    replicate 25 0x00
  Once dur int (cycInt, fade, cycDur) ->
    let
      byte0  = scaleDuration dur
      byte1  = shiftL (scaleIntensity int) 4
      byte2  = shiftL (scaleIntensity cycInt) 4
      byte3H = clampMultiplier fade
      byte3L = clampMultiplier cycDur
    in
      byte0 : byte1 : byte2 : combine byte3H byte3L : replicate 45 0x00
  Cyclic dur int cfgs rep ->
    let
      cycles = take 15 cfgs
      byte0H = length cycles
      byte0L = scaleDuration dur
      byte1H = scaleIntensity int
      byte1L = case rep of
        Forever -> 0x0
        Times n -> clamp 1 15 n
      padded = cycles ++ replicate (16 - byte0H) (0,0,0)
      pairBytes = fmap (uncurry pairCommand) $ pairs padded
    in
      combine (fromIntegral byte0H) byte0L
        : combine byte1H byte1L
        : join pairBytes
       ++ replicate 23 0x00
  where
    scaleIntensity   = discretize 0 100 0 15
    scaleDuration    = discretize 8 175 0 15
    clampMultiplier  = clamp 0 15
    
    pairCommand :: CycleConfig -> CycleConfig -> [Word8]
    pairCommand (int1, fade1, dur1) (int2, fade2, dur2) =
      let
        byte0H = scaleIntensity int1
        byte0L = scaleIntensity int2
        byte1H = clampMultiplier fade1
        byte1L = clampMultiplier dur1
        byte2H = clampMultiplier fade2
        byte2L = clampMultiplier dur2
      in
        [combine byte0H byte0L, combine byte1H byte1L, combine byte2H byte2L]

-- | A convenient home light configuration which pulsates the home light LED:
--
-- @
--     'Cyclic'
--       ( 100 )         -- Base duration factor is 100ms.
--       (   0 )         -- LED is turned off at the beginning (intensity 0).
--       [ (100, 5, 1)   -- Fade to LED intensity 100 in 500ms (100ms * 5) and stay there for 100ms (100ms * 1).
--       , (  0, 5, 1) ] -- Fade to LED intensity   0 in 500ms (100ms * 5) and stay there for 100ms (100ms * 1).
--       ( Forever )     -- Repeat these two cycles forever, thus generating a pulse-like LED.
-- @
endlessPulse :: HomeLightConfig
endlessPulse =
  Cyclic
    ( 100 )
    ( 0   )
    [ (100, 5, 1), (0, 5, 1) ]
    ( Forever )

-- | Sets the home light (i.e., the LED ring around the home button) of a Nintendo
-- Switch controller.
--
-- Note: After sending a command like this to a controller, it is highly advised
-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'
-- ('Device.Nintendo.Switch.SetHomeLight', to be exact) or at least call
-- 'Device.Nintendo.Switch.getInput' once before sending another command to
-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a
-- convenient way to wait for a specific command reply from the controller.
setHomeLight :: HasHomeLight t => HomeLightConfig -> Controller t -> IO ()
setHomeLight cfg controller =
  sendSubcommand controller 0x01 0x38 $
    lightConfigCommand cfg

-- | Enables ('True') or disables ('False') the inertial measurement unit (i.e., 
-- accelerometer, gyroscope) of a Nintendo Switch controller. Inertial measurement
-- is disabled by default.
--
-- Note: After sending a command like this to a controller, it is highly advised
-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'
-- ('Device.Nintendo.Switch.SetInertialMeasurement', to be exact) or at least call
-- 'Device.Nintendo.Switch.getInput' once before sending another command to
-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a
-- convenient way to wait for a specific command reply from the controller.
setInertialMeasurement :: Bool -> Controller t -> IO ()
setInertialMeasurement on controller =
  sendSubcommand controller 0x01 0x40 $
    (if on then 0x01 else 0x00) : replicate 48 0x00

-- | The input mode of a Nintendo Switch controller determines the frequency and
-- amount of information received by 'Device.Nintendo.Switch.getInput'.
data InputMode
  = Standard
    -- ^ The default input mode. In this mode, controllers push 'Device.Nintendo.Switch.Input'
    -- packages in a 60Hz (Joy-Con) or 120Hz (Pro Controller) frequency, including
    -- 'Device.Nintendo.Switch.battery' information, 'Device.Nintendo.Switch.Analog' stick
    -- directions ('Device.Nintendo.Switch.stickLeft', 'Device.Nintendo.Switch.stickRight')
    -- and 'Device.Nintendo.Switch.Inertial' sensor data ('Device.Nintendo.Switch.extras')
    -- if activated via 'setInertialMeasurement'.
  | Simple
    -- ^ A simple input mode where a controller only pushes its 'Device.Nintendo.Switch.Input'
    -- whenever a button is pressed or a 'Device.Nintendo.Switch.CommandReply' ('Device.Nintendo.Switch.extras')
    -- is sent. In this mode, controllers only send 'Device.Nintendo.Switch.Discrete' stick
    -- directions ('Device.Nintendo.Switch.stickLeft', 'Device.Nintendo.Switch.stickRight')
    -- and no inertial sensor data. Furthermore, 'Device.Nintendo.Switch.battery' information
    -- is only sent in combination with command replies.
  deriving (Eq, Read, Show)

-- | Sets the input mode of a Nintendo Switch controller.
--
-- Note: After sending a command like this to a controller, it is highly advised
-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'
-- ('Device.Nintendo.Switch.SetInputMode', to be exact) or at least call
-- 'Device.Nintendo.Switch.getInput' once before sending another command to
-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a
-- convenient way to wait for a specific command reply from the controller.
setInputMode :: HasInputMode t => InputMode -> Controller t -> IO ()
setInputMode = setInputModeInternal

setInputModeInternal :: InputMode -> Controller t -> IO ()
setInputModeInternal mode controller =
  sendSubcommand controller 0x01 0x03 $
    toByte mode : replicate 48 0x00
  where
    toByte = \case
      Standard -> 0x30
      Simple   -> 0x3F

neutralPartRumble :: [Word8]
neutralPartRumble = [0x00, 0x01, 0x40, 0x40]

neutralRumble :: [Word8]
neutralRumble = neutralPartRumble ++ neutralPartRumble

sendCommand :: Device -> Word8 -> [Word8] -> IO ()
sendCommand dev cmdID cmdData = do
  size <- write dev $ BS.pack (cmdID : cmdData)
  when (size <= 0) $ throwIO WriteException -- should check the size more precisely here

sendRawSubcommand :: Device -> IORef Word8 -> Word8 -> Word8 -> [Word8] -> IO ()
sendRawSubcommand dev ref cmdID subID subData = do
  count <- readIORef ref
  sendCommand dev cmdID $ count : neutralRumble ++ subID : subData
  writeIORef ref $ 0x0F .&. succ count

sendSubcommand :: Controller t -> Word8 -> Word8 -> [Word8] -> IO ()
sendSubcommand controller =
  sendRawSubcommand
    ( handle controller )
    ( counter controller )

encodeHF :: (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeHF freq = (hfH, hfL)
  where clamped = clamp 81.75177 1252.572266 freq
        base = round $ logBase 2 (clamped * 0.1) * 32
        hf = (base - 0x60) * 4 :: Int
        hfH = fromIntegral $ hf .&. 0xFF
        hfL = fromIntegral $ shiftR hf 8 .&. 0xFF

encodeLF :: (Floating a, RealFrac a) => a -> Word8
encodeLF freq = base - 0x40
  where clamped = clamp 40.875885 626.286133 freq
        base = round $ logBase 2 (clamped * 0.1) * 32

encodeHA :: (Floating a, RealFrac a) => a -> Word8
encodeHA amp | clamped < 0.117 = round $ (base - 0x60) / (5 - (2 ** clamped)) - 1
             | clamped >= 0.23 = round $ (base - 0x60) * 2 - 0xF6
             | otherwise = round $ base - 0xBC
  where clamped = clamp 0.0 1.0 amp
        base = logBase 2 (clamped * 1000) * 32

encodeLA :: (Floating a, RealFrac a) => a -> (Word8, Word8)
encodeLA amp = (laH, laL)
  where encoded = encodeHA amp `div` 2
        isOdd = odd encoded
        laH = if isOdd then 0x80 else 0x00
        laL = 0x40 + (if isOdd then encoded - 1 else encoded) `div` 2

rumblePartCommand :: RumbleConfig -> [Word8]
rumblePartCommand cfg = let
    (hfH, hfL) = encodeHF $ highFrequency cfg
    ha         = encodeHA $ highAmplitude cfg
    lf         = encodeLF $ lowFrequency cfg
    (laH, laL) = encodeLA $ lowAmplitude cfg
  in [hfH, ha + hfL, lf + laH, laL]

-- | Nintendo Switch controllers have a HD rumble feature which allows
-- fine-grained control of rumble strengths and directions. As a consequence,
-- a rumble is not configured by a mere numeric value, but by two (high and low)
-- pairs of frequencies and amplitudes. This library constrains the value ranges
-- of frequencies and amplitudes in order to always obtain sane configurations.
-- However, sending extreme values for these pairs over an extended period of time
-- may still damage a controller, so experiment wisely with rather short rumbles.
--
-- For technical discussions and the meaning of these values, one can read
-- <https://github.com/dekuNukem/Nintendo_Switch_Reverse_Engineering/issues/11 this>,
-- for example. A sample rumble configuration is provided by 'normalRumble'.
data RumbleConfig =
  RumbleConfig
    { highFrequency :: Double
      -- ^ The high frequency. It will always be limited to an interval between
      -- 81.75177 Hz and 1252.572266 Hz.
    , highAmplitude :: Double
      -- ^ The high amplitude. It will always be limited to an interval between
      -- 0.0 and 1.0.
    , lowFrequency  :: Double
      -- ^ The low frequency. It will always be limited to an interval between
      -- 40.875885 Hz and 626.286133 Hz.
    , lowAmplitude  :: Double
      -- ^ The low amplitude. It will always be limited to an interval between
      -- 0.0 and 1.0.
    }
  deriving (Eq, Read, Show)

-- | A convenient rumble configuration indicating a medium rumble strength.
--
-- @
--     'RumbleConfig'
--       { 'highFrequency' = 800
--       , 'highAmplitude' = 0.5
--       , 'lowFrequency'  = 330
--       , 'lowAmplitude'  = 0.75
--       }
-- @
normalRumble :: RumbleConfig
normalRumble =
  RumbleConfig
    { highFrequency = 800
    , highAmplitude = 0.5
    , lowFrequency  = 330
    , lowAmplitude  = 0.75
    }

-- | A convenient rumble configuration indicating no rumble.
noRumble :: RumbleConfig
noRumble =
  RumbleConfig
    { highFrequency = 320
    , highAmplitude = 0
    , lowFrequency  = 160
    , lowAmplitude  = 0
    }

-- | Enables ('True') or disables ('False') the rumble feature of a Nintendo
-- Switch controller. The rumble feature is disabled by default.
--
-- Note: After sending a command like this to a controller, it is highly advised
-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'
-- ('Device.Nintendo.Switch.SetVibration', to be exact) or at least call
-- 'Device.Nintendo.Switch.getInput' once before sending another command to
-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a
-- convenient way to wait for a specific command reply from the controller.
setVibration :: Bool -> Controller t -> IO ()
setVibration on controller =
  sendSubcommand controller 0x01 0x48 $
    (if on then 0x01 else 0x00) : replicate 48 0x00

-- | Sets the left rumble of a Nintendo Switch controller.
setLeftRumble :: HasLeftRumble t => RumbleConfig -> Controller t -> IO ()
setLeftRumble cfg controller =
  sendRawRumbleCommand
    ( handle controller )
    ( rumblePartCommand cfg )
    ( neutralPartRumble )

-- | Sets the right rumble of a Nintendo Switch controller.
setRightRumble :: HasRightRumble t => RumbleConfig -> Controller t -> IO ()
setRightRumble cfg controller =
  sendRawRumbleCommand
    ( handle controller )
    ( neutralPartRumble )
    ( rumblePartCommand cfg )

-- | Sets both the left rumble and right rumble of a Nintendo Switch controller.
-- Note that this is more efficient than setting the left rumble and right rumble
-- separately via 'setLeftRumble' and 'setRightRumble'.
setRumble
  :: (HasLeftRumble t, HasRightRumble t)
  => RumbleConfig -- ^ The left-side rumble configuration.
  -> RumbleConfig -- ^ The right-side rumble configuration.
  -> Controller t -- ^ The controller which should rumble.
  -> IO ()
setRumble leftCfg rightCfg controller =
  sendRawRumbleCommand
    ( handle controller )
    ( rumblePartCommand leftCfg )
    ( rumblePartCommand rightCfg )

sendRawRumbleCommand :: Device -> [Word8] -> [Word8] -> IO ()
sendRawRumbleCommand dev left right =
  sendCommand dev 0x10 $ 0x00 : left ++ right ++ replicate 40 0x00

requestRawSPI :: Device -> IORef Word8 -> Word32 -> Word8 -> IO ()
requestRawSPI dev ref start len =
  let
    byte0 = fromIntegral $         start .&. 0x000000FF
    byte1 = fromIntegral $ shiftR (start .&. 0x0000FF00) 8
    byte2 = fromIntegral $ shiftR (start .&. 0x00FF0000) 16
    byte3 = fromIntegral $ shiftR (start .&. 0xFF000000) 24
  in
  sendRawSubcommand dev ref 0x01 0x10 $
    [byte0, byte1, byte2, byte3, clamp 0x00 0x1D len] ++ replicate 44 0x00

-- | Nintendo Switch controllers have four LEDs that can be used to indicate
-- various things, for example the player number or the Bluetooth pairing status.
-- The LEDs are numbered from left to right (i.e., 'led0' is the leftmost LED,
-- 'led3' is the rightmost LED).
data PlayerLightsConfig =
  PlayerLightsConfig
    { led0 :: LightMode
    , led1 :: LightMode
    , led2 :: LightMode
    , led3 :: LightMode
    }
  deriving (Eq, Read, Show)

-- | Each player light LED can be individually turned on, turned off or used in
-- a pulsating manner (i.e., flashing).
data LightMode
  = LightOn
  | LightOff
  | Flashing
  deriving (Eq, Read, Show)

-- | A convenient player lights configuration where all LEDs are turned off.
noPlayerLights :: PlayerLightsConfig
noPlayerLights =
  PlayerLightsConfig
    { led0 = LightOff
    , led1 = LightOff
    , led2 = LightOff
    , led3 = LightOff
    }

-- | A convenient player lights configuration indicating player one (i.e., 'led0' is set).
playerOne :: PlayerLightsConfig
playerOne = noPlayerLights { led0 = LightOn }

-- | A convenient player lights configuration indicating player two (i.e., 'led1' is set).
playerTwo :: PlayerLightsConfig
playerTwo = noPlayerLights { led1 = LightOn }

-- | A convenient player lights configuration indicating player three (i.e., 'led2' is set).
playerThree :: PlayerLightsConfig
playerThree = noPlayerLights { led2 = LightOn }

-- | A convenient player lights configuration indicating player four (i.e., 'led3' is set).
playerFour :: PlayerLightsConfig
playerFour = noPlayerLights { led3 = LightOn }

-- | A convenient player lights configuration where all LEDs are flashing.
flashAll :: PlayerLightsConfig
flashAll =
  PlayerLightsConfig
    { led0 = Flashing
    , led1 = Flashing
    , led2 = Flashing
    , led3 = Flashing
    }

-- | Sets the player lights of a Nintendo Switch controller.
--
-- Note: After sending a command like this to a controller, it is highly advised
-- to check its corresponding 'Device.Nintendo.Switch.CommandReply'
-- ('Device.Nintendo.Switch.SetPlayerLights', to be exact) or at least call
-- 'Device.Nintendo.Switch.getInput' once before sending another command to
-- that controller. The function 'Device.Nintendo.Switch.withCommandReply' is a
-- convenient way to wait for a specific command reply from the controller.
setPlayerLights :: HasPlayerLights t => PlayerLightsConfig -> Controller t -> IO ()
setPlayerLights config controller =
  sendSubcommand controller 0x01 0x30 $
    [ setBit led0 0x01
    . setBit led1 0x02
    . setBit led2 0x04
    . setBit led3 0x08
    $ 0x00
    ]
  where
    setBit f position =
      case f config of
        LightOn  -> (position .|.)
        LightOff -> id
        Flashing -> (shiftL position 4 .|.)