Controller.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE KindSignatures      #-}
module Device.Nintendo.Switch.Controller where

-- attoparsec
import Data.Attoparsec.ByteString (IResult(Done), Parser, anyWord8, parse, take, word8)

-- base
import Data.Bits      ((.&.), (.|.), Bits, shiftL, shiftR)
import Data.Int       (Int16)
import Data.IORef     (IORef)
import Data.Word      (Word8, Word16)
import Prelude hiding (take)

-- bytestring
import Data.ByteString (ByteString)

-- hidapi
import System.HIDAPI (Device)

-- switch
import Device.Nintendo.Switch.Utils (tripleParser, tripleZipWith)

-- | The types of Nintendo Switch controllers that are currently supported by
-- this library.
--
-- Note that this type is mostly used on the type level (using @DataKinds@)
-- in order to prevent programming mistakes at compile-time (e.g., to prevent
-- sending a rumble command to a controller which has no rumble feature).
--
-- Chances are very high that you don't need this type on the value level, but
-- rather on the type level, for example via @TypeApplications@
-- (see 'Device.Nintendo.Switch.getControllerInfos').
data ControllerType
  = LeftJoyCon
  | RightJoyCon
  | ProController
  deriving (Eq, Read, Show)

-- | A handle which represents a connected Nintendo Switch controller.
data Controller (t :: ControllerType) =
  Controller
    { handle      :: Device
    , counter     :: IORef Word8
    , calibration :: Calibration
    }

data Calibration =
  Calibration
    { accCoeffs     :: (Float, Float, Float)
    , gyroCoeffs    :: (Float, Float, Float)
    , leftStickCal  :: StickCalibration
    , rightStickCal :: StickCalibration
    }
  deriving (Eq, Read, Show)

data RawSensorCalibration =
  RawSensorCalibration
    { rawAcc             :: (Int16, Int16, Int16)
    , rawAccSensitivity  :: (Int16, Int16, Int16)
    , rawGyro            :: (Int16, Int16, Int16)
    , rawGyroSensitivity :: (Int16, Int16, Int16)
    }
  deriving (Eq, Read, Show)

data RawStickCalibration =
  RawStickCalibration
    { rawMinusX  :: Word16
    , rawCenterX :: Word16
    , rawPlusX   :: Word16
    , rawMinusY  :: Word16
    , rawCenterY :: Word16
    , rawPlusY   :: Word16
    }
  deriving (Eq, Read, Show)

data RawCalibration =
  RawCalibration
    { rawLeftStickCal  :: RawStickCalibration
    , rawRightStickCal :: RawStickCalibration
    , rawSensorCal     :: RawSensorCalibration
    }
  deriving (Eq, Read, Show)

data StickCalibration =
  StickCalibration
    { deadCenter :: Float
    , deadOuter  :: Float
    , minusX     :: Float
    , centerX    :: Float
    , plusX      :: Float
    , minusY     :: Float
    , centerY    :: Float
    , plusY      :: Float
    }
  deriving (Eq, Read, Show)

-- | A constraint which indicates that a Nintendo Switch controller is able to
-- turn portions of its internal flash memory into valid calibration information.
class HasCalibration (t :: ControllerType) where
  calibrate :: RawCalibration -> Calibration

instance HasCalibration 'LeftJoyCon where
  calibrate (RawCalibration l r s) =
    Calibration
      { accCoeffs     = tripleZipWith toAccCoeff (rawAcc s) (rawAccSensitivity s)
      , gyroCoeffs    = tripleZipWith toGyroCoeff (rawGyro s) (rawGyroSensitivity s)
      , leftStickCal  = toStickCal 0.15 0.10 l
      , rightStickCal = toStickCal 0.15 0.10 r
      }

instance HasCalibration 'RightJoyCon where
  calibrate (RawCalibration l r s) =
    Calibration
      { accCoeffs     = tripleZipWith toAccCoeff (rawAcc s) (rawAccSensitivity s)
      , gyroCoeffs    = tripleZipWith toGyroCoeff (rawGyro s) (rawGyroSensitivity s)
      , leftStickCal  = toStickCal 0.15 0.10 l
      , rightStickCal = toStickCal 0.15 0.10 r
      }

instance HasCalibration 'ProController where
  calibrate (RawCalibration l r s) =
    Calibration
      { accCoeffs     = tripleZipWith toAccCoeff (rawAcc s) (rawAccSensitivity s)
      , gyroCoeffs    = tripleZipWith toGyroCoeff (rawGyro s) (rawGyroSensitivity s)
      , leftStickCal  = toStickCal 0.10 0.10 l
      , rightStickCal = toStickCal 0.10 0.10 r
      }

toAccCoeff :: Int16 -> Int16 -> Float
toAccCoeff sense value =
  (1 / (fromIntegral sense - fromIntegral value)) * 4 -- in Gs

toGyroCoeff :: Int16 -> Int16 -> Float
toGyroCoeff sense value =
  (936 / (fromIntegral sense - fromIntegral value)) * (pi / 180) -- in radians per second

toStickCal :: Float -> Float -> RawStickCalibration -> StickCalibration
toStickCal dc dout raw =
  StickCalibration
    { deadCenter = dc
    , deadOuter  = dout
    , minusX     = fromIntegral $ rawMinusX raw
    , centerX    = fromIntegral $ rawCenterX raw
    , plusX      = fromIntegral $ rawPlusX raw
    , minusY     = fromIntegral $ rawMinusY raw
    , centerY    = fromIntegral $ rawCenterY raw
    , plusY      = fromIntegral $ rawPlusY raw
    }

axisCalibrationParser :: Parser RawSensorCalibration
axisCalibrationParser = do
  acc       <- tripleParser
  accSense  <- tripleParser
  gyro      <- tripleParser
  gyroSense <- tripleParser
  pure $
    RawSensorCalibration
      { rawAcc             = acc
      , rawAccSensitivity  = accSense
      , rawGyro            = gyro
      , rawGyroSensitivity = gyroSense
      }

axisUserParser :: Parser RawSensorCalibration
axisUserParser = do
  _ <- word8 0xB2
  _ <- word8 0xA1
  axisCalibrationParser

parseStickUserCalibration :: ByteString -> (Maybe RawStickCalibration, Maybe RawStickCalibration)
parseStickUserCalibration string =
  case parse stickUserParser string of
    Done _ result -> result
    _             -> (Nothing, Nothing)

stickCalibrationParser :: (Bits a, Num a) => Parser (a, a, a, a, a, a)
stickCalibrationParser = do
  byte0 <- fromIntegral <$> anyWord8
  byte1 <- fromIntegral <$> anyWord8
  byte2 <- fromIntegral <$> anyWord8
  byte3 <- fromIntegral <$> anyWord8
  byte4 <- fromIntegral <$> anyWord8
  byte5 <- fromIntegral <$> anyWord8
  byte6 <- fromIntegral <$> anyWord8
  byte7 <- fromIntegral <$> anyWord8
  byte8 <- fromIntegral <$> anyWord8
  let d0 = shiftL byte1 8 .&. 0x0F00 .|. byte0
      d1 = shiftL byte2 4 .|. shiftR byte1 4
      d2 = shiftL byte4 8 .&. 0x0F00 .|. byte3
      d3 = shiftL byte5 4 .|. shiftR byte4 4
      d4 = shiftL byte7 8 .&. 0x0F00 .|. byte6
      d5 = shiftL byte8 4 .|. shiftR byte7 4
  pure (d0, d1, d2, d3, d4, d5)

leftStickCalibrationParser :: Parser RawStickCalibration
leftStickCalibrationParser = do
  (d0, d1, d2, d3, d4, d5) <- stickCalibrationParser
  pure $
    RawStickCalibration
      { rawMinusX  = d2 - d4
      , rawCenterX = d2
      , rawPlusX   = d2 + d0
      , rawMinusY  = d3 - d5
      , rawCenterY = d3
      , rawPlusY   = d3 + d1
      }

rightStickCalibrationParser :: Parser RawStickCalibration
rightStickCalibrationParser = do
  (d0, d1, d2, d3, d4, d5) <- stickCalibrationParser
  pure $
    RawStickCalibration
      { rawMinusX  = d0 - d2
      , rawCenterX = d0
      , rawPlusX   = d0 + d4
      , rawMinusY  = d1 - d3
      , rawCenterY = d1
      , rawPlusY   = d1 + d5
      }

stickFactoryParser :: Parser (RawStickCalibration, RawStickCalibration)
stickFactoryParser = do
  leftCal <- leftStickCalibrationParser
  rightCal <- rightStickCalibrationParser
  pure (leftCal, rightCal)

stickUserParser :: Parser (Maybe RawStickCalibration, Maybe RawStickCalibration)
stickUserParser = do
  magicL0 <- anyWord8
  magicL1 <- anyWord8
  ls <- if magicL0 == 0xB2 && magicL1 == 0xA1
        then Just <$> leftStickCalibrationParser
        else const Nothing <$> take 9
  magicR0 <- anyWord8
  magicR1 <- anyWord8
  rs <- if magicR0 == 0xB2 && magicR1 == 0xA1
        then Just <$> rightStickCalibrationParser
        else pure Nothing
  pure (ls, rs)