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