Merge branch 'master' of git://factorcode.org/git/factor

extra/automata/ui/ui.factor

@@ -23,11 +23,8 @@ IN: automata.ui
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-QUALIFIED: ui.gadgets
 QUALIFIED: ui.gadgets.grids
 
-: add-gadget ( parent child -- parent ) over ui.gadgets:add-gadget ;
-
 : grid-add ( grid child i j -- grid )
   >r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
 

extra/boids/ui/ui.factor

@@ -120,24 +120,24 @@ VARS: population-label cohesion-label alignment-label separation-label ;
     [ "1 - Randomize" [ drop randomize ] button* ]
 
     [ <pile> 1 over set-pack-fill
-      population-label> over add-gadget
-      "3 - Add 10" [ drop add-10-boids ] button* over add-gadget
-      "2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ]
+      population-label> add-gadget
+      "3 - Add 10" [ drop add-10-boids ] button* add-gadget
+      "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
 
     [ <pile> 1 over set-pack-fill
-      cohesion-label> over add-gadget
-      "q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget
-      "a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ]
+      cohesion-label> add-gadget
+      "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
+      "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
 
     [ <pile> 1 over set-pack-fill
-      alignment-label> over add-gadget
-      "w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget
-      "s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ]
+      alignment-label> add-gadget
+      "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
+      "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
 
     [ <pile> 1 over set-pack-fill
-      separation-label> over add-gadget
-      "e - +0.1" [ drop inc-separation-weight ] button* over add-gadget
-      "d - -0.1" [ drop dec-separation-weight ] button* over add-gadget ]
+      separation-label> add-gadget
+      "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
+      "d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
 
   } [ call ] map [ [ gadget, ] each ] make-shelf
     1 over set-pack-fill

extra/ui/gadgets/books/books.factor

@@ -19,7 +19,7 @@ M: book model-changed
 : new-book ( pages model class -- book )
     new-gadget
         swap >>model
-        [ add-gadgets ] keep ; inline
+        [ swap add-gadgets drop ] keep ; inline
 
 : <book> ( pages model -- book )
     book new-book ;

extra/ui/gadgets/borders/borders.factor

@@ -10,7 +10,7 @@ TUPLE: border < gadget
 { align initial: { 1/2 1/2 } } ;
 
 : new-border ( child class -- border )
-    new-gadget [ add-gadget ] keep ; inline
+    new-gadget [ swap add-gadget drop ] keep ; inline
 
 : <border> ( child gap -- border )
     swap border new-border

extra/ui/gadgets/gadgets-tests.factor

@@ -9,9 +9,9 @@ io.streams.string math.geometry.rect ;
     ! c contains b contains a
     <gadget> "a" set
     <gadget> "b" set
-    "a" get "b" get add-gadget
+    "a" get "b" get swap add-gadget drop
     <gadget> "c" set
-    "b" get "c" get add-gadget
+    "b" get "c" get swap add-gadget drop
 
     ! position a and b
     { 100 200 } "a" get set-rect-loc
@@ -33,8 +33,8 @@ io.streams.string math.geometry.rect ;
 <gadget> "g3" set
 { 100 200 } "g3" get set-rect-dim
 
-"g1" get "g2" get add-gadget
-"g2" get "g3" get add-gadget
+"g1" get "g2" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
 
 [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
 [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
@@ -49,11 +49,11 @@ io.streams.string math.geometry.rect ;
 <gadget> "g1" set
 { 300 300 } "g1" get set-rect-dim
 <gadget> "g2" set
-"g2" get "g1" get add-gadget
+"g2" get "g1" get swap add-gadget drop
 { 20 20 } "g2" get set-rect-loc
 { 20 20 } "g2" get set-rect-dim
 <gadget> "g3" set
-"g3" get "g1" get add-gadget
+"g3" get "g1" get swap add-gadget drop
 { 100 100 } "g3" get set-rect-loc
 { 20 20 } "g3" get set-rect-dim
 
@@ -66,7 +66,7 @@ io.streams.string math.geometry.rect ;
 [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
 
 <gadget> "g4" set
-"g4" get "g2" get add-gadget
+"g4" get "g2" get swap add-gadget drop
 { 5 5 } "g4" get set-rect-loc
 { 1 1 } "g4" get set-rect-dim
 
@@ -123,7 +123,7 @@ M: mock-gadget ungraft*
     : add-some-children
         3 [
             <mock-gadget> over <model> over set-gadget-model
-            dup "g" get add-gadget
+            dup "g" get swap add-gadget drop
             swap 1+ number>string set
         ] each ;
 

extra/ui/gadgets/gadgets.factor

@@ -285,22 +285,27 @@ SYMBOL: in-layout?
     not-in-layout
     dup (clear-gadget) relayout ;
 
-: ((add-gadget)) ( gadget box -- )
-    [ children>> ?push ] keep (>>children) ;
+: ((add-gadget)) ( parent child -- parent )
+    over children>> ?push >>children ;
 
-: (add-gadget) ( gadget box -- )
-    over unparent
-    dup pick (>>parent)
-    [ ((add-gadget)) ] 2keep
-    graft-state>> second [ graft ] [ drop ] if ;
+: (add-gadget) ( parent child -- parent )
+    dup unparent
+    over >>parent
+    tuck ((add-gadget))
+    tuck graft-state>> second
+        [ graft ]
+        [ drop  ]
+    if ;
 
-: add-gadget ( gadget parent -- )
+: add-gadget ( parent child -- parent )
     not-in-layout
-    [ (add-gadget) ] keep relayout ;
-
-: add-gadgets ( seq parent -- )
+    (add-gadget)
+    dup relayout ;
+  
+: add-gadgets ( parent children -- parent )
     not-in-layout
-    swap [ over (add-gadget) ] each relayout ;
+    [ (add-gadget) ] each
+    dup relayout ;
 
 : parents ( gadget -- seq )
     [ parent>> ] follow ;
@@ -352,7 +357,7 @@ M: f request-focus-on 2drop ;
 : focus-path ( world -- seq )
     [ focus>> ] follow ;
 
-: gadget, ( gadget -- ) gadget get add-gadget ;
+: gadget, ( gadget -- ) gadget get swap add-gadget drop ;
 
 : g ( -- gadget ) gadget get ;
 

extra/ui/gadgets/grids/grids.factor

@@ -12,7 +12,7 @@ grid
 
 : new-grid ( children class -- grid )
     new-gadget
-    [ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ;
+    [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
     inline
 
 : <grid> ( children -- grid )
@@ -21,7 +21,7 @@ grid
 : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
 
 : grid-add ( gadget grid i j -- )
-    >r >r 2dup add-gadget r> r>
+    >r >r 2dup swap add-gadget drop r> r>
     3dup grid-child unparent rot grid>> nth set-nth ;
 
 : grid-remove ( grid i j -- )

extra/ui/gadgets/incremental/incremental.factor

@@ -45,7 +45,7 @@ M: incremental pref-dim*
 
 : add-incremental ( gadget incremental -- )
     not-in-layout
-    2dup (add-gadget)
+    2dup swap (add-gadget) drop
     over prefer-incremental
     over layout-later
     2dup incremental-loc

extra/ui/gadgets/lists/lists.factor

@@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ;
 M: list model-changed
     nip
     dup clear-gadget
-    dup <list-items> over add-gadgets
+    dup <list-items> over swap add-gadgets drop
     bound-index ;
 
 : selected-rect ( list -- rect )

extra/ui/gadgets/menus/menus.factor

@@ -15,7 +15,7 @@ TUPLE: menu-glass < gadget ;
 : <menu-glass> ( menu world -- glass )
     menu-glass new-gadget
     >r over menu-loc over set-rect-loc r>
-    [ add-gadget ] keep ;
+    [ swap add-gadget drop ] keep ;
 
 M: menu-glass layout* gadget-child prefer ;
 
@@ -26,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ;
 : show-glass ( gadget world -- )
     over hand-clicked set-global
     [ hide-glass ] keep
-    [ add-gadget ] 2keep
+    [ swap add-gadget drop ] 2keep
     set-world-glass ;
 
 : show-menu ( gadget owner -- )

extra/ui/gadgets/panes/panes.factor

@@ -22,10 +22,10 @@ selection-color caret mark selecting? ;
     drop ;
 
 : add-output ( current pane -- )
-    [ set-pane-output ] [ add-gadget ] 2bi ;
+    [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
 
 : add-current ( current pane -- )
-    [ set-pane-current ] [ add-gadget ] 2bi ;
+    [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
 
 : prepare-line ( pane -- )
     [ clear-selection ]
@@ -120,7 +120,7 @@ C: <pane-stream> pane-stream
 GENERIC: write-gadget ( gadget stream -- )
 
 M: pane-stream write-gadget
-    pane-stream-pane pane-current add-gadget ;
+    pane-stream-pane pane-current swap add-gadget drop ;
 
 M: style-stream write-gadget
     stream>> write-gadget ;
@@ -299,12 +299,12 @@ M: paragraph dispose drop ;
 
 : gadget-write ( string gadget -- )
     over empty?
-    [ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
+    [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
 
 M: pack stream-write gadget-write ;
 
 : gadget-bl ( style stream -- )
-    >r " " <word-break-gadget> style-label r> add-gadget ;
+    >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
 
 M: paragraph stream-write
     swap " " split
@@ -322,7 +322,7 @@ M: paragraph stream-write1
 
 : gadget-format ( string style stream -- )
     pick empty?
-    [ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;
+    [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
 
 M: pack stream-format
     gadget-format ;

extra/ui/gadgets/scrollers/scrollers-tests.factor

@@ -61,7 +61,7 @@ tools.test.ui math.geometry.rect ;
 
 <gadget> { 600 400 } over set-rect-dim "g1" set
 <gadget> { 600 10 } over set-rect-dim "g2" set
-"g2" get "g1" get add-gadget
+"g2" get "g1" get swap add-gadget drop
 
 "g1" get <scroller>
 { 300 300 } over set-rect-dim

extra/ui/gadgets/sliders/sliders.factor

@@ -140,7 +140,7 @@ M: elevator layout*
 
 : elevator, ( orientation -- )
     dup <elevator> g-> set-slider-elevator
-    swap <thumb> g-> set-slider-thumb over add-gadget
+    swap <thumb> g-> set-slider-thumb add-gadget
     @center frame, ;
 
 : <left-button> ( -- button )

extra/ui/gadgets/tabs/tabs.factor

@@ -16,7 +16,7 @@ DEFER: (del-page)
     [ [ gadget-parent '[ , , , (del-page) ] "X" swap
        <bevel-button> @right frame, ] 3keep 
       [ swapd <toggle-button> @center frame, ] dip ] make-frame
-    swap add-gadget ;
+    add-gadget drop ;
 
 : redo-toggler ( tabbed -- )
      [ names>> ] [ model>> ] [ toggler>> ] tri
@@ -41,7 +41,7 @@ DEFER: (del-page)
     [ [ model>> swap ]
       [ names>> length 1 - swap ]
       [ toggler>> ] tri add-toggle ]
-    [ content>> add-gadget ]
+    [ content>> swap add-gadget drop ]
     [ refresh-book ] tri ;
 
 : del-page ( name tabbed -- )

extra/ui/gadgets/tracks/tracks.factor

@@ -47,7 +47,7 @@ M: track pref-dim*
     rot gadget-orientation set-axis ;
 
 : track-add ( gadget track constraint -- )
-    over track-sizes push add-gadget ;
+    over track-sizes push swap add-gadget drop ;
 
 : track, ( gadget constraint -- )
     gadget get swap track-add ;

extra/ui/gadgets/viewports/viewports.factor

@@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
     viewport new-gadget
         swap >>model
         t >>clipped?
-        [ add-gadget ] keep ;
+        [ swap add-gadget drop ] keep ;
 
 M: viewport layout*
     dup rect-dim viewport-gap 2 v*n v-

extra/ui/gadgets/worlds/worlds-tests.factor

@@ -18,7 +18,7 @@ namespaces models kernel ;
 
 <gadget> "g1" set
 <gadget> "g2" set
-"g1" get "g2" get add-gadget
+"g1" get "g2" get swap add-gadget drop
 
 [ ] [
     "g2" get <test-world> "w" set
@@ -33,8 +33,8 @@ namespaces models kernel ;
 <gadget> "g1" set
 <gadget> "g2" set
 <gadget> "g3" set
-"g1" get "g3" get add-gadget
-"g2" get "g3" get add-gadget
+"g1" get "g3" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
 
 [ ] [
     "g3" get <test-world> "w" set
@@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
 
 : <focus-test>
     focus-test new-gadget
-    <focusing> over add-gadget ;
+    <focusing> over swap add-gadget drop ;
 
 M: focus-test focusable-child* gadget-child ;
 

extra/ui/gadgets/wrappers/wrappers.factor

@@ -7,7 +7,7 @@ TUPLE: wrapper < gadget ;
 
 : new-wrapper ( child class -- wrapper )
     new-gadget
-        [ add-gadget ] keep ; inline
+        [ swap add-gadget drop ] keep ; inline
 
 : <wrapper> ( child -- border )
     wrapper new-wrapper ;