diff --git a/Data/Bitmap.hs b/Data/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap.hs @@ -0,0 +1,53 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap +-- Version : 0.0.0 +-- License : BSD3 +-- Copyright : (c) 2009 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI, CPP and ScopedTypeVariables +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | A library to handle bitmaps (uncompressed pixel rectangles). +-- The smallest storage unit is 1 byte (thus /bit/maps, in the literal sense +-- of the word, are not supported). +-- You may want to import this module qualified. +-- +-- Terminology: +-- Pixels are made out of one or more \"components\". These components +-- are also referred as \"channels\"; for example a color image could be made out +-- of three channels, the red, green and blue one. The components can be unsigned +-- bytes, words, dwords, or floats. The pixels are stored in horizontal order, +-- and the channels are interleaved: That is, the structure of an RGB image is +-- @R0 G0 B0 R1 G1 B1 ...@. +-- Most of the library is agnostic to the meaning of different channels. +-- +-- \"Padding\" refers to unused bytes at the end of each row. This is sometimes +-- necessary because other software components want the rows aligned to machine +-- word boundary, for example. +-- +-- The library should be relatively fast (except where noted), but +-- performance is not the primary goal (thus there is no inline assembly, +-- no SSE, etc). +-- +-- There are both pure and IO versions of the API; you shouldn't mix +-- the two without taking special care. +-- This module re-exports the pure interface; if you want the IO one, +-- import 'Data.Bitmap.IO' instead. +-- + +{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +module Data.Bitmap + ( module Data.Bitmap.Pure + ) + where + +-------------------------------------------------------------------------------- + +import Data.Bitmap.Pure + +-------------------------------------------------------------------------------- + diff --git a/Data/Bitmap/Base.hs b/Data/Bitmap/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/Base.hs @@ -0,0 +1,68 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.Base +-- Version : 0.0.0 +-- License : BSD3 +-- Copyright : (c) 2009 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI, CPP and ScopedTypeVariables +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- +-- Terminology: +-- Pixels are made out of one or more \"components\". These components +-- are also referred as \"channels\"; for example a color image could be made out +-- of three channels, the red, green and blue one. The components can be unsigned +-- bytes, words, dwords, or floats. The pixels are stored in horizontal order, +-- and the channels are interleaved: That is, the structure of an RGB image is +-- @R0 G0 B0 R1 G1 B1 ...@. +-- Most of the library is agnostic to the meaning of different channels. +-- The fixed point types (byte, word and dword) are interpreted as numbers +-- between 0 and 1; the floating point type can exceed the [0..1] interval. +-- +-- \"Padding\" refers to unused bytes at the end of each row. This is sometimes +-- necessary because other software components want the rows aligned to machine +-- word boundary, for example. +-- + +{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +module Data.Bitmap.Base + ( + -- * Types + PixelComponent + , PixelComponentType(..) + , pixelComponentType + -- + , Word8 + , Word16 + , Word32 + -- + , Size + , Offset + , NChn + , Alignment + , Padding + -- + , Bitmap + , bitmapSize + , bitmapNChannels + , bitmapRowPadding + , bitmapRowAlignment + -- + , bitmapComponentSizeInBytes + , bitmapPixelSizeInBytes + , bitmapPaddedRowSizeInBytes + , bitmapUnpaddedRowSizeInBytes + , bitmapSizeInBytes + ) + where + +-------------------------------------------------------------------------------- + +import Data.Word +import Data.Bitmap.Internal + +-------------------------------------------------------------------------------- diff --git a/Data/Bitmap/IO.hs b/Data/Bitmap/IO.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/IO.hs @@ -0,0 +1,539 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.IO +-- Version : 0.0.0 +-- License : BSD3 +-- Copyright : (c) 2009 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI, CPP and ScopedTypeVariables +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | The full, mutable API in the IO monad. + +{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +{-# CFILES cbits/bm.c #-} -- for Hugs +module Data.Bitmap.IO + ( + module Data.Bitmap.Base + -- * Creating and accessing bitmaps + , newBitmap + , newBitmapUninitialized + , copyBitmapFromPtr + , bitmapFromForeignPtrUnsafe + , withBitmap + -- * Mapping over bitmaps + , componentMap + , componentMap' + , componentMapInPlace + -- * Cropping and extending + , copySubImage + , copySubImage' + , copySubImageInto + -- * Manipulating channels + , combineChannels + , extractChannels + , extractSingleChannel + , extractChannelInto + -- * Conversion to\/from ByteString + , copyBitmapToByteString + , copyBitmapFromByteString + ) + where + +-------------------------------------------------------------------------------- + +import Control.Monad + +--import Data.Array.IArray + +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 (width,row) nchannels padding@. We do not initialize the new bitmap! +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 } + +-- | 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. +-- +-- The resulting new bitmap is filled with zeros. +newBitmap + :: forall t. PixelComponent t + => Size -- ^ (width,height) + -> NChn -- ^ number of channels (components\/pixel) + -> Maybe Alignment -- ^ the row alignment of the new image + -> IO (Bitmap t) +newBitmap siz nchn malign = do + bm <- newBitmapUninitialized siz nchn malign -- :: IO (Bitmap t) + 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 -- ^ (width,height) of the source + -> NChn -- ^ number of channels in the source + -> Padding -- ^ source padding + -> Ptr t -- ^ the source + -> Maybe Alignment -- ^ target 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..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 + +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 bitmap $ \\(w,h) nchn padding ptr -> ...@ +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 + +-------------------------------------------------------------------------------- + +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Word8 -> Ptr Word8 -> IO ()) -> Bitmap Word8 -> Bitmap Word8 -> IO () #-} +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Word16 -> Ptr Word16 -> IO ()) -> Bitmap Word16 -> Bitmap Word16 -> IO () #-} +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Word32 -> Ptr Word32 -> IO ()) -> Bitmap Word32 -> Bitmap Word32 -> IO () #-} +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Float -> Ptr Float -> IO ()) -> Bitmap Float -> Bitmap Float -> IO () #-} + +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Word8 -> Ptr Float -> IO ()) -> Bitmap Word8 -> Bitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Float -> Ptr Word8 -> IO ()) -> Bitmap Float -> Bitmap Word8 -> IO () #-} + +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Word16 -> Ptr Float -> IO ()) -> Bitmap Word16 -> Bitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentRowMap + :: (Int -> Ptr Float -> Ptr Word16 -> IO ()) -> Bitmap Float -> Bitmap Word16 -> IO () #-} + +-- the @Int@ is the number of pixel components (nchn*width) +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..h1-1]) + (map (*xlen2) [0..h2-1])) $ \(vo1,vo2) -> do + let p1 = ptr1 `myPlusPtr` vo1 + p2 = ptr2 `myPlusPtr` vo2 + rowAction npc p1 p2 + +------- + +-- the @Int@ is the number of pixels (width) +genericPixelRowMap + :: (PixelComponent s, PixelComponent t) + => (Int -> Ptr s -> NChn -> Ptr t -> NChn -> IO ()) -- width ptr1 nchn1 ptr2 nchn2 + -> 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..h1-1]) (map (*xlen2) [0..h2-1])) $ \(o1,o2) -> do + let p1 = ptr1 `plusPtr` o1 + p2 = ptr2 `plusPtr` o2 + rowAction minw p1 nchn1 p2 nchn2 + +-------------------------------------------------------------------------------- + +{-# SPECIALIZE genericComponentMap :: (Word8 -> Word8 ) -> Bitmap Word8 -> Bitmap Word8 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Word16 -> Word16) -> Bitmap Word16 -> Bitmap Word16 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Word32 -> Word32) -> Bitmap Word32 -> Bitmap Word32 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Float -> Float ) -> Bitmap Float -> Bitmap Float -> IO () #-} + +{-# SPECIALIZE genericComponentMap :: (Word8 -> Float ) -> Bitmap Word8 -> Bitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Float -> Word8 ) -> Bitmap Float -> Bitmap Word8 -> IO () #-} + +{-# SPECIALIZE genericComponentMap :: (Word16 -> Float ) -> Bitmap Word16 -> Bitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Float -> Word16) -> Bitmap Float -> Bitmap Word16 -> IO () #-} + +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..n-1] + + +-- | Maps a function over each component of each pixel. Warning: this is 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) -> Bitmap s -> IO (Bitmap s) +componentMap f bm1 = do + let siz = bitmapSize bm1 + nchn = bitmapNChannels bm1 + align = bitmapRowAlignment bm1 +-- x = bitmapPaddedRowSizeInBytes 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 + +-- | See the comments at 'componentMap'. +componentMap' + :: (PixelComponent s, PixelComponent t) + => (s -> t) + -> Bitmap s -- ^ source bitmap + -> Maybe Alignment -- ^ row alignment of the resulting bitmap + -> 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 + +-------------------------------------------------------------------------------- + +-- | Copies a subrectangle of the source image into a new image. +copySubImage + :: PixelComponent t + => Bitmap t -- ^ source image + -> Offset -- ^ source rectangle offset + -> Size -- ^ source rectangle size + -> IO (Bitmap t) +copySubImage bm ofs1 siz1 = copySubImage' bm ofs1 siz1 (0,0) siz1 + +-- | Copy into a new \"black\" bitmap; common generalization of crop and extend. +copySubImage' + :: PixelComponent t + => Bitmap t -- ^ source image + -> Offset -- ^ source rectangle offset + -> Size -- ^ source rectangle size + -> Size -- ^ target image size + -> Offset -- ^ target rectangle 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 + +-- | 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 + => Bitmap t -- ^ source image + -> Offset -- ^ source rectangle offset + -> Size -- ^ source rectangle size + -> Bitmap 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 + +-------------------------------------------------------------------------------- + +extractSingleChannel + :: PixelComponent t + => Bitmap t -- ^ source image + -> Maybe Alignment -- ^ target image row alignment + -> Int -- ^ source channel index + -> IO (Bitmap t) +extractSingleChannel bm1 malign j = do + let nchn = bitmapNChannels bm1 + siz@(w,h) = bitmapSize bm1 + -- pad1 = bitmapRowPadding bm1 + -- fptr1 = bitmapPtr 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..nchn-1] + 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 -- ^ source image + -> Int -- ^ source channel index + -> Bitmap 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" + + 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) + +-------------------------------------------------------------------------------- + +-- | The data is copied, not shared. +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. +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 > len-ofs + 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 } + +-------------------------------------------------------------------------------- + +-- 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)) + +-- 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 + +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 () + +{- +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 + ); +-} + +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 () + +-------------------------------------------------------------------------------- diff --git a/Data/Bitmap/Internal.hs b/Data/Bitmap/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/Internal.hs @@ -0,0 +1,105 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.Internal +-- Version : 0.0.0 +-- License : BSD3 +-- Copyright : (c) 2009 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI, CPP and ScopedTypeVariables +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +module Data.Bitmap.Internal where + +-------------------------------------------------------------------------------- + +import Control.Monad + +--import Data.Array.IArray +import Data.Word + +import Foreign +import Foreign.C + +-------------------------------------------------------------------------------- + +data PixelComponentType + = PctWord8 + | PctWord16 + | PctWord32 + | PctFloat + deriving Show + +class (Num t, Storable t) => PixelComponent t where + c_type :: t -> CInt + nbytes :: t -> Int + nbytes x = sizeOf x + toFloat :: t -> Float + fromFloat :: Float -> t + +pixelComponentType :: PixelComponent t => t -> PixelComponentType +pixelComponentType t = case c_type t of + 1 -> PctWord8 + 2 -> PctWord16 + 3 -> PctWord32 + 4 -> PctFloat + +instance PixelComponent Word8 where + c_type _ = 1 + fromFloat = floor . (*255.99999) + toFloat = (*3.92156862745098e-3) . fromIntegral -- 1/255 + +instance PixelComponent Word16 where + c_type _ = 2 + fromFloat = floor . (*65535.99999) + toFloat = (*1.5259021896696422e-5) . fromIntegral -- 1/65535 + +instance PixelComponent Word32 where + c_type _ = 3 + fromFloat = floor . (*4294967295.99999) + toFloat = (*2.3283064370807974e-10) . fromIntegral -- 1/(2^32-1) + +instance PixelComponent Float where + c_type _ = 4 + toFloat = id + fromFloat = id + +-- to provide better documentation +type Size = (Int,Int) +type Offset = (Int,Int) +type NChn = Int +type Padding = Int +type Alignment = Int + +data Bitmap t = Bitmap + { bitmapSize :: Size -- ^ (width,height) + , bitmapNChannels :: NChn -- ^ number of channels (eg. 3 for RGB) + , bitmapPtr :: ForeignPtr t -- ^ pointer to the data + , bitmapRowPadding :: Padding -- ^ the padding of the rows, measured in /bytes/ + , bitmapRowAlignment :: Alignment -- ^ the alignment of the rows (in bytes) + } + deriving Show + +bitmapComponentSizeInBytes :: forall t. PixelComponent t => Bitmap t -> Int +bitmapComponentSizeInBytes _ = sizeOf (undefined::t) + +bitmapPixelSizeInBytes :: PixelComponent t => Bitmap t -> Int +bitmapPixelSizeInBytes bm = bitmapNChannels bm * bitmapComponentSizeInBytes bm + +bitmapUnpaddedRowSizeInBytes :: forall t. PixelComponent t => Bitmap t -> Int +bitmapUnpaddedRowSizeInBytes bm = w * sizeOf (undefined::t) * nchn where + (w,h) = bitmapSize bm + nchn = bitmapNChannels bm + +bitmapPaddedRowSizeInBytes :: PixelComponent t => Bitmap t -> Int +bitmapPaddedRowSizeInBytes bm = bitmapUnpaddedRowSizeInBytes bm + bitmapRowPadding bm + +bitmapSizeInBytes :: PixelComponent t => Bitmap t -> Int +bitmapSizeInBytes bm = h*x where + x = bitmapPaddedRowSizeInBytes bm + (_,h) = bitmapSize bm + +-------------------------------------------------------------------------------- diff --git a/Data/Bitmap/Pure.hs b/Data/Bitmap/Pure.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/Pure.hs @@ -0,0 +1,145 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.Pure +-- Version : 0.0.0 +-- License : BSD3 +-- Copyright : (c) 2009 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI, CPP and ScopedTypeVariables +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +module Data.Bitmap.Pure + ( + module Data.Bitmap.Base + + , emptyBitmap + -- * Mapping over bitmaps + , componentMap + , componentMap' + -- * Cropping and extending + , copySubImage + , copySubImage' + -- * Manipulating channels + , combineChannels + , extractChannels + , extractSingleChannel + -- * Conversion to ByteString + , bitmapToByteString + ) + where + +-------------------------------------------------------------------------------- + +import Data.Word + +import Foreign + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B + +import Data.Bitmap.Base +import Data.Bitmap.Internal +import qualified Data.Bitmap.IO as IO + +import System.IO.Unsafe + +-------------------------------------------------------------------------------- + +-- | A bitmap filled with zero values. +-- 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. +emptyBitmap + :: forall t. PixelComponent t + => Size -- ^ (width,height) + -> NChn -- ^ number of channels (components\/pixel) + -> Maybe Alignment -- ^ the row alignment of the new image + -> Bitmap t +emptyBitmap siz nchn malign = unsafePerformIO $ IO.newBitmap siz nchn malign + +-------------------------------------------------------------------------------- + +-- | Warning: this is probably slow +componentMap :: PixelComponent s => (s -> s) -> Bitmap s -> Bitmap s +componentMap f bm = unsafePerformIO $ IO.componentMap f bm + +-- | Warning: this is probably slow +componentMap' :: (PixelComponent s, PixelComponent t) => (s -> t) -> Bitmap s -> Maybe Alignment -> Bitmap t +componentMap' f bm malign = unsafePerformIO $ IO.componentMap' f bm malign + +-------------------------------------------------------------------------------- + +-- | Copies a subrectangle of the source image into a new image. +copySubImage + :: PixelComponent t + => Bitmap t -- ^ source image + -> Offset -- ^ source rectangle offset + -> Size -- ^ source rectangle size + -> Bitmap t +copySubImage bm ofs siz = unsafePerformIO $ IO.copySubImage bm ofs siz + +-- | Copy into a new \"black\" bitmap; common generalization of crop and extend. +copySubImage' + :: PixelComponent t + => Bitmap t -- ^ source image + -> Offset -- ^ source rectangle offset + -> Size -- ^ source rectangle size + -> Size -- ^ target image size + -> Offset -- ^ target rectangle offset + -> Bitmap t +copySubImage' bm1 ofs1 rsiz tsiz ofs2 = unsafePerformIO $ + IO.copySubImage' bm1 ofs1 rsiz tsiz ofs2 + +-------------------------------------------------------------------------------- + +extractSingleChannel + :: PixelComponent t + => Bitmap t -- ^ source image + -> Maybe Alignment -- ^ target image row alignment + -> Int -- ^ source channel index + -> Bitmap t +extractSingleChannel bm1 malign j = unsafePerformIO $ + IO.extractSingleChannel bm1 malign j + +extractChannels :: PixelComponent t => Bitmap t -> Maybe Alignment -> [Bitmap t] +extractChannels bm malign = unsafePerformIO $ + IO.extractChannels bm malign + +combineChannels :: forall t. PixelComponent t => [Bitmap t] -> Maybe Alignment -> Bitmap t +combineChannels bms malign = unsafePerformIO $ + IO.combineChannels bms malign + +-------------------------------------------------------------------------------- + +-- | Note that the data is /shared/. +bitmapToByteString :: PixelComponent t => Bitmap t -> ByteString +bitmapToByteString bm = bs where + bs = B.fromForeignPtr (castForeignPtr $ bitmapPtr bm) 0 n + n = bitmapSizeInBytes bm + +{- +-- | As its name says, this pretty much unsafe! +reallyUnsafeBitmapFromByteString :: forall t. ByteString -> Size -> NChn -> Padding -> Bitmap t +reallyUnsafeBitmapFromByteString bs siz nchn pad = + if n > len || ofs /= 0 + then error "reallyUnsafeBitmapFromByteString: better than segfault :)" + else bm + where + bm = Bitmap + { bitmapSize = siz + , bitmapNChannels = nchn + , bitmapPtr = fptr + , bitmapRowPadding = pad + , bitmapRowAlignment = 1 + } :: Bitmap t + n = bitmapSizeInBytes bm + (fptr,ofs,len) = B.toForeignPtr bm +-} + +-------------------------------------------------------------------------------- + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2009, Balazs Komuves +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither names of the copyright holders nor the names of the contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/bitmap.cabal b/bitmap.cabal new file mode 100644 --- /dev/null +++ b/bitmap.cabal @@ -0,0 +1,43 @@ +Name: bitmap +Version: 0.0.0 +Synopsis: A library for handling and manipulating bitmaps. +Description: A library for handling and manipulating bitmaps (that is, + rectangular pixel arrays). +License: BSD3 +License-file: LICENSE +Copyright: (c) 2009 Balazs Komuves +Author: Balazs Komuves +Maintainer: bkomuves (plus) hackage (at) gmail (dot) com +Homepage: http://code.haskell.org/~bkomuves/ +Stability: Experimental +Category: Graphics, Data +Tested-With: GHC == 6.10.1 +Cabal-Version: >= 1.2 +Build-Type: Simple + +extra-source-files: cbits/bm.h + +Flag base4 + Description: Base v4 + +Library + if flag(base4) + Build-Depends: base >= 4 && < 5, array, containers, bytestring >= 0.9 + cpp-options: -DBASE_VERSION=4 + else + Build-Depends: base >= 3 && < 4, array, containers, bytestring >= 0.9 + cpp-options: -DBASE_VERSION=3 + + Exposed-Modules: Data.Bitmap, + Data.Bitmap.Base, + Data.Bitmap.IO, + Data.Bitmap.Pure + + Other-Modules: Data.Bitmap.Internal + + Hs-Source-Dirs: . + Extensions: ForeignFunctionInterface, CPP, ScopedTypeVariables + + C-Sources: cbits/bm.c + Include-Dirs: cbits + diff --git a/cbits/bm.c b/cbits/bm.c new file mode 100644 --- /dev/null +++ b/cbits/bm.c @@ -0,0 +1,79 @@ + +/* +the C part of the Data.Bitmap library +(c) 2009 Balazs Komuves +*/ + +#include +#include "bm.h" + +// ----------------------------------------------------------------------------- + +void c_memset(word8 *q, int count, word8 x) +{ memset(q,x,count); +} + +// (from, to, count) +void c_memcpy(word8 *p, word8 *q, int count) +{ memcpy(q,p,count); +} + +// ----------------------------------------------------------------------------- + +#define K_WORD8 1 +#define K_WORD16 2 +#define K_WORD32 3 +#define K_FLOAT 4 + +#define PLUSPTR(P,TYP,K) P=(TYP*)(((word8*)P)+K); + +// ----------------------------------------------------------------------------- + +#define C_EXTRACT_CHANNEL(TYP) \ +void c_extract_channel_ ## TYP \ + ( int width, int height \ + , TYP *p1, int nchn1, int pad1, int ofs1 \ + , TYP *p2, int nchn2, int pad2, int ofs2 \ + ) \ +{ int x,y; \ + TYP *q1,*q2; \ + q1 = p1 + ofs1; \ + q2 = p2 + ofs2; \ + for(y=0;y + +typedef uint8_t word8; +typedef uint16_t word16; +typedef uint32_t word32; + +//------------------------------------------------------------------------------ + +void c_memset(word8 *q, int count, word8 x); + +// (from, to, count) +void c_memcpy(word8 *p, word8 *q, int count); + +//------------------------------------------------------------------------------ + +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 + );