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
|
2005-03-03 20:43:55 -05:00
|
|
|
USING: alien generic kernel lists math namespaces prettyprint
|
2005-04-25 19:54:21 -04:00
|
|
|
sequences sdl stdio ;
|
2005-02-01 20:14:03 -05:00
|
|
|
|
2005-02-03 22:21:51 -05:00
|
|
|
DEFER: pick-up
|
2005-02-03 18:18:47 -05:00
|
|
|
|
|
|
|
: 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
|
2005-03-01 18:55:25 -05:00
|
|
|
gadget-children reverse pick-up-list dup [
|
2005-02-03 18:18:47 -05:00
|
|
|
2nip
|
|
|
|
] [
|
2005-02-03 22:21:51 -05:00
|
|
|
3drop t
|
2005-02-03 18:18:47 -05:00
|
|
|
] 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 ;
|
|
|
|
|
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
|
2005-03-08 22:54:59 -05:00
|
|
|
TUPLE: hand world
|
2005-03-06 19:46:29 -05:00
|
|
|
click-pos click-rel clicked buttons
|
2005-03-08 22:54:59 -05:00
|
|
|
gadget focus ;
|
2005-02-01 20:14:03 -05:00
|
|
|
|
2005-02-01 21:47:10 -05:00
|
|
|
C: hand ( world -- hand )
|
2005-02-26 00:57:53 -05:00
|
|
|
<empty-gadget>
|
2005-03-08 22:54:59 -05:00
|
|
|
over set-delegate
|
2005-02-18 19:02:06 -05:00
|
|
|
[ set-hand-world ] 2keep
|
2005-02-05 11:52:24 -05:00
|
|
|
[ set-gadget-parent ] 2keep
|
2005-03-06 19:46:29 -05:00
|
|
|
[ 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
|
2005-03-22 22:38:24 -05:00
|
|
|
dup screen-pos over set-hand-click-pos
|
2005-03-06 19:46:29 -05:00
|
|
|
dup hand-gadget over relative over set-hand-click-rel
|
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
|
|
|
|
2005-02-05 22:51:41 -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 -- )
|
2005-02-05 22:51:41 -05:00
|
|
|
hand-gadget [ screen-pos - ] keep mouse-enter ;
|
2005-02-05 11:52:24 -05:00
|
|
|
|
2005-03-03 20:43:55 -05:00
|
|
|
: update-hand-gadget ( hand -- )
|
2005-03-06 19:46:29 -05:00
|
|
|
dup dup hand-world pick-up swap set-hand-gadget ;
|
2005-03-03 20:43:55 -05:00
|
|
|
|
|
|
|
: motion-gesture ( hand gadget gesture -- )
|
|
|
|
#! Send a gesture like [ drag 2 ].
|
|
|
|
rot hand-buttons car unit append swap handle-gesture drop ;
|
2005-02-05 22:51:41 -05:00
|
|
|
|
|
|
|
: fire-motion ( hand -- )
|
2005-02-26 02:11:25 -05:00
|
|
|
#! Fire a motion gesture to the gadget underneath the hand,
|
|
|
|
#! and if a mouse button is down, fire a drag gesture to the
|
|
|
|
#! gadget that was clicked.
|
|
|
|
[ motion ] over hand-gadget handle-gesture drop
|
|
|
|
dup hand-buttons [
|
2005-03-03 20:43:55 -05:00
|
|
|
dup hand-clicked [ drag ] motion-gesture
|
2005-02-26 02:11:25 -05:00
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] ifte ;
|
2005-02-05 11:52:24 -05:00
|
|
|
|
|
|
|
: move-hand ( x y hand -- )
|
|
|
|
dup shape-pos >r
|
|
|
|
[ move-gadget ] keep
|
2005-02-05 22:51:41 -05:00
|
|
|
dup hand-gadget >r
|
2005-02-05 11:52:24 -05:00
|
|
|
dup update-hand-gadget
|
2005-02-05 22:51:41 -05:00
|
|
|
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 ;
|