1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
{-
ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Support for reading a file of raw RGB data:
4 bytes big-endian width
4 bytes big-endian height
width * height RGB byte triples
-}
module ReadImage ( readImage ) where
import Data.Word ( Word8, Word32 )
import Control.Exception ( bracket )
import Control.Monad ( when )
import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )
import System.IO.Error ( mkIOError, eofErrorType )
import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )
import Graphics.UI.GLUT
-- This is probably overkill, but anyway...
newtype Word32BigEndian = Word32BigEndian Word32
word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei
word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x
instance Storable Word32BigEndian where
sizeOf ~(Word32BigEndian x) = sizeOf x
alignment ~(Word32BigEndian x) = alignment x
peek ptr = do
let numBytes = sizeOf (undefined :: Word32BigEndian)
bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8]
let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes
return $ Word32BigEndian value
poke = error ""
-- This is the reason for all this stuff above...
readGLsizei :: Handle -> IO GLsizei
readGLsizei handle =
alloca $ \buf -> do
hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian))
fmap word32BigEndianToGLsizei $ peek buf
-- A handy variant of hGetBuf with additional error checking
hGetBufFully :: Handle -> Ptr a -> Int -> IO ()
hGetBufFully handle ptr numBytes = do
bytesRead <- hGetBuf handle ptr numBytes
when (bytesRead /= numBytes) $
ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing
-- Closing a file is nice, even when an error occurs during reading.
withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a
withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose
readImage :: FilePath -> IO (Size, PixelData a)
readImage filePath =
withBinaryFile filePath $ \handle -> do
width <- readGLsizei handle
height <- readGLsizei handle
let numBytes = fromIntegral (3 * width * height)
buf <- mallocBytes numBytes
hGetBufFully handle buf numBytes
return (Size width height, PixelData RGB UnsignedByte buf)
|
