Re-introducing sum and product words, new change-nth and remove-index words, track control replaces and generalizes splitter

TODO.FACTOR.txt

@@ -33,6 +33,8 @@
 
 + ui/help:
 
+- zooming doesn't work
+- sort out various round-off issues
 - implement handlers for open, quit events, and whatever else
 - fix top level window positioning
 - changing window titles

library/bootstrap/boot-stage1.factor

@@ -186,7 +186,7 @@ vectors words ;
         "/library/ui/sliders.factor"
         "/library/ui/scrolling.factor"
         "/library/ui/editors.factor"
-        "/library/ui/splitters.factor"
+        "/library/ui/tracks.factor"
         "/library/ui/incremental.factor"
         "/library/ui/paragraphs.factor"
         "/library/ui/panes.factor"

library/collections/sequence-combinators.factor

@@ -60,9 +60,13 @@ IN: sequences
 : accumulate ( list identity quot -- values | quot: x y -- z )
     rot [ pick >r swap call r> ] map-with nip ; inline
 
+: change-nth ( seq i quot -- )
+    pick pick >r >r >r swap nth
+    r> call r> r> swap set-nth ; inline
+
 : inject ( seq quot -- | quot: elt -- elt )
     over length
-    [ [ swap change-nth-unsafe ] 3keep ] repeat 2drop ;
+    [ [ swap change-nth ] 3keep ] repeat 2drop ;
     inline
 
 : inject-with ( obj seq quot -- | quot: obj elt -- elt )

library/collections/sequences.factor

@@ -43,10 +43,6 @@ 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
-
 ! The f object supports the sequence protocol trivially
 M: f length drop 0 ;
 M: f nth nip ;

library/collections/slicing.factor

@@ -48,6 +48,9 @@ strings vectors ;
     tuck >r >r head-slice r> r> tail-slice swapd append3 ;
     flushable
 
+: remove-index ( n seq -- seq )
+    [ head-slice ] 2keep >r 1+ r> tail-slice append ;
+
 : (cut) ( n seq -- before after )
     [ head ] 2keep tail-slice ; flushable
 

library/compiler/generator/templates.factor

@@ -153,7 +153,7 @@ SYMBOL: phantom-r
 
 : additional-vregs ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
-    0 [ 0 max + ] reduce ;
+    [ 0 max ] map sum ;
 
 : free-vregs# ( -- int# float# )
     T{ int-regs } free-vregs length

library/math/vectors.factor

@@ -24,3 +24,6 @@ USING: arrays generic kernel sequences ;
 
 : set-axis ( x y axis -- v )
     dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ;
+
+: sum ( seq -- n ) 0 [ + ] reduce ;
+: product ( seq -- n ) 1 [ * ] reduce ;

library/test/collections/sequences.factor

