Extract OpenGL modes in GlWindow.

Extract OpenGL modes in GlWindow.

{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.Base.GlWindow
    (
     glWindowNew,
     glWindowCustom,
     glWindowCanDo
    , drawGlWindowBase
   , handleGlWindowBase
   , resizeGlWindowBase
   , hideGlWindowBase
   , showWidgetGlWindowBase
     -- * Hierarchy
     --
     -- $hierarchy

     -- * GlWindow functions
     --
     -- $functions
    )
where
#include "Fl_C.h"
#include "Fl_Double_WindowC.h"
#include "Fl_Gl_WindowC.h"
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import Foreign
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Window
import Graphics.UI.FLTK.LowLevel.Base.Widget
import Graphics.UI.FLTK.LowLevel.Base.Window
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Dispatch
import qualified Data.Text as T

{# fun Fl_OverriddenGl_Window_New as overriddenWindowNew' {`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGl_Window_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGl_Window_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int',`CString', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGl_Window_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', `CString', id `Ptr ()'} -> `Ptr ()' id #}
glWindowCustom :: Size                           -- ^ The size of this window
               -> Maybe Position                 -- ^ The position of this window
               -> Maybe T.Text                   -- ^ The window label
               -> Maybe (Ref GlWindow -> IO ())  -- ^ Optional custom drawing function
               -> CustomWidgetFuncs GlWindow     -- ^ other custom widget functions
               -> CustomWindowFuncs GlWindow     -- ^ Other custom window functions
               -> IO (Ref GlWindow)
glWindowCustom size position title draw' customWidgetFuncs' customWindowFuncs' =
  windowMaker
    size
    position
    title
    draw'
    customWidgetFuncs'
    customWindowFuncs'
    overriddenWindowNew'
    overriddenWindowNewWithLabel'
    overriddenWindowNewXY'
    overriddenWindowNewXYWithLabel'
glWindowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref GlWindow)
glWindowNew size position title =
  windowMaker
    size
    position
    title
    Nothing
    (defaultCustomWidgetFuncs :: CustomWidgetFuncs GlWindow)
    (defaultCustomWindowFuncs :: CustomWindowFuncs GlWindow)
    overriddenWindowNew'
    overriddenWindowNewWithLabel'
    overriddenWindowNewXY'
    overriddenWindowNewXYWithLabel'

{# fun Fl_Gl_Window_can_do_with_m as canDoWithM' { `Int'} -> `Bool' cToBool #}
glWindowCanDo :: Mode -> IO Bool
glWindowCanDo m = canDoWithM' (fromEnum m)

{# fun Fl_Gl_Window_draw_super as drawSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
drawGlWindowBase ::  Ref GlWindowBase -> IO ()
drawGlWindowBase glWindow = withRef glWindow $ \glWindowPtr -> drawSuper' glWindowPtr
{# fun Fl_Gl_Window_handle_super as handleSuper' { id `Ptr ()',`Int' } -> `Int' #}
handleGlWindowBase :: Ref GlWindowBase -> Event ->  IO (Either UnknownEvent ())
handleGlWindowBase glWindow event = withRef glWindow $ \glWindowPtr -> handleSuper' glWindowPtr (fromIntegral (fromEnum event)) >>= return . successOrUnknownEvent
{# fun Fl_Gl_Window_resize_super as resizeSuper' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
resizeGlWindowBase :: Ref GlWindowBase -> Rectangle -> IO ()
resizeGlWindowBase glWindow rectangle =
    let (x_pos, y_pos, width, height) = fromRectangle rectangle
    in withRef glWindow $ \glWindowPtr -> resizeSuper' glWindowPtr x_pos y_pos width height
{# fun Fl_Gl_Window_hide_super as hideSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
hideGlWindowBase ::  Ref GlWindowBase -> IO ()
hideGlWindowBase glWindow = withRef glWindow $ \glWindowPtr -> hideSuper' glWindowPtr
{# fun Fl_Gl_Window_show_super as showSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
showWidgetGlWindowBase ::  Ref GlWindowBase -> IO ()
showWidgetGlWindowBase glWindow = withRef glWindow $ \glWindowPtr -> showSuper' glWindowPtr

{# fun Fl_DerivedGl_Window_flush as flush' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Flush ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> flush' winPtr
{# fun Fl_DerivedGl_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Hide ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> hide' winPtr
{# fun Fl_DerivedGl_Window_show as show' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (ShowWidget ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> show' winPtr
{# fun Fl_DerivedGl_Window_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO(Either UnknownEvent ()))) => Op (Handle ()) GlWindowBase orig impl where
  runOp _ _ self event = withRef self $ \selfPtr -> handle' selfPtr event >>= return  . successOrUnknownEvent
{# fun Fl_DerivedGl_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr
{# fun Fl_DerivedGl_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle ->  IO ())) => Op (Resize ()) GlWindowBase orig impl where
  runOp _ _ win rectangle' =
    let (x_pos', y_pos', width', height') = fromRectangle rectangle' in
    withRef win $ \winPtr -> resize' winPtr x_pos' y_pos' width' height'

{# fun Fl_Gl_Window_valid as valid' { id `Ptr ()' } -> `Bool' #}
instance (impl ~ ( IO (Bool))) => Op (GetValid ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> valid' winPtr
{# fun Fl_Gl_Window_set_valid as setValid' { id `Ptr ()', `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetValid ()) GlWindowBase orig impl where
  runOp _ _ win v = withRef win $ \winPtr -> setValid' winPtr v
{# fun Fl_Gl_Window_invalidate as invalidate' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Invalidate ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> invalidate' winPtr
{# fun Fl_Gl_Window_context_valid as contextValid' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (GetContextValid ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> contextValid' winPtr
{# fun Fl_Gl_Window_set_context_valid as setContextValid' { id `Ptr ()', fromBool `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetContextValid ()) GlWindowBase orig impl where
  runOp _ _ win v = withRef win $ \winPtr -> setContextValid' winPtr v
{# fun Fl_Gl_Window_can_do as canDo' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (CanDo ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> canDo' winPtr
{# fun Fl_Gl_Window_mode as mode' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Modes))) => Op (GetMode ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> mode' winPtr >>= return . intToModes
{# fun Fl_Gl_Window_set_mode as setMode' { id `Ptr ()',`Int' } -> `Int' #}
instance (impl ~ (Modes ->  IO ())) => Op (SetMode ()) GlWindowBase orig impl where
  runOp _ _ win a = withRef win $ \winPtr -> setMode' winPtr (modesToInt a) >> return ()
{# fun Fl_Gl_Window_context as context' { id `Ptr ()' } -> `Ptr ()'  #}
instance (impl ~ ( IO (Ref FlGlContext))) => Op (GetContext ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> context' winPtr >>= toRef
{# fun Fl_Gl_Window_set_context as setContext' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( Ref FlGlContext ->  IO ())) => Op (SetContext ()) GlWindowBase orig impl where
  runOp _ _ win context = withRef win $ \winPtr -> withRef context $ \contextPtr -> setContext' winPtr contextPtr
{# fun Fl_Gl_Window_set_context_with_destroy_flag as setContextWithDestroyFlag' { id `Ptr ()',id `Ptr ()', fromBool `Bool'} -> `()' supressWarningAboutRes #}
instance (impl ~ ( Ref FlGlContext ->  Bool -> IO ())) => Op (SetContextWithDestroyFlag ()) GlWindowBase orig impl where
  runOp _ _ win context destroyFlag= withRef win $ \winPtr -> withRef context $ \contextPtr -> setContextWithDestroyFlag' winPtr contextPtr destroyFlag
{# fun Fl_Gl_Window_swap_buffers as swapBuffers' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SwapBuffers ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> swapBuffers' winPtr
{# fun Fl_Gl_Window_ortho as ortho' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Ortho ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> ortho' winPtr
{# fun Fl_Gl_Window_can_do_overlay as canDoOverlay' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (CanDoOverlay ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> canDoOverlay' winPtr
{# fun Fl_Gl_Window_redraw_overlay as redrawOverlay' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (RedrawOverlay ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> redrawOverlay' winPtr
{# fun Fl_Gl_Window_hide_overlay as hideOverlay' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (HideOverlay ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> hideOverlay' winPtr
{# fun Fl_Gl_Window_make_overlay_current as makeOverlayCurrent' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (MakeOverlayCurrent ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> makeOverlayCurrent' winPtr
{# fun Fl_Gl_Window_pixels_per_unit as pixelsPerUnit' { id `Ptr ()'} -> `Float' #}
instance (impl ~ ( IO (Float))) => Op (PixelsPerUnit ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> pixelsPerUnit' winPtr
{# fun Fl_Gl_Window_pixel_h as pixelH' { id `Ptr ()'} -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (PixelH ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> pixelH' winPtr
{# fun Fl_Gl_Window_pixel_w as pixelW' { id `Ptr ()'} -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (PixelW ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> pixelW' winPtr

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Base.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Window"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.GlWindow"
-- @

-- $functions
-- @
-- canDo :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- canDoOverlay :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- destroy :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- flush :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- getContext :: 'Ref' 'GlWindowBase' -> 'IO' ('Ref' 'FlGlContext')
--
-- getContextValid :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- getMode :: 'Ref' 'GlWindowBase' -> 'IO' ('Mode')
--
-- getValid :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- handle :: 'Ref' 'GlWindowBase' -> 'Event' -> 'IO(Either' 'UnknownEvent' ())
--
-- hide :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- hideOverlay :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- invalidate :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- makeOverlayCurrent :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- ortho :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- pixelH :: 'Ref' 'GlWindowBase' -> 'IO' ('Int')
--
-- pixelW :: 'Ref' 'GlWindowBase' -> 'IO' ('Int')
--
-- pixelsPerUnit :: 'Ref' 'GlWindowBase' -> 'IO' ('Float')
--
-- redrawOverlay :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- resize :: 'Ref' 'GlWindowBase' -> 'Rectangle' -> 'IO' ()
--
-- setContext :: 'Ref' 'GlWindowBase' -> 'Ref' 'FlGlContext' -> 'IO' ()
--
-- setContextValid :: 'Ref' 'GlWindowBase' -> 'Bool' -> 'IO' ()
--
-- setContextWithDestroyFlag :: 'Ref' 'GlWindowBase' -> 'Ref' 'FlGlContext' -> 'Bool' -> 'IO' ()
--
-- setMode :: 'Ref' 'GlWindowBase' -> 'Modes' -> 'IO' ()
--
-- setValid :: 'Ref' 'GlWindowBase' -> 'Bool' -> 'IO' ()
--
-- showWidget :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- swapBuffers :: 'Ref' 'GlWindowBase' -> 'IO' ()
-- @

{-# LANGUAGE CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.Base.GlWindow
    (
     glWindowNew,
     glWindowCustom,
     glWindowCanDo
    , drawGlWindowBase
   , handleGlWindowBase
   , resizeGlWindowBase
   , hideGlWindowBase
   , showWidgetGlWindowBase
     -- * Hierarchy
     --
     -- $hierarchy

     -- * GlWindow functions
     --
     -- $functions
    )
where
#include "Fl_C.h"
#include "Fl_Double_WindowC.h"
#include "Fl_Gl_WindowC.h"
import C2HS hiding (cFromEnum, cFromBool, cToBool,cToEnum)
import Foreign
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Window
import Graphics.UI.FLTK.LowLevel.Base.Widget
import Graphics.UI.FLTK.LowLevel.Base.Window
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Dispatch
import qualified Data.Text as T

{# fun Fl_OverriddenGl_Window_New as overriddenWindowNew' {`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGl_Window_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGl_Window_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int',`CString', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenGl_Window_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', `CString', id `Ptr ()'} -> `Ptr ()' id #}
glWindowCustom :: Size                           -- ^ The size of this window
               -> Maybe Position                 -- ^ The position of this window
               -> Maybe T.Text                   -- ^ The window label
               -> Maybe (Ref GlWindow -> IO ())  -- ^ Optional custom drawing function
               -> CustomWidgetFuncs GlWindow     -- ^ other custom widget functions
               -> CustomWindowFuncs GlWindow     -- ^ Other custom window functions
               -> IO (Ref GlWindow)
glWindowCustom size position title draw' customWidgetFuncs' customWindowFuncs' =
  windowMaker
    size
    position
    title
    draw'
    customWidgetFuncs'
    customWindowFuncs'
    overriddenWindowNew'
    overriddenWindowNewWithLabel'
    overriddenWindowNewXY'
    overriddenWindowNewXYWithLabel'
glWindowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref GlWindow)
glWindowNew size position title =
  windowMaker
    size
    position
    title
    Nothing
    (defaultCustomWidgetFuncs :: CustomWidgetFuncs GlWindow)
    (defaultCustomWindowFuncs :: CustomWindowFuncs GlWindow)
    overriddenWindowNew'
    overriddenWindowNewWithLabel'
    overriddenWindowNewXY'
    overriddenWindowNewXYWithLabel'

{# fun Fl_Gl_Window_can_do_with_m as canDoWithM' { `Int'} -> `Bool' cToBool #}
glWindowCanDo :: Mode -> IO Bool
glWindowCanDo m = canDoWithM' (fromEnum m)

{# fun Fl_Gl_Window_draw_super as drawSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
drawGlWindowBase ::  Ref GlWindowBase -> IO ()
drawGlWindowBase glWindow = withRef glWindow $ \glWindowPtr -> drawSuper' glWindowPtr
{# fun Fl_Gl_Window_handle_super as handleSuper' { id `Ptr ()',`Int' } -> `Int' #}
handleGlWindowBase :: Ref GlWindowBase -> Event ->  IO (Either UnknownEvent ())
handleGlWindowBase glWindow event = withRef glWindow $ \glWindowPtr -> handleSuper' glWindowPtr (fromIntegral (fromEnum event)) >>= return . successOrUnknownEvent
{# fun Fl_Gl_Window_resize_super as resizeSuper' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
resizeGlWindowBase :: Ref GlWindowBase -> Rectangle -> IO ()
resizeGlWindowBase glWindow rectangle =
    let (x_pos, y_pos, width, height) = fromRectangle rectangle
    in withRef glWindow $ \glWindowPtr -> resizeSuper' glWindowPtr x_pos y_pos width height
{# fun Fl_Gl_Window_hide_super as hideSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
hideGlWindowBase ::  Ref GlWindowBase -> IO ()
hideGlWindowBase glWindow = withRef glWindow $ \glWindowPtr -> hideSuper' glWindowPtr
{# fun Fl_Gl_Window_show_super as showSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
showWidgetGlWindowBase ::  Ref GlWindowBase -> IO ()
showWidgetGlWindowBase glWindow = withRef glWindow $ \glWindowPtr -> showSuper' glWindowPtr

{# fun Fl_DerivedGl_Window_flush as flush' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Flush ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> flush' winPtr
{# fun Fl_DerivedGl_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Hide ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> hide' winPtr
{# fun Fl_DerivedGl_Window_show as show' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (ShowWidget ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> show' winPtr
{# fun Fl_DerivedGl_Window_handle as handle' { id `Ptr ()', cFromEnum `Event' } -> `Int' #}
instance (impl ~ (Event ->  IO(Either UnknownEvent ()))) => Op (Handle ()) GlWindowBase orig impl where
  runOp _ _ self event = withRef self $ \selfPtr -> handle' selfPtr event >>= return  . successOrUnknownEvent
{# fun Fl_DerivedGl_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr
{# fun Fl_DerivedGl_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle ->  IO ())) => Op (Resize ()) GlWindowBase orig impl where
  runOp _ _ win rectangle' =
    let (x_pos', y_pos', width', height') = fromRectangle rectangle' in
    withRef win $ \winPtr -> resize' winPtr x_pos' y_pos' width' height'

{# fun Fl_Gl_Window_valid as valid' { id `Ptr ()' } -> `Bool' #}
instance (impl ~ ( IO (Bool))) => Op (GetValid ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> valid' winPtr
{# fun Fl_Gl_Window_set_valid as setValid' { id `Ptr ()', `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetValid ()) GlWindowBase orig impl where
  runOp _ _ win v = withRef win $ \winPtr -> setValid' winPtr v
{# fun Fl_Gl_Window_invalidate as invalidate' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Invalidate ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> invalidate' winPtr
{# fun Fl_Gl_Window_context_valid as contextValid' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (GetContextValid ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> contextValid' winPtr
{# fun Fl_Gl_Window_set_context_valid as setContextValid' { id `Ptr ()', fromBool `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetContextValid ()) GlWindowBase orig impl where
  runOp _ _ win v = withRef win $ \winPtr -> setContextValid' winPtr v
{# fun Fl_Gl_Window_can_do as canDo' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (CanDo ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> canDo' winPtr
{# fun Fl_Gl_Window_mode as mode' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Mode))) => Op (GetMode ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> mode' winPtr >>= return . toEnum
{# fun Fl_Gl_Window_set_mode as setMode' { id `Ptr ()',`Int' } -> `Int' #}
instance (impl ~ (Modes ->  IO ())) => Op (SetMode ()) GlWindowBase orig impl where
  runOp _ _ win a = withRef win $ \winPtr -> setMode' winPtr (modesToInt a) >> return ()
{# fun Fl_Gl_Window_context as context' { id `Ptr ()' } -> `Ptr ()'  #}
instance (impl ~ ( IO (Ref FlGlContext))) => Op (GetContext ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> context' winPtr >>= toRef
{# fun Fl_Gl_Window_set_context as setContext' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( Ref FlGlContext ->  IO ())) => Op (SetContext ()) GlWindowBase orig impl where
  runOp _ _ win context = withRef win $ \winPtr -> withRef context $ \contextPtr -> setContext' winPtr contextPtr
{# fun Fl_Gl_Window_set_context_with_destroy_flag as setContextWithDestroyFlag' { id `Ptr ()',id `Ptr ()', fromBool `Bool'} -> `()' supressWarningAboutRes #}
instance (impl ~ ( Ref FlGlContext ->  Bool -> IO ())) => Op (SetContextWithDestroyFlag ()) GlWindowBase orig impl where
  runOp _ _ win context destroyFlag= withRef win $ \winPtr -> withRef context $ \contextPtr -> setContextWithDestroyFlag' winPtr contextPtr destroyFlag
{# fun Fl_Gl_Window_swap_buffers as swapBuffers' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SwapBuffers ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> swapBuffers' winPtr
{# fun Fl_Gl_Window_ortho as ortho' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Ortho ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> ortho' winPtr
{# fun Fl_Gl_Window_can_do_overlay as canDoOverlay' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (CanDoOverlay ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> canDoOverlay' winPtr
{# fun Fl_Gl_Window_redraw_overlay as redrawOverlay' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (RedrawOverlay ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> redrawOverlay' winPtr
{# fun Fl_Gl_Window_hide_overlay as hideOverlay' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (HideOverlay ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> hideOverlay' winPtr
{# fun Fl_Gl_Window_make_overlay_current as makeOverlayCurrent' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (MakeOverlayCurrent ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> makeOverlayCurrent' winPtr
{# fun Fl_Gl_Window_pixels_per_unit as pixelsPerUnit' { id `Ptr ()'} -> `Float' #}
instance (impl ~ ( IO (Float))) => Op (PixelsPerUnit ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> pixelsPerUnit' winPtr
{# fun Fl_Gl_Window_pixel_h as pixelH' { id `Ptr ()'} -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (PixelH ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> pixelH' winPtr
{# fun Fl_Gl_Window_pixel_w as pixelW' { id `Ptr ()'} -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (PixelW ()) GlWindowBase orig impl where
  runOp _ _ win = withRef win $ \winPtr -> pixelW' winPtr

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Base.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.Window"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Base.GlWindow"
-- @

-- $functions
-- @
-- canDo :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- canDoOverlay :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- destroy :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- flush :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- getContext :: 'Ref' 'GlWindowBase' -> 'IO' ('Ref' 'FlGlContext')
--
-- getContextValid :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- getMode :: 'Ref' 'GlWindowBase' -> 'IO' ('Mode')
--
-- getValid :: 'Ref' 'GlWindowBase' -> 'IO' ('Bool')
--
-- handle :: 'Ref' 'GlWindowBase' -> 'Event' -> 'IO(Either' 'UnknownEvent' ())
--
-- hide :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- hideOverlay :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- invalidate :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- makeOverlayCurrent :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- ortho :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- pixelH :: 'Ref' 'GlWindowBase' -> 'IO' ('Int')
--
-- pixelW :: 'Ref' 'GlWindowBase' -> 'IO' ('Int')
--
-- pixelsPerUnit :: 'Ref' 'GlWindowBase' -> 'IO' ('Float')
--
-- redrawOverlay :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- resize :: 'Ref' 'GlWindowBase' -> 'Rectangle' -> 'IO' ()
--
-- setContext :: 'Ref' 'GlWindowBase' -> 'Ref' 'FlGlContext' -> 'IO' ()
--
-- setContextValid :: 'Ref' 'GlWindowBase' -> 'Bool' -> 'IO' ()
--
-- setContextWithDestroyFlag :: 'Ref' 'GlWindowBase' -> 'Ref' 'FlGlContext' -> 'Bool' -> 'IO' ()
--
-- setMode :: 'Ref' 'GlWindowBase' -> 'Modes' -> 'IO' ()
--
-- setValid :: 'Ref' 'GlWindowBase' -> 'Bool' -> 'IO' ()
--
-- showWidget :: 'Ref' 'GlWindowBase' -> 'IO' ()
--
-- swapBuffers :: 'Ref' 'GlWindowBase' -> 'IO' ()
-- @


Added some unicode to Morphology.

Added some unicode to Morphology.

Just for fun

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, UnicodeSyntax#-}
#include "cvWrapLEO.h"
module CV.Morphology (StructuringElement
                  ,structuringElement
                  ,customSE
                  ,basicSE,bigSE
                  ,geodesic
                  ,openOp,closeOp
                  ,open,close
                  ,erode,dilate
                  ,blackTopHat,whiteTopHat
                  ,dilateOp,erodeOp,ellipseShape
                  ,crossShape,rectShape)
where

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Array

import CV.Image

import CV.ImageOp
import qualified CV.ImageMath as IM

import C2HSTools

-- Morphological opening
openOp :: StructuringElement -> ImageOperation GrayScale D32
openOp se = erodeOp se 1 #> dilateOp se 1
open se = unsafeOperate (openOp se)
a ○ b = open b a
-- a ○ b = (a ⊖ b) ⊕ b

-- Morphological closing
closeOp :: StructuringElement -> ImageOperation GrayScale D32
closeOp se = dilateOp se 1 #> erodeOp se 1
close se = unsafeOperate (closeOp se)
a ● b = close b a

geodesic :: Image GrayScale D32 -> ImageOperation GrayScale D32 -> ImageOperation GrayScale D32
geodesic mask op = op #> IM.limitToOp mask

blackTopHat size i = unsafePerformIO $ do
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) rectShape
                  x <- runImageOperation i (closeOp se)
                  return $ x `IM.sub` i

whiteTopHat size i = unsafePerformIO $ do
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) rectShape
                  x <- runImageOperation i (openOp se)
                  return $ i `IM.sub` x

basicSE = structuringElement (3,3) (1,1) rectShape
bigSE = structuringElement (9,9) (4,4) rectShape

---------- Low level wrapper
rectShape = 0
crossShape = 1
ellipseShape = 2
customShape = 100

{#pointer *IplConvKernel as ConvKernel foreign newtype#}

type StructuringElement = ConvKernel

foreign import ccall "& wrapReleaseStructuringElement"
    releaseSE :: FinalizerPtr ConvKernel

-- Check morphology element
isGoodSE s@(w,h) d@(x,y) | x>=0 && y>=0
                         && w>=0 && h>=0
                         && x<w  && y<h
                         = True

                         | otherwise = False

-- Create a structuring element for morphological operations
structuringElement s d | isGoodSE s d = createSE s d
                       | otherwise = error "Bad values in structuring element"

-- Create SE with custom shape that is taken from flat list shape.
createSE (w,h) (x,y) shape = unsafePerformIO $ do
    iptr <- {#call cvCreateStructuringElementEx#}
             w h x y (fromIntegral shape) nullPtr
    fptr <- newForeignPtr releaseSE iptr
    return (ConvKernel fptr)

customSE s@(w,h) o shape | isGoodSE s o
                         && length shape == fromIntegral (w*h)
                            = createCustomSE s o shape

createCustomSE (w,h) (x,y) shape = unsafePerformIO $ do
            iptr <- withArray shape $ \arr ->
                    {#call cvCreateStructuringElementEx#}
                      w h x y (fromIntegral customShape) arr
            fptr <- newForeignPtr releaseSE iptr
            return (ConvKernel fptr)

{#fun cvErode as erosion
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}
{#fun cvDilate as dilation
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}

erodeOp se count = ImgOp $ \(S img)  -> erosion img img se count
dilateOp se count = ImgOp $ \(S img) -> dilation img img se count

erode se count  i = unsafeOperate (erodeOp se count)  i
dilate se count i = unsafeOperate (dilateOp se count) i

a ⊕ b = erode b 1 a
a ⊖ b = erode b 1 a

erode' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvErode#} (castPtr image)
                              (castPtr image)
                              ck count

dilate' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvDilate#} (castPtr image)
                              (castPtr image)
                              ck count

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables#-}
#include "cvWrapLEO.h"
module CV.Morphology (StructuringElement
                  ,structuringElement
                  ,customSE
                  ,basicSE,bigSE
                  ,geodesic
                  ,openOp,closeOp
                  ,open,close
                  ,erode,dilate
                  ,blackTopHat,whiteTopHat
                  ,dilateOp,erodeOp,ellipseShape
                  ,crossShape,rectShape)
where

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Array

import CV.Image

import CV.ImageOp
import qualified CV.ImageMath as IM

import C2HSTools

-- Morphological opening
openOp :: StructuringElement -> ImageOperation GrayScale D32
openOp se = erodeOp se 1 #> dilateOp se 1
open se = unsafeOperate (openOp se)
-- Morphological closing
closeOp :: StructuringElement -> ImageOperation GrayScale D32
closeOp se = dilateOp se 1 #> erodeOp se 1
close se = unsafeOperate (closeOp se)

geodesic :: Image GrayScale D32 -> ImageOperation GrayScale D32 -> ImageOperation GrayScale D32
geodesic mask op = op #> IM.limitToOp mask

blackTopHat size i = unsafePerformIO $ do
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) rectShape
                  x <- runImageOperation i (closeOp se)
                  return $ x `IM.sub` i

whiteTopHat size i = unsafePerformIO $ do
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) rectShape
                  x <- runImageOperation i (openOp se)
                  return $ i `IM.sub` x

basicSE = structuringElement (3,3) (1,1) rectShape
bigSE = structuringElement (9,9) (4,4) rectShape

---------- Low level wrapper
rectShape = 0
crossShape = 1
ellipseShape = 2
customShape = 100

{#pointer *IplConvKernel as ConvKernel foreign newtype#}

type StructuringElement = ConvKernel

foreign import ccall "& wrapReleaseStructuringElement"
    releaseSE :: FinalizerPtr ConvKernel

-- Check morphology element
isGoodSE s@(w,h) d@(x,y) | x>=0 && y>=0
                         && w>=0 && h>=0
                         && x<w  && y<h
                         = True

                         | otherwise = False

-- Create a structuring element for morphological operations
structuringElement s d | isGoodSE s d = createSE s d
                       | otherwise = error "Bad values in structuring element"

-- Create SE with custom shape that is taken from flat list shape.
createSE (w,h) (x,y) shape = unsafePerformIO $ do
    iptr <- {#call cvCreateStructuringElementEx#}
             w h x y (fromIntegral shape) nullPtr
    fptr <- newForeignPtr releaseSE iptr
    return (ConvKernel fptr)

customSE s@(w,h) o shape | isGoodSE s o
                         && length shape == fromIntegral (w*h)
                            = createCustomSE s o shape

createCustomSE (w,h) (x,y) shape = unsafePerformIO $ do
            iptr <- withArray shape $ \arr ->
                    {#call cvCreateStructuringElementEx#}
                      w h x y (fromIntegral customShape) arr
            fptr <- newForeignPtr releaseSE iptr
            return (ConvKernel fptr)

{#fun cvErode as erosion
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}
{#fun cvDilate as dilation
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}

erodeOp se count = ImgOp $ \(S img)  -> erosion img img se count
dilateOp se count = ImgOp $ \(S img) -> dilation img img se count

erode se count  i = unsafeOperate (erodeOp se count)  i
dilate se count i = unsafeOperate (dilateOp se count) i

erode' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvErode#} (castPtr image)
                              (castPtr image)
                              ck count

dilate' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvDilate#} (castPtr image)
                              (castPtr image)
                              ck count


run in constant space, by using a strict fold (as before)

Ignore-this: d713170477c6c97d023420d8454706af

darcs-hash:20090916054719-9241b-c83c4d4de5e7615ad30a612456c640afdacad505.gz

{-# LANGUAGE CPP, ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Sequest
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- An implementation of the SEQUEST algorithm for fast cross-correlation based
-- identification of protein sequences.
--
--
-- References:
--
-- [1] J. K. Eng, B. Fischer, J. Grossmann, and M. J. MacCoss. "A fast sequest
--     cross correlation algorithm." Journal of Proteome Research,
--     7(10):4598-4602, 2008.
--
-- [2] J. K. Eng, A. L. McCormack, and I. John R. Yates. "An approach to
--     correlate tandem mass spectral data of peptides with amino acid sequences
--     in a protein database." Journal of the American Society for Mass
--     Spectrometry, 5(11):976-989, November 1994.
--
--------------------------------------------------------------------------------

module Sequest
  (
    Match(..),
    MatchCollection,
    searchForMatches
  )
  where

#include "kernels/kernels.h"

import Mass
import Config
import Protein
import Spectrum
import IonSeries

import Data.List
import Data.Maybe

import C2HS
import Foreign.CUDA (DevicePtr, withDevicePtr)
import qualified Foreign.CUDA as G

--------------------------------------------------------------------------------
-- Data Structures
--------------------------------------------------------------------------------

type MatchCollection = [Match]

--
-- A structure to store the result of a peptide/spectrum similarity test
--
data Match = Match
    {
        candidate :: Peptide,           -- The fragment that was examined
        scoreXC   :: Float              -- Sequest cross-correlation score
--        scoreSP   :: (Int, Int)         -- Matched ions / total ions
    }
    deriving (Eq, Show)

--------------------------------------------------------------------------------
-- Database search
--------------------------------------------------------------------------------

--
-- Left fold with strict accumulator and monadic operator
--
foldlM' :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldlM' f z0 xs0 = go z0 xs0
    where go z []     = return z
          go z (x:xs) = do z'  <-   f z x
                           z' `seq` go z' xs

--
-- Search the database for amino acid sequences within a defined mass tolerance.
-- Only peptides which fall within this range will be considered.
--
searchForMatches :: ConfigParams -> ProteinDatabase -> Spectrum -> IO MatchCollection
searchForMatches cp database spec = do
    specExp <- buildExpSpecXCorr cp spec
    finish `fmap` foldlM' record nomatch [ score specExp peptide |
                                            protein <- candidates database,
                                            peptide <- fragments protein
                                         ]
    where
        specThry b = buildThrySpecXCorr cp b (round (charge spec))
        candidates = findCandidates cp spec . map (digestProtein cp)
        finish     = reverse . catMaybes

        record l   = fmap $ tail . flip (insertBy cmp) l . Just
        n          = max (numMatches cp) (numMatchesDetail cp)
        nomatch    = replicate n Nothing

        score e p  = Match p `fmap` (specThry (bnds e) p >>= sequestXC cp e)

        bnds (XCorrSpecExp b _) = b
        cmp (Just x) (Just y)   = compare (scoreXC x) (scoreXC y)
        cmp _        _          = GT

#if 0
searchForMatches :: ConfigParams -> ProteinDatabase -> Spectrum -> MatchCollection
searchForMatches cp database spec = finish $
    foldl' record nomatch [ score peptide |
                              protein <- candidates database,
                              peptide <- fragments protein
                          ]
    where
        specExp    = buildExpSpecXCorr  cp spec
        specThry   = buildThrySpecXCorr cp (charge spec)
        candidates = findCandidates cp spec . map (digestProtein cp)
        finish     = reverse . catMaybes

        record l   = tail . flip (insertBy cmp) l . Just
        n          = max (numMatches cp) (numMatchesDetail cp)
        nomatch    = replicate n Nothing

        score p    = Match {
            scoreXC   = sequestXC cp spec specExp (specThry p),
            candidate = p
          }

        cmp (Just x) (Just y) = compare (scoreXC x) (scoreXC y)
        cmp _        _        = GT
#endif

--
-- Search the protein database for candidate peptides within the specified mass
-- tolerance that should be examined by spectral cross-correlation.
--
findCandidates :: ConfigParams -> Spectrum -> ProteinDatabase -> ProteinDatabase
findCandidates cp spec =
    filter (not.null.fragments) . map (\p -> p {fragments = filter inrange (fragments p)})
    where
        inrange p = (mass - limit) <= pmass p && pmass p <= (mass + limit)
        mass      = (precursor spec * charge spec) - ((charge spec * massH) - 1)
        limit     = massTolerance cp

--------------------------------------------------------------------------------
-- Scoring
--------------------------------------------------------------------------------

--
-- Score a peptide against the observed intensity spectrum. The sequest cross
-- correlation is the dot product between the theoretical representation and the
-- preprocessed experimental spectra.
--
sequestXC :: ConfigParams -> XCorrSpecExp -> XCorrSpecThry -> IO Float
sequestXC _cp (XCorrSpecExp (m,n) d_exp) (XCorrSpecThry _ d_thry) =
  do
    G.allocaBytes bytes $ \d_xs -> do
    zipWith_timesif d_thry d_exp d_xs len
    fold_plusf d_xs len >>= \x -> return (x / 10000)
    where
      len   = (n-m)
      bytes = fromIntegral len * fromIntegral (sizeOf (undefined::CFloat))

{# fun unsafe zipWith_timesif
    { withDevicePtr* `DevicePtr CInt'   ,
      withDevicePtr* `DevicePtr CFloat' ,
      withDevicePtr* `DevicePtr CFloat' ,
                     `Int'              } -> `()' #}

{# fun unsafe fold_plusf
    { withDevicePtr* `DevicePtr CFloat' ,
                     `Int'              } -> `Float' #}

#if 0
--
-- Explicitly de-forested array dot product [P. Walder, Deforestation, 1988]
--
dot     :: (Ix a, Num a, Num e) => Array a e -> Array a e -> e
dot v w =  loop m 0
    where
        (m,n)                  = bounds v
        loop i acc | i > n     = acc
                   | otherwise = loop (i+1) (v!i * w!i + acc)

--
-- Score a peptide against the observed intensity spectrum. The sequest cross
-- correlation is the dot product between the theoretical representation and the
-- preprocessed experimental spectra.
--
sequestXC :: ConfigParams -> Spectrum -> XCorrSpecExp -> XCorrSpecThry -> Float
sequestXC cp spec v sv = (dot v w) / 10000
    where
        w      = accumArray max 0 bnds [(bin i,e) | (i,e) <- sv, inRange bnds (bin i)]
        bin mz = round (mz / width)
        width  = if aaMassTypeMono cp then 1.0005079 else 1.0011413

        cutoff = 50 + precursor spec * charge spec
        (m,n)  = bounds v
        bnds   = (m, min n (bin cutoff))
#endif

{-# LANGUAGE CPP, ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Sequest
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- An implementation of the SEQUEST algorithm for fast cross-correlation based
-- identification of protein sequences.
--
--
-- References:
--
-- [1] J. K. Eng, B. Fischer, J. Grossmann, and M. J. MacCoss. "A fast sequest
--     cross correlation algorithm." Journal of Proteome Research,
--     7(10):4598-4602, 2008.
--
-- [2] J. K. Eng, A. L. McCormack, and I. John R. Yates. "An approach to
--     correlate tandem mass spectral data of peptides with amino acid sequences
--     in a protein database." Journal of the American Society for Mass
--     Spectrometry, 5(11):976-989, November 1994.
--
--------------------------------------------------------------------------------

module Sequest
  (
    Match(..),
    MatchCollection,
    searchForMatches
  )
  where

#include "kernels/kernels.h"

import Mass
import Config
import Protein
import Spectrum
import IonSeries

import Data.List
import Data.Maybe

import C2HS
import Foreign.CUDA (DevicePtr, withDevicePtr)
import qualified Foreign.CUDA as G

--------------------------------------------------------------------------------
-- Data Structures
--------------------------------------------------------------------------------

type MatchCollection = [Match]

--
-- A structure to store the result of a peptide/spectrum similarity test
--
data Match = Match
    {
        candidate :: Peptide,           -- The fragment that was examined
        scoreXC   :: Float              -- Sequest cross-correlation score
--        scoreSP   :: (Int, Int)         -- Matched ions / total ions
    }
    deriving (Eq, Show)

--------------------------------------------------------------------------------
-- Database search
--------------------------------------------------------------------------------

--
-- Search the database for amino acid sequences within a defined mass tolerance.
-- Only peptides which fall within this range will be considered.
--
searchForMatches :: ConfigParams -> ProteinDatabase -> Spectrum -> IO MatchCollection
searchForMatches cp database spec = do
    specExp <- buildExpSpecXCorr cp spec
    scores  <- sequence [ score specExp peptide |
                            protein <- candidates database,
                            peptide <- fragments protein
                        ]

    return . finish $ foldl' record nomatch scores
    where
        specThry b = buildThrySpecXCorr cp b (round (charge spec))
        candidates = findCandidates cp spec . map (digestProtein cp)
        finish     = reverse . catMaybes

        record l   = tail . flip (insertBy cmp) l . Just
        n          = max (numMatches cp) (numMatchesDetail cp)
        nomatch    = replicate n Nothing

        score e p  = Match p `fmap` (specThry (bnds e) p >>= sequestXC cp e)

        bnds (XCorrSpecExp b _) = b
        cmp (Just x) (Just y)   = compare (scoreXC x) (scoreXC y)
        cmp _        _          = GT

#if 0
searchForMatches :: ConfigParams -> ProteinDatabase -> Spectrum -> MatchCollection
searchForMatches cp database spec = finish $
    foldl' record nomatch [ score peptide |
                              protein <- candidates database,
                              peptide <- fragments protein
                          ]
    where
        specExp    = buildExpSpecXCorr  cp spec
        specThry   = buildThrySpecXCorr cp (charge spec)
        candidates = findCandidates cp spec . map (digestProtein cp)
        finish     = reverse . catMaybes

        record l   = tail . flip (insertBy cmp) l . Just
        n          = max (numMatches cp) (numMatchesDetail cp)
        nomatch    = replicate n Nothing

        score p    = Match {
            scoreXC   = sequestXC cp spec specExp (specThry p),
            candidate = p
          }

        cmp (Just x) (Just y) = compare (scoreXC x) (scoreXC y)
        cmp _        _        = GT
#endif

--
-- Search the protein database for candidate peptides within the specified mass
-- tolerance that should be examined by spectral cross-correlation.
--
findCandidates :: ConfigParams -> Spectrum -> ProteinDatabase -> ProteinDatabase
findCandidates cp spec =
    filter (not.null.fragments) . map (\p -> p {fragments = filter inrange (fragments p)})
    where
        inrange p = (mass - limit) <= pmass p && pmass p <= (mass + limit)
        mass      = (precursor spec * charge spec) - ((charge spec * massH) - 1)
        limit     = massTolerance cp

--------------------------------------------------------------------------------
-- Scoring
--------------------------------------------------------------------------------

--
-- Score a peptide against the observed intensity spectrum. The sequest cross
-- correlation is the dot product between the theoretical representation and the
-- preprocessed experimental spectra.
--
sequestXC :: ConfigParams -> XCorrSpecExp -> XCorrSpecThry -> IO Float
sequestXC _cp (XCorrSpecExp (m,n) d_exp) (XCorrSpecThry _ d_thry) =
  do
    G.allocaBytes bytes $ \d_xs -> do
    zipWith_timesif d_thry d_exp d_xs len
    fold_plusf d_xs len >>= \x -> return (x / 10000)
    where
      len   = (n-m)
      bytes = fromIntegral len * fromIntegral (sizeOf (undefined::CFloat))

{# fun unsafe zipWith_timesif
    { withDevicePtr* `DevicePtr CInt'   ,
      withDevicePtr* `DevicePtr CFloat' ,
      withDevicePtr* `DevicePtr CFloat' ,
                     `Int'              } -> `()' #}

{# fun unsafe fold_plusf
    { withDevicePtr* `DevicePtr CFloat' ,
                     `Int'              } -> `Float' #}

#if 0
--
-- Explicitly de-forested array dot product [P. Walder, Deforestation, 1988]
--
dot     :: (Ix a, Num a, Num e) => Array a e -> Array a e -> e
dot v w =  loop m 0
    where
        (m,n)                  = bounds v
        loop i acc | i > n     = acc
                   | otherwise = loop (i+1) (v!i * w!i + acc)

--
-- Score a peptide against the observed intensity spectrum. The sequest cross
-- correlation is the dot product between the theoretical representation and the
-- preprocessed experimental spectra.
--
sequestXC :: ConfigParams -> Spectrum -> XCorrSpecExp -> XCorrSpecThry -> Float
sequestXC cp spec v sv = (dot v w) / 10000
    where
        w      = accumArray max 0 bnds [(bin i,e) | (i,e) <- sv, inRange bnds (bin i)]
        bin mz = round (mz / width)
        width  = if aaMassTypeMono cp then 1.0005079 else 1.0011413

        cutoff = 50 + precursor spec * charge spec
        (m,n)  = bounds v
        bnds   = (m, min n (bin cutoff))
#endif


error when cuddMakeTreeNode fails

error when cuddMakeTreeNode fails

{-#LANGUAGE ForeignFunctionInterface #-}

module CuddReorder where

import System.IO
import Foreign
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Control.Monad

import CuddInternal
import CuddHook

#include <stdio.h>
#include <cudd.h>

readIntegral :: (Integral i, Num j) => (Ptr CDdManager -> IO i) -> DdManager -> IO j
readIntegral f (DdManager m) = liftM fromIntegral $ f m

setIntegral :: (Integral i, Num j) => (Ptr CDdManager -> j -> IO ()) -> DdManager -> i -> IO ()
setIntegral f (DdManager m) v = f m (fromIntegral v)

readFloat :: (Real r, Fractional f) => (Ptr CDdManager -> IO r) -> DdManager -> IO f
readFloat f (DdManager m) = liftM realToFrac $ f m

setFloat :: (Real r, Fractional f) => (Ptr CDdManager -> f -> IO ()) -> DdManager -> r -> IO ()
setFloat f (DdManager m) v = f m (realToFrac v)

--Reordering types
{#enum Cudd_ReorderingType as CuddReorderingType {underscoreToCase} deriving (Show, Eq) #}

--Reorder when needed
foreign import ccall unsafe "cudd.h Cudd_ReorderingStatus"
	c_cuddReorderingStatus :: Ptr CDdManager -> Ptr CInt -> IO (CInt)

cuddReorderingStatus :: DdManager -> IO (Int, CuddReorderingType)
cuddReorderingStatus (DdManager m) = do
	alloca $ \mem -> do
		res <- c_cuddReorderingStatus m mem
		typ <- peek mem
		return $ (fromIntegral res, toEnum $ fromIntegral typ)

foreign import ccall unsafe "cudd.h Cudd_AutodynEnable"
	c_cuddAutodynEnable :: Ptr CDdManager -> CInt -> IO ()

cuddAutodynEnable :: DdManager -> CuddReorderingType -> IO ()
cuddAutodynEnable (DdManager m) t = c_cuddAutodynEnable m (fromIntegral $ fromEnum t)

--Reorder right now
foreign import ccall unsafe "cudd.h Cudd_ReduceHeap"
	c_cuddReduceHeap :: Ptr CDdManager -> CInt -> CInt -> IO (CInt)

cuddReduceHeap :: DdManager -> CuddReorderingType -> Int -> IO (Int)
cuddReduceHeap (DdManager m) typ minsize = liftM fromIntegral $ c_cuddReduceHeap m (fromIntegral $ fromEnum typ) (fromIntegral minsize)

--Grouping
foreign import ccall unsafe "cudd.h Cudd_MakeTreeNode"
	c_cuddMakeTreeNode :: Ptr CDdManager -> CUInt -> CUInt -> CUInt -> IO (Ptr ())

cuddMakeTreeNode :: DdManager -> Int -> Int -> Int -> IO (Ptr ())
cuddMakeTreeNode (DdManager m) low size typ = do
    res <- c_cuddMakeTreeNode m (fromIntegral low) (fromIntegral size) (fromIntegral typ)
    when (res==nullPtr) (error "cuddMakeTreeNode returned error")
    return res

--Reordering stats
foreign import ccall unsafe "cudd.h Cudd_ReadReorderingTime"
	c_cuddReadReorderingTime :: Ptr CDdManager -> IO (CLong)

cuddReadReorderingTime :: DdManager -> IO (Int)
cuddReadReorderingTime = readIntegral c_cuddReadReorderingTime

foreign import ccall unsafe "cudd.h Cudd_ReadReorderings"
	c_cuddReadReorderings :: Ptr CDdManager -> IO (CInt)

cuddReadReorderings :: DdManager -> IO (Int)
cuddReadReorderings = readIntegral c_cuddReadReorderings

--Hooks
foreign import ccall unsafe "cudd.h &Cudd_StdPreReordHook"
	c_cuddStdPreReordHook :: HookFP

foreign import ccall unsafe "cudd.h &Cudd_StdPostReordHook"
	c_cuddStdPostReordHook :: HookFP

foreign import ccall unsafe "cudd.h Cudd_EnableReorderingReporting"
	c_cuddEnableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddEnableReorderingReporting :: DdManager -> IO (Int)
cuddEnableReorderingReporting (DdManager m) = liftM fromIntegral $ c_cuddEnableReorderingReporting m

foreign import ccall unsafe "cudd.h Cudd_DisableReorderingReporting"
	c_cuddDisableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddDisableReorderingReporting :: DdManager -> IO (Int)
cuddDisableReorderingReporting (DdManager m) = liftM fromIntegral $ c_cuddDisableReorderingReporting m

foreign import ccall unsafe "cudd.h Cudd_ReorderingReporting"
	c_cuddReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddReorderingReporting :: DdManager -> IO (Int)
cuddReorderingReporting (DdManager m) = liftM fromIntegral $ c_cuddReorderingReporting m

regStdPreReordHook :: DdManager -> IO (Int)
regStdPreReordHook m = cuddAddHook m c_cuddStdPreReordHook CuddPreReorderingHook

regStdPostReordHook :: DdManager -> IO (Int)
regStdPostReordHook m = cuddAddHook m c_cuddStdPostReordHook CuddPostReorderingHook

--Universal reordering params
foreign import ccall unsafe "cudd.h Cudd_TurnOffCountDead"
	c_cuddTurnOffCountDead :: Ptr CDdManager -> IO ()

cuddturnOffCountDead :: DdManager -> IO ()
cuddturnOffCountDead (DdManager m) = c_cuddTurnOffCountDead m

foreign import ccall unsafe "cudd.h Cudd_TurnOnCountDead"
	c_cuddTurnOnCountDead :: Ptr CDdManager -> IO ()

cuddTurnOnCountDead :: DdManager -> IO ()
cuddTurnOnCountDead (DdManager m) = c_cuddTurnOnCountDead m

foreign import ccall unsafe "cudd.h Cudd_DeadAreCounted"
	c_cuddDeadAreCounted :: Ptr CDdManager -> IO CInt

cuddDeadAreCounted :: DdManager -> IO (Int)
cuddDeadAreCounted (DdManager m) = liftM fromIntegral $ c_cuddDeadAreCounted m

--Sifting parameters
foreign import ccall unsafe "cudd.h Cudd_ReadSiftMaxSwap"
	c_cuddReadSiftMaxSwap :: Ptr CDdManager -> IO (CInt)

cuddReadSiftMaxSwap :: DdManager -> IO (Int)
cuddReadSiftMaxSwap = readIntegral c_cuddReadSiftMaxSwap

foreign import ccall unsafe "cudd.h Cudd_SetSiftMaxSwap"
	c_cuddSetSiftMaxSwap :: Ptr CDdManager -> CInt -> IO ()

cuddSetSiftMaxSwap :: DdManager -> Int -> IO ()
cuddSetSiftMaxSwap = setIntegral c_cuddSetSiftMaxSwap

foreign import ccall unsafe "cudd.h Cudd_ReadSiftMaxVar"
	c_cuddReadSiftMaxVar :: Ptr CDdManager -> IO (Int)

cuddReadSiftMaxVar :: DdManager -> IO (Int)
cuddReadSiftMaxVar = readIntegral c_cuddReadSiftMaxVar

foreign import ccall unsafe "cudd.h Cudd_SetSiftMaxVar"
	c_cuddSetSiftMaxVar :: Ptr CDdManager -> CInt -> IO ()

cuddSetsiftMaxVar :: DdManager -> Int -> IO ()
cuddSetsiftMaxVar = setIntegral c_cuddSetSiftMaxVar

foreign import ccall unsafe "cudd.h Cudd_ReadNextReordering"
	c_cuddReadNextReordering :: Ptr CDdManager -> IO (Int)

cuddReadNextReordering :: DdManager -> IO (Int)
cuddReadNextReordering = readIntegral c_cuddReadNextReordering

foreign import ccall unsafe "cudd.h Cudd_SetNextReordering"
	c_cuddSetNextReordering :: Ptr CDdManager -> CInt -> IO ()

cuddSetNextReordering :: DdManager -> Int -> IO ()
cuddSetNextReordering = setIntegral c_cuddSetNextReordering

foreign import ccall unsafe "cudd.h Cudd_ReadMaxGrowthAlternate"
	c_cuddReadMaxGrowthAlternate :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowthAlternate :: DdManager -> IO (Double)
cuddReadMaxGrowthAlternate = readFloat c_cuddReadMaxGrowthAlternate

foreign import ccall unsafe "cudd.h Cudd_SetMaxGrowthAlternate"
	c_cuddSetMaxGrowthAlternate :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowthAlternate :: DdManager -> Double -> IO ()
cuddSetMaxGrowthAlternate = setFloat c_cuddSetMaxGrowthAlternate

foreign import ccall unsafe "cudd.h Cudd_ReadMaxGrowth"
	c_cuddReadMaxGrowth :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowth :: DdManager -> IO CDouble
cuddReadMaxGrowth = readFloat c_cuddReadMaxGrowth

foreign import ccall unsafe "cudd.h Cudd_SetMaxGrowth"
	c_cuddSetMaxGrowth :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowth :: DdManager -> Double -> IO ()
cuddSetMaxGrowth = setFloat c_cuddSetMaxGrowth

foreign import ccall unsafe "cudd.h Cudd_ReadReorderingCycle"
	c_cuddReadReorderingCycle :: Ptr CDdManager -> IO (CInt)

cuddReadReorderingCycle :: DdManager -> IO Int
cuddReadReorderingCycle = readIntegral c_cuddReadReorderingCycle

foreign import ccall unsafe "cudd.h Cudd_SetReorderingCycle"
	c_cuddSetReorderingCycle :: Ptr CDdManager -> CInt -> IO ()

cuddSetReorderingCycle :: DdManager -> CInt -> IO ()
cuddSetReorderingCycle = setIntegral c_cuddSetReorderingCycle

--Genetic algorithm
foreign import ccall unsafe "cudd.h Cudd_ReadPopulationSize"
	c_cuddReadPopulationSize :: Ptr CDdManager -> IO (CInt)

cuddReadPopulationSize :: DdManager -> IO (Int)
cuddReadPopulationSize = readIntegral c_cuddReadPopulationSize

foreign import ccall unsafe "cudd.h Cudd_SetPopulationSize"
	c_cuddSetPopulationSize :: Ptr CDdManager -> CInt -> IO ()

cuddSetPopulationSize :: DdManager -> Int -> IO ()
cuddSetPopulationSize = setIntegral c_cuddSetPopulationSize

foreign import ccall unsafe "cudd.h Cudd_ReadNumberXovers"
	c_cuddReadNumberXovers :: Ptr CDdManager -> IO (CInt)

cuddReadNumberXovers :: DdManager -> IO (Int)
cuddReadNumberXovers = readIntegral c_cuddReadNumberXovers

foreign import ccall unsafe "cudd.h Cudd_SetNumberXovers"
	c_cuddSetNumberXovers :: Ptr CDdManager -> CInt -> IO ()

cuddSetNumberXovers :: DdManager -> Int -> IO ()
cuddSetNumberXovers = setIntegral c_cuddSetNumberXovers

{-#LANGUAGE ForeignFunctionInterface #-}

module CuddReorder where

import System.IO
import Foreign
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Control.Monad

import CuddInternal
import CuddHook

#include <stdio.h>
#include <cudd.h>

readIntegral :: (Integral i, Num j) => (Ptr CDdManager -> IO i) -> DdManager -> IO j
readIntegral f (DdManager m) = liftM fromIntegral $ f m

setIntegral :: (Integral i, Num j) => (Ptr CDdManager -> j -> IO ()) -> DdManager -> i -> IO ()
setIntegral f (DdManager m) v = f m (fromIntegral v)

readFloat :: (Real r, Fractional f) => (Ptr CDdManager -> IO r) -> DdManager -> IO f
readFloat f (DdManager m) = liftM realToFrac $ f m

setFloat :: (Real r, Fractional f) => (Ptr CDdManager -> f -> IO ()) -> DdManager -> r -> IO ()
setFloat f (DdManager m) v = f m (realToFrac v)

--Reordering types
{#enum Cudd_ReorderingType as CuddReorderingType {underscoreToCase} deriving (Show, Eq) #}

--Reorder when needed
foreign import ccall unsafe "cudd.h Cudd_ReorderingStatus"
	c_cuddReorderingStatus :: Ptr CDdManager -> Ptr CInt -> IO (CInt)

cuddReorderingStatus :: DdManager -> IO (Int, CuddReorderingType)
cuddReorderingStatus (DdManager m) = do
	alloca $ \mem -> do
		res <- c_cuddReorderingStatus m mem
		typ <- peek mem
		return $ (fromIntegral res, toEnum $ fromIntegral typ)

foreign import ccall unsafe "cudd.h Cudd_AutodynEnable"
	c_cuddAutodynEnable :: Ptr CDdManager -> CInt -> IO ()

cuddAutodynEnable :: DdManager -> CuddReorderingType -> IO ()
cuddAutodynEnable (DdManager m) t = c_cuddAutodynEnable m (fromIntegral $ fromEnum t)

--Reorder right now
foreign import ccall unsafe "cudd.h Cudd_ReduceHeap"
	c_cuddReduceHeap :: Ptr CDdManager -> CInt -> CInt -> IO (CInt)

cuddReduceHeap :: DdManager -> CuddReorderingType -> Int -> IO (Int)
cuddReduceHeap (DdManager m) typ minsize = liftM fromIntegral $ c_cuddReduceHeap m (fromIntegral $ fromEnum typ) (fromIntegral minsize)

--Grouping
foreign import ccall unsafe "cudd.h Cudd_MakeTreeNode"
	c_cuddMakeTreeNode :: Ptr CDdManager -> CUInt -> CUInt -> CUInt -> IO (Ptr ())

cuddMakeTreeNode :: DdManager -> Int -> Int -> Int -> IO (Ptr ())
cuddMakeTreeNode (DdManager m) low size typ = c_cuddMakeTreeNode m (fromIntegral low) (fromIntegral size) (fromIntegral typ)

--Reordering stats
foreign import ccall unsafe "cudd.h Cudd_ReadReorderingTime"
	c_cuddReadReorderingTime :: Ptr CDdManager -> IO (CLong)

cuddReadReorderingTime :: DdManager -> IO (Int)
cuddReadReorderingTime = readIntegral c_cuddReadReorderingTime

foreign import ccall unsafe "cudd.h Cudd_ReadReorderings"
	c_cuddReadReorderings :: Ptr CDdManager -> IO (CInt)

cuddReadReorderings :: DdManager -> IO (Int)
cuddReadReorderings = readIntegral c_cuddReadReorderings

--Hooks
foreign import ccall unsafe "cudd.h &Cudd_StdPreReordHook"
	c_cuddStdPreReordHook :: HookFP

foreign import ccall unsafe "cudd.h &Cudd_StdPostReordHook"
	c_cuddStdPostReordHook :: HookFP

foreign import ccall unsafe "cudd.h Cudd_EnableReorderingReporting"
	c_cuddEnableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddEnableReorderingReporting :: DdManager -> IO (Int)
cuddEnableReorderingReporting (DdManager m) = liftM fromIntegral $ c_cuddEnableReorderingReporting m

foreign import ccall unsafe "cudd.h Cudd_DisableReorderingReporting"
	c_cuddDisableReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddDisableReorderingReporting :: DdManager -> IO (Int)
cuddDisableReorderingReporting (DdManager m) = liftM fromIntegral $ c_cuddDisableReorderingReporting m

foreign import ccall unsafe "cudd.h Cudd_ReorderingReporting"
	c_cuddReorderingReporting :: Ptr CDdManager -> IO (CInt)

cuddReorderingReporting :: DdManager -> IO (Int)
cuddReorderingReporting (DdManager m) = liftM fromIntegral $ c_cuddReorderingReporting m

regStdPreReordHook :: DdManager -> IO (Int)
regStdPreReordHook m = cuddAddHook m c_cuddStdPreReordHook CuddPreReorderingHook

regStdPostReordHook :: DdManager -> IO (Int)
regStdPostReordHook m = cuddAddHook m c_cuddStdPostReordHook CuddPostReorderingHook

--Universal reordering params
foreign import ccall unsafe "cudd.h Cudd_TurnOffCountDead"
	c_cuddTurnOffCountDead :: Ptr CDdManager -> IO ()

cuddturnOffCountDead :: DdManager -> IO ()
cuddturnOffCountDead (DdManager m) = c_cuddTurnOffCountDead m

foreign import ccall unsafe "cudd.h Cudd_TurnOnCountDead"
	c_cuddTurnOnCountDead :: Ptr CDdManager -> IO ()

cuddTurnOnCountDead :: DdManager -> IO ()
cuddTurnOnCountDead (DdManager m) = c_cuddTurnOnCountDead m

foreign import ccall unsafe "cudd.h Cudd_DeadAreCounted"
	c_cuddDeadAreCounted :: Ptr CDdManager -> IO CInt

cuddDeadAreCounted :: DdManager -> IO (Int)
cuddDeadAreCounted (DdManager m) = liftM fromIntegral $ c_cuddDeadAreCounted m

--Sifting parameters
foreign import ccall unsafe "cudd.h Cudd_ReadSiftMaxSwap"
	c_cuddReadSiftMaxSwap :: Ptr CDdManager -> IO (CInt)

cuddReadSiftMaxSwap :: DdManager -> IO (Int)
cuddReadSiftMaxSwap = readIntegral c_cuddReadSiftMaxSwap

foreign import ccall unsafe "cudd.h Cudd_SetSiftMaxSwap"
	c_cuddSetSiftMaxSwap :: Ptr CDdManager -> CInt -> IO ()

cuddSetSiftMaxSwap :: DdManager -> Int -> IO ()
cuddSetSiftMaxSwap = setIntegral c_cuddSetSiftMaxSwap

foreign import ccall unsafe "cudd.h Cudd_ReadSiftMaxVar"
	c_cuddReadSiftMaxVar :: Ptr CDdManager -> IO (Int)

cuddReadSiftMaxVar :: DdManager -> IO (Int)
cuddReadSiftMaxVar = readIntegral c_cuddReadSiftMaxVar

foreign import ccall unsafe "cudd.h Cudd_SetSiftMaxVar"
	c_cuddSetSiftMaxVar :: Ptr CDdManager -> CInt -> IO ()

cuddSetsiftMaxVar :: DdManager -> Int -> IO ()
cuddSetsiftMaxVar = setIntegral c_cuddSetSiftMaxVar

foreign import ccall unsafe "cudd.h Cudd_ReadNextReordering"
	c_cuddReadNextReordering :: Ptr CDdManager -> IO (Int)

cuddReadNextReordering :: DdManager -> IO (Int)
cuddReadNextReordering = readIntegral c_cuddReadNextReordering

foreign import ccall unsafe "cudd.h Cudd_SetNextReordering"
	c_cuddSetNextReordering :: Ptr CDdManager -> CInt -> IO ()

cuddSetNextReordering :: DdManager -> Int -> IO ()
cuddSetNextReordering = setIntegral c_cuddSetNextReordering

foreign import ccall unsafe "cudd.h Cudd_ReadMaxGrowthAlternate"
	c_cuddReadMaxGrowthAlternate :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowthAlternate :: DdManager -> IO (Double)
cuddReadMaxGrowthAlternate = readFloat c_cuddReadMaxGrowthAlternate

foreign import ccall unsafe "cudd.h Cudd_SetMaxGrowthAlternate"
	c_cuddSetMaxGrowthAlternate :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowthAlternate :: DdManager -> Double -> IO ()
cuddSetMaxGrowthAlternate = setFloat c_cuddSetMaxGrowthAlternate

foreign import ccall unsafe "cudd.h Cudd_ReadMaxGrowth"
	c_cuddReadMaxGrowth :: Ptr CDdManager -> IO CDouble

cuddReadMaxGrowth :: DdManager -> IO CDouble
cuddReadMaxGrowth = readFloat c_cuddReadMaxGrowth

foreign import ccall unsafe "cudd.h Cudd_SetMaxGrowth"
	c_cuddSetMaxGrowth :: Ptr CDdManager -> CDouble -> IO ()

cuddSetMaxGrowth :: DdManager -> Double -> IO ()
cuddSetMaxGrowth = setFloat c_cuddSetMaxGrowth

foreign import ccall unsafe "cudd.h Cudd_ReadReorderingCycle"
	c_cuddReadReorderingCycle :: Ptr CDdManager -> IO (CInt)

cuddReadReorderingCycle :: DdManager -> IO Int
cuddReadReorderingCycle = readIntegral c_cuddReadReorderingCycle

foreign import ccall unsafe "cudd.h Cudd_SetReorderingCycle"
	c_cuddSetReorderingCycle :: Ptr CDdManager -> CInt -> IO ()

cuddSetReorderingCycle :: DdManager -> CInt -> IO ()
cuddSetReorderingCycle = setIntegral c_cuddSetReorderingCycle

--Genetic algorithm
foreign import ccall unsafe "cudd.h Cudd_ReadPopulationSize"
	c_cuddReadPopulationSize :: Ptr CDdManager -> IO (CInt)

cuddReadPopulationSize :: DdManager -> IO (Int)
cuddReadPopulationSize = readIntegral c_cuddReadPopulationSize

foreign import ccall unsafe "cudd.h Cudd_SetPopulationSize"
	c_cuddSetPopulationSize :: Ptr CDdManager -> CInt -> IO ()

cuddSetPopulationSize :: DdManager -> Int -> IO ()
cuddSetPopulationSize = setIntegral c_cuddSetPopulationSize

foreign import ccall unsafe "cudd.h Cudd_ReadNumberXovers"
	c_cuddReadNumberXovers :: Ptr CDdManager -> IO (CInt)

cuddReadNumberXovers :: DdManager -> IO (Int)
cuddReadNumberXovers = readIntegral c_cuddReadNumberXovers

foreign import ccall unsafe "cudd.h Cudd_SetNumberXovers"
	c_cuddSetNumberXovers :: Ptr CDdManager -> CInt -> IO ()

cuddSetNumberXovers :: DdManager -> Int -> IO ()
cuddSetNumberXovers = setIntegral c_cuddSetNumberXovers


update to gathering of device properties

Old versions of the driver API gathered device properties via two separate means. This was changed in CUDA-5.0 to present a single interface, which we now use.

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
#ifdef USE_EMPTY_CASE
{-# LANGUAGE EmptyCase                #-}
#endif
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Device
-- Copyright : [2009..2014] Trevor L. McDonell
-- License   : BSD
--
-- Device management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Device (

  -- * Device Management
  Device(..), -- should be exported abstractly
  DeviceProperties(..), DeviceAttribute(..), Compute(..), ComputeMode(..), InitFlag,
  initialise, capability, device, attribute, count, name, props, totalMem

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad                                    ( liftM )
import Control.Applicative
import Prelude

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

newtype Device = Device { useDevice :: {# type CUdevice #}}
  deriving (Eq, Show)

-- |
-- Device attributes
--
{# enum CUdevice_attribute as DeviceAttribute
    { underscoreToCase
    , MAX as CU_DEVICE_ATTRIBUTE_MAX }          -- ignore
    with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #}

{# pointer *CUdevprop as ^ foreign -> CUDevProp nocode #}

#if CUDA_VERSION < 5000
--
-- Properties of the compute device (internal helper).
-- Replaced by cuDeviceGetAttribute in CUDA-5.0 and later.
--
data CUDevProp = CUDevProp
  {
    cuMaxThreadsPerBlock :: !Int,               -- Maximum number of threads per block
    cuMaxBlockSize       :: !(Int,Int,Int),     -- Maximum size of each dimension of a block
    cuMaxGridSize        :: !(Int,Int,Int),     -- Maximum size of each dimension of a grid
    cuSharedMemPerBlock  :: !Int64,             -- Shared memory available per block in bytes
    cuTotalConstMem      :: !Int64,             -- Constant memory available on device in bytes
    cuWarpSize           :: !Int,               -- Warp size in threads (SIMD width)
    cuMemPitch           :: !Int64,             -- Maximum pitch in bytes allowed by memory copies
    cuRegsPerBlock       :: !Int,               -- 32-bit registers available per block
    cuClockRate          :: !Int,               -- Clock frequency in kilohertz
    cuTextureAlignment   :: !Int64              -- Alignment requirement for textures
  }
  deriving (Show)

instance Storable CUDevProp where
  sizeOf _    = {#sizeof CUdevprop#}
  alignment _ = alignment (undefined :: Ptr ())

  poke _ _    = error "no instance for Foreign.Storable.poke DeviceProperties"
  peek p      = do
    tb <- cIntConv `fmap` {#get CUdevprop.maxThreadsPerBlock#} p
    sm <- cIntConv `fmap` {#get CUdevprop.sharedMemPerBlock#} p
    cm <- cIntConv `fmap` {#get CUdevprop.totalConstantMemory#} p
    ws <- cIntConv `fmap` {#get CUdevprop.SIMDWidth#} p
    mp <- cIntConv `fmap` {#get CUdevprop.memPitch#} p
    rb <- cIntConv `fmap` {#get CUdevprop.regsPerBlock#} p
    cl <- cIntConv `fmap` {#get CUdevprop.clockRate#} p
    ta <- cIntConv `fmap` {#get CUdevprop.textureAlign#} p

    [t1,t2,t3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxThreadsDim#} p
    [g1,g2,g3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxGridSize#} p

    return CUDevProp
      {
        cuMaxThreadsPerBlock = tb,
        cuMaxBlockSize       = (t1,t2,t3),
        cuMaxGridSize        = (g1,g2,g3),
        cuSharedMemPerBlock  = sm,
        cuTotalConstMem      = cm,
        cuWarpSize           = ws,
        cuMemPitch           = mp,
        cuRegsPerBlock       = rb,
        cuClockRate          = cl,
        cuTextureAlignment   = ta
      }
#endif

-- |
-- Possible option flags for CUDA initialisation. Dummy instance until the API
-- exports actual option values.
--
data InitFlag
instance Enum InitFlag where
#ifdef USE_EMPTY_CASE
  toEnum   x = case x of {}
  fromEnum x = case x of {}
#endif

--------------------------------------------------------------------------------
-- Initialisation
--------------------------------------------------------------------------------

-- |
-- Initialise the CUDA driver API. This must be called before any other
-- driver function.
--
-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__INITIALIZE.html#group__CUDA__INITIALIZE_1g0a2f1517e1bd8502c7194c3a8c134bc3>
--
{-# INLINEABLE initialise #-}
initialise :: [InitFlag] -> IO ()
initialise !flags = nothingIfOk =<< cuInit flags

{-# INLINE cuInit #-}
{# fun unsafe cuInit
  { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Device Management
--------------------------------------------------------------------------------

-- |
-- Return the compute compatibility revision supported by the device
--
{-# INLINEABLE capability #-}
capability :: Device -> IO Compute
#if CUDA_VERSION >= 5000
capability !dev =
  Compute <$> attribute dev ComputeCapabilityMajor
          <*> attribute dev ComputeCapabilityMinor
#else
-- Deprecated as of CUDA-5.0
--
capability !dev =
  (\(!s,!a,!b) -> resultIfOk (s,Compute a b)) =<< cuDeviceComputeCapability dev

{-# INLINE cuDeviceComputeCapability #-}
{# fun unsafe cuDeviceComputeCapability
  { alloca-   `Int'    peekIntConv*
  , alloca-   `Int'    peekIntConv*
  , useDevice `Device'              } -> `Status' cToEnum #}
#endif

-- |
-- Return a handle to the compute device at the given ordinal.
--
-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g8bdd1cc7201304b01357b8034f6587cb>
--
{-# INLINEABLE device #-}
device :: Int -> IO Device
device !d = resultIfOk =<< cuDeviceGet d

{-# INLINE cuDeviceGet #-}
{# fun unsafe cuDeviceGet
  { alloca-  `Device' dev*
  , cIntConv `Int'           } -> `Status' cToEnum #}
  where dev = liftM Device . peek

-- |
-- Return the selected attribute for the given device.
--
-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g9c3e1414f0ad901d3278a4d6645fc266>
--
{-# INLINEABLE attribute #-}
attribute :: Device -> DeviceAttribute -> IO Int
attribute !d !a = resultIfOk =<< cuDeviceGetAttribute a d

{-# INLINE cuDeviceGetAttribute #-}
{# fun unsafe cuDeviceGetAttribute
  { alloca-   `Int'             peekIntConv*
  , cFromEnum `DeviceAttribute'
  , useDevice `Device'                       } -> `Status' cToEnum #}

-- |
-- Return the number of device with compute capability > 1.0.
--
-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1g52b5ce05cb8c5fb6831b2c0ff2887c74>
--
{-# INLINEABLE count #-}
count :: IO Int
count = resultIfOk =<< cuDeviceGetCount

{-# INLINE cuDeviceGetCount #-}
{# fun unsafe cuDeviceGetCount
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- The identifying name of the device.
--
-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1gef75aa30df95446a845f2a7b9fffbb7f>
--
{-# INLINEABLE name #-}
name :: Device -> IO String
name !d = resultIfOk =<< cuDeviceGetName d

{-# INLINE cuDeviceGetName #-}
{# fun unsafe cuDeviceGetName
  { allocaS-  `String'& peekS*
  , useDevice `Device'         } -> `Status' cToEnum #}
  where
    len       = 512
    allocaS a = allocaBytes len $ \p -> a (p, cIntConv len)
    peekS s _ = peekCString s

-- |
-- Return the properties of the selected device
--
{-# INLINEABLE props #-}
props :: Device -> IO DeviceProperties
props !d = do

#if CUDA_VERSION < 5000
  -- Old versions of the CUDA API used the separate cuDeviceGetProperties
  -- function to probe some properties, and cuDeviceGetAttribute for
  -- others. As of CUDA-5.0, the former was deprecated and its
  -- functionality subsumed by the latter, which we use below.
  --
  p   <- resultIfOk =<< cuDeviceGetProperties d
  let cm = cuTotalConstMem p
      sm = cuSharedMemPerBlock p
      rb = cuRegsPerBlock p
      ws = cuWarpSize p
      tb = cuMaxThreadsPerBlock p
      bs = cuMaxBlockSize p
      gs = cuMaxGridSize p
      cl = cuClockRate p
      mp = cuMemPitch p
      ta = cuTextureAlignment p
#else
  cm  <- fromIntegral <$> attribute d TotalConstantMemory
  sm  <- fromIntegral <$> attribute d SharedMemoryPerBlock
  mp  <- fromIntegral <$> attribute d MaxPitch
  ta  <- fromIntegral <$> attribute d TextureAlignment
  cl  <- attribute d ClockRate
  ws  <- attribute d WarpSize
  rb  <- attribute d RegistersPerBlock
  tb  <- attribute d MaxThreadsPerBlock
  bs  <- (,,) <$> attribute d MaxBlockDimX
              <*> attribute d MaxBlockDimY
              <*> attribute d MaxBlockDimZ
  gs  <- (,,) <$> attribute d MaxGridDimX
              <*> attribute d MaxGridDimY
              <*> attribute d MaxGridDimZ
#endif

  -- The rest of the properties.
  --
  n   <- name d
  cc  <- capability d
  gm  <- totalMem d
  pc  <- attribute d MultiprocessorCount
  md  <- toEnum `fmap` attribute d ComputeMode
  ov  <- toBool `fmap` attribute d GpuOverlap
  ke  <- toBool `fmap` attribute d KernelExecTimeout
  tg  <- toBool `fmap` attribute d Integrated
  hm  <- toBool `fmap` attribute d CanMapHostMemory
#if CUDA_VERSION >= 3000
  ck  <- toBool `fmap` attribute d ConcurrentKernels
  ee  <- toBool `fmap` attribute d EccEnabled
  u1  <- attribute d MaximumTexture1dWidth
  u21 <- attribute d MaximumTexture2dWidth
  u22 <- attribute d MaximumTexture2dHeight
  u31 <- attribute d MaximumTexture3dWidth
  u32 <- attribute d MaximumTexture3dHeight
  u33 <- attribute d MaximumTexture3dDepth
#endif
#if CUDA_VERSION >= 4000
  ae  <- attribute d AsyncEngineCount
  l2  <- attribute d L2CacheSize
  tm  <- attribute d MaxThreadsPerMultiprocessor
  mw  <- attribute d GlobalMemoryBusWidth
  mc  <- attribute d MemoryClockRate
  pb  <- attribute d PciBusId
  pd  <- attribute d PciDeviceId
  pm  <- attribute d PciDomainId
  ua  <- toBool `fmap` attribute d UnifiedAddressing
  tcc <- toBool `fmap` attribute d TccDriver
#endif

  return DeviceProperties
    {
      deviceName                        = n,
      computeCapability                 = cc,
      totalGlobalMem                    = gm,
      totalConstMem                     = cm,
      sharedMemPerBlock                 = sm,
      regsPerBlock                      = rb,
      warpSize                          = ws,
      maxThreadsPerBlock                = tb,
      maxBlockSize                      = bs,
      maxGridSize                       = gs,
      clockRate                         = cl,
      multiProcessorCount               = pc,
      memPitch                          = mp,
      textureAlignment                  = ta,
      computeMode                       = md,
      deviceOverlap                     = ov,
#if CUDA_VERSION >= 3000
      concurrentKernels                 = ck,
      eccEnabled                        = ee,
      maxTextureDim1D                   = u1,
      maxTextureDim2D                   = (u21,u22),
      maxTextureDim3D                   = (u31,u32,u33),
#endif
#if CUDA_VERSION >= 4000
      asyncEngineCount                  = ae,
      cacheMemL2                        = l2,
      maxThreadsPerMultiProcessor       = tm,
      memBusWidth                       = mw,
      memClockRate                      = mc,
      pciInfo                           = PCI pb pd pm,
      tccDriverEnabled                  = tcc,
      unifiedAddressing                 = ua,
#endif
      kernelExecTimeoutEnabled          = ke,
      integrated                        = tg,
      canMapHostMemory                  = hm
    }

#if CUDA_VERSION < 5000
-- Deprecated as of CUDA-5.0
{-# INLINE cuDeviceGetProperties #-}
{# fun unsafe cuDeviceGetProperties
  { alloca-   `CUDevProp' peek*
  , useDevice `Device'          } -> `Status' cToEnum #}
#endif

-- |
-- The total memory available on the device (bytes).
--
-- <http://docs.nvidia.com/cuda/cuda-driver-api/group__CUDA__DEVICE.html#group__CUDA__DEVICE_1gc6a0d6551335a3780f9f3c967a0fde5d>
--
{-# INLINEABLE totalMem #-}
totalMem :: Device -> IO Int64
totalMem !d = resultIfOk =<< cuDeviceTotalMem d

{-# INLINE cuDeviceTotalMem #-}
{# fun unsafe cuDeviceTotalMem
  { alloca-   `Int64'  peekIntConv*
  , useDevice `Device'              } -> `Status' cToEnum #}

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
#ifdef USE_EMPTY_CASE
{-# LANGUAGE EmptyCase                #-}
#endif
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Device
-- Copyright : [2009..2014] Trevor L. McDonell
-- License   : BSD
--
-- Device management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Device (

  -- * Device Management
  Device(..), -- should be exported abstractly
  DeviceProperties(..), DeviceAttribute(..), Compute(..), ComputeMode(..), InitFlag,
  initialise, capability, device, attribute, count, name, props, totalMem

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad                                    ( liftM )

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

newtype Device = Device { useDevice :: {# type CUdevice #}}
  deriving (Eq, Show)

-- |
-- Device attributes
--
{# enum CUdevice_attribute as DeviceAttribute
    { underscoreToCase
    , MAX as CU_DEVICE_ATTRIBUTE_MAX }          -- ignore
    with prefix="CU_DEVICE_ATTRIBUTE" deriving (Eq, Show) #}

{# pointer *CUdevprop as ^ foreign -> CUDevProp nocode #}

--
-- Properties of the compute device (internal helper)
--
data CUDevProp = CUDevProp
  {
    cuMaxThreadsPerBlock :: !Int,               -- Maximum number of threads per block
    cuMaxBlockSize       :: !(Int,Int,Int),     -- Maximum size of each dimension of a block
    cuMaxGridSize        :: !(Int,Int,Int),     -- Maximum size of each dimension of a grid
    cuSharedMemPerBlock  :: !Int64,             -- Shared memory available per block in bytes
    cuTotalConstMem      :: !Int64,             -- Constant memory available on device in bytes
    cuWarpSize           :: !Int,               -- Warp size in threads (SIMD width)
    cuMemPitch           :: !Int64,             -- Maximum pitch in bytes allowed by memory copies
    cuRegsPerBlock       :: !Int,               -- 32-bit registers available per block
    cuClockRate          :: !Int,               -- Clock frequency in kilohertz
    cuTextureAlignment   :: !Int64              -- Alignment requirement for textures
  }
  deriving (Show)

instance Storable CUDevProp where
  sizeOf _    = {#sizeof CUdevprop#}
  alignment _ = alignment (undefined :: Ptr ())

  poke _ _    = error "no instance for Foreign.Storable.poke DeviceProperties"
  peek p      = do
    tb <- cIntConv `fmap` {#get CUdevprop.maxThreadsPerBlock#} p
    sm <- cIntConv `fmap` {#get CUdevprop.sharedMemPerBlock#} p
    cm <- cIntConv `fmap` {#get CUdevprop.totalConstantMemory#} p
    ws <- cIntConv `fmap` {#get CUdevprop.SIMDWidth#} p
    mp <- cIntConv `fmap` {#get CUdevprop.memPitch#} p
    rb <- cIntConv `fmap` {#get CUdevprop.regsPerBlock#} p
    cl <- cIntConv `fmap` {#get CUdevprop.clockRate#} p
    ta <- cIntConv `fmap` {#get CUdevprop.textureAlign#} p

    [t1,t2,t3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxThreadsDim#} p
    [g1,g2,g3] <- peekArrayWith cIntConv 3 =<< {#get CUdevprop.maxGridSize#} p

    return CUDevProp
      {
        cuMaxThreadsPerBlock = tb,
        cuMaxBlockSize       = (t1,t2,t3),
        cuMaxGridSize        = (g1,g2,g3),
        cuSharedMemPerBlock  = sm,
        cuTotalConstMem      = cm,
        cuWarpSize           = ws,
        cuMemPitch           = mp,
        cuRegsPerBlock       = rb,
        cuClockRate          = cl,
        cuTextureAlignment   = ta
      }

-- |
-- Possible option flags for CUDA initialisation. Dummy instance until the API
-- exports actual option values.
--
data InitFlag
instance Enum InitFlag where
#ifdef USE_EMPTY_CASE
  toEnum   x = case x of {}
  fromEnum x = case x of {}
#endif

--------------------------------------------------------------------------------
-- Initialisation
--------------------------------------------------------------------------------

-- |
-- Initialise the CUDA driver API. Must be called before any other driver
-- function.
--
{-# INLINEABLE initialise #-}
initialise :: [InitFlag] -> IO ()
initialise !flags = nothingIfOk =<< cuInit flags

{-# INLINE cuInit #-}
{# fun unsafe cuInit
  { combineBitMasks `[InitFlag]' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Device Management
--------------------------------------------------------------------------------

-- |
-- Return the compute compatibility revision supported by the device
--
{-# INLINEABLE capability #-}
capability :: Device -> IO Compute
capability !dev =
  (\(!s,!a,!b) -> resultIfOk (s,Compute a b)) =<< cuDeviceComputeCapability dev

{-# INLINE cuDeviceComputeCapability #-}
{# fun unsafe cuDeviceComputeCapability
  { alloca-   `Int'    peekIntConv*
  , alloca-   `Int'    peekIntConv*
  , useDevice `Device'              } -> `Status' cToEnum #}

-- |
-- Return a device handle
--
{-# INLINEABLE device #-}
device :: Int -> IO Device
device !d = resultIfOk =<< cuDeviceGet d

{-# INLINE cuDeviceGet #-}
{# fun unsafe cuDeviceGet
  { alloca-  `Device' dev*
  , cIntConv `Int'           } -> `Status' cToEnum #}
  where dev = liftM Device . peek

-- |
-- Return the selected attribute for the given device
--
{-# INLINEABLE attribute #-}
attribute :: Device -> DeviceAttribute -> IO Int
attribute !d !a = resultIfOk =<< cuDeviceGetAttribute a d

{-# INLINE cuDeviceGetAttribute #-}
{# fun unsafe cuDeviceGetAttribute
  { alloca-   `Int'             peekIntConv*
  , cFromEnum `DeviceAttribute'
  , useDevice `Device'                       } -> `Status' cToEnum #}

-- |
-- Return the number of device with compute capability > 1.0
--
{-# INLINEABLE count #-}
count :: IO Int
count = resultIfOk =<< cuDeviceGetCount

{-# INLINE cuDeviceGetCount #-}
{# fun unsafe cuDeviceGetCount
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Name of the device
--
{-# INLINEABLE name #-}
name :: Device -> IO String
name !d = resultIfOk =<< cuDeviceGetName d

{-# INLINE cuDeviceGetName #-}
{# fun unsafe cuDeviceGetName
  { allocaS-  `String'& peekS*
  , useDevice `Device'         } -> `Status' cToEnum #}
  where
    len       = 512
    allocaS a = allocaBytes len $ \p -> a (p, cIntConv len)
    peekS s _ = peekCString s

-- |
-- Return the properties of the selected device
--

-- Annoyingly, the driver API requires several different functions to extract
-- all device properties that are part of a single structure in the runtime API
--
{-# INLINEABLE props #-}
props :: Device -> IO DeviceProperties
props !d = do
  p   <- resultIfOk =<< cuDeviceGetProperties d

  -- And the remaining properties
  --
  n   <- name d
  cc  <- capability d
  gm  <- totalMem d
  pc  <- attribute d MultiprocessorCount
  md  <- toEnum `fmap` attribute d ComputeMode
  ov  <- toBool `fmap` attribute d GpuOverlap
  ke  <- toBool `fmap` attribute d KernelExecTimeout
  tg  <- toBool `fmap` attribute d Integrated
  hm  <- toBool `fmap` attribute d CanMapHostMemory
#if CUDA_VERSION >= 3000
  ck  <- toBool `fmap` attribute d ConcurrentKernels
  ee  <- toBool `fmap` attribute d EccEnabled
  u1  <- attribute d MaximumTexture1dWidth
  u21 <- attribute d MaximumTexture2dWidth
  u22 <- attribute d MaximumTexture2dHeight
  u31 <- attribute d MaximumTexture3dWidth
  u32 <- attribute d MaximumTexture3dHeight
  u33 <- attribute d MaximumTexture3dDepth
#endif
#if CUDA_VERSION >= 4000
  ae  <- attribute d AsyncEngineCount
  l2  <- attribute d L2CacheSize
  tm  <- attribute d MaxThreadsPerMultiprocessor
  mw  <- attribute d GlobalMemoryBusWidth
  mc  <- attribute d MemoryClockRate
  pb  <- attribute d PciBusId
  pd  <- attribute d PciDeviceId
  pm  <- attribute d PciDomainId
  ua  <- toBool `fmap` attribute d UnifiedAddressing
  tcc <- toBool `fmap` attribute d TccDriver
#endif

  return DeviceProperties
    {
      deviceName                        = n,
      computeCapability                 = cc,
      totalGlobalMem                    = gm,
      totalConstMem                     = cuTotalConstMem p,
      sharedMemPerBlock                 = cuSharedMemPerBlock p,
      regsPerBlock                      = cuRegsPerBlock p,
      warpSize                          = cuWarpSize p,
      maxThreadsPerBlock                = cuMaxThreadsPerBlock p,
      maxBlockSize                      = cuMaxBlockSize p,
      maxGridSize                       = cuMaxGridSize p,
      clockRate                         = cuClockRate p,
      multiProcessorCount               = pc,
      memPitch                          = cuMemPitch p,
      textureAlignment                  = cuTextureAlignment p,
      computeMode                       = md,
      deviceOverlap                     = ov,
#if CUDA_VERSION >= 3000
      concurrentKernels                 = ck,
      eccEnabled                        = ee,
      maxTextureDim1D                   = u1,
      maxTextureDim2D                   = (u21,u22),
      maxTextureDim3D                   = (u31,u32,u33),
#endif
#if CUDA_VERSION >= 4000
      asyncEngineCount                  = ae,
      cacheMemL2                        = l2,
      maxThreadsPerMultiProcessor       = tm,
      memBusWidth                       = mw,
      memClockRate                      = mc,
      pciInfo                           = PCI pb pd pm,
      tccDriverEnabled                  = tcc,
      unifiedAddressing                 = ua,
#endif
      kernelExecTimeoutEnabled          = ke,
      integrated                        = tg,
      canMapHostMemory                  = hm
    }

{-# INLINE cuDeviceGetProperties #-}
{# fun unsafe cuDeviceGetProperties
  { alloca-   `CUDevProp' peek*
  , useDevice `Device'          } -> `Status' cToEnum #}

-- |
-- Total memory available on the device (bytes)
--
{-# INLINEABLE totalMem #-}
totalMem :: Device -> IO Int64
totalMem !d = resultIfOk =<< cuDeviceTotalMem d

{-# INLINE cuDeviceTotalMem #-}
{# fun unsafe cuDeviceTotalMem
  { alloca-   `Int64'  peekIntConv*
  , useDevice `Device'              } -> `Status' cToEnum #}