factor/library/ui/hand.factor

97 lines
2.7 KiB
Factor
Raw Normal View History

2005-02-01 20:14:03 -05:00
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien generic kernel lists math namespaces sdl sdl-event
sdl-video ;
DEFER: pick-up
: pick-up-list ( point list -- gadget )
dup [
2dup car pick-up dup [
2nip
] [
drop cdr pick-up-list
] ifte
] [
2drop f
] ifte ;
: pick-up* ( point gadget -- gadget/t )
#! The logic is thus. If the point is definately outside the
#! box, return f. Otherwise, see if the point is contained
#! in any subgadget. If not, see if it is contained in the
#! box delegate.
2dup inside? [
2dup [ translate ] keep
gadget-children pick-up-list dup [
2nip
] [
3drop t
] ifte
] [
2drop f
] ifte ;
: pick-up ( point gadget -- gadget )
#! pick-up* returns t to mean 'this gadget', avoiding the
#! exposed facade issue.
tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
DEFER: world
2005-02-01 21:47:10 -05:00
2005-02-01 20:14:03 -05:00
! The hand is a special gadget that holds mouse position and
! mouse button click state. The hand's parent is the world, but
! it is special in that the world does not list it as part of
2005-02-10 23:58:28 -05:00
! its contents. Some comments on the slots:
! - hand-gadget is the gadget under the mouse position
! - hand-clicked is the most recently clicked gadget
! - hand-focus is the gadget holding keyboard focus
TUPLE: hand click-pos clicked buttons gadget focus delegate ;
2005-02-01 20:14:03 -05:00
2005-02-01 21:47:10 -05:00
C: hand ( world -- hand )
2005-02-05 11:52:24 -05:00
0 0 0 0 <rectangle> <gadget>
2005-02-01 21:47:10 -05:00
over set-hand-delegate
2005-02-05 11:52:24 -05:00
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
2005-02-01 20:14:03 -05:00
: button/ ( n hand -- )
2005-02-05 11:52:24 -05:00
dup hand-gadget over set-hand-clicked
dup shape-pos over set-hand-click-pos
2005-02-01 20:14:03 -05:00
[ hand-buttons unique ] keep set-hand-buttons ;
: button\ ( n hand -- )
[ hand-buttons remove ] keep set-hand-buttons ;
2005-02-05 11:52:24 -05:00
: fire-leave ( hand gadget -- )
[ swap shape-pos swap screen-pos - ] keep mouse-leave ;
2005-02-05 11:52:24 -05:00
: fire-enter ( oldpos hand -- )
hand-gadget [ screen-pos - ] keep mouse-enter ;
2005-02-05 11:52:24 -05:00
: update-hand-gadget ( hand -- )
#! The hand gadget is the gadget under the hand right now.
dup world get pick-up swap set-hand-gadget ;
: fire-motion ( hand -- )
2005-02-12 21:15:30 -05:00
[ motion ] swap hand-gadget handle-gesture drop ;
2005-02-05 11:52:24 -05:00
: move-hand ( x y hand -- )
dup shape-pos >r
[ move-gadget ] keep
dup hand-gadget >r
2005-02-05 11:52:24 -05:00
dup update-hand-gadget
dup r> fire-leave
dup fire-motion
2005-02-05 11:52:24 -05:00
r> swap fire-enter ;
2005-02-10 23:58:28 -05:00
2005-02-15 18:05:28 -05:00
: update-hand ( hand -- )
#! Called when a gadget is removed or added.
[ dup shape-x swap shape-y ] keep move-hand ;
2005-02-11 19:09:48 -05:00
: request-focus ( gadget hand -- )
dup >r hand-focus
2005-02-10 23:58:28 -05:00
2dup lose-focus
2005-02-11 19:09:48 -05:00
swap dup r> set-hand-focus
2005-02-10 23:58:28 -05:00
gain-focus ;