@@ -210,3 +210,5 @@ unit-test
 [ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
 
 [ 10 "hi" "bye" copy-into ] unit-test-fails
+
+[ { 1 2 3 5 6 } ] [ 3 { 1 2 3 4 5 6 } remove-index ] unit-test

library/ui/layouts.factor

@@ -80,13 +80,18 @@ TUPLE: pack align fill gap ;
     >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
 
 : packed-dim-2 ( gadget sizes -- list )
-    [ over rect-dim over v- rot pack-fill v*n v+ ] map-with ;
+    [
+        over rect-dim over v- rot pack-fill v*n v+
+        [ >fixnum ] map 
+    ] map-with ;
 
 : packed-dims ( gadget sizes -- seq )
     2dup packed-dim-2 swap orient ;
 
 : packed-loc-1 ( gadget sizes -- seq )
-    { 0 0 0 } [ v+ over pack-gap v+ ] accumulate nip ;
+    { 0 0 0 } [
+        v+ over pack-gap v+ [ >fixnum ] map
+    ] accumulate nip ;
 
 : packed-loc-2 ( gadget sizes -- seq )
     [

library/ui/listener.factor

@@ -3,7 +3,7 @@
 IN: gadgets-listener
 USING: arrays gadgets gadgets-editors gadgets-labels
 gadgets-layouts gadgets-panes gadgets-scrolling
-gadgets-splitters gadgets-theme generic hashtables io jedit
+gadgets-theme generic hashtables io jedit
 kernel listener math namespaces parser prettyprint
 sequences styles threads words ;
 

library/ui/splitters.factor

@@ -1,60 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets-splitters
-USING: arrays gadgets gadgets-layouts gadgets-theme generic
-kernel math namespaces sequences styles ;
-
-TUPLE: divider splitter ;
-
-: divider-size { 8 8 0 } ;
-
-M: divider pref-dim* drop divider-size ;
-
-TUPLE: splitter split ;
-
-: hand>split ( splitter -- n )
-    drag-loc divider-size 1/2 v*n v+ ;
-
-: divider-motion ( splitter -- )
-    dup hand>split
-    over rect-dim { 1 1 1 } vmax v/ over gadget-orientation v.
-    0 max 1 min over set-splitter-split relayout-1 ;
-
-: divider-actions ( thumb -- )
-    dup [ drop ] T{ button-down } set-action
-    dup [ drop ] T{ button-up } set-action
-    [ gadget-parent divider-motion ] T{ drag } set-action ;
-
-C: divider ( -- divider )
-    dup delegate>gadget
-    dup reverse-video-theme
-    dup divider-actions ;
-
-C: splitter ( first second split vector -- splitter )
-    [ delegate>pack ] keep
-    [ set-splitter-split ] keep
-    [ >r >r <divider> r> 3array r> add-gadgets ] keep
-    1 over set-pack-fill ;
-
-: <x-splitter> ( first second split -- splitter )
-    { 0 1 0 } <splitter> ;
-
-: <y-splitter> ( first second split -- splitter )
-    { 1 0 0 } <splitter> ;
-
-: splitter-part ( splitter -- vec )
-    dup splitter-split swap rect-dim
-    n*v [ >fixnum ] map divider-size 1/2 v*n v- ;
-
-: splitter-layout ( splitter -- { a b c } )
-    [
-        dup splitter-part ,
-        divider-size ,
-        dup rect-dim divider-size v- swap splitter-part v- ,
-    ] { } make ;
-
-M: splitter layout* ( splitter -- )
-    dup splitter-layout packed-layout ;
-
-: find-splitter ( gadget -- splitter )
-    [ splitter? ] find-parent ;

library/ui/tracks.factor

@@ -0,0 +1,84 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-tracks
+USING: gadgets gadgets-layouts gadgets-theme io kernel math
+namespaces sequences ;
+
+TUPLE: divider # splitter ;
+
+: divider-size { 8 8 0 } ;
+
+M: divider pref-dim* drop divider-size ;
+
+TUPLE: track sizes saved-sizes ;
+
+C: track ( orientation -- track )
+    [ delegate>pack ] keep 1 over set-pack-fill ;
+
+: track-dim ( track -- dim )
+    #! Space available for content (minus dividers)
+    dup rect-dim swap track-sizes length 1-
+    divider-size n*v v- ;
+
+: track-layout ( track -- sizes )
+    dup track-dim swap track-sizes
+    [ [ over n*v , ] [ divider-size , ] interleave ] { } make
+    nip ;
+
+M: track layout* ( splitter -- )
+    dup track-layout packed-layout ;
+
+: divider-delta ( track -- delta )
+    #! How far the divider has moved along the track?
+    drag-loc over track-dim { 1 1 1 } vmax v/
+    swap gadget-orientation v. ;
+
+: +nth ( delta n seq -- ) swap [ + ] change-nth ;
+
+: save-sizes ( track -- )
+    dup track-sizes clone swap set-track-saved-sizes ;
+
+: restore-sizes ( track -- )
+    dup track-saved-sizes clone swap set-track-sizes ;
+
+: change-divider ( delta n track -- )
+    [
+        dup restore-sizes
+        track-sizes
+        [ +nth ] 3keep
+        >r 1+ >r neg r> r> 2dup length = [ 3drop ] [ +nth ] if
+    ] keep relayout-1 ;
+
+: divider-motion ( divider -- )
+    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 ;
+
+C: divider ( n -- divider )
+    [ set-divider-# ] keep
+    dup delegate>gadget
+    dup divider-actions
+    dup reverse-video-theme ;
+
+: normalize-sizes ( sizes -- sizes )
+    dup sum swap [ swap / ] map-with ;
+
+: track-add-size ( sizes -- sizes )
+    dup length 1 max recip add normalize-sizes ;
+
+: add-divider ( track -- )
+    dup track-sizes length dup zero?
+    [ 2drop ] [ 1- <divider> swap add-gadget ] if ;
+
+: track-add ( gadget track -- )
+    dup add-divider [ add-gadget ] keep
+    dup track-sizes track-add-size swap set-track-sizes ;
+
+: track-remove ( gadget track -- )
+    ! wrong
+    [ gadget-children index ] 2keep swap unparent
+    [ remove-index ] keep set-track-sizes ;