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 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: texture-wrap
  53     clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
  54 VARIANT: texture-filter
  55     filter-nearest filter-linear ;
  56
  57 UNION: wrap-set texture-wrap sequence ;
  58 UNION: ?texture-filter texture-filter POSTPONE: f ;
  59
  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 } ;
  70
  71 <PRIVATE
  72
  73 GENERIC: texture-object ( texture-data-target -- texture )
  74 M: cube-map-face texture-object
  75     texture>> ;
  76 M: texture texture-object
  77     ;
  78
  79 : gl-wrap ( wrap -- gl-wrap )
  80     {
  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 ] }
  85     } case ;
  86
  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 ]
  92     } 2cleave ;
  93
  94 : gl-mag-filter ( filter -- gl-filter )
  95     {
  96         { filter-nearest [ GL_NEAREST ] }
  97         { filter-linear [ GL_LINEAR ] }
  98     } case ;
  99
 100 : gl-min-filter ( filter mipmap-filter -- gl-filter )
 101     2array {
 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  ] }
 108     } case ;
 109
 110 GENERIC: texture-gl-target ( texture -- target )
 111 GENERIC: texture-data-gl-target ( texture -- target )
 112
 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 ;
 120
 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
 128     axis>> {
 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 ] }
 135     } case ;
 136
 137 : texture-gl-internal-format ( texture -- internal-format )
 138     [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
 139
 140 : texture-data-gl-args ( texture data -- format type ptr )
 141     [
 142         nip
 143         [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
 144         [ ptr>> ] bi
 145     ] [
 146         [ component-order>> ] [ component-type>> ] bi image-data-format f
 147     ] if* ;
 148
 149 :: bind-tdt ( tdt -- texture )
 150     tdt texture-object :> texture
 151     texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
 152     texture ;
 153
 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 ;
 158
 159 : ?product ( x -- y )
 160     dup number? [ product ] unless ;
 161
 162 PRIVATE>
 163
 164 GENERIC# allocate-texture 3 ( tdt level dim data -- )
 165
 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 ;
 171
 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 ;
 177
 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 ;
 183
 184 GENERIC# update-texture 4 ( tdt level loc dim data -- )
 185
 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 ;
 191
 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 ;
 198
 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 ;
 205
 206 : image>texture-data ( image -- dim texture-data )
 207     { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
 208     <texture-data> ; inline
 209
 210 GENERIC# texture-dim 1 ( tdt level -- dim )
 211
 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 ;
 215
 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
 220     2array ;
 221
 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
 228     3array ;
 229
 230 : texture-data-size ( tdt level -- size )
 231     [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ;
 232
 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 ;
 238
 239 : read-texture ( tdt level -- byte-array )
 240     2dup texture-data-size <byte-array>
 241     [ read-texture-to ] keep ;
 242
 243 : allocate-texture-image ( tdt level image -- )
 244     image>texture-data allocate-texture ;
 245
 246 : update-texture-image ( tdt level loc image -- )
 247     image>texture-data update-texture ;
 248
 249 : read-texture-image ( tdt level -- image )
 250     [ texture-dim ]
 251     [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
 252     [ read-texture ] 2tri
 253     image boa ;
 254
 255 <PRIVATE
 256 : bind-texture ( texture -- gl-target )
 257     [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ;
 258 PRIVATE>
 259
 260 : generate-mipmaps ( texture -- )
 261     bind-texture glGenerateMipmap ;
 262
 263 : set-texture-parameters ( texture parameters -- )
 264     [ bind-texture ] dip {
 265         [ wrap>> set-texture-gl-wrap ]
 266         [
 267             [ GL_TEXTURE_MIN_FILTER ] dip
 268             [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
 269         ] [
 270             [ GL_TEXTURE_MAG_FILTER ] dip
 271             mag-filter>> gl-mag-filter glTexParameteri
 272         ]
 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 ]
 278     } 2cleave ;
 279
 280 <PRIVATE
 281
 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
 285
 286 PRIVATE>
 287
 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> ;
 302