Fixing UI scrolling issues

TODO.FACTOR.txt

@@ -2,6 +2,7 @@
 - code walker & exceptions -- test and debug problems
 - code walker and callbacks is broken?
 - prettyprinter's highlighting of non-leaves looks bad
+- look at xref issue
 
 + io:
 

library/bootstrap/boot-stage1.factor

@@ -184,6 +184,7 @@ vectors words ;
         "/library/ui/buttons.factor"
         "/library/ui/line-editor.factor"
         "/library/ui/sliders.factor"
+        "/library/ui/viewports.factor"
         "/library/ui/scrolling.factor"
         "/library/ui/editors.factor"
         "/library/ui/tracks.factor"

library/ui/gestures.factor

@@ -74,14 +74,14 @@ SYMBOL: hand-buttons
 V{ } clone hand-buttons set-global
 
 : button-gesture ( button gesture -- )
-    #! Send a gesture like [ button-down 2 ]; if nobody
+    #! Send a gesture like T{ button-down f 2 }; if nobody
     #! handles it, send T{ button-down }.
     hand-clicked get-global
     3dup >r with-button r> handle-gesture
     [ handle-gesture 2drop ] [ 3drop ] if ;
 
 : drag-gesture ( -- )
-    #! Send a gesture like [ drag 2 ]; if nobody handles it,
+    #! Send a gesture like T{ drag f 2 }; if nobody handles it,
     #! send T{ drag }.
     hand-buttons get-global first T{ drag } button-gesture ;
 

library/ui/hierarchy.factor

@@ -33,8 +33,7 @@ M: gadget remove-notify* drop ;
     ] when* ;
 
 : (clear-gadget) ( gadget -- )
-    dup gadget-children [ (unparent) ] each
-    f swap set-gadget-children ;
+    dup [ (unparent) ] each-child f swap set-gadget-children ;
 
 : clear-gadget ( gadget -- )
     dup (clear-gadget) relayout ;

library/ui/scrolling.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-scrolling
-USING: arrays gadgets gadgets-layouts kernel math namespaces
-sequences ;
-
-! A viewport can be scrolled.
-TUPLE: viewport ;
+USING: arrays gadgets gadgets-layouts generic kernel math
+namespaces sequences ;
 
 ! A scroller combines a viewport with two x and y sliders.
 ! The follows slot is set by scroll-to.
@@ -18,27 +15,39 @@ TUPLE: scroller viewport x y follows ;
 
 : find-scroller [ scroller? ] find-parent ;
 
-: find-viewport [ viewport? ] find-parent ;
+: scroll-to ( gadget -- )
+    #! Scroll the scroller that contains this gadget, if any, so
+    #! that the gadget becomes visible.
+    dup find-scroller dup
+    [ [ set-scroller-follows ] keep relayout ] [ 2drop ] if ;
 
-: viewport-dim gadget-child pref-dim ;
+: scroll-up-line scroller-y -1 swap slide-by-line ;
 
-C: viewport ( content -- viewport )
-    dup delegate>gadget
-    t over set-gadget-root?
-    [ add-gadget ] keep ;
+: scroll-down-line scroller-y 1 swap slide-by-line ;
 
-M: viewport pref-dim* gadget-child pref-dim ;
+: 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 ;
 
-: set-slider ( page max value slider -- )
+C: scroller ( gadget -- scroller )
+    #! Wrap a scrolling pane around the gadget.
+    {
+        { [ <viewport> ] set-scroller-viewport @center }
+        { [ <x-slider> ] set-scroller-x @bottom }
+        { [ <y-slider> ] set-scroller-y @right }
+    } make-frame* dup scroller-actions ;
+
+: set-slider ( value page max slider -- )
     #! page/max/value are 3-vectors.
-    [ [ gadget-orientation v. ] keep set-slider-value ] keep
     [ [ gadget-orientation v. ] keep set-slider-max ] keep
     [ [ gadget-orientation v. ] keep set-slider-page ] keep
-    fix-slider ;
+    [ [ gadget-orientation v. ] keep set-slider-value* ] keep
+    slider-elevator relayout-1 ;
 
 : update-slider ( scroller value slider -- )
-    >r >r scroller-viewport dup rect-dim swap viewport-dim
-    r> r> set-slider ;
+    >r swap scroller-viewport dup rect-dim swap viewport-dim
+    r> set-slider ;
 
 : scroll ( scroller value -- )
     2dup over scroller-x update-slider
@@ -61,41 +70,15 @@ M: viewport pref-dim* gadget-child pref-dim ;
 : update-scroller ( scroller -- )
     [ dup do-scroll ] keep scroller-origin v+ scroll ;
 
-: position-viewport ( viewport scroller -- )
-    scroller-origin vneg swap gadget-child set-rect-loc ;
+: position-viewport ( scroller -- )
+    dup scroller-origin vneg
+    swap scroller-viewport gadget-child
+    set-rect-loc ;
 
