Added bindings for cvCountNonZero to ImageMath

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, FlexibleContexts#-}
#include "cvWrapLEO.h"

-- | Mathematical and statistical operations for images. See also module
--   "CV.ImageMathOp" which contains handy operators for some of these.
module CV.ImageMath(
  -- * Operations  for two images
  add
, sub
, absDiff
, mul
, CV.ImageMath.div
, CV.ImageMath.min
, CV.ImageMath.max
, maskedMerge
, averageImages
, CV.ImageMath.atan2
  -- * Operations for one image
, subMean
, subMeanAbs
, CV.ImageMath.sqrt
, CV.ImageMath.log
, CV.ImageMath.abs
, CV.ImageMath.atan
, invert
  -- * Operations for a scalar and an image
, addS
, subS
, subRS
, mulS
-- TODO: divS is missing, is it needed?
-- , divS
, minS
, maxS
  -- * Pixelwise logical operations
, CV.ImageMath.not
, CV.ImageMath.and
, CV.ImageMath.or
, CV.ImageMath.notOp
, CV.ImageMath.andOp
, CV.ImageMath.orOp
  -- * Comparison operations
, lessThan
, moreThan
, less2Than
, more2Than
, lessEq2Than
, moreEq2Than
  -- * Image statistics
, CV.ImageMath.sum
, average
, countNonZero
, averageMask
, stdDeviation
, stdDeviationMask
, findMinMax
, findMinMaxLoc
, findMinMaxMask
, imageMinMax -- TODO: merge with findMinMax / replace binding?
, minValue
, maxValue
, imageAvgSdv -- TODO: merge with average and stdDeviation / replace binding?
  -- * Misc (to be moved?)
, gaussianImage -- TODO: move to other module?
, fadedEdgeImage -- TODO: move to other module?
, fadeToCenter -- TODO: move to other module?
, maximalCoveringCircle -- TODO: move to other module?
, limitToOp -- TODO: remove? needed in Morphology; export operations at end?
-- TODO: add section "Image operations" and add the bare operations there for combining with others?
) where

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

import CV.Bindings.Types
import CV.Bindings.Core
import CV.Image
import CV.ImageOp

-- import C2HSTools
{#import CV.Image#}
import Foreign.Marshal
import Foreign.Storable
import Foreign.Ptr
import System.IO.Unsafe
import Control.Applicative ((<$>))

mkBinaryImageOpIO f = \a -> \b ->
          withGenImage a $ \ia ->
          withGenImage b $ \ib ->
          withCloneValue a    $ \clone ->
          withGenImage clone $ \cl -> do
            f ia ib cl
            return clone

mkBinaryImageOp
  :: (Ptr () -> Ptr () -> Ptr () -> IO a)
     -> CV.Image.Image c1 d1
     -> CV.Image.Image c1 d1
     -> CV.Image.Image c1 d1

mkBinaryImageOp f = \a -> \b -> unsafePerformIO $
          withGenImage a $ \ia ->
          withGenImage b $ \ib ->
          withCloneValue a    $ \clone ->
          withGenImage clone $ \cl -> do
            f ia ib cl
            return clone

-- I just can't think of a proper name for this
   -- Friday Evening
abcNullPtr f = \a b c -> f a b c nullPtr

addOp imageToBeAdded = ImgOp $ \target ->
              withGenImage target $ \ctarget ->
              withGenImage imageToBeAdded $ \cadd ->
               {#call cvAdd#} ctarget cadd ctarget nullPtr

-- | Calculates the per-pixel sum of two images.
add = mkBinaryImageOp $ abcNullPtr {#call cvAdd#}

-- | Calculates the per-pixel difference of two images.
sub = mkBinaryImageOp $ abcNullPtr {#call cvSub#}

subFrom what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvSub#} ifrom iwhat ifrom nullPtr

logOp :: ImageOperation GrayScale D32
logOp  = ImgOp $ \i -> withGenImage i (\img -> {#call cvLog#}  img img)

-- | Calculates the natural logarithm of every pixel.
log = unsafeOperate logOp

sqrtOp :: ImageOperation GrayScale D32
sqrtOp  = ImgOp $ \i -> withGenImage i (\img -> {#call sqrtImage#}  img img)

-- | Calculates the square root of every pixel.
sqrt = unsafeOperate sqrtOp

-- | Operation to limit image with another image; same as 'ImageMath.min'.
limitToOp what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvMin#} ifrom iwhat ifrom

-- | Limit image with another image; same as 'ImageMath.min'.
limitTo x y = unsafeOperate (limitToOp x) y

-- | Calculates the per-pixel product of two images.
mul = mkBinaryImageOp
    (\a b c -> {#call cvMul#} a b c 1)

-- | Calculates the per-pixel division of two images.
div = mkBinaryImageOp
    (\a b c -> {#call cvDiv#} a b c 1)

-- | Calculates the per-pixel minimum of two images.
min = mkBinaryImageOp {#call cvMin#}

-- | Calculates the per-pixel maximum of two images.
max = mkBinaryImageOp {#call cvMax#}

-- | Calculates the per-pixel absolute difference of two images.
absDiff = mkBinaryImageOp {#call cvAbsDiff#}

-- | Calculates the atan of every pixel.
atan :: Image GrayScale D32 -> Image GrayScale D32
atan i = unsafePerformIO $ do
                    let (w,h) = getSize i
                    res <- create (w,h)
                    withImage i $ \s ->
                     withImage res $ \r -> do
                      {#call calculateAtan#} s r
                      return res

-- | Calculates the atan2 of pixel values in two images.
atan2 :: Image GrayScale D32 -> Image GrayScale D32 -> Image GrayScale D32
atan2 a b = unsafePerformIO $ do
                    res <- create (getSize a)
                    withImage a $ \c_a ->
                     withImage b $ \c_b ->
                      withImage res $ \c_res -> do
                       {#call calculateAtan2#} c_a c_b c_res
                       return res

-- Operation that subtracts image mean from image
subtractMeanAbsOp = ImgOp $ \image -> do
                      av <- average' image
                      withGenImage image $ \i ->
                        {#call wrapAbsDiffS#} i (realToFrac av) i -- TODO: check C datatype sizes

-- | Calculates the absolute difference of every pixel to image mean.
--   See also 'ImageMath.subMean'.
subMeanAbs = unsafeOperate subtractMeanAbsOp

-- | Logical inversion of image (ie. invert, but stay on [0..1] range;
--   multiply by @-1@ and add @1@).
invert i = addS 1 $ mulS (-1) i

notOp :: ImageOperation GrayScale D8
notOp =  ImgOp $ \image -> withGenImage image $ \i -> {#call cvNot#} i i

not :: Image GrayScale D8 -> Image GrayScale D8
not = unsafeOperate notOp

andOp :: Image GrayScale D8 -> Mask -> ImageOperation GrayScale D8
andOp image0 mask = ImgOp $ \image1 ->
                  withGenImage image0 $ \ci0 ->
                  withGenImage image1 $ \ci1 ->
                  withMask     mask   $ \cmask ->
                  {#call cvAnd#} ci0 ci1 ci1 cmask

and :: Image GrayScale D8 -> Image GrayScale D8 -> Mask -> Image GrayScale D8
and i j mask = unsafeOperate (andOp i mask) j

orOp :: Image GrayScale D8 -> Mask -> ImageOperation GrayScale D8
orOp image0 mask = ImgOp $ \image1 ->
                  withGenImage image0 $ \ci0 ->
                  withGenImage image1 $ \ci1 ->
                  withMask     mask   $ \cmask ->
                  {#call cvOr#} ci0 ci1 ci1 cmask

or :: Image GrayScale D8 -> Image GrayScale D8 -> Mask -> Image GrayScale D8
or i j mask = unsafeOperate (orOp i mask) j

absOp = ImgOp $ \image -> do
                      withGenImage image $ \i ->
                        {#call wrapAbsDiffS#} i 0 i

-- | Calculates the absolute value of every pixel.
abs = unsafeOperate absOp

subtractMeanOp :: ImageOperation GrayScale D32
subtractMeanOp = ImgOp $ \image -> do
                      let s =  CV.ImageMath.sum image
                      let mean = s / (fromIntegral $ getArea image )
                      let (ImgOp subop) = subRSOp (realToFrac mean)
                      subop image

-- | Calculates the (non-absolute) difference of every pixel to image mean.
--   See also 'ImageMath.subMeanAbs'.
subMean = unsafeOperate subtractMeanOp

subRSOp :: D32 -> ImageOperation GrayScale D32
subRSOp scalar =  ImgOp $ \a ->
          withGenImage a $ \ia -> do
            {#call wrapSubRS#} ia (realToFrac scalar) ia

-- | Subtracts a scalar from every pixel, scalar on right.
subRS s a= unsafeOperate (subRSOp s) a

subSOp scalar =  ImgOp $ \a ->
          withGenImage a $ \ia -> do
            {#call wrapSubS#} ia (realToFrac scalar) ia

-- | Subtracts a scalar from every pixel, scalar on left.
subS a s = unsafeOperate (subSOp s) a

-- Multiply the image with scalar
mulSOp :: D32 -> ImageOperation GrayScale D32
mulSOp scalar = ImgOp $ \a ->
          withGenImage a $ \ia -> do
            {#call cvConvertScale#} ia ia s 0
            return ()
        where s = realToFrac scalar
                -- I've heard this will lose information

-- | Multiplies every pixel by a scalar.
mulS s = unsafeOperate $ mulSOp s

mkImgScalarOp op scalar = ImgOp $ \a ->
              withGenImage a $ \ia -> do
                op ia (realToFrac scalar) ia
                return ()

-- TODO: Relax the addition so it works on multiple image depths
addSOp :: D32 -> ImageOperation GrayScale D32
addSOp = mkImgScalarOp $ {#call wrapAddS#}

-- | Adds a scalar to every pixel.
addS s = unsafeOperate $ addSOp s

minSOp = mkImgScalarOp $ {#call cvMinS#}

-- | Calculates the per-pixel minimum between an image and a scalar.
minS :: Float -> Image c d -> Image c d
minS s = unsafeOperate $ minSOp s

maxSOp = mkImgScalarOp $ {#call cvMaxS#}

-- | Calculates the per-pixel maximum between an image and a scalar.
maxS :: Float -> Image c d -> Image c d
maxS s = unsafeOperate $ maxSOp s

-- Comparison operators
cmpEQ = 0
cmpGT = 1
cmpGE = 2
cmpLT = 3
cmpLE = 4
cmpNE = 5

-- TODO: For some reason the below was going through 8U images. Investigate
mkCmpOp :: CInt -> D32 -> (Image GrayScale D32 -> Image GrayScale D8)
mkCmpOp cmp = \scalar a -> unsafePerformIO $
          withGenImage a $ \ia -> do
                        new  <- create (getSize a) --8UC1
                        withGenImage new $ \cl -> do
                            {#call cvCmpS#} ia (realToFrac scalar) cl cmp
                            --imageTo32F new
                            return new

-- TODO: For some reason the below was going through 8U images. Investigate
mkCmp2Op :: (CreateImage (Image GrayScale d)) =>
           CInt -> (Image GrayScale d -> Image GrayScale d -> Image GrayScale D8)
mkCmp2Op cmp = \imgA imgB -> unsafePerformIO $ do
          withGenImage imgA $ \ia -> do
          withGenImage imgB $ \ib -> do
                        new  <- create (getSize imgA) -- 8U
                        withGenImage new $ \cl -> do
                            {#call cvCmp#} ia ib cl cmp
                            return new
                            --imageTo32F new

-- | Compares each pixel to a scalar, and produces a binary image where the
--   pixel value is less than the scalar. For example, @(lessThan s I)@ has
--   white pixels where value of I is less than s. Notice that the order of
--   operands is opposite to the intuitive interpretation of @s ``lessThan`` I@.
lessThan ::  D32 -> Image GrayScale D32 -> Image GrayScale D8
lessThan = mkCmpOp cmpLT

-- | Compares each pixel to a scalar, and produces a binary image where the
--   pixel value is greater than the scalar. For example, @(moreThan s I)@ has
--   white pixels where value of I is greater than s. Notice that the order of
--   operands is opposite to the intuitive interpretation of @s ``moreThan`` I@.
moreThan ::  D32 -> Image GrayScale D32 -> Image GrayScale D8
moreThan = mkCmpOp cmpGT

-- | Compares two images and produces a binary image that has white pixels in
--   those positions where the comparison is true. For example,
--   @(less2Than A B)@ has white pixels where value of A is less than value of
--   B. Notice that these functions follow the intuitive order of operands,
--   unlike 'lessThan' and 'moreThan'.
less2Than,lessEq2Than,more2Than, moreEq2Than
     :: (CreateImage (Image GrayScale d)) => Image GrayScale d -> Image GrayScale d -> Image GrayScale D8

less2Than = mkCmp2Op cmpLT
lessEq2Than = mkCmp2Op cmpLE
moreEq2Than = mkCmp2Op cmpGE
more2Than = mkCmp2Op cmpGT

-- Statistics

average' :: Image GrayScale D32 -> IO D32
average' img = withGenImage img $ \image ->
                {#call wrapAvg#} image nullPtr >>= return . realToFrac

-- | Calculate number of nonzero pixels
countNonZero :: Image GrayScale a -> Int
countNonZero img = unsafePerformIO $ withGenImage img $ \cImg -> fromIntegral <$> {#call cvCountNonZero#} cImg

-- | Calculates the average pixel value in whole image.
average :: Image GrayScale D32 -> D32
average = realToFrac.unsafePerformIO.average'

-- | Calculates the average value for pixels that have non-zero mask value.
averageMask :: Image GrayScale D32 -> Image GrayScale D8 -> D32
averageMask img mask = unsafePerformIO $
                       withGenImage img $ \c_image ->
                       withGenImage mask $ \c_mask ->
                        {#call wrapAvg#} c_image c_mask >>= return . realToFrac

-- | Calculates the sum of pixel values in whole image
--   (notice that OpenCV automatically casts the result to double).
sum :: Image GrayScale D32 -> D32
sum img = realToFrac $ unsafePerformIO $ withGenImage img $ \image ->
                    {#call wrapSum#} image

-- | Calculates the average of multiple images by adding the pixel values and
--   dividing the resulting values by number of images.
averageImages is = ( (1/(fromIntegral $ length is)) `mulS`) (foldl1 add is)

-- sum img = unsafePerformIO $ withGenImage img $ \image ->
--                    {#call wrapSum#} image

stdDeviation' img = withGenImage img {#call wrapStdDev#}

-- | Calculates the standard deviation of pixel values in whole image.
stdDeviation :: Image GrayScale D32 -> D32
stdDeviation = realToFrac . unsafePerformIO . stdDeviation'

-- | Calculates the standard deviation of values for pixels that have non-zero
--   mask value.
stdDeviationMask img mask = unsafePerformIO $
                                 withGenImage img $ \i ->
                                  withGenImage mask $ \m ->
                                   {#call wrapStdDevMask#} i m

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b
peekFloatConv a = fmap realToFrac (peek a)

{#fun wrapMinMax as findMinMax'
    { withGenBareImage* `BareImage'
    , withGenBareImage* `BareImage'
    , alloca-  `D32' peekFloatConv*
    , alloca-  `D32' peekFloatConv*} -- TODO: Check datatype sizes used in C!
    -> `()'#}

-- | Finds the minimum and maximum pixel value in the image and the locations
--   where these values were found.
findMinMaxLoc img = unsafePerformIO $
	     alloca $ \(ptrintmaxx :: Ptr CInt)->
	      alloca $ \(ptrintmaxy :: Ptr CInt)->
           alloca $ \(ptrintminx :: Ptr CInt)->
            alloca $ \(ptrintminy :: Ptr CInt)->
             alloca $ \(ptrintmin :: Ptr CDouble)->
              alloca $ \(ptrintmax :: Ptr CDouble)->
               withImage img $ \cimg -> do {
                 {#call wrapMinMaxLoc#} cimg ptrintminx ptrintminy ptrintmaxx ptrintmaxy ptrintmin ptrintmax;
		         minx <- fromIntegral <$> peek ptrintminx;
		         miny <- fromIntegral <$> peek ptrintminy;
		         maxx <- fromIntegral <$> peek ptrintmaxx;
		         maxy <- fromIntegral <$> peek ptrintmaxy;
		         maxval <- realToFrac <$> peek ptrintmax;
		         minval <- realToFrac <$> peek ptrintmin;
                 return (((minx,miny),minval),((maxx,maxy),maxval));}

-- TODO: create one function findMinMaxLoc' which takes also mask and base
-- findMinMax, findMinMaxLoc and findMinMaxMask (findMinMaxLocMask?) on it

-- findMinMax and findMinMaxLoc using the new bindings of cvMinMaxLoc...
-- do these really work also with D8 images? depends on fractional instance?
-- maybe create a new class or add a function to some existing class that
-- allows to get a pixel value from float..

-- | Finds the minimum and maximum pixel value in the image.
imageMinMax :: (Fractional d) => Image GrayScale d -> (d,d)
imageMinMax image = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      minval :: CDouble
      minval = 0
      maxval :: CDouble
      maxval = 0
    with minval $ \pminval ->
      with maxval $ \pmaxval -> do
        c'cvMinMaxLoc (castPtr pimage) pminval pmaxval nullPtr nullPtr nullPtr
        minv <- peek pminval
        maxv <- peek pmaxval
        return ((realToFrac minv), (realToFrac maxv))

-- | Finds the minimum and maximum pixel value in the image.
imageMinMaxLoc ::  (Fractional d) => Image GrayScale d -> (((Int,Int),d), ((Int,Int),d))
imageMinMaxLoc image = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      minval :: CDouble
      minval = 0
      maxval :: CDouble
      maxval = 0
      minloc :: C'CvPoint
      minloc = C'CvPoint 0 0
      maxloc :: C'CvPoint
      maxloc = C'CvPoint 0 0
    with minval $ \pminval ->
      with maxval $ \pmaxval ->
        with minloc $ \pminloc ->
          with maxloc $ \pmaxloc -> do
            c'cvMinMaxLoc (castPtr pimage) pminval pmaxval pminloc pmaxloc nullPtr
            minv <- peek pminval
            (C'CvPoint minx miny) <- peek pminloc
            maxv <- peek pmaxval
            (C'CvPoint maxx maxy) <- peek pmaxloc
            return $
              (((fromIntegral minx, fromIntegral miny), realToFrac minv),
               ((fromIntegral maxx, fromIntegral maxy), realToFrac maxv))

-- TODO: enable using a mask
-- | Calculates the average and standard deviation of pixel values in the image
--   in one operation.
imageAvgSdv :: (Fractional d) => Image GrayScale d -> (d,d)
imageAvgSdv i = unsafePerformIO $ do
  withImage i $ \i_ptr -> do
    let
      avg = (C'CvScalar 0 0 0 0)
      sdv = (C'CvScalar 0 0 0 0)
    with avg $ \avg_ptr ->
      with sdv $ \sdv_ptr -> do
        c'cvAvgSdv (castPtr i_ptr) avg_ptr sdv_ptr nullPtr
        (C'CvScalar a1 _ _ _) <- peek avg_ptr
        (C'CvScalar s1 _ _ _) <- peek sdv_ptr
        return (realToFrac a1, realToFrac s1)

-- | Finds the minimum and maximum pixel value in the image.
findMinMax i = unsafePerformIO $ do
               nullp <- newForeignPtr_ nullPtr
               (findMinMax' (unS i) (BareImage nullp))

-- | Finds the minimum and maximum value for pixels with non-zero mask value.
findMinMaxMask i mask  = unsafePerformIO (findMinMax' i mask)

-- let a = getAllPixels i in (minimum a,maximum a)

-- | Utility functions for getting the maximum or minimum pixel value of the
--   image; equal to @snd . findMinMax@ and @fst . findMinMax@.
maxValue,minValue :: Image GrayScale D32 -> D32
maxValue = snd.findMinMax
minValue = fst.findMinMax

-- | Render image of 2D gaussian curve with standard deviation of (stdX,stdY) to image size (w,h)
--   The origin/center of curve is in center of the image.
gaussianImage :: (Int,Int) -> (Double,Double) -> Image GrayScale D32
gaussianImage (w,h) (stdX,stdY) = unsafePerformIO $ do
    dst <- create (w,h) -- 32F_C1
    withImage dst $ \d-> do
                           {#call render_gaussian#} d (realToFrac stdX) (realToFrac stdY)
                           return dst

-- | Produce white image with 'edgeW' amount of edges fading to black.
fadedEdgeImage (w,h) edgeW = unsafePerformIO $ creatingImage ({#call fadedEdges#} w h edgeW)

-- | Produce image where pixel is coloured according to distance from the edge.
fadeToCenter (w,h) = unsafePerformIO $ creatingImage ({#call rectangularDistance#} w h )

-- TODO: Fix C-code of masked_merge to accept D8 input for the mask
-- | Merge two images according to a mask. Result is @R = A*m + B*(m-1)@.
maskedMerge :: Image GrayScale D8 -> Image GrayScale D32 -> Image GrayScale D32 -> Image GrayScale D32
maskedMerge mask img img2 = unsafePerformIO $ do
                              res <- create (getSize img)  -- 32FC1
                              withImage img $ \cimg ->
                               withImage img2 $ \cimg2 ->
                                withImage res $ \cres ->
                                  withImage (unsafeImageTo32F mask) $ \cmask ->
                                   {#call masked_merge#} cimg cmask cimg2 cres
                              return res

-- | Given a distance map and a circle, return the biggest circle with radius less
--   than given in the distance map that fully covers the previous one.
maximalCoveringCircle distMap (x,y,r)
  = unsafePerformIO $
     withImage distMap $ \c_distmap ->
       alloca $ \(ptr_int_max_x :: Ptr CInt) ->
        alloca $ \(ptr_int_max_y :: Ptr CInt) ->
         alloca $ \(ptr_double_max_r :: Ptr CDouble) ->
          do
           {#call maximal_covering_circle#} x y r c_distmap ptr_int_max_x ptr_int_max_y ptr_double_max_r
           max_x <- fromIntegral <$> peek ptr_int_max_x
           max_y <- fromIntegral <$> peek ptr_int_max_y
           max_r <- realToFrac   <$> peek ptr_double_max_r
           return (max_x,max_y,max_r)

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, FlexibleContexts#-}
#include "cvWrapLEO.h"

-- | Mathematical and statistical operations for images. See also module
--   "CV.ImageMathOp" which contains handy operators for some of these.
module CV.ImageMath(
  -- * Operations  for two images
  add
, sub
, absDiff
, mul
, CV.ImageMath.div
, CV.ImageMath.min
, CV.ImageMath.max
, maskedMerge
, averageImages
, CV.ImageMath.atan2
  -- * Operations for one image
, subMean
, subMeanAbs
, CV.ImageMath.sqrt
, CV.ImageMath.log
, CV.ImageMath.abs
, CV.ImageMath.atan
, invert
  -- * Operations for a scalar and an image
, addS
, subS
, subRS
, mulS
-- TODO: divS is missing, is it needed?
-- , divS
, minS
, maxS
  -- * Pixelwise logical operations
, CV.ImageMath.not
, CV.ImageMath.and
, CV.ImageMath.or
, CV.ImageMath.notOp
, CV.ImageMath.andOp
, CV.ImageMath.orOp
  -- * Comparison operations
, lessThan
, moreThan
, less2Than
, more2Than
, lessEq2Than
, moreEq2Than
  -- * Image statistics
, CV.ImageMath.sum
, average
, averageMask
, stdDeviation
, stdDeviationMask
, findMinMax
, findMinMaxLoc
, findMinMaxMask
, imageMinMax -- TODO: merge with findMinMax / replace binding?
, minValue
, maxValue
, imageAvgSdv -- TODO: merge with average and stdDeviation / replace binding?
  -- * Misc (to be moved?)
, gaussianImage -- TODO: move to other module?
, fadedEdgeImage -- TODO: move to other module?
, fadeToCenter -- TODO: move to other module?
, maximalCoveringCircle -- TODO: move to other module?
, limitToOp -- TODO: remove? needed in Morphology; export operations at end?
-- TODO: add section "Image operations" and add the bare operations there for combining with others?
) where

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

import CV.Bindings.Types
import CV.Bindings.Core
import CV.Image
import CV.ImageOp

-- import C2HSTools
{#import CV.Image#}
import Foreign.Marshal
import Foreign.Storable
import Foreign.Ptr
import System.IO.Unsafe
import Control.Applicative ((<$>))

mkBinaryImageOpIO f = \a -> \b ->
          withGenImage a $ \ia ->
          withGenImage b $ \ib ->
          withCloneValue a    $ \clone ->
          withGenImage clone $ \cl -> do
            f ia ib cl
            return clone

mkBinaryImageOp
  :: (Ptr () -> Ptr () -> Ptr () -> IO a)
     -> CV.Image.Image c1 d1
     -> CV.Image.Image c1 d1
     -> CV.Image.Image c1 d1

mkBinaryImageOp f = \a -> \b -> unsafePerformIO $
          withGenImage a $ \ia ->
          withGenImage b $ \ib ->
          withCloneValue a    $ \clone ->
          withGenImage clone $ \cl -> do
            f ia ib cl
            return clone

-- I just can't think of a proper name for this
   -- Friday Evening
abcNullPtr f = \a b c -> f a b c nullPtr

addOp imageToBeAdded = ImgOp $ \target ->
              withGenImage target $ \ctarget ->
              withGenImage imageToBeAdded $ \cadd ->
               {#call cvAdd#} ctarget cadd ctarget nullPtr

-- | Calculates the per-pixel sum of two images.
add = mkBinaryImageOp $ abcNullPtr {#call cvAdd#}

-- | Calculates the per-pixel difference of two images.
sub = mkBinaryImageOp $ abcNullPtr {#call cvSub#}

subFrom what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvSub#} ifrom iwhat ifrom nullPtr

logOp :: ImageOperation GrayScale D32
logOp  = ImgOp $ \i -> withGenImage i (\img -> {#call cvLog#}  img img)

-- | Calculates the natural logarithm of every pixel.
log = unsafeOperate logOp

sqrtOp :: ImageOperation GrayScale D32
sqrtOp  = ImgOp $ \i -> withGenImage i (\img -> {#call sqrtImage#}  img img)

-- | Calculates the square root of every pixel.
sqrt = unsafeOperate sqrtOp

-- | Operation to limit image with another image; same as 'ImageMath.min'.
limitToOp what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvMin#} ifrom iwhat ifrom

-- | Limit image with another image; same as 'ImageMath.min'.
limitTo x y = unsafeOperate (limitToOp x) y

-- | Calculates the per-pixel product of two images.
mul = mkBinaryImageOp
    (\a b c -> {#call cvMul#} a b c 1)

-- | Calculates the per-pixel division of two images.
div = mkBinaryImageOp
    (\a b c -> {#call cvDiv#} a b c 1)

-- | Calculates the per-pixel minimum of two images.
min = mkBinaryImageOp {#call cvMin#}

-- | Calculates the per-pixel maximum of two images.
max = mkBinaryImageOp {#call cvMax#}

-- | Calculates the per-pixel absolute difference of two images.
absDiff = mkBinaryImageOp {#call cvAbsDiff#}

-- | Calculates the atan of every pixel.
atan :: Image GrayScale D32 -> Image GrayScale D32
atan i = unsafePerformIO $ do
                    let (w,h) = getSize i
                    res <- create (w,h)
                    withImage i $ \s ->
                     withImage res $ \r -> do
                      {#call calculateAtan#} s r
                      return res

-- | Calculates the atan2 of pixel values in two images.
atan2 :: Image GrayScale D32 -> Image GrayScale D32 -> Image GrayScale D32
atan2 a b = unsafePerformIO $ do
                    res <- create (getSize a)
                    withImage a $ \c_a ->
                     withImage b $ \c_b ->
                      withImage res $ \c_res -> do
                       {#call calculateAtan2#} c_a c_b c_res
                       return res

-- Operation that subtracts image mean from image
subtractMeanAbsOp = ImgOp $ \image -> do
                      av <- average' image
                      withGenImage image $ \i ->
                        {#call wrapAbsDiffS#} i (realToFrac av) i -- TODO: check C datatype sizes

-- | Calculates the absolute difference of every pixel to image mean.
--   See also 'ImageMath.subMean'.
subMeanAbs = unsafeOperate subtractMeanAbsOp

-- | Logical inversion of image (ie. invert, but stay on [0..1] range;
--   multiply by @-1@ and add @1@).
invert i = addS 1 $ mulS (-1) i

notOp :: ImageOperation GrayScale D8
notOp =  ImgOp $ \image -> withGenImage image $ \i -> {#call cvNot#} i i

not :: Image GrayScale D8 -> Image GrayScale D8
not = unsafeOperate notOp

andOp :: Image GrayScale D8 -> Mask -> ImageOperation GrayScale D8
andOp image0 mask = ImgOp $ \image1 ->
                  withGenImage image0 $ \ci0 ->
                  withGenImage image1 $ \ci1 ->
                  withMask     mask   $ \cmask ->
                  {#call cvAnd#} ci0 ci1 ci1 cmask

and :: Image GrayScale D8 -> Image GrayScale D8 -> Mask -> Image GrayScale D8
and i j mask = unsafeOperate (andOp i mask) j

orOp :: Image GrayScale D8 -> Mask -> ImageOperation GrayScale D8
orOp image0 mask = ImgOp $ \image1 ->
                  withGenImage image0 $ \ci0 ->
                  withGenImage image1 $ \ci1 ->
                  withMask     mask   $ \cmask ->
                  {#call cvOr#} ci0 ci1 ci1 cmask

or :: Image GrayScale D8 -> Image GrayScale D8 -> Mask -> Image GrayScale D8
or i j mask = unsafeOperate (orOp i mask) j

absOp = ImgOp $ \image -> do
                      withGenImage image $ \i ->
                        {#call wrapAbsDiffS#} i 0 i

-- | Calculates the absolute value of every pixel.
abs = unsafeOperate absOp

subtractMeanOp :: ImageOperation GrayScale D32
subtractMeanOp = ImgOp $ \image -> do
                      let s =  CV.ImageMath.sum image
                      let mean = s / (fromIntegral $ getArea image )
                      let (ImgOp subop) = subRSOp (realToFrac mean)
                      subop image

-- | Calculates the (non-absolute) difference of every pixel to image mean.
--   See also 'ImageMath.subMeanAbs'.
subMean = unsafeOperate subtractMeanOp

subRSOp :: D32 -> ImageOperation GrayScale D32
subRSOp scalar =  ImgOp $ \a ->
          withGenImage a $ \ia -> do
            {#call wrapSubRS#} ia (realToFrac scalar) ia

-- | Subtracts a scalar from every pixel, scalar on right.
subRS s a= unsafeOperate (subRSOp s) a

subSOp scalar =  ImgOp $ \a ->
          withGenImage a $ \ia -> do
            {#call wrapSubS#} ia (realToFrac scalar) ia

-- | Subtracts a scalar from every pixel, scalar on left.
subS a s = unsafeOperate (subSOp s) a

-- Multiply the image with scalar
mulSOp :: D32 -> ImageOperation GrayScale D32
mulSOp scalar = ImgOp $ \a ->
          withGenImage a $ \ia -> do
            {#call cvConvertScale#} ia ia s 0
            return ()
        where s = realToFrac scalar
                -- I've heard this will lose information

-- | Multiplies every pixel by a scalar.
mulS s = unsafeOperate $ mulSOp s

mkImgScalarOp op scalar = ImgOp $ \a ->
              withGenImage a $ \ia -> do
                op ia (realToFrac scalar) ia
                return ()

-- TODO: Relax the addition so it works on multiple image depths
addSOp :: D32 -> ImageOperation GrayScale D32
addSOp = mkImgScalarOp $ {#call wrapAddS#}

-- | Adds a scalar to every pixel.
addS s = unsafeOperate $ addSOp s

minSOp = mkImgScalarOp $ {#call cvMinS#}

-- | Calculates the per-pixel minimum between an image and a scalar.
minS :: Float -> Image c d -> Image c d
minS s = unsafeOperate $ minSOp s

maxSOp = mkImgScalarOp $ {#call cvMaxS#}

-- | Calculates the per-pixel maximum between an image and a scalar.
maxS :: Float -> Image c d -> Image c d
maxS s = unsafeOperate $ maxSOp s

-- Comparison operators
cmpEQ = 0
cmpGT = 1
cmpGE = 2
cmpLT = 3
cmpLE = 4
cmpNE = 5

-- TODO: For some reason the below was going through 8U images. Investigate
mkCmpOp :: CInt -> D32 -> (Image GrayScale D32 -> Image GrayScale D8)
mkCmpOp cmp = \scalar a -> unsafePerformIO $
          withGenImage a $ \ia -> do
                        new  <- create (getSize a) --8UC1
                        withGenImage new $ \cl -> do
                            {#call cvCmpS#} ia (realToFrac scalar) cl cmp
                            --imageTo32F new
                            return new

-- TODO: For some reason the below was going through 8U images. Investigate
mkCmp2Op :: (CreateImage (Image GrayScale d)) =>
           CInt -> (Image GrayScale d -> Image GrayScale d -> Image GrayScale D8)
mkCmp2Op cmp = \imgA imgB -> unsafePerformIO $ do
          withGenImage imgA $ \ia -> do
          withGenImage imgB $ \ib -> do
                        new  <- create (getSize imgA) -- 8U
                        withGenImage new $ \cl -> do
                            {#call cvCmp#} ia ib cl cmp
                            return new
                            --imageTo32F new

-- | Compares each pixel to a scalar, and produces a binary image where the
--   pixel value is less than the scalar. For example, @(lessThan s I)@ has
--   white pixels where value of I is less than s. Notice that the order of
--   operands is opposite to the intuitive interpretation of @s ``lessThan`` I@.
lessThan ::  D32 -> Image GrayScale D32 -> Image GrayScale D8
lessThan = mkCmpOp cmpLT

-- | Compares each pixel to a scalar, and produces a binary image where the
--   pixel value is greater than the scalar. For example, @(moreThan s I)@ has
--   white pixels where value of I is greater than s. Notice that the order of
--   operands is opposite to the intuitive interpretation of @s ``moreThan`` I@.
moreThan ::  D32 -> Image GrayScale D32 -> Image GrayScale D8
moreThan = mkCmpOp cmpGT

-- | Compares two images and produces a binary image that has white pixels in
--   those positions where the comparison is true. For example,
--   @(less2Than A B)@ has white pixels where value of A is less than value of
--   B. Notice that these functions follow the intuitive order of operands,
--   unlike 'lessThan' and 'moreThan'.
less2Than,lessEq2Than,more2Than, moreEq2Than
     :: (CreateImage (Image GrayScale d)) => Image GrayScale d -> Image GrayScale d -> Image GrayScale D8

less2Than = mkCmp2Op cmpLT
lessEq2Than = mkCmp2Op cmpLE
moreEq2Than = mkCmp2Op cmpGE
more2Than = mkCmp2Op cmpGT

-- Statistics

average' :: Image GrayScale D32 -> IO D32
average' img = withGenImage img $ \image ->
                {#call wrapAvg#} image nullPtr >>= return . realToFrac

-- | Calculates the average pixel value in whole image.
average :: Image GrayScale D32 -> D32
average = realToFrac.unsafePerformIO.average'

-- | Calculates the average value for pixels that have non-zero mask value.
averageMask :: Image GrayScale D32 -> Image GrayScale D8 -> D32
averageMask img mask = unsafePerformIO $
                       withGenImage img $ \c_image ->
                       withGenImage mask $ \c_mask ->
                        {#call wrapAvg#} c_image c_mask >>= return . realToFrac

-- | Calculates the sum of pixel values in whole image
--   (notice that OpenCV automatically casts the result to double).
sum :: Image GrayScale D32 -> D32
sum img = realToFrac $ unsafePerformIO $ withGenImage img $ \image ->
                    {#call wrapSum#} image

-- | Calculates the average of multiple images by adding the pixel values and
--   dividing the resulting values by number of images.
averageImages is = ( (1/(fromIntegral $ length is)) `mulS`) (foldl1 add is)

-- sum img = unsafePerformIO $ withGenImage img $ \image ->
--                    {#call wrapSum#} image

stdDeviation' img = withGenImage img {#call wrapStdDev#}

-- | Calculates the standard deviation of pixel values in whole image.
stdDeviation :: Image GrayScale D32 -> D32
stdDeviation = realToFrac . unsafePerformIO . stdDeviation'

-- | Calculates the standard deviation of values for pixels that have non-zero
--   mask value.
stdDeviationMask img mask = unsafePerformIO $
                                 withGenImage img $ \i ->
                                  withGenImage mask $ \m ->
                                   {#call wrapStdDevMask#} i m

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b
peekFloatConv a = fmap realToFrac (peek a)

{#fun wrapMinMax as findMinMax'
    { withGenBareImage* `BareImage'
    , withGenBareImage* `BareImage'
    , alloca-  `D32' peekFloatConv*
    , alloca-  `D32' peekFloatConv*} -- TODO: Check datatype sizes used in C!
    -> `()'#}

-- | Finds the minimum and maximum pixel value in the image and the locations
--   where these values were found.
findMinMaxLoc img = unsafePerformIO $
	     alloca $ \(ptrintmaxx :: Ptr CInt)->
	      alloca $ \(ptrintmaxy :: Ptr CInt)->
           alloca $ \(ptrintminx :: Ptr CInt)->
            alloca $ \(ptrintminy :: Ptr CInt)->
             alloca $ \(ptrintmin :: Ptr CDouble)->
              alloca $ \(ptrintmax :: Ptr CDouble)->
               withImage img $ \cimg -> do {
                 {#call wrapMinMaxLoc#} cimg ptrintminx ptrintminy ptrintmaxx ptrintmaxy ptrintmin ptrintmax;
		         minx <- fromIntegral <$> peek ptrintminx;
		         miny <- fromIntegral <$> peek ptrintminy;
		         maxx <- fromIntegral <$> peek ptrintmaxx;
		         maxy <- fromIntegral <$> peek ptrintmaxy;
		         maxval <- realToFrac <$> peek ptrintmax;
		         minval <- realToFrac <$> peek ptrintmin;
                 return (((minx,miny),minval),((maxx,maxy),maxval));}

-- TODO: create one function findMinMaxLoc' which takes also mask and base
-- findMinMax, findMinMaxLoc and findMinMaxMask (findMinMaxLocMask?) on it

-- findMinMax and findMinMaxLoc using the new bindings of cvMinMaxLoc...
-- do these really work also with D8 images? depends on fractional instance?
-- maybe create a new class or add a function to some existing class that
-- allows to get a pixel value from float..

-- | Finds the minimum and maximum pixel value in the image.
imageMinMax :: (Fractional d) => Image GrayScale d -> (d,d)
imageMinMax image = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      minval :: CDouble
      minval = 0
      maxval :: CDouble
      maxval = 0
    with minval $ \pminval ->
      with maxval $ \pmaxval -> do
        c'cvMinMaxLoc (castPtr pimage) pminval pmaxval nullPtr nullPtr nullPtr
        minv <- peek pminval
        maxv <- peek pmaxval
        return ((realToFrac minv), (realToFrac maxv))

-- | Finds the minimum and maximum pixel value in the image.
imageMinMaxLoc ::  (Fractional d) => Image GrayScale d -> (((Int,Int),d), ((Int,Int),d))
imageMinMaxLoc image = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      minval :: CDouble
      minval = 0
      maxval :: CDouble
      maxval = 0
      minloc :: C'CvPoint
      minloc = C'CvPoint 0 0
      maxloc :: C'CvPoint
      maxloc = C'CvPoint 0 0
    with minval $ \pminval ->
      with maxval $ \pmaxval ->
        with minloc $ \pminloc ->
          with maxloc $ \pmaxloc -> do
            c'cvMinMaxLoc (castPtr pimage) pminval pmaxval pminloc pmaxloc nullPtr
            minv <- peek pminval
            (C'CvPoint minx miny) <- peek pminloc
            maxv <- peek pmaxval
            (C'CvPoint maxx maxy) <- peek pmaxloc
            return $
              (((fromIntegral minx, fromIntegral miny), realToFrac minv),
               ((fromIntegral maxx, fromIntegral maxy), realToFrac maxv))

-- TODO: enable using a mask
-- | Calculates the average and standard deviation of pixel values in the image
--   in one operation.
imageAvgSdv :: (Fractional d) => Image GrayScale d -> (d,d)
imageAvgSdv i = unsafePerformIO $ do
  withImage i $ \i_ptr -> do
    let
      avg = (C'CvScalar 0 0 0 0)
      sdv = (C'CvScalar 0 0 0 0)
    with avg $ \avg_ptr ->
      with sdv $ \sdv_ptr -> do
        c'cvAvgSdv (castPtr i_ptr) avg_ptr sdv_ptr nullPtr
        (C'CvScalar a1 _ _ _) <- peek avg_ptr
        (C'CvScalar s1 _ _ _) <- peek sdv_ptr
        return (realToFrac a1, realToFrac s1)

-- | Finds the minimum and maximum pixel value in the image.
findMinMax i = unsafePerformIO $ do
               nullp <- newForeignPtr_ nullPtr
               (findMinMax' (unS i) (BareImage nullp))

-- | Finds the minimum and maximum value for pixels with non-zero mask value.
findMinMaxMask i mask  = unsafePerformIO (findMinMax' i mask)

-- let a = getAllPixels i in (minimum a,maximum a)

-- | Utility functions for getting the maximum or minimum pixel value of the
--   image; equal to @snd . findMinMax@ and @fst . findMinMax@.
maxValue,minValue :: Image GrayScale D32 -> D32
maxValue = snd.findMinMax
minValue = fst.findMinMax

-- | Render image of 2D gaussian curve with standard deviation of (stdX,stdY) to image size (w,h)
--   The origin/center of curve is in center of the image.
gaussianImage :: (Int,Int) -> (Double,Double) -> Image GrayScale D32
gaussianImage (w,h) (stdX,stdY) = unsafePerformIO $ do
    dst <- create (w,h) -- 32F_C1
    withImage dst $ \d-> do
                           {#call render_gaussian#} d (realToFrac stdX) (realToFrac stdY)
                           return dst

-- | Produce white image with 'edgeW' amount of edges fading to black.
fadedEdgeImage (w,h) edgeW = unsafePerformIO $ creatingImage ({#call fadedEdges#} w h edgeW)

-- | Produce image where pixel is coloured according to distance from the edge.
fadeToCenter (w,h) = unsafePerformIO $ creatingImage ({#call rectangularDistance#} w h )

-- TODO: Fix C-code of masked_merge to accept D8 input for the mask
-- | Merge two images according to a mask. Result is @R = A*m + B*(m-1)@.
maskedMerge :: Image GrayScale D8 -> Image GrayScale D32 -> Image GrayScale D32 -> Image GrayScale D32
maskedMerge mask img img2 = unsafePerformIO $ do
                              res <- create (getSize img)  -- 32FC1
                              withImage img $ \cimg ->
                               withImage img2 $ \cimg2 ->
                                withImage res $ \cres ->
                                  withImage (unsafeImageTo32F mask) $ \cmask ->
                                   {#call masked_merge#} cimg cmask cimg2 cres
                              return res

-- | Given a distance map and a circle, return the biggest circle with radius less
--   than given in the distance map that fully covers the previous one.
maximalCoveringCircle distMap (x,y,r)
  = unsafePerformIO $
     withImage distMap $ \c_distmap ->
       alloca $ \(ptr_int_max_x :: Ptr CInt) ->
        alloca $ \(ptr_int_max_y :: Ptr CInt) ->
         alloca $ \(ptr_double_max_r :: Ptr CDouble) ->
          do
           {#call maximal_covering_circle#} x y r c_distmap ptr_int_max_x ptr_int_max_y ptr_double_max_r
           max_x <- fromIntegral <$> peek ptr_int_max_x
           max_y <- fromIntegral <$> peek ptr_int_max_y
           max_r <- realToFrac   <$> peek ptr_double_max_r
           return (max_x,max_y,max_r)


Change for poppler-glib-0.16

Change for poppler-glib-0.16

{-# LANGUAGE CPP, DeriveDataTypeable #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to poppler -*-haskell-*-
--
--  Author : Andy Stewart
--  Created: 18-Jun-2010
--
--  Copyright (c) 2010 Andy Stewart
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  POPPLER, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original POPPLER documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Graphics.UI.Gtk.Poppler.Page (
-- * Types
    Cairo,
    PopplerRectangle (..),
    PopplerColor (..),
    ImageMapping,
    PageTransition,
    LinkMapping,
    FormFieldMapping,

-- * Enums
    SelectionStyle (..),

-- * Methods
    pageRender,
    pageRenderToPixbuf,
    pageGetSize,
    pageGetIndex,
    pageGetThumbnail,
    pageGetThumbnailSize,
    pageRenderToPs,
    pageFindText,
    pageGetText,
    pageGetDuration,
    pageGetTransition,
    pageGetLinkMapping,
    pageGetImageMapping,
    pageGetFormFieldMapping,
    pageGetSelectionRegion,
    pageRenderSelection,
    pageRenderSelectionToPixbuf,
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs
import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO)
import Graphics.Rendering.Cairo.Internal (Render(..), bracketR)

{# context lib="poppler" prefix="poppler" #}

-- | Render the page to the given cairo context. This function is for rendering a page that will be
-- displayed. If you want to render a page that will be printed use 'pageRenderForPrinting'
-- instead
pageRender :: PageClass page => page
 -> Render ()
pageRender page =
  ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x)

-- | First scale the document to match the specified pixels per point, then render the rectangle given by
-- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering
-- a page that will be displayed. If you want to render a page that will be printed use
-- 'pageRenderToPixbufForPrinting' instead
pageRenderToPixbuf :: PageClass page => page
 -> Rectangle -- ^ @rect@      rectangle to render
 -> Double -- ^ @scale@      scale specified as pixels per point
 -> Int -- ^ @rotation@   rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@     pixbuf to render into
 -> IO ()
pageRenderToPixbuf page (Rectangle x y width height) scale rotation pixbuf =
  {#call poppler_page_render_to_pixbuf #}
    (toPage page)
    (fromIntegral x)
    (fromIntegral y)
    (fromIntegral width)
    (fromIntegral height)
    (realToFrac scale)
    (fromIntegral rotation)
    pixbuf

-- | Gets the size of page at the current scale and rotation.
pageGetSize :: PageClass page => page
 -> IO (Double, Double)
pageGetSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
      {#call poppler_page_get_size #}
        (toPage page)
        widthPtr
        heightPtr
      width <- peek widthPtr
      height <- peek heightPtr
      return (realToFrac width, realToFrac height)

-- | Returns the index of page
pageGetIndex :: PageClass page => page
 -> IO Int  -- ^ returns index value of page
pageGetIndex page =
  liftM fromIntegral $
  {#call poppler_page_get_index #} (toPage page)

-- | Get the embedded thumbnail for the specified page. If the document doesn't have an embedded
-- thumbnail for the page, this function returns 'Nothing'.
pageGetThumbnail :: PageClass page => page
 -> IO (Maybe Surface) -- ^ returns the tumbnail as a @cairoSurfaceT@ or 'Nothing' if the document doesn't have a thumbnail for this page.
pageGetThumbnail page = do
  surfacePtr <- {#call poppler_page_get_thumbnail #} (toPage page)
  if surfacePtr == nullPtr
     then return Nothing
     else liftM Just (mkSurface surfacePtr)

-- | Returns 'True' if page has a thumbnail associated with it. It also fills in width and height with the
-- width and height of the thumbnail. The values of width and height are not changed if no appropriate
-- thumbnail exists.
pageGetThumbnailSize :: PageClass page => page
 -> IO (Maybe (Int, Int))
pageGetThumbnailSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
    success <- liftM toBool $
                {#call poppler_page_get_thumbnail_size #}
                  (toPage page)
                  widthPtr
                  heightPtr
    if success
       then do
         width  <- peek widthPtr
         height <- peek heightPtr
         return $ Just (fromIntegral width, fromIntegral height)
       else return Nothing

-- | Render the page on a postscript file
pageRenderToPs :: (PageClass page, PSFileClass psFile) => page -> psFile -> IO ()
pageRenderToPs page psFile =
  {#call poppler_page_render_to_ps #} (toPage page) (toPSFile psFile)

-- | A GList of rectangles for each occurance of the text on the page. The coordinates are in PDF points.
pageFindText :: PageClass page => page
 -> String  -- ^ @text@    the text to search for (UTF-8 encoded)
 -> IO [PopplerRectangle]
pageFindText page text =
  withUTFString text $ \ textPtr -> do
    glistPtr <- {#call poppler_page_find_text #} (toPage page) textPtr
    list <- fromGList glistPtr
    mapM peekPopplerRectangle list

-- | Retrieves the contents of the specified selection as text.
pageGetText :: PageClass page => page -> IO String  -- ^ returns selection string
pageGetText page =
  {#call poppler_page_get_text #} (toPage page)
  >>= peekUTFString

-- | Returns the duration of page
pageGetDuration :: PageClass page => page
 -> IO Double  -- ^ returns duration in seconds of page or -1.
pageGetDuration page =
  liftM realToFrac $
  {#call poppler_page_get_duration #} (toPage page)

-- | Returns the transition effect of page
pageGetTransition :: PageClass page => page
 -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'.
pageGetTransition page = do
  ptr <- {#call poppler_page_get_transition #} (toPage page)
  if ptr == nullPtr
     then return Nothing
     else liftM Just $ makeNewPageTransition (castPtr ptr)

{#pointer *PageTransition foreign newtype #}

makeNewPageTransition :: Ptr PageTransition -> IO PageTransition
makeNewPageTransition rPtr = do
  transition <- newForeignPtr rPtr page_transition_free
  return (PageTransition transition)

foreign import ccall unsafe "&poppler_page_transition_free"
  page_transition_free :: FinalizerPtr PageTransition

-- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'.
pageGetLinkMapping :: PageClass page => page
 -> IO [LinkMapping]
pageGetLinkMapping page = do
  glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewLinkMapping list
  {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *LinkMapping foreign newtype #}

makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping
makeNewLinkMapping rPtr = do
  linkMapping <- newForeignPtr rPtr poppler_link_mapping_free
  return (LinkMapping linkMapping)

foreign import ccall unsafe "&poppler_link_mapping_free"
  poppler_link_mapping_free :: FinalizerPtr LinkMapping

-- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'.
pageGetImageMapping :: PageClass page => page
 -> IO [ImageMapping]
pageGetImageMapping page = do
  glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewImageMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *ImageMapping foreign newtype #}

makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping
makeNewImageMapping rPtr = do
  imageMapping <- newForeignPtr rPtr poppler_image_mapping_free
  return (ImageMapping imageMapping)

foreign import ccall unsafe "&poppler_image_mapping_free"
  poppler_image_mapping_free :: FinalizerPtr ImageMapping

-- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'.
pageGetFormFieldMapping :: PageClass page => page
 -> IO [FormFieldMapping]
pageGetFormFieldMapping page = do
  glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewFormFieldMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *FormFieldMapping foreign newtype #}

makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping
makeNewFormFieldMapping rPtr = do
  formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free
  return (FormFieldMapping formFieldMapping)

foreign import ccall unsafe "&poppler_form_field_mapping_free"
  poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping

-- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or
-- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle.
pageGetSelectionRegion :: PageClass page => page
 -> Double -- ^ @scale@     scale specified as pixels per point
 -> SelectionStyle -- ^ @style@     a 'SelectionStyle'
 -> PopplerRectangle -- ^ @selection@ start and end point of selection as a rectangle
 -> IO [PopplerRectangle]
pageGetSelectionRegion page scale style selection =
  with selection $ \ selectionPtr -> do
    glistPtr <- {#call poppler_page_get_selection_region #}
                 (toPage page)
                 (realToFrac scale)
                 ((fromIntegral . fromEnum) style)
                 (castPtr selectionPtr)
    list <- fromGList glistPtr
    rectangles <- mapM peekPopplerRectangle list
    {#call unsafe poppler_page_selection_region_free #} (castPtr glistPtr)
    return rectangles

-- | Render the selection specified by selection for page to the given cairo context. The selection will
-- be rendered, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered to cairo, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelection :: PageClass page => page
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> PopplerColor -- ^ @glyphColor@      color to use for drawing glyphs
 -> PopplerColor -- ^ @backgroundColor@ color to use for the selection background
 -> Render ()
pageRenderSelection page selection oldSelection style glyphColor backgroundColor = do
  cairo <- ask
  liftIO $
         with selection $ \ selectionPtr ->
         with oldSelection $ \ oldSelectionPtr ->
         with glyphColor $ \ glyphColorPtr ->
         with backgroundColor $ \ backgroundColorPtr ->
              {#call poppler_page_render_selection #}
                  (toPage page)
                  cairo
                  (castPtr selectionPtr)
                  (castPtr oldSelectionPtr)
                  ((fromIntegral . fromEnum) style)
                  (castPtr glyphColorPtr)
                  (castPtr backgroundColorPtr)

-- | Render the selection specified by selection for page into pixbuf. The selection will be rendered at
-- scale, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered in pixbuf, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelectionToPixbuf :: PageClass page => page
 -> Double -- ^ @scale@            scale specified as pixels per point
 -> Int -- ^ @rotation@         rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@           pixbuf to render to
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> Color -- ^ @glyphColor@      color to use for drawing glyphs
 -> Color -- ^ @backgroundColor@ color to use for the selection background
 -> IO ()
pageRenderSelectionToPixbuf page scale rotation pixbuf selection oldSelection style glyphColor backgroundColor =
  with selection $ \ selectionPtr ->
  with oldSelection $ \ oldSelectionPtr ->
  with glyphColor $ \ glyphColorPtr ->
  with backgroundColor $ \ backgroundColorPtr ->
      {#call poppler_page_render_selection_to_pixbuf #}
        (toPage page)
        (realToFrac scale)
        (fromIntegral rotation)
        pixbuf
        (castPtr selectionPtr)
        (castPtr oldSelectionPtr)
        ((fromIntegral . fromEnum) style)
        (castPtr glyphColorPtr)
        (castPtr backgroundColorPtr)

{-# LANGUAGE CPP, DeriveDataTypeable #-}
--  GIMP Toolkit (GTK) Binding for Haskell: binding to poppler -*-haskell-*-
--
--  Author : Andy Stewart
--  Created: 18-Jun-2010
--
--  Copyright (c) 2010 Andy Stewart
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  POPPLER, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original POPPLER documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Graphics.UI.Gtk.Poppler.Page (
-- * Types
    Cairo,
    PopplerRectangle (..),
    PopplerColor (..),
    ImageMapping,
    PageTransition,
    LinkMapping,
    FormFieldMapping,

-- * Enums
    SelectionStyle (..),

-- * Methods
    pageRender,
    pageRenderToPixbuf,
    pageGetSize,
    pageGetIndex,
    pageGetThumbnail,
    pageGetThumbnailSize,
    pageRenderToPs,
    pageFindText,
    pageGetText,
    pageGetDuration,
    pageGetTransition,
    pageGetLinkMapping,
    pageGetImageMapping,
    pageGetFormFieldMapping,
    pageGetSelectionRegion,
    pageRenderSelection,
    pageRenderSelectionToPixbuf,
    ) where

import Control.Monad
import Data.Typeable
import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.GObject
import System.Glib.GList
import System.Glib.UTFString
import Graphics.UI.Gtk.Poppler.Enums
import Graphics.UI.Gtk.Abstract.Widget (Rectangle (..), Color (..))
{#import Graphics.UI.GtkInternals#}
{#import Graphics.Rendering.Cairo.Types#}
{#import Graphics.UI.Gtk.Poppler.Types#}
import Graphics.UI.Gtk.Poppler.Structs
import Control.Monad.Reader (ReaderT(runReaderT), ask, MonadIO, liftIO)
import Graphics.Rendering.Cairo.Internal (Render(..), bracketR)

{# context lib="poppler" prefix="poppler" #}

-- | Render the page to the given cairo context. This function is for rendering a page that will be
-- displayed. If you want to render a page that will be printed use 'pageRenderForPrinting'
-- instead
pageRender :: PageClass page => page
 -> Render ()
pageRender page =
  ask >>= \ x -> liftIO ({#call poppler_page_render #} (toPage page) x)

-- | First scale the document to match the specified pixels per point, then render the rectangle given by
-- the upper left corner at (@srcX@, @srcY@) and @srcWidth@ and @srcHeight@. This function is for rendering
-- a page that will be displayed. If you want to render a page that will be printed use
-- 'pageRenderToPixbufForPrinting' instead
pageRenderToPixbuf :: PageClass page => page
 -> Rectangle -- ^ @rect@      rectangle to render
 -> Double -- ^ @scale@      scale specified as pixels per point
 -> Int -- ^ @rotation@   rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@     pixbuf to render into
 -> IO ()
pageRenderToPixbuf page (Rectangle x y width height) scale rotation pixbuf =
  {#call poppler_page_render_to_pixbuf #}
    (toPage page)
    (fromIntegral x)
    (fromIntegral y)
    (fromIntegral width)
    (fromIntegral height)
    (realToFrac scale)
    (fromIntegral rotation)
    pixbuf

-- | Gets the size of page at the current scale and rotation.
pageGetSize :: PageClass page => page
 -> IO (Double, Double)
pageGetSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
      {#call poppler_page_get_size #}
        (toPage page)
        widthPtr
        heightPtr
      width <- peek widthPtr
      height <- peek heightPtr
      return (realToFrac width, realToFrac height)

-- | Returns the index of page
pageGetIndex :: PageClass page => page
 -> IO Int  -- ^ returns index value of page
pageGetIndex page =
  liftM fromIntegral $
  {#call poppler_page_get_index #} (toPage page)

-- | Get the embedded thumbnail for the specified page. If the document doesn't have an embedded
-- thumbnail for the page, this function returns 'Nothing'.
pageGetThumbnail :: PageClass page => page
 -> IO (Maybe Surface) -- ^ returns the tumbnail as a @cairoSurfaceT@ or 'Nothing' if the document doesn't have a thumbnail for this page.
pageGetThumbnail page = do
  surfacePtr <- {#call poppler_page_get_thumbnail #} (toPage page)
  if surfacePtr == nullPtr
     then return Nothing
     else liftM Just (mkSurface surfacePtr)

-- | Returns 'True' if page has a thumbnail associated with it. It also fills in width and height with the
-- width and height of the thumbnail. The values of width and height are not changed if no appropriate
-- thumbnail exists.
pageGetThumbnailSize :: PageClass page => page
 -> IO (Maybe (Int, Int))
pageGetThumbnailSize page =
  alloca $ \ widthPtr ->
  alloca $ \ heightPtr -> do
    success <- liftM toBool $
                {#call poppler_page_get_thumbnail_size #}
                  (toPage page)
                  widthPtr
                  heightPtr
    if success
       then do
         width  <- peek widthPtr
         height <- peek heightPtr
         return $ Just (fromIntegral width, fromIntegral height)
       else return Nothing

-- | Render the page on a postscript file
pageRenderToPs :: (PageClass page, PSFileClass psFile) => page -> psFile -> IO ()
pageRenderToPs page psFile =
  {#call poppler_page_render_to_ps #} (toPage page) (toPSFile psFile)

-- | A GList of rectangles for each occurance of the text on the page. The coordinates are in PDF points.
pageFindText :: PageClass page => page
 -> String  -- ^ @text@    the text to search for (UTF-8 encoded)
 -> IO [PopplerRectangle]
pageFindText page text =
  withUTFString text $ \ textPtr -> do
    glistPtr <- {#call poppler_page_find_text #} (toPage page) textPtr
    list <- fromGList glistPtr
    mapM peekPopplerRectangle list

-- | Retrieves the contents of the specified selection as text.
pageGetText :: PageClass page => page -> SelectionStyle -> PopplerRectangle
 -> IO String  -- ^ returns selection string
pageGetText page style rect =
  with rect $ \ rectPtr ->
  {#call poppler_page_get_text #} (toPage page) ((fromIntegral . fromEnum) style) (castPtr rectPtr)
  >>= peekUTFString

-- | Returns the duration of page
pageGetDuration :: PageClass page => page
 -> IO Double  -- ^ returns duration in seconds of page or -1.
pageGetDuration page =
  liftM realToFrac $
  {#call poppler_page_get_duration #} (toPage page)

-- | Returns the transition effect of page
pageGetTransition :: PageClass page => page
 -> IO (Maybe PageTransition) -- ^ returns a 'PageTransition' or 'Nothing'.
pageGetTransition page = do
  ptr <- {#call poppler_page_get_transition #} (toPage page)
  if ptr == nullPtr
     then return Nothing
     else liftM Just $ makeNewPageTransition (castPtr ptr)

{#pointer *PageTransition foreign newtype #}

makeNewPageTransition :: Ptr PageTransition -> IO PageTransition
makeNewPageTransition rPtr = do
  transition <- newForeignPtr rPtr page_transition_free
  return (PageTransition transition)

foreign import ccall unsafe "&poppler_page_transition_free"
  page_transition_free :: FinalizerPtr PageTransition

-- | Returns a list of 'LinkMapping' items that map from a location on page to a 'Action'.
pageGetLinkMapping :: PageClass page => page
 -> IO [LinkMapping]
pageGetLinkMapping page = do
  glistPtr <- {#call poppler_page_get_link_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewLinkMapping list
  {#call unsafe poppler_page_free_link_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *LinkMapping foreign newtype #}

makeNewLinkMapping :: Ptr LinkMapping -> IO LinkMapping
makeNewLinkMapping rPtr = do
  linkMapping <- newForeignPtr rPtr poppler_link_mapping_free
  return (LinkMapping linkMapping)

foreign import ccall unsafe "&poppler_link_mapping_free"
  poppler_link_mapping_free :: FinalizerPtr LinkMapping

-- | Returns a list of 'ImageMapping' items that map from a location on page to a 'Action'.
pageGetImageMapping :: PageClass page => page
 -> IO [ImageMapping]
pageGetImageMapping page = do
  glistPtr <- {#call poppler_page_get_image_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewImageMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *ImageMapping foreign newtype #}

makeNewImageMapping :: Ptr ImageMapping -> IO ImageMapping
makeNewImageMapping rPtr = do
  imageMapping <- newForeignPtr rPtr poppler_image_mapping_free
  return (ImageMapping imageMapping)

foreign import ccall unsafe "&poppler_image_mapping_free"
  poppler_image_mapping_free :: FinalizerPtr ImageMapping

-- | Returns a list of 'FormFieldMapping' items that map from a location on page to a 'Action'.
pageGetFormFieldMapping :: PageClass page => page
 -> IO [FormFieldMapping]
pageGetFormFieldMapping page = do
  glistPtr <- {#call poppler_page_get_form_field_mapping #} (toPage page)
  list <- fromGList glistPtr
  mappings <- mapM makeNewFormFieldMapping list
  {#call unsafe poppler_page_free_image_mapping #} (castPtr glistPtr)
  return mappings

{#pointer *FormFieldMapping foreign newtype #}

makeNewFormFieldMapping :: Ptr FormFieldMapping -> IO FormFieldMapping
makeNewFormFieldMapping rPtr = do
  formFieldMapping <- newForeignPtr rPtr poppler_form_field_mapping_free
  return (FormFieldMapping formFieldMapping)

foreign import ccall unsafe "&poppler_form_field_mapping_free"
  poppler_form_field_mapping_free :: FinalizerPtr FormFieldMapping

-- | Returns a region containing the area that would be rendered by 'pageRenderSelection' or
-- 'pageRenderSelectionToPixbuf' as a GList of PopplerRectangle.
pageGetSelectionRegion :: PageClass page => page
 -> Double -- ^ @scale@     scale specified as pixels per point
 -> SelectionStyle -- ^ @style@     a 'SelectionStyle'
 -> PopplerRectangle -- ^ @selection@ start and end point of selection as a rectangle
 -> IO [PopplerRectangle]
pageGetSelectionRegion page scale style selection =
  with selection $ \ selectionPtr -> do
    glistPtr <- {#call poppler_page_get_selection_region #}
                 (toPage page)
                 (realToFrac scale)
                 ((fromIntegral . fromEnum) style)
                 (castPtr selectionPtr)
    list <- fromGList glistPtr
    rectangles <- mapM peekPopplerRectangle list
    {#call unsafe poppler_page_selection_region_free #} (castPtr glistPtr)
    return rectangles

-- | Render the selection specified by selection for page to the given cairo context. The selection will
-- be rendered, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered to cairo, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelection :: PageClass page => page
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> PopplerColor -- ^ @glyphColor@      color to use for drawing glyphs
 -> PopplerColor -- ^ @backgroundColor@ color to use for the selection background
 -> Render ()
pageRenderSelection page selection oldSelection style glyphColor backgroundColor = do
  cairo <- ask
  liftIO $
         with selection $ \ selectionPtr ->
         with oldSelection $ \ oldSelectionPtr ->
         with glyphColor $ \ glyphColorPtr ->
         with backgroundColor $ \ backgroundColorPtr ->
              {#call poppler_page_render_selection #}
                  (toPage page)
                  cairo
                  (castPtr selectionPtr)
                  (castPtr oldSelectionPtr)
                  ((fromIntegral . fromEnum) style)
                  (castPtr glyphColorPtr)
                  (castPtr backgroundColorPtr)

-- | Render the selection specified by selection for page into pixbuf. The selection will be rendered at
-- scale, using @glyphColor@ for the glyphs and @backgroundColor@ for the selection background.
--
-- If non-'Nothing', @oldSelection@ specifies the selection that is already rendered in pixbuf, in which case
-- this function will (some day) only render the changed part of the selection.
pageRenderSelectionToPixbuf :: PageClass page => page
 -> Double -- ^ @scale@            scale specified as pixels per point
 -> Int -- ^ @rotation@         rotate the document by the specified degree
 -> Pixbuf -- ^ @pixbuf@           pixbuf to render to
 -> PopplerRectangle -- ^ @selection@        start and end point of selection as a rectangle
 -> PopplerRectangle -- ^ @oldSelection@    previous selection
 -> SelectionStyle -- ^ @style@            a 'SelectionStyle'
 -> Color -- ^ @glyphColor@      color to use for drawing glyphs
 -> Color -- ^ @backgroundColor@ color to use for the selection background
 -> IO ()
pageRenderSelectionToPixbuf page scale rotation pixbuf selection oldSelection style glyphColor backgroundColor =
  with selection $ \ selectionPtr ->
  with oldSelection $ \ oldSelectionPtr ->
  with glyphColor $ \ glyphColorPtr ->
  with backgroundColor $ \ backgroundColorPtr ->
      {#call poppler_page_render_selection_to_pixbuf #}
        (toPage page)
        (realToFrac scale)
        (fromIntegral rotation)
        pixbuf
        (castPtr selectionPtr)
        (castPtr oldSelectionPtr)
        ((fromIntegral . fromEnum) style)
        (castPtr glyphColorPtr)
        (castPtr backgroundColorPtr)


Fix the get side of all container child attributes. It was accidentally calling 'set' rather than 'get'. doh! :-)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Container child Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting container child properties
--
module Graphics.UI.Gtk.Abstract.ContainerChildProperties (
  containerChildGetPropertyBool,
  containerChildSetPropertyBool,

  newAttrFromContainerChildIntProperty,
  newAttrFromContainerChildUIntProperty,
  newAttrFromContainerChildBoolProperty,
  newAttrFromContainerChildEnumProperty,
  newAttrFromContainerChildFlagsProperty,
  newAttrFromContainerChildStringProperty,
  ) where

import Control.Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags
{#import Graphics.UI.Gtk.Types#}
import System.Glib.GType
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GValueTypes
{#import System.Glib.GValue#}		(GValue(GValue), allocaGValue, valueInit)
import System.Glib.Attributes		(Attr, newAttr)

{# context lib="gtk" prefix="gtk" #}

containerChildSetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> a -> IO ())
 -> String
 -> child
 -> container
 -> a
 -> IO ()
containerChildSetPropertyInternal gtype valueSet prop child container val =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue

containerChildGetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> IO a)
 -> String
 -> child
 -> container
 -> IO a
containerChildGetPropertyInternal gtype valueGet prop child container =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call container_child_get_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue
  valueGet gvalue

-- Versions for specific types:
-- we actually don't use any others than bool at the moment
--

containerChildGetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> IO Bool
containerChildGetPropertyBool =
          containerChildGetPropertyInternal GType.bool valueGetBool

containerChildSetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> Bool -> IO ()
containerChildSetPropertyBool =
          containerChildSetPropertyInternal GType.bool valueSetBool

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromContainerChildIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.int valueGetInt propName child)
  (containerChildSetPropertyInternal GType.int valueSetInt propName child)

newAttrFromContainerChildUIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildUIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.uint
    (\gv -> liftM fromIntegral $ valueGetUInt gv) propName child)
  (containerChildSetPropertyInternal GType.uint
    (\gv v -> valueSetUInt gv (fromIntegral v)) propName child)

newAttrFromContainerChildBoolProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Bool
newAttrFromContainerChildBoolProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.bool valueGetBool propName child)
  (containerChildSetPropertyInternal GType.bool valueSetBool propName child)

newAttrFromContainerChildEnumProperty ::
 (ContainerClass container, WidgetClass child, Enum enum)
 => String -> GType -> child -> Attr container enum
newAttrFromContainerChildEnumProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetEnum propName child)
  (containerChildSetPropertyInternal gtype valueSetEnum propName child)

newAttrFromContainerChildFlagsProperty ::
 (ContainerClass container, WidgetClass child, Flags flag)
 => String -> GType -> child -> Attr container [flag]
newAttrFromContainerChildFlagsProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetFlags propName child)
  (containerChildSetPropertyInternal gtype valueSetFlags propName child)

newAttrFromContainerChildStringProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container String
newAttrFromContainerChildStringProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.string valueGetString propName child)
  (containerChildSetPropertyInternal GType.string valueSetString propName child)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Container child Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting container child properties
--
module Graphics.UI.Gtk.Abstract.ContainerChildProperties (
  containerChildGetPropertyBool,
  containerChildSetPropertyBool,

  newAttrFromContainerChildIntProperty,
  newAttrFromContainerChildUIntProperty,
  newAttrFromContainerChildBoolProperty,
  newAttrFromContainerChildEnumProperty,
  newAttrFromContainerChildFlagsProperty,
  newAttrFromContainerChildStringProperty,
  ) where

import Control.Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags
{#import Graphics.UI.Gtk.Types#}
import System.Glib.GType
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GValueTypes
{#import System.Glib.GValue#}		(GValue(GValue), allocaGValue, valueInit)
import System.Glib.Attributes		(Attr, newAttr)

{# context lib="gtk" prefix="gtk" #}

containerChildSetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> a -> IO ())
 -> String
 -> child
 -> container
 -> a
 -> IO ()
containerChildSetPropertyInternal gtype valueSet prop child container val =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue

containerChildGetPropertyInternal ::
 (ContainerClass container, WidgetClass child)
 => GType
 -> (GValue -> IO a)
 -> String
 -> child
 -> container
 -> IO a
containerChildGetPropertyInternal gtype valueGet prop child container =
  withCString prop $ \propertyNamePtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call container_child_set_property #}
    (toContainer container)
    (toWidget child)
    propertyNamePtr
    gvalue
  valueGet gvalue

-- Versions for specific types:
-- we actually don't use any others than bool at the moment
--

containerChildGetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> IO Bool
containerChildGetPropertyBool =
          containerChildGetPropertyInternal GType.bool valueGetBool

containerChildSetPropertyBool :: (ContainerClass container, WidgetClass child)
 => String -> child -> container -> Bool -> IO ()
containerChildSetPropertyBool =
          containerChildSetPropertyInternal GType.bool valueSetBool

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromContainerChildIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.int valueGetInt propName child)
  (containerChildSetPropertyInternal GType.int valueSetInt propName child)

newAttrFromContainerChildUIntProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Int
newAttrFromContainerChildUIntProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.uint
    (\gv -> liftM fromIntegral $ valueGetUInt gv) propName child)
  (containerChildSetPropertyInternal GType.uint
    (\gv v -> valueSetUInt gv (fromIntegral v)) propName child)

newAttrFromContainerChildBoolProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container Bool
newAttrFromContainerChildBoolProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.bool valueGetBool propName child)
  (containerChildSetPropertyInternal GType.bool valueSetBool propName child)

newAttrFromContainerChildEnumProperty ::
 (ContainerClass container, WidgetClass child, Enum enum)
 => String -> GType -> child -> Attr container enum
newAttrFromContainerChildEnumProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetEnum propName child)
  (containerChildSetPropertyInternal gtype valueSetEnum propName child)

newAttrFromContainerChildFlagsProperty ::
 (ContainerClass container, WidgetClass child, Flags flag)
 => String -> GType -> child -> Attr container [flag]
newAttrFromContainerChildFlagsProperty propName gtype child = newAttr
  (containerChildGetPropertyInternal gtype valueGetFlags propName child)
  (containerChildSetPropertyInternal gtype valueSetFlags propName child)

newAttrFromContainerChildStringProperty ::
 (ContainerClass container, WidgetClass child)
 => String -> child -> Attr container String
newAttrFromContainerChildStringProperty propName child = newAttr
  (containerChildGetPropertyInternal GType.string valueGetString propName child)
  (containerChildSetPropertyInternal GType.string valueSetString propName child)


Compile on platforms where int64_t == long long. (#6)

In particular, this helps fix the build on Mac OS X.

-- Copyright 2016 TensorFlow authors.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE ForeignFunctionInterface #-}

module TensorFlow.Internal.Raw where

#include "third_party/tensorflow/c/c_api.h"

import Foreign
import Foreign.C

{#enum TF_DataType as DataType {} deriving (Show, Eq) #}
{#enum TF_Code as Code {} deriving (Show, Eq) #}

-- Status.
{#pointer *TF_Status as Status newtype #}

newStatus :: IO Status
newStatus = {# call TF_NewStatus as ^ #}

deleteStatus :: Status -> IO ()
deleteStatus = {# call TF_DeleteStatus as ^ #}

setStatus :: Status -> Code -> CString -> IO ()
setStatus s c = {# call TF_SetStatus as ^ #} s (fromIntegral $ fromEnum c)

getCode :: Status -> IO Code
getCode s = toEnum . fromIntegral <$> {# call TF_GetCode as ^ #} s

message :: Status -> IO CString
message = {# call TF_Message as ^ #}

-- Buffer.
data Buffer
{#pointer *TF_Buffer as BufferPtr -> Buffer #}

getBufferData :: BufferPtr -> IO (Ptr ())
getBufferData = {#get TF_Buffer->data #}

getBufferLength :: BufferPtr -> IO CULong
getBufferLength ={#get TF_Buffer->length #}

-- Tensor.
{#pointer *TF_Tensor as Tensor newtype #}

instance Storable Tensor where
    sizeOf (Tensor t) = sizeOf t
    alignment (Tensor t) = alignment t
    peek p = fmap Tensor (peek (castPtr p))
    poke p (Tensor t) = poke (castPtr p) t

-- A synonym for the int64_t type, which is used in the TensorFlow API.
-- On some platforms it's `long`; on others (e.g., Mac OS X) it's `long long`;
-- and as far as Haskell is concerned, those are distinct types (`CLong` vs
-- `CLLong`).
type CInt64 = {#type int64_t #}

newTensor :: DataType
          -> Ptr CInt64   -- dimensions array
          -> CInt         -- num dimensions
          -> Ptr ()       -- data
          -> CULong       -- data len
          -> FunPtr (Ptr () -> CULong -> Ptr () -> IO ())  -- deallocator
          -> Ptr ()       -- deallocator arg
          -> IO Tensor
newTensor dt = {# call TF_NewTensor as ^ #} (fromIntegral $ fromEnum dt)

deleteTensor :: Tensor -> IO ()
deleteTensor = {# call TF_DeleteTensor as ^ #}

tensorType :: Tensor -> IO DataType
tensorType t = toEnum . fromIntegral <$> {# call TF_TensorType as ^ #} t

numDims :: Tensor -> IO CInt
numDims = {# call TF_NumDims as ^ #}

dim :: Tensor -> CInt -> IO CInt64
dim = {# call TF_Dim as ^ #}

tensorByteSize :: Tensor -> IO CULong
tensorByteSize = {# call TF_TensorByteSize as ^ #}

tensorData :: Tensor -> IO (Ptr ())
tensorData = {# call TF_TensorData as ^ #}

-- Session Options.
{# pointer *TF_SessionOptions as SessionOptions newtype #}

newSessionOptions :: IO SessionOptions
newSessionOptions = {# call TF_NewSessionOptions as ^ #}

setTarget :: SessionOptions -> CString -> IO ()
setTarget = {# call TF_SetTarget as ^ #}

setConfig :: SessionOptions -> Ptr () -> CULong -> Status -> IO ()
setConfig = {# call TF_SetConfig as ^ #}

deleteSessionOptions :: SessionOptions -> IO ()
deleteSessionOptions = {# call TF_DeleteSessionOptions as ^ #}

-- Session.
{# pointer *TF_Session as Session newtype #}

newSession :: SessionOptions -> Status -> IO Session
newSession = {# call TF_NewSession as ^ #}

closeSession :: Session -> Status -> IO ()
closeSession = {# call TF_CloseSession as ^ #}

deleteSession :: Session -> Status -> IO ()
deleteSession = {# call TF_DeleteSession as ^ #}

extendGraph :: Session -> Ptr () -> CULong -> Status -> IO ()
extendGraph = {# call TF_ExtendGraph as ^ #}

run :: Session
    -> BufferPtr                          -- RunOptions proto.
    -> Ptr CString -> Ptr Tensor -> CInt  -- Input (names, tensors, count).
    -> Ptr CString -> Ptr Tensor -> CInt  -- Output (names, tensors, count).
    -> Ptr CString -> CInt                -- Target nodes (names, count).
    -> BufferPtr                          -- RunMetadata proto.
    -> Status
    -> IO ()
run = {# call TF_Run as ^ #}

-- FFI helpers.
type TensorDeallocFn = Ptr () -> CULong -> Ptr () -> IO ()
foreign import ccall "wrapper"
    wrapTensorDealloc :: TensorDeallocFn -> IO (FunPtr TensorDeallocFn)

-- | Get the OpList of all OpDefs defined in this address space.
-- Returns a BufferPtr, ownership of which is transferred to the caller
-- (and can be freed using deleteBuffer).
--
-- The data in the buffer will be the serialized OpList proto for ops registered
-- in this address space.
getAllOpList :: IO BufferPtr
getAllOpList = {# call TF_GetAllOpList as ^ #}

foreign import ccall "&TF_DeleteBuffer"
  deleteBuffer :: FunPtr (BufferPtr -> IO ())

-- Copyright 2016 TensorFlow authors.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE ForeignFunctionInterface #-}

module TensorFlow.Internal.Raw where

#include "third_party/tensorflow/c/c_api.h"

import Foreign
import Foreign.C

{#enum TF_DataType as DataType {} deriving (Show, Eq) #}
{#enum TF_Code as Code {} deriving (Show, Eq) #}

-- Status.
{#pointer *TF_Status as Status newtype #}

newStatus :: IO Status
newStatus = {# call TF_NewStatus as ^ #}

deleteStatus :: Status -> IO ()
deleteStatus = {# call TF_DeleteStatus as ^ #}

setStatus :: Status -> Code -> CString -> IO ()
setStatus s c = {# call TF_SetStatus as ^ #} s (fromIntegral $ fromEnum c)

getCode :: Status -> IO Code
getCode s = toEnum . fromIntegral <$> {# call TF_GetCode as ^ #} s

message :: Status -> IO CString
message = {# call TF_Message as ^ #}

-- Buffer.
data Buffer
{#pointer *TF_Buffer as BufferPtr -> Buffer #}

getBufferData :: BufferPtr -> IO (Ptr ())
getBufferData = {#get TF_Buffer->data #}

getBufferLength :: BufferPtr -> IO CULong
getBufferLength ={#get TF_Buffer->length #}

-- Tensor.
{#pointer *TF_Tensor as Tensor newtype #}

instance Storable Tensor where
    sizeOf (Tensor t) = sizeOf t
    alignment (Tensor t) = alignment t
    peek p = fmap Tensor (peek (castPtr p))
    poke p (Tensor t) = poke (castPtr p) t

newTensor :: DataType
          -> Ptr CLong    -- dimensions array
          -> CInt         -- num dimensions
          -> Ptr ()       -- data
          -> CULong       -- data len
          -> FunPtr (Ptr () -> CULong -> Ptr () -> IO ())  -- deallocator
          -> Ptr ()       -- deallocator arg
          -> IO Tensor
newTensor dt = {# call TF_NewTensor as ^ #} (fromIntegral $ fromEnum dt)

deleteTensor :: Tensor -> IO ()
deleteTensor = {# call TF_DeleteTensor as ^ #}

tensorType :: Tensor -> IO DataType
tensorType t = toEnum . fromIntegral <$> {# call TF_TensorType as ^ #} t

numDims :: Tensor -> IO CInt
numDims = {# call TF_NumDims as ^ #}

dim :: Tensor -> CInt -> IO CLong
dim = {# call TF_Dim as ^ #}

tensorByteSize :: Tensor -> IO CULong
tensorByteSize = {# call TF_TensorByteSize as ^ #}

tensorData :: Tensor -> IO (Ptr ())
tensorData = {# call TF_TensorData as ^ #}

-- Session Options.
{# pointer *TF_SessionOptions as SessionOptions newtype #}

newSessionOptions :: IO SessionOptions
newSessionOptions = {# call TF_NewSessionOptions as ^ #}

setTarget :: SessionOptions -> CString -> IO ()
setTarget = {# call TF_SetTarget as ^ #}

setConfig :: SessionOptions -> Ptr () -> CULong -> Status -> IO ()
setConfig = {# call TF_SetConfig as ^ #}

deleteSessionOptions :: SessionOptions -> IO ()
deleteSessionOptions = {# call TF_DeleteSessionOptions as ^ #}

-- Session.
{# pointer *TF_Session as Session newtype #}

newSession :: SessionOptions -> Status -> IO Session
newSession = {# call TF_NewSession as ^ #}

closeSession :: Session -> Status -> IO ()
closeSession = {# call TF_CloseSession as ^ #}

deleteSession :: Session -> Status -> IO ()
deleteSession = {# call TF_DeleteSession as ^ #}

extendGraph :: Session -> Ptr () -> CULong -> Status -> IO ()
extendGraph = {# call TF_ExtendGraph as ^ #}

run :: Session
    -> BufferPtr                          -- RunOptions proto.
    -> Ptr CString -> Ptr Tensor -> CInt  -- Input (names, tensors, count).
    -> Ptr CString -> Ptr Tensor -> CInt  -- Output (names, tensors, count).
    -> Ptr CString -> CInt                -- Target nodes (names, count).
    -> BufferPtr                          -- RunMetadata proto.
    -> Status
    -> IO ()
run = {# call TF_Run as ^ #}

-- FFI helpers.
type TensorDeallocFn = Ptr () -> CULong -> Ptr () -> IO ()
foreign import ccall "wrapper"
    wrapTensorDealloc :: TensorDeallocFn -> IO (FunPtr TensorDeallocFn)

-- | Get the OpList of all OpDefs defined in this address space.
-- Returns a BufferPtr, ownership of which is transferred to the caller
-- (and can be freed using deleteBuffer).
--
-- The data in the buffer will be the serialized OpList proto for ops registered
-- in this address space.
getAllOpList :: IO BufferPtr
getAllOpList = {# call TF_GetAllOpList as ^ #}

foreign import ccall "&TF_DeleteBuffer"
  deleteBuffer :: FunPtr (BufferPtr -> IO ())