library/ui/opengl/opengl-utils.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: opengl
   4 USING: alien errors io kernel math namespaces opengl
   5 sequences ;
   6
   7 : gl-color ( colorspec -- ) first4 glColor4d ; inline
   8
   9 : gl-error ( -- )
  10     glGetError dup zero? [
  11         "GL error: " write dup gluErrorString print flush
  12     ] unless drop ;
  13
  14 : do-state ( what quot -- )
  15     swap glBegin call glEnd ; inline
  16
  17 : do-enabled ( what quot -- )
  18     over glEnable swap slip glDisable ; inline
  19
  20 : do-matrix ( mode quot -- )
  21     swap [ glMatrixMode glPushMatrix call ] keep
  22     glMatrixMode glPopMatrix ; inline
  23
  24 : top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
  25
  26 : top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
  27
  28 : bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
  29
  30 : gl-vertex first2 glVertex2i ; inline
  31
  32 : bottom-right 1 1 glTexCoord2i gl-vertex ; inline
  33
  34 : four-sides ( dim -- )
  35     dup top-left dup top-right dup bottom-right bottom-left ;
  36
  37 : gl-line ( a b -- )
  38     GL_LINES [ gl-vertex gl-vertex ] do-state ;
  39
  40 : gl-fill-rect ( dim -- )
  41     #! Draws a two-dimensional box.
  42     GL_QUADS [ four-sides ] do-state ;
  43
  44 : gl-rect ( dim -- )
  45     #! Draws a two-dimensional box.
  46     GL_FRONT_AND_BACK GL_LINE glPolygonMode
  47     GL_MODELVIEW [
  48         0.5 0.5 0.0 glTranslated { 1 1 } v-
  49         GL_QUADS [ dup four-sides top-left ] do-state
  50     ] do-matrix
  51     GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
  52
  53 : (gl-poly) [ [ gl-vertex ] each ] do-state ;
  54
  55 : gl-fill-poly ( points -- )
  56     #! Draw a filled polygon.
  57     dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
  58
  59 : gl-poly ( points -- )
  60     #! Draw a polygon.
  61     GL_LINE_LOOP (gl-poly) ;
  62
  63 : prepare-gradient ( direction dim -- v1 v2 )
  64     tuck v* [ v- ] keep ;
  65
  66 : gl-gradient ( direction colors dim -- )
  67     #! Draws a quad strip.
  68     GL_QUAD_STRIP [
  69         swap >r prepare-gradient r>
  70         [ length dup 1- v/n ] keep [
  71             >r >r 2dup r> r> gl-color v*n
  72             dup gl-vertex v+ gl-vertex
  73         ] 2each 2drop
  74     ] do-state ;
  75
  76 : gen-texture ( -- id )
  77     #! Generate texture ID.
  78     1 0 <uint> [ glGenTextures ] keep *uint ;
  79
  80 : save-attribs ( bits quot -- )
  81     swap glPushAttrib call glPopAttrib ; inline
  82
  83 ! A sprite is a texture and a display list.
  84 TUPLE: sprite dlist texture loc dim dim2 ;
  85
  86 C: sprite ( loc dim dim2 -- sprite )
  87     [ set-sprite-dim2 ] keep
  88     [ set-sprite-dim ] keep
  89     [ set-sprite-loc ] keep ;
  90
  91 : sprite-size2 sprite-dim2 first2 ;
  92
  93 : sprite-width sprite-dim first ;
  94
  95 : gray-texture ( sprite buffer -- id )
  96     #! Given a buffer holding a width x height (powers of two)
  97     #! grayscale texture, bind it and return the ID.
  98     gen-texture [
  99         GL_TEXTURE_BIT [
 100             GL_TEXTURE_2D swap glBindTexture
 101             >r >r GL_TEXTURE_2D 0 GL_RGBA r>
 102             sprite-size2 0 GL_LUMINANCE_ALPHA
 103             GL_UNSIGNED_BYTE r> glTexImage2D
 104         ] save-attribs
 105     ] keep ;
 106
 107 : gen-dlist ( -- id )
 108     #! Generate display list ID.
 109     1 glGenLists ;
 110
 111 : make-dlist ( type quot -- id )
 112     #! Make a display list.
 113     gen-dlist [ rot glNewList call glEndList ] keep ; inline
 114
 115 : init-texture ( -- )
 116     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
 117     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
 118     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
 119     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
 120
 121 : gl-translate ( point -- ) first2 0.0 glTranslated ;
 122
 123 : draw-sprite ( sprite -- )
 124     dup sprite-loc gl-translate
 125     GL_TEXTURE_2D over sprite-texture glBindTexture
 126     init-texture
 127     dup sprite-dim2 gl-fill-rect
 128     dup sprite-dim { 1 0 } v*
 129     swap sprite-loc v- gl-translate
 130     GL_TEXTURE_2D 0 glBindTexture ;
 131
 132 : make-sprite-dlist ( sprite -- id )
 133     GL_MODELVIEW [
 134         GL_COMPILE [ draw-sprite ] make-dlist
 135     ] do-matrix ;
 136
 137 : init-sprite ( texture sprite -- )
 138     [ set-sprite-texture ] keep
 139     [ make-sprite-dlist ] keep set-sprite-dlist ;
 140
 141 : free-sprite ( sprite -- )
 142     dup sprite-dlist 1 glDeleteLists
 143     sprite-texture <uint> 1 swap glDeleteTextures ;
 144
 145 : free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ;