Added CV.Transforms.gaussianPyramid

Added CV.Transforms.gaussianPyramid

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
-- |Various image transformations from opencv and other sources.
module CV.Transforms  where

import CV.Image
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp

-- |Since DCT is valid only for even sized images, we provide a
-- function to crop images to even sizes.
takeEvenSized img = getRegion (0,0) (w-wadjust,h-hadjust) img
    where
     (w,h) = getSize img
     hadjust | odd h = 1
             | otherwise = 2
     wadjust | odd w = 1
             | otherwise = 2

-- |Perform Discrete Cosine Transform
dct :: Image GrayScale d -> Image GrayScale d
dct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 0)
        | otherwise = error "DCT needs even sized image"

-- |Perform Inverse Discrete Cosine Transform
idct :: Image GrayScale d -> Image GrayScale d
idct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 1)
        | otherwise = error "IDCT needs even sized image"

data MirrorAxis = Vertical | Horizontal deriving (Show,Eq)

-- |Mirror an image over a cardinal axis
flip :: CreateImage (Image c d) => MirrorAxis -> Image c d -> Image c d
flip axis img = unsafePerformIO $ do
                 let cl = emptyCopy img
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

-- |Rotate `img` `angle` radians.
rotate :: Double -> Image c d -> Image c d
rotate (realToFrac -> angle) img = unsafePerformIO $
                    withImage img $ \i ->
                        creatingImage
                         ({#call rotateImage#} i 1 angle)

data Interpolation = NearestNeighbour | Linear
                   | Area | Cubic
                deriving (Eq,Ord,Enum,Show)

-- |Simulate a radial distortion over an image
radialDistort :: Image GrayScale D32 -> Double -> Image GrayScale D32
radialDistort img k = unsafePerformIO $ do
                       let target = emptyCopy img
                       withImage img $ \cimg ->
                        withImage target $ \ctarget ->
                         {#call radialRemap#} cimg ctarget (realToFrac k)
                       return target

-- |Scale image by one ratio on both of the axes
scaleSingleRatio tpe x img = scale tpe (x,x) img

-- |Scale an image with different ratios for axes
scale :: (CreateImage (Image c D32), RealFloat a) => Interpolation -> (a,a) -> Image c D32 -> Image c D32
scale tpe (x,y) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (w,h) = getSize img
             (w',h') = (round $ fromIntegral w*y
                       ,round $ fromIntegral h*x)

-- |Scale an image to a given size
scaleToSize :: (CreateImage (Image c D32)) =>
    Interpolation -> Bool -> (Int,Int) -> Image c D32 -> Image c D32
scaleToSize tpe retainRatio (w,h) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (ow,oh) = getSize img
             (w',h') = if retainRatio
                         then (floor $ fromIntegral ow*ratio,floor $ fromIntegral oh*ratio)
                         else (w,h)
             ratio  = max (fromIntegral w/fromIntegral ow)
                          (fromIntegral h/fromIntegral oh)

-- |Apply a perspective transform to the image. The transformation 3x3 matrix is supplied as
--  a row ordered, flat, list.
perspectiveTransform :: Real a => Image c d -> [a] -> Image c d
perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

-- |Find a homography between two sets of points in. The resulting 3x3 matrix is returned as a list.
getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = map realToFrac . concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

--- Pyramid transforms
-- |Return a copy of an image with an even size
evenize :: Image channels depth -> Image channels depth
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

-- |Return a copy of an image with an odd size
oddize :: Image channels depth -> Image channels depth
oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

-- |Pad images to same size
sameSizePad :: Image channels depth -> Image c d -> Image channels depth
sameSizePad img img2 = if (size1 /= size2)
              then unsafePerformIO $ do
                r <- creatingImage $
                       withGenImage img2 $ \cImg -> {#call padUp#} cImg (toI $ w2<w1) (toI $ h2<h1)
                if getSize r /= getSize img
                    then error ("Couldn't pad: "++show size1++"/"++show size2)
                    else return r
              else img
    where
     toI True = 1
     toI False = 0
     size1@(w1,h1)  = getSize img
     size2@(w2,h2)  = getSize img2

cv_Gaussian = 7
-- |Downsize image by 50% efficiently. Image dimensions must be even.
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

-- |Enlarge image to double in each dimension. Used to recover pyramidal layers
pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

-- TODO: For additional efficiency, make this so that pyrDown result is directly put into
--       proper size image which is then padded
safePyrDown img = evenize result
    where
     result = pyrDown img
     (w,h)  = getSize result

-- | Enlargen the image so that its size is a power of two.
minEnlarge :: Image GrayScale D32 -> Image GrayScale D32
minEnlarge i = enlargeShadow (min (ceiling (logBase 2 (f w))) (ceiling (logBase 2 (f h)))) i
    where
     f = fromIntegral
     (w,h) = getSize i

-- | Calculate an infinite gaussian pyramid of an image while keeping track of
--   various corner cases and gotchas.
gaussianPyramid :: Image GrayScale D32 -> [Image GrayScale D32]
gaussianPyramid = iterate pyrDown' . minEnlarge
    where
     pyrDown' i = let (w,h) = getSize i
                  in if (w`div`2) <=1 || (h`div`2) <= 1 then i else pyrDown i

-- |Calculate the laplacian pyramid of an image up to the nth level.
--  Notice that the image size must be divisible by 2^n or opencv
--  will abort (TODO!)
laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

-- |Reconstruct an image from a laplacian pyramid
reconstructFromLaplacian :: [Image GrayScale D32] -> Image GrayScale D32
reconstructFromLaplacian pyramid = foldl1 (\a b -> (pyrUp a) #+ b) (pyramid)
  --  where
  --   safeAdd x y = sameSizePad y x #+ y

-- TODO: Could have wider type
-- |Enlargen the image so that its size is divisible by 2^n. Fill the area
--  outside the image with black.
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

-- | Enlargen the image so that its size is is divisible by 2^n. Replicate
--   the border of the image.
enlargeShadow :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlargeShadow n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   withImage img $ \c_img ->
                    withImage i  $ \c_i   -> {#call blitShadow#} c_i c_img
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
     C =  CV_DIST_C
    ,L1 =  CV_DIST_L1
    ,L2 =  CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

#ifdef OpenCV24
#c
enum LabelType {
     DIST_LABEL_CCOMP = CV_DIST_LABEL_CCOMP
    ,DIST_LABEL_PIXEL = CV_DIST_LABEL_PIXEL
};
#endc
{#enum LabelType {}#}
#endif

-- |Mask sizes accepted by distanceTransform
data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show)

-- |Perform a distance transform on the image
distanceTransform :: DistanceType -> MaskSize -> Image GrayScale D8 -> Image GrayScale D32 --TODO: Input should be a black and white image
distanceTransform dtype maskSize source = unsafePerformIO $ do
    result :: Image GrayScale D32 <- create (getSize source)
    withGenImage source $ \c_source ->
     withGenImage result $ \c_result ->
        {#call cvDistTransform #} c_source c_result
                                  (fromIntegral . fromEnum $ dtype)
                                  (fromIntegral . fromEnum $ maskSize)
                                   nullPtr nullPtr
#ifdef OpenCV24
                                   (fromIntegral . fromEnum $ DIST_LABEL_CCOMP)
#endif
    return result
    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
-- |Various image transformations from opencv and other sources.
module CV.Transforms  where

import CV.Image
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp

-- |Since DCT is valid only for even sized images, we provide a
-- function to crop images to even sizes.
takeEvenSized img = getRegion (0,0) (w-wadjust,h-hadjust) img
    where
     (w,h) = getSize img
     hadjust | odd h = 1
             | otherwise = 2
     wadjust | odd w = 1
             | otherwise = 2

-- |Perform Discrete Cosine Transform
dct :: Image GrayScale d -> Image GrayScale d
dct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 0)
        | otherwise = error "DCT needs even sized image"

-- |Perform Inverse Discrete Cosine Transform
idct :: Image GrayScale d -> Image GrayScale d
idct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 1)
        | otherwise = error "IDCT needs even sized image"

data MirrorAxis = Vertical | Horizontal deriving (Show,Eq)

-- |Mirror an image over a cardinal axis
flip :: CreateImage (Image c d) => MirrorAxis -> Image c d -> Image c d
flip axis img = unsafePerformIO $ do
                 let cl = emptyCopy img
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

-- |Rotate `img` `angle` radians.
rotate :: Double -> Image c d -> Image c d
rotate (realToFrac -> angle) img = unsafePerformIO $
                    withImage img $ \i ->
                        creatingImage
                         ({#call rotateImage#} i 1 angle)

data Interpolation = NearestNeighbour | Linear
                   | Area | Cubic
                deriving (Eq,Ord,Enum,Show)

-- |Simulate a radial distortion over an image
radialDistort :: Image GrayScale D32 -> Double -> Image GrayScale D32
radialDistort img k = unsafePerformIO $ do
                       let target = emptyCopy img
                       withImage img $ \cimg ->
                        withImage target $ \ctarget ->
                         {#call radialRemap#} cimg ctarget (realToFrac k)
                       return target

-- |Scale image by one ratio on both of the axes
scaleSingleRatio tpe x img = scale tpe (x,x) img

-- |Scale an image with different ratios for axes
scale :: (CreateImage (Image c D32), RealFloat a) => Interpolation -> (a,a) -> Image c D32 -> Image c D32
scale tpe (x,y) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (w,h) = getSize img
             (w',h') = (round $ fromIntegral w*y
                       ,round $ fromIntegral h*x)

-- |Scale an image to a given size
scaleToSize :: (CreateImage (Image c D32)) =>
    Interpolation -> Bool -> (Int,Int) -> Image c D32 -> Image c D32
scaleToSize tpe retainRatio (w,h) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (ow,oh) = getSize img
             (w',h') = if retainRatio
                         then (floor $ fromIntegral ow*ratio,floor $ fromIntegral oh*ratio)
                         else (w,h)
             ratio  = max (fromIntegral w/fromIntegral ow)
                          (fromIntegral h/fromIntegral oh)

-- |Apply a perspective transform to the image. The transformation 3x3 matrix is supplied as
--  a row ordered, flat, list.
perspectiveTransform :: Real a => Image c d -> [a] -> Image c d
perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

-- |Find a homography between two sets of points in. The resulting 3x3 matrix is returned as a list.
getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = map realToFrac . concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

--- Pyramid transforms
-- |Return a copy of an image with an even size
evenize :: Image channels depth -> Image channels depth
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

-- |Return a copy of an image with an odd size
oddize :: Image channels depth -> Image channels depth
oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

-- |Pad images to same size
sameSizePad :: Image channels depth -> Image c d -> Image channels depth
sameSizePad img img2 = if (size1 /= size2)
              then unsafePerformIO $ do
                r <- creatingImage $
                       withGenImage img2 $ \cImg -> {#call padUp#} cImg (toI $ w2<w1) (toI $ h2<h1)
                if getSize r /= getSize img
                    then error ("Couldn't pad: "++show size1++"/"++show size2)
                    else return r
              else img
    where
     toI True = 1
     toI False = 0
     size1@(w1,h1)  = getSize img
     size2@(w2,h2)  = getSize img2

cv_Gaussian = 7
-- |Downsize image by 50% efficiently. Image dimensions must be even.
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

-- |Enlarge image to double in each dimension. Used to recover pyramidal layers
pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

-- TODO: For additional efficiency, make this so that pyrDown result is directly put into
--       proper size image which is then padded
safePyrDown img = evenize result
    where
     result = pyrDown img
     (w,h)  = getSize result

-- |Calculate the laplacian pyramid of an image up to the nth level.
--  Notice that the image size must be divisible by 2^n or opencv
--  will abort (TODO!)
laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

-- |Reconstruct an image from a laplacian pyramid
reconstructFromLaplacian :: [Image GrayScale D32] -> Image GrayScale D32
reconstructFromLaplacian pyramid = foldl1 (\a b -> (pyrUp a) #+ b) (pyramid)
  --  where
  --   safeAdd x y = sameSizePad y x #+ y

-- TODO: Could have wider type
-- |Enlargen the image so that its size is divisible by 2^n. Fill the area
--  outside the image with black.
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

-- | Enlargen the image so that its size is is divisible by 2^n. Replicate
--   the border of the image.
enlargeShadow :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlargeShadow n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   withImage img $ \c_img ->
                    withImage i  $ \c_i   -> {#call blitShadow#} c_i c_img
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
     C =  CV_DIST_C
    ,L1 =  CV_DIST_L1
    ,L2 =  CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

#ifdef OpenCV24
#c
enum LabelType {
     DIST_LABEL_CCOMP = CV_DIST_LABEL_CCOMP
    ,DIST_LABEL_PIXEL = CV_DIST_LABEL_PIXEL
};
#endc
{#enum LabelType {}#}
#endif

-- |Mask sizes accepted by distanceTransform
data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show)

-- |Perform a distance transform on the image
distanceTransform :: DistanceType -> MaskSize -> Image GrayScale D8 -> Image GrayScale D32 --TODO: Input should be a black and white image
distanceTransform dtype maskSize source = unsafePerformIO $ do
    result :: Image GrayScale D32 <- create (getSize source)
    withGenImage source $ \c_source ->
     withGenImage result $ \c_result ->
        {#call cvDistTransform #} c_source c_result
                                  (fromIntegral . fromEnum $ dtype)
                                  (fromIntegral . fromEnum $ maskSize)
                                   nullPtr nullPtr
#ifdef OpenCV24
                                   (fromIntegral . fromEnum $ DIST_LABEL_CCOMP)
#endif
    return result
    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks


Implement exponential backoff in polling hyperclient_loop

{-# LANGUAGE ViewPatterns #-}

module Database.HyperDex.Internal.Client
  ( Hyperclient, Client
  , ConnectInfo (..)
  , defaultConnectInfo
  , ConnectOptions (..)
  , defaultConnectOptions
  , BackoffMethod (..)
  , Handle
  , Result, AsyncResult, AsyncResultHandle
  , connect, close
  , loopClient, loopClientUntil
  , withClient, withClientImmediate
  )
  where

{# import Database.HyperDex.Internal.ReturnCode #}
import Database.HyperDex.Internal.Util

import Data.Maybe

import Data.Map (Map)
import qualified Data.Map as Map

import Control.Concurrent (yield, threadDelay)
import Control.Concurrent.MVar

import Data.Word (Word16)

import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as Text (pack)

import Data.Default

import Debug.Trace

#include "hyperclient.h"

{#pointer *hyperclient as Hyperclient #}

-- | Parameters for connecting to a HyperDex cluster.
data ConnectInfo =
  ConnectInfo
    { connectHost :: String
    , connectPort :: Word16
    , connectOptions :: ConnectOptions
    }
  deriving (Eq, Read, Show)

instance Default ConnectInfo where
  def =
    ConnectInfo
      { connectHost = "127.0.0.1"
      , connectPort = 1982
      , connectOptions = def
      }

defaultConnectInfo :: ConnectInfo
defaultConnectInfo = def

-- | Additional options for connecting and managing the connection
-- to a HyperDex cluster.
data ConnectOptions =
  ConnectOptions
    { backoff :: BackoffMethod
    , backoffCap :: Maybe Int
    }
  deriving (Eq, Read, Show)

instance Default ConnectOptions where
  def =
    ConnectOptions
      { backoff = BackoffExponential 10 2 -- 10 * 2^n
      , backoffCap = Just 500000          -- Half a second.
      }

-- | Sane defaults for HyperDex connection options.
defaultConnectOptions :: ConnectOptions
defaultConnectOptions = def

-- | A backoff method controls how frequently the client polls internally.
--
-- This is provided to allow fine-tuning performance. Do note that
-- this does not affect any method the HyperClient C library uses to poll
-- its connection to a HyperDex cluster.
--
-- All integer values are in microseconds.
data BackoffMethod
  -- | No delay is used except the thread is yielded.
  = BackoffYield
  -- | Delay a constant number of microseconds each inter.
  | BackoffConstant Int
  -- | Delay with an initial number of microseconds, increasing linearly by the second value.
  | BackoffLinear Int Int
  -- | Delay with an initial number of microseconds, increasing exponentially by the second value.
  | BackoffExponential Int Double
  deriving (Eq, Read, Show)

type HyperclientWrapper = MVar (Maybe Hyperclient, Map Handle (IO ()))

data ClientData =
  ClientData
    { hyperclientWrapper :: HyperclientWrapper
    , connectionInfo     :: ConnectInfo
    }

-- | A connection to a HyperDex cluster.
newtype Client = Client { unClientData :: ClientData }

-- | Internal method for returning the (MVar) wrapped connection.
getClient :: Client -> HyperclientWrapper
getClient = hyperclientWrapper . unClientData

-- | Get the connection info used for a 'Client'.
getConnectInfo :: Client -> ConnectInfo
getConnectInfo = connectionInfo . unClientData

-- | Get the connection options for a 'Client'.
getConnectOptions :: Client -> ConnectOptions
getConnectOptions = connectOptions . getConnectInfo

-- | Return value from hyperclient operations.
--
-- Per the specification, it's guaranteed to be a unique integer for
-- each outstanding operation using a given HyperClient. In practice
-- it is monotonically increasing while operations are outstanding,
-- lower values are used first, and negative values represent an
-- error.
type Handle = {# type int64_t #}

-- | A return value from HyperDex.
type Result a = IO (Either ReturnCode a)

-- | A return value used internally by HyperClient operations.
--
-- Internally the wrappers to the HyperDex library will return
-- a computation that yields a 'Handle' referring to that request
-- and a continuation that will force the request to return an
-- error in the form of a ReturnCode or a result.
--
-- The result of forcing the result is undefined.
-- The HyperClient and its workings are not party to the MVar locking
-- mechanism, and the ReturnCode and/or return value may be in the
-- process of being modified when the computation is forced.
--
-- Consequently, the only safe way to use this is with a wrapper such
-- as 'withClient', which only allows the continuation to be run after
-- the HyperClient has returned the corresponding Handle or after the
-- HyperClient has been destroyed.
type AsyncResultHandle a = IO (Handle, Result a)

-- | A return value from HyperDex in an asynchronous wrapper.
--
-- The full type is an IO (IO (Either ReturnCode a)). Evaluating
-- the result of an asynchronous call, such as the default get and
-- put operations starts the request to the HyperDex cluster. Evaluating
-- the result of that evaluation will poll internally, using the
-- connection's 'BackoffMethod' until the result is available.
--
-- This API may be deprecated in favor of exclusively using MVars in
-- a future version.
type AsyncResult a = IO (Result a)

-- | Connect to a HyperDex cluster.
connect :: ConnectInfo -> IO Client
connect info = do
  hyperclient <- hyperclientCreate (encodeUtf8 . Text.pack . connectHost $ info) (connectPort info)
  clientData <- newMVar (Just hyperclient, Map.empty)
  return $
    Client
    $ ClientData
      { hyperclientWrapper = clientData
      , connectionInfo = info
      }

-- | Close a connection and terminate any outstanding asynchronous
-- requests.
--
-- /Note:/ This does force all asynchronous requests to complete
-- immediately. Any outstanding requests at the time the 'Client'
-- is closed ought to return a 'ReturnCode' indicating the failure
-- condition, but the behavior is ultimately undefined. Any pending
-- requests should be disregarded.
close :: Client -> IO ()
close (getClient -> c) = do
  clientData <- takeMVar c
  case clientData of
    (Nothing, _)        -> error "HyperDex client error - cannot close a client connection twice."
    (Just hc, handles)  -> do
      hyperclientDestroy hc
      sequence_ $ Map.elems handles
      putMVar c (Nothing, Map.empty)

doExponentialBackoff :: Int -> Double -> (Int, BackoffMethod)
doExponentialBackoff b x =
  let result = ceiling (fromIntegral b ** x) in
    (result, BackoffExponential result x)

cappedBackoff :: Int -> Maybe Int -> (Int, Bool)
cappedBackoff n Nothing = (n, False)
cappedBackoff n (Just c) | n  < c  = (n, False)
                         | n >= c  = (c, True)

performBackoff :: BackoffMethod -> Maybe Int -> IO (BackoffMethod)
performBackoff method cap = do
  let (delay, newBackoff) = case method of
            BackoffYield      -> (0, method)
            BackoffConstant n -> (0, method)
            BackoffLinear m b -> (m, BackoffLinear (m+b) b)
            BackoffExponential b x -> doExponentialBackoff b x
      (backoff, capped) = cappedBackoff delay cap
  let delay = case backoff of
                0 -> yield
                n -> threadDelay n
      next  = case capped of
                True  -> BackoffConstant backoff
                False -> newBackoff
  delay >> return next

-- | Runs hyperclient_loop exactly once, setting the appropriate MVar.
loopClient' :: Bool -> Client -> IO (Maybe Handle)
loopClient' debug client@(getClient -> c) = do
  clientData <- takeMVar c
  case clientData of
    (Nothing, _)        -> return Nothing
    (Just hc, handles)  -> do
      -- TODO: Examine returnCode for things that might matter.
      (handle, returnCode) <- hyperclientLoop hc 0
      case returnCode of
        HyperclientSuccess -> do
          if debug
            then traceIO $ "Recovering from failure, returncode: " ++ show returnCode
            else return ()
          fromMaybe (return ()) $ Map.lookup handle handles
          putMVar c (Just hc, Map.delete handle handles)
          return $ Just handle
        HyperclientTimeout -> do
          putMVar c (Just hc, handles)
          loopClient' False client
        HyperclientNonepending -> do
          sequence_ $ Map.elems handles
          putMVar c (Just hc, Map.empty)
          return $ Just handle
        _ -> do
          traceIO $ "Encountered " ++ show returnCode
          putMVar c (Just hc, handles)
          loopClient' True client

loopClient :: Client -> IO (Maybe Handle)
loopClient = loopClient' False

-- | Run hyperclient_loop at most N times or forever until a handle
-- is returned.
loopClientUntil :: Client -> BackoffMethod -> Handle -> Maybe Int -> MVar (Either ReturnCode a) -> IO (Bool)
loopClientUntil _      _    _ (Just 0) _ = return False

loopClientUntil client back h (Just n) v = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential backoff or some other approach for polling
      case clientData of
        (Nothing, _)       -> return True
        (Just _, handles)  -> do
          case Map.member h handles of
            False -> return True
            True  -> do
              back' <- performBackoff back (backoffCap . getConnectOptions $ client)
              loopClientUntil client back' h (Just $ n - 1) v
    False -> return True

loopClientUntil client back h (Nothing) v = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential backoff or some other approach for polling
      case clientData of
        (Nothing, _)       -> return False
        (Just _, handles)  -> do
          case Map.member h handles of
            False -> return True
            True  -> do
              back' <- performBackoff back (backoffCap . getConnectOptions $ client)
              loopClientUntil client back' h (Nothing) v
    False -> return True

-- | Peek at the value of an 'MVar' and return its contents if full.
--
-- /Note:/ This isn't truly a reliable way of performing this operation
-- as between the 'tryTakeMVar' and the 'putMVar', another thread could
-- perform the 'putMVar'. However, it is implicitly guaranteed that the
-- internal API will never have multiple-writer contention on the
-- 'HyperclientWrapper'. Every operation performs a 'TakeMVar' before a
-- 'PutMVar', and the surface area is small enough to guarantee that.
--
-- Per 'Control.Concurrent.MVar', this function is only atomic if there
-- are no other producers for this 'MVar'.
peekMVar :: MVar a -> IO (Maybe a)
peekMVar m = do
  res <- tryTakeMVar m
  case res of
    Just r  -> do
      putMVar m r
      return $ Just r
    Nothing -> return $ Nothing

-- | Wrap a HyperClient request and wait until completion or failure.
withClientImmediate :: Client -> (Hyperclient -> IO a) -> IO a
withClientImmediate (getClient -> c) f =
  withMVar c $ \value -> do
    case value of
      (Nothing, _) -> error "HyperDex client error - cannot use a closed connection."
      (Just hc, _) -> f hc

-- | Wrap a Hyperclient request.
withClient :: Client -> (Hyperclient -> AsyncResultHandle a) -> AsyncResult a
withClient client@(getClient -> c) f = do
  value <- takeMVar c
  case value of
    (Nothing, _)        -> error "HyperDex client error - cannot use a closed connection."
    (Just hc, handles)  -> do
      (h, cont) <- f hc
      case h > 0 of
        True  -> do
          v <- newEmptyMVar :: IO (MVar (Either ReturnCode a))
          putMVar c (Just hc, Map.insert h (cont >>= putMVar v) handles)
          return $ do
            _ <- loopClientUntil client (backoff . getConnectOptions $ client) h Nothing v
            res <- peekMVar v
            return $ fromMaybe (error "This should not occur!") res
        False -> do
          putMVar c (Just hc, handles)
          return cont

-- | C wrapper for hyperclient_create. Creates a HyperClient given a host
-- and a port.
--
-- C definition:
--
-- > struct hyperclient*
-- > hyperclient_create(const char* coordinator, uint16_t port);
hyperclientCreate :: ByteString -> Word16 -> IO Hyperclient
hyperclientCreate h port = withCBString h $ \host -> {# call hyperclient_create #} host (fromIntegral port)

-- | C wrapper for hyperclient_destroy. Destroys a HyperClient.
--
-- /Note:/ This does not ensure resources are freed. Any memory
-- allocated as staging for incomplete requests will not be returned.
--
-- C definition:
--
-- > void
-- > hyperclient_destroy(struct hyperclient* client);
hyperclientDestroy :: Hyperclient -> IO ()
hyperclientDestroy client = do
  {# call hyperclient_destroy #} client

-- | C wrapper for hyperclient_loop. Waits up to some number of
-- milliseconds for a result before returning.
--
-- A negative 'Handle' return value indicates a failure condition
-- or timeout, a positive value indicates completion of an asynchronous
-- request.
--
-- C definition:
--
-- > int64_t
-- > hyperclient_loop(struct hyperclient* client, int timeout,
-- >                  enum hyperclient_returncode* status);
hyperclientLoop :: Hyperclient -> Int -> IO (Handle, ReturnCode)
hyperclientLoop client timeout =
  alloca $ \returnCodePtr -> do
    handle <- {# call hyperclient_loop #} client (fromIntegral timeout) returnCodePtr
    returnCode <- fmap (toEnum . fromIntegral) $ peek returnCodePtr
    return (handle, returnCode)

{-# LANGUAGE ViewPatterns #-}

module Database.HyperDex.Internal.Client
  ( Hyperclient, Client
  , ConnectInfo (..)
  , defaultConnectInfo
  , ConnectOptions (..)
  , defaultConnectOptions
  , BackoffMethod (..)
  , Handle
  , Result, AsyncResult, AsyncResultHandle
  , connect, close
  , loopClient, loopClientUntil
  , withClient, withClientImmediate
  )
  where

{# import Database.HyperDex.Internal.ReturnCode #}
import Database.HyperDex.Internal.Util

import Data.Maybe

import Data.Map (Map)
import qualified Data.Map as Map

import Control.Concurrent.MVar

import Data.Word (Word16)

import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as Text (pack)

import Data.Default

import Debug.Trace

#include "hyperclient.h"

{#pointer *hyperclient as Hyperclient #}

-- | Parameters for connecting to a HyperDex cluster.
data ConnectInfo =
  ConnectInfo
    { connectHost :: String
    , connectPort :: Word16
    , connectOptions :: ConnectOptions
    }
  deriving (Eq, Read, Show)

instance Default ConnectInfo where
  def =
    ConnectInfo
      { connectHost = "127.0.0.1"
      , connectPort = 1982
      , connectOptions = def
      }

defaultConnectInfo :: ConnectInfo
defaultConnectInfo = def

-- | Additional options for connecting and managing the connection
-- to a HyperDex cluster.
data ConnectOptions =
  ConnectOptions
    { backoff :: BackoffMethod
    , backoffCap :: Maybe Int
    }
  deriving (Eq, Read, Show)

instance Default ConnectOptions where
  def =
    ConnectOptions
      { backoff = BackoffExponential 10 2 -- 10 * 2^n
      , backoffCap = Just 500000          -- Half a second.
      }

-- | Sane defaults for HyperDex connection options.
defaultConnectOptions :: ConnectOptions
defaultConnectOptions = def

-- | A backoff method controls how frequently the client polls internally.
--
-- This is provided to allow fine-tuning performance. Do note that
-- this does not affect any method the HyperClient C library uses to poll
-- its connection to a HyperDex cluster.
--
-- All integer values are in microseconds.
data BackoffMethod
  -- | No delay is used and the connection is polled until completion or failure.
  = BackoffNone
  -- | Delay a constant number of microseconds each inter.
  | BackoffConstant Int
  -- | Delay with an initial number of microseconds, increasing linearly by the second value.
  | BackoffLinear Int Int
  -- | Delay with an initial number of microseconds, increasing exponentially by the second value.
  | BackoffExponential Int Double
  deriving (Eq, Read, Show)

type HyperclientWrapper = MVar (Maybe Hyperclient, Map Handle (IO ()))

data ClientData =
  ClientData
    { hyperclientWrapper :: HyperclientWrapper
    , connectionInfo     :: ConnectInfo
    }

-- | A connection to a HyperDex cluster.
newtype Client = Client { unClientData :: ClientData }

-- | Internal method for returning the (MVar) wrapped connection.
getClient :: Client -> HyperclientWrapper
getClient = hyperclientWrapper . unClientData

-- | Return value from hyperclient operations.
--
-- Per the specification, it's guaranteed to be a unique integer for
-- each outstanding operation using a given HyperClient. In practice
-- it is monotonically increasing while operations are outstanding,
-- lower values are used first, and negative values represent an
-- error.
type Handle = {# type int64_t #}

-- | A return value from HyperDex.
type Result a = IO (Either ReturnCode a)

-- | A return value used internally by HyperClient operations.
--
-- Internally the wrappers to the HyperDex library will return
-- a computation that yields a 'Handle' referring to that request
-- and a continuation that will force the request to return an
-- error in the form of a ReturnCode or a result.
--
-- The result of forcing the result is undefined.
-- The HyperClient and its workings are not party to the MVar locking
-- mechanism, and the ReturnCode and/or return value may be in the
-- process of being modified when the computation is forced.
--
-- Consequently, the only safe way to use this is with a wrapper such
-- as 'withClient', which only allows the continuation to be run after
-- the HyperClient has returned the corresponding Handle or after the
-- HyperClient has been destroyed.
type AsyncResultHandle a = IO (Handle, Result a)

-- | A return value from HyperDex in an asynchronous wrapper.
--
-- The full type is an IO (IO (Either ReturnCode a)). Evaluating
-- the result of an asynchronous call, such as the default get and
-- put operations starts the request to the HyperDex cluster. Evaluating
-- the result of that evaluation will poll internally, using the
-- connection's 'BackoffMethod' until the result is available.
--
-- This API may be deprecated in favor of exclusively using MVars in
-- a future version.
type AsyncResult a = IO (Result a)

-- | Connect to a HyperDex cluster.
connect :: ConnectInfo -> IO Client
connect info = do
  hyperclient <- hyperclientCreate (encodeUtf8 . Text.pack . connectHost $ info) (connectPort info)
  clientData <- newMVar (Just hyperclient, Map.empty)
  return $
    Client
    $ ClientData
      { hyperclientWrapper = clientData
      , connectionInfo = info
      }

-- | Close a connection and terminate any outstanding asynchronous
-- requests.
--
-- /Note:/ This does force all asynchronous requests to complete
-- immediately. Any outstanding requests at the time the 'Client'
-- is closed ought to return a 'ReturnCode' indicating the failure
-- condition, but the behavior is ultimately undefined. Any pending
-- requests should be disregarded.
close :: Client -> IO ()
close (getClient -> c) = do
  clientData <- takeMVar c
  case clientData of
    (Nothing, _)        -> error "HyperDex client error - cannot close a client connection twice."
    (Just hc, handles)  -> do
      hyperclientDestroy hc
      sequence_ $ Map.elems handles
      putMVar c (Nothing, Map.empty)

-- | Runs hyperclient_loop exactly once, setting the appropriate MVar.
loopClient' :: Bool -> Client -> IO (Maybe Handle)
loopClient' debug client@(getClient -> c) = do
  clientData <- takeMVar c
  case clientData of
    (Nothing, _)        -> return Nothing
    (Just hc, handles)  -> do
      -- TODO: Examine returnCode for things that might matter.
      (handle, returnCode) <- hyperclientLoop hc 0
      case returnCode of
        HyperclientSuccess -> do
          if debug
            then traceIO $ "Recovering from failure, returncode: " ++ show returnCode
            else return ()
          fromMaybe (return ()) $ Map.lookup handle handles
          putMVar c (Just hc, Map.delete handle handles)
          return $ Just handle
        HyperclientTimeout -> do
          putMVar c (Just hc, handles)
          loopClient' False client
        HyperclientNonepending -> do
          sequence_ $ Map.elems handles
          putMVar c (Just hc, Map.empty)
          return $ Just handle
        _ -> do
          traceIO $ "Encountered " ++ show returnCode
          putMVar c (Just hc, handles)
          loopClient' True client

loopClient :: Client -> IO (Maybe Handle)
loopClient = loopClient' False

-- | Run hyperclient_loop at most N times or forever until a handle
-- is returned.
loopClientUntil :: Client -> Handle -> Maybe Int -> MVar (Either ReturnCode a) -> IO (Bool)
loopClientUntil _      _ (Just 0) _ = return False

loopClientUntil client h (Just n) v = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential backoff or some other approach for polling
      case clientData of
        (Nothing, _)       -> return True
        (Just _, handles)  -> do
          case Map.member h handles of
            False -> return True
            True  -> loopClientUntil client h (Just $ n - 1) v
    False -> return True

loopClientUntil client h (Nothing) v = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential backoff or some other approach for polling
      case clientData of
        (Nothing, _)       -> return False
        (Just _, handles)  -> do
          case Map.member h handles of
            False -> return True
            True  -> loopClientUntil client h (Nothing) v
    False -> return True

-- | Peek at the value of an 'MVar' and return its contents if full.
--
-- /Note:/ This isn't truly a reliable way of performing this operation
-- as between the 'tryTakeMVar' and the 'putMVar', another thread could
-- perform the 'putMVar'. However, it is implicitly guaranteed that the
-- internal API will never have multiple-writer contention on the
-- 'HyperclientWrapper'. Every operation performs a 'TakeMVar' before a
-- 'PutMVar', and the surface area is small enough to guarantee that.
--
-- Per 'Control.Concurrent.MVar', this function is only atomic if there
-- are no other producers for this 'MVar'.
peekMVar :: MVar a -> IO (Maybe a)
peekMVar m = do
  res <- tryTakeMVar m
  case res of
    Just r  -> do
      putMVar m r
      return $ Just r
    Nothing -> return $ Nothing

-- | Wrap a HyperClient request and wait until completion or failure.
withClientImmediate :: Client -> (Hyperclient -> IO a) -> IO a
withClientImmediate (getClient -> c) f =
  withMVar c $ \value -> do
    case value of
      (Nothing, _) -> error "HyperDex client error - cannot use a closed connection."
      (Just hc, _) -> f hc

-- | Wrap a Hyperclient request.
withClient :: Client -> (Hyperclient -> AsyncResultHandle a) -> AsyncResult a
withClient client@(getClient -> c) f = do
  value <- takeMVar c
  case value of
    (Nothing, _)        -> error "HyperDex client error - cannot use a closed connection."
    (Just hc, handles)  -> do
      (h, cont) <- f hc
      case h > 0 of
        True  -> do
          v <- newEmptyMVar :: IO (MVar (Either ReturnCode a))
          putMVar c (Just hc, Map.insert h (cont >>= putMVar v) handles)
          return $ do
            _ <- loopClientUntil client h Nothing v
            res <- peekMVar v
            return $ fromMaybe (error "This should not occur!") res
        False -> do
          putMVar c (Just hc, handles)
          return cont

-- | C wrapper for hyperclient_create. Creates a HyperClient given a host
-- and a port.
--
-- C definition:
--
-- > struct hyperclient*
-- > hyperclient_create(const char* coordinator, uint16_t port);
hyperclientCreate :: ByteString -> Word16 -> IO Hyperclient
hyperclientCreate h port = withCBString h $ \host -> {# call hyperclient_create #} host (fromIntegral port)

-- | C wrapper for hyperclient_destroy. Destroys a HyperClient.
--
-- /Note:/ This does not ensure resources are freed. Any memory
-- allocated as staging for incomplete requests will not be returned.
--
-- C definition:
--
-- > void
-- > hyperclient_destroy(struct hyperclient* client);
hyperclientDestroy :: Hyperclient -> IO ()
hyperclientDestroy client = do
  {# call hyperclient_destroy #} client

-- | C wrapper for hyperclient_loop. Waits up to some number of
-- milliseconds for a result before returning.
--
-- A negative 'Handle' return value indicates a failure condition
-- or timeout, a positive value indicates completion of an asynchronous
-- request.
--
-- C definition:
--
-- > int64_t
-- > hyperclient_loop(struct hyperclient* client, int timeout,
-- >                  enum hyperclient_returncode* status);
hyperclientLoop :: Hyperclient -> Int -> IO (Handle, ReturnCode)
hyperclientLoop client timeout =
  alloca $ \returnCodePtr -> do
    handle <- {# call hyperclient_loop #} client (fromIntegral timeout) returnCodePtr
    returnCode <- fmap (toEnum . fromIntegral) $ peek returnCodePtr
    return (handle, returnCode)


error strings exist in constant memory, and is thus pure

Ignore-this: 4cd0d5bd1f8c86be933726d10f2f6984

darcs-hash:20090718051315-115f9-8fcfe986c7ab69a603777cf92f1e48324476a0f9.gz

{-
 - Utilities
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Utils
  (
    getErrorString, resultIfOk, nothingIfOk
  )
  where

import Foreign.CUDA.Types

import Foreign.CUDA.Internal.C2HS

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

--------------------------------------------------------------------------------
-- Error Handling
--------------------------------------------------------------------------------

--
-- Return the descriptive string associated with a particular error code.
-- Logically, this must a pure function, returning a pointer to a statically
-- defined string constant.
--
{# fun pure unsafe GetErrorString as ^
    { cFromEnum `Result' } -> `String' #}

resultIfOk :: (Result, a) -> Either String a
resultIfOk (status,result) =
    case status of
        Success -> Right result
        _       -> Left (getErrorString status)

nothingIfOk :: Result -> Maybe String
nothingIfOk = nothingIf (/= Success) getErrorString

{-
 - Utilities
 -}

{-# LANGUAGE ForeignFunctionInterface #-}

module Foreign.CUDA.Utils
  (
    resultIfSuccess, nothingIfSuccess
  )
  where

import Foreign.CUDA.Types

import Foreign.CUDA.Internal.C2HS

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

--------------------------------------------------------------------------------
-- Error Handling
--------------------------------------------------------------------------------

--
-- Return the descriptive string associated with a particular error code
--
{# fun unsafe GetErrorString as ^
    { cFromEnum `Result' } -> `String' #}

resultIfSuccess :: (Result, a) -> IO (Either String a)
resultIfSuccess (status,result) =
    case status of
        Success -> (return.Right) result
        _       -> getErrorString status >>= (return.Left)

nothingIfSuccess :: Result -> IO (Maybe String)
nothingIfSuccess status =
    case status of
        Success -> return Nothing
        _       -> getErrorString status >>= (return.Just)


Remove a type signature of 'withBDD', since recent version of c2hs automatically generate it.

-- -*- haskell -*-- -----------------------------------------------
-- |
-- Module      :  Data.Boolean.CUDD
-- Copyright   :  (C) 2002-2005, 2009 University of New South Wales, (C) 2009-2011 Peter Gammie
-- License     :  LGPL (see COPYING.LIB for details)
--
-- A binding for CUDD (Fabio Somenzi, University of Colorado).
--
-- Note this library is not thread-safe.
-------------------------------------------------------------------
module Data.Boolean.CUDD
    (
        BDD
    ,	module Data.Boolean

        -- * CUDD-specific functions
--          ,	gc
    ,	stats
    ,	reorder
    ,	dynamicReordering
    ,	varIndices
    ,	bddSize
    ,	printInfo
    ) where

-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------

#include "cudd_im.h"

import Control.DeepSeq  ( NFData )
import Control.Monad	( foldM, liftM, mapAndUnzipM, zipWithM_ )

import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
import Data.List	( genericLength )
import Data.Maybe	( fromJust, isJust )

import Data.Map         ( Map )
import qualified Data.Map as Map

import Foreign		( ForeignPtr, withForeignPtr, newForeignPtr, newForeignPtr_, finalizerFree, touchForeignPtr
                        , Ptr, advancePtr, castPtr, peek, pokeElemOff, ptrToIntPtr
                        , mallocArray )
import Foreign.C

import GHC.ForeignPtr   ( newConcForeignPtr )

import System.IO	( Handle, hIsReadable, hIsWritable )
-- import System.Mem	( performGC )
import System.Posix.IO	( handleToFd )
import System.IO.Unsafe	( unsafePerformIO )

import Data.Boolean

-------------------------------------------------------------------
-- Extra FFI functions.
-------------------------------------------------------------------

-- | A C file handle.
{#pointer *FILE -> CFile#}

-- | Convert a Haskell Handle into a C FILE *.
-- - FIXME: throw exception on error.
-- - suggested by Simon Marlow.
handleToCFile :: Handle -> IO FILE
handleToCFile h =
    do r <- hIsReadable h
       w <- hIsWritable h
       modestr <- newCString $ mode r w
       fd <- handleToFd h
       {#call unsafe fdopen#} (cToNum fd) modestr
    where mode :: Bool -> Bool -> String
          mode False False = error "Handle not readable or writable!"
          mode False True  = "w"
          mode True  False = "r"
          mode True  True  = "r+" -- FIXME

-- | The Haskell Handle is unusable after calling 'handleToCFile',
-- so provide a neutered "fprintf"-style thing here.
printCFile :: FILE -> String -> IO ()
printCFile file str =
    withCString str ({#call unsafe fprintf_neutered#} file)

--  Close a C FILE *.
-- - FIXME: throw exception on error.
-- closeCFile :: FILE -> IO ()
-- closeCFile cfile = do {#call unsafe fclose#} cfile
--                    return ()

cToNum :: (Num i, Integral e) => e -> i
cToNum  = fromIntegral . toInteger
{-# INLINE cToNum #-}

cFromEnum :: (Integral i, Enum e) => e -> i
cFromEnum  = fromIntegral . fromEnum
{-# INLINE cFromEnum #-}

-------------------------------------------------------------------
-- Types.
-------------------------------------------------------------------

-- | The BDD manager, which we hide from clients.
{#pointer *DdManager as DDManager newtype#}

-- | The arguments to 'Cudd_Init'.
{#enum CuddSubtableSize {} #}
{#enum CuddCacheSize {} #}

-- | Variable reordering tree options.
{#enum CuddMTRParams {} #}

-- | The abstract type of BDDs.
{#pointer *DdNode as BDD foreign newtype#}

{-# INLINE withBDD #-}

-- BDDs are just pointers, so there's no work to do when we @deepseq@ them.
instance Control.DeepSeq.NFData BDD

-- Belt-and-suspenders equality checking and ordering.
instance Eq BDD where
    bdd0 == bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p

instance Ord BDD where
    bdd0 <= bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p || bdd0p < bdd1p

instance Show BDD where
-- Print out the BDD as a sum-of-products.
    showsPrec _ = sop

-------------------------------------------------------------------
-- Administrative functions.
-------------------------------------------------------------------

-- | The BDD manager. This needs to be invoked before any of the
-- following functions... which we arrange for automagically.
ddmanager :: DDManager
ddmanager = unsafePerformIO $
  {#call unsafe Cudd_Init as _cudd_Init #}
    0 0 (cFromEnum UNIQUE_SLOTS) (cFromEnum CACHE_SLOTS) 0
{-# NOINLINE ddmanager #-}

-- | A map to and from BDD variable numbers.
-- FIXME: the second one would be more efficiently Data.IntMap, but we don't use it often.
type VarMap = (Map String BDD, Map CUInt String)

-- | Tracks existing variables.
bdd_vars :: IORef VarMap
bdd_vars = unsafePerformIO $ newIORef (Map.empty, Map.empty)
{-# NOINLINE bdd_vars #-}

-- | Attaches a finalizer to a BDD object.
-- The call to "Cudd_Ref" happens in C to ensure atomicity.
-- Returning objects with initial refcount 0 is a bad design decision.
addBDDfinalizer :: Ptr BDD -> IO BDD
addBDDfinalizer bddp = liftM BDD $ newConcForeignPtr bddp bddf
    where bddf = {#call unsafe Cudd_RecursiveDeref as _cudd_RecursiveDeref#} ddmanager bddp
                   >> return ()
{-# INLINE addBDDfinalizer #-}

-- | Attaches a null finalizer to a 'BDD' object.
-- Used for variables and constants.
addBDDnullFinalizer :: Ptr BDD -> IO BDD
addBDDnullFinalizer bddp = fmap BDD $ newForeignPtr_ bddp
{-# INLINE addBDDnullFinalizer #-}

-- Simulate an "apply" function to simplify atomic refcount incrementing.
{#enum CuddBinOp {} #}

-------------------------------------------------------------------
-- Logical operations.
-------------------------------------------------------------------

-- | Allocate a variable.
newVar :: IO (Ptr BDD) -> String -> IO (Maybe CUInt, BDD)
newVar allocVar label =
      do (toBDD, fromBDD) <- readIORef bdd_vars
         case label `Map.lookup` toBDD of
           Just bdd -> return (Nothing, bdd)
           Nothing ->
             do putStrLn $ "Allocating: " ++ label
                bddp <- allocVar
                vid <- fmap cToNum $
                         {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                --putStrLn $ label ++ " -> " ++ (show (vid, bdd))
                bdd <- addBDDnullFinalizer bddp
                writeIORef bdd_vars ( Map.insert label bdd   toBDD
                                    , Map.insert vid   label fromBDD )
                return (Just vid, bdd)

instance BooleanVariable BDD where
    bvar label = unsafePerformIO $
      fmap snd $ newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)  label

    bvars labels =
      case labels of
        [] -> []
        ls -> unsafePerformIO $
          do (vids, vars) <- mapAndUnzipM (newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)) ls
             if all isJust vids
               then groupVars (fromJust (head vids)) (genericLength vids)
               else putStrLn $ "hBDD-CUDD warning: not grouping variables " ++ show ls
             return vars
      where
        -- FIXME why one or the other?
        groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_DEFAULT) >> return ()
        -- groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_FIXED) >> return ()
        makeTreeNode = {#call unsafe Cudd_MakeTreeNode as _cudd_MakeTreeNode#}

    unbvar bdd = unsafePerformIO $ bdd `seq`
                   withBDD bdd $ \bddp ->
                     do vid <- {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                        (_, fromBDD) <- readIORef bdd_vars
                        return $ case cToNum vid `Map.lookup` fromBDD of
                                   Nothing -> "(VID: " ++ show vid ++ ")"
                                   Just v  -> v

instance Boolean BDD where
    true  = cudd_constant {#call unsafe Cudd_ReadOne as _cudd_ReadOne#}
    false = cudd_constant {#call unsafe Cudd_ReadLogicZero as _cudd_ReadLogicZero#}

    (/\)  = bddBinOp AND
    neg x = unsafePerformIO $ withBDD x $ \xp ->
      {#call unsafe cudd_bddNot#} xp >>= addBDDfinalizer

    nand  = bddBinOp NAND
    (\/)  = bddBinOp OR
    nor   = bddBinOp NOR
    xor   = bddBinOp XOR
    -- (-->) = FIXME ???
    (<->) = bddBinOp XNOR

    -- bITE i t e = unsafePerformIO $
    --   withBDD i $ \ip -> withBDD t $ \tp -> withBDD e $ \ep ->
    --     {#call unsafe cudd_bddIte#} ddmanager ip tp ep
    --       >>= addBDDfinalizer

cudd_constant :: (DDManager -> IO (Ptr BDD)) -> BDD
cudd_constant f = unsafePerformIO $ f ddmanager >>= addBDDnullFinalizer
{-# INLINE cudd_constant #-}

bddBinOp :: CuddBinOp -> BDD -> BDD -> BDD
bddBinOp op x y = unsafePerformIO $
  withBDD x $ \xp -> withBDD y $ \yp ->
    {#call unsafe cudd_BinOp#} ddmanager (cFromEnum op) xp yp >>= addBDDfinalizer
{-# INLINE bddBinOp #-}

instance QBF BDD where
    data Group BDD = MkGroup !BDD

    mkGroup = MkGroup . conjoin -- FIXME maybe use Cudd_bddComputeCube
    exists = cudd_exists
    forall = cudd_forall
    rel_product = cudd_rel_product

instance Substitution BDD where
  -- Cache substitution arrays.
  data Subst BDD = MkSubst {-# UNPACK #-} !Int
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))

  mkSubst = cudd_mkSubst
  rename = cudd_rename
  substitute = error "CUDD substitute" -- cudd_substitute

cudd_mkSubst :: [(BDD, BDD)] -> Subst BDD
cudd_mkSubst subst = unsafePerformIO $
    do arrayx  <- mallocArray len
       arrayx' <- mallocArray len
       zipWithM_ (pokeSubst arrayx arrayx') subst [0..]
       fpx  <- newForeignPtr finalizerFree arrayx
       fpx' <- newForeignPtr finalizerFree arrayx'
       return (MkSubst len fpx fpx')
  where
    pokeSubst :: Ptr (Ptr BDD) -> Ptr (Ptr BDD) -> (BDD, BDD) -> Int -> IO ()
    pokeSubst arrayx arrayx' (v, v') i =
      do withBDD v  $ pokeElemOff arrayx  i
         withBDD v' $ pokeElemOff arrayx' i

    len = length subst
{-# INLINE cudd_mkSubst #-}

instance BDDOps BDD where
    get_bdd_ptr bdd = unsafePerformIO $ withBDD bdd (return . ptrToIntPtr)
    bif bdd = unsafePerformIO $
      do vid <- withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
         {#call unsafe Cudd_bddIthVar as _cudd_bddIthVar#} ddmanager (cToNum vid)
           >>= addBDDnullFinalizer
    bthen bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddT#} bddp >>= addBDDfinalizer
    belse bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddE#} bddp >>= addBDDfinalizer

    reduce = cudd_reduce
    satisfy = cudd_satisfy
    support = cudd_support

-------------------------------------------------------------------
-- Implementations.
-------------------------------------------------------------------

withGroup :: Group BDD -> (Ptr BDD -> IO a) -> IO a
withGroup (MkGroup g) = withBDD g

cudd_exists :: Group BDD -> BDD -> BDD
cudd_exists group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddExistAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_exists #-}

cudd_forall :: Group BDD -> BDD -> BDD
cudd_forall group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddUnivAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_forall #-}

cudd_rel_product :: Group BDD -> BDD -> BDD -> BDD
cudd_rel_product group f g = unsafePerformIO $
  withGroup group $ \groupp -> withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddAndAbstract#} ddmanager fp gp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_rel_product #-}

-- | This function swaps variables, as it uses
-- @cudd_bddSwapVariables@. This is not exactly a "rename" behaviour.
cudd_rename :: Subst BDD -> BDD -> BDD
cudd_rename s@(MkSubst len fpx fpx') f = unsafePerformIO $ s `seq` f `seq`
  withBDD f $ \fp ->
    withForeignPtr fpx $ \arrayx -> withForeignPtr fpx' $ \arrayx' ->
      {#call unsafe cudd_bddSwapVariables#} ddmanager fp arrayx arrayx' (fromIntegral len)
        >>= addBDDfinalizer
{-# INLINE cudd_rename #-}

-- FIXME verify implementation.
cudd_reduce :: BDD -> BDD -> BDD
cudd_reduce f g = unsafePerformIO $
  withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddLICompaction#} ddmanager fp gp
      >>= addBDDfinalizer

-- FIXME verify implementation.
cudd_satisfy :: BDD -> BDD
cudd_satisfy bdd = unsafePerformIO $
  withBDD bdd ({#call unsafe cudd_satone#} ddmanager) >>= addBDDfinalizer

cudd_support :: BDD -> [BDD]
cudd_support bdd = unsafePerformIO $
  do varBitArray <- withBDD bdd ({#call unsafe Cudd_SupportIndex as _cudd_SupportIndex#} ddmanager)
     touchForeignPtr (case bdd of BDD fp -> fp)
     -- The array is as long as the number of variables allocated.
     (_toBDD, fromBDD) <- readIORef bdd_vars
     bdds <- foldM (toBDDs varBitArray) [] (Map.toList fromBDD)
     {#call unsafe cFree#} (castPtr varBitArray)
     return bdds
  where
    toBDDs varBitArray bdds (vid, var) =
      do varInSupport <- peek (advancePtr varBitArray (cToNum vid))
         return $ if varInSupport /= 0
                    then bvar var : bdds
                    else bdds

-------------------------------------------------------------------
-- Operations specific to this BDD binding.
-------------------------------------------------------------------

-- | Dump usage statistics to the given 'Handle'.
stats :: Handle -> IO ()
stats handle =
    do cfile <- handleToCFile handle
       printCFile cfile "CUDD stats\n"
       _ <- {#call unsafe Cudd_PrintInfo as _cudd_PrintInfo#} ddmanager cfile
       printCFile cfile "\nVariable groups\n"
       {#call unsafe cudd_printVarGroups#} ddmanager

----------------------------------------
-- Variable Reordering.
----------------------------------------

{#enum Cudd_ReorderingType as CUDDReorderingMethod {} deriving (Eq, Ord, Show)#}

decodeROM :: ReorderingMethod -> CInt
decodeROM rom = cFromEnum $ case rom of
  ReorderNone -> CUDD_REORDER_NONE
  ReorderSift -> CUDD_REORDER_SIFT
  ReorderSiftSym -> CUDD_REORDER_SYMM_SIFT
  ReorderStableWindow3 -> CUDD_REORDER_WINDOW3

-- | Reorder the variables now.
reorder :: ReorderingMethod -> IO ()
reorder rom = {#call unsafe Cudd_ReduceHeap as _cudd_ReduceHeap#} ddmanager (decodeROM rom) 1 >> return ()

-- | Set the dynamic variable ordering heuristic.
dynamicReordering :: ReorderingMethod -> IO ()
dynamicReordering rom = {#call unsafe Cudd_AutodynEnable as _cudd_AutodynEnable#} ddmanager (decodeROM rom) >> return ()

----------------------------------------
-- | Returns the relationship between BDD indices, BDD ids and
-- variable names. This may be useful for discovering what the
-- dynamic reordering is doing.
--
-- The intention of this function is to return
--   @[(position in variable order, immutable variable id, label)]@
-- so that the variable order can be saved.
----------------------------------------

varIndices :: IO [(CInt, CInt, String)]
varIndices = do (toBDD, _fromBDD) <- readIORef bdd_vars
                mapM procVar $ Map.toList toBDD
    where -- procVar :: (String, BDD) -> IO (CUInt, CUInt, String)
          procVar (var, bdd) =
              do -- FIXME CUDD inconsistently uses signed and unsigned ints.
                 vid <- fmap cToNum $
                          withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
                 level <- {#call unsafe Cudd_ReadPerm as _cudd_ReadPerm#} ddmanager vid
                 return (level, vid, var)
{-# NOINLINE varIndices #-}

----------------------------------------
-- BDD Statistics.
----------------------------------------

-- | Determine the size of a BDD.
bddSize :: BDD -> Int
bddSize bdd = unsafePerformIO $
  do size <- withBDD bdd ({#call unsafe Cudd_DagSize as _cudd_DagSize#})
     return $ cToNum size

printInfo :: IO ()
printInfo = {#call unsafe print_stats#} ddmanager

-- -*- haskell -*-- -----------------------------------------------
-- |
-- Module      :  Data.Boolean.CUDD
-- Copyright   :  (C) 2002-2005, 2009 University of New South Wales, (C) 2009-2011 Peter Gammie
-- License     :  LGPL (see COPYING.LIB for details)
--
-- A binding for CUDD (Fabio Somenzi, University of Colorado).
--
-- Note this library is not thread-safe.
-------------------------------------------------------------------
module Data.Boolean.CUDD
    (
        BDD
    ,	module Data.Boolean

        -- * CUDD-specific functions
--          ,	gc
    ,	stats
    ,	reorder
    ,	dynamicReordering
    ,	varIndices
    ,	bddSize
    ,	printInfo
    ) where

-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------

#include "cudd_im.h"

import Control.DeepSeq  ( NFData )
import Control.Monad	( foldM, liftM, mapAndUnzipM, zipWithM_ )

import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
import Data.List	( genericLength )
import Data.Maybe	( fromJust, isJust )

import Data.Map         ( Map )
import qualified Data.Map as Map

import Foreign		( ForeignPtr, withForeignPtr, newForeignPtr, newForeignPtr_, finalizerFree, touchForeignPtr
                        , Ptr, advancePtr, castPtr, peek, pokeElemOff, ptrToIntPtr
                        , mallocArray )
import Foreign.C

import GHC.ForeignPtr   ( newConcForeignPtr )

import System.IO	( Handle, hIsReadable, hIsWritable )
-- import System.Mem	( performGC )
import System.Posix.IO	( handleToFd )
import System.IO.Unsafe	( unsafePerformIO )

import Data.Boolean

-------------------------------------------------------------------
-- Extra FFI functions.
-------------------------------------------------------------------

-- | A C file handle.
{#pointer *FILE -> CFile#}

-- | Convert a Haskell Handle into a C FILE *.
-- - FIXME: throw exception on error.
-- - suggested by Simon Marlow.
handleToCFile :: Handle -> IO FILE
handleToCFile h =
    do r <- hIsReadable h
       w <- hIsWritable h
       modestr <- newCString $ mode r w
       fd <- handleToFd h
       {#call unsafe fdopen#} (cToNum fd) modestr
    where mode :: Bool -> Bool -> String
          mode False False = error "Handle not readable or writable!"
          mode False True  = "w"
          mode True  False = "r"
          mode True  True  = "r+" -- FIXME

-- | The Haskell Handle is unusable after calling 'handleToCFile',
-- so provide a neutered "fprintf"-style thing here.
printCFile :: FILE -> String -> IO ()
printCFile file str =
    withCString str ({#call unsafe fprintf_neutered#} file)

--  Close a C FILE *.
-- - FIXME: throw exception on error.
-- closeCFile :: FILE -> IO ()
-- closeCFile cfile = do {#call unsafe fclose#} cfile
--                    return ()

cToNum :: (Num i, Integral e) => e -> i
cToNum  = fromIntegral . toInteger
{-# INLINE cToNum #-}

cFromEnum :: (Integral i, Enum e) => e -> i
cFromEnum  = fromIntegral . fromEnum
{-# INLINE cFromEnum #-}

-------------------------------------------------------------------
-- Types.
-------------------------------------------------------------------

-- | The BDD manager, which we hide from clients.
{#pointer *DdManager as DDManager newtype#}

-- | The arguments to 'Cudd_Init'.
{#enum CuddSubtableSize {} #}
{#enum CuddCacheSize {} #}

-- | Variable reordering tree options.
{#enum CuddMTRParams {} #}

-- | The abstract type of BDDs.
{#pointer *DdNode as BDD foreign newtype#}

withBDD :: BDD -> (Ptr BDD -> IO a) -> IO a
{-# INLINE withBDD #-}

-- BDDs are just pointers, so there's no work to do when we @deepseq@ them.
instance Control.DeepSeq.NFData BDD

-- Belt-and-suspenders equality checking and ordering.
instance Eq BDD where
    bdd0 == bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p

instance Ord BDD where
    bdd0 <= bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p || bdd0p < bdd1p

instance Show BDD where
-- Print out the BDD as a sum-of-products.
    showsPrec _ = sop

-------------------------------------------------------------------
-- Administrative functions.
-------------------------------------------------------------------

-- | The BDD manager. This needs to be invoked before any of the
-- following functions... which we arrange for automagically.
ddmanager :: DDManager
ddmanager = unsafePerformIO $
  {#call unsafe Cudd_Init as _cudd_Init #}
    0 0 (cFromEnum UNIQUE_SLOTS) (cFromEnum CACHE_SLOTS) 0
{-# NOINLINE ddmanager #-}

-- | A map to and from BDD variable numbers.
-- FIXME: the second one would be more efficiently Data.IntMap, but we don't use it often.
type VarMap = (Map String BDD, Map CUInt String)

-- | Tracks existing variables.
bdd_vars :: IORef VarMap
bdd_vars = unsafePerformIO $ newIORef (Map.empty, Map.empty)
{-# NOINLINE bdd_vars #-}

-- | Attaches a finalizer to a BDD object.
-- The call to "Cudd_Ref" happens in C to ensure atomicity.
-- Returning objects with initial refcount 0 is a bad design decision.
addBDDfinalizer :: Ptr BDD -> IO BDD
addBDDfinalizer bddp = liftM BDD $ newConcForeignPtr bddp bddf
    where bddf = {#call unsafe Cudd_RecursiveDeref as _cudd_RecursiveDeref#} ddmanager bddp
                   >> return ()
{-# INLINE addBDDfinalizer #-}

-- | Attaches a null finalizer to a 'BDD' object.
-- Used for variables and constants.
addBDDnullFinalizer :: Ptr BDD -> IO BDD
addBDDnullFinalizer bddp = fmap BDD $ newForeignPtr_ bddp
{-# INLINE addBDDnullFinalizer #-}

-- Simulate an "apply" function to simplify atomic refcount incrementing.
{#enum CuddBinOp {} #}

-------------------------------------------------------------------
-- Logical operations.
-------------------------------------------------------------------

-- | Allocate a variable.
newVar :: IO (Ptr BDD) -> String -> IO (Maybe CUInt, BDD)
newVar allocVar label =
      do (toBDD, fromBDD) <- readIORef bdd_vars
         case label `Map.lookup` toBDD of
           Just bdd -> return (Nothing, bdd)
           Nothing ->
             do putStrLn $ "Allocating: " ++ label
                bddp <- allocVar
                vid <- fmap cToNum $
                         {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                --putStrLn $ label ++ " -> " ++ (show (vid, bdd))
                bdd <- addBDDnullFinalizer bddp
                writeIORef bdd_vars ( Map.insert label bdd   toBDD
                                    , Map.insert vid   label fromBDD )
                return (Just vid, bdd)

instance BooleanVariable BDD where
    bvar label = unsafePerformIO $
      fmap snd $ newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)  label

    bvars labels =
      case labels of
        [] -> []
        ls -> unsafePerformIO $
          do (vids, vars) <- mapAndUnzipM (newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)) ls
             if all isJust vids
               then groupVars (fromJust (head vids)) (genericLength vids)
               else putStrLn $ "hBDD-CUDD warning: not grouping variables " ++ show ls
             return vars
      where
        -- FIXME why one or the other?
        groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_DEFAULT) >> return ()
        -- groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_FIXED) >> return ()
        makeTreeNode = {#call unsafe Cudd_MakeTreeNode as _cudd_MakeTreeNode#}

    unbvar bdd = unsafePerformIO $ bdd `seq`
                   withBDD bdd $ \bddp ->
                     do vid <- {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                        (_, fromBDD) <- readIORef bdd_vars
                        return $ case cToNum vid `Map.lookup` fromBDD of
                                   Nothing -> "(VID: " ++ show vid ++ ")"
                                   Just v  -> v

instance Boolean BDD where
    true  = cudd_constant {#call unsafe Cudd_ReadOne as _cudd_ReadOne#}
    false = cudd_constant {#call unsafe Cudd_ReadLogicZero as _cudd_ReadLogicZero#}

    (/\)  = bddBinOp AND
    neg x = unsafePerformIO $ withBDD x $ \xp ->
      {#call unsafe cudd_bddNot#} xp >>= addBDDfinalizer

    nand  = bddBinOp NAND
    (\/)  = bddBinOp OR
    nor   = bddBinOp NOR
    xor   = bddBinOp XOR
    -- (-->) = FIXME ???
    (<->) = bddBinOp XNOR

    -- bITE i t e = unsafePerformIO $
    --   withBDD i $ \ip -> withBDD t $ \tp -> withBDD e $ \ep ->
    --     {#call unsafe cudd_bddIte#} ddmanager ip tp ep
    --       >>= addBDDfinalizer

cudd_constant :: (DDManager -> IO (Ptr BDD)) -> BDD
cudd_constant f = unsafePerformIO $ f ddmanager >>= addBDDnullFinalizer
{-# INLINE cudd_constant #-}

bddBinOp :: CuddBinOp -> BDD -> BDD -> BDD
bddBinOp op x y = unsafePerformIO $
  withBDD x $ \xp -> withBDD y $ \yp ->
    {#call unsafe cudd_BinOp#} ddmanager (cFromEnum op) xp yp >>= addBDDfinalizer
{-# INLINE bddBinOp #-}

instance QBF BDD where
    data Group BDD = MkGroup !BDD

    mkGroup = MkGroup . conjoin -- FIXME maybe use Cudd_bddComputeCube
    exists = cudd_exists
    forall = cudd_forall
    rel_product = cudd_rel_product

instance Substitution BDD where
  -- Cache substitution arrays.
  data Subst BDD = MkSubst {-# UNPACK #-} !Int
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))

  mkSubst = cudd_mkSubst
  rename = cudd_rename
  substitute = error "CUDD substitute" -- cudd_substitute

cudd_mkSubst :: [(BDD, BDD)] -> Subst BDD
cudd_mkSubst subst = unsafePerformIO $
    do arrayx  <- mallocArray len
       arrayx' <- mallocArray len
       zipWithM_ (pokeSubst arrayx arrayx') subst [0..]
       fpx  <- newForeignPtr finalizerFree arrayx
       fpx' <- newForeignPtr finalizerFree arrayx'
       return (MkSubst len fpx fpx')
  where
    pokeSubst :: Ptr (Ptr BDD) -> Ptr (Ptr BDD) -> (BDD, BDD) -> Int -> IO ()
    pokeSubst arrayx arrayx' (v, v') i =
      do withBDD v  $ pokeElemOff arrayx  i
         withBDD v' $ pokeElemOff arrayx' i

    len = length subst
{-# INLINE cudd_mkSubst #-}

instance BDDOps BDD where
    get_bdd_ptr bdd = unsafePerformIO $ withBDD bdd (return . ptrToIntPtr)
    bif bdd = unsafePerformIO $
      do vid <- withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
         {#call unsafe Cudd_bddIthVar as _cudd_bddIthVar#} ddmanager (cToNum vid)
           >>= addBDDnullFinalizer
    bthen bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddT#} bddp >>= addBDDfinalizer
    belse bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddE#} bddp >>= addBDDfinalizer

    reduce = cudd_reduce
    satisfy = cudd_satisfy
    support = cudd_support

-------------------------------------------------------------------
-- Implementations.
-------------------------------------------------------------------

withGroup :: Group BDD -> (Ptr BDD -> IO a) -> IO a
withGroup (MkGroup g) = withBDD g

cudd_exists :: Group BDD -> BDD -> BDD
cudd_exists group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddExistAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_exists #-}

cudd_forall :: Group BDD -> BDD -> BDD
cudd_forall group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddUnivAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_forall #-}

cudd_rel_product :: Group BDD -> BDD -> BDD -> BDD
cudd_rel_product group f g = unsafePerformIO $
  withGroup group $ \groupp -> withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddAndAbstract#} ddmanager fp gp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_rel_product #-}

-- | This function swaps variables, as it uses
-- @cudd_bddSwapVariables@. This is not exactly a "rename" behaviour.
cudd_rename :: Subst BDD -> BDD -> BDD
cudd_rename s@(MkSubst len fpx fpx') f = unsafePerformIO $ s `seq` f `seq`
  withBDD f $ \fp ->
    withForeignPtr fpx $ \arrayx -> withForeignPtr fpx' $ \arrayx' ->
      {#call unsafe cudd_bddSwapVariables#} ddmanager fp arrayx arrayx' (fromIntegral len)
        >>= addBDDfinalizer
{-# INLINE cudd_rename #-}

-- FIXME verify implementation.
cudd_reduce :: BDD -> BDD -> BDD
cudd_reduce f g = unsafePerformIO $
  withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddLICompaction#} ddmanager fp gp
      >>= addBDDfinalizer

-- FIXME verify implementation.
cudd_satisfy :: BDD -> BDD
cudd_satisfy bdd = unsafePerformIO $
  withBDD bdd ({#call unsafe cudd_satone#} ddmanager) >>= addBDDfinalizer

cudd_support :: BDD -> [BDD]
cudd_support bdd = unsafePerformIO $
  do varBitArray <- withBDD bdd ({#call unsafe Cudd_SupportIndex as _cudd_SupportIndex#} ddmanager)
     touchForeignPtr (case bdd of BDD fp -> fp)
     -- The array is as long as the number of variables allocated.
     (_toBDD, fromBDD) <- readIORef bdd_vars
     bdds <- foldM (toBDDs varBitArray) [] (Map.toList fromBDD)
     {#call unsafe cFree#} (castPtr varBitArray)
     return bdds
  where
    toBDDs varBitArray bdds (vid, var) =
      do varInSupport <- peek (advancePtr varBitArray (cToNum vid))
         return $ if varInSupport /= 0
                    then bvar var : bdds
                    else bdds

-------------------------------------------------------------------
-- Operations specific to this BDD binding.
-------------------------------------------------------------------

-- | Dump usage statistics to the given 'Handle'.
stats :: Handle -> IO ()
stats handle =
    do cfile <- handleToCFile handle
       printCFile cfile "CUDD stats\n"
       _ <- {#call unsafe Cudd_PrintInfo as _cudd_PrintInfo#} ddmanager cfile
       printCFile cfile "\nVariable groups\n"
       {#call unsafe cudd_printVarGroups#} ddmanager

----------------------------------------
-- Variable Reordering.
----------------------------------------

{#enum Cudd_ReorderingType as CUDDReorderingMethod {} deriving (Eq, Ord, Show)#}

decodeROM :: ReorderingMethod -> CInt
decodeROM rom = cFromEnum $ case rom of
  ReorderNone -> CUDD_REORDER_NONE
  ReorderSift -> CUDD_REORDER_SIFT
  ReorderSiftSym -> CUDD_REORDER_SYMM_SIFT
  ReorderStableWindow3 -> CUDD_REORDER_WINDOW3

-- | Reorder the variables now.
reorder :: ReorderingMethod -> IO ()
reorder rom = {#call unsafe Cudd_ReduceHeap as _cudd_ReduceHeap#} ddmanager (decodeROM rom) 1 >> return ()

-- | Set the dynamic variable ordering heuristic.
dynamicReordering :: ReorderingMethod -> IO ()
dynamicReordering rom = {#call unsafe Cudd_AutodynEnable as _cudd_AutodynEnable#} ddmanager (decodeROM rom) >> return ()

----------------------------------------
-- | Returns the relationship between BDD indices, BDD ids and
-- variable names. This may be useful for discovering what the
-- dynamic reordering is doing.
--
-- The intention of this function is to return
--   @[(position in variable order, immutable variable id, label)]@
-- so that the variable order can be saved.
----------------------------------------

varIndices :: IO [(CInt, CInt, String)]
varIndices = do (toBDD, _fromBDD) <- readIORef bdd_vars
                mapM procVar $ Map.toList toBDD
    where -- procVar :: (String, BDD) -> IO (CUInt, CUInt, String)
          procVar (var, bdd) =
              do -- FIXME CUDD inconsistently uses signed and unsigned ints.
                 vid <- fmap cToNum $
                          withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
                 level <- {#call unsafe Cudd_ReadPerm as _cudd_ReadPerm#} ddmanager vid
                 return (level, vid, var)
{-# NOINLINE varIndices #-}

----------------------------------------
-- BDD Statistics.
----------------------------------------

-- | Determine the size of a BDD.
bddSize :: BDD -> Int
bddSize bdd = unsafePerformIO $
  do size <- withBDD bdd ({#call unsafe Cudd_DagSize as _cudd_DagSize#})
     return $ cToNum size

printInfo :: IO ()
printInfo = {#call unsafe print_stats#} ddmanager