UI paint cleanups
parent
06aee28239
commit
9bcde6657d
|
@ -10,6 +10,9 @@ IN: styles
|
||||||
: green [ 0 255 0 ] ;
|
: green [ 0 255 0 ] ;
|
||||||
: blue [ 0 0 255 ] ;
|
: blue [ 0 0 255 ] ;
|
||||||
|
|
||||||
|
SYMBOL: filled
|
||||||
|
SYMBOL: etched
|
||||||
|
|
||||||
SYMBOL: foreground ! Used for text and outline shapes.
|
SYMBOL: foreground ! Used for text and outline shapes.
|
||||||
SYMBOL: background ! Used for filled shapes.
|
SYMBOL: background ! Used for filled shapes.
|
||||||
SYMBOL: rollover-bg
|
SYMBOL: rollover-bg
|
||||||
|
|
|
@ -40,3 +40,6 @@ sequences io sequences styles ;
|
||||||
dup [ button-update ] [ mouse-leave ] set-action
|
dup [ button-update ] [ mouse-leave ] set-action
|
||||||
dup [ button-update ] [ mouse-enter ] set-action
|
dup [ button-update ] [ mouse-enter ] set-action
|
||||||
[ drop ] [ drag 1 ] set-action ;
|
[ drop ] [ drag 1 ] set-action ;
|
||||||
|
|
||||||
|
: <button> ( label quot -- button )
|
||||||
|
>r <label> line-border dup r> button-gestures ;
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: generic hashtables kernel lists math matrices namespaces
|
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
|
! A gadget is a shape, a paint, a mapping of gestures to
|
||||||
! actions, and a reference to the gadget's parent. A gadget
|
! actions, and a reference to the gadget's parent. A gadget
|
||||||
|
@ -17,16 +17,6 @@ C: gadget ( -- gadget )
|
||||||
{ 0 0 0 } dup <rectangle> over set-delegate
|
{ 0 0 0 } dup <rectangle> over set-delegate
|
||||||
t over set-gadget-visible? ;
|
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
|
DEFER: add-invalid
|
||||||
|
|
||||||
: invalidate ( gadget -- )
|
: invalidate ( gadget -- )
|
||||||
|
|
|
@ -36,18 +36,13 @@ GENERIC: draw-gadget* ( gadget -- )
|
||||||
] with-clip
|
] with-clip
|
||||||
] [ drop ] ifte ;
|
] [ drop ] ifte ;
|
||||||
|
|
||||||
M: gadget draw-gadget* ( gadget -- ) drop ;
|
|
||||||
|
|
||||||
: paint-prop* ( gadget key -- value )
|
: paint-prop* ( gadget key -- value )
|
||||||
swap gadget-paint ?hash ;
|
swap gadget-paint ?hash ;
|
||||||
|
|
||||||
: paint-prop ( gadget key -- value )
|
: paint-prop ( gadget key -- value )
|
||||||
over [
|
over [
|
||||||
2dup paint-prop* dup [
|
2dup paint-prop* dup
|
||||||
2nip
|
[ 2nip ] [ drop >r gadget-parent r> paint-prop ] ifte
|
||||||
] [
|
|
||||||
drop >r gadget-parent r> paint-prop
|
|
||||||
] ifte
|
|
||||||
] [
|
] [
|
||||||
2drop f
|
2drop f
|
||||||
] ifte ;
|
] ifte ;
|
||||||
|
@ -66,16 +61,39 @@ M: gadget draw-gadget* ( gadget -- ) drop ;
|
||||||
dup rollover paint-prop rollover-bg background ?
|
dup rollover paint-prop rollover-bg background ?
|
||||||
] ifte paint-prop ;
|
] ifte paint-prop ;
|
||||||
|
|
||||||
: plain-rect ( shape -- )
|
: filled-rect
|
||||||
#! Draw a filled rect with the bounds of an arbitrary shape.
|
>r surface get r> [ rect>screen ] keep bg rgb boxColor ;
|
||||||
[ rect>screen ] keep bg rgb boxColor ;
|
|
||||||
|
|
||||||
M: plain-gadget draw-gadget* ( gadget -- )
|
: etched-rect
|
||||||
>r surface get r> plain-rect ;
|
>r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
|
||||||
|
fg rgb rectangleColor ;
|
||||||
|
|
||||||
: hollow-rect ( shape -- )
|
! Paint properties
|
||||||
#! Draw a hollow rect with the bounds of an arbitrary shape.
|
SYMBOL: interior
|
||||||
[ rect>screen >r 1 - r> 1 - ] keep fg rgb rectangleColor ;
|
SYMBOL: boundary
|
||||||
|
|
||||||
M: etched-gadget draw-gadget* ( gadget -- )
|
GENERIC: draw-interior ( gadget interior -- )
|
||||||
>r surface get r> 2dup plain-rect hollow-rect ;
|
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: gadget draw-gadget* ( gadget -- )
|
||||||
|
dup
|
||||||
|
dup interior paint-prop* draw-interior
|
||||||
|
dup boundary paint-prop* draw-boundary ;
|
||||||
|
|
||||||
|
: <plain-gadget> ( -- gadget )
|
||||||
|
<gadget> dup << solid f >> interior set-paint-prop ;
|
||||||
|
|
||||||
|
: <etched-gadget> ( -- gadget )
|
||||||
|
<plain-gadget> dup << solid f >> boundary set-paint-prop ;
|
||||||
|
|
Loading…
Reference in New Issue