[
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 ] [
] 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
[ f ] [
default-paint [
- 35 0 <point>
+ 35 0 rect>
[ 10 30 50 70 ] [ funny-rect ] map
pick-up
] bind
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 ;
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 ;
! 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
[ 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.
: 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 ;
! 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 [
#! 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 ;
! 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 ;
[ 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 ;
: 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 ;
! 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.
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 )
#! 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 ;
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
projects / factor.git / commitdiff