factor/library/ui/buttons.factor

57 lines
1.6 KiB
Factor
Raw Normal View History

! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
2005-03-02 21:26:11 -05:00
USING: generic kernel lists math namespaces prettyprint sdl
stdio ;
2005-03-03 20:43:55 -05:00
: button-down? ( n -- ? ) hand hand-buttons contains? ;
2005-02-19 23:25:21 -05:00
2005-03-03 20:43:55 -05:00
: mouse-over? ( gadget -- ? ) hand hand-gadget child? ;
: button-pressed? ( button -- ? )
2005-02-19 22:55:45 -05:00
#! Return true if the mouse was clicked on the button, and
#! is currently over the button.
dup mouse-over? [
2005-02-19 22:55:45 -05:00
1 button-down? [
2005-03-03 20:43:55 -05:00
hand hand-clicked child?
] [
drop f
] ifte
] [
drop f
] ifte ;
: button-update ( button -- )
2005-03-06 19:46:29 -05:00
dup dup mouse-over? rollover? set-paint-prop
dup dup button-pressed? reverse-video set-paint-prop
2005-03-01 18:55:25 -05:00
redraw ;
: button-clicked ( button -- )
#! If the mouse is released while still inside the button,
#! fire an action gesture.
dup mouse-over? [
2005-02-12 21:15:30 -05:00
[ action ] swap handle-gesture drop
] [
drop
] ifte ;
: button-actions ( button quot -- )
dupd [ action ] set-action
2005-03-01 18:55:25 -05:00
dup [ dup button-update button-clicked ] [ button-up 1 ] set-action
dup [ button-update ] [ button-down 1 ] set-action
dup [ button-update ] [ mouse-leave ] set-action
2005-03-06 19:46:29 -05:00
dup [ button-update ] [ mouse-enter ] set-action
[ drop ] [ drag 1 ] set-action ;
: <button> ( label quot -- button )
2005-03-01 18:55:25 -05:00
>r <label> line-border dup r> button-actions ;
2005-03-02 21:26:11 -05:00
: roll-border ( child -- border )
0 0 0 0 <roll-rect> <gadget> 1 <border> ;
2005-02-07 18:27:55 -05:00
2005-03-02 21:26:11 -05:00
: <roll-button> ( label quot -- gadget )
#! Thinner border that is only visible when the mouse is
#! over the button.
2005-03-06 19:46:29 -05:00
>r <label> roll-border dup r> button-actions
dup f reverse-video set-paint-prop ;