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

-----------------------------------------------------------------------------
-- |
-- Module      : Hoodle.Device 
-- Copyright   : (c) 2011, 2012 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 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)
{-# LINE 116 "src/Hoodle/Device.hsc" #-}
      if ty `elem` [ 4
{-# LINE 117 "src/Hoodle/Device.hsc" #-}
                   , 5
{-# LINE 118 "src/Hoodle/Device.hsc" #-}
                   , 6
{-# LINE 119 "src/Hoodle/Device.hsc" #-}
                   , 7] 
{-# LINE 120 "src/Hoodle/Device.hsc" #-}
        then do 
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr 
{-# LINE 122 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 123 "src/Hoodle/Device.hsc" #-}
          (btn :: Int32) <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
{-# LINE 124 "src/Hoodle/Device.hsc" #-}
          (dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
{-# LINE 125 "src/Hoodle/Device.hsc" #-}
          let axisfunc = (\hsc_ptr -> peekByteOff hsc_ptr 32)
{-# LINE 126 "src/Hoodle/Device.hsc" #-}
          return (ty,btn,realToFrac x,realToFrac y,Just dev,Just axisfunc)
        else if ty `elem` [ 31 ] 
{-# LINE 128 "src/Hoodle/Device.hsc" #-}
        then do
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 130 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 131 "src/Hoodle/Device.hsc" #-}
          (dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 40) ptr
{-# LINE 132 "src/Hoodle/Device.hsc" #-}
          return (ty,0,realToFrac x, realToFrac y,Just dev,Nothing)
        else if ty `elem` [ 3 ] 
{-# LINE 134 "src/Hoodle/Device.hsc" #-}
        then do
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 136 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 24) ptr
{-# LINE 137 "src/Hoodle/Device.hsc" #-}
          (dev :: CInt) <- (\hsc_ptr -> peekByteOff hsc_ptr 44) ptr
{-# LINE 138 "src/Hoodle/Device.hsc" #-}
          let axisfunc = (\hsc_ptr -> peekByteOff hsc_ptr 32)          
{-# LINE 139 "src/Hoodle/Device.hsc" #-}
          return (ty,0,realToFrac x, realToFrac y,Just dev,Just axisfunc)
        else if ty `elem` [ 10,
{-# LINE 141 "src/Hoodle/Device.hsc" #-}
                            11] 
{-# LINE 142 "src/Hoodle/Device.hsc" #-}
        then do
          (x :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr
{-# LINE 144 "src/Hoodle/Device.hsc" #-}
          (y :: Double) <- (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
{-# LINE 145 "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 $ 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*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)