BufferIterator.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}

-- | FFI module for Buffer iterators
module GEGL.FFI.Buffer.BufferIterator
  ( GeglBufferIterator(..)
  , GeglBufferIteratorDummy
  , c_gegl_buffer_iterator_new
  , c_gegl_buffer_iterator_next
  , ComponentValue(..)
  , c_gegl_peek_data
  , c_gegl_peek_roi
  , c_gegl_poke_data
  ) where

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

import GEGL.FFI.Rectangle (GeglRectangle(..))
import GEGL.FFI.Buffer    (GeglBufferDummy)
import GEGL.FFI.Tuple

import BABL.FFI.Format    (BablFormatDummy)
import BABL.Format

import Data.Monoid ((<>))

import qualified Language.C.Inline as C
import qualified Language.C.Types as C
import qualified Language.C.Inline.Context as C

import Debug.Trace

C.context (C.baseCtx <> tupleCtx)

-- DEBUGGING

C.include "<assert.h>"

-- /DEBUGGING

C.include "<gegl.h>"
C.include "../Tuple.h"

newtype GeglBufferIterator = GeglBufferIterator GeglBufferIteratorDummy

type GeglBufferIteratorDummy = Ptr ()

-- | Interface the the @gegl_buffer_iterator_new@ function in C.
foreign import ccall unsafe "gegl.h gegl_buffer_iterator_new"
  c_gegl_buffer_iterator_new
    :: GeglBufferDummy   -- ^ Buffer to draw data from
    -> Ptr GeglRectangle -- ^ Rectangle to iterate over
    -> CInt              -- ^ Representation of level
    -> BablFormatDummy   -- ^ Format to process the buffer data in
    -> CInt              -- ^ Representation of set 'GeglAccessMode'
    -> CInt              -- ^ Representation of set 'GeglAbyssPolicy'
    -> IO GeglBufferIteratorDummy

-- | Interface to the @gegl_buffer_iterator_next@ function in C.
foreign import ccall unsafe "gegl.h gegl_buffer_iterator_next"
  c_gegl_buffer_iterator_next
    :: GeglBufferIteratorDummy -- ^ Iterator to manipulate
    -> IO Bool

-- | Container type for component values
data ComponentValue
  = CVhalf CUShort
  | CVfloat CFloat
  | CVdouble CDouble
  | CVu8 CUChar
  | CVu15 CUShort
  | CVu16 CUShort
  | CVu32 CUInt
  | CVa8 CUChar
  | CVrgb24 CUChar
  | CVrgba32 CUChar

-- | Get the list of pixel data out of a 'GeglBufferIterator'.
c_gegl_peek_data
  :: GeglBufferIteratorDummy -- ^ Iterator to take data from
  -> PixelFormat             -- ^ Pixel format of iterator
  -> IO [ComponentValue]
c_gegl_peek_data ptr form = do
  let pitch = babl_components_per_pixel form
  case pfType form of
    CFfloat -> do
      tupPtr <- [C.block| tupleFloat * {
        static GeglBufferIterator * cptr = NULL;
        static tupleFloat tuple;
        cptr = (GeglBufferIterator *)$(void * ptr);
        tuple.length = cptr->length;
        tuple.data = (float *)cptr->data[0];
        return &tuple;
        }|]
      tup <- peek tupPtr
      let clength = tupleFloatLength tup
          fptr    = tupleFloatData tup
          flength (CInt c) = fromIntegral c :: Int
          length = flength clength
      arr <- peekArray (length * pitch) fptr
      return $ map CVfloat arr
    CFdouble -> do
      tupPtr <- [C.block| tupleDouble * {
        static GeglBufferIterator * cptr = NULL;
        static tupleDouble tuple;
        cptr = (GeglBufferIterator *)$(void * ptr);
        tuple.length = cptr->length;
        tuple.data = (double *)cptr->data[0];
        return &tuple;
        }|]
      tup <- peek tupPtr
      let clength = tupleDoubleLength tup
          dptr    = tupleDoubleData tup
          dlength (CInt c) = fromIntegral c :: Int
          length = dlength clength
      arr <- peekArray (length * pitch) dptr
      return $ map CVdouble arr
    _ ->
      error "not yet implemented!"

-- | Returns the current roi Rectangle
c_gegl_peek_roi
  :: GeglBufferIteratorDummy -- ^ Iterator to peek data from
  -> IO GeglRectangle        -- ^ Rectangle of interest
c_gegl_peek_roi ptr = do
  roiptr <- [C.block| void * {
    static void * a = NULL;
    static GeglBufferIterator * cptr = NULL;
    cptr = (GeglBufferIterator *)$(void * ptr);
    a = (void *)&cptr->roi[0];
    return a;
    }|]
  peek (castPtr roiptr :: Ptr GeglRectangle)

-- | Return a list of pixel data to a 'GeglBufferIterator'
c_gegl_poke_data
  :: GeglBufferIteratorDummy -- ^ Iterator to return data to
  -> [ComponentValue]                -- ^ Pixel data
  -> PixelFormat             -- ^ Format the data are in
  -> IO ()
c_gegl_poke_data ptr vs form =
  case pfType form of
    CFfloat -> do
      let rfs = map (\(CVfloat f) -> f) vs
      rptr <- [C.block| float * {
        static GeglBufferIterator * cptr = NULL;
        static float * a = NULL;
        cptr = $(void * ptr);
        a = (float *) cptr->data[0];
        assert(a != NULL);
        return a;
      }|]
      pokeArray rptr rfs
    CFdouble -> do
      let rfs = map (\(CVdouble d) -> d) vs
      rptr <- [C.block| double * {
        static GeglBufferIterator * cptr;
        static double * a;
        cptr = $(void * ptr);
        a = (double *) cptr->data[0];
        assert(a != NULL);
        return a;
      }|]
      pokeArray rptr rfs
    _ -> error "not yet implemented"