extra/opengl/opengl.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! Portions copyright (C) 2007 Eduardo Cavazos.
   3 ! Portions copyright (C) 2008 Joe Groff.
   4 ! See http://factorcode.org/license.txt for BSD license.
   5 USING: alien alien.c-types continuations kernel libc math macros
   6 namespaces math.vectors math.constants math.functions
   7 math.parser opengl.gl opengl.glu combinators arrays sequences
   8 splitting words byte-arrays assocs combinators.lib ;
   9 IN: opengl
  10
  11 : coordinates ( point1 point2 -- x1 y2 x2 y2 )
  12     [ first2 ] bi@ ;
  13
  14 : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
  15     [ first2 [ >fixnum ] bi@ ] bi@ ;
  16
  17 : gl-color ( color -- ) first4 glColor4d ; inline
  18
  19 : gl-clear-color ( color -- )
  20     first4 glClearColor ;
  21
  22 : gl-clear ( color -- )
  23     gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
  24
  25 : gl-error ( -- )
  26     glGetError dup zero? [
  27         "GL error: " over gluErrorString append throw
  28     ] unless drop ;
  29
  30 : do-state ( mode quot -- )
  31     swap glBegin call glEnd ; inline
  32
  33 : do-enabled ( what quot -- )
  34     over glEnable dip glDisable ; inline
  35 : do-enabled-client-state ( what quot -- )
  36     over glEnableClientState dip glDisableClientState ; inline
  37
  38 : words>values ( word/value-seq -- value-seq )
  39     [ dup word? [ execute ] [ ] if ] map ;
  40
  41 : (all-enabled) ( seq quot -- )
  42     over [ glEnable ] each dip [ glDisable ] each ; inline
  43 : (all-enabled-client-state) ( seq quot -- )
  44     over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
  45
  46 MACRO: all-enabled ( seq quot -- )
  47     >r words>values r> [ (all-enabled) ] 2curry ;
  48 MACRO: all-enabled-client-state ( seq quot -- )
  49     >r words>values r> [ (all-enabled-client-state) ] 2curry ;
  50
  51 : do-matrix ( mode quot -- )
  52     swap [ glMatrixMode glPushMatrix call ] keep
  53     glMatrixMode glPopMatrix ; inline
  54
  55 : gl-vertex ( point -- )
  56     dup length {
  57         { 2 [ first2 glVertex2d ] }
  58         { 3 [ first3 glVertex3d ] }
  59         { 4 [ first4 glVertex4d ] }
  60     } case ;
  61
  62 : gl-normal ( normal -- ) first3 glNormal3d ;
  63
  64 : gl-material ( face pname params -- )
  65     >c-float-array glMaterialfv ;
  66
  67 : gl-line ( a b -- )
  68     GL_LINES [ gl-vertex gl-vertex ] do-state ;
  69
  70 : gl-fill-rect ( loc ext -- )
  71     coordinates glRectd ;
  72
  73 : gl-rect ( loc ext -- )
  74     GL_FRONT_AND_BACK GL_LINE glPolygonMode
  75     >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
  76     GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
  77
  78 : (gl-poly) ( points state -- )
  79     [ [ gl-vertex ] each ] do-state ;
  80
  81 : gl-fill-poly ( points -- )
  82     dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
  83
  84 : gl-poly ( points -- )
  85     GL_LINE_LOOP (gl-poly) ;
  86
  87 : circle-steps ( steps -- angles )
  88     dup length v/n 2 pi * v*n ;
  89
  90 : unit-circle ( angles -- points1 points2 )
  91     [ [ sin ] map ] [ [ cos ] map ] bi ;
  92
  93 : adjust-points ( points1 points2 -- points1' points2' )
  94     [ [ 1 + 0.5 * ] map ] bi@ ;
  95
  96 : scale-points ( loc dim points1 points2 -- points )
  97     zip [ v* ] with map [ v+ ] with map ;
  98
  99 : circle-points ( loc dim steps -- points )
 100     circle-steps unit-circle adjust-points scale-points ;
 101
 102 : gl-circle ( loc dim steps -- )
 103     circle-points gl-poly ;
 104
 105 : gl-fill-circle ( loc dim steps -- )
 106     circle-points gl-fill-poly ;
 107
 108 : prepare-gradient ( direction dim -- v1 v2 )
 109     tuck v* [ v- ] keep ;
 110
 111 : gl-gradient ( direction colors dim -- )
 112     GL_QUAD_STRIP [
 113         swap >r prepare-gradient r>
 114         [ length dup 1- v/n ] keep [
 115             >r >r 2dup r> r> gl-color v*n
 116             dup gl-vertex v+ gl-vertex
 117         ] 2each 2drop
 118     ] do-state ;
 119
 120 : (gen-gl-object) ( quot -- id )
 121     >r 1 0 <uint> r> keep *uint ; inline
 122 : gen-texture ( -- id )
 123     [ glGenTextures ] (gen-gl-object) ;
 124 : gen-gl-buffer ( -- id )
 125     [ glGenBuffers ] (gen-gl-object) ;
 126
 127 : (delete-gl-object) ( id quot -- )
 128     >r 1 swap <uint> r> call ; inline
 129 : delete-texture ( id -- )
 130     [ glDeleteTextures ] (delete-gl-object) ;
 131 : delete-gl-buffer ( id -- )
 132     [ glDeleteBuffers ] (delete-gl-object) ;
 133
 134 : with-gl-buffer ( binding id quot -- )
 135     -rot dupd glBindBuffer
 136     [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
 137
 138 : with-array-element-buffers ( array-buffer element-buffer quot -- )
 139     -rot GL_ELEMENT_ARRAY_BUFFER swap [
 140         swap GL_ARRAY_BUFFER -rot with-gl-buffer
 141     ] with-gl-buffer ; inline
 142
 143 : <gl-buffer> ( target data hint -- id )
 144     pick gen-gl-buffer [ [
 145         >r dup byte-length swap r> glBufferData
 146     ] with-gl-buffer ] keep ;
 147
 148 : buffer-offset ( int -- alien )
 149     <alien> ; inline
 150
 151 : bind-texture-unit ( id target unit -- )
 152     glActiveTexture swap glBindTexture gl-error ;
 153
 154 : (set-draw-buffers) ( buffers -- )
 155     dup length swap >c-uint-array glDrawBuffers ;
 156
 157 MACRO: set-draw-buffers ( buffers -- )
 158     words>values [ (set-draw-buffers) ] curry ;
 159
 160 : do-attribs ( bits quot -- )
 161     swap glPushAttrib call glPopAttrib ; inline
 162
 163 : gl-look-at ( eye focus up -- )
 164     [ first3 ] tri@ gluLookAt ;
 165
 166 TUPLE: sprite loc dim dim2 dlist texture ;
 167
 168 : <sprite> ( loc dim dim2 -- sprite )
 169     f f sprite boa ;
 170
 171 : sprite-size2 ( sprite -- w h ) sprite-dim2 first2 ;
 172
 173 : sprite-width ( sprite -- w ) sprite-dim first ;
 174
 175 : gray-texture ( sprite pixmap -- id )
 176     gen-texture [
 177         GL_TEXTURE_BIT [
 178             GL_TEXTURE_2D swap glBindTexture
 179             >r >r GL_TEXTURE_2D 0 GL_RGBA r>
 180             sprite-size2 0 GL_LUMINANCE_ALPHA
 181             GL_UNSIGNED_BYTE r> glTexImage2D
 182         ] do-attribs
 183     ] keep ;
 184
 185 : gen-dlist ( -- id ) 1 glGenLists ;
 186
 187 : make-dlist ( type quot -- id )
 188     gen-dlist [ rot glNewList call glEndList ] keep ; inline
 189
 190 : init-texture ( -- )
 191     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
 192     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
 193     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
 194     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
 195
 196 : gl-translate ( point -- ) first2 0.0 glTranslated ;
 197
 198 : top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
 199
 200 : top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
 201
 202 : bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
 203
 204 : bottom-right 1 1 glTexCoord2i gl-vertex ; inline
 205
 206 : four-sides ( dim -- )
 207     dup top-left dup top-right dup bottom-right bottom-left ;
 208
 209 : draw-sprite ( sprite -- )
 210     dup sprite-loc gl-translate
 211     GL_TEXTURE_2D over sprite-texture glBindTexture
 212     init-texture
 213     GL_QUADS [ sprite-dim2 four-sides ] do-state
 214     GL_TEXTURE_2D 0 glBindTexture ;
 215
 216 : rect-vertices ( lower-left upper-right -- )
 217     GL_QUADS [
 218         over first2 glVertex2d
 219         dup first pick second glVertex2d
 220         dup first2 glVertex2d
 221         swap first swap second glVertex2d
 222     ] do-state ;
 223
 224 : make-sprite-dlist ( sprite -- id )
 225     GL_MODELVIEW [
 226         GL_COMPILE [ draw-sprite ] make-dlist
 227     ] do-matrix ;
 228
 229 : init-sprite ( texture sprite -- )
 230     [ set-sprite-texture ] keep
 231     [ make-sprite-dlist ] keep set-sprite-dlist ;
 232
 233 : delete-dlist ( id -- ) 1 glDeleteLists ;
 234
 235 : free-sprite ( sprite -- )
 236     dup sprite-dlist delete-dlist
 237     sprite-texture delete-texture ;
 238
 239 : free-sprites ( sprites -- )
 240     [ nip [ free-sprite ] when* ] assoc-each ;
 241
 242 : with-translation ( loc quot -- )
 243     GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
 244
 245 : gl-set-clip ( loc dim -- )
 246     fix-coordinates glScissor ;
 247
 248 : gl-viewport ( loc dim -- )
 249     fix-coordinates glViewport ;
 250
 251 : init-matrices ( -- )
 252     GL_PROJECTION glMatrixMode
 253     glLoadIdentity
 254     GL_MODELVIEW glMatrixMode
 255     glLoadIdentity ;