--------------------------------------------------------------------------------
-- Module      : Data.Bitmap.Internal
-- 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
--------------------------------------------------------------------------------

{-# LANGUAGE CPP #-}
module Data.Bitmap.Internal where

--------------------------------------------------------------------------------

import Control.Monad

--import Data.Array.IArray
import Data.Word

import Foreign
import Foreign.C

--------------------------------------------------------------------------------

data PixelComponentType 
  = PctWord8 
  | PctWord16
  | PctWord32 
  | PctFloat
  deriving (Int -> PixelComponentType -> ShowS
[PixelComponentType] -> ShowS
PixelComponentType -> String
(Int -> PixelComponentType -> ShowS)
-> (PixelComponentType -> String)
-> ([PixelComponentType] -> ShowS)
-> Show PixelComponentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PixelComponentType] -> ShowS
$cshowList :: [PixelComponentType] -> ShowS
show :: PixelComponentType -> String
$cshow :: PixelComponentType -> String
showsPrec :: Int -> PixelComponentType -> ShowS
$cshowsPrec :: Int -> PixelComponentType -> ShowS
Show,PixelComponentType -> PixelComponentType -> Bool
(PixelComponentType -> PixelComponentType -> Bool)
-> (PixelComponentType -> PixelComponentType -> Bool)
-> Eq PixelComponentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PixelComponentType -> PixelComponentType -> Bool
$c/= :: PixelComponentType -> PixelComponentType -> Bool
== :: PixelComponentType -> PixelComponentType -> Bool
$c== :: PixelComponentType -> PixelComponentType -> Bool
Eq)
  
pixelComponentSize :: PixelComponentType -> Int
pixelComponentSize :: PixelComponentType -> Int
pixelComponentSize PixelComponentType
pct = case PixelComponentType
pct of
  PixelComponentType
PctWord8  -> Int
1 
  PixelComponentType
PctWord16 -> Int
2 
  PixelComponentType
PctWord32 -> Int
4 
  PixelComponentType
PctFloat  -> Int
4 

prettyPrintPixelComponentType :: PixelComponentType -> String
prettyPrintPixelComponentType :: PixelComponentType -> String
prettyPrintPixelComponentType PixelComponentType
t = case PixelComponentType
t of
  PixelComponentType
PctWord8  -> String
"Word8"
  PixelComponentType
PctWord16 -> String
"Word16"
  PixelComponentType
PctWord32 -> String
"Word32"
  PixelComponentType
PctFloat  -> String
"Float"

--------------------------------------------------------------------------------

class (Num t, Storable t) => PixelComponent t where
  c_type :: t -> CInt
--  nbytes :: t -> Int
--  nbytes x = sizeOf x
  toFloat   :: t -> Float
  fromFloat :: Float -> t
  
pixelComponentType :: PixelComponent t => t -> PixelComponentType
pixelComponentType :: t -> PixelComponentType
pixelComponentType t
t = CInt -> PixelComponentType
decodeCType (t -> CInt
forall t. PixelComponent t => t -> CInt
c_type t
t)
  
decodeCType :: CInt -> PixelComponentType 
decodeCType :: CInt -> PixelComponentType
decodeCType CInt
k = case CInt
k of
  CInt
1 -> PixelComponentType
PctWord8
  CInt
2 -> PixelComponentType
PctWord16
  CInt
3 -> PixelComponentType
PctWord32
  CInt
4 -> PixelComponentType
PctFloat

-- hmm hmm let's hope ghc will inline this into an 
-- inlined function if i explicitely ask for it... 
{-# INLINE clamp #-}
clamp :: Float -> Float
clamp :: Float -> Float
clamp = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0
 
instance PixelComponent Word8 where 
  {-# SPECIALIZE instance PixelComponent Word8  #-}
  c_type :: Word8 -> CInt
c_type Word8
_ = CInt
1
  fromFloat :: Float -> Word8
fromFloat = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Word8) -> (Float -> Float) -> Float -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
0.5) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
255) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0
  toFloat :: Word8 -> Float
toFloat = (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
3.92156862745098e-3) (Float -> Float) -> (Word8 -> Float) -> Word8 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral     -- 1/255

instance PixelComponent Word16 where 
  {-# SPECIALIZE instance PixelComponent Word16 #-}
  c_type :: Word16 -> CInt
c_type Word16
_ = CInt
2
  fromFloat :: Float -> Word16
fromFloat = Float -> Word16
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Word16) -> (Float -> Float) -> Float -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
0.5) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
65535) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0
  toFloat :: Word16 -> Float
toFloat = (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
1.5259021896696422e-5) (Float -> Float) -> (Word16 -> Float) -> Word16 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral   -- 1/65535

instance PixelComponent Word32 where 
  {-# SPECIALIZE instance PixelComponent Word32 #-}
  c_type :: Word32 -> CInt
c_type Word32
_ = CInt
3
  fromFloat :: Float -> Word32
fromFloat = Float -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Word32) -> (Float -> Float) -> Float -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
0.5) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
4294967295) (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
1 (Float -> Float) -> (Float -> Float) -> Float -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0
  toFloat :: Word32 -> Float
toFloat = (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
2.3283064370807974e-10) (Float -> Float) -> (Word32 -> Float) -> Word32 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral  -- 1/(2^32-1)
  
instance PixelComponent Float where 
  {-# SPECIALIZE instance PixelComponent Float  #-}
  c_type :: Float -> CInt
c_type Float
_ = CInt
4
  fromFloat :: Float -> Float
fromFloat = Float -> Float
forall a. a -> a
id
  toFloat :: Float -> Float
toFloat = Float -> Float
forall a. a -> a
id

--------------------------------------------------------------------------------

-- this is for portability, to avoid ScopedTypeVariables

bitmapUndefined :: BitmapClass bitmap => bitmap t -> t
bitmapUndefined :: bitmap t -> t
bitmapUndefined bitmap t
_ = t
forall a. HasCallStack => a
undefined  

bitmapCType :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> CInt
bitmapCType :: bitmap t -> CInt
bitmapCType = t -> CInt
forall t. PixelComponent t => t -> CInt
c_type (t -> CInt) -> (bitmap t -> t) -> bitmap t -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bitmap t -> t
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> t
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 :: Bitmap t -> Bitmap t
underlyingBitmap = Bitmap t -> Bitmap t
forall a. a -> a
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)
type NChn      = Int
type Padding   = Int
type Alignment = Int

-- | A bitmap.
data Bitmap t = Bitmap
  { Bitmap t -> Size
_bitmapSize      :: Size          -- ^ (width,height)
  , Bitmap t -> Int
_bitmapNChannels :: NChn          -- ^ number of channels (eg. 3 for RGB)
  , Bitmap t -> ForeignPtr t
_bitmapPtr  :: ForeignPtr t       -- ^ pointer to the data
  , Bitmap t -> Int
_bitmapRowPadding   :: Padding    -- ^ the padding of the rows, measured in /bytes/
  , Bitmap t -> Int
_bitmapRowAlignment :: Alignment  -- ^ the alignment of the rows (in bytes)
  }
--  deriving Show

--------------------------------------------------------------------------------

-- | A mutable Bitmap in the IO Monad. Only the content is mutable, the shape isn't.
newtype IOBitmap t = IOBitmap { IOBitmap t -> Bitmap t
unIOBitmap :: Bitmap t }
-- | A mutable Bitmap in the ST Monad. Only the content is mutable, the shape isn't.
newtype STBitmap t = STBitmap { STBitmap t -> Bitmap t
unSTBitmap :: Bitmap t }

instance BitmapClass IOBitmap where underlyingBitmap :: IOBitmap t -> Bitmap t
underlyingBitmap = IOBitmap t -> Bitmap t
forall t. IOBitmap t -> Bitmap t
unIOBitmap
instance BitmapClass STBitmap where underlyingBitmap :: STBitmap t -> Bitmap t
underlyingBitmap = STBitmap t -> Bitmap t
forall t. STBitmap t -> Bitmap t
unSTBitmap

--------------------------------------------------------------------------------

bitmapSize :: BitmapClass bitmap => bitmap t -> Size
bitmapSize :: bitmap t -> Size
bitmapSize = Bitmap t -> Size
forall t. Bitmap t -> Size
_bitmapSize (Bitmap t -> Size) -> (bitmap t -> Bitmap t) -> bitmap t -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bitmap t -> Bitmap t
forall (b :: * -> *) t. BitmapClass b => b t -> Bitmap t
underlyingBitmap  

bitmapNChannels :: BitmapClass bitmap => bitmap t -> NChn
bitmapNChannels :: bitmap t -> Int
bitmapNChannels = Bitmap t -> Int
forall t. Bitmap t -> Int
_bitmapNChannels (Bitmap t -> Int) -> (bitmap t -> Bitmap t) -> bitmap t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bitmap t -> Bitmap t
forall (b :: * -> *) t. BitmapClass b => b t -> Bitmap t
underlyingBitmap  

bitmapPtr :: BitmapClass bitmap => bitmap t -> ForeignPtr t
bitmapPtr :: bitmap t -> ForeignPtr t
bitmapPtr = Bitmap t -> ForeignPtr t
forall t. Bitmap t -> ForeignPtr t
_bitmapPtr (Bitmap t -> ForeignPtr t)
-> (bitmap t -> Bitmap t) -> bitmap t -> ForeignPtr t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bitmap t -> Bitmap t
forall (b :: * -> *) t. BitmapClass b => b t -> Bitmap t
underlyingBitmap  

bitmapRowPadding :: BitmapClass bitmap => bitmap t -> Padding
bitmapRowPadding :: bitmap t -> Int
bitmapRowPadding = Bitmap t -> Int
forall t. Bitmap t -> Int
_bitmapRowPadding (Bitmap t -> Int) -> (bitmap t -> Bitmap t) -> bitmap t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bitmap t -> Bitmap t
forall (b :: * -> *) t. BitmapClass b => b t -> Bitmap t
underlyingBitmap  

bitmapRowAlignment :: BitmapClass bitmap => bitmap t -> Alignment
bitmapRowAlignment :: bitmap t -> Int
bitmapRowAlignment = Bitmap t -> Int
forall t. Bitmap t -> Int
_bitmapRowAlignment (Bitmap t -> Int) -> (bitmap t -> Bitmap t) -> bitmap t -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bitmap t -> Bitmap t
forall (b :: * -> *) t. BitmapClass b => b t -> Bitmap t
underlyingBitmap  

--------------------------------------------------------------------------------

bitmapComponentType :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> PixelComponentType
bitmapComponentType :: bitmap t -> PixelComponentType
bitmapComponentType bitmap t
bm = t -> PixelComponentType
forall t. PixelComponent t => t -> PixelComponentType
pixelComponentType (bitmap t -> t
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> t
bitmapUndefined bitmap t
bm)

bitmapComponentSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
bitmapComponentSizeInBytes :: bitmap t -> Int
bitmapComponentSizeInBytes bitmap t
bm = t -> Int
forall a. Storable a => a -> Int
sizeOf (bitmap t -> t
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> t
bitmapUndefined bitmap t
bm) 

bitmapPixelSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
bitmapPixelSizeInBytes :: bitmap t -> Int
bitmapPixelSizeInBytes bitmap t
bm = bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapNChannels bitmap t
bm Int -> Int -> Int
forall a. Num a => a -> a -> a
* bitmap t -> Int
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> Int
bitmapComponentSizeInBytes bitmap t
bm
  
bitmapUnpaddedRowSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int  
bitmapUnpaddedRowSizeInBytes :: bitmap t -> Int
bitmapUnpaddedRowSizeInBytes bitmap t
bm = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* t -> Int
forall a. Storable a => a -> Int
sizeOf (bitmap t -> t
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> t
bitmapUndefined bitmap t
bm) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
nchn where
  (Int
w,Int
h) = bitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize bitmap t
bm
  nchn :: Int
nchn  = bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapNChannels bitmap t
bm   
  
bitmapPaddedRowSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int  
bitmapPaddedRowSizeInBytes :: bitmap t -> Int
bitmapPaddedRowSizeInBytes bitmap t
bm = bitmap t -> Int
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> Int
bitmapUnpaddedRowSizeInBytes bitmap t
bm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapRowPadding bitmap t
bm 
  
bitmapSizeInBytes :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int 
bitmapSizeInBytes :: bitmap t -> Int
bitmapSizeInBytes bitmap t
bm = Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x where
  x :: Int
x = bitmap t -> Int
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> Int
bitmapPaddedRowSizeInBytes bitmap t
bm
  (Int
_,Int
h) = bitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize bitmap t
bm  
 
-- | The width divided by the height.
bitmapAspect :: (Fractional a, BitmapClass bitmap) => bitmap t -> a
bitmapAspect :: bitmap t -> a
bitmapAspect bitmap t
bm = (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) where
  (Int
x,Int
y) = bitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize bitmap t
bm

--------------------------------------------------------------------------------

prettyPrintBitmap :: (BitmapClass bitmap, PixelComponent t) => String -> bitmap t -> String
prettyPrintBitmap :: String -> bitmap t -> String
prettyPrintBitmap String
prefix bitmap t
bm = String
text where
  text :: String
text = String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
typ String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
xres String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
yres String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nchn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" channels>" where
  (Int
xres,Int
yres) = bitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize bitmap t
bm
  typ :: String
typ = PixelComponentType -> String
prettyPrintPixelComponentType (bitmap t -> PixelComponentType
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> PixelComponentType
bitmapComponentType bitmap t
bm)
  nchn :: Int
nchn = bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapNChannels bitmap t
bm

instance PixelComponent t => Show (Bitmap t) where
  show :: Bitmap t -> String
show = String -> Bitmap t -> String
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
String -> bitmap t -> String
prettyPrintBitmap String
"Bitmap"

--------------------------------------------------------------------------------

-- | @withBitmap bitmap $ \\(w,h) nchn padding ptr -> ...@
withBitmap :: PixelComponent t => Bitmap t -> (Size -> NChn -> Padding -> Ptr t -> IO a) -> IO a
withBitmap :: Bitmap t -> (Size -> Int -> Int -> Ptr t -> IO a) -> IO a
withBitmap Bitmap t
bm Size -> Int -> Int -> Ptr t -> IO a
action = 
  ForeignPtr t -> (Ptr t -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Bitmap t -> ForeignPtr t
forall (bitmap :: * -> *) t.
BitmapClass bitmap =>
bitmap t -> ForeignPtr t
bitmapPtr Bitmap t
bm) ((Ptr t -> IO a) -> IO a) -> (Ptr t -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr t
p -> 
    Size -> Int -> Int -> Ptr t -> IO a
action (Bitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize Bitmap t
bm) (Bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapNChannels Bitmap t
bm) (Bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapRowPadding Bitmap t
bm) Ptr t
p

bitmapFromForeignPtrUnsafe 
  :: PixelComponent t 
  => Size -> NChn -> Alignment -> Padding -> ForeignPtr t -> Bitmap t
bitmapFromForeignPtrUnsafe :: Size -> Int -> Int -> Int -> ForeignPtr t -> Bitmap t
bitmapFromForeignPtrUnsafe Size
siz Int
nchn Int
align Int
pad ForeignPtr t
fptr = Bitmap :: forall t. Size -> Int -> ForeignPtr t -> Int -> Int -> Bitmap t
Bitmap
  { _bitmapSize :: Size
_bitmapSize      = Size
siz 
  , _bitmapNChannels :: Int
_bitmapNChannels = Int
nchn 
  , _bitmapPtr :: ForeignPtr t
_bitmapPtr       = ForeignPtr t
fptr 
  , _bitmapRowPadding :: Int
_bitmapRowPadding   = Int
pad 
  , _bitmapRowAlignment :: Int
_bitmapRowAlignment = Int
align
  }
    
--------------------------------------------------------------------------------
  
{-# SPECIALIZE isValidAlignment :: Int -> Bool #-}
isValidAlignment :: Integral a => a -> Bool
isValidAlignment :: a -> Bool
isValidAlignment a
a = a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
a [a
1,a
2,a
4,a
8,a
16]

--------------------------------------------------------------------------------

-- we mimic the OpenGL padding at the moment
recommendedPadding :: (BitmapClass bitmap, PixelComponent t) => bitmap t -> Int
recommendedPadding :: bitmap t -> Int
recommendedPadding bitmap t
bm = Int
pad where
  (Int
w,Int
_) = bitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize bitmap t
bm
  n :: Int
n = bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapNChannels bitmap t
bm
  b :: Int
b = bitmap t -> Int
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Int
bitmapRowAlignment bitmap t
bm
  s :: Int
s = t -> Int
forall a. Storable a => a -> Int
sizeOf (bitmap t -> t
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> t
bitmapUndefined bitmap t
bm)
  a :: Int
a = if Int
bInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
s then Int
s else Int
b
  k :: Int
k = case Int -> Int -> Size
forall a. Integral a => a -> a -> (a, a)
divMod Int
a Int
s of (Int
q,Int
r) -> if Int
rInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then Int
q else String -> Int
forall a. HasCallStack => String -> a
error String
"recommendedPadding: should not happen"
  pad :: Int
pad = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
* ( Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
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<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 + k-1) k - n*w )    

  kk = a * (div (s*n*w + a-1) a)
  pad2 = kk - w*s*nn
-}
  
--------------------------------------------------------------------------------