big cleanup of UI code

library/math/math.factor

@@ -60,19 +60,16 @@ GENERIC: abs ( z -- |z| )
     2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;
 
 : (repeat) ( i n quot -- )
-    pick pick >= [
+    pick pick >=
-        3drop
+    [ 3drop ] [ [ swap >r call 1 + r> ] keep (repeat) ] ifte ;
-    ] [
+    inline
-        [ swap >r call 1 + r> ] keep (repeat)
-    ] ifte ; inline
 
-: repeat ( n quot -- )
+: repeat ( n quot -- | quot: n -- n )
-    #! Execute a quotation n times. The loop counter is kept on
+    #! The loop counter is kept on the stack, and ranges from
-    #! the stack, and ranges from 0 to n-1.
+    #! 0 to n-1.
     0 -rot (repeat) ; inline
 
-: times ( n quot -- )
+: times ( n quot -- | quot: -- )
-    #! Evaluate a quotation n times.
     swap [ >r dup slip r> ] repeat drop ; inline
 
 : 2repeat ( i j quot -- | quot: i j -- i j )

library/test/gadgets.factor

@@ -67,16 +67,6 @@ USING: gadgets kernel lists math namespaces test sequences ;
     ] with-scope
 ] unit-test
 
-[
-    300 620
-] [
-    0 { 10 10 10 } 0 <pile> "pile" set
-    0 0 100 100 <rectangle> <gadget> "pile" get add-gadget
-    0 0 200 200 <rectangle> <gadget> "pile" get add-gadget
-    0 0 300 300 <rectangle> <gadget> "pile" get add-gadget
-    "pile" get pref-size
-] unit-test
-
 [ ] [ "pile" get layout* ] unit-test
 
 [

library/ui/borders.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: errors generic hashtables kernel lists math namespaces
+USING: errors generic hashtables kernel lists math matrices
-sdl vectors ;
+namespaces sdl vectors ;
 
 ! A border lays out its children on top of each other, all with
 ! a 5-pixel padding.
@@ -34,8 +34,8 @@ C: border ( child delegate size -- border )
     gadget-child resize-gadget ;
 
 M: border pref-dim ( border -- dim )
-    [ border-size 2 * ] keep
+    [ border-size dup dup 3vector 2 v*n ] keep
-    gadget-child pref-size >r over + r> rot + 0 3vector ;
+    gadget-child pref-dim v+ ;
 
 M: border layout* ( border -- )
     dup layout-border-x/y layout-border-w/h ;

library/ui/checkboxes.factor

@@ -41,7 +41,7 @@ TUPLE: checkbox bevel selected? ;
     [ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
 
 C: checkbox ( label -- checkbox )
-    <default-shelf> over set-delegate
+    <line-shelf> over set-delegate
     [ f line-border swap init-checkbox-bevel ] keep
     [ >r <label> r> add-gadget ] keep
     dup checkbox-actions

library/ui/frames.factor

@@ -113,4 +113,4 @@ SYMBOL: frame-bottom-run
     frame-bottom pos-frame-bottom ;
 
 M: frame layout* ( frame -- )
-    [ dup setup-frame  layout-frame ] with-layout ;
+    [ 0 x set 0 y set dup setup-frame layout-frame ] with-scope ;

library/ui/init-world.factor

@@ -18,9 +18,9 @@ global [
         [[ font-style plain ]]
     }} world get set-gadget-paint
     
-    1024 768 world get resize-gadget
+    { 1024 768 0 } world get set-gadget-dim
     
-    <plain-gadget> world get add-gadget
+    <plain-gadget> add-layer
 
     <console> "Stack display goes here" <label> <y-splitter>
     3/4 over set-splitter-split add-layer

library/ui/layouts.factor

@@ -19,21 +19,84 @@ namespaces sdl sequences ;
         drop
     ] ifte ;
 
-: with-pref-size ( quot -- )
+GENERIC: alignment
-    [
+GENERIC: filling
-        0 width set  0 height set  call  width get height get
+GENERIC: orientation
-    ] with-scope ; inline
-
-: with-layout ( quot -- )
-    [ 0 x set 0 y set call ] with-scope ; inline
 
 : pref-dims ( gadget -- list )
     gadget-children [ pref-dim ] map ;
 
-: packed-pref-dim ( gadget gap axis -- dim )
+: packed-pref-dim ( gadget -- dim )
     #! The preferred size of the gadget, if all children are
     #! packed in the direction of the given axis.
-    >r
+    [
-    over length 0 max v*n >r pref-dims r>
+        pref-dims
-    2dup [ v+ ] reduce >r [ vmax ] reduce r>
+        [ { 0 0 0 } [ vmax ] reduce ] keep
-    r> set-axis ;
+        { 0 0 0 } [ v+ ] reduce
+    ] keep orientation set-axis ;
+
+: orient ( gadget list1 list2 -- list )
+    zip >r orientation r> [ uncons rot set-axis ] map-with ;
+
+: packed-dim-2 ( gadget sizes -- list )
+    [ over shape-dim over v- rot filling v*n v+ ] map-with ;
+
+: (packed-dims) ( gadget sizes -- list )
+    2dup packed-dim-2 swap orient ;
+
+: packed-dims ( gadget sizes -- list )
+    over gadget-children >r (packed-dims) r>
+    zip [ uncons set-gadget-dim ] each ;
+
+: packed-loc-1 ( sizes -- list )
+    { 0 0 0 } [ v+ ] accumulate ;
+
+: packed-loc-2 ( gadget sizes -- list )
+    >r dup shape-dim over r> packed-dim-2 [ v- ] map-with
+    >r dup alignment swap shape-dim r>
+    [ >r 2dup r> v- n*v ] map 2nip ;
+
+: (packed-locs) ( gadget sizes -- list )
+    dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
+
+: packed-locs ( gadget sizes -- )
+    over gadget-children >r (packed-locs) r>
+    zip [ uncons set-gadget-loc ] each ;
+
+: packed-layout ( gadget sizes -- )
+    2dup packed-locs packed-dims ;
+
+TUPLE: pack align fill vector ;
+
+C: pack ( align fill vector -- pack )
+    #! align: 0 left aligns, 1/2 center, 1 right.
+    #! gap: between each child.
+    #! fill: 0 leaves default width, 1 fills to pack width.
+    [ <empty-gadget> swap set-delegate ] keep
+    [ set-pack-vector ] keep
+    [ set-pack-fill ] keep
+    [ set-pack-align ] keep ;
+
+: <pile> { 0 1 0 } <pack> ;
+
+: <line-pile> 0 1 <pile> ;
+
+: <shelf> { 1 0 0 } <pack> ;
+
+: <line-shelf> 0 1 <shelf> ;
+
+M: pack orientation pack-vector ;
+
+M: pack filling pack-fill ;
+
+M: pack alignment pack-align ;
+
+M: pack pref-dim packed-pref-dim ;
+
+M: pack layout* ( pack -- )
+    dup pref-dims packed-layout ;
+
+: <stack> ( list -- gadget )
+    #! A stack lays out all its children on top of each other.
+    0 1 { 0 0 1 } <pack>
+    swap [ over add-gadget ] each ;

library/ui/load.factor

@@ -14,10 +14,7 @@ USING: kernel parser sequences io ;
     "/library/ui/gestures.factor"
     "/library/ui/hand.factor"
     "/library/ui/layouts.factor"
-    "/library/ui/piles.factor"
-    "/library/ui/shelves.factor"
     "/library/ui/borders.factor"
-    "/library/ui/stacks.factor"
     "/library/ui/frames.factor"
     "/library/ui/world.factor"
     "/library/ui/labels.factor"

library/ui/menus.factor

@@ -12,7 +12,7 @@ USING: generic kernel lists math namespaces sequences ;
     hide-menu
     world get
     2dup set-world-menu
-    2dup world-hand screen-pos >rect rot move-gadget
+    2dup world-hand screen-loc swap set-gadget-loc
     show-glass ;
 
 : menu-item-border ( child -- border )

library/ui/piles.factor

@@ -1,49 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: errors generic hashtables kernel lists math namespaces
-sdl sequences vectors ;
-
-! pile-align
-!
-! if the component is smaller than its allocated space, where to
-! place the component inside the allocated space.
-!
-! pile-gap
-! 
-! amount of space, in pixels, between components.
-! 
-! pile-fill
-! 
-! if the component is smaller than its allocated space, how much
-! to scale the size, where a value of 0 represents no scaling, and
-! a value of 1 represents resizing to fully fill allocated space.
-TUPLE: pile align gap fill ;
-
-C: pile ( align gap fill -- pile )
-    #! align: 0 left aligns, 1/2 center, 1 right.
-    #! gap: between each child.
-    #! fill: 0 leaves default width, 1 fills to pile width.
-    [ <empty-gadget> swap set-delegate ] keep
-    [ set-pile-fill ] keep
-    [ set-pile-gap ] keep
-    [ set-pile-align ] keep ;
-
-: <line-pile> 0 { 0 0 0 } 1 <pile> ;
-
-M: pile pref-dim ( pile -- dim )
-    dup pile-gap { 0 1 0 } packed-pref-dim ;
-
-: w- swap shape-w swap pref-size drop - ;
-: pile-x/y ( pile gadget offset -- )
-    rot pile-align * >fixnum y get rot move-gadget ;
-: pile-w/h ( pile gadget offset -- )
-    rot dup pile-gap first y [ + ] change
-    pile-fill * >fixnum over pref-size dup y [ + ] change
-    >r + r> rot resize-gadget ;
-: vertically ( pile gadget -- ) 2dup w- 3dup pile-x/y pile-w/h ;
-
-M: pile layout* ( pile -- )
-    [
-        dup gadget-children [ vertically ] each-with
-    ] with-layout ;

library/ui/presentations.factor

@@ -4,6 +4,8 @@ IN: gadgets
 USING: hashtables io kernel lists namespaces parser prettyprint
 sequences ;
 
+DEFER: pane-eval
+
 : actions-menu ( pane actions -- menu )
     [ uncons rot [ pane-eval ] cons cons cons ] map-with <menu> ;
 

library/ui/scrolling.factor

@@ -13,8 +13,6 @@ TUPLE: viewport origin ;
 : set-viewport-x [ viewport-y 0 3vector ] keep set-viewport-origin ;
 : set-viewport-y [ viewport-x swap 0 3vector ] keep set-viewport-origin ;
 
-: viewport-h ( viewport -- h ) gadget-child pref-size nip ;
-
 : viewport-dim ( viewport -- h ) gadget-child pref-dim ;
 
 : fix-scroll ( origin viewport -- origin )
@@ -23,12 +21,6 @@ TUPLE: viewport origin ;
 : scroll ( origin viewport -- )
     [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
 
-: scroll-viewport ( y viewport -- )
-    #! y is a number between -1 and 0..
-    [ viewport-h * >fixnum ] keep
-    [ viewport-x swap 0 3vector ] keep 
-    scroll ;
-
 C: viewport ( content -- viewport )
     [ <empty-gadget> swap set-delegate ] keep
     [ add-gadget ] keep

library/ui/shelves.factor

@@ -1,45 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: errors generic hashtables kernel lists math namespaces
-sdl sequences vectors ;
-
-! A shelf is a box that lays out its contents horizontally.
-TUPLE: shelf gap align fill ;
-
-C: shelf ( align gap fill -- shelf )
-    #! align: 0 left aligns, 1/2 center, 1 right.
-    #! gap: between each child.
-    #! fill: 0 leaves default width, 1 fills to pile width.
-    <empty-gadget> over set-delegate
-    [ set-shelf-fill ] keep
-    [ set-shelf-gap ] keep
-    [ set-shelf-align ] keep ;
-
-: <default-shelf> 1/2 { 3 3 3 } 0 <shelf> ;
-: <line-shelf> 0 0 1 <shelf> ;
-
-M: shelf pref-dim ( pile -- dim )
-    [
-        dup shelf-gap swap gadget-children
-        [ length 1 - 0 max * width set ] keep
-        [
-            pref-size
-            height [ max ] change
-            width [ + ] change
-        ] each
-    ] with-pref-size 0 3vector ;
-
-: h- swap shape-h swap pref-size nip - ;
-: shelf-x/y rot shelf-align * >fixnum >r x get r> rot move-gadget ;
-: shelf-w/h ( shelf gadget offset -- )
-    rot dup shelf-gap x [ + ] change
-    shelf-fill * >fixnum >r dup pref-size over x [ + ] change
-    r> + rot resize-gadget ; 
-: horizontally ( shelf gadget -- )
-    2dup h- 3dup shelf-x/y shelf-w/h ;
-
-M: shelf layout* ( pile -- )
-    [
-        dup gadget-children [ horizontally ] each-with
-    ] with-layout ;

library/ui/splitters.factor

@@ -43,8 +43,13 @@ C: splitter ( first second vector -- splitter )
 
 : <y-splitter> { 1 0 0 } <splitter> ;
 
-M: splitter pref-dim
+M: splitter orientation splitter-vector ;
-    { 0 0 0 } over splitter-vector packed-pref-dim ;
+
+M: splitter filling drop 1 ;
+
+M: splitter alignment drop 0 ;
+
+M: splitter pref-dim packed-pref-dim ;
 
 : splitter-part ( splitter -- vec )
     dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ;
@@ -56,22 +61,5 @@ M: splitter pref-dim
         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 packed-layout ;

library/ui/stacks.factor

@@ -1,20 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: errors generic hashtables kernel lists math matrices
-namespaces sdl sequences ;
-
-! A stack just lays out all its children on top of each other.
-TUPLE: stack ;
-C: stack ( list -- stack )
-    <empty-gadget> over set-delegate
-    swap [ over add-gadget ] each ;
-
-: max-dim ( shapelist -- dim )
-    { 0 0 0 } [ shape-dim vmax ] reduce ;
-
-M: stack pref-dim gadget-children max-dim ;
-
-M: stack layout* ( stack -- )
-    dup shape-dim swap gadget-children
-    [ set-gadget-dim ] each-with ;