factor/library/ui/buttons.factor

77 lines
2.4 KiB
Factor
Raw Normal View History

! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-buttons
USING: gadgets gadgets-borders generic io kernel lists math
namespaces sdl sequences sequences styles threads ;
2005-07-16 22:16:18 -04:00
: button-down? ( n -- ? ) hand hand-buttons member? ;
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? [
1 button-down?
[ hand hand-clicked child? ] [ drop f ] ifte
] [
drop f
] ifte ;
: button-update ( button -- )
dup dup mouse-over? rollover set-paint-prop
2005-03-06 19:46:29 -05:00
dup dup button-pressed? reverse-video set-paint-prop
relayout ;
: button-clicked ( button -- )
#! If the mouse is released while still inside the button,
#! fire an action gesture.
2005-08-27 15:12:37 -04:00
dup button-update dup mouse-over?
[ [ action ] swap handle-gesture ] when drop ;
2005-08-26 00:55:56 -04:00
: button-theme ( button -- )
dup { 216 216 216 } background set-paint-prop
dup f reverse-video set-paint-prop
<< solid f >> interior set-paint-prop ;
: roll-button-theme ( button -- )
dup f reverse-video set-paint-prop
dup <rollover-only> interior set-paint-prop
<rollover-only> boundary set-paint-prop ;
2005-05-03 19:00:52 -04:00
: button-action ( action -- quot )
[ [ swap handle-gesture drop ] cons ] [ [ drop ] ] ifte* ;
: button-gestures ( button quot -- )
dupd [ action ] set-action
2005-08-27 15:12:37 -04:00
dup [ button-clicked ] [ button-up 1 ] set-action
dup [ button-update ] [ button-down 1 ] set-action
dup [ button-update ] [ mouse-leave ] set-action
2005-08-27 15:12:37 -04:00
[ button-update ] [ mouse-enter ] set-action ;
2005-07-17 02:49:07 -04:00
2005-08-27 15:12:37 -04:00
TUPLE: button ;
C: button ( gadget quot -- button )
rot bevel-border over set-delegate
dup button-theme [ swap button-gestures ] keep ;
2005-08-26 00:55:56 -04:00
2005-08-26 21:42:43 -04:00
: <roll-button> ( gadget quot -- button )
>r dup roll-button-theme dup r> button-gestures ;
2005-08-27 15:12:37 -04:00
: repeat-button-down ( button -- )
dup 100 add-timer button-clicked ;
: repeat-button-up ( button -- )
dup button-update remove-timer ;
: repeat-actions ( button -- )
dup [ repeat-button-down ] [ button-down 1 ] set-action
[ repeat-button-up ] [ button-up 1 ] set-action ;
: <repeat-button> ( gadget quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
<button> dup repeat-actions ;
M: button tick ( ms object -- ) nip button-clicked ;