2005-02-03 22:21:51 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: gadgets
|
|
|
|
USING: generic kernel lists math namespaces sdl ;
|
|
|
|
|
2005-02-19 23:25:21 -05:00
|
|
|
: button-down? ( n -- ? )
|
|
|
|
my-hand hand-buttons contains? ;
|
|
|
|
|
2005-02-05 22:51:41 -05:00
|
|
|
: mouse-over? ( gadget -- ? ) my-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.
|
2005-02-05 22:51:41 -05:00
|
|
|
dup mouse-over? [
|
2005-02-19 22:55:45 -05:00
|
|
|
1 button-down? [
|
2005-02-05 22:51:41 -05:00
|
|
|
my-hand hand-clicked child?
|
|
|
|
] [
|
|
|
|
drop f
|
|
|
|
] ifte
|
|
|
|
] [
|
|
|
|
drop f
|
|
|
|
] ifte ;
|
|
|
|
|
|
|
|
: button-update ( button -- )
|
2005-03-01 18:55:25 -05:00
|
|
|
dup dup button-pressed? reverse-video set-paint-property
|
|
|
|
redraw ;
|
2005-02-05 22:51:41 -05:00
|
|
|
|
|
|
|
: 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
|
2005-02-05 22:51:41 -05:00
|
|
|
] [
|
|
|
|
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
|
2005-02-05 22:51:41 -05:00
|
|
|
dup [ button-update ] [ button-down 1 ] set-action
|
|
|
|
dup [ button-update ] [ mouse-leave ] set-action
|
2005-02-06 00:21:26 -05:00
|
|
|
[ button-update ] [ mouse-enter ] set-action ;
|
2005-02-05 22:51:41 -05:00
|
|
|
|
2005-02-03 22:21:51 -05:00
|
|
|
: <button> ( label quot -- button )
|
2005-03-01 18:55:25 -05:00
|
|
|
>r <label> line-border dup r> button-actions ;
|
2005-02-05 22:51:41 -05:00
|
|
|
|
2005-02-07 20:10:02 -05:00
|
|
|
: <check> ( w h -- cross )
|
2005-02-07 18:27:55 -05:00
|
|
|
2dup >r >r 0 0 r> r> <line> <gadget>
|
2005-02-07 20:10:02 -05:00
|
|
|
>r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
|
|
|
|
2list <stack> ;
|
2005-02-07 18:27:55 -05:00
|
|
|
|
2005-02-07 20:10:02 -05:00
|
|
|
TUPLE: checkbox bevel selected? delegate ;
|
|
|
|
|
|
|
|
: init-checkbox-bevel ( bevel checkbox -- )
|
|
|
|
2dup set-checkbox-bevel add-gadget ;
|
|
|
|
|
|
|
|
: update-checkbox ( checkbox -- )
|
|
|
|
#! Really, there should only be one child.
|
|
|
|
dup checkbox-bevel gadget-children [ unparent ] each
|
|
|
|
dup checkbox-selected? [
|
2005-03-01 18:55:25 -05:00
|
|
|
7 7 <check>
|
2005-02-07 20:10:02 -05:00
|
|
|
] [
|
2005-03-01 18:55:25 -05:00
|
|
|
0 0 7 7 <rectangle> <gadget>
|
2005-02-07 20:10:02 -05:00
|
|
|
] ifte swap checkbox-bevel add-gadget ;
|
|
|
|
|
|
|
|
: toggle-checkbox ( checkbox -- )
|
|
|
|
dup checkbox-selected? not over set-checkbox-selected?
|
|
|
|
update-checkbox ;
|
|
|
|
|
2005-03-01 18:55:25 -05:00
|
|
|
: checkbox-update ( checkbox -- )
|
|
|
|
dup button-pressed? >r checkbox-bevel r>
|
|
|
|
reverse-video set-paint-property ;
|
|
|
|
|
|
|
|
: checkbox-actions ( checkbox -- )
|
|
|
|
dup [ toggle-checkbox ] [ action ] set-action
|
|
|
|
dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
|
|
|
|
dup [ checkbox-update ] [ button-down 1 ] set-action
|
|
|
|
dup [ checkbox-update ] [ mouse-leave ] set-action
|
|
|
|
[ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
|
|
|
|
|
2005-02-07 20:10:02 -05:00
|
|
|
C: checkbox ( label -- checkbox )
|
2005-02-19 19:57:26 -05:00
|
|
|
<default-shelf> over set-checkbox-delegate
|
2005-03-01 18:55:25 -05:00
|
|
|
[ f line-border swap init-checkbox-bevel ] keep
|
2005-02-19 21:49:37 -05:00
|
|
|
[ >r <label> r> add-gadget ] keep
|
2005-03-01 18:55:25 -05:00
|
|
|
dup checkbox-actions
|
2005-02-07 20:10:02 -05:00
|
|
|
dup update-checkbox ;
|