--------------------------------------------------------------------------------
-- 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:
-- <http://hackage.haskell.org/package/stb-image>.
--
-- 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 :: FilePath -> IO (IOBitmap t)
readBitmap FilePath
fpath = do
  Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
ReadMode
  (Size, NChn, PixelComponentType)
header <- Handle -> IO (Size, NChn, PixelComponentType)
hGetHeader Handle
h
  IOBitmap t
bitmap <- Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
forall t.
PixelComponent t =>
Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
hGetRawData Handle
h (Size, NChn, PixelComponentType)
header
  Handle -> IO ()
hClose Handle
h
  IOBitmap t -> IO (IOBitmap t)
forall (m :: * -> *) a. Monad m => a -> m a
return IOBitmap t
bitmap
  
readRawData :: PixelComponent t => FilePath -> (Size,NChn,PixelComponentType) -> IO (IOBitmap t) 
readRawData :: FilePath -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
readRawData FilePath
fpath (Size, NChn, PixelComponentType)
header = do 
  Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
ReadMode
  IOBitmap t
bitmap <- Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
forall t.
PixelComponent t =>
Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
hGetRawData Handle
h (Size, NChn, PixelComponentType)
header
  Handle -> IO ()
hClose Handle
h
  IOBitmap t -> IO (IOBitmap t)
forall (m :: * -> *) a. Monad m => a -> m a
return IOBitmap t
bitmap

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

writeBitmap :: PixelComponent t => FilePath -> IOBitmap t -> IO ()
writeBitmap :: FilePath -> IOBitmap t -> IO ()
writeBitmap FilePath
fpath IOBitmap t
bm = do
  Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
WriteMode
  Handle -> IOBitmap t -> IO ()
forall t. PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutHeader  Handle
h IOBitmap t
bm
  Handle -> IOBitmap t -> IO ()
forall t. PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutRawData Handle
h IOBitmap t
bm
  Handle -> IO ()
hClose Handle
h

-- | Saves only the raw pixel data, no resolution etc.
writeRawData :: PixelComponent t => FilePath -> IOBitmap t -> IO ()
writeRawData :: FilePath -> IOBitmap t -> IO ()
writeRawData FilePath
fpath IOBitmap t
bm = do
  Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
WriteMode
  Handle -> IOBitmap t -> IO ()
forall t. PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutRawData Handle
h IOBitmap t
bm
  Handle -> IO ()
hClose Handle
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 :: Handle -> IOBitmap t -> IO ()
hPutHeader Handle
h IOBitmap t
bm = do
  let (NChn
xsize,NChn
ysize) = IOBitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize IOBitmap t
bm
      nchn :: NChn
nchn = IOBitmap t -> NChn
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> NChn
bitmapNChannels IOBitmap t
bm
      typ :: CInt
