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 : (draw-gadget) ( gadget -- )
40 dup rect-loc translate
41 ! dup dup gadget-interior draw-interior
43 dup visible-children [ draw-gadget ] each
44 ! dup gadget-boundary draw-boundary
48 : change-clip ( gadget -- )
49 >absolute clip [ rect-intersect ] change ;
51 : clip-x/y ( loc dim -- x y )
53 [ second ] 2apply + world get rect-dim second swap - ;
55 : gl-set-clip ( loc dim -- )
56 [ clip-x/y ] keep first2 glScissor ;
58 : do-clip ( -- ) clip get rect-bounds gl-set-clip ;
60 : with-clipping ( gadget quot -- )
62 over change-clip do-clip call
63 r> clip set do-clip ; inline
65 : draw-gadget ( gadget -- )
67 { [ dup gadget-visible? not ] [ drop ] }
68 { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
69 { [ t ] [ [ (draw-gadget) ] with-clipping ] }
72 : (draw-world) ( world -- )
74 dup rect-dim init-gl draw-gadget
77 ! Pen paint properties
78 M: f draw-interior 2drop ;
79 M: f draw-boundary 2drop ;
85 : (solid) solid-color gl-color rect-dim >r origin get r> ;
87 M: solid draw-interior (solid) gl-fill-rect ;
89 M: solid draw-boundary (solid) gl-rect ;
92 TUPLE: gradient colors ;
94 M: gradient draw-interior
96 over gadget-orientation
103 TUPLE: polygon color points ;
105 : draw-polygon ( polygon quot -- )
106 >r dup polygon-color gl-color polygon-points r> each ;
109 M: polygon draw-boundary
110 [ gl-poly ] draw-polygon drop ;
112 M: polygon draw-interior
113 [ gl-fill-poly ] draw-polygon drop ;
115 : arrow-up { { { 3 0 } { 6 6 } { 0 6 } } } ;
116 : arrow-right { { { 0 0 } { 6 3 } { 0 6 } } } ;
117 : arrow-down { { { 0 0 } { 6 0 } { 3 6 } } } ;
118 : arrow-left { { { 0 3 } { 6 0 } { 6 6 } } } ;
120 : <polygon-gadget> ( color points -- gadget )
121 dup { 0 0 } [ max-dim vmax ] reduce
122 >r <polygon> <gadget> r> over set-rect-dim
123 [ set-gadget-interior ] keep ;