Fixed blit

Fixed blit

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns,ParallelListComp, FlexibleInstances, FlexibleContexts, TypeFamilies, EmptyDataDecls, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable, UndecidableInstances #-}
#include "cvWrapLEO.h"
module CV.Image (
-- * Basic types
 Image(..)
, create
, empty
, emptyCopy
, cloneImage
, withClone
, withCloneValue
, CreateImage

-- * Colour spaces
, ChannelOf
, GrayScale
, DFT
, RGB
, RGBA
, RGB_Channel(..)
, LAB
, LAB_Channel(..)
, D32
, D64
, D8
, Tag
, lab
, rgba
, rgb
, compose
, composeMultichannelImage

-- * IO operations
, Loadable(..)
, saveImage
, loadColorImage
, loadImage

-- * Pixel level access
, GetPixel(..)
, SetPixel(..)
, getAllPixels
, getAllPixelsRowMajor
, mapImageInplace

-- * Image information
, ImageDepth
, Sized(..)
, getArea
, getChannel
, getImageChannels
, getImageDepth
, getImageInfo

-- * ROI's, COI's and subregions
, setCOI
, setROI
, resetROI
, getRegion
, withIOROI
, withROI

-- * Blitting
, blendBlit
, blit
, blitM
, subPixelBlit
, safeBlit
, montage
, tileImages

-- * Conversions
, rgbToGray
, grayToRGB
, rgbToLab
, bgrToRgb
, rgbToBgr
, unsafeImageTo32F
, unsafeImageTo8Bit

-- * Low level access operations
, BareImage(..)
, creatingImage
, unImage
, unS
, withGenBareImage
, withBareImage
, creatingBareImage
, withGenImage
, withImage
, imageFPTR
, ensure32F

-- * Extended error handling
, setCatch
, CvException
) where

import System.Mem
import System.Directory

import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Utils
import Foreign.ForeignPtr hiding (newForeignPtr,unsafeForeignPtrToPtr)
import Foreign.Concurrent
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq
import CV.Bindings.Error

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
import Foreign.Storable
import System.IO.Unsafe
import Data.Word
import Data.Complex
import Data.Complex
import Control.Monad
import Control.Exception
import Data.Data
import Data.Typeable

-- Colorspaces

-- | Single channel grayscale image
data GrayScale

data DFT
data RGB
data RGB_Channel = Red | Green | Blue deriving (Eq,Ord,Enum)

data BGR

data LAB
data RGBA
data LAB_Channel = LAB_L | LAB_A | LAB_B deriving (Eq,Ord,Enum)

-- | Type family for expressing which channels a colorspace contains. This needs to be fixed wrt. the BGR color space.
type family ChannelOf a :: *
type instance ChannelOf RGB_Channel = RGB
type instance ChannelOf LAB_Channel = LAB

-- Bit Depths
type D8  = Word8
type D32 = Float
type D64 = Double

-- | The type for Images
newtype Image channels depth = S BareImage

-- | Remove typing info from an image
unS (S i) = i -- Unsafe and ugly

imageFPTR :: Image c d -> ForeignPtr BareImage
imageFPTR (S (BareImage fptr)) = fptr

withImage :: Image c d -> (Ptr BareImage ->IO a) -> IO a
withImage (S i) op = withBareImage i op
--withGenNewImage (S i) op = withGenImage i op

-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

freeBareImage ptr = with ptr {#call cvReleaseImage#}

--foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr BareImage

instance NFData (Image a b) where
    rnf a@(S (BareImage fptr)) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr iptr (freeBareImage iptr)
              return . S . BareImage $ fptr

creatingBareImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr iptr (freeBareImage iptr)
              return . BareImage $ fptr

unImage (S (BareImage fptr)) = fptr

data Tag tp;
rgb = undefined :: Tag RGB
rgba = undefined :: Tag RGBA
lab = undefined :: Tag LAB

-- | Typeclass for elements that are build from component elements. For example,
--   RGB images can be constructed from three grayscale images.
class Composes a where
   type Source a :: *
   compose :: Source a -> a

instance (CreateImage (Image RGBA a)) => Composes (Image RGBA a) where
   type Source (Image RGBA a) = (Image GrayScale a, Image GrayScale a
                               ,Image GrayScale a, Image GrayScale a)
   compose (r,g,b,a) = composeMultichannelImage (Just b) (Just g) (Just r) (Just a) rgba

instance (CreateImage (Image RGB a)) => Composes (Image RGB a) where
   type Source (Image RGB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a)
   compose (r,g,b) = composeMultichannelImage (Just b) (Just g) (Just r) Nothing rgb

instance (CreateImage (Image LAB a)) => Composes (Image LAB a) where
   type Source (Image LAB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a)
   compose (l,a,b) = composeMultichannelImage (Just l) (Just a) (Just b) Nothing lab

{-# DEPRECATED composeMultichannelImage "This is unsafe. Use compose instead" #-}
composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannelImage = composeMultichannel

composeMultichannel :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannel (c2)
                         (c1)
                         (c3)
                         (c4)
                         totag
    = unsafePerformIO $ do
        res <- create (size) -- TODO: Check channel count -- This is NOT correct
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- | Typeclass for CV items that can be read from file. Mainly images at this point.
class Loadable a where
    readFromFile :: FilePath -> IO a

instance Loadable ((Image GrayScale D32)) where
    readFromFile fp = do
        e <- loadImage fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image RGB D32)) where
    readFromFile fp = do
        e <- loadColorImage8 fp
        case e of
         Just i -> return $ unsafeImageTo32F $ bgrToRgb i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image RGB D8)) where
    readFromFile fp = do
        e <- loadColorImage8 fp
        case e of
         Just i -> return $ bgrToRgb i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image GrayScale D8)) where
    readFromFile fp = do
        e <- loadImage8 fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

-- | This function loads and converts image to an arbitrary format. Notice that it is
--   polymorphic enough to cause run time errors if the declared and actual types of the
--   images do not match. Use with care.
unsafeloadUsing x p n = do
              exists <- doesFileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name p)
                              bw <- x i
                              return . Just . S $ bw

loadImage :: FilePath -> IO (Maybe (Image GrayScale D32))
loadImage = unsafeloadUsing imageTo32F 0
loadImage8 :: FilePath -> IO (Maybe (Image GrayScale D8))
loadImage8 = unsafeloadUsing imageTo8Bit 0
loadColorImage :: FilePath -> IO (Maybe (Image BGR D32))
loadColorImage = unsafeloadUsing imageTo32F 1
loadColorImage8 :: FilePath -> IO (Maybe (Image BGR D8))
loadColorImage8 = unsafeloadUsing imageTo8Bit 1

-- | Typeclass for elements with a size, such as images and matrices.
class Sized a where
    type Size a :: *
    getSize :: a -> Size a

instance Sized BareImage where
    type Size BareImage = (Int,Int)
   -- getSize :: (Integral a, Integral b) => Image c d -> (a,b)
    getSize image = unsafePerformIO $ withBareImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

instance Sized (Image c d) where
    type Size (Image c d) = (Int,Int)
    getSize = getSize . unS

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.

#c
enum CvtFlags {
    CvtFlip   = CV_CVTIMG_FLIP,
    CvtSwapRB = CV_CVTIMG_SWAP_RB
     };
#endc

#c
enum CvtCodes {
    CV_BGR2BGRA    =0,
    CV_RGB2RGBA    =CV_BGR2BGRA,

    CV_BGRA2BGR    =1,
    CV_RGBA2RGB    =CV_BGRA2BGR,

    CV_BGR2RGBA    =2,
    CV_RGB2BGRA    =CV_BGR2RGBA,

    CV_RGBA2BGR    =3,
    CV_BGRA2RGB    =CV_RGBA2BGR,

    CV_BGR2RGB     =4,
    CV_RGB2BGR     =CV_BGR2RGB,

    CV_BGRA2RGBA   =5,
    CV_RGBA2BGRA   =CV_BGRA2RGBA,

    CV_BGR2GRAY    =6,
    CV_RGB2GRAY    =7,
    CV_GRAY2BGR    =8,
    CV_GRAY2RGB    =CV_GRAY2BGR,
    CV_GRAY2BGRA   =9,
    CV_GRAY2RGBA   =CV_GRAY2BGRA,
    CV_BGRA2GRAY   =10,
    CV_RGBA2GRAY   =11,

    CV_BGR2BGR565  =12,
    CV_RGB2BGR565  =13,
    CV_BGR5652BGR  =14,
    CV_BGR5652RGB  =15,
    CV_BGRA2BGR565 =16,
    CV_RGBA2BGR565 =17,
    CV_BGR5652BGRA =18,
    CV_BGR5652RGBA =19,

    CV_GRAY2BGR565 =20,
    CV_BGR5652GRAY =21,

    CV_BGR2BGR555  =22,
    CV_RGB2BGR555  =23,
    CV_BGR5552BGR  =24,
    CV_BGR5552RGB  =25,
    CV_BGRA2BGR555 =26,
    CV_RGBA2BGR555 =27,
    CV_BGR5552BGRA =28,
    CV_BGR5552RGBA =29,

    CV_GRAY2BGR555 =30,
    CV_BGR5552GRAY =31,

    CV_BGR2XYZ     =32,
    CV_RGB2XYZ     =33,
    CV_XYZ2BGR     =34,
    CV_XYZ2RGB     =35,

    CV_BGR2YCrCb   =36,
    CV_RGB2YCrCb   =37,
    CV_YCrCb2BGR   =38,
    CV_YCrCb2RGB   =39,

    CV_BGR2HSV     =40,
    CV_RGB2HSV     =41,

    CV_BGR2Lab     =44,
    CV_RGB2Lab     =45,

    CV_BayerBG2BGR =46,
    CV_BayerGB2BGR =47,
    CV_BayerRG2BGR =48,
    CV_BayerGR2BGR =49,

    CV_BayerBG2RGB =CV_BayerRG2BGR,
    CV_BayerGB2RGB =CV_BayerGR2BGR,
    CV_BayerRG2RGB =CV_BayerBG2BGR,
    CV_BayerGR2RGB =CV_BayerGB2BGR,

    CV_BGR2Luv     =50,
    CV_RGB2Luv     =51,
    CV_BGR2HLS     =52,
    CV_RGB2HLS     =53,

    CV_HSV2BGR     =54,
    CV_HSV2RGB     =55,

    CV_Lab2BGR     =56,
    CV_Lab2RGB     =57,
    CV_Luv2BGR     =58,
    CV_Luv2RGB     =59,
    CV_HLS2BGR     =60,
    CV_HLS2RGB     =61,

    CV_BayerBG2BGR_VNG =62,
    CV_BayerGB2BGR_VNG =63,
    CV_BayerRG2BGR_VNG =64,
    CV_BayerGR2BGR_VNG =65,

    CV_BayerBG2RGB_VNG =CV_BayerRG2BGR_VNG,
    CV_BayerGB2RGB_VNG =CV_BayerGR2BGR_VNG,
    CV_BayerRG2RGB_VNG =CV_BayerBG2BGR_VNG,
    CV_BayerGR2RGB_VNG =CV_BayerGB2BGR_VNG,

    CV_BGR2HSV_FULL = 66,
    CV_RGB2HSV_FULL = 67,
    CV_BGR2HLS_FULL = 68,
    CV_RGB2HLS_FULL = 69,

    CV_HSV2BGR_FULL = 70,
    CV_HSV2RGB_FULL = 71,
    CV_HLS2BGR_FULL = 72,
    CV_HLS2RGB_FULL = 73,

    CV_LBGR2Lab     = 74,
    CV_LRGB2Lab     = 75,
    CV_LBGR2Luv     = 76,
    CV_LRGB2Luv     = 77,

    CV_Lab2LBGR     = 78,
    CV_Lab2LRGB     = 79,
    CV_Luv2LBGR     = 80,
    CV_Luv2LRGB     = 81,

    CV_BGR2YUV      = 82,
    CV_RGB2YUV      = 83,
    CV_YUV2BGR      = 84,
    CV_YUV2RGB      = 85,

    CV_COLORCVT_MAX  =100
};
#endc

{#enum CvtCodes {}#}

{#enum CvtFlags {}#}

rgbToLab :: Image RGB D32 -> Image LAB D32
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS

rgbToGray :: Image RGB D32 -> Image GrayScale D32
rgbToGray = S . convertTo cvRGBtoGRAY 1 . unS

grayToRGB :: Image GrayScale D32 -> Image RGB D32
grayToRGB = S . convertTo (fromIntegral . fromEnum $ CV_GRAY2BGR) 3 . unS

bgrToRgb :: Image BGR depth -> Image RGB depth
bgrToRgb = S . swapRB . unS

rgbToBgr :: Image BGR depth -> Image RGB depth
rgbToBgr = S . swapRB . unS

swapRB :: BareImage -> BareImage
swapRB img = unsafePerformIO $ do
    res <- cloneBareImage img
    withBareImage img $ \cimg ->
     withBareImage res $ \cres ->
        {#call cvConvertImage#} (castPtr cimg) (castPtr cres) (fromIntegral . fromEnum $ CvtSwapRB)
    return res

class GetPixel a where
    type P a :: *
    getPixel   :: (Int,Int) -> a -> P a

-- #define FGET(img,x,y) (((float *)((img)->imageData + (y)*(img)->widthStep))[(x)])
instance GetPixel (Image GrayScale D32) where
    type P (Image GrayScale D32) = D32
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Float))):: Ptr Float)

instance GetPixel (Image DFT D32) where
    type P (Image DFT D32) = Complex D32
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: Float)
                                         re <- peek (castPtr (d`plusPtr` (y*cs + x*2*fs)))
                                         im <- peek (castPtr (d`plusPtr` (y*cs +(x*2+1)*fs)))
                                         return (re:+im)

-- #define UGETC(img,color,x,y) (((uint8_t *)((img)->imageData + (y)*(img)->widthStep))[(x)*3+(color)])
instance GetPixel (Image RGB D32) where
    type P (Image RGB D32) = (D32,D32,D32)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: Float)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

getPixelOldRGB (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

-- | Perform (a destructive) inplace map of the image. This should be wrapped inside
-- withClone or an image operation
mapImageInplace :: (P (Image GrayScale D32) -> P (Image GrayScale D32))
            -> Image GrayScale D32
            -> IO ()
mapImageInplace f image = withGenImage image $ \c_i -> do
             d <- {#get IplImage->imageData#} c_i
             s <- {#get IplImage->widthStep#} c_i
             let (w,h) = getSize image
                 cs = fromIntegral s
                 fs = sizeOf (undefined :: Float)
             forM_ [(x,y) | x<-[0..w-1], y <- [0..h-1]] $ \(x,y) -> do
                   v <- peek (castPtr (d `plusPtr` (y*cs+x*fs)))
                   poke (castPtr (d `plusPtr` (y*cs+x*fs))) (f v)

instance  GetPixel (Image RGB D8) where
    type P (Image RGB D8) = (D8,D8,D8)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: D8)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

convertTo :: CInt -> CInt -> BareImage -> BareImage
convertTo code channels img = unsafePerformIO $ creatingBareImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withBareImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (fromIntegral -> w,fromIntegral -> h) = getSize img

-- | Class for images that exist.
class CreateImage a where
    -- | Create an image from size
    create :: (Int,Int) -> IO a

instance CreateImage (Image GrayScale D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image DFT D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 2
instance CreateImage (Image LAB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 4

-- | Allocate a new empty image
empty :: (CreateImage (Image a b)) => (Int,Int) -> (Image a b)
empty size = unsafePerformIO $ create size

-- | Allocate a new image that of the same size and type as the exemplar image given.
emptyCopy :: (CreateImage (Image a b)) => Image a b -> (Image a b)
emptyCopy img = unsafePerformIO $ create (getSize img)

-- | Save image. This will convert the image to 8 bit one before saving
saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit $ unS image
                           withCString  filename $ \name  ->
                            withGenBareImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getArea :: (Sized a,Num b, Size a ~ (b,b)) => a -> b
getArea = uncurry (*).getSize

getRegion :: (Int,Int) -> (Int,Int) -> Image c d -> Image c d
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = S . getRegion' (x,y) (w,h) $ unS image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (fromIntegral -> width,fromIntegral -> height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withBareImage image $ \i ->
                                 creatingBareImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
blitFix = blit
blit :: Image GrayScale D32 -> Image GrayScale D32
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 (fromIntegral y) (fromIntegral x))
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0

-- blitM :: (CreateImage (Image c d)) => (Int,Int) -> [((Int,Int),Image c d)] -> Image c d
blitM (rw,rh) imgs = resultPic
    where
     resultPic = unsafePerformIO $ do
                    r <- create (fromIntegral rw,fromIntegral rh)
                    sequence_ [blit r i (fromIntegral x, fromIntegral y)
                              | ((x,y),i) <- imgs ]
                    return r

subPixelBlit
  :: Image c d -> Image c d -> (CDouble, CDouble) -> IO ()

subPixelBlit (image1) (image2) (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

-- | Create a copy of an image
cloneImage :: Image a b -> IO (Image a b)
cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

-- | Create a copy of a non-types image
cloneBareImage :: BareImage -> IO BareImage
cloneBareImage img = withGenBareImage img $ \image ->
                    creatingBareImage ({#call cvCloneImage #} image)

withClone
  :: Image channels depth
     -> (Image channels depth -> IO ())
     -> IO (Image channels depth)
withClone img fun = do
                result <- cloneImage img
                fun result
                return result

withCloneValue
  :: Image channels depth
     -> (Image channels depth -> IO a)
     -> IO a
withCloneValue img fun = do
                result <- cloneImage img
                r <- fun result
                return r

unsafeImageTo32F :: Image c d -> Image c D32
unsafeImageTo32F img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)

unsafeImageTo8Bit :: Image cspace a -> Image cspace D8
unsafeImageTo8Bit img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)

--toD32 :: Image c d -> Image c D32
--toD32 i =
--  unsafePerformIO $
--    withImage i $ \i_ptr ->
--      creatingImage

imageTo32F img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure32F #} image)

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)
#c
enum ImageDepth {
     Depth32F = IPL_DEPTH_32F,
     Depth64F = IPL_DEPTH_64F,
     Depth8U  = IPL_DEPTH_8U,
     Depth8S  = IPL_DEPTH_8S,
     Depth16U  = IPL_DEPTH_16U,
     Depth16S  = IPL_DEPTH_16S,
     Depth32S  = IPL_DEPTH_32S
     };
#endc

{#enum ImageDepth {}#}

deriving instance Show ImageDepth

getImageDepth :: Image c d -> IO ImageDepth
getImageDepth i = withImage i $ \c_img -> {#get IplImage->depth #} c_img >>= return.toEnum.fromIntegral
getImageChannels i = withImage i $ \c_img -> {#get IplImage->nChannels #} c_img

getImageInfo x = do
    let s = getSize x
    d <- getImageDepth x
    c <- getImageChannels x
    return (s,d,c)

-- Manipulating regions of interest:
setROI (fromIntegral -> x,fromIntegral -> y)
       (fromIntegral -> w,fromIntegral -> h)
       image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h

resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

-- #TODO: Replace the Int below with proper channel identifier
getChannel :: (Enum a) => a -> Image (ChannelOf a) d -> Image GrayScale d
getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI (1+fromEnum no) image
    cres <- {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI :: (Int, Int) -> (Int, Int) -> Image c d -> (Image c d -> a) -> a
withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image -- BUG
                        resetROI image
                        return x

class SetPixel a where
   type SP a :: *
   setPixel :: (Int,Int) -> SP a -> a -> IO ()

instance SetPixel (Image GrayScale D32) where
   type SP (Image GrayScale D32) = D32
   {-#INLINE setPixel#-}
   setPixel (x,y) v image = withGenImage image $ \c_i -> do
                                  d <- {#get IplImage->imageData#} c_i
                                  s <- {#get IplImage->widthStep#} c_i
                                  poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                       + x*sizeOf (0::Float))):: Ptr Float)
                                       v

instance SetPixel (Image GrayScale D8) where
   type SP (Image GrayScale D8) = D8
   {-#INLINE setPixel#-}
   setPixel (x,y) v image = withGenImage image $ \c_i -> do
                             d <- {#get IplImage->imageData#} c_i
                             s <- {#get IplImage->widthStep#} c_i
                             poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                  + x*sizeOf (0::Word8))):: Ptr Word8)
                                  v

instance SetPixel (Image DFT D32) where
    type SP (Image DFT D32) = Complex D32
    {-#INLINE setPixel#-}
    setPixel (x,y) (re:+im) image = withGenImage image $ \c_i -> do
                             d <- {#get IplImage->imageData#} c_i
                             s <- {#get IplImage->widthStep#} c_i
                             let cs = fromIntegral s
                                 fs = sizeOf (undefined :: Float)
                             poke (castPtr (d`plusPtr` (y*cs + x*2*fs))) re
                             poke (castPtr (d`plusPtr` (y*cs + (x*2+1)*fs))) im

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (CreateImage (Image c d)) => (Int,Int) -> Int -> [Image c d] -> Image c d
montage (u',v') space' imgs
    | u'*v' /= (length imgs) = error ("Montage mismatch: "++show (u,v, length imgs))
    | otherwise              = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- create (rw,rh)
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep)
                               | y <- [0..v-1] , x <- [0..u-1]
                               | i <- imgs ]
                    return r

data CvException = CvException Int String String String Int
     deriving (Show, Typeable)

instance Exception CvException

setCatch = do
   let catch i cstr1 cstr2 cstr3 j = do
         func <- peekCString cstr1
         msg  <- peekCString cstr2
         file <- peekCString cstr3
         throw (CvException (fromIntegral i) func msg file (fromIntegral j))
         return 0
   cb <- mk'CvErrorCallback catch
   c'cvRedirectError cb nullPtr nullPtr
   c'cvSetErrMode c'CV_ErrModeSilent

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns,ParallelListComp, FlexibleInstances, FlexibleContexts, TypeFamilies, EmptyDataDecls, ScopedTypeVariables, StandaloneDeriving, DeriveDataTypeable, UndecidableInstances #-}
#include "cvWrapLEO.h"
module CV.Image (
-- * Basic types
 Image(..)
, create
, empty
, emptyCopy
, cloneImage
, withClone
, withCloneValue
, CreateImage

-- * Colour spaces
, ChannelOf
, GrayScale
, DFT
, RGB
, RGBA
, RGB_Channel(..)
, LAB
, LAB_Channel(..)
, D32
, D64
, D8
, Tag
, lab
, rgba
, rgb
, compose
, composeMultichannelImage

-- * IO operations
, Loadable(..)
, saveImage
, loadColorImage
, loadImage

-- * Pixel level access
, GetPixel(..)
, SetPixel(..)
, getAllPixels
, getAllPixelsRowMajor
, mapImageInplace

-- * Image information
, ImageDepth
, Sized(..)
, getArea
, getChannel
, getImageChannels
, getImageDepth
, getImageInfo

-- * ROI's, COI's and subregions
, setCOI
, setROI
, resetROI
, getRegion
, withIOROI
, withROI

-- * Blitting
, blendBlit
, blit
, blitM
, subPixelBlit
, safeBlit
, montage
, tileImages

-- * Conversions
, rgbToGray
, grayToRGB
, rgbToLab
, bgrToRgb
, rgbToBgr
, unsafeImageTo32F
, unsafeImageTo8Bit

-- * Low level access operations
, BareImage(..)
, creatingImage
, unImage
, unS
, withGenBareImage
, withBareImage
, creatingBareImage
, withGenImage
, withImage
, imageFPTR
, ensure32F

-- * Extended error handling
, setCatch
, CvException
) where

import System.Mem
import System.Directory

import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Utils
import Foreign.ForeignPtr hiding (newForeignPtr,unsafeForeignPtrToPtr)
import Foreign.Concurrent
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq
import CV.Bindings.Error

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
import Foreign.Storable
import System.IO.Unsafe
import Data.Word
import Data.Complex
import Data.Complex
import Control.Monad
import Control.Exception
import Data.Data
import Data.Typeable

-- Colorspaces

-- | Single channel grayscale image
data GrayScale

data DFT
data RGB
data RGB_Channel = Red | Green | Blue deriving (Eq,Ord,Enum)

data BGR

data LAB
data RGBA
data LAB_Channel = LAB_L | LAB_A | LAB_B deriving (Eq,Ord,Enum)

-- | Type family for expressing which channels a colorspace contains. This needs to be fixed wrt. the BGR color space.
type family ChannelOf a :: *
type instance ChannelOf RGB_Channel = RGB
type instance ChannelOf LAB_Channel = LAB

-- Bit Depths
type D8  = Word8
type D32 = Float
type D64 = Double

-- | The type for Images
newtype Image channels depth = S BareImage

-- | Remove typing info from an image
unS (S i) = i -- Unsafe and ugly

imageFPTR :: Image c d -> ForeignPtr BareImage
imageFPTR (S (BareImage fptr)) = fptr

withImage :: Image c d -> (Ptr BareImage ->IO a) -> IO a
withImage (S i) op = withBareImage i op
--withGenNewImage (S i) op = withGenImage i op

-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

freeBareImage ptr = with ptr {#call cvReleaseImage#}

--foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr BareImage

instance NFData (Image a b) where
    rnf a@(S (BareImage fptr)) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr iptr (freeBareImage iptr)
              return . S . BareImage $ fptr

creatingBareImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr iptr (freeBareImage iptr)
              return . BareImage $ fptr

unImage (S (BareImage fptr)) = fptr

data Tag tp;
rgb = undefined :: Tag RGB
rgba = undefined :: Tag RGBA
lab = undefined :: Tag LAB

-- | Typeclass for elements that are build from component elements. For example,
--   RGB images can be constructed from three grayscale images.
class Composes a where
   type Source a :: *
   compose :: Source a -> a

instance (CreateImage (Image RGBA a)) => Composes (Image RGBA a) where
   type Source (Image RGBA a) = (Image GrayScale a, Image GrayScale a
                               ,Image GrayScale a, Image GrayScale a)
   compose (r,g,b,a) = composeMultichannelImage (Just b) (Just g) (Just r) (Just a) rgba

instance (CreateImage (Image RGB a)) => Composes (Image RGB a) where
   type Source (Image RGB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a)
   compose (r,g,b) = composeMultichannelImage (Just b) (Just g) (Just r) Nothing rgb

instance (CreateImage (Image LAB a)) => Composes (Image LAB a) where
   type Source (Image LAB a) = (Image GrayScale a, Image GrayScale a, Image GrayScale a)
   compose (l,a,b) = composeMultichannelImage (Just l) (Just a) (Just b) Nothing lab

{-# DEPRECATED composeMultichannelImage "This is unsafe. Use compose instead" #-}
composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannelImage = composeMultichannel

composeMultichannel :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannel (c2)
                         (c1)
                         (c3)
                         (c4)
                         totag
    = unsafePerformIO $ do
        res <- create (size) -- TODO: Check channel count -- This is NOT correct
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- | Typeclass for CV items that can be read from file. Mainly images at this point.
class Loadable a where
    readFromFile :: FilePath -> IO a

instance Loadable ((Image GrayScale D32)) where
    readFromFile fp = do
        e <- loadImage fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image RGB D32)) where
    readFromFile fp = do
        e <- loadColorImage8 fp
        case e of
         Just i -> return $ unsafeImageTo32F $ bgrToRgb i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image RGB D8)) where
    readFromFile fp = do
        e <- loadColorImage8 fp
        case e of
         Just i -> return $ bgrToRgb i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image GrayScale D8)) where
    readFromFile fp = do
        e <- loadImage8 fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

-- | This function loads and converts image to an arbitrary format. Notice that it is
--   polymorphic enough to cause run time errors if the declared and actual types of the
--   images do not match. Use with care.
unsafeloadUsing x p n = do
              exists <- doesFileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name p)
                              bw <- x i
                              return . Just . S $ bw

loadImage :: FilePath -> IO (Maybe (Image GrayScale D32))
loadImage = unsafeloadUsing imageTo32F 0
loadImage8 :: FilePath -> IO (Maybe (Image GrayScale D8))
loadImage8 = unsafeloadUsing imageTo8Bit 0
loadColorImage :: FilePath -> IO (Maybe (Image BGR D32))
loadColorImage = unsafeloadUsing imageTo32F 1
loadColorImage8 :: FilePath -> IO (Maybe (Image BGR D8))
loadColorImage8 = unsafeloadUsing imageTo8Bit 1

-- | Typeclass for elements with a size, such as images and matrices.
class Sized a where
    type Size a :: *
    getSize :: a -> Size a

instance Sized BareImage where
    type Size BareImage = (Int,Int)
   -- getSize :: (Integral a, Integral b) => Image c d -> (a,b)
    getSize image = unsafePerformIO $ withBareImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

instance Sized (Image c d) where
    type Size (Image c d) = (Int,Int)
    getSize = getSize . unS

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.

#c
enum CvtFlags {
    CvtFlip   = CV_CVTIMG_FLIP,
    CvtSwapRB = CV_CVTIMG_SWAP_RB
     };
#endc

#c
enum CvtCodes {
    CV_BGR2BGRA    =0,
    CV_RGB2RGBA    =CV_BGR2BGRA,

    CV_BGRA2BGR    =1,
    CV_RGBA2RGB    =CV_BGRA2BGR,

    CV_BGR2RGBA    =2,
    CV_RGB2BGRA    =CV_BGR2RGBA,

    CV_RGBA2BGR    =3,
    CV_BGRA2RGB    =CV_RGBA2BGR,

    CV_BGR2RGB     =4,
    CV_RGB2BGR     =CV_BGR2RGB,

    CV_BGRA2RGBA   =5,
    CV_RGBA2BGRA   =CV_BGRA2RGBA,

    CV_BGR2GRAY    =6,
    CV_RGB2GRAY    =7,
    CV_GRAY2BGR    =8,
    CV_GRAY2RGB    =CV_GRAY2BGR,
    CV_GRAY2BGRA   =9,
    CV_GRAY2RGBA   =CV_GRAY2BGRA,
    CV_BGRA2GRAY   =10,
    CV_RGBA2GRAY   =11,

    CV_BGR2BGR565  =12,
    CV_RGB2BGR565  =13,
    CV_BGR5652BGR  =14,
    CV_BGR5652RGB  =15,
    CV_BGRA2BGR565 =16,
    CV_RGBA2BGR565 =17,
    CV_BGR5652BGRA =18,
    CV_BGR5652RGBA =19,

    CV_GRAY2BGR565 =20,
    CV_BGR5652GRAY =21,

    CV_BGR2BGR555  =22,
    CV_RGB2BGR555  =23,
    CV_BGR5552BGR  =24,
    CV_BGR5552RGB  =25,
    CV_BGRA2BGR555 =26,
    CV_RGBA2BGR555 =27,
    CV_BGR5552BGRA =28,
    CV_BGR5552RGBA =29,

    CV_GRAY2BGR555 =30,
    CV_BGR5552GRAY =31,

    CV_BGR2XYZ     =32,
    CV_RGB2XYZ     =33,
    CV_XYZ2BGR     =34,
    CV_XYZ2RGB     =35,

    CV_BGR2YCrCb   =36,
    CV_RGB2YCrCb   =37,
    CV_YCrCb2BGR   =38,
    CV_YCrCb2RGB   =39,

    CV_BGR2HSV     =40,
    CV_RGB2HSV     =41,

    CV_BGR2Lab     =44,
    CV_RGB2Lab     =45,

    CV_BayerBG2BGR =46,
    CV_BayerGB2BGR =47,
    CV_BayerRG2BGR =48,
    CV_BayerGR2BGR =49,

    CV_BayerBG2RGB =CV_BayerRG2BGR,
    CV_BayerGB2RGB =CV_BayerGR2BGR,
    CV_BayerRG2RGB =CV_BayerBG2BGR,
    CV_BayerGR2RGB =CV_BayerGB2BGR,

    CV_BGR2Luv     =50,
    CV_RGB2Luv     =51,
    CV_BGR2HLS     =52,
    CV_RGB2HLS     =53,

    CV_HSV2BGR     =54,
    CV_HSV2RGB     =55,

    CV_Lab2BGR     =56,
    CV_Lab2RGB     =57,
    CV_Luv2BGR     =58,
    CV_Luv2RGB     =59,
    CV_HLS2BGR     =60,
    CV_HLS2RGB     =61,

    CV_BayerBG2BGR_VNG =62,
    CV_BayerGB2BGR_VNG =63,
    CV_BayerRG2BGR_VNG =64,
    CV_BayerGR2BGR_VNG =65,

    CV_BayerBG2RGB_VNG =CV_BayerRG2BGR_VNG,
    CV_BayerGB2RGB_VNG =CV_BayerGR2BGR_VNG,
    CV_BayerRG2RGB_VNG =CV_BayerBG2BGR_VNG,
    CV_BayerGR2RGB_VNG =CV_BayerGB2BGR_VNG,

    CV_BGR2HSV_FULL = 66,
    CV_RGB2HSV_FULL = 67,
    CV_BGR2HLS_FULL = 68,
    CV_RGB2HLS_FULL = 69,

    CV_HSV2BGR_FULL = 70,
    CV_HSV2RGB_FULL = 71,
    CV_HLS2BGR_FULL = 72,
    CV_HLS2RGB_FULL = 73,

    CV_LBGR2Lab     = 74,
    CV_LRGB2Lab     = 75,
    CV_LBGR2Luv     = 76,
    CV_LRGB2Luv     = 77,

    CV_Lab2LBGR     = 78,
    CV_Lab2LRGB     = 79,
    CV_Luv2LBGR     = 80,
    CV_Luv2LRGB     = 81,

    CV_BGR2YUV      = 82,
    CV_RGB2YUV      = 83,
    CV_YUV2BGR      = 84,
    CV_YUV2RGB      = 85,

    CV_COLORCVT_MAX  =100
};
#endc

{#enum CvtCodes {}#}

{#enum CvtFlags {}#}

rgbToLab :: Image RGB D32 -> Image LAB D32
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS

rgbToGray :: Image RGB D32 -> Image GrayScale D32
rgbToGray = S . convertTo cvRGBtoGRAY 1 . unS

grayToRGB :: Image GrayScale D32 -> Image RGB D32
grayToRGB = S . convertTo (fromIntegral . fromEnum $ CV_GRAY2BGR) 3 . unS

bgrToRgb :: Image BGR depth -> Image RGB depth
bgrToRgb = S . swapRB . unS

rgbToBgr :: Image BGR depth -> Image RGB depth
rgbToBgr = S . swapRB . unS

swapRB :: BareImage -> BareImage
swapRB img = unsafePerformIO $ do
    res <- cloneBareImage img
    withBareImage img $ \cimg ->
     withBareImage res $ \cres ->
        {#call cvConvertImage#} (castPtr cimg) (castPtr cres) (fromIntegral . fromEnum $ CvtSwapRB)
    return res

class GetPixel a where
    type P a :: *
    getPixel   :: (Int,Int) -> a -> P a

-- #define FGET(img,x,y) (((float *)((img)->imageData + (y)*(img)->widthStep))[(x)])
instance GetPixel (Image GrayScale D32) where
    type P (Image GrayScale D32) = D32
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Float))):: Ptr Float)

instance GetPixel (Image DFT D32) where
    type P (Image DFT D32) = Complex D32
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: Float)
                                         re <- peek (castPtr (d`plusPtr` (y*cs + x*2*fs)))
                                         im <- peek (castPtr (d`plusPtr` (y*cs +(x*2+1)*fs)))
                                         return (re:+im)

-- #define UGETC(img,color,x,y) (((uint8_t *)((img)->imageData + (y)*(img)->widthStep))[(x)*3+(color)])
instance GetPixel (Image RGB D32) where
    type P (Image RGB D32) = (D32,D32,D32)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: Float)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

getPixelOldRGB (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

-- | Perform (a destructive) inplace map of the image. This should be wrapped inside
-- withClone or an image operation
mapImageInplace :: (P (Image GrayScale D32) -> P (Image GrayScale D32))
            -> Image GrayScale D32
            -> IO ()
mapImageInplace f image = withGenImage image $ \c_i -> do
             d <- {#get IplImage->imageData#} c_i
             s <- {#get IplImage->widthStep#} c_i
             let (w,h) = getSize image
                 cs = fromIntegral s
                 fs = sizeOf (undefined :: Float)
             forM_ [(x,y) | x<-[0..w-1], y <- [0..h-1]] $ \(x,y) -> do
                   v <- peek (castPtr (d `plusPtr` (y*cs+x*fs)))
                   poke (castPtr (d `plusPtr` (y*cs+x*fs))) (f v)

instance  GetPixel (Image RGB D8) where
    type P (Image RGB D8) = (D8,D8,D8)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: D8)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

convertTo :: CInt -> CInt -> BareImage -> BareImage
convertTo code channels img = unsafePerformIO $ creatingBareImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withBareImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (fromIntegral -> w,fromIntegral -> h) = getSize img

-- | Class for images that exist.
class CreateImage a where
    -- | Create an image from size
    create :: (Int,Int) -> IO a

instance CreateImage (Image GrayScale D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image DFT D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 2
instance CreateImage (Image LAB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 4

-- | Allocate a new empty image
empty :: (CreateImage (Image a b)) => (Int,Int) -> (Image a b)
empty size = unsafePerformIO $ create size

-- | Allocate a new image that of the same size and type as the exemplar image given.
emptyCopy :: (CreateImage (Image a b)) => Image a b -> (Image a b)
emptyCopy img = unsafePerformIO $ create (getSize img)

-- | Save image. This will convert the image to 8 bit one before saving
saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit $ unS image
                           withCString  filename $ \name  ->
                            withGenBareImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getArea :: (Sized a,Num b, Size a ~ (b,b)) => a -> b
getArea = uncurry (*).getSize

getRegion :: (Int,Int) -> (Int,Int) -> Image c d -> Image c d
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = S . getRegion' (x,y) (w,h) $ unS image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (fromIntegral -> width,fromIntegral -> height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withBareImage image $ \i ->
                                 creatingBareImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
blitFix = blit
blit :: Image GrayScale D32 -> Image GrayScale D32
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call blitImg#} i1 i2 (fromIntegral y) (fromIntegral x))
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0

-- blitM :: (CreateImage (Image c d)) => (Int,Int) -> [((Int,Int),Image c d)] -> Image c d
blitM (rw,rh) imgs = resultPic
    where
     resultPic = unsafePerformIO $ do
                    r <- create (fromIntegral rw,fromIntegral rh)
                    sequence_ [blit r i (fromIntegral x, fromIntegral y)
                              | ((x,y),i) <- imgs ]
                    return r

subPixelBlit
  :: Image c d -> Image c d -> (CDouble, CDouble) -> IO ()

subPixelBlit (image1) (image2) (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

-- | Create a copy of an image
cloneImage :: Image a b -> IO (Image a b)
cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

-- | Create a copy of a non-types image
cloneBareImage :: BareImage -> IO BareImage
cloneBareImage img = withGenBareImage img $ \image ->
                    creatingBareImage ({#call cvCloneImage #} image)

withClone
  :: Image channels depth
     -> (Image channels depth -> IO ())
     -> IO (Image channels depth)
withClone img fun = do
                result <- cloneImage img
                fun result
                return result

withCloneValue
  :: Image channels depth
     -> (Image channels depth -> IO a)
     -> IO a
withCloneValue img fun = do
                result <- cloneImage img
                r <- fun result
                return r

unsafeImageTo32F :: Image c d -> Image c D32
unsafeImageTo32F img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)

unsafeImageTo8Bit :: Image cspace a -> Image cspace D8
unsafeImageTo8Bit img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)

--toD32 :: Image c d -> Image c D32
--toD32 i =
--  unsafePerformIO $
--    withImage i $ \i_ptr ->
--      creatingImage

imageTo32F img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure32F #} image)

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)
#c
enum ImageDepth {
     Depth32F = IPL_DEPTH_32F,
     Depth64F = IPL_DEPTH_64F,
     Depth8U  = IPL_DEPTH_8U,
     Depth8S  = IPL_DEPTH_8S,
     Depth16U  = IPL_DEPTH_16U,
     Depth16S  = IPL_DEPTH_16S,
     Depth32S  = IPL_DEPTH_32S
     };
#endc

{#enum ImageDepth {}#}

deriving instance Show ImageDepth

getImageDepth :: Image c d -> IO ImageDepth
getImageDepth i = withImage i $ \c_img -> {#get IplImage->depth #} c_img >>= return.toEnum.fromIntegral
getImageChannels i = withImage i $ \c_img -> {#get IplImage->nChannels #} c_img

getImageInfo x = do
    let s = getSize x
    d <- getImageDepth x
    c <- getImageChannels x
    return (s,d,c)

-- Manipulating regions of interest:
setROI (fromIntegral -> x,fromIntegral -> y)
       (fromIntegral -> w,fromIntegral -> h)
       image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h

resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

-- #TODO: Replace the Int below with proper channel identifier
getChannel :: (Enum a) => a -> Image (ChannelOf a) d -> Image GrayScale d
getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI (1+fromEnum no) image
    cres <- {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI :: (Int, Int) -> (Int, Int) -> Image c d -> (Image c d -> a) -> a
withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image -- BUG
                        resetROI image
                        return x

class SetPixel a where
   type SP a :: *
   setPixel :: (Int,Int) -> SP a -> a -> IO ()

instance SetPixel (Image GrayScale D32) where
   type SP (Image GrayScale D32) = D32
   {-#INLINE setPixel#-}
   setPixel (x,y) v image = withGenImage image $ \c_i -> do
                                  d <- {#get IplImage->imageData#} c_i
                                  s <- {#get IplImage->widthStep#} c_i
                                  poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                       + x*sizeOf (0::Float))):: Ptr Float)
                                       v

instance SetPixel (Image GrayScale D8) where
   type SP (Image GrayScale D8) = D8
   {-#INLINE setPixel#-}
   setPixel (x,y) v image = withGenImage image $ \c_i -> do
                             d <- {#get IplImage->imageData#} c_i
                             s <- {#get IplImage->widthStep#} c_i
                             poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                  + x*sizeOf (0::Word8))):: Ptr Word8)
                                  v

instance SetPixel (Image DFT D32) where
    type SP (Image DFT D32) = Complex D32
    {-#INLINE setPixel#-}
    setPixel (x,y) (re:+im) image = withGenImage image $ \c_i -> do
                             d <- {#get IplImage->imageData#} c_i
                             s <- {#get IplImage->widthStep#} c_i
                             let cs = fromIntegral s
                                 fs = sizeOf (undefined :: Float)
                             poke (castPtr (d`plusPtr` (y*cs + x*2*fs))) re
                             poke (castPtr (d`plusPtr` (y*cs + (x*2+1)*fs))) im

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (CreateImage (Image c d)) => (Int,Int) -> Int -> [Image c d] -> Image c d
montage (u',v') space' imgs
    | u'*v' /= (length imgs) = error ("Montage mismatch: "++show (u,v, length imgs))
    | otherwise              = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- create (rw,rh)
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep)
                               | y <- [0..v-1] , x <- [0..u-1]
                               | i <- imgs ]
                    return r

data CvException = CvException Int String String String Int
     deriving (Show, Typeable)

instance Exception CvException

setCatch = do
   let catch i cstr1 cstr2 cstr3 j = do
         func <- peekCString cstr1
         msg  <- peekCString cstr2
         file <- peekCString cstr3
         throw (CvException (fromIntegral i) func msg file (fromIntegral j))
         return 0
   cb <- mk'CvErrorCallback catch
   c'cvRedirectError cb nullPtr nullPtr
   c'cvSetErrMode c'CV_ErrModeSilent


Remote

Remote

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/remote.h>

module Data.HGit2.Remote where

import Data.HGit2.Git2
import Data.HGit2.Config
import Data.HGit2.Types
import Foreign
import Foreign.C

newtype Remote = Remote CPtr
newtype HeadArray = HeadArray CPtr

instance CWrapper Remote where
  unwrap (Remote r) = r

instance CWrapper HeadArray where
  unwrap (HeadArray a) = a

-- | Get the information for a particular remote
remote :: Config -> String -> IOEitherErr Remote
remote (Config cfp) str =
  withForeignPtr cfp $ \c ->
  withCString str $ \str' ->
  callPeek Remote (\out -> {#call git_remote_get#} out c str')

-- | Get the remote's name
remoteName :: Remote -> String
remoteName (Remote rfp) = unsafePerformIO $
  withForeignPtr rfp $ \r ->
  peekCString =<< {#call git_remote_name#} r

-- | Get the remote's url
remoteURL :: Remote -> String
remoteURL (Remote rfp) = unsafePerformIO $
  withForeignPtr rfp $ \r ->
  peekCString =<< {#call git_remote_url#} r

-- | Get the fetch refspec
remoteRefSpec :: Remote -> IO (Maybe RefSpec)
remoteRefSpec (Remote rfp) =
  withForeignPtr rfp $ \r -> do
  ptr <- mkFPtr =<< {#call git_remote_fetchspec#} r
  retRes RefSpec ptr

-- | Get the push refspec
pushSpec :: Remote -> IO (Maybe RefSpec)
pushSpec (Remote rfp) =
  withForeignPtr rfp $ \r -> do
  ptr <- mkFPtr =<< {#call git_remote_pushspec#} r
  retRes RefSpec ptr

-- | Open a connection to a remote
--
-- The transport is selected based on the URL
connect :: Remote -> Int -> IOCanFail
connect (Remote rfp) n =
  withForeignPtr rfp $ \r ->
  retMaybe =<< {#call git_remote_connect#} r (fromIntegral n)

-- | Get a list of refs at the remote
--
-- The remote (or more exactly its transport) must be connected.
remoteLs :: Remote -> HeadArray -> IOCanFail
remoteLs (Remote rfp) (HeadArray hfp) =
  withForeignPtr rfp $ \r ->
  withForeignPtr hfp $ \h ->
  retMaybe =<< {#call git_remote_ls#} r h

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/remote.h>

module Data.HGit2.Remote where

import Data.HGit2.Git2
import Data.HGit2.Config
import Data.HGit2.Types
import Foreign
import Foreign.C

newtype Remote = Remote CPtr
newtype HeadArray = HeadArray CPtr

instance CWrapper Remote where
  unwrap (Remote r) = r

instance CWrapper HeadArray where
  unwrap (HeadArray a) = a

-- | Get the information for a particular remote
remote :: Config -> String -> IOEitherErr Remote
remote (Config cfp) str =
  withForeignPtr cfp $ \c ->
  withCString str $ \str' ->
  callPeek Remote (\out -> {#call git_remote_get#} out c str')

-- | Get the remote's name
remoteName :: Remote -> String
remoteName = undefined -- unsafePeekStr {#call git_remote_name#}

-- | Get the remote's url
remoteURL :: Remote -> String
remoteURL = undefined --unsafePeekStr {#call git_remote_url#}

-- | Get the fetch refspec
remoteRefSpec :: Remote -> IO (Maybe RefSpec)
remoteRefSpec (Remote rfp) =
  withForeignPtr rfp $ \r ->
  undefined
  {- retRes' RefSpec $ {#call git_remote_fetchspec#} r-}

-- | Get the push refspec
pushSpec :: Remote -> IO (Maybe RefSpec)
pushSpec  (Remote rfp) =
  withForeignPtr rfp $ \r ->
  undefined
  {- retRes' RefSpec $ {#call git_remote_pushspec#} r-}

-- | Open a connection to a remote
--
-- The transport is selected based on the URL
connect :: Remote -> Int -> IOCanFail
connect (Remote rfp) n =
  withForeignPtr rfp $ \r ->
  retMaybe =<< {#call git_remote_connect#} r (fromIntegral n)

-- | Get a list of refs at the remote
--
-- The remote (or more exactly its transport) must be connected.
remoteLs :: Remote -> HeadArray -> IOCanFail
remoteLs (Remote rfp) (HeadArray hfp) =
  withForeignPtr rfp $ \r ->
  withForeignPtr hfp $ \h ->
  retMaybe =<< {#call git_remote_ls#} r h


Add documentation for MRL

Add documentation for MRL

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

-- |
-- Module      : Xine.Foreign
-- Copyright   : (c) Joachim Fasting 2010
-- License     : LGPL
-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>
-- Stability   : unstable
-- Portability : not portable
--
-- A simple binding to xine-lib. Low-level bindings.

module Xine.Foreign (
    -- * Version information
    xine_get_version_string, xine_get_version, xine_check_version,
    -- * Global engine handling
    Engine, AudioPort, VideoPort, VisualType(..),
    xine_new, xine_init, xine_open_audio_driver, xine_open_video_driver,
    xine_close_audio_driver, xine_close_video_driver, xine_exit,
    -- * Stream handling
    Stream, StreamParam(..), Speed(..), NormalSpeed(..), Zoom(..),
    AspectRatio(..), MRL, EngineParam(..),
    xine_stream_new, xine_open, xine_play, xine_stop, xine_close,
    xine_engine_set_param, xine_engine_get_param,
    xine_set_param, xine_get_param,
    -- * Information retrieval
    EngineStatus(..), XineError(..),
    xine_get_error, xine_get_status
    ) where

import Control.Monad (liftM)
import Foreign
import Foreign.C

#include <xine.h>

-- Define the name of the dynamic library that has to be loaded before any of
-- the external C functions may be invoked.
-- The prefix declaration allows us to refer to identifiers while omitting the
-- prefix. Prefix matching is case insensitive and any underscore characters
-- between the prefix and the stem of the identifiers are also removed.
{#context lib="xine" prefix="xine"#}

-- Opaque types used for structures that are never dereferenced on the
-- Haskell side.
{#pointer *xine_t as Engine foreign newtype#}
{#pointer *xine_audio_port_t as AudioPort foreign newtype#}
{#pointer *xine_video_port_t as VideoPort foreign newtype#}
{#pointer *xine_stream_t as Stream foreign newtype#}

newtype Data = Data (Ptr Data)

-- | Media Resource Locator.
-- Describes the media to read from. Valid MRLs may be plain file names or
-- one of the following:
--
-- * Filesystem:
--
-- file:\<path\>
--
-- fifo:\<path\>
--
-- stdin:\/
--
-- * CD and DVD:
--
-- dvd:\/[device_name][\/title[.part]]
--
-- dvd:\/DVD_image_file[\/title[.part]]
--
-- dvd:\/DVD_directory[\/title[.part]]
--
-- vcd:\/\/[CD_image_or_device_name][\@[letter]number]
--
-- vcdo:\/\/track_number
--
-- cdda:\/[device][\/track_number]
--
-- * Video devices:
--
-- v4l:\/\/[tuner_device\/frequency
--
-- v4l2:\/\/tuner_device
--
-- dvb:\/\/channel_number
--
-- dvb:\/\/channel_name
--
-- dvbc:\/\/channel_name:tuning_parameters
--
-- dvbs:\/\/channel_name:tuning_parameters
--
-- dvbt:\/\/channel_name:tuning_parameters
--
-- dvba:\/\/channel_name:tuning_parameters
--
-- pvr:\/tmp_files_path!saved_files_path!max_page_age
--
-- * Network:
--
-- http:\/\/host
--
-- tcp:\/\/host[:port]
--
-- udp:\/\/host[:port[?iface=interface]]
--
-- rtp:\/\/host[:port[?iface=interface]]
--
-- smb:\/\/
--
-- mms:\/\/host
--
-- pnm:\/\/host
--
-- rtsp:\/\/host
type MRL = String

------------------------------------------------------------------------------
-- Marshalling
------------------------------------------------------------------------------

int2bool = (/= 0)

cint2enum :: Enum a => CInt -> a
cint2enum = toEnum . fromIntegral

enum2cint :: Enum a => a -> CInt
enum2cint = fromIntegral . fromEnum

peekInt = liftM fromIntegral . peek

maybeForeignPtr_ c x | x == nullPtr = return Nothing
                     | otherwise    = (Just . c) `liftM` newForeignPtr_ x

peekEngine = liftM Engine . newForeignPtr_

peekAudioPort = maybeForeignPtr_ AudioPort

peekVideoPort = maybeForeignPtr_ VideoPort

peekStream = maybeForeignPtr_ Stream

withData f = f nullPtr

withMaybeString :: Maybe String -> (CString -> IO a) -> IO a
withMaybeString Nothing f  = f nullPtr
withMaybeString (Just s) f = withCString s f

------------------------------------------------------------------------------
-- Version information
------------------------------------------------------------------------------

-- | Get xine-lib version string.
--
-- Header declaration:
--
-- const char *xine_get_version_string (void)
{#fun pure xine_get_version_string {} -> `String' peekCString*#}

-- | Get version as a triple: major, minor, sub
--
-- Header declaration:
--
-- void xine_get_version (int *major, int *minor, int *sub)
{#fun pure xine_get_version
 {alloca- `Int' peekInt*,
  alloca- `Int' peekInt*,
  alloca- `Int' peekInt*} -> `()'#}

-- | Compare given version to xine-lib version (major, minor, sub).
--
-- Header declaration:
--
-- int xine_check_version (int major, int minor, int sub)
--
-- returns 1 if compatible, 0 otherwise.
{#fun pure xine_check_version
 {fromIntegral `Int',
  fromIntegral `Int',
  fromIntegral `Int'} -> `Bool' int2bool#}

------------------------------------------------------------------------------
-- Global engine handling
------------------------------------------------------------------------------

-- | Valid visual types
{#enum define VisualType {XINE_VISUAL_TYPE_NONE as None
                         ,XINE_VISUAL_TYPE_X11 as X11
                         ,XINE_VISUAL_TYPE_X11_2 as X11_2
                         ,XINE_VISUAL_TYPE_AA as AA
                         ,XINE_VISUAL_TYPE_FB as FB
                         ,XINE_VISUAL_TYPE_GTK as GTK
                         ,XINE_VISUAL_TYPE_DFB as DFB
                         ,XINE_VISUAL_TYPE_PM as PM
                         ,XINE_VISUAL_TYPE_DIRECTX as DirectX
                         ,XINE_VISUAL_TYPE_CACA as CACA
                         ,XINE_VISUAL_TYPE_MACOSX as MacOSX
                         ,XINE_VISUAL_TYPE_XCB as XCB
                         ,XINE_VISUAL_TYPE_RAW as Raw
                         }#}

-- | Pre-init the Xine engine.
--
-- Header declaration:
--
-- xine_t *xine_new (void)
{#fun unsafe xine_new {} -> `Engine' peekEngine*#}

-- | Post-init the Xine engine.
--
-- Header declaration:
--
-- void xine_init (xine_t *self)
{#fun unsafe xine_init {withEngine* `Engine'} -> `()'#}

-- | Initialise audio driver.
--
-- Header declaration:
--
-- xine_audio_port_t *xine_open_audio_driver (xine_t *self, const char *id,
--                        void *data)
--
-- id: identifier of the driver, may be NULL for auto-detection
--
-- data: special data struct for ui/driver communication
--
-- May return NULL if the driver failed to load.
{#fun unsafe xine_open_audio_driver
 {withEngine* `Engine'
 ,withMaybeString* `(Maybe String)'
 ,withData- `Data'} -> `(Maybe AudioPort)' peekAudioPort*#}

-- | Initialise video driver.
--
-- Header declaration:
--
-- xine_video_port_t *xine_open_video_driver (xine_t *self, const char *id,
--                        int visual, void *data)
--
-- id: identifier of the driver, may be NULL for auto-detection
--
-- data: special data struct for ui/driver communication
--
-- visual : video driver flavor selector
--
-- May return NULL if the driver failed to load.
{#fun unsafe xine_open_video_driver
 {withEngine* `Engine'
 ,withMaybeString* `(Maybe String)'
 ,enum2cint `VisualType'
 ,withData- `Data'} -> `(Maybe VideoPort)' peekVideoPort*#}

-- | Close audio port.
--
-- Header declaration:
--
-- void xine_close_audio_driver (xine_t *self, xine_audio_port_t *driver)
{#fun unsafe xine_close_audio_driver
 {withEngine* `Engine'
 ,withAudioPort* `AudioPort'} -> `()'#}

-- | Close video port.
--
-- Header declaration:
--
-- void xine_close_video_driver (xine_t *self, xine_video_port_t *driver)
{#fun unsafe xine_close_video_driver
 {withEngine* `Engine'
 ,withVideoPort* `VideoPort'} -> `()'#}

-- | Free all resources, close all plugins, close engine.
--
-- Header declaration:
--
-- void xine_exit (xine_t *self)
{#fun unsafe xine_exit {withEngine* `Engine'} -> `()'#}

------------------------------------------------------------------------------
-- Stream handling
------------------------------------------------------------------------------

-- | Engine parameter enumeration.
{#enum define EngineParam
           {XINE_ENGINE_PARAM_VERBOSITY as EngineVerbosity}#}

-- | Stream parameter enumeration.
{#enum define StreamParam
           {XINE_PARAM_SPEED as Speed
           ,XINE_PARAM_AV_OFFSET as AvOffset
           ,XINE_PARAM_AUDIO_CHANNEL_LOGICAL as AudioChannelLogical
           ,XINE_PARAM_SPU_CHANNEL as SpuChannel
           ,XINE_PARAM_AUDIO_VOLUME as AudioVolume
           ,XINE_PARAM_AUDIO_MUTE as AudioMute
           ,XINE_PARAM_AUDIO_COMPR_LEVEL as AudioComprLevel
           ,XINE_PARAM_AUDIO_REPORT_LEVEL as AudioReportLevel
           ,XINE_PARAM_VERBOSITY as Verbosity
           ,XINE_PARAM_SPU_OFFSET as SpuOffset
           ,XINE_PARAM_IGNORE_VIDEO as IgnoreVideo
           ,XINE_PARAM_IGNORE_AUDIO as IgnoreAudio
           ,XINE_PARAM_BROADCASTER_PORT as BroadcasterPort
           ,XINE_PARAM_METRONOM_PREBUFFER as MetronomPrebuffer
           ,XINE_PARAM_EQ_30HZ as Eq30Hz
           ,XINE_PARAM_EQ_60HZ as Eq60Hz
           ,XINE_PARAM_EQ_125HZ as Eq125Hz
           ,XINE_PARAM_EQ_500HZ as Eq500Hz
           ,XINE_PARAM_EQ_1000HZ as Eq1000Hz
           ,XINE_PARAM_EQ_2000HZ as Eq2000Hz
           ,XINE_PARAM_EQ_4000HZ as Eq4000Hz
           ,XINE_PARAM_EQ_8000HZ as Eq8000Hz
           ,XINE_PARAM_EQ_16000HZ as Eq16000Hz
           ,XINE_PARAM_AUDIO_CLOSE_DEVICE as AudioCloseDevice
           ,XINE_PARAM_AUDIO_AMP_MUTE as AmpMute
           ,XINE_PARAM_FINE_SPEED as FineSpeed
           ,XINE_PARAM_EARLY_FINISHED_EVENT as EarlyFinishedEvent
           ,XINE_PARAM_GAPLESS_SWITCH as GaplessSwitch
           ,XINE_PARAM_DELAY_FINISHED_EVENT as DelayFinishedEvent
           ,XINE_PARAM_VO_DEINTERLACE as Deinterlace
           ,XINE_PARAM_VO_ASPECT_RATIO as AspectRatio
           ,XINE_PARAM_VO_HUE as Hue
           ,XINE_PARAM_VO_SATURATION as Saturation
           ,XINE_PARAM_VO_CONTRAST as Contrast
           ,XINE_PARAM_VO_BRIGHTNESS as Brightness
           ,XINE_PARAM_VO_ZOOM_X as ZoomX
           ,XINE_PARAM_VO_ZOOM_Y as ZoomY
           ,XINE_PARAM_VO_PAN_SCAN as PanScan
           ,XINE_PARAM_VO_TVMODE as TvMode
           ,XINE_PARAM_VO_WINDOW_WIDTH as WindowWidth
           ,XINE_PARAM_VO_WINDOW_HEIGHT as WindowHeight
           ,XINE_PARAM_VO_CROP_LEFT as CropLeft
           ,XINE_PARAM_VO_CROP_RIGHT as CropRight
           ,XINE_PARAM_VO_CROP_TOP as CropTop
           ,XINE_PARAM_VO_CROP_BOTTOM as CropBottom
           }#}

-- | Values for XINE_PARAM_SPEED parameter.
{#enum define Speed
           {XINE_SPEED_PAUSE as Pause
           ,XINE_SPEED_SLOW_4 as Slow4
           ,XINE_SPEED_SLOW_2 as Slow2
           ,XINE_SPEED_NORMAL as Normal
           ,XINE_SPEED_FAST_2 as Fast2
           ,XINE_SPEED_FAST_4 as Fast4
           }#}

deriving instance Eq Speed

-- | Value for XINE_PARAM_FINE_SPEED
{#enum define NormalSpeed
           {XINE_FINE_SPEED_NORMAL as NormalSpeed}#}

-- | Values for XINE_PARAM_VO_ZOOM_
{#enum define Zoom
           {XINE_VO_ZOOM_STEP as ZoomStep
           ,XINE_VO_ZOOM_MAX as ZoomMax
           ,XINE_VO_ZOOM_MIN as ZoomMin}#}

-- | Values for XINE_PARAM_VO_ASPECT_RATIO
{#enum define AspectRatio
           {XINE_VO_ASPECT_AUTO as AspectAuto
           ,XINE_VO_ASPECT_SQUARE as AspectSquare
           ,XINE_VO_ASPECT_4_3 as Aspect43
           ,XINE_VO_ASPECT_ANAMORPHIC as AspectAnamorphic
           ,XINE_VO_ASPECT_DVB as AspectDvb
           ,XINE_VO_ASPECT_NUM_RATIOS as AspectNumRatios
           }#}

-- | Create a new stream for media playback.
--
-- Header declaration:
--
-- xine_stream_t *xine_stream_new (xine_t *self,
--     xine_audio_port *ao, xine_video_port_t *vo)
--
-- Returns xine_stream_t* if OK, NULL on error.
{#fun unsafe xine_stream_new
 {withEngine* `Engine'
 ,withAudioPort* `AudioPort'
 ,withVideoPort* `VideoPort'} -> `(Maybe Stream)' peekStream*#}

-- | Open a stream.
--
-- Header declaration:
--
-- int xine_open (xine_stream_t *stream, const char *mrl)
--
-- Returns 1 if OK, 0 on error.
{#fun unsafe xine_open
 {withStream* `Stream'
 ,withCAString* `MRL'} -> `Int' fromIntegral#}

-- | Play a stream from a given position.
--
-- Header declaration:
--
-- int xine_play (xine_stream_t *stream, int start_pos, int start_time)
--
-- Returns 1 if OK, 0 on error.
{#fun unsafe xine_play
 {withStream* `Stream'
 ,fromIntegral `Int'
 ,fromIntegral `Int'} -> `Int' fromIntegral#}

-- | Stop stream playback.
-- The stream stays valid for new 'xine_open' or 'xine_play'.
--
-- Header declaration:
--
-- void xine_stop (xine_stream *stream)
{#fun unsafe xine_stop {withStream* `Stream'} -> `()'#}

-- | Free all stream-related resources.
-- The stream stays valid for new xine_open.
--
-- Header declaration:
--
-- void xine_close (xine_stream_t *stream)
{#fun unsafe xine_close {withStream* `Stream'} -> `()'#}

-- | Set engine parameter.
--
-- Header declaration:
--
-- void xine_engine_set_param (xine_t *self, int param, int value)
{#fun unsafe xine_engine_set_param
 {withEngine* `Engine'
 ,enum2cint `EngineParam'
 ,fromIntegral `Int'} -> `()'#}

-- | Get engine parameter.
--
-- Header declaration:
--
-- int xine_engine_get_param(xine_t *self, int param)
{#fun unsafe xine_engine_get_param
 {withEngine* `Engine'
 ,enum2cint `EngineParam'} -> `Int' fromIntegral#}

-- | Set stream parameter.
--
-- Header declaration:
--
-- void xine_set_param (xine_stream_t *stream, int param, int value)
{#fun unsafe xine_set_param
 `(Enum a)' =>
 {withStream* `Stream'
 ,enum2cint `StreamParam'
 ,enum2cint `a'} -> `()'#}

-- | Get stream parameter.
--
-- Header declaration:
--
-- int xine_get_param (xine_stream_t *stream, int param)
{#fun unsafe xine_get_param
 `(Enum a)' =>
 {withStream* `Stream'
 ,enum2cint `StreamParam'} -> `a' cint2enum#}

------------------------------------------------------------------------------
-- Information retrieval
------------------------------------------------------------------------------

-- | Engine status codes.
{#enum define EngineStatus
           {XINE_STATUS_IDLE as Idle
           ,XINE_STATUS_STOP as Stopped
           ,XINE_STATUS_PLAY as Playing
           ,XINE_STATUS_QUIT as Quitting}#}

deriving instance Eq EngineStatus
deriving instance Show EngineStatus

-- | Xine error codes.
{#enum define XineError
           {XINE_ERROR_NONE as NoError
           ,XINE_ERROR_NO_INPUT_PLUGIN as NoInputPlugin
           ,XINE_ERROR_NO_DEMUX_PLUGIN as NoDemuxPlugin
           ,XINE_ERROR_MALFORMED_MRL as MalformedMrl
           ,XINE_ERROR_INPUT_FAILED as InputFailed}#}

deriving instance Eq XineError
deriving instance Show XineError

-- | Return last error.
--
-- Header declaration:
--
-- int xine_get_error (xine_stream_t *stream)
{#fun unsafe xine_get_error
 {withStream* `Stream'} -> `XineError' cint2enum#}

-- | Get current xine engine status.
--
-- int xine_get_status (xine_stream_t *stream)
{#fun unsafe xine_get_status
 {withStream* `Stream'} -> `EngineStatus' cint2enum#}

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

-- |
-- Module      : Xine.Foreign
-- Copyright   : (c) Joachim Fasting 2010
-- License     : LGPL
-- Maintainer  : Joachim Fasting <joachim.fasting@gmail.com>
-- Stability   : unstable
-- Portability : not portable
--
-- A simple binding to xine-lib. Low-level bindings.

module Xine.Foreign (
    -- * Version information
    xine_get_version_string, xine_get_version, xine_check_version,
    -- * Global engine handling
    Engine, AudioPort, VideoPort, VisualType(..),
    xine_new, xine_init, xine_open_audio_driver, xine_open_video_driver,
    xine_close_audio_driver, xine_close_video_driver, xine_exit,
    -- * Stream handling
    Stream, StreamParam(..), Speed(..), NormalSpeed(..), Zoom(..),
    AspectRatio(..), MRL, EngineParam(..),
    xine_stream_new, xine_open, xine_play, xine_stop, xine_close,
    xine_engine_set_param, xine_engine_get_param,
    xine_set_param, xine_get_param,
    -- * Information retrieval
    EngineStatus(..), XineError(..),
    xine_get_error, xine_get_status
    ) where

import Control.Monad (liftM)
import Foreign
import Foreign.C

#include <xine.h>

-- Define the name of the dynamic library that has to be loaded before any of
-- the external C functions may be invoked.
-- The prefix declaration allows us to refer to identifiers while omitting the
-- prefix. Prefix matching is case insensitive and any underscore characters
-- between the prefix and the stem of the identifiers are also removed.
{#context lib="xine" prefix="xine"#}

-- Opaque types used for structures that are never dereferenced on the
-- Haskell side.
{#pointer *xine_t as Engine foreign newtype#}
{#pointer *xine_audio_port_t as AudioPort foreign newtype#}
{#pointer *xine_video_port_t as VideoPort foreign newtype#}
{#pointer *xine_stream_t as Stream foreign newtype#}

newtype Data = Data (Ptr Data)

-- | Media Resource Locator.
type MRL = String

------------------------------------------------------------------------------
-- Marshalling
------------------------------------------------------------------------------

int2bool = (/= 0)

cint2enum :: Enum a => CInt -> a
cint2enum = toEnum . fromIntegral

enum2cint :: Enum a => a -> CInt
enum2cint = fromIntegral . fromEnum

peekInt = liftM fromIntegral . peek

maybeForeignPtr_ c x | x == nullPtr = return Nothing
                     | otherwise    = (Just . c) `liftM` newForeignPtr_ x

peekEngine = liftM Engine . newForeignPtr_

peekAudioPort = maybeForeignPtr_ AudioPort

peekVideoPort = maybeForeignPtr_ VideoPort

peekStream = maybeForeignPtr_ Stream

withData f = f nullPtr

withMaybeString :: Maybe String -> (CString -> IO a) -> IO a
withMaybeString Nothing f  = f nullPtr
withMaybeString (Just s) f = withCString s f

------------------------------------------------------------------------------
-- Version information
------------------------------------------------------------------------------

-- | Get xine-lib version string.
--
-- Header declaration:
--
-- const char *xine_get_version_string (void)
{#fun pure xine_get_version_string {} -> `String' peekCString*#}

-- | Get version as a triple: major, minor, sub
--
-- Header declaration:
--
-- void xine_get_version (int *major, int *minor, int *sub)
{#fun pure xine_get_version
 {alloca- `Int' peekInt*,
  alloca- `Int' peekInt*,
  alloca- `Int' peekInt*} -> `()'#}

-- | Compare given version to xine-lib version (major, minor, sub).
--
-- Header declaration:
--
-- int xine_check_version (int major, int minor, int sub)
--
-- returns 1 if compatible, 0 otherwise.
{#fun pure xine_check_version
 {fromIntegral `Int',
  fromIntegral `Int',
  fromIntegral `Int'} -> `Bool' int2bool#}

------------------------------------------------------------------------------
-- Global engine handling
------------------------------------------------------------------------------

-- | Valid visual types
{#enum define VisualType {XINE_VISUAL_TYPE_NONE as None
                         ,XINE_VISUAL_TYPE_X11 as X11
                         ,XINE_VISUAL_TYPE_X11_2 as X11_2
                         ,XINE_VISUAL_TYPE_AA as AA
                         ,XINE_VISUAL_TYPE_FB as FB
                         ,XINE_VISUAL_TYPE_GTK as GTK
                         ,XINE_VISUAL_TYPE_DFB as DFB
                         ,XINE_VISUAL_TYPE_PM as PM
                         ,XINE_VISUAL_TYPE_DIRECTX as DirectX
                         ,XINE_VISUAL_TYPE_CACA as CACA
                         ,XINE_VISUAL_TYPE_MACOSX as MacOSX
                         ,XINE_VISUAL_TYPE_XCB as XCB
                         ,XINE_VISUAL_TYPE_RAW as Raw
                         }#}

-- | Pre-init the Xine engine.
--
-- Header declaration:
--
-- xine_t *xine_new (void)
{#fun unsafe xine_new {} -> `Engine' peekEngine*#}

-- | Post-init the Xine engine.
--
-- Header declaration:
--
-- void xine_init (xine_t *self)
{#fun unsafe xine_init {withEngine* `Engine'} -> `()'#}

-- | Initialise audio driver.
--
-- Header declaration:
--
-- xine_audio_port_t *xine_open_audio_driver (xine_t *self, const char *id,
--                        void *data)
--
-- id: identifier of the driver, may be NULL for auto-detection
--
-- data: special data struct for ui/driver communication
--
-- May return NULL if the driver failed to load.
{#fun unsafe xine_open_audio_driver
 {withEngine* `Engine'
 ,withMaybeString* `(Maybe String)'
 ,withData- `Data'} -> `(Maybe AudioPort)' peekAudioPort*#}

-- | Initialise video driver.
--
-- Header declaration:
--
-- xine_video_port_t *xine_open_video_driver (xine_t *self, const char *id,
--                        int visual, void *data)
--
-- id: identifier of the driver, may be NULL for auto-detection
--
-- data: special data struct for ui/driver communication
--
-- visual : video driver flavor selector
--
-- May return NULL if the driver failed to load.
{#fun unsafe xine_open_video_driver
 {withEngine* `Engine'
 ,withMaybeString* `(Maybe String)'
 ,enum2cint `VisualType'
 ,withData- `Data'} -> `(Maybe VideoPort)' peekVideoPort*#}

-- | Close audio port.
--
-- Header declaration:
--
-- void xine_close_audio_driver (xine_t *self, xine_audio_port_t *driver)
{#fun unsafe xine_close_audio_driver
 {withEngine* `Engine'
 ,withAudioPort* `AudioPort'} -> `()'#}

-- | Close video port.
--
-- Header declaration:
--
-- void xine_close_video_driver (xine_t *self, xine_video_port_t *driver)
{#fun unsafe xine_close_video_driver
 {withEngine* `Engine'
 ,withVideoPort* `VideoPort'} -> `()'#}

-- | Free all resources, close all plugins, close engine.
--
-- Header declaration:
--
-- void xine_exit (xine_t *self)
{#fun unsafe xine_exit {withEngine* `Engine'} -> `()'#}

------------------------------------------------------------------------------
-- Stream handling
------------------------------------------------------------------------------

-- | Engine parameter enumeration.
{#enum define EngineParam
           {XINE_ENGINE_PARAM_VERBOSITY as EngineVerbosity}#}

-- | Stream parameter enumeration.
{#enum define StreamParam
           {XINE_PARAM_SPEED as Speed
           ,XINE_PARAM_AV_OFFSET as AvOffset
           ,XINE_PARAM_AUDIO_CHANNEL_LOGICAL as AudioChannelLogical
           ,XINE_PARAM_SPU_CHANNEL as SpuChannel
           ,XINE_PARAM_AUDIO_VOLUME as AudioVolume
           ,XINE_PARAM_AUDIO_MUTE as AudioMute
           ,XINE_PARAM_AUDIO_COMPR_LEVEL as AudioComprLevel
           ,XINE_PARAM_AUDIO_REPORT_LEVEL as AudioReportLevel
           ,XINE_PARAM_VERBOSITY as Verbosity
           ,XINE_PARAM_SPU_OFFSET as SpuOffset
           ,XINE_PARAM_IGNORE_VIDEO as IgnoreVideo
           ,XINE_PARAM_IGNORE_AUDIO as IgnoreAudio
           ,XINE_PARAM_BROADCASTER_PORT as BroadcasterPort
           ,XINE_PARAM_METRONOM_PREBUFFER as MetronomPrebuffer
           ,XINE_PARAM_EQ_30HZ as Eq30Hz
           ,XINE_PARAM_EQ_60HZ as Eq60Hz
           ,XINE_PARAM_EQ_125HZ as Eq125Hz
           ,XINE_PARAM_EQ_500HZ as Eq500Hz
           ,XINE_PARAM_EQ_1000HZ as Eq1000Hz
           ,XINE_PARAM_EQ_2000HZ as Eq2000Hz
           ,XINE_PARAM_EQ_4000HZ as Eq4000Hz
           ,XINE_PARAM_EQ_8000HZ as Eq8000Hz
           ,XINE_PARAM_EQ_16000HZ as Eq16000Hz
           ,XINE_PARAM_AUDIO_CLOSE_DEVICE as AudioCloseDevice
           ,XINE_PARAM_AUDIO_AMP_MUTE as AmpMute
           ,XINE_PARAM_FINE_SPEED as FineSpeed
           ,XINE_PARAM_EARLY_FINISHED_EVENT as EarlyFinishedEvent
           ,XINE_PARAM_GAPLESS_SWITCH as GaplessSwitch
           ,XINE_PARAM_DELAY_FINISHED_EVENT as DelayFinishedEvent
           ,XINE_PARAM_VO_DEINTERLACE as Deinterlace
           ,XINE_PARAM_VO_ASPECT_RATIO as AspectRatio
           ,XINE_PARAM_VO_HUE as Hue
           ,XINE_PARAM_VO_SATURATION as Saturation
           ,XINE_PARAM_VO_CONTRAST as Contrast
           ,XINE_PARAM_VO_BRIGHTNESS as Brightness
           ,XINE_PARAM_VO_ZOOM_X as ZoomX
           ,XINE_PARAM_VO_ZOOM_Y as ZoomY
           ,XINE_PARAM_VO_PAN_SCAN as PanScan
           ,XINE_PARAM_VO_TVMODE as TvMode
           ,XINE_PARAM_VO_WINDOW_WIDTH as WindowWidth
           ,XINE_PARAM_VO_WINDOW_HEIGHT as WindowHeight
           ,XINE_PARAM_VO_CROP_LEFT as CropLeft
           ,XINE_PARAM_VO_CROP_RIGHT as CropRight
           ,XINE_PARAM_VO_CROP_TOP as CropTop
           ,XINE_PARAM_VO_CROP_BOTTOM as CropBottom
           }#}

-- | Values for XINE_PARAM_SPEED parameter.
{#enum define Speed
           {XINE_SPEED_PAUSE as Pause
           ,XINE_SPEED_SLOW_4 as Slow4
           ,XINE_SPEED_SLOW_2 as Slow2
           ,XINE_SPEED_NORMAL as Normal
           ,XINE_SPEED_FAST_2 as Fast2
           ,XINE_SPEED_FAST_4 as Fast4
           }#}

deriving instance Eq Speed

-- | Value for XINE_PARAM_FINE_SPEED
{#enum define NormalSpeed
           {XINE_FINE_SPEED_NORMAL as NormalSpeed}#}

-- | Values for XINE_PARAM_VO_ZOOM_
{#enum define Zoom
           {XINE_VO_ZOOM_STEP as ZoomStep
           ,XINE_VO_ZOOM_MAX as ZoomMax
           ,XINE_VO_ZOOM_MIN as ZoomMin}#}

-- | Values for XINE_PARAM_VO_ASPECT_RATIO
{#enum define AspectRatio
           {XINE_VO_ASPECT_AUTO as AspectAuto
           ,XINE_VO_ASPECT_SQUARE as AspectSquare
           ,XINE_VO_ASPECT_4_3 as Aspect43
           ,XINE_VO_ASPECT_ANAMORPHIC as AspectAnamorphic
           ,XINE_VO_ASPECT_DVB as AspectDvb
           ,XINE_VO_ASPECT_NUM_RATIOS as AspectNumRatios
           }#}

-- | Create a new stream for media playback.
--
-- Header declaration:
--
-- xine_stream_t *xine_stream_new (xine_t *self,
--     xine_audio_port *ao, xine_video_port_t *vo)
--
-- Returns xine_stream_t* if OK, NULL on error.
{#fun unsafe xine_stream_new
 {withEngine* `Engine'
 ,withAudioPort* `AudioPort'
 ,withVideoPort* `VideoPort'} -> `(Maybe Stream)' peekStream*#}

-- | Open a stream.
--
-- Header declaration:
--
-- int xine_open (xine_stream_t *stream, const char *mrl)
--
-- Returns 1 if OK, 0 on error.
{#fun unsafe xine_open
 {withStream* `Stream'
 ,withCAString* `MRL'} -> `Int' fromIntegral#}

-- | Play a stream from a given position.
--
-- Header declaration:
--
-- int xine_play (xine_stream_t *stream, int start_pos, int start_time)
--
-- Returns 1 if OK, 0 on error.
{#fun unsafe xine_play
 {withStream* `Stream'
 ,fromIntegral `Int'
 ,fromIntegral `Int'} -> `Int' fromIntegral#}

-- | Stop stream playback.
-- The stream stays valid for new 'xine_open' or 'xine_play'.
--
-- Header declaration:
--
-- void xine_stop (xine_stream *stream)
{#fun unsafe xine_stop {withStream* `Stream'} -> `()'#}

-- | Free all stream-related resources.
-- The stream stays valid for new xine_open.
--
-- Header declaration:
--
-- void xine_close (xine_stream_t *stream)
{#fun unsafe xine_close {withStream* `Stream'} -> `()'#}

-- | Set engine parameter.
--
-- Header declaration:
--
-- void xine_engine_set_param (xine_t *self, int param, int value)
{#fun unsafe xine_engine_set_param
 {withEngine* `Engine'
 ,enum2cint `EngineParam'
 ,fromIntegral `Int'} -> `()'#}

-- | Get engine parameter.
--
-- Header declaration:
--
-- int xine_engine_get_param(xine_t *self, int param)
{#fun unsafe xine_engine_get_param
 {withEngine* `Engine'
 ,enum2cint `EngineParam'} -> `Int' fromIntegral#}

-- | Set stream parameter.
--
-- Header declaration:
--
-- void xine_set_param (xine_stream_t *stream, int param, int value)
{#fun unsafe xine_set_param
 `(Enum a)' =>
 {withStream* `Stream'
 ,enum2cint `StreamParam'
 ,enum2cint `a'} -> `()'#}

-- | Get stream parameter.
--
-- Header declaration:
--
-- int xine_get_param (xine_stream_t *stream, int param)
{#fun unsafe xine_get_param
 `(Enum a)' =>
 {withStream* `Stream'
 ,enum2cint `StreamParam'} -> `a' cint2enum#}

------------------------------------------------------------------------------
-- Information retrieval
------------------------------------------------------------------------------

-- | Engine status codes.
{#enum define EngineStatus
           {XINE_STATUS_IDLE as Idle
           ,XINE_STATUS_STOP as Stopped
           ,XINE_STATUS_PLAY as Playing
           ,XINE_STATUS_QUIT as Quitting}#}

deriving instance Eq EngineStatus
deriving instance Show EngineStatus

-- | Xine error codes.
{#enum define XineError
           {XINE_ERROR_NONE as NoError
           ,XINE_ERROR_NO_INPUT_PLUGIN as NoInputPlugin
           ,XINE_ERROR_NO_DEMUX_PLUGIN as NoDemuxPlugin
           ,XINE_ERROR_MALFORMED_MRL as MalformedMrl
           ,XINE_ERROR_INPUT_FAILED as InputFailed}#}

deriving instance Eq XineError
deriving instance Show XineError

-- | Return last error.
--
-- Header declaration:
--
-- int xine_get_error (xine_stream_t *stream)
{#fun unsafe xine_get_error
 {withStream* `Stream'} -> `XineError' cint2enum#}

-- | Get current xine engine status.
--
-- int xine_get_status (xine_stream_t *stream)
{#fun unsafe xine_get_status
 {withStream* `Stream'} -> `EngineStatus' cint2enum#}