diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for switch + +## 0.1.0.0 (2021-03-31) + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Michael Szvetits (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Szvetits nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +

+ +

+ +# switch + +[![Hackage](https://img.shields.io/hackage/v/switch.svg?logo=haskell&label=switch)](https://hackage.haskell.org/package/switch) + +`switch` is a library for interacting with Nintendo Switch controllers, written in Haskell. It allows your application to detect controllers via Bluetooth, connect to them, read input (e.g., buttons, sensors) from them and sending commands (e.g., rumble) to them. Notable features of this library are: + +* Supports all popular controller types (left Joy-Con, right Joy-Con, Pro Controller). +* Supports controller input: read button states, analog stick directions and battery information. +* Supports controller output: send rumble commands, set player lights and configure the home light. +* Supports position tracking of a controller using its accelerometer and gyroscope. +* Provides a type-safe interface for controller interaction (e.g., trying to configure the home light of a controller which has no home light results in a compile error). + +The communication protocol of the controllers is based on [existing efforts of the reverse engineering community](https://github.com/dekuNukem/Nintendo_Switch_Reverse_Engineering/). The documentation of the library can be found on [Hackage](https://hackage.haskell.org/package/switch). + +## Usage + +1. Press and hold the SYNC button on your Nintendo Switch controller for a few seconds. It is the small black button on the side (Joy-Con) or top (Pro Controller) of the controller. +2. Scan for Bluetooth devices on your computer. Depending on your controller, you should detect a device named *Joy-Con (L)*, *Joy-Con (R)* or *Pro Controller*. Connect to it. +3. Talk to the controller by developing and running an application that uses the `switch` library on your computer, or try one of the provided [examples](/test). + +

+ +

