bitmap-0.0.2: Data/Bitmap/IO.hs
--------------------------------------------------------------------------------
-- Module : Data.Bitmap.IO
-- Version : 0.0.2
-- License : BSD3
-- Copyright : (c) 2009-2010 Balazs Komuves
-- Author : Balazs Komuves
-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com
-- Stability : experimental
-- Portability : requires FFI and CPP
-- Tested with : GHC 6.10.1
--------------------------------------------------------------------------------
-- | The full, mutable API in the IO monad.
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
{-# CFILES cbits/bm.c #-} -- for Hugs
module Data.Bitmap.IO
(
module Data.Bitmap.Base
-- * Mutable bitmap type
, IOBitmap
, IOBitmapChannel
, unsafeFreezeBitmap
, unsafeThawBitmap
-- * Creating and accessing bitmaps
, emptyBitmap
, cloneBitmap
, emptyCloneBitmap
, createSingleChannelBitmap
, newIOBitmap
, newIOBitmapUninitialized
, copyBitmapFromPtr
-- , bitmapFromForeignPtrUnsafe
, ioBitmapFromForeignPtrUnsafe
-- * Using bitmaps
, withIOBitmap
-- * Mapping over bitmaps
, componentMap
, componentMap'
, componentMapInPlace
-- * Cropping and extending
, copySubImage
, copySubImage'
, copySubImageInto
-- * Flipping and mirroring
, flipBitmap
, flipBitmapInPlace
, mirrorBitmap
, mirrorBitmapInPlace
-- * Cast
, castBitmap
-- , castChannel
-- , castChannelInto
-- * Manipulating channels
, combineChannels
, extractChannels
, extractSingleChannel
, extractChannelInto
-- * Bilinear resampling
, bilinearResample
, bilinearResampleChannel
, bilinearResampleChannelInto
-- * Blending
, blendBitmaps
, blendChannels
, blendChannelsInto
-- * Gamma correction
, powerlawGammaCorrection
, powerlawGammaCorrectionChannel
, powerlawGammaCorrectionChannelInto
{-
-- * Conversion to\/from ByteString
, copyBitmapToByteString
, copyBitmapFromByteString
-}
{-
-- * Reading and writing pixels
, withComponentPtr
, IOBitmap1 (..)
, IOBitmap2 (..)
, IOBitmap3 (..)
, IOBitmap4 (..)
, unsafeReadComponent
, unsafeWriteComponent
, unsafeReadComponents
, unsafeWriteComponents
, unsafeReadPixel
, unsafeReadPixel1
, unsafeReadPixel2
, unsafeReadPixel3
, unsafeReadPixel4
, unsafeWritePixel1
, unsafeWritePixel2
, unsafeWritePixel3
, unsafeWritePixel4
-}
)
where
--------------------------------------------------------------------------------
import Control.Monad
import Control.Applicative
--import Data.Array.IArray
import Data.Word
import Data.List (nub)
import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.Marshal
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.Bitmap.Internal
import Data.Bitmap.Base
--------------------------------------------------------------------------------
unsafeFreezeBitmap :: IOBitmap t -> Bitmap t
unsafeFreezeBitmap = unIOBitmap
unsafeThawBitmap :: Bitmap t -> IOBitmap t
unsafeThawBitmap = IOBitmap
--------------------------------------------------------------------------------
defaultAlignment :: Int
defaultAlignment = 4
validateMaybeAlignment :: Maybe Alignment -> Alignment
validateMaybeAlignment = maybe defaultAlignment validateAlignment
validateAlignment :: Alignment -> Alignment
validateAlignment k =
if isValidAlignment k
then k
else error "invalid row alignment (allowed values: 1, 2, 4, and 8)" -- and 16)"
--------------------------------------------------------------------------------
-- GHC's type inference is acting up, that's why we need this here
allocBitmap :: PixelComponent t => Bitmap t -> IO (Bitmap t)
allocBitmap bm0 = do
fptr <- mallocForeignPtrBytes (bitmapSizeInBytes bm0) -- :: IO (ForeignPtr t)
return $ bm0 { _bitmapPtr = fptr }
allocIOBitmap :: PixelComponent t => IOBitmap t -> IO (IOBitmap t)
allocIOBitmap bm = IOBitmap <$> (allocBitmap $ unIOBitmap bm)
-- we do not initialize the new bitmap!
newBitmapRaw :: PixelComponent t => Size -> NChn -> Padding -> Alignment -> IO (IOBitmap t)
newBitmapRaw siz nchn pad align = do
let bm0 = Bitmap
{ _bitmapSize = siz
, _bitmapNChannels = nchn
, _bitmapPtr = undefined
, _bitmapRowPadding = pad
, _bitmapRowAlignment = align
} -- :: Bitmap t
{-
let len = bitmapSizeInBytes bm0
fptr <- mallocForeignPtrBytes len -- :: IO (ForeignPtr t)
return $ bm0 { bitmapPtr = fptr }
-}
IOBitmap <$> allocBitmap bm0
-- | Note: we /cannot/ guarantee the alignment
-- of the memory block (but typically it is aligned at least to machine word boundary),
-- but what we /can/ guarantee is that the rows are properly padded.
--
-- At the moment, the default alignment is 4, valid alignments are 1, 2, 4, 8 and 16,
-- and the padding method is compatible with the OpenGL one (that is, the padding is the
-- smallest multiple of a component size such that the next row is aligned).
--
-- The resulting new bitmap is filled with zeros.
newIOBitmap
:: PixelComponent t
=> Size -- ^ (width,height)
-> NChn -- ^ number of channels (components\/pixel)
-> Maybe Alignment -- ^ the row alignment of the new image
-> IO (IOBitmap t)
newIOBitmap siz nchn malign = do
bm <- newIOBitmapUninitialized siz nchn malign -- :: IO (Bitmap t)
let fptr = bitmapPtr bm
len = bitmapSizeInBytes bm
withForeignPtr fptr $ \p -> c_memset (castPtr p) len 0
return bm
allocBitmapWithRecommendedPadding :: PixelComponent t => Bitmap t -> IO (Bitmap t)
allocBitmapWithRecommendedPadding bm0 =
allocBitmap $
bm0 { _bitmapRowPadding = recommendedPadding bm0 }
newIOBitmapUninitialized :: PixelComponent t => Size -> NChn -> Maybe Alignment -> IO (IOBitmap t)
newIOBitmapUninitialized siz nchn malign = do
let align = validateMaybeAlignment malign
bm0 = Bitmap
{ _bitmapSize = siz
, _bitmapNChannels = nchn
, _bitmapPtr = undefined
, _bitmapRowPadding = undefined -- pad
, _bitmapRowAlignment = align
} -- :: Bitmap t
{-
let pad = recommendedPadding bm0
newBitmapRaw siz nchn pad align
-}
bm <- allocBitmapWithRecommendedPadding bm0
return (IOBitmap bm)
-- | Creates a new single-channel bitmap, using the given function to compute
-- the pixel values.
-- Warning, this is probably slow!
createSingleChannelBitmap
:: PixelComponent t
=> Size -- ^ (width,height)
-> Maybe Alignment -- ^ the row alignment of the new image
-> (Int -> Int -> t) -- ^ the function we will use to fill the bitmap
-> IO (IOBitmap t)
createSingleChannelBitmap siz malign fun = do
bm <- newIOBitmapUninitialized siz 1 malign
let fptr = bitmapPtr bm
len = bitmapSizeInBytes bm
-- f :: Int -> Int -> t -> t
f x y _ = fun x y
genericComponentMapWithPos f bm bm
return bm
{-
createBitmap
:: PixelComponent t
=> Size -- ^ (width,height)
-> Maybe Alignment -- ^ the row alignment of the new image
-> [Int -> Int -> t] -- ^ the functions we will use to fill the bitmap
-> IO (Bitmap t)
createBitmap siz malign funs = do
let nchn = length funs
bm <- newIOBitmapUninitialized siz nchn malign
let fptr = bitmapPtr bm
len = bitmapSizeInBytes bm
f :: Int -> Int -> t -> t
f x y _ = fun x y
genericComponentMapWithPos f bm bm
return bm
-}
copyBitmapFromPtr
:: PixelComponent t
=> Size -- ^ (width,height) of the source
-> NChn -- ^ number of channels in the source
-> Padding -- ^ source padding
-> Ptr t -- ^ the source
-> Maybe Alignment -- ^ target alignment
-> IO (IOBitmap t)
copyBitmapFromPtr siz@(w,h) nchn srcpad srcptr tgtmalign = do
bm <- newIOBitmapUninitialized siz nchn tgtmalign
withIOBitmap bm $ \_ _ _ tgtptr -> do
let pure_line = bitmapUnpaddedRowSizeInBytes bm
src_line = pure_line + srcpad
tgt_line = bitmapPaddedRowSizeInBytes bm
forM_ [0..h-1] $ \y -> do
let p = srcptr `myPlusPtr` (y*src_line)
q = tgtptr `myPlusPtr` (y*tgt_line)
c_memcpy (castPtr p) (castPtr q) pure_line
return bm
ioBitmapFromForeignPtrUnsafe
:: PixelComponent t
=> Size -> NChn -> Alignment -> Padding -> ForeignPtr t -> IOBitmap t
ioBitmapFromForeignPtrUnsafe siz nchn align pad fptr = IOBitmap $
bitmapFromForeignPtrUnsafe siz nchn align pad fptr
-- | @withIOBitmap bitmap $ \\(w,h) nchn padding ptr -> ...@
withIOBitmap :: PixelComponent t => IOBitmap t -> (Size -> NChn -> Padding -> Ptr t -> IO a) -> IO a
withIOBitmap (IOBitmap bm) action =
withForeignPtr (bitmapPtr bm) $ \p ->
action (bitmapSize bm) (bitmapNChannels bm) (bitmapRowPadding bm) p
--------------------------------------------------------------------------------
{-
-- | Note that the resulting pointer is valid only within a line (because of the padding)
withComponentPtr
:: PixelComponent t
=> IOBitmap t -- ^ the bitmap
-> Offset -- ^ position (x,y)
-> Int -- ^ channel index {0,1,...,nchannels-1}
-> (Ptr t -> IO a) -- ^ user action
-> IO a
withComponentPtr (IOBitmap bm) (x,y) ofs action =
withForeignPtr (bitmapPtr bm) $ \p -> do
let nchn = bitmapNChannels bm
rowsize = bitmapPaddedRowSizeInBytes bm
q = p `myPlusPtr` ( ( nchn*x + ofs ) * sizeOf (bitmapUndefined bm) + y * rowsize )
action q
-- | It is not very efficient to read\/write lots of pixels this way.
unsafeReadComponent
:: PixelComponent t
=> IOBitmap t -- ^ the bitmap
-> Offset -- ^ position (x,y)
-> Int -- ^ channel index {0,1,...,nchannels-1}
-> IO t
unsafeReadComponent bm xy ofs = withComponentPtr bm xy ofs $ peek
unsafeWriteComponent
:: PixelComponent t
=> IOBitmap t -- ^ the bitmap
-> Offset -- ^ position (x,y)
-> Int -- ^ channel index {0,1,...,nchannels-1}
-> t -- ^ the value to write
-> IO ()
unsafeWriteComponent bm xy ofs value = withComponentPtr bm xy ofs $ \q -> poke q value
-- | Please note that the component array to read shouldn't cross
-- the boundary between lines.
unsafeReadComponents
:: PixelComponent t
=> IOBitmap t -- ^ the bitmap
-> Offset -- ^ position (x,y)
-> Int -- ^ channel index {0,1,...,nchannels-1}
-> Int -- ^ the number of components to read
-> IO [t]
unsafeReadComponents bm xy ofs k = withComponentPtr bm xy ofs $ \p -> peekArray k p
-- | Please note that the component array to write shouldn't cross
-- the boundary between lines.
unsafeWriteComponents
:: PixelComponent t
=> IOBitmap t -- ^ the bitmap
-> Offset -- ^ position (x,y)
-> Int -- ^ channel index {0,1,...,nchannels-1}
-> [t] -- ^ the components to write
-> IO ()
unsafeWriteComponents bm xy ofs values = withComponentPtr bm xy ofs $ \q -> pokeArray q values
unsafeReadPixel
:: PixelComponent t
=> IOBitmap t -- ^ the bitmap
-> Offset -- ^ position (x,y)
-> IO [t]
unsafeReadPixel bm xy = unsafeReadComponents bm xy 0 (bitmapNChannels bm)
--------------------------------------------------------------------------------
instance BitmapClass IOBitmap1 where
underlyingBitmap = unIOBitmap . fromIOBitmap1
instance BitmapClass IOBitmap2 where
underlyingBitmap = unIOBitmap . fromIOBitmap2
instance BitmapClass IOBitmap3 where
underlyingBitmap = unIOBitmap . fromIOBitmap3
instance BitmapClass IOBitmap4 where
underlyingBitmap = unIOBitmap . fromIOBitmap4
--------------------------------------------------------------------------------
-- | Newtypes for mutable bitmaps with a fixed number of channels (components per pixel)
newtype IOBitmap1 t = IOBitmap1 { fromIOBitmap1 :: IOBitmap t }
newtype IOBitmap2 t = IOBitmap2 { fromIOBitmap2 :: IOBitmap t }
newtype IOBitmap3 t = IOBitmap3 { fromIOBitmap3 :: IOBitmap t }
newtype IOBitmap4 t = IOBitmap4 { fromIOBitmap4 :: IOBitmap t }
ioBitmap1 :: IOBitmap t -> IOBitmap1 t
ioBitmap2 :: IOBitmap t -> IOBitmap2 t
ioBitmap3 :: IOBitmap t -> IOBitmap3 t
ioBitmap4 :: IOBitmap t -> IOBitmap4 t
ioBitmap1 bm = if bitmapNChannels bm == 1 then IOBitmap1 bm else error "bitmap/ioBitmap1: number of channels is not 1"
ioBitmap2 bm = if bitmapNChannels bm == 2 then IOBitmap2 bm else error "bitmap/ioBitmap2: number of channels is not 2"
ioBitmap3 bm = if bitmapNChannels bm == 3 then IOBitmap3 bm else error "bitmap/ioBitmap3: number of channels is not 3"
ioBitmap4 bm = if bitmapNChannels bm == 4 then IOBitmap4 bm else error "bitmap/ioBitmap4: number of channels is not 4"
--------------------------------------------------------------------------------
unsafeReadPixel1 :: PixelComponent t => IOBitmap1 t -> Offset -> IO t
unsafeReadPixel2 :: PixelComponent t => IOBitmap2 t -> Offset -> IO (t,t)
unsafeReadPixel3 :: PixelComponent t => IOBitmap3 t -> Offset -> IO (t,t,t)
unsafeReadPixel4 :: PixelComponent t => IOBitmap4 t -> Offset -> IO (t,t,t,t)
unsafeWritePixel1 :: PixelComponent t => IOBitmap1 t -> Offset -> t -> IO ()
unsafeWritePixel2 :: PixelComponent t => IOBitmap2 t -> Offset -> (t,t) -> IO ()
unsafeWritePixel3 :: PixelComponent t => IOBitmap3 t -> Offset -> (t,t,t) -> IO ()
unsafeWritePixel4 :: PixelComponent t => IOBitmap4 t -> Offset -> (t,t,t,t) -> IO ()
unsafeReadPixel1 bm xy = withComponentPtr (fromIOBitmap1 bm) xy 0 $ \p -> liftM (\[x] -> x ) $ peekArray 1 p
unsafeReadPixel2 bm xy = withComponentPtr (fromIOBitmap2 bm) xy 0 $ \p -> liftM (\[x,y] -> (x,y) ) $ peekArray 2 p
unsafeReadPixel3 bm xy = withComponentPtr (fromIOBitmap3 bm) xy 0 $ \p -> liftM (\[x,y,z] -> (x,y,z) ) $ peekArray 3 p
unsafeReadPixel4 bm xy = withComponentPtr (fromIOBitmap4 bm) xy 0 $ \p -> liftM (\[x,y,z,w] -> (x,y,z,w)) $ peekArray 4 p
unsafeWritePixel1 bm xy x = withComponentPtr (fromIOBitmap1 bm) xy 0 $ \q -> pokeArray q [x]
unsafeWritePixel2 bm xy (x,y) = withComponentPtr (fromIOBitmap2 bm) xy 0 $ \q -> pokeArray q [x,y]
unsafeWritePixel3 bm xy (x,y,z) = withComponentPtr (fromIOBitmap3 bm) xy 0 $ \q -> pokeArray q [x,y,z]
unsafeWritePixel4 bm xy (x,y,z,w) = withComponentPtr (fromIOBitmap4 bm) xy 0 $ \q -> pokeArray q [x,y,z,w]
-}
--------------------------------------------------------------------------------
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO ()) -> IOBitmap Word8 -> IOBitmap Word8 -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Word16 -> Ptr Word16 -> IO ()) -> IOBitmap Word16 -> IOBitmap Word16 -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Word32 -> Ptr Word32 -> IO ()) -> IOBitmap Word32 -> IOBitmap Word32 -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Float -> Ptr Float -> IO ()) -> IOBitmap Float -> IOBitmap Float -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Word8 -> Ptr Float -> IO ()) -> IOBitmap Word8 -> IOBitmap Float -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Float -> Ptr Word8 -> IO ()) -> IOBitmap Float -> IOBitmap Word8 -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Word16 -> Ptr Float -> IO ()) -> IOBitmap Word16 -> IOBitmap Float -> IO () #-}
{-# SPECIALIZE genericComponentRowMap
:: (Int -> Int -> Ptr Float -> Ptr Word16 -> IO ()) -> IOBitmap Float -> IOBitmap Word16 -> IO () #-}
-- the first Int is the y position
-- the second Int is the number of pixel components (nchn*width)
genericComponentRowMap
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> Ptr s -> Ptr t -> IO ()) -- ^ ypos totalNumberOfComps src tgt
-> IOBitmap s -> IOBitmap t -> IO ()
genericComponentRowMap rowAction bm1 bm2 = do
let (w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
nchn1 = bitmapNChannels bm1
fptr1 = bitmapPtr bm1
xlen1 = bitmapPaddedRowSizeInBytes bm1
let (w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
nchn2 = bitmapNChannels bm2
fptr2 = bitmapPtr bm2
xlen2 = bitmapPaddedRowSizeInBytes bm2
let minw = min w1 w2
npc = nchn1 * minw
when (nchn1 /= nchn2) $
error "bitmap/genericRowMap: number of channels disagree"
withForeignPtr fptr1 $ \ptr1 -> withForeignPtr fptr2 $ \ptr2 ->
forM_ (zip3 [0..h1-1]
(map (*xlen1) [0..h1-1])
(map (*xlen2) [0..h2-1])) $ \(ypos,vo1,vo2) -> do
let p1 = ptr1 `myPlusPtr` vo1
p2 = ptr2 `myPlusPtr` vo2
rowAction ypos npc p1 p2
-------
-- userAction ypos width ptr1 nchn1 ptr2 nchn2
genericPixelRowMap
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> Ptr s -> NChn -> Ptr t -> NChn -> IO ()) -- ^ ypos width ptr1 nchn1 ptr2 nchn2
-> IOBitmap s -> IOBitmap t -> IO ()
genericPixelRowMap rowAction bm1 bm2 = do
let (w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
nchn1 = bitmapNChannels bm1
fptr1 = bitmapPtr bm1
xlen1 = bitmapPaddedRowSizeInBytes bm1
let (w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
nchn2 = bitmapNChannels bm2
fptr2 = bitmapPtr bm2
xlen2 = bitmapPaddedRowSizeInBytes bm2
let minw = min w1 w2
withForeignPtr fptr1 $ \ptr1 -> withForeignPtr fptr2 $ \ptr2 ->
forM_ (zip3 [0..h1-1]
(map (*xlen1) [0..h1-1])
(map (*xlen2) [0..h2-1])) $ \(ypos,o1,o2) -> do
let p1 = ptr1 `myPlusPtr` o1
p2 = ptr2 `myPlusPtr` o2
rowAction ypos minw p1 nchn1 p2 nchn2
--------------------------------------------------------------------------------
{-# SPECIALIZE genericComponentMap :: (Word8 -> Word8 ) -> IOBitmap Word8 -> IOBitmap Word8 -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Word16 -> Word16) -> IOBitmap Word16 -> IOBitmap Word16 -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Word32 -> Word32) -> IOBitmap Word32 -> IOBitmap Word32 -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Float -> Float ) -> IOBitmap Float -> IOBitmap Float -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Word8 -> Float ) -> IOBitmap Word8 -> IOBitmap Float -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Float -> Word8 ) -> IOBitmap Float -> IOBitmap Word8 -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Word16 -> Float ) -> IOBitmap Word16 -> IOBitmap Float -> IO () #-}
{-# SPECIALIZE genericComponentMap :: (Float -> Word16) -> IOBitmap Float -> IOBitmap Word16 -> IO () #-}
genericComponentMap
-- :: forall s t . (PixelComponent s, PixelComponent t)
:: (PixelComponent s, PixelComponent t)
=> (s -> t) -> IOBitmap s -> IOBitmap t -> IO ()
genericComponentMap f bm1 bm2 = genericComponentRowMap g bm1 bm2 where
--h :: (Ptr s, Ptr t) -> Int -> IO (Ptr s, Ptr t)
h (q1,q2) _ = do
x <- peek q1
poke q2 (f x)
return (advancePtr1 q1, advancePtr1 q2)
--g :: Int -> Int -> Ptr s -> Ptr t -> IO ()
g ypos n p1 p2 = do
foldM_ h (p1,p2) [0..n-1]
{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word8 -> Word8 ) -> IOBitmap Word8 -> IOBitmap Word8 -> IO () #-}
{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word16 -> Word16) -> IOBitmap Word16 -> IOBitmap Word16 -> IO () #-}
{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word32 -> Word32) -> IOBitmap Word32 -> IOBitmap Word32 -> IO () #-}
{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Float -> Float ) -> IOBitmap Float -> IOBitmap Float -> IO () #-}
genericComponentMapWithPos
-- :: forall s t . (PixelComponent s, PixelComponent t)
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> s -> t) -> IOBitmap s -> IOBitmap t -> IO ()
genericComponentMapWithPos f bm1 bm2 = genericComponentRowMap g bm1 bm2 where
--h :: Int -> (Ptr s, Ptr t) -> Int -> IO (Ptr s, Ptr t)
h ypos (q1,q2) xpos = do
x <- peek q1
poke q2 (f xpos ypos x)
return (advancePtr1 q1, advancePtr1 q2)
--g :: Int -> Int -> Ptr s -> Ptr t -> IO ()
g ypos n p1 p2 = do
foldM_ (h ypos) (p1,p2) [0..n-1]
--------------------------------------------------------------------------------
-- | Maps a function over each component of each pixel. Warning: this is probably slow!
-- Use a specialized function if there is one for your task.
{-
-- Note: We don't do the more general (s->t) here, because then we would have no idea
-- about the padding in the new bitmap. See `componentMap'` for that.
-}
componentMap :: PixelComponent s => (s -> s) -> IOBitmap s -> IO (IOBitmap s)
componentMap f bm1 = do
let siz = bitmapSize bm1
nchn = bitmapNChannels bm1
align = bitmapRowAlignment bm1
bm2 <- newIOBitmapUninitialized siz nchn (Just align)
genericComponentMap f bm1 bm2
return bm2
componentMapInPlace :: PixelComponent s => (s -> s) -> IOBitmap s -> IO ()
componentMapInPlace f bm = do
genericComponentMap f bm bm
-- See the comments at 'componentMap'.
componentMap'
:: (PixelComponent s, PixelComponent t)
=> (s -> t)
-> IOBitmap s -- ^ source bitmap
-> Maybe Alignment -- ^ row alignment of the resulting bitmap
-> IO (IOBitmap t)
componentMap' f bm1 malign = do
let siz = bitmapSize bm1
nchn = bitmapNChannels bm1
x = bitmapPaddedRowSizeInBytes bm1
bm2 <- newIOBitmapUninitialized siz nchn malign
genericComponentMap f bm1 bm2
return bm2
--------------------------------------------------------------------------------
-- | Clones a bitmap.
cloneBitmap
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Maybe Alignment -- ^ target alignment
-> IO (IOBitmap t)
cloneBitmap bm1 malign = do
let siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
nchn1 = bitmapNChannels bm1
fptr1 = bitmapPtr bm1
xlen1 = bitmapPaddedRowSizeInBytes bm1
bm2 <- newIOBitmapUninitialized siz1 nchn1 malign
let fptr2 = bitmapPtr bm2
xlen2 = bitmapPaddedRowSizeInBytes bm2
let len1 = bitmapUnpaddedRowSizeInBytes bm1
len2 = bitmapUnpaddedRowSizeInBytes bm2
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
forM_ [0..h1-1] $ \i -> do
let p = plusPtr ptr1 (i*xlen1)
q = plusPtr ptr2 (i*xlen2)
c_memcpy p q len1
return bm2
-- | Creates an empty bitmap with the same properties as the source.
emptyCloneBitmap
:: PixelComponent t
=> IOBitmap t -- ^ source (only dimensions and such is used)
-> Maybe Alignment -- ^ target alignment
-> IO (IOBitmap t) -- ^ new empty bitmap
emptyCloneBitmap bm1 malign = do
let siz1 = bitmapSize bm1
nchn1 = bitmapNChannels bm1
bm2 <- newIOBitmapUninitialized siz1 nchn1 malign
let fptr2 = bitmapPtr bm2
n = bitmapSizeInBytes bm2
withForeignPtr fptr2 $ \ptr2 -> do
c_memset (castPtr ptr2 :: Ptr Word8) n 0
return bm2
-- | Synonym for 'newIOBitmap'
emptyBitmap
:: PixelComponent t
=> Size -- ^ (width,height)
-> NChn -- ^ number of channels (components\/pixel)
-> Maybe Alignment -- ^ the row alignment of the new image
-> IO (IOBitmap t)
emptyBitmap = newIOBitmap
--------------------------------------------------------------------------------
-- | Copies a subrectangle of the source image into a new image.
copySubImage
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Offset -- ^ source rectangle offset
-> Size -- ^ source rectangle size
-> IO (IOBitmap t)
copySubImage bm ofs1 siz1 = copySubImage' bm ofs1 siz1 siz1 (0,0)
-- | Copy into a new \"black\" bitmap; common generalization of crop and extend.
copySubImage'
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Offset -- ^ source rectangle offset
-> Size -- ^ source rectangle size
-> Size -- ^ target image size
-> Offset -- ^ target rectangle offset
-> IO (IOBitmap t)
copySubImage' bm1 ofs1 rsiz tsiz ofs2 = do
let align = bitmapRowAlignment bm1
nchn = bitmapNChannels bm1
bm2 <- newIOBitmap tsiz nchn (Just align)
copySubImageInto bm1 ofs1 rsiz bm2 ofs2
return bm2
-- | The source rectangle may be arbitrary, may or may not intersect the
-- source image in any way. We only copy the intersection of the rectangle
-- with the image.
copySubImageInto
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Offset -- ^ source rectangle offset
-> Size -- ^ source rectangle size
-> IOBitmap t -- ^ target image
-> Offset -- ^ target rectangle offset
-> IO ()
copySubImageInto bm1 ofs1@(o1x0,o1y0) siz1@(sx0,sy0) bm2 ofs2@(o2x0,o2y0) = do
let (bm1xs,bm1ys) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
align1 = bitmapRowAlignment bm1
nchn1 = bitmapNChannels bm1
pixsiz1 = bitmapPixelSizeInBytes bm1
fptr1 = bitmapPtr bm1
xlen1 = bitmapPaddedRowSizeInBytes bm1
let (bm2xs,bm2ys) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
align2 = bitmapRowAlignment bm2
nchn2 = bitmapNChannels bm2
pixsiz2 = bitmapPixelSizeInBytes bm2
fptr2 = bitmapPtr bm2
xlen2 = bitmapPaddedRowSizeInBytes bm2
when (nchn1/=nchn2) $ error "bitmap/copySubImageInto: number of channels disagree"
-- handle negative offsets
let (o1x1,sx1,o2x1) = if o1x0 >= 0 then (o1x0, sx0, o2x0) else (0, sx0+o1x0, o2x0-o1x0)
(o1y1,sy1,o2y1) = if o1y0 >= 0 then (o1y0, sy0, o2y0) else (0, sy0+o1y0, o2y0-o1y0)
(o1x ,sx ,o2x ) = if o2x1 >= 0 then (o1x1, sx1, o2x1) else (o1x1-o2x1, sx1+o2x1, 0)
(o1y ,sy ,o2y ) = if o2y1 >= 0 then (o1y1, sy1, o2y1) else (o1y1-o2y1, sy1+o2y1, 0)
-- size of the rectangle we actually copy
let xs = minimum [ sx , (bm1xs - o1x) , (bm2xs - o2x) ]
ys = minimum [ sy , (bm1ys - o1y) , (bm2ys - o2y) ]
pixsiz = pixsiz1
when (xs>0 && ys>0) $ do
withForeignPtr fptr1 $ \ptr1' -> withForeignPtr fptr2 $ \ptr2' -> do
let ptr1 = ptr1' `myPlusPtr` (pixsiz*o1x)
ptr2 = ptr2' `myPlusPtr` (pixsiz*o2x)
nbytes = pixsiz*xs
forM_ (zip (map (*xlen1) [o1y..o1y+ys-1])
(map (*xlen2) [o2y..o2y+ys-1])) $ \(vo1,vo2) -> do
let p1 = ptr1 `plusPtr` vo1
p2 = ptr2 `plusPtr` vo2
c_memcpy p1 p2 nbytes
--------------------------------------------------------------------------------
-- | Convert a bitmap to one with a different component type.
castBitmap
:: (PixelComponent s, PixelComponent t)
=> IOBitmap s -- ^ source image
-> Maybe Alignment -- ^ target image row alignment
-> IO (IOBitmap t)
castBitmap bm1 malign = do
let nchn1 = bitmapNChannels bm1
siz1@(w,h) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
bm2 <- newIOBitmapUninitialized siz1 nchn1 malign
let pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
c_cast_bitmap
(bitmapCType bm1) (bitmapCType bm2)
(ci w) (ci h)
ptr1 (ci nchn1) (ci pad1) 0 -- (ci ofs1)
ptr2 (ci nchn1) (ci pad2) 0 -- (ci ofs2)
return bm2
--------------------------------------------------------------------------------
_flipBitmapInto
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> IOBitmap t -- ^ target image
-> IO ()
_flipBitmapInto bm1 bm2 = do
let siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
nchn1 = bitmapNChannels bm1
fptr1 = bitmapPtr bm1
xlen1 = bitmapPaddedRowSizeInBytes bm1
let siz2@(w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
nchn2 = bitmapNChannels bm2
fptr2 = bitmapPtr bm2
xlen2 = bitmapPaddedRowSizeInBytes bm2
let len1 = bitmapUnpaddedRowSizeInBytes bm1
len2 = bitmapUnpaddedRowSizeInBytes bm2
when ( siz1 /= siz2 || nchn1 /= nchn2 || len1 /= len2 ) $ error "_flipBitmapInto"
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
if ptr1 == ptr2
then do
allocaBytes len1 $ \tmp -> do
forM_ [0..(div h1 2)-1] $ \i -> do
let j = h1-1-i
p1 = plusPtr ptr1 (i*xlen1)
q1 = plusPtr ptr1 (j*xlen1)
p2 = plusPtr ptr2 (i*xlen2)
q2 = plusPtr ptr2 (j*xlen2)
-- we have to be careful, since the two bitmaps coincide.
-- that's why the extra copy
c_memcpy p1 tmp len1
c_memcpy q1 p2 len1
c_memcpy tmp q2 len1
else do
forM_ [0..h1-1] $ \i -> do
let j = h1-1-i
p = plusPtr ptr1 (i*xlen1)
q = plusPtr ptr2 (j*xlen2)
c_memcpy p q len1
-- | Flips the bitmap vertically.
flipBitmap
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Maybe Alignment -- ^ target image row alignment
-> IO (IOBitmap t)
flipBitmap bm1 malign = do
let nchn = bitmapNChannels bm1
siz@(w,h) = bitmapSize bm1
bm2 <- newIOBitmapUninitialized siz nchn malign
_flipBitmapInto bm1 bm2
return bm2
flipBitmapInPlace
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> IO ()
flipBitmapInPlace bm = do
_flipBitmapInto bm bm
--------------------------------------------------------------------------------
_mirrorBitmapInto
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> IOBitmap t -- ^ target image
-> IO ()
_mirrorBitmapInto bm1 bm2 = do
let siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
nchn1 = bitmapNChannels bm1
fptr1 = bitmapPtr bm1
xlen1 = bitmapPaddedRowSizeInBytes bm1
let siz2@(w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
nchn2 = bitmapNChannels bm2
fptr2 = bitmapPtr bm2
xlen2 = bitmapPaddedRowSizeInBytes bm2
let len1 = bitmapUnpaddedRowSizeInBytes bm1
len2 = bitmapUnpaddedRowSizeInBytes bm2
bpp1 = bitmapPixelSizeInBytes bm1
bpp2 = bitmapPixelSizeInBytes bm2
when ( siz1 /= siz2 || nchn1 /= nchn2 || len1 /= len2 || bpp1 /= bpp2 ) $ error "_mirrorBitmapInto"
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
forM_ [0..h1-1] $ \i -> do
let p = plusPtr ptr1 (i*xlen1)
q = plusPtr ptr2 (i*xlen2)
c_mirror_line (ci w1) (ci bpp1) p q
-- | Flips the bitmap horizontally.
mirrorBitmap
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Maybe Alignment -- ^ target image row alignment
-> IO (IOBitmap t)
mirrorBitmap bm1 malign = do
let nchn = bitmapNChannels bm1
siz@(w,h) = bitmapSize bm1
bm2 <- newIOBitmapUninitialized siz nchn malign
_mirrorBitmapInto bm1 bm2
return bm2
mirrorBitmapInPlace
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> IO ()
mirrorBitmapInPlace bm = do
_mirrorBitmapInto bm bm
--------------------------------------------------------------------------------
extractSingleChannel
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Maybe Alignment -- ^ target image row alignment
-> Int -- ^ source channel index
-> IO (IOBitmap t)
extractSingleChannel bm1 malign j = do
let nchn = bitmapNChannels bm1
siz@(w,h) = bitmapSize bm1
when (j<0 || j>=nchn) $ error "bitmap/extractSingleChannel: invalid channel index"
bm2 <- newIOBitmapUninitialized siz 1 malign
extractChannelInto bm1 j bm2 0
return bm2
extractChannels :: PixelComponent t => IOBitmap t -> Maybe Alignment -> IO [IOBitmap t]
extractChannels bm malign =
mapM (extractSingleChannel bm malign) [0..nchn-1]
where nchn = bitmapNChannels bm
combineChannels :: PixelComponent t => [IOBitmap t] -> Maybe Alignment -> IO (IOBitmap t)
combineChannels [] _ = error "bitmap/combineChannels: no channel data"
combineChannels bms malign = do
let sizes = map bitmapSize bms
nchns = map bitmapNChannels bms
pixsizs = map bitmapPixelSizeInBytes bms
sumchn = sum nchns
siz@(w,h) = head sizes
when (length (nub sizes) /= 1) $ error "bitmap/combineChannels: incompatible sizes"
bm2 <- newIOBitmapUninitialized siz sumchn malign
let pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
let loop = concatMap (\bm -> zip (repeat bm) [0..bitmapNChannels bm - 1]) bms
withForeignPtr fptr2 $ \ptr2 -> do
forM_ (zip [0..] loop) $ \(i,(bm1,j)) -> do
let pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
nchn1 = bitmapNChannels bm1
withForeignPtr fptr1 $ \ptr1 ->
c_extract_channel
(bitmapCType (head bms))
(ci w) (ci h)
ptr1 (ci nchn1) (ci pad1) (ci j)
ptr2 (ci sumchn) (ci pad2) (ci i)
return bm2
extractChannelInto
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Int -- ^ source channel index
-> IOBitmap t -- ^ target image
-> Int -- ^ target channel index
-> IO ()
extractChannelInto bm1 ofs1 bm2 ofs2 = do
let nchn1 = bitmapNChannels bm1
siz1@(w,h) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
let nchn2 = bitmapNChannels bm2
siz2 = bitmapSize bm2
pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
when (siz1 /= siz2) $ error "bitmap/extractChannelInto: incompatible dimensions"
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/extractChannelInto: invalid source channel index"
when (ofs2<0 || ofs2>=nchn2) $ error "bitmap/extractChannelInto: invalid target channel index"
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
c_extract_channel
(bitmapCType bm1)
(ci w) (ci h)
ptr1 (ci nchn1) (ci pad1) (ci ofs1)
ptr2 (ci nchn2) (ci pad2) (ci ofs2)
--------------------------------------------------------------------------------
bilinearResample
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Size -- ^ target image size
-> Maybe Alignment -- ^ target image alignment
-> IO (IOBitmap t)
bilinearResample bm1 siz2@(w2,h2) malign = do
let nchn1 = bitmapNChannels bm1
bm2 <- newIOBitmapUninitialized siz2 nchn1 malign
forM_ [0..nchn1-1] $ \ofs ->
bilinearResampleChannelInto bm1 ofs bm2 ofs
return bm2
bilinearResampleChannel
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Int -- ^ source channel index
-> Size -- ^ target image size
-> Maybe Alignment -- ^ target image alignment
-> IO (IOBitmap t)
bilinearResampleChannel bm1 ofs1 siz2@(w2,h2) malign = do
let nchn1 = bitmapNChannels bm1
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/bilinearResampleChannel: invalid channel index"
bm2 <- newIOBitmapUninitialized siz2 1 malign
bilinearResampleChannelInto bm1 ofs1 bm2 0
return bm2
bilinearResampleChannelInto
:: PixelComponent t
=> IOBitmap t -- ^ source image
-> Int -- ^ source channel index
-> IOBitmap t -- ^ target image
-> Int -- ^ target channel index
-> IO ()
bilinearResampleChannelInto bm1 ofs1 bm2 ofs2 = do
let nchn1 = bitmapNChannels bm1
siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
let nchn2 = bitmapNChannels bm2
siz2@(w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/bilinearResampleChannelInto: invalid source channel index"
when (ofs2<0 || ofs2>=nchn2) $ error "bitmap/bilinearResampleChannelInto: invalid target channel index"
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
c_bilinear_resample_channel
(c_type (bitmapUndefined bm1))
(ci w1) (ci h1) ptr1 (ci nchn1) (ci pad1) (ci ofs1)
(ci w2) (ci h2) ptr2 (ci nchn2) (ci pad2) (ci ofs2)
--------------------------------------------------------------------------------
-- | This is equivalent to @componentMap (\c -> c^gamma)@, except that
-- @(^)@ is defined only for integral exponents; but should be faster anyway.
powerlawGammaCorrection
:: PixelComponent t
=> Float -- ^ gamma
-> IOBitmap t -- ^ source bitmap
-> Maybe Alignment -- ^ target alignment
-> IO (IOBitmap t)
powerlawGammaCorrection gamma bm1 malign = do
let nchn1 = bitmapNChannels bm1
siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
bm2 <- newIOBitmapUninitialized siz1 nchn1 malign
let pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
c_gamma_correct_all_channels
(c_type (bitmapUndefined bm1))
(realToFrac gamma)
(ci w1) (ci h1) (ci nchn1)
ptr1 (ci pad1)
ptr2 (ci pad2)
return bm2
powerlawGammaCorrectionChannel
:: PixelComponent t
=> Float -- ^ gamma
-> IOBitmap t -- ^ source image
-> Int -- ^ source channel index
-> Maybe Alignment -- ^ target image alignment
-> IO (IOBitmap t)
powerlawGammaCorrectionChannel gamma bm1 ofs1 malign = do
let nchn1 = bitmapNChannels bm1
siz1 = bitmapSize bm1
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/powerlawGammaCorrectionChannel: invalid channel index"
bm2 <- newIOBitmapUninitialized siz1 1 malign
powerlawGammaCorrectionChannelInto gamma bm1 ofs1 bm2 0
return bm2
powerlawGammaCorrectionChannelInto
:: PixelComponent t
=> Float -- ^ gamma
-> IOBitmap t -- ^ source image
-> Int -- ^ source channel index
-> IOBitmap t -- ^ target image
-> Int -- ^ target channel index
-> IO ()
powerlawGammaCorrectionChannelInto gamma bm1 ofs1 bm2 ofs2 = do
let nchn1 = bitmapNChannels bm1
siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
let nchn2 = bitmapNChannels bm2
siz2@(w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
when (siz1 /= siz2) $ error "bitmap/powerlawGammaCorrectionChannelInto: incompatible dimensions"
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/powerlawGammaCorrectionChannelInto: invalid source channel index"
when (ofs2<0 || ofs2>=nchn2) $ error "bitmap/powerlawGammaCorrectionChannelInto: invalid target channel index"
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
c_gamma_correct_channel
(c_type (bitmapUndefined bm1))
(realToFrac gamma)
(ci w1) (ci h1)
ptr1 (ci nchn1) (ci pad1) (ci ofs1)
ptr2 (ci nchn2) (ci pad2) (ci ofs2)
--------------------------------------------------------------------------------
-- | Blends two bitmaps with the given weights; that is, the result is
-- the specified linear combination. If the values are outside the allowed
-- range (this can happen with the Word8, Word16, Word32 types and weights
-- whose sum is bigger than 1, or with a negative weight), then they are
-- clipped. The clipping /does not/ happen with the Float component type.
blendBitmaps
:: PixelComponent t
=> Float -- ^ weight1
-> Float -- ^ weight2
-> IOBitmap t -- ^ source1 image
-> IOBitmap t -- ^ source2 image
-> Maybe Alignment -- ^ target alignment
-> IO (IOBitmap t)
-- this could be implemented more effectively by a specialized c routine
blendBitmaps weight1 weight2 bm1 bm2 malign = do
let nchn1 = bitmapNChannels bm1
siz1 = bitmapSize bm1
let nchn2 = bitmapNChannels bm2
siz2 = bitmapSize bm2
when (siz1 /= siz2 ) $ error "bitmap/blend: incompatible dimensions"
when (nchn1 /= nchn2) $ error "bitmap/blend: incompatible number of channels"
bm3 <- newIOBitmapUninitialized siz1 nchn1 malign
forM [0..nchn1-1] $ \ofs ->
blendChannelsInto weight1 weight2 bm1 ofs bm2 ofs bm3 ofs
return bm3
blendChannels
:: PixelComponent t
=> Float -- ^ weight1
-> Float -- ^ weight2
-> IOBitmap t -- ^ source1 image
-> Int -- ^ source1 channel index
-> IOBitmap t -- ^ source2 image
-> Int -- ^ source2 channel index
-> Maybe Alignment -- ^ target alignment
-> IO (IOBitmap t)
blendChannels weight1 weight2 bm1 ofs1 bm2 ofs2 malign = do
let nchn1 = bitmapNChannels bm1
siz1 = bitmapSize bm1
let nchn2 = bitmapNChannels bm2
siz2 = bitmapSize bm2
when (siz1 /= siz2) $ error "bitmap/blendChannels: incompatible dimensions"
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/blendChannels: invalid channel index"
when (ofs2<0 || ofs2>=nchn2) $ error "bitmap/blendChannels: invalid channel index"
bm3 <- newIOBitmapUninitialized siz1 1 malign
blendChannelsInto weight1 weight2 bm1 ofs1 bm2 ofs2 bm3 0
return bm3
blendChannelsInto
:: PixelComponent t
=> Float -- ^ weight1
-> Float -- ^ weight2
-> IOBitmap t -- ^ source1 image
-> Int -- ^ source1 channel index
-> IOBitmap t -- ^ source2 image
-> Int -- ^ source2 channel index
-> IOBitmap t -- ^ target image
-> Int -- ^ target channel index
-> IO ()
blendChannelsInto weight1 weight2 bm1 ofs1 bm2 ofs2 bm3 ofs3 = do
let nchn1 = bitmapNChannels bm1
siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
let nchn2 = bitmapNChannels bm2
siz2@(w2,h2) = bitmapSize bm2
pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
let nchn3 = bitmapNChannels bm3
siz3@(w3,h3) = bitmapSize bm3
pad3 = bitmapRowPadding bm3
fptr3 = bitmapPtr bm3
when (siz1 /= siz2) $ error "bitmap/blendChannelInto: incompatible dimensions"
when (siz2 /= siz3) $ error "bitmap/blendChannelInto: incompatible dimensions"
when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/blendChannelInto: invalid source channel index 1"
when (ofs2<0 || ofs2>=nchn2) $ error "bitmap/blendChannelInto: invalid source channel index 2"
when (ofs3<0 || ofs3>=nchn3) $ error "bitmap/blendChannelInto: invalid target channel index"
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
withForeignPtr fptr3 $ \ptr3 ->
c_linear_combine_channels
(bitmapCType bm1)
(realToFrac weight1) (realToFrac weight2)
(ci w1) (ci h1)
ptr1 (ci nchn1) (ci pad1) (ci ofs1)
ptr2 (ci nchn2) (ci pad2) (ci ofs2)
ptr3 (ci nchn3) (ci pad3) (ci ofs3)
--------------------------------------------------------------------------------
{-
-- | The data is copied, not shared. Note that the resulting ByteString is
-- encoded using the host machine's endianness, so it may be not compatible
-- across different architectures!
copyBitmapToByteString :: PixelComponent t => Bitmap t -> IO ByteString
copyBitmapToByteString bm = do
let n = bitmapSizeInBytes bm
newfp <- B.mallocByteString n
withBitmap bm $ \_ _ _ src ->
withForeignPtr newfp $ \tgt -> do
c_memcpy (castPtr src) tgt n
return $ B.fromForeignPtr (castForeignPtr newfp) 0 n
-- | The data is copied, not shared.
-- Note that we expect the ByteString to be encoded
-- encoded using the host machine's endianness.
copyBitmapFromByteString :: PixelComponent t => ByteString -> Size -> NChn -> Padding -> IO (Bitmap t)
copyBitmapFromByteString bs siz nchn pad = do
let (bsfptr0,ofs,len) = B.toForeignPtr bs
bm = Bitmap
{ bitmapSize = siz
, bitmapNChannels = nchn
, bitmapPtr = undefined
, bitmapRowPadding = pad
, bitmapRowAlignment = 1
} -- :: Bitmap t
n = bitmapSizeInBytes bm
if n > len-ofs
then error "copyBitmapFromByteString: ByteString is too short"
else do
newfptr <- mallocForeignPtrBytes n
withForeignPtr bsfptr0 $ \src0 -> do
let src = src0 `myPlusPtr` ofs
withForeignPtr newfptr $ \tgt ->
c_memcpy src tgt n
return $ bm { bitmapPtr = castForeignPtr newfptr }
-}
--------------------------------------------------------------------------------
ptrUndefined :: Ptr a -> a
ptrUndefined _ = undefined
-- no multiplication
{-# SPECIALIZE advancePtr1 :: Ptr Word8 -> Ptr Word8 #-}
{-# SPECIALIZE advancePtr1 :: Ptr Float -> Ptr Float #-}
--advancePtr1 :: forall a. Storable a => Ptr a -> Ptr a
--advancePtr1 p = p `plusPtr` (sizeOf (undefined::a))
advancePtr1 :: Storable a => Ptr a -> Ptr a
advancePtr1 p = p `plusPtr` (sizeOf (ptrUndefined p))
-- restricted type
{-# SPECIALIZE myPlusPtr :: Ptr Word8 -> Int -> Ptr Word8 #-}
{-# SPECIALIZE myPlusPtr :: Ptr Float -> Int -> Ptr Float #-}
myPlusPtr :: Ptr a -> Int -> Ptr a
myPlusPtr = plusPtr
ci :: Int -> CInt
ci = fromIntegral
-- @c_memset target count fill@.
-- Note that we use /nonstandard/ argument order!
foreign import ccall unsafe "bm.h c_memset"
c_memset :: Ptr Word8 -> Int -> Word8 -> IO ()
-- @c_memcpy from to cnt@.
-- Note that we use /nonstandard/ argument order!
foreign import ccall unsafe "bm.h c_memcpy"
c_memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
--------------------
{-
// tgt and src can be potentally the same
void c_mirror_line(int width, int bytesperpixel, void *src, void *tgt);
-}
foreign import ccall unsafe "bm.h c_mirror_line"
c_mirror_line
:: CInt -- ^ width
-> CInt -- ^ bytesperpixel
-> Ptr a -- ^ src
-> Ptr a -- ^ tgt
-> IO ()
--------------------
{-
void c_cast_bitmap
( int k_type1, int k_type2
, int width, int height
, void *p1, int nchn1, int pad1, int ofs1
, void *p2, int nchn2, int pad2, int ofs2
);
-}
-- offset is measured in components, not bytes!
-- also, nchn1 should be equal to nchn2
-- offset should be zero
foreign import ccall unsafe "bm.h c_cast_bitmap"
c_cast_bitmap
:: CInt -> CInt -- ^ component types
-> CInt -> CInt -- ^ width, height
-> Ptr a -> CInt -> CInt -> CInt -- ^ source, nchn, pad, offset
-> Ptr b -> CInt -> CInt -> CInt -- ^ target, nchn, pad, offset
-> IO ()
--------------------
{-
void c_extract_channel(
( int k_type
, int width, int height
, void *p1, int nchn1, int pad1, int ofs1
, void *p2, int nchn2, int pad2, int ofs2
);
-}
-- offset is measured in components, not bytes!
foreign import ccall unsafe "bm.h c_extract_channel"
c_extract_channel
:: CInt -- ^ component type
-> CInt -> CInt -- ^ width, height
-> Ptr a -> CInt -> CInt -> CInt -- ^ source, nchn, pad, offset
-> Ptr a -> CInt -> CInt -> CInt -- ^ target, nchn, pad, offset
-> IO ()
--------------------
{-
void c_bilinear_resample_channel
( int k_type
, int width1, int height1, void *p1, int nchn1, int pad1, int ofs1
, int width2, int height2, void *p2, int nchn2, int pad2, int ofs2
);
-}
-- offset is measured in components, not bytes!
foreign import ccall unsafe "bm.h c_bilinear_resample_channel"
c_bilinear_resample_channel
:: CInt -- ^ component type
-> CInt -> CInt -> Ptr a -> CInt -> CInt -> CInt -- ^ width, height, source, nchn, pad, offset
-> CInt -> CInt -> Ptr a -> CInt -> CInt -> CInt -- ^ width, height, target, nchn, pad, offset
-> IO ()
--------------------
{-
void c_gamma_correct_channel
( int k_type
, float gamma
, int width, int height
, void *p1, int nchn1, int pad1, int ofs1
, void *p2, int nchn2, int pad2, int ofs2
);
void c_gamma_correct_all_channels
( int k_type
, float gamma
, int width, int height, int nchn
, void *p1, int pad1
, void *p2, int pad2
);
-}
-- offset is measured in components, not bytes!
foreign import ccall unsafe "bm.h c_gamma_correct_channel"
c_gamma_correct_channel
:: CInt -- ^ component type
-> CFloat -- ^ gamma
-> CInt -> CInt -- ^ width, height
-> Ptr a -> CInt -> CInt -> CInt -- ^ source, nchn, pad, offset
-> Ptr a -> CInt -> CInt -> CInt -- ^ target, nchn, pad, offset
-> IO ()
foreign import ccall unsafe "bm.h c_gamma_correct_all_channels"
c_gamma_correct_all_channels
:: CInt -- ^ component type
-> CFloat -- ^ gamma
-> CInt -> CInt -> CInt -- ^ width, height, nchn
-> Ptr a -> CInt -- ^ source, pad
-> Ptr a -> CInt -- ^ target, pad
-> IO ()
--------------------
{-
void c_linear_combine_channels
( int k_type
, float weight1, float weight2
, int width, int height
, void *p1, int nchn1, int pad1, int ofs1
, void *p2, int nchn2, int pad2, int ofs2
, void *p3, int nchn3, int pad3, int ofs3
);
-}
-- offset is measured in components, not bytes!
foreign import ccall unsafe "bm.h c_linear_combine_channels"
c_linear_combine_channels
:: CInt -- ^ component type
-> CFloat -> CFloat -- ^ weight1, weight2
-> CInt -> CInt -- ^ width, height
-> Ptr a -> CInt -> CInt -> CInt -- ^ source1, nchn, pad, offset
-> Ptr a -> CInt -> CInt -> CInt -- ^ source2, nchn, pad, offset
-> Ptr a -> CInt -> CInt -> CInt -- ^ target, nchn, pad, offset
-> IO ()
--------------------------------------------------------------------------------