module System.Hardware.Hydra
(
sixenseInit
, sixenseExit
, autoEnableHemisphereTracking
, getMaxControllers
, maxBases
, setActiveBase
, baseConnected
, controllerEnabled
, numActiveControllers
, historySize
, SixenseSuccess(..)
, ControllerID
, Button
, buttonBumper, buttonJoystick
, button1, button2, button3, button4
, buttonStart
, ControllerData(..)
, AllControllerData(..)
, getData
, getAllData
, getNewestData
, getAllNewestData
, setFilterEnabled
, getFilterEnabled
)
where
import Foreign
import Foreign.C.Types
import Foreign.C.Error
import Foreign.Storable
import qualified Data.Packed.Vector as Vector
import Data.Packed.Vector(Vector)
import qualified Data.Packed.Matrix as Matrix
import Data.Packed.Matrix(Matrix,(><))
import Control.Monad
import Control.Applicative
import Control.Concurrent(threadDelay)
newtype Button = Button { unButton :: CUInt }
deriving (Eq,Show)
buttonBumper :: Button
buttonBumper = Button 128
buttonJoystick :: Button
buttonJoystick = Button 256
button1 :: Button
button1 = Button 32
button2 :: Button
button2 = Button 64
button3 :: Button
button3 = Button 8
button4 :: Button
button4 = Button 16
buttonStart :: Button
buttonStart = Button 1
combineButtons :: [Button] -> Button
combineButtons = Button . foldr ((.|.) . unButton) 0
maxControllers :: Int
maxControllers = (fromIntegral :: CInt -> Int) 4
data SixenseSuccess = Success | Failure deriving (Show, Eq)
fromCInt :: CInt -> SixenseSuccess
fromCInt i = if i == 1 then Failure else Success
mFromCInt :: IO CInt -> IO SixenseSuccess
mFromCInt = liftM fromCInt
data ControllerData = ControllerData
{ pos :: Vector Float
, rotMat :: Matrix Float
, joystickX :: !Float
, joystickY :: !Float
, trigger :: !Float
, buttons :: !Button
, sequenceNumber :: !Word8
, rotQuat :: Vector Float
, firmwareRevision :: !CUShort
, hardwareRevision :: !CUShort
, packetType :: !CUShort
, magneticFrequency :: !CUShort
, enabled :: !Bool
, controllerIndex :: !CInt
, isDocked :: !Bool
, whichHand :: !Word8
, hemiTrackingEnabled :: !Bool
}
instance Storable ControllerData where
sizeOf _ = (104)
alignment _ = alignment (undefined :: CInt)
peek p = ControllerData
<$> (do
let ptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 0) p) :: Ptr CFloat
lst <- peekArray 3 ptr
return $ Vector.fromList $ map realToFrac lst)
<*> (do
let ptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 12) p) :: Ptr CFloat
lst <- peekArray (3 * 3) ptr
return $ (3><3) $ map realToFrac lst)
<*> liftM realToFrac (((\hsc_ptr -> peekByteOff hsc_ptr 48) p) :: IO CFloat)
<*> liftM realToFrac (((\hsc_ptr -> peekByteOff hsc_ptr 52) p) :: IO CFloat)
<*> liftM realToFrac (((\hsc_ptr -> peekByteOff hsc_ptr 56) p) :: IO CFloat)
<*> liftM Button ((\hsc_ptr -> peekByteOff hsc_ptr 60) p)
<*> liftM fromIntegral (((\hsc_ptr -> peekByteOff hsc_ptr 64) p) :: IO CUChar)
<*> (do
let ptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 68) p) :: Ptr CFloat
lst <- peekArray 4 ptr
return $ Vector.fromList $ map realToFrac lst)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 84) p)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 86) p)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 88) p)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 90) p)
<*> liftM (/= 0) (((\hsc_ptr -> peekByteOff hsc_ptr 92) p) :: IO CInt)
<*> ((\hsc_ptr -> peekByteOff hsc_ptr 96) p)
<*> liftM (/= 0) (((\hsc_ptr -> peekByteOff hsc_ptr 100) p) :: IO CUChar)
<*> liftM fromIntegral (((\hsc_ptr -> peekByteOff hsc_ptr 101) p) :: IO CUChar)
<*> liftM (/= 0) (((\hsc_ptr -> peekByteOff hsc_ptr 102) p) :: IO CUChar)
poke p x = do
(pokeArray
((\hsc_ptr -> hsc_ptr `plusPtr` 0) p)
(Vector.toList $ pos x))
(pokeArray
((\hsc_ptr -> hsc_ptr `plusPtr` 12) p)
(Vector.toList $ Matrix.flatten $ rotMat x))
(\hsc_ptr -> pokeByteOff hsc_ptr 48) p (joystickX x)
(\hsc_ptr -> pokeByteOff hsc_ptr 52) p (joystickY x)
(\hsc_ptr -> pokeByteOff hsc_ptr 56) p (trigger x)
(\hsc_ptr -> pokeByteOff hsc_ptr 60) p (unButton $ buttons x)
(\hsc_ptr -> pokeByteOff hsc_ptr 64) p (sequenceNumber x)
(pokeArray
((\hsc_ptr -> hsc_ptr `plusPtr` 68) p)
(Vector.toList $ rotQuat x))
(\hsc_ptr -> pokeByteOff hsc_ptr 84) p (firmwareRevision x)
(\hsc_ptr -> pokeByteOff hsc_ptr 86) p (hardwareRevision x)
(\hsc_ptr -> pokeByteOff hsc_ptr 88) p (packetType x)
(\hsc_ptr -> pokeByteOff hsc_ptr 90) p (magneticFrequency x)
(\hsc_ptr -> pokeByteOff hsc_ptr 92) p (((fromIntegral . fromEnum) :: Bool -> CInt) $ enabled x)
(\hsc_ptr -> pokeByteOff hsc_ptr 96) p (controllerIndex x)
(\hsc_ptr -> pokeByteOff hsc_ptr 100) p (((fromIntegral . fromEnum) :: Bool -> CInt) $ isDocked x)
(\hsc_ptr -> pokeByteOff hsc_ptr 101) p (whichHand x)
(\hsc_ptr -> pokeByteOff hsc_ptr 102) p (((fromIntegral . fromEnum) :: Bool -> CInt) $ hemiTrackingEnabled x)
data AllControllerData = AllControllerData { controllers :: [ControllerData] }
instance Storable AllControllerData where
sizeOf _ = (416)
alignment _ = alignment (undefined :: ControllerData)
peek p = AllControllerData <$> (do
let ptr = ((\hsc_ptr -> hsc_ptr `plusPtr` 0) p) :: Ptr ControllerData
lst <- peekArray maxControllers ptr
return lst)
poke p x = do
(pokeArray ((\hsc_ptr -> hsc_ptr `plusPtr` 0) p) (controllers x))
type ControllerID = Int
foreign import ccall "sixense.h sixenseInit"
c_sixsenseInit :: IO CInt
sixenseInit :: IO SixenseSuccess
sixenseInit = do
r <- mFromCInt c_sixsenseInit
threadDelay 2000000
return r
foreign import ccall "sixense.h sixenseExit"
c_sixsenseExit :: IO CInt
sixenseExit :: IO SixenseSuccess
sixenseExit = mFromCInt c_sixsenseExit
foreign import ccall "sixense.h sixenseAutoEnableHemisphereTracking"
c_sixenseAutoEnableHemisphereTracking :: CInt -> IO CInt
autoEnableHemisphereTracking :: ControllerID -> IO SixenseSuccess
autoEnableHemisphereTracking controller = mFromCInt $ c_sixenseAutoEnableHemisphereTracking (fromIntegral controller)
foreign import ccall "sixense.h sixenseGetMaxBases"
c_sixenseGetMaxBases :: CInt
maxBases :: Int
maxBases = fromIntegral c_sixenseGetMaxBases
foreign import ccall "sixense.h sixenseSetActiveBase"
c_sixenseSetActiveBase :: CInt -> IO CInt
setActiveBase :: Int -> IO SixenseSuccess
setActiveBase = mFromCInt . c_sixenseSetActiveBase . fromIntegral
foreign import ccall "sixense.h sixenseIsBaseConnected"
c_sixenseIsBaseConnected :: CInt -> IO CInt
baseConnected :: ControllerID -> IO Bool
baseConnected = liftM (/= 0) . c_sixenseIsBaseConnected . fromIntegral
foreign import ccall "sixense.h sixenseGetMaxControllers"
c_sixenseGetMaxControllers :: CInt
getMaxControllers :: Int
getMaxControllers = fromIntegral c_sixenseGetMaxControllers
foreign import ccall "sixense.h sixenseIsControllerEnabled"
c_sixenseIsControllerEnabled :: CInt -> IO CInt
controllerEnabled :: ControllerID -> IO Bool
controllerEnabled = (liftM (/= 0)) . c_sixenseIsControllerEnabled . fromIntegral
foreign import ccall "sixense.h sixenseGetNumActiveControllers"
c_sixenseGetNumActiveControllers :: IO CInt
numActiveControllers :: IO Int
numActiveControllers = (liftM fromIntegral) c_sixenseGetNumActiveControllers
foreign import ccall "sixense.h sixenseGetHistorySize"
c_sixenseGetHistorySize :: IO CInt
historySize :: IO Int
historySize = (liftM fromIntegral) c_sixenseGetHistorySize
foreign import ccall "sixense.h sixenseGetData"
c_sixenseGetData :: CInt -> CInt -> Ptr ControllerData -> IO CInt
getData :: ControllerID
-> Int
-> IO (Maybe ControllerData)
getData which historyLength = alloca $ \dataPtr -> do
success <- mFromCInt (c_sixenseGetData (fromIntegral which) (fromIntegral historyLength) dataPtr)
case success of
Success -> peek dataPtr >>= return . Just
Failure -> return Nothing
foreign import ccall "sixense.h sixenseGetAllData"
c_sixenseGetAllData :: CInt -> Ptr AllControllerData -> IO CInt
getAllData :: Int
-> IO (Maybe AllControllerData)
getAllData historyLength = alloca $ \dataPtr -> do
success <- mFromCInt (c_sixenseGetAllData (fromIntegral historyLength) dataPtr)
case success of
Success -> peek dataPtr >>= return . Just
Failure -> return Nothing
foreign import ccall "sixense.h sixenseGetNewestData"
c_sixenseGetNewestData :: CInt -> Ptr ControllerData -> IO CInt
getNewestData :: ControllerID -> IO (Maybe ControllerData)
getNewestData which = alloca $ \dataPtr -> do
success <- mFromCInt (c_sixenseGetNewestData (fromIntegral which) dataPtr)
case success of
Success -> peek dataPtr >>= return . Just
Failure -> return Nothing
foreign import ccall "sixense.h sixenseGetNewestData"
c_sixenseGetAllNewestData :: Ptr AllControllerData -> IO CInt
getAllNewestData :: IO (Maybe AllControllerData)
getAllNewestData = alloca $ \dataPtr -> do
success <- mFromCInt (c_sixenseGetAllNewestData dataPtr)
case success of
Success -> peek dataPtr >>= return . Just
Failure -> return Nothing
foreign import ccall "sixense.h sixenseSetFilterEnabled"
c_sixenseSetFilterEnabled :: CInt -> IO CInt
setFilterEnabled :: Bool -> IO SixenseSuccess
setFilterEnabled onOrOff = mFromCInt $ c_sixenseSetFilterEnabled ((fromIntegral . fromEnum) onOrOff)
foreign import ccall "sixense.h sixenseGetFilterEnabled"
c_sixenseGetFilterEnabled :: Ptr CInt -> IO CInt
getFilterEnabled :: IO Bool
getFilterEnabled = alloca $ \ptr -> do
success <- mFromCInt $ c_sixenseGetFilterEnabled ptr
case success of
Success -> peek ptr >>= return . (/= 0)
Failure -> return False
foreign import ccall "sixense.h sixenseSetFilterParams"
c_sixenseSetFilterParams :: CFloat -> CFloat -> CFloat -> CFloat -> IO CInt
setFilterParams :: Float
-> Float
-> Float
-> Float
-> IO SixenseSuccess
setFilterParams nearRange nearVal farRange farVal =
mFromCInt $ c_sixenseSetFilterParams
(realToFrac nearRange) (realToFrac nearVal)
(realToFrac farRange) (realToFrac farVal)
foreign import ccall "sixense.h sixenseGetFilterParams"
c_sixenseGetFilterParams :: Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO CInt
getFilterParams :: IO (Maybe (Float, Float, Float, Float))
getFilterParams = allocaArray 4 $ \valPtrs -> do
let nRangePtr = valPtrs
nValPtr = advancePtr valPtrs 1
fRangePtr = advancePtr valPtrs 2
fValPtr = advancePtr valPtrs 3
success <- mFromCInt $ c_sixenseGetFilterParams nRangePtr nValPtr fRangePtr fValPtr
case success of
Success -> peekArray 4 valPtrs >>= \vals -> case map realToFrac vals of
[nR,nV,fR,fV] -> return $ Just (nR,nV,fR,fV)
Failure -> return Nothing
foreign import ccall "sixense.h sixenseSetBaseColor"
c_sixenseSetBaseColor :: CUChar -> CUChar -> CUChar -> IO CInt
setBaseColor :: Int -> Int -> Int -> IO SixenseSuccess
setBaseColor r g b = mFromCInt $ c_sixenseSetBaseColor (fromIntegral r) (fromIntegral g) (fromIntegral b)
foreign import ccall "sixense.h sixenseGetBaseColor"
c_sixenseGetBaseColor :: Ptr CUChar -> Ptr CUChar -> Ptr CUChar -> IO CInt
getBaseColor :: IO (Maybe (Int, Int, Int))
getBaseColor = allocaArray 3 $ \colorsPtrs -> do
let (rPtr,gPtr,bPtr) = (colorsPtrs, advancePtr colorsPtrs 1, advancePtr colorsPtrs 2)
success <- mFromCInt $ c_sixenseGetBaseColor rPtr gPtr bPtr
case success of
Failure -> return Nothing
Success -> do
colors <- peekArray 3 colorsPtrs
let [r,g,b] = map fromIntegral colors
return $ Just (r,g,b)