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 fry 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 ;
   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-order>format ( component-order -- format type )
  26
  27 M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
  28 M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
  29 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
  30 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
  31 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
  32 M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
  33 M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
  34 M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
  35
  36 SLOT: display-list
  37
  38 : draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
  39
  40 GENERIC: draw-scaled-texture ( dim texture -- )
  41
  42 DEFER: make-texture
  43
  44 <PRIVATE
  45
  46 TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
  47
  48 : adjust-texture-dim ( dim -- dim' )
  49     non-power-of-2-textures? get [
  50         [ dup 1 = [ next-power-of-2 ] unless ] map
  51     ] unless ;
  52
  53 : (tex-image) ( image bitmap -- )
  54     [
  55         [ GL_TEXTURE_2D 0 GL_RGBA ] dip
  56         [ dim>> adjust-texture-dim first2 0 ]
  57         [ component-order>> component-order>format ] bi
  58     ] dip
  59     glTexImage2D ;
  60
  61 : (tex-sub-image) ( image -- )
  62     [ GL_TEXTURE_2D 0 0 0 ] dip
  63     [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
  64     glTexSubImage2D ;
  65
  66 : init-texture ( -- )
  67     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
  68     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
  69     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
  70     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
  71
  72 : with-texturing ( quot -- )
  73     GL_TEXTURE_2D [
  74         GL_TEXTURE_BIT [
  75             GL_TEXTURE_COORD_ARRAY [
  76                 COLOR: white gl-color
  77                 call
  78             ] do-enabled-client-state
  79         ] do-attribs
  80     ] do-enabled ; inline
  81
  82 : (draw-textured-rect) ( dim texture -- )
  83     [ loc>> ]
  84     [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
  85     [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
  86     swap gl-fill-rect ;
  87
  88 : draw-textured-rect ( dim texture -- )
  89     [
  90         [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
  91         [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
  92         [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
  93         tri
  94     ] with-texturing ;
  95
  96 : texture-coords ( texture -- coords )
  97     [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
  98     [
  99         image>> upside-down?>>
 100         { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
 101         { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
 102     ] bi
 103     [ v* ] with map float-array{ } join ;
 104
 105 : make-texture-display-list ( texture -- dlist )
 106     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 107
 108 : <single-texture> ( image loc -- texture )
 109     single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
 110     dup image>> dim>> product 0 = [
 111         dup texture-coords >>texture-coords
 112         dup image>> make-texture >>texture
 113         dup make-texture-display-list >>display-list
 114     ] unless ;
 115
 116 M: single-texture dispose*
 117     [ texture>> [ delete-texture ] when* ]
 118     [ display-list>> [ delete-dlist ] when* ] bi ;
 119
 120 M: single-texture draw-scaled-texture
 121     2dup dim>> = [ nip draw-texture ] [
 122         dup texture>> [ draw-textured-rect ] [ 2drop ] if
 123     ] if ;
 124
 125 TUPLE: multi-texture grid display-list loc disposed ;
 126
 127 : image-locs ( image-grid -- loc-grid )
 128     [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
 129     [ 0 [ + ] accumulate nip ] bi@
 130     cross-zip flip ;
 131
 132 : <texture-grid> ( image-grid loc -- grid )
 133     [ dup image-locs ] dip
 134     '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
 135
 136 : draw-textured-grid ( grid -- )
 137     [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
 138
 139 : grid-has-alpha? ( grid -- ? )
 140     first first image>> has-alpha? ;
 141
 142 : make-textured-grid-display-list ( grid -- dlist )
 143     GL_COMPILE [
 144         [
 145             [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
 146             [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
 147             [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
 148             GL_TEXTURE_2D 0 glBindTexture
 149         ] with-texturing
 150     ] make-dlist ;
 151
 152 : <multi-texture> ( image-grid loc -- multi-texture )
 153     [
 154         [
 155             <texture-grid> dup
 156             make-textured-grid-display-list
 157         ] keep
 158         f multi-texture boa
 159     ] with-destructors ;
 160
 161 M: multi-texture draw-scaled-texture nip draw-texture ;
 162
 163 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 164
 165 CONSTANT: max-texture-size { 512 512 }
 166
 167 PRIVATE>
 168
 169 : make-texture ( image -- id )
 170     #! We use glTexSubImage2D to work around the power of 2 texture size
 171     #! limitation
 172     gen-texture [
 173         GL_TEXTURE_BIT [
 174             GL_TEXTURE_2D swap glBindTexture
 175             non-power-of-2-textures? get
 176             [ dup bitmap>> (tex-image) ]
 177             [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
 178         ] do-attribs
 179     ] keep ;
 180
 181 : <texture> ( image loc -- texture )
 182     over dim>> max-texture-size [ <= ] 2all?
 183     [ <single-texture> ]
 184     [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;