1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: math.rectangles math.vectors namespaces kernel accessors
4 assocs combinators sequences opengl opengl.gl colors
5 colors.constants ui.backend ui.gadgets ui.pens ;
10 SYMBOL: viewport-translation
12 : flip-rect ( rect -- loc dim )
14 [ { 1 -1 } v* ] dip { 0 -1 } v* v+
15 viewport-translation get v+
18 : do-clip ( -- ) clip get flip-rect gl-set-clip ;
20 : init-clip ( clip-rect -- )
23 [ { 0 1 } v* viewport-translation set ]
24 [ [ { 0 0 } ] dip gl-viewport ]
25 [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
30 : init-gl ( clip-rect -- )
31 GL_SMOOTH glShadeModel
32 GL_SCISSOR_TEST glEnable
34 GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
35 GL_VERTEX_ARRAY glEnableClientState
39 : clear-gl ( transparent? -- )
41 system-background-color
42 [ red>> ] [ green>> ] [ blue>> ] tri 0.0
44 GL_COLOR_BUFFER_BIT glClear
46 ! white gl-clear is broken w.r.t window resizing
47 ! Linux/PPC Radeon 9200
49 { 0 0 } clip get dim>> gl-fill-rect
52 GENERIC: draw-gadget* ( gadget -- )
54 M: gadget draw-gadget* drop ;
58 { 0 0 } origin set-global
60 : visible-children ( gadget -- seq )
61 [ clip get origin get vneg offset-rect ] dip children-on ;
63 : translate ( rect/point -- ) loc>> origin [ v+ ] change ;
65 GENERIC: draw-children ( gadget -- )
67 ! For gadget selection
68 SYMBOL: selected-gadgets
70 SYMBOL: selection-background
72 GENERIC: selected-children ( gadget -- assoc/f selection-background )
74 M: gadget selected-children drop f f ;
81 GENERIC: gadget-background ( gadget -- color )
83 M: gadget gadget-background dup interior>> pen-background ;
85 GENERIC: gadget-foreground ( gadget -- color )
87 M: gadget gadget-foreground dup interior>> pen-foreground ;
91 : draw-selection-background ( gadget -- )
92 selection-background get background set
93 selection-background get gl-color
94 [ { 0 0 } ] dip dim>> gl-fill-rect ;
96 : draw-standard-background ( object -- )
97 dup interior>> dup [ draw-interior ] [ 2drop ] if ;
99 : draw-background ( gadget -- )
102 dup selected-gadgets get key?
103 [ draw-selection-background ]
104 [ draw-standard-background ] if
105 ] [ draw-gadget* ] bi
108 : draw-border ( object -- )
110 origin get [ draw-boundary ] with-translation
115 : (draw-gadget) ( gadget -- )
116 dup loc>> origin get v+ origin [
117 [ draw-background ] [ draw-children ] [ draw-border ] tri
120 : >absolute ( rect -- rect )
121 origin get offset-rect ;
123 : change-clip ( gadget -- )
124 >absolute clip [ rect-intersect ] change ;
126 : with-clipping ( gadget quot -- )
127 clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
129 : draw-gadget ( gadget -- )
131 { [ dup visible?>> not ] [ drop ] }
132 { [ dup clipped?>> not ] [ (draw-gadget) ] }
133 [ [ (draw-gadget) ] with-clipping ]
136 M: gadget draw-children
140 [ selected-children ]
141 [ gadget-background ]
142 [ gadget-foreground ]
146 [ [ selected-gadgets set ] when* ]
147 [ [ selection-background set ] when* ]
148 [ [ background set ] when* ]
149 [ [ foreground set ] when* ]
155 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
157 CONSTANT: panel-background-color
165 CONSTANT: focus-border-color COLOR: dark-gray