basis/opengl/textures/textures.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs cache colors.constants destructors kernel
   4 opengl opengl.gl opengl.capabilities combinators images
   5 images.tesselation grouping specialized-arrays.float sequences math
   6 math.vectors math.matrices generalizations fry arrays namespaces
   7 system locals ;
   8 IN: opengl.textures
   9
  10 SYMBOL: non-power-of-2-textures?
  11
  12 : check-extensions ( -- )
  13     #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
  14     #! See thread 'Linux font display problem' April 2009 on Factor-talk
  15     gl-vendor "ATI Technologies Inc." = not os macosx? or [
  16         "2.0" { "GL_ARB_texture_non_power_of_two" }
  17         has-gl-version-or-extensions?
  18         non-power-of-2-textures? set
  19     ] when ;
  20
  21 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
  22
  23 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
  24
  25 GENERIC: component-type>type ( component-type -- internal-format type )
  26 GENERIC: component-order>format ( type component-order -- type format )
  27 GENERIC: component-order>integer-format ( type component-order -- type format )
  28
  29 ERROR: unsupported-component-order component-order ;
  30
  31 M: ubyte-components component-type>type drop GL_RGBA8 GL_UNSIGNED_BYTE ;
  32 M: ushort-components component-type>type drop GL_RGBA16 GL_UNSIGNED_SHORT ;
  33 M: half-components component-type>type drop GL_RGBA16F_ARB GL_HALF_FLOAT_ARB ;
  34 M: float-components component-type>type drop GL_RGBA32F_ARB GL_FLOAT ;
  35 M: byte-integer-components component-type>type drop GL_RGBA8I_EXT GL_BYTE ;
  36 M: short-integer-components component-type>type drop GL_RGBA16I_EXT GL_SHORT ;
  37 M: int-integer-components component-type>type drop GL_RGBA32I_EXT GL_INT ;
  38 M: ubyte-integer-components component-type>type drop GL_RGBA8I_EXT GL_UNSIGNED_BYTE ;
  39 M: ushort-integer-components component-type>type drop GL_RGBA16I_EXT GL_UNSIGNED_SHORT ;
  40 M: uint-integer-components component-type>type drop GL_RGBA32I_EXT GL_UNSIGNED_INT ;
  41
  42 M: RGB component-order>format drop GL_RGB ;
  43 M: BGR component-order>format drop GL_BGR ;
  44 M: RGBA component-order>format drop GL_RGBA ;
  45 M: ARGB component-order>format
  46     swap GL_UNSIGNED_BYTE =
  47     [ drop GL_UNSIGNED_INT_8_8_8_8_REV GL_BGRA ]
  48     [ unsupported-component-order ] if ;
  49 M: BGRA component-order>format drop GL_BGRA ;
  50 M: BGRX component-order>format drop GL_BGRA ;
  51 M: LA component-order>format drop GL_LUMINANCE_ALPHA ;
  52 M: L component-order>format drop GL_LUMINANCE ;
  53
  54 M: object component-order>format unsupported-component-order ;
  55
  56 M: RGB component-order>integer-format drop GL_RGB_INTEGER_EXT ;
  57 M: BGR component-order>integer-format drop GL_BGR_INTEGER_EXT ;
  58 M: RGBA component-order>integer-format drop GL_RGBA_INTEGER_EXT ;
  59 M: BGRA component-order>integer-format drop GL_BGRA_INTEGER_EXT ;
  60 M: BGRX component-order>integer-format drop GL_BGRA_INTEGER_EXT ;
  61 M: LA component-order>integer-format drop GL_LUMINANCE_ALPHA_INTEGER_EXT ;
  62 M: L component-order>integer-format drop GL_LUMINANCE_INTEGER_EXT ;
  63
  64 M: object component-order>integer-format unsupported-component-order ;
  65
  66 SLOT: display-list
  67
  68 : draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
  69
  70 GENERIC: draw-scaled-texture ( dim texture -- )
  71
  72 DEFER: make-texture
  73
  74 <PRIVATE
  75
  76 TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
  77
  78 : adjust-texture-dim ( dim -- dim' )
  79     non-power-of-2-textures? get [
  80         [ dup 1 = [ next-power-of-2 ] unless ] map
  81     ] unless ;
  82
  83 : image-format ( image -- internal-format format type )
  84     dup component-type>>
  85     [ nip component-type>type ]
  86     [
  87         unnormalized-integer-components?
  88         [ component-order>> component-order>integer-format ]
  89         [ component-order>> component-order>format ] if
  90     ] 2bi swap ;
  91
  92 :: tex-image ( image bitmap -- )
  93     image image-format :> type :> format :> internal-format
  94     GL_TEXTURE_2D 0 internal-format
  95     image dim>> adjust-texture-dim first2 0
  96     format type bitmap glTexImage2D ;
  97
  98 : tex-sub-image ( image -- )
  99     [ GL_TEXTURE_2D 0 0 0 ] dip
 100     [ dim>> first2 ]
 101     [ image-format [ drop ] 2dip ]
 102     [ bitmap>> ] tri
 103     glTexSubImage2D ;
 104
 105 : init-texture ( -- )
 106     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
 107     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
 108     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
 109     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
 110
 111 : with-texturing ( quot -- )
 112     GL_TEXTURE_2D [
 113         GL_TEXTURE_BIT [
 114             GL_TEXTURE_COORD_ARRAY [
 115                 COLOR: white gl-color
 116                 call
 117             ] do-enabled-client-state
 118         ] do-attribs
 119     ] do-enabled ; inline
 120
 121 : (draw-textured-rect) ( dim texture -- )
 122     [ loc>> ]
 123     [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
 124     [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
 125     swap gl-fill-rect ;
 126
 127 : draw-textured-rect ( dim texture -- )
 128     [
 129         [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
 130         [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
 131         [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
 132         tri
 133     ] with-texturing ;
 134
 135 : texture-coords ( texture -- coords )
 136     [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
 137     [
 138         image>> upside-down?>>
 139         { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
 140         { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
 141     ] bi
 142     [ v* ] with map float-array{ } join ;
 143
 144 : make-texture-display-list ( texture -- dlist )
 145     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 146
 147 : <single-texture> ( image loc -- texture )
 148     single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
 149     dup image>> dim>> product 0 = [
 150         dup texture-coords >>texture-coords
 151         dup image>> make-texture >>texture
 152         dup make-texture-display-list >>display-list
 153     ] unless ;
 154
 155 M: single-texture dispose*
 156     [ texture>> [ delete-texture ] when* ]
 157     [ display-list>> [ delete-dlist ] when* ] bi ;
 158
 159 M: single-texture draw-scaled-texture
 160     2dup dim>> = [ nip draw-texture ] [
 161         dup texture>> [ draw-textured-rect ] [ 2drop ] if
 162     ] if ;
 163
 164 TUPLE: multi-texture grid display-list loc disposed ;
 165
 166 : image-locs ( image-grid -- loc-grid )
 167     [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
 168     [ 0 [ + ] accumulate nip ] bi@
 169     cross-zip flip ;
 170
 171 : <texture-grid> ( image-grid loc -- grid )
 172     [ dup image-locs ] dip
 173     '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
 174
 175 : grid-has-alpha? ( grid -- ? )
 176     first first image>> has-alpha? ;
 177
 178 : make-textured-grid-display-list ( grid -- dlist )
 179     GL_COMPILE [
 180         [
 181             [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
 182             [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
 183             [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
 184             GL_TEXTURE_2D 0 glBindTexture
 185         ] with-texturing
 186     ] make-dlist ;
 187
 188 : <multi-texture> ( image-grid loc -- multi-texture )
 189     [
 190         [
 191             <texture-grid> dup
 192             make-textured-grid-display-list
 193         ] keep
 194         f multi-texture boa
 195     ] with-destructors ;
 196
 197 M: multi-texture draw-scaled-texture nip draw-texture ;
 198
 199 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 200
 201 CONSTANT: max-texture-size { 512 512 }
 202
 203 PRIVATE>
 204
 205 : make-texture ( image -- id )
 206     #! We use glTexSubImage2D to work around the power of 2 texture size
 207     #! limitation
 208     gen-texture [
 209         GL_TEXTURE_BIT [
 210             GL_TEXTURE_2D swap glBindTexture
 211             non-power-of-2-textures? get
 212             [ dup bitmap>> tex-image ]
 213             [ [ f tex-image ] [ tex-sub-image ] bi ] if
 214         ] do-attribs
 215     ] keep ;
 216
 217 : <texture> ( image loc -- texture )
 218     over dim>> max-texture-size [ <= ] 2all?
 219     [ <single-texture> ]
 220     [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;