Document the Matrix representation

Document the Matrix representation

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation as a matrix.
--
-- The 'Matrix' type actually represents as 3x3 matrix but with some elements
-- are constant and so are not included. Specifically if we assume that our
-- coordinates are row vectors then correspondence is:
--
-- >    Matrix xx yx xy yy x0 y0
-- > ==
-- >    / xx yx 0 \
-- >    | xy yy 0 |
-- >    \ x0 y0 1 /
--
-- and the matrix operates on @(x,y)@ coordinates:
--
-- > (x y 1) / xx yx 0 \  = (x' y' 1)
-- >         | xy yy 0 |  where x' = xx * x + xy * y + x0
-- >         \ x0 y0 1 /        y' = yx * x + yy * y + y0
--
data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yx - xy*yy

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yx - xy*yy


MINOR: Improve scEnDeCryptInplace Implementation

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- recommended by GHC manual

module Codec.ShonkyCrypt.ShonkyCryptFFI where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import Foreign.C.String (CStringLen, CString)
import Foreign.C.Types (CChar(..), CULong(..), CDouble(..))
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU

#include "shonky-crypt.h"

data ShonkyCryptKey = ShonkyCryptKey
    { sckKeyStart :: !Word8
    , sckKeyInc :: !Word8
    , sckOnlyAlnum :: !Bool
    } deriving Show