-M: viewport layout* ( viewport -- )
-    dup gadget-child dup prefer layout
-    dup find-scroller dup update-scroller position-viewport ;
-
-M: viewport focusable-child* ( viewport -- gadget )
-    gadget-child ;
-
-M: viewport pref-dim* ( viewport -- dim )
-    gadget-child pref-dim ;
-
-: scroll-to ( gadget -- )
-    #! Scroll the scroller that contains this gadget, if any, so
-    #! that the gadget becomes visible.
-    dup find-scroller dup
-    [ [ set-scroller-follows ] keep relayout ] [ 2drop ] if ;
-
-: scroll-up-line scroller-y -1 swap slide-by-line ;
-
-: 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
-    [ scroller-viewport relayout-1 ] T{ slider-changed } set-action ;
-
-C: scroller ( gadget -- scroller )
-    #! Wrap a scrolling pane around the gadget.
-    {
-        { [ <viewport> ] set-scroller-viewport @center }
-        { [ <x-slider> ] set-scroller-x @bottom }
-        { [ <y-slider> ] set-scroller-y @right }
-    } make-frame* dup scroller-actions ;
+M: scroller layout* ( scroller -- )
+    dup delegate layout*
+    dup layout-children
+    dup update-scroller position-viewport ;
 
 M: scroller focusable-child* ( scroller -- viewport )
     scroller-viewport ;

library/ui/sliders.factor

@@ -15,24 +15,31 @@ TUPLE: slider elevator thumb value saved max page ;
 
 : find-slider [ slider? ] find-parent ;
 
+: elevator-length ( slider -- n )
+    dup slider-elevator rect-dim
+    swap gadget-orientation v. ;
+
+: min-thumb-dim 30 ;
+
+: thumb-dim ( slider -- h )
+    dup slider-page over slider-max 1 max / 1 min
+    swap elevator-length * min-thumb-dim max ;
+
+: slider-max* dup slider-max swap slider-page - 1 max ;
+
 : slider-scale ( slider -- n )
     #! A scaling factor such that if x is a slider co-ordinate,
     #! x*n is the screen position of the thumb, and conversely
     #! for x/n. The '1 max' calls avoid division by zero.
-    dup slider-elevator rect-dim
-    over gadget-orientation v. 1 max
-    swap slider-max 1 max / ;
+    dup elevator-length over thumb-dim - 1 max
+    swap slider-max* / ;
 
 : slider>screen slider-scale * ;
 
 : screen>slider slider-scale / ;
 
 : fix-slider-value ( n slider -- n )
-    dup slider-max swap slider-page - min 0 max >fixnum ;
-
-: fix-slider ( slider -- )
-    dup slider-elevator relayout-1
-    dup slider-max over slider-page max swap set-slider-max ;
+    slider-max* min 0 max >fixnum ;
 
 TUPLE: slider-changed ;
 
@@ -40,7 +47,8 @@ TUPLE: slider-changed ;
     [ fix-slider-value ] keep 2dup slider-value = [
         2drop
     ] [
-        [ set-slider-value ] keep [ fix-slider ] keep
+        [ set-slider-value ] keep
+        dup slider-elevator relayout-1
         T{ slider-changed } swap handle-gesture drop
     ] if ;
 
@@ -83,7 +91,7 @@ C: elevator ( vector -- elevator )
     dup delegate>gadget [ set-gadget-orientation ] keep
     dup elevator-theme dup elevator-actions ;
 
-: (layout-thumb) ( slider n -- n )
+: (layout-thumb) ( slider n -- n thumb )
     over gadget-orientation n*v swap slider-thumb ;
 
 : thumb-loc ( slider -- loc )
@@ -92,9 +100,6 @@ C: elevator ( vector -- elevator )
 : layout-thumb-loc ( slider -- )
     dup thumb-loc (layout-thumb) set-rect-loc ;
 
-: thumb-dim ( slider -- h )
-    dup slider-page swap slider>screen ;
-
 : layout-thumb-dim ( slider -- )
     dup dup thumb-dim (layout-thumb)
     >r >r dup rect-dim r> rot gadget-orientation set-axis r>

library/ui/viewports.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-scrolling
+USING: arrays gadgets gadgets-layouts generic kernel math
+namespaces sequences ;
+
+! A viewport can be scrolled.
+TUPLE: viewport ;
+
+: find-viewport [ viewport? ] find-parent ;
+
+: viewport-dim gadget-child pref-dim ;
+
+C: viewport ( content -- viewport )
+    dup delegate>gadget
+    t over set-gadget-root?
+    [ add-gadget ] keep ;
+
+M: viewport pref-dim* gadget-child pref-dim ;
+
+M: viewport layout* ( viewport -- )
+    gadget-child dup prefer layout ;
+
+M: viewport focusable-child* ( viewport -- gadget )
+    gadget-child ;
+
+M: viewport pref-dim* ( viewport -- dim )
+    gadget-child pref-dim ;