1 ! Copyright (C) 2007, 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types arrays byte-arrays columns
4 combinators fry grouping io io.binary io.encodings.binary
5 io.files kernel libc macros math math.bitwise math.functions
6 namespaces opengl opengl.gl prettyprint sequences strings
7 summary ui ui.gadgets.panes images.backend ;
10 TUPLE: bitmap-image < image ;
12 ! Currently can only handle 24/32bit bitmaps.
13 ! Handles row-reversed bitmaps (their height is negative)
15 TUPLE: bitmap magic size reserved offset header-length width
16 height planes bit-count compression size-image
17 x-pels y-pels color-used color-important rgb-quads color-index
21 : array-copy ( bitmap array -- bitmap array' )
22 over size-image>> abs memory>byte-array ;
24 : 8bit>buffer ( bitmap -- array )
25 [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
26 [ color-index>> >array ] bi [ swap nth ] with map concat ;
28 ERROR: bmp-not-supported n ;
30 : raw-bitmap>buffer ( bitmap -- array )
33 { 32 [ color-index>> ] }
34 { 24 [ color-index>> ] }
35 { 16 [ bmp-not-supported ] }
37 { 4 [ bmp-not-supported ] }
38 { 2 [ bmp-not-supported ] }
39 { 1 [ bmp-not-supported ] }
44 M: bitmap-magic summary
45 drop "First two bytes of bitmap stream must be 'BM'" ;
47 : read2 ( -- n ) 2 read le> ;
48 : read4 ( -- n ) 4 read le> ;
50 : parse-file-header ( bitmap -- bitmap )
51 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
56 : parse-bitmap-header ( bitmap -- bitmap )
67 read4 >>color-important ;
69 : rgb-quads-length ( bitmap -- n )
70 [ offset>> 14 - ] [ header-length>> ] bi - ;
72 : color-index-length ( bitmap -- n )
76 [ bit-count>> * 31 + 32 /i 4 * ]
80 : parse-bitmap ( bitmap -- bitmap )
81 dup rgb-quads-length read >>rgb-quads
82 dup color-index-length read >>color-index ;
84 : load-bitmap-data ( path -- bitmap )
87 parse-file-header parse-bitmap-header parse-bitmap
90 : alpha-channel-zero? ( bitmap -- ? )
91 buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
93 : process-bitmap-data ( bitmap -- bitmap )
94 dup raw-bitmap>buffer >>buffer
95 dup alpha-channel-zero? >>alpha-channel-zero? ;
97 : load-bitmap ( path -- bitmap )
98 load-bitmap-data process-bitmap-data ;
100 : bitmap>image ( bitmap -- bitmap-image )
101 { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
102 bitmap-image new-image ;
104 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
108 MACRO: (nbits>bitmap) ( bits -- )
111 2over * _ * >>size-image
114 swap array-copy [ >>buffer ] [ >>color-index ] bi
115 _ >>bit-count bitmap>image
118 : bgr>bitmap ( array height width -- bitmap )
121 : bgra>bitmap ( array height width -- bitmap )
124 : write2 ( n -- ) 2 >le write ;
125 : write4 ( n -- ) 4 >le write ;
127 : save-bitmap ( bitmap path -- )
129 B{ CHAR: B CHAR: M } write
131 buffer>> length 14 + 40 + write4
139 [ planes>> 1 or write2 ]
140 [ bit-count>> 24 or write2 ]
141 [ compression>> 0 or write4 ]
142 [ size-image>> write4 ]
143 [ x-pels>> 0 or write4 ]
144 [ y-pels>> 0 or write4 ]
145 [ color-used>> 0 or write4 ]
146 [ color-important>> 0 or write4 ]
147 [ rgb-quads>> write ]
148 [ color-index>> write ]