module Data.Bitmap.Internal where
import Control.Monad
import Data.Word
import Foreign
import Foreign.C
data PixelComponentType
= PctWord8
| PctWord16
| PctWord32
| PctFloat
deriving (Show,Eq)
pixelComponentSize :: PixelComponentType -> Int
pixelComponentSize pct = case pct of
PctWord8 -> 1
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
c_type :: t -> CInt
toFloat :: t -> Float
fromFloat :: Float -> t
pixelComponentType :: PixelComponent t => t -> PixelComponentType
pixelComponentType t = decodeCType (c_type t)
decodeCType :: CInt -> PixelComponentType
decodeCType k = case k of
1 -> PctWord8
2 -> PctWord16
3 -> PctWord32
4 -> PctFloat
clamp :: Float -> Float
clamp = min 1 . max 0
instance PixelComponent Word8 where
c_type _ = 1
fromFloat = floor . (+0.5) . (*255) . min 1 . max 0
toFloat = (*3.92156862745098e-3) . fromIntegral
instance PixelComponent Word16 where
c_type _ = 2
fromFloat = floor . (+0.5) . (*65535) . min 1 . max 0
toFloat = (*1.5259021896696422e-5) . fromIntegral
instance PixelComponent Word32 where
c_type _ = 3
fromFloat = floor . (+0.5) . (*4294967295) . min 1 . max 0
toFloat = (*2.3283064370807974e-10) . fromIntegral
instance PixelComponent Float where
c_type _ = 4
fromFloat = id
toFloat = id
bitmapUndefined :: BitmapClass bitmap => bitmap t -> t
bitmapUndefined _ = undefined
bitmapCType :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> CInt
bitmapCType = c_type . bitmapUndefined
class BitmapClass b where
underlyingBitmap :: b t -> Bitmap t
instance BitmapClass Bitmap where
underlyingBitmap = id
data BitmapChannel t = BmChn (Bitmap t) Int
data IOBitmapChannel t = IOBmChn (IOBitmap t) Int
data STBitmapChannel t = STBmChn (STBitmap t) Int
type Size = (Int,Int)
type Offset = (Int,Int)
type NChn = Int
type Padding = Int
type Alignment = Int
data Bitmap t = Bitmap
{ _bitmapSize :: Size
, _bitmapNChannels :: NChn
, _bitmapPtr :: ForeignPtr t
, _bitmapRowPadding :: Padding
, _bitmapRowAlignment :: Alignment
}
newtype IOBitmap t = IOBitmap { unIOBitmap :: Bitmap 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 :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
bitmapUnpaddedRowSizeInBytes bm = w * sizeOf (bitmapUndefined bm) * nchn where
(w,h) = bitmapSize bm
nchn = bitmapNChannels bm
bitmapPaddedRowSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
bitmapPaddedRowSizeInBytes bm = bitmapUnpaddedRowSizeInBytes bm + bitmapRowPadding bm
bitmapSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
bitmapSizeInBytes bm = h*x where
x = bitmapPaddedRowSizeInBytes bm
(_,h) = bitmapSize bm
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 :: 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
}
isValidAlignment :: Integral a => a -> Bool
isValidAlignment a = elem a [1,2,4,8,16]
recommendedPadding :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
recommendedPadding bm = pad where
(w,_) = bitmapSize bm
n = bitmapNChannels bm
b = bitmapRowAlignment bm
s = sizeOf (bitmapUndefined bm)
a = if b<s then s else b
k = case divMod a s of (q,r) -> if r==0 then q else error "recommendedPadding: should not happen"
pad = s * ( k * div (n*w + k1) k n*w )