1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.data assocs cache colors.constants
4 destructors kernel opengl opengl.gl opengl.capabilities
5 combinators images images.tessellation grouping sequences math
6 math.statistics math.vectors generalizations fry arrays
7 namespaces system locals literals specialized-arrays ;
8 FROM: alien.c-types => int float ;
9 SPECIALIZED-ARRAY: float
12 SYMBOL: non-power-of-2-textures?
14 : check-extensions ( -- )
15 #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
16 #! See thread 'Linux font display problem' April 2009 on Factor-talk
17 gl-vendor "ATI Technologies Inc." = not os macosx? or [
18 "2.0" { "GL_ARB_texture_non_power_of_two" }
19 has-gl-version-or-extensions?
20 non-power-of-2-textures? set
23 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
25 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
27 ERROR: unsupported-component-order component-order component-type ;
29 CONSTANT: image-internal-formats H{
30 { { A ubyte-components } $ GL_ALPHA8 }
31 { { A ushort-components } $ GL_ALPHA16 }
32 { { A half-components } $ GL_ALPHA16F_ARB }
33 { { A float-components } $ GL_ALPHA32F_ARB }
34 { { A byte-integer-components } $ GL_ALPHA8I_EXT }
35 { { A ubyte-integer-components } $ GL_ALPHA8UI_EXT }
36 { { A short-integer-components } $ GL_ALPHA16I_EXT }
37 { { A ushort-integer-components } $ GL_ALPHA16UI_EXT }
38 { { A int-integer-components } $ GL_ALPHA32I_EXT }
39 { { A uint-integer-components } $ GL_ALPHA32UI_EXT }
41 { { L ubyte-components } $ GL_LUMINANCE8 }
42 { { L ushort-components } $ GL_LUMINANCE16 }
43 { { L half-components } $ GL_LUMINANCE16F_ARB }
44 { { L float-components } $ GL_LUMINANCE32F_ARB }
45 { { L byte-integer-components } $ GL_LUMINANCE8I_EXT }
46 { { L ubyte-integer-components } $ GL_LUMINANCE8UI_EXT }
47 { { L short-integer-components } $ GL_LUMINANCE16I_EXT }
48 { { L ushort-integer-components } $ GL_LUMINANCE16UI_EXT }
49 { { L int-integer-components } $ GL_LUMINANCE32I_EXT }
50 { { L uint-integer-components } $ GL_LUMINANCE32UI_EXT }
52 { { R ubyte-components } $ GL_R8 }
53 { { R ushort-components } $ GL_R16 }
54 { { R half-components } $ GL_R16F }
55 { { R float-components } $ GL_R32F }
56 { { R byte-integer-components } $ GL_R8I }
57 { { R ubyte-integer-components } $ GL_R8UI }
58 { { R short-integer-components } $ GL_R16I }
59 { { R ushort-integer-components } $ GL_R16UI }
60 { { R int-integer-components } $ GL_R32I }
61 { { R uint-integer-components } $ GL_R32UI }
63 { { INTENSITY ubyte-components } $ GL_INTENSITY8 }
64 { { INTENSITY ushort-components } $ GL_INTENSITY16 }
65 { { INTENSITY half-components } $ GL_INTENSITY16F_ARB }
66 { { INTENSITY float-components } $ GL_INTENSITY32F_ARB }
67 { { INTENSITY byte-integer-components } $ GL_INTENSITY8I_EXT }
68 { { INTENSITY ubyte-integer-components } $ GL_INTENSITY8UI_EXT }
69 { { INTENSITY short-integer-components } $ GL_INTENSITY16I_EXT }
70 { { INTENSITY ushort-integer-components } $ GL_INTENSITY16UI_EXT }
71 { { INTENSITY int-integer-components } $ GL_INTENSITY32I_EXT }
72 { { INTENSITY uint-integer-components } $ GL_INTENSITY32UI_EXT }
74 { { DEPTH ushort-components } $ GL_DEPTH_COMPONENT16 }
75 { { DEPTH u-24-components } $ GL_DEPTH_COMPONENT24 }
76 { { DEPTH uint-components } $ GL_DEPTH_COMPONENT32 }
77 { { DEPTH float-components } $ GL_DEPTH_COMPONENT32F }
79 { { LA ubyte-components } $ GL_LUMINANCE8_ALPHA8 }
80 { { LA ushort-components } $ GL_LUMINANCE16_ALPHA16 }
81 { { LA half-components } $ GL_LUMINANCE_ALPHA16F_ARB }
82 { { LA float-components } $ GL_LUMINANCE_ALPHA32F_ARB }
83 { { LA byte-integer-components } $ GL_LUMINANCE_ALPHA8I_EXT }
84 { { LA ubyte-integer-components } $ GL_LUMINANCE_ALPHA8UI_EXT }
85 { { LA short-integer-components } $ GL_LUMINANCE_ALPHA16I_EXT }
86 { { LA ushort-integer-components } $ GL_LUMINANCE_ALPHA16UI_EXT }
87 { { LA int-integer-components } $ GL_LUMINANCE_ALPHA32I_EXT }
88 { { LA uint-integer-components } $ GL_LUMINANCE_ALPHA32UI_EXT }
90 { { RG ubyte-components } $ GL_RG8 }
91 { { RG ushort-components } $ GL_RG16 }
92 { { RG half-components } $ GL_RG16F }
93 { { RG float-components } $ GL_RG32F }
94 { { RG byte-integer-components } $ GL_RG8I }
95 { { RG ubyte-integer-components } $ GL_RG8UI }
96 { { RG short-integer-components } $ GL_RG16I }
97 { { RG ushort-integer-components } $ GL_RG16UI }
98 { { RG int-integer-components } $ GL_RG32I }
99 { { RG uint-integer-components } $ GL_RG32UI }
101 { { DEPTH-STENCIL u-24-8-components } $ GL_DEPTH24_STENCIL8 }
102 { { DEPTH-STENCIL float-32-u-8-components } $ GL_DEPTH32F_STENCIL8 }
104 { { RGB ubyte-components } $ GL_RGB8 }
105 { { RGB ushort-components } $ GL_RGB16 }
106 { { RGB half-components } $ GL_RGB16F }
107 { { RGB float-components } $ GL_RGB32F }
108 { { RGB byte-integer-components } $ GL_RGB8I }
109 { { RGB ubyte-integer-components } $ GL_RGB8UI }
110 { { RGB byte-integer-components } $ GL_RGB8I }
111 { { RGB ubyte-integer-components } $ GL_RGB8UI }
112 { { RGB short-integer-components } $ GL_RGB16I }
113 { { RGB ushort-integer-components } $ GL_RGB16UI }
114 { { RGB int-integer-components } $ GL_RGB32I }
115 { { RGB uint-integer-components } $ GL_RGB32UI }
116 { { RGB u-5-6-5-components } $ GL_RGB5 }
117 { { RGB u-9-9-9-e5-components } $ GL_RGB9_E5 }
118 { { RGB float-11-11-10-components } $ GL_R11F_G11F_B10F }
120 { { RGBA ubyte-components } $ GL_RGBA8 }
121 { { RGBA ushort-components } $ GL_RGBA16 }
122 { { RGBA half-components } $ GL_RGBA16F }
123 { { RGBA float-components } $ GL_RGBA32F }
124 { { RGBA byte-integer-components } $ GL_RGBA8I }
125 { { RGBA ubyte-integer-components } $ GL_RGBA8UI }
126 { { RGBA byte-integer-components } $ GL_RGBA8I }
127 { { RGBA ubyte-integer-components } $ GL_RGBA8UI }
128 { { RGBA short-integer-components } $ GL_RGBA16I }
129 { { RGBA ushort-integer-components } $ GL_RGBA16UI }
130 { { RGBA int-integer-components } $ GL_RGBA32I }
131 { { RGBA uint-integer-components } $ GL_RGBA32UI }
132 { { RGBA u-5-5-5-1-components } $ GL_RGB5_A1 }
133 { { RGBA u-10-10-10-2-components } $ GL_RGB10_A2 }
136 GENERIC: fix-internal-component-order ( order -- order' )
138 M: object fix-internal-component-order ;
139 M: BGR fix-internal-component-order drop RGB ;
140 M: BGRA fix-internal-component-order drop RGBA ;
141 M: ARGB fix-internal-component-order drop RGBA ;
142 M: ABGR fix-internal-component-order drop RGBA ;
143 M: RGBX fix-internal-component-order drop RGBA ;
144 M: BGRX fix-internal-component-order drop RGBA ;
145 M: XRGB fix-internal-component-order drop RGBA ;
146 M: XBGR fix-internal-component-order drop RGBA ;
148 : image-internal-format ( component-order component-type -- internal-format )
150 [ fix-internal-component-order ] dip 2array image-internal-formats at
151 [ 2nip ] [ throw-unsupported-component-order ] if* ;
153 : reversed-type? ( component-type -- ? )
154 { u-9-9-9-e5-components float-11-11-10-components } member? ;
156 : (component-order>format) ( component-order component-type -- gl-format )
157 dup unnormalized-integer-components? [
159 { A [ drop GL_ALPHA_INTEGER_EXT ] }
160 { L [ drop GL_LUMINANCE_INTEGER_EXT ] }
161 { R [ drop GL_RED_INTEGER ] }
162 { LA [ drop GL_LUMINANCE_ALPHA_INTEGER_EXT ] }
163 { RG [ drop GL_RG_INTEGER ] }
164 { BGR [ drop GL_BGR_INTEGER ] }
165 { RGB [ drop GL_RGB_INTEGER ] }
166 { BGRA [ drop GL_BGRA_INTEGER ] }
167 { RGBA [ drop GL_RGBA_INTEGER ] }
168 { BGRX [ drop GL_BGRA_INTEGER ] }
169 { RGBX [ drop GL_RGBA_INTEGER ] }
170 [ swap throw-unsupported-component-order ]
174 { A [ drop GL_ALPHA ] }
175 { L [ drop GL_LUMINANCE ] }
176 { R [ drop GL_RED ] }
177 { LA [ drop GL_LUMINANCE_ALPHA ] }
178 { RG [ drop GL_RG ] }
179 { BGR [ reversed-type? GL_RGB GL_BGR ? ] }
180 { RGB [ reversed-type? GL_BGR GL_RGB ? ] }
181 { BGRA [ drop GL_BGRA ] }
182 { RGBA [ drop GL_RGBA ] }
183 { ARGB [ drop GL_BGRA ] }
184 { ABGR [ drop GL_RGBA ] }
185 { BGRX [ drop GL_BGRA ] }
186 { RGBX [ drop GL_RGBA ] }
187 { XRGB [ drop GL_BGRA ] }
188 { XBGR [ drop GL_RGBA ] }
189 { INTENSITY [ drop GL_INTENSITY ] }
190 { DEPTH [ drop GL_DEPTH_COMPONENT ] }
191 { DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] }
192 [ swap throw-unsupported-component-order ]
196 GENERIC: (component-type>type) ( component-order component-type -- gl-type )
198 M: object (component-type>type) throw-unsupported-component-order ;
200 : four-channel-alpha-first? ( component-order component-type -- ? )
201 over component-count 4 =
202 [ drop alpha-channel-precedes-colors? ]
203 [ throw-unsupported-component-order ] if ;
205 : not-alpha-first ( component-order component-type -- )
206 over alpha-channel-precedes-colors?
207 [ throw-unsupported-component-order ]
210 M: ubyte-components (component-type>type)
211 drop alpha-channel-precedes-colors?
212 [ GL_UNSIGNED_INT_8_8_8_8_REV ]
213 [ GL_UNSIGNED_BYTE ] if ;
215 M: ushort-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
216 M: uint-components (component-type>type) not-alpha-first GL_UNSIGNED_INT ;
217 M: half-components (component-type>type) not-alpha-first GL_HALF_FLOAT ;
218 M: float-components (component-type>type) not-alpha-first GL_FLOAT ;
219 M: byte-integer-components (component-type>type) not-alpha-first GL_BYTE ;
220 M: ubyte-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_BYTE ;
221 M: short-integer-components (component-type>type) not-alpha-first GL_SHORT ;
222 M: ushort-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
223 M: int-integer-components (component-type>type) not-alpha-first GL_INT ;
224 M: uint-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_INT ;
226 M: u-5-5-5-1-components (component-type>type)
227 four-channel-alpha-first?
228 [ GL_UNSIGNED_SHORT_1_5_5_5_REV ]
229 [ GL_UNSIGNED_SHORT_5_5_5_1 ] if ;
231 M: u-5-6-5-components (component-type>type) 2drop GL_UNSIGNED_SHORT_5_6_5 ;
233 M: u-10-10-10-2-components (component-type>type)
234 four-channel-alpha-first?
235 [ GL_UNSIGNED_INT_2_10_10_10_REV ]
236 [ GL_UNSIGNED_INT_10_10_10_2 ] if ;
238 M: u-24-components (component-type>type)
240 [ 2drop GL_UNSIGNED_INT ]
241 [ throw-unsupported-component-order ] if ;
243 M: u-24-8-components (component-type>type)
245 [ 2drop GL_UNSIGNED_INT_24_8 ]
246 [ throw-unsupported-component-order ] if ;
248 M: u-9-9-9-e5-components (component-type>type)
250 [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ]
251 [ throw-unsupported-component-order ] if ;
253 M: float-11-11-10-components (component-type>type)
255 [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ]
256 [ throw-unsupported-component-order ] if ;
258 : image-data-format ( component-order component-type -- gl-format gl-type )
259 [ (component-order>format) ] [ (component-type>type) ] 2bi ;
263 : draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
265 GENERIC: draw-scaled-texture ( dim texture -- )
269 : (image-format) ( component-order component-type -- internal-format format type )
270 [ image-internal-format ] [ image-data-format ] 2bi ;
272 : image-format ( image -- internal-format format type )
273 [ component-order>> ] [ component-type>> ] bi (image-format) ;
277 TUPLE: single-texture < disposable image dim loc texture-coords texture display-list ;
279 : adjust-texture-dim ( dim -- dim' )
280 non-power-of-2-textures? get [
281 [ dup 1 = [ next-power-of-2 ] unless ] map
284 :: tex-image ( image bitmap -- )
285 image image-format :> ( internal-format format type )
286 GL_TEXTURE_2D 0 internal-format
287 image dim>> adjust-texture-dim first2 0
288 format type bitmap glTexImage2D ;
290 : tex-sub-image ( image -- )
291 [ GL_TEXTURE_2D 0 0 0 ] dip
293 [ image-format [ drop ] 2dip ]
297 : init-texture ( -- )
298 GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
299 GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
300 GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
301 GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
303 : with-texturing ( quot -- )
306 GL_TEXTURE_COORD_ARRAY [
307 COLOR: white gl-color
309 ] do-enabled-client-state
311 ] do-enabled ; inline
313 : texture-dim ( texture -- dim )
314 [ dim>> ] [ image>> ] bi 2x?>> [ [ 2.0 / ] map ] when ;
316 : (draw-textured-rect) ( dim texture -- )
318 [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
319 [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
322 : set-blend-mode ( texture -- )
323 image>> dup has-alpha?
324 [ premultiplied-alpha?>> [ GL_ONE GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
325 [ drop GL_BLEND glDisable ] if ;
327 : reset-blend-mode ( texture -- )
328 image>> dup has-alpha?
329 [ premultiplied-alpha?>> [ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
330 [ drop GL_BLEND glEnable ] if ;
332 : draw-textured-rect ( dim texture -- )
335 [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
336 [ reset-blend-mode ] tri
339 : texture-coords ( texture -- coords )
340 [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
342 image>> upside-down?>>
343 { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
344 { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
346 [ v* ] with map float-array{ } join ;
348 : make-texture-display-list ( texture -- dlist )
350 [ texture-dim ] keep draw-textured-rect
353 : <single-texture> ( image loc -- texture )
354 single-texture new-disposable
356 swap [ >>image ] [ dim>> >>dim ] bi
357 dup image>> dim>> product 0 = [
358 dup texture-coords >>texture-coords
359 dup image>> make-texture >>texture
360 dup make-texture-display-list >>display-list
363 M: single-texture dispose*
364 [ texture>> [ delete-texture ] when* ]
365 [ display-list>> [ delete-dlist ] when* ] bi ;
367 M: single-texture draw-scaled-texture
368 2dup dim>> = [ nip draw-texture ] [
369 dup texture>> [ draw-textured-rect ] [ 2drop ] if
372 TUPLE: multi-texture < disposable grid display-list loc ;
374 : image-locs ( image-grid -- loc-grid )
375 [ first [ image-dim first ] map ]
376 [ [ first image-dim second ] map ] bi
377 [ cum-sum0 ] bi@ cartesian-product flip ;
379 : <texture-grid> ( image-grid loc -- grid )
380 [ dup image-locs ] dip
381 '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
383 : grid-has-alpha? ( grid -- ? )
384 first first image>> has-alpha? ;
386 : make-textured-grid-display-list ( grid -- dlist )
389 [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
390 [ [ [ [ texture-dim ] keep (draw-textured-rect) ] each ] each ]
391 [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
392 GL_TEXTURE_2D 0 glBindTexture
396 : <multi-texture> ( image-grid loc -- multi-texture )
398 [ multi-texture new-disposable ] 2dip
399 [ nip >>loc ] [ <texture-grid> >>grid ] 2bi
400 dup grid>> make-textured-grid-display-list >>display-list
403 M: multi-texture draw-scaled-texture nip draw-texture ;
405 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
407 CONSTANT: max-texture-size { 512 512 }
411 : make-texture ( image -- id )
412 #! We use glTexSubImage2D to work around the power of 2 texture size
416 GL_TEXTURE_2D swap glBindTexture
417 non-power-of-2-textures? get
418 [ dup bitmap>> tex-image ]
419 [ [ f tex-image ] [ tex-sub-image ] bi ] if
423 : <texture> ( image loc -- texture )
424 over dim>> max-texture-size [ <= ] 2all?
426 [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
428 : get-texture-float ( target level enum -- value )
429 { float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline
431 : get-texture-int ( target level enum -- value )
432 { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline