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 byte-arrays
4 combinators compression.run-length fry grouping images
5 images.loader images.normalization io io.binary
6 io.encodings.8-bit.latin1 io.encodings.string kernel math
7 math.bitwise sequences specialized-arrays summary
9 QUALIFIED-WITH: bitstreams b
10 SPECIALIZED-ARRAYS: uint ushort ;
13 ! http://www.fileformat.info/format/bmp/egff.htm
14 ! http://www.digicamsoft.com/bmp/bmp.html
17 "bmp" bmp-image register-image-class
19 : write2 ( n -- ) 2 >le write ;
20 : write4 ( n -- ) 4 >le write ;
22 ERROR: unknown-component-order bitmap ;
23 ERROR: unknown-bitmap-header n ;
25 : read2 ( -- n ) 2 read le> ;
26 : read4 ( -- n ) 4 read le> ;
30 color-palette color-index bitfields ;
33 { magic initial: "BM" }
35 { reserved1 initial: 0 }
36 { reserved2 initial: 0 }
44 { bit-count initial: 0 }
45 { compression initial: 0 }
46 { image-size initial: 0 }
47 { x-resolution initial: 0 }
48 { y-resolution initial: 0 }
49 { colors-used initial: 0 }
50 { colors-important initial: 0 } ;
52 TUPLE: v4-header < v3-header
53 { red-mask initial: 0 }
54 { green-mask initial: 0 }
55 { blue-mask initial: 0 }
56 { alpha-mask initial: 0 }
57 { cs-type initial: 0 }
58 { end-points initial: 0 }
59 { gamma-red initial: 0 }
60 { gamma-green initial: 0 }
61 { gamma-blue initial: 0 } ;
63 TUPLE: v5-header < v4-header
65 { profile-data initial: 0 }
66 { profile-size initial: 0 }
67 { reserved3 initial: 0 } ;
73 { bit-count initial: 0 } ;
75 TUPLE: os2v2-header < os2v1-header
76 { compression initial: 0 }
77 { image-size initial: 0 }
78 { x-resolution initial: 0 }
79 { y-resolution initial: 0 }
80 { colors-used initial: 0 }
81 { colors-important initial: 0 }
83 { reserved initial: 0 }
84 { recording initial: 0 }
85 { rendering initial: 0 }
88 { color-encoding initial: 0 }
89 { identifier initial: 0 } ;
91 UNION: v-header v3-header v4-header v5-header ;
92 UNION: os2-header os2v1-header os2v2-header ;
94 : parse-file-header ( -- file-header )
96 2 read latin1 decode >>magic
101 read4 >>header-length ;
103 : read-v3-header-data ( header -- header )
105 read4 32 >signed >>height
113 read4 >>colors-important ;
115 : read-v3-header ( -- header )
117 read-v3-header-data ;
119 : read-v4-header-data ( header -- header )
125 read4 read4 read4 3array >>end-points
130 : read-v4-header ( -- v4-header )
133 read-v4-header-data ;
135 : read-v5-header-data ( v5-header -- v5-header )
141 : read-v5-header ( -- loading-bitmap )
145 read-v5-header-data ;
147 : read-os2v1-header ( -- os2v1-header )
150 read2 16 >signed >>height
154 : read-os2v2-header-data ( os2v2-header -- os2v2-header )
156 read4 32 >signed >>height
164 read4 >>colors-important
171 read4 >>color-encoding
174 : read-os2v2-header ( -- os2v2-header )
176 read-os2v2-header-data ;
178 : parse-header ( n -- header )
180 { 12 [ read-os2v1-header ] }
181 { 64 [ read-os2v2-header ] }
182 { 40 [ read-v3-header ] }
183 { 108 [ read-v4-header ] }
184 { 124 [ read-v5-header ] }
185 [ unknown-bitmap-header ]
188 : color-index-length ( header -- n )
192 [ bit-count>> * 31 + 32 /i 4 * ]
196 : color-palette-length ( loading-bitmap -- n )
198 [ offset>> 14 - ] [ header-length>> ] bi - ;
200 : parse-color-palette ( loading-bitmap -- loading-bitmap )
201 dup color-palette-length read >>color-palette ;
203 GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
205 : parse-color-data ( loading-bitmap -- loading-bitmap )
206 dup header>> parse-color-data* ;
208 M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
209 color-index-length read >>color-index ;
211 M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
212 dup image-size>> [ 0 ] unless* dup 0 >
213 [ nip ] [ drop color-index-length ] if read >>color-index ;
215 : alpha-used? ( loading-bitmap -- ? )
216 color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
218 GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
220 : bitmap>component-order ( loading-bitmap -- object )
221 dup header>> bitmap>component-order* ;
223 : simple-bitmap>component-order ( loading-bitamp -- object )
224 header>> bit-count>> {
231 [ unknown-component-order ]
234 : advanced-bitmap>component-order ( loading-bitmap -- object )
235 [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
236 { { 32 t } [ drop BGRA ] }
237 { { 32 f } [ drop BGRX ] }
238 [ drop simple-bitmap>component-order ]
241 : color-lookup3 ( loading-bitmap -- seq )
242 [ color-index>> >array ]
243 [ color-palette>> 3 <sliced-groups> ] bi
244 '[ _ nth ] map concat ;
246 : color-lookup4 ( loading-bitmap -- seq )
247 [ color-index>> >array ]
248 [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
249 '[ _ nth ] map concat ;
251 ! os2v1 is 3bytes each, all others are 3 + 1 unused
252 : color-lookup ( loading-bitmap -- seq )
253 dup file-header>> header-length>> {
254 { 12 [ color-lookup3 ] }
255 { 64 [ color-lookup4 ] }
256 { 40 [ color-lookup4 ] }
257 { 108 [ color-lookup4 ] }
258 { 124 [ color-lookup4 ] }
261 M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
262 M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
263 M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
264 M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
265 M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
267 : uncompress-bitfield ( seq masks -- bytes' )
270 [ bitand ] [ bit-count ] [ log2 ] tri - shift
272 ] { } map-as B{ } concat-as ;
274 ERROR: bmp-not-supported n ;
276 : bitmap>bytes ( loading-bitmap -- byte-array )
277 dup header>> bit-count>>
279 { 32 [ color-index>> ] }
280 { 24 [ color-index>> ] }
286 ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
288 { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
292 { 8 [ color-lookup ] }
293 { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
294 { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
295 [ bmp-not-supported ]
298 : set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
299 dup header>> bit-count>> {
300 { 16 [ dup color-palette>> 4 group [ le> ] map ] }
301 { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
302 } case reverse >>bitfields ;
304 ERROR: unsupported-bitfield-widths n ;
306 M: unsupported-bitfield-widths summary
307 drop "Bitmaps only support bitfield compression in 16/32bit images" ;
309 : uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
311 dup header>> bit-count>> {
314 ushort cast-array _ uncompress-bitfield
318 [ unsupported-bitfield-widths ]
321 ERROR: unsupported-bitmap-compression compression ;
323 GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
325 : uncompress-bitmap ( loading-bitmap -- loading-bitmap )
326 dup header>> uncompress-bitmap* ;
328 M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
331 : do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
333 _ header>> [ width>> ] [ height>> ] bi
335 ] change-color-index ; inline
337 M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
341 { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
342 { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
343 { 3 [ uncompress-bitfield-widths ] }
344 { 4 [ "jpeg" unsupported-bitmap-compression ] }
345 { 5 [ "png" unsupported-bitmap-compression ] }
348 ERROR: unsupported-bitmap-file magic ;
350 : load-bitmap ( stream -- loading-bitmap )
354 parse-file-header [ >>file-header ] [ ] bi magic>> {
356 dup file-header>> header-length>> parse-header >>header
360 ! { "BA" [ parse-os2-bitmap-array ] }
361 ! { "CI" [ parse-os2-color-icon ] }
362 ! { "CP" [ parse-os2-color-pointer ] }
363 ! { "IC" [ parse-os2-icon ] }
364 ! { "PT" [ parse-os2-pointer ] }
365 [ unsupported-bitmap-file ]
368 ] with-input-stream ;
370 : loading-bitmap>bytes ( loading-bitmap -- byte-array )
371 uncompress-bitmap bitmap>bytes ;
373 M: bmp-image stream>image ( stream bmp-image -- bitmap )
377 [ loading-bitmap>bytes >>bitmap ]
378 [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
379 [ header>> height>> 0 < not >>upside-down? ]
380 [ bitmap>component-order >>component-order ubyte-components >>component-type ]
383 : output-width-and-height ( image -- )
384 [ dim>> first write4 ]
386 [ dim>> second ] [ upside-down?>> ] bi
387 [ neg ] unless write4
390 : output-bmp ( image -- )
391 B{ CHAR: B CHAR: M } write
393 bitmap>> length 14 + 40 + write4
399 [ output-width-and-height ]
411 [ bitmap>> length write4 ]
430 M: bmp-image image>stream
431 drop BGR reorder-components output-bmp ;