factor/library/ui/buttons.factor

82 lines
2.6 KiB
Factor
Raw Normal View History

! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-buttons
2005-09-28 23:29:00 -04:00
USING: gadgets gadgets-borders gadgets-layouts gadgets-theme
generic io kernel lists math namespaces sequences sequences
2005-09-28 23:29:00 -04:00
styles threads ;
2005-10-25 21:52:26 -04:00
TUPLE: button rollover? pressed? ;
2005-12-17 00:56:10 -05:00
: button-down? ( -- ? ) hand get hand-buttons empty? not ;
2005-02-19 23:25:21 -05:00
2005-10-07 20:26:21 -04:00
: mouse-over? ( gadget -- ? ) hand get hand-gadget child? ;
2005-10-25 21:52:26 -04:00
: mouse-clicked? ( gadget -- ? ) hand get hand-clicked child? ;
: button-update ( button -- )
2005-10-25 21:52:26 -04:00
dup mouse-over? over set-button-rollover?
2005-12-17 00:56:10 -05:00
dup button-rollover? button-down? and
2005-10-25 21:52:26 -04:00
over mouse-clicked? and over set-button-pressed?
2005-09-25 20:41:49 -04:00
relayout-1 ;
: button-clicked ( button -- )
#! If the mouse is released while still inside the button,
#! fire an action gesture.
2005-10-25 21:52:26 -04:00
dup button-update dup button-rollover?
2005-08-27 15:12:37 -04:00
[ [ action ] swap handle-gesture ] when drop ;
2005-05-03 19:00:52 -04:00
: button-action ( action -- quot )
2005-09-24 15:21:17 -04:00
[ [ swap handle-gesture drop ] cons ] [ [ drop ] ] if* ;
2005-05-03 19:00:52 -04:00
: button-gestures ( button quot -- )
dupd [ action ] set-action
2005-12-17 00:12:32 -05:00
dup [ button-clicked ] [ button-up ] set-action
dup [ button-update ] [ button-down ] 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
C: button ( gadget quot -- button )
2005-12-17 20:03:41 -05:00
rot <default-border> over set-gadget-delegate
2005-10-09 21:27:14 -04:00
[ swap button-gestures ] keep ;
2005-08-26 00:55:56 -04:00
2005-10-25 21:52:26 -04:00
: <highlight-button> ( gadget quot -- button )
<button> { 0 0 0 } over set-border-size ;
2005-10-25 21:52:26 -04:00
2005-08-26 21:42:43 -04:00
: <roll-button> ( gadget quot -- button )
2005-10-25 21:52:26 -04:00
<highlight-button> dup roll-button-theme ;
2005-09-27 00:44:38 -04:00
2005-10-25 21:52:26 -04:00
: <bevel-button> ( gadget quot -- button )
<button> dup bevel-button-theme ;
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 -- )
2005-12-17 00:12:32 -05:00
dup [ repeat-button-down ] [ button-down ] set-action
[ repeat-button-up ] [ button-up ] set-action ;
2005-08-27 15:12:37 -04:00
: <repeat-button> ( gadget quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
2005-10-25 21:52:26 -04:00
<bevel-button> dup repeat-actions ;
2005-08-27 15:12:37 -04:00
M: button tick ( ms object -- ) nip button-clicked ;
2005-10-25 21:52:26 -04:00
TUPLE: button-paint plain rollover pressed ;
: button-paint ( button paint -- button paint )
{
{ [ over button-pressed? ] [ button-paint-pressed ] }
{ [ over button-rollover? ] [ button-paint-rollover ] }
{ [ t ] [ button-paint-plain ] }
} cond ;
2005-10-25 21:52:26 -04:00
M: button-paint draw-interior ( button paint -- )
button-paint draw-interior ;
M: button-paint draw-boundary ( button paint -- )
button-paint draw-boundary ;