gstreamer: M.S.G.Core.ElementFactory: Control.Monad.>=> not available before ghc 6.8

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A factory for creating 'Element's.
module Media.Streaming.GStreamer.Core.ElementFactory (

-- * Detail

  -- | 'ElementFactory' is used to create instances of 'Element's.
  --
  --   Use 'elementFactoryFind' and 'elementFactoryCreate' to create
  --   element instances, or use 'elementFactoryMake' as a convenient
  --   shortcut.

-- * Types
  ElementFactory,
  ElementFactoryClass,
  castToElementFactory,
  toElementFactory,

-- * ElementFactory Operations
  elementFactoryFind,
  elementFactoryGetElementType,
  elementFactoryGetLongname,
  elementFactoryGetKlass,
  elementFactoryGetDescription,
  elementFactoryGetAuthor,
  elementFactoryGetNumPadTemplates,
  elementFactoryGetURIType,
  elementFactoryGetURIProtocols,
  elementFactoryHasInterface,
  elementFactoryCreate,
  elementFactoryMake,
  elementFactoryCanSinkCaps,
  elementFactoryCanSrcCaps,
  elementFactoryGetPadTemplates

  ) where

import Control.Monad         ( liftM )
import Data.Maybe            ( fromMaybe )
import System.Glib.FFI
import System.Glib.UTFString ( withUTFString
                             , peekUTFString
                             , peekUTFStringArray0 )
import System.Glib.GType     ( GType )
import System.Glib.GList     ( readGList )
{# import Media.Streaming.GStreamer.Core.Types #}

{# context lib = "gstreamer" prefix = "gst" #}

-- | Search for an element factory with the given name.
elementFactoryFind :: String                    -- ^ @name@ - the name of the desired factory
                   -> IO (Maybe ElementFactory) -- ^ the factory if found, otherwise 'Nothing'
elementFactoryFind name =
    withUTFString name {# call element_factory_find #} >>= maybePeek takeObject

-- | Get the 'GType' for elements managed by the given factory. The type
--   can only be retrieved if the element factory is loaded, which can
--   be assured with
--   'Media.Streaming.GStreamer.Core.PluginFeature.pluginFeatureLoad'.
elementFactoryGetElementType :: (ElementFactoryClass elementFactory)
                             => elementFactory   -- ^ @factory@ - an element factory
                             -> IO (Maybe GType) -- ^ the type of elements managed
                                                 --   by the factory, or 'Nothing' if
                                                 --   the factory is not loaded
elementFactoryGetElementType factory =
    do gtype <- {# call element_factory_get_element_type #} (toElementFactory factory)
       if gtype == 0
          then return $ Just $ fromIntegral gtype
          else return Nothing

-- | Get the long name for the given factory.
elementFactoryGetLongname :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> IO String      -- ^ the factory's long name
elementFactoryGetLongname factory =
    {# call element_factory_get_longname #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the class for the given factory.
elementFactoryGetKlass :: (ElementFactoryClass elementFactory)
                       => elementFactory -- ^ @factory@ - an element factory
                       -> IO String      -- ^ the factory's class
elementFactoryGetKlass factory =
    {# call element_factory_get_klass #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the description for the given factory.
elementFactoryGetDescription :: (ElementFactoryClass elementFactory)
                             => elementFactory -- ^ @factory@ - an element factory
                             -> IO String      -- ^ the factory's description
elementFactoryGetDescription factory =
    {# call element_factory_get_description #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the author of the given factory.
elementFactoryGetAuthor :: (ElementFactoryClass elementFactory)
                        => elementFactory -- ^ @factory@ - an element factory
                        -> IO String      -- ^ the factory's author
elementFactoryGetAuthor factory =
    {# call element_factory_get_author #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the number of 'PadTemplate's provided by the given factory.
elementFactoryGetNumPadTemplates :: (ElementFactoryClass elementFactory)
                                 => elementFactory -- ^ @factory@ - an element factory
                                 -> IO Word        -- ^ the number of 'PadTemplate's
elementFactoryGetNumPadTemplates factory =
    liftM fromIntegral $
        {# call element_factory_get_num_pad_templates #} $ toElementFactory factory

-- | Get the type of URIs supported by the given factory.
elementFactoryGetURIType :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> IO Int         -- ^ the type of URIs supported by the factory
elementFactoryGetURIType factory =
    liftM fromIntegral $
        {# call element_factory_get_uri_type #} $ toElementFactory factory

-- | Get the list of protocols supported by the given factory.
elementFactoryGetURIProtocols :: (ElementFactoryClass elementFactory)
                              => elementFactory -- ^ @factory@ - an element factory
                              -> IO [String]    -- ^ the supported protocols
elementFactoryGetURIProtocols factory =
    {# call element_factory_get_uri_protocols #} (toElementFactory factory) >>=
        liftM (fromMaybe []) . maybePeek peekUTFStringArray0

-- | Check if the given factory implements the interface with the given name.
elementFactoryHasInterface :: (ElementFactoryClass elementFactory)
                           => elementFactory -- ^ @factory@ - an element factory
                           -> String         -- ^ @name@ - the interface name
                           -> IO Bool        -- ^ true if the interface is implemented
elementFactoryHasInterface factory name =
    liftM toBool .
        withUTFString name .
        {# call element_factory_has_interface #} .
        toElementFactory $
        factory

-- | Create a new element of the type supplied by the given
--   factory. It will be given the name supplied.
elementFactoryCreate :: (ElementFactoryClass elementFactory)
                     => elementFactory     -- ^ @factory@ - an element factory
                     -> String             -- ^ @name@ - the new element's name
                     -> IO (Maybe Element) -- ^ the new element if it could be created,
                                           --   otherwise 'Nothing'
elementFactoryCreate factory name =
    withUTFString name $ \cName ->
        {# call element_factory_create #} (toElementFactory factory) cName >>=
            maybePeek takeObject

-- | Create a new element of the type supplied by the named
--   factory.
elementFactoryMake :: String             -- ^ @factoryName@ - the name of an element factory
                   -> Maybe String       -- ^ @name@ - the new element's name, or
                                         --   'Nothing' generate a unique name
                   -> IO (Maybe Element) -- ^ the new element if it could be created,
                                         --   otherwise 'Nothing'
elementFactoryMake factoryName name =
    withUTFString factoryName $ \cFactoryName ->
        maybeWith withUTFString name $ \cName ->
            {# call element_factory_make #} cFactoryName cName >>=
                maybePeek takeObject

-- | Check if the given factory can sink the given capabilities.
elementFactoryCanSinkCaps :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> Caps           -- ^ @caps@ - the capabilities to check for
                          -> IO Bool        -- ^ 'True' if @factory@ can sink the given capabilities
elementFactoryCanSinkCaps factory caps =
    liftM toBool $ {# call element_factory_can_sink_caps #} (toElementFactory factory) caps

-- | Check if the given factory can source the given capabilities.
elementFactoryCanSrcCaps :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> Caps           -- ^ @caps@ - the capabilities to check for
                         -> IO Bool        -- ^ 'True' if @factory@ can source the given capabilities
elementFactoryCanSrcCaps factory caps =
    liftM toBool $ {# call element_factory_can_src_caps #} (toElementFactory factory) caps

-- | Get the pad templates provided by the given factory.
elementFactoryGetPadTemplates :: (ElementFactoryClass elementFactory)
                              => elementFactory   -- ^ @factory@ - an element factory
                              -> IO [PadTemplate] -- ^ the provided pad templates
elementFactoryGetPadTemplates =
    {# call element_factory_get_static_pad_templates #} . toElementFactory >=>
        readGList >=> mapM staticPadTemplateGet
    where infixr 8 >=>
          a >=> b = \x -> a x >>= b

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A factory for creating 'Element's.
module Media.Streaming.GStreamer.Core.ElementFactory (

-- * Detail

  -- | 'ElementFactory' is used to create instances of 'Element's.
  --
  --   Use 'elementFactoryFind' and 'elementFactoryCreate' to create
  --   element instances, or use 'elementFactoryMake' as a convenient
  --   shortcut.

-- * Types
  ElementFactory,
  ElementFactoryClass,
  castToElementFactory,
  toElementFactory,

-- * ElementFactory Operations
  elementFactoryFind,
  elementFactoryGetElementType,
  elementFactoryGetLongname,
  elementFactoryGetKlass,
  elementFactoryGetDescription,
  elementFactoryGetAuthor,
  elementFactoryGetNumPadTemplates,
  elementFactoryGetURIType,
  elementFactoryGetURIProtocols,
  elementFactoryHasInterface,
  elementFactoryCreate,
  elementFactoryMake,
  elementFactoryCanSinkCaps,
  elementFactoryCanSrcCaps,
  elementFactoryGetPadTemplates

  ) where

import Control.Monad         ( liftM
                             , (>=>) )
import Data.Maybe            ( fromMaybe )
import System.Glib.FFI
import System.Glib.UTFString ( withUTFString
                             , peekUTFString
                             , peekUTFStringArray0 )
import System.Glib.GType     ( GType )
import System.Glib.GList     ( readGList )
{# import Media.Streaming.GStreamer.Core.Types #}

{# context lib = "gstreamer" prefix = "gst" #}

-- | Search for an element factory with the given name.
elementFactoryFind :: String                    -- ^ @name@ - the name of the desired factory
                   -> IO (Maybe ElementFactory) -- ^ the factory if found, otherwise 'Nothing'
elementFactoryFind name =
    withUTFString name {# call element_factory_find #} >>= maybePeek takeObject

-- | Get the 'GType' for elements managed by the given factory. The type
--   can only be retrieved if the element factory is loaded, which can
--   be assured with
--   'Media.Streaming.GStreamer.Core.PluginFeature.pluginFeatureLoad'.
elementFactoryGetElementType :: (ElementFactoryClass elementFactory)
                             => elementFactory   -- ^ @factory@ - an element factory
                             -> IO (Maybe GType) -- ^ the type of elements managed
                                                 --   by the factory, or 'Nothing' if
                                                 --   the factory is not loaded
elementFactoryGetElementType factory =
    do gtype <- {# call element_factory_get_element_type #} (toElementFactory factory)
       if gtype == 0
          then return $ Just $ fromIntegral gtype
          else return Nothing

-- | Get the long name for the given factory.
elementFactoryGetLongname :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> IO String      -- ^ the factory's long name
elementFactoryGetLongname factory =
    {# call element_factory_get_longname #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the class for the given factory.
elementFactoryGetKlass :: (ElementFactoryClass elementFactory)
                       => elementFactory -- ^ @factory@ - an element factory
                       -> IO String      -- ^ the factory's class
elementFactoryGetKlass factory =
    {# call element_factory_get_klass #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the description for the given factory.
elementFactoryGetDescription :: (ElementFactoryClass elementFactory)
                             => elementFactory -- ^ @factory@ - an element factory
                             -> IO String      -- ^ the factory's description
elementFactoryGetDescription factory =
    {# call element_factory_get_description #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the author of the given factory.
elementFactoryGetAuthor :: (ElementFactoryClass elementFactory)
                        => elementFactory -- ^ @factory@ - an element factory
                        -> IO String      -- ^ the factory's author
elementFactoryGetAuthor factory =
    {# call element_factory_get_author #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the number of 'PadTemplate's provided by the given factory.
elementFactoryGetNumPadTemplates :: (ElementFactoryClass elementFactory)
                                 => elementFactory -- ^ @factory@ - an element factory
                                 -> IO Word        -- ^ the number of 'PadTemplate's
elementFactoryGetNumPadTemplates factory =
    liftM fromIntegral $
        {# call element_factory_get_num_pad_templates #} $ toElementFactory factory

-- | Get the type of URIs supported by the given factory.
elementFactoryGetURIType :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> IO Int         -- ^ the type of URIs supported by the factory
elementFactoryGetURIType factory =
    liftM fromIntegral $
        {# call element_factory_get_uri_type #} $ toElementFactory factory

-- | Get the list of protocols supported by the given factory.
elementFactoryGetURIProtocols :: (ElementFactoryClass elementFactory)
                              => elementFactory -- ^ @factory@ - an element factory
                              -> IO [String]    -- ^ the supported protocols
elementFactoryGetURIProtocols factory =
    {# call element_factory_get_uri_protocols #} (toElementFactory factory) >>=
        liftM (fromMaybe []) . maybePeek peekUTFStringArray0

-- | Check if the given factory implements the interface with the given name.
elementFactoryHasInterface :: (ElementFactoryClass elementFactory)
                           => elementFactory -- ^ @factory@ - an element factory
                           -> String         -- ^ @name@ - the interface name
                           -> IO Bool        -- ^ true if the interface is implemented
elementFactoryHasInterface factory name =
    liftM toBool .
        withUTFString name .
        {# call element_factory_has_interface #} .
        toElementFactory $
        factory

-- | Create a new element of the type supplied by the given
--   factory. It will be given the name supplied.
elementFactoryCreate :: (ElementFactoryClass elementFactory)
                     => elementFactory     -- ^ @factory@ - an element factory
                     -> String             -- ^ @name@ - the new element's name
                     -> IO (Maybe Element) -- ^ the new element if it could be created,
                                           --   otherwise 'Nothing'
elementFactoryCreate factory name =
    withUTFString name $ \cName ->
        {# call element_factory_create #} (toElementFactory factory) cName >>=
            maybePeek takeObject

-- | Create a new element of the type supplied by the named
--   factory.
elementFactoryMake :: String             -- ^ @factoryName@ - the name of an element factory
                   -> Maybe String       -- ^ @name@ - the new element's name, or
                                         --   'Nothing' generate a unique name
                   -> IO (Maybe Element) -- ^ the new element if it could be created,
                                         --   otherwise 'Nothing'
elementFactoryMake factoryName name =
    withUTFString factoryName $ \cFactoryName ->
        maybeWith withUTFString name $ \cName ->
            {# call element_factory_make #} cFactoryName cName >>=
                maybePeek takeObject

-- | Check if the given factory can sink the given capabilities.
elementFactoryCanSinkCaps :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> Caps           -- ^ @caps@ - the capabilities to check for
                          -> IO Bool        -- ^ 'True' if @factory@ can sink the given capabilities
elementFactoryCanSinkCaps factory caps =
    liftM toBool $ {# call element_factory_can_sink_caps #} (toElementFactory factory) caps

-- | Check if the given factory can source the given capabilities.
elementFactoryCanSrcCaps :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> Caps           -- ^ @caps@ - the capabilities to check for
                         -> IO Bool        -- ^ 'True' if @factory@ can source the given capabilities
elementFactoryCanSrcCaps factory caps =
    liftM toBool $ {# call element_factory_can_src_caps #} (toElementFactory factory) caps

-- | Get the pad templates provided by the given factory.
elementFactoryGetPadTemplates :: (ElementFactoryClass elementFactory)
                              => elementFactory   -- ^ @factory@ - an element factory
                              -> IO [PadTemplate] -- ^ the provided pad templates
elementFactoryGetPadTemplates =
    {# call element_factory_get_static_pad_templates #} . toElementFactory >=>
        readGList >=> mapM staticPadTemplateGet


Fixed typing bug in CV.ImageMath.sum

Fixed typing bug in CV.ImageMath.sum

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, FlexibleContexts#-}
#include "cvWrapLEO.h"
module CV.ImageMath where
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr

import CV.Image
import CV.ImageOp

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

import C2HS

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

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

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

-- I just can't think of a proper name for this
   -- Friday Evening
abcNullPtr f = \a b c -> f a b c nullPtr
addOp imageToBeAdded = ImgOp $ \target ->
              withGenImage target $ \ctarget ->
              withGenImage imageToBeAdded $ \cadd ->
               {#call cvAdd#} ctarget cadd ctarget nullPtr

add = mkBinaryImageOp $ abcNullPtr {#call cvAdd#}
sub = mkBinaryImageOp $ abcNullPtr {#call cvSub#}
subFrom what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvSub#} ifrom iwhat ifrom nullPtr

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

sqrtOp  = ImgOp $ \i -> withGenImage i (\img -> {#call sqrtImage#}  img img)
sqrt = unsafeOperate sqrtOp

limitToOp what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvMin#} ifrom iwhat ifrom

limitTo x y = unsafeOperate (limitToOp x) y

mul = mkBinaryImageOp
    (\a b c -> {#call cvMul#} a b c 1)

div = mkBinaryImageOp
    (\a b c -> {#call cvDiv#} a b c 1)

min = mkBinaryImageOp {#call cvMin#}

max = mkBinaryImageOp {#call cvMax#}

absDiff = mkBinaryImageOp {#call cvAbsDiff#}

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

atan2 a b = unsafePerformIO $ do
                    res <- create (getSize a)
                    withImage a $ \c_a ->
                     withImage b $ \c_b ->
                      withImage res $ \c_res -> do
                       {#call calculateAtan2#} c_a c_b c_res
                       return res

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

-- Logical inversion of image (Ie. invert, but stay on [0..1] range)
invert i = addS 1 $ mulS (-1) i

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

abs = unsafeOperate absOp

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

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

subRS s a= unsafeOperate (subRSOp s) a

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

subS a s = unsafeOperate (subSOp s) a

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

mkImgScalarOp op scalar = ImgOp $ \a ->
              withGenImage a $ \ia -> do
                op ia (realToFrac scalar) ia
                return ()
           -- where s = realToFrac scalar
                -- I've heard this will lose information

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

minSOp = mkImgScalarOp $ {#call cvMinS#}
minS s = unsafeOperate $ minSOp s

maxSOp = mkImgScalarOp $ {#call cvMaxS#}
maxS s = unsafeOperate $ maxSOp s

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

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

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

-- Compare Image to Scalar
lessThan, moreThan ::  D32 -> Image GrayScale D32 ->Image GrayScale D8

lessThan = mkCmpOp cmpLT
moreThan = mkCmpOp cmpGT

less2Than,lessEq2Than,more2Than :: (CreateImage (Image GrayScale d)) => Image GrayScale d
                                    -> Image GrayScale d -> Image GrayScale D8
less2Than = mkCmp2Op cmpLT
lessEq2Than = mkCmp2Op cmpLE
more2Than = mkCmp2Op cmpGT

-- Statistics
average' :: Image GrayScale a -> IO D32
average' img = withGenImage img $ \image -> -- TODO: Check c datatype size
                {#call wrapAvg#} image >>= return . realToFrac

average :: Image GrayScale D32 -> D32
average = realToFrac.unsafePerformIO.average'

-- | Sum the pixels in the image. Notice that OpenCV automatically casts the
--   result to double sum :: Image GrayScale D32 -> D32
sum :: Image GrayScale D32 -> D32
sum img = realToFrac $ unsafePerformIO $ withGenImage img $ \image ->
                    {#call wrapSum#} image

averageImages is = ( (1/(fromIntegral $ length is)) `mulS`) (foldl1 add is)

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

stdDeviation' img = withGenImage img {#call wrapStdDev#}
stdDeviation :: Image GrayScale D32 -> D32
stdDeviation = realToFrac . unsafePerformIO . stdDeviation'

stdDeviationMask img mask = unsafePerformIO $
                                 withGenImage img $ \i ->
                                  withGenImage mask $ \m ->
                                   {#call wrapStdDevMask#} i m

averageMask img mask = unsafePerformIO $
                                 withGenImage img $ \i ->
                                  withGenImage mask $ \m ->
                                   {#call wrapStdDevMask#} i m

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

findMinMaxLoc img = unsafePerformIO $
	     alloca $ \(ptrintmaxx :: Ptr CInt)->
	      alloca $ \(ptrintmaxy :: Ptr CInt)->
           alloca $ \(ptrintminx :: Ptr CInt)->
            alloca $ \(ptrintminy :: Ptr CInt)->
             alloca $ \(ptrintmin :: Ptr CDouble)->
              alloca $ \(ptrintmax :: Ptr CDouble)->
               withImage img $ \cimg -> do {
                 {#call wrapMinMaxLoc#} cimg ptrintminx ptrintminy ptrintmaxx ptrintmaxy ptrintmin ptrintmax;
		         minx <- fromIntegral <$> peek ptrintminx;
		         miny <- fromIntegral <$> peek ptrintminy;
		         maxx <- fromIntegral <$> peek ptrintmaxx;
		         maxy <- fromIntegral <$> peek ptrintmaxy;
		         maxval <- realToFrac <$> peek ptrintmax;
		         minval <- realToFrac <$> peek ptrintmin;
                 return (((minx,miny),minval),((maxx,maxy),maxval));}

findMinMax i = unsafePerformIO $ do
               nullp <- newForeignPtr_ nullPtr
               (findMinMax' (unS i) (BareImage nullp))

-- |Find minimum and maximum value of image i in area specified by the mask.
findMinMaxMask i mask  = unsafePerformIO (findMinMax' i mask)
-- let a = getAllPixels i in (minimum a,maximum a)

maxValue,minValue :: Image GrayScale D32 -> D32
maxValue = snd.findMinMax
minValue = fst.findMinMax

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

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

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

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

-- | Given a distance map and a circle, return the biggest circle with radius less
--   than given in the distance map that fully covers the previous one

maximalCoveringCircle distMap (x,y,r)
  = unsafePerformIO $
     withImage distMap $ \c_distmap ->
       alloca $ \(ptr_int_max_x :: Ptr CInt) ->
        alloca $ \(ptr_int_max_y :: Ptr CInt) ->
         alloca $ \(ptr_double_max_r :: Ptr CDouble) ->
          do
           {#call maximal_covering_circle#} x y r c_distmap ptr_int_max_x ptr_int_max_y ptr_double_max_r
           max_x <- fromIntegral <$> peek ptr_int_max_x
           max_y <- fromIntegral <$> peek ptr_int_max_y
           max_r <- realToFrac   <$> peek ptr_double_max_r
           return (max_x,max_y,max_r)

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, FlexibleContexts#-}
#include "cvWrapLEO.h"
module CV.ImageMath where
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr

import CV.Image
import CV.ImageOp

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

import C2HS

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

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

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

-- I just can't think of a proper name for this
   -- Friday Evening
abcNullPtr f = \a b c -> f a b c nullPtr
addOp imageToBeAdded = ImgOp $ \target ->
              withGenImage target $ \ctarget ->
              withGenImage imageToBeAdded $ \cadd ->
               {#call cvAdd#} ctarget cadd ctarget nullPtr

add = mkBinaryImageOp $ abcNullPtr {#call cvAdd#}
sub = mkBinaryImageOp $ abcNullPtr {#call cvSub#}
subFrom what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvSub#} ifrom iwhat ifrom nullPtr

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

sqrtOp  = ImgOp $ \i -> withGenImage i (\img -> {#call sqrtImage#}  img img)
sqrt = unsafeOperate sqrtOp

limitToOp what = ImgOp $ \from ->
          withGenImage from $ \ifrom ->
          withGenImage what $ \iwhat ->
           {#call cvMin#} ifrom iwhat ifrom

limitTo x y = unsafeOperate (limitToOp x) y

mul = mkBinaryImageOp
    (\a b c -> {#call cvMul#} a b c 1)

div = mkBinaryImageOp
    (\a b c -> {#call cvDiv#} a b c 1)

min = mkBinaryImageOp {#call cvMin#}

max = mkBinaryImageOp {#call cvMax#}

absDiff = mkBinaryImageOp {#call cvAbsDiff#}

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

atan2 a b = unsafePerformIO $ do
                    res <- create (getSize a)
                    withImage a $ \c_a ->
                     withImage b $ \c_b ->
                      withImage res $ \c_res -> do
                       {#call calculateAtan2#} c_a c_b c_res
                       return res

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

-- Logical inversion of image (Ie. invert, but stay on [0..1] range)
invert i = addS 1 $ mulS (-1) i

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

abs = unsafeOperate absOp

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

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

subRS s a= unsafeOperate (subRSOp s) a

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

subS a s = unsafeOperate (subSOp s) a

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

mkImgScalarOp op scalar = ImgOp $ \a ->
              withGenImage a $ \ia -> do
                op ia (realToFrac scalar) ia
                return ()
           -- where s = realToFrac scalar
                -- I've heard this will lose information

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

minSOp = mkImgScalarOp $ {#call cvMinS#}
minS s = unsafeOperate $ minSOp s

maxSOp = mkImgScalarOp $ {#call cvMaxS#}
maxS s = unsafeOperate $ maxSOp s

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

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

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

-- Compare Image to Scalar
lessThan, moreThan ::  D32 -> Image GrayScale D32 ->Image GrayScale D8

lessThan = mkCmpOp cmpLT
moreThan = mkCmpOp cmpGT

less2Than,lessEq2Than,more2Than :: (CreateImage (Image GrayScale d)) => Image GrayScale d
                                    -> Image GrayScale d -> Image GrayScale D8
less2Than = mkCmp2Op cmpLT
lessEq2Than = mkCmp2Op cmpLE
more2Than = mkCmp2Op cmpGT

-- Statistics
average' :: Image GrayScale a -> IO D32
average' img = withGenImage img $ \image -> -- TODO: Check c datatype size
                {#call wrapAvg#} image >>= return . realToFrac

average :: Image GrayScale D32 -> D32
average = realToFrac.unsafePerformIO.average'

-- | Sum the pixels in the image. Notice that OpenCV automatically casts the
--   result to double sum :: Image GrayScale D32 -> D32
sum :: Image GrayScale a -> Double
sum img = realToFrac $ unsafePerformIO $ withGenImage img $ \image ->
                    {#call wrapSum#} image

averageImages is = ( (1/(fromIntegral $ length is)) `mulS`) (foldl1 add is)

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

stdDeviation' img = withGenImage img {#call wrapStdDev#}
stdDeviation :: Image GrayScale D32 -> D32
stdDeviation = realToFrac . unsafePerformIO . stdDeviation'

stdDeviationMask img mask = unsafePerformIO $
                                 withGenImage img $ \i ->
                                  withGenImage mask $ \m ->
                                   {#call wrapStdDevMask#} i m

averageMask img mask = unsafePerformIO $
                                 withGenImage img $ \i ->
                                  withGenImage mask $ \m ->
                                   {#call wrapStdDevMask#} i m

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

findMinMaxLoc img = unsafePerformIO $
	     alloca $ \(ptrintmaxx :: Ptr CInt)->
	      alloca $ \(ptrintmaxy :: Ptr CInt)->
           alloca $ \(ptrintminx :: Ptr CInt)->
            alloca $ \(ptrintminy :: Ptr CInt)->
             alloca $ \(ptrintmin :: Ptr CDouble)->
              alloca $ \(ptrintmax :: Ptr CDouble)->
               withImage img $ \cimg -> do {
                 {#call wrapMinMaxLoc#} cimg ptrintminx ptrintminy ptrintmaxx ptrintmaxy ptrintmin ptrintmax;
		         minx <- fromIntegral <$> peek ptrintminx;
		         miny <- fromIntegral <$> peek ptrintminy;
		         maxx <- fromIntegral <$> peek ptrintmaxx;
		         maxy <- fromIntegral <$> peek ptrintmaxy;
		         maxval <- realToFrac <$> peek ptrintmax;
		         minval <- realToFrac <$> peek ptrintmin;
                 return (((minx,miny),minval),((maxx,maxy),maxval));}

findMinMax i = unsafePerformIO $ do
               nullp <- newForeignPtr_ nullPtr
               (findMinMax' (unS i) (BareImage nullp))

-- |Find minimum and maximum value of image i in area specified by the mask.
findMinMaxMask i mask  = unsafePerformIO (findMinMax' i mask)
-- let a = getAllPixels i in (minimum a,maximum a)

maxValue,minValue :: Image GrayScale D32 -> D32
maxValue = snd.findMinMax
minValue = fst.findMinMax

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

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

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

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

-- | Given a distance map and a circle, return the biggest circle with radius less
--   than given in the distance map that fully covers the previous one

maximalCoveringCircle distMap (x,y,r)
  = unsafePerformIO $
     withImage distMap $ \c_distmap ->
       alloca $ \(ptr_int_max_x :: Ptr CInt) ->
        alloca $ \(ptr_int_max_y :: Ptr CInt) ->
         alloca $ \(ptr_double_max_r :: Ptr CDouble) ->
          do
           {#call maximal_covering_circle#} x y r c_distmap ptr_int_max_x ptr_int_max_y ptr_double_max_r
           max_x <- fromIntegral <$> peek ptr_int_max_x
           max_y <- fromIntegral <$> peek ptr_int_max_y
           max_r <- realToFrac   <$> peek ptr_double_max_r
           return (max_x,max_y,max_r)