70 lines
1.8 KiB
Factor
70 lines
1.8 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: gadgets
|
|
USING: generic kernel lists math matrices namespaces sdl styles
|
|
vectors ;
|
|
|
|
TUPLE: rectangle loc dim ;
|
|
|
|
M: rectangle shape-loc rectangle-loc ;
|
|
M: rectangle set-shape-loc set-rectangle-loc ;
|
|
|
|
M: rectangle shape-dim rectangle-dim ;
|
|
M: rectangle set-shape-dim set-rectangle-dim ;
|
|
|
|
: screen-bounds ( shape -- rect )
|
|
shape-bounds >r origin v+ r> <rectangle> ;
|
|
|
|
M: rectangle inside? ( loc rect -- ? )
|
|
screen-bounds shape-bounds
|
|
>r v- { 0 0 0 } r> vbetween? conj ;
|
|
|
|
M: rectangle draw-shape drop ;
|
|
|
|
: intersect ( shape shape -- rect )
|
|
>r shape-extent r> shape-extent
|
|
swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
|
|
<rectangle> ;
|
|
|
|
: rect>screen ( shape -- x1 y1 x2 y2 )
|
|
[ shape-x x get + ] keep
|
|
[ shape-y y get + ] keep
|
|
[ shape-w pick + ] keep
|
|
shape-h pick + ;
|
|
|
|
! A rectangle only whose outline is visible.
|
|
TUPLE: hollow-rect ;
|
|
|
|
C: hollow-rect ( loc dim -- 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 ( loc dim -- 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 ( loc dim -- rect )
|
|
[ >r <rectangle> r> set-delegate ] keep ;
|
|
|
|
M: etched-rect draw-shape ( rect -- )
|
|
>r surface get r> 2dup plain-rect hollow-rect ;
|