From 711c19445dbaf11dfb22011a27313b90ea785fcd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Feb 2005 16:52:24 +0000 Subject: [PATCH] mouse enter/leave events --- library/test/gadgets.factor | 10 ++++----- library/ui/buttons.factor | 6 ++++- library/ui/events.factor | 22 ++++++++----------- library/ui/gadgets.factor | 41 +++++++++++++++++++--------------- library/ui/gestures.factor | 44 ++++++++++++++++++++++++++++--------- library/ui/hand.factor | 44 ++++++++++++++++++++++++------------- library/ui/layouts.factor | 6 ++--- library/ui/paint.factor | 13 ++++++----- library/ui/shapes.factor | 33 ++++++++++++---------------- 9 files changed, 130 insertions(+), 89 deletions(-) diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor index a2e26ca202..737d4762d2 100644 --- a/library/test/gadgets.factor +++ b/library/test/gadgets.factor @@ -5,21 +5,21 @@ USING: gadgets kernel lists math namespaces test ; [ 2000 x set 2000 y set - 2030 2040 10 20 300 400 inside? + 2030 2040 rect> 10 20 300 400 inside? ] with-scope ] unit-test [ f ] [ [ 2000 x set 2000 y set - 2500 2040 10 20 300 400 inside? + 2500 2040 rect> 10 20 300 400 inside? ] with-scope ] unit-test [ t ] [ [ -10 x set -20 y set - 0 0 10 20 300 400 inside? + 0 0 rect> 10 20 300 400 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 -10 -10 20 20 [ pick-up ] keep = + 0 0 rect> -10 -10 20 20 [ pick-up ] keep = ] bind ] unit-test @@ -43,7 +43,7 @@ USING: gadgets kernel lists math namespaces test ; [ f ] [ default-paint [ - 35 0 + 35 0 rect> [ 10 30 50 70 ] [ funny-rect ] map pick-up ] bind diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index 8a7dcf4dd0..629cd7bba9 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -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 ; diff --git a/library/ui/events.factor b/library/ui/events.factor index da283fac09..d7c5dbb57b 100644 --- a/library/ui/events.factor +++ b/library/ui/events.factor @@ -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 ; +: 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 ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 75f9f8dcdc..ff628d745e 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -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 ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index 844df6343e..f87b52d7e5 100644 --- a/library/ui/gestures.factor +++ b/library/ui/gestures.factor @@ -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 ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 1cb688f6d7..3d79517357 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -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 + 0 0 0 0 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 ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 769e96f166..1fabba7cf9 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -55,7 +55,7 @@ C: border ( delegate size -- border ) [ set-border-size ] keep [ set-border-delegate ] keep ; : standard-border ( child delegate -- border ) - 5 [ box+ ] keep ; + 5 [ add-gadget ] keep ; : empty-border ( child -- border ) 0 0 0 0 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 ; diff --git a/library/ui/paint.factor b/library/ui/paint.factor index 1882a5b49f..b1d4a92588 100644 --- a/library/ui/paint.factor +++ b/library/ui/paint.factor @@ -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 ) diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 288c03f962..86ff250bbc 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -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> ; + 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