1 ! Copyright (C) 2007, 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.data arrays
4 byte-arrays combinators compression.run-length endian grouping
5 images images.loader images.normalization io io.encodings.latin1
6 io.encodings.string io.streams.throwing kernel math math.bitwise
7 sequences specialized-arrays summary ;
8 QUALIFIED-WITH: bitstreams b
9 SPECIALIZED-ARRAYS: uint ushort ;
12 ! http://www.fileformat.info/format/bmp/egff.htm
13 ! http://www.digicamsoft.com/bmp/bmp.html
16 "bmp" bmp-image ?register-image-class
18 : write2 ( n -- ) 2 >le write ;
19 : write4 ( n -- ) 4 >le write ;
21 ERROR: unknown-component-order bitmap ;
22 ERROR: unknown-bitmap-header n ;
24 : read2 ( -- n ) 2 read le> ;
25 : read4 ( -- n ) 4 read le> ;
29 color-palette color-index bitfields ;
32 { magic initial: "BM" }
34 { reserved1 initial: 0 }
35 { reserved2 initial: 0 }
43 { bit-count initial: 0 }
44 { compression initial: 0 }
45 { image-size initial: 0 }
46 { x-resolution initial: 0 }
47 { y-resolution initial: 0 }
48 { colors-used initial: 0 }
49 { colors-important initial: 0 } ;
51 TUPLE: v4-header < v3-header
52 { red-mask initial: 0 }
53 { green-mask initial: 0 }
54 { blue-mask initial: 0 }
55 { alpha-mask initial: 0 }
56 { cs-type initial: 0 }
57 { end-points initial: 0 }
58 { gamma-red initial: 0 }
59 { gamma-green initial: 0 }
60 { gamma-blue initial: 0 } ;
62 TUPLE: v5-header < v4-header
64 { profile-data initial: 0 }
65 { profile-size initial: 0 }
66 { reserved3 initial: 0 } ;
72 { bit-count initial: 0 } ;
74 TUPLE: os2v2-header < os2v1-header
75 { compression initial: 0 }
76 { image-size initial: 0 }
77 { x-resolution initial: 0 }
78 { y-resolution initial: 0 }
79 { colors-used initial: 0 }
80 { colors-important initial: 0 }
82 { reserved initial: 0 }
83 { recording initial: 0 }
84 { rendering initial: 0 }
87 { color-encoding initial: 0 }
88 { identifier initial: 0 } ;
90 UNION: v-header v3-header v4-header v5-header ;
91 UNION: os2-header os2v1-header os2v2-header ;
93 : parse-file-header ( -- file-header )
95 2 read latin1 decode >>magic
100 read4 >>header-length ;
102 : read-v3-header-data ( header -- header )
104 read4 32 >signed >>height
112 read4 >>colors-important ;
114 : read-v3-header ( -- header )
116 read-v3-header-data ;
118 : read-v4-header-data ( header -- header )
124 read4 read4 read4 3array >>end-points
129 : read-v4-header ( -- v4-header )
132 read-v4-header-data ;
134 : read-v5-header-data ( v5-header -- v5-header )
140 : read-v5-header ( -- loading-bitmap )
144 read-v5-header-data ;
146 : read-os2v1-header ( -- os2v1-header )
149 read2 16 >signed >>height
153 : read-os2v2-header-data ( os2v2-header -- os2v2-header )
155 read4 32 >signed >>height
163 read4 >>colors-important
170 read4 >>color-encoding
173 : read-os2v2-header ( -- os2v2-header )
175 read-os2v2-header-data ;
177 : parse-header ( n -- header )
179 { 12 [ read-os2v1-header ] }
180 { 64 [ read-os2v2-header ] }
181 { 40 [ read-v3-header ] }
182 { 108 [ read-v4-header ] }
183 { 124 [ read-v5-header ] }
184 [ unknown-bitmap-header ]
187 : color-index-length ( header -- n )
191 [ bit-count>> * 31 + 32 /i 4 * ]
195 : color-palette-length ( loading-bitmap -- n )
197 [ offset>> 14 - ] [ header-length>> ] bi - ;
199 : parse-color-palette ( loading-bitmap -- loading-bitmap )
200 dup color-palette-length read >>color-palette ;
202 GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
204 : parse-color-data ( loading-bitmap -- loading-bitmap )
205 dup header>> parse-color-data* ;
207 M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
208 color-index-length read >>color-index ;
210 M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
211 dup image-size>> [ 0 ] unless* dup 0 >
212 [ nip ] [ drop color-index-length ] if read >>color-index ;
214 : alpha-used? ( loading-bitmap -- ? )
215 color-index>> 4 <groups> [ fourth 0 = ] all? not ;
217 GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
219 : bitmap>component-order ( loading-bitmap -- object )
220 dup header>> bitmap>component-order* ;
222 : simple-bitmap>component-order ( loading-bitamp -- object )
223 header>> bit-count>> {
230 [ unknown-component-order ]
233 : advanced-bitmap>component-order ( loading-bitmap -- object )
234 [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
235 { { 32 t } [ drop BGRA ] }
236 { { 32 f } [ drop BGRX ] }
237 [ drop simple-bitmap>component-order ]
240 : color-lookup3 ( loading-bitmap -- seq )
241 [ color-index>> >array ]
242 [ color-palette>> 3 <groups> ] bi
243 '[ _ nth ] map concat ;
245 : color-lookup4 ( loading-bitmap -- seq )
246 [ color-index>> >array ]
247 [ color-palette>> 4 <groups> [ 3 head-slice ] map ] bi
248 '[ _ nth ] map concat ;
250 ! os2v1 is 3bytes each, all others are 3 + 1 unused
251 : color-lookup ( loading-bitmap -- seq )
252 dup file-header>> header-length>> {
253 { 12 [ color-lookup3 ] }
254 { 64 [ color-lookup4 ] }
255 { 40 [ color-lookup4 ] }
256 { 108 [ color-lookup4 ] }
257 { 124 [ color-lookup4 ] }
260 M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
261 M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
262 M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
263 M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
264 M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
266 : uncompress-bitfield ( seq masks -- bytes' )
269 [ bitand ] [ bit-count ] [ log2 ] tri - shift
271 ] { } map-as B{ } concat-as ;
273 ERROR: bmp-not-supported n ;
275 : bitmap>bytes ( loading-bitmap -- byte-array )
276 dup header>> bit-count>>
278 { 32 [ color-index>> ] }
279 { 24 [ color-index>> ] }
285 ! { 0xf800 0x7e0 0x1f } uncompress-bitfield
287 { 0x7c00 0x3e0 0x1f } uncompress-bitfield
291 { 8 [ color-lookup ] }
292 { 4 [ [ 4 b:byte-array-n>sequence ] change-color-index color-lookup ] }
293 { 1 [ [ 1 b:byte-array-n>sequence ] change-color-index color-lookup ] }
294 [ bmp-not-supported ]
297 : set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
298 dup header>> bit-count>> {
299 { 16 [ dup color-palette>> 4 group [ le> ] map ] }
300 { 32 [ { 0xff0000 0xff00 0xff } ] }
301 } case reverse >>bitfields ;
303 ERROR: unsupported-bitfield-widths n ;
305 M: unsupported-bitfield-widths summary
306 drop "Bitmaps only support bitfield compression in 16/32bit images" ;
308 : uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
310 dup header>> bit-count>> {
313 ushort cast-array _ uncompress-bitfield
317 [ unsupported-bitfield-widths ]
320 ERROR: unsupported-bitmap-compression compression ;
322 GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
324 : uncompress-bitmap ( loading-bitmap -- loading-bitmap )
325 dup header>> uncompress-bitmap* ;
327 M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
330 : do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
332 _ header>> [ width>> ] [ height>> ] bi
334 ] change-color-index ; inline
336 M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
340 { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
341 { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
342 { 3 [ uncompress-bitfield-widths ] }
343 { 4 [ "jpeg" unsupported-bitmap-compression ] }
344 { 5 [ "png" unsupported-bitmap-compression ] }
347 ERROR: unsupported-bitmap-file magic ;
349 : load-bitmap ( stream -- loading-bitmap )
353 parse-file-header [ >>file-header ] [ ] bi magic>> {
355 dup file-header>> header-length>> parse-header >>header
359 ! { "BA" [ parse-os2-bitmap-array ] }
360 ! { "CI" [ parse-os2-color-icon ] }
361 ! { "CP" [ parse-os2-color-pointer ] }
362 ! { "IC" [ parse-os2-icon ] }
363 ! { "PT" [ parse-os2-pointer ] }
364 [ unsupported-bitmap-file ]
367 ] with-input-stream ;
369 : loading-bitmap>bytes ( loading-bitmap -- byte-array )
370 uncompress-bitmap bitmap>bytes ;
372 M: bmp-image stream>image* ( stream bmp-image -- bitmap )
376 [ loading-bitmap>bytes >>bitmap ]
377 [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
378 [ header>> height>> 0 < not >>upside-down? ]
379 [ bitmap>component-order >>component-order ubyte-components >>component-type ]
382 : output-width-and-height ( image -- )
383 [ dim>> first write4 ]
385 [ dim>> second ] [ upside-down?>> ] bi
386 [ neg ] unless write4
389 : output-bmp ( image -- )
390 B{ CHAR: B CHAR: M } write
392 bitmap>> length 14 + 40 + write4
398 [ output-width-and-height ]
410 [ bitmap>> length write4 ]
429 M: bmp-image image>stream
430 2drop BGR reorder-components output-bmp ;