module Hoodle.Device where
import Control.Applicative
import Control.Monad.Reader
import Data.Configurator.Types
import Data.Int
import Foreign.C
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import Graphics.UI.Gtk
import Hoodle.Config
data PointerType = Core | Stylus | Eraser | Touch
deriving (Show,Eq,Ord)
data PenButton = PenButton1 | PenButton2 | PenButton3 | EraserButton | TouchButton
deriving (Show,Eq,Ord)
data DeviceList = DeviceList { dev_core :: CInt
, dev_core_str :: String
, dev_stylus :: CInt
, dev_stylus_str :: String
, dev_eraser :: CInt
, dev_eraser_str :: String
, dev_touch :: CInt
, dev_touch_str :: String
}
deriving Show
data PointerCoord = PointerCoord { pointerType :: PointerType
, pointerX :: Double
, pointerY :: Double
, pointerZ :: Double
}
| NoPointerCoord
deriving (Show,Eq,Ord)
foreign import ccall "c_initdevice.h initdevice" c_initdevice
:: Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> Ptr CInt
-> CString
-> CString
-> CString
-> CString
-> IO ()
foreign import ccall "c_initdevice.h find_wacom" c_find_wacom
:: CString -> CString -> IO ()
initDevice :: Config -> IO DeviceList
initDevice cfg = do
pstylusname_detect <- newCString "stylus"
perasername_detect <- newCString "eraser"
ptouchname_detect <- newCString "touch"
(mcore,mstylus,meraser,mtouch) <- getPenDevConfig cfg
with 0 $ \pcore ->
with 0 $ \pstylus ->
with 0 $ \peraser -> do
with 0 $ \ptouch -> do
(pcorename,corename) <- case mcore of
Nothing -> (,) <$> newCString "Core Pointer" <*> pure "Core Pointer"
Just core -> (,) <$> newCString core <*> pure core
(pstylusname,stylusname) <- case mstylus of
Nothing -> return (pstylusname_detect,"stylus")
Just spen -> (,) <$> newCString spen <*> pure spen
(perasername,erasername) <- case meraser of
Nothing -> return (perasername_detect,"eraser")
Just seraser -> (,) <$> newCString seraser <*> pure seraser
(ptouchname,touchname) <-
maybe (return (ptouchname_detect,"touch")) (\stouch->(,) <$> newCString stouch <*> pure stouch)
mtouch
c_initdevice pcore pstylus peraser ptouch pcorename pstylusname perasername ptouchname
core_val <- peek pcore
stylus_val <- peek pstylus
eraser_val <- peek peraser
touch_val <- peek ptouch
return $ DeviceList core_val corename stylus_val stylusname eraser_val erasername touch_val touchname
getPointer :: DeviceList -> EventM t (Maybe PenButton,Maybe PointerCoord)
getPointer devlst = do
ptr <- ask
(_ty,btn,x,y,mdev,maxf) <- liftIO (getInfo ptr)
let rbtn | btn == 0 = Nothing
| btn == 1 = Just PenButton1
| btn == 2 = Just PenButton2
| btn == 3 = Just PenButton3
| otherwise = Nothing
case mdev of
Nothing ->
return (rbtn,Nothing)
Just dev -> case maxf of
Nothing -> return (rbtn,Just (PointerCoord Core x y 1.0))
Just axf -> do
mpcoord <- liftIO $ coord ptr x y dev axf
let rbtnfinal = case mpcoord of
Nothing -> rbtn
Just pcoord -> case pointerType pcoord of
Eraser -> Just EraserButton
Touch -> Just TouchButton
_ -> rbtn
let tst = (rbtnfinal,mpcoord)
return tst
where
getInfo ptr = do
(ty :: Int32) <- peek (castPtr ptr)
if ty `elem` [ 4
, 5
, 6
, 7]
then do
(x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
(y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
(btn :: Int32) <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
(dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
let axisfunc = (\hsc_ptr -> peekByteOff hsc_ptr 32)
return (ty,btn,realToFrac x,realToFrac y,Just dev,Just axisfunc)
else if ty `elem` [ 31 ]
then do
(x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
(y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
(dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
return (ty,0,realToFrac x, realToFrac y,Just dev,Nothing)
else if ty `elem` [ 3 ]
then do
(x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
(y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
(dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
let axisfunc = (\hsc_ptr -> peekByteOff hsc_ptr 32)
return (ty,0,realToFrac x, realToFrac y,Just dev,Just axisfunc)
else if ty `elem` [ 10,
11]
then do
(x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
(y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
return (ty,0,realToFrac x, realToFrac y,Nothing,Nothing)
else error ("eventCoordinates: none for event type "++show ty)
coord ptr x y device axf
| device == dev_core devlst = return $ Just (PointerCoord Core x y 1.0)
| device == dev_stylus devlst = do
(ptrax :: Ptr CDouble ) <- axf ptr
(wacomx :: Double) <- peekByteOff ptrax 0
(wacomy :: Double) <- peekByteOff ptrax 8
(wacomz :: Double) <- peekByteOff ptrax 16
return $ Just (PointerCoord Stylus wacomx wacomy wacomz)
| device == dev_eraser devlst = do
(ptrax :: Ptr CDouble ) <- axf ptr
(wacomx :: Double) <- peekByteOff ptrax 0
(wacomy :: Double) <- peekByteOff ptrax 8
(wacomz :: Double) <- peekByteOff ptrax 16
return $ Just (PointerCoord Eraser wacomx wacomy wacomz)
| device == dev_touch devlst = do
(ptrax :: Ptr CDouble ) <- axf ptr
(touchx :: Double) <- peekByteOff ptrax 0
(touchy :: Double) <- peekByteOff ptrax 8
(touchz :: Double) <- peekByteOff ptrax 16
(touchw :: Double) <- peekByteOff ptrax 24
return $ Just (PointerCoord Touch touchx touchy touchz)
| otherwise = return Nothing
wacomCoordConvert :: WidgetClass self => self
-> (Double,Double)
-> IO (Double,Double)
wacomCoordConvert canvas (x,y)= do
win <- widgetGetDrawWindow canvas
(x0,y0) <- drawWindowGetOrigin win
screen <- widgetGetScreen canvas
(ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen
return (fromIntegral ws*xfromIntegral x0,fromIntegral hs*yfromIntegral y0)
wacomPConvert :: WidgetClass self => self
-> PointerCoord
-> IO (Double,Double)
wacomPConvert canvas pcoord = do
let (px,py) = (,) <$> pointerX <*> pointerY $ pcoord
case pointerType pcoord of
Core -> return (px,py)
_ -> do
wacomCoordConvert canvas (px,py)