module Data.Bitmap.IO
(
module Data.Bitmap.Base
, IOBitmap
, IOBitmapChannel
, unsafeFreezeBitmap
, unsafeThawBitmap
, emptyBitmap
, cloneBitmap
, emptyCloneBitmap
, createSingleChannelBitmap
, newIOBitmap
, newIOBitmapUninitialized
, copyBitmapFromPtr
, ioBitmapFromForeignPtrUnsafe
, withIOBitmap
, componentMap
, componentMap'
, componentMapInPlace
, copySubImage
, copySubImage'
, copySubImageInto
, flipBitmap
, flipBitmapInPlace
, mirrorBitmap
, mirrorBitmapInPlace
, castBitmap
, combineChannels
, extractChannels
, extractSingleChannel
, extractChannelInto
, bilinearResample
, bilinearResampleChannel
, bilinearResampleChannelInto
, blendBitmaps
, blendChannels
, blendChannelsInto
, powerlawGammaCorrection
, powerlawGammaCorrectionChannel
, powerlawGammaCorrectionChannelInto
)
where
import Control.Monad
import Control.Applicative
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)"
allocBitmap :: PixelComponent t => Bitmap t -> IO (Bitmap t)
allocBitmap bm0 = do
fptr <- mallocForeignPtrBytes (bitmapSizeInBytes bm0)
return $ bm0 { _bitmapPtr = fptr }
allocIOBitmap :: PixelComponent t => IOBitmap t -> IO (IOBitmap t)
allocIOBitmap bm = IOBitmap <$> (allocBitmap $ unIOBitmap bm)
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
}
IOBitmap <$> allocBitmap bm0
newIOBitmap
:: PixelComponent t
=> Size
-> NChn
-> Maybe Alignment
-> IO (IOBitmap t)
newIOBitmap siz nchn malign = do
bm <- newIOBitmapUninitialized siz nchn malign
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
, _bitmapRowAlignment = align
}
bm <- allocBitmapWithRecommendedPadding bm0
return (IOBitmap bm)
createSingleChannelBitmap
:: PixelComponent t
=> Size
-> Maybe Alignment
-> (Int -> Int -> t)
-> IO (IOBitmap t)
createSingleChannelBitmap siz malign fun = do
bm <- newIOBitmapUninitialized siz 1 malign
let fptr = bitmapPtr bm
len = bitmapSizeInBytes bm
f x y _ = fun x y
genericComponentMapWithPos f bm bm
return bm
copyBitmapFromPtr
:: PixelComponent t
=> Size
-> NChn
-> Padding
-> Ptr t
-> Maybe 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..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
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 :: 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
genericComponentRowMap
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> Ptr s -> Ptr t -> IO ())
-> 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..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 ())
-> 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..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
:: (PixelComponent s, PixelComponent t)
=> (s -> t) -> IOBitmap s -> IOBitmap t -> IO ()
genericComponentMap f bm1 bm2 = genericComponentRowMap g bm1 bm2 where
h (q1,q2) _ = do
x <- peek q1
poke q2 (f x)
return (advancePtr1 q1, advancePtr1 q2)
g ypos n p1 p2 = do
foldM_ h (p1,p2) [0..n1]
genericComponentMapWithPos
:: (PixelComponent s, PixelComponent t)
=> (Int -> Int -> s -> t) -> IOBitmap s -> IOBitmap t -> IO ()
genericComponentMapWithPos f bm1 bm2 = genericComponentRowMap g bm1 bm2 where
h ypos (q1,q2) xpos = do
x <- peek q1
poke q2 (f xpos ypos x)
return (advancePtr1 q1, advancePtr1 q2)
g ypos n p1 p2 = do
foldM_ (h ypos) (p1,p2) [0..n1]
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
componentMap'
:: (PixelComponent s, PixelComponent t)
=> (s -> t)
-> IOBitmap s
-> Maybe Alignment
-> 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
cloneBitmap
:: PixelComponent t
=> IOBitmap t
-> Maybe 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..h11] $ \i -> do
let p = plusPtr ptr1 (i*xlen1)
q = plusPtr ptr2 (i*xlen2)
c_memcpy p q len1
return bm2
emptyCloneBitmap
:: PixelComponent t
=> IOBitmap t
-> Maybe Alignment
-> IO (IOBitmap t)
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
emptyBitmap
:: PixelComponent t
=> Size
-> NChn
-> Maybe Alignment
-> IO (IOBitmap t)
emptyBitmap = newIOBitmap
copySubImage
:: PixelComponent t
=> IOBitmap t
-> Offset
-> Size
-> IO (IOBitmap t)
copySubImage bm ofs1 siz1 = copySubImage' bm ofs1 siz1 siz1 (0,0)
copySubImage'
:: PixelComponent t
=> IOBitmap t
-> Offset
-> Size
-> Size
-> 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
copySubImageInto
:: PixelComponent t
=> IOBitmap t
-> Offset
-> Size
-> IOBitmap 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
castBitmap
:: (PixelComponent s, PixelComponent t)
=> IOBitmap s
-> Maybe 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
ptr2 (ci nchn1) (ci pad2) 0
return bm2
_flipBitmapInto
:: PixelComponent t
=> IOBitmap t
-> IOBitmap t
-> 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 = h11i
p1 = plusPtr ptr1 (i*xlen1)
q1 = plusPtr ptr1 (j*xlen1)
p2 = plusPtr ptr2 (i*xlen2)
q2 = plusPtr ptr2 (j*xlen2)
c_memcpy p1 tmp len1
c_memcpy q1 p2 len1
c_memcpy tmp q2 len1
else do
forM_ [0..h11] $ \i -> do
let j = h11i
p = plusPtr ptr1 (i*xlen1)
q = plusPtr ptr2 (j*xlen2)
c_memcpy p q len1
flipBitmap
:: PixelComponent t
=> IOBitmap t
-> Maybe 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
-> IO ()
flipBitmapInPlace bm = do
_flipBitmapInto bm bm
_mirrorBitmapInto
:: PixelComponent t
=> IOBitmap t
-> IOBitmap t
-> 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..h11] $ \i -> do
let p = plusPtr ptr1 (i*xlen1)
q = plusPtr ptr2 (i*xlen2)
c_mirror_line (ci w1) (ci bpp1) p q
mirrorBitmap
:: PixelComponent t
=> IOBitmap t
-> Maybe 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
-> IO ()
mirrorBitmapInPlace bm = do
_mirrorBitmapInto bm bm
extractSingleChannel
:: PixelComponent t
=> IOBitmap t
-> Maybe Alignment
-> Int
-> 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..nchn1]
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
-> Int
-> IOBitmap 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
(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
-> Size
-> Maybe Alignment
-> IO (IOBitmap t)
bilinearResample bm1 siz2@(w2,h2) malign = do
let nchn1 = bitmapNChannels bm1
bm2 <- newIOBitmapUninitialized siz2 nchn1 malign
forM_ [0..nchn11] $ \ofs ->
bilinearResampleChannelInto bm1 ofs bm2 ofs
return bm2
bilinearResampleChannel
:: PixelComponent t
=> IOBitmap t
-> Int
-> Size
-> Maybe 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
-> Int
-> IOBitmap 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 (bitmapUndefined bm1))
(ci w1) (ci h1) ptr1 (ci nchn1) (ci pad1) (ci ofs1)
(ci w2) (ci h2) ptr2 (ci nchn2) (ci pad2) (ci ofs2)
powerlawGammaCorrection
:: PixelComponent t
=> Float
-> IOBitmap t
-> Maybe 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
-> IOBitmap t
-> Int
-> Maybe 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
-> IOBitmap t
-> Int
-> IOBitmap 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 (bitmapUndefined bm1))
(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
-> IOBitmap t
-> IOBitmap t
-> Maybe Alignment
-> IO (IOBitmap 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 <- newIOBitmapUninitialized siz1 nchn1 malign
forM [0..nchn11] $ \ofs ->
blendChannelsInto weight1 weight2 bm1 ofs bm2 ofs bm3 ofs
return bm3
blendChannels
:: PixelComponent t
=> Float
-> Float
-> IOBitmap t
-> Int
-> IOBitmap t
-> Int
-> Maybe 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
-> Float
-> IOBitmap t
-> Int
-> IOBitmap t
-> Int
-> IOBitmap 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
(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)
ptrUndefined :: Ptr a -> a
ptrUndefined _ = undefined
advancePtr1 :: Storable a => Ptr a -> Ptr a
advancePtr1 p = p `plusPtr` (sizeOf (ptrUndefined p))
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_mirror_line"
c_mirror_line
:: CInt
-> CInt
-> Ptr a
-> Ptr a
-> IO ()
foreign import ccall unsafe "bm.h c_cast_bitmap"
c_cast_bitmap
:: CInt -> CInt
-> CInt -> CInt
-> Ptr a -> CInt -> CInt -> CInt
-> Ptr b -> CInt -> CInt -> CInt
-> 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 ()