core/ui/opengl/utilities.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 ( color -- ) 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 : gl-vertex ( point -- ) first2 glVertex2d ; inline
  25
  26 : gl-line ( a b -- )
  27     GL_LINES [ gl-vertex gl-vertex ] do-state ;
  28
  29 : gl-fill-rect ( loc dim -- )
  30     [ first2 ] 2apply glRectd ;
  31
  32 : gl-rect ( loc dim -- )
  33     GL_FRONT_AND_BACK GL_LINE glPolygonMode
  34     >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
  35     GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
  36
  37 : (gl-poly) [ [ gl-vertex ] each ] do-state ;
  38
  39 : gl-fill-poly ( points -- )
  40     dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
  41
  42 : gl-poly ( points -- )
  43     GL_LINE_LOOP (gl-poly) ;
  44
  45 : prepare-gradient ( direction dim -- v1 v2 )
  46     tuck v* [ v- ] keep ;
  47
  48 : gl-gradient ( direction colors dim -- )
  49     GL_QUAD_STRIP [
  50         swap >r prepare-gradient r>
  51         [ length dup 1- v/n ] keep [
  52             >r >r 2dup r> r> gl-color v*n
  53             dup gl-vertex v+ gl-vertex
  54         ] 2each 2drop
  55     ] do-state ;
  56
  57 : gen-texture ( -- id )
  58     1 0 <uint> [ glGenTextures ] keep *uint ;
  59
  60 : save-attribs ( bits quot -- )
  61     swap glPushAttrib call glPopAttrib ; inline
  62
  63 TUPLE: sprite dlist texture loc dim dim2 ;
  64
  65 C: sprite ( loc dim dim2 -- sprite )
  66     [ set-sprite-dim2 ] keep
  67     [ set-sprite-dim ] keep
  68     [ set-sprite-loc ] keep ;
  69
  70 : sprite-size2 sprite-dim2 first2 ;
  71
  72 : sprite-width sprite-dim first ;
  73
  74 : gray-texture ( sprite pixmap -- id )
  75     gen-texture [
  76         GL_TEXTURE_BIT [
  77             GL_TEXTURE_2D swap glBindTexture
  78             >r >r GL_TEXTURE_2D 0 GL_RGBA r>
  79             sprite-size2 0 GL_LUMINANCE_ALPHA
  80             GL_UNSIGNED_BYTE r> glTexImage2D
  81         ] save-attribs
  82     ] keep ;
  83
  84 : gen-dlist ( -- id ) 1 glGenLists ;
  85
  86 : make-dlist ( type quot -- id )
  87     gen-dlist [ rot glNewList call glEndList ] keep ; inline
  88
  89 : init-texture ( -- )
  90     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
  91     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
  92     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
  93     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
  94
  95 : gl-translate ( point -- ) first2 0.0 glTranslated ;
  96
  97 : top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
  98
  99 : top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
 100
 101 : bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
 102
 103 : bottom-right 1 1 glTexCoord2i gl-vertex ; inline
 104
 105 : four-sides ( dim -- )
 106     dup top-left dup top-right dup bottom-right bottom-left ;
 107
 108 : draw-sprite ( sprite -- )
 109     dup sprite-loc gl-translate
 110     GL_TEXTURE_2D over sprite-texture glBindTexture
 111     init-texture
 112     GL_QUADS [ dup sprite-dim2 four-sides ] do-state
 113     dup sprite-dim { 1 0 } v*
 114     swap sprite-loc v- gl-translate
 115     GL_TEXTURE_2D 0 glBindTexture ;
 116
 117 : make-sprite-dlist ( sprite -- id )
 118     GL_MODELVIEW [
 119         GL_COMPILE [ draw-sprite ] make-dlist
 120     ] do-matrix ;
 121
 122 : init-sprite ( texture sprite -- )
 123     [ set-sprite-texture ] keep
 124     [ make-sprite-dlist ] keep set-sprite-dlist ;
 125
 126 : free-sprite ( sprite -- )
 127     dup sprite-dlist 1 glDeleteLists
 128     sprite-texture <uint> 1 swap glDeleteTextures ;
 129
 130 : free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ;
 131
 132 : with-translation ( loc quot -- )
 133     GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline