diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index f96778606d..e1c7c3cfb0 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -135,12 +135,19 @@ M: object reverse ( seq -- seq ) [ ] keep like ; : all-eq? ( seq -- ? ) [ eq? ] monotonic? ; +: mismatch ( seq1 seq2 -- i ) + #! Return the first index where the two sequences differ. + 2dup min-length + [ >r 2dup r> 2nth-unsafe = not ] find + swap >r 3drop r> ; flushable + ! Lexicographic comparison : lexi ( s1 s2 -- n ) #! Lexicographically compare two sequences of numbers #! (usually strings). Negative if s1s2. - 0 pick pick min-length (lexi) ; flushable + 2dup mismatch dup -1 = [ 3drop 0 ] [ 2nth-unsafe - ] if ; + flushable : flip ( seq -- seq ) #! An example illustrates this word best: diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index c0956bbcaa..6ec2a6d676 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -49,6 +49,9 @@ GENERIC: resize ( n seq -- seq ) : bounds-check? ( n seq -- ? ) over 0 >= [ length < ] [ 2drop f ] if ; +: 2nth ( s s n -- x x ) + tuck swap nth >r swap nth r> ; inline + IN: sequences-internals ! Unsafe sequence protocol for inner loops @@ -58,9 +61,6 @@ GENERIC: set-nth-unsafe M: object nth-unsafe nth ; M: object set-nth-unsafe set-nth ; -: 2nth-unsafe ( s s n -- x x ) - tuck swap nth-unsafe >r swap nth-unsafe r> ; inline - : change-nth-unsafe ( seq i quot -- ) pick pick >r >r >r swap nth-unsafe r> call r> r> swap set-nth-unsafe ; inline diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index 00ac4d240f..a2a55cfa35 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -101,3 +101,7 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; : cut ( n seq -- before after ) [ (cut) ] keep like ; flushable + +: drop-prefix ( seq1 seq2 -- seq1 seq2 ) + 2dup mismatch dup -1 = [ drop 2dup min-length ] when + tuck swap tail-slice >r swap tail-slice r> ; diff --git a/library/collections/virtual-sequences.factor b/library/collections/virtual-sequences.factor index e6a3bef242..0860e2fb58 100644 --- a/library/collections/virtual-sequences.factor +++ b/library/collections/virtual-sequences.factor @@ -37,6 +37,7 @@ TUPLE: slice seq from to ; dup slice-from swap slice-seq >r tuck + >r + r> r> ; : check-slice ( from to seq -- ) + pick 0 < [ "Slice begins before 0" throw ] when length over < [ "Slice longer than sequence" throw ] when > [ "Slice start is after slice end" throw ] when ; diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor index 1da904dd12..560ab9412f 100644 --- a/library/help/tutorial.factor +++ b/library/help/tutorial.factor @@ -29,9 +29,7 @@ M: general-list tutorial-line car dup example-theme ; : ( list -- gadget ) - [ tutorial-line ] map - make-pile 1 over set-pack-fill - empty-border ; + [ tutorial-line ] map make-pile 1 over set-pack-fill ; : tutorial-pages { diff --git a/library/test/collections/sequences.factor b/library/test/collections/sequences.factor index 70cdc828b5..6f5e940d4e 100644 --- a/library/test/collections/sequences.factor +++ b/library/test/collections/sequences.factor @@ -176,3 +176,17 @@ unit-test [ -1 f ] [ -1 { 1 2 3 } [ 1 = ] find* ] unit-test [ { 1 2 3 } ] [ { 1 1 2 2 3 3 } prune ] unit-test + +[ 0 ] [ { "a" "b" "c" } { "A" "B" "C" } mismatch ] unit-test + +[ 1 ] [ { "a" "b" "c" } { "a" "B" "C" } mismatch ] unit-test + +[ -1 ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test + +[ { } { } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test + +[ { "C" } { "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test + +[ -1 1 "abc" ] unit-test-fails + +[ { "a" "b" } { } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test diff --git a/library/ui/books.factor b/library/ui/books.factor index f1b812a355..eda99834f7 100644 --- a/library/ui/books.factor +++ b/library/ui/books.factor @@ -8,8 +8,8 @@ sequences ; TUPLE: book page ; C: book ( pages -- book ) - over set-delegate - 0 over set-book-page [ add-gadgets ] keep ; + [ >r make-stack r> set-gadget-delegate ] keep + 0 over set-book-page ; M: book layout* ( book -- ) dup delegate layout* @@ -47,6 +47,6 @@ TUPLE: book-browser book ; ] { } make make-shelf ; C: book-browser ( book -- gadget ) - dup frame-delegate + dup delegate>frame over @top frame-add [ 2dup set-book-browser-book @center frame-add ] keep ; diff --git a/library/ui/borders.factor b/library/ui/borders.factor index 5db14e42d1..8f530576f6 100644 --- a/library/ui/borders.factor +++ b/library/ui/borders.factor @@ -6,17 +6,16 @@ hashtables kernel math namespaces vectors ; TUPLE: border size ; -C: border ( size -- border ) - dup gadget-delegate [ set-border-size ] keep ; - -: empty-border ( child -- border ) - @{ 5 5 0 }@ [ add-gadget ] keep ; +C: border ( child -- border ) + dup delegate>gadget + @{ 5 5 0 }@ over set-border-size + [ add-gadget ] keep ; : line-border ( child -- border ) - empty-border dup solid-boundary ; + dup solid-boundary ; : bevel-border ( child -- border ) - empty-border dup bevel-theme ; + dup bevel-theme ; : layout-border-loc ( border -- ) dup border-size swap gadget-child set-rect-loc ; diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor index 8d1d125080..78c8ca2c6e 100644 --- a/library/ui/buttons.factor +++ b/library/ui/buttons.factor @@ -39,10 +39,8 @@ styles threads ; TUPLE: button ; C: button ( gadget quot -- button ) - @{ 5 5 0 }@ over set-delegate - dup button-theme - [ swap button-gestures ] keep - [ add-gadget ] keep ; + rot bevel-border over set-gadget-delegate + [ swap button-gestures ] keep ; : ( gadget quot -- button ) >r dup roll-button-theme dup r> button-gestures ; diff --git a/library/ui/editors.factor b/library/ui/editors.factor index 43d65ac30b..b0b3158295 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -9,7 +9,7 @@ lists math namespaces sdl sequences strings styles threads ; TUPLE: caret ; C: caret ( -- caret ) - dup gadget-delegate dup caret-theme ; + dup delegate>gadget dup caret-theme ; M: caret tick ( ms caret -- ) nip toggle-visible ; @@ -112,7 +112,7 @@ TUPLE: editor line caret ; }} add-actions ; C: editor ( text -- ) - dup gadget-delegate + dup delegate>gadget dup editor-theme over set-editor-line over set-editor-caret diff --git a/library/ui/frames.factor b/library/ui/frames.factor index 485cb6a1f4..1c025d53fe 100644 --- a/library/ui/frames.factor +++ b/library/ui/frames.factor @@ -23,9 +23,9 @@ TUPLE: frame grid ; : @bottom-right 2 2 ; C: frame ( -- frame ) - dup gadget-delegate over set-frame-grid ; + dup delegate>gadget over set-frame-grid ; -: frame-delegate ( tuple -- ) swap set-delegate ; +: delegate>frame ( tuple -- ) swap set-delegate ; : frame-child ( frame i j -- gadget ) rot frame-grid nth nth ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index e8087a284a..2c968364d7 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -36,7 +36,7 @@ M: array rect-dim drop @{ 0 0 0 }@ ; ! actions, and a reference to the gadget's parent. TUPLE: gadget paint gestures visible? relayout? root? - parent children help ; + parent children ; : show-gadget t swap set-gadget-visible? ; @@ -49,7 +49,7 @@ M: gadget = eq? ; C: gadget ( -- gadget ) @{ 0 0 0 }@ dup over set-delegate dup show-gadget ; -: gadget-delegate ( tuple -- ) swap set-delegate ; +: delegate>gadget ( tuple -- ) swap set-delegate ; GENERIC: user-input* ( ch gadget -- ? ) @@ -74,13 +74,21 @@ M: gadget children-on ( rect/point gadget -- list ) : translate ( rect/point -- ) rect-loc origin [ v+ ] change ; -: (pick-up) ( rect/point gadget -- gadget ) - 2dup inside? [ - dup translate 2dup pick-up-list dup - [ nip (pick-up) ] [ rot 2drop ] if - ] [ 2drop f ] if ; - : pick-up ( rect/point gadget -- gadget ) - [ (pick-up) ] with-scope ; + [ + 2dup inside? [ + dup translate 2dup pick-up-list dup + [ nip pick-up ] [ rot 2drop ] if + ] [ 2drop f ] if + ] with-scope ; : max-dim ( dims -- dim ) @{ 0 0 0 }@ [ vmax ] reduce ; + +: set-gadget-delegate ( delegate gadget -- ) + dup pick gadget-children [ set-gadget-parent ] each-with + set-delegate ; + +! Pointer help protocol +GENERIC: gadget-help + +M: gadget gadget-help drop f ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 7d1d2e6b56..d829d14e3c 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -14,7 +14,7 @@ prettyprint sdl sequences vectors ; TUPLE: hand click-loc click-rel clicked buttons gadget focus ; C: hand ( -- hand ) - dup gadget-delegate { } clone over set-hand-buttons ; + dup delegate>gadget { } clone over set-hand-buttons ; : button/ ( n hand -- ) dup hand-gadget over set-hand-clicked @@ -37,27 +37,27 @@ C: hand ( -- hand ) dup hand-buttons empty? [ dup dup hand-clicked [ drag ] drag-gesture ] unless drop ; -: drop-prefix ( l1 l2 -- l1 l2 ) - 2dup and [ 2dup 2car eq? [ 2cdr drop-prefix ] when ] when ; - : each-gesture ( gesture seq -- ) [ handle-gesture* drop ] each-with ; -: hand-gestures ( hand new old -- ) - drop-prefix - reverse [ mouse-leave ] swap each-gesture - swap fire-motion +: hand-gestures ( new old -- ) + drop-prefix reverse-slice + [ mouse-leave ] swap each-gesture + hand get fire-motion [ mouse-enter ] swap each-gesture ; : focus-gestures ( new old -- ) - drop-prefix - reverse [ lose-focus ] swap each-gesture + drop-prefix reverse-slice + [ lose-focus ] swap each-gesture [ gain-focus ] swap each-gesture ; +: focused-ancestors ( hand -- seq ) + hand get hand-focus parents reverse-slice ; + : request-focus ( gadget -- ) - focusable-child - hand get dup hand-focus parents-down >r - dupd set-hand-focus parents-down r> focus-gestures ; + focusable-child focused-ancestors >r + hand get set-hand-focus focused-ancestors + r> focus-gestures ; : drag-loc ( gadget -- loc ) hand get [ relative ] keep hand-click-rel v- ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index d422fe32b3..a27334b58f 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -35,28 +35,24 @@ namespaces sequences vectors ; #! Add all gadgets in a sequence to a parent gadget. swap [ over (add-gadget) ] each relayout ; -: (parents-down) ( list gadget -- list ) - [ [ swons ] keep gadget-parent (parents-down) ] when* ; +: (parents) ( gadget vector -- ) + over + [ 2dup push >r gadget-parent r> (parents) ] [ 2drop ] if ; -: parents-down ( gadget -- list ) - #! A list of all parents of the gadget, the last element - #! is the gadget itself. - f swap (parents-down) ; - -: parents-up ( gadget -- list ) +: parents ( gadget -- vector ) #! A list of all parents of the gadget, the first element #! is the gadget itself. - dup [ dup gadget-parent parents-up cons ] when ; + { } clone [ (parents) ] keep ; : each-parent ( gadget quot -- ? ) - >r parents-up r> all? ; inline + >r parents r> all? ; inline : find-parent ( gadget quot -- ? ) - >r parents-up r> find nip ; inline + >r parents r> find nip ; inline : screen-loc ( gadget -- point ) #! The position of the gadget on the screen. - parents-up @{ 0 0 0 }@ [ rect-loc v+ ] reduce ; + parents @{ 0 0 0 }@ [ rect-loc v+ ] reduce ; : gadget-point ( gadget vector -- point ) #! @{ 0 0 0 }@ - top left corner @@ -66,7 +62,7 @@ namespaces sequences vectors ; : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ; -: child? ( parent child -- ? ) parents-down memq? ; +: child? ( parent child -- ? ) parents memq? ; GENERIC: focusable-child* ( gadget -- gadget/t ) @@ -81,3 +77,5 @@ IN: gadgets-layouts : make-pile ( children -- pack ) [ add-gadgets ] keep ; : make-shelf ( children -- pack ) [ add-gadgets ] keep ; + +: make-stack ( children -- pack ) [ add-gadgets ] keep ; diff --git a/library/ui/incremental.factor b/library/ui/incremental.factor index 354075131b..6d10d55df9 100644 --- a/library/ui/incremental.factor +++ b/library/ui/incremental.factor @@ -15,8 +15,8 @@ USING: gadgets generic io kernel math namespaces ; TUPLE: incremental cursor ; C: incremental ( pack -- incremental ) - [ set-delegate ] keep - @{ 0 0 0 }@ over set-incremental-cursor ; + [ set-gadget-delegate ] keep + dup delegate pref-dim over set-incremental-cursor ; M: incremental pref-dim ( incremental -- dim ) dup gadget-relayout? [ diff --git a/library/ui/labels.factor b/library/ui/labels.factor index 7e9d6499a7..bbc38b2cea 100644 --- a/library/ui/labels.factor +++ b/library/ui/labels.factor @@ -8,7 +8,7 @@ kernel math namespaces sdl sequences styles ; TUPLE: label text ; C: label ( text -- label ) - dup gadget-delegate [ set-label-text ] keep ; + dup delegate>gadget [ set-label-text ] keep ; : label-size ( gadget text -- dim ) >r gadget-font r> size-string 0 3array ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 125d5347db..196799f9c2 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -91,12 +91,12 @@ C: pack ( vector -- pack ) #! fill: 0 leaves default width, 1 fills to pack width. #! align: 0 left, 1/2 center, 1 right. [ set-pack-vector ] keep - dup gadget-delegate + dup delegate>gadget 0 over set-pack-align 0 over set-pack-fill @{ 0 0 0 }@ over set-pack-gap ; -: pack-delegate ( vector tuple -- ) >r r> set-delegate ; +: delegate>pack ( vector tuple -- ) >r r> set-delegate ; : ( -- pack ) @{ 0 1 0 }@ ; @@ -128,7 +128,7 @@ TUPLE: stack ; C: stack ( -- gadget ) #! A stack lays out all its children on top of each other. - @{ 0 0 1 }@ over pack-delegate 1 over set-pack-fill ; + @{ 0 0 1 }@ over delegate>pack 1 over set-pack-fill ; M: stack children-on ( point stack -- gadget ) nip gadget-children ; diff --git a/library/ui/listener.factor b/library/ui/listener.factor index 71e427bc74..6e85e5c608 100644 --- a/library/ui/listener.factor +++ b/library/ui/listener.factor @@ -22,7 +22,7 @@ TUPLE: display title pane ; 2dup set-display-title @top frame-add ; C: display ( -- display ) - dup frame-delegate + dup delegate>frame "" over add-display-title f f 2dup swap set-display-pane over @center frame-add ; diff --git a/library/ui/menus.factor b/library/ui/menus.factor index 54e4f4c25e..dcb6c664b2 100644 --- a/library/ui/menus.factor +++ b/library/ui/menus.factor @@ -6,10 +6,8 @@ gadgets-labels gadgets-theme generic kernel lists math namespaces sequences ; : retarget-drag ( -- ) - hand get [ rect-loc world get pick-up ] keep - 2dup hand-clicked eq? [ - 2dup set-hand-clicked dup update-hand - ] unless 2drop ; + hand get [ hand-gadget ] keep 2dup hand-clicked eq? + [ 2dup set-hand-clicked update-hand ] unless 2drop ; : menu-actions ( glass -- ) dup [ drop retarget-drag ] [ drag 1 ] set-action @@ -40,8 +38,6 @@ namespaces sequences ; #! Given an association list mapping labels to quotations. menu-items line-border dup menu-theme ; -: ( gadget quot -- button ) - [ show-hand-menu ] append +: menu-button-actions ( gadget -- ) dup [ button-clicked ] [ button-down 1 ] set-action - dup [ button-update ] [ button-up 1 ] set-action ; - + [ button-update ] [ button-up 1 ] set-action ; diff --git a/library/ui/outliner.factor b/library/ui/outliner.factor index e2f391df54..42da01fdb1 100644 --- a/library/ui/outliner.factor +++ b/library/ui/outliner.factor @@ -25,7 +25,7 @@ DEFER: : ( ? -- gadget ) arrow-right arrow-down ? - dup icon-theme empty-border ; + dup icon-theme ; : ( ? -- gadget ) #! If true, the button expands, otherwise it collapses. @@ -35,7 +35,7 @@ DEFER: C: outliner ( gadget quot -- gadget ) #! The quotation generates child gadgets. - dup frame-delegate + dup delegate>frame [ set-outliner-quot ] keep [ >r 1array make-shelf r> @top frame-add ] keep f over set-outliner-expanded? ; diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index f8a88e4884..6e65a65652 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -2,9 +2,10 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets-presentations USING: arrays compiler gadgets gadgets-buttons gadgets-labels -gadgets-menus gadgets-outliner gadgets-panes generic hashtables -inference inspector io jedit kernel lists memory namespaces -parser prettyprint sequences strings styles words ; +gadgets-menus gadgets-outliner gadgets-panes gadgets-theme +generic hashtables inference inspector io jedit kernel lists +memory namespaces parser prettyprint sequences strings styles +words ; SYMBOL: commands @@ -19,14 +20,23 @@ SYMBOL: commands : command-quot ( presented quot -- quot ) [ \ drop , curry , [ pane get pane-call ] % ] [ ] make ; -: command-menu ( presented -- menu ) - dup applicable - [ [ third command-quot ] keep second swons ] map-with - ; +TUPLE: command-button object ; -: ( gadget object -- button ) - [ [ nip command-menu ] curry ] keep - summary over set-gadget-help ; +: command-menu ( command-button -- ) + command-button-object dup applicable + [ [ third command-quot ] keep second swons ] map-with + show-hand-menu ; + +C: command-button ( gadget object -- button ) + [ set-command-button-object ] keep + [ set-gadget-delegate ] keep + dup [ command-menu ] button-gestures + dup roll-button-theme + dup menu-button-actions ; + +M: command-button gadget-help ( button -- string ) + command-button-object + dup word? [ [ synopsis ] string-out ] [ summary ] if ; : init-commands ( gadget -- gadget ) dup presented paint-prop [ ] when* ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 8d774842af..e09899ff03 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -22,7 +22,7 @@ TUPLE: scroller viewport x y ; : viewport-dim gadget-child pref-dim ; C: viewport ( content -- viewport ) - dup gadget-delegate + dup delegate>gadget t over set-gadget-root? [ add-gadget ] keep ; @@ -83,7 +83,7 @@ M: viewport focusable-child* ( viewport -- gadget ) C: scroller ( gadget -- scroller ) #! Wrap a scrolling pane around the gadget. - dup frame-delegate + dup delegate>frame [ >r r> add-viewport ] keep over add-x-slider over add-y-slider diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor index 2ecd41d311..dbcac58daa 100644 --- a/library/ui/sliders.factor +++ b/library/ui/sliders.factor @@ -54,7 +54,7 @@ SYMBOL: slider-changed [ find-elevator elevator-drag ] [ drag 1 ] set-action ; : ( -- thumb ) - dup button-theme + dup bevel-theme t over set-gadget-root? dup thumb-actions ; @@ -75,7 +75,7 @@ SYMBOL: slider-changed [ elevator-click ] [ button-down 1 ] set-action ; C: elevator ( -- elevator ) - dup gadget-delegate + dup delegate>gadget dup elevator-theme dup elevator-actions ; @@ -126,7 +126,7 @@ M: elevator layout* ( elevator -- ) C: slider ( vector -- slider ) [ set-slider-vector ] keep - dup frame-delegate + dup delegate>frame 0 over set-slider-value 0 over set-slider-page 0 over set-slider-max diff --git a/library/ui/splitters.factor b/library/ui/splitters.factor index 3d6862e2fb..a9abdde72d 100644 --- a/library/ui/splitters.factor +++ b/library/ui/splitters.factor @@ -26,10 +26,10 @@ TUPLE: splitter split ; [ gadget-parent divider-motion ] [ drag 1 ] set-action ; C: divider ( -- divider ) - dup gadget-delegate dup divider-theme dup divider-actions ; + dup delegate>gadget dup divider-theme dup divider-actions ; C: splitter ( first second split vector -- splitter ) - [ pack-delegate ] keep + [ delegate>pack ] keep [ set-splitter-split ] keep [ >r >r r> 3array r> add-gadgets ] keep 1 over set-pack-fill ; diff --git a/library/ui/theme.factor b/library/ui/theme.factor index 34012e4cf5..771ec98a8b 100644 --- a/library/ui/theme.factor +++ b/library/ui/theme.factor @@ -11,18 +11,13 @@ USING: gadgets kernel styles ; : bevel-theme ( gadget -- ) dup solid-interior + dup @{ 216 216 216 }@ background set-paint-prop << bevel f 2 >> boundary set-paint-prop ; : editor-theme ( editor -- ) bold font-style set-paint-prop ; -: button-theme ( button -- ) - dup bevel-theme - dup @{ 216 216 216 }@ background set-paint-prop - f reverse-video set-paint-prop ; - : roll-button-theme ( button -- ) - dup f reverse-video set-paint-prop dup interior set-paint-prop boundary set-paint-prop ; diff --git a/library/ui/world.factor b/library/ui/world.factor index e311c7ddac..8065df5591 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -62,15 +62,21 @@ M: f set-message 2drop ; : update-help ( -- ) #! Update mouse-over help message. hand get hand-gadget - parents-up [ gadget-help ] map [ ] find nip + parents [ gadget-help ] map [ ] find nip show-message ; +: under-hand ( -- seq ) + #! A sequence whose first element is the world and last is + #! the current gadget, with all parents in between. + hand get hand-gadget parents reverse-slice ; + +: hand-grab ( -- gadget ) + hand get rect-loc world get pick-up ; + : move-hand ( loc -- ) - hand get dup hand-gadget parents-down >r - 2dup set-rect-loc - [ >r world get pick-up r> set-hand-gadget ] keep - dup hand-gadget parents-down r> hand-gestures - update-help ; + under-hand >r hand get set-rect-loc + hand-grab hand get set-hand-gadget + under-hand r> hand-gestures update-help ; M: motion-event handle-event ( event -- ) motion-event-loc move-hand ;