instance Storable ShonkyCryptKey where
    sizeOf _ = {#sizeof shonky_crypt_key_t #}
    alignment _ = 4
    peek p = ShonkyCryptKey
               <$> liftM fromIntegral ({#get shonky_crypt_key_t->key_start #} p)
               <*> liftM fromIntegral ({#get shonky_crypt_key_t->key_inc #} p)
               <*> liftM toBool ({#get shonky_crypt_key_t->only_alnum #} p)
    poke p x =
      do {#set shonky_crypt_key_t.key_start #} p (fromIntegral $ sckKeyStart x)
         {#set shonky_crypt_key_t.key_inc #} p (fromIntegral $ sckKeyInc x)
         {#set shonky_crypt_key_t.only_alnum #} p (fromBool $ sckOnlyAlnum x)

{#pointer shonky_crypt_key_t as ShonkyCryptKeyPtr -> ShonkyCryptKey #}

fromMallocedStorable :: Storable a => Ptr a -> IO a
fromMallocedStorable p =
    do key <- peek p
       free p
       return key

newShonkyCryptContextPointer :: Ptr ShonkyCryptContext -> IO ShonkyCryptContext
newShonkyCryptContextPointer p =
    do fp <- newForeignPtr scReleaseContextPtr p
       return $ ShonkyCryptContext fp

unsafePackMallocCStringLen :: CStringLen -> IO ByteString
unsafePackMallocCStringLen (cstr, len) = do
    fp <- newForeignPtr BSI.c_free_finalizer (castPtr cstr)
    return $! BSI.PS fp 0 len

withShonkyCryptContext :: ShonkyCryptContext -> (Ptr ShonkyCryptContext -> IO b) -> IO b
{#pointer shonky_crypt_context_t as ShonkyCryptContext foreign newtype #}

foreign import ccall "shonky-crypt.h &sc_release_context"
  scReleaseContextPtr :: FunPtr (Ptr ShonkyCryptContext -> IO ())

withTrickC2HS :: Storable a => a -> (Ptr a -> IO b) -> IO b
withTrickC2HS = with

{#fun pure unsafe sc_alloc_context_with_key as
    ^ { withTrickC2HS* `ShonkyCryptKey' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer* #}

withByteStringLen :: ByteString -> ((CString, CULong) -> IO a) -> IO a
withByteStringLen str f = BSU.unsafeUseAsCStringLen str (\(cstr, len) ->
    f (cstr, fromIntegral len))

{#fun pure unsafe sc_entropy as
    ^ { withByteStringLen *`ByteString'& } -> `Double' #}

{#fun pure unsafe sc_copy_context as
    ^ { withShonkyCryptContext* `ShonkyCryptContext' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer* #}

type InPlaceEnDeCryptFun =
     Ptr ShonkyCryptContext -> Ptr CChar -> Ptr CChar -> CULong -> IO ()
type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CULong -> IO CString

scEnDeCryptInplace :: InPlaceEnDeCryptFun
                   -> ShonkyCryptContext
                   -> ByteString
                   -> (ByteString, ShonkyCryptContext)
scEnDeCryptInplace f ctx input =
     unsafePerformIO $
     BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
     withShonkyCryptContext ctx $ \ctx' ->
     do
        newContext' <- {#call sc_copy_context #} ctx'
        outBuffer <- mallocBytes inputLen
        f newContext' inputBytes outBuffer (fromIntegral inputLen)
        out <- unsafePackMallocCStringLen (outBuffer, inputLen)
        newContext <- newShonkyCryptContextPointer newContext'
        return (out, newContext)

encryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
encryptS = scEnDeCryptInplace {#call unsafe sc_encrypt_inplace #}
decryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
decryptS = scEnDeCryptInplace {#call unsafe sc_decrypt_inplace #}

scEnDecryptNew :: NewEnDeCryptFun -> ShonkyCryptKey -> ByteString -> ByteString
scEnDecryptNew f key input =
    unsafePerformIO $
    BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
    with key $ \key' ->
    do outputC <- f key' inputBytes (fromIntegral inputLen)
       unsafePackMallocCStringLen (outputC, inputLen)

encrypt :: ShonkyCryptKey -> ByteString -> ByteString
encrypt = scEnDecryptNew {#call unsafe sc_encrypt_new #}

decrypt :: ShonkyCryptKey -> ByteString -> ByteString
decrypt = scEnDecryptNew {#call unsafe sc_decrypt_new #}

{#fun pure unsafe sc_new_crypt_key_with as
    ^ { `Word8', `Word8', `Bool' } -> `ShonkyCryptKey' fromMallocedStorable* #}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- recommended by GHC manual

module Codec.ShonkyCrypt.ShonkyCryptFFI where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import Foreign.C.String (CStringLen, CString)
import Foreign.C.Types (CChar(..), CULong(..), CDouble(..))
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU

#include "shonky-crypt.h"

data ShonkyCryptKey = ShonkyCryptKey
    { sckKeyStart :: !Word8
    , sckKeyInc :: !Word8
    , sckOnlyAlnum :: !Bool
    } deriving Show

instance Storable ShonkyCryptKey where
    sizeOf _ = {#sizeof shonky_crypt_key_t #}
    alignment _ = 4
    peek p = ShonkyCryptKey
               <$> liftM fromIntegral ({#get shonky_crypt_key_t->key_start #} p)
               <*> liftM fromIntegral ({#get shonky_crypt_key_t->key_inc #} p)
               <*> liftM toBool ({#get shonky_crypt_key_t->only_alnum #} p)
    poke p x =
      do {#set shonky_crypt_key_t.key_start #} p (fromIntegral $ sckKeyStart x)
         {#set shonky_crypt_key_t.key_inc #} p (fromIntegral $ sckKeyInc x)
         {#set shonky_crypt_key_t.only_alnum #} p (fromBool $ sckOnlyAlnum x)

{#pointer shonky_crypt_key_t as ShonkyCryptKeyPtr -> ShonkyCryptKey #}

fromMallocedStorable :: Storable a => Ptr a -> IO a
fromMallocedStorable p =
    do key <- peek p
       free p
       return key

newShonkyCryptContextPointer :: Ptr ShonkyCryptContext -> IO ShonkyCryptContext
newShonkyCryptContextPointer p =
    do fp <- newForeignPtr scReleaseContextPtr p
       return $ ShonkyCryptContext fp

unsafePackMallocCStringLen :: CStringLen -> IO ByteString
unsafePackMallocCStringLen (cstr, len) = do
    fp <- newForeignPtr BSI.c_free_finalizer (castPtr cstr)
    return $! BSI.PS fp 0 len

withShonkyCryptContext :: ShonkyCryptContext -> (Ptr ShonkyCryptContext -> IO b) -> IO b
{#pointer shonky_crypt_context_t as ShonkyCryptContext foreign newtype #}

foreign import ccall "shonky-crypt.h &sc_release_context"
  scReleaseContextPtr :: FunPtr (Ptr ShonkyCryptContext -> IO ())

withTrickC2HS :: Storable a => a -> (Ptr a -> IO b) -> IO b
withTrickC2HS = with

{#fun pure unsafe sc_alloc_context_with_key as
    ^ { withTrickC2HS* `ShonkyCryptKey' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer* #}

withByteStringLen :: ByteString -> ((CString, CULong) -> IO a) -> IO a
withByteStringLen str f = BSU.unsafeUseAsCStringLen str (\(cstr, len) ->
    f (cstr, fromIntegral len))

{#fun pure unsafe sc_entropy as
    ^ { withByteStringLen *`ByteString'& } -> `Double' #}

{#fun pure unsafe sc_copy_context as
    ^ { withShonkyCryptContext* `ShonkyCryptContext' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer* #}

type InPlaceEnDeCryptFun =
     Ptr ShonkyCryptContext -> Ptr CChar -> Ptr CChar -> CULong -> IO ()
type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CULong -> IO CString

scEnDeCryptInplace :: InPlaceEnDeCryptFun
                   -> ShonkyCryptContext
                   -> ByteString
                   -> (ByteString, ShonkyCryptContext)
scEnDeCryptInplace f ctx input =
    let !newContext = scCopyContext ctx
     in unsafePerformIO $
        BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
        withShonkyCryptContext newContext $ \newContext' ->
        do
           outBuffer <- mallocBytes inputLen
           f newContext' inputBytes outBuffer (fromIntegral inputLen)
           out <- unsafePackMallocCStringLen (outBuffer, inputLen)
           return (out, newContext)

encryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
encryptS = scEnDeCryptInplace {#call unsafe sc_encrypt_inplace #}
decryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
decryptS = scEnDeCryptInplace {#call unsafe sc_decrypt_inplace #}

scEnDecryptNew :: NewEnDeCryptFun -> ShonkyCryptKey -> ByteString -> ByteString
scEnDecryptNew f key input =
    unsafePerformIO $
    BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
    with key $ \key' ->
    do outputC <- f key' inputBytes (fromIntegral inputLen)
       unsafePackMallocCStringLen (outputC, inputLen)

encrypt :: ShonkyCryptKey -> ByteString -> ByteString
encrypt = scEnDecryptNew {#call unsafe sc_encrypt_new #}

decrypt :: ShonkyCryptKey -> ByteString -> ByteString
decrypt = scEnDecryptNew {#call unsafe sc_decrypt_new #}

{#fun pure unsafe sc_new_crypt_key_with as
    ^ { `Word8', `Word8', `Bool' } -> `ShonkyCryptKey' fromMallocedStorable* #}


Add CPP language directive to Transforms.chs

To handle Transform.chs's OpenCV24 ifdefs
correctly, run it with CPP pre-processor
before compiling.

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

import CV.Image as I
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp
import qualified CV.Matrix as M
import CV.Matrix (Matrix,withMatPtr)

-- |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
                 cl <- I.create (getSize 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
                       target <- I.create (getSize 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 <- I.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 <- I.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

perspectiveTransform' :: (CreateImage (Image c d)) => Matrix Float -> Image c d -> (Int,Int)-> Image c d
perspectiveTransform' mat img size
    = unsafePerformIO $ do
       r <- create  size
       withImage img $ \c_img ->
         withMatPtr mat $ \c_mat ->
         withImage r $ \c_r -> {#call wrapWarpPerspective#} (castPtr c_img) (castPtr c_r) (castPtr c_mat)
       return r

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

#c
enum HomographyMethod {
     Default = 0,
     Ransac  = CV_RANSAC,
     LMeds   = CV_LMEDS
     };
#endc
{#enum HomographyMethod {}#}

getHomography' :: Matrix Float -> Matrix Float -> HomographyMethod -> Float -> Matrix Float
getHomography' srcPts dstPts method ransacThreshold =
    unsafePerformIO $ do
    hmg <- M.create (3,3) :: IO (Matrix Float)
    withMatPtr srcPts  $ \c_src ->
     withMatPtr dstPts $ \c_dst ->
     withMatPtr hmg    $ \c_hmg -> do
                          {#call cvFindHomography#}
                           (castPtr c_src)
                           (castPtr c_dst)
                           (castPtr c_hmg)
                           (fromIntegral $ fromEnum method)
                           (realToFrac ransacThreshold)
                           nullPtr
                          return hmg

--- 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 <- I.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 <- I.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 <- 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 {
     CCOMP = CV_DIST_LABEL_CCOMP
    ,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 <- I.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 $ 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 as I
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp
import qualified CV.Matrix as M
import CV.Matrix (Matrix,withMatPtr)

-- |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
                 cl <- I.create (getSize 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
                       target <- I.create (getSize 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 <- I.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 <- I.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

perspectiveTransform' :: (CreateImage (Image c d)) => Matrix Float -> Image c d -> (Int,Int)-> Image c d
perspectiveTransform' mat img size
    = unsafePerformIO $ do
       r <- create  size
       withImage img $ \c_img ->
         withMatPtr mat $ \c_mat ->
         withImage r $ \c_r -> {#call wrapWarpPerspective#} (castPtr c_img) (castPtr c_r) (castPtr c_mat)
       return r

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

#c
enum HomographyMethod {
     Default = 0,
     Ransac  = CV_RANSAC,
     LMeds   = CV_LMEDS
     };
#endc
{#enum HomographyMethod {}#}

getHomography' :: Matrix Float -> Matrix Float -> HomographyMethod -> Float -> Matrix Float
getHomography' srcPts dstPts method ransacThreshold =
    unsafePerformIO $ do
    hmg <- M.create (3,3) :: IO (Matrix Float)
    withMatPtr srcPts  $ \c_src ->
     withMatPtr dstPts $ \c_dst ->
     withMatPtr hmg    $ \c_hmg -> do
                          {#call cvFindHomography#}
                           (castPtr c_src)
                           (castPtr c_dst)
                           (castPtr c_hmg)
                           (fromIntegral $ fromEnum method)
                           (realToFrac ransacThreshold)
                           nullPtr
                          return hmg

--- 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 <- I.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 <- I.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 <- 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 {
     CCOMP = CV_DIST_LABEL_CCOMP
    ,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 <- I.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 $ CCOMP)
#endif

    return result

    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks


Switch to a soft close of the connection by default.

This better supports resource pool usage, where closing the client does not
cause all pending asynchronous requests to return HyperclientGarbage
statuses.

{-# LANGUAGE ViewPatterns #-}

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

import Foreign
import Foreign.C

import Data.ByteString (ByteString)

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

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

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

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

import Data.Default

#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
    { connectionBackoff :: BackoffMethod
    , connectionBackoffCap :: Maybe Int
    }
  deriving (Eq, Read, Show)

instance Default ConnectOptions where
  def =
    ConnectOptions
      { connectionBackoff = BackoffYield -- 10 * 2^n
      , connectionBackoffCap = Just 50000           -- 0.05 seconds.
      }

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

-- | A connectionBackoff 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)

-- | A callback used to perform work when the Hyperclient loop indicates an
-- operation has been completed.
--
-- A 'Nothing' value indicates that no further work is necessary, and a 'Just' value
-- will store a new Handle and HandleCallback.
newtype HandleCallback = HandleCallback (Maybe ReturnCode -> IO (Maybe (Handle, HandleCallback)))

-- | The core data type managing access to a 'Hyperclient' object and all
-- currently running asynchronous operations.
--
-- The 'MVar' is used as a lock to control access to the 'Hyperclient' and
-- a map of open handles and continuations, or callbacks, that must be executed
-- to complete operations. A 'HandleCallback' may yield Nothing or a new 'Handle'
-- and 'HandleCallback' to be stored in the map.
type HyperclientWrapper = MVar (Maybe Hyperclient, Map Handle HandleCallback)

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 used internally by HyperClient operations.
--
-- This is the same as 'AsyncResultHandle' except it gives the callback
-- the result of the loop operation that yields the returned 'Handle'.
type StreamResultHandle a = IO (Handle, Maybe ReturnCode -> 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)

newtype SearchStream a = SearchStream (a, Result (SearchStream 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.
forceClose :: Client -> IO ()
forceClose (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
      mapM_ (\(HandleCallback cont) -> cont Nothing) $ Map.elems handles
      putMVar c (Nothing, Map.empty)

-- | Wait for graceful termination of all outstanding requests and
-- then close the connection.
--
-- /Note:/ If it is necessary to have this operation complete quickly
-- and outstanding requests are not needed, then use 'forceClose'.
close :: Client -> IO ()
close client@(getClient -> c) = do
  clientData <- takeMVar c
  case clientData of
    (Nothing, _)        -> error "HyperDex client error - cannot close a client connection twice."
    (Just hc, handles)  -> do
      case Map.null handles of
        True  -> do
          hyperclientDestroy hc
          putMVar c (Nothing, Map.empty)
        False -> do
          -- Have to put it back in order to run loopClient
          (_, newHandles) <- handleLoop hc handles
          putMVar c (Just hc, newHandles)
          close client

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

cappedBackoff :: Int -> Maybe Int -> (Int, Bool)
cappedBackoff n Nothing               = (n, False)
cappedBackoff n (Just c) | n  < c     = (n, False)
                         | otherwise  = (c, True)
{-# INLINE cappedBackoff #-}

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

-- | Runs a single iteration of hyperclient_loop, returning whether
-- or not a handle was completed and a new set of callbacks.
--
-- This function does not use locking around the client.
handleLoop :: Hyperclient -> Map Handle HandleCallback -> IO (Maybe Handle, Map Handle HandleCallback)
handleLoop hc handles = do
  -- TODO: Examine returnCode for things that might matter.
  (handle, returnCode) <- hyperclientLoop hc 0
  case returnCode of
    HyperclientSuccess -> do
      let clearedMap = Map.delete handle handles
      resultMap <- do
        case Map.lookup handle handles of
          Just (HandleCallback entry) -> do
            cont <- entry $ Just returnCode
            case cont of
              Nothing     -> return clearedMap
              Just (h, e) -> return $ Map.insert h e clearedMap
          Nothing -> return clearedMap
      return $ (Just handle, resultMap)
    HyperclientTimeout -> do
      handleLoop hc handles
    HyperclientNonepending -> do
      mapM_ (\(HandleCallback cont) -> cont Nothing) $ Map.elems handles
      return $ (Just handle, Map.empty)
    _ -> do
      handleLoop hc handles

{-# INLINE handleLoop #-}

-- | Runs hyperclient_loop exactly once, setting the appropriate MVar.
loopClient :: Client -> IO (Maybe Handle)
loopClient (getClient -> c) = do
  clientData <- takeMVar c
  case clientData of
    (Nothing, _)       -> error "HyperDex client error - client has been closed."
    (Just hc, handles) -> do
      (maybeHandle, newHandles) <- handleLoop hc handles
      putMVar c (Just hc, newHandles)
      return maybeHandle
{-# INLINE loopClient #-}

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

loopClientUntil client h v back (Just n) = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential connectionBackoff 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 (connectionBackoffCap . getConnectOptions $ client)
              loopClientUntil client h v back' (Just $ n - 1)
    False -> return True

loopClientUntil client h v back Nothing = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential connectionBackoff 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 (connectionBackoffCap . getConnectOptions $ client)
              loopClientUntil client h v back' Nothing
    False -> return True
{-# INLINE loopClientUntil #-}

-- | 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
{-# INLINE withClientImmediate #-}

-- | 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))
          let wrappedCallback = HandleCallback $ const $ do
                returnValue <- cont
                putMVar v returnValue
                return Nothing
          putMVar c (Just hc, Map.insert h wrappedCallback handles)
          return $ do
            success <- loopClientUntil client h v (connectionBackoff . getConnectOptions $ client) Nothing
            case success of
              True  -> takeMVar v
              False -> return $ Left HyperclientPollfailed
        False -> do
          putMVar c (Just hc, handles)
          returnValue <- cont
          -- A HyperclientInterrupted return code indicates that there was a signal
          -- received by the client that prevented the call from completing, thus
          -- the request should be transparently retried.
          case returnValue of
            Left HyperclientInterrupted -> withClient client f
            _ -> return . return $ returnValue
{-# INLINE withClient #-}

-- | Wrap a Hyperclient request that returns a search stream.
withClientStream :: Client -> (Hyperclient -> StreamResultHandle a) -> AsyncResult (SearchStream a)
withClientStream 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 (SearchStream a)))
          let wrappedCallback = HandleCallback $ \code -> do
                returnValue <- cont code
                (result, callback) <- wrapSearchStream returnValue client h cont
                putMVar v $ result
                return $ Just (h, callback)
          putMVar c (Just hc, Map.insert h wrappedCallback handles)
          return $ do
            success <- loopClientUntil client h v (connectionBackoff . getConnectOptions $ client) Nothing
            case success of
              True  -> takeMVar v
              False -> return $ Left HyperclientPollfailed
        False -> do
          putMVar c (Just hc, handles)
          returnValue <- cont Nothing
          case returnValue of
            Left HyperclientInterrupted -> withClientStream client f
            _ -> do
              (result, _) <- wrapSearchStream returnValue client h cont
              return . return $ result
{-# INLINE withClientStream #-}

wrapSearchStream :: Either ReturnCode a -> Client -> Handle -> (Maybe ReturnCode -> Result a) -> IO (Either ReturnCode (SearchStream a), HandleCallback)
wrapSearchStream (Left e)  _      _ _    = return $ (Left e, HandleCallback $ const $ return Nothing)
wrapSearchStream (Right a) client h cont = do
  v <- newEmptyMVar
  let wrappedCallback = HandleCallback $ \code -> do
        returnValue <- cont code
        (result, callback) <- wrapSearchStream returnValue client h cont
        putMVar v $ result
        return $ Just (h, callback)
  let cont' = do
        success <- loopClientUntil client h v (connectionBackoff . getConnectOptions $ client) Nothing
        case success of
          True  -> takeMVar v
                  -- TODO: Return actual ReturnCode
          False -> return $ Left HyperclientPollfailed
  return $ (return $ SearchStream (a, cont'), wrappedCallback)
{-# INLINE wrapSearchStream #-}

-- | 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 ->
  wrapHyperCall $ {# 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 = wrapHyperCall $
  {# 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 <- wrapHyperCall $ {# call hyperclient_loop #} client (fromIntegral timeout) returnCodePtr
    returnCode <- fmap (toEnum . fromIntegral) $ peek returnCodePtr
    return (handle, returnCode)
{-# INLINE hyperclientLoop #-}

{-# LANGUAGE ViewPatterns #-}

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

import Foreign
import Foreign.C

import Data.ByteString (ByteString)

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

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

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

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

import Data.Default

#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
    { connectionBackoff :: BackoffMethod
    , connectionBackoffCap :: Maybe Int
    }
  deriving (Eq, Read, Show)

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

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

-- | A connectionBackoff 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)

-- | A callback used to perform work when the Hyperclient loop indicates an
-- operation has been completed.
--
-- A 'Nothing' value indicates that no further work is necessary, and a 'Just' value
-- will store a new Handle and HandleCallback.
newtype HandleCallback = HandleCallback (Maybe ReturnCode -> IO (Maybe (Handle, HandleCallback)))

-- | The core data type managing access to a 'Hyperclient' object and all
-- currently running asynchronous operations.
--
-- The 'MVar' is used as a lock to control access to the 'Hyperclient' and
-- a map of open handles and continuations, or callbacks, that must be executed
-- to complete operations. A 'HandleCallback' may yield Nothing or a new 'Handle'
-- and 'HandleCallback' to be stored in the map.
type HyperclientWrapper = MVar (Maybe Hyperclient, Map Handle HandleCallback)

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 used internally by HyperClient operations.
--
-- This is the same as 'AsyncResultHandle' except it gives the callback
-- the result of the loop operation that yields the returned 'Handle'.
type StreamResultHandle a = IO (Handle, Maybe ReturnCode -> 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)

newtype SearchStream a = SearchStream (a, Result (SearchStream 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
      mapM_ (\(HandleCallback cont) -> cont Nothing) $ 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)
{-# INLINE doExponentialBackoff #-}

cappedBackoff :: Int -> Maybe Int -> (Int, Bool)
cappedBackoff n Nothing               = (n, False)
cappedBackoff n (Just c) | n  < c     = (n, False)
                         | otherwise  = (c, True)
{-# INLINE cappedBackoff #-}

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

-- | Runs hyperclient_loop exactly once, setting the appropriate MVar.
loopClient :: Client -> IO (Maybe Handle)
loopClient 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
          let newMap = Map.delete handle handles
          case Map.lookup handle handles of
            Just (HandleCallback entry) -> do
              cont <- entry $ Just returnCode
              case cont of
                Nothing -> putMVar c (Just hc, newMap)
                Just (h, e) -> putMVar c (Just hc, Map.insert h e newMap)
            Nothing -> putMVar c (Just hc, newMap)
          return $ Just handle
        HyperclientTimeout -> do
          putMVar c (Just hc, handles)
          loopClient client
        HyperclientNonepending -> do
          mapM_ (\(HandleCallback cont) -> cont Nothing) $ Map.elems handles
          putMVar c (Just hc, Map.empty)
          return $ Just handle
        _ -> do
          putMVar c (Just hc, handles)
          loopClient client
{-# INLINE loopClient #-}

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

loopClientUntil client h v back (Just n) = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential connectionBackoff 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 (connectionBackoffCap . getConnectOptions $ client)
              loopClientUntil client h v back' (Just $ n - 1)
    False -> return True

loopClientUntil client h v back Nothing = do
  empty <- isEmptyMVar v
  case empty of
    True -> do
      _ <- loopClient client
      clientData <- readMVar $ getClient client
      --  TODO: Exponential connectionBackoff 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 (connectionBackoffCap . getConnectOptions $ client)
              loopClientUntil client h v back' Nothing
    False -> return True
{-# INLINE loopClientUntil #-}

-- | 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
{-# INLINE withClientImmediate #-}

-- | 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))
          let wrappedCallback = HandleCallback $ const $ do
                returnValue <- cont
                putMVar v returnValue
                return Nothing
          putMVar c (Just hc, Map.insert h wrappedCallback handles)
          return $ do
            success <- loopClientUntil client h v (connectionBackoff . getConnectOptions $ client) Nothing
            case success of
              True  -> takeMVar v
              False -> return $ Left HyperclientPollfailed
        False -> do
          putMVar c (Just hc, handles)
          returnValue <- cont
          -- A HyperclientInterrupted return code indicates that there was a signal
          -- received by the client that prevented the call from completing, thus
          -- the request should be transparently retried.
          case returnValue of
            Left HyperclientInterrupted -> withClient client f
            _ -> return . return $ returnValue
{-# INLINE withClient #-}

-- | Wrap a Hyperclient request that returns a search stream.
withClientStream :: Client -> (Hyperclient -> StreamResultHandle a) -> AsyncResult (SearchStream a)
withClientStream 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 (SearchStream a)))
          let wrappedCallback = HandleCallback $ \code -> do
                returnValue <- cont code
                (result, callback) <- wrapSearchStream returnValue client h cont
                putMVar v $ result
                return $ Just (h, callback)
          putMVar c (Just hc, Map.insert h wrappedCallback handles)
          return $ do
            success <- loopClientUntil client h v (connectionBackoff . getConnectOptions $ client) Nothing
            case success of
              True  -> takeMVar v
              False -> return $ Left HyperclientPollfailed
        False -> do
          putMVar c (Just hc, handles)
          returnValue <- cont Nothing
          case returnValue of
            Left HyperclientInterrupted -> withClientStream client f
            _ -> do
              (result, _) <- wrapSearchStream returnValue client h cont
              return . return $ result
{-# INLINE withClientStream #-}

wrapSearchStream :: Either ReturnCode a -> Client -> Handle -> (Maybe ReturnCode -> Result a) -> IO (Either ReturnCode (SearchStream a), HandleCallback)
wrapSearchStream (Left e)  _      _ _    = return $ (Left e, HandleCallback $ const $ return Nothing)
wrapSearchStream (Right a) client h cont = do
  v <- newEmptyMVar
  let wrappedCallback = HandleCallback $ \code -> do
        returnValue <- cont code
        (result, callback) <- wrapSearchStream returnValue client h cont
        putMVar v $ result
        return $ Just (h, callback)
  let cont' = do
        success <- loopClientUntil client h v (connectionBackoff . getConnectOptions $ client) Nothing
        case success of
          True  -> takeMVar v
                  -- TODO: Return actual ReturnCode
          False -> return $ Left HyperclientPollfailed
  return $ (return $ SearchStream (a, cont'), wrappedCallback)
{-# INLINE wrapSearchStream #-}

-- | 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 ->
  wrapHyperCall $ {# 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 = wrapHyperCall $
  {# 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 <- wrapHyperCall $ {# call hyperclient_loop #} client (fromIntegral timeout) returnCodePtr
    returnCode <- fmap (toEnum . fromIntegral) $ peek returnCodePtr
    return (handle, returnCode)
{-# INLINE hyperclientLoop #-}


Documentation effort: 5/23

Documentation effort: 5/23

{-#LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, TypeSynonymInstances#-}
#include "cvWrapLEO.h"
-- | Module for exposing opencv drawing functions. These are meant for quick and dirty marking
--   and not for anything presentable. For any real drawing
--   you should figure out how to use cairo or related package, such as diagrams. They are
--   way better.
--
--   Consult the "CV.ImageOp" module for functions to apply the operations in this module to images.

module CV.Drawing(
                -- * Drawable class
                 ShapeStyle(Filled,Stroked)
                ,Drawable(..)
                -- * Extra drawing operations
                ,drawLinesOp
                ,rectOpS
                -- * Floodfill operations
                ,fillOp
                ,floodfill
                -- * Shorthand for drawing single shapes
                ,circle
                ,drawLines
                ,rectangle
                ,fillPoly) where

import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import System.IO.Unsafe
import Control.Monad(when)

{#import CV.Image#}

import CV.ImageOp

-- | Is the shape filled or just a boundary?
data ShapeStyle = Filled | Stroked Int
    deriving(Eq,Show)

styleToCV Filled = -1
styleToCV (Stroked w) = fromIntegral w

-- TODO: The instances in here could be significantly smaller..
-- |Typeclass for images that support elementary drawing operations.
class Drawable a b where
    -- | Type of the pixel, i.e. Float for a grayscale image and 3-tuple for RGB image.
    type Color a b :: *
    -- | Put text of certain color to given coordinates. Good size seems to be around 0.5-1.5.
    putTextOp :: (Color a b) -> Float -> String -> (Int,Int) -> ImageOperation a b
    -- | Draw a line between two points.
    lineOp :: (Color a b)  -> Int -> (Int,Int) -> (Int,Int) -> ImageOperation a b
    -- | Draw a Circle
    circleOp :: (Color a b) -> (Int,Int) -> Int -> ShapeStyle -> ImageOperation a b
    -- | Draw a Rectangle by supplying two corners
    rectOp   :: (Color a b) -> Int -> (Int,Int) -> (Int,Int)  -> ImageOperation a b
    -- | Draw a filled polygon
    fillPolyOp :: (Color a b) -> [(Int,Int)] -> ImageOperation a b

instance Drawable RGB D32 where
    type Color RGB D32 = (D32,D32,D32)
    putTextOp (r,g,b) size text (x,y)  = ImgOp $ \img -> do
                                   withGenImage img $ \cimg ->
                                    withCString text $ \(ctext) ->
                                    {#call wrapDrawText#} cimg ctext (realToFrac size)
                                        (fromIntegral x) (fromIntegral y)
                                        (realToFrac r) (realToFrac g) (realToFrac b)

    lineOp (r,g,b) t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawLine#} img (fromIntegral x) (fromIntegral y)
                                                        (fromIntegral x1) (fromIntegral y1)
                                                        (realToFrac r) (realToFrac g)
                                                        (realToFrac b) (fromIntegral t)

    circleOp (red,g,b) (x,y) r s = ImgOp $ \i -> do
                        when (r>0) $ withGenImage i $ \img ->
                              ({#call wrapDrawCircle#} img (fromIntegral x) (fromIntegral y)
                                                           (fromIntegral r) (realToFrac red)
                                                           (realToFrac g) (realToFrac b)
                                                           $ styleToCV s)
    rectOp (r,g,b) t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawRectangle#} img (fromIntegral x)
                               (fromIntegral y) (fromIntegral x1) (fromIntegral y1)
                               (realToFrac r) (realToFrac g)(realToFrac b)(fromIntegral t)
    fillPolyOp (r,g,b) pts = ImgOp $ \i -> do
                             withImage i $ \img -> do
                                  let (xs,ys) = unzip pts
                                  xs' <- newArray $ map fromIntegral xs
                                  ys' <- newArray $ map fromIntegral  ys
                                  {#call wrapFillPolygon#} img
                                       (fromIntegral $ length xs) xs' ys'
                                   (realToFrac r) (realToFrac g) (realToFrac b)
                                  free xs'
                                  free ys'

instance Drawable GrayScale D32 where
    type Color GrayScale D32 = D32

    putTextOp color size text (x,y)  = ImgOp $ \img -> do
                                   withGenImage img $ \cimg ->
                                    withCString text $ \(ctext) ->
                                    {#call wrapDrawText#} cimg ctext (realToFrac size)
                                        (fromIntegral x) (fromIntegral y)
                                        (realToFrac color) (realToFrac color) (realToFrac color)

    lineOp c t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawLine#} img (fromIntegral x) (fromIntegral y)
                                                        (fromIntegral x1) (fromIntegral y1)
                                                        (realToFrac c) (realToFrac c)
                                                        (realToFrac c) (fromIntegral t)

    circleOp c (x,y) r s = ImgOp $ \i -> do
                        when (r>0) $ withGenImage i $ \img ->
                              ({#call wrapDrawCircle#} img (fromIntegral x) (fromIntegral y)
                                                           (fromIntegral r)
                                                           (realToFrac c) (realToFrac c) (realToFrac c)
                                                           $ styleToCV s)

    rectOp c t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawRectangle#} img (fromIntegral x)
                               (fromIntegral y) (fromIntegral x1) (fromIntegral y1)
                               (realToFrac c)(realToFrac c)(realToFrac c) (fromIntegral t)

    fillPolyOp c pts = ImgOp $ \i -> do
                             withImage i $ \img -> do
                                  let (xs,ys) = unzip pts
                                  xs' <- newArray $ map fromIntegral xs
                                  ys' <- newArray $ map fromIntegral  ys
                                  {#call wrapFillPolygon#} img
                                       (fromIntegral $ length xs) xs' ys'
                                   (realToFrac c) (realToFrac c) (realToFrac c)
                                  free xs'
                                  free ys'

-- | Draw a rectangle by giving top left corner and size.
rectOpS :: Drawable a b => Color a b -> Int -> (Int, Int) -> (Int, Int)
            -> ImageOperation a b
rectOpS c t pos@(x,y) (w,h) = rectOp c t pos (x+w,y+h)

-- | Flood fill a region of the image
fillOp :: (Int,Int) -> D32 -> D32 -> D32 -> Bool -> ImageOperation GrayScale D32
fillOp (x,y) color low high floats =
    ImgOp $ \i -> do
      withImage i $ \img ->
        ({#call wrapFloodFill#} img (fromIntegral x) (fromIntegral y)
            (realToFrac color) (realToFrac low) (realToFrac high) (toCINT $ floats))
    where
     toCINT False = 0
     toCINT True  = 1

-- | Apply rectOp to an image
rectangle :: Drawable c d => Color c d -> Int -> (Int, Int) -> (Int, Int) -> Image c d
             -> IO (Image c d)
rectangle color thickness a b i =
    operate (rectOp color thickness a b ) i

-- | Apply fillPolyOp to an image
fillPoly :: Drawable c d => Color c d -> [(Int, Int)] -> Image c d -> IO (Image c d)
fillPoly c pts i = operate (fillPolyOp c pts) i

-- | Draw a polyline
drawLinesOp :: Drawable c d => Color c d -> Int -> [((Int, Int), (Int, Int))] -> CV.ImageOp.ImageOperation c d
drawLinesOp color thickness segments =
    foldl (#>) nonOp
     $ map (\(a,b) -> lineOp color thickness a b) segments

-- | Apply drawLinesOp to an image
drawLines :: Drawable c d => Image c d -> Color c d -> Int -> [((Int, Int), (Int, Int))]
                                -> IO (Image c d)
drawLines img color thickness segments = operateOn img
                    (drawLinesOp color thickness segments)

-- | Apply circleOp to an image
circle :: Drawable c d => (Int, Int) -> Int -> Color c d -> ShapeStyle -> Image c d -> Image c d
circle center r color s i = unsafeOperate (circleOp color center r s) i

-- | Apply fillOp to an image
floodfill :: (Int, Int) -> D32 -> D32 -> D32 -> Bool -> Image GrayScale D32 -> Image GrayScale D32
floodfill (x,y) color low high floats =
    unsafeOperate (fillOp (x,y) color low high floats)

{-#LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, TypeSynonymInstances#-}
#include "cvWrapLEO.h"

module CV.Drawing(ShapeStyle(Filled,Stroked),circle
              ,Drawable(..)
              ,floodfill,drawLinesOp,drawLines,rectangle
              ,rectOpS,fillPoly) where

import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import System.IO.Unsafe
import Control.Monad(when)

{#import CV.Image#}

import CV.ImageOp

data ShapeStyle = Filled | Stroked Int
    deriving(Eq,Show)

styleToCV Filled = -1
styleToCV (Stroked w) = fromIntegral w

-- TODO: Add fillstyle for rectOp

-- TODO: The instances in here could be significantly smaller..
class Drawable a b where
    type Color a b :: *
    putTextOp :: (Color a b) -> Float -> String -> (Int,Int) -> ImageOperation a b
    lineOp :: (Color a b)   -> Int -> (Int,Int) -> (Int,Int) -> ImageOperation a b
    circleOp :: (Color a b) -> (Int,Int) -> Int -> ShapeStyle -> ImageOperation a b
    rectOp   :: (Color a b) -> Int -> (Int,Int) -> (Int,Int)  -> ImageOperation a b
    fillPolyOp :: (Color a b) -> [(Int,Int)] -> ImageOperation a b

instance Drawable RGB D32 where
    type Color RGB D32 = (D32,D32,D32)
    putTextOp (r,g,b) size text (x,y)  = ImgOp $ \img -> do
                                   withGenImage img $ \cimg ->
                                    withCString text $ \(ctext) ->
                                    {#call wrapDrawText#} cimg ctext (realToFrac size)
                                        (fromIntegral x) (fromIntegral y)
                                        (realToFrac r) (realToFrac g) (realToFrac b)

    lineOp (r,g,b) t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawLine#} img (fromIntegral x) (fromIntegral y)
                                                        (fromIntegral x1) (fromIntegral y1)
                                                        (realToFrac r) (realToFrac g)
                                                        (realToFrac b) (fromIntegral t)

    circleOp (red,g,b) (x,y) r s = ImgOp $ \i -> do
                        when (r>0) $ withGenImage i $ \img ->
                              ({#call wrapDrawCircle#} img (fromIntegral x) (fromIntegral y)
                                                           (fromIntegral r) (realToFrac red)
                                                           (realToFrac g) (realToFrac b)
                                                           $ styleToCV s)
    rectOp (r,g,b) t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawRectangle#} img (fromIntegral x)
                               (fromIntegral y) (fromIntegral x1) (fromIntegral y1)
                               (realToFrac r) (realToFrac g)(realToFrac b)(fromIntegral t)
    fillPolyOp (r,g,b) pts = ImgOp $ \i -> do
                             withImage i $ \img -> do
                                  let (xs,ys) = unzip pts
                                  xs' <- newArray $ map fromIntegral xs
                                  ys' <- newArray $ map fromIntegral  ys
                                  {#call wrapFillPolygon#} img
                                       (fromIntegral $ length xs) xs' ys'
                                   (realToFrac r) (realToFrac g) (realToFrac b)
                                  free xs'
                                  free ys'

instance Drawable GrayScale D32 where
    type Color GrayScale D32 = D32

    putTextOp color size text (x,y)  = ImgOp $ \img -> do
                                   withGenImage img $ \cimg ->
                                    withCString text $ \(ctext) ->
                                    {#call wrapDrawText#} cimg ctext (realToFrac size)
                                        (fromIntegral x) (fromIntegral y)
                                        (realToFrac color) (realToFrac color) (realToFrac color)

    lineOp c t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawLine#} img (fromIntegral x) (fromIntegral y)
                                                        (fromIntegral x1) (fromIntegral y1)
                                                        (realToFrac c) (realToFrac c)
                                                        (realToFrac c) (fromIntegral t)

    circleOp c (x,y) r s = ImgOp $ \i -> do
                        when (r>0) $ withGenImage i $ \img ->
                              ({#call wrapDrawCircle#} img (fromIntegral x) (fromIntegral y)
                                                           (fromIntegral r)
                                                           (realToFrac c) (realToFrac c) (realToFrac c)
                                                           $ styleToCV s)

    rectOp c t (x,y) (x1,y1) = ImgOp $ \i -> do
                         withGenImage i $ \img ->
                              {#call wrapDrawRectangle#} img (fromIntegral x)
                               (fromIntegral y) (fromIntegral x1) (fromIntegral y1)
                               (realToFrac c)(realToFrac c)(realToFrac c) (fromIntegral t)

    fillPolyOp c pts = ImgOp $ \i -> do
                             withImage i $ \img -> do
                                  let (xs,ys) = unzip pts
                                  xs' <- newArray $ map fromIntegral xs
                                  ys' <- newArray $ map fromIntegral  ys
                                  {#call wrapFillPolygon#} img
                                       (fromIntegral $ length xs) xs' ys'
                                   (realToFrac c) (realToFrac c) (realToFrac c)
                                  free xs'
                                  free ys'

rectOpS c t pos@(x,y) (w,h) = rectOp c t pos (x+w,y+h)

fillOp :: (Int,Int) -> D32 -> D32 -> D32 -> Bool -> ImageOperation GrayScale D32
fillOp (x,y) color low high floats =
    ImgOp $ \i -> do
      withImage i $ \img ->
        ({#call wrapFloodFill#} img (fromIntegral x) (fromIntegral y)
            (realToFrac color) (realToFrac low) (realToFrac high) (toCINT $ floats))
    where
     toCINT False = 0
     toCINT True  = 1

-- Shorthand for single drawing operations. You should however use #> and <## in CV.ImageOp
-- rather than these

--line color thickness start end i =
--    operate (lineOp color thickness start end ) i

rectangle color thickness a b i =
    operate (rectOp color thickness a b ) i

fillPoly c pts i = operate (fillPolyOp c pts) i

drawLinesOp color thickness segments =
    foldl (#>) nonOp
     $ map (\(a,b) -> lineOp color thickness a b) segments

drawLines img color thickness segments = operateOn img
                    (drawLinesOp color thickness segments)

circle center r color s i = unsafeOperate (circleOp color center r s) i

floodfill (x,y) color low high floats =
    unsafeOperate (fillOp (x,y) color low high floats)