factor/library/ui/checkboxes.factor

46 lines
1.4 KiB
Factor
Raw Normal View History

2005-03-02 21:26:11 -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 ;
: <check> ( w h -- cross )
2dup >r >r 0 0 r> r> <line> <gadget>
>r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
2list <stack> ;
TUPLE: checkbox bevel selected? ;
2005-03-02 21:26:11 -05:00
: 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? [
7 7 <check>
] [
0 0 7 7 <rectangle> <gadget>
] ifte swap checkbox-bevel add-gadget ;
: toggle-checkbox ( checkbox -- )
dup checkbox-selected? not over set-checkbox-selected?
update-checkbox ;
: checkbox-update ( checkbox -- )
dup button-pressed? >r checkbox-bevel r>
2005-03-06 19:46:29 -05:00
reverse-video set-paint-prop ;
2005-03-02 21:26:11 -05:00
: 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 ;
C: checkbox ( label -- checkbox )
<default-shelf> over set-delegate
2005-03-02 21:26:11 -05:00
[ f line-border swap init-checkbox-bevel ] keep
[ >r <label> r> add-gadget ] keep
dup checkbox-actions
dup update-checkbox ;