! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables kernel lists math matrices namespaces
-sequences vectors ;
+sequences styles vectors ;
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
{ 0 0 0 } dup <rectangle> over set-delegate
t over set-gadget-visible? ;
-TUPLE: plain-gadget ;
-
-C: plain-gadget ( -- gadget )
- <gadget> over set-delegate ;
-
-TUPLE: etched-gadget ;
-
-C: etched-gadget ( -- gadget )
- <gadget> over set-delegate ;
-
DEFER: add-invalid
: invalidate ( gadget -- )
] with-clip
] [ drop ] ifte ;
-M: gadget draw-gadget* ( gadget -- ) drop ;
-
: paint-prop* ( gadget key -- value )
swap gadget-paint ?hash ;
: paint-prop ( gadget key -- value )
over [
- 2dup paint-prop* dup [
- 2nip
- ] [
- drop >r gadget-parent r> paint-prop
- ] ifte
+ 2dup paint-prop* dup
+ [ 2nip ] [ drop >r gadget-parent r> paint-prop ] ifte
] [
2drop f
] ifte ;
dup rollover paint-prop rollover-bg background ?
] ifte paint-prop ;
-: plain-rect ( shape -- )
- #! Draw a filled rect with the bounds of an arbitrary shape.
- [ rect>screen ] keep bg rgb boxColor ;
+: filled-rect
+ >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
+
+: etched-rect
+ >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
+ fg rgb rectangleColor ;
+
+! Paint properties
+SYMBOL: interior
+SYMBOL: boundary
+
+GENERIC: draw-interior ( gadget interior -- )
+GENERIC: draw-boundary ( gadget boundary -- )
+
+M: f draw-interior 2drop ;
+M: f draw-boundary 2drop ;
+
+TUPLE: solid ;
+
+M: solid draw-interior
+ drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
+
+M: solid draw-boundary
+ drop >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
+ fg rgb rectangleColor ;
-M: plain-gadget draw-gadget* ( gadget -- )
- >r surface get r> plain-rect ;
+M: gadget draw-gadget* ( gadget -- )
+ dup
+ dup interior paint-prop* draw-interior
+ dup boundary paint-prop* draw-boundary ;
-: hollow-rect ( shape -- )
- #! Draw a hollow rect with the bounds of an arbitrary shape.
- [ rect>screen >r 1 - r> 1 - ] keep fg rgb rectangleColor ;
+: <plain-gadget> ( -- gadget )
+ <gadget> dup << solid f >> interior set-paint-prop ;
-M: etched-gadget draw-gadget* ( gadget -- )
- >r surface get r> 2dup plain-rect hollow-rect ;
+: <etched-gadget> ( -- gadget )
+ <plain-gadget> dup << solid f >> boundary set-paint-prop ;