splitter control in the UI works, improving panes, various UI cleanups

library/collections/lists.factor

@@ -64,7 +64,7 @@ M: general-list contains? ( obj list -- ? )
     2dup contains? [ nip ] [ cons ] ifte ;
 
 M: general-list reverse ( list -- list )
-    [ ] swap [ swons ] each ;
+    [ ] [ swons ] reduce ;
 
 M: f map ( list quot -- list ) drop ;
 

library/collections/sequences.factor

@@ -32,6 +32,9 @@ G: each ( seq quot -- | quot: elt -- )
 : each-with ( obj seq quot -- | quot: obj elt -- )
     swap [ with ] each 2drop ; inline
 
+: reduce ( list identity quot -- value | quot: x y -- z )
+    swapd each ; inline
+
 G: tree-each ( obj quot -- | quot: elt -- )
     [ over ] [ type ] ; inline
 
@@ -44,6 +47,9 @@ G: map ( seq quot -- seq | quot: elt -- elt )
 : map-with ( obj list quot -- list | quot: obj elt -- elt )
     swap [ with rot ] map 2nip ; inline
 
+: accumulate ( list identity quot -- values | quot: x y -- z )
+    rot [ pick >r swap call r> ] map-with nip ; inline
+
 G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
     [ over ] [ type ] ; inline
 

library/math/matrices.factor

@@ -17,8 +17,11 @@ vectors ;
 : vmin ( v v -- v ) [ min ] 2map ;
 : vneg ( v -- v ) [ neg ] map ;
 
-: sum ( v -- n ) 0 swap [ + ] each ;
+: sum ( v -- n ) 0 [ + ] reduce ;
-: product 1 swap [ * ] each ;
+: product 1 [ * ] reduce ;
+
+: set-axis ( x y axis -- v )
+    2dup v* >r >r drop dup r> v* v- r> v+ ;
 
 ! Later, this will fixed when 2each works properly
 ! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;

library/sdl/sdl-utils.factor

@@ -43,13 +43,6 @@ SYMBOL: surface
     [ set-rect-y ] keep
     [ set-rect-x ] keep ;
 
