{-# LINE 1 "src/Hoodle/Device.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
{-# LINE 2 "src/Hoodle/Device.hsc" #-}

-----------------------------------------------------------------------------
-- |
-- Module      : Hoodle.Device 
-- Copyright   : (c) 2011-2013 Ian-Woo Kim
--
-- License     : BSD3
-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------


{-# LINE 16 "src/Hoodle/Device.hsc" #-}

{-# LINE 17 "src/Hoodle/Device.hsc" #-}

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 -- ^ core 
  -> Ptr CInt -- ^ stylus
  -> Ptr CInt -- ^ eraser
  -> Ptr CInt -- ^ touch 
  -> CString  -- ^ core 
  -> CString  -- ^ stylus
  -> CString  -- ^ eraser
  -> CString  -- ^ touch 
  -> IO ()


-- | 
foreign import ccall "c_initdevice.h find_wacom" c_find_wacom
  :: CString -> CString -> IO ()

{- 
-- | 
foreign import ccall "c_initdevice.h enable_touch" c_enable_touch
  :: CString -> IO ()
     
-- | 
foreign import ccall "c_initdevice.h disable_touch" c_disable_touch
  :: DrawWindow -> CString -> IO ()
-}



-- | 
initDevice :: Config -> IO DeviceList  
initDevice cfg = do 
  pstylusname_detect <- newCString "stylus" 
  perasername_detect <- newCString "eraser" 
  ptouchname_detect <- newCString "touch"
  -- c_find_wacom pstylusname_detect perasername_detect
  (mcore,mstylus,meraser,mtouch) <- getPenDevConfig cfg 
  -- putStrLn $ show mstylus 
  -- putStrLn $ show meraser
  -- putStrLn $ show mtouch
  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,PointerCoord Core x y 1.0)
                 return (rbtn,Nothing)
      Just dev -> case maxf of 
                    Nothing -> return (rbtn,Just (PointerCoord Core x y 1.0))
                               -- return (rbtn,Nothing)
                    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)
{-# LINE 159 "src/Hoodle/Device.hsc" #-}
      if ty `elem` [ 4
{-# LINE 160 "src/Hoodle/Device.hsc" #-}
                   , 5
{-# LINE 161 "src/Hoodle/Device.hsc" #-}
                   , 6
{-# LINE 162 "src/Hoodle/Device.hsc" #-}
                   , 7] 
{-# LINE 163 "src/Hoodle/Device.hsc" #-}
        then do 
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr 
{-# LINE 165 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 166 "src/Hoodle/Device.hsc" #-}
          (btn :: Int32) <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
{-# LINE 167 "src/Hoodle/Device.hsc" #-}
          (dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
{-# LINE 168 "src/Hoodle/Device.hsc" #-}
          let axisfunc = (\hsc_ptr -> peekByteOff hsc_ptr 32)
{-# LINE 169 "src/Hoodle/Device.hsc" #-}
          return (ty,btn,realToFrac x,realToFrac y,Just dev,Just axisfunc)
        else if ty `elem` [ 31 ] 
{-# LINE 171 "src/Hoodle/Device.hsc" #-}
        then do
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 173 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 174 "src/Hoodle/Device.hsc" #-}
          (dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
{-# LINE 175 "src/Hoodle/Device.hsc" #-}
          return (ty,0,realToFrac x, realToFrac y,Just dev,Nothing)
        else if ty `elem` [ 3 ] 
{-# LINE 177 "src/Hoodle/Device.hsc" #-}
        then do
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 179 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 180 "src/Hoodle/Device.hsc" #-}
          (dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
{-# LINE 181 "src/Hoodle/Device.hsc" #-}
          let axisfunc = (\hsc_ptr -> peekByteOff hsc_ptr 32)          
{-# LINE 182 "src/Hoodle/Device.hsc" #-}
          return (ty,0,realToFrac x, realToFrac y,Just dev,Just axisfunc)
        else if ty `elem` [ 10,
{-# LINE 184 "src/Hoodle/Device.hsc" #-}
                            11] 
{-# LINE 185 "src/Hoodle/Device.hsc" #-}
        then do
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
{-# LINE 187 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
{-# LINE 188 "src/Hoodle/Device.hsc" #-}
          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 -- 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*x-fromIntegral x0,fromIntegral hs*y-fromIntegral 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)