Export Histogram

Export Histogram

{-#LANGUAGE ForeignFunctionInterface#-}
#include "cvWrapLEO.h"
module CV.Histogram
    ( module CV.Histogram
    , I.Histogram
    ) where

import CV.Image
{#import CV.Image#}

import Data.List
import Data.Array
import Data.Array.ST
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import CV.Bindings.Types
import qualified CV.Bindings.ImgProc as I
import System.IO.Unsafe
import Utils.Pointer

-- import Utils.List

newtype HistogramData a = HGD [(a,a)]

-- | Given a set of images, such as the color channels of color image, and
--   a histogram with corresponding number of channels, replace the pixels of
--   the image with the likelihoods from the histogram
backProjectHistogram :: [Image GrayScale D8] -> I.Histogram -> Image GrayScale D8
backProjectHistogram images@(img:_) (I.Histogram hist) = unsafePerformIO $ do
    r <- cloneImage img
    withImage r $ \c_r ->
     withPtrList (map imageFPTR images) $ \ptrs ->
      withForeignPtr hist $ \c_hist ->
        I.c'cvCalcArrBackProject (castPtr ptrs) (castPtr c_r) c_hist
    return r
backProjectHistogram _ _ = error "Empty list of images"

-- | Calculate an opencv histogram object from set of images, each with it's
-- own number of bins.
histogram :: [(Image GrayScale D8, Int)] -> Bool -> Maybe (Image GrayScale D8)
               -> I.Histogram
histogram imageBins accumulate mask  = unsafePerformIO $
 I.creatingHistogram $ do
        hist <-  I.emptyUniformHistogramND ds
        withPtrList (map imageFPTR images) $ \ptrs ->
         case mask of
            Just m -> do
                withImage m $ \c_mask -> do
                I.c'cvCalcArrHist (castPtr ptrs) hist c_accumulate (castPtr c_mask)
                return hist
            Nothing -> do
                I.c'cvCalcArrHist (castPtr ptrs) hist c_accumulate (nullPtr)
                return hist
   where
    (images,ds) = unzip imageBins
    c_accumulate = 0

-- getHistogramBin (I.Histogram hs) n = unsafePerformIO $ withForeignPtr hs (\h -> I.c'cvGetHistValue_1D (castPtr h) n)

---- Assume [0,1] distribution and calculate skewness
--skewness bins image = do
--                 hg <- buildHistogram cbins image
--                 bins <-  mapM (getBin hg) [0..cbins-1]
--                 let avg = sum bins / (fromIntegral.length) bins
--                 let u3 = sum.map (\(value,bin) ->
--                                     (value-avg)*(value-avg)*(value-avg)
--                                     *bin) $
--                            zip binValues bins
--                 let u2 = sum.map (\(value,bin) ->
--                                     (value-avg)*(value-avg)
--                                     *bin) $
--                            zip binValues bins
----
--                 return (u3 / (sqrt u2*sqrt u2*sqrt u2))
--                where
--                 cbins :: CInt
--                 cbins = fromIntegral bins
--                 binValues = [0,fstep..1]
--                 fstep = 1/(fromIntegral bins)

values (HGD a) = snd.unzip $ a

-- This does not make any sense!
cmpUnion a b = sum $ zipWith (max) a b

cmpIntersect a b = sum $ zipWith min a b

cmpEuclidian a b = sum $ (zipWith (\x y -> (x-y)^2) a b)
cmpAbs a b = sum $ (zipWith (\x y -> abs (x-y)) a b)

chiSqrHG  a b = chiSqr (values a) (values b)
chiSqr a b = sum $ zipWith (calc) a b
    where
     calc a b = (a-b)*(a-b) `divide` (a+b)
     divide a b | abs(b) > 0.000001 = a/b
                | otherwise = 0

liftBins op (HGD a) = zip (op bins) values
            where (bins,values) = unzip a

liftValues op (HGD a) = zip bins (op values)
            where (bins,values) = unzip a

sub (HGD a) (HGD b) | bins a == bins b
                    = HGD $ zip (bins a) values
                where
                 bins a = map fst a
                 msnd = map snd
                 values = zipWith (-) (msnd a) (msnd b)

noBins (HGD a) = length a

getPositivePart (HGD a) = HGD $ dropWhile ((<0).fst) a
tcumulate [] = []
tcumulate values = tail $ scanl (+) 0 values

--getCumulativeNormalHistogram binCount image
--    = HGD $ zip bins $ tcumulate values
--    where
--        HGD lst = getNormalHistogram binCount image
--        bins :: [Double]
--        values :: [Double]
--        (bins,values) = unzip lst

weightedHistogram img weights start end binCount = unsafePerformIO $
    withImage img $ \i ->
     withImage weights $ \w -> do
      bins <- mallocArray (fromIntegral binCount)
      {#call get_weighted_histogram#} i w (realToFrac start)
                                          (realToFrac end)
                                          (fromIntegral binCount) bins
      r <- peekArray binCount bins >>= return.map realToFrac
      free bins
      return r

-- TODO: Add binary images
simpleGetHistogram :: Image GrayScale D32 -> Maybe (Image GrayScale D8)
                       -> D32 -> D32 -> Int -> Bool -> [D32]
simpleGetHistogram img mask start end binCount cumulative = unsafePerformIO $
    withImage img $ \i -> do
      bins <- mallocArray binCount
      let isCum | cumulative == True  = 1
                | cumulative == False = 0

      case mask of
        (Just msk) -> do
                   withImage msk $ \m -> do
                    {#call get_histogram#} i m (realToFrac start) (realToFrac end)
                                               isCum (fromIntegral binCount) bins
        Nothing  -> {#call get_histogram#} i (nullPtr)
                                             (realToFrac start) (realToFrac end)
                                             isCum (fromIntegral binCount) bins

      r <- peekArray binCount bins >>= return.map realToFrac
      free bins
      return r

--getNormalHistogram bins image = HGD new
--    where
--        (HGD lst) = getHistogram bins image
----
----        value :: [Double]
--        bin   :: [Double]
--        (bin,value) = unzip lst
--        new = zip bin $ map (/size) value
--        size = fromIntegral $ uncurry (*) $ getSize image

--getHistogram :: Int -> Image GrayScale D32 -> HistogramData Double
--getHistogram bins image = unsafePerformIO $ do
--                            h <- buildHistogram cbins image
--                            values <- mapM (getBin h)
--                                        [0..fromIntegral bins-1]
--                            return.HGD $
--                                zip [-1,-1+2/(realToFrac bins)..1] values
--                        where
--                         cbins = fromIntegral bins

{-#LANGUAGE ForeignFunctionInterface#-}
#include "cvWrapLEO.h"
module CV.Histogram where

import CV.Image
{#import CV.Image#}

import Data.List
import Data.Array
import Data.Array.ST
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import CV.Bindings.Types
import qualified CV.Bindings.ImgProc as I
import System.IO.Unsafe
import Utils.Pointer

-- import Utils.List

newtype HistogramData a = HGD [(a,a)]

-- | Given a set of images, such as the color channels of color image, and
--   a histogram with corresponding number of channels, replace the pixels of
--   the image with the likelihoods from the histogram
backProjectHistogram :: [Image GrayScale D8] -> I.Histogram -> Image GrayScale D8
backProjectHistogram images@(img:_) (I.Histogram hist) = unsafePerformIO $ do
    r <- cloneImage img
    withImage r $ \c_r ->
     withPtrList (map imageFPTR images) $ \ptrs ->
      withForeignPtr hist $ \c_hist ->
        I.c'cvCalcArrBackProject (castPtr ptrs) (castPtr c_r) c_hist
    return r
backProjectHistogram _ _ = error "Empty list of images"

-- | Calculate an opencv histogram object from set of images, each with it's
-- own number of bins.
histogram :: [(Image GrayScale D8, Int)] -> Bool -> Maybe (Image GrayScale D8)
               -> I.Histogram
histogram imageBins accumulate mask  = unsafePerformIO $
 I.creatingHistogram $ do
        hist <-  I.emptyUniformHistogramND ds
        withPtrList (map imageFPTR images) $ \ptrs ->
         case mask of
            Just m -> do
                withImage m $ \c_mask -> do
                I.c'cvCalcArrHist (castPtr ptrs) hist c_accumulate (castPtr c_mask)
                return hist
            Nothing -> do
                I.c'cvCalcArrHist (castPtr ptrs) hist c_accumulate (nullPtr)
                return hist
   where
    (images,ds) = unzip imageBins
    c_accumulate = 0

-- getHistogramBin (I.Histogram hs) n = unsafePerformIO $ withForeignPtr hs (\h -> I.c'cvGetHistValue_1D (castPtr h) n)

---- Assume [0,1] distribution and calculate skewness
--skewness bins image = do
--                 hg <- buildHistogram cbins image
--                 bins <-  mapM (getBin hg) [0..cbins-1]
--                 let avg = sum bins / (fromIntegral.length) bins
--                 let u3 = sum.map (\(value,bin) ->
--                                     (value-avg)*(value-avg)*(value-avg)
--                                     *bin) $
--                            zip binValues bins
--                 let u2 = sum.map (\(value,bin) ->
--                                     (value-avg)*(value-avg)
--                                     *bin) $
--                            zip binValues bins
----
--                 return (u3 / (sqrt u2*sqrt u2*sqrt u2))
--                where
--                 cbins :: CInt
--                 cbins = fromIntegral bins
--                 binValues = [0,fstep..1]
--                 fstep = 1/(fromIntegral bins)

values (HGD a) = snd.unzip $ a

-- This does not make any sense!
cmpUnion a b = sum $ zipWith (max) a b

cmpIntersect a b = sum $ zipWith min a b

cmpEuclidian a b = sum $ (zipWith (\x y -> (x-y)^2) a b)
cmpAbs a b = sum $ (zipWith (\x y -> abs (x-y)) a b)

chiSqrHG  a b = chiSqr (values a) (values b)
chiSqr a b = sum $ zipWith (calc) a b
    where
     calc a b = (a-b)*(a-b) `divide` (a+b)
     divide a b | abs(b) > 0.000001 = a/b
                | otherwise = 0

liftBins op (HGD a) = zip (op bins) values
            where (bins,values) = unzip a

liftValues op (HGD a) = zip bins (op values)
            where (bins,values) = unzip a

sub (HGD a) (HGD b) | bins a == bins b
                    = HGD $ zip (bins a) values
                where
                 bins a = map fst a
                 msnd = map snd
                 values = zipWith (-) (msnd a) (msnd b)

noBins (HGD a) = length a

getPositivePart (HGD a) = HGD $ dropWhile ((<0).fst) a
tcumulate [] = []
tcumulate values = tail $ scanl (+) 0 values

--getCumulativeNormalHistogram binCount image
--    = HGD $ zip bins $ tcumulate values
--    where
--        HGD lst = getNormalHistogram binCount image
--        bins :: [Double]
--        values :: [Double]
--        (bins,values) = unzip lst

weightedHistogram img weights start end binCount = unsafePerformIO $
    withImage img $ \i ->
     withImage weights $ \w -> do
      bins <- mallocArray (fromIntegral binCount)
      {#call get_weighted_histogram#} i w (realToFrac start)
                                          (realToFrac end)
                                          (fromIntegral binCount) bins
      r <- peekArray binCount bins >>= return.map realToFrac
      free bins
      return r

-- TODO: Add binary images
simpleGetHistogram :: Image GrayScale D32 -> Maybe (Image GrayScale D8)
                       -> D32 -> D32 -> Int -> Bool -> [D32]
simpleGetHistogram img mask start end binCount cumulative = unsafePerformIO $
    withImage img $ \i -> do
      bins <- mallocArray binCount
      let isCum | cumulative == True  = 1
                | cumulative == False = 0

      case mask of
        (Just msk) -> do
                   withImage msk $ \m -> do
                    {#call get_histogram#} i m (realToFrac start) (realToFrac end)
                                               isCum (fromIntegral binCount) bins
        Nothing  -> {#call get_histogram#} i (nullPtr)
                                             (realToFrac start) (realToFrac end)
                                             isCum (fromIntegral binCount) bins

      r <- peekArray binCount bins >>= return.map realToFrac
      free bins
      return r

--getNormalHistogram bins image = HGD new
--    where
--        (HGD lst) = getHistogram bins image
----
----        value :: [Double]
--        bin   :: [Double]
--        (bin,value) = unzip lst
--        new = zip bin $ map (/size) value
--        size = fromIntegral $ uncurry (*) $ getSize image

--getHistogram :: Int -> Image GrayScale D32 -> HistogramData Double
--getHistogram bins image = unsafePerformIO $ do
--                            h <- buildHistogram cbins image
--                            values <- mapM (getBin h)
--                                        [0..fromIntegral bins-1]
--                            return.HGD $
--                                zip [-1,-1+2/(realToFrac bins)..1] values
--                        where
--                         cbins = fromIntegral bins


variable grouping

variable grouping

{-#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

{-#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)

--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


fix type of memset, and minor tidy up

fix type of memset, and minor tidy up

Ignore-this: 6cb278c8bcd50b703e9476f9837254fb

darcs-hash:20090720021953-115f9-192fea0cb1be6f0533e817c91809c3df21b6243a.gz

{-
 - Haskell bindings to the CUDA library
 -
 - This uses the higher-level "C for CUDA" interface and runtime API, which
 - itself is implemented with the lower-level driver API.
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Runtime
  (
    --
    -- Thread management
    --
    threadSynchronize,

    --
    -- Device management
    --
    chooseDevice,
    getDevice,
    getDeviceCount,
    getDeviceProperties,
    setDevice,
    setDeviceFlags,
    setValidDevices,

    --
    -- Memory management
    --
    malloc, mallocPitch,
    memcpy, memcpyAsync,
    memset,

    --
    -- Stream management
    --
    streamCreate,
    streamDestroy,
    streamQuery,
    streamSynchronize
  ) where

import Foreign.CUDA.Types
import Foreign.CUDA.Utils

import Foreign.CUDA.Internal.C2HS hiding (malloc)

#include <cuda_runtime_api.h>
{#context lib="cudart" prefix="cuda"#}

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

--------------------------------------------------------------------------------
-- Thread Management
--------------------------------------------------------------------------------

--
-- Block until the device has completed all preceding requests
--
threadSynchronize :: IO (Maybe String)
threadSynchronize =  nothingIfOk `fmap` cudaThreadSynchronize

{# fun unsafe cudaThreadSynchronize
    { } -> `Status' cToEnum #}

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

--
-- Select compute device which best matches criteria
--
chooseDevice     :: DeviceProperties -> IO (Either String Int)
chooseDevice dev =  resultIfOk `fmap` cudaChooseDevice dev

{# fun unsafe cudaChooseDevice
    { alloca-      `Int'              peekIntConv* ,
      withDevProp* `DeviceProperties'              } -> `Status' cToEnum #}
    where
        withDevProp = with

--
-- Returns which device is currently being used
--
getDevice :: IO (Either String Int)
getDevice =  resultIfOk `fmap` cudaGetDevice

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

--
-- Returns the number of compute-capable devices
--
getDeviceCount :: IO (Either String Int)
getDeviceCount =  resultIfOk `fmap` cudaGetDeviceCount

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

--
-- Return information about the selected compute device
--
getDeviceProperties   :: Int -> IO (Either String DeviceProperties)
getDeviceProperties n =  resultIfOk `fmap` cudaGetDeviceProperties n

{# fun unsafe cudaGetDeviceProperties
    { alloca- `DeviceProperties' peek* ,
              `Int'                    } -> `Status' cToEnum #}

--
-- Set device to be used for GPU execution
--
setDevice   :: Int -> IO (Maybe String)
setDevice n =  nothingIfOk `fmap` cudaSetDevice n

{# fun unsafe cudaSetDevice
    { `Int' } -> `Status' cToEnum #}

--
-- Set flags to be used for device executions
--
setDeviceFlags   :: [DeviceFlags] -> IO (Maybe String)
setDeviceFlags f =  nothingIfOk `fmap` cudaSetDeviceFlags (combineBitMasks f)

{# fun unsafe cudaSetDeviceFlags
    { `Int' } -> `Status' cToEnum #}

--
-- Set list of devices for CUDA execution in priority order
--
setValidDevices   :: [Int] -> IO (Maybe String)
setValidDevices l =  nothingIfOk `fmap` cudaSetValidDevices l (length l)

{# fun unsafe cudaSetValidDevices
    { withArrayIntConv* `[Int]' ,
                        `Int'   } -> `Status' cToEnum #}
    where
        withArrayIntConv = withArray . map cIntConv

--------------------------------------------------------------------------------
-- Memory Management
--------------------------------------------------------------------------------

--
-- Allocate the specified number of bytes in linear memory on the device. The
-- memory is suitably aligned for any kind of variable, and is not cleared.
--
-- If the allocation is successful, it is marked to be automatically released
-- when no longer needed.
--
malloc       :: Integer -> IO (Either String DevicePtr)
malloc bytes = do
    (rv,ptr) <- cudaMalloc bytes
    case rv of
        Success -> doAutoRelease cudaFree_ >>= \fp ->
                   newDevicePtr fp ptr     >>= (return.Right)
        _       -> return.Left $ getErrorString rv

{# fun unsafe cudaMalloc
    { alloca-  `Ptr ()'  peek* ,
      cIntConv `Integer'       } -> `Status' cToEnum #}

--
-- Allocate pitched memory on the device
--
mallocPitch              :: Integer -> Integer -> IO (Either String (DevicePtr,Integer))
mallocPitch width height =  do
    (rv,ptr,pitch) <- cudaMallocPitch width height
    case rv of
        Success -> doAutoRelease cudaFree_ >>= \fp ->
                   newDevicePtr fp ptr     >>= \dp -> return.Right $ (dp,pitch)
        _       -> return.Left $ getErrorString rv

{# fun unsafe cudaMallocPitch
    { alloca-  `Ptr ()'  peek*        ,
      alloca-  `Integer' peekIntConv* ,
      cIntConv `Integer'              ,
      cIntConv `Integer'              } -> `Status' cToEnum #}

--
-- Free previously allocated memory on the device
--
cudaFree_   :: Ptr () -> IO ()
cudaFree_ p =  throwIf_ (/= Success) (getErrorString) (cudaFree p)

{# fun unsafe cudaFree
    { id `Ptr ()' } -> `Status' cToEnum #}

foreign import ccall "wrapper"
    doAutoRelease   :: (Ptr () -> IO ()) -> IO (FunPtr (Ptr () -> IO ()))

--
-- Copy data between host and device
--
memcpy :: DevicePtr -> DevicePtr -> Integer -> CopyDirection -> IO (Maybe String)
memcpy dst src bytes dir =  nothingIfOk `fmap` cudaMemcpy dst src bytes dir

{# fun unsafe cudaMemcpy
    { withDevicePtr* `DevicePtr'     ,
      withDevicePtr* `DevicePtr'     ,
      cIntConv       `Integer'       ,
      cFromEnum      `CopyDirection' } -> `Status' cToEnum #}

--
-- Copy data between host and device asynchronously
--
memcpyAsync :: DevicePtr -> DevicePtr -> Integer -> CopyDirection -> Stream -> IO (Maybe String)
memcpyAsync dst src bytes dir stream =  nothingIfOk `fmap` cudaMemcpyAsync dst src bytes dir stream

{# fun unsafe cudaMemcpyAsync
    { withDevicePtr* `DevicePtr'     ,
      withDevicePtr* `DevicePtr'     ,
      cIntConv       `Integer'       ,
      cFromEnum      `CopyDirection' ,
      cIntConv       `Stream'        } -> `Status' cToEnum #}

--
-- Initialize device memory to a given value
--
memset                  :: DevicePtr -> Int -> Integer -> IO (Maybe String)
memset ptr symbol bytes =  nothingIfOk `fmap` cudaMemset ptr bytes symbol

{# fun unsafe cudaMemset
    { withDevicePtr* `DevicePtr' ,
                     `Int'       ,
      cIntConv       `Integer'   } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Stream Management
--------------------------------------------------------------------------------

--
-- Create an asynchronous stream
--
streamCreate :: IO (Either String Stream)
streamCreate =  resultIfOk `fmap` cudaStreamCreate

{# fun unsafe cudaStreamCreate
    { alloca- `Stream' peek* } -> `Status' cToEnum #}

--
-- Destroy and clean up an asynchronous stream
--
streamDestroy   :: Stream -> IO (Maybe String)
streamDestroy s =  nothingIfOk `fmap` cudaStreamDestroy s

{# fun unsafe cudaStreamDestroy
    { cIntConv `Stream' } -> `Status' cToEnum #}

--
-- Determine if all operations in a stream have completed
--
streamQuery   :: Stream -> IO (Either String Bool)
streamQuery s = cudaStreamQuery s >>= \rv -> do
    return $ case rv of
        Success  -> Right True
        NotReady -> Right False
        _        -> Left (getErrorString rv)

{# fun unsafe cudaStreamQuery
    { cIntConv `Stream' } -> `Status' cToEnum #}

--
-- Block until all operations have been completed
--
streamSynchronize   :: Stream -> IO (Maybe String)
streamSynchronize s =  nothingIfOk `fmap` cudaStreamSynchronize s

{# fun unsafe cudaStreamSynchronize
    { cIntConv `Stream' } -> `Status' cToEnum #}

{-
 - Haskell bindings to the CUDA library
 -
 - This uses the higher-level "C for CUDA" interface and runtime API, which
 - itself is implemented with the lower-level driver API.
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Runtime
  (
    --
    -- Thread management
    --
    threadSynchronize,

    --
    -- Device management
    --
    chooseDevice,
    getDevice,
    getDeviceCount,
    getDeviceProperties,
    setDevice,
    setDeviceFlags,
    setValidDevices,

    --
    -- Memory management
    --
    malloc, mallocPitch,
    memcpy, memcpyAsync,
    memset,

    --
    -- Stream management
    --
    streamCreate,
    streamDestroy,
    streamQuery,
    streamSynchronize
  ) where

import Foreign.CUDA.Types
import Foreign.CUDA.Utils

import Foreign.CUDA.Internal.C2HS hiding (malloc)

#include <cuda_runtime_api.h>
{#context lib="cudart" prefix="cuda"#}

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

--------------------------------------------------------------------------------
-- Thread Management
--------------------------------------------------------------------------------

--
-- Block until the device has completed all preceding requests
--
threadSynchronize :: IO (Maybe String)
threadSynchronize =  nothingIfOk `fmap` cudaThreadSynchronize

{# fun unsafe cudaThreadSynchronize
    { } -> `Status' cToEnum #}

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

--
-- Select compute device which best matches criteria
--
chooseDevice     :: DeviceProperties -> IO (Either String Int)
chooseDevice dev =  resultIfOk `fmap` cudaChooseDevice dev

{# fun unsafe cudaChooseDevice
    { alloca-      `Int'              peekIntConv* ,
      withDevProp* `DeviceProperties'              } -> `Status' cToEnum #}
    where
        withDevProp = with

--
-- Returns which device is currently being used
--
getDevice :: IO (Either String Int)
getDevice =  resultIfOk `fmap` cudaGetDevice

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

--
-- Returns the number of compute-capable devices
--
getDeviceCount :: IO (Either String Int)
getDeviceCount =  resultIfOk `fmap` cudaGetDeviceCount

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

--
-- Return information about the selected compute device
--
getDeviceProperties   :: Int -> IO (Either String DeviceProperties)
getDeviceProperties n =  resultIfOk `fmap` cudaGetDeviceProperties n

{# fun unsafe cudaGetDeviceProperties
    { alloca- `DeviceProperties' peek* ,
              `Int'                    } -> `Status' cToEnum #}

--
-- Set device to be used for GPU execution
--
setDevice   :: Int -> IO (Maybe String)
setDevice n =  nothingIfOk `fmap` cudaSetDevice n

{# fun unsafe cudaSetDevice
    { `Int' } -> `Status' cToEnum #}

--
-- Set flags to be used for device executions
--
setDeviceFlags   :: [DeviceFlags] -> IO (Maybe String)
setDeviceFlags f =  nothingIfOk `fmap` cudaSetDeviceFlags (combineBitMasks f)

{# fun unsafe cudaSetDeviceFlags
    { `Int' } -> `Status' cToEnum #}

--
-- Set list of devices for CUDA execution in priority order
--
setValidDevices   :: [Int] -> IO (Maybe String)
setValidDevices l =  nothingIfOk `fmap` cudaSetValidDevices l (length l)

{# fun unsafe cudaSetValidDevices
    { withArrayIntConv* `[Int]' ,
                        `Int'   } -> `Status' cToEnum #}
    where
        withArrayIntConv = withArray . map cIntConv

--------------------------------------------------------------------------------
-- Memory Management
--------------------------------------------------------------------------------

--
-- Allocate the specified number of bytes in linear memory on the device. The
-- memory is suitably aligned for any kind of variable, and is not cleared.
--
-- If the allocation is successful, it is marked to be automatically released
-- when no longer needed.
--
malloc       :: Integer -> IO (Either String DevicePtr)
malloc bytes = do
    (rv,ptr) <- cudaMalloc bytes
    case rv of
        Success -> doAutoRelease cudaFree_ >>= \fp ->
                   newDevicePtr fp ptr >>= (return.Right)
        _       -> return.Left $ getErrorString rv

{# fun unsafe cudaMalloc
    { alloca-  `Ptr ()'  peek* ,
      cIntConv `Integer'       } -> `Status' cToEnum #}

--
-- Allocate pitched memory on the device
--
mallocPitch              :: Integer -> Integer -> IO (Either String (DevicePtr,Integer))
mallocPitch width height =  do
    (rv,ptr,pitch) <- cudaMallocPitch width height
    case rv of
        Success -> doAutoRelease cudaFree_ >>= \fp ->
                   newDevicePtr fp ptr >>= \dp -> return.Right $ (dp,pitch)
        _       -> return.Left $ getErrorString rv

{# fun unsafe cudaMallocPitch
    { alloca-  `Ptr ()' peek*         ,
      alloca-  `Integer' peekIntConv* ,
      cIntConv `Integer'              ,
      cIntConv `Integer'              } -> `Status' cToEnum #}

--
-- Free previously allocated memory on the device
--
cudaFree_   :: Ptr () -> IO ()
cudaFree_ p =  throwIf_ (/= Success) (getErrorString) (cudaFree p)

{# fun unsafe cudaFree
    { id `Ptr ()' } -> `Status' cToEnum #}

foreign import ccall "wrapper"
    doAutoRelease   :: (Ptr () -> IO ()) -> IO (FunPtr (Ptr () -> IO ()))

--
-- Copy data between host and device
--
memcpy :: DevicePtr -> DevicePtr -> Integer -> CopyDirection -> IO (Maybe String)
memcpy dst src bytes dir =  nothingIfOk `fmap` cudaMemcpy dst src bytes dir

{# fun unsafe cudaMemcpy
    { withDevicePtr* `DevicePtr'     ,
      withDevicePtr* `DevicePtr'     ,
      cIntConv       `Integer'       ,
      cFromEnum      `CopyDirection' } -> `Status' cToEnum #}

--
-- Copy data between host and device asynchronously
--
memcpyAsync :: DevicePtr -> DevicePtr -> Integer -> CopyDirection -> Stream -> IO (Maybe String)
memcpyAsync dst src bytes dir stream =  nothingIfOk `fmap` cudaMemcpyAsync dst src bytes dir stream

{# fun unsafe cudaMemcpyAsync
    { withDevicePtr* `DevicePtr'     ,
      withDevicePtr* `DevicePtr'     ,
      cIntConv       `Integer'       ,
      cFromEnum      `CopyDirection' ,
      cIntConv       `Stream'        } -> `Status' cToEnum #}

--
-- Initialize device memory to a given value
--
memset                  :: DevicePtr -> Integer -> Int -> IO (Maybe String)
memset ptr symbol bytes =  nothingIfOk `fmap` cudaMemset ptr bytes symbol

{# fun unsafe cudaMemset
    { withDevicePtr* `DevicePtr' ,
                     `Int'       ,
      cIntConv       `Integer'   } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Stream Management
--------------------------------------------------------------------------------

--
-- Create an asynchronous stream
--
streamCreate :: IO (Either String Stream)
streamCreate =  resultIfOk `fmap` cudaStreamCreate

{# fun unsafe cudaStreamCreate
    { alloca- `Stream' peek* } -> `Status' cToEnum #}

--
-- Destroy and clean up an asynchronous stream
--
streamDestroy   :: Stream -> IO (Maybe String)
streamDestroy s =  nothingIfOk `fmap` cudaStreamDestroy s

{# fun unsafe cudaStreamDestroy
    { cIntConv `Stream' } -> `Status' cToEnum #}

--
-- Determine if all operations in a stream have completed
--
streamQuery   :: Stream -> IO (Either String Bool)
streamQuery s = cudaStreamQuery s >>= \rv -> do
    return $ case rv of
        Success  -> Right True
        NotReady -> Right False
        _        -> Left (getErrorString rv)

{# fun unsafe cudaStreamQuery
    { cIntConv `Stream' } -> `Status' cToEnum #}

--
-- Block until all operations have been completed
--
streamSynchronize   :: Stream -> IO (Maybe String)
streamSynchronize s =  nothingIfOk `fmap` cudaStreamSynchronize s

{# fun unsafe cudaStreamSynchronize
    { cIntConv `Stream' } -> `Status' cToEnum #}


cuddAutydynDisable

cuddAutydynDisable

{-#LANGUAGE ForeignFunctionInterface #-}

module CuddReorder (
    CuddReorderingType(..),
    cuddReorderingStatus,
    cuddAutodynEnable,
    cuddAutodynDisable,
    cuddReduceHeap,
    cuddMakeTreeNode,
    cuddReadReorderingTime,
    cuddReadReorderings,
    cuddEnableReorderingReporting,
    cuddDisableReorderingReporting,
    cuddReorderingReporting,
    regStdPreReordHook,
    regStdPostReordHook,
    cuddTurnOnCountDead,
    cuddTurnOffCountDead,
    cuddDeadAreCounted,
    cuddReadSiftMaxSwap,
    cuddSetSiftMaxSwap,
    cuddReadNextReordering,
    cuddSetNextReordering,
    cuddReadMaxGrowthAlternate,
    cuddSetMaxGrowthAlternate,
    cuddReadMaxGrowth,
    cuddReadReorderingCycle,
    cuddSetReorderingCycle,
    cuddSetPopulationSize,
    cuddReadNumberXovers,
    cuddSetNumberXovers,
    regReordGCHook
    ) where

import System.IO
import System.Mem
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 safe "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 safe "cudd.h Cudd_AutodynEnable"
	c_cuddAutodynEnable :: Ptr CDdManager -> CInt -> IO ()

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

foreign import ccall safe "cudd.h Cudd_AutodynDisable"
	c_cuddAutodynDisable :: Ptr CDdManager -> IO ()

cuddAutodynDisable :: DdManager -> IO ()
cuddAutodynDisable (DdManager m) = c_cuddAutodynDisable m

--Reorder right now
foreign import ccall safe "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 safe "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 safe "cudd.h Cudd_ReadReorderingTime"
	c_cuddReadReorderingTime :: Ptr CDdManager -> IO (CLong)

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

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

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

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

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

foreign import ccall safe "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 safe "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 safe "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 safe "cudd.h Cudd_TurnOffCountDead"
	c_cuddTurnOffCountDead :: Ptr CDdManager -> IO ()

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

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

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

foreign import ccall safe "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 safe "cudd.h Cudd_ReadSiftMaxSwap"
	c_cuddReadSiftMaxSwap :: Ptr CDdManager -> IO (CInt)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

reordGCHook :: HookTyp
reordGCHook _ _ _ = do
    --putStrLn "reordGCHook"
    performGC
    --putStrLn "gc done"
    return (fromIntegral 1)

foreign import ccall "wrapper"
    makeFunPtr :: HookTyp -> IO (FunPtr HookTyp)

regReordGCHook :: DdManager -> IO Int
regReordGCHook m = do
    hk <- makeFunPtr reordGCHook
    cuddAddHook m hk CuddPreReorderingHook

{-#LANGUAGE ForeignFunctionInterface #-}

module CuddReorder (
    CuddReorderingType(..),
    cuddReorderingStatus,
    cuddAutodynEnable,
    cuddReduceHeap,
    cuddMakeTreeNode,
    cuddReadReorderingTime,
    cuddReadReorderings,
    cuddEnableReorderingReporting,
    cuddDisableReorderingReporting,
    cuddReorderingReporting,
    regStdPreReordHook,
    regStdPostReordHook,
    cuddTurnOnCountDead,
    cuddTurnOffCountDead,
    cuddDeadAreCounted,
    cuddReadSiftMaxSwap,
    cuddSetSiftMaxSwap,
    cuddReadNextReordering,
    cuddSetNextReordering,
    cuddReadMaxGrowthAlternate,
    cuddSetMaxGrowthAlternate,
    cuddReadMaxGrowth,
    cuddReadReorderingCycle,
    cuddSetReorderingCycle,
    cuddSetPopulationSize,
    cuddReadNumberXovers,
    cuddSetNumberXovers,
    regReordGCHook
    ) where

import System.IO
import System.Mem
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 safe "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 safe "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 safe "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 safe "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 safe "cudd.h Cudd_ReadReorderingTime"
	c_cuddReadReorderingTime :: Ptr CDdManager -> IO (CLong)

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

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

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

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

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

foreign import ccall safe "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 safe "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 safe "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 safe "cudd.h Cudd_TurnOffCountDead"
	c_cuddTurnOffCountDead :: Ptr CDdManager -> IO ()

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

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

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

foreign import ccall safe "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 safe "cudd.h Cudd_ReadSiftMaxSwap"
	c_cuddReadSiftMaxSwap :: Ptr CDdManager -> IO (CInt)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

reordGCHook :: HookTyp
reordGCHook _ _ _ = do
    --putStrLn "reordGCHook"
    performGC
    --putStrLn "gc done"
    return (fromIntegral 1)

foreign import ccall "wrapper"
    makeFunPtr :: HookTyp -> IO (FunPtr HookTyp)

regReordGCHook :: DdManager -> IO Int
regReordGCHook m = do
    hk <- makeFunPtr reordGCHook
    cuddAddHook m hk CuddPreReorderingHook