1 ! Copyright (C) 2007 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: alien arrays byte-arrays combinators summary
5 io.backend graphics.viewer io io.binary io.files kernel libc
6 math math.functions namespaces opengl opengl.gl prettyprint
7 sequences strings ui ui.gadgets.panes io.encodings.binary ;
10 ! Currently can only handle 24bit bitmaps.
11 ! Handles row-reversed bitmaps (their height is negative)
13 TUPLE: bitmap magic size reserved offset header-length width
14 height planes bit-count compression size-image
15 x-pels y-pels color-used color-important rgb-quads color-index array ;
17 : raw-bitmap>string ( str n -- str )
19 { 32 [ "32bit" throw ] }
21 { 16 [ "16bit" throw ] }
22 { 8 [ "8bit" throw ] }
23 { 4 [ "4bit" throw ] }
24 { 2 [ "2bit" throw ] }
25 { 1 [ "1bit" throw ] }
30 M: bitmap-magic summary
31 drop "First two bytes of bitmap stream must be 'BM'" ;
33 : parse-file-header ( bitmap -- )
34 2 read >string dup "BM" = [ bitmap-magic ] unless
36 4 read le> over set-bitmap-size
37 4 read le> over set-bitmap-reserved
38 4 read le> swap set-bitmap-offset ;
40 : parse-bitmap-header ( bitmap -- )
41 4 read le> over set-bitmap-header-length
42 4 read le> over set-bitmap-width
43 4 read le> over set-bitmap-height
44 2 read le> over set-bitmap-planes
45 2 read le> over set-bitmap-bit-count
46 4 read le> over set-bitmap-compression
47 4 read le> over set-bitmap-size-image
48 4 read le> over set-bitmap-x-pels
49 4 read le> over set-bitmap-y-pels
50 4 read le> over set-bitmap-color-used
51 4 read le> swap set-bitmap-color-important ;
53 : rgb-quads-length ( bitmap -- n )
54 [ bitmap-offset 14 - ] keep bitmap-header-length - ;
56 : color-index-length ( bitmap -- n )
57 [ bitmap-width ] keep [ bitmap-planes * ] keep
58 [ bitmap-bit-count * 31 + 32 /i 4 * ] keep
61 : parse-bitmap ( bitmap -- )
62 dup rgb-quads-length read over set-bitmap-rgb-quads
63 dup color-index-length read swap set-bitmap-color-index ;
65 : load-bitmap ( path -- bitmap )
66 normalize-path binary [
69 dup parse-bitmap-header
72 dup bitmap-color-index over bitmap-bit-count
73 raw-bitmap>string >byte-array over set-bitmap-array ;
75 : save-bitmap ( bitmap path -- )
78 dup bitmap-array length 14 + 40 + 4 >le write
83 dup bitmap-width 4 >le write
84 dup bitmap-height 4 >le write
85 dup bitmap-planes 1 or 2 >le write
86 dup bitmap-bit-count 24 or 2 >le write
87 dup bitmap-compression 0 or 4 >le write
88 dup bitmap-size-image 4 >le write
89 dup bitmap-x-pels 4 >le write
90 dup bitmap-y-pels 4 >le write
91 dup bitmap-color-used 4 >le write
92 dup bitmap-color-important 4 >le write
93 dup bitmap-rgb-quads write
94 bitmap-color-index write
97 M: bitmap draw-image ( bitmap -- )
98 dup bitmap-height 0 < [
102 0 over bitmap-height abs glRasterPos2i
105 [ bitmap-width ] keep
107 [ bitmap-height abs ] keep
109 ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
110 { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
112 ] keep bitmap-array glDrawPixels ;
114 M: bitmap width ( bitmap -- ) bitmap-width ;
115 M: bitmap height ( bitmap -- ) bitmap-height ;
117 : bitmap. ( path -- )
118 load-bitmap <graphics-gadget> gadget. ;
120 : bitmap-window ( path -- gadget )
121 load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
123 : test-bitmap24 ( -- )
124 "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
126 : test-bitmap8 ( -- )
127 "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
129 : test-bitmap4 ( -- )
130 "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
132 : test-bitmap1 ( -- )
133 "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;