basis/opengl/textures/textures.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.data arrays assocs colors combinators
   4 destructors images images.tessellation kernel literals math
   5 math.statistics math.vectors namespaces opengl
   6 opengl.capabilities opengl.gl sequences specialized-arrays
   7 system ;
   8 FROM: alien.c-types => int float ;
   9 SPECIALIZED-ARRAY: float
  10 IN: opengl.textures
  11
  12 SYMBOL: non-power-of-2-textures?
  13
  14 : check-extensions ( -- )
  15     ! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
  16     ! See thread 'Linux font display problem' April 2009 on Factor-talk
  17     gl-vendor "ATI Technologies Inc." = not os macosx? or [
  18         "2.0" { "GL_ARB_texture_non_power_of_two" }
  19         has-gl-version-or-extensions?
  20         non-power-of-2-textures? set
  21     ] when ;
  22
  23 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
  24
  25 : create-texture ( target -- id )
  26     [ glCreateTextures ] (gen-gl-object) ;
  27
  28 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
  29
  30 ERROR: unsupported-component-order component-order component-type ;
  31
  32 CONSTANT: image-internal-formats H{
  33     { { A         ubyte-components          } $ GL_ALPHA8            }
  34     { { A         ushort-components         } $ GL_ALPHA16           }
  35     { { A         half-components           } $ GL_ALPHA16F_ARB      }
  36     { { A         float-components          } $ GL_ALPHA32F_ARB      }
  37     { { A         byte-integer-components   } $ GL_ALPHA8I_EXT       }
  38     { { A         ubyte-integer-components  } $ GL_ALPHA8UI_EXT      }
  39     { { A         short-integer-components  } $ GL_ALPHA16I_EXT      }
  40     { { A         ushort-integer-components } $ GL_ALPHA16UI_EXT     }
  41     { { A         int-integer-components    } $ GL_ALPHA32I_EXT      }
  42     { { A         uint-integer-components   } $ GL_ALPHA32UI_EXT     }
  43
  44     { { L         ubyte-components          } $ GL_LUMINANCE8        }
  45     { { L         ushort-components         } $ GL_LUMINANCE16       }
  46     { { L         half-components           } $ GL_LUMINANCE16F_ARB  }
  47     { { L         float-components          } $ GL_LUMINANCE32F_ARB  }
  48     { { L         byte-integer-components   } $ GL_LUMINANCE8I_EXT   }
  49     { { L         ubyte-integer-components  } $ GL_LUMINANCE8UI_EXT  }
  50     { { L         short-integer-components  } $ GL_LUMINANCE16I_EXT  }
  51     { { L         ushort-integer-components } $ GL_LUMINANCE16UI_EXT }
  52     { { L         int-integer-components    } $ GL_LUMINANCE32I_EXT  }
  53     { { L         uint-integer-components   } $ GL_LUMINANCE32UI_EXT }
  54
  55     { { R         ubyte-components          } $ GL_R8    }
  56     { { R         ushort-components         } $ GL_R16   }
  57     { { R         half-components           } $ GL_R16F  }
  58     { { R         float-components          } $ GL_R32F  }
  59     { { R         byte-integer-components   } $ GL_R8I   }
  60     { { R         ubyte-integer-components  } $ GL_R8UI  }
  61     { { R         short-integer-components  } $ GL_R16I  }
  62     { { R         ushort-integer-components } $ GL_R16UI }
  63     { { R         int-integer-components    } $ GL_R32I  }
  64     { { R         uint-integer-components   } $ GL_R32UI }
  65
  66     { { INTENSITY ubyte-components          } $ GL_INTENSITY8        }
  67     { { INTENSITY ushort-components         } $ GL_INTENSITY16       }
  68     { { INTENSITY half-components           } $ GL_INTENSITY16F_ARB  }
  69     { { INTENSITY float-components          } $ GL_INTENSITY32F_ARB  }
  70     { { INTENSITY byte-integer-components   } $ GL_INTENSITY8I_EXT   }
  71     { { INTENSITY ubyte-integer-components  } $ GL_INTENSITY8UI_EXT  }
  72     { { INTENSITY short-integer-components  } $ GL_INTENSITY16I_EXT  }
  73     { { INTENSITY ushort-integer-components } $ GL_INTENSITY16UI_EXT }
  74     { { INTENSITY int-integer-components    } $ GL_INTENSITY32I_EXT  }
  75     { { INTENSITY uint-integer-components   } $ GL_INTENSITY32UI_EXT }
  76
  77     { { DEPTH     ushort-components         } $ GL_DEPTH_COMPONENT16  }
  78     { { DEPTH     u-24-components           } $ GL_DEPTH_COMPONENT24  }
  79     { { DEPTH     uint-components           } $ GL_DEPTH_COMPONENT32  }
  80     { { DEPTH     float-components          } $ GL_DEPTH_COMPONENT32F }
  81
  82     { { LA        ubyte-components          } $ GL_LUMINANCE8_ALPHA8       }
  83     { { LA        ushort-components         } $ GL_LUMINANCE16_ALPHA16     }
  84     { { LA        half-components           } $ GL_LUMINANCE_ALPHA16F_ARB  }
  85     { { LA        float-components          } $ GL_LUMINANCE_ALPHA32F_ARB  }
  86     { { LA        byte-integer-components   } $ GL_LUMINANCE_ALPHA8I_EXT   }
  87     { { LA        ubyte-integer-components  } $ GL_LUMINANCE_ALPHA8UI_EXT  }
  88     { { LA        short-integer-components  } $ GL_LUMINANCE_ALPHA16I_EXT  }
  89     { { LA        ushort-integer-components } $ GL_LUMINANCE_ALPHA16UI_EXT }
  90     { { LA        int-integer-components    } $ GL_LUMINANCE_ALPHA32I_EXT  }
  91     { { LA        uint-integer-components   } $ GL_LUMINANCE_ALPHA32UI_EXT }
  92
  93     { { RG        ubyte-components          } $ GL_RG8    }
  94     { { RG        ushort-components         } $ GL_RG16   }
  95     { { RG        half-components           } $ GL_RG16F  }
  96     { { RG        float-components          } $ GL_RG32F  }
  97     { { RG        byte-integer-components   } $ GL_RG8I   }
  98     { { RG        ubyte-integer-components  } $ GL_RG8UI  }
  99     { { RG        short-integer-components  } $ GL_RG16I  }
 100     { { RG        ushort-integer-components } $ GL_RG16UI }
 101     { { RG        int-integer-components    } $ GL_RG32I  }
 102     { { RG        uint-integer-components   } $ GL_RG32UI }
 103
 104     { { DEPTH-STENCIL u-24-8-components       } $ GL_DEPTH24_STENCIL8 }
 105     { { DEPTH-STENCIL float-32-u-8-components } $ GL_DEPTH32F_STENCIL8 }
 106
 107     { { RGB       ubyte-components          } $ GL_RGB8               }
 108     { { RGB       ushort-components         } $ GL_RGB16              }
 109     { { RGB       half-components           } $ GL_RGB16F         }
 110     { { RGB       float-components          } $ GL_RGB32F         }
 111     { { RGB       byte-integer-components   } $ GL_RGB8I          }
 112     { { RGB       ubyte-integer-components  } $ GL_RGB8UI         }
 113     { { RGB       byte-integer-components   } $ GL_RGB8I          }
 114     { { RGB       ubyte-integer-components  } $ GL_RGB8UI         }
 115     { { RGB       short-integer-components  } $ GL_RGB16I         }
 116     { { RGB       ushort-integer-components } $ GL_RGB16UI        }
 117     { { RGB       int-integer-components    } $ GL_RGB32I         }
 118     { { RGB       uint-integer-components   } $ GL_RGB32UI        }
 119     { { RGB       u-5-6-5-components        } $ GL_RGB5               }
 120     { { RGB       u-9-9-9-e5-components     } $ GL_RGB9_E5        }
 121     { { RGB       float-11-11-10-components } $ GL_R11F_G11F_B10F }
 122
 123     { { RGBA      ubyte-components          } $ GL_RGBA8              }
 124     { { RGBA      ushort-components         } $ GL_RGBA16             }
 125     { { RGBA      half-components           } $ GL_RGBA16F        }
 126     { { RGBA      float-components          } $ GL_RGBA32F        }
 127     { { RGBA      byte-integer-components   } $ GL_RGBA8I         }
 128     { { RGBA      ubyte-integer-components  } $ GL_RGBA8UI        }
 129     { { RGBA      byte-integer-components   } $ GL_RGBA8I         }
 130     { { RGBA      ubyte-integer-components  } $ GL_RGBA8UI        }
 131     { { RGBA      short-integer-components  } $ GL_RGBA16I        }
 132     { { RGBA      ushort-integer-components } $ GL_RGBA16UI       }
 133     { { RGBA      int-integer-components    } $ GL_RGBA32I        }
 134     { { RGBA      uint-integer-components   } $ GL_RGBA32UI       }
 135     { { RGBA      u-5-5-5-1-components      } $ GL_RGB5_A1            }
 136     { { RGBA      u-10-10-10-2-components   } $ GL_RGB10_A2           }
 137 }
 138
 139 GENERIC: fix-internal-component-order ( order -- order' )
 140
 141 M: object fix-internal-component-order ;
 142 M: BGR fix-internal-component-order drop RGB ;
 143 M: BGRA fix-internal-component-order drop RGBA ;
 144 M: ARGB fix-internal-component-order drop RGBA ;
 145 M: ABGR fix-internal-component-order drop RGBA ;
 146 M: RGBX fix-internal-component-order drop RGBA ;
 147 M: BGRX fix-internal-component-order drop RGBA ;
 148 M: XRGB fix-internal-component-order drop RGBA ;
 149 M: XBGR fix-internal-component-order drop RGBA ;
 150
 151 : image-internal-format ( component-order component-type -- internal-format )
 152     2dup
 153     [ fix-internal-component-order ] dip 2array image-internal-formats at
 154     [ 2nip ] [ unsupported-component-order ] if* ;
 155
 156 : reversed-type? ( component-type -- ? )
 157     { u-9-9-9-e5-components float-11-11-10-components } member? ;
 158
 159 : (component-order>format) ( component-order component-type -- gl-format )
 160     dup unnormalized-integer-components? [
 161         swap {
 162             { A [ drop GL_ALPHA_INTEGER_EXT ] }
 163             { L [ drop GL_LUMINANCE_INTEGER_EXT ] }
 164             { R [ drop GL_RED_INTEGER ] }
 165             { LA [ drop GL_LUMINANCE_ALPHA_INTEGER_EXT ] }
 166             { RG [ drop GL_RG_INTEGER ] }
 167             { BGR [ drop GL_BGR_INTEGER ] }
 168             { RGB [ drop GL_RGB_INTEGER ] }
 169             { BGRA [ drop GL_BGRA_INTEGER ] }
 170             { RGBA [ drop GL_RGBA_INTEGER ] }
 171             { BGRX [ drop GL_BGRA_INTEGER ] }
 172             { RGBX [ drop GL_RGBA_INTEGER ] }
 173             [ swap unsupported-component-order ]
 174         } case
 175     ] [
 176         swap {
 177             { A [ drop GL_ALPHA ] }
 178             { L [ drop GL_LUMINANCE ] }
 179             { R [ drop GL_RED ] }
 180             { LA [ drop GL_LUMINANCE_ALPHA ] }
 181             { RG [ drop GL_RG ] }
 182             { BGR [ reversed-type? GL_RGB GL_BGR ? ] }
 183             { RGB [ reversed-type? GL_BGR GL_RGB ? ] }
 184             { BGRA [ drop GL_BGRA ] }
 185             { RGBA [ drop GL_RGBA ] }
 186             { ARGB [ drop GL_BGRA ] }
 187             { ABGR [ drop GL_RGBA ] }
 188             { BGRX [ drop GL_BGRA ] }
 189             { RGBX [ drop GL_RGBA ] }
 190             { XRGB [ drop GL_BGRA ] }
 191             { XBGR [ drop GL_RGBA ] }
 192             { INTENSITY [ drop GL_INTENSITY ] }
 193             { DEPTH [ drop GL_DEPTH_COMPONENT ] }
 194             { DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] }
 195             [ swap unsupported-component-order ]
 196         } case
 197     ] if ;
 198
 199 GENERIC: (component-type>type) ( component-order component-type -- gl-type )
 200
 201 M: object (component-type>type) unsupported-component-order ;
 202
 203 : four-channel-alpha-first? ( component-order component-type -- ? )
 204     over component-count 4 =
 205     [ drop alpha-channel-precedes-colors? ]
 206     [ unsupported-component-order ] if ;
 207
 208 : not-alpha-first ( component-order component-type -- )
 209     over alpha-channel-precedes-colors?
 210     [ unsupported-component-order ]
 211     [ 2drop ] if ;
 212
 213 M: ubyte-components          (component-type>type)
 214     drop alpha-channel-precedes-colors?
 215     [ GL_UNSIGNED_INT_8_8_8_8_REV ]
 216     [ GL_UNSIGNED_BYTE ] if ;
 217
 218 M: ushort-components         (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
 219 M: uint-components           (component-type>type) not-alpha-first GL_UNSIGNED_INT   ;
 220 M: half-components           (component-type>type) not-alpha-first GL_HALF_FLOAT ;
 221 M: float-components          (component-type>type) not-alpha-first GL_FLOAT          ;
 222 M: byte-integer-components   (component-type>type) not-alpha-first GL_BYTE           ;
 223 M: ubyte-integer-components  (component-type>type) not-alpha-first GL_UNSIGNED_BYTE  ;
 224 M: short-integer-components  (component-type>type) not-alpha-first GL_SHORT          ;
 225 M: ushort-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
 226 M: int-integer-components    (component-type>type) not-alpha-first GL_INT            ;
 227 M: uint-integer-components   (component-type>type) not-alpha-first GL_UNSIGNED_INT   ;
 228
 229 M: u-5-5-5-1-components      (component-type>type)
 230     four-channel-alpha-first?
 231     [ GL_UNSIGNED_SHORT_1_5_5_5_REV ]
 232     [ GL_UNSIGNED_SHORT_5_5_5_1     ] if ;
 233
 234 M: u-5-6-5-components        (component-type>type) 2drop GL_UNSIGNED_SHORT_5_6_5 ;
 235
 236 M: u-10-10-10-2-components   (component-type>type)
 237     four-channel-alpha-first?
 238     [ GL_UNSIGNED_INT_2_10_10_10_REV ]
 239     [ GL_UNSIGNED_INT_10_10_10_2     ] if ;
 240
 241 M: u-24-components           (component-type>type)
 242     over DEPTH =
 243     [ 2drop GL_UNSIGNED_INT ]
 244     [ unsupported-component-order ] if ;
 245
 246 M: u-24-8-components         (component-type>type)
 247     over DEPTH-STENCIL =
 248     [ 2drop GL_UNSIGNED_INT_24_8 ]
 249     [ unsupported-component-order ] if ;
 250
 251 M: u-9-9-9-e5-components     (component-type>type)
 252     over BGR =
 253     [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ]
 254     [ unsupported-component-order ] if ;
 255
 256 M: float-11-11-10-components (component-type>type)
 257     over BGR =
 258     [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ]
 259     [ unsupported-component-order ] if ;
 260
 261 : image-data-format ( component-order component-type -- gl-format gl-type )
 262     [ (component-order>format) ] [ (component-type>type) ] 2bi ;
 263
 264 SLOT: display-list
 265
 266 : draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
 267
 268 GENERIC: draw-scaled-texture ( dim texture -- )
 269
 270 DEFER: make-texture
 271
 272 : (image-format) ( component-order component-type -- internal-format format type )
 273     [ image-internal-format ] [ image-data-format ] 2bi ;
 274
 275 : image-format ( image -- internal-format format type )
 276     [ component-order>> ] [ component-type>> ] bi (image-format) ;
 277
 278 <PRIVATE
 279
 280 TUPLE: single-texture < disposable image dim loc texture-coords texture display-list ;
 281
 282 : adjust-texture-dim ( dim -- dim' )
 283     non-power-of-2-textures? get [
 284         [ dup 1 = [ next-power-of-2 ] unless ] map
 285     ] unless ;
 286
 287 :: tex-image ( image bitmap -- )
 288     image image-format :> ( internal-format format type )
 289     GL_TEXTURE_2D 0 internal-format
 290     image dim>> adjust-texture-dim first2 0
 291     format type bitmap glTexImage2D ;
 292
 293 : tex-sub-image ( image -- )
 294     [ GL_TEXTURE_2D 0 0 0 ] dip
 295     [ dim>> first2 ]
 296     [ image-format nipd ]
 297     [ bitmap>> ] tri
 298     glTexSubImage2D ;
 299
 300 : init-texture ( -- )
 301     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
 302     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
 303     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
 304     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
 305
 306 : with-texturing ( quot -- )
 307     GL_TEXTURE_2D [
 308         GL_TEXTURE_BIT [
 309             GL_TEXTURE_COORD_ARRAY [
 310                 COLOR: white gl-color
 311                 call
 312             ] do-enabled-client-state
 313         ] do-attribs
 314     ] do-enabled ; inline
 315
 316 : texture-dim ( texture -- dim )
 317     [ dim>> ] [ image>> ] bi 2x?>> [ [ 2.0 / ] map ] when ;
 318
 319 : (draw-textured-rect) ( dim texture -- )
 320     [ loc>> ]
 321     [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
 322     [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
 323     swap gl-fill-rect ;
 324
 325 : set-blend-mode ( texture -- )
 326     image>> dup has-alpha?
 327     [ premultiplied-alpha?>> [ GL_ONE GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
 328     [ drop GL_BLEND glDisable ] if ;
 329
 330 : reset-blend-mode ( texture -- )
 331     image>> dup has-alpha?
 332     [ premultiplied-alpha?>> [ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
 333     [ drop GL_BLEND glEnable ] if ;
 334
 335 : draw-textured-rect ( dim texture -- )
 336     [
 337         [ set-blend-mode ]
 338         [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
 339         [ reset-blend-mode ] tri
 340     ] with-texturing ;
 341
 342 : texture-coords ( texture -- coords )
 343     [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
 344     [
 345         image>> upside-down?>>
 346         { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
 347         { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
 348     ] bi
 349     [ v* ] with map float-array{ } join ;
 350
 351 : make-texture-display-list ( texture -- dlist )
 352     GL_COMPILE [
 353         [ texture-dim ] keep draw-textured-rect
 354     ] make-dlist ;
 355
 356 : <single-texture> ( image loc -- texture )
 357     single-texture new-disposable
 358         swap >>loc
 359         swap [ >>image ] [ dim>> >>dim ] bi
 360     dup image>> dim>> product 0 = [
 361         dup texture-coords >>texture-coords
 362         dup image>> make-texture >>texture
 363         dup make-texture-display-list >>display-list
 364     ] unless ;
 365
 366 M: single-texture dispose*
 367     [ texture>> [ delete-texture ] when* ]
 368     [ display-list>> [ delete-dlist ] when* ] bi ;
 369
 370 M: single-texture draw-scaled-texture
 371     2dup dim>> = [ nip draw-texture ] [
 372         dup texture>> [ draw-textured-rect ] [ 2drop ] if
 373     ] if ;
 374
 375 TUPLE: multi-texture < disposable grid display-list loc ;
 376
 377 : image-locs ( image-grid -- loc-grid )
 378     [ first [ image-dim first ] map ]
 379     [ [ first image-dim second ] map ] bi
 380     [ cum-sum0 ] bi@ cartesian-product flip ;
 381
 382 : <texture-grid> ( image-grid loc -- grid )
 383     [ dup image-locs ] dip
 384     '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
 385
 386 : grid-has-alpha? ( grid -- ? )
 387     first first image>> has-alpha? ;
 388
 389 : make-textured-grid-display-list ( grid -- dlist )
 390     GL_COMPILE [
 391         [
 392             [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
 393             [ [ [ [ texture-dim ] keep (draw-textured-rect) ] each ] each ]
 394             [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
 395             GL_TEXTURE_2D 0 glBindTexture
 396         ] with-texturing
 397     ] make-dlist ;
 398
 399 : <multi-texture> ( image-grid loc -- multi-texture )
 400     [
 401         [ multi-texture new-disposable ] 2dip
 402         [ nip >>loc ] [ <texture-grid> >>grid ] 2bi
 403         dup grid>> make-textured-grid-display-list >>display-list
 404     ] with-destructors ;
 405
 406 M: multi-texture draw-scaled-texture nip draw-texture ;
 407
 408 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 409
 410 CONSTANT: max-texture-size { 512 512 }
 411
 412 PRIVATE>
 413
 414 : make-texture ( image -- id )
 415     ! We use glTexSubImage2D to work around the power of 2 texture size
 416     ! limitation
 417     gen-texture [
 418         GL_TEXTURE_BIT [
 419             GL_TEXTURE_2D swap glBindTexture
 420             non-power-of-2-textures? get
 421             [ dup bitmap>> tex-image ]
 422             [ [ f tex-image ] [ tex-sub-image ] bi ] if
 423         ] do-attribs
 424     ] keep ;
 425
 426 : <texture> ( image loc -- texture )
 427     over dim>> max-texture-size [ <= ] 2all?
 428     [ <single-texture> ]
 429     [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
 430
 431 : get-texture-float ( target level enum -- value )
 432     { float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline
 433
 434 : get-texture-int ( target level enum -- value )
 435     { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline