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 grouping specialized-arrays.float
   5 locals sequences math math.vectors generalizations ;
   6 IN: opengl.textures
   7
   8 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
   9
  10 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
  11
  12 TUPLE: texture loc dim texture-coords texture display-list disposed ;
  13
  14 <PRIVATE
  15
  16 GENERIC: component-order>format ( component-order -- format type )
  17
  18 M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
  19 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
  20 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
  21
  22 : repeat-last ( seq n -- seq' )
  23     over peek pad-tail concat ;
  24
  25 : power-of-2-bitmap ( rows dim size -- bitmap dim )
  26     '[
  27         first2
  28         [ [ _ ] dip '[ _ group _ repeat-last ] map ]
  29         [ repeat-last ]
  30         bi*
  31     ] keep ;
  32
  33 : image-rows ( image -- rows )
  34     [ bitmap>> ]
  35     [ dim>> first ]
  36     [ component-order>> bytes-per-pixel ]
  37     tri * group ; inline
  38
  39 : power-of-2-image ( image -- image )
  40     dup dim>> [ 0 = ] all? [
  41         clone dup
  42         [ image-rows ]
  43         [ dim>> [ next-power-of-2 ] map ]
  44         [ component-order>> bytes-per-pixel ] tri
  45         power-of-2-bitmap
  46         [ >>bitmap ] [ >>dim ] bi*
  47     ] unless ;
  48
  49 :: make-texture ( image -- id )
  50     gen-texture [
  51         GL_TEXTURE_BIT [
  52             GL_TEXTURE_2D swap glBindTexture
  53             GL_TEXTURE_2D
  54             0
  55             GL_RGBA
  56             image dim>> first2
  57             0
  58             image component-order>> component-order>format
  59             image bitmap>>
  60             glTexImage2D
  61         ] do-attribs
  62     ] keep ;
  63
  64 : init-texture ( -- )
  65     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
  66     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
  67     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
  68     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
  69
  70 : draw-textured-rect ( dim texture -- )
  71     GL_TEXTURE_2D [
  72         GL_TEXTURE_BIT [
  73             GL_TEXTURE_COORD_ARRAY [
  74                 COLOR: white gl-color
  75                 dup loc>> [
  76                     [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
  77                     [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
  78                     fill-rect-vertices (gl-fill-rect)
  79                     GL_TEXTURE_2D 0 glBindTexture
  80                 ] with-translation
  81             ] do-enabled-client-state
  82         ] do-attribs
  83     ] do-enabled ;
  84
  85 : texture-coords ( dim -- coords )
  86     [ dup next-power-of-2 /f ] map
  87     { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
  88     float-array{ } join ;
  89
  90 : make-texture-display-list ( texture -- dlist )
  91     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
  92
  93 PRIVATE>
  94
  95 : <texture> ( image loc -- texture )
  96     texture new swap >>loc
  97     swap
  98     [ dim>> >>dim ] keep
  99     [ dim>> product 0 = ] keep '[
 100         _
 101         [ dim>> texture-coords >>texture-coords ]
 102         [ power-of-2-image make-texture >>texture ] bi
 103         dup make-texture-display-list >>display-list
 104     ] unless ;
 105
 106 M: texture dispose*
 107     [ texture>> [ delete-texture ] when* ]
 108     [ display-list>> [ delete-dlist ] when* ] bi ;
 109
 110 : draw-texture ( texture -- )
 111     display-list>> [ glCallList ] when* ;
 112
 113 : draw-scaled-texture ( dim texture -- )
 114     dup texture>> [ draw-textured-rect ] [ 2drop ] if ;