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.float ui.gadgets.worlds variants ;
8 TUPLE: texture < gpu-object
9 { component-order component-order read-only initial: RGBA }
10 { component-type component-type read-only initial: ubyte-components } ;
12 TUPLE: texture-1d < texture ;
13 TUPLE: texture-2d < texture ;
14 TUPLE: texture-rectangle < texture ;
15 TUPLE: texture-3d < texture ;
16 TUPLE: texture-cube-map < texture ;
18 TUPLE: texture-1d-array < texture ;
19 TUPLE: texture-2d-array < texture ;
21 VARIANT: cube-map-axis
25 { texture texture-cube-map read-only }
26 { axis cube-map-axis read-only } ;
27 C: <cube-map-face> cube-map-face
29 UNION: texture-1d-data-target
31 UNION: texture-2d-data-target
32 texture-2d texture-rectangle texture-1d-array cube-map-face ;
33 UNION: texture-3d-data-target
34 texture-3d texture-2d-array ;
35 UNION: texture-data-target
36 texture-1d-data-target texture-2d-data-target texture-3d-data-target ;
39 [ [ delete-texture ] when* f ] change-handle drop ;
43 { component-order component-order read-only initial: RGBA }
44 { component-type component-type read-only initial: ubyte-components } ;
46 C: <texture-data> texture-data
47 UNION: ?texture-data texture-data POSTPONE: f ;
48 UNION: ?float-array float-array POSTPONE: f ;
51 clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
52 VARIANT: texture-filter
53 filter-nearest filter-linear ;
55 UNION: wrap-set texture-wrap sequence ;
56 UNION: ?texture-filter texture-filter POSTPONE: f ;
58 TUPLE: texture-parameters
59 { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
60 { min-filter texture-filter initial: filter-nearest }
61 { min-mipmap-filter ?texture-filter initial: filter-linear }
62 { mag-filter texture-filter initial: filter-linear }
63 { min-lod integer initial: -1000 }
64 { max-lod integer initial: 1000 }
65 { lod-bias integer initial: 0 }
66 { base-level integer initial: 0 }
67 { max-level integer initial: 1000 } ;
71 GENERIC: texture-object ( texture-data-target -- texture )
72 M: cube-map-face texture-object
74 M: texture texture-object
77 : gl-wrap ( wrap -- gl-wrap )
79 { clamp-texcoord-to-edge [ GL_CLAMP_TO_EDGE ] }
80 { clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
81 { repeat-texcoord [ GL_REPEAT ] }
82 { repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
85 : set-texture-gl-wrap ( target wraps -- )
86 dup sequence? [ 1array ] unless 3 over last pad-tail {
87 [ [ GL_TEXTURE_WRAP_S ] dip first gl-wrap glTexParameteri ]
88 [ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
89 [ [ GL_TEXTURE_WRAP_R ] dip third gl-wrap glTexParameteri ]
92 : gl-mag-filter ( filter -- gl-filter )
94 { filter-nearest [ GL_NEAREST ] }
95 { filter-linear [ GL_LINEAR ] }
98 : gl-min-filter ( filter mipmap-filter -- gl-filter )
100 { { filter-nearest f } [ GL_NEAREST ] }
101 { { filter-linear f } [ GL_LINEAR ] }
102 { { filter-nearest filter-nearest } [ GL_NEAREST_MIPMAP_NEAREST ] }
103 { { filter-linear filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST ] }
104 { { filter-linear filter-linear } [ GL_LINEAR_MIPMAP_LINEAR ] }
105 { { filter-nearest filter-linear } [ GL_NEAREST_MIPMAP_LINEAR ] }
108 GENERIC: texture-gl-target ( texture -- target )
109 GENERIC: texture-data-gl-target ( texture -- target )
111 M: texture-1d texture-gl-target drop GL_TEXTURE_1D ;
112 M: texture-2d texture-gl-target drop GL_TEXTURE_2D ;
113 M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ;
114 M: texture-3d texture-gl-target drop GL_TEXTURE_3D ;
115 M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ;
116 M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ;
117 M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ;
119 M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ;
120 M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ;
121 M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ;
122 M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ;
123 M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ;
124 M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ;
125 M: cube-map-face texture-data-gl-target
127 { -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
128 { -Y [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y ] }
129 { -Z [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z ] }
130 { +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
131 { +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
132 { +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
135 : texture-gl-internal-format ( texture -- internal-format )
136 [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
138 : texture-data-gl-args ( texture data -- format type ptr )
141 [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
144 [ component-order>> ] [ component-type>> ] bi image-data-format f
147 :: bind-tdt ( tdt -- texture )
148 tdt texture-object :> texture
149 texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
152 : get-texture-float ( target level enum -- value )
153 0 <float> [ glGetTexLevelParameterfv ] keep *float ;
154 : get-texture-int ( target level enum -- value )
155 0 <int> [ glGetTexLevelParameteriv ] keep *int ;
157 : ?product ( x -- y )
158 dup number? [ product ] unless ;
162 GENERIC# allocate-texture 3 ( tdt level dim data -- )
164 M:: texture-1d-data-target allocate-texture ( tdt level dim data -- )
165 tdt bind-tdt :> texture
166 tdt texture-data-gl-target level texture texture-gl-internal-format
167 dim 0 texture data texture-data-gl-args
168 pixel-unpack-buffer [ glTexImage1D ] with-gpu-data-ptr ;
170 M:: texture-2d-data-target allocate-texture ( tdt level dim data -- )
171 tdt bind-tdt :> texture
172 tdt texture-data-gl-target level texture texture-gl-internal-format
173 dim first2 0 texture data texture-data-gl-args
174 pixel-unpack-buffer [ glTexImage2D ] with-gpu-data-ptr ;
176 M:: texture-3d-data-target allocate-texture ( tdt level dim data -- )
177 tdt bind-tdt :> texture
178 tdt texture-data-gl-target level texture texture-gl-internal-format
179 dim first3 0 texture data texture-data-gl-args
180 pixel-unpack-buffer [ glTexImage3D ] with-gpu-data-ptr ;
182 GENERIC# update-texture 4 ( tdt level loc dim data -- )
184 M:: texture-1d-data-target update-texture ( tdt level loc dim data -- )
185 tdt bind-tdt :> texture
186 tdt texture-data-gl-target level
187 loc dim texture data texture-data-gl-args
188 pixel-unpack-buffer [ glTexSubImage1D ] with-gpu-data-ptr ;
190 M:: texture-2d-data-target update-texture ( tdt level loc dim data -- )
191 tdt bind-tdt :> texture
192 tdt texture-data-gl-target level
193 loc dim [ first2 ] bi@
194 texture data texture-data-gl-args
195 pixel-unpack-buffer [ glTexSubImage2D ] with-gpu-data-ptr ;
197 M:: texture-3d-data-target update-texture ( tdt level loc dim data -- )
198 tdt bind-tdt :> texture
199 tdt texture-data-gl-target level
200 loc dim [ first3 ] bi@
201 texture data texture-data-gl-args
202 pixel-unpack-buffer [ glTexSubImage3D ] with-gpu-data-ptr ;
204 : image>texture-data ( image -- dim texture-data )
205 { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
206 <texture-data> ; inline
208 GENERIC# texture-dim 1 ( tdt level -- dim )
210 M:: texture-1d-data-target texture-dim ( tdt level -- dim )
211 tdt bind-tdt :> texture
212 tdt texture-data-gl-target level GL_TEXTURE_WIDTH get-texture-int ;
214 M:: texture-2d-data-target texture-dim ( tdt level -- dim )
215 tdt bind-tdt :> texture
216 tdt texture-data-gl-target level
217 [ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
220 M:: texture-3d-data-target texture-dim ( tdt level -- dim )
221 tdt bind-tdt :> texture
222 tdt texture-data-gl-target level
223 [ GL_TEXTURE_WIDTH get-texture-int ]
224 [ GL_TEXTURE_HEIGHT get-texture-int ]
225 [ GL_TEXTURE_DEPTH get-texture-int ] 2tri
228 : texture-data-size ( tdt level -- size )
229 [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ;
231 :: read-texture-to ( tdt level gpu-data-ptr -- )
232 tdt bind-tdt :> texture
233 tdt texture-data-gl-target level
234 texture [ component-order>> ] [ component-type>> ] bi image-data-format
235 gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
237 : read-texture ( tdt level -- byte-array )
238 2dup texture-data-size <byte-array>
239 [ read-texture-to ] keep ;
241 : allocate-texture-image ( tdt level image -- )
242 image>texture-data allocate-texture ;
244 : update-texture-image ( tdt level loc image -- )
245 image>texture-data update-texture ;
247 : read-texture-image ( tdt level -- image )
249 [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
250 [ read-texture ] 2tri
254 : bind-texture ( texture -- gl-target )
255 [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ;
258 : generate-mipmaps ( texture -- )
259 bind-texture glGenerateMipmap ;
261 : set-texture-parameters ( texture parameters -- )
262 [ bind-texture ] dip {
263 [ wrap>> set-texture-gl-wrap ]
265 [ GL_TEXTURE_MIN_FILTER ] dip
266 [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
268 [ GL_TEXTURE_MAG_FILTER ] dip
269 mag-filter>> gl-mag-filter glTexParameteri
271 [ [ GL_TEXTURE_MIN_LOD ] dip min-lod>> glTexParameteri ]
272 [ [ GL_TEXTURE_MAX_LOD ] dip max-lod>> glTexParameteri ]
273 [ [ GL_TEXTURE_LOD_BIAS ] dip lod-bias>> glTexParameteri ]
274 [ [ GL_TEXTURE_BASE_LEVEL ] dip base-level>> glTexParameteri ]
275 [ [ GL_TEXTURE_MAX_LEVEL ] dip max-level>> glTexParameteri ]
280 : <texture> ( component-order component-type parameters class -- texture )
281 '[ [ gen-texture ] 2dip _ boa dup window-resource ] dip
282 [ T{ texture-parameters } clone ] unless* set-texture-parameters ; inline
286 : <texture-1d> ( component-order component-type parameters -- texture )
287 texture-1d <texture> ;
288 : <texture-2d> ( component-order component-type parameters -- texture )
289 texture-2d <texture> ;
290 : <texture-3d> ( component-order component-type parameters -- texture )
291 texture-3d <texture> ;
292 : <texture-cube-map> ( component-order component-type parameters -- texture )
293 texture-cube-map <texture> ;
294 : <texture-rectangle> ( component-order component-type parameters -- texture )
295 texture-rectangle <texture> ;
296 : <texture-1d-array> ( component-order component-type parameters -- texture )
297 texture-1d-array <texture> ;
298 : <texture-2d-array> ( component-order component-type parameters -- texture )
299 texture-2d-array <texture> ;