packages feed

bitmap (empty) → 0.0.0

raw patch · 10 files changed

+1087/−0 lines, 10 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, containers

Files

+ Data/Bitmap.hs view
@@ -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++--------------------------------------------------------------------------------+
+ Data/Bitmap/Base.hs view
@@ -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++--------------------------------------------------------------------------------
+ Data/Bitmap/IO.hs view
@@ -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 ()+        +--------------------------------------------------------------------------------
+ Data/Bitmap/Internal.hs view
@@ -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  ++--------------------------------------------------------------------------------
+ Data/Bitmap/Pure.hs view
@@ -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+-}+  +--------------------------------------------------------------------------------+
+ LICENSE view
@@ -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.+
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell
+ 
+> import Distribution.Simple
+> main = defaultMain
+ bitmap.cabal view
@@ -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+
+ cbits/bm.c view
@@ -0,0 +1,79 @@++/*+the C part of the Data.Bitmap library+(c) 2009 Balazs Komuves+*/++#include <string.h>+#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<height;y++)   \+  { for(x=0;x<width;x++)  \+    { *q2 = *q1;    \+      q1 += nchn1;  \+      q2 += nchn2;  \+    }               \+    PLUSPTR(q1,TYP,pad1); \+    PLUSPTR(q2,TYP,pad2); \+  }   \+} ++C_EXTRACT_CHANNEL(word8 )+C_EXTRACT_CHANNEL(word16)+C_EXTRACT_CHANNEL(word32)+C_EXTRACT_CHANNEL(float )++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 +  ) +{ switch(k_type)+  { case K_WORD8: +      c_extract_channel_word8 ( width,height, p1,nchn1,pad1,ofs1, p2,nchn2,pad2,ofs2 );+      break;+    case K_WORD16: +      c_extract_channel_word16( width,height, p1,nchn1,pad1,ofs1, p2,nchn2,pad2,ofs2 );+      break;+    case K_WORD32: +      c_extract_channel_word32( width,height, p1,nchn1,pad1,ofs1, p2,nchn2,pad2,ofs2 );+      break;+    case K_FLOAT: +      c_extract_channel_float ( width,height, p1,nchn1,pad1,ofs1, p2,nchn2,pad2,ofs2 );+      break;+  }+}+
+ cbits/bm.h view
@@ -0,0 +1,22 @@++#include <stdint.h>++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 +  );