+ +## Compatibility + +This library *should* work with Windows, Linux and macOS, but it was primarily tested under Windows 10. + +## Limitations and Remarks + +The following features are not implemented yet: + +* Interacting with the NFC sensor of the right Joy-Con. +* Interacting with the IR camera of the right Joy-Con. diff --git a/src/Device/Nintendo/Switch.hs b/src/Device/Nintendo/Switch.hs new file mode 100644 --- /dev/null +++ b/src/Device/Nintendo/Switch.hs @@ -0,0 +1,104 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Device.Nintendo.Switch +-- Copyright : (c) Michael Szvetits, 2021 +-- License : BSD3 (see the file LICENSE) +-- Maintainer : typedbyte@qualified.name +-- Stability : stable +-- Portability : portable +-- +-- Types and functions for connecting to Nintendo Switch controllers, reading +-- input (e.g., buttons, sensors) and sending commands (e.g., rumble). +----------------------------------------------------------------------------- +module Device.Nintendo.Switch + ( -- * Connection + -- ** Switch Console + Console + , init + , exit + , withConsole + -- ** Switch Controllers + , ControllerType(..) + , ControllerInfo + , Controller + , getControllerInfos + , connect + , disconnect + , withController + -- * Controller Input + -- ** Input Mode + , InputMode(..) + , setInputMode + , setInertialMeasurement + -- ** Getting Input + , getInput + , getTimeoutInput + -- ** Input Types + , Input + , ControllerInput(..) + , StickDirection(..) + , Direction(..) + , BatteryInfo(..) + , BatteryStatus(..) + , ExtraInput(..) + , Accelerometer + , Gyroscope + , ReplyData(SetHomeLight, SetInertialMeasurement, SetInputMode, SetPlayerLights, SetVibration) + , Acknowledgement(..) + -- ** Convenience + , noInput + , coordinates + , mergeInputs + , withCommandReply + -- * Controller Output + -- ** Home Light + , setHomeLight + , HomeLightConfig(..) + , CycleConfig + , BaseDuration + , Intensity + , FadeFactor + , LightFactor + , RepeatBehaviour + , endlessPulse + -- ** Player Lights + , setPlayerLights + , PlayerLightsConfig(..) + , LightMode(..) + , noPlayerLights + , playerOne + , playerTwo + , playerThree + , playerFour + , flashAll + -- ** Rumble + , setVibration + , setLeftRumble + , setRightRumble + , setRumble + , RumbleConfig(..) + , normalRumble + , noRumble + -- * Exceptions + , ConnectionException(..) + , InputException(..) + , OutputException(..) + -- * Type Classes + , IsController + , HasCalibration + , HasInputMode + , HasInput + , HasHomeLight + , HasPlayerLights + , HasLeftRumble + , HasRightRumble + ) where + +-- base +import Prelude hiding (init) + +-- switch +import Device.Nintendo.Switch.Connection +import Device.Nintendo.Switch.Controller +import Device.Nintendo.Switch.Input +import Device.Nintendo.Switch.Output diff --git a/src/Device/Nintendo/Switch/Connection.hs b/src/Device/Nintendo/Switch/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Device/Nintendo/Switch/Connection.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Device.Nintendo.Switch.Connection where + +-- attoparsec +import Data.Attoparsec.ByteString (Parser, maybeResult, parse) + +-- base +import Control.Exception (Exception, bracket, throwIO) +import Data.IORef (newIORef) +import Prelude hiding (init) + +-- bytestring +import Data.ByteString (ByteString) + +-- switch +import Device.Nintendo.Switch.Controller (Controller(..), ControllerType(..), + HasCalibration(..), RawCalibration(..), + axisCalibrationParser, stickFactoryParser, + parseStickUserCalibration, axisUserParser) +import Device.Nintendo.Switch.Input (Acknowledgement(ACK), ReplyData(SetInputMode), + withCommandReply, withRawSPIData) +import Device.Nintendo.Switch.Output (InputMode(Standard), setInputModeInternal) + +import qualified System.HIDAPI as HID + +-- | A handle which represents a virtual Nintendo Switch console. The handle +-- is used to detect controllers and manage their connections. +data Console = Console + deriving (Eq, Ord, Read, Show) + +-- | Initializes a Nintendo Switch console handle. In other words, it lets us +-- pretend to be Nintendo Switch console in order to detect controllers and manage +-- their connections. You must call this first before doing anything else. +init :: IO Console +init = HID.init >> pure Console + +-- | Destroys a virtual Nintendo Switch handle. You must call this when you are +-- finished talking to the controllers. +exit :: Console -> IO () +exit Console = HID.exit + +-- | A convenient wrapper around 'init' and 'exit'. +withConsole :: (Console -> IO a) -> IO a +withConsole = bracket init exit + +-- | A handle which represents an unconnected Nintendo Switch controller. +newtype ControllerInfo (t :: ControllerType) = + ControllerInfo HID.DeviceInfo + deriving Show + +-- | A constraint which indicates that a controller is a valid Nintendo Switch +-- controller that can be detected and connected to. +class IsController (t :: ControllerType) where + productID :: HID.ProductID + vendorID :: HID.VendorID + vendorID = 0x057E -- standard: Nintendo + +instance IsController 'LeftJoyCon where + productID = 0x2006 + +instance IsController 'RightJoyCon where + productID = 0x2007 + +instance IsController 'ProController where + productID = 0x2009 + +-- | A 'ConnectionException' is thrown if something goes wrong when reading the +-- internal data of a Nintendo Switch controller when connecting to it. This +-- should not occur if you have an unmodified controller (i.e., you have not +-- tampered with its internal SPI flash memory). +data ConnectionException + = NoFactoryStickException -- ^ Indicates that a controller has no factory stick calibration. + | NoFactoryAxisException -- ^ Indicates that a controller has no factory sensor calibration. + deriving Eq + +instance Exception ConnectionException +instance Show ConnectionException where + show NoFactoryStickException = "Could not determine the factory stick calibration." + show NoFactoryAxisException = "Could not determine the factory sensor calibration." + +-- | Connects to a detected Nintendo Switch controller. +-- +-- Can throw a 'ConnectionException' if something is very wrong with your +-- internal controller memory (i.e., if you have tampered with it). +connect + :: forall t . HasCalibration t + => ControllerInfo t -- ^ The detected Nintendo Switch controller. + -> IO (Controller t) -- ^ The connected Nintendo Switch controller. +connect (ControllerInfo devInfo) = do + dev <- HID.openDeviceInfo devInfo + ref <- newIORef 0 + facStick <- withRawSPIData dev ref 0x603D 18 (tryParse stickFactoryParser) + facAxis <- withRawSPIData dev ref 0x6020 24 (tryParse axisCalibrationParser) + (usl,usr) <- withRawSPIData dev ref 0x8010 22 parseStickUserCalibration + usrAxis <- withRawSPIData dev ref 0x8026 26 (tryParse axisUserParser) + controller <- + case (facStick, facAxis) of + (Nothing, _) -> throwIO NoFactoryStickException + (_, Nothing) -> throwIO NoFactoryAxisException + (Just (fsl,fsr), Just sensor) -> + let ls = maybe fsl id usl + rs = maybe fsr id usr + ax = maybe sensor id usrAxis + cal = calibrate @t (RawCalibration ls rs ax) in + pure $ Controller dev ref cal + setInputModeInternal Standard controller + withCommandReply 10 50 controller $ \case + SetInputMode (ACK ()) -> Just () + _ -> Nothing + pure controller + where + tryParse :: Parser a -> ByteString -> Maybe a + tryParse parser = maybeResult . parse parser + +-- | Disconnects a Nintendo Switch controller. You must not use the controller +-- handle after disconnecting. +disconnect :: Controller t -> IO () +disconnect = HID.close . handle + +-- | A convenient wrapper around 'connect' and 'disconnect'. +withController :: HasCalibration t => ControllerInfo t -> (Controller t -> IO a) -> IO a +withController info = + bracket + ( connect info ) + ( disconnect ) + +-- | Detects all Nintendo Switch controllers of a specific 'ControllerType', +-- usually connected via Bluetooth. +-- +-- You may want to use this function with @TypeApplications@ if the controller +-- type cannot be inferred, like: +-- +-- @ +-- 'getControllerInfos' \@''LeftJoyCon' console +-- @ +-- +getControllerInfos :: forall t . IsController t => Console -> IO [ControllerInfo t] +getControllerInfos Console = + let + vendID = vendorID @t + prodID = productID @t + in do + devInfos <- HID.enumerate (Just vendID) (Just prodID) + pure $ ControllerInfo <$> devInfos diff --git a/src/Device/Nintendo/Switch/Controller.hs b/src/Device/Nintendo/Switch/Controller.hs new file mode 100644 --- /dev/null +++ b/src/Device/Nintendo/Switch/Controller.hs @@ -0,0 +1,241 @@ +{-# 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) diff --git a/src/Device/Nintendo/Switch/Input.hs b/src/Device/Nintendo/Switch/Input.hs new file mode 100644 --- /dev/null +++ b/src/Device/Nintendo/Switch/Input.hs @@ -0,0 +1,729 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +module Device.Nintendo.Switch.Input where + +-- attoparsec +import Data.Attoparsec.ByteString (IResult(Done), Parser, anyWord8, parse, take, word8) + +-- base +import Control.Applicative ((<|>)) +import Control.Exception (Exception, throwIO) +import Data.Bits ((.&.), (.|.), shiftL, shiftR) +import Data.IORef (IORef) +import Data.Int (Int16) +import Data.List (intercalate) +import Data.Word (Word8, Word16, Word32) +import Numeric (showHex) +import Prelude hiding (Left, Right, read, take) + +-- bytestring +import qualified Data.ByteString as BS + +-- hidapi +import System.HIDAPI (Device, read, readTimeout) + +-- switch +import Device.Nintendo.Switch.Controller +import Device.Nintendo.Switch.Output (requestRawSPI) +import Device.Nintendo.Switch.Utils (checkMask, clamp, tripleMap, tripleParser, tripleZipWith) + +-- | A constraint which indicates that a Nintendo Switch controller can provide +-- t'Input' (see 'getInput'). +class HasInput t where + convert :: Controller t -> RawInput -> Input + +instance HasInput 'LeftJoyCon where + convert controller raw = + noInput + { btnL = btnL raw + , btnZL = btnZL raw + , btnMinus = btnMinus raw + , btnLeftStick = btnLeftStick raw + , btnUp = btnUp raw + , btnLeft = btnLeft raw + , btnRight = btnRight raw + , btnDown = btnDown raw + , btnCapture = btnCapture raw + , btnLeftSL = btnLeftSL raw + , btnLeftSR = btnLeftSR raw + , stickLeft = adjustStick (stickLeft raw) (leftStickCal cal) + , extras = adjustSensor (extras raw) (accCoeffs cal) (gyroCoeffs cal) + , battery = battery raw + } + where + cal = calibration controller + +instance HasInput 'RightJoyCon where + convert controller raw = + noInput + { btnR = btnR raw + , btnZR = btnZR raw + , btnPlus = btnPlus raw + , btnX = btnX raw + , btnY = btnY raw + , btnA = btnA raw + , btnB = btnB raw + , btnRightStick = btnRightStick raw + , btnHome = btnHome raw + , btnRightSL = btnRightSL raw + , btnRightSR = btnRightSR raw + , stickRight = adjustStick (stickRight raw) (rightStickCal cal) + , extras = extraMap + ( \(x,y,z) -> (x, -y, -z) ) -- compensate the reverse-installed IMU chip + ( adjustSensor (extras raw) (accCoeffs cal) (gyroCoeffs cal) ) + , battery = battery raw + } + where + cal = calibration controller + extraMap f = \case + Inertial a g -> Inertial (tripleMap f a) (tripleMap f g) + other -> other + +instance HasInput 'ProController where + convert controller raw = + raw + { stickLeft = adjustStick (stickLeft raw) (leftStickCal cal) + , stickRight = adjustStick (stickRight raw) (rightStickCal cal) + , extras = adjustSensor (extras raw) (accCoeffs cal) (gyroCoeffs cal) + } + where + cal = calibration controller + +-- | An 'InputException' is thrown if something goes wrong with 'getInput'. +data InputException + = NoReplyException + -- ^ Indicates that an expected reply wasn't received in a specific time interval. + | UnknownFormatException BS.ByteString + -- ^ Indicates that the controller input has an unexpected format. It essentially + -- means that a specific part of the protocol has not been implemented yet. This + -- should not occur as long as you stick to the public API of this library. + deriving Eq + +instance Exception InputException +instance Show InputException where + show = \case + NoReplyException -> + "Did not receive a reply in a given time interval." + UnknownFormatException bs -> + "Encountered an unknown input format: " + ++ (intercalate " " $ fmap (flip showHex "") (BS.unpack bs)) + +-- | The input provided by a Nintendo Switch controller. +type Input = ControllerInput Float Float + +type RawInput = ControllerInput Word16 Int16 + +-- | The input provided by a Nintendo Switch controller, where @s@ is the +-- numeric type of the analog stick direction and @e@ is the numeric type +-- of the sensor readings (i.e., accelerometer and gyroscope). +data ControllerInput s e = + Input + { -- left buttons + btnL :: Bool + , btnZL :: Bool + , btnMinus :: Bool + , btnLeftStick :: Bool + , btnUp :: Bool + , btnLeft :: Bool + , btnRight :: Bool + , btnDown :: Bool + , btnCapture :: Bool + , btnLeftSL :: Bool + , btnLeftSR :: Bool + -- right buttons + , btnR :: Bool + , btnZR :: Bool + , btnPlus :: Bool + , btnX :: Bool + , btnY :: Bool + , btnA :: Bool + , btnB :: Bool + , btnRightStick :: Bool + , btnHome :: Bool + , btnRightSL :: Bool + , btnRightSR :: Bool + -- sticks + , stickLeft :: StickDirection s + , stickRight :: StickDirection s + -- others + , extras :: ExtraInput e + , battery :: Maybe BatteryInfo + } + deriving (Eq, Read, Show) + +-- | A convenient constant that represents no input. This can be used to set +-- specific buttons and stick directions in order to test functions without +-- having a Nintendo Switch controller at hand, like: +-- +-- @ +-- 'noInput' { 'btnX' = 'True', 'stickLeft' = 'Discrete' 'Up' } +-- @ +-- +noInput :: ControllerInput s e +noInput = + Input + { btnL = False + , btnZL = False + , btnMinus = False + , btnLeftStick = False + , btnUp = False + , btnLeft = False + , btnRight = False + , btnDown = False + , btnCapture = False + , btnLeftSL = False + , btnLeftSR = False + , btnR = False + , btnZR = False + , btnPlus = False + , btnX = False + , btnY = False + , btnA = False + , btnB = False + , btnRightStick = False + , btnHome = False + , btnRightSL = False + , btnRightSR = False + , stickLeft = Discrete None + , stickRight = Discrete None + , extras = Unavailable + , battery = Nothing + } + +-- | Accelerometer data consists of three measurements recorded in 15ms (i.e., +-- the precision is 5ms). Each measurement is an x\/y\/z triple measured in Gs. +type Accelerometer a = ((a, a, a), (a, a, a), (a, a, a)) + +-- | Gyroscope data consists of three measurements recorded in 15ms (i.e., the +-- precision is 5ms). Each measurement is an x\/y\/z triple measured in radians +-- per second. +type Gyroscope a = ((a, a, a), (a, a, a), (a, a, a)) + +-- | Depending on the t'Device.Nintendo.Switch.InputMode', v'Input' can contain +-- additional information: Replies to commands (e.g., an acknowledgement when +-- sending a rumble command) and inertial sensor data (i.e., accelerometer and +-- gyroscope). +data ExtraInput a + = CommandReply ReplyData + -- ^ After sending commands to the controller (e.g., setting the + -- t'Device.Nintendo.Switch.InputMode'), a command reply is returned as extra + -- data in the next input. + | Inertial (Accelerometer a) (Gyroscope a) + -- ^ A controller provides inertial sensor data (i.e., accelerometer and + -- gyroscope) only if it is in 'Device.Nintendo.Switch.Standard' input mode and + -- inertial measurement is activated via 'Device.Nintendo.Switch.setInertialMeasurement'. + -- + -- Regarding the x\/y\/z coordinate system, consider the left Joy-Con lying + -- flat on a table, the analog stick pointing up. The x-axis then points + -- towards the Z/ZL shoulder buttons (or alternatively: to where the up arrow + -- button is pointing), the y-axis points to the opposite side of the SL/SR + -- buttons (or alternatively: to where the left arrow button is pointing), + -- and the z-axis points up in the air. The coordinate system is the same for + -- all controller types. + | Unavailable + -- ^ Indicates that there is no additional input data. + deriving (Eq, Functor, Read, Show) + +-- | Whenever a command is sent to a controller (e.g., setting the +-- t'Device.Nintendo.Switch.InputMode'), the controller replies with an +-- 'Acknowledgement'. +data Acknowledgement a + = ACK a -- ^ The command was executed successfully, possibly holding some response + -- data (e.g., if the command was a query of the internal SPI flash memory). + | NACK -- ^ The command was not executed successfully. + deriving (Eq, Functor, Read, Show) + +-- | Data type that combines the command type and its corresponding acknowledgement. +data ReplyData + = RequestSPI (Acknowledgement (Word32, Word8, BS.ByteString)) + | SetHomeLight (Acknowledgement ()) + | SetInertialMeasurement (Acknowledgement ()) + | SetInputMode (Acknowledgement ()) + | SetPlayerLights (Acknowledgement ()) + | SetVibration (Acknowledgement ()) + | UnknownCommand Word8 Word8 + deriving (Eq, Read, Show) + +-- | The direction of the left ('stickLeft') and right ('stickRight') analog sticks. +data StickDirection a + = Discrete Direction + -- ^ In 'Device.Nintendo.Switch.Simple' input mode, controllers send discrete + -- stick directions. + | Analog a a + -- ^ In 'Device.Nintendo.Switch.Standard' input mode, controllers send analog + -- stick directions. The first value is left/right (interval @[-1,1]@), the + -- second value is down/up (interval @[-1,1]@). + deriving (Eq, Functor, Read, Show) + +-- | The nine possible discrete positions of the analog stick in +-- 'Device.Nintendo.Switch.Simple' input mode. +data Direction + = None + | Left + | Up + | Right + | Down + | LeftUp + | LeftDown + | RightUp + | RightDown + deriving (Eq, Read, Show) + +-- | Converts stick directions into x\/y coordinates in the interval @[-1,1]@. +-- 'Analog' values are taken as is, while 'Discrete' directions are converted +-- to their analog counterpart. +coordinates :: StickDirection Float -> (Float, Float) +coordinates (Analog x y) = (x, y) +coordinates (Discrete dir) = + case dir of + None -> ( 0, 0) + Left -> ( left, 0) + Up -> ( 0, up) + Right -> (right, 0) + Down -> ( 0, down) + LeftUp -> ( left, up) + LeftDown -> ( left, down) + RightUp -> (right, up) + RightDown -> (right, down) + where + right = cos (pi / 4) + left = -right + up = sin (pi / 4) + down = -up + +-- | Merges the inputs of two Nintendo Switch controllers. The resulting input +-- contains the left button states and left analog stick direction from one input, +-- and the right button states and right analog stick direction from the other +-- input. This can be used to unify the inputs of two controllers that belong +-- together (e.g., a pair of left and right Joy-Cons). +-- +-- Note that the 'extras' and 'battery' information of the original inputs are +-- discarded in the merged input (they are set to 'Unavailable' and 'Nothing', +-- respectively). +mergeInputs + :: Input -- ^ The left-side input to be merged. + -> Input -- ^ The right-side input to be merged. + -> Input -- ^ The merged input, without 'extras' and 'battery'. +mergeInputs leftInput rightInput = + leftInput + { btnR = btnR rightInput + , btnZR = btnZR rightInput + , btnPlus = btnPlus rightInput + , btnX = btnX rightInput + , btnY = btnY rightInput + , btnA = btnA rightInput + , btnB = btnB rightInput + , btnRightStick = btnRightStick rightInput + , btnHome = btnHome rightInput + , btnRightSL = btnRightSL rightInput + , btnRightSR = btnRightSR rightInput + , stickRight = stickRight rightInput + , extras = Unavailable + , battery = Nothing + } + +-- | The battery status of a Nintendo Switch controller. +data BatteryStatus + = Empty + | Low + | Medium + | Good + | Full + deriving (Eq, Ord, Read, Show) + +-- | Information about the battery of a Nintendo Switch controller. It is only +-- returned by 'getInput' (see 'battery') if the controller sends a command reply +-- or the input mode of the controller is 'Device.Nintendo.Switch.Standard'. +data BatteryInfo = + BatteryInfo + { batteryStatus :: BatteryStatus + , charging :: Bool + } + deriving (Eq, Read, Show) + +adjustSensor + :: ExtraInput Int16 + -> (Float, Float, Float) + -> (Float, Float, Float) + -> ExtraInput Float +adjustSensor Unavailable _ _ = Unavailable +adjustSensor (CommandReply r) _ _ = CommandReply r +adjustSensor (Inertial acc gyro) accs gyros = + Inertial newAcc newGyro + where facc = tripleMap (tripleMap fromIntegral) acc + fgyro = tripleMap (tripleMap fromIntegral) gyro + newAcc = tripleMap (tripleZipWith (*) accs) facc + newGyro = tripleMap (tripleZipWith (*) gyros) fgyro + +readRawInput :: Device -> IO RawInput +readRawInput dev = do + response <- read dev 362 + case parse inputParser response of + Done _ raw -> pure raw + _ -> throwIO $ UnknownFormatException response + +-- | Reads input from a Nintendo Switch controller. Blocks until controller +-- input is available. +getInput :: HasInput t => Controller t -> IO Input +getInput controller = + convert controller <$> + readRawInput (handle controller) + +readRawTimeoutInput :: Int -> Device -> IO (Maybe RawInput) +readRawTimeoutInput timeout dev = do + response <- readTimeout dev 362 timeout + if BS.length response <= 0 + then pure Nothing + else case parse inputParser response of + Done _ raw -> pure $ Just raw + _ -> throwIO $ UnknownFormatException response + +-- | Reads input from a Nintendo Switch controller. Blocks until controller +-- input is available or a given time interval elapses. +getTimeoutInput + :: HasInput t + => Int -- ^ The time interval in milliseconds. + -> Controller t -- ^ The controller to read the input from. + -> IO (Maybe Input) -- ^ Returns 'Nothing' if the controller does not provide + -- an input within the specified time interval. +getTimeoutInput timeout controller = + fmap (convert controller) <$> + readRawTimeoutInput timeout (handle controller) + +inputParser :: Parser RawInput +inputParser + = standardParser + <|> buttonPushParser + <|> commandParser + +commandDetailParser :: Parser ReplyData +commandDetailParser + = requestSPIReplyParser + <|> homeLightReplyParser + <|> vibrationReplyParser + <|> inertialReplyParser + <|> inputModeReplyParser + <|> playerLightsReplyParser + <|> unknownCommandParser + +ackParser :: Parser Bool +ackParser = checkMask 0x80 <$> anyWord8 + +toAck :: Bool -> Acknowledgement () +toAck True = ACK () +toAck False = NACK + +requestSPIReplyParser :: Parser ReplyData +requestSPIReplyParser = do + ack <- ackParser + _ <- word8 0x10 + case ack of + False -> pure $ RequestSPI NACK + True -> do + byte0 <- fromIntegral <$> anyWord8 + byte1 <- fromIntegral <$> anyWord8 + byte2 <- fromIntegral <$> anyWord8 + byte3 <- fromIntegral <$> anyWord8 + len <- anyWord8 + value <- take (fromIntegral len) + let addrByte0 = shiftL byte3 24 + addrByte1 = shiftL byte2 16 + addrByte2 = shiftL byte1 8 + addrByte3 = byte0 + address = addrByte0 + addrByte1 + addrByte2 + addrByte3 + pure $ RequestSPI (ACK (address, len, value)) + +homeLightReplyParser :: Parser ReplyData +homeLightReplyParser = do + ack <- ackParser + _ <- word8 0x38 + pure $ SetHomeLight (toAck ack) + +vibrationReplyParser :: Parser ReplyData +vibrationReplyParser = do + ack <- ackParser + _ <- word8 0x48 + pure $ SetVibration (toAck ack) + +inertialReplyParser :: Parser ReplyData +inertialReplyParser = do + ack <- ackParser + _ <- word8 0x40 + pure $ SetInertialMeasurement (toAck ack) + +inputModeReplyParser :: Parser ReplyData +inputModeReplyParser = do + ack <- ackParser + _ <- word8 0x03 + pure $ SetInputMode (toAck ack) + +playerLightsReplyParser :: Parser ReplyData +playerLightsReplyParser = do + ack <- ackParser + _ <- word8 0x30 + pure $ SetPlayerLights (toAck ack) + +unknownCommandParser :: Parser ReplyData +unknownCommandParser = do + byte0 <- anyWord8 + byte1 <- anyWord8 + pure $ UnknownCommand byte0 byte1 + +standardParser :: Parser RawInput +standardParser = do + _ <- word8 0x30 + _ <- anyWord8 -- timer byte + batInfo <- batteryParser + btnInput <- buttonStandardParser noInput + leftStick <- rawStickParser + rightStick <- rawStickParser + _ <- anyWord8 -- vibration byte + acc1 <- tripleParser + gyro1 <- tripleParser + acc2 <- tripleParser + gyro2 <- tripleParser + acc3 <- tripleParser + gyro3 <- tripleParser + pure $ + btnInput + { stickLeft = leftStick + , stickRight = rightStick + , extras = Inertial (acc1,acc2,acc3) (gyro1,gyro2,gyro3) + , battery = Just batInfo + } + +commandParser :: Parser RawInput +commandParser = do + _ <- word8 0x21 + _ <- anyWord8 -- timer byte + batInfo <- batteryParser + btnInput <- buttonStandardParser noInput + leftStick <- rawStickParser + rightStick <- rawStickParser + _ <- anyWord8 -- vibration byte + cmd <- commandDetailParser + pure $ + btnInput + { stickLeft = leftStick + , stickRight = rightStick + , extras = CommandReply cmd + , battery = Just batInfo + } + +buttonPushParser :: Parser RawInput +buttonPushParser = do + _ <- word8 0x3F + btnByte1 <- anyWord8 + btnByte2 <- anyWord8 + stickByte <- anyWord8 + analogStick <- analogParser + let down = checkMask 0x01 btnByte1 + right = checkMask 0x02 btnByte1 + left = checkMask 0x04 btnByte1 + up = checkMask 0x08 btnByte1 + sl = checkMask 0x10 btnByte1 + sr = checkMask 0x20 btnByte1 + lr = checkMask 0x40 btnByte2 + zlzr = checkMask 0x80 btnByte2 + (leftStick, rightStick) = + case analogStick of + Just (l,r) -> (l,r) + Nothing -> + ( case stickByte of + 0x00 -> Discrete Right + 0x01 -> Discrete RightDown + 0x02 -> Discrete Down + 0x03 -> Discrete LeftDown + 0x04 -> Discrete Left + 0x05 -> Discrete LeftUp + 0x06 -> Discrete Up + 0x07 -> Discrete RightUp + _ -> Discrete None + , case stickByte of + 0x00 -> Discrete Left + 0x01 -> Discrete LeftUp + 0x02 -> Discrete Up + 0x03 -> Discrete RightUp + 0x04 -> Discrete Right + 0x05 -> Discrete RightDown + 0x06 -> Discrete Down + 0x07 -> Discrete LeftDown + _ -> Discrete None + ) + pure $ + Input + { btnL = lr + , btnZL = zlzr + , btnMinus = checkMask 0x01 btnByte2 + , btnLeftStick = checkMask 0x04 btnByte2 + , btnUp = left + , btnLeft = down + , btnRight = up + , btnDown = right + , btnCapture = checkMask 0x20 btnByte2 + , btnLeftSL = sl + , btnLeftSR = sr + , btnR = lr + , btnZR = zlzr + , btnPlus = checkMask 0x02 btnByte2 + , btnX = right + , btnY = up + , btnA = down + , btnB = left + , btnRightStick = checkMask 0x08 btnByte2 + , btnHome = checkMask 0x10 btnByte2 + , btnRightSL = sl + , btnRightSR = sr + , stickLeft = leftStick + , stickRight = rightStick + , extras = Unavailable + , battery = Nothing + } + where + analogParser :: Parser (Maybe (StickDirection Word16, StickDirection Word16)) + analogParser = fillerParser <|> proParser + fillerParser = do + _ <- word8 0x00 + _ <- word8 0x80 + _ <- word8 0x00 + _ <- word8 0x80 + _ <- word8 0x00 + _ <- word8 0x80 + _ <- word8 0x00 + _ <- word8 0x80 + pure Nothing + proParser = do + left <- stickBytesParser + right <- stickBytesParser + pure $ Just (left, right) + stickBytesParser = do + stickByte0 <- fromIntegral <$> anyWord8 + stickByte1 <- fromIntegral <$> anyWord8 + stickByte2 <- fromIntegral <$> anyWord8 + stickByte3 <- fromIntegral <$> anyWord8 + pure $ + Analog + ( stickByte0 .|. shiftL stickByte1 8 ) + ( stickByte2 .|. shiftL stickByte3 8 ) + +batteryParser :: Parser BatteryInfo +batteryParser = do + batteryByte <- anyWord8 + pure $ + BatteryInfo { + batteryStatus = toStatus batteryByte, + charging = checkMask 0x01 batteryByte + } + where toStatus b | b <= 1 = Empty + | b <= 3 = Low + | b <= 5 = Medium + | b <= 7 = Good + | otherwise = Full + +buttonStandardParser :: RawInput -> Parser RawInput +buttonStandardParser raw = do + rightByte <- anyWord8 + sharedByte <- anyWord8 + leftByte <- anyWord8 + pure $ + raw + { btnLeftStick = checkMask 0x08 sharedByte + , btnZL = checkMask 0x80 leftByte + , btnL = checkMask 0x40 leftByte + , btnMinus = checkMask 0x01 sharedByte + , btnUp = checkMask 0x02 leftByte + , btnLeft = checkMask 0x08 leftByte + , btnRight = checkMask 0x04 leftByte + , btnDown = checkMask 0x01 leftByte + , btnCapture = checkMask 0x20 sharedByte + , btnLeftSL = checkMask 0x20 leftByte + , btnLeftSR = checkMask 0x10 leftByte + , btnRightStick = checkMask 0x04 sharedByte + , btnZR = checkMask 0x80 rightByte + , btnR = checkMask 0x40 rightByte + , btnPlus = checkMask 0x02 sharedByte + , btnX = checkMask 0x02 rightByte + , btnY = checkMask 0x01 rightByte + , btnA = checkMask 0x08 rightByte + , btnB = checkMask 0x04 rightByte + , btnHome = checkMask 0x10 sharedByte + , btnRightSL = checkMask 0x20 rightByte + , btnRightSR = checkMask 0x10 rightByte + } + +rawStickParser :: Parser (StickDirection Word16) +rawStickParser = do + byte0 <- fromIntegral <$> anyWord8 + byte1 <- fromIntegral <$> anyWord8 + byte2 <- fromIntegral <$> anyWord8 + let x = byte0 .|. shiftL (byte1 .&. 0x0F) 8 + y = shiftR byte1 4 .|. shiftL byte2 4 + pure $ Analog x y + +adjustStick :: StickDirection Word16 -> StickCalibration -> StickDirection Float +adjustStick (Discrete dir) _ = Discrete dir +adjustStick (Analog x y) (StickCalibration dc dout mx cx px my cy py) = let + clampX = clamp mx px (fromIntegral x) + clampY = clamp my py (fromIntegral y) + xf = if clampX >= cx + then (clampX - cx) / (px - cx) + else (clampX - cx) / (cx - mx) + yf = if clampY >= cy + then (clampY - cy) / (py - cy) + else (clampY - cy) / (cy - my) + mag = sqrt (xf * xf + yf * yf) + legalRange = 1 - dout - dc + normMag = min 1 ((mag - dc) / legalRange) + scale = normMag / mag + in if mag > dc + then Analog (xf * scale) (yf * scale) + else Analog 0 0 + +withRawSPIData :: Device -> IORef Word8 -> Word32 -> Word8 -> (BS.ByteString -> a) -> IO a +withRawSPIData dev ref start len f = do + requestRawSPI dev ref start len + withRawCommandReply 10 50 dev $ \case + RequestSPI (ACK (addr, rLen, value)) | addr == start && rLen == len -> + Just $ f value + _ -> + Nothing + +withRawCommandReply :: Int -> Int -> Device -> (ReplyData -> Maybe a) -> IO a +withRawCommandReply count timeout dev f = loop 0 + where + cCount = clamp 0 maxBound count + cTimeout = clamp 0 maxBound timeout + loop times + | times == cCount = throwIO NoReplyException + | otherwise = do + input <- readRawTimeoutInput cTimeout dev + case input of + Just (Input { extras = CommandReply obj }) -> + case f obj of + Just r -> pure r + Nothing -> loop (succ times) + _ -> loop (succ times) + +-- | Consumes inputs from a Nintendo Switch controller until a specific command +-- reply is encountered. Throws a 'NoReplyException' if the expected command +-- reply is not encountered within a specified count of inputs. +-- +-- This function can be used to make sure that the controller is in an expected +-- state after sending commands (e.g., to wait for an 'Acknowledgement' after +-- switching its t'Device.Nintendo.Switch.InputMode'). +withCommandReply + :: Int + -- ^ The maximum count of inputs that should be consumed. + -> Int + -- ^ The timeout per input read (see 'getTimeoutInput'). + -> Controller t + -- ^ The controller to read the input from. + -> (ReplyData -> Maybe a) + -- ^ The function which checks the command reply. It must return 'Nothing' + -- if a 'ReplyData' is encountered which we are not looking for, or 'Just' @a@ + -- if everything went well. + -> IO a + -- ^ The data extracted from the expected command reply. +withCommandReply count timeout controller f = + withRawCommandReply count timeout (handle controller) f diff --git a/src/Device/Nintendo/Switch/Output.hs b/src/Device/Nintendo/Switch/Output.hs new file mode 100644 --- /dev/null +++ b/src/Device/Nintendo/Switch/Output.hs @@ -0,0 +1,517 @@ +{-# 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 +-- , +-- 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 .|.) diff --git a/src/Device/Nintendo/Switch/Utils.hs b/src/Device/Nintendo/Switch/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Device/Nintendo/Switch/Utils.hs @@ -0,0 +1,53 @@ +module Device.Nintendo.Switch.Utils where + +-- attoparsec +import Data.Attoparsec.ByteString (Parser, anyWord8) + +-- base +import Data.Bits ((.|.), (.&.), Bits, shiftL) +import Data.Word (Word8) + +checkMask :: (Bits a, Eq a) => a -> a -> Bool +checkMask mask value = + mask .&. value == mask + +clamp :: Ord a => a -> a -> a -> a +clamp low high value + | value <= low = low + | value >= high = high + | otherwise = value + +combine :: Word8 -> Word8 -> Word8 +combine high low = + shiftL high 4 .|. low + +pairs :: [a] -> [(a,a)] +pairs (x:y:rest) = (x,y) : pairs rest +pairs _ = [] + +discretize :: (Real a, Integral b) => a -> a -> b -> b -> a -> b +discretize srcMin srcMax tgtMin tgtMax value + | value <= srcMin = tgtMin + | value >= srcMax = tgtMax + | otherwise = round $ fromIntegral tgtMin + frac * fromIntegral (tgtMax - tgtMin) + where + frac = (realToFrac (value - srcMin) / realToFrac (srcMax - srcMin)) :: Float + +tripleZipWith :: (a -> b -> c) -> (a, a, a) -> (b, b, b) -> (c, c, c) +tripleZipWith f (a1, a2, a3) (b1, b2, b3) = (f a1 b1, f a2 b2, f a3 b3) + +tripleMap :: (a -> b) -> (a, a, a) -> (b, b, b) +tripleMap f (a1, a2, a3) = (f a1, f a2, f a3) + +littleEndianWord16Parser :: (Bits a, Num a) => Parser a +littleEndianWord16Parser = do + byte0 <- fromIntegral <$> anyWord8 + byte1 <- fromIntegral <$> anyWord8 + pure $ shiftL byte1 8 .|. byte0 + +tripleParser :: (Bits a, Num a) => Parser (a, a, a) +tripleParser = do + x <- littleEndianWord16Parser + y <- littleEndianWord16Parser + z <- littleEndianWord16Parser + pure (x, y, z) diff --git a/switch.cabal b/switch.cabal new file mode 100644 --- /dev/null +++ b/switch.cabal @@ -0,0 +1,122 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 81d011fda80ad7d42c19e742590057585396cb1e966349ccd658968fdb1d1631 + +name: switch +version: 0.1.0.0 +synopsis: Nintendo Switch Controller Library +description: Please see the README on GitHub at +category: Game +homepage: https://github.com/typedbyte/switch#readme +bug-reports: https://github.com/typedbyte/switch/issues +author: Michael Szvetits +maintainer: typedbyte@qualified.name +copyright: 2021 Michael Szvetits +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/typedbyte/switch + +library + exposed-modules: + Device.Nintendo.Switch + other-modules: + Device.Nintendo.Switch.Connection + Device.Nintendo.Switch.Controller + Device.Nintendo.Switch.Input + Device.Nintendo.Switch.Output + Device.Nintendo.Switch.Utils + Paths_switch + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + attoparsec >=0.13.2.0 && <0.14.0.0 + , base >=4.7 && <5 + , bytestring >=0.10.12.0 && <0.12.0.0 + , hidapi >=0.1.6 && <0.2.0 + default-language: Haskell2010 + +test-suite cube + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Madgwick + Paths_switch + hs-source-dirs: + test/Cube + ghc-options: -Wall + build-depends: + GPipe + , GPipe-GLFW + , attoparsec >=0.13.2.0 && <0.14.0.0 + , base >=4.7 && <5 + , bytestring >=0.10.12.0 && <0.12.0.0 + , hidapi >=0.1.6 && <0.2.0 + , linear + , switch + default-language: Haskell2010 + +test-suite leftJoyCon + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + ControllerTest + Paths_switch + hs-source-dirs: + test/Common + test/LeftJoyCon + ghc-options: -Wall + build-depends: + attoparsec >=0.13.2.0 && <0.14.0.0 + , base >=4.7 && <5 + , bytestring >=0.10.12.0 && <0.12.0.0 + , hidapi >=0.1.6 && <0.2.0 + , switch + default-language: Haskell2010 + +test-suite proController + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + ControllerTest + Paths_switch + hs-source-dirs: + test/Common + test/ProController + ghc-options: -Wall + build-depends: + attoparsec >=0.13.2.0 && <0.14.0.0 + , base >=4.7 && <5 + , bytestring >=0.10.12.0 && <0.12.0.0 + , hidapi >=0.1.6 && <0.2.0 + , switch + default-language: Haskell2010 + +test-suite rightJoyCon + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + ControllerTest + Paths_switch + hs-source-dirs: + test/Common + test/RightJoyCon + ghc-options: -Wall + build-depends: + attoparsec >=0.13.2.0 && <0.14.0.0 + , base >=4.7 && <5 + , bytestring >=0.10.12.0 && <0.12.0.0 + , hidapi >=0.1.6 && <0.2.0 + , switch + default-language: Haskell2010 diff --git a/test/Common/ControllerTest.hs b/test/Common/ControllerTest.hs new file mode 100644 --- /dev/null +++ b/test/Common/ControllerTest.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +module ControllerTest where + +-- base +import Control.Monad (unless) +import Text.Printf (printf) + +-- switch +import Device.Nintendo.Switch + +ackInputMode :: Controller t -> IO () +ackInputMode controller = + withCommandReply 10 50 controller $ \case + SetInputMode (ACK ()) -> Just () + _ -> Nothing + +leftTest :: (HasInput t, HasLeftRumble t) => Controller t -> IO () +leftTest controller = loop noInput + where + loop old = do + input <- getInput controller + if | old == input -> loop input -- to prevent flooding the output, only show changes + | btnMinus input -> pure () -- end on - button + | otherwise -> do + putStrLn $ show input + if | btnDown input -> setLeftRumble normalRumble controller + | btnRight input -> setLeftRumble noRumble controller + | otherwise -> pure () + loop input + +rightTest :: (HasInput t, HasRightRumble t, HasHomeLight t) => Controller t -> IO () +rightTest controller = loop noInput + where + loop old = do + input <- getInput controller + if | old == input -> loop input -- to prevent flooding the output, only show changes + | btnPlus input -> pure () -- end on + button + | otherwise -> do + putStrLn $ show input + if | btnY input -> setHomeLight endlessPulse controller + | btnX input -> setHomeLight Off controller + | btnB input -> setRightRumble normalRumble controller + | btnA input -> setRightRumble noRumble controller + | otherwise -> pure () + loop input + +sensorTest :: HasInput t => (Input -> Bool) -> Controller t -> IO () +sensorTest end controller = do + input <- getInput controller + case extras input of + -- for simplicity, we only take one of three measurements. + Inertial (acc,_,_) (gyro,_,_) -> + let + (ax, ay, az) = acc + (gx, gy, gz) = gyro + (lx, ly) = coordinates $ stickLeft input + (rx, ry) = coordinates $ stickRight input + in + putStrLn $ + printf + ( "Left Stick: %+.2f / %+.2f | " + ++ "Right Stick: %+.2f / %+.2f | " + ++ "Accelerometer (in Gs): %+.2f / %+.2f / %+.2f | " + ++ "Gyroscope (in radians/s): %+.2f / %+.2f / %+.2f" ) + lx ly rx ry ax ay az gx gy gz + _ -> pure () + unless (end input) (sensorTest end controller) diff --git a/test/Cube/Madgwick.hs b/test/Cube/Madgwick.hs new file mode 100644 --- /dev/null +++ b/test/Cube/Madgwick.hs @@ -0,0 +1,62 @@ +module Madgwick where + +-- linear +import Linear.Quaternion +import Linear.V3 + +-- Madgwick's sensor fusion algorithm. +-- See: https://x-io.co.uk/open-source-imu-and-ahrs-algorithms/ +madgwick + :: (Float, Float, Float) + -> (Float, Float, Float) + -> Float + -> Float + -> Quaternion Float + -> Quaternion Float +madgwick (ax,ay,az) (gx,gy,gz) beta sampleFreq (Quaternion q0 (V3 q1 q2 q3)) = + let + qDot1 = 0.5 * (-q1 * gx - q2 * gy - q3 * gz) + qDot2 = 0.5 * (q0 * gx + q2 * gz - q3 * gy) + qDot3 = 0.5 * (q0 * gy - q1 * gz + q3 * gx) + qDot4 = 0.5 * (q0 * gz + q1 * gy - q2 * gx) + + (newDot1, newDot2, newDot3, newDot4) = help qDot1 qDot2 qDot3 qDot4 + + q0t = q0 + newDot1 * (1.0 / sampleFreq) + q1t = q1 + newDot2 * (1.0 / sampleFreq) + q2t = q2 + newDot3 * (1.0 / sampleFreq) + q3t = q3 + newDot4 * (1.0 / sampleFreq) + + recipNorm = 1 / sqrt (q0t * q0t + q1t * q1t + q2t * q2t + q3t * q3t) + in + Quaternion (q0t * recipNorm) (V3 (q1t * recipNorm) (q2t * recipNorm) (q3t * recipNorm)) + where + help qDot1 qDot2 qDot3 qDot4 = + if(not ((ax == 0) && (ay == 0) && (az == 0))) then + let recipNorm = 1 / sqrt (ax * ax + ay * ay + az * az) + fax = ax * recipNorm + fay = ay * recipNorm + faz = az * recipNorm; + + _2q0 = 2.0 * q0 + _2q1 = 2.0 * q1 + _2q2 = 2.0 * q2 + _2q3 = 2.0 * q3 + _4q0 = 4.0 * q0 + _4q1 = 4.0 * q1 + _4q2 = 4.0 * q2 + _8q1 = 8.0 * q1 + _8q2 = 8.0 * q2 + q0q0 = q0 * q0 + q1q1 = q1 * q1 + q2q2 = q2 * q2 + q3q3 = q3 * q3 + + s0 = _4q0 * q2q2 + _2q2 * fax + _4q0 * q1q1 - _2q1 * fay + s1 = _4q1 * q3q3 - _2q3 * fax + 4.0 * q0q0 * q1 - _2q0 * fay - _4q1 + _8q1 * q1q1 + _8q1 * q2q2 + _4q1 * faz + s2 = 4.0 * q0q0 * q2 + _2q0 * fax + _4q2 * q3q3 - _2q3 * fay - _4q2 + _8q2 * q1q1 + _8q2 * q2q2 + _4q2 * faz + s3 = 4.0 * q1q1 * q3 - _2q1 * fax + 4.0 * q2q2 * q3 - _2q2 * fay + recipNorm2 = 1 / sqrt (s0 * s0 + s1 * s1 + s2 * s2 + s3 * s3) + in (qDot1 - beta * s0 * recipNorm2, qDot2 - beta * s1 * recipNorm2, qDot3 - beta * s2 * recipNorm2, qDot4 - beta * s3 * recipNorm2) + else + (qDot1, qDot2, qDot3, qDot4) diff --git a/test/Cube/Main.hs b/test/Cube/Main.hs new file mode 100644 --- /dev/null +++ b/test/Cube/Main.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +module Main where + +-- base +import Control.Monad (forM_, unless, void) +import Control.Monad.IO.Class (liftIO) + +-- GPipe +import Graphics.GPipe + +-- GPipe-GLFW +import qualified Graphics.GPipe.Context.GLFW as GLFW + +-- switch +import Device.Nintendo.Switch + +import Madgwick + +toV3 :: V4 a -> V3 a +toV3 (V4 x y z _) = V3 x y z + +toV4 :: Num a => V3 a -> V4 a +toV4 (V3 x y z) = V4 x y z 1 + +rot :: Num a => Quaternion a -> V3 a -> V3 a +rot (Quaternion s u) v = (V3 a a a) * u + (V3 b b b) * v + (V3 c c c) * cross u v + where a = 2 * (dot u v) + b = s*s - dot u u + c = 2 * s + +main :: IO () +main = do + putStrLn "--------------------------------------------------------------------" + putStrLn "Testing sensors of all connected left Joy-Cons one after another ..." + putStrLn "Close the window to end the test run." + putStrLn "--------------------------------------------------------------------" + withConsole $ \switch -> do + infos <- getControllerInfos switch + forM_ infos $ \info -> + withController info $ \controller -> do + setInertialMeasurement True controller + void $ getInput controller -- ack + runContextT GLFW.defaultHandleConfig $ do + -- window + let windowConfig = + GLFW.WindowConfig + 800 800 + "Left Joy-Con 3D Test (will drift, press Capture to reset)" + Nothing [] Nothing + win <- newWindow (WindowFormatColor RGB8) windowConfig + + -- cube vertices + vertexBuffer <- newBuffer 36 + writeBuffer vertexBuffer 0 + [ (V4 (-0.5) (-0.5) (-0.5) 1, V3 1 0 1) + , (V4 ( 0.5) ( 0.5) (-0.5) 1, V3 1 0 1) + , (V4 ( 0.5) (-0.5) (-0.5) 1, V3 1 0 1) + , (V4 (-0.5) (-0.5) (-0.5) 1, V3 1 0 1) + , (V4 (-0.5) ( 0.5) (-0.5) 1, V3 1 0 1) + , (V4 ( 0.5) ( 0.5) (-0.5) 1, V3 1 0 1) + + , (V4 (-0.5) (-0.5) (-0.5) 1, V3 0 0 1) + , (V4 (-0.5) (-0.5) ( 0.5) 1, V3 0 0 1) + , (V4 (-0.5) ( 0.5) ( 0.5) 1, V3 0 0 1) + , (V4 (-0.5) (-0.5) (-0.5) 1, V3 0 0 1) + , (V4 (-0.5) ( 0.5) ( 0.5) 1, V3 0 0 1) + , (V4 (-0.5) ( 0.5) (-0.5) 1, V3 0 0 1) + + , (V4 ( 0.5) (-0.5) (-0.5) 1, V3 0 1 0) + , (V4 ( 0.5) ( 0.5) ( 0.5) 1, V3 0 1 0) + , (V4 ( 0.5) (-0.5) ( 0.5) 1, V3 0 1 0) + , (V4 ( 0.5) (-0.5) (-0.5) 1, V3 0 1 0) + , (V4 ( 0.5) ( 0.5) (-0.5) 1, V3 0 1 0) + , (V4 ( 0.5) ( 0.5) ( 0.5) 1, V3 0 1 0) + + , (V4 (-0.5) (-0.5) ( 0.5) 1, V3 1 0 0) + , (V4 ( 0.5) (-0.5) ( 0.5) 1, V3 1 0 0) + , (V4 ( 0.5) ( 0.5) ( 0.5) 1, V3 1 0 0) + , (V4 (-0.5) (-0.5) ( 0.5) 1, V3 1 0 0) + , (V4 ( 0.5) ( 0.5) ( 0.5) 1, V3 1 0 0) + , (V4 (-0.5) ( 0.5) ( 0.5) 1, V3 1 0 0) + + , (V4 (-0.5) (-0.5) (-0.5) 1, V3 0 1 1) + , (V4 ( 0.5) (-0.5) (-0.5) 1, V3 0 1 1) + , (V4 ( 0.5) (-0.5) ( 0.5) 1, V3 0 1 1) + , (V4 (-0.5) (-0.5) (-0.5) 1, V3 0 1 1) + , (V4 ( 0.5) (-0.5) ( 0.5) 1, V3 0 1 1) + , (V4 (-0.5) (-0.5) ( 0.5) 1, V3 0 1 1) + + , (V4 (-0.5) ( 0.5) (-0.5) 1, V3 1 1 0) + , (V4 ( 0.5) ( 0.5) ( 0.5) 1, V3 1 1 0) + , (V4 ( 0.5) ( 0.5) (-0.5) 1, V3 1 1 0) + , (V4 (-0.5) ( 0.5) (-0.5) 1, V3 1 1 0) + , (V4 (-0.5) ( 0.5) ( 0.5) 1, V3 1 1 0) + , (V4 ( 0.5) ( 0.5) ( 0.5) 1, V3 1 1 0) + ] + + uniformBuffer <- newBuffer 1 + + shader <- compileShader $ do + quart <- getUniform (const (uniformBuffer,0)) + primitiveStream <- toPrimitiveStream id + let rotatedStream = fmap (\(v,c) -> (toV4 (rot quart (toV3 v)), c)) primitiveStream + fragmentStream <- rasterize (const (Front, ViewPort (V2 0 0) (V2 800 800), DepthRange 0 1)) rotatedStream + drawWindowColor (const (win, ContextColorOption NoBlending (V3 True True True))) fragmentStream + + loop controller (Quaternion 1 (V3 0 0 0)) vertexBuffer uniformBuffer shader win + setInputMode Simple controller + void $ getInput controller -- ack + +loop + :: Controller 'LeftJoyCon + -> Quaternion Float + -> Buffer os (B4 Float, B3 Float) + -> Buffer os (Uniform (Quaternion (B Float))) + -> CompiledShader os (PrimitiveArray Triangles (B4 Float, B3 Float)) + -> Window os RGBFloat () + -> ContextT GLFW.Handle os IO () +loop controller quart vertexBuffer uniformBuffer shader win = do + input <- liftIO $ getInput controller + let newQuart@(Quaternion w (V3 xq yq zq)) = + -- Capture button resets rotation because of sensor drift + if btnCapture input then + Quaternion 1 (V3 0 0 0) + else + case extras input of + Inertial (a1,a2,a3) (g1, g2, g3) -> + let + -- convert Joy-Con axes to Madgwick axes + flipAxes (x,y,z) = (x,-y,-z) + -- disable Z rotation (yaw) to stabilize output with 6 DoF IMU + zeroZ (x,y,_) = (x,y,0) + -- beta parameter can be tweaked for Madgwick algorithm + beta = 0.01 + -- Joy-Con provides three measurements in 15ms, hence a 5ms rate + freq = 1 / 0.005 + -- Madgwick algorithm for accelerometer and gyroscope sensor fusion + newQ1 = madgwick (flipAxes a1) (flipAxes $ zeroZ g1) beta freq quart + newQ2 = madgwick (flipAxes a2) (flipAxes $ zeroZ g2) beta freq newQ1 + newQ3 = madgwick (flipAxes a3) (flipAxes $ zeroZ g3) beta freq newQ2 + in newQ3 + _ -> quart + -- convert Madgwick axes to OpenGL axes + let openGLquart = Quaternion w (V3 (-yq) zq xq) + writeBuffer uniformBuffer 0 [openGLquart] + render $ do + clearWindowColor win (V3 0 0 0) + vertexArray <- newVertexArray vertexBuffer + shader $ toPrimitiveArray TriangleList vertexArray + swapWindowBuffers win + + closeRequested <- GLFW.windowShouldClose win + unless (closeRequested == Just True) $ + loop controller newQuart vertexBuffer uniformBuffer shader win diff --git a/test/LeftJoyCon/Main.hs b/test/LeftJoyCon/Main.hs new file mode 100644 --- /dev/null +++ b/test/LeftJoyCon/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +module Main where + +-- base +import Control.Monad (forM_, void) + +-- switch +import Device.Nintendo.Switch + +import ControllerTest (ackInputMode, leftTest, sensorTest) + +main :: IO () +main = do + putStrLn "------------------------------------------------------------------" + putStrLn "Testing all connected left Joy-Cons one after another ..." + putStrLn "Press Arrow Down to enable controller vibration." + putStrLn "Press Arrow Right to disable controller vibration." + putStrLn "Press - to test the sensors and analog stick input." + putStrLn "Press Capture to end the test of the sensors and the stick." + putStrLn "------------------------------------------------------------------" + withConsole $ \switch -> do + infos <- getControllerInfos @'LeftJoyCon switch + forM_ infos $ \info -> + withController info $ \controller -> do + setInputMode Simple controller + ackInputMode controller -- ack + setPlayerLights flashAll controller + void $ getInput controller -- ack + setVibration True controller + leftTest controller -- ack comes with first input + setInertialMeasurement True controller + void $ getInput controller -- ack + setInputMode Standard controller + sensorTest btnCapture controller -- ack comes with first input + setInputMode Simple controller + void $ getInput controller -- ack diff --git a/test/ProController/Main.hs b/test/ProController/Main.hs new file mode 100644 --- /dev/null +++ b/test/ProController/Main.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +module Main where + +-- base +import Control.Monad (forM_, void) + +-- switch +import Device.Nintendo.Switch + +import ControllerTest (leftTest, rightTest, sensorTest) + +main :: IO () +main = do + putStrLn "------------------------------------------------------------------" + putStrLn "Testing all connected Pro controllers one after another ..." + putStrLn "------------------------------------------------------------------" + withConsole $ \switch -> do + infos <- getControllerInfos @'ProController switch + forM_ infos $ \info -> + withController info $ \controller -> do + setPlayerLights flashAll controller + void $ getInput controller -- ack + setInertialMeasurement False controller + void $ getInput controller -- ack + setVibration True controller + putStrLn "------------------------------------------------------------------" + putStrLn "Testing left side of Pro controller ..." + putStrLn "Press Arrow Down to enable controller vibration." + putStrLn "Press Arrow Right to disable controller vibration." + putStrLn "Press - to switch to right side." + putStrLn "------------------------------------------------------------------" + leftTest controller -- ack comes with first input + putStrLn "------------------------------------------------------------------" + putStrLn "Testing right side of Pro controller ..." + putStrLn "Press Y to enable the home light." + putStrLn "Press X to disable the home light." + putStrLn "Press B to enable controller vibration." + putStrLn "Press A to disable controller vibration." + putStrLn "Press + to test the sensors and analog stick inputs." + putStrLn "Press Home to end the test of the sensors and the sticks." + putStrLn "------------------------------------------------------------------" + rightTest controller + setInertialMeasurement True controller + sensorTest btnHome controller -- ack comes with first input diff --git a/test/RightJoyCon/Main.hs b/test/RightJoyCon/Main.hs new file mode 100644 --- /dev/null +++ b/test/RightJoyCon/Main.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +module Main where + +-- base +import Control.Monad (forM_, void) + +-- switch +import Device.Nintendo.Switch + +import ControllerTest (ackInputMode, rightTest, sensorTest) + +main :: IO () +main = do + putStrLn "----------------------------------------------------------" + putStrLn "Testing all connected right Joy-Cons one after another ..." + putStrLn "Press Y to enable the home light." + putStrLn "Press X to disable the home light." + putStrLn "Press B to enable controller vibration." + putStrLn "Press A to disable controller vibration." + putStrLn "Press + to test the sensors and analog stick input." + putStrLn "Press Home to end the test of the sensors and the stick." + putStrLn "----------------------------------------------------------" + withConsole $ \switch -> do + infos <- getControllerInfos @'RightJoyCon switch + forM_ infos $ \info -> + withController info $ \controller -> do + setInputMode Simple controller + ackInputMode controller -- ack + setPlayerLights flashAll controller + void $ getInput controller -- ack + setVibration True controller + rightTest controller -- ack comes with first input + setInertialMeasurement True controller + void $ getInput controller -- ack + setInputMode Standard controller + sensorTest btnHome controller -- ack comes with first input + setInputMode Simple controller + void $ getInput controller -- ack