-: black [ 0   0   0   ] ;
-: gray  [ 128 128 128 ] ;
-: white [ 255 255 255 ] ;
-: red   [ 255 0   0   ] ;
-: green [ 0   255 0   ] ;
-: blue  [ 0   0   255 ] ;
-
 : with-pixels ( quot -- )
     width get [
         height get [

library/syntax/parse-numbers.factor

@@ -20,7 +20,7 @@ M: object digit> not-a-number ;
     dup empty? [
         not-a-number
     ] [
-        0 swap [ digit> pick digit+ ] each nip
+        0 [ digit> pick digit+ ] reduce nip
     ] ifte ;
 
 : base> ( str base -- num )

library/test/sequences.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: lists sequences test vectors ;
+USING: lists math sequences test vectors ;
 
 [ [ 1 2 3 4 ] ] [ 1 5 <range> >list ] unit-test
 [ 3 ] [ 1 4 <range> length ] unit-test
@@ -14,3 +14,8 @@ USING: lists sequences test vectors ;
 [ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
 
 [ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test
+
+[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
+
+[ [ 1 1 2 6 24 120 720 ] ]
+[ [ 1 2 3 4 5 6 7 ] 1 [ * ] accumilate ] unit-test

library/ui/colors.factor

@@ -0,0 +1,8 @@
+IN: gadgets
+
+: black [ 0   0   0   ] ;
+: gray  [ 128 128 128 ] ;
+: white [ 255 255 255 ] ;
+: red   [ 255 0   0   ] ;
+: green [ 0   255 0   ] ;
+: blue  [ 0   0   255 ] ;

library/ui/gadgets.factor

@@ -90,11 +90,3 @@ M: gadget layout*
 GENERIC: user-input* ( ch gadget -- ? )
 
 M: gadget user-input* 2drop t ;
-
-GENERIC: orientation ( gadget -- vector )
-
-: orient* ( x y axis -- v )
-    2dup v* >r >r drop dup r> v* v- r> v+ ;
-
-: orient ( x y gadget -- vec )
-    orientation orient* ;

library/ui/init-world.factor

@@ -16,4 +16,10 @@ global [
     }} world get set-gadget-paint
     
     1024 768 world get resize-gadget
+    
+    <plain-gadget> world get add-gadget
+
+    <console> "Stack display goes here" <label> <y-splitter>
+    3/4 over set-splitter-split
+    world get add-gadget
 ] bind

library/ui/panes.factor

@@ -7,15 +7,20 @@ sequences io strings threads ;
 ! A pane is an area that can display text.
 
 ! output: pile
-! current: label
+! current: shelf
 ! input: editor
-TUPLE: pane output current input continuation ;
+TUPLE: pane output active current input continuation ;
 
 : add-output 2dup set-pane-output add-gadget ;
 : add-input 2dup set-pane-input add-gadget ;
 
-: <active-line> ( current input -- line )
+: <active-line> ( input current -- line )
-    <line-shelf> [ tuck add-gadget add-gadget ] keep ;
+    <line-shelf> [ add-gadget ] keep [ add-gadget ] keep ;
+
+: init-active-line ( pane -- )
+    dup pane-active [ unparent ] when*
+    [ dup pane-input swap pane-current <active-line> ] keep
+    2dup set-pane-active add-gadget ;
 
 : pane-paint ( pane -- )
     [[ "Monospaced" 12 ]] font set-paint-prop ;
@@ -43,22 +48,18 @@ TUPLE: pane output current input continuation ;
 C: pane ( -- pane )
     <line-pile> over set-delegate
     <line-pile> over add-output
-    "" <label> dup pick set-pane-current >r
+    "" <label> over set-pane-current
-    "" <editor> dup pick set-pane-input r>
+    "" <editor> over set-pane-input
-    <active-line> over add-gadget
+    dup init-active-line
     dup pane-paint
     dup pane-actions ;
 
-: add-line ( text pane -- )
-    >r <label> r> pane-output add-gadget ;
-
 : pane-write-1 ( text pane -- )
-    pane-current dup label-text rot append over set-label-text
+    >r <label> r> pane-current add-gadget ;
-    relayout ;
 
 : pane-terpri ( pane -- )
-    dup pane-current dup label-text rot add-line
+    dup pane-current over pane-output add-gadget
-    "" over set-label-text relayout ;
+    <line-shelf> over set-pane-current init-active-line ;
 
 : pane-write ( pane list -- )
     2dup car swap pane-write-1
@@ -81,12 +82,12 @@ M: pane stream-write-attr ( string style stream -- )
 M: pane stream-close ( stream -- ) drop ;
 
 : <console> ( -- pane )
-    <pane> dup [
+    <pane> dup
-        [ clear  print-banner listener ] in-thread
+    [ [ clear  print-banner listener ] in-thread ] with-stream
-    ] with-stream ;
+    <scroller> ;
 
 : console ( -- )
     #! Open an UI console window.
-    <console> <scroller> "Listener" <tile> world get [
+    <console> "Listener" <tile> world get [
         shape-size rect> 3/4 * >rect rot resize-gadget
     ] 2keep add-gadget ;

library/ui/scrolling.factor

@@ -78,7 +78,7 @@ TUPLE: slider viewport thumb vector ;
 
 : <thumb> ( -- thumb )
     <plain-gadget>
-    dup t reverse-video set-paint-prop
+    dup gray background set-paint-prop
     dup thumb-actions ;
 
 : add-thumb ( thumb slider -- )

library/ui/splitters.factor

@@ -1,21 +1,33 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists matrices namespaces sequences ;
+USING: generic kernel lists math matrices namespaces sequences ;
 
 TUPLE: divider splitter ;
 
-C: divider ( -- divider )
-    <plain-gadget> over set-delegate
-    dup t reverse-video set-paint-prop ;
-
 : divider-size { 8 8 0 } ;
 
 M: divider pref-size drop divider-size 3unseq drop ;
 
 TUPLE: splitter vector split ;
 
-M: splitter orientation splitter-vector ;
+: hand>split ( splitter -- n )
+    hand relative hand hand-click-rel v- divider-size 1/2 v*n v+ ;
+
+: divider-motion ( splitter -- )
+    dup hand>split
+    over shape-dim { 1 1 1 } vmax v/ over splitter-vector v.
+    0 max 1 min over set-splitter-split relayout ;
+
+: divider-actions ( thumb -- )
+    dup [ drop ] [ button-down 1 ] set-action
+    dup [ drop ] [ button-up 1 ] set-action
+    [ gadget-parent divider-motion ] [ drag 1 ] set-action ;
+
+C: divider ( -- divider )
+    <plain-gadget> over set-delegate
+    dup t reverse-video set-paint-prop
+    dup divider-actions ;
 
 C: splitter ( first second vector -- splitter )
     <empty-gadget> over set-delegate
@@ -26,16 +38,16 @@ C: splitter ( first second vector -- splitter )
     [ add-gadget ] keep
     1/2 over set-splitter-split ;
 
-: <x-splitter> { 1 0 0 } <splitter> ;
+: <x-splitter> { 0 1 0 } <splitter> ;
 
-: <y-splitter> { 0 1 0 } <splitter> ;
+: <y-splitter> { 1 0 0 } <splitter> ;
 
 M: splitter pref-size
     [
         gadget-children [ pref-dim ] map
-        dup { 0 0 0 } swap [ vmax ] each
+        dup { 0 0 0 } [ vmax ] reduce
-        swap { 0 0 0 } swap [ v+ ] each
+        swap { 0 0 0 } [ v+ ] reduce
-    ] keep orient 3unseq drop ;
+    ] keep splitter-vector set-axis 3unseq drop ;
 
 : splitter-part ( splitter -- vec )
     dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ;
@@ -47,10 +59,22 @@ M: splitter pref-size
         dup shape-dim swap splitter-part v- ,
     ] make-list ;
 
+: packed-locs ( axis sizes gadget -- )
+    >r
+    { 0 0 0 } [ v+ ] accumulate
+    [ { 0 0 0 } swap rot set-axis ] map-with
+    r> gadget-children zip [ uncons set-gadget-loc ] each ;
+
+: packed-dims ( axis sizes gadget -- dims )
+    [
+        shape-dim swap [ >r 2dup r> rot set-axis ] map 2nip
+    ] keep gadget-children zip [ uncons set-gadget-dim ] each ;
+
 : layout-divider ( assoc -- )
     [ uncons set-gadget-dim ] each ;
 
+: packed-layout ( axis sizes gadgets -- )
+    3dup packed-locs packed-dims ;
+
 M: splitter layout* ( splitter -- )
-    [
+    dup splitter-vector over splitter-layout rot packed-layout ;
-        dup splitter-layout [ nip ( { 0 0 0 } rot orient ) ] map-with
-    ] keep gadget-children zip layout-divider ;

library/ui/tool-menus.factor

@@ -15,4 +15,4 @@ SYMBOL: root-menu
     [[ "Exit" [ f world get set-world-running? ] ]]
 ] root-menu set
 
-world get [ drop show-root-menu ] [ button-down 1 ] set-action
+! world get [ drop show-root-menu ] [ button-down 1 ] set-action

library/ui/world.factor

@@ -11,11 +11,8 @@ threads sequences ;
 ! open at any one time.
 TUPLE: world running? hand menu ;
 
-: <world-box> ( -- box )
-    <plain-gadget> ;
-
 C: world ( -- world )
-    <world-box> over set-delegate
+    f <stack> over set-delegate
     t over set-world-running?
     dup <hand> over set-world-hand ;