steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

mouse enter/leave events

cvs
Slava Pestov 2005-02-05 16:52:24 +00:00
parent 3ba50f6665
commit 711c19445d
9 changed files with 130 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
library/test/gadgets.factor
View File

@ -5,21 +5,21 @@ USING: gadgets kernel lists math namespaces test ;
[
2000 x set
2000 y set
2030 2040 <point> 10 20 300 400 <rectangle> inside?
2030 2040 rect> 10 20 300 400 <rectangle> inside?
] with-scope
] unit-test
[ f ] [
[
2000 x set
2000 y set
2500 2040 <point> 10 20 300 400 <rectangle> inside?
2500 2040 rect> 10 20 300 400 <rectangle> inside?
] with-scope
] unit-test
[ t ] [
[
-10 x set
-20 y set
0 0 <point> 10 20 300 400 <rectangle> inside?
0 0 rect> 10 20 300 400 <rectangle> inside?
] with-scope
] unit-test
[ 11 11 41 41 ] [
@ -33,7 +33,7 @@ USING: gadgets kernel lists math namespaces test ;
] unit-test
[ t ] [
default-paint [
0 0 <point> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
0 0 rect> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
] bind
] unit-test
@ -43,7 +43,7 @@ USING: gadgets kernel lists math namespaces test ;
[ f ] [
default-paint [
35 0 <point>
35 0 rect>
[ 10 30 50 70 ] [ funny-rect ] map
pick-up
] bind

6
library/ui/buttons.factor
View File

@ -14,4 +14,8 @@ USING: generic kernel lists math namespaces sdl ;
dup [ dup button-released ] r> append
[ button-up 1 ] set-action
dup [ button-pressed ]
[ button-down 1 ] set-action ;
[ button-down 1 ] set-action
dup [ USE: prettyprint . "Mouse left" USE: stdio print ]
[ mouse-leave ] set-action
dup [ USE: prettyprint . "Mouse enter" USE: stdio print ]
[ mouse-enter ] set-action ;

22
library/ui/events.factor
View File

@ -18,23 +18,19 @@ M: resize-event handle-event ( event -- )
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
world get redraw ;
: button-event-pos ( event -- point )
dup button-event-x swap button-event-y <point> ;
: button-gesture ( button gesture -- [ gesture button ] )
swap unit append my-hand hand-clicked handle-gesture ;
M: button-down-event handle-event ( event -- )
dup button-event-pos my-hand set-hand-click-pos
my-hand hand-click-pos world get pick-up
my-hand set-hand-clicked
button-event-button dup my-hand button/
button-down swap 2list my-hand button-gesture ;
[ button-down ] button-gesture ;
M: button-up-event handle-event ( event -- )
button-event-button
dup my-hand button\
button-up swap 2list my-hand button-gesture
f my-hand set-hand-clicked
f my-hand set-hand-click-pos ;
button-event-button dup my-hand button\
[ button-up ] button-gesture ;
: motion-event-pos ( event -- x y )
dup motion-event-x swap motion-event-y ;
M: motion-event handle-event ( event -- )
dup motion-event-x swap motion-event-y my-hand move-gadget
[ motion ] my-hand motion-gesture ;
motion-event-pos my-hand move-hand ;

41
library/ui/gadgets.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables kernel lists namespaces ;
USING: generic hashtables kernel lists math namespaces ;
! A gadget is a shape, a paint, a mapping of gestures to
! actions, and a reference to the gadget's parent. A gadget
@ -18,18 +18,6 @@ C: gadget ( shape -- gadget )
[ t swap set-gadget-relayout? ] keep
[ t swap set-gadget-redraw? ] keep ;
: paint-property ( gadget key -- value )
swap gadget-paint hash ;
: set-paint-property ( gadget value key -- )
rot gadget-paint set-hash ;
: action ( gadget gesture -- quot )
swap gadget-gestures hash ;
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
: redraw ( gadget -- )
#! Redraw a gadget before the next iteration of the event
#! loop.
@ -50,20 +38,37 @@ C: gadget ( shape -- gadget )
: resize-gadget ( w h gadget -- )
[ resize-shape ] keep redraw ;
: box- ( gadget box -- )
: remove-gadget ( gadget box -- )
[ 2dup gadget-children remq swap set-gadget-children ] keep
relayout
f swap set-gadget-parent ;
: (box+) ( gadget box -- )
: (add-gadget) ( gadget box -- )
[ gadget-children cons ] keep set-gadget-children ;
: unparent ( gadget -- )
dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
dup gadget-parent dup [ remove-gadget ] [ 2drop ] ifte ;
: box+ ( gadget box -- )
: add-gadget ( gadget box -- )
#! Add a gadget to a box.
over unparent
dup pick set-gadget-parent
tuck (box+)
tuck (add-gadget)
relayout ;
: each-parent ( gadget quot -- )
#! Apply quotation to each parent of the gadget in turn,
#! stopping when the quotation returns f.
[ call ] 2keep rot [
>r gadget-parent dup [
r> each-parent
] [
r> 2drop
] ifte
] [
2drop
] ifte ;
: screen-pos ( gadget -- point )
#! The position of the gadget on the screen.
0 swap [ shape-pos + t ] each-parent ;

44
library/ui/gestures.factor
View File

@ -1,7 +1,13 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien generic hashtables kernel lists sdl-event ;
USING: alien generic hashtables kernel lists math sdl-event ;
: action ( gadget gesture -- quot )
swap gadget-gestures hash ;
: set-action ( gadget quot gesture -- )
rot gadget-gestures set-hash ;
: handle-gesture* ( gesture gadget -- ? )
tuck gadget-gestures hash* dup [
@ -14,17 +20,35 @@ USING: alien generic hashtables kernel lists sdl-event ;
#! If a gadget's handle-gesture* generic returns t, the
#! event was not consumed and is passed on to the gadget's
#! parent.
dup [
2dup handle-gesture* [
gadget-parent handle-gesture
] [
2drop
] ifte
] [
2drop
] ifte ;
[ dupd handle-gesture* ] each-parent drop ;
! Mouse gestures are lists where the first element is one of:
SYMBOL: motion
SYMBOL: button-up
SYMBOL: button-down
: mouse-enter ( point gadget -- )
#! If the old point is inside the new gadget, do not fire an
#! enter gesture, since the mouse did not enter. Otherwise,
#! fire an enter gesture and go on to the parent.
[
[ shape-pos + ] keep
2dup inside? [
drop f
] [
[ mouse-enter ] swap handle-gesture* drop t
] ifte
] each-parent drop ;
: mouse-leave ( point gadget -- )
#! If the new point is inside the old gadget, do not fire a
#! leave gesture, since the mouse did not leave. Otherwise,
#! fire a leave gesture and go on to the parent.
[
[ shape-pos + ] keep
2dup inside? [
drop f
] [
[ mouse-leave ] swap handle-gesture* drop t
] ifte
] each-parent drop ;

44
library/ui/hand.factor
View File

@ -44,27 +44,41 @@ DEFER: world
! 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
! its contents.
TUPLE: hand click-pos clicked buttons delegate ;
TUPLE: hand click-pos clicked buttons gadget delegate ;
C: hand ( world -- hand )
0 0 <point> <gadget>
0 0 0 0 <rectangle> <gadget>
over set-hand-delegate
[ set-gadget-parent ] keep ;
: motion-gesture ( gesture hand -- )
#! Send the gesture to the gadget at the hand's position in
#! the world.
world get pick-up handle-gesture ;
: button-gesture ( gesture hand -- )
#! Send the gesture to the gadget at the hand's last click
#! position in the world. This is used to send a button up
#! to the gadget that was clicked, regardless of the mouse
#! position at the time of the button up.
hand-clicked handle-gesture ;
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
: button/ ( n hand -- )
dup hand-gadget over set-hand-clicked
dup shape-pos over set-hand-click-pos
[ hand-buttons unique ] keep set-hand-buttons ;
: button\ ( n hand -- )
[ hand-buttons remove ] keep set-hand-buttons ;
: fire-leave ( hand -- )
dup hand-gadget [ swap shape-pos swap screen-pos - ] keep
mouse-leave ;
: fire-enter ( oldpos hand -- )
hand-gadget [ screen-pos - ] keep
mouse-enter ;
: gadget-at-hand ( hand -- gadget )
dup gadget-children [ car ] [ world get pick-up ] ?ifte ;
: update-hand-gadget ( hand -- )
#! The hand gadget is the gadget under the hand right now.
dup gadget-at-hand [ swap set-hand-gadget ] keep ;
: move-hand ( x y hand -- )
dup shape-pos >r
[ move-gadget ] keep
dup fire-leave
dup update-hand-gadget
[ motion ] swap handle-gesture
r> swap fire-enter ;

6
library/ui/layouts.factor
View File

@ -55,7 +55,7 @@ C: border ( delegate size -- border )
[ set-border-size ] keep [ set-border-delegate ] keep ;
: standard-border ( child delegate -- border )
5 <border> [ box+ ] keep ;
5 <border> [ add-gadget ] keep ;
: empty-border ( child -- border )
0 0 0 0 <rectangle> <gadget> standard-border ;
@ -76,8 +76,8 @@ C: border ( delegate size -- border )
: layout-border-w/h ( border -- )
[
dup shape-h over border-size - >r
dup shape-w swap border-size - r>
dup shape-h over border-size 2 * - >r
dup shape-w swap border-size 2 * - r>
] keep
gadget-children [ >r 2dup r> resize-gadget ] each 2drop ;

13
library/ui/paint.factor
View File

@ -1,13 +1,20 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel lists math namespaces sdl sdl-gfx ;
USING: generic hashtables kernel lists math namespaces
sdl sdl-gfx ;
! The painting protocol. Painting is controlled by various
! dynamically-scoped variables.
! "Paint" is a namespace containing some or all of these values.
: paint-property ( gadget key -- value )
swap gadget-paint hash ;
: set-paint-property ( gadget value key -- )
rot gadget-paint set-hash ;
! Colors are lists of three integers, 0..255.
SYMBOL: foreground ! Used for text and outline shapes.
SYMBOL: background ! Used for filled shapes.
@ -27,10 +34,6 @@ GENERIC: draw-shape ( obj -- )
M: rectangle draw-shape drop ;
M: point draw-shape ( point -- )
>r surface get r> dup point-x swap point-y
foreground get rgb pixelColor ;
TUPLE: hollow-rect delegate ;
C: hollow-rect ( x y w h -- rect )

33
library/ui/shapes.factor
View File

@ -49,28 +49,23 @@ GENERIC: resize-shape ( w h shape -- )
#! Compute a list of running sums of heights of shapes.
[ 0 swap [ over , shape-h + ] each ] make-list ;
! A point is the simplest shape.
TUPLE: point x y ;
! A point, represented as a complex number, is the simplest
! shape. It is not mutable and cannot be used as the delegate of
! a gadget.
: shape-pos ( shape -- pos )
dup shape-x swap shape-y rect> ;
C: point ( x y -- point )
[ set-point-y ] keep [ set-point-x ] keep ;
M: number inside? ( point point -- )
>r shape-pos r> = ;
M: point inside? ( point point -- )
over shape-x over point-x = >r
swap shape-y swap point-y = r> and ;
M: point shape-x point-x ;
M: point shape-y point-y ;
M: point shape-w drop 0 ;
M: point shape-h drop 0 ;
M: point move-shape ( x y point -- )
tuck set-point-y set-point-x ;
M: number shape-x real ;
M: number shape-y imaginary ;
M: number shape-w drop 0 ;
M: number shape-h drop 0 ;
: translate ( point shape -- point )
#! Translate a point relative to the shape.
over shape-y over shape-y - >r
swap shape-x swap shape-x - r> <point> ;
swap shape-pos swap shape-pos - ;
! A rectangle maps trivially to the shape protocol.
TUPLE: rectangle x y w h ;
@ -97,10 +92,10 @@ M: rectangle resize-shape ( w h rect -- )
tuck set-rectangle-h set-rectangle-w ;
: rectangle-x-extents ( rect -- x1 x2 )
dup rectangle-x x get + swap rectangle-w dupd + ;
dup rectangle-x x get + swap rectangle-w 1 - dupd + ;
: rectangle-y-extents ( rect -- x1 x2 )
dup rectangle-y y get + swap rectangle-h dupd + ;
dup rectangle-y y get + swap rectangle-h 1 - dupd + ;
M: rectangle inside? ( point rect -- ? )
over shape-x over rectangle-x-extents between? >r