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 colors accessors
9 generalizations locals specialized-arrays.float
10 specialized-arrays.uint ;
13 : color>raw ( object -- r g b a )
14 >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
16 : gl-color ( color -- ) color>raw glColor4d ; inline
18 : gl-clear-color ( color -- ) color>raw glClearColor ;
20 : gl-clear ( color -- )
21 gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
24 glGetError dup zero? [
25 "GL error: " over gluErrorString append throw
28 : do-enabled ( what quot -- )
29 over glEnable dip glDisable ; inline
31 : do-enabled-client-state ( what quot -- )
32 over glEnableClientState dip glDisableClientState ; inline
34 : words>values ( word/value-seq -- value-seq )
35 [ dup word? [ execute ] when ] map ;
37 : (all-enabled) ( seq quot -- )
38 over [ glEnable ] each dip [ glDisable ] each ; inline
40 : (all-enabled-client-state) ( seq quot -- )
41 [ dup [ glEnableClientState ] each ] dip
43 [ glDisableClientState ] each ; inline
45 MACRO: all-enabled ( seq quot -- )
46 [ words>values ] dip [ (all-enabled) ] 2curry ;
48 MACRO: all-enabled-client-state ( seq quot -- )
49 [ words>values ] dip [ (all-enabled-client-state) ] 2curry ;
51 : do-matrix ( mode quot -- )
52 swap [ glMatrixMode glPushMatrix call ] keep
53 glMatrixMode glPopMatrix ; inline
55 : gl-material ( face pname params -- )
56 float-array{ } like underlying>> glMaterialfv ;
58 : gl-vertex-pointer ( seq -- )
59 [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
61 : gl-color-pointer ( seq -- )
62 [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
64 : gl-texture-coord-pointer ( seq -- )
65 [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
67 : line-vertices ( a b -- )
68 [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
72 line-vertices GL_LINES 0 2 glDrawArrays ;
74 : (rect-vertices) ( dim -- vertices )
75 #! We use GL_LINE_STRIP with a duplicated first vertex
76 #! instead of GL_LINE_LOOP to work around a bug in Apple's
81 [ [ first 0.3 - ] [ second 0.3 - ] bi ]
82 [ second 0.3 - 0.5 swap ]
84 } cleave 10 float-array{ } nsequence ;
86 : rect-vertices ( dim -- )
87 (rect-vertices) gl-vertex-pointer ;
90 GL_LINE_STRIP 0 5 glDrawArrays ;
93 rect-vertices (gl-rect) ;
95 : (fill-rect-vertices) ( dim -- vertices )
101 } cleave 8 float-array{ } nsequence ;
103 : fill-rect-vertices ( dim -- )
104 (fill-rect-vertices) gl-vertex-pointer ;
106 : (gl-fill-rect) ( -- )
107 GL_QUADS 0 4 glDrawArrays ;
109 : gl-fill-rect ( dim -- )
110 fill-rect-vertices (gl-fill-rect) ;
112 : circle-steps ( steps -- angles )
113 dup length v/n 2 pi * v*n ;
115 : unit-circle ( angles -- points1 points2 )
116 [ [ sin ] map ] [ [ cos ] map ] bi ;
118 : adjust-points ( points1 points2 -- points1' points2' )
119 [ [ 1 + 0.5 * ] map ] bi@ ;
121 : scale-points ( loc dim points1 points2 -- points )
122 zip [ v* ] with map [ v+ ] with map ;
124 : circle-points ( loc dim steps -- points )
125 circle-steps unit-circle adjust-points scale-points ;
127 : close-path ( points -- points' )
130 : circle-vertices ( loc dim steps -- vertices )
131 #! We use GL_LINE_STRIP with a duplicated first vertex
132 #! instead of GL_LINE_LOOP to work around a bug in Apple's
134 circle-points close-path concat >float-array ;
136 : fill-circle-vertices ( loc dim steps -- vertices )
137 circle-points concat >float-array ;
139 : (gen-gl-object) ( quot -- id )
140 [ 1 0 <uint> ] dip keep *uint ; inline
142 : gen-texture ( -- id )
143 [ glGenTextures ] (gen-gl-object) ;
145 : gen-gl-buffer ( -- id )
146 [ glGenBuffers ] (gen-gl-object) ;
148 : (delete-gl-object) ( id quot -- )
149 [ 1 swap <uint> ] dip call ; inline
151 : delete-texture ( id -- )
152 [ glDeleteTextures ] (delete-gl-object) ;
154 : delete-gl-buffer ( id -- )
155 [ glDeleteBuffers ] (delete-gl-object) ;
157 : with-gl-buffer ( binding id quot -- )
158 -rot dupd glBindBuffer
159 [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
161 : with-array-element-buffers ( array-buffer element-buffer quot -- )
162 -rot GL_ELEMENT_ARRAY_BUFFER swap [
163 swap GL_ARRAY_BUFFER -rot with-gl-buffer
164 ] with-gl-buffer ; inline
166 : <gl-buffer> ( target data hint -- id )
167 pick gen-gl-buffer [ [
168 [ dup byte-length swap ] dip glBufferData
169 ] with-gl-buffer ] keep ;
171 : buffer-offset ( int -- alien )
174 : bind-texture-unit ( id target unit -- )
175 glActiveTexture swap glBindTexture gl-error ;
177 : (set-draw-buffers) ( buffers -- )
178 [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
180 MACRO: set-draw-buffers ( buffers -- )
181 words>values [ (set-draw-buffers) ] curry ;
183 : do-attribs ( bits quot -- )
184 swap glPushAttrib call glPopAttrib ; inline
186 : gl-look-at ( eye focus up -- )
187 [ first3 ] tri@ gluLookAt ;
189 TUPLE: sprite loc dim dim2 dlist texture ;
191 : <sprite> ( loc dim dim2 -- sprite )
194 : sprite-size2 ( sprite -- w h ) dim2>> first2 ;
196 : sprite-width ( sprite -- w ) dim>> first ;
198 : gray-texture ( sprite pixmap -- id )
201 GL_TEXTURE_2D swap glBindTexture
203 [ GL_TEXTURE_2D 0 GL_RGBA ] dip
204 sprite-size2 0 GL_LUMINANCE_ALPHA
210 : gen-dlist ( -- id ) 1 glGenLists ;
212 : make-dlist ( type quot -- id )
213 gen-dlist [ rot glNewList call glEndList ] keep ; inline
215 : init-texture ( -- )
216 GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
217 GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
218 GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
219 GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
221 : gl-translate ( point -- ) first2 0.0 glTranslated ;
223 : rect-texture-coords ( -- )
224 float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
226 : draw-sprite ( sprite -- )
227 GL_TEXTURE_COORD_ARRAY [
228 dup loc>> gl-translate
229 GL_TEXTURE_2D over texture>> glBindTexture
230 init-texture rect-texture-coords
231 dim2>> fill-rect-vertices
233 GL_TEXTURE_2D 0 glBindTexture
234 ] do-enabled-client-state ;
236 : make-sprite-dlist ( sprite -- id )
238 GL_COMPILE [ draw-sprite ] make-dlist
241 : init-sprite ( texture sprite -- )
243 dup make-sprite-dlist >>dlist drop ;
245 : delete-dlist ( id -- ) 1 glDeleteLists ;
247 : free-sprite ( sprite -- )
248 [ dlist>> delete-dlist ]
249 [ texture>> delete-texture ] bi ;
251 : free-sprites ( sprites -- )
252 [ nip [ free-sprite ] when* ] assoc-each ;
254 : with-translation ( loc quot -- )
255 GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
257 : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
258 [ first2 [ >fixnum ] bi@ ] bi@ ;
260 : gl-set-clip ( loc dim -- )
261 fix-coordinates glScissor ;
263 : gl-viewport ( loc dim -- )
264 fix-coordinates glViewport ;
266 : init-matrices ( -- )
267 GL_PROJECTION glMatrixMode
269 GL_MODELVIEW glMatrixMode