typ  = IOBitmap t -> CInt
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> CInt
bitmapCType IOBitmap t
bm
  Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (NChn -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral NChn
xsize :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4 
  Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (NChn -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral NChn
ysize :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4 
  Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (NChn -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral NChn
nchn  :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4 
  Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (CInt -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
typ   :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4 
  
-- | Saves only the raw pixel data, no resolution etc.
hPutRawData :: PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutRawData :: Handle -> IOBitmap t -> IO ()
hPutRawData Handle
h IOBitmap t
bm = 
  IOBitmap t -> (Size -> NChn -> NChn -> Ptr t -> IO ()) -> IO ()
forall t a.
PixelComponent t =>
IOBitmap t -> (Size -> NChn -> NChn -> Ptr t -> IO a) -> IO a
withIOBitmap IOBitmap t
bm ((Size -> NChn -> NChn -> Ptr t -> IO ()) -> IO ())
-> (Size -> NChn -> NChn -> Ptr t -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(NChn
xres,NChn
yres) NChn
nchn NChn
padding Ptr t
ptr -> do
    [NChn] -> (NChn -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NChn
0..NChn
yresNChn -> NChn -> NChn
forall a. Num a => a -> a -> a
-NChn
1] ((NChn -> IO ()) -> IO ()) -> (NChn -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NChn
k -> do
      let q :: Ptr b
q = Ptr t
ptr Ptr t -> NChn -> Ptr b
forall a b. Ptr a -> NChn -> Ptr b
`plusPtr` (NChn
kNChn -> NChn -> NChn
forall a. Num a => a -> a -> a
*NChn
long)
      Handle -> Ptr Any -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Any
forall b. Ptr b
q NChn
short    
  where
    long :: NChn
long  = IOBitmap t -> NChn
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> NChn
bitmapPaddedRowSizeInBytes   IOBitmap t
bm
    short :: NChn
short = IOBitmap t -> NChn
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> NChn
bitmapUnpaddedRowSizeInBytes IOBitmap t
bm
    
--------------------------------------------------------------------------------
    
hGetRawData :: PixelComponent t => Handle -> (Size,NChn,PixelComponentType) -> IO (IOBitmap t)
hGetRawData :: Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
hGetRawData Handle
h (Size
siz,NChn
nchn,PixelComponentType
pct) = do
  IOBitmap t
bm <- Size -> NChn -> Maybe NChn -> IO (IOBitmap t)
forall t.
PixelComponent t =>
Size -> NChn -> Maybe NChn -> IO (IOBitmap t)
newIOBitmapUninitialized Size
siz NChn
nchn (NChn -> Maybe NChn
forall a. a -> Maybe a
Just NChn
1)
  if IOBitmap t -> PixelComponentType
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> PixelComponentType
bitmapComponentType IOBitmap t
bm PixelComponentType -> PixelComponentType -> Bool
forall a. Eq a => a -> a -> Bool
/= PixelComponentType
pct
    then FilePath -> IO (IOBitmap t)
forall a. HasCallStack => FilePath -> a
error FilePath
"bitmap/getRawData: bitmap component type does not match"
    else do
      IOBitmap t
-> (Size -> NChn -> NChn -> Ptr t -> IO (IOBitmap t))
-> IO (IOBitmap t)
forall t a.
PixelComponent t =>
IOBitmap t -> (Size -> NChn -> NChn -> Ptr t -> IO a) -> IO a
withIOBitmap IOBitmap t
bm ((Size -> NChn -> NChn -> Ptr t -> IO (IOBitmap t))
 -> IO (IOBitmap t))
-> (Size -> NChn -> NChn -> Ptr t -> IO (IOBitmap t))
-> IO (IOBitmap t)
forall a b. (a -> b) -> a -> b
$ \(NChn
_,NChn
ysiz) NChn
_ NChn
_ Ptr t
ptr -> do
        let n :: NChn
n = NChn
ysiz NChn -> NChn -> NChn
forall a. Num a => a -> a -> a
* IOBitmap t -> NChn
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> NChn
bitmapUnpaddedRowSizeInBytes IOBitmap t
bm
        NChn
k <- Handle -> Ptr t -> NChn -> IO NChn
forall a. Handle -> Ptr a -> NChn -> IO NChn
hGetBuf Handle
h Ptr t
ptr NChn
n
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NChn
kNChn -> NChn -> Bool
forall a. Eq a => a -> a -> Bool
/=NChn
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"bitmap/getRawData: not enough data"
        IOBitmap t -> IO (IOBitmap t)
forall (m :: * -> *) a. Monad m => a -> m a
return IOBitmap t
bm 
    
hGetHeader :: Handle -> IO (Size,NChn,PixelComponentType)
hGetHeader :: Handle -> IO (Size, NChn, PixelComponentType)
hGetHeader Handle
h = do
  Int32
xsize <- IO Int32
loadInt32
  Int32
ysize <- IO Int32
loadInt32
  Int32
nchn  <- IO Int32
loadInt32
  Int32
ctyp  <- IO Int32
loadInt32
  (Size, NChn, PixelComponentType)
-> IO (Size, NChn, PixelComponentType)
forall (m :: * -> *) a. Monad m => a -> m a
return 
    ( (Int32 -> NChn
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
xsize, Int32 -> NChn
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ysize)
    , Int32 -> NChn
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
nchn
    , CInt -> PixelComponentType
decodeCType (Int32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ctyp)
    )
  where
    loadInt32 :: IO Int32
    loadInt32 :: IO Int32
loadInt32 = (Ptr Int32 -> IO Int32) -> IO Int32
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int32 -> IO Int32) -> IO Int32)
-> (Ptr Int32 -> IO Int32) -> IO Int32
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> do
      Handle -> Ptr Int32 -> NChn -> IO NChn
forall a. Handle -> Ptr a -> NChn -> IO NChn
hGetBuf Handle
h Ptr Int32
p NChn
4
      Ptr Int32 -> IO Int32
forall a. Storable a => Ptr a -> IO a
peek Ptr Int32
p
    
--------------------------------------------------------------------------------