100 lines
2.7 KiB
Factor
100 lines
2.7 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: gadgets
|
|
USING: generic kernel lists math namespaces sdl ;
|
|
|
|
! A rectangle maps trivially to the shape protocol.
|
|
TUPLE: rectangle x y w h ;
|
|
M: rectangle shape-x rectangle-x ;
|
|
M: rectangle shape-y rectangle-y ;
|
|
M: rectangle shape-w rectangle-w ;
|
|
M: rectangle shape-h rectangle-h ;
|
|
|
|
: rect>screen ( shape -- x1 y1 x2 y2 )
|
|
[ rectangle-x x get + ] keep
|
|
[ rectangle-y y get + ] keep
|
|
[ rectangle-w pick + ] keep
|
|
rectangle-h pick + ;
|
|
|
|
: fix-neg ( a b c -- a+c b -c )
|
|
dup 0 < [ neg tuck >r >r + r> r> ] when ;
|
|
|
|
C: rectangle ( x y w h -- rect )
|
|
#! We handle negative w/h for convinience.
|
|
>r fix-neg >r fix-neg r> r>
|
|
[ set-rectangle-h ] keep
|
|
[ set-rectangle-w ] keep
|
|
[ set-rectangle-y ] keep
|
|
[ set-rectangle-x ] keep ;
|
|
|
|
M: rectangle move-shape ( x y rect -- )
|
|
tuck set-rectangle-y set-rectangle-x ;
|
|
|
|
M: rectangle resize-shape ( w h rect -- )
|
|
tuck set-rectangle-h set-rectangle-w ;
|
|
|
|
: rectangle-x-extents ( rect x0 -- x1 x2 )
|
|
>r dup shape-x r> + swap shape-w dupd + ;
|
|
|
|
: rectangle-y-extents ( rect y0 -- y1 y2 )
|
|
>r dup shape-y r> + swap shape-h dupd + ;
|
|
|
|
: inside-rect? ( point rect -- ? )
|
|
over shape-x over x get rectangle-x-extents 1 - between? >r
|
|
swap shape-y swap y get rectangle-y-extents 1 - between? r>
|
|
and ;
|
|
|
|
M: rectangle inside? ( point rect -- ? )
|
|
inside-rect? ;
|
|
|
|
M: rectangle draw-shape drop ;
|
|
|
|
! A rectangle only whose outline is visible.
|
|
TUPLE: hollow-rect ;
|
|
|
|
C: hollow-rect ( x y w h -- rect )
|
|
[ >r <rectangle> r> set-delegate ] keep ;
|
|
|
|
: hollow-rect ( shape -- )
|
|
#! Draw a hollow rect with the bounds of an arbitrary shape.
|
|
rect>screen >r 1 - r> 1 - fg rgb rectangleColor ;
|
|
|
|
M: hollow-rect draw-shape ( rect -- )
|
|
>r surface get r> hollow-rect ;
|
|
|
|
! A rectangle that is filled.
|
|
TUPLE: plain-rect ;
|
|
|
|
C: plain-rect ( x y w h -- rect )
|
|
[ >r <rectangle> r> set-delegate ] keep ;
|
|
|
|
: plain-rect ( shape -- )
|
|
#! Draw a filled rect with the bounds of an arbitrary shape.
|
|
rect>screen bg rgb boxColor ;
|
|
|
|
M: plain-rect draw-shape ( rect -- )
|
|
>r surface get r> plain-rect ;
|
|
|
|
! A rectangle that is filled with the background color and also
|
|
! has an outline.
|
|
TUPLE: etched-rect ;
|
|
|
|
C: etched-rect ( x y w h -- rect )
|
|
[ >r <rectangle> r> set-delegate ] keep ;
|
|
|
|
M: etched-rect draw-shape ( rect -- )
|
|
>r surface get r> 2dup plain-rect hollow-rect ;
|
|
|
|
! A rectangle that has a visible outline only if the rollover
|
|
! paint property is set.
|
|
SYMBOL: rollover?
|
|
|
|
TUPLE: roll-rect ;
|
|
|
|
C: roll-rect ( x y w h -- rect )
|
|
[ >r <rectangle> r> set-delegate ] keep ;
|
|
|
|
M: roll-rect draw-shape ( rect -- )
|
|
>r surface get r> 2dup
|
|
plain-rect rollover? get [ hollow-rect ] [ 2drop ] ifte ;
|