diff --git a/Data/Bitmap.hs b/Data/Bitmap.hs --- a/Data/Bitmap.hs +++ b/Data/Bitmap.hs @@ -1,13 +1,13 @@ -------------------------------------------------------------------------------- -- Module : Data.Bitmap --- Version : 0.0.1 +-- Version : 0.0.2 -- License : BSD3 --- Copyright : (c) 2009 Balazs Komuves +-- Copyright : (c) 2009-2010 Balazs Komuves -- Author : Balazs Komuves -- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com -- Stability : experimental --- Portability : requires FFI, CPP and ScopedTypeVariables +-- Portability : requires FFI and CPP -- Tested with : GHC 6.10.1 -------------------------------------------------------------------------------- @@ -36,21 +36,18 @@ -- performance is not the primary goal (thus there is no inline assembly, -- no SSE, etc.; but the critical functions are coded in C). -- --- 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. +-- There are both pure and mutable IO versions of the API (ST is also planned). +-- This module re-exports the simplified pure interface. -- -{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} module Data.Bitmap - ( module Data.Bitmap.Pure + ( module Data.Bitmap.Simple ) where -------------------------------------------------------------------------------- -import Data.Bitmap.Pure +import Data.Bitmap.Simple -------------------------------------------------------------------------------- diff --git a/Data/Bitmap/Base.hs b/Data/Bitmap/Base.hs --- a/Data/Bitmap/Base.hs +++ b/Data/Bitmap/Base.hs @@ -1,13 +1,13 @@ -------------------------------------------------------------------------------- -- Module : Data.Bitmap.Base --- Version : 0.0.1 +-- Version : 0.0.2 -- 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 +-- Portability : requires FFI and CPP -- Tested with : GHC 6.10.1 -------------------------------------------------------------------------------- @@ -28,10 +28,10 @@ -- word boundary, for example. -- -{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Data.Bitmap.Base ( - -- * Types + -- PixelComponent , PixelComponentType(..) , pixelComponentSize @@ -53,12 +53,21 @@ , bitmapRowPadding , bitmapRowAlignment , bitmapAspect + , bitmapComponentType -- , bitmapComponentSizeInBytes , bitmapPixelSizeInBytes , bitmapPaddedRowSizeInBytes , bitmapUnpaddedRowSizeInBytes , bitmapSizeInBytes + -- + , BitmapClass -- (..) +{- + , Bitmap1, Bitmap2, Bitmap3, Bitmap4 + , bitmap1, bitmap2, bitmap3, bitmap4 +-} + -- + , BitmapChannel(..) ) where diff --git a/Data/Bitmap/IO.hs b/Data/Bitmap/IO.hs --- a/Data/Bitmap/IO.hs +++ b/Data/Bitmap/IO.hs @@ -1,30 +1,40 @@ -------------------------------------------------------------------------------- -- Module : Data.Bitmap.IO --- Version : 0.0.1 +-- Version : 0.0.2 -- License : BSD3 --- Copyright : (c) 2009 Balazs Komuves +-- Copyright : (c) 2009-2010 Balazs Komuves -- Author : Balazs Komuves -- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com -- Stability : experimental --- Portability : requires FFI, CPP and ScopedTypeVariables +-- Portability : requires FFI and CPP -- Tested with : GHC 6.10.1 -------------------------------------------------------------------------------- -- | The full, mutable API in the IO monad. -{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} {-# CFILES cbits/bm.c #-} -- for Hugs module Data.Bitmap.IO ( module Data.Bitmap.Base + -- * Mutable bitmap type + , IOBitmap + , IOBitmapChannel + , unsafeFreezeBitmap + , unsafeThawBitmap -- * Creating and accessing bitmaps - , newBitmap - , newBitmapUninitialized + , emptyBitmap + , cloneBitmap + , emptyCloneBitmap , createSingleChannelBitmap + , newIOBitmap + , newIOBitmapUninitialized , copyBitmapFromPtr - , bitmapFromForeignPtrUnsafe - , withBitmap + -- , bitmapFromForeignPtrUnsafe + , ioBitmapFromForeignPtrUnsafe + -- * Using bitmaps + , withIOBitmap -- * Mapping over bitmaps , componentMap , componentMap' @@ -33,6 +43,15 @@ , copySubImage , copySubImage' , copySubImageInto + -- * Flipping and mirroring + , flipBitmap + , flipBitmapInPlace + , mirrorBitmap + , mirrorBitmapInPlace + -- * Cast + , castBitmap + -- , castChannel + -- , castChannelInto -- * Manipulating channels , combineChannels , extractChannels @@ -50,11 +69,18 @@ , powerlawGammaCorrection , powerlawGammaCorrectionChannel , powerlawGammaCorrectionChannelInto +{- -- * Conversion to\/from ByteString , copyBitmapToByteString , copyBitmapFromByteString +-} +{- -- * Reading and writing pixels , withComponentPtr + , IOBitmap1 (..) + , IOBitmap2 (..) + , IOBitmap3 (..) + , IOBitmap4 (..) , unsafeReadComponent , unsafeWriteComponent , unsafeReadComponents @@ -68,20 +94,25 @@ , unsafeWritePixel2 , unsafeWritePixel3 , unsafeWritePixel4 +-} ) where -------------------------------------------------------------------------------- import Control.Monad +import Control.Applicative --import Data.Array.IArray import Data.Word import Data.List (nub) -import Foreign 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 @@ -91,7 +122,15 @@ import Data.Bitmap.Base -------------------------------------------------------------------------------- + +unsafeFreezeBitmap :: IOBitmap t -> Bitmap t +unsafeFreezeBitmap = unIOBitmap +unsafeThawBitmap :: Bitmap t -> IOBitmap t +unsafeThawBitmap = IOBitmap + +-------------------------------------------------------------------------------- + defaultAlignment :: Int defaultAlignment = 4 @@ -102,24 +141,36 @@ validateAlignment k = if isValidAlignment k then k - else error "invalid row alignment (allowed values: 1, 2, 4 and 8)" + else error "invalid row alignment (allowed values: 1, 2, 4, and 8)" -- and 16)" -------------------------------------------------------------------------------- - + +-- GHC's type inference is acting up, that's why we need this here +allocBitmap :: PixelComponent t => Bitmap t -> IO (Bitmap t) +allocBitmap bm0 = do + fptr <- mallocForeignPtrBytes (bitmapSizeInBytes bm0) -- :: IO (ForeignPtr t) + return $ bm0 { _bitmapPtr = fptr } + +allocIOBitmap :: PixelComponent t => IOBitmap t -> IO (IOBitmap t) +allocIOBitmap bm = IOBitmap <$> (allocBitmap $ unIOBitmap bm) + -- we do not initialize the new bitmap! -newBitmapRaw :: forall t. PixelComponent t => Size -> NChn -> Padding -> Alignment -> IO (Bitmap t) +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 - } :: Bitmap t - len = bitmapSizeInBytes bm0 - fptr <- mallocForeignPtrBytes len :: IO (ForeignPtr t) + { _bitmapSize = siz + , _bitmapNChannels = nchn + , _bitmapPtr = undefined + , _bitmapRowPadding = pad + , _bitmapRowAlignment = align + } -- :: Bitmap t +{- + let len = bitmapSizeInBytes bm0 + fptr <- mallocForeignPtrBytes len -- :: IO (ForeignPtr t) return $ bm0 { bitmapPtr = fptr } - +-} + IOBitmap <$> allocBitmap bm0 + -- | 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. @@ -129,67 +180,69 @@ -- smallest multiple of a component size such that the next row is aligned). -- -- The resulting new bitmap is filled with zeros. -newBitmap - :: forall t. PixelComponent t +newIOBitmap + :: 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) + -> IO (IOBitmap t) +newIOBitmap siz nchn malign = do + bm <- newIOBitmapUninitialized 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 - - align = validateMaybeAlignment malign - pad = recommendedPadding 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 +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 -- pad + , _bitmapRowAlignment = align + } -- :: Bitmap t +{- + let pad = recommendedPadding bm0 + newBitmapRaw siz nchn pad align +-} + bm <- allocBitmapWithRecommendedPadding bm0 + return (IOBitmap bm) + -- | Creates a new single-channel bitmap, using the given function to compute -- the pixel values. -- Warning, this is probably slow! createSingleChannelBitmap - :: forall t. PixelComponent t + :: PixelComponent t => Size -- ^ (width,height) -> Maybe Alignment -- ^ the row alignment of the new image -> (Int -> Int -> t) -- ^ the function we will use to fill the bitmap - -> IO (Bitmap t) + -> IO (IOBitmap t) createSingleChannelBitmap siz malign fun = do - bm <- newBitmapUninitialized siz 1 malign + bm <- newIOBitmapUninitialized siz 1 malign let fptr = bitmapPtr bm len = bitmapSizeInBytes bm - f :: Int -> Int -> t -> t + -- f :: Int -> Int -> t -> t f x y _ = fun x y genericComponentMapWithPos f bm bm return bm {- createBitmap - :: forall t. PixelComponent t + :: PixelComponent t => Size -- ^ (width,height) -> Maybe Alignment -- ^ the row alignment of the new image -> [Int -> Int -> t] -- ^ the functions we will use to fill the bitmap -> IO (Bitmap t) createBitmap siz malign funs = do let nchn = length funs - bm <- newBitmapUninitialized siz nchn malign + bm <- newIOBitmapUninitialized siz nchn malign let fptr = bitmapPtr bm len = bitmapSizeInBytes bm f :: Int -> Int -> t -> t @@ -199,16 +252,16 @@ -} copyBitmapFromPtr - :: forall t. PixelComponent 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) + -> IO (IOBitmap t) copyBitmapFromPtr siz@(w,h) nchn srcpad srcptr tgtmalign = do - bm <- newBitmapUninitialized siz nchn tgtmalign - withBitmap bm $ \_ _ _ tgtptr -> do + bm <- newIOBitmapUninitialized siz nchn tgtmalign + withIOBitmap bm $ \_ _ _ tgtptr -> do let pure_line = bitmapUnpaddedRowSizeInBytes bm src_line = pure_line + srcpad tgt_line = bitmapPaddedRowSizeInBytes bm @@ -216,46 +269,43 @@ let p = srcptr `myPlusPtr` (y*src_line) q = tgtptr `myPlusPtr` (y*tgt_line) c_memcpy (castPtr p) (castPtr q) pure_line - return bm + 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 = +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 bitmap $ \\(w,h) nchn padding ptr -> ...@ +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 -------------------------------------------------------------------------------- +{- + -- | Note that the resulting pointer is valid only within a line (because of the padding) withComponentPtr - :: forall t a. PixelComponent t - => Bitmap t -- ^ the bitmap + :: PixelComponent t + => IOBitmap t -- ^ the bitmap -> Offset -- ^ position (x,y) -> Int -- ^ channel index {0,1,...,nchannels-1} -> (Ptr t -> IO a) -- ^ user action -> IO a -withComponentPtr bm (x,y) ofs action = +withComponentPtr (IOBitmap bm) (x,y) ofs action = withForeignPtr (bitmapPtr bm) $ \p -> do let nchn = bitmapNChannels bm rowsize = bitmapPaddedRowSizeInBytes bm - q = p `myPlusPtr` ( ( nchn*x + ofs ) * sizeOf (undefined::t) + y * rowsize ) + q = p `myPlusPtr` ( ( nchn*x + ofs ) * sizeOf (bitmapUndefined bm) + y * rowsize ) action q -- | It is not very efficient to read\/write lots of pixels this way. unsafeReadComponent :: PixelComponent t - => Bitmap t -- ^ the bitmap + => IOBitmap t -- ^ the bitmap -> Offset -- ^ position (x,y) -> Int -- ^ channel index {0,1,...,nchannels-1} -> IO t @@ -263,7 +313,7 @@ unsafeWriteComponent :: PixelComponent t - => Bitmap t -- ^ the bitmap + => IOBitmap t -- ^ the bitmap -> Offset -- ^ position (x,y) -> Int -- ^ channel index {0,1,...,nchannels-1} -> t -- ^ the value to write @@ -274,7 +324,7 @@ -- the boundary between lines. unsafeReadComponents :: PixelComponent t - => Bitmap t -- ^ the bitmap + => IOBitmap t -- ^ the bitmap -> Offset -- ^ position (x,y) -> Int -- ^ channel index {0,1,...,nchannels-1} -> Int -- ^ the number of components to read @@ -285,7 +335,7 @@ -- the boundary between lines. unsafeWriteComponents :: PixelComponent t - => Bitmap t -- ^ the bitmap + => IOBitmap t -- ^ the bitmap -> Offset -- ^ position (x,y) -> Int -- ^ channel index {0,1,...,nchannels-1} -> [t] -- ^ the components to write @@ -294,64 +344,94 @@ unsafeReadPixel :: PixelComponent t - => Bitmap t -- ^ the bitmap + => IOBitmap t -- ^ the bitmap -> Offset -- ^ position (x,y) -> IO [t] unsafeReadPixel bm xy = unsafeReadComponents bm xy 0 (bitmapNChannels bm) --- | These functions assume that the number of channels of the bitmap --- agrees with the number suffix of the function. --- --- (Maybe I should put --- the number of components into the Bitmap type? But that would cause --- different problems...) -unsafeReadPixel1 :: PixelComponent t => Bitmap t -> Offset -> IO t -unsafeReadPixel2 :: PixelComponent t => Bitmap t -> Offset -> IO (t,t) -unsafeReadPixel3 :: PixelComponent t => Bitmap t -> Offset -> IO (t,t,t) -unsafeReadPixel4 :: PixelComponent t => Bitmap t -> Offset -> IO (t,t,t,t) +-------------------------------------------------------------------------------- -unsafeWritePixel1 :: PixelComponent t => Bitmap t -> Offset -> t -> IO () -unsafeWritePixel2 :: PixelComponent t => Bitmap t -> Offset -> (t,t) -> IO () -unsafeWritePixel3 :: PixelComponent t => Bitmap t -> Offset -> (t,t,t) -> IO () -unsafeWritePixel4 :: PixelComponent t => Bitmap t -> Offset -> (t,t,t,t) -> IO () +instance BitmapClass IOBitmap1 where + underlyingBitmap = unIOBitmap . fromIOBitmap1 -unsafeReadPixel1 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x] -> x ) $ peekArray 1 p -unsafeReadPixel2 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x,y] -> (x,y) ) $ peekArray 2 p -unsafeReadPixel3 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x,y,z] -> (x,y,z) ) $ peekArray 3 p -unsafeReadPixel4 bm xy = withComponentPtr bm xy 0 $ \p -> liftM (\[x,y,z,w] -> (x,y,z,w)) $ peekArray 4 p +instance BitmapClass IOBitmap2 where + underlyingBitmap = unIOBitmap . fromIOBitmap2 -unsafeWritePixel1 bm xy x = withComponentPtr bm xy 0 $ \q -> pokeArray q [x] -unsafeWritePixel2 bm xy (x,y) = withComponentPtr bm xy 0 $ \q -> pokeArray q [x,y] -unsafeWritePixel3 bm xy (x,y,z) = withComponentPtr bm xy 0 $ \q -> pokeArray q [x,y,z] -unsafeWritePixel4 bm xy (x,y,z,w) = withComponentPtr bm xy 0 $ \q -> pokeArray q [x,y,z,w] +instance BitmapClass IOBitmap3 where + underlyingBitmap = unIOBitmap . fromIOBitmap3 +instance BitmapClass IOBitmap4 where + underlyingBitmap = unIOBitmap . fromIOBitmap4 + -------------------------------------------------------------------------------- + +-- | Newtypes for mutable bitmaps with a fixed number of channels (components per pixel) +newtype IOBitmap1 t = IOBitmap1 { fromIOBitmap1 :: IOBitmap t } +newtype IOBitmap2 t = IOBitmap2 { fromIOBitmap2 :: IOBitmap t } +newtype IOBitmap3 t = IOBitmap3 { fromIOBitmap3 :: IOBitmap t } +newtype IOBitmap4 t = IOBitmap4 { fromIOBitmap4 :: IOBitmap t } +ioBitmap1 :: IOBitmap t -> IOBitmap1 t +ioBitmap2 :: IOBitmap t -> IOBitmap2 t +ioBitmap3 :: IOBitmap t -> IOBitmap3 t +ioBitmap4 :: IOBitmap t -> IOBitmap4 t + +ioBitmap1 bm = if bitmapNChannels bm == 1 then IOBitmap1 bm else error "bitmap/ioBitmap1: number of channels is not 1" +ioBitmap2 bm = if bitmapNChannels bm == 2 then IOBitmap2 bm else error "bitmap/ioBitmap2: number of channels is not 2" +ioBitmap3 bm = if bitmapNChannels bm == 3 then IOBitmap3 bm else error "bitmap/ioBitmap3: number of channels is not 3" +ioBitmap4 bm = if bitmapNChannels bm == 4 then IOBitmap4 bm else error "bitmap/ioBitmap4: number of channels is not 4" + +-------------------------------------------------------------------------------- + +unsafeReadPixel1 :: PixelComponent t => IOBitmap1 t -> Offset -> IO t +unsafeReadPixel2 :: PixelComponent t => IOBitmap2 t -> Offset -> IO (t,t) +unsafeReadPixel3 :: PixelComponent t => IOBitmap3 t -> Offset -> IO (t,t,t) +unsafeReadPixel4 :: PixelComponent t => IOBitmap4 t -> Offset -> IO (t,t,t,t) + +unsafeWritePixel1 :: PixelComponent t => IOBitmap1 t -> Offset -> t -> IO () +unsafeWritePixel2 :: PixelComponent t => IOBitmap2 t -> Offset -> (t,t) -> IO () +unsafeWritePixel3 :: PixelComponent t => IOBitmap3 t -> Offset -> (t,t,t) -> IO () +unsafeWritePixel4 :: PixelComponent t => IOBitmap4 t -> Offset -> (t,t,t,t) -> IO () + +unsafeReadPixel1 bm xy = withComponentPtr (fromIOBitmap1 bm) xy 0 $ \p -> liftM (\[x] -> x ) $ peekArray 1 p +unsafeReadPixel2 bm xy = withComponentPtr (fromIOBitmap2 bm) xy 0 $ \p -> liftM (\[x,y] -> (x,y) ) $ peekArray 2 p +unsafeReadPixel3 bm xy = withComponentPtr (fromIOBitmap3 bm) xy 0 $ \p -> liftM (\[x,y,z] -> (x,y,z) ) $ peekArray 3 p +unsafeReadPixel4 bm xy = withComponentPtr (fromIOBitmap4 bm) xy 0 $ \p -> liftM (\[x,y,z,w] -> (x,y,z,w)) $ peekArray 4 p + +unsafeWritePixel1 bm xy x = withComponentPtr (fromIOBitmap1 bm) xy 0 $ \q -> pokeArray q [x] +unsafeWritePixel2 bm xy (x,y) = withComponentPtr (fromIOBitmap2 bm) xy 0 $ \q -> pokeArray q [x,y] +unsafeWritePixel3 bm xy (x,y,z) = withComponentPtr (fromIOBitmap3 bm) xy 0 $ \q -> pokeArray q [x,y,z] +unsafeWritePixel4 bm xy (x,y,z,w) = withComponentPtr (fromIOBitmap4 bm) xy 0 $ \q -> pokeArray q [x,y,z,w] + +-} + +-------------------------------------------------------------------------------- + {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO ()) -> Bitmap Word8 -> Bitmap Word8 -> IO () #-} + :: (Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO ()) -> IOBitmap Word8 -> IOBitmap Word8 -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Word16 -> Ptr Word16 -> IO ()) -> Bitmap Word16 -> Bitmap Word16 -> IO () #-} + :: (Int -> Int -> Ptr Word16 -> Ptr Word16 -> IO ()) -> IOBitmap Word16 -> IOBitmap Word16 -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Word32 -> Ptr Word32 -> IO ()) -> Bitmap Word32 -> Bitmap Word32 -> IO () #-} + :: (Int -> Int -> Ptr Word32 -> Ptr Word32 -> IO ()) -> IOBitmap Word32 -> IOBitmap Word32 -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Float -> Ptr Float -> IO ()) -> Bitmap Float -> Bitmap Float -> IO () #-} + :: (Int -> Int -> Ptr Float -> Ptr Float -> IO ()) -> IOBitmap Float -> IOBitmap Float -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Word8 -> Ptr Float -> IO ()) -> Bitmap Word8 -> Bitmap Float -> IO () #-} + :: (Int -> Int -> Ptr Word8 -> Ptr Float -> IO ()) -> IOBitmap Word8 -> IOBitmap Float -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Float -> Ptr Word8 -> IO ()) -> Bitmap Float -> Bitmap Word8 -> IO () #-} + :: (Int -> Int -> Ptr Float -> Ptr Word8 -> IO ()) -> IOBitmap Float -> IOBitmap Word8 -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Word16 -> Ptr Float -> IO ()) -> Bitmap Word16 -> Bitmap Float -> IO () #-} + :: (Int -> Int -> Ptr Word16 -> Ptr Float -> IO ()) -> IOBitmap Word16 -> IOBitmap Float -> IO () #-} {-# SPECIALIZE genericComponentRowMap - :: (Int -> Int -> Ptr Float -> Ptr Word16 -> IO ()) -> Bitmap Float -> Bitmap Word16 -> IO () #-} + :: (Int -> Int -> Ptr Float -> Ptr Word16 -> IO ()) -> IOBitmap Float -> IOBitmap Word16 -> IO () #-} -- the first Int is the y position -- the second Int is the number of pixel components (nchn*width) genericComponentRowMap :: (PixelComponent s, PixelComponent t) => (Int -> Int -> Ptr s -> Ptr t -> IO ()) -- ^ ypos totalNumberOfComps src tgt - -> Bitmap s -> Bitmap t -> IO () + -> IOBitmap s -> IOBitmap t -> IO () genericComponentRowMap rowAction bm1 bm2 = do let (w1,h1) = bitmapSize bm1 @@ -386,7 +466,7 @@ genericPixelRowMap :: (PixelComponent s, PixelComponent t) => (Int -> Int -> Ptr s -> NChn -> Ptr t -> NChn -> IO ()) -- ^ ypos width ptr1 nchn1 ptr2 nchn2 - -> Bitmap s -> Bitmap t -> IO () + -> IOBitmap s -> IOBitmap t -> IO () genericPixelRowMap rowAction bm1 bm2 = do let (w1,h1) = bitmapSize bm1 @@ -413,45 +493,47 @@ -------------------------------------------------------------------------------- -{-# 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 -> Word8 ) -> IOBitmap Word8 -> IOBitmap Word8 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Word16 -> Word16) -> IOBitmap Word16 -> IOBitmap Word16 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Word32 -> Word32) -> IOBitmap Word32 -> IOBitmap Word32 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Float -> Float ) -> IOBitmap Float -> IOBitmap Float -> IO () #-} -{-# SPECIALIZE genericComponentMap :: (Word8 -> Float ) -> Bitmap Word8 -> Bitmap Float -> IO () #-} -{-# SPECIALIZE genericComponentMap :: (Float -> Word8 ) -> Bitmap Float -> Bitmap Word8 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Word8 -> Float ) -> IOBitmap Word8 -> IOBitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Float -> Word8 ) -> IOBitmap Float -> IOBitmap Word8 -> IO () #-} -{-# SPECIALIZE genericComponentMap :: (Word16 -> Float ) -> Bitmap Word16 -> Bitmap Float -> IO () #-} -{-# SPECIALIZE genericComponentMap :: (Float -> Word16) -> Bitmap Float -> Bitmap Word16 -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Word16 -> Float ) -> IOBitmap Word16 -> IOBitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentMap :: (Float -> Word16) -> IOBitmap Float -> IOBitmap Word16 -> IO () #-} genericComponentMap - :: forall s t . (PixelComponent s, PixelComponent t) - => (s -> t) -> Bitmap s -> Bitmap t -> IO () +-- :: forall s t . (PixelComponent s, PixelComponent t) + :: (PixelComponent s, PixelComponent t) + => (s -> t) -> IOBitmap s -> IOBitmap t -> IO () genericComponentMap f bm1 bm2 = genericComponentRowMap g bm1 bm2 where - h :: (Ptr s, Ptr t) -> Int -> IO (Ptr s, Ptr t) + --h :: (Ptr s, Ptr t) -> Int -> IO (Ptr s, Ptr t) h (q1,q2) _ = do x <- peek q1 poke q2 (f x) return (advancePtr1 q1, advancePtr1 q2) - g :: Int -> Int -> Ptr s -> Ptr t -> IO () + --g :: Int -> Int -> Ptr s -> Ptr t -> IO () g ypos n p1 p2 = do foldM_ h (p1,p2) [0..n-1] -{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word8 -> Word8 ) -> Bitmap Word8 -> Bitmap Word8 -> IO () #-} -{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word16 -> Word16) -> Bitmap Word16 -> Bitmap Word16 -> IO () #-} -{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word32 -> Word32) -> Bitmap Word32 -> Bitmap Word32 -> IO () #-} -{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Float -> Float ) -> Bitmap Float -> Bitmap Float -> IO () #-} +{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word8 -> Word8 ) -> IOBitmap Word8 -> IOBitmap Word8 -> IO () #-} +{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word16 -> Word16) -> IOBitmap Word16 -> IOBitmap Word16 -> IO () #-} +{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Word32 -> Word32) -> IOBitmap Word32 -> IOBitmap Word32 -> IO () #-} +{-# SPECIALIZE genericComponentMapWithPos :: (Int -> Int -> Float -> Float ) -> IOBitmap Float -> IOBitmap Float -> IO () #-} genericComponentMapWithPos - :: forall s t . (PixelComponent s, PixelComponent t) - => (Int -> Int -> s -> t) -> Bitmap s -> Bitmap t -> IO () +-- :: forall s t . (PixelComponent s, PixelComponent t) + :: (PixelComponent s, PixelComponent t) + => (Int -> Int -> s -> t) -> IOBitmap s -> IOBitmap t -> IO () genericComponentMapWithPos f bm1 bm2 = genericComponentRowMap g bm1 bm2 where - h :: Int -> (Ptr s, Ptr t) -> Int -> IO (Ptr s, Ptr t) + --h :: Int -> (Ptr s, Ptr t) -> Int -> IO (Ptr s, Ptr t) h ypos (q1,q2) xpos = do x <- peek q1 poke q2 (f xpos ypos x) return (advancePtr1 q1, advancePtr1 q2) - g :: Int -> Int -> Ptr s -> Ptr t -> IO () + --g :: Int -> Int -> Ptr s -> Ptr t -> IO () g ypos n p1 p2 = do foldM_ (h ypos) (p1,p2) [0..n-1] @@ -463,16 +545,16 @@ -- 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 :: PixelComponent s => (s -> s) -> IOBitmap s -> IO (IOBitmap s) componentMap f bm1 = do let siz = bitmapSize bm1 nchn = bitmapNChannels bm1 align = bitmapRowAlignment bm1 - bm2 <- newBitmapUninitialized siz nchn (Just align) + bm2 <- newIOBitmapUninitialized siz nchn (Just align) genericComponentMap f bm1 bm2 return bm2 -componentMapInPlace :: PixelComponent s => (s -> s) -> Bitmap s -> IO () +componentMapInPlace :: PixelComponent s => (s -> s) -> IOBitmap s -> IO () componentMapInPlace f bm = do genericComponentMap f bm bm @@ -480,41 +562,103 @@ componentMap' :: (PixelComponent s, PixelComponent t) => (s -> t) - -> Bitmap s -- ^ source bitmap + -> IOBitmap s -- ^ source bitmap -> Maybe Alignment -- ^ row alignment of the resulting bitmap - -> IO (Bitmap t) + -> IO (IOBitmap t) componentMap' f bm1 malign = do let siz = bitmapSize bm1 nchn = bitmapNChannels bm1 x = bitmapPaddedRowSizeInBytes bm1 - bm2 <- newBitmapUninitialized siz nchn malign + bm2 <- newIOBitmapUninitialized siz nchn malign genericComponentMap f bm1 bm2 return bm2 -------------------------------------------------------------------------------- +-- | Clones a bitmap. +cloneBitmap + :: PixelComponent t + => IOBitmap t -- ^ source image + -> Maybe Alignment -- ^ target 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..h1-1] $ \i -> do + let p = plusPtr ptr1 (i*xlen1) + q = plusPtr ptr2 (i*xlen2) + c_memcpy p q len1 + + return bm2 + +-- | Creates an empty bitmap with the same properties as the source. +emptyCloneBitmap + :: PixelComponent t + => IOBitmap t -- ^ source (only dimensions and such is used) + -> Maybe Alignment -- ^ target alignment + -> IO (IOBitmap t) -- ^ new empty bitmap +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 + +-- | Synonym for 'newIOBitmap' +emptyBitmap + :: PixelComponent t + => Size -- ^ (width,height) + -> NChn -- ^ number of channels (components\/pixel) + -> Maybe Alignment -- ^ the row alignment of the new image + -> IO (IOBitmap t) +emptyBitmap = newIOBitmap + +-------------------------------------------------------------------------------- + + -- | Copies a subrectangle of the source image into a new image. copySubImage :: PixelComponent t - => Bitmap t -- ^ source image + => IOBitmap 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 + -> IO (IOBitmap t) +copySubImage bm ofs1 siz1 = copySubImage' bm ofs1 siz1 siz1 (0,0) -- | Copy into a new \"black\" bitmap; common generalization of crop and extend. copySubImage' :: PixelComponent t - => Bitmap t -- ^ source image + => IOBitmap t -- ^ source image -> Offset -- ^ source rectangle offset -> Size -- ^ source rectangle size -> Size -- ^ target image size -> Offset -- ^ target rectangle offset - -> IO (Bitmap t) + -> IO (IOBitmap t) copySubImage' bm1 ofs1 rsiz tsiz ofs2 = do let align = bitmapRowAlignment bm1 nchn = bitmapNChannels bm1 - bm2 <- newBitmap tsiz nchn (Just align) + bm2 <- newIOBitmap tsiz nchn (Just align) copySubImageInto bm1 ofs1 rsiz bm2 ofs2 return bm2 @@ -523,10 +667,10 @@ -- with the image. copySubImageInto :: PixelComponent t - => Bitmap t -- ^ source image + => IOBitmap t -- ^ source image -> Offset -- ^ source rectangle offset -> Size -- ^ source rectangle size - -> Bitmap t -- ^ target image + -> IOBitmap t -- ^ target image -> Offset -- ^ target rectangle offset -> IO () @@ -575,28 +719,182 @@ -------------------------------------------------------------------------------- +-- | Convert a bitmap to one with a different component type. +castBitmap + :: (PixelComponent s, PixelComponent t) + => IOBitmap s -- ^ source image + -> Maybe Alignment -- ^ target image row 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 -- (ci ofs1) + ptr2 (ci nchn1) (ci pad2) 0 -- (ci ofs2) + + return bm2 + +-------------------------------------------------------------------------------- + +_flipBitmapInto + :: PixelComponent t + => IOBitmap t -- ^ source image + -> IOBitmap t -- ^ target image + -> 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 = h1-1-i + p1 = plusPtr ptr1 (i*xlen1) + q1 = plusPtr ptr1 (j*xlen1) + p2 = plusPtr ptr2 (i*xlen2) + q2 = plusPtr ptr2 (j*xlen2) + -- we have to be careful, since the two bitmaps coincide. + -- that's why the extra copy + c_memcpy p1 tmp len1 + c_memcpy q1 p2 len1 + c_memcpy tmp q2 len1 + else do + forM_ [0..h1-1] $ \i -> do + let j = h1-1-i + p = plusPtr ptr1 (i*xlen1) + q = plusPtr ptr2 (j*xlen2) + c_memcpy p q len1 + +-- | Flips the bitmap vertically. +flipBitmap + :: PixelComponent t + => IOBitmap t -- ^ source image + -> Maybe Alignment -- ^ target image row 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 -- ^ source image + -> IO () +flipBitmapInPlace bm = do + _flipBitmapInto bm bm + +-------------------------------------------------------------------------------- + +_mirrorBitmapInto + :: PixelComponent t + => IOBitmap t -- ^ source image + -> IOBitmap t -- ^ target image + -> 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..h1-1] $ \i -> do + let p = plusPtr ptr1 (i*xlen1) + q = plusPtr ptr2 (i*xlen2) + c_mirror_line (ci w1) (ci bpp1) p q + +-- | Flips the bitmap horizontally. +mirrorBitmap + :: PixelComponent t + => IOBitmap t -- ^ source image + -> Maybe Alignment -- ^ target image row 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 -- ^ source image + -> IO () +mirrorBitmapInPlace bm = do + _mirrorBitmapInto bm bm + +-------------------------------------------------------------------------------- + extractSingleChannel :: PixelComponent t - => Bitmap t -- ^ source image + => IOBitmap t -- ^ source image -> Maybe Alignment -- ^ target image row alignment -> Int -- ^ source channel index - -> IO (Bitmap t) + -> 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 <- newBitmapUninitialized siz 1 malign + bm2 <- newIOBitmapUninitialized siz 1 malign extractChannelInto bm1 j bm2 0 return bm2 - -extractChannels :: PixelComponent t => Bitmap t -> Maybe Alignment -> IO [Bitmap t] +extractChannels :: PixelComponent t => IOBitmap t -> Maybe Alignment -> IO [IOBitmap 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 :: 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 @@ -607,7 +905,7 @@ when (length (nub sizes) /= 1) $ error "bitmap/combineChannels: incompatible sizes" - bm2 <- newBitmapUninitialized siz sumchn malign + bm2 <- newIOBitmapUninitialized siz sumchn malign let pad2 = bitmapRowPadding bm2 fptr2 = bitmapPtr bm2 @@ -620,7 +918,7 @@ nchn1 = bitmapNChannels bm1 withForeignPtr fptr1 $ \ptr1 -> c_extract_channel - (c_type (undefined::t)) + (bitmapCType (head bms)) (ci w) (ci h) ptr1 (ci nchn1) (ci pad1) (ci j) ptr2 (ci sumchn) (ci pad2) (ci i) @@ -628,10 +926,10 @@ return bm2 extractChannelInto - :: forall t. PixelComponent t - => Bitmap t -- ^ source image + :: PixelComponent t + => IOBitmap t -- ^ source image -> Int -- ^ source channel index - -> Bitmap t -- ^ target image + -> IOBitmap t -- ^ target image -> Int -- ^ target channel index -> IO () extractChannelInto bm1 ofs1 bm2 ofs2 = do @@ -653,7 +951,7 @@ withForeignPtr fptr1 $ \ptr1 -> withForeignPtr fptr2 $ \ptr2 -> c_extract_channel - (c_type (undefined::t)) + (bitmapCType bm1) (ci w) (ci h) ptr1 (ci nchn1) (ci pad1) (ci ofs1) ptr2 (ci nchn2) (ci pad2) (ci ofs2) @@ -662,13 +960,13 @@ bilinearResample :: PixelComponent t - => Bitmap t -- ^ source image + => IOBitmap t -- ^ source image -> Size -- ^ target image size -> Maybe Alignment -- ^ target image alignment - -> IO (Bitmap t) + -> IO (IOBitmap t) bilinearResample bm1 siz2@(w2,h2) malign = do let nchn1 = bitmapNChannels bm1 - bm2 <- newBitmapUninitialized siz2 nchn1 malign + bm2 <- newIOBitmapUninitialized siz2 nchn1 malign forM_ [0..nchn1-1] $ \ofs -> bilinearResampleChannelInto bm1 ofs bm2 ofs return bm2 @@ -676,24 +974,24 @@ bilinearResampleChannel :: PixelComponent t - => Bitmap t -- ^ source image + => IOBitmap t -- ^ source image -> Int -- ^ source channel index -> Size -- ^ target image size -> Maybe Alignment -- ^ target image alignment - -> IO (Bitmap t) + -> 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 <- newBitmapUninitialized siz2 1 malign + bm2 <- newIOBitmapUninitialized siz2 1 malign bilinearResampleChannelInto bm1 ofs1 bm2 0 return bm2 bilinearResampleChannelInto - :: forall t. PixelComponent t - => Bitmap t -- ^ source image + :: PixelComponent t + => IOBitmap t -- ^ source image -> Int -- ^ source channel index - -> Bitmap t -- ^ target image + -> IOBitmap t -- ^ target image -> Int -- ^ target channel index -> IO () bilinearResampleChannelInto bm1 ofs1 bm2 ofs2 = do @@ -714,7 +1012,7 @@ withForeignPtr fptr1 $ \ptr1 -> withForeignPtr fptr2 $ \ptr2 -> c_bilinear_resample_channel - (c_type (undefined::t)) + (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) @@ -723,23 +1021,23 @@ -- | This is equivalent to @componentMap (\c -> c^gamma)@, except that -- @(^)@ is defined only for integral exponents; but should be faster anyway. powerlawGammaCorrection - :: forall t. PixelComponent t + :: PixelComponent t => Float -- ^ gamma - -> Bitmap t -- ^ source bitmap + -> IOBitmap t -- ^ source bitmap -> Maybe Alignment -- ^ target alignment - -> IO (Bitmap t) + -> IO (IOBitmap t) powerlawGammaCorrection gamma bm1 malign = do let nchn1 = bitmapNChannels bm1 siz1@(w1,h1) = bitmapSize bm1 pad1 = bitmapRowPadding bm1 fptr1 = bitmapPtr bm1 - bm2 <- newBitmapUninitialized siz1 nchn1 malign + 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 (undefined::t)) + (c_type (bitmapUndefined bm1)) (realToFrac gamma) (ci w1) (ci h1) (ci nchn1) ptr1 (ci pad1) @@ -750,24 +1048,25 @@ powerlawGammaCorrectionChannel :: PixelComponent t => Float -- ^ gamma - -> Bitmap t -- ^ source image + -> IOBitmap t -- ^ source image -> Int -- ^ source channel index -> Maybe Alignment -- ^ target image alignment - -> IO (Bitmap t) + -> 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 <- newBitmapUninitialized siz1 1 malign + bm2 <- newIOBitmapUninitialized siz1 1 malign powerlawGammaCorrectionChannelInto gamma bm1 ofs1 bm2 0 return bm2 + powerlawGammaCorrectionChannelInto - :: forall t. PixelComponent t + :: PixelComponent t => Float -- ^ gamma - -> Bitmap t -- ^ source image + -> IOBitmap t -- ^ source image -> Int -- ^ source channel index - -> Bitmap t -- ^ target image + -> IOBitmap t -- ^ target image -> Int -- ^ target channel index -> IO () powerlawGammaCorrectionChannelInto gamma bm1 ofs1 bm2 ofs2 = do @@ -789,7 +1088,7 @@ withForeignPtr fptr1 $ \ptr1 -> withForeignPtr fptr2 $ \ptr2 -> c_gamma_correct_channel - (c_type (undefined::t)) + (c_type (bitmapUndefined bm1)) (realToFrac gamma) (ci w1) (ci h1) ptr1 (ci nchn1) (ci pad1) (ci ofs1) @@ -806,10 +1105,10 @@ :: PixelComponent t => Float -- ^ weight1 -> Float -- ^ weight2 - -> Bitmap t -- ^ source1 image - -> Bitmap t -- ^ source2 image + -> IOBitmap t -- ^ source1 image + -> IOBitmap t -- ^ source2 image -> Maybe Alignment -- ^ target alignment - -> IO (Bitmap t) + -> IO (IOBitmap t) -- this could be implemented more effectively by a specialized c routine blendBitmaps weight1 weight2 bm1 bm2 malign = do let nchn1 = bitmapNChannels bm1 @@ -818,7 +1117,7 @@ siz2 = bitmapSize bm2 when (siz1 /= siz2 ) $ error "bitmap/blend: incompatible dimensions" when (nchn1 /= nchn2) $ error "bitmap/blend: incompatible number of channels" - bm3 <- newBitmapUninitialized siz1 nchn1 malign + bm3 <- newIOBitmapUninitialized siz1 nchn1 malign forM [0..nchn1-1] $ \ofs -> blendChannelsInto weight1 weight2 bm1 ofs bm2 ofs bm3 ofs return bm3 @@ -827,12 +1126,12 @@ :: PixelComponent t => Float -- ^ weight1 -> Float -- ^ weight2 - -> Bitmap t -- ^ source1 image + -> IOBitmap t -- ^ source1 image -> Int -- ^ source1 channel index - -> Bitmap t -- ^ source2 image + -> IOBitmap t -- ^ source2 image -> Int -- ^ source2 channel index -> Maybe Alignment -- ^ target alignment - -> IO (Bitmap t) + -> IO (IOBitmap t) blendChannels weight1 weight2 bm1 ofs1 bm2 ofs2 malign = do let nchn1 = bitmapNChannels bm1 siz1 = bitmapSize bm1 @@ -841,19 +1140,19 @@ when (siz1 /= siz2) $ error "bitmap/blendChannels: incompatible dimensions" when (ofs1<0 || ofs1>=nchn1) $ error "bitmap/blendChannels: invalid channel index" when (ofs2<0 || ofs2>=nchn2) $ error "bitmap/blendChannels: invalid channel index" - bm3 <- newBitmapUninitialized siz1 1 malign + bm3 <- newIOBitmapUninitialized siz1 1 malign blendChannelsInto weight1 weight2 bm1 ofs1 bm2 ofs2 bm3 0 return bm3 blendChannelsInto - :: forall t. PixelComponent t + :: PixelComponent t => Float -- ^ weight1 -> Float -- ^ weight2 - -> Bitmap t -- ^ source1 image + -> IOBitmap t -- ^ source1 image -> Int -- ^ source1 channel index - -> Bitmap t -- ^ source2 image + -> IOBitmap t -- ^ source2 image -> Int -- ^ source2 channel index - -> Bitmap t -- ^ target image + -> IOBitmap t -- ^ target image -> Int -- ^ target channel index -> IO () blendChannelsInto weight1 weight2 bm1 ofs1 bm2 ofs2 bm3 ofs3 = do @@ -883,7 +1182,7 @@ withForeignPtr fptr2 $ \ptr2 -> withForeignPtr fptr3 $ \ptr3 -> c_linear_combine_channels - (c_type (undefined::t)) + (bitmapCType bm1) (realToFrac weight1) (realToFrac weight2) (ci w1) (ci h1) ptr1 (ci nchn1) (ci pad1) (ci ofs1) @@ -892,6 +1191,8 @@ -------------------------------------------------------------------------------- +{- + -- | The data is copied, not shared. Note that the resulting ByteString is -- encoded using the host machine's endianness, so it may be not compatible -- across different architectures! @@ -907,7 +1208,7 @@ -- | The data is copied, not shared. -- Note that we expect the ByteString to be encoded -- encoded using the host machine's endianness. -copyBitmapFromByteString :: forall t. PixelComponent t => ByteString -> Size -> NChn -> Padding -> IO (Bitmap t) +copyBitmapFromByteString :: PixelComponent t => ByteString -> Size -> NChn -> Padding -> IO (Bitmap t) copyBitmapFromByteString bs siz nchn pad = do let (bsfptr0,ofs,len) = B.toForeignPtr bs bm = Bitmap @@ -916,7 +1217,7 @@ , bitmapPtr = undefined , bitmapRowPadding = pad , bitmapRowAlignment = 1 - } :: Bitmap t + } -- :: Bitmap t n = bitmapSizeInBytes bm if n > len-ofs then error "copyBitmapFromByteString: ByteString is too short" @@ -927,14 +1228,21 @@ withForeignPtr newfptr $ \tgt -> c_memcpy src tgt n return $ bm { bitmapPtr = castForeignPtr newfptr } + +-} -------------------------------------------------------------------------------- +ptrUndefined :: Ptr a -> a +ptrUndefined _ = undefined + -- 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)) +--advancePtr1 :: forall a. Storable a => Ptr a -> Ptr a +--advancePtr1 p = p `plusPtr` (sizeOf (undefined::a)) +advancePtr1 :: Storable a => Ptr a -> Ptr a +advancePtr1 p = p `plusPtr` (sizeOf (ptrUndefined p)) -- restricted type {-# SPECIALIZE myPlusPtr :: Ptr Word8 -> Int -> Ptr Word8 #-} @@ -954,6 +1262,43 @@ -- Note that we use /nonstandard/ argument order! foreign import ccall unsafe "bm.h c_memcpy" c_memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () + +-------------------- + +{- +// tgt and src can be potentally the same +void c_mirror_line(int width, int bytesperpixel, void *src, void *tgt); +-} + +foreign import ccall unsafe "bm.h c_mirror_line" + c_mirror_line + :: CInt -- ^ width + -> CInt -- ^ bytesperpixel + -> Ptr a -- ^ src + -> Ptr a -- ^ tgt + -> IO () + +-------------------- + +{- +void c_cast_bitmap + ( int k_type1, int k_type2 + , int width, int height + , void *p1, int nchn1, int pad1, int ofs1 + , void *p2, int nchn2, int pad2, int ofs2 + ); +-} + +-- offset is measured in components, not bytes! +-- also, nchn1 should be equal to nchn2 +-- offset should be zero +foreign import ccall unsafe "bm.h c_cast_bitmap" + c_cast_bitmap + :: CInt -> CInt -- ^ component types + -> CInt -> CInt -- ^ width, height + -> Ptr a -> CInt -> CInt -> CInt -- ^ source, nchn, pad, offset + -> Ptr b -> CInt -> CInt -> CInt -- ^ target, nchn, pad, offset + -> IO () -------------------- diff --git a/Data/Bitmap/IO/File.hs b/Data/Bitmap/IO/File.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/IO/File.hs @@ -0,0 +1,166 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.IO.File +-- Version : 0.0.2 +-- License : BSD3 +-- Copyright : (c) 2009-2010 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI and CPP +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | Saving and loading uncompressed bitmaps. +-- For loading from compressed formats, see the @stb-image@ library: +-- . +-- +-- The goal of this module is to provide the simplest possible interface +-- for loading and saving bitmaps; so you can start experimenting +-- without much hassle. +-- +-- Note: Endianness is the endianness of the host, so the resulting file is +-- not portable across platforms with different endiannesses. +-- +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Data.Bitmap.IO.File + ( readBitmap + , writeBitmap + -- + , readRawData + , writeRawData + -- + , hPutHeader + , hPutRawData + , hGetHeader + , hGetRawData + ) + where + +-------------------------------------------------------------------------------- + +import Control.Monad +import System.IO + +--import Foreign -- GHC 7 complains? +import Foreign.C +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable +import Foreign.Marshal + +import Data.Int + +import Data.Bitmap.Base +import Data.Bitmap.Internal +import Data.Bitmap.IO + +-------------------------------------------------------------------------------- + +readBitmap :: PixelComponent t => FilePath -> IO (IOBitmap t) +readBitmap fpath = do + h <- openFile fpath ReadMode + header <- hGetHeader h + bitmap <- hGetRawData h header + hClose h + return bitmap + +readRawData :: PixelComponent t => FilePath -> (Size,NChn,PixelComponentType) -> IO (IOBitmap t) +readRawData fpath header = do + h <- openFile fpath ReadMode + bitmap <- hGetRawData h header + hClose h + return bitmap + +-------------------------------------------------------------------------------- + +writeBitmap :: PixelComponent t => FilePath -> IOBitmap t -> IO () +writeBitmap fpath bm = do + h <- openFile fpath WriteMode + hPutHeader h bm + hPutRawData h bm + hClose h + +-- | Saves only the raw pixel data, no resolution etc. +writeRawData :: PixelComponent t => FilePath -> IOBitmap t -> IO () +writeRawData fpath bm = do + h <- openFile fpath WriteMode + hPutRawData h bm + hClose h + +-------------------------------------------------------------------------------- + +-- | Writes a 16 byte header in the following format: +-- +-- > dword xsize +-- > dword ysize +-- > dword nchn +-- > dword pixelcomponent_type +-- +-- Pixel component encoding is the following: +-- +-- * 1 = Word8 +-- +-- * 2 = Word16 +-- +-- * 3 = Word32 +-- +-- * 4 = Float +-- +-- Endianness is the endianness of the host, so the resulting file is +-- not portable across platform with different endiannesses. +hPutHeader :: PixelComponent t => Handle -> IOBitmap t -> IO () +hPutHeader h bm = do + let (xsize,ysize) = bitmapSize bm + nchn = bitmapNChannels bm + typ = bitmapCType bm + with (fromIntegral xsize :: Int32) $ \p -> hPutBuf h p 4 + with (fromIntegral ysize :: Int32) $ \p -> hPutBuf h p 4 + with (fromIntegral nchn :: Int32) $ \p -> hPutBuf h p 4 + with (fromIntegral typ :: Int32) $ \p -> hPutBuf h p 4 + +-- | Saves only the raw pixel data, no resolution etc. +hPutRawData :: PixelComponent t => Handle -> IOBitmap t -> IO () +hPutRawData h bm = + withIOBitmap bm $ \(xres,yres) nchn padding ptr -> do + forM_ [0..yres-1] $ \k -> do + let q = ptr `plusPtr` (k*long) + hPutBuf h q short + where + long = bitmapPaddedRowSizeInBytes bm + short = bitmapUnpaddedRowSizeInBytes bm + +-------------------------------------------------------------------------------- + +hGetRawData :: PixelComponent t => Handle -> (Size,NChn,PixelComponentType) -> IO (IOBitmap t) +hGetRawData h (siz,nchn,pct) = do + bm <- newIOBitmapUninitialized siz nchn (Just 1) + if bitmapComponentType bm /= pct + then error "bitmap/getRawData: bitmap component type does not match" + else do + withIOBitmap bm $ \(_,ysiz) _ _ ptr -> do + let n = ysiz * bitmapUnpaddedRowSizeInBytes bm + k <- hGetBuf h ptr n + when (k/=n) $ error "bitmap/getRawData: not enough data" + return bm + +hGetHeader :: Handle -> IO (Size,NChn,PixelComponentType) +hGetHeader h = do + xsize <- loadInt32 + ysize <- loadInt32 + nchn <- loadInt32 + ctyp <- loadInt32 + return + ( (fromIntegral xsize, fromIntegral ysize) + , fromIntegral nchn + , decodeCType (fromIntegral ctyp) + ) + where + loadInt32 :: IO Int32 + loadInt32 = alloca $ \p -> do + hGetBuf h p 4 + peek p + +-------------------------------------------------------------------------------- + + diff --git a/Data/Bitmap/IO/Pixels.hs b/Data/Bitmap/IO/Pixels.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/IO/Pixels.hs @@ -0,0 +1,202 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.IO.Pixels +-- Version : 0.0.2 +-- License : BSD3 +-- Copyright : (c) 2009-2010 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI and CPP +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | Accessing individual pixels. + +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Data.Bitmap.IO.Pixels + ( + -- * Types + IOBitmap1 -- (..) + , IOBitmap2 -- (..) + , IOBitmap3 -- (..) + , IOBitmap4 -- (..) + -- + , ioBitmap1 + , ioBitmap2 + , ioBitmap3 + , ioBitmap4 + -- + , fromIOBitmap1 + , fromIOBitmap2 + , fromIOBitmap3 + , fromIOBitmap4 + -- * Reading and writing pixels + , withComponentPtr + -- + , unsafeReadComponent + , unsafeWriteComponent + , unsafeReadComponents + , unsafeWriteComponents + -- + , unsafeReadPixel + , unsafeReadPixel1 + , unsafeReadPixel2 + , unsafeReadPixel3 + , unsafeReadPixel4 + , unsafeWritePixel1 + , unsafeWritePixel2 + , unsafeWritePixel3 + , unsafeWritePixel4 + ) + where + +-------------------------------------------------------------------------------- + +import Control.Monad +import Control.Applicative + +import Data.Word + +--import Foreign -- GHC 7 complains? +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 +import Data.Bitmap.IO + +-------------------------------------------------------------------------------- + +-- | Note that the resulting pointer is valid only within a line (because of the padding) +withComponentPtr + :: PixelComponent t + => IOBitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> (Ptr t -> IO a) -- ^ user action + -> IO a +withComponentPtr (IOBitmap bm) (x,y) ofs action = + withForeignPtr (bitmapPtr bm) $ \p -> do + let nchn = bitmapNChannels bm + rowsize = bitmapPaddedRowSizeInBytes bm + q = p `myPlusPtr` ( ( nchn*x + ofs ) * sizeOf (bitmapUndefined bm) + y * rowsize ) + action q + +-- | It is not very efficient to read\/write lots of pixels this way. +unsafeReadComponent + :: PixelComponent t + => IOBitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> IO t +unsafeReadComponent bm xy ofs = withComponentPtr bm xy ofs $ peek + +unsafeWriteComponent + :: PixelComponent t + => IOBitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> t -- ^ the value to write + -> IO () +unsafeWriteComponent bm xy ofs value = withComponentPtr bm xy ofs $ \q -> poke q value + +-- | Please note that the component array to read shouldn't cross +-- the boundary between lines. +unsafeReadComponents + :: PixelComponent t + => IOBitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> Int -- ^ the number of components to read + -> IO [t] +unsafeReadComponents bm xy ofs k = withComponentPtr bm xy ofs $ \p -> peekArray k p + +-- | Please note that the component array to write shouldn't cross +-- the boundary between lines. +unsafeWriteComponents + :: PixelComponent t + => IOBitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> [t] -- ^ the components to write + -> IO () +unsafeWriteComponents bm xy ofs values = withComponentPtr bm xy ofs $ \q -> pokeArray q values + +unsafeReadPixel + :: PixelComponent t + => IOBitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> IO [t] +unsafeReadPixel bm xy = unsafeReadComponents bm xy 0 (bitmapNChannels bm) + +-------------------------------------------------------------------------------- + +instance BitmapClass IOBitmap1 where + underlyingBitmap = unIOBitmap . fromIOBitmap1 + +instance BitmapClass IOBitmap2 where + underlyingBitmap = unIOBitmap . fromIOBitmap2 + +instance BitmapClass IOBitmap3 where + underlyingBitmap = unIOBitmap . fromIOBitmap3 + +instance BitmapClass IOBitmap4 where + underlyingBitmap = unIOBitmap . fromIOBitmap4 + +-------------------------------------------------------------------------------- + +-- | Newtypes for mutable bitmaps with a fixed number of channels (components per pixel) +newtype IOBitmap1 t = IOBitmap1 { fromIOBitmap1 :: IOBitmap t } +newtype IOBitmap2 t = IOBitmap2 { fromIOBitmap2 :: IOBitmap t } +newtype IOBitmap3 t = IOBitmap3 { fromIOBitmap3 :: IOBitmap t } +newtype IOBitmap4 t = IOBitmap4 { fromIOBitmap4 :: IOBitmap t } + +ioBitmap1 :: IOBitmap t -> IOBitmap1 t +ioBitmap2 :: IOBitmap t -> IOBitmap2 t +ioBitmap3 :: IOBitmap t -> IOBitmap3 t +ioBitmap4 :: IOBitmap t -> IOBitmap4 t + +ioBitmap1 bm = if bitmapNChannels bm == 1 then IOBitmap1 bm else error "bitmap/ioBitmap1: number of channels is not 1" +ioBitmap2 bm = if bitmapNChannels bm == 2 then IOBitmap2 bm else error "bitmap/ioBitmap2: number of channels is not 2" +ioBitmap3 bm = if bitmapNChannels bm == 3 then IOBitmap3 bm else error "bitmap/ioBitmap3: number of channels is not 3" +ioBitmap4 bm = if bitmapNChannels bm == 4 then IOBitmap4 bm else error "bitmap/ioBitmap4: number of channels is not 4" + +-------------------------------------------------------------------------------- + +unsafeReadPixel1 :: PixelComponent t => IOBitmap1 t -> Offset -> IO t +unsafeReadPixel2 :: PixelComponent t => IOBitmap2 t -> Offset -> IO (t,t) +unsafeReadPixel3 :: PixelComponent t => IOBitmap3 t -> Offset -> IO (t,t,t) +unsafeReadPixel4 :: PixelComponent t => IOBitmap4 t -> Offset -> IO (t,t,t,t) + +unsafeWritePixel1 :: PixelComponent t => IOBitmap1 t -> Offset -> t -> IO () +unsafeWritePixel2 :: PixelComponent t => IOBitmap2 t -> Offset -> (t,t) -> IO () +unsafeWritePixel3 :: PixelComponent t => IOBitmap3 t -> Offset -> (t,t,t) -> IO () +unsafeWritePixel4 :: PixelComponent t => IOBitmap4 t -> Offset -> (t,t,t,t) -> IO () + +unsafeReadPixel1 bm xy = withComponentPtr (fromIOBitmap1 bm) xy 0 $ \p -> liftM (\[x] -> x ) $ peekArray 1 p +unsafeReadPixel2 bm xy = withComponentPtr (fromIOBitmap2 bm) xy 0 $ \p -> liftM (\[x,y] -> (x,y) ) $ peekArray 2 p +unsafeReadPixel3 bm xy = withComponentPtr (fromIOBitmap3 bm) xy 0 $ \p -> liftM (\[x,y,z] -> (x,y,z) ) $ peekArray 3 p +unsafeReadPixel4 bm xy = withComponentPtr (fromIOBitmap4 bm) xy 0 $ \p -> liftM (\[x,y,z,w] -> (x,y,z,w)) $ peekArray 4 p + +unsafeWritePixel1 bm xy x = withComponentPtr (fromIOBitmap1 bm) xy 0 $ \q -> pokeArray q [x] +unsafeWritePixel2 bm xy (x,y) = withComponentPtr (fromIOBitmap2 bm) xy 0 $ \q -> pokeArray q [x,y] +unsafeWritePixel3 bm xy (x,y,z) = withComponentPtr (fromIOBitmap3 bm) xy 0 $ \q -> pokeArray q [x,y,z] +unsafeWritePixel4 bm xy (x,y,z,w) = withComponentPtr (fromIOBitmap4 bm) xy 0 $ \q -> pokeArray q [x,y,z,w] + +-------------------------------------------------------------------------------- + +-- restricted type +{-# SPECIALIZE myPlusPtr :: Ptr Word8 -> Int -> Ptr Word8 #-} +{-# SPECIALIZE myPlusPtr :: Ptr Float -> Int -> Ptr Float #-} +myPlusPtr :: Ptr a -> Int -> Ptr a +myPlusPtr = plusPtr + +-------------------------------------------------------------------------------- diff --git a/Data/Bitmap/Internal.hs b/Data/Bitmap/Internal.hs --- a/Data/Bitmap/Internal.hs +++ b/Data/Bitmap/Internal.hs @@ -1,17 +1,17 @@ -------------------------------------------------------------------------------- -- Module : Data.Bitmap.Internal --- Version : 0.0.1 +-- Version : 0.0.2 -- License : BSD3 --- Copyright : (c) 2009 Balazs Komuves +-- Copyright : (c) 2009-2010 Balazs Komuves -- Author : Balazs Komuves -- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com -- Stability : experimental --- Portability : requires FFI, CPP and ScopedTypeVariables +-- Portability : requires FFI and CPP -- Tested with : GHC 6.10.1 -------------------------------------------------------------------------------- -{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Data.Bitmap.Internal where -------------------------------------------------------------------------------- @@ -31,7 +31,7 @@ | PctWord16 | PctWord32 | PctFloat - deriving Show + deriving (Show,Eq) pixelComponentSize :: PixelComponentType -> Int pixelComponentSize pct = case pct of @@ -39,7 +39,14 @@ PctWord16 -> 2 PctWord32 -> 4 PctFloat -> 4 - + +prettyPrintPixelComponentType :: PixelComponentType -> String +prettyPrintPixelComponentType t = case t of + PctWord8 -> "Word8" + PctWord16 -> "Word16" + PctWord32 -> "Word32" + PctFloat -> "Float" + -------------------------------------------------------------------------------- class (Num t, Storable t) => PixelComponent t where @@ -50,7 +57,10 @@ fromFloat :: Float -> t pixelComponentType :: PixelComponent t => t -> PixelComponentType -pixelComponentType t = case c_type t of +pixelComponentType t = decodeCType (c_type t) + +decodeCType :: CInt -> PixelComponentType +decodeCType k = case k of 1 -> PctWord8 2 -> PctWord16 3 -> PctWord32 @@ -88,12 +98,67 @@ -------------------------------------------------------------------------------- -{-# SPECIALIZE isValidAlignment :: Int -> Bool #-} -isValidAlignment :: Integral a => a -> Bool -isValidAlignment a = elem a [1,2,4,8,16] +-- this is for portability, to avoid ScopedTypeVariables --------------------------------------------------------------------------------- +bitmapUndefined :: BitmapClass bitmap => bitmap t -> t +bitmapUndefined _ = undefined + +bitmapCType :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> CInt +bitmapCType = c_type . bitmapUndefined +-------------------------------------------------------------------------------- + +{- +-- | Newtypes for bitmaps with a fixed number of channels (components per pixel) +newtype Bitmap1 t = Bitmap1 { fromBitmap1 :: Bitmap t } +newtype Bitmap2 t = Bitmap2 { fromBitmap2 :: Bitmap t } +newtype Bitmap3 t = Bitmap3 { fromBitmap3 :: Bitmap t } +newtype Bitmap4 t = Bitmap4 { fromBitmap4 :: Bitmap t } + +bitmap1 :: Bitmap t -> Bitmap1 t +bitmap2 :: Bitmap t -> Bitmap2 t +bitmap3 :: Bitmap t -> Bitmap3 t +bitmap4 :: Bitmap t -> Bitmap4 t + +bitmap1 bm = if bitmapNChannels bm == 1 then Bitmap1 bm else error "bitmap/bitmap1: number of channels is not 1" +bitmap2 bm = if bitmapNChannels bm == 2 then Bitmap2 bm else error "bitmap/bitmap2: number of channels is not 2" +bitmap3 bm = if bitmapNChannels bm == 3 then Bitmap3 bm else error "bitmap/bitmap3: number of channels is not 3" +bitmap4 bm = if bitmapNChannels bm == 4 then Bitmap4 bm else error "bitmap/bitmap4: number of channels is not 4" +-} + +-------------------------------------------------------------------------------- + +-- | A class so that using newtypes is convenient. +class BitmapClass b where + underlyingBitmap :: b t -> Bitmap t -- ?? better name ?? + +instance BitmapClass Bitmap where + underlyingBitmap = id + +{- +instance BitmapClass Bitmap1 where + underlyingBitmap = fromBitmap1 + +instance BitmapClass Bitmap2 where + underlyingBitmap = fromBitmap2 + +instance BitmapClass Bitmap3 where + underlyingBitmap = fromBitmap3 + +instance BitmapClass Bitmap4 where + underlyingBitmap = fromBitmap4 +-} + +-------------------------------------------------------------------------------- + +-- A fixed channel of a bitmap +data BitmapChannel t = BmChn (Bitmap t) Int + +data IOBitmapChannel t = IOBmChn (IOBitmap t) Int +data STBitmapChannel t = STBmChn (STBitmap t) Int + +-------------------------------------------------------------------------------- + -- to provide better documentation type Size = (Int,Int) type Offset = (Int,Int) @@ -101,50 +166,137 @@ type Padding = Int type Alignment = Int +-- | A bitmap. 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) + { _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 +-- deriving Show -bitmapComponentSizeInBytes :: forall t. PixelComponent t => Bitmap t -> Int -bitmapComponentSizeInBytes _ = sizeOf (undefined::t) +-------------------------------------------------------------------------------- -bitmapPixelSizeInBytes :: PixelComponent t => Bitmap t -> Int +-- | A mutable Bitmap in the IO Monad. Only the content is mutable, the shape isn't. +newtype IOBitmap t = IOBitmap { unIOBitmap :: Bitmap t } +-- | A mutable Bitmap in the ST Monad. Only the content is mutable, the shape isn't. +newtype STBitmap t = STBitmap { unSTBitmap :: Bitmap t } + +instance BitmapClass IOBitmap where underlyingBitmap = unIOBitmap +instance BitmapClass STBitmap where underlyingBitmap = unSTBitmap + +-------------------------------------------------------------------------------- + +bitmapSize :: BitmapClass bitmap => bitmap t -> Size +bitmapSize = _bitmapSize . underlyingBitmap + +bitmapNChannels :: BitmapClass bitmap => bitmap t -> NChn +bitmapNChannels = _bitmapNChannels . underlyingBitmap + +bitmapPtr :: BitmapClass bitmap => bitmap t -> ForeignPtr t +bitmapPtr = _bitmapPtr . underlyingBitmap + +bitmapRowPadding :: BitmapClass bitmap => bitmap t -> Padding +bitmapRowPadding = _bitmapRowPadding . underlyingBitmap + +bitmapRowAlignment :: BitmapClass bitmap => bitmap t -> Alignment +bitmapRowAlignment = _bitmapRowAlignment . underlyingBitmap + +-------------------------------------------------------------------------------- + +bitmapComponentType :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> PixelComponentType +bitmapComponentType bm = pixelComponentType (bitmapUndefined bm) + +bitmapComponentSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int +bitmapComponentSizeInBytes bm = sizeOf (bitmapUndefined bm) + +bitmapPixelSizeInBytes :: (BitmapClass bitmap, 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 +bitmapUnpaddedRowSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int +bitmapUnpaddedRowSizeInBytes bm = w * sizeOf (bitmapUndefined bm) * nchn where (w,h) = bitmapSize bm nchn = bitmapNChannels bm -bitmapPaddedRowSizeInBytes :: PixelComponent t => Bitmap t -> Int +bitmapPaddedRowSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int bitmapPaddedRowSizeInBytes bm = bitmapUnpaddedRowSizeInBytes bm + bitmapRowPadding bm -bitmapSizeInBytes :: PixelComponent t => Bitmap t -> Int +bitmapSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int bitmapSizeInBytes bm = h*x where x = bitmapPaddedRowSizeInBytes bm (_,h) = bitmapSize bm -- | The width divided by the height. -bitmapAspect :: Fractional a => Bitmap t -> a +bitmapAspect :: (Fractional a, BitmapClass bitmap) => bitmap t -> a bitmapAspect bm = (fromIntegral x / fromIntegral y) where (x,y) = bitmapSize bm -------------------------------------------------------------------------------- +prettyPrintBitmap :: (BitmapClass bitmap, PixelComponent t) => String -> bitmap t -> String +prettyPrintBitmap prefix bm = text where + text = "<" ++ prefix ++ " " ++ typ ++ ", " ++ show xres ++ "x" ++ show yres ++ ", " ++ show nchn ++ " channels>" where + (xres,yres) = bitmapSize bm + typ = prettyPrintPixelComponentType (bitmapComponentType bm) + nchn = bitmapNChannels bm + +instance PixelComponent t => Show (Bitmap t) where + show = prettyPrintBitmap "Bitmap" + +-------------------------------------------------------------------------------- + +-- | @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 + +bitmapFromForeignPtrUnsafe + :: 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 + } + +-------------------------------------------------------------------------------- + +{-# SPECIALIZE isValidAlignment :: Int -> Bool #-} +isValidAlignment :: Integral a => a -> Bool +isValidAlignment a = elem a [1,2,4,8,16] + +-------------------------------------------------------------------------------- + -- we mimic the OpenGL padding at the moment -recommendedPadding :: forall t. PixelComponent t => Bitmap t -> Int +recommendedPadding :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int recommendedPadding bm = pad where (w,_) = bitmapSize bm n = bitmapNChannels bm b = bitmapRowAlignment bm - s = sizeOf (undefined::t) + s = sizeOf (bitmapUndefined bm) a = if b if r==0 then q else error "recommendedPadding: should not happen" pad = s * ( k * div (n*w + k-1) k - n*w ) + +{- +-- OpenGL padding algorithm test +recommendedPadding' + :: Int -- ^ number of channels + -> Int -- ^ size of a component + -> Int -- ^ width of the picture + -> Int -- ^ target alignment + -> (Int,Int) +recommendedPadding' n s w b = (pad,pad2) where + a = if b if r==0 then q else error "recommendedPadding': should not happen" + pad = s * ( k * div (n*w + k-1) k - n*w ) + + kk = a * (div (s*n*w + a-1) a) + pad2 = kk - w*s*nn +-} -------------------------------------------------------------------------------- diff --git a/Data/Bitmap/Pure.hs b/Data/Bitmap/Pure.hs --- a/Data/Bitmap/Pure.hs +++ b/Data/Bitmap/Pure.hs @@ -1,30 +1,43 @@ -------------------------------------------------------------------------------- -- Module : Data.Bitmap.Pure --- Version : 0.0.1 +-- Version : 0.0.2 -- License : BSD3 --- Copyright : (c) 2009 Balazs Komuves +-- Copyright : (c) 2009-2010 Balazs Komuves -- Author : Balazs Komuves -- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com -- Stability : experimental --- Portability : requires FFI, CPP and ScopedTypeVariables +-- Portability : requires FFI and CPP -- Tested with : GHC 6.10.1 -------------------------------------------------------------------------------- -{-# LANGUAGE CPP, ScopedTypeVariables #-} +-- | The pure, inmutable API. + +{-# LANGUAGE CPP #-} module Data.Bitmap.Pure ( module Data.Bitmap.Base -- * Creating bitmaps , emptyBitmap + , cloneBitmap + , emptyCloneBitmap , createSingleChannelBitmap + , bitmapFromForeignPtrUnsafe + -- * Using bitmaps + , withBitmap -- * Mapping over bitmaps , componentMap , componentMap' -- * Cropping and extending , copySubImage - , copySubImage' + , copySubImage' + -- * Flipping and mirroring + , flipBitmap + , mirrorBitmap + -- * Casting + , castBitmap + -- , castChannel -- * Manipulating channels , combineChannels , extractChannels @@ -38,8 +51,10 @@ -- * Gamma correction , powerlawGammaCorrection , powerlawGammaCorrectionChannel +{- -- * Conversion to ByteString , bitmapToByteString +-} ) where @@ -47,7 +62,7 @@ import Data.Word -import Foreign +-- import Foreign.ForeignPtr import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -66,33 +81,55 @@ -- 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 + :: 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 +emptyBitmap siz nchn malign = unIOBitmap $ unsafePerformIO $ IO.newIOBitmap siz nchn malign -- | Creates a single channel bitmap from a function. -- This is probably a bit slow. createSingleChannelBitmap - :: forall t. PixelComponent t + :: PixelComponent t => Size -- ^ (width,height) -> Maybe Alignment -- ^ the row alignment of the new image -> (Int -> Int -> t) -- ^ the function used to create the bitmap -> Bitmap t -createSingleChannelBitmap siz maling fun = unsafePerformIO $ +createSingleChannelBitmap siz maling fun = unIOBitmap $ unsafePerformIO $ IO.createSingleChannelBitmap siz maling fun +-- | Creates an empty bitmap with the same properties as the source. +emptyCloneBitmap + :: PixelComponent t + => Bitmap t -- ^ source (only dimensions and such is used) + -> Maybe Alignment -- ^ target alignment + -> Bitmap t -- ^ new empty bitmap +emptyCloneBitmap bm1 malign = unIOBitmap $ unsafePerformIO $ + IO.emptyCloneBitmap (IOBitmap bm1) malign + +-- | Clones a bitmap. The only effect of this in the pure +-- setting should be that the alignment/padding can change. +-- You shouldn't normally use this function. +cloneBitmap + :: PixelComponent t + => Bitmap t -- ^ source image + -> Maybe Alignment -- ^ target alignment + -> Bitmap t +cloneBitmap bm1 malign = unIOBitmap $ unsafePerformIO $ + IO.cloneBitmap (IOBitmap bm1) malign + -------------------------------------------------------------------------------- -- | Warning: this is probably slow. componentMap :: PixelComponent s => (s -> s) -> Bitmap s -> Bitmap s -componentMap f bm = unsafePerformIO $ IO.componentMap f bm +componentMap f bm = unIOBitmap $ unsafePerformIO $ + IO.componentMap f (IOBitmap 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 +componentMap' f bm malign = unIOBitmap $ unsafePerformIO $ + IO.componentMap' f (IOBitmap bm) malign -------------------------------------------------------------------------------- @@ -103,7 +140,8 @@ -> Offset -- ^ source rectangle offset -> Size -- ^ source rectangle size -> Bitmap t -copySubImage bm ofs siz = unsafePerformIO $ IO.copySubImage bm ofs siz +copySubImage bm ofs siz = unIOBitmap $ unsafePerformIO $ + IO.copySubImage (IOBitmap bm) ofs siz -- | Copy into a new \"black\" bitmap; common generalization of crop and extend. copySubImage' @@ -114,27 +152,56 @@ -> Size -- ^ target image size -> Offset -- ^ target rectangle offset -> Bitmap t -copySubImage' bm1 ofs1 rsiz tsiz ofs2 = unsafePerformIO $ - IO.copySubImage' bm1 ofs1 rsiz tsiz ofs2 +copySubImage' bm1 ofs1 rsiz tsiz ofs2 = unIOBitmap $ unsafePerformIO $ + IO.copySubImage' (IOBitmap bm1) ofs1 rsiz tsiz ofs2 -------------------------------------------------------------------------------- +-- | Flips the bitmap vertically. +flipBitmap + :: PixelComponent t + => Bitmap t + -> Maybe Alignment + -> Bitmap t +flipBitmap bm malign = unIOBitmap $ unsafePerformIO $ IO.flipBitmap (IOBitmap bm) malign + +-- | Flips the bitmap horizontally. +mirrorBitmap + :: PixelComponent t + => Bitmap t + -> Maybe Alignment + -> Bitmap t +mirrorBitmap bm malign = unIOBitmap $ unsafePerformIO $ IO.mirrorBitmap (IOBitmap bm) malign + +-------------------------------------------------------------------------------- + +-- | Converts between different component types. +castBitmap + :: (PixelComponent s, PixelComponent t) + => Bitmap s -- ^ source image + -> Maybe Alignment -- ^ target image row alignment + -> Bitmap t +castBitmap bm1 malign = unIOBitmap $ unsafePerformIO $ + IO.castBitmap (IOBitmap bm1) malign + +-------------------------------------------------------------------------------- + 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 +extractSingleChannel bm1 malign j = unIOBitmap $ unsafePerformIO $ + IO.extractSingleChannel (IOBitmap bm1) malign j extractChannels :: PixelComponent t => Bitmap t -> Maybe Alignment -> [Bitmap t] -extractChannels bm malign = unsafePerformIO $ - IO.extractChannels bm malign +extractChannels bm malign = map unIOBitmap $ unsafePerformIO $ + IO.extractChannels (IOBitmap bm) malign -combineChannels :: forall t. PixelComponent t => [Bitmap t] -> Maybe Alignment -> Bitmap t -combineChannels bms malign = unsafePerformIO $ - IO.combineChannels bms malign +combineChannels :: PixelComponent t => [Bitmap t] -> Maybe Alignment -> Bitmap t +combineChannels bms malign = unIOBitmap $ unsafePerformIO $ + IO.combineChannels (map IOBitmap bms) malign -------------------------------------------------------------------------------- @@ -144,8 +211,8 @@ -> Size -- ^ target image size -> Maybe Alignment -- ^ target image row alignment -> Bitmap t -bilinearResample bm siz malign = unsafePerformIO $ - IO.bilinearResample bm siz malign +bilinearResample bm siz malign = unIOBitmap $ unsafePerformIO $ + IO.bilinearResample (IOBitmap bm) siz malign bilinearResampleChannel :: PixelComponent t @@ -154,8 +221,8 @@ -> Size -- ^ target image size -> Maybe Alignment -- ^ target image row alignment -> Bitmap t -bilinearResampleChannel bm j siz malign = unsafePerformIO $ - IO.bilinearResampleChannel bm j siz malign +bilinearResampleChannel bm j siz malign = unIOBitmap $ unsafePerformIO $ + IO.bilinearResampleChannel (IOBitmap bm) j siz malign -------------------------------------------------------------------------------- @@ -172,8 +239,8 @@ -> Bitmap t -- ^ source image 2 -> Maybe Alignment -- ^ target alignment -> Bitmap t -blendBitmaps w1 w2 bm1 bm2 malign = unsafePerformIO $ - IO.blendBitmaps w1 w2 bm1 bm2 malign +blendBitmaps w1 w2 bm1 bm2 malign = unIOBitmap $ unsafePerformIO $ + IO.blendBitmaps w1 w2 (IOBitmap bm1) (IOBitmap bm2) malign blendChannels :: PixelComponent t @@ -185,8 +252,8 @@ -> Int -- ^ channel index 2 -> Maybe Alignment -- ^ target alignment -> Bitmap t -blendChannels w1 w2 bm1 ofs1 bm2 ofs2 malign = unsafePerformIO $ - IO.blendChannels w1 w2 bm1 ofs1 bm2 ofs2 malign +blendChannels w1 w2 bm1 ofs1 bm2 ofs2 malign = unIOBitmap $ unsafePerformIO $ + IO.blendChannels w1 w2 (IOBitmap bm1) ofs1 (IOBitmap bm2) ofs2 malign -------------------------------------------------------------------------------- @@ -198,8 +265,8 @@ -> Bitmap t -- ^ source image -> Maybe Alignment -- ^ target image row alignment -> Bitmap t -powerlawGammaCorrection gamma bm malign = unsafePerformIO $ - IO.powerlawGammaCorrection gamma bm malign +powerlawGammaCorrection gamma bm malign = unIOBitmap $ unsafePerformIO $ + IO.powerlawGammaCorrection gamma (IOBitmap bm) malign powerlawGammaCorrectionChannel :: PixelComponent t @@ -208,21 +275,23 @@ -> Int -- ^ source channel indexe -> Maybe Alignment -- ^ target image row alignment -> Bitmap t -powerlawGammaCorrectionChannel gamma bm j malign = unsafePerformIO $ - IO.powerlawGammaCorrectionChannel gamma bm j malign +powerlawGammaCorrectionChannel gamma bm j malign = unIOBitmap $ unsafePerformIO $ + IO.powerlawGammaCorrectionChannel gamma (IOBitmap bm) j malign -------------------------------------------------------------------------------- +{- -- | Note that the data is /shared/; and also that the resulting ByteString -- is encoded using the host machine's endianness. 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 :: ByteString -> Size -> NChn -> Padding -> Bitmap t reallyUnsafeBitmapFromByteString bs siz nchn pad = if n > len || ofs /= 0 then error "reallyUnsafeBitmapFromByteString: better than segfault :)" diff --git a/Data/Bitmap/Pure/File.hs b/Data/Bitmap/Pure/File.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/Pure/File.hs @@ -0,0 +1,67 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.Pure.File +-- Version : 0.0.2 +-- License : BSD3 +-- Copyright : (c) 2009-2010 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI and CPP +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | Saving and loading uncompressed bitmaps. +-- For loading from compressed formats, see the @stb-image@ library: +-- . +-- +-- The goal of this module is to provide the simplest possible interface +-- for loading and saving bitmaps; so you can start experimenting +-- without much hassle. +-- +-- Note: Endianness is the endianness of the host, so the resulting file is +-- not portable across platforms with different endiannesses. +-- +-- See the module "Data.Bitmap.IO.File" for the file format. +-- + +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Data.Bitmap.Pure.File + ( readBitmap + , writeBitmap + , readRawData + , writeRawData + ) + where + +-------------------------------------------------------------------------------- + +import Control.Applicative +import Control.Monad +import Foreign +import System.IO + +import Data.Bitmap.Base +import Data.Bitmap.Internal +import Data.Bitmap.IO +import qualified Data.Bitmap.IO.File as IO + +-------------------------------------------------------------------------------- + +readBitmap :: PixelComponent t => FilePath -> IO (Bitmap t) +readBitmap fpath = unIOBitmap <$> IO.readBitmap fpath + +readRawData :: PixelComponent t => FilePath -> (Size,NChn,PixelComponentType) -> IO (Bitmap t) +readRawData fpath header = unIOBitmap <$> IO.readRawData fpath header + +-------------------------------------------------------------------------------- + +writeBitmap :: PixelComponent t => FilePath -> Bitmap t -> IO () +writeBitmap fpath bm = IO.writeBitmap fpath (IOBitmap bm) + +-- | Saves only the raw pixel data, no resolution etc. +writeRawData :: PixelComponent t => FilePath -> Bitmap t -> IO () +writeRawData fpath bm = IO.writeRawData fpath (IOBitmap bm) + +-------------------------------------------------------------------------------- + diff --git a/Data/Bitmap/Pure/Pixels.hs b/Data/Bitmap/Pure/Pixels.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/Pure/Pixels.hs @@ -0,0 +1,153 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.Pure.Pixels +-- Version : 0.0.2 +-- License : BSD3 +-- Copyright : (c) 2009-2010 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI and CPP +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | Access to individual pixels. It isn't very efficient to handle bitmaps this way. + +{-# LANGUAGE CPP #-} +module Data.Bitmap.Pure.Pixels + ( + Bitmap1, Bitmap2, Bitmap3, Bitmap4 + , bitmap1, bitmap2, bitmap3, bitmap4 + -- + , unsafeReadComponent + , unsafeReadComponents + -- + , unsafeReadPixel + , unsafeReadPixel1 + , unsafeReadPixel2 + , unsafeReadPixel3 + , unsafeReadPixel4 + ) + where + +-------------------------------------------------------------------------------- + +import Control.Monad +import Control.Applicative + +import Data.Word +import Foreign hiding (unsafePerformIO) + +import Data.Bitmap.Base +import Data.Bitmap.Internal + +import System.IO.Unsafe + +-------------------------------------------------------------------------------- + +-- | Note that the resulting pointer is valid only within a line (because of the padding) +withComponentPtr + :: PixelComponent t + => Bitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> (Ptr t -> IO a) -- ^ user action + -> IO a +withComponentPtr bm (x,y) ofs action = + withForeignPtr (bitmapPtr bm) $ \p -> do + let nchn = bitmapNChannels bm + rowsize = bitmapPaddedRowSizeInBytes bm + q = p `myPlusPtr` ( ( nchn*x + ofs ) * sizeOf (bitmapUndefined bm) + y * rowsize ) + action q + +-------------------------------------------------------------------------------- + +-- | Newtypes for bitmaps with a fixed number of channels (components per pixel) +newtype Bitmap1 t = Bitmap1 { fromBitmap1 :: Bitmap t } +newtype Bitmap2 t = Bitmap2 { fromBitmap2 :: Bitmap t } +newtype Bitmap3 t = Bitmap3 { fromBitmap3 :: Bitmap t } +newtype Bitmap4 t = Bitmap4 { fromBitmap4 :: Bitmap t } + +bitmap1 :: Bitmap t -> Bitmap1 t +bitmap2 :: Bitmap t -> Bitmap2 t +bitmap3 :: Bitmap t -> Bitmap3 t +bitmap4 :: Bitmap t -> Bitmap4 t + +bitmap1 bm = if bitmapNChannels bm == 1 then Bitmap1 bm else error "bitmap/bitmap1: number of channels is not 1" +bitmap2 bm = if bitmapNChannels bm == 2 then Bitmap2 bm else error "bitmap/bitmap2: number of channels is not 2" +bitmap3 bm = if bitmapNChannels bm == 3 then Bitmap3 bm else error "bitmap/bitmap3: number of channels is not 3" +bitmap4 bm = if bitmapNChannels bm == 4 then Bitmap4 bm else error "bitmap/bitmap4: number of channels is not 4" + + +instance BitmapClass Bitmap1 where + underlyingBitmap = fromBitmap1 + +instance BitmapClass Bitmap2 where + underlyingBitmap = fromBitmap2 + +instance BitmapClass Bitmap3 where + underlyingBitmap = fromBitmap3 + +instance BitmapClass Bitmap4 where + underlyingBitmap = fromBitmap4 + +-------------------------------------------------------------------------------- + +-- | It is not very efficient to read\/write lots of pixels this way. +unsafeReadComponent + :: PixelComponent t + => Bitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> t +unsafeReadComponent bm xy ofs = unsafePerformIO $ withComponentPtr bm xy ofs $ peek + +-- | Please note that the component array to read shouldn't cross +-- the boundary between lines. +unsafeReadComponents + :: PixelComponent t + => Bitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> Int -- ^ channel index {0,1,...,nchannels-1} + -> Int -- ^ the number of components to read + -> [t] +unsafeReadComponents bm xy ofs k = unsafePerformIO $ withComponentPtr bm xy ofs $ \p -> peekArray k p + + +unsafeReadPixel + :: PixelComponent t + => Bitmap t -- ^ the bitmap + -> Offset -- ^ position (x,y) + -> [t] +unsafeReadPixel bm xy = unsafeReadComponents bm xy 0 (bitmapNChannels bm) + + +-------------------------------------------------------------------------------- + +unsafeReadPixel1 :: PixelComponent t => Bitmap1 t -> Offset -> t +unsafeReadPixel2 :: PixelComponent t => Bitmap2 t -> Offset -> (t,t) +unsafeReadPixel3 :: PixelComponent t => Bitmap3 t -> Offset -> (t,t,t) +unsafeReadPixel4 :: PixelComponent t => Bitmap4 t -> Offset -> (t,t,t,t) + +unsafeReadPixel1 bm xy = unsafePerformIO $ + withComponentPtr (fromBitmap1 bm) xy 0 $ \p -> liftM (\[x] -> x ) $ peekArray 1 p + +unsafeReadPixel2 bm xy = unsafePerformIO $ + withComponentPtr (fromBitmap2 bm) xy 0 $ \p -> liftM (\[x,y] -> (x,y) ) $ peekArray 2 p + +unsafeReadPixel3 bm xy = unsafePerformIO $ + withComponentPtr (fromBitmap3 bm) xy 0 $ \p -> liftM (\[x,y,z] -> (x,y,z) ) $ peekArray 3 p + +unsafeReadPixel4 bm xy = unsafePerformIO $ + withComponentPtr (fromBitmap4 bm) xy 0 $ \p -> liftM (\[x,y,z,w] -> (x,y,z,w)) $ peekArray 4 p + +-------------------------------------------------------------------------------- + +-- restricted type +{-# SPECIALIZE myPlusPtr :: Ptr Word8 -> Int -> Ptr Word8 #-} +{-# SPECIALIZE myPlusPtr :: Ptr Float -> Int -> Ptr Float #-} +myPlusPtr :: Ptr a -> Int -> Ptr a +myPlusPtr = plusPtr + +-------------------------------------------------------------------------------- + diff --git a/Data/Bitmap/Simple.hs b/Data/Bitmap/Simple.hs new file mode 100644 --- /dev/null +++ b/Data/Bitmap/Simple.hs @@ -0,0 +1,236 @@ + +-------------------------------------------------------------------------------- +-- Module : Data.Bitmap.Simple +-- Version : 0.0.2 +-- License : BSD3 +-- Copyright : (c) 2009-2010 Balazs Komuves +-- Author : Balazs Komuves +-- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com +-- Stability : experimental +-- Portability : requires FFI and CPP +-- Tested with : GHC 6.10.1 +-------------------------------------------------------------------------------- + +-- | This is the same as the pure API, without the annoying alignment stuff. +-- All functions use the default alignment. + +{-# LANGUAGE CPP #-} +module Data.Bitmap.Simple + ( + module Data.Bitmap.Base + + -- * Creating bitmaps + , emptyBitmap + , emptyCloneBitmap + , createSingleChannelBitmap + -- * Using bitmaps + , withBitmap + -- * Mapping over bitmaps + , componentMap + , componentMap' + -- * Cropping and extending + , copySubImage + , copySubImage' + -- * Flipping and mirroring + , flipBitmap + , mirrorBitmap + -- * Casting + , castBitmap + -- , castChannel + -- * Manipulating channels + , combineChannels + , extractChannels + , extractSingleChannel + -- * Bilinear resampling + , bilinearResample + , bilinearResampleChannel + -- * Blending + , blendBitmaps + , blendChannels + -- * Gamma correction + , powerlawGammaCorrection + , powerlawGammaCorrectionChannel +{- + -- * 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.Pure as P + +-------------------------------------------------------------------------------- + +-- | A bitmap filled with zero values. +emptyBitmap + :: PixelComponent t + => Size -- ^ (width,height) + -> NChn -- ^ number of channels (components\/pixel) + -> Bitmap t +emptyBitmap siz nchn = P.emptyBitmap siz nchn Nothing + +-- | Creates a single channel bitmap from a function. +-- This is probably a bit slow. +createSingleChannelBitmap + :: PixelComponent t + => Size -- ^ (width,height) + -> (Int -> Int -> t) -- ^ the function used to create the bitmap + -> Bitmap t +createSingleChannelBitmap siz fun = P.createSingleChannelBitmap siz Nothing fun + +-- | Creates an empty bitmap with the same properties as the source. +emptyCloneBitmap + :: PixelComponent t + => Bitmap t -- ^ source (only dimensions and such is used) + -> Bitmap t -- ^ new empty bitmap +emptyCloneBitmap bm = P.emptyCloneBitmap bm Nothing + +-------------------------------------------------------------------------------- + +-- | Warning: this is probably slow. +componentMap :: PixelComponent s => (s -> s) -> Bitmap s -> Bitmap s +componentMap = P.componentMap + +-- | Warning: this is probably slow. +componentMap' :: (PixelComponent s, PixelComponent t) => (s -> t) -> Bitmap s -> Bitmap t +componentMap' f bm = P.componentMap' f bm Nothing + +-------------------------------------------------------------------------------- + +-- | 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 = P.copySubImage + +-- | 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' = P.copySubImage' + +-------------------------------------------------------------------------------- + +-- | Flips the bitmap vertically. +flipBitmap + :: PixelComponent t + => Bitmap t + -> Bitmap t +flipBitmap bm = P.flipBitmap bm Nothing + +-- | Flips the bitmap horizontally. +mirrorBitmap + :: PixelComponent t + => Bitmap t + -> Bitmap t +mirrorBitmap bm = P.mirrorBitmap bm Nothing + +-------------------------------------------------------------------------------- + +-- | Converts between different component types. +castBitmap + :: (PixelComponent s, PixelComponent t) + => Bitmap s -- ^ source image + -> Bitmap t +castBitmap bm1 = P.castBitmap bm1 Nothing + +-------------------------------------------------------------------------------- + +extractSingleChannel + :: PixelComponent t + => Bitmap t -- ^ source image + -> Int -- ^ source channel index + -> Bitmap t +extractSingleChannel bm1 j = P.extractSingleChannel bm1 Nothing j + +extractChannels :: PixelComponent t => Bitmap t -> [Bitmap t] +extractChannels bm = P.extractChannels bm Nothing + +combineChannels :: PixelComponent t => [Bitmap t] -> Bitmap t +combineChannels bms = P.combineChannels bms Nothing + +-------------------------------------------------------------------------------- + +bilinearResample + :: PixelComponent t + => Bitmap t -- ^ source image + -> Size -- ^ target image size + -> Bitmap t +bilinearResample bm siz = P.bilinearResample bm siz Nothing + +bilinearResampleChannel + :: PixelComponent t + => Bitmap t -- ^ source image + -> Int -- ^ source channel indexe + -> Size -- ^ target image size + -> Bitmap t +bilinearResampleChannel bm j siz = P.bilinearResampleChannel bm j siz Nothing + +-------------------------------------------------------------------------------- + +-- | Blends two bitmaps with the given weights; that is, the result is +-- the specified linear combination. If the values are outside the allowed +-- range (this can happen with the Word8, Word16, Word32 types and weights +-- whose sum is bigger than 1, or with a negative weight), then they are +-- clipped. The clipping /does not/ happen with the Float component type. +blendBitmaps + :: PixelComponent t + => Float -- ^ weight 1 + -> Float -- ^ weight 2 + -> Bitmap t -- ^ source image 1 + -> Bitmap t -- ^ source image 2 + -> Bitmap t +blendBitmaps w1 w2 bm1 bm2 = P.blendBitmaps w1 w2 bm1 bm2 Nothing + +blendChannels + :: PixelComponent t + => Float -- ^ weight 1 + -> Float -- ^ weight 2 + -> Bitmap t -- ^ source image 1 + -> Int -- ^ channel index 1 + -> Bitmap t -- ^ source image 2 + -> Int -- ^ channel index 2 + -> Bitmap t +blendChannels w1 w2 bm1 ofs1 bm2 ofs2 = P.blendChannels w1 w2 bm1 ofs1 bm2 ofs2 Nothing + +-------------------------------------------------------------------------------- + +-- | This is equivalent to @componentMap (\c -> c^gamma)@, except that +-- @(^)@ is defined only for integral exponents; but should be faster anyway. +powerlawGammaCorrection + :: PixelComponent t + => Float -- ^ gamma + -> Bitmap t -- ^ source image + -> Bitmap t +powerlawGammaCorrection gamma bm = P.powerlawGammaCorrection gamma bm Nothing + +powerlawGammaCorrectionChannel + :: PixelComponent t + => Float -- ^ gamma + -> Bitmap t -- ^ source image + -> Int -- ^ source channel indexe + -> Bitmap t +powerlawGammaCorrectionChannel gamma bm j = P.powerlawGammaCorrectionChannel gamma bm j Nothing + +-------------------------------------------------------------------------------- + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, Balazs Komuves +Copyright (c) 2009-2011, Balazs Komuves All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/bitmap.cabal b/bitmap.cabal --- a/bitmap.cabal +++ b/bitmap.cabal @@ -1,11 +1,11 @@ Name: bitmap -Version: 0.0.1 -Synopsis: A library for handling and manipulating bitmaps. +Version: 0.0.2 +Synopsis: A library for handling and manipulating bitmaps (rectangular pixel arrays). Description: A library for handling and manipulating bitmaps (that is, rectangular pixel arrays). License: BSD3 License-file: LICENSE -Copyright: (c) 2009 Balazs Komuves +Copyright: (c) 2009-2011 Balazs Komuves Author: Balazs Komuves Maintainer: bkomuves (plus) hackage (at) gmail (dot) com Homepage: http://code.haskell.org/~bkomuves/ @@ -30,14 +30,20 @@ Exposed-Modules: Data.Bitmap, Data.Bitmap.Base, + Data.Bitmap.Simple, + Data.Bitmap.Pure, + Data.Bitmap.Pure.File, + Data.Bitmap.Pure.Pixels, Data.Bitmap.IO, - Data.Bitmap.Pure + Data.Bitmap.IO.File, + Data.Bitmap.IO.Pixels Other-Modules: Data.Bitmap.Internal Hs-Source-Dirs: . - Extensions: ForeignFunctionInterface, CPP, ScopedTypeVariables + Extensions: ForeignFunctionInterface, CPP C-Sources: cbits/bm.c Include-Dirs: cbits + cc-options: -O3 diff --git a/cbits/bm.c b/cbits/bm.c --- a/cbits/bm.c +++ b/cbits/bm.c @@ -57,8 +57,47 @@ inline word32 fromFloat_word32 (float x) { return ( floor ( 0.5 + 4294967295.0 * CLAMP_01(x) ) ); } inline float fromFloat_float (float x) { return x; } + // ----------------------------------------------------------------------------- +// tgt and src can be potentally the same +void c_mirror_line(int width, int bytesperpixel, void *src, void *tgt) +{ + int i,k; + word8 *p = (word8*)src; + word8 *q = ((word8*)tgt) + (width-1)*bytesperpixel; + + if (src == tgt) + { + word8 *tmp = alloca(bytesperpixel); + + k = width / 2; + for(i=0;i