1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types arrays hashtables io kernel
4 math namespaces opengl opengl.gl opengl.glu sequences strings
5 vectors combinators math.vectors ui.gadgets colors
6 math.order math.geometry.rect locals specialized-arrays.float ;
11 SYMBOL: viewport-translation
13 : flip-rect ( rect -- loc dim )
15 [ { 1 -1 } v* ] dip { 0 -1 } v* v+
16 viewport-translation get v+
19 : do-clip ( -- ) clip get flip-rect gl-set-clip ;
21 : init-clip ( clip-rect -- )
24 [ { 0 1 } v* viewport-translation set ]
25 [ [ { 0 0 } ] dip gl-viewport ]
26 [ [ 0 ] dip first2 0 gluOrtho2D ] tri
31 : init-gl ( clip-rect -- )
32 GL_SMOOTH glShadeModel
33 GL_SCISSOR_TEST glEnable
35 GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
36 GL_VERTEX_ARRAY glEnableClientState
39 ! white gl-clear is broken w.r.t window resizing
40 ! Linux/PPC Radeon 9200
42 clip get dim>> gl-fill-rect ;
44 GENERIC: draw-gadget* ( gadget -- )
46 M: gadget draw-gadget* drop ;
48 GENERIC: draw-interior ( gadget interior -- )
50 GENERIC: draw-boundary ( gadget boundary -- )
54 { 0 0 } origin set-global
56 : visible-children ( gadget -- seq )
57 clip get origin get vneg offset-rect swap children-on ;
59 : translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
63 : (draw-gadget) ( gadget -- )
67 origin get [ dupd draw-interior ] with-translation
70 dup visible-children [ draw-gadget ] each
72 origin get [ dupd draw-boundary ] with-translation
77 : >absolute ( rect -- rect )
78 origin get offset-rect ;
80 : change-clip ( gadget -- )
81 >absolute clip [ rect-intersect ] change ;
83 : with-clipping ( gadget quot -- )
84 clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
86 : draw-gadget ( gadget -- )
88 { [ dup visible?>> not ] [ drop ] }
89 { [ dup clipped?>> not ] [ (draw-gadget) ] }
90 [ [ (draw-gadget) ] with-clipping ]
93 ! A pen that caches vertex arrays, etc
94 TUPLE: caching-pen last-dim ;
96 GENERIC: recompute-pen ( gadget pen -- )
98 : compute-pen ( gadget pen -- )
99 2dup [ dim>> ] [ last-dim>> ] bi* = [
102 [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
106 TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
108 : <solid> ( color -- solid ) solid new swap >>color ;
110 M: solid recompute-pen
112 [ (fill-rect-vertices) >>interior-vertices ]
113 [ (rect-vertices) >>boundary-vertices ]
119 : (solid) ( gadget pen -- )
120 [ compute-pen ] [ color>> gl-color ] bi ;
124 M: solid draw-interior
125 [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
128 M: solid draw-boundary
129 [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
133 TUPLE: gradient < caching-pen colors last-vertices last-colors ;
135 : <gradient> ( colors -- gradient ) gradient new swap >>colors ;
139 :: gradient-vertices ( direction dim colors -- seq )
140 direction dim v* dim over v- swap
141 colors length dup 1- v/n [ v*n ] with map
142 swap [ over v+ 2array ] curry map
143 concat concat >float-array ;
145 : gradient-colors ( colors -- seq )
146 [ >rgba-components 4array dup 2array ] map concat concat
149 M: gradient recompute-pen ( gadget gradient -- )
150 [ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi
151 [ gradient-vertices >>last-vertices ]
152 [ gradient-colors >>last-colors ]
155 : draw-gradient ( colors -- )
157 [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
158 ] do-enabled-client-state ;
162 M: gradient draw-interior
165 [ last-vertices>> gl-vertex-pointer ]
166 [ last-colors>> gl-color-pointer ]
167 [ colors>> draw-gradient ]
177 : <polygon> ( color points -- polygon )
178 dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
181 M: polygon draw-boundary
184 [ boundary-vertices>> gl-vertex-pointer ]
185 [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
188 M: polygon draw-interior
191 [ interior-vertices>> gl-vertex-pointer ]
192 [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
195 CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } }
196 CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
197 CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } }
198 CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } }
199 CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
201 : <polygon-gadget> ( color points -- gadget )
203 [ <polygon> <gadget> ] dip >>dim