module Hoodle.Device where
import Hoodle.Config
import Data.Configurator.Types
import Control.Applicative
import Control.Monad.Reader
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.C
import Foreign.Storable
import Graphics.UI.Gtk
import Data.Int
data PointerType = Core | Stylus | Eraser
deriving (Show,Eq,Ord)
data PenButton = PenButton1 | PenButton2 | PenButton3 | EraserButton
deriving (Show,Eq,Ord)
data DeviceList = DeviceList { dev_core :: CInt
, dev_stylus :: CInt
, dev_eraser :: CInt }
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 -> CString -> CString -> CString -> IO ()
initDevice :: Config -> IO DeviceList
initDevice cfg = do
(mcore,mstylus,meraser) <- getPenDevConfig cfg
putStrLn $ show mstylus
putStrLn $ show meraser
with 0 $ \pcore ->
with 0 $ \pstylus ->
with 0 $ \peraser -> do
pcorename <- case mcore of
Nothing -> newCString "Core Pointer"
Just core -> newCString core
pstylusname <- case mstylus of
Nothing -> newCString "stylus"
Just spen -> newCString spen
perasername <- case meraser of
Nothing -> newCString "eraser"
Just seraser -> newCString seraser
c_initdevice pcore pstylus peraser pcorename pstylusname perasername
core_val <- peek pcore
stylus_val <- peek pstylus
eraser_val <- peek peraser
return $ DeviceList core_val stylus_val eraser_val
getPointer :: DeviceList -> EventM t (Maybe PenButton,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,PointerCoord Core x y 1.0)
Just dev -> case maxf of
Nothing -> return (rbtn,PointerCoord Core x y 1.0)
Just axf -> do
pcoord <- liftIO $ coord ptr x y dev axf
let rbtnfinal = case pointerType pcoord of
Eraser -> Just EraserButton
_ -> rbtn
let tst = (rbtnfinal,pcoord)
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 $ 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 $ 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 $ PointerCoord Eraser wacomx wacomy wacomz
| otherwise = return $ PointerCoord Core x y 1.0
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)