1 ! Copyright (C) 2005, 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: alien errors io kernel math namespaces opengl
7 : gl-color ( color -- ) first4 glColor4d ; inline
10 glGetError dup zero? [
11 "GL error: " write dup gluErrorString print flush
14 : do-state ( what quot -- )
15 swap glBegin call glEnd ; inline
17 : do-enabled ( what quot -- )
18 over glEnable swap slip glDisable ; inline
20 : do-matrix ( mode quot -- )
21 swap [ glMatrixMode glPushMatrix call ] keep
22 glMatrixMode glPopMatrix ; inline
24 : gl-vertex ( point -- ) first2 glVertex2d ; inline
27 GL_LINES [ gl-vertex gl-vertex ] do-state ;
29 : gl-fill-rect ( loc dim -- )
30 [ first2 ] 2apply glRectd ;
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 ;
37 : (gl-poly) [ [ gl-vertex ] each ] do-state ;
39 : gl-fill-poly ( points -- )
40 dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
42 : gl-poly ( points -- )
43 GL_LINE_LOOP (gl-poly) ;
45 : prepare-gradient ( direction dim -- v1 v2 )
48 : gl-gradient ( direction colors dim -- )
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
57 : gen-texture ( -- id )
58 1 0 <uint> [ glGenTextures ] keep *uint ;
60 : save-attribs ( bits quot -- )
61 swap glPushAttrib call glPopAttrib ; inline
63 TUPLE: sprite dlist texture loc dim dim2 ;
65 C: sprite ( loc dim dim2 -- sprite )
66 [ set-sprite-dim2 ] keep
67 [ set-sprite-dim ] keep
68 [ set-sprite-loc ] keep ;
70 : sprite-size2 sprite-dim2 first2 ;
72 : sprite-width sprite-dim first ;
74 : gray-texture ( sprite pixmap -- id )
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
84 : gen-dlist ( -- id ) 1 glGenLists ;
86 : make-dlist ( type quot -- id )
87 gen-dlist [ rot glNewList call glEndList ] keep ; inline
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 ;
95 : gl-translate ( point -- ) first2 0.0 glTranslated ;
97 : top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
99 : top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
101 : bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
103 : bottom-right 1 1 glTexCoord2i gl-vertex ; inline
105 : four-sides ( dim -- )
106 dup top-left dup top-right dup bottom-right bottom-left ;
108 : draw-sprite ( sprite -- )
109 dup sprite-loc gl-translate
110 GL_TEXTURE_2D over sprite-texture glBindTexture
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 ;
117 : make-sprite-dlist ( sprite -- id )
119 GL_COMPILE [ draw-sprite ] make-dlist
122 : init-sprite ( texture sprite -- )
123 [ set-sprite-texture ] keep
124 [ make-sprite-dlist ] keep set-sprite-dlist ;
126 : free-sprite ( sprite -- )
127 dup sprite-dlist 1 glDeleteLists
128 sprite-texture <uint> 1 swap glDeleteTextures ;
130 : free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ;
132 : with-translation ( loc quot -- )
133 GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline