gtk2hs: wacom xinput test

c_initdevice.c

#include <gtk/gtk.h>
#include <stdio.h>

void initdevice( int* stylus )
{
  GList* dev_list;
  GdkDevice* device;
  dev_list = gdk_devices_list();
  (*stylus) = 0;
  while (dev_list != NULL) {
    printf ("one device\n"); 
    device = (GdkDevice *)dev_list->data;
    printf(" %d : %s \n", device, device->name );
    if (device != gdk_device_get_core_pointer()) {
      // #ifdef ENABLE_XINPUT_BUGFIX
      gdk_device_set_axis_use(device, 0, GDK_AXIS_IGNORE);
      gdk_device_set_axis_use(device, 1, GDK_AXIS_IGNORE);
      // #endif
      gdk_device_set_mode(device, GDK_MODE_SCREEN);

      printf("   yeah this is xinput device %s \n", device -> name);
      if( !strcmp (device->name, "stylus") )
        (*stylus) = (int) device; 
    } 
    dev_list = dev_list->next; 
  }

}


// void extEventCanvas( void* canvas ) {
/* Important note: we'd like ONLY the canvas window itself to receive
   XInput events, while its child window in the GDK hierarchy (also
   associated to the canvas widget) receives the core events.
   This way on_canvas_... will get both types of events -- otherwise,
   the proximity detection code in GDK is broken and we'll lose core
   events.
   
   Up to GTK+ 2.10, gtk_widget_set_extension_events() only sets
   extension events for the widget's main window itself; in GTK+ 2.11
   also traverses GDK child windows that belong to the widget
   and sets their extension events too. We want to avoid that.
   So we use gdk_input_set_extension_events() directly on the canvas.
*/
   
/*  // this causes GTK+ 2.11 bugs
  gtk_widget_set_extension_events(GTK_WIDGET(canvas),GDK_EXTENSION_EVENTS_ALL); 
*/

//  gdk_input_set_extension_events(GTK_WIDGET(canvas)->window, GDK_POINTER_MOTION_MASK | GDK_BUTTON_MOTION_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK, GDK_EXTENSION_EVENTS_ALL);
//}

c_initdevice.h

#include <gtk/gtk.h>
#include <stdio.h>

void initdevice( int* );  

//void extEventCanvas( void* ); 

InitDevice.hs

{-# LANGUAGE ForeignFunctionInterface #-}

module InitDevice (
   initdevice
-- , extEventCanvas
 ) where

import Foreign.Ptr
import Foreign.C

foreign import ccall "c_initdevice.h initdevice" c_initdevice
  :: Ptr CInt -> IO ()

-- foreign import ccall "c_initdevice.h extEventCanvas" c_extEventCanvas
--  :: Ptr () -> IO ()

initdevice :: Ptr CInt -> IO () 
initdevice = c_initdevice

{-
extEventCanvas :: Ptr () -> IO ()
extEventCanvas = c_extEventCanvas
-}

UI.hs

module UI where

import Graphics.UI.Gtk


initWindows = do 
  window <- windowNew
  
  
  vbox <- vBoxNew False 0 
  hbox <- hBoxNew False 0 
  
  buttonpen   <- buttonNewWithLabel "Pen"
  buttonerase <- buttonNewWithLabel "Erase"
  canvas <- drawingAreaNew
  
  boxPackStart hbox buttonpen   PackGrow 0 
  boxPackStart hbox buttonerase PackGrow 0 
  
  boxPackEnd vbox hbox   PackNatural 0 
  boxPackEnd vbox canvas PackGrow    0 
  
  
  set window [containerChild := vbox ]

  return (window, buttonpen, buttonerase, canvas)

xinputtest.hs

{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, GADTs #-}

module Main where

import Graphics.Rendering.Cairo
-- import Type
import UI 
import InitDevice
import Control.Monad.IO.Class
import Control.Applicative
-- import Event 

import Graphics.UI.Gtk
import Control.Monad.Reader 

import Data.Int 
import Data.IORef
import Foreign.Storable
import Foreign.Ptr 
import Foreign.Marshal.Array
import Foreign.C

data Status = Drawing | NonDrawing

main :: IO () 
main = do 
  pointref <- newIORef ((0,0) :: (Double,Double))
  stateref <- newIORef NonDrawing
  (stylusdevptr :: Ptr CInt) <- mallocArray 100 
  
  initGUI
  initdevice stylusdevptr
  stylusdev <- peekByteOff stylusdevptr 0
  
  (window,buttonpen,buttonerase,canvas) <- initWindows 
 
  widgetAddEvents canvas [PointerMotionMask,ButtonMotionMask]
  canvas `on` sizeRequest $ return (Requisition 480 640)
  canvas `on` buttonPressEvent $ tryEvent $ do
    ptr <- ask 
    liftIO $ do 
      (ty :: Int32) <- peek (castPtr ptr) 
      (x :: Double) <- peekByteOff ptr 16
      (y :: Double) <- peekByteOff ptr 24
      (device :: CInt ) <- peekByteOff ptr 44
      if device == stylusdev 
        then do 
          (ptrax :: Ptr CDouble ) <- peekByteOff ptr 32
          (wacomx :: Double) <- peekByteOff ptrax 0
          (wacomy :: Double) <- peekByteOff ptrax 8
          point <- readIORef pointref 
          if wacomx < 1.0 && wacomx > 0.0 && wacomy < 1.0 && wacomy > 0.0 
            then do 
              writeIORef stateref Drawing
              writeIORef pointref (wacomx,wacomy)
            else return ()
        else return ()
   
  canvas `on` buttonReleaseEvent $ tryEvent $ do 
    liftIO $ writeIORef stateref NonDrawing

  canvas `on` motionNotifyEvent  $ tryEvent $ do 
    st <- liftIO $ readIORef stateref
    case st of 
      NonDrawing -> return () 
      Drawing -> do 
        ptr <- ask 
        liftIO $ do 
          (ty :: Int32) <- peek (castPtr ptr) 
          (x :: Double) <- peekByteOff ptr 16
          (y :: Double) <- peekByteOff ptr 24
          (device :: CInt ) <- peekByteOff ptr 44
          if device == stylusdev 
            then do 
              (ptrax :: Ptr CDouble ) <- peekByteOff ptr 32
              (wacomx :: Double) <- peekByteOff ptrax 0
              (wacomy :: Double) <- peekByteOff ptrax 8
              point <- readIORef pointref 
              if wacomx < 1.0 && wacomx > 0.0 && wacomy < 1.0 && wacomy > 0.0 
                then do putStrLn $ show point ++ show (wacomx,wacomy)
                        win <- widgetGetDrawWindow canvas
                        (w',h') <- widgetGetSize canvas
                        (x0,y0) <- drawWindowGetOrigin win
                        let (x0' :: Double ,y0' :: Double) = (fromIntegral x0, fromIntegral y0)
                        screen <- widgetGetScreen canvas
                        (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen
                        -- print (w',h')
                        -- print (ws,hs)
                        -- print (x0',y0')
                        let f (x,y) = (fromIntegral ws*x-x0',fromIntegral hs*y-y0')
                        -- print (f point)
                        renderWithDrawable win $ do 
                          setLineWidth 1.0 
                          uncurry moveTo (f point)
                          uncurry lineTo (f (wacomx,wacomy))
                          stroke
               
                        writeIORef pointref (wacomx,wacomy)
                else return ()
          -- print (wacomx, wacomy)
          -- (w :: Double) <- peekByteOff ptr 48 
          -- putStrLn $ show (ty,x,y,device,w) 
            else return ()
    
  widgetSetExtensionEvents canvas [ExtensionEventsAll]  
  onDestroy window mainQuit
  widgetShowAll window
  
  mainGUI