1 ! (c)2009 Joe Groff bsd license
2 USING: accessors alien.c-types arrays byte-arrays combinators
3 destructors fry gpu gpu.buffers images kernel locals math
4 opengl opengl.gl opengl.textures sequences
5 specialized-arrays typed ui.gadgets.worlds variants ;
6 FROM: alien.c-types => float ;
7 SPECIALIZED-ARRAY: float
10 TUPLE: texture < gpu-object
11 { component-order component-order read-only initial: RGBA }
12 { component-type component-type read-only initial: ubyte-components } ;
14 TUPLE: texture-1d < texture ;
15 TUPLE: texture-2d < texture ;
16 TUPLE: texture-rectangle < texture ;
17 TUPLE: texture-3d < texture ;
18 TUPLE: texture-cube-map < texture ;
20 TUPLE: texture-1d-array < texture ;
21 TUPLE: texture-2d-array < texture ;
23 VARIANT: cube-map-axis
27 { texture texture-cube-map read-only }
28 { axis cube-map-axis read-only } ;
29 C: <cube-map-face> cube-map-face
31 UNION: texture-1d-data-target
33 UNION: texture-2d-data-target
34 texture-2d texture-rectangle texture-1d-array cube-map-face ;
35 UNION: texture-3d-data-target
36 texture-3d texture-2d-array ;
37 UNION: texture-data-target
38 texture-1d-data-target texture-2d-data-target texture-3d-data-target ;
41 [ [ delete-texture ] when* f ] change-handle drop ;
45 { component-order component-order read-only initial: RGBA }
46 { component-type component-type read-only initial: ubyte-components } ;
48 C: <texture-data> texture-data
49 UNION: ?texture-data texture-data POSTPONE: f ;
50 UNION: ?float-array float-array POSTPONE: f ;
52 VARIANT: compressed-texture-format
53 DXT1-RGB DXT1-RGBA DXT3 DXT5
54 LATC1 LATC1-SIGNED LATC2 LATC2-SIGNED
55 RGTC1 RGTC1-SIGNED RGTC2 RGTC2-SIGNED ;
57 TUPLE: compressed-texture-data
59 { format compressed-texture-format read-only }
60 { length integer read-only } ;
62 C: <compressed-texture-data> compressed-texture-data
63 UNION: ?compressed-texture-data compressed-texture-data POSTPONE: f ;
66 clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
67 VARIANT: texture-filter
68 filter-nearest filter-linear ;
70 UNION: wrap-set texture-wrap sequence ;
71 UNION: ?texture-filter texture-filter POSTPONE: f ;
73 TUPLE: texture-parameters
74 { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
75 { min-filter texture-filter initial: filter-nearest }
76 { min-mipmap-filter ?texture-filter initial: filter-linear }
77 { mag-filter texture-filter initial: filter-linear }
78 { min-lod integer initial: -1000 }
79 { max-lod integer initial: 1000 }
80 { lod-bias integer initial: 0 }
81 { base-level integer initial: 0 }
82 { max-level integer initial: 1000 } ;
86 GENERIC: texture-object ( texture-data-target -- texture )
87 M: cube-map-face texture-object
89 M: texture texture-object
92 : gl-compressed-texture-format ( format -- gl-format )
94 { DXT1-RGB [ GL_COMPRESSED_RGB_S3TC_DXT1_EXT ] }
95 { DXT1-RGBA [ GL_COMPRESSED_RGBA_S3TC_DXT1_EXT ] }
96 { DXT3 [ GL_COMPRESSED_RGBA_S3TC_DXT3_EXT ] }
97 { DXT5 [ GL_COMPRESSED_RGBA_S3TC_DXT5_EXT ] }
98 { RGTC1 [ GL_COMPRESSED_RED_RGTC1 ] }
99 { RGTC1-SIGNED [ GL_COMPRESSED_SIGNED_RED_RGTC1 ] }
100 { RGTC2 [ GL_COMPRESSED_RG_RGTC2 ] }
101 { RGTC2-SIGNED [ GL_COMPRESSED_SIGNED_RG_RGTC2 ] }
104 : gl-wrap ( wrap -- gl-wrap )
106 { clamp-texcoord-to-edge [ GL_CLAMP_TO_EDGE ] }
107 { clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
108 { repeat-texcoord [ GL_REPEAT ] }
109 { repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
112 : set-texture-gl-wrap ( target wraps -- )
113 dup sequence? [ 1array ] unless 3 over last pad-tail {
114 [ [ GL_TEXTURE_WRAP_S ] dip first gl-wrap glTexParameteri ]
115 [ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
116 [ [ GL_TEXTURE_WRAP_R ] dip third gl-wrap glTexParameteri ]
119 : gl-mag-filter ( filter -- gl-filter )
121 { filter-nearest [ GL_NEAREST ] }
122 { filter-linear [ GL_LINEAR ] }
125 : gl-min-filter ( filter mipmap-filter -- gl-filter )
127 { { filter-nearest f } [ GL_NEAREST ] }
128 { { filter-linear f } [ GL_LINEAR ] }
129 { { filter-nearest filter-nearest } [ GL_NEAREST_MIPMAP_NEAREST ] }
130 { { filter-linear filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST ] }
131 { { filter-linear filter-linear } [ GL_LINEAR_MIPMAP_LINEAR ] }
132 { { filter-nearest filter-linear } [ GL_NEAREST_MIPMAP_LINEAR ] }
135 GENERIC: texture-gl-target ( texture -- target )
136 GENERIC: texture-data-gl-target ( texture -- target )
138 M: texture-1d texture-gl-target drop GL_TEXTURE_1D ; inline
139 M: texture-2d texture-gl-target drop GL_TEXTURE_2D ; inline
140 M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ; inline
141 M: texture-3d texture-gl-target drop GL_TEXTURE_3D ; inline
142 M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ; inline
143 M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ; inline
144 M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ; inline
146 M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ; inline
147 M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ; inline
148 M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ; inline
149 M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ; inline
150 M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ; inline
151 M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ; inline
152 M: cube-map-face texture-data-gl-target
154 { -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
155 { -Y [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y ] }
156 { -Z [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z ] }
157 { +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
158 { +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
159 { +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
162 : texture-gl-internal-format ( texture -- internal-format )
163 [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
165 : texture-data-gl-args ( texture data -- format type ptr )
168 [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
171 [ component-order>> ] [ component-type>> ] bi image-data-format f
174 :: bind-tdt ( tdt -- texture )
175 tdt texture-object :> texture
176 texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
179 : get-texture-float ( target level enum -- value )
180 0 <float> [ glGetTexLevelParameterfv ] keep *float ; inline
181 : get-texture-int ( target level enum -- value )
182 0 <int> [ glGetTexLevelParameteriv ] keep *int ; inline
184 : ?product ( x -- y )
185 dup number? [ product ] unless ; inline
187 :: (allocate-texture) ( tdt level dim data dim-quot teximage-quot -- )
188 tdt bind-tdt :> texture
189 tdt texture-data-gl-target level texture texture-gl-internal-format
190 dim dim-quot call 0 texture data texture-data-gl-args
191 pixel-unpack-buffer teximage-quot with-gpu-data-ptr ; inline
193 :: (allocate-compressed-texture) ( tdt level dim compressed-data dim-quot teximage-quot -- )
194 tdt bind-tdt :> texture
195 tdt texture-data-gl-target level compressed-data format>> gl-compressed-texture-format
196 dim dim-quot call 0 compressed-data [ length>> ] [ ptr>> ] bi
197 pixel-unpack-buffer teximage-quot with-gpu-data-ptr ; inline
199 :: (update-texture) ( tdt level loc dim data dim-quot texsubimage-quot -- )
200 tdt bind-tdt :> texture
201 tdt texture-data-gl-target level
203 texture data texture-data-gl-args
204 pixel-unpack-buffer texsubimage-quot with-gpu-data-ptr ; inline
206 :: (update-compressed-texture) ( tdt level loc dim compressed-data dim-quot texsubimage-quot -- )
207 tdt bind-tdt :> texture
208 tdt texture-data-gl-target level
210 compressed-data [ format>> gl-compressed-texture-format ] [ length>> ] [ ptr>> ] tri
211 pixel-unpack-buffer texsubimage-quot with-gpu-data-ptr ; inline
215 GENERIC# allocate-texture 3 ( tdt level dim data -- )
217 M: texture-1d-data-target allocate-texture ( tdt level dim data -- )
218 [ ] [ glTexImage1D ] (allocate-texture) ;
220 M: texture-2d-data-target allocate-texture ( tdt level dim data -- )
221 [ first2 ] [ glTexImage2D ] (allocate-texture) ;
223 M: texture-3d-data-target allocate-texture ( tdt level dim data -- )
224 [ first3 ] [ glTexImage3D ] (allocate-texture) ;
226 GENERIC# allocate-compressed-texture 3 ( tdt level dim compressed-data -- )
228 M: texture-1d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
229 [ ] [ glCompressedTexImage1D ] (allocate-compressed-texture) ;
231 M: texture-2d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
232 [ first2 ] [ glCompressedTexImage2D ] (allocate-compressed-texture) ;
234 M: texture-3d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
235 [ first3 ] [ glCompressedTexImage3D ] (allocate-compressed-texture) ;
237 GENERIC# update-texture 4 ( tdt level loc dim data -- )
239 M: texture-1d-data-target update-texture ( tdt level loc dim data -- )
240 [ ] [ glTexSubImage1D ] (update-texture) ;
242 M: texture-2d-data-target update-texture ( tdt level loc dim data -- )
243 [ first2 ] [ glTexSubImage2D ] (update-texture) ;
245 M: texture-3d-data-target update-texture ( tdt level loc dim data -- )
246 [ first3 ] [ glTexSubImage3D ] (update-texture) ;
248 GENERIC# update-compressed-texture 4 ( tdt level loc dim compressed-data -- )
250 M: texture-1d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
251 [ ] [ glCompressedTexSubImage1D ] (update-compressed-texture) ;
253 M: texture-2d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
254 [ first2 ] [ glCompressedTexSubImage2D ] (update-compressed-texture) ;
256 M: texture-3d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
257 [ first3 ] [ glCompressedTexSubImage3D ] (update-compressed-texture) ;
259 : image>texture-data ( image -- dim texture-data )
260 { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
261 <texture-data> ; inline
263 GENERIC# texture-dim 1 ( tdt level -- dim )
265 M:: texture-1d-data-target texture-dim ( tdt level -- dim )
266 tdt bind-tdt :> texture
267 tdt texture-data-gl-target level GL_TEXTURE_WIDTH get-texture-int ; inline
269 M:: texture-2d-data-target texture-dim ( tdt level -- dim )
270 tdt bind-tdt :> texture
271 tdt texture-data-gl-target level
272 [ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
275 M:: texture-3d-data-target texture-dim ( tdt level -- dim )
276 tdt bind-tdt :> texture
277 tdt texture-data-gl-target level
278 [ GL_TEXTURE_WIDTH get-texture-int ]
279 [ GL_TEXTURE_HEIGHT get-texture-int ]
280 [ GL_TEXTURE_DEPTH get-texture-int ] 2tri
283 : compressed-texture-data-size ( tdt level -- size )
284 [ [ bind-tdt drop ] [ texture-data-gl-target ] bi ] dip
285 GL_TEXTURE_COMPRESSED_IMAGE_SIZE get-texture-int ; inline
287 : texture-data-size ( tdt level -- size )
288 [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ; inline
290 TYPED:: read-texture-to ( tdt: texture-data-target level: integer gpu-data-ptr -- )
291 tdt bind-tdt :> texture
292 tdt texture-data-gl-target level
293 texture [ component-order>> ] [ component-type>> ] bi image-data-format
294 gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
296 TYPED: read-texture ( tdt: texture-data-target level: integer -- byte-array: byte-array )
297 2dup texture-data-size (byte-array)
298 [ read-texture-to ] keep ;
300 TYPED:: read-compressed-texture-to ( tdt: texture-data-target level: integer gpu-data-ptr -- )
301 tdt bind-tdt :> texture
302 tdt texture-data-gl-target level
303 gpu-data-ptr pixel-pack-buffer [ glGetCompressedTexImage ] with-gpu-data-ptr ;
305 TYPED: read-compressed-texture ( tdt: texture-data-target level: integer -- byte-array: byte-array )
306 2dup compressed-texture-data-size (byte-array)
307 [ read-compressed-texture-to ] keep ;
309 : allocate-texture-image ( tdt level image -- )
310 image>texture-data allocate-texture ; inline
312 : update-texture-image ( tdt level loc image -- )
313 image>texture-data update-texture ; inline
315 : read-texture-image ( tdt level -- image )
317 [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
318 [ read-texture ] 2tri
322 : bind-texture ( texture -- gl-target )
323 [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ; inline
326 : generate-mipmaps ( texture -- )
327 bind-texture glGenerateMipmap ; inline
329 TYPED: set-texture-parameters ( texture: texture parameters: texture-parameters -- )
330 [ bind-texture ] dip {
331 [ wrap>> set-texture-gl-wrap ]
333 [ GL_TEXTURE_MIN_FILTER ] dip
334 [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
336 [ GL_TEXTURE_MAG_FILTER ] dip
337 mag-filter>> gl-mag-filter glTexParameteri
339 [ [ GL_TEXTURE_MIN_LOD ] dip min-lod>> glTexParameteri ]
340 [ [ GL_TEXTURE_MAX_LOD ] dip max-lod>> glTexParameteri ]
341 [ [ GL_TEXTURE_LOD_BIAS ] dip lod-bias>> glTexParameteri ]
342 [ [ GL_TEXTURE_BASE_LEVEL ] dip base-level>> glTexParameteri ]
343 [ [ GL_TEXTURE_MAX_LEVEL ] dip max-level>> glTexParameteri ]
348 : <texture> ( component-order component-type parameters class -- texture )
349 '[ [ gen-texture ] 2dip _ boa dup window-resource ] dip
350 [ T{ texture-parameters } clone ] unless* set-texture-parameters ; inline
354 : <texture-1d> ( component-order component-type parameters -- texture )
355 texture-1d <texture> ; inline
356 : <texture-2d> ( component-order component-type parameters -- texture )
357 texture-2d <texture> ; inline
358 : <texture-3d> ( component-order component-type parameters -- texture )
359 texture-3d <texture> ; inline
360 : <texture-cube-map> ( component-order component-type parameters -- texture )
361 texture-cube-map <texture> ; inline
362 : <texture-rectangle> ( component-order component-type parameters -- texture )
363 texture-rectangle <texture> ; inline
364 : <texture-1d-array> ( component-order component-type parameters -- texture )
365 texture-1d-array <texture> ; inline
366 : <texture-2d-array> ( component-order component-type parameters -- texture )
367 texture-2d-array <texture> ; inline