module Data.Bitmap.IO
(
module Data.Bitmap.Base
, newBitmap
, newBitmapUninitialized
, copyBitmapFromPtr
, bitmapFromForeignPtrUnsafe
, withBitmap
, componentMap
, componentMap'
, componentMapInPlace
, copySubImage
, copySubImage'
, copySubImageInto
, combineChannels
, extractChannels
, extractSingleChannel
, extractChannelInto
, copyBitmapToByteString
, copyBitmapFromByteString
)
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
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
(pad,align) = case malign of
Nothing -> (0,1)
Just align -> let x1 = align * ((x0 + align 1) `div` align) in (x1 x0, align)
newBitmapRaw siz nchn pad align
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
genericComponentRowMap
:: (PixelComponent s, PixelComponent t)
=> (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_ (zip (map (*xlen1) [0..h11])
(map (*xlen2) [0..h21])) $ \(vo1,vo2) -> do
let p1 = ptr1 `myPlusPtr` vo1
p2 = ptr2 `myPlusPtr` vo2
rowAction npc p1 p2
genericPixelRowMap
:: (PixelComponent s, PixelComponent t)
=> (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_ (zip (map (*xlen1) [0..h11]) (map (*xlen2) [0..h21])) $ \(o1,o2) -> do
let p1 = ptr1 `plusPtr` o1
p2 = ptr2 `plusPtr` o2
rowAction 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 -> Ptr s -> Ptr t -> IO ()
g n p1 p2 = do
foldM_ h (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"
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)
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 `plusPtr` 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 ()