1 ! Copyright (C) 2005, 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays freetype generic hashtables io kernel
4 math namespaces opengl sequences strings styles
11 GL_PROJECTION glMatrixMode
13 GL_MODELVIEW glMatrixMode
15 { 0 0 } over <rect> clip set
16 dup first2 0 0 2swap glViewport
17 0 over first2 0 gluOrtho2D
18 first2 0 0 2swap glScissor
19 GL_SMOOTH glShadeModel
21 GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
22 GL_SCISSOR_TEST glEnable
23 1.0 1.0 1.0 1.0 glClearColor
24 GL_COLOR_BUFFER_BIT glClear ;
26 GENERIC: draw-gadget* ( gadget -- )
28 M: gadget draw-gadget* drop ;
30 GENERIC: draw-interior ( gadget interior -- )
32 GENERIC: draw-boundary ( gadget boundary -- )
34 : visible-children ( gadget -- seq ) clip get swap children-on ;
38 : with-translation ( loc quot -- )
39 over translate over gl-translate
41 vneg dup translate gl-translate ; inline
43 : (draw-gadget) ( gadget -- )
45 dup dup gadget-interior draw-interior
47 dup visible-children [ draw-gadget ] each
48 dup gadget-boundary draw-boundary
51 : change-clip ( gadget -- )
52 >absolute clip [ rect-intersect ] change ;
54 : clip-x/y ( loc dim -- x y )
56 [ second ] 2apply + world get rect-dim second swap - ;
58 : gl-set-clip ( loc dim -- )
59 [ clip-x/y ] keep first2 glScissor ;
61 : do-clip ( -- ) clip get rect-bounds gl-set-clip ;
63 : with-clipping ( gadget quot -- )
65 over change-clip do-clip call
66 r> clip set do-clip ; inline
68 : draw-gadget ( gadget -- )
70 { [ dup gadget-visible? not ] [ drop ] }
71 { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
72 { [ t ] [ [ (draw-gadget) ] with-clipping ] }
75 : (draw-world) ( world -- )
77 dup rect-dim init-gl draw-gadget
80 ! Pen paint properties
81 M: f draw-interior 2drop ;
82 M: f draw-boundary 2drop ;
88 M: solid draw-interior
89 solid-color gl-color rect-dim gl-fill-rect ;
91 M: solid draw-boundary
92 solid-color gl-color rect-dim gl-rect ;
95 TUPLE: gradient colors ;
97 M: gradient draw-interior
98 over gadget-orientation swap gradient-colors rot rect-dim
102 TUPLE: polygon color points ;
104 : draw-polygon ( polygon quot -- )
105 >r dup polygon-color gl-color polygon-points r> each ; inline
107 M: polygon draw-boundary
108 [ gl-poly ] draw-polygon drop ;
110 M: polygon draw-interior
111 [ gl-fill-poly ] draw-polygon drop ;
113 : arrow-up { { { 3 0 } { 6 6 } { 0 6 } } } ;
114 : arrow-right { { { 0 0 } { 6 3 } { 0 6 } } } ;
115 : arrow-down { { { 0 0 } { 6 0 } { 3 6 } } } ;
116 : arrow-left { { { 0 3 } { 6 0 } { 6 6 } } } ;
118 : <polygon-gadget> ( color points -- gadget )
119 dup { 0 0 } [ max-dim vmax ] reduce
120 >r <polygon> <gadget> r> over set-rect-dim
121 [ set-gadget-interior ] keep ;