extra/gpu/textures/textures.factor

   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
   8 IN: gpu.textures
   9
  10 TUPLE: texture < gpu-object
  11     { component-order component-order read-only initial: RGBA }
  12     { component-type component-type read-only initial: ubyte-components } ;
  13
  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 ;
  19
  20 TUPLE: texture-1d-array < texture ;
  21 TUPLE: texture-2d-array < texture ;
  22
  23 VARIANT: cube-map-axis
  24     -X -Y -Z +X +Y +Z ;
  25
  26 TUPLE: cube-map-face
  27     { texture texture-cube-map read-only }
  28     { axis cube-map-axis read-only } ;
  29 C: <cube-map-face> cube-map-face
  30
  31 UNION: texture-1d-data-target
  32     texture-1d ;
  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 ;
  39
  40 M: texture dispose
  41     [ [ delete-texture ] when* f ] change-handle drop ;
  42
  43 TUPLE: texture-data
  44     { ptr read-only }
  45     { component-order component-order read-only initial: RGBA }
  46     { component-type component-type read-only initial: ubyte-components } ;
  47
  48 C: <texture-data> texture-data
  49 UNION: ?texture-data texture-data POSTPONE: f ;
  50 UNION: ?float-array float-array POSTPONE: f ;
  51
  52 VARIANT: compressed-texture-format
  53     DXT1-RGB DXT1-RGBA DXT3 DXT5
  54     RGTC1 RGTC1-SIGNED RGTC2 RGTC2-SIGNED ;
  55
  56 TUPLE: compressed-texture-data
  57     { ptr read-only }
  58     { format compressed-texture-format read-only }
  59     { length integer read-only } ;
  60
  61 C: <compressed-texture-data> compressed-texture-data
  62 UNION: ?compressed-texture-data compressed-texture-data POSTPONE: f ;
  63
  64 VARIANT: texture-wrap
  65     clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
  66 VARIANT: texture-filter
  67     filter-nearest filter-linear ;
  68
  69 UNION: wrap-set texture-wrap sequence ;
  70 UNION: ?texture-filter texture-filter POSTPONE: f ;
  71
  72 TUPLE: texture-parameters
  73     { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
  74     { min-filter texture-filter initial: filter-nearest }
  75     { min-mipmap-filter ?texture-filter initial: filter-linear }
  76     { mag-filter texture-filter initial: filter-linear }
  77     { min-lod integer initial: -1000 }
  78     { max-lod integer initial:  1000 }
  79     { lod-bias integer initial: 0 }
  80     { base-level integer initial: 0 }
  81     { max-level integer initial: 1000 } ;
  82
  83 <PRIVATE
  84
  85 GENERIC: texture-object ( texture-data-target -- texture )
  86 M: cube-map-face texture-object
  87     texture>> ; inline
  88 M: texture texture-object
  89     ; inline
  90
  91 : gl-compressed-texture-format ( format -- gl-format )
  92     {
  93         { DXT1-RGB     [ GL_COMPRESSED_RGB_S3TC_DXT1_EXT  ] }
  94         { DXT1-RGBA    [ GL_COMPRESSED_RGBA_S3TC_DXT1_EXT ] }
  95         { DXT3         [ GL_COMPRESSED_RGBA_S3TC_DXT3_EXT ] }
  96         { DXT5         [ GL_COMPRESSED_RGBA_S3TC_DXT5_EXT ] }
  97         { RGTC1        [ GL_COMPRESSED_RED_RGTC1          ] }
  98         { RGTC1-SIGNED [ GL_COMPRESSED_SIGNED_RED_RGTC1   ] }
  99         { RGTC2        [ GL_COMPRESSED_RG_RGTC2           ] }
 100         { RGTC2-SIGNED [ GL_COMPRESSED_SIGNED_RG_RGTC2    ] }
 101     } case ; inline
 102
 103 : gl-wrap ( wrap -- gl-wrap )
 104     {
 105         { clamp-texcoord-to-edge [ GL_CLAMP_TO_EDGE ] }
 106         { clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
 107         { repeat-texcoord [ GL_REPEAT ] }
 108         { repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
 109     } case ; inline
 110
 111 : set-texture-gl-wrap ( target wraps -- )
 112     dup sequence? [ 1array ] unless 3 over last pad-tail {
 113         [ [ GL_TEXTURE_WRAP_S ] dip first  gl-wrap glTexParameteri ]
 114         [ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
 115         [ [ GL_TEXTURE_WRAP_R ] dip third  gl-wrap glTexParameteri ]
 116     } 2cleave ; inline
 117
 118 : gl-mag-filter ( filter -- gl-filter )
 119     {
 120         { filter-nearest [ GL_NEAREST ] }
 121         { filter-linear [ GL_LINEAR ] }
 122     } case ; inline
 123
 124 : gl-min-filter ( filter mipmap-filter -- gl-filter )
 125     2array {
 126         { { filter-nearest f              } [ GL_NEAREST                ] }
 127         { { filter-linear  f              } [ GL_LINEAR                 ] }
 128         { { filter-nearest filter-nearest } [ GL_NEAREST_MIPMAP_NEAREST ] }
 129         { { filter-linear  filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST  ] }
 130         { { filter-linear  filter-linear  } [ GL_LINEAR_MIPMAP_LINEAR   ] }
 131         { { filter-nearest filter-linear  } [ GL_NEAREST_MIPMAP_LINEAR  ] }
 132     } case ; inline
 133
 134 GENERIC: texture-gl-target ( texture -- target )
 135 GENERIC: texture-data-gl-target ( texture -- target )
 136
 137 M: texture-1d        texture-gl-target drop GL_TEXTURE_1D ; inline
 138 M: texture-2d        texture-gl-target drop GL_TEXTURE_2D ; inline
 139 M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ; inline
 140 M: texture-3d        texture-gl-target drop GL_TEXTURE_3D ; inline
 141 M: texture-cube-map  texture-gl-target drop GL_TEXTURE_CUBE_MAP ; inline
 142 M: texture-1d-array  texture-gl-target drop GL_TEXTURE_1D_ARRAY ; inline
 143 M: texture-2d-array  texture-gl-target drop GL_TEXTURE_2D_ARRAY ; inline
 144
 145 M: texture-1d        texture-data-gl-target drop GL_TEXTURE_1D ; inline
 146 M: texture-2d        texture-data-gl-target drop GL_TEXTURE_2D ; inline
 147 M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ; inline
 148 M: texture-3d        texture-data-gl-target drop GL_TEXTURE_3D ; inline
 149 M: texture-1d-array  texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ; inline
 150 M: texture-2d-array  texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ; inline
 151 M: cube-map-face     texture-data-gl-target
 152     axis>> {
 153         { -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
 154         { -Y [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y ] }
 155         { -Z [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z ] }
 156         { +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
 157         { +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
 158         { +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
 159     } case ; inline
 160
 161 : texture-gl-internal-format ( texture -- internal-format )
 162     [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
 163
 164 : texture-data-gl-args ( texture data -- format type ptr )
 165     [
 166         nip
 167         [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
 168         [ ptr>> ] bi
 169     ] [
 170         [ component-order>> ] [ component-type>> ] bi image-data-format f
 171     ] if* ; inline
 172
 173 :: bind-tdt ( tdt -- texture )
 174     tdt texture-object :> texture
 175     texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
 176     texture ; inline
 177
 178 : get-texture-float ( target level enum -- value )
 179     0 <float> [ glGetTexLevelParameterfv ] keep *float ; inline
 180 : get-texture-int ( target level enum -- value )
 181     0 <int> [ glGetTexLevelParameteriv ] keep *int ; inline
 182
 183 : ?product ( x -- y )
 184     dup number? [ product ] unless ; inline
 185
 186 :: (allocate-texture) ( tdt level dim data dim-quot teximage-quot -- )
 187     tdt bind-tdt :> texture
 188     tdt texture-data-gl-target level texture texture-gl-internal-format
 189     dim dim-quot call 0 texture data texture-data-gl-args
 190     pixel-unpack-buffer teximage-quot with-gpu-data-ptr ; inline
 191
 192 :: (allocate-compressed-texture) ( tdt level dim compressed-data dim-quot teximage-quot -- )
 193     tdt bind-tdt :> texture
 194     tdt texture-data-gl-target level compressed-data format>> gl-compressed-texture-format
 195     dim dim-quot call 0 compressed-data [ length>> ] [ ptr>> ] bi
 196     pixel-unpack-buffer teximage-quot with-gpu-data-ptr ; inline
 197
 198 :: (update-texture) ( tdt level loc dim data dim-quot texsubimage-quot -- )
 199     tdt bind-tdt :> texture
 200     tdt texture-data-gl-target level
 201     loc dim dim-quot bi@
 202     texture data texture-data-gl-args
 203     pixel-unpack-buffer texsubimage-quot with-gpu-data-ptr ; inline
 204
 205 :: (update-compressed-texture) ( tdt level loc dim compressed-data dim-quot texsubimage-quot -- )
 206     tdt bind-tdt :> texture
 207     tdt texture-data-gl-target level
 208     loc dim dim-quot bi@
 209     compressed-data [ format>> gl-compressed-texture-format ] [ length>> ] [ ptr>> ] tri
 210     pixel-unpack-buffer texsubimage-quot with-gpu-data-ptr ; inline
 211
 212 PRIVATE>
 213
 214 GENERIC# allocate-texture 3 ( tdt level dim data -- )
 215
 216 M: texture-1d-data-target allocate-texture ( tdt level dim data -- )
 217     [ ] [ glTexImage1D ] (allocate-texture) ;
 218
 219 M: texture-2d-data-target allocate-texture ( tdt level dim data -- )
 220     [ first2 ] [ glTexImage2D ] (allocate-texture) ;
 221
 222 M: texture-3d-data-target allocate-texture ( tdt level dim data -- )
 223     [ first3 ] [ glTexImage3D ] (allocate-texture) ;
 224
 225 GENERIC# allocate-compressed-texture 3 ( tdt level dim compressed-data -- )
 226
 227 M: texture-1d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
 228     [ ] [ glCompressedTexImage1D ] (allocate-compressed-texture) ;
 229
 230 M: texture-2d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
 231     [ first2 ] [ glCompressedTexImage2D ] (allocate-compressed-texture) ;
 232
 233 M: texture-3d-data-target allocate-compressed-texture ( tdt level dim compressed-data -- )
 234     [ first3 ] [ glCompressedTexImage3D ] (allocate-compressed-texture) ;
 235
 236 GENERIC# update-texture 4 ( tdt level loc dim data -- )
 237
 238 M: texture-1d-data-target update-texture ( tdt level loc dim data -- )
 239     [ ] [ glTexSubImage1D ] (update-texture) ;
 240
 241 M: texture-2d-data-target update-texture ( tdt level loc dim data -- )
 242     [ first2 ] [ glTexSubImage2D ] (update-texture) ;
 243
 244 M: texture-3d-data-target update-texture ( tdt level loc dim data -- )
 245     [ first3 ] [ glTexSubImage3D ] (update-texture) ;
 246
 247 GENERIC# update-compressed-texture 4 ( tdt level loc dim compressed-data -- )
 248
 249 M: texture-1d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
 250     [ ] [ glCompressedTexSubImage1D ] (update-compressed-texture) ;
 251
 252 M: texture-2d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
 253     [ first2 ] [ glCompressedTexSubImage2D ] (update-compressed-texture) ;
 254
 255 M: texture-3d-data-target update-compressed-texture ( tdt level loc dim compressed-data -- )
 256     [ first3 ] [ glCompressedTexSubImage3D ] (update-compressed-texture) ;
 257
 258 : image>texture-data ( image -- dim texture-data )
 259     { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
 260     <texture-data> ; inline
 261
 262 GENERIC# texture-dim 1 ( tdt level -- dim )
 263
 264 M:: texture-1d-data-target texture-dim ( tdt level -- dim )
 265     tdt bind-tdt :> texture
 266     tdt texture-data-gl-target level GL_TEXTURE_WIDTH get-texture-int ; inline
 267
 268 M:: texture-2d-data-target texture-dim ( tdt level -- dim )
 269     tdt bind-tdt :> texture
 270     tdt texture-data-gl-target level
 271     [ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
 272     2array ; inline
 273
 274 M:: texture-3d-data-target texture-dim ( tdt level -- dim )
 275     tdt bind-tdt :> texture
 276     tdt texture-data-gl-target level
 277     [ GL_TEXTURE_WIDTH get-texture-int ]
 278     [ GL_TEXTURE_HEIGHT get-texture-int ]
 279     [ GL_TEXTURE_DEPTH get-texture-int ] 2tri
 280     3array ; inline
 281
 282 : compressed-texture-data-size ( tdt level -- size )
 283     [ [ bind-tdt drop ] [ texture-data-gl-target ] bi ] dip
 284     GL_TEXTURE_COMPRESSED_IMAGE_SIZE get-texture-int ; inline
 285
 286 : texture-data-size ( tdt level -- size )
 287     [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ; inline
 288
 289 TYPED:: read-texture-to ( tdt: texture-data-target level: integer gpu-data-ptr -- )
 290     tdt bind-tdt :> texture
 291     tdt texture-data-gl-target level
 292     texture [ component-order>> ] [ component-type>> ] bi image-data-format
 293     gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
 294
 295 TYPED: read-texture ( tdt: texture-data-target level: integer -- byte-array: byte-array )
 296     2dup texture-data-size (byte-array)
 297     [ read-texture-to ] keep ;
 298
 299 TYPED:: read-compressed-texture-to ( tdt: texture-data-target level: integer gpu-data-ptr -- )
 300     tdt bind-tdt :> texture
 301     tdt texture-data-gl-target level
 302     gpu-data-ptr pixel-pack-buffer [ glGetCompressedTexImage ] with-gpu-data-ptr ;
 303
 304 TYPED: read-compressed-texture ( tdt: texture-data-target level: integer -- byte-array: byte-array )
 305     2dup compressed-texture-data-size (byte-array)
 306     [ read-compressed-texture-to ] keep ;
 307
 308 : allocate-texture-image ( tdt level image -- )
 309     image>texture-data allocate-texture ; inline
 310
 311 : update-texture-image ( tdt level loc image -- )
 312     image>texture-data update-texture ; inline
 313
 314 : read-texture-image ( tdt level -- image )
 315     [ texture-dim ]
 316     [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
 317     [ read-texture ] 2tri
 318     image boa ; inline
 319
 320 <PRIVATE
 321 : bind-texture ( texture -- gl-target )
 322     [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ; inline
 323 PRIVATE>
 324
 325 : generate-mipmaps ( texture -- )
 326     bind-texture glGenerateMipmap ; inline
 327
 328 TYPED: set-texture-parameters ( texture: texture parameters: texture-parameters -- )
 329     [ bind-texture ] dip {
 330         [ wrap>> set-texture-gl-wrap ]
 331         [
 332             [ GL_TEXTURE_MIN_FILTER ] dip
 333             [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
 334         ] [
 335             [ GL_TEXTURE_MAG_FILTER ] dip
 336             mag-filter>> gl-mag-filter glTexParameteri
 337         ]
 338         [ [ GL_TEXTURE_MIN_LOD ] dip min-lod>> glTexParameteri ]
 339         [ [ GL_TEXTURE_MAX_LOD ] dip max-lod>> glTexParameteri ]
 340         [ [ GL_TEXTURE_LOD_BIAS ] dip lod-bias>> glTexParameteri ]
 341         [ [ GL_TEXTURE_BASE_LEVEL ] dip base-level>> glTexParameteri ]
 342         [ [ GL_TEXTURE_MAX_LEVEL ] dip max-level>> glTexParameteri ]
 343     } 2cleave ;
 344
 345 <PRIVATE
 346
 347 : <texture> ( component-order component-type parameters class -- texture )
 348     '[ [ gen-texture ] 2dip _ boa dup window-resource ] dip
 349     [ T{ texture-parameters } clone ] unless* set-texture-parameters ; inline
 350
 351 PRIVATE>
 352
 353 : <texture-1d> ( component-order component-type parameters -- texture )
 354     texture-1d <texture> ; inline
 355 : <texture-2d> ( component-order component-type parameters -- texture )
 356     texture-2d <texture> ; inline
 357 : <texture-3d> ( component-order component-type parameters -- texture )
 358     texture-3d <texture> ; inline
 359 : <texture-cube-map> ( component-order component-type parameters -- texture )
 360     texture-cube-map <texture> ; inline
 361 : <texture-rectangle> ( component-order component-type parameters -- texture )
 362     texture-rectangle <texture> ; inline
 363 : <texture-1d-array> ( component-order component-type parameters -- texture )
 364     texture-1d-array <texture> ; inline
 365 : <texture-2d-array> ( component-order component-type parameters -- texture )
 366     texture-2d-array <texture> ; inline
 367