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 combinators images images.tesselation grouping
   5 specialized-arrays.float locals sequences math math.vectors
   6 math.matrices generalizations fry columns ;
   7 IN: opengl.textures
   8
   9 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
  10
  11 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
  12
  13 GENERIC: component-order>format ( component-order -- format type )
  14
  15 M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
  16 M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
  17 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
  18 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
  19 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
  20 M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
  21
  22 GENERIC: draw-texture ( texture -- )
  23
  24 GENERIC: draw-scaled-texture ( dim texture -- )
  25
  26 <PRIVATE
  27
  28 TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
  29
  30 : repeat-last ( seq n -- seq' )
  31     over peek pad-tail concat ;
  32
  33 : power-of-2-bitmap ( rows dim size -- bitmap dim )
  34     '[
  35         first2
  36         [ [ _ ] dip '[ _ group _ repeat-last ] map ]
  37         [ repeat-last ]
  38         bi*
  39     ] keep ;
  40
  41 : image-rows ( image -- rows )
  42     [ bitmap>> ]
  43     [ dim>> first ]
  44     [ component-order>> bytes-per-pixel ]
  45     tri * group ; inline
  46
  47 : power-of-2-image ( image -- image )
  48     dup dim>> [ 0 = ] all? [
  49         clone dup
  50         [ image-rows ]
  51         [ dim>> [ next-power-of-2 ] map ]
  52         [ component-order>> bytes-per-pixel ] tri
  53         power-of-2-bitmap
  54         [ >>bitmap ] [ >>dim ] bi*
  55     ] unless ;
  56
  57 :: make-texture ( image -- id )
  58     gen-texture [
  59         GL_TEXTURE_BIT [
  60             GL_TEXTURE_2D swap glBindTexture
  61             GL_TEXTURE_2D
  62             0
  63             GL_RGBA
  64             image dim>> first2
  65             0
  66             image component-order>> component-order>format
  67             image bitmap>>
  68             glTexImage2D
  69         ] do-attribs
  70     ] keep ;
  71
  72 : init-texture ( -- )
  73     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
  74     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
  75     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
  76     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
  77
  78 : with-texturing ( quot -- )
  79     GL_TEXTURE_2D [
  80         GL_TEXTURE_BIT [
  81             GL_TEXTURE_COORD_ARRAY [
  82                 COLOR: white gl-color
  83                 call
  84             ] do-enabled-client-state
  85         ] do-attribs
  86     ] do-enabled ; inline
  87
  88 : (draw-textured-rect) ( dim texture -- )
  89     [ loc>> ]
  90     [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
  91     [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
  92     swap gl-fill-rect ;
  93
  94 : draw-textured-rect ( dim texture -- )
  95     [
  96         (draw-textured-rect)
  97         GL_TEXTURE_2D 0 glBindTexture
  98     ] with-texturing ;
  99
 100 : texture-coords ( dim -- coords )
 101     [ dup next-power-of-2 /f ] map
 102     { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
 103     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
 110     swap
 111     [ dim>> >>dim ] keep
 112     [ dim>> product 0 = ] keep '[
 113         _
 114         [ dim>> texture-coords >>texture-coords ]
 115         [ power-of-2-image make-texture >>texture ] bi
 116         dup make-texture-display-list >>display-list
 117     ] unless ;
 118
 119 M: single-texture dispose*
 120     [ texture>> [ delete-texture ] when* ]
 121     [ display-list>> [ delete-dlist ] when* ] bi ;
 122
 123 M: single-texture draw-texture display-list>> [ glCallList ] when* ;
 124
 125 M: single-texture draw-scaled-texture
 126     dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
 127
 128 TUPLE: multi-texture grid display-list loc disposed ;
 129
 130 : image-locs ( image-grid -- loc-grid )
 131     [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
 132     [ 0 [ + ] accumulate nip ] bi@
 133     cross-zip flip ;
 134
 135 : <texture-grid> ( image-grid loc -- grid )
 136     [ dup image-locs ] dip
 137     '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
 138
 139 : draw-textured-grid ( grid -- )
 140     [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
 141
 142 : make-textured-grid-display-list ( grid -- dlist )
 143     GL_COMPILE [
 144         [
 145             [
 146                 [
 147                     [ dim>> ] keep (draw-textured-rect)
 148                 ] each
 149             ] each
 150             GL_TEXTURE_2D 0 glBindTexture
 151         ] with-texturing
 152     ] make-dlist ;
 153
 154 : <multi-texture> ( image-grid loc -- multi-texture )
 155     [
 156         [
 157             <texture-grid> dup
 158             make-textured-grid-display-list
 159         ] keep
 160         f multi-texture boa
 161     ] with-destructors ;
 162
 163 M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
 164
 165 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 166
 167 CONSTANT: max-texture-size { 256 256 }
 168
 169 PRIVATE>
 170
 171 : <texture> ( image loc -- texture )
 172     over dim>> max-texture-size [ <= ] 2all?
 173     [ <single-texture> ]
 174     [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;