factor/library/ui/paint.factor

100 lines
2.6 KiB
Factor
Raw Normal View History

2005-01-31 14:02:09 -05:00
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables io kernel lists math matrices
2005-07-13 21:03:34 -04:00
namespaces sdl sequences strings styles ;
2005-02-27 03:48:27 -05:00
SYMBOL: clip
2005-03-01 22:19:26 -05:00
: >sdl-rect ( rectangle -- sdlrect )
[ shape-x ] keep [ shape-y ] keep [ shape-w ] keep shape-h
2005-03-01 22:19:26 -05:00
make-rect ;
2005-02-27 16:51:12 -05:00
: set-clip ( rect -- ? )
#! The top/left corner of the clip rectangle is the location
#! of the gadget on the screen. The bottom/right is the
#! intersected clip rectangle. Return f if the clip region
2005-02-27 16:51:12 -05:00
#! is an empty region.
surface get swap >sdl-rect SDL_SetClipRect ;
2005-02-27 16:51:12 -05:00
2005-02-27 03:48:27 -05:00
: with-clip ( shape quot -- )
2005-02-27 16:51:12 -05:00
#! All drawing done inside the quotation is clipped to the
2005-07-17 00:21:10 -04:00
#! shape's bounds.
2005-02-27 16:51:12 -05:00
[
2005-03-06 19:46:29 -05:00
>r screen-bounds clip [ intersect dup ] change set-clip
2005-07-17 00:21:10 -04:00
[ r> call ] [ r> 2drop ] ifte
2005-02-27 16:51:12 -05:00
] with-scope ; inline
2005-02-27 03:48:27 -05:00
2005-07-13 21:03:34 -04:00
GENERIC: draw-gadget* ( gadget -- )
2005-02-27 03:48:27 -05:00
: draw-gadget ( gadget -- )
2005-07-17 00:21:10 -04:00
dup gadget-visible? [
dup [
2005-07-13 21:03:34 -04:00
dup draw-gadget* dup [
gadget-children [ draw-gadget ] each
] with-trans
2005-07-17 00:21:10 -04:00
] with-clip
] [ drop ] ifte ;
2005-07-13 21:03:34 -04:00
2005-07-13 21:17:47 -04:00
: paint-prop* ( gadget key -- value )
swap gadget-paint ?hash ;
2005-07-13 21:03:34 -04:00
: paint-prop ( gadget key -- value )
over [
2005-07-17 02:49:07 -04:00
2dup paint-prop* dup
[ 2nip ] [ drop >r gadget-parent r> paint-prop ] ifte
2005-07-13 21:03:34 -04:00
] [
2drop f
] ifte ;
: set-paint-prop ( gadget value key -- )
2005-07-13 21:17:47 -04:00
pick gadget-paint ?set-hash swap set-gadget-paint ;
2005-07-13 21:03:34 -04:00
: fg ( gadget -- color )
dup reverse-video paint-prop
background foreground ? paint-prop ;
: bg ( gadget -- color )
dup reverse-video paint-prop [
foreground
] [
dup rollover paint-prop rollover-bg background ?
] ifte paint-prop ;
2005-07-17 02:49:07 -04:00
: 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 ;
2005-07-13 21:03:34 -04:00
2005-07-17 02:49:07 -04:00
M: gadget draw-gadget* ( gadget -- )
dup
dup interior paint-prop* draw-interior
dup boundary paint-prop* draw-boundary ;
2005-07-13 21:03:34 -04:00
2005-07-17 02:49:07 -04:00
: <plain-gadget> ( -- gadget )
<gadget> dup << solid f >> interior set-paint-prop ;
2005-07-13 21:03:34 -04:00
2005-07-17 02:49:07 -04:00
: <etched-gadget> ( -- gadget )
<plain-gadget> dup << solid f >> boundary set-paint-prop ;