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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
{-# OPTIONS_HADDOCK hide #-}
module Codec.BMP.BitmapInfoV3
( BitmapInfoV3 (..)
, Compression (..)
, sizeOfBitmapInfoV3
, checkBitmapInfoV3
, imageSizeFromBitmapInfoV3)
where
import Codec.BMP.Error
import Codec.BMP.Compression
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.Int
import Debug.Trace
-- | Device Independent Bitmap (DIB) header for Windows V3.
data BitmapInfoV3
= BitmapInfoV3
{ -- | (+0) Size of the image header, in bytes.
dib3Size :: Word32
-- | (+4) Width of the image, in pixels.
, dib3Width :: Word32
-- | (+8) Height of the image, in pixels.
, dib3Height :: Word32
-- | If the height field in the file is negative then this is interpreted
-- as an image with the rows flipped.
, dib3HeightFlipped :: Bool
-- | (+12) Number of color planes.
, dib3Planes :: Word16
-- | (+14) Number of bits per pixel.
, dib3BitCount :: Word16
-- | (+16) Image compression mode.
, dib3Compression :: Compression
-- | (+20) Size of raw image data.
-- Some encoders set this to zero, so we need to calculate it based
-- on the overall file size.
--
-- If it is non-zero then we check it matches the file size - header
-- size.
, dib3ImageSize :: Word32
-- | (+24) Prefered resolution in pixels per meter, along the X axis.
, dib3PelsPerMeterX :: Word32
-- | (+28) Prefered resolution in pixels per meter, along the Y axis.
, dib3PelsPerMeterY :: Word32
-- | (+32) Number of color entries that are used.
, dib3ColorsUsed :: Word32
-- | (+36) Number of significant colors.
, dib3ColorsImportant :: Word32
}
deriving (Show)
-- | Size of `BitmapInfoV3` header (in bytes)
sizeOfBitmapInfoV3 :: Int
sizeOfBitmapInfoV3 = 40
instance Binary BitmapInfoV3 where
get
= do size <- getWord32le
width <- getWord32le
-- We're supposed to treat the height field as a signed integer.
-- If it's negative it means the image is flipped along the X axis.
-- (which is crazy, but we just have to eat it)
heightW32 <- getWord32le
let heightI32 = (fromIntegral heightW32 :: Int32)
let (height, flipped)
= if heightI32 < 0
then (fromIntegral (abs heightI32), True)
else (heightW32, False)
planes <- getWord16le
bitc <- getWord16le
comp <- get
imgsize <- getWord32le
pelsX <- getWord32le
pelsY <- getWord32le
cused <- getWord32le
cimp <- getWord32le
return $ BitmapInfoV3
{ dib3Size = size
, dib3Width = width
, dib3Height = height
, dib3HeightFlipped = flipped
, dib3Planes = planes
, dib3BitCount = bitc
, dib3Compression = comp
, dib3ImageSize = imgsize
, dib3PelsPerMeterX = pelsX
, dib3PelsPerMeterY = pelsY
, dib3ColorsUsed = cused
, dib3ColorsImportant = cimp }
put header
= do putWord32le $ dib3Size header
putWord32le $ dib3Width header
putWord32le $ dib3Height header
putWord16le $ dib3Planes header
putWord16le $ dib3BitCount header
put $ dib3Compression header
putWord32le $ dib3ImageSize header
putWord32le $ dib3PelsPerMeterX header
putWord32le $ dib3PelsPerMeterY header
putWord32le $ dib3ColorsUsed header
putWord32le $ dib3ColorsImportant header
-- | Check headers for problems and unsupported features.
checkBitmapInfoV3 :: BitmapInfoV3 -> Word32 -> Maybe Error
checkBitmapInfoV3 header physicalBufferSize
-- We only handle a single color plane.
| dib3Planes header /= 1
= Just $ ErrorUnhandledPlanesCount $ dib3Planes header
-- We only handle 24 and 32 bit images.
| dib3BitCount header /= 24
, dib3BitCount header /= 32
= Just $ ErrorUnhandledColorDepth $ dib3BitCount header
-- If the image size field in the header is non-zero,
-- then it must be less than the physical size of the image buffer.
-- The buffer may be larger than the size of the image stated
-- in the header, because some encoders add padding to the end.
| headerImageSize <- dib3ImageSize header
, headerImageSize /= 0
, physicalBufferSize < headerImageSize
= Just $ ErrorImagePhysicalSizeMismatch
headerImageSize physicalBufferSize
-- Check that the physical buffer contains enough image data.
-- The buffer may be larger than the size of the image stated
-- in the header, because some encoders add padding to the end.
| Just calculatedImageSize <- imageSizeFromBitmapInfoV3 header
, fromIntegral physicalBufferSize < calculatedImageSize
= trace (show header)
$ Just $ ErrorImageDataTruncated
calculatedImageSize
(fromIntegral physicalBufferSize)
-- We only handle uncompresssed images.
| dib3Compression header /= CompressionRGB
&& dib3Compression header /= CompressionBitFields
= Just $ ErrorUnhandledCompressionMode (dib3Compression header)
| otherwise
= Nothing
-- | Compute the size of the image data from the header.
--
-- * We can't just use the 'dib3ImageSize' field because some encoders
-- set this to zero.
--
-- * We also can't use the physical size of the data in the file because
-- some encoders add zero padding bytes on the end.
--
imageSizeFromBitmapInfoV3 :: BitmapInfoV3 -> Maybe Int
imageSizeFromBitmapInfoV3 header
| dib3BitCount header == 32
, dib3Planes header == 1
, dib3Compression header == CompressionRGB
|| dib3Compression header == CompressionBitFields
= Just $ fromIntegral (dib3Width header * dib3Height header * 4)
| dib3BitCount header == 24
, dib3Planes header == 1
, dib3Compression header == CompressionRGB
|| dib3Compression header == CompressionBitFields
= let imageBytesPerLine = dib3Width header * 3
tailBytesPerLine = imageBytesPerLine `mod` 4
padBytesPerLine = if tailBytesPerLine > 0
then 4 - tailBytesPerLine
else 0
in Just $ fromIntegral
$ dib3Height header * imageBytesPerLine + padBytesPerLine
| otherwise
= trace (show header) $ Nothing
|
