UI refactoring and fixes

library/collections/sequences-epilogue.factor

@@ -135,12 +135,19 @@ M: object reverse ( seq -- seq ) [ <reversed> ] 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 s1<s2, zero if s1=s2,
     #! positive if s1>s2.
-    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:

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

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> ;

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 ;
 

library/help/tutorial.factor

@@ -29,9 +29,7 @@ M: general-list tutorial-line
     car <input-button> dup example-theme ;
 
 : <page> ( list -- gadget )
-    [ tutorial-line ] map
+    [ tutorial-line ] map make-pile 1 over set-pack-fill <border> ;
-    make-pile 1 over set-pack-fill
-    empty-border ;
 
 : tutorial-pages
     {

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" <slice> ] unit-test-fails
+
+[ { "a" "b" } { } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test

library/ui/books.factor

@@ -8,8 +8,8 @@ sequences ;
 TUPLE: book page ;
 
 C: book ( pages -- book )
-    <stack> over set-delegate
+    [ >r make-stack r> set-gadget-delegate ] keep
-    0 over set-book-page [ add-gadgets ] 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
     <book-buttons> over @top frame-add
     [ 2dup set-book-browser-book @center frame-add ] keep ;

library/ui/borders.factor

@@ -6,17 +6,16 @@ hashtables kernel math namespaces vectors ;
 
 TUPLE: border size ;
 
-C: border ( size -- border )
+C: border ( child -- border )
-    dup gadget-delegate [ set-border-size ] keep ;
+    dup delegate>gadget
-
+    @{ 5 5 0 }@ over set-border-size
-: empty-border ( child -- border )
+    [ add-gadget ] keep ;
-    @{ 5 5 0 }@ <border> [ add-gadget ] keep ;
 
 : line-border ( child -- border )
-    empty-border dup solid-boundary ;
+    <border> dup solid-boundary ;
 
 : bevel-border ( child -- border )
-    empty-border dup bevel-theme ;
+    <border> dup bevel-theme ;
 
 : layout-border-loc ( border -- )
     dup border-size swap gadget-child set-rect-loc ;

library/ui/buttons.factor

@@ -39,10 +39,8 @@ styles threads ;
 TUPLE: button ;
 
 C: button ( gadget quot -- button )
-    @{ 5 5 0 }@ <border> over set-delegate
+    rot bevel-border over set-gadget-delegate
-    dup button-theme
+    [ swap button-gestures ] keep ;
-    [ swap button-gestures ] keep
-    [ add-gadget ] keep ;
 
 : <roll-button> ( gadget quot -- button )
     >r dup roll-button-theme dup r> button-gestures ;

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
     <line-editor> over set-editor-line
     <caret> over set-editor-caret

library/ui/frames.factor

@@ -23,9 +23,9 @@ TUPLE: frame grid ;
 : @bottom-right 2 2 ;
 
 C: frame ( -- frame )
-    dup gadget-delegate <frame-grid> over set-frame-grid ;
+    dup delegate>gadget <frame-grid> over set-frame-grid ;
 
-: frame-delegate ( tuple -- ) <frame> swap set-delegate ;
+: delegate>frame ( tuple -- ) <frame> swap set-delegate ;
 
 : frame-child ( frame i j -- gadget ) rot frame-grid nth nth ;
 

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 <rect> over set-delegate dup show-gadget ;
 
-: gadget-delegate ( tuple -- ) <gadget> swap set-delegate ;
+: delegate>gadget ( tuple -- ) <gadget> 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 ;

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 -- )
+: hand-gestures ( new old -- )
-    drop-prefix
+    drop-prefix reverse-slice
-    reverse [ mouse-leave ] swap each-gesture
+    [ mouse-leave ] swap each-gesture
-    swap fire-motion
+    hand get fire-motion
     [ mouse-enter ] swap each-gesture ;
 
 : focus-gestures ( new old -- )
-    drop-prefix
+    drop-prefix reverse-slice
-    reverse [ lose-focus ] swap each-gesture
+    [ 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
+    focusable-child focused-ancestors >r
-    hand get dup hand-focus parents-down >r
+    hand get set-hand-focus focused-ancestors
-    dupd set-hand-focus parents-down r> focus-gestures ;
+    r> focus-gestures ;
 
 : drag-loc ( gadget -- loc )
     hand get [ relative ] keep hand-click-rel v- ;

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 )
+: (parents) ( gadget vector -- )
-    [ [ swons ] keep gadget-parent (parents-down) ] when* ;
+    over
+    [ 2dup push >r gadget-parent r> (parents) ] [ 2drop ] if ;
 
-: parents-down ( gadget -- list )
+: parents ( gadget -- vector )
-    #! A list of all parents of the gadget, the last element
-    #! is the gadget itself.
-    f swap (parents-down) ;
-
-: parents-up ( gadget -- list )
     #! 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 ) <pile> [ add-gadgets ] keep ;
 
 : make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;
+
+: make-stack ( children -- pack ) <stack> [ add-gadgets ] keep ;

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
+    [ set-gadget-delegate ] keep
-    @{ 0 0 0 }@ over set-incremental-cursor ;
+    dup delegate pref-dim over set-incremental-cursor ;
 
 M: incremental pref-dim ( incremental -- dim )
     dup gadget-relayout? [

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 ;

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 <pack> r> set-delegate ;
+: delegate>pack ( vector tuple -- ) >r <pack> r> set-delegate ;
 
 : <pile> ( -- pack ) @{ 0 1 0 }@ <pack> ;
 
@@ -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 ;

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
     "" <display-title> over add-display-title
     f f <pane> 2dup swap set-display-pane
     <scroller> over @center frame-add ;

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
+    hand get [ hand-gadget ] keep 2dup hand-clicked eq?
-    2dup hand-clicked eq? [
+    [ 2dup set-hand-clicked update-hand ] unless 2drop ;
-        2dup set-hand-clicked dup 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 ;
 
-: <menu-button> ( gadget quot -- button )
+: menu-button-actions ( gadget -- )
-    [ show-hand-menu ] append <roll-button>
     dup [ button-clicked ] [ button-down 1 ] set-action
-    dup [ button-update ] [ button-up 1 ] set-action ;
+    [ button-update ] [ button-up 1 ] set-action ;
-

library/ui/outliner.factor

@@ -25,7 +25,7 @@ DEFER: <expand-button>
 
 : <expand-arrow> ( ? -- gadget )
     arrow-right arrow-down ? <polygon-gadget>
-    dup icon-theme empty-border ;
+    dup icon-theme <border> ;
 
 : <expand-button> ( ? -- gadget )
     #! If true, the button expands, otherwise it collapses.
@@ -35,7 +35,7 @@ DEFER: <expand-button>
 
 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? ;

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
+gadgets-menus gadgets-outliner gadgets-panes gadgets-theme
-inference inspector io jedit kernel lists memory namespaces
+generic hashtables inference inspector io jedit kernel lists
-parser prettyprint sequences strings styles words ;
+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 )
+TUPLE: command-button object ;
-    dup applicable
-    [ [ third command-quot ] keep second swons ] map-with
-    <menu> ;
 
-: <command-button> ( gadget object -- button )
+: command-menu ( command-button -- )
-    [ [ nip command-menu ] curry <menu-button> ] keep
+    command-button-object dup applicable
-    summary over set-gadget-help ;
+    [ [ third command-quot ] keep second swons ] map-with
+    <menu> 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 [ <command-button> ] when* ;

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 <viewport> r> add-viewport ] keep
     <x-slider> over add-x-slider
     <y-slider> over add-y-slider

library/ui/sliders.factor

@@ -54,7 +54,7 @@ SYMBOL: slider-changed
     [ find-elevator elevator-drag ] [ drag 1 ] set-action ;
 
 : <thumb> ( -- thumb )
-    <gadget> dup button-theme
+    <gadget> 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

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 <divider> r> 3array r> add-gadgets ] keep
     1 over set-pack-fill ;

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 <rollover-only> interior set-paint-prop
     <rollover-only> boundary set-paint-prop ;
 

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
+    under-hand >r hand get set-rect-loc
-    2dup set-rect-loc
+    hand-grab hand get set-hand-gadget
-    [ >r world get pick-up r> set-hand-gadget ] keep
+    under-hand r> hand-gestures update-help ;
-    dup hand-gadget parents-down r> hand-gestures
-    update-help ;
 
 M: motion-event handle-event ( event -- )
     motion-event-loc move-hand ;