New gesture handling style

TODO.FACTOR.txt

@@ -90,7 +90,6 @@ listener-gadget-scroller 4 slot ;
 - display lists
 - saving the image should save window configuration
 - variable width word wrap
-- new gesture style
 
 + compiler/ffi:
 

library/ui/apropos.factor

@@ -5,21 +5,20 @@ kernel ;
 
 TUPLE: apropos-gadget scroller input ;
 
-: apropos-pane ( gadget -- pane )
-    [ apropos-gadget? ] find-parent
+: apropos-gadget-pane ( apropos -- pane )
     apropos-gadget-scroller scroller-gadget ;
 
-: <prompt> ( quot -- editor )
-    "" <editor> [
-        swap T{ key-down f f "RETURN" } set-action
-    ] keep ;
-
-: show-apropos ( editor -- )
-    dup commit-editor-text
-    swap apropos-pane [ apropos ] with-pane ;
-
 : <apropos-prompt> ( -- gadget )
-    [ show-apropos ] <prompt> dup faint-boundary ;
+    "" <editor> dup faint-boundary ;
+
+: show-apropos ( apropos -- )
+    dup apropos-gadget-input commit-editor-text
+    swap apropos-gadget-pane [ apropos ] with-pane ;
+
+M: apropos-gadget gadget-gestures
+    drop H{
+        { T{ key-down f f "RETURN" } [ show-apropos ] }
+    } ;
 
 C: apropos-gadget ( -- )
     {

library/ui/buttons.factor

@@ -27,16 +27,17 @@ TUPLE: button rollover? pressed? quot ;
 : button-clicked ( button -- )
     dup button-quot if-clicked ;
 
-: button-gestures ( button quot -- )
-    over set-button-quot
-    dup [ button-clicked ] T{ button-up } set-action
-    dup [ button-update ] T{ button-down } set-action
-    dup [ button-update ] T{ mouse-leave } set-action
-    [ button-update ] T{ mouse-enter } set-action ;
+M: button gadget-gestures
+    drop H{
+        { T{ button-up } [ button-clicked ] }
+        { T{ button-down } [ button-update ] }
+        { T{ mouse-leave } [ button-update ] }
+        { T{ mouse-enter } [ button-update ] }
+    } ;
 
 C: button ( gadget quot -- button )
     rot <default-border> over set-gadget-delegate
-    [ swap button-gestures ] keep ;
+    [ set-button-quot ] keep ;
 
 : <highlight-button> ( gadget quot -- button )
     <button> { 0 0 0 } over set-border-size ;
@@ -53,16 +54,22 @@ C: button ( gadget quot -- button )
 : repeat-button-up ( button -- )
     dup button-update remove-timer ;
 
-: repeat-actions ( button -- )
-    dup [ repeat-button-down ] T{ button-down } set-action
-    [ repeat-button-up ] T{ button-up } set-action ;
+TUPLE: repeat-button ;
 
-: <repeat-button> ( gadget quot -- button )
+M: repeat-button gadget-gestures
+    drop H{
+        { T{ button-down } [ repeat-button-down ] }
+        { T{ button-up } [ repeat-button-up ] }
+        { T{ mouse-leave } [ button-update ] }
+        { T{ mouse-enter } [ button-update ] }
+    } ;
+
+C: repeat-button ( gadget quot -- button )
     #! Button that calls the quotation every 100ms as long as
     #! the mouse is held down.
-    <bevel-button> dup repeat-actions ;
+    [ >r <bevel-button> r> set-gadget-delegate ] keep ;
 
-M: button tick ( ms object -- ) nip button-clicked ;
+M: repeat-button tick ( ms object -- ) nip button-clicked ;
 
 TUPLE: button-paint plain rollover pressed ;
 

library/ui/editors.factor

@@ -74,35 +74,11 @@ TUPLE: editor line caret font color ;
 : click-editor ( editor -- )
     dup hand-click-rel first over set-caret-x request-focus ;
 
-: popup-location ( editor -- loc )
-    dup screen-loc swap editor-caret rect-extent nip v+ ;
-
-: <completion-item> ( completion editor -- menu-item )
-    dupd [ [ complete ] with-editor drop ] curry curry 2array ;
-
-! : <completion-menu> ( editor completions -- menu )
-!     [ swap <completion-item> ] map-with <menu> ;
-
-: completion-menu ( editor completions -- )
-    2drop ;
-!    over popup-location -rot
-!    over >r <completion-menu> r> show-menu ;
-
-: do-completion-1 ( editor completions -- )
-    swap [ first complete ] with-editor ;
-
-: do-completion ( editor -- )
-    dup [ line-completions ] with-editor {
-        { [ dup empty? ] [ 2drop ] }
-        { [ dup length 1 = ] [ do-completion-1 ] }
-        { [ t ] [ completion-menu ] }
-    } cond ;
-
-: editor-actions ( editor -- )
-    H{
+M: editor gadget-gestures
+    drop H{
+        { T{ button-down } [ click-editor ] }
         { T{ gain-focus } [ focus-editor ] }
         { T{ lose-focus } [ unfocus-editor ] }
-        { T{ button-down } [ click-editor ] }
         { T{ key-down f f "BACKSPACE" } [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
         { T{ key-down f f "DELETE" } [ [ T{ char-elt } delete-next-elt ] with-editor ] }
         { T{ key-down f { C+ } "BACKSPACE" } [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
@@ -117,15 +93,14 @@ TUPLE: editor line caret font color ;
         { T{ key-down f f "END" } [ [ T{ document-elt } next-elt ] with-editor ] }
         { T{ key-down f { C+ } "k" } [ [ line-clear ] with-editor ] }
         { T{ key-down f f "TAB" } [ do-completion ] }
-    } add-actions ;
+    } ;
 
 C: editor ( text -- )
     dup delegate>gadget
     dup editor-theme
     <line-editor> over set-editor-line
     <caret> over set-editor-caret
-    [ set-editor-text ] keep
-    dup editor-actions ;
+    [ set-editor-text ] keep ;
 
 : offset>x ( gadget offset str -- x )
     head-slice >r label-font* r> string-width ;

library/ui/gadgets.factor

@@ -42,8 +42,7 @@ M: array rect-dim drop { 0 0 0 } ;
 
 TUPLE: gadget
     pref-dim parent children orientation
-    gestures visible? relayout? root?
-    interior boundary ;
+    visible? relayout? root? interior boundary ;
 
 : show-gadget t swap set-gadget-visible? ;
 

library/ui/gestures.factor

@@ -4,21 +4,12 @@ IN: gadgets
 USING: gadgets-labels gadgets-layouts hashtables kernel math
 namespaces queues sequences threads ;
 
-: action ( gadget gesture -- quot )
-    swap gadget-gestures ?hash ;
+GENERIC: gadget-gestures ( gadget -- hash )
 
-: init-gestures ( gadget -- gestures )
-    dup gadget-gestures
-    [ ] [ H{ } clone dup rot set-gadget-gestures ] ?if ;
+M: gadget gadget-gestures drop H{ } ;
 
-: set-action ( gadget quot gesture -- )
-    rot init-gestures set-hash ;
-
-: add-actions ( gadget hash -- )
-    dup [ >r init-gestures r> hash-update ] [ 2drop ] if ;
-
-: handle-gesture* ( gesture gadget -- ? )
-    tuck gadget-gestures ?hash dup [ call f ] [ 2drop t ] if ;
+: handle-gesture* ( gesture gadget -- )
+    tuck gadget-gestures hash [ call f ] [ drop t ] if* ;
 
 : handle-gesture ( gesture gadget -- ? )
     #! If a gadget's handle-gesture* generic returns t, the

library/ui/panes.factor

@@ -12,7 +12,7 @@ prettyprint sequences strings styles threads ;
 ! current: shelf
 ! input: editor
 TUPLE: pane output active current input prototype
-continuation scrolls? ;
+continuation input? ;
 
 : add-output 2dup set-pane-output add-gadget ;
 
@@ -61,24 +61,27 @@ SYMBOL: structured-input
 : pane-clear ( pane -- )
     dup pane-output clear-incremental pane-current clear-gadget ;
 
-: pane-actions ( line -- )
-    H{
-        { T{ button-down } [ pane-input click-editor ] }
-        { T{ key-down f f "RETURN" } [ pane-commit ] }
-        { T{ key-down f f "UP" } [ pane-input [ history-prev ] with-editor ] }
-        { T{ key-down f f "DOWN" } [ pane-input [ history-next ] with-editor ] }
-        { T{ key-down f { C+ } "l" } [ pane-clear ] }
-    } add-actions ;
-
 C: pane ( -- pane )
     <pile> over set-delegate
     <shelf> over set-pane-prototype
     <pile> <incremental> over add-output
     dup prepare-line ;
 
+M: pane gadget-gestures
+    pane-input [
+        H{
+            { T{ button-down } [ pane-input click-editor ] }
+            { T{ key-down f f "RETURN" } [ pane-commit ] }
+            { T{ key-down f f "UP" } [ pane-input [ history-prev ] with-editor ] }
+            { T{ key-down f f "DOWN" } [ pane-input [ history-next ] with-editor ] }
+            { T{ key-down f { C+ } "l" } [ pane-clear ] }
+        }
+    ] [
+        H{ }
+    ] if ;
+
 : <input-pane> ( -- pane )
-    <pane> t over set-pane-scrolls?
-    "" <editor> over set-pane-input dup pane-actions ;
+    <pane> "" <editor> over set-pane-input ;
 
 M: pane focusable-child* ( pane -- editor )
     pane-input [ t ] unless* ;
@@ -118,8 +121,7 @@ M: pane stream-flush ( pane -- ) drop ;
 M: pane stream-readln ( pane -- line )
     [ over set-pane-continuation stop ] callcc1 nip ;
 
-: scroll-pane ( pane -- )
-    dup pane-scrolls? [ pane-input scroll>caret ] [ drop ] if ;
+: scroll-pane ( pane -- ) pane-input [ scroll>caret ] when* ;
 
 M: pane stream-write1 ( char pane -- )
     [ pane-current stream-write1 ] keep scroll-pane ;

library/ui/scrolling.factor

@@ -25,10 +25,12 @@ TUPLE: scroller viewport x y follows ;
 
 : scroll-down-line scroller-y 1 swap slide-by-line ;
 
-: scroller-actions ( scroller -- )
-    dup [ scroll-up-line ] T{ wheel-up } set-action
-    dup [ scroll-down-line ] T{ wheel-down } set-action
-    [ relayout-1 ] T{ slider-changed } set-action ;
+M: scroller gadget-gestures
+    drop H{
+        { T{ wheel-up } [ scroll-up-line ] }
+        { T{ wheel-down } [ scroll-down-line ] }
+        { T{ slider-changed } [ relayout-1 ] }
+    } ;
 
 C: scroller ( gadget -- scroller )
     #! Wrap a scrolling pane around the gadget.
@@ -37,7 +39,6 @@ C: scroller ( gadget -- scroller )
         { [ <x-slider> ] set-scroller-x @bottom }
         { [ <y-slider> ] set-scroller-y @right }
     } make-frame*
-    dup scroller-actions
     t over set-gadget-root? ;
 
 : set-slider ( value page max slider -- )

library/ui/sliders.factor

@@ -52,6 +52,8 @@ TUPLE: slider-changed ;
         T{ slider-changed } swap handle-gesture drop
     ] if ;
 
+TUPLE: thumb ;
+
 : begin-drag ( thumb -- )
     find-slider dup slider-value swap set-slider-saved ;
 
@@ -60,16 +62,18 @@ TUPLE: slider-changed ;
     over screen>slider swap [ slider-saved + ] keep
     set-slider-value* ;
 
-: thumb-actions ( thumb -- )
-    dup [ drop ] T{ button-up } set-action
-    dup [ begin-drag ] T{ button-down } set-action
-    [ do-drag ] T{ drag } set-action ;
+M: thumb gadget-gestures
+    drop H{
+        { T{ button-down } [ begin-drag ] }
+        { T{ button-up } [ drop ] }
+        { T{ drag } [ do-drag ] }
+    } ;
 
-: <thumb> ( vector -- thumb )
-    <gadget> [ set-gadget-orientation ] keep
+C: thumb ( vector -- thumb )
+    dup delegate>gadget
     t over set-gadget-root?
     dup thumb-theme
-    dup thumb-actions ;
+    [ set-gadget-orientation ] keep ;
 
 : slide-by ( amount gadget -- )
     #! The gadget can be any child of a slider.
@@ -84,12 +88,13 @@ TUPLE: slider-changed ;
     over screen>slider over slider-value - sgn
     swap slide-by-page ;
 
-: elevator-actions ( elevator -- )
-    [ elevator-click ] T{ button-down } set-action ;
+M: elevator gadget-gestures
+    drop H{ { T{ button-down } [ elevator-click ] } } ;
 
 C: elevator ( vector -- elevator )
-    dup delegate>gadget [ set-gadget-orientation ] keep
-    dup elevator-theme dup elevator-actions ;
+    dup delegate>gadget
+    dup elevator-theme
+    [ set-gadget-orientation ] keep ;
 
 : (layout-thumb) ( slider n -- n thumb )
     over gadget-orientation n*v swap slider-thumb ;

library/ui/tracks.factor

@@ -69,15 +69,15 @@ M: track pref-dim* ( track -- dim )
     dup gadget-parent divider-delta
     over divider-# rot gadget-parent change-divider ;
 
-: divider-actions ( divider -- )
-    dup [ gadget-parent save-sizes ] T{ button-down } set-action
-    dup [ drop ] T{ button-up } set-action
-    [ divider-motion ] T{ drag } set-action ;
+M: divider gadget-gestures
+    drop H{
+        { T{ button-down } [ gadget-parent save-sizes ] }
+        { T{ button-up } [ drop ] }
+        { T{ drag } [ divider-motion ] }
+    } ;
 
 C: divider ( -- divider )
-    dup delegate>gadget
-    dup divider-actions
-    dup reverse-video-theme ;
+    dup delegate>gadget dup reverse-video-theme ;
 
 : normalize-sizes ( sizes -- sizes )
     dup sum swap [ swap / ] map-with ;