module Data.Bitmap.Foreign
( FBBitmapBase
, BitmapForeign(..)
) where
import Control.Monad.Record
import qualified Data.Bitmap as FB
import qualified Data.Bitmap.IO as FB
import Data.Bitmap.Class
import Data.Bitmap.Pixel
import Data.Bitmap.Types
import Foreign (unsafePerformIO)
import Foreign.Storable
import Text.Printf
type FBBitmapBase = FB.Bitmap
newtype BitmapForeign = BitmapForeign {unwrapBitmapForeign :: FBBitmapBase PixelComponent}
instance Bitmap BitmapForeign where
type BIndexType BitmapForeign = Int
type BPixelType BitmapForeign = PixelRGB
depth (BitmapForeign b) = unsafePerformIO . FB.withBitmap b $ \_ numComponents _ _ -> case numComponents of
3 -> return Depth24RGB
4 -> return Depth32RGBA
_ -> return $ error $ printf "Bitmap.ForeignBitmap.depth: invalid numConponents value: %d" numComponents
dimensions (BitmapForeign b) = unsafePerformIO . FB.withBitmap b $ \dms _ _ _ -> return dms
getPixel (BitmapForeign b) (row, column) = unsafePerformIO . FB.withBitmap b $ \(w, _) numComponents padding ptr -> do
let bytesPixel = numComponents
bytesRow = bytesPixel * w + padding
offset = bytesRow * row + bytesPixel * column
(thisRed :: PixelComponent) <- peekByteOff ptr offset
(thisGreen :: PixelComponent) <- peekByteOff ptr (offset + 1)
(thisBlue :: PixelComponent) <- peekByteOff ptr (offset + 2)
return . (red =: thisRed) . (green =: thisGreen) . (blue =: thisBlue) $ leastIntensity
constructPixels f dms@(w, _) = unsafePerformIO $ do
let bytesPixel = 3
fbBitmap <- FB.newBitmap dms bytesPixel (Just 4)
FB.withBitmap fbBitmap $ \(width, height) _ padding ptr -> do
let bytesRow = bytesPixel * w + padding
maxRow = abs . pred $ height
maxColumn = abs . pred $ width
m i@(row, column) = do
let offset = bytesRow * row + bytesPixel * column
pixel = f i
pokeByteOff ptr offset $ red <: pixel
pokeByteOff ptr (offset + 1) $ green <: pixel
pokeByteOff ptr (offset + 2) $ blue <: pixel
if column == maxColumn
then do
if row == maxRow
then do
return ()
else do
m (succ row, 0)
else do
m (row, succ column)
m (0, 0)
return $ BitmapForeign fbBitmap