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
|
2005-02-26 02:11:25 -05:00
|
|
|
USING: generic hashtables kernel lists math namespaces sdl
|
2005-03-01 22:11:08 -05:00
|
|
|
sdl-gfx sdl-ttf sdl-video stdio strings ;
|
2005-01-31 14:02:09 -05:00
|
|
|
|
|
|
|
! The painting protocol. Painting is controlled by various
|
|
|
|
! dynamically-scoped variables.
|
|
|
|
|
|
|
|
! "Paint" is a namespace containing some or all of these values.
|
2005-02-03 22:21:51 -05:00
|
|
|
|
2005-02-05 11:52:24 -05:00
|
|
|
: paint-property ( gadget key -- value )
|
|
|
|
swap gadget-paint hash ;
|
|
|
|
|
|
|
|
: set-paint-property ( gadget value key -- )
|
|
|
|
rot gadget-paint set-hash ;
|
|
|
|
|
2005-02-03 22:21:51 -05:00
|
|
|
! Colors are lists of three integers, 0..255.
|
|
|
|
SYMBOL: foreground ! Used for text and outline shapes.
|
|
|
|
SYMBOL: background ! Used for filled shapes.
|
2005-03-01 18:55:25 -05:00
|
|
|
SYMBOL: reverse-video
|
|
|
|
|
|
|
|
: fg reverse-video get background foreground ? get ;
|
|
|
|
: bg reverse-video get foreground background ? get ;
|
2005-02-03 22:21:51 -05:00
|
|
|
|
2005-02-02 22:00:46 -05:00
|
|
|
SYMBOL: font ! a list of two elements, a font name and size.
|
2005-01-31 14:02:09 -05:00
|
|
|
|
2005-02-02 22:00:46 -05:00
|
|
|
GENERIC: draw-shape ( obj -- )
|
2005-01-31 14:02:09 -05:00
|
|
|
|
2005-02-02 22:00:46 -05:00
|
|
|
M: rectangle draw-shape drop ;
|
2005-02-01 20:14:03 -05:00
|
|
|
|
2005-03-01 22:11:08 -05:00
|
|
|
! A rectangle only whose outline is visible.
|
2005-02-02 22:00:46 -05:00
|
|
|
TUPLE: hollow-rect delegate ;
|
|
|
|
|
|
|
|
C: hollow-rect ( x y w h -- rect )
|
|
|
|
[ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
|
|
|
|
|
|
|
|
M: hollow-rect draw-shape ( rect -- )
|
2005-03-01 18:55:25 -05:00
|
|
|
>r surface get r> rect>screen fg rgb rectangleColor ;
|
2005-02-02 22:00:46 -05:00
|
|
|
|
2005-03-01 22:11:08 -05:00
|
|
|
! A rectangle that is filled.
|
2005-02-02 22:00:46 -05:00
|
|
|
TUPLE: plain-rect delegate ;
|
|
|
|
|
|
|
|
C: plain-rect ( x y w h -- rect )
|
|
|
|
[ >r <rectangle> r> set-plain-rect-delegate ] keep ;
|
|
|
|
|
|
|
|
M: plain-rect draw-shape ( rect -- )
|
2005-03-01 18:55:25 -05:00
|
|
|
>r surface get r> rect>screen bg rgb boxColor ;
|
2005-02-03 22:21:51 -05:00
|
|
|
|
2005-03-01 22:11:08 -05:00
|
|
|
! A rectangle that is filled, and has a visible outline.
|
2005-03-01 18:55:25 -05:00
|
|
|
TUPLE: etched-rect delegate ;
|
2005-02-03 22:21:51 -05:00
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
C: etched-rect ( x y w h -- rect )
|
|
|
|
[ >r <rectangle> r> set-etched-rect-delegate ] keep ;
|
2005-02-02 22:00:46 -05:00
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
M: etched-rect draw-shape ( rect -- )
|
|
|
|
>r surface get r> 2dup
|
|
|
|
rect>screen bg rgb boxColor
|
|
|
|
rect>screen fg rgb rectangleColor ;
|
2005-01-31 14:02:09 -05:00
|
|
|
|
2005-03-01 22:11:08 -05:00
|
|
|
! A rectangle that has a visible outline only if the rollover
|
|
|
|
! paint property is set.
|
|
|
|
SYMBOL: rollover?
|
|
|
|
|
|
|
|
TUPLE: roll-rect delegate ;
|
|
|
|
|
|
|
|
C: roll-rect ( x y w h -- rect )
|
|
|
|
[ >r <rectangle> r> set-roll-rect-delegate ] keep ;
|
|
|
|
|
|
|
|
M: roll-rect draw-shape ( rect -- )
|
|
|
|
rollover? get [
|
|
|
|
>r surface get r> rect>screen fg rgb rectangleColor
|
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte ;
|
|
|
|
|
2005-02-05 22:51:41 -05:00
|
|
|
M: line draw-shape ( line -- )
|
|
|
|
>r surface get r>
|
2005-02-07 18:27:55 -05:00
|
|
|
line>screen
|
2005-03-01 18:55:25 -05:00
|
|
|
fg rgb
|
|
|
|
aalineColor ;
|
2005-02-05 22:51:41 -05:00
|
|
|
|
|
|
|
M: ellipse draw-shape drop ;
|
|
|
|
|
|
|
|
TUPLE: hollow-ellipse delegate ;
|
|
|
|
|
|
|
|
C: hollow-ellipse ( x y w h -- ellipse )
|
|
|
|
[ >r <ellipse> r> set-hollow-ellipse-delegate ] keep ;
|
|
|
|
|
|
|
|
M: hollow-ellipse draw-shape ( ellipse -- )
|
2005-03-01 18:55:25 -05:00
|
|
|
>r surface get r> ellipse>screen fg rgb
|
2005-02-05 22:51:41 -05:00
|
|
|
ellipseColor ;
|
|
|
|
|
|
|
|
TUPLE: plain-ellipse delegate ;
|
|
|
|
|
|
|
|
C: plain-ellipse ( x y w h -- ellipse )
|
|
|
|
[ >r <ellipse> r> set-plain-ellipse-delegate ] keep ;
|
|
|
|
|
|
|
|
M: plain-ellipse draw-shape ( ellipse -- )
|
2005-03-01 18:55:25 -05:00
|
|
|
>r surface get r> ellipse>screen bg rgb
|
2005-02-26 02:11:25 -05:00
|
|
|
filledEllipseColor ;
|
|
|
|
|
2005-02-11 19:09:48 -05:00
|
|
|
! Strings are shapes too. This is somewhat of a hack and strings
|
|
|
|
! do not have x/y co-ordinates.
|
|
|
|
M: string shape-x drop 0 ;
|
|
|
|
M: string shape-y drop 0 ;
|
|
|
|
M: string shape-w
|
|
|
|
font get swap size-string ( h -) drop ;
|
|
|
|
|
|
|
|
M: string shape-h ( text -- h )
|
|
|
|
#! This is just the height of the current font.
|
|
|
|
drop font get lookup-font TTF_FontHeight ;
|
|
|
|
|
|
|
|
M: string draw-shape ( text -- )
|
2005-02-11 19:35:50 -05:00
|
|
|
>r x get y get font get r>
|
2005-03-01 18:55:25 -05:00
|
|
|
fg 3unlist make-color
|
2005-02-11 19:09:48 -05:00
|
|
|
draw-string drop ;
|
2005-02-27 03:48:27 -05:00
|
|
|
|
|
|
|
! Clipping
|
|
|
|
|
|
|
|
SYMBOL: clip
|
|
|
|
|
|
|
|
: intersect* ( gadget rect quot -- t1 t2 )
|
|
|
|
call >r >r max r> r> min 2dup > [ drop dup ] when ;
|
|
|
|
|
|
|
|
: intersect-x ( gadget rect -- x1 x2 )
|
|
|
|
[
|
2005-03-01 18:55:25 -05:00
|
|
|
0 rectangle-x-extents >r swap 0 rectangle-x-extents r>
|
2005-02-27 03:48:27 -05:00
|
|
|
] intersect* ;
|
|
|
|
|
|
|
|
: intersect-y ( gadget rect -- y1 y2 )
|
|
|
|
[
|
2005-03-01 18:55:25 -05:00
|
|
|
0 rectangle-y-extents >r swap 0 rectangle-y-extents r>
|
2005-02-27 03:48:27 -05:00
|
|
|
] intersect* ;
|
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
: screen-bounds ( shape -- rect )
|
|
|
|
[ shape-x x get + ] keep
|
|
|
|
[ shape-y y get + ] keep
|
|
|
|
[ shape-w 1 + ] keep
|
|
|
|
shape-h 1 +
|
|
|
|
<rectangle> ;
|
|
|
|
|
2005-02-27 03:48:27 -05:00
|
|
|
: clip-rect ( x1 x2 y1 y2 -- rect )
|
2005-03-01 18:55:25 -05:00
|
|
|
over - 0 max >r >r over - 0 max r> swap r>
|
|
|
|
<rectangle> ;
|
2005-02-27 03:48:27 -05:00
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
: intersect ( rect rect -- rect )
|
2005-02-27 03:48:27 -05:00
|
|
|
[ intersect-x ] 2keep intersect-y clip-rect ;
|
|
|
|
|
2005-03-01 22:19:26 -05:00
|
|
|
: >sdl-rect ( rectangle -- sdlrect )
|
|
|
|
[ rectangle-x ] keep
|
|
|
|
[ rectangle-y ] keep
|
|
|
|
[ rectangle-w ] keep
|
|
|
|
rectangle-h
|
|
|
|
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 t if the clip region
|
|
|
|
#! is an empty region.
|
|
|
|
surface get swap [ >sdl-rect SDL_SetClipRect drop ] keep
|
|
|
|
dup shape-w 0 = swap shape-h 0 = or ;
|
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
GENERIC: shape-clip ( shape -- clip )
|
|
|
|
M: object shape-clip
|
|
|
|
#! By default, we clip to the bounds of the shape. However,
|
|
|
|
#! the hand disables clipping for its children.
|
|
|
|
screen-bounds ;
|
|
|
|
|
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
|
|
|
|
#! shape's bounds. The quotation is called with a boolean
|
|
|
|
#! that is set to false if
|
|
|
|
[
|
2005-03-01 18:55:25 -05:00
|
|
|
>r shape-clip clip [ intersect dup ] change set-clip r>
|
|
|
|
call
|
2005-02-27 16:51:12 -05:00
|
|
|
] with-scope ; inline
|
2005-02-27 03:48:27 -05:00
|
|
|
|
|
|
|
: draw-gadget ( gadget -- )
|
|
|
|
#! All drawing done inside draw-shape is done with the
|
|
|
|
#! gadget's paint. If the gadget does not have any custom
|
|
|
|
#! paint, just call the quotation.
|
|
|
|
dup gadget-paint [
|
|
|
|
dup [
|
2005-02-27 16:51:12 -05:00
|
|
|
[
|
|
|
|
drop
|
|
|
|
] [
|
2005-03-01 18:55:25 -05:00
|
|
|
dup draw-shape dup [
|
2005-02-27 16:51:12 -05:00
|
|
|
gadget-children [ draw-gadget ] each
|
|
|
|
] with-trans
|
|
|
|
] ifte
|
2005-02-27 03:48:27 -05:00
|
|
|
] with-clip
|
|
|
|
] bind ;
|