Export ContourFunctionUS

Export ContourFunctionUS

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables#-}
-- | This module contains functions for extracting features from connected components
--   of black and white images as well as extracting other shape related features.
module CV.ConnectedComponents
       (
       -- * Working with connected components
        fillConnectedComponents
       ,maskConnectedComponent
       ,selectSizedComponents
       ,countBlobs
       -- * Working with Image moments
       -- |Note that these functions should probably go to a different module, since
       --  they deal with entire moments of entire images.
       ,spatialMoments
       ,centralMoments
       ,normalizedCentralMoments
       ,huMoments
       -- * Working with component contours aka. object boundaries.
       -- |This part is really old code and probably could be improved a lot.
       ,Contours
       ,ContourFunctionUS
       ,getContours
       ,contourArea
       ,contourPerimeter
       ,contourPoints
       ,mapContours
       ,contourHuMoments)
where
#include "cvWrapLEO.h"

import CV.Bindings.ImgProc
import CV.Bindings.Types
import Control.Monad ((>=>))
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils (with)
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe
{#import CV.Image#}

import CV.ImageOp

fillConnectedComponents :: Image GrayScale D8 -> (Image GrayScale D8, Int)
fillConnectedComponents image = unsafePerformIO $ do
  let
    count :: CInt
    count = 0
  withCloneValue image $ \clone ->
    withImage clone $ \pclone ->
      with count $ \pcount -> do
        c'fillConnectedComponents (castPtr pclone) pcount
        c <- peek pcount
        return (clone, fromIntegral c)

maskConnectedComponent :: Image GrayScale D8 -> Int -> Image GrayScale D8
maskConnectedComponent image index = unsafePerformIO $
  withCloneValue image $ \clone ->
    withImage image $ \pimage ->
      withImage clone $ \pclone -> do
        c'maskConnectedComponent (castPtr pimage) (castPtr pclone) (fromIntegral index)
        return clone

-- |Count the number of connected components in the image
countBlobs :: Image GrayScale D8 -> Int
countBlobs image = fromIntegral $ unsafePerformIO $ do
    withGenImage image $ \i ->
     {#call blobCount#} i

-- |Remove all connected components that fall outside of given size range from the image.
selectSizedComponents :: Double -> Double -> Image GrayScale D8 -> Image GrayScale D8
selectSizedComponents minSize maxSize image = unsafePerformIO $ do
    withGenImage image $ \i ->
     creatingImage ({#call sizeFilter#} i (realToFrac minSize) (realToFrac maxSize))

-- * Working with Image moments.

-- Utility function for getting the moments
getMoments :: (Ptr C'CvMoments -> CInt -> CInt -> IO (CDouble)) -> Image GrayScale D32 -> Bool -> [Double]
getMoments f image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments :: C'CvMoments
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
      ms <- sequence [ f pmoments i j
                       | i <- [0..3], j <- [0..3], i+j <= 3 ]
      return (map realToFrac ms)

-- | Extract raw spatial moments of the image.
spatialMoments = getMoments c'cvGetSpatialMoment

-- | Extract central moments of the image. These are useful for describing the
--   object shape for a classifier system.
centralMoments = getMoments c'cvGetCentralMoment

-- | Extract normalized central moments of the image.
normalizedCentralMoments = getMoments c'cvGetNormalizedCentralMoment

{-
centralMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   ms <- sequence [{#call cvGetCentralMoment#} moments i j
                  | i <- [0..3], j<-[0..3], i+j <= 3]
   {#call freeCvMoments#} moments
   return (map realToFrac ms)
-}

-- |Extract Hu-moments of the image. These features are rotation invariant.
huMoments :: Image GrayScale D32 -> Bool -> [Double]
huMoments image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      hu = C'CvHuMoments 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      with hu $ \phu -> do
        c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
        c'cvGetHuMoments pmoments phu
        (C'CvHuMoments hu1 hu2 hu3 hu4 hu5 hu6 hu7) <- peek phu
        return (map realToFrac [hu1,hu2,hu3,hu4,hu5,hu6,hu7])

{-
huMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   hu <- readHu moments
   {#call freeCvMoments#} moments
   return (map realToFrac hu)
-}

-- read stuff out of hu-moments structure.. This could be done way better.
readHu m = do
   hu <- mallocArray 7
   {#call getHuMoments#} m hu
   hu' <- peekArray 7 hu
   free hu
   return hu'

-- |Structure that contains the opencv sequence holding the contour data.
{#pointer *FoundContours as Contours foreign newtype#}
foreign import ccall "& free_found_contours" releaseContours
    :: FinalizerPtr Contours

-- | This function maps an opencv contour calculation over all
--   contours of the image.
mapContours :: ContourFunctionUS a -> Contours -> [a]
mapContours (CFUS op) contours = unsafePerformIO $ do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

-- |Extract contours of connected components of the image.
getContours :: Image GrayScale D8 -> Contours
getContours img = unsafePerformIO $ do
        withImage img $ \i -> do
          ptr <- {#call get_contours#} i
          fptr <- newForeignPtr releaseContours ptr
          return $ Contours fptr

newtype ContourFunctionUS a = CFUS (Contours -> IO a)
newtype ContourFunctionIO a = CFIO (Contours -> IO a)

rawContourOpUS op = CFUS $ \c -> withContours c op
rawContourOp op = CFIO $ \c -> withContours c op

printContour = rawContourOp {#call print_contour#}

contourArea :: ContourFunctionUS Double
contourArea = rawContourOpUS ({#call contour_area#} >=> return.realToFrac)
-- ^The area of a contour.

contourPerimeter :: ContourFunctionUS Double
contourPerimeter = rawContourOpUS $ {#call contour_perimeter#} >=> return.realToFrac
-- ^Get the perimeter of a contour.

-- |Get a list of the points in the contour.
contourPoints :: ContourFunctionUS [(Double,Double)]
contourPoints = rawContourOpUS getContourPoints'
getContourPoints' f = do
     count <- {#call cur_contour_size#} f
     let count' = fromIntegral count
     ----print count
     xs <- mallocArray count'
     ys <- mallocArray count'
     {#call contour_points#} f xs ys
     xs' <- peekArray count' xs
     ys' <- peekArray count' ys
     free xs
     free ys
     return $ zip (map fromIntegral xs') (map fromIntegral ys')

-- | Operation for extracting Hu-moments from a contour
contourHuMoments :: ContourFunctionUS [Double]
contourHuMoments = rawContourOpUS $ getContourHuMoments' >=> return.map realToFrac
getContourHuMoments' f = do
   m <- {#call contour_moments#} f
   hu <- readHu m
   {#call freeCvMoments#} m
   return hu

mapContoursIO :: ContourFunctionIO a -> Contours -> IO [a]
mapContoursIO (CFIO op) contours = do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

{#pointer *CvMoments as Moments foreign newtype#}

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables#-}
-- | This module contains functions for extracting features from connected components
--   of black and white images as well as extracting other shape related features.
module CV.ConnectedComponents
       (
       -- * Working with connected components
        fillConnectedComponents
       ,maskConnectedComponent
       ,selectSizedComponents
       ,countBlobs
       -- * Working with Image moments
       -- |Note that these functions should probably go to a different module, since
       --  they deal with entire moments of entire images.
       ,spatialMoments
       ,centralMoments
       ,normalizedCentralMoments
       ,huMoments
       -- * Working with component contours aka. object boundaries.
       -- |This part is really old code and probably could be improved a lot.
       ,Contours
       ,getContours
       ,contourArea
       ,contourPerimeter
       ,contourPoints
       ,mapContours
       ,contourHuMoments)
where
#include "cvWrapLEO.h"

import CV.Bindings.ImgProc
import CV.Bindings.Types
import Control.Monad ((>=>))
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils (with)
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe
{#import CV.Image#}

import CV.ImageOp

fillConnectedComponents :: Image GrayScale D8 -> (Image GrayScale D8, Int)
fillConnectedComponents image = unsafePerformIO $ do
  let
    count :: CInt
    count = 0
  withCloneValue image $ \clone ->
    withImage clone $ \pclone ->
      with count $ \pcount -> do
        c'fillConnectedComponents (castPtr pclone) pcount
        c <- peek pcount
        return (clone, fromIntegral c)

maskConnectedComponent :: Image GrayScale D8 -> Int -> Image GrayScale D8
maskConnectedComponent image index = unsafePerformIO $
  withCloneValue image $ \clone ->
    withImage image $ \pimage ->
      withImage clone $ \pclone -> do
        c'maskConnectedComponent (castPtr pimage) (castPtr pclone) (fromIntegral index)
        return clone

-- |Count the number of connected components in the image
countBlobs :: Image GrayScale D8 -> Int
countBlobs image = fromIntegral $ unsafePerformIO $ do
    withGenImage image $ \i ->
     {#call blobCount#} i

-- |Remove all connected components that fall outside of given size range from the image.
selectSizedComponents :: Double -> Double -> Image GrayScale D8 -> Image GrayScale D8
selectSizedComponents minSize maxSize image = unsafePerformIO $ do
    withGenImage image $ \i ->
     creatingImage ({#call sizeFilter#} i (realToFrac minSize) (realToFrac maxSize))

-- * Working with Image moments.

-- Utility function for getting the moments
getMoments :: (Ptr C'CvMoments -> CInt -> CInt -> IO (CDouble)) -> Image GrayScale D32 -> Bool -> [Double]
getMoments f image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments :: C'CvMoments
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
      ms <- sequence [ f pmoments i j
                       | i <- [0..3], j <- [0..3], i+j <= 3 ]
      return (map realToFrac ms)

-- | Extract raw spatial moments of the image.
spatialMoments = getMoments c'cvGetSpatialMoment

-- | Extract central moments of the image. These are useful for describing the
--   object shape for a classifier system.
centralMoments = getMoments c'cvGetCentralMoment

-- | Extract normalized central moments of the image.
normalizedCentralMoments = getMoments c'cvGetNormalizedCentralMoment

{-
centralMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   ms <- sequence [{#call cvGetCentralMoment#} moments i j
                  | i <- [0..3], j<-[0..3], i+j <= 3]
   {#call freeCvMoments#} moments
   return (map realToFrac ms)
-}

-- |Extract Hu-moments of the image. These features are rotation invariant.
huMoments :: Image GrayScale D32 -> Bool -> [Double]
huMoments image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      hu = C'CvHuMoments 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      with hu $ \phu -> do
        c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
        c'cvGetHuMoments pmoments phu
        (C'CvHuMoments hu1 hu2 hu3 hu4 hu5 hu6 hu7) <- peek phu
        return (map realToFrac [hu1,hu2,hu3,hu4,hu5,hu6,hu7])

{-
huMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   hu <- readHu moments
   {#call freeCvMoments#} moments
   return (map realToFrac hu)
-}

-- read stuff out of hu-moments structure.. This could be done way better.
readHu m = do
   hu <- mallocArray 7
   {#call getHuMoments#} m hu
   hu' <- peekArray 7 hu
   free hu
   return hu'

-- |Structure that contains the opencv sequence holding the contour data.
{#pointer *FoundContours as Contours foreign newtype#}
foreign import ccall "& free_found_contours" releaseContours
    :: FinalizerPtr Contours

-- | This function maps an opencv contour calculation over all
--   contours of the image.
mapContours :: ContourFunctionUS a -> Contours -> [a]
mapContours (CFUS op) contours = unsafePerformIO $ do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

-- |Extract contours of connected components of the image.
getContours :: Image GrayScale D8 -> Contours
getContours img = unsafePerformIO $ do
        withImage img $ \i -> do
          ptr <- {#call get_contours#} i
          fptr <- newForeignPtr releaseContours ptr
          return $ Contours fptr

newtype ContourFunctionUS a = CFUS (Contours -> IO a)
newtype ContourFunctionIO a = CFIO (Contours -> IO a)

rawContourOpUS op = CFUS $ \c -> withContours c op
rawContourOp op = CFIO $ \c -> withContours c op

printContour = rawContourOp {#call print_contour#}

contourArea :: ContourFunctionUS Double
contourArea = rawContourOpUS ({#call contour_area#} >=> return.realToFrac)
-- ^The area of a contour.

contourPerimeter :: ContourFunctionUS Double
contourPerimeter = rawContourOpUS $ {#call contour_perimeter#} >=> return.realToFrac
-- ^Get the perimeter of a contour.

-- |Get a list of the points in the contour.
contourPoints :: ContourFunctionUS [(Double,Double)]
contourPoints = rawContourOpUS getContourPoints'
getContourPoints' f = do
     count <- {#call cur_contour_size#} f
     let count' = fromIntegral count
     ----print count
     xs <- mallocArray count'
     ys <- mallocArray count'
     {#call contour_points#} f xs ys
     xs' <- peekArray count' xs
     ys' <- peekArray count' ys
     free xs
     free ys
     return $ zip (map fromIntegral xs') (map fromIntegral ys')

-- | Operation for extracting Hu-moments from a contour
contourHuMoments :: ContourFunctionUS [Double]
contourHuMoments = rawContourOpUS $ getContourHuMoments' >=> return.map realToFrac
getContourHuMoments' f = do
   m <- {#call contour_moments#} f
   hu <- readHu m
   {#call freeCvMoments#} m
   return hu

mapContoursIO :: ContourFunctionIO a -> Contours -> IO [a]
mapContoursIO (CFIO op) contours = do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

{#pointer *CvMoments as Moments foreign newtype#}


openRepoObjDir

openRepoObjDir

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.Primitive
import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type Ptr2Int = Ptr () -> IO CInt

newtype ObjDB      = ObjDB { unODB :: Ptr () }
newtype Repository = Repository { unRepository :: Ptr () }
newtype Index      = Index { unIndex :: Ptr () }

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res  <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir db idxFile workTree = undefined -- git_repository_open3

-- TODO: size? GIT_EXTERN(int) git_repository_discover(char *repository_path, size_t size, const char *start_path, int across_fs, const char *ceiling_dirs);
discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = undefined -- git_repository_discover

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  if res == 0
    then fmap (Right . Index) $ peek idx
    else return . Left . toEnum . fromIntegral $ res

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

-- TODO: Refactor some bits
init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.Primitive
import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type Ptr2Int = Ptr () -> IO CInt

newtype ObjDB      = ObjDB { unODB :: Ptr () }
newtype Repository = Repository { unRepository :: Ptr () }
newtype Index      = Index { unIndex :: Ptr () }

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = undefined -- git_repository_open2

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir db idxFile workTree = undefined -- git_repository_open3

-- TODO: size? GIT_EXTERN(int) git_repository_discover(char *repository_path, size_t size, const char *start_path, int across_fs, const char *ceiling_dirs);
discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = undefined -- git_repository_discover

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  if res == 0
    then fmap (Right . Index) $ peek idx
    else return . Left . toEnum . fromIntegral $ res

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

-- TODO: Refactor some bits
init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}


no need to register finalizer for warp options since gdal clones them

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}

module GDAL.Internal.Warper (
    ResampleAlg (..)
  , WarpOptions (..)
  , BandOptions (..)
  , GDALWarpException (..)
  , reprojectImage
  , setTransformer
  , createWarpedVRT
  , def
) where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (when, void, forM_, forM)
import Control.Monad.IO.Class (liftIO)
import Control.DeepSeq (NFData(rnf))
import Control.Exception (Exception(..), bracket)
import Data.Maybe (isJust, fromMaybe)
import Data.Typeable (Typeable)
import Data.Default (Default(..))
import Foreign.C.String (CString)
import Foreign.C.Types (CDouble(..), CInt(..), CChar(..))
import Foreign.Ptr (
    Ptr
  , FunPtr
  , nullPtr
  , castPtr
  , castFunPtr
  , nullFunPtr
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Storable (Storable(..))

import GDAL.Internal.Types
import GDAL.Internal.Util (fromEnumC)
import GDAL.Internal.CPLConv
{#import GDAL.Internal.Algorithms #}
{#import GDAL.Internal.CPLError #}
{#import GDAL.Internal.CPLString #}
{#import GDAL.Internal.CPLProgress #}
{#import GDAL.Internal.OSR #}
{#import GDAL.Internal.GDAL #}

#include "gdal.h"
#include "gdalwarper.h"

data GDALWarpException
  = WarpStopped
  deriving (Typeable, Show, Eq)

instance NFData GDALWarpException where
  rnf a = a `seq` ()

instance Exception GDALWarpException where
  toException   = bindingExceptionToException
  fromException = bindingExceptionFromException

{# enum GDALResampleAlg as ResampleAlg {upcaseFirstLetter} with prefix = "GRA_"
     deriving (Eq,Read,Show,Bounded) #}

data BandOptions a b
  = BandOptions {
      biSrc       :: !Int
    , biDst       :: !Int
    , biSrcNoData :: !(Maybe a)
    , biDstNoData :: !(Maybe b)
    } deriving Show

data WarpOptions s a b
  = forall t. (Transformer t, GDALType a, GDALType b)
  => WarpOptions {
      woResampleAlg     :: ResampleAlg
    , woWarpOptions     :: OptionList
    , woMemoryLimit     :: Double
    , woWorkingDatatype :: Datatype
    , woBands           :: [BandOptions a b]
    , woTransfomer      :: Maybe (t s a b)
    , woProgressFun     :: Maybe ProgressFun
    }

instance (GDALType a, GDALType b) => Default (WarpOptions s a b) where
  def = WarpOptions {
          woResampleAlg     = NearestNeighbour
        , woWarpOptions     = []
        , woMemoryLimit     = 0
        , woWorkingDatatype = GDT_Unknown
        , woBands           = []
        , woTransfomer      = Nothing :: Maybe (GenImgProjTransformer s a b)
        , woProgressFun     = Nothing
        }

-- Avoids "Record update for insufficiently polymorphic field" when doigs
-- opts { woTransfomer = Just ...}
setTransformer
  :: forall t s a b. (Transformer t, GDALType a, GDALType b)
  => t s a b -> WarpOptions s a b -> WarpOptions s a b
setTransformer t opts = WarpOptions {
    woResampleAlg     = woResampleAlg opts
  , woWarpOptions     = woWarpOptions opts
  , woMemoryLimit     = woMemoryLimit opts
  , woWorkingDatatype = woWorkingDatatype opts
  , woBands           = woBands opts
  , woTransfomer      = Just t
  , woProgressFun     = woProgressFun opts
  }

setOptionDefaults
  :: (GDALType a, GDALType b)
  => RODataset s a -> Maybe (Dataset s t b) -> WarpOptions s a b
  -> GDAL s (WarpOptions s a b)
setOptionDefaults ds moDs wo@WarpOptions{..} = do
  bands <- if null woBands
            then forM [1..datasetBandCount ds] $ \i -> do
              srcNd <- getBand i ds >>= bandNodataValue
              dstNd <- case moDs of
                         Just oDs -> getBand i oDs >>= bandNodataValue
                         Nothing  -> return (fmap (fromNodata . toNodata) srcNd)
              return (BandOptions i i srcNd dstNd)
            else return woBands
  let warpOptions
        | any (isJust . biDstNoData) bands
        = ("INIT_DEST","NO_DATA") : woWarpOptions
        | otherwise = woWarpOptions
  return (wo { woWarpOptions = warpOptions, woBands = bands})

anyBandHasNoData :: WarpOptions s a b -> Bool
anyBandHasNoData wo
  = any (\BandOptions{..} -> isJust biSrcNoData || isJust biDstNoData) (woBands wo)

anyBandHasDstNoData :: WarpOptions s a b -> Bool
anyBandHasDstNoData wo = any (\BandOptions{..} -> isJust biDstNoData) (woBands wo)

withWarpOptionsPtr
  :: (GDALType a, GDALType b)
  => RODataset s a -> WarpOptions s a b -> (Ptr (WarpOptions s a b) -> IO c)
  -> IO c
withWarpOptionsPtr ds wo@WarpOptions{..}
  = bracket createWarpOptions destroyWarpOptions
  where
    dsPtr = unDataset ds
    createWarpOptions = do
      p <- c_createWarpOptions
      {#set GDALWarpOptions.hSrcDS #} p (castPtr dsPtr)
      {#set GDALWarpOptions.eResampleAlg #} p (fromEnumC woResampleAlg)
      oListPtr <- toOptionListPtr woWarpOptions
      {#set GDALWarpOptions.papszWarpOptions #} p oListPtr
      {#set GDALWarpOptions.dfWarpMemoryLimit #} p (realToFrac woMemoryLimit)
      {#set GDALWarpOptions.eWorkingDataType #} p (fromEnumC woWorkingDatatype)
      {#set GDALWarpOptions.nBandCount #} p (fromIntegral (length woBands))
      {#set GDALWarpOptions.panSrcBands #} p =<<
        listToPtr (map (fromIntegral . biSrc) woBands)
      {#set GDALWarpOptions.panDstBands #} p =<<
        listToPtr (map (fromIntegral . biDst) woBands)
      case woTransfomer of
        Just t -> do
          {#set GDALWarpOptions.pfnTransformer #} p
            (castFunPtr (transformerFunc t))
          tArg <- fmap castPtr (createTransformer dsPtr t)
          {#set GDALWarpOptions.pTransformerArg #} p tArg
        Nothing -> do
          {#set GDALWarpOptions.pfnTransformer #} p nullFunPtr
          {#set GDALWarpOptions.pTransformerArg #} p nullPtr
      when (anyBandHasNoData wo) $ do
        vPtrSrcR <- listToPtr
                      (map (toNodata . fromMaybe nodata . biSrcNoData) woBands)
        vPtrSrcI <- listToPtr (replicate (length woBands) 0)
        vPtrDstR <- listToPtr
                      (map (toNodata . fromMaybe nodata . biDstNoData) woBands)
        vPtrDstI <- listToPtr (replicate (length woBands) 0)
        {#set GDALWarpOptions.padfDstNoDataReal #} p vPtrDstR
        {#set GDALWarpOptions.padfDstNoDataImag #} p vPtrDstI
        {#set GDALWarpOptions.padfSrcNoDataReal #} p vPtrSrcR
        {#set GDALWarpOptions.padfSrcNoDataImag #} p vPtrSrcI
      return p

    destroyWarpOptions = c_destroyWarpOptions

    listToPtr [] = return nullPtr
    listToPtr l = do
      ptr <- cplMallocArray (length l)
      mapM_ (\(i,v) -> pokeElemOff ptr i v) (zip [0..] l)
      return ptr

foreign import ccall unsafe "gdalwarper.h GDALCreateWarpOptions"
  c_createWarpOptions :: IO (Ptr (WarpOptions s a b))

foreign import ccall unsafe "gdalwarper.h GDALDestroyWarpOptions"
  c_destroyWarpOptions :: Ptr (WarpOptions s a b) -> IO ()

reprojectImage
  :: (GDALType a, GDALType b)
  => RODataset s a
  -> Maybe SpatialReference
  -> RWDataset s b
  -> Maybe SpatialReference
  -> ResampleAlg
  -> Double
  -> Double
  -> Maybe ProgressFun
  -> OptionList
  -> GDAL s ()
reprojectImage srcDs srcSrs dstDs dstSrs algo memLimit maxError progressFun opts
  = do options' <- setOptionDefaults srcDs (Just dstDs)
                     (def {woWarpOptions=opts})
       ret <- liftIO $
          withProgressFun progressFun $ \pFun ->
          throwIfError "reprojectImage" $
          withLockedDatasetPtr srcDs $ \srcPtr ->
          withLockedDatasetPtr dstDs $ \dstPtr ->
          withMaybeSRAsCString srcSrs $ \srcSrs' ->
          withMaybeSRAsCString dstSrs $ \dstSrs' ->
          withWarpOptionsPtr srcDs options' $ \wopts ->
            void $ c_reprojectImage srcPtr srcSrs' dstPtr dstSrs' algo'
                     memLimit' maxError' pFun nullPtr wopts
       maybe (throwBindingException WarpStopped) return ret
  where
    algo'     = fromEnumC algo
    maxError' = realToFrac maxError
    memLimit' = realToFrac memLimit

foreign import ccall safe "gdalwarper.h GDALReprojectImage" c_reprojectImage
  :: Ptr (Dataset s t a)     -- ^Source dataset
  -> CString                 -- ^Source proj (WKT)
  -> Ptr (RWDataset s b)     -- ^Dest dataset
  -> CString                 -- ^Dest proj (WKT)
  -> CInt                    -- ^Resample alg
  -> CDouble                 -- ^Memory limit
  -> CDouble                 -- ^Max error
  -> ProgressFunPtr          -- ^Progress func
  -> Ptr ()                  -- ^Progress arg (unused)
  -> Ptr (WarpOptions s a b) -- ^warp options
  -> IO CInt

createWarpedVRT
  :: forall s a b. (GDALType a, GDALType b)
  => RODataset s a
  -> Size
  -> Geotransform
  -> WarpOptions s a b
  -> GDAL s (RODataset s b)
createWarpedVRT srcDs (XY nPixels nLines) geotransform wo@WarpOptions{..} = do
  options'' <- setOptionDefaults srcDs Nothing options'
  newDsPtr <- liftIO $
    withWarpOptionsPtr srcDs options'' $ \opts ->
    alloca $ \gt -> do
      poke (castPtr gt) geotransform
      pArg <- {#get GDALWarpOptions.pTransformerArg #} opts
      when (pArg /= nullPtr) $
        {#call GDALSetGenImgProjTransformerDstGeoTransform as ^#} pArg gt
      c_createWarpedVRT dsPtr nPixels' nLines' gt opts
  oDs <- newDerivedDatasetHandle srcDs newDsPtr
  setDstNodata oDs options''
  unsafeToReadOnly oDs
  where
    nPixels' = fromIntegral nPixels
    nLines'  = fromIntegral nLines
    dsPtr    = unDataset srcDs
    options' = case woTransfomer of
                 Nothing -> setTransformer (def :: GenImgProjTransformer s a b)
                                           wo
                 Just _  -> wo

setDstNodata :: GDALType b => RWDataset s b -> WarpOptions s a b -> GDAL s ()
setDstNodata oDs options
  = when (anyBandHasDstNoData options) $
      forM_ (woBands options) $ \BandOptions{..} ->
        case biDstNoData of
          Just nd -> do
            b <- getBand biDst oDs
            setBandNodataValue b nd
          Nothing -> return ()

foreign import ccall safe "gdalwarper.h GDALCreateWarpedVRT" c_createWarpedVRT
  :: Ptr (RODataset s a)     -- ^Source dataset
  -> CInt                    -- ^nPixels
  -> CInt                    -- ^nLines
  -> Ptr CDouble             -- ^geotransform
  -> Ptr (WarpOptions s a b) -- ^warp options
  -> IO (Ptr (RWDataset s b))

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}

module GDAL.Internal.Warper (
    ResampleAlg (..)
  , WarpOptions (..)
  , BandOptions (..)
  , GDALWarpException (..)
  , reprojectImage
  , setTransformer
  , createWarpedVRT
  , def
) where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (when, void, forM_, forM)
import Control.Monad.IO.Class (liftIO)
import Control.DeepSeq (NFData(rnf))
import Control.Exception (Exception(..), bracket)
import Data.Maybe (isJust, fromMaybe)
import Data.Typeable (Typeable)
import Data.Default (Default(..))
import Foreign.C.String (CString)
import Foreign.C.Types (CDouble(..), CInt(..), CChar(..))
import Foreign.Ptr (
    Ptr
  , FunPtr
  , nullPtr
  , castPtr
  , castFunPtr
  , nullFunPtr
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Storable (Storable(..))

import GDAL.Internal.Types
import GDAL.Internal.Util (fromEnumC)
import GDAL.Internal.CPLConv
{#import GDAL.Internal.Algorithms #}
{#import GDAL.Internal.CPLError #}
{#import GDAL.Internal.CPLString #}
{#import GDAL.Internal.CPLProgress #}
{#import GDAL.Internal.OSR #}
{#import GDAL.Internal.GDAL #}

#include "gdal.h"
#include "gdalwarper.h"

data GDALWarpException
  = WarpStopped
  deriving (Typeable, Show, Eq)

instance NFData GDALWarpException where
  rnf a = a `seq` ()

instance Exception GDALWarpException where
  toException   = bindingExceptionToException
  fromException = bindingExceptionFromException

{# enum GDALResampleAlg as ResampleAlg {upcaseFirstLetter} with prefix = "GRA_"
     deriving (Eq,Read,Show,Bounded) #}

data BandOptions a b
  = BandOptions {
      biSrc       :: !Int
    , biDst       :: !Int
    , biSrcNoData :: !(Maybe a)
    , biDstNoData :: !(Maybe b)
    } deriving Show

data WarpOptions s a b
  = forall t. (Transformer t, GDALType a, GDALType b)
  => WarpOptions {
      woResampleAlg     :: ResampleAlg
    , woWarpOptions     :: OptionList
    , woMemoryLimit     :: Double
    , woWorkingDatatype :: Datatype
    , woBands           :: [BandOptions a b]
    , woTransfomer      :: Maybe (t s a b)
    , woProgressFun     :: Maybe ProgressFun
    }

instance (GDALType a, GDALType b) => Default (WarpOptions s a b) where
  def = WarpOptions {
          woResampleAlg     = NearestNeighbour
        , woWarpOptions     = []
        , woMemoryLimit     = 0
        , woWorkingDatatype = GDT_Unknown
        , woBands           = []
        , woTransfomer      = Nothing :: Maybe (GenImgProjTransformer s a b)
        , woProgressFun     = Nothing
        }

-- Avoids "Record update for insufficiently polymorphic field" when doigs
-- opts { woTransfomer = Just ...}
setTransformer
  :: forall t s a b. (Transformer t, GDALType a, GDALType b)
  => t s a b -> WarpOptions s a b -> WarpOptions s a b
setTransformer t opts = WarpOptions {
    woResampleAlg     = woResampleAlg opts
  , woWarpOptions     = woWarpOptions opts
  , woMemoryLimit     = woMemoryLimit opts
  , woWorkingDatatype = woWorkingDatatype opts
  , woBands           = woBands opts
  , woTransfomer      = Just t
  , woProgressFun     = woProgressFun opts
  }

setOptionDefaults
  :: (GDALType a, GDALType b)
  => RODataset s a -> Maybe (Dataset s t b) -> WarpOptions s a b
  -> GDAL s (WarpOptions s a b)
setOptionDefaults ds moDs wo@WarpOptions{..} = do
  bands <- if null woBands
            then forM [1..datasetBandCount ds] $ \i -> do
              srcNd <- getBand i ds >>= bandNodataValue
              dstNd <- case moDs of
                         Just oDs -> getBand i oDs >>= bandNodataValue
                         Nothing  -> return (fmap (fromNodata . toNodata) srcNd)
              return (BandOptions i i srcNd dstNd)
            else return woBands
  let warpOptions
        | any (isJust . biDstNoData) bands
        = ("INIT_DEST","NO_DATA") : woWarpOptions
        | otherwise = woWarpOptions
  return (wo { woWarpOptions = warpOptions, woBands = bands})

anyBandHasNoData :: WarpOptions s a b -> Bool
anyBandHasNoData wo
  = any (\BandOptions{..} -> isJust biSrcNoData || isJust biDstNoData) (woBands wo)

anyBandHasDstNoData :: WarpOptions s a b -> Bool
anyBandHasDstNoData wo = any (\BandOptions{..} -> isJust biDstNoData) (woBands wo)

withWarpOptionsPtr
  :: (GDALType a, GDALType b)
  => RODataset s a -> WarpOptions s a b -> (Ptr (WarpOptions s a b) -> IO c)
  -> IO c
withWarpOptionsPtr ds wo f = do
  (opts, finalize) <- mkWarpOptionsPtr ds wo
  bracket (return opts) (const finalize) f

mkWarpOptionsPtr
  :: (GDALType a, GDALType b)
  => RODataset s a -> WarpOptions s a b
  -> IO (Ptr (WarpOptions s a b), IO ())
mkWarpOptionsPtr ds wo@WarpOptions{..} = do
  p <- createWarpOptions
  return (p, destroyWarpOptions p)
  where
    dsPtr = unDataset ds
    createWarpOptions = do
      p <- c_createWarpOptions
      {#set GDALWarpOptions.hSrcDS #} p (castPtr dsPtr)
      {#set GDALWarpOptions.eResampleAlg #} p (fromEnumC woResampleAlg)
      oListPtr <- toOptionListPtr woWarpOptions
      {#set GDALWarpOptions.papszWarpOptions #} p oListPtr
      {#set GDALWarpOptions.dfWarpMemoryLimit #} p (realToFrac woMemoryLimit)
      {#set GDALWarpOptions.eWorkingDataType #} p (fromEnumC woWorkingDatatype)
      {#set GDALWarpOptions.nBandCount #} p (fromIntegral (length woBands))
      {#set GDALWarpOptions.panSrcBands #} p =<<
        listToPtr (map (fromIntegral . biSrc) woBands)
      {#set GDALWarpOptions.panDstBands #} p =<<
        listToPtr (map (fromIntegral . biDst) woBands)
      case woTransfomer of
        Just t -> do
          {#set GDALWarpOptions.pfnTransformer #} p
            (castFunPtr (transformerFunc t))
          tArg <- fmap castPtr (createTransformer dsPtr t)
          {#set GDALWarpOptions.pTransformerArg #} p tArg
        Nothing -> do
          {#set GDALWarpOptions.pfnTransformer #} p nullFunPtr
          {#set GDALWarpOptions.pTransformerArg #} p nullPtr
      when (anyBandHasNoData wo) $ do
        vPtrSrcR <- listToPtr
                      (map (toNodata . fromMaybe nodata . biSrcNoData) woBands)
        vPtrSrcI <- listToPtr (replicate (length woBands) 0)
        vPtrDstR <- listToPtr
                      (map (toNodata . fromMaybe nodata . biDstNoData) woBands)
        vPtrDstI <- listToPtr (replicate (length woBands) 0)
        {#set GDALWarpOptions.padfDstNoDataReal #} p vPtrDstR
        {#set GDALWarpOptions.padfDstNoDataImag #} p vPtrDstI
        {#set GDALWarpOptions.padfSrcNoDataReal #} p vPtrSrcR
        {#set GDALWarpOptions.padfSrcNoDataImag #} p vPtrSrcI
      return p

    destroyWarpOptions = c_destroyWarpOptions

    listToPtr [] = return nullPtr
    listToPtr l = do
      ptr <- cplMallocArray (length l)
      mapM_ (\(i,v) -> pokeElemOff ptr i v) (zip [0..] l)
      return ptr

foreign import ccall unsafe "gdalwarper.h GDALCreateWarpOptions"
  c_createWarpOptions :: IO (Ptr (WarpOptions s a b))

foreign import ccall unsafe "gdalwarper.h GDALDestroyWarpOptions"
  c_destroyWarpOptions :: Ptr (WarpOptions s a b) -> IO ()

reprojectImage
  :: (GDALType a, GDALType b)
  => RODataset s a
  -> Maybe SpatialReference
  -> RWDataset s b
  -> Maybe SpatialReference
  -> ResampleAlg
  -> Double
  -> Double
  -> Maybe ProgressFun
  -> OptionList
  -> GDAL s ()
reprojectImage srcDs srcSrs dstDs dstSrs algo memLimit maxError progressFun opts
  = do options' <- setOptionDefaults srcDs (Just dstDs)
                     (def {woWarpOptions=opts})
       ret <- liftIO $
          withProgressFun progressFun $ \pFun ->
          throwIfError "reprojectImage" $
          withLockedDatasetPtr srcDs $ \srcPtr ->
          withLockedDatasetPtr dstDs $ \dstPtr ->
          withMaybeSRAsCString srcSrs $ \srcSrs' ->
          withMaybeSRAsCString dstSrs $ \dstSrs' ->
          withWarpOptionsPtr srcDs options' $ \wopts ->
            void $ c_reprojectImage srcPtr srcSrs' dstPtr dstSrs' algo'
                     memLimit' maxError' pFun nullPtr wopts
       maybe (throwBindingException WarpStopped) return ret
  where
    algo'     = fromEnumC algo
    maxError' = realToFrac maxError
    memLimit' = realToFrac memLimit

foreign import ccall safe "gdalwarper.h GDALReprojectImage" c_reprojectImage
  :: Ptr (Dataset s t a)     -- ^Source dataset
  -> CString                 -- ^Source proj (WKT)
  -> Ptr (RWDataset s b)     -- ^Dest dataset
  -> CString                 -- ^Dest proj (WKT)
  -> CInt                    -- ^Resample alg
  -> CDouble                 -- ^Memory limit
  -> CDouble                 -- ^Max error
  -> ProgressFunPtr          -- ^Progress func
  -> Ptr ()                  -- ^Progress arg (unused)
  -> Ptr (WarpOptions s a b) -- ^warp options
  -> IO CInt

createWarpedVRT
  :: forall s a b. (GDALType a, GDALType b)
  => RODataset s a
  -> Size
  -> Geotransform
  -> WarpOptions s a b
  -> GDAL s (RODataset s b)
createWarpedVRT srcDs (XY nPixels nLines) geotransform wo@WarpOptions{..} = do
  let dsPtr = unDataset srcDs
  options'' <- setOptionDefaults srcDs Nothing options'
  (opts,finalizeOpts) <- liftIO (mkWarpOptionsPtr srcDs options'')
  registerFinalizer finalizeOpts
  newDsPtr <- liftIO $ alloca $ \gt -> do
    poke (castPtr gt) geotransform
    pArg <- {#get GDALWarpOptions.pTransformerArg #} opts
    when (pArg /= nullPtr) $
      {#call GDALSetGenImgProjTransformerDstGeoTransform as ^#} pArg gt
    c_createWarpedVRT dsPtr (fromIntegral nPixels) (fromIntegral nLines) gt opts
  oDs <- newDerivedDatasetHandle srcDs newDsPtr
  setDstNodata oDs options''
  unsafeToReadOnly oDs
  where
    options' = case woTransfomer of
                 Nothing -> setTransformer (def :: GenImgProjTransformer s a b)
                                           wo
                 Just _  -> wo

setDstNodata :: GDALType b => RWDataset s b -> WarpOptions s a b -> GDAL s ()
setDstNodata oDs options
  = when (anyBandHasDstNoData options) $
      forM_ (woBands options) $ \BandOptions{..} ->
        case biDstNoData of
          Just nd -> do
            b <- getBand biDst oDs
            setBandNodataValue b nd
          Nothing -> return ()

foreign import ccall safe "gdalwarper.h GDALCreateWarpedVRT" c_createWarpedVRT
  :: Ptr (RODataset s a)     -- ^Source dataset
  -> CInt                    -- ^nPixels
  -> CInt                    -- ^nLines
  -> Ptr CDouble             -- ^geotransform
  -> Ptr (WarpOptions s a b) -- ^warp options
  -> IO (Ptr (RWDataset s b))


BUGFIX: Compile on 32bit

BUGFIX: Compile on 32bit

{-# 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(..), CUInt(..), 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"

type CSizeT = {# type size_t #}

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, CSizeT) -> 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 -> CSizeT -> IO ()
type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CSizeT -> 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 =
     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 * #}


Handle AnnotFlag bytemask

Handle AnnotFlag bytemask

{-# LANGUAGE CPP, DeriveDataTypeable #-}
module Graphics.UI.Gtk.Poppler.Annotation (
    Annot,
    AnnotClass,
    PopplerAnnotType (..),
    AnnotFlag (..),
    AnnotMarkup,
    AnnotMarkupClass,
    AnnotText,
    AnnotTextClass,
    castToAnnotText,
    annotGetAnnotType,
    annotGetAnnotFlags,
    annotSetAnnotFlags,
    annotGetName,
    annotGetPageIndex,
    annotGetColor,
    annotSetColor,
    annotGetContents,
    annotSetContents,
    annotGetModified,
    annotMarkupGetLabel,
    annotMarkupSetLabel,
    annotMarkupGetSubject,
    annotMarkupGetOpacity,
    annotMarkupSetOpacity,
    annotMarkupHasPopup,
    annotMarkupSetPopup,
    annotMarkupGetPopupIsOpen,
    annotMarkupSetPopupIsOpen,
    annotTextNew,
    annotTextGetIsOpen,
    annotTextSetIsOpen
    ) where

import Control.Monad
import Data.Typeable
import Data.Bits
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

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

toByteMask :: [AnnotFlag] -> Int
toByteMask = foldr (.|.) 0 . fmap fromEnum

fromByteMask :: Int -> [AnnotFlag]
fromByteMask mask = foldr go [] (enumFrom minBound)
    where
      go x xs
          | AnnotFlagUnknown == x             = xs
          | fromEnum x == fromEnum x .&. mask = x:xs
          | otherwise                         = xs

annotGetAnnotType :: AnnotClass annot => annot -> IO PopplerAnnotType
annotGetAnnotType annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_annot_type #} (toAnnot annot)

annotGetAnnotFlags :: AnnotClass annot => annot -> IO [AnnotFlag]
annotGetAnnotFlags annot =
  liftM (fromByteMask . fromIntegral) $
  {# call poppler_annot_get_flags #} (toAnnot annot)

annotSetAnnotFlags :: AnnotClass annot => annot -> [AnnotFlag] -> IO ()
annotSetAnnotFlags annot flags =
  {# call poppler_annot_set_flags #}
  (toAnnot annot)
  (fromIntegral $ toByteMask flags)

annotGetName :: AnnotClass annot => annot -> IO String
annotGetName annot =
  {# call poppler_annot_get_name #} (toAnnot annot) >>= peekUTFString

annotGetPageIndex :: AnnotClass annot => annot -> IO Int
annotGetPageIndex annot =
  liftM fromIntegral $
  {# call poppler_annot_get_page_index #} (toAnnot annot)

annotGetColor :: AnnotClass annot => annot -> IO PopplerColor
annotGetColor annot =
  (peekPopplerColor . castPtr) =<<
  {# call poppler_annot_get_color #} (toAnnot annot)

annotSetColor :: AnnotClass annot => annot -> PopplerColor -> IO ()
annotSetColor annot color =
  with color $ \colorPtr ->
    {# call poppler_annot_set_color #} (toAnnot annot) (castPtr colorPtr)

annotGetContents :: AnnotClass annot => annot -> IO String
annotGetContents annot =
  {# call poppler_annot_get_contents #} (toAnnot annot) >>= peekUTFString

annotSetContents :: AnnotClass annot => annot -> String -> IO ()
annotSetContents annot content =
  withUTFString content $ \contentPtr ->
    {# call poppler_annot_set_contents #} (toAnnot annot) contentPtr

annotGetModified :: AnnotClass annot => annot -> IO String
annotGetModified annot =
  {# call poppler_annot_get_modified #} (toAnnot annot) >>= peekUTFString

annotMarkupGetLabel :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetLabel mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_label #} (toAnnotMarkup mark)

annotMarkupSetLabel :: AnnotMarkupClass mark => mark -> String -> IO ()
annotMarkupSetLabel mark label =
  withUTFString label $ \labelPtr ->
    {# call poppler_annot_markup_set_label #}
    (toAnnotMarkup mark)
    (castPtr labelPtr)

annotMarkupGetSubject :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetSubject mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_subject #} (toAnnotMarkup mark)

annotMarkupGetOpacity :: AnnotMarkupClass mark => mark -> IO Double
annotMarkupGetOpacity mark =
  liftM realToFrac $
  {# call poppler_annot_markup_get_opacity #} (toAnnotMarkup mark)

annotMarkupSetOpacity :: AnnotMarkupClass mark => mark -> Double -> IO ()
annotMarkupSetOpacity mark opacity =
  {# call poppler_annot_markup_set_opacity #}
  (toAnnotMarkup mark)
  (realToFrac opacity)

annotMarkupHasPopup :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupHasPopup mark =
  liftM toBool $
  {# call poppler_annot_markup_has_popup #} (toAnnotMarkup mark)

annotMarkupSetPopup :: AnnotMarkupClass mark
                    => mark
                    -> PopplerRectangle
                    -> IO ()
annotMarkupSetPopup mark rect =
  with rect $ \rectPtr ->
    {# call poppler_annot_markup_set_popup #} (toAnnotMarkup mark) (castPtr rectPtr)

annotMarkupGetPopupIsOpen :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupGetPopupIsOpen mark =
  liftM toBool $
  {# call poppler_annot_markup_get_popup_is_open #} (toAnnotMarkup mark)

annotMarkupSetPopupIsOpen :: AnnotMarkupClass mark => mark -> Bool -> IO ()
annotMarkupSetPopupIsOpen mark bool =
  {# call poppler_annot_markup_set_popup_is_open #}
  (toAnnotMarkup mark)
  (fromBool bool)

annotTextNew :: DocumentClass doc => doc -> PopplerRectangle -> IO AnnotText
annotTextNew doc selection =
  wrapNewGObject mkAnnotText $
  with selection $ \selectionPtr ->
    liftM castPtr $
    {# call poppler_annot_text_new #} (toDocument doc) (castPtr selectionPtr)

annotTextGetIsOpen :: AnnotTextClass annot => annot -> IO Bool
annotTextGetIsOpen annot =
  liftM toBool $
  {# call poppler_annot_text_get_is_open #} (toAnnotText annot)

annotTextSetIsOpen :: AnnotTextClass annot => annot -> Bool -> IO ()
annotTextSetIsOpen annot bool =
  {# call poppler_annot_text_set_is_open #}
  (toAnnotText annot)
  (fromBool bool)

{-# LANGUAGE CPP, DeriveDataTypeable #-}
module Graphics.UI.Gtk.Poppler.Annotation (
    Annot,
    AnnotClass,
    PopplerAnnotType (..),
    AnnotFlag (..),
    AnnotMarkup,
    AnnotMarkupClass,
    AnnotText,
    AnnotTextClass,
    castToAnnotText,
    annotGetAnnotType,
    annotGetAnnotFlags,
    annotSetAnnotFlags,
    annotGetName,
    annotGetPageIndex,
    annotGetColor,
    annotSetColor,
    annotGetContents,
    annotSetContents,
    annotGetModified,
    annotMarkupGetLabel,
    annotMarkupSetLabel,
    annotMarkupGetSubject,
    annotMarkupGetOpacity,
    annotMarkupSetOpacity,
    annotMarkupHasPopup,
    annotMarkupSetPopup,
    annotMarkupGetPopupIsOpen,
    annotMarkupSetPopupIsOpen,
    annotTextNew,
    annotTextGetIsOpen,
    annotTextSetIsOpen
    ) 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

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

annotGetAnnotType :: AnnotClass annot => annot -> IO PopplerAnnotType
annotGetAnnotType annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_annot_type #} (toAnnot annot)

annotGetAnnotFlags :: AnnotClass annot => annot -> IO AnnotFlag
annotGetAnnotFlags annot =
  liftM (toEnum . fromIntegral) $
  {# call poppler_annot_get_flags #} (toAnnot annot)

annotSetAnnotFlags :: AnnotClass annot => annot -> AnnotFlag -> IO ()
annotSetAnnotFlags annot flag =
  {# call poppler_annot_set_flags #}
  (toAnnot annot)
  (fromIntegral $ fromEnum flag)

annotGetName :: AnnotClass annot => annot -> IO String
annotGetName annot =
  {# call poppler_annot_get_name #} (toAnnot annot) >>= peekUTFString

annotGetPageIndex :: AnnotClass annot => annot -> IO Int
annotGetPageIndex annot =
  liftM fromIntegral $
  {# call poppler_annot_get_page_index #} (toAnnot annot)

annotGetColor :: AnnotClass annot => annot -> IO PopplerColor
annotGetColor annot =
  (peekPopplerColor . castPtr) =<<
  {# call poppler_annot_get_color #} (toAnnot annot)

annotSetColor :: AnnotClass annot => annot -> PopplerColor -> IO ()
annotSetColor annot color =
  with color $ \colorPtr ->
    {# call poppler_annot_set_color #} (toAnnot annot) (castPtr colorPtr)

annotGetContents :: AnnotClass annot => annot -> IO String
annotGetContents annot =
  {# call poppler_annot_get_contents #} (toAnnot annot) >>= peekUTFString

annotSetContents :: AnnotClass annot => annot -> String -> IO ()
annotSetContents annot content =
  withUTFString content $ \contentPtr ->
    {# call poppler_annot_set_contents #} (toAnnot annot) contentPtr

annotGetModified :: AnnotClass annot => annot -> IO String
annotGetModified annot =
  {# call poppler_annot_get_modified #} (toAnnot annot) >>= peekUTFString

annotMarkupGetLabel :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetLabel mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_label #} (toAnnotMarkup mark)

annotMarkupSetLabel :: AnnotMarkupClass mark => mark -> String -> IO ()
annotMarkupSetLabel mark label =
  withUTFString label $ \labelPtr ->
    {# call poppler_annot_markup_set_label #}
    (toAnnotMarkup mark)
    (castPtr labelPtr)

annotMarkupGetSubject :: AnnotMarkupClass mark => mark -> IO String
annotMarkupGetSubject mark =
  peekUTFString =<<
  {# call poppler_annot_markup_get_subject #} (toAnnotMarkup mark)

annotMarkupGetOpacity :: AnnotMarkupClass mark => mark -> IO Double
annotMarkupGetOpacity mark =
  liftM realToFrac $
  {# call poppler_annot_markup_get_opacity #} (toAnnotMarkup mark)

annotMarkupSetOpacity :: AnnotMarkupClass mark => mark -> Double -> IO ()
annotMarkupSetOpacity mark opacity =
  {# call poppler_annot_markup_set_opacity #}
  (toAnnotMarkup mark)
  (realToFrac opacity)

annotMarkupHasPopup :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupHasPopup mark =
  liftM toBool $
  {# call poppler_annot_markup_has_popup #} (toAnnotMarkup mark)

annotMarkupSetPopup :: AnnotMarkupClass mark
                    => mark
                    -> PopplerRectangle
                    -> IO ()
annotMarkupSetPopup mark rect =
  with rect $ \rectPtr ->
    {# call poppler_annot_markup_set_popup #} (toAnnotMarkup mark) (castPtr rectPtr)

annotMarkupGetPopupIsOpen :: AnnotMarkupClass mark => mark -> IO Bool
annotMarkupGetPopupIsOpen mark =
  liftM toBool $
  {# call poppler_annot_markup_get_popup_is_open #} (toAnnotMarkup mark)

annotMarkupSetPopupIsOpen :: AnnotMarkupClass mark => mark -> Bool -> IO ()
annotMarkupSetPopupIsOpen mark bool =
  {# call poppler_annot_markup_set_popup_is_open #}
  (toAnnotMarkup mark)
  (fromBool bool)

annotTextNew :: DocumentClass doc => doc -> PopplerRectangle -> IO AnnotText
annotTextNew doc selection =
  wrapNewGObject mkAnnotText $
  with selection $ \selectionPtr ->
    liftM castPtr $
    {# call poppler_annot_text_new #} (toDocument doc) (castPtr selectionPtr)

annotTextGetIsOpen :: AnnotTextClass annot => annot -> IO Bool
annotTextGetIsOpen annot =
  liftM toBool $
  {# call poppler_annot_text_get_is_open #} (toAnnotText annot)

annotTextSetIsOpen :: AnnotTextClass annot => annot -> Bool -> IO ()
annotTextSetIsOpen annot bool =
  {# call poppler_annot_text_set_is_open #}
  (toAnnotText annot)
  (fromBool bool)


gtksourceview2: typo: can-redo -> can-undo (for sourceBufferCanUndo)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2003-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceBuffer (
  SourceBuffer,
  SourceBufferClass,
  castToSourceBuffer,
  sourceBufferNew,
  sourceBufferNewWithLanguage,
  sourceBufferSetHighlightSyntax,
  sourceBufferGetHighlightSyntax,
  sourceBufferSetLanguage,
  sourceBufferGetLanguage,
  sourceBufferSetHighlightMatchingBrackets,
  sourceBufferGetHighlightMatchingBrackets,
  sourceBufferSetStyleScheme,
  sourceBufferGetStyleScheme,
  sourceBufferSetMaxUndoLevels,
  sourceBufferGetMaxUndoLevels,
  sourceBufferGetCanUndo,
  sourceBufferGetCanRedo,
  sourceBufferUndo,
  sourceBufferRedo,
  sourceBufferBeginNotUndoableAction,
  sourceBufferEndNotUndoableAction,
  sourceBufferCreateSourceMark,
  sourceBufferEnsureHighlight,
  sourceBufferCanRedo,
  sourceBufferCanUndo,
  sourceBufferHighlightMatchingBrackets,
  sourceBufferHighlightSyntax,
  sourceBufferLanguage,
  sourceBufferSourceStyleScheme,
  sourceBufferHighlightUpdated
  ) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.GObject              (constructNewGObject,
					 makeNewGObject)
{#import System.Glib.Properties#}
import System.Glib.Attributes
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.Signals#}
{#import Graphics.UI.Gtk.Multiline.Types#}
{#import Graphics.UI.Gtk.Multiline.TextIter#}

import Graphics.UI.Gtk.SourceView.SourceMark

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

-- methods

-- | Create a new 'SourceBuffer', possibly
-- taking a 'TextTagTable'.
--
sourceBufferNew :: Maybe TextTagTable -> IO SourceBuffer
sourceBufferNew tt = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new#}
  (fromMaybe (mkTextTagTable nullForeignPtr) tt)

-- | Create a new 'SourceBuffer'
-- with a 'SourceLanguage'.
--
sourceBufferNewWithLanguage :: SourceLanguage -> IO SourceBuffer
sourceBufferNewWithLanguage lang = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new_with_language#} lang

-- |
--
sourceBufferSetHighlightSyntax :: SourceBuffer -> Bool -> IO ()
sourceBufferSetHighlightSyntax sb newVal =
  {#call unsafe source_buffer_set_highlight_syntax#} sb (fromBool newVal)

-- |
--
sourceBufferGetHighlightSyntax :: SourceBuffer -> IO Bool
sourceBufferGetHighlightSyntax sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_syntax#} sb

-- |
--
sourceBufferSetLanguage :: SourceBuffer -> SourceLanguage -> IO ()
sourceBufferSetLanguage sb lang =
  {#call unsafe source_buffer_set_language#} sb lang

-- |
--
sourceBufferGetLanguage :: SourceBuffer -> IO SourceLanguage
sourceBufferGetLanguage sb = makeNewGObject mkSourceLanguage $
  {#call unsafe source_buffer_get_language#} sb

-- |
--
sourceBufferSetHighlightMatchingBrackets :: SourceBuffer -> Bool -> IO ()
sourceBufferSetHighlightMatchingBrackets sb newVal =
  {#call unsafe source_buffer_set_highlight_matching_brackets#} sb (fromBool newVal)

-- |
--
sourceBufferGetHighlightMatchingBrackets :: SourceBuffer -> IO Bool
sourceBufferGetHighlightMatchingBrackets sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_matching_brackets#} sb

-- |
--
sourceBufferSetStyleScheme :: SourceBuffer -> SourceStyleScheme -> IO ()
sourceBufferSetStyleScheme sb sss =
    {#call unsafe source_buffer_set_style_scheme#} sb sss

-- |
--
sourceBufferGetStyleScheme :: SourceBuffer -> IO SourceStyleScheme
sourceBufferGetStyleScheme sb = makeNewGObject mkSourceStyleScheme $
  {#call unsafe source_buffer_get_style_scheme#} sb

-- |
--
sourceBufferSetMaxUndoLevels :: SourceBuffer -> Int -> IO ()
sourceBufferSetMaxUndoLevels sb newVal =
  {#call unsafe source_buffer_set_max_undo_levels#} sb (fromIntegral newVal)

-- |
--
sourceBufferGetMaxUndoLevels :: SourceBuffer -> IO Int
sourceBufferGetMaxUndoLevels sb = liftM fromIntegral $
  {#call unsafe source_buffer_get_max_undo_levels#} sb

-- |
--
sourceBufferGetCanUndo :: SourceBuffer -> IO Bool
sourceBufferGetCanUndo sb = liftM toBool $
  {#call unsafe source_buffer_can_undo#} sb

-- |
--
sourceBufferGetCanRedo :: SourceBuffer -> IO Bool
sourceBufferGetCanRedo sb = liftM toBool $
  {#call unsafe source_buffer_can_redo#} sb

-- |
--
sourceBufferUndo :: SourceBuffer -> IO ()
sourceBufferUndo sb =
  {#call source_buffer_undo#} sb

-- |
--
sourceBufferRedo :: SourceBuffer -> IO ()
sourceBufferRedo sb =
  {#call source_buffer_redo#} sb

-- |
--
sourceBufferBeginNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferBeginNotUndoableAction sb =
  {#call source_buffer_begin_not_undoable_action#} sb

-- |
--
sourceBufferEndNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferEndNotUndoableAction sb =
  {#call source_buffer_end_not_undoable_action#} sb

-- | Creates a marker in the buffer of the given type.
--
-- *  A marker is
--    semantically very similar to a 'Graphics.UI.Gtk.Multiline.TextMark',
--    except it has a type
--    which is used by the 'SourceView' displaying the buffer to show a
--    pixmap on the left margin, at the line the marker is in.  Because
--    of this, a marker is generally associated to a line and not a
--    character position.  Markers are also accessible through a position
--    or range in the buffer.
--
-- *  Markers are implemented using 'Graphics.UI.Gtk.Multiline.TextMark',
--    so all characteristics
--    and restrictions to marks apply to markers too.  These includes
--    life cycle issues and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkSet'
--    and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkDeleted' signal
--    emissions.
--
-- *  Like a 'Graphics.UI.Gtk.Multiline.TextMark', a 'SourceMarker'
--    can be anonymous if the
--    passed name is @Nothing@.  Also, the buffer owns the markers so you
--    shouldn't unreference it.

sourceBufferCreateSourceMark :: SourceBuffer -- the buffer
                         -> Maybe String -- the name of the mark
                         -> String -- the category of the mark
                         -> TextIter -> IO SourceMark
sourceBufferCreateSourceMark sb name category iter =
  makeNewGObject mkSourceMark $
  maybeWith withCString name       $ \strPtr1 ->
  withCString category $ \strPtr2 ->
  {#call source_buffer_create_source_mark#} sb strPtr1 strPtr2 iter

-- |
--
sourceBufferEnsureHighlight :: SourceBuffer -> TextIter -> TextIter -> IO ()
sourceBufferEnsureHighlight sb start end =
    {#call source_buffer_ensure_highlight#} sb start end

-- |
--
sourceBufferCanRedo :: ReadAttr SourceBuffer Bool
sourceBufferCanRedo = readAttrFromBoolProperty "can-redo"

-- |
--
sourceBufferCanUndo :: ReadAttr SourceBuffer Bool
sourceBufferCanUndo = readAttrFromBoolProperty "can-undo"

-- |
--
sourceBufferHighlightMatchingBrackets :: Attr SourceBuffer Bool
sourceBufferHighlightMatchingBrackets = newAttrFromBoolProperty "highlight-matching-brackets"

-- |
--
sourceBufferHighlightSyntax :: Attr SourceBuffer Bool
sourceBufferHighlightSyntax = newAttrFromBoolProperty "highlight-matching-brackets"

-- |
--
sourceBufferLanguage :: Attr SourceBuffer (Maybe SourceLanguage)
sourceBufferLanguage = newAttrFromMaybeObjectProperty "language" gTypeSourceLanguage

-- |
--
sourceBufferMaxUndoLevels :: Attr SourceBuffer Int
sourceBufferMaxUndoLevels = newAttrFromIntProperty "max-undo-levels"

-- |
--
sourceBufferSourceStyleScheme :: Attr SourceBuffer (Maybe SourceStyleScheme)
sourceBufferSourceStyleScheme = newAttrFromMaybeObjectProperty "style-scheme" gTypeSourceStyleScheme

-- |
--
sourceBufferHighlightUpdated :: Signal SourceBuffer (TextIter -> TextIter -> IO ())
sourceBufferHighlightUpdated = Signal $ connect_BOXED_BOXED__NONE "highlight-updated" mkTextIterCopy mkTextIterCopy

-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Peter Gavin
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2003-2008 Peter Gavin, Duncan Coutts, Axel Simon
--
--  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.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceBuffer (
  SourceBuffer,
  SourceBufferClass,
  castToSourceBuffer,
  sourceBufferNew,
  sourceBufferNewWithLanguage,
  sourceBufferSetHighlightSyntax,
  sourceBufferGetHighlightSyntax,
  sourceBufferSetLanguage,
  sourceBufferGetLanguage,
  sourceBufferSetHighlightMatchingBrackets,
  sourceBufferGetHighlightMatchingBrackets,
  sourceBufferSetStyleScheme,
  sourceBufferGetStyleScheme,
  sourceBufferSetMaxUndoLevels,
  sourceBufferGetMaxUndoLevels,
  sourceBufferGetCanUndo,
  sourceBufferGetCanRedo,
  sourceBufferUndo,
  sourceBufferRedo,
  sourceBufferBeginNotUndoableAction,
  sourceBufferEndNotUndoableAction,
  sourceBufferCreateSourceMark,
  sourceBufferEnsureHighlight,
  sourceBufferCanRedo,
  sourceBufferCanUndo,
  sourceBufferHighlightMatchingBrackets,
  sourceBufferHighlightSyntax,
  sourceBufferLanguage,
  sourceBufferSourceStyleScheme,
  sourceBufferHighlightUpdated
  ) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.GObject              (constructNewGObject,
					 makeNewGObject)
{#import System.Glib.Properties#}
import System.Glib.Attributes
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.Signals#}
{#import Graphics.UI.Gtk.Multiline.Types#}
{#import Graphics.UI.Gtk.Multiline.TextIter#}

import Graphics.UI.Gtk.SourceView.SourceMark

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

-- methods

-- | Create a new 'SourceBuffer', possibly
-- taking a 'TextTagTable'.
--
sourceBufferNew :: Maybe TextTagTable -> IO SourceBuffer
sourceBufferNew tt = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new#}
  (fromMaybe (mkTextTagTable nullForeignPtr) tt)

-- | Create a new 'SourceBuffer'
-- with a 'SourceLanguage'.
--
sourceBufferNewWithLanguage :: SourceLanguage -> IO SourceBuffer
sourceBufferNewWithLanguage lang = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new_with_language#} lang

-- |
--
sourceBufferSetHighlightSyntax :: SourceBuffer -> Bool -> IO ()
sourceBufferSetHighlightSyntax sb newVal =
  {#call unsafe source_buffer_set_highlight_syntax#} sb (fromBool newVal)

-- |
--
sourceBufferGetHighlightSyntax :: SourceBuffer -> IO Bool
sourceBufferGetHighlightSyntax sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_syntax#} sb

-- |
--
sourceBufferSetLanguage :: SourceBuffer -> SourceLanguage -> IO ()
sourceBufferSetLanguage sb lang =
  {#call unsafe source_buffer_set_language#} sb lang

-- |
--
sourceBufferGetLanguage :: SourceBuffer -> IO SourceLanguage
sourceBufferGetLanguage sb = makeNewGObject mkSourceLanguage $
  {#call unsafe source_buffer_get_language#} sb

-- |
--
sourceBufferSetHighlightMatchingBrackets :: SourceBuffer -> Bool -> IO ()
sourceBufferSetHighlightMatchingBrackets sb newVal =
  {#call unsafe source_buffer_set_highlight_matching_brackets#} sb (fromBool newVal)

-- |
--
sourceBufferGetHighlightMatchingBrackets :: SourceBuffer -> IO Bool
sourceBufferGetHighlightMatchingBrackets sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_matching_brackets#} sb

-- |
--
sourceBufferSetStyleScheme :: SourceBuffer -> SourceStyleScheme -> IO ()
sourceBufferSetStyleScheme sb sss =
    {#call unsafe source_buffer_set_style_scheme#} sb sss

-- |
--
sourceBufferGetStyleScheme :: SourceBuffer -> IO SourceStyleScheme
sourceBufferGetStyleScheme sb = makeNewGObject mkSourceStyleScheme $
  {#call unsafe source_buffer_get_style_scheme#} sb

-- |
--
sourceBufferSetMaxUndoLevels :: SourceBuffer -> Int -> IO ()
sourceBufferSetMaxUndoLevels sb newVal =
  {#call unsafe source_buffer_set_max_undo_levels#} sb (fromIntegral newVal)

-- |
--
sourceBufferGetMaxUndoLevels :: SourceBuffer -> IO Int
sourceBufferGetMaxUndoLevels sb = liftM fromIntegral $
  {#call unsafe source_buffer_get_max_undo_levels#} sb

-- |
--
sourceBufferGetCanUndo :: SourceBuffer -> IO Bool
sourceBufferGetCanUndo sb = liftM toBool $
  {#call unsafe source_buffer_can_undo#} sb

-- |
--
sourceBufferGetCanRedo :: SourceBuffer -> IO Bool
sourceBufferGetCanRedo sb = liftM toBool $
  {#call unsafe source_buffer_can_redo#} sb

-- |
--
sourceBufferUndo :: SourceBuffer -> IO ()
sourceBufferUndo sb =
  {#call source_buffer_undo#} sb

-- |
--
sourceBufferRedo :: SourceBuffer -> IO ()
sourceBufferRedo sb =
  {#call source_buffer_redo#} sb

-- |
--
sourceBufferBeginNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferBeginNotUndoableAction sb =
  {#call source_buffer_begin_not_undoable_action#} sb

-- |
--
sourceBufferEndNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferEndNotUndoableAction sb =
  {#call source_buffer_end_not_undoable_action#} sb

-- | Creates a marker in the buffer of the given type.
--
-- *  A marker is
--    semantically very similar to a 'Graphics.UI.Gtk.Multiline.TextMark',
--    except it has a type
--    which is used by the 'SourceView' displaying the buffer to show a
--    pixmap on the left margin, at the line the marker is in.  Because
--    of this, a marker is generally associated to a line and not a
--    character position.  Markers are also accessible through a position
--    or range in the buffer.
--
-- *  Markers are implemented using 'Graphics.UI.Gtk.Multiline.TextMark',
--    so all characteristics
--    and restrictions to marks apply to markers too.  These includes
--    life cycle issues and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkSet'
--    and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkDeleted' signal
--    emissions.
--
-- *  Like a 'Graphics.UI.Gtk.Multiline.TextMark', a 'SourceMarker'
--    can be anonymous if the
--    passed name is @Nothing@.  Also, the buffer owns the markers so you
--    shouldn't unreference it.

sourceBufferCreateSourceMark :: SourceBuffer -- the buffer
                         -> Maybe String -- the name of the mark
                         -> String -- the category of the mark
                         -> TextIter -> IO SourceMark
sourceBufferCreateSourceMark sb name category iter =
  makeNewGObject mkSourceMark $
  maybeWith withCString name       $ \strPtr1 ->
  withCString category $ \strPtr2 ->
  {#call source_buffer_create_source_mark#} sb strPtr1 strPtr2 iter

-- |
--
sourceBufferEnsureHighlight :: SourceBuffer -> TextIter -> TextIter -> IO ()
sourceBufferEnsureHighlight sb start end =
    {#call source_buffer_ensure_highlight#} sb start end

-- |
--
sourceBufferCanRedo :: ReadAttr SourceBuffer Bool
sourceBufferCanRedo = readAttrFromBoolProperty "can-redo"

-- |
--
sourceBufferCanUndo :: ReadAttr SourceBuffer Bool
sourceBufferCanUndo = readAttrFromBoolProperty "can-redo"

-- |
--
sourceBufferHighlightMatchingBrackets :: Attr SourceBuffer Bool
sourceBufferHighlightMatchingBrackets = newAttrFromBoolProperty "highlight-matching-brackets"

-- |
--
sourceBufferHighlightSyntax :: Attr SourceBuffer Bool
sourceBufferHighlightSyntax = newAttrFromBoolProperty "highlight-matching-brackets"

-- |
--
sourceBufferLanguage :: Attr SourceBuffer (Maybe SourceLanguage)
sourceBufferLanguage = newAttrFromMaybeObjectProperty "language" gTypeSourceLanguage

-- |
--
sourceBufferMaxUndoLevels :: Attr SourceBuffer Int
sourceBufferMaxUndoLevels = newAttrFromIntProperty "max-undo-levels"

-- |
--
sourceBufferSourceStyleScheme :: Attr SourceBuffer (Maybe SourceStyleScheme)
sourceBufferSourceStyleScheme = newAttrFromMaybeObjectProperty "style-scheme" gTypeSourceStyleScheme

-- |
--
sourceBufferHighlightUpdated :: Signal SourceBuffer (TextIter -> TextIter -> IO ())
sourceBufferHighlightUpdated = Signal $ connect_BOXED_BOXED__NONE "highlight-updated" mkTextIterCopy mkTextIterCopy


Explicitly type and comment some Morphology funcs.

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

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

import CV.Image

import CV.ImageOp
import qualified CV.ImageMath as IM

import System.IO.Unsafe

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

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

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

-- | Perform a black tophat filtering of size
blackTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (closeOp se) i
                  in x `IM.sub` i

-- | Perform a white tophat filtering of size
whiteTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (openOp se) i
                  in i `IM.sub` x

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

---------- Low level wrapper
#c
enum KernelShape {
    RectShape    = CV_SHAPE_RECT
    ,CrossShape   = CV_SHAPE_CROSS
    ,EllipseShape = CV_SHAPE_ELLIPSE
    ,CustomShape  = CV_SHAPE_CUSTOM
    };
#endc
{#enum KernelShape {} #}

{#pointer *IplConvKernel as ConvKernel foreign newtype#}

type StructuringElement = ConvKernel

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

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

                         | otherwise = False

-- |Create a structuring element for morphological operations
-- The first pair is @(width,height)@ while the second is the origin @(x,y)@
structuringElement :: (Int, Int) -> (Int, Int) -> KernelShape -> StructuringElement
structuringElement s d | isGoodSE s d = createSE s d
                       | otherwise = error "Bad values in structuring element"

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

customSE :: (CInt, CInt) -> (CInt, CInt) -> [CInt] -> ConvKernel
customSE s@(w,h) o shape | isGoodSE s o
                         && length shape == fromIntegral (w*h)
                            = createCustomSE s o shape

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

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

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

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

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

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

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

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

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

import CV.Image

import CV.ImageOp
import qualified CV.ImageMath as IM

import System.IO.Unsafe

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

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

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

-- | Perform a black tophat filtering of size
blackTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (closeOp se) i
                  in x `IM.sub` i

-- | Perform a white tophat filtering of size
whiteTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (openOp se) i
                  in i `IM.sub` x

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

---------- Low level wrapper
#c
enum KernelShape {
    RectShape    = CV_SHAPE_RECT
    ,CrossShape   = CV_SHAPE_CROSS
    ,EllipseShape = CV_SHAPE_ELLIPSE
    ,CustomShape  = CV_SHAPE_CUSTOM
    };
#endc
{#enum KernelShape {} #}

{#pointer *IplConvKernel as ConvKernel foreign newtype#}

type StructuringElement = ConvKernel

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

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

                         | otherwise = False

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

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

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

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

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

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

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

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

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

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


doc additions

doc additions

-- -*-haskell-*-

{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}

{- |
 I reserve the right to make this module private at any time.
 Specifically, this module will become private once I can do
 so without breaking c2hs preprocessing.
 -}
module Foreign.IOVec
    (IOVec()
    ,withLazyByteString
    ,withByteString
    ,withIOVec
    ,writev
    )
    where

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.ByteString.Lazy as L

import Foreign
import Foreign.C.Types

#include <sys/uio.h>

#c
typedef struct iovec hs_iovec;
#endc

-- | The IOVev type is a newtype around
-- an FFI `Ptr`, so you can pass it as is
-- to FFI calls.
{#pointer *hs_iovec as IOVec newtype#}

withIOVec :: IOVec -> (Ptr IOVec -> IO a) -> IO a
withIOVec (IOVec ptr) f = f ptr
{-# INLINE withIOVec #-}

withByteString :: S.ByteString -> (IOVec -> Int -> IO b) -> IO b
withByteString b = withLazyByteString (L.fromChunks [b])

-- | This is intented for calling into something like writev.
-- But I suppose that nothing stops you from calling into
-- readv and blowing away the passed-in ByteString. Don't do that.
--
-- The number passed to the callback is the number of blocks
-- in the `IOVec`.
--
-- The spin of the lazy bytestring is forced prior to traversal.
withLazyByteString :: L.ByteString -> (IOVec -> Int -> IO b) -> IO b
withLazyByteString lbs f =
    let bs = L.toChunks lbs
        num = length bs
    in allocaBytes (num * {#sizeof hs_iovec#}) $
           \vecAry -> do
             fill vecAry 0 bs
             x <- f (IOVec vecAry) num
             touchAllBS bs
             return x

   where fill _vecAry !_off [] = return ()
         fill vecAry !off (b:bs) =

             let vec = vecAry `plusPtr` (off * {#sizeof hs_iovec#})

             in do
               S.unsafeUseAsCStringLen b $ \(bsptr,bslen) -> do
                  {#set hs_iovec->iov_base#} vec $ castPtr $ bsptr
                  {#set hs_iovec->iov_len#}  vec $ fromIntegral bslen
               fill vecAry (off+1) bs

-- utility functions
touchBS :: S.ByteString -> IO ()
touchBS b = case S.toForeignPtr b of (fptr,_,_) -> touchForeignPtr fptr

touchAllBS :: [S.ByteString] -> IO ()
touchAllBS xs = mapM_ touchBS xs

-- | Binding to writev using 'withLazyByteString'. For testing.
writev :: CInt -> L.ByteString -> IO CSize
writev fd bs = withLazyByteString bs $ \iov count ->
               c_writev fd iov (fromIntegral count)

foreign import ccall unsafe "writev" c_writev :: CInt -> IOVec -> CInt -> IO CSize

-- -*-haskell-*-

{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}

module Foreign.IOVec
    (IOVec()
    ,withByteString
    ,withLazyByteString
    ,withIOVec
    ,writev
    )
    where

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.ByteString.Lazy as L

import Foreign
import Foreign.C.Types

#include <sys/uio.h>

#c
typedef struct iovec hs_iovec;
#endc

{#pointer *hs_iovec as IOVec newtype#}

withIOVec :: IOVec -> (Ptr IOVec -> IO a) -> IO a
withIOVec (IOVec ptr) f = f ptr
{-# INLINE withIOVec #-}

withByteString :: S.ByteString -> (IOVec -> Int -> IO b) -> IO b
withByteString b = withLazyByteString (L.fromChunks [b])

-- | This is intented for calling into something like writev.
-- But I suppose that nothing stops you from calling into
-- readv and blowing away the passed-in ByteString.
withLazyByteString :: L.ByteString -> (IOVec -> Int -> IO b) -> IO b
withLazyByteString lbs f =
    let bs = L.toChunks lbs
        num = length bs
    in allocaBytes (num * {#sizeof hs_iovec#}) $
           \vecAry -> do
             fill vecAry 0 bs
             x <- f (IOVec vecAry) num
             touchAllBS bs
             return x

   where fill _vecAry !_off [] = return ()
         fill vecAry !off (b:bs) =

             let vec = vecAry `plusPtr` (off * {#sizeof hs_iovec#})

             in do
               S.unsafeUseAsCStringLen b $ \(bsptr,bslen) -> do
                  {#set hs_iovec->iov_base#} vec $ castPtr $ bsptr
                  {#set hs_iovec->iov_len#}  vec $ fromIntegral bslen
               fill vecAry (off+1) bs

-- utility functions
touchBS :: S.ByteString -> IO ()
touchBS b = case S.toForeignPtr b of (fptr,_,_) -> touchForeignPtr fptr

touchAllBS :: [S.ByteString] -> IO ()
touchAllBS xs = mapM_ touchBS xs

-- | Binding to writev using 'withLazyByteString'. For testing.
writev :: CInt -> L.ByteString -> IO CSize
writev fd bs = withLazyByteString bs $ \iov count ->
               c_writev fd iov (fromIntegral count)

foreign import ccall unsafe "writev" c_writev :: CInt -> IOVec -> CInt -> IO CSize