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