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 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 ;
53 clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
54 VARIANT: texture-filter
55 filter-nearest filter-linear ;
57 UNION: wrap-set texture-wrap sequence ;
58 UNION: ?texture-filter texture-filter POSTPONE: f ;
60 TUPLE: texture-parameters
61 { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
62 { min-filter texture-filter initial: filter-nearest }
63 { min-mipmap-filter ?texture-filter initial: filter-linear }
64 { mag-filter texture-filter initial: filter-linear }
65 { min-lod integer initial: -1000 }
66 { max-lod integer initial: 1000 }
67 { lod-bias integer initial: 0 }
68 { base-level integer initial: 0 }
69 { max-level integer initial: 1000 } ;
73 GENERIC: texture-object ( texture-data-target -- texture )
74 M: cube-map-face texture-object
76 M: texture texture-object
79 : gl-wrap ( wrap -- gl-wrap )
81 { clamp-texcoord-to-edge [ GL_CLAMP_TO_EDGE ] }
82 { clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
83 { repeat-texcoord [ GL_REPEAT ] }
84 { repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
87 : set-texture-gl-wrap ( target wraps -- )
88 dup sequence? [ 1array ] unless 3 over last pad-tail {
89 [ [ GL_TEXTURE_WRAP_S ] dip first gl-wrap glTexParameteri ]
90 [ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
91 [ [ GL_TEXTURE_WRAP_R ] dip third gl-wrap glTexParameteri ]
94 : gl-mag-filter ( filter -- gl-filter )
96 { filter-nearest [ GL_NEAREST ] }
97 { filter-linear [ GL_LINEAR ] }
100 : gl-min-filter ( filter mipmap-filter -- gl-filter )
102 { { filter-nearest f } [ GL_NEAREST ] }
103 { { filter-linear f } [ GL_LINEAR ] }
104 { { filter-nearest filter-nearest } [ GL_NEAREST_MIPMAP_NEAREST ] }
105 { { filter-linear filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST ] }
106 { { filter-linear filter-linear } [ GL_LINEAR_MIPMAP_LINEAR ] }
107 { { filter-nearest filter-linear } [ GL_NEAREST_MIPMAP_LINEAR ] }
110 GENERIC: texture-gl-target ( texture -- target )
111 GENERIC: texture-data-gl-target ( texture -- target )
113 M: texture-1d texture-gl-target drop GL_TEXTURE_1D ;
114 M: texture-2d texture-gl-target drop GL_TEXTURE_2D ;
115 M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ;
116 M: texture-3d texture-gl-target drop GL_TEXTURE_3D ;
117 M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ;
118 M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ;
119 M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ;
121 M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ;
122 M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ;
123 M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ;
124 M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ;
125 M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ;
126 M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ;
127 M: cube-map-face texture-data-gl-target
129 { -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
130 { -Y [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y ] }
131 { -Z [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z ] }
132 { +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
133 { +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
134 { +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
137 : texture-gl-internal-format ( texture -- internal-format )
138 [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
140 : texture-data-gl-args ( texture data -- format type ptr )
143 [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
146 [ component-order>> ] [ component-type>> ] bi image-data-format f
149 :: bind-tdt ( tdt -- texture )
150 tdt texture-object :> texture
151 texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
154 : get-texture-float ( target level enum -- value )
155 0 <float> [ glGetTexLevelParameterfv ] keep *float ;
156 : get-texture-int ( target level enum -- value )
157 0 <int> [ glGetTexLevelParameteriv ] keep *int ;
159 : ?product ( x -- y )
160 dup number? [ product ] unless ;
164 GENERIC# allocate-texture 3 ( tdt level dim data -- )
166 M:: texture-1d-data-target allocate-texture ( tdt level dim data -- )
167 tdt bind-tdt :> texture
168 tdt texture-data-gl-target level texture texture-gl-internal-format
169 dim 0 texture data texture-data-gl-args
170 pixel-unpack-buffer [ glTexImage1D ] with-gpu-data-ptr ;
172 M:: texture-2d-data-target allocate-texture ( tdt level dim data -- )
173 tdt bind-tdt :> texture
174 tdt texture-data-gl-target level texture texture-gl-internal-format
175 dim first2 0 texture data texture-data-gl-args
176 pixel-unpack-buffer [ glTexImage2D ] with-gpu-data-ptr ;
178 M:: texture-3d-data-target allocate-texture ( tdt level dim data -- )
179 tdt bind-tdt :> texture
180 tdt texture-data-gl-target level texture texture-gl-internal-format
181 dim first3 0 texture data texture-data-gl-args
182 pixel-unpack-buffer [ glTexImage3D ] with-gpu-data-ptr ;
184 GENERIC# update-texture 4 ( tdt level loc dim data -- )
186 M:: texture-1d-data-target update-texture ( tdt level loc dim data -- )
187 tdt bind-tdt :> texture
188 tdt texture-data-gl-target level
189 loc dim texture data texture-data-gl-args
190 pixel-unpack-buffer [ glTexSubImage1D ] with-gpu-data-ptr ;
192 M:: texture-2d-data-target update-texture ( tdt level loc dim data -- )
193 tdt bind-tdt :> texture
194 tdt texture-data-gl-target level
195 loc dim [ first2 ] bi@
196 texture data texture-data-gl-args
197 pixel-unpack-buffer [ glTexSubImage2D ] with-gpu-data-ptr ;
199 M:: texture-3d-data-target update-texture ( tdt level loc dim data -- )
200 tdt bind-tdt :> texture
201 tdt texture-data-gl-target level
202 loc dim [ first3 ] bi@
203 texture data texture-data-gl-args
204 pixel-unpack-buffer [ glTexSubImage3D ] with-gpu-data-ptr ;
206 : image>texture-data ( image -- dim texture-data )
207 { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
208 <texture-data> ; inline
210 GENERIC# texture-dim 1 ( tdt level -- dim )
212 M:: texture-1d-data-target texture-dim ( tdt level -- dim )
213 tdt bind-tdt :> texture
214 tdt texture-data-gl-target level GL_TEXTURE_WIDTH get-texture-int ;
216 M:: texture-2d-data-target texture-dim ( tdt level -- dim )
217 tdt bind-tdt :> texture
218 tdt texture-data-gl-target level
219 [ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
222 M:: texture-3d-data-target texture-dim ( tdt level -- dim )
223 tdt bind-tdt :> texture
224 tdt texture-data-gl-target level
225 [ GL_TEXTURE_WIDTH get-texture-int ]
226 [ GL_TEXTURE_HEIGHT get-texture-int ]
227 [ GL_TEXTURE_DEPTH get-texture-int ] 2tri
230 : texture-data-size ( tdt level -- size )
231 [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ;
233 :: read-texture-to ( tdt level gpu-data-ptr -- )
234 tdt bind-tdt :> texture
235 tdt texture-data-gl-target level
236 texture [ component-order>> ] [ component-type>> ] bi image-data-format
237 gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
239 : read-texture ( tdt level -- byte-array )
240 2dup texture-data-size <byte-array>
241 [ read-texture-to ] keep ;
243 : allocate-texture-image ( tdt level image -- )
244 image>texture-data allocate-texture ;
246 : update-texture-image ( tdt level loc image -- )
247 image>texture-data update-texture ;
249 : read-texture-image ( tdt level -- image )
251 [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
252 [ read-texture ] 2tri
256 : bind-texture ( texture -- gl-target )
257 [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ;
260 : generate-mipmaps ( texture -- )
261 bind-texture glGenerateMipmap ;
263 : set-texture-parameters ( texture parameters -- )
264 [ bind-texture ] dip {
265 [ wrap>> set-texture-gl-wrap ]
267 [ GL_TEXTURE_MIN_FILTER ] dip
268 [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
270 [ GL_TEXTURE_MAG_FILTER ] dip
271 mag-filter>> gl-mag-filter glTexParameteri
273 [ [ GL_TEXTURE_MIN_LOD ] dip min-lod>> glTexParameteri ]
274 [ [ GL_TEXTURE_MAX_LOD ] dip max-lod>> glTexParameteri ]
275 [ [ GL_TEXTURE_LOD_BIAS ] dip lod-bias>> glTexParameteri ]
276 [ [ GL_TEXTURE_BASE_LEVEL ] dip base-level>> glTexParameteri ]
277 [ [ GL_TEXTURE_MAX_LEVEL ] dip max-level>> glTexParameteri ]
282 : <texture> ( component-order component-type parameters class -- texture )
283 '[ [ gen-texture ] 2dip _ boa dup window-resource ] dip
284 [ T{ texture-parameters } clone ] unless* set-texture-parameters ; inline
288 : <texture-1d> ( component-order component-type parameters -- texture )
289 texture-1d <texture> ;
290 : <texture-2d> ( component-order component-type parameters -- texture )
291 texture-2d <texture> ;
292 : <texture-3d> ( component-order component-type parameters -- texture )
293 texture-3d <texture> ;
294 : <texture-cube-map> ( component-order component-type parameters -- texture )
295 texture-cube-map <texture> ;
296 : <texture-rectangle> ( component-order component-type parameters -- texture )
297 texture-rectangle <texture> ;
298 : <texture-1d-array> ( component-order component-type parameters -- texture )
299 texture-1d-array <texture> ;
300 : <texture-2d-array> ( component-order component-type parameters -- texture )
301 texture-2d-array <texture> ;