diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Brian W Bush + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/ReadMe.md b/ReadMe.md new file mode 100644 --- /dev/null +++ b/ReadMe.md @@ -0,0 +1,16 @@ +Web Socket interface for Leap Motion controllers +================================================ + +This Haskell package contains functions for interfacing with Leap Motion controllers, <>. It is based on the WebSocket API <> and inspired by <>. It has been tested with Service Version 2.3.1+31549 of the Web Sockets server from Leap Motion. + +Skeletal example +---------------- + +This simple example program prints all Leap Motion events: + +```haskell +main :: IO () +main = + runWithHandler def [setFocused True, setGestures True] $ \event -> + print (event :: Event Float) +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hleap.cabal b/hleap.cabal new file mode 100644 --- /dev/null +++ b/hleap.cabal @@ -0,0 +1,60 @@ +name: hleap +version: 0.1.2.4 +synopsis: Web Socket interface to Leap Motion controller +description: This Haskell package contains functions for interfacing with Leap Motion controllers, <>. It is based on the WebSocket API <> and inspired by <>. It has been tested with Service Version 2.3.1+31549 of the Web Sockets server from Leap Motion. + +license: MIT +license-file: LICENSE +author: Brian W Bush +maintainer: Brian W Bush +copyright: (c) 2016 Brian W Bush +category: Hardware +build-type: Simple +cabal-version: >= 1.10 +stability: Stable +homepage: https://bitbucket.org/bwbush/hleap +bug-reports: https://bwbush.atlassian.net/projects/HLEAP/issues/ +package-url: https://bitbucket.org/bwbush/hleap/downloads/hleap-0.1.2.4.tar.gz +author: Brian W Bush +maintainer: b.w.bush@acm.org + +extra-source-files: ReadMe.md + +source-repository head + type: git + location: https://bwbush@bitbucket.org/bwbush/hleap.git + +library + build-depends: base >= 4.8 && < 5 + , aeson >= 0.10.0.0 + , containers >= 0.5.6.2 + , data-default >= 0.5.3 + , mtl >= 2.2.1 + , text >= 1.2.1.3 + , unordered-containers >= 0.2.5.1 + , websockets >= 0.9.6.1 + exposed-modules: System.Hardware.Leap + System.Hardware.Leap.Event + System.Hardware.Leap.Event.Gesture + System.Hardware.Leap.Event.Hand + System.Hardware.Leap.Event.Pointable + System.Hardware.Leap.Types + hs-source-dirs: src + exposed: True + buildable: True + ghc-options: -Wall + default-language: Haskell2010 + +executable leap-tracker + main-is: Main.hs + build-depends: base >=4.8 && <4.9 + , aeson + , containers + , data-default + , mtl + , text + , unordered-containers + , websockets + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,57 @@ +{-| +Module : Main +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Tracing events from Leap Motion \<\>, based on the Web Socket API \<\>. +-} + + +{-# LANGUAGE RecordWildCards #-} + + +module Main ( + main +) where + + +import Data.Default (def) +import System.Hardware.Leap (runWithHandler, setFocused, setGestures) +import System.Hardware.Leap.Event (Event(..)) +import System.Hardware.Leap.Event.Hand (Hand(side)) +import System.Hardware.Leap.Event.Gesture (Gesture(..)) +import System.Hardware.Leap.Event.Pointable (Pointable(..)) + + +-- | Main entry point. +main :: IO () +main = runWithHandler def [setFocused True, setGestures True] handler + + +-- | Handle events. +handler :: Event Float -> IO () +handler Tracking{..} + | not (null gestures ) = mapM_ handleGesture gestures + | not (null pointables) = mapM_ handlePointable pointables + | otherwise = return () +handler _ = return () + + +-- | Handle pointable events. +handlePointable :: Show a => Pointable a -> IO () +handlePointable Finger{..} = putStrLn $ "FINGER\t " ++ show (side hand) ++ "\t" ++ show finger ++ "\t" ++ show stabilizedTipPosition +handlePointable Tool{..} = putStrLn $ "TOOL\t " ++ show (side hand) ++ "\t" ++ show stabilizedTipPosition +handlePointable PointableReference{} = return () + + +-- | Handle gesture events. +handleGesture :: Gesture a -> IO () +handleGesture Circle{..} = putStrLn $ "CIRCLE\t " ++ show state ++ "\t" ++ show (map side hands) +handleGesture Swipe{..} = putStrLn $ "SWIPE\t" ++ show state ++ "\t" ++ show (map side hands) +handleGesture KeyTap{..} = putStrLn $ "KEY TAP\t" ++ show state ++ "\t" ++ show (map side hands) +handleGesture ScreenTap{..} = putStrLn $ "SCREEN TAP\t" ++ show state ++ "\t" ++ show (map side hands) +handleGesture GestureReference{} = return () diff --git a/src/System/Hardware/Leap.hs b/src/System/Hardware/Leap.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Leap.hs @@ -0,0 +1,165 @@ +{-| +Module : System.Hardware.Leap +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Interaction with Leap Motion \<\>, based on the Web Socket API \<\>. + +Here is a simple example applicaton that prints all events: + +@ +main :: IO () +main = + runWithHandler def [setFocused True, setGestures True] $ \event -> + print (event :: Event Float) +@ +-} + + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module System.Hardware.Leap ( +-- * Configuration + Configuration(..) +, Version(..) +, setBackground +, setFocused +, setGestures +, setOptimizedHMD +-- * Applications +, ClientApp +, Handler +, run +, runWithHandler +) where + + +import Control.Applicative (empty) +import Control.Monad (forever) +import Data.Aeson (FromJSON(..), Value(..), (.:), eitherDecode) +import Data.Default (Default(..)) +import Data.Text (pack) +import Network.WebSockets (Connection, receiveData, runClient, sendTextData) +import System.Hardware.Leap.Event (Event(..)) + + +-- | Configuration for a connection to a Leap Motion controller via Web Sockets. +data Configuration = + Configuration + { + host :: String -- ^ Host name. + , port :: Int -- ^ Port number. + } + deriving (Eq, Ord, Read, Show) + +instance Default Configuration where + def = + Configuration + { + host = "localhost" + , port = 6437 + } + + +-- | A client application for Leap Motion using Web Sockets. +type ClientApp a = Connection -- ^ The Web Socet connection. + -> IO a -- ^ Action for the client application. + + +-- | A handler for Leap Motion events. +type Handler a = Event a -- ^ The event. + -> IO () -- ^ The action for handling the event. + + +-- | Run a Leap Motion application using Web Sockets. +run :: Configuration -- ^ The Web Socket configuration. + -> ClientApp a -- ^ The client application. + -> IO a -- ^ Action for running the client. +run Configuration{..} app = + runClient host port "/v6.json" $ \connection -> + do + version' <- eitherDecode <$> receiveData connection + case version' of + Right v@(Version _ 6) -> putStrLn $ "Leap connection" ++ show v + Right v -> error $ "Incorrect version: " ++ show v + Left s -> error s + app connection + + +-- | Modify a Leap Motion connection. +type ConnectionModifier = Connection -- ^ The Web Socket connection. + -> IO () -- ^ Action for modifying the connection. + + +-- | Run and process events from Leap Motion using Web Sockets. +runWithHandler :: FromJSON a + => Configuration -- ^ The Web Socket configuration. + -> [ConnectionModifier] -- ^ Modifications to be made to the connection. + -> Handler a -- ^ The event handler. + -> IO () -- ^ Action for running with event handling. +runWithHandler configuration modifiers handler = + run configuration $ \connection -> + do + mapM_ ($ connection) modifiers + forever $ do + event' <- eitherDecode <$> receiveData connection + case event' of + Right e -> handler e + Left s -> error s + + +-- | Version information for Leap Motion. +data Version = + Version + { + serviceVersion :: String + , version :: Int + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON Version where + parseJSON (Object o) = + Version + <$> o .: "serviceVersion" + <*> o .: "version" + parseJSON _ = empty + + +-- | Enable or disable background events. See \<\> for details. +setBackground :: Bool -- ^ Whether to enable background events. + -> ConnectionModifier -- ^ Function for making the modification. +setBackground = setSomething "background" + + +-- | Enable or disable focus. See \<\> for details. +setFocused :: Bool -- ^ Whether to enable focus. + -> ConnectionModifier -- ^ Function for making the modification. +setFocused = setSomething "focused" + + +-- | Enable or disable gestures. See \<\> for details. +setGestures :: Bool -- ^ Whether to enable gestiure events. + -> ConnectionModifier -- ^ Function for making the modification. +setGestures = setSomething "enableGestures" + + +-- | Enable or disable head-mounted-display optimization. See \<\> for details. +setOptimizedHMD :: Bool -- ^ Whether to enable HMD optimization. + -> ConnectionModifier -- ^ Function for making the modification. +setOptimizedHMD = setSomething "optimizeHMD" + + +-- | Enable or disable something in Leap Motion. +setSomething :: String -- ^ What to enable or disable. + -> Bool -- ^ Whether to enable it. + -> ConnectionModifier -- ^ Function for making the modification. +setSomething item enabled connection = + sendTextData connection + $ pack + $ "{\"" ++ item ++ "\" : " ++ (if enabled then "true" else "false") ++ "}" diff --git a/src/System/Hardware/Leap/Event.hs b/src/System/Hardware/Leap/Event.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Leap/Event.hs @@ -0,0 +1,143 @@ +{-| +Module : System.Hardware.Leap.Event +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Events for Leap Motion \<\>, based on the Web Socket API \<\>. +-} + + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module System.Hardware.Leap.Event ( +-- * Events + Event(..) +, State(..) +, InteractionBox(..) +) where + + +import Control.Applicative (empty) +import Data.Aeson (FromJSON(..), Value(..), (.:)) +import Data.List (find) +import Data.Maybe (fromMaybe) +import System.Hardware.Leap.Event.Gesture (Gesture(..)) +import System.Hardware.Leap.Event.Hand (Hand(HandReference)) +import System.Hardware.Leap.Event.Pointable (Pointable(..)) +import System.Hardware.Leap.Types (Duration, LeapId, Matrix, Vector) + +import qualified Data.HashMap.Strict as M (lookup) +import qualified System.Hardware.Leap.Event.Gesture as G (hands, pointables) +import qualified System.Hardware.Leap.Event.Hand as H (leapId) +import qualified System.Hardware.Leap.Event.Pointable as P (hand, leapId) + + +-- | State of a Leap device. +data State = + State + { + attached :: Bool + , leap :: String + , streaming :: Bool + , leapType :: String + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON State where + parseJSON (Object o) = + State + <$> o .: "attached" + <*> o .: "id" + <*> o .: "streaming" + <*> o .: "type" + parseJSON _ = empty + + +-- | Event information. See \<\> for details. +data Event a = + Event + { + state :: State + , event :: String + } + | Tracking + { + currentFrameRate :: a + , leapId :: LeapId + , r :: Matrix a + , s :: a + , t :: Vector a + , timestamp :: Duration + , devices :: [String] + , gestures :: [Gesture a] + , hands :: [Hand a] + , interactionBox :: InteractionBox a + , pointables :: [Pointable a] + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON a => FromJSON (Event a) where + parseJSON (Object o) = + case "event" `M.lookup` o of + Just (Object o') -> Event + <$> o' .: "state" + <*> o' .: "type" + Nothing -> tracking + <$> o .: "currentFrameRate" + <*> o .: "id" + <*> o .: "r" + <*> o .: "s" + <*> o .: "t" + <*> o .: "timestamp" + <*> o .: "devices" + <*> o .: "gestures" + <*> o .: "hands" + <*> o .: "interactionBox" + <*> o .: "pointables" + _ -> empty + parseJSON _ = empty + + +-- | Construct tracking information. +tracking :: a -> Int -> Matrix a -> a -> Vector a -> Int -> [String] -> [Gesture a] -> [Hand a] -> InteractionBox a -> [Pointable a] -> Event a +tracking currentFrameRate leapId r s t timestamp devices gestures' hands interactionBox pointables' = + let + replaceHand h@(HandReference i) = fromMaybe h $ find ((== i) . H.leapId) hands + replaceHand h = h + replacePointable p@(PointableReference i) = fromMaybe p $ find ((== i) . P.leapId) pointables + replacePointable p = p + updatePointable p@Finger{} = p {P.hand = replaceHand $ P.hand p} + updatePointable p@Tool{} = p {P.hand = replaceHand $ P.hand p} + updatePointable p@PointableReference{} = p + updateGesture g@Circle{} = g {G.hands = map replaceHand $ G.hands g, G.pointables = map replacePointable $ G.pointables g} + updateGesture g@Swipe{} = g {G.hands = map replaceHand $ G.hands g, G.pointables = map replacePointable $ G.pointables g} + updateGesture g@KeyTap{} = g {G.hands = map replaceHand $ G.hands g, G.pointables = map replacePointable $ G.pointables g} + updateGesture g@ScreenTap{} = g {G.hands = map replaceHand $ G.hands g, G.pointables = map replacePointable $ G.pointables g} + updateGesture g@GestureReference{} = g + pointables = map updatePointable pointables' + gestures = map updateGesture gestures' + in + Tracking{..} + + +-- | An interaction box. +data InteractionBox a = + InteractionBox + { + center :: Vector a + , size :: Vector a + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON a => FromJSON (InteractionBox a) where + parseJSON (Object o) = + InteractionBox + <$> o .: "center" + <*> o .: "size" + parseJSON _ = empty diff --git a/src/System/Hardware/Leap/Event/Gesture.hs b/src/System/Hardware/Leap/Event/Gesture.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Leap/Event/Gesture.hs @@ -0,0 +1,141 @@ +{-| +Module : System.Hardware.Leap.Event.Gesture +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Gesture events for Leap Motion \<\>, based on the Web Socket API \<\>. +-} + + +{-# LANGUAGE OverloadedStrings #-} + + +module System.Hardware.Leap.Event.Gesture ( +-- * Events + Gesture(..) +, State(..) +) where + + +import Control.Applicative (empty) +import Data.Aeson (FromJSON(..), Value(..), (.:)) +import System.Hardware.Leap.Event.Hand (Hand(HandReference)) +import System.Hardware.Leap.Event.Pointable (Pointable(PointableReference)) +import System.Hardware.Leap.Types (Duration, LeapId, Vector) + +import qualified Data.HashMap.Strict as M (lookup) + + +-- | The state of a gesture. +data State = Start | Update | Stop + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance FromJSON State where + parseJSON (String "start" ) = return Start + parseJSON (String "update") = return Update + parseJSON (String "stop" ) = return Stop + parseJSON _ = empty + + +-- | Gesture tracking information. See \<\> for details. +data Gesture a = + GestureReference + { + leapId :: LeapId + } + | Circle + { + center :: Vector a + , duration :: Duration + , hands :: [Hand a] + , leapId :: LeapId + , normal :: Vector a + , pointables :: [Pointable a] + , progress :: a + , radius :: a + , state :: State + } + | Swipe + { + direction :: Vector a + , duration :: Duration + , hands :: [Hand a] + , leapId :: LeapId + , pointables :: [Pointable a] + , position :: Vector a + , speed :: a + , startPosition :: Vector a + , state :: State + } + | KeyTap + { + direction :: Vector a + , duration :: Duration + , hands :: [Hand a] + , leapId :: LeapId + , pointables :: [Pointable a] + , position :: Vector a + , progress :: a + , state :: State + } + | ScreenTap + { + direction :: Vector a + , duration :: Duration + , hands :: [Hand a] + , leapId :: LeapId + , pointables :: [Pointable a] + , position :: Vector a + , progress :: a + , state :: State + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON a => FromJSON (Gesture a) where + parseJSON (Object o) + | t == Just "circle" = Circle + <$> o .: "center" + <*> o .: "duration" + <*> (map HandReference <$> o .: "handIds") + <*> o .: "id" + <*> o .: "normal" + <*> (map PointableReference <$> o .: "pointableIds") + <*> o .: "progress" + <*> o .: "radius" + <*> o .: "state" + | t == Just "swipe" = Swipe + <$> o .: "direction" + <*> o .: "duration" + <*> (map HandReference <$> o .: "handIds") + <*> o .: "id" + <*> (map PointableReference <$> o .: "pointableIds") + <*> o .: "position" + <*> o .: "speed" + <*> o .: "startPosition" + <*> o .: "state" + | t == Just "keyTap" = KeyTap + <$> o .: "direction" + <*> o .: "duration" + <*> (map HandReference <$> o .: "handIds") + <*> o .: "id" + <*> (map PointableReference <$> o .: "pointableIds") + <*> o .: "position" + <*> o .: "progress" + <*> o .: "state" + | t == Just "screenTap" = ScreenTap + <$> o .: "direction" + <*> o .: "duration" + <*> (map HandReference <$> o .: "handIds") + <*> o .: "id" + <*> (map PointableReference <$> o .: "pointableIds") + <*> o .: "position" + <*> o .: "progress" + <*> o .: "state" + | otherwise = empty + where + t = "type" `M.lookup` o + parseJSON _ = empty diff --git a/src/System/Hardware/Leap/Event/Hand.hs b/src/System/Hardware/Leap/Event/Hand.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Leap/Event/Hand.hs @@ -0,0 +1,93 @@ +{-| +Module : System.Hardware.Leap.Event.Hand +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Hand events for Leap Motion \<\>, based on the Web Socket API \<\>. +-} + + +{-# LANGUAGE OverloadedStrings #-} + + +module System.Hardware.Leap.Event.Hand ( +-- * Events + Hand(..) +, Side(..) +) where + + +import Control.Applicative (empty) +import Data.Aeson (FromJSON(..), Value(..), (.:)) +import System.Hardware.Leap.Types (Basis, LeapId, Matrix, Vector) + + +-- | Hands. +data Side = LeftHand | RightHand + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance FromJSON Side where + parseJSON (String "left" ) = return LeftHand + parseJSON (String "right") = return RightHand + parseJSON _ = empty + + +-- | Hand tracking information. See \<\> for details. +data Hand a = + HandReference + { + leapId :: LeapId + } + | Hand + { + armBasis :: Basis a + , armWidth :: a + , confidence :: a + , direction :: Vector a + , elbow :: Vector a + , grabStrength :: a + , leapId :: LeapId + , palmNormal :: Vector a + , palmPosition :: Vector a + , palmVelocity :: Vector a + , pinchStrength :: a + , r :: Matrix a + , s :: a + , sphereCenter :: Vector a + , sphereRadius :: a + , stabilizedPalmPosition :: Vector a + , t :: Vector a + , timeVisible :: a + , side :: Side + , wrist :: Vector a + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON a => FromJSON (Hand a) where + parseJSON (Object o) = + Hand + <$> o .: "armBasis" + <*> o .: "armWidth" + <*> o .: "confidence" + <*> o .: "direction" + <*> o .: "elbow" + <*> o .: "grabStrength" + <*> o .: "id" + <*> o .: "palmNormal" + <*> o .: "palmPosition" + <*> o .: "palmVelocity" + <*> o .: "pinchStrength" + <*> o .: "r" + <*> o .: "s" + <*> o .: "sphereCenter" + <*> o .: "sphereRadius" + <*> o .: "stabilizedPalmPosition" + <*> o .: "t" + <*> o .: "timeVisible" + <*> o .: "type" + <*> o .: "wrist" + parseJSON _ = empty diff --git a/src/System/Hardware/Leap/Event/Pointable.hs b/src/System/Hardware/Leap/Event/Pointable.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Leap/Event/Pointable.hs @@ -0,0 +1,136 @@ +{-| +Module : System.Hardware.Leap.Event.Pointable +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Pointable events for Leap Motion \<\>, based on the Web Socket API \<\>. +-} + + +{-# LANGUAGE OverloadedStrings #-} + + +module System.Hardware.Leap.Event.Pointable ( +-- * Events + Pointable(..) +, TouchZone(..) +, Finger(..) +) where + + +import Control.Applicative (empty) +import Data.Aeson (FromJSON(..), Value(..), (.:)) +import Data.Map.Strict (Map, fromList) +import System.Hardware.Leap.Event.Hand (Hand(HandReference)) +import System.Hardware.Leap.Types (Basis, LeapId, Vector) + +import qualified Data.HashMap.Strict as M (lookup) + + +-- | Touch zones. +data TouchZone = None | Hovering | Touching + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance FromJSON TouchZone where + parseJSON (String "none" ) = return None + parseJSON (String "hovering") = return Hovering + parseJSON (String "touching") = return Touching + parseJSON _ = empty + + +-- | Fingers. +data Finger = Thumb | IndexFinger | MiddleFinger | RingFinger | Pinky + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance FromJSON Finger where + parseJSON (Number 0) = return Thumb + parseJSON (Number 1) = return IndexFinger + parseJSON (Number 2) = return MiddleFinger + parseJSON (Number 3) = return RingFinger + parseJSON (Number 4) = return Pinky + parseJSON _ = empty + + +-- | Pointable tracking information. See \<\> for details. +data Pointable a = + PointableReference + { + leapId :: LeapId + } + | Finger + { + bases :: Map Finger (Basis a) + , btipPosition :: Vector a + , carpPosition :: Vector a + , dipPosition :: Vector a + , direction :: Vector a + , extended :: Bool + , hand :: Hand a + , leapId :: LeapId + , pointableLength :: a + , mcpPosition :: Vector a + , pipPosition :: Vector a + , stabilizedTipPosition :: Vector a + , timeVisible :: a + , tipPosition :: Vector a + , tipVelocity :: Vector a + , touchDistance :: a + , touchZone :: TouchZone + , finger :: Finger + , width :: a + } + | Tool + { + direction :: Vector a + , hand :: Hand a + , leapId :: LeapId + , pointableLength :: a + , stabilizedTipPosition :: Vector a + , timeVisible :: a + , tipPosition :: Vector a + , tipVelocity :: Vector a + , touchDistance :: a + , touchZone :: TouchZone + , width :: a + } + deriving (Eq, Ord, Read, Show) + +instance FromJSON a => FromJSON (Pointable a) where + parseJSON (Object o) + | "tool" `M.lookup` o == Just (Bool True) = Tool + <$> o .: "direction" + <*> (HandReference <$> o .: "handId") + <*> o .: "id" + <*> o .: "length" + <*> o .: "stabilizedTipPosition" + <*> o .: "timeVisible" + <*> o .: "tipPosition" + <*> o .: "tipVelocity" + <*> o .: "touchDistance" + <*> o .: "touchZone" + <*> o .: "width" + | otherwise = Finger + <$> (fromList . zip [minBound..maxBound] <$> o .: "bases") + <*> o .: "btipPosition" + <*> o .: "carpPosition" + <*> o .: "dipPosition" + <*> o .: "direction" + <*> o .: "extended" + <*> (HandReference <$> o .: "handId") + <*> o .: "id" + <*> o .: "length" + <*> o .: "mcpPosition" + <*> o .: "pipPosition" + <*> o .: "stabilizedTipPosition" + <*> o .: "timeVisible" + <*> o .: "tipPosition" + <*> o .: "tipVelocity" + <*> o .: "touchDistance" + <*> o .: "touchZone" + <*> o .: "type" + <*> o .: "width" + parseJSON _ = empty diff --git a/src/System/Hardware/Leap/Types.hs b/src/System/Hardware/Leap/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Hardware/Leap/Types.hs @@ -0,0 +1,41 @@ +{-| +Module : System.Hardware.Leap.Event.Types +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Stable +Portability : Portable + + +Types for Leap Motion \<\>, based on the Web Socket API \<\>. +-} + + +module System.Hardware.Leap.Types ( +-- * Types + LeapId +, Duration +, Vector +, Basis +, Matrix +) where + + +-- | ID for an item tracked by Leap. +type LeapId = Int + + +-- | Measurement of time. +type Duration = Int + + +-- | Three dimensional vector. +type Vector a = (a, a, a) + + +-- | Three dimensionsional basis. +type Basis a = (Vector a, Vector a, Vector a) + + +-- | Three dimensionsional rotation matrix. +type Matrix a = (Vector a, Vector a, Vector a)