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-09-27 00:24:42 -04:00
|
|
|
USING: alien arrays gadgets-layouts generic hashtables io kernel
|
|
|
|
lists math matrices namespaces sdl sequences strings styles
|
|
|
|
vectors ;
|
2005-02-27 03:48:27 -05:00
|
|
|
|
|
|
|
SYMBOL: clip
|
|
|
|
|
2005-03-01 22:19:26 -05:00
|
|
|
: >sdl-rect ( rectangle -- sdlrect )
|
2005-09-02 23:44:23 -04:00
|
|
|
[ rect-loc first2 ] keep rect-dim first2 make-rect ;
|
2005-03-01 22:19:26 -05:00
|
|
|
|
2005-08-23 23:28:54 -04:00
|
|
|
: set-clip ( rect -- )
|
2005-02-27 16:51:12 -05:00
|
|
|
#! The top/left corner of the clip rectangle is the location
|
|
|
|
#! of the gadget on the screen. The bottom/right is the
|
2005-08-23 23:28:54 -04:00
|
|
|
#! intersected clip rectangle.
|
|
|
|
surface get swap >sdl-rect SDL_SetClipRect drop ;
|
|
|
|
|
2005-08-24 19:25:12 -04:00
|
|
|
: visible-children ( gadget -- seq ) clip get swap children-on ;
|
2005-02-27 03:48:27 -05:00
|
|
|
|
2005-07-13 21:03:34 -04:00
|
|
|
GENERIC: draw-gadget* ( gadget -- )
|
|
|
|
|
2005-08-24 19:25:12 -04:00
|
|
|
: do-clip ( gadget -- )
|
|
|
|
>absolute clip [ intersect dup ] change set-clip ;
|
2005-08-23 23:28:54 -04:00
|
|
|
|
2005-02-27 03:48:27 -05:00
|
|
|
: draw-gadget ( gadget -- )
|
2005-08-24 19:25:12 -04:00
|
|
|
clip get over inside? [
|
2005-08-24 00:30:07 -04:00
|
|
|
[
|
2005-08-24 19:25:12 -04:00
|
|
|
dup do-clip dup translate dup draw-gadget*
|
2005-08-23 23:28:54 -04:00
|
|
|
visible-children [ draw-gadget ] each
|
|
|
|
] with-scope
|
2005-09-24 15:21:17 -04:00
|
|
|
] [ drop ] if ;
|
2005-07-13 21:03:34 -04:00
|
|
|
|
2005-08-24 19:25:12 -04:00
|
|
|
: paint-prop* ( gadget key -- value ) swap gadget-paint ?hash ;
|
2005-07-13 21:17:47 -04:00
|
|
|
|
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
|
2005-09-24 15:21:17 -04:00
|
|
|
[ 2nip ] [ drop >r gadget-parent r> paint-prop ] if
|
2005-07-13 21:03:34 -04:00
|
|
|
] [
|
|
|
|
2drop f
|
2005-09-24 15:21:17 -04:00
|
|
|
] if ;
|
2005-07-13 21:03:34 -04:00
|
|
|
|
|
|
|
: 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 ?
|
2005-09-24 15:21:17 -04:00
|
|
|
] if paint-prop ;
|
2005-07-13 21:03:34 -04:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Pen paint properties
|
2005-07-17 02:49:07 -04:00
|
|
|
SYMBOL: interior
|
|
|
|
SYMBOL: boundary
|
|
|
|
|
|
|
|
GENERIC: draw-interior ( gadget interior -- )
|
|
|
|
GENERIC: draw-boundary ( gadget boundary -- )
|
|
|
|
|
|
|
|
M: f draw-interior 2drop ;
|
|
|
|
M: f draw-boundary 2drop ;
|
|
|
|
|
2005-08-26 00:55:56 -04:00
|
|
|
! Solid fill/border
|
2005-07-17 02:49:07 -04:00
|
|
|
TUPLE: solid ;
|
|
|
|
|
2005-07-17 03:47:14 -04:00
|
|
|
: rect>screen ( shape -- x1 y1 x2 y2 )
|
2005-08-23 23:28:54 -04:00
|
|
|
>r origin get dup r> rect-dim v+
|
2005-09-16 20:49:24 -04:00
|
|
|
[ first2 ] 2apply [ 1 - ] 2apply ;
|
2005-07-17 03:47:14 -04:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Solid pen
|
2005-07-17 02:49:07 -04:00
|
|
|
M: solid draw-interior
|
|
|
|
drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
|
|
|
|
|
|
|
|
M: solid draw-boundary
|
2005-08-23 23:28:54 -04:00
|
|
|
drop >r surface get r> [ rect>screen ] keep
|
2005-07-17 02:49:07 -04:00
|
|
|
fg rgb rectangleColor ;
|
2005-07-13 21:03:34 -04:00
|
|
|
|
2005-08-26 00:55:56 -04:00
|
|
|
! Rollover only
|
|
|
|
TUPLE: rollover-only ;
|
|
|
|
|
|
|
|
C: rollover-only << solid f >> over set-delegate ;
|
|
|
|
|
|
|
|
M: rollover-only draw-interior ( gadget interior -- )
|
|
|
|
over rollover paint-prop
|
2005-09-24 15:21:17 -04:00
|
|
|
[ delegate draw-interior ] [ 2drop ] if ;
|
2005-08-26 00:55:56 -04:00
|
|
|
|
|
|
|
M: rollover-only draw-boundary ( gadget boundary -- )
|
|
|
|
over rollover paint-prop
|
2005-09-24 15:21:17 -04:00
|
|
|
[ delegate draw-boundary ] [ 2drop ] if ;
|
2005-08-26 00:55:56 -04:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Gradient pen
|
2005-07-17 03:47:14 -04:00
|
|
|
TUPLE: gradient vector from to ;
|
|
|
|
|
|
|
|
: gradient-color ( gradient prop -- color )
|
|
|
|
over gradient-from 1 pick - v*n
|
|
|
|
>r swap gradient-to n*v r> v+ ;
|
|
|
|
|
|
|
|
: (gradient-x) ( gradient dim y -- x1 x2 y color )
|
|
|
|
dup pick second / >r rot r> gradient-color >r
|
2005-07-19 17:40:32 -04:00
|
|
|
>r >r origin get first r> origin get v+ first
|
|
|
|
r> origin get second + r> ;
|
2005-07-17 03:47:14 -04:00
|
|
|
|
|
|
|
: gradient-x ( gradient dim y -- )
|
|
|
|
>r >r >r surface get r> r> r> (gradient-x) rgb hlineColor ;
|
|
|
|
|
|
|
|
: vert-gradient ( gradient dim -- )
|
|
|
|
dup second [ 3dup gradient-x ] repeat 2drop ;
|
|
|
|
|
|
|
|
: (gradient-y) ( gradient dim x -- x y1 y2 color )
|
|
|
|
dup pick first / >r rot r> gradient-color
|
2005-07-19 17:40:32 -04:00
|
|
|
>r origin get first + origin get second rot
|
|
|
|
origin get v+ second r> ;
|
2005-07-17 03:47:14 -04:00
|
|
|
|
|
|
|
: gradient-y ( gradient dim x -- )
|
|
|
|
>r >r >r surface get r> r> r> (gradient-y) rgb vlineColor ;
|
|
|
|
|
|
|
|
: horiz-gradient ( gradient dim -- )
|
|
|
|
dup first [ 3dup gradient-y ] repeat 2drop ;
|
|
|
|
|
|
|
|
M: gradient draw-interior ( gadget gradient -- )
|
2005-09-11 20:46:55 -04:00
|
|
|
swap rect-dim @{ 1 1 1 }@ vmax
|
|
|
|
over gradient-vector @{ 1 0 0 }@ =
|
2005-09-24 15:21:17 -04:00
|
|
|
[ horiz-gradient ] [ vert-gradient ] if ;
|
2005-07-17 03:47:14 -04:00
|
|
|
|
2005-07-18 18:14:13 -04:00
|
|
|
! Bevel pen
|
|
|
|
TUPLE: bevel width ;
|
|
|
|
|
2005-09-02 23:44:23 -04:00
|
|
|
: x1/x2/y1 surface get pick pick >r first2 r> first swap ;
|
|
|
|
: x1/x2/y2 surface get pick pick >r first r> first2 ;
|
|
|
|
: x1/y1/y2 surface get pick pick >r first2 r> second ;
|
|
|
|
: x2/y1/y2 surface get pick pick >r second r> first2 swapd ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
|
|
|
SYMBOL: bevel-1
|
|
|
|
SYMBOL: bevel-2
|
|
|
|
|
2005-09-27 00:24:42 -04:00
|
|
|
: bevel-color ( gadget ? -- rgb )
|
|
|
|
>r dup reverse-video paint-prop bevel-1 bevel-2
|
|
|
|
r> [ swap ] when ? paint-prop rgb ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
|
|
|
: draw-bevel ( v1 v2 gadget -- )
|
2005-09-27 00:24:42 -04:00
|
|
|
[ >r x1/x2/y1 r> f bevel-color hlineColor ] keep
|
|
|
|
[ >r x1/x2/y2 r> t bevel-color hlineColor ] keep
|
|
|
|
[ >r x1/y1/y2 r> f bevel-color vlineColor ] keep
|
|
|
|
[ >r x2/y1/y2 r> t bevel-color vlineColor ] keep
|
2005-07-18 18:14:13 -04:00
|
|
|
3drop ;
|
|
|
|
|
|
|
|
M: bevel draw-boundary ( gadget boundary -- )
|
|
|
|
#! Ugly code.
|
|
|
|
bevel-width [
|
2005-08-23 23:28:54 -04:00
|
|
|
>r origin get over rect-dim over v+ r>
|
2005-09-11 20:46:55 -04:00
|
|
|
@{ 1 1 0 }@ n*v tuck v- @{ 1 1 0 }@ v- >r v+ r>
|
2005-07-31 23:38:33 -04:00
|
|
|
rot draw-bevel
|
|
|
|
] each-with ;
|
2005-07-18 18:14:13 -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 ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
|
|
|
: <bevel-gadget> ( -- gadget )
|
|
|
|
<plain-gadget> dup << bevel f 2 >> boundary set-paint-prop ;
|
2005-09-01 01:20:43 -04:00
|
|
|
|
2005-09-27 00:24:42 -04:00
|
|
|
! Polygon pen
|
|
|
|
TUPLE: polygon points ;
|
|
|
|
|
|
|
|
: >short-array ( seq -- short-array )
|
|
|
|
dup length <short-array> over length [
|
|
|
|
[ tuck >r >r swap nth r> r> swap set-short-nth ] 3keep
|
|
|
|
] repeat nip ;
|
|
|
|
|
2005-09-27 14:12:17 -04:00
|
|
|
: polygon-x/y ( gadget polygon -- vx vy n )
|
2005-09-27 00:24:42 -04:00
|
|
|
polygon-points [
|
2005-09-27 14:12:17 -04:00
|
|
|
swap rect-dim over max-dim v- 2 v/n origin get v+
|
|
|
|
swap [ v+ ] map-with
|
2005-09-27 00:24:42 -04:00
|
|
|
dup [ first ] map swap [ second ] map
|
|
|
|
[ >short-array ] 2apply
|
|
|
|
] keep length ;
|
|
|
|
|
|
|
|
: (polygon) ( gadget polygon -- surface vx vy n gadget )
|
2005-09-27 14:12:17 -04:00
|
|
|
over >r surface get -rot polygon-x/y r> ;
|
2005-09-27 00:24:42 -04:00
|
|
|
|
|
|
|
M: polygon draw-boundary ( gadget polygon -- )
|
|
|
|
(polygon) fg rgb polygonColor ;
|
|
|
|
|
|
|
|
M: polygon draw-interior ( gadget polygon -- )
|
|
|
|
(polygon) bg rgb filledPolygonColor ;
|
|
|
|
|
2005-09-27 14:12:17 -04:00
|
|
|
: arrow-up @{ @{ 4 0 0 }@ @{ 8 8 0 }@ @{ 0 8 0 }@ }@ ;
|
|
|
|
: arrow-right @{ @{ 0 0 0 }@ @{ 8 4 0 }@ @{ 0 8 0 }@ }@ ;
|
|
|
|
: arrow-down @{ @{ 0 0 0 }@ @{ 8 0 0 }@ @{ 4 8 0 }@ }@ ;
|
|
|
|
: arrow-left @{ @{ 0 4 0 }@ @{ 8 0 0 }@ @{ 8 8 0 }@ }@ ;
|
2005-09-27 00:24:42 -04:00
|
|
|
|
2005-09-27 14:12:17 -04:00
|
|
|
: arrow-right|
|
2005-09-27 00:24:42 -04:00
|
|
|
@{
|
|
|
|
@{ 0 0 0 }@ @{ 0 8 0 }@ @{ 8 4 0 }@
|
|
|
|
@{ 8 8 0 }@ @{ 8 0 0 }@ @{ 8 4 0 }@
|
|
|
|
}@ ;
|
|
|
|
|
2005-09-27 14:12:17 -04:00
|
|
|
: arrow-|left
|
2005-09-27 00:24:42 -04:00
|
|
|
@{
|
|
|
|
@{ 8 0 0 }@ @{ 8 8 0 }@ @{ 0 4 0 }@
|
|
|
|
@{ 0 8 0 }@ @{ 0 0 0 }@ @{ 0 4 0 }@
|
|
|
|
}@ ;
|
|
|
|
|
|
|
|
: <polygon-gadget> ( points -- gadget )
|
|
|
|
dup max-dim >r <polygon> <gadget> r> over set-rect-dim
|
|
|
|
dup rot interior set-paint-prop
|
|
|
|
dup gray background set-paint-prop
|
|
|
|
dup light-gray rollover-bg set-paint-prop ;
|