module Data.Bitmap.IO
(
module Data.Bitmap.Base
, newBitmap
, newBitmapUninitialized
, createSingleChannelBitmap
, copyBitmapFromPtr
, bitmapFromForeignPtrUnsafe
, withBitmap
, componentMap
, componentMap'
, componentMapInPlace
, copySubImage
, copySubImage'
, copySubImageInto
, combineChannels
, extractChannels
, extractSingleChannel
, extractChannelInto
, bilinearResample
, bilinearResampleChannel
, bilinearResampleChannelInto
, blendBitmaps
, blendChannels
, blendChannelsInto
, powerlawGammaCorrection
, powerlawGammaCorrectionChannel
, powerlawGammaCorrectionChannelInto
, copyBitmapToByteString
, copyBitmapFromByteString
, withComponentPtr
, unsafeReadComponent
, unsafeWriteComponent
, unsafeReadComponents
, unsafeWriteComponents
, unsafeReadPixel
, unsafeReadPixel1
, unsafeReadPixel2
, unsafeReadPixel3
, unsafeReadPixel4
, unsafeWritePixel1
, unsafeWritePixel2
, unsafeWritePixel3
, unsafeWritePixel4
)
where
import Control.Monad
import Data.Word
import Data.List (nub)
import Foreign
import Foreign.C
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
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)"
newBitmapRaw :: forall t. PixelComponent t => Size -> NChn -> Padding -> Alignment -> IO (Bitmap t)
newBitmapRaw siz nchn pad align = do
let bm0 = Bitmap
{ bitmapSize = siz
, bitmapNChannels = nchn
, bitmapPtr = undefined
, bitmapRowPadding = pad
, bitmapRowAlignment = align
} :: Bitmap t
len = bitmapSizeInBytes bm0
fptr <- mallocForeignPtrBytes len :: IO (ForeignPtr t)
return $ bm0 { bitmapPtr = fptr }
newBitmap
:: forall t. PixelComponent t
=> Size
-> NChn
-> Maybe Alignment
-> IO (Bitmap t)
newBitmap siz nchn malign = do
bm <- newBitmapUninitialized siz nchn malign
let fptr = bitmapPtr bm
len = bitmapSizeInBytes bm
withForeignPtr fptr $ \p -> c_memset (castPtr p) len 0
return bm
newBitmapUninitialized :: forall t. PixelComponent t => Size -> NChn -> Maybe Alignment -> IO (Bitmap t)
newBitmapUninitialized siz nchn malign = do
let bm0 = Bitmap
{ bitmapSize = siz
, bitmapNChannels = nchn
, bitmapPtr = undefined
, bitmapRowPadding = pad
, bitmapRowAlignment = align
} :: Bitmap t
x0 = bitmapUnpaddedRowSizeInBytes bm0
align = validateMaybeAlignment malign
pad = recommendedPadding bm0
newBitmapRaw siz nchn pad align
createSingleChannelBitmap
:: forall t. PixelComponent t
=> Size
-> Maybe Alignment
-> (Int -> Int -> t)
-> IO (Bitmap t)
createSingleChannelBitmap siz malign fun = do
bm <- newBitmapUninitialized 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
copyBitmapFromPtr
:: forall t. PixelComponent t
=> Size
-> NChn
-> Padding
-> Ptr t
-> Maybe Alignment
-> IO (Bitmap t)
copyBitmapFromPtr siz@(w,h) nchn srcpad srcptr tgtmalign = do
bm <- newBitmapUninitialized siz nchn tgtmalign
withBitmap bm $ \_ _ _ tgtptr -> do
let pure_line = bitmapUnpaddedRowSizeInBytes bm
src_line = pure_line + srcpad
tgt_line = bitmapPaddedRowSizeInBytes bm
forM_ [0..h1] $ \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
bitmapFromForeignPtrUnsafe
:: forall t. PixelComponent t
=> Size -> NChn -> Alignment -> Padding -> ForeignPtr t -> Bitmap t
bitmapFromForeignPtrUnsafe siz nchn align pad fptr = Bitmap
{ bitmapSize = siz
, bitmapNChannels = nchn
, bitmapPtr = fptr
, bitmapRowPadding = pad
, bitmapRowAlignment = align
}
withBitmap :: PixelComponent t => Bitmap t -> (Size -> NChn -> Padding -> Ptr t -> IO a) -> IO a
withBitmap bm action =
withForeignPtr (bitmapPtr bm) $ \p ->
action (bitmapSize bm) (bitmapNChannels bm) (bitmapRowPadding bm) p
withComponentPtr
:: forall t a. PixelComponent t
=> Bitmap t
-> Offset
-> Int
-> (Ptr t -> IO a)
-> IO a
withComponentPtr bm (x,y) ofs action =
withForeignPtr (bitmapPtr bm) $ \p -> do
let nchn = bitmapNChannels bm
rowsize = bitmapPaddedRowSizeInBytes bm
q = p `myPlusPtr` ( ( nchn*x + ofs ) * sizeOf (undefined::t) + y * rowsize )
action q
unsafeReadComponent
:: PixelComponent t
=> Bitmap t
-> Offset
-> Int
-> IO t
unsafeReadComponent bm xy ofs = withComponentPtr bm xy ofs $ peek
unsafeWriteComponent
:: PixelComponent t
=> Bitmap t
-> Offset
-> Int
-> t
-> IO ()
unsafeWriteComponent bm xy ofs value = withComponentPtr bm xy ofs $ \q -> poke q value
unsafeReadComponents
:: PixelComponent t
=> Bitmap t
-> Offset
-> Int
-> Int
-> IO [t]
unsafeReadComponents bm xy ofs k = withComponentPtr bm xy ofs $ \p -> peekArray k p
unsafeWriteComponents
:: PixelComponent t
=> Bitmap t
-> Offset
-> Int
-> [t]
-> IO ()
unsafeWriteComponents bm xy ofs values = withComponentPtr bm xy ofs $ \q -> pokeArray q values
unsafeReadPixel
:: PixelComponent t
=> Bitmap t
-> Offset
-> IO [t]
unsafeReadPixel bm xy = unsafeReadComponents bm xy 0 (bitmapNChannels bm)
unsafeReadPixel1 :: PixelComponent t => Bitmap t -> Offset -> IO t
unsafeReadPixel2 :: PixelComponent t => Bitmap t -> Offset -> IO (t,t)
unsafeReadPixel3 :: PixelComponent t => Bitmap t -> Offset -> IO (t,t,t)
unsafeReadPixel4 :: PixelComponent t => Bitmap t -> Offset -> IO (t,t,t,t)
unsafeWritePixel1 :: PixelComponent t => Bitmap t -> Offset -> t -> IO ()
unsafeWritePixel2 :: PixelComponent t => Bitmap t -> Offset -> (t,t) -> IO ()
unsafeWritePixel3 :: PixelComponent t => Bitmap t -> Offset -> (t,t,t) -> IO ()
unsafeWritePixel4 :: PixelComponent t => Bitmap t -> Offset -> (t,t,t,t) -> IO ()
unsafeReadPixel1 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x] -> x ) $ peekArray 1 p
unsafeReadPixel2 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x,y] -> (x,y) ) $ peekArray 2 p
unsafeReadPixel3 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x,y,z] -> (x,y,z) ) $ peekArray 3 p
unsafeReadPixel4 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x,y,z,w] -> (x,y,z,w)) $ peekArray 4 p
unsafeWritePixel1 bm xy x = withComponentPtr bm xy 0 $ \q -> pokeArray q [x]
unsafeWritePixel2 bm xy (x,y) = withComponentPtr bm xy 0 $ \q -> pokeArray q [x,y]
unsafeWritePixel3 bm xy (x,y,z) = withComponentPtr bm xy 0 $ \q -> pokeArray q [x,y,z]
unsafeWritePixel4 bm xy (x,y,z,w) = withComponentPtr bm xy 0 $ \q -> pokeArray q [x,y,z,w]
genericComponentRowMap
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> Ptr s -> Ptr t -> IO ())
-> Bitmap s -> Bitmap 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..h11]
(map (*xlen1) [0..h11])
(map (*xlen2) [0..h21])) $ \(ypos,vo1,vo2) -> do
let p1 = ptr1 `myPlusPtr` vo1
p2 = ptr2 `myPlusPtr` vo2
rowAction ypos npc p1 p2
genericPixelRowMap
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> Ptr s -> NChn -> Ptr t -> NChn -> IO ())
-> Bitmap s -> Bitmap 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..h11]
(map (*xlen1) [0..h11])
(map (*xlen2) [0..h21])) $ \(ypos,o1,o2) -> do
let p1 = ptr1 `myPlusPtr` o1
p2 = ptr2 `myPlusPtr` o2
rowAction ypos minw p1 nchn1 p2 nchn2
genericComponentMap
:: forall s t . (PixelComponent s, PixelComponent t)
=> (s -> t) -> Bitmap s -> Bitmap 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..n1]
genericComponentMapWithPos
:: forall s t . (PixelComponent s, PixelComponent t)
=> (Int -> Int -> s -> t) -> Bitmap s -> Bitmap 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..n1]
componentMap :: PixelComponent s => (s -> s) -> Bitmap s -> IO (Bitmap s)
componentMap f bm1 = do
let siz = bitmapSize bm1
nchn = bitmapNChannels bm1
align = bitmapRowAlignment bm1
bm2 <- newBitmapUninitialized siz nchn (Just align)
genericComponentMap f bm1 bm2
return bm2
componentMapInPlace :: PixelComponent s => (s -> s) -> Bitmap s -> IO ()
componentMapInPlace f bm = do
genericComponentMap f bm bm
componentMap'
:: (PixelComponent s, PixelComponent t)
=> (s -> t)
-> Bitmap s
-> Maybe Alignment
-> IO (Bitmap t)
componentMap' f bm1 malign = do
let siz = bitmapSize bm1
nchn = bitmapNChannels bm1
x = bitmapPaddedRowSizeInBytes bm1
bm2 <- newBitmapUninitialized siz nchn malign
genericComponentMap f bm1 bm2
return bm2
copySubImage
:: PixelComponent t
=> Bitmap t
-> Offset
-> Size
-> IO (Bitmap t)
copySubImage bm ofs1 siz1 = copySubImage' bm ofs1 siz1 (0,0) siz1
copySubImage'
:: PixelComponent t
=> Bitmap t
-> Offset
-> Size
-> Size
-> Offset
-> IO (Bitmap t)
copySubImage' bm1 ofs1 rsiz tsiz ofs2 = do
let align = bitmapRowAlignment bm1
nchn = bitmapNChannels bm1
bm2 <- newBitmap tsiz nchn (Just align)
copySubImageInto bm1 ofs1 rsiz bm2 ofs2
return bm2
copySubImageInto
:: PixelComponent t
=> Bitmap t
-> Offset
-> Size
-> Bitmap t
-> 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"
let (o1x1,sx1,o2x1) = if o1x0 >= 0 then (o1x0, sx0, o2x0) else (0, sx0+o1x0, o2x0o1x0)
(o1y1,sy1,o2y1) = if o1y0 >= 0 then (o1y0, sy0, o2y0) else (0, sy0+o1y0, o2y0o1y0)
(o1x ,sx ,o2x ) = if o2x1 >= 0 then (o1x1, sx1, o2x1) else (o1x1o2x1, sx1+o2x1, 0)
(o1y ,sy ,o2y ) = if o2y1 >= 0 then (o1y1, sy1, o2y1) else (o1y1o2y1, sy1+o2y1, 0)
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+ys1])
(map (*xlen2) [o2y..o2y+ys1])) $ \(vo1,vo2) -> do
let p1 = ptr1 `plusPtr` vo1
p2 = ptr2 `plusPtr` vo2
c_memcpy p1 p2 nbytes
extractSingleChannel
:: PixelComponent t
=> Bitmap t
-> Maybe Alignment
-> Int
-> IO (Bitmap 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 <- newBitmapUninitialized siz 1 malign
extractChannelInto bm1 j bm2 0
return bm2
extractChannels :: PixelComponent t => Bitmap t -> Maybe Alignment -> IO [Bitmap t]
extractChannels bm malign =
mapM (extractSingleChannel bm malign) [0..nchn1]
where nchn = bitmapNChannels bm
combineChannels :: forall t. PixelComponent t => [Bitmap t] -> Maybe Alignment -> IO (Bitmap 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 <- newBitmapUninitialized 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
(c_type (undefined::t))
(ci w) (ci h)
ptr1 (ci nchn1) (ci pad1) (ci j)
ptr2 (ci sumchn) (ci pad2) (ci i)
return bm2
extractChannelInto
:: forall t. PixelComponent t
=> Bitmap t
-> Int
-> Bitmap t
-> Int
-> 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
(c_type (undefined::t))
(ci w) (ci h)
ptr1 (ci nchn1) (ci pad1) (ci ofs1)
ptr2 (ci nchn2) (ci pad2) (ci ofs2)
bilinearResample
:: PixelComponent t
=> Bitmap t
-> Size
-> Maybe Alignment
-> IO (Bitmap t)
bilinearResample bm1 siz2@(w2,h2) malign = do
let nchn1 = bitmapNChannels bm1
bm2 <- newBitmapUninitialized siz2 nchn1 malign
forM_ [0..nchn11] $ \ofs ->
bilinearResampleChannelInto bm1 ofs bm2 ofs
return bm2
bilinearResampleChannel
:: PixelComponent t
=> Bitmap t
-> Int
-> Size
-> Maybe Alignment
-> IO (Bitmap 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 <- newBitmapUninitialized siz2 1 malign
bilinearResampleChannelInto bm1 ofs1 bm2 0
return bm2
bilinearResampleChannelInto
:: forall t. PixelComponent t
=> Bitmap t
-> Int
-> Bitmap t
-> Int
-> 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 (undefined::t))
(ci w1) (ci h1) ptr1 (ci nchn1) (ci pad1) (ci ofs1)
(ci w2) (ci h2) ptr2 (ci nchn2) (ci pad2) (ci ofs2)
powerlawGammaCorrection
:: forall t. PixelComponent t
=> Float
-> Bitmap t
-> Maybe Alignment
-> IO (Bitmap t)
powerlawGammaCorrection gamma bm1 malign = do
let nchn1 = bitmapNChannels bm1
siz1@(w1,h1) = bitmapSize bm1
pad1 = bitmapRowPadding bm1
fptr1 = bitmapPtr bm1
bm2 <- newBitmapUninitialized siz1 nchn1 malign
let pad2 = bitmapRowPadding bm2
fptr2 = bitmapPtr bm2
withForeignPtr fptr1 $ \ptr1 ->
withForeignPtr fptr2 $ \ptr2 ->
c_gamma_correct_all_channels
(c_type (undefined::t))
(realToFrac gamma)
(ci w1) (ci h1) (ci nchn1)
ptr1 (ci pad1)
ptr2 (ci pad2)
return bm2
powerlawGammaCorrectionChannel
:: PixelComponent t
=> Float
-> Bitmap t
-> Int
-> Maybe Alignment
-> IO (Bitmap 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 <- newBitmapUninitialized siz1 1 malign
powerlawGammaCorrectionChannelInto gamma bm1 ofs1 bm2 0
return bm2
powerlawGammaCorrectionChannelInto
:: forall t. PixelComponent t
=> Float
-> Bitmap t
-> Int
-> Bitmap t
-> Int
-> 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 (undefined::t))
(realToFrac gamma)
(ci w1) (ci h1)
ptr1 (ci nchn1) (ci pad1) (ci ofs1)
ptr2 (ci nchn2) (ci pad2) (ci ofs2)
blendBitmaps
:: PixelComponent t
=> Float
-> Float
-> Bitmap t
-> Bitmap t
-> Maybe Alignment
-> IO (Bitmap t)
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 <- newBitmapUninitialized siz1 nchn1 malign
forM [0..nchn11] $ \ofs ->
blendChannelsInto weight1 weight2 bm1 ofs bm2 ofs bm3 ofs
return bm3
blendChannels
:: PixelComponent t
=> Float
-> Float
-> Bitmap t
-> Int
-> Bitmap t
-> Int
-> Maybe Alignment
-> IO (Bitmap 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 <- newBitmapUninitialized siz1 1 malign
blendChannelsInto weight1 weight2 bm1 ofs1 bm2 ofs2 bm3 0
return bm3
blendChannelsInto
:: forall t. PixelComponent t
=> Float
-> Float
-> Bitmap t
-> Int
-> Bitmap t
-> Int
-> Bitmap t
-> Int
-> 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
(c_type (undefined::t))
(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)
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
copyBitmapFromByteString :: forall t. 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 > lenofs
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 }
advancePtr1 :: forall a. Storable a => Ptr a -> Ptr a
advancePtr1 p = p `plusPtr` (sizeOf (undefined::a))
myPlusPtr :: Ptr a -> Int -> Ptr a
myPlusPtr = plusPtr
ci :: Int -> CInt
ci = fromIntegral
foreign import ccall unsafe "bm.h c_memset"
c_memset :: Ptr Word8 -> Int -> Word8 -> IO ()
foreign import ccall unsafe "bm.h c_memcpy"
c_memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
foreign import ccall unsafe "bm.h c_extract_channel"
c_extract_channel
:: CInt
-> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> IO ()
foreign import ccall unsafe "bm.h c_bilinear_resample_channel"
c_bilinear_resample_channel
:: CInt
-> CInt -> CInt -> Ptr a -> CInt -> CInt -> CInt
-> CInt -> CInt -> Ptr a -> CInt -> CInt -> CInt
-> IO ()
foreign import ccall unsafe "bm.h c_gamma_correct_channel"
c_gamma_correct_channel
:: CInt
-> CFloat
-> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> IO ()
foreign import ccall unsafe "bm.h c_gamma_correct_all_channels"
c_gamma_correct_all_channels
:: CInt
-> CFloat
-> CInt -> CInt -> CInt
-> Ptr a -> CInt
-> Ptr a -> CInt
-> IO ()
foreign import ccall unsafe "bm.h c_linear_combine_channels"
c_linear_combine_channels
:: CInt
-> CFloat -> CFloat
-> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> IO ()