2005-01-31 22:32:06 -05:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
|
|
IN: gadgets
|
2005-10-11 23:28:17 -04:00
|
|
|
USING: alien generic hashtables kernel lists math sequences ;
|
2005-02-05 11:52:24 -05:00
|
|
|
|
|
|
|
: action ( gadget gesture -- quot )
|
2005-07-13 21:17:47 -04:00
|
|
|
swap gadget-gestures ?hash ;
|
2005-02-05 11:52:24 -05:00
|
|
|
|
2005-10-07 20:26:21 -04:00
|
|
|
: init-gestures ( gadget -- gestures )
|
|
|
|
dup gadget-gestures
|
2005-10-29 23:25:38 -04:00
|
|
|
[ ] [ H{ } clone dup rot set-gadget-gestures ] ?if ;
|
2005-10-07 20:26:21 -04:00
|
|
|
|
2005-02-05 11:52:24 -05:00
|
|
|
: set-action ( gadget quot gesture -- )
|
2005-10-07 20:26:21 -04:00
|
|
|
rot init-gestures set-hash ;
|
2005-02-01 21:47:10 -05:00
|
|
|
|
2005-10-07 20:26:21 -04:00
|
|
|
: add-actions ( gadget hash -- )
|
|
|
|
dup [ >r init-gestures r> hash-update ] [ 2drop ] if ;
|
2005-03-01 22:11:08 -05:00
|
|
|
|
2005-02-01 21:47:10 -05:00
|
|
|
: handle-gesture* ( gesture gadget -- ? )
|
2005-09-24 15:21:17 -04:00
|
|
|
tuck gadget-gestures ?hash dup [ call f ] [ 2drop t ] if ;
|
2005-01-31 22:32:06 -05:00
|
|
|
|
2005-02-12 21:15:30 -05:00
|
|
|
: handle-gesture ( gesture gadget -- ? )
|
2005-01-31 22:32:06 -05:00
|
|
|
#! If a gadget's handle-gesture* generic returns t, the
|
|
|
|
#! event was not consumed and is passed on to the gadget's
|
2005-02-12 21:15:30 -05:00
|
|
|
#! parent. This word returns t if no gadget handled the
|
|
|
|
#! gesture, otherwise returns f.
|
|
|
|
[ dupd handle-gesture* ] each-parent nip ;
|
|
|
|
|
2006-03-22 17:22:05 -05:00
|
|
|
: user-input ( str gadget -- )
|
|
|
|
[ dupd user-input* ] each-parent 2drop ;
|
2005-02-01 20:14:03 -05:00
|
|
|
|
2005-02-01 21:47:10 -05:00
|
|
|
! Mouse gestures are lists where the first element is one of:
|
|
|
|
SYMBOL: motion
|
2005-02-26 02:11:25 -05:00
|
|
|
SYMBOL: drag
|
2005-02-01 21:47:10 -05:00
|
|
|
SYMBOL: button-up
|
|
|
|
SYMBOL: button-down
|
2005-12-17 00:12:32 -05:00
|
|
|
SYMBOL: wheel-up
|
|
|
|
SYMBOL: wheel-down
|
2005-07-20 18:04:29 -04:00
|
|
|
SYMBOL: mouse-enter
|
|
|
|
SYMBOL: mouse-leave
|
2005-02-05 11:52:24 -05:00
|
|
|
|
2005-07-20 18:04:29 -04:00
|
|
|
SYMBOL: lose-focus
|
|
|
|
SYMBOL: gain-focus
|