removed boxes; all gadgets can contain children now

library/bootstrap/boot-stage2.factor

@@ -153,9 +153,8 @@ cpu "x86" = [
         "/library/ui/line-editor.factor"
         "/library/ui/console.factor"
         "/library/ui/shapes.factor"
-        "/library/ui/paint.factor"
         "/library/ui/gadgets.factor"
-        "/library/ui/boxes.factor"
+        "/library/ui/paint.factor"
         "/library/ui/gestures.factor"
         "/library/ui/hand.factor"
         "/library/ui/world.factor"

library/ui/boxes.factor

@@ -1,60 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic hashtables kernel lists namespaces ;
-
-! A box is a gadget holding other gadgets.
-TUPLE: box children delegate ;
-
-C: box ( gadget -- box )
-    [ set-box-delegate ] keep ;
-
-M: box gadget-children box-children ;
-
-M: box draw-shape ( box -- )
-    dup box-delegate draw-gadget
-    dup [ box-children [ draw-gadget ] each ] with-translation ;
-
-M: general-list pick-up* ( point list -- gadget )
-    dup [
-        2dup car pick-up dup [
-            2nip
-        ] [
-            drop cdr pick-up
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-M: box pick-up* ( point box -- gadget )
-    #! The logic is thus. If the point is definately outside the
-    #! box, return f. Otherwise, see if the point is contained
-    #! in any subgadget. If not, see if it is contained in the
-    #! box delegate.
-    2dup inside? [
-        2dup [ translate ] keep box-children pick-up dup [
-            2nip
-        ] [
-            drop box-delegate pick-up*
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-: box- ( gadget box -- )
-    [ 2dup box-children remq swap set-box-children ] keep
-    relayout
-    f swap set-gadget-parent ;
-
-: (box+) ( gadget box -- )
-    [ box-children cons ] keep set-box-children ;
-
-: unparent ( gadget -- )
-    dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
-
-: box+ ( gadget box -- )
-    #! Add a gadget to a box.
-    over unparent
-    dup pick set-gadget-parent
-    tuck (box+)
-    relayout ;

library/ui/gadgets.factor

@@ -6,34 +6,10 @@ USING: generic hashtables kernel lists namespaces ;
 ! A gadget is a shape, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent. A gadget
 ! delegates to its shape.
-TUPLE: gadget paint gestures parent relayout? redraw? delegate ;
+TUPLE: gadget
-
+    paint gestures
-! Gadget protocol.
+    relayout? redraw?
-GENERIC: pick-up* ( point gadget -- gadget/t )
+    parent children delegate ;
-
-: pick-up ( point gadget -- gadget )
-    #! pick-up* returns t to mean 'this gadget', avoiding the
-    #! exposed facade issue.
-    tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
-
-GENERIC: gadget-children ( gadget -- list )
-M: gadget gadget-children drop f ;
-
-GENERIC: layout* ( gadget -- )
-M: gadget layout* drop ;
-
-: layout ( gadget -- )
-    #! Set the gadget's width and height to its preferred width
-    #! and height. The gadget's children are laid out first.
-    #! Note that nothing is done if the gadget does not need to
-    #! be laid out.
-    dup gadget-relayout? [
-        f over set-gadget-relayout?
-        dup gadget-children [ layout ] each
-        layout*
-    ] [
-        drop
-    ] ifte ;
 
 C: gadget ( shape -- gadget )
     [ set-gadget-delegate ] keep
@@ -54,30 +30,26 @@ C: gadget ( shape -- gadget )
 : set-action ( gadget quot gesture -- )
     rot gadget-gestures set-hash ;
 
-: draw-gadget ( gadget -- )
-    #! All drawing done inside draw-shape is done with the
-    #! gadget's paint. If the gadget does not have any custom
-    #! paint, just call the quotation.
-    dup gadget-paint [ draw-shape ] bind ;
-
-M: gadget pick-up* inside? ;
-
-: redraw ( gadget -- )
-    #! Redraw a gadget before the next iteration of the event
-    #! loop.
-    t over set-gadget-redraw?
-    gadget-parent [ redraw ] when* ;
-
-: relayout ( gadget -- )
-    #! Relayout a gadget before the next iteration of the event
-    #! loop. Since relayout also implies the visual
-    #! representation changed, we redraw the gadget too.
-    t over set-gadget-redraw?
-    t over set-gadget-relayout?
-    gadget-parent [ relayout ] when* ;
-
 : move-gadget ( x y gadget -- )
     [ move-shape ] keep redraw ;
 
 : resize-gadget ( w h gadget -- )
     [ resize-shape ] keep redraw ;
+
+: box- ( gadget box -- )
+    [ 2dup gadget-children remq swap set-gadget-children ] keep
+    relayout
+    f swap set-gadget-parent ;
+
+: (box+) ( gadget box -- )
+    [ gadget-children cons ] keep set-gadget-children ;
+
+: unparent ( gadget -- )
+    dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
+
+: box+ ( gadget box -- )
+    #! Add a gadget to a box.
+    over unparent
+    dup pick set-gadget-parent
+    tuck (box+)
+    relayout ;

library/ui/hand.factor

@@ -4,7 +4,41 @@ IN: gadgets
 USING: alien generic kernel lists math namespaces sdl sdl-event
 sdl-video ;
 
-SYMBOL: world
+DEFER: pick-up*
+
+: pick-up-list ( point list -- gadget )
+    dup [
+        2dup car pick-up dup [
+            2nip
+        ] [
+            drop cdr pick-up-list
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+: pick-up* ( point gadget -- gadget/t )
+    #! The logic is thus. If the point is definately outside the
+    #! box, return f. Otherwise, see if the point is contained
+    #! in any subgadget. If not, see if it is contained in the
+    #! box delegate.
+    2dup inside? [
+        2dup [ translate ] keep
+        gadget-children pick-up-list dup [
+            2nip
+        ] [
+            drop inside?
+        ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
+: pick-up ( point gadget -- gadget )
+    #! pick-up* returns t to mean 'this gadget', avoiding the
+    #! exposed facade issue.
+    tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
+
+DEFER: world
 
 ! The hand is a special gadget that holds mouse position and
 ! mouse button click state. The hand's parent is the world, but
@@ -13,7 +47,7 @@ SYMBOL: world
 TUPLE: hand click-pos clicked buttons delegate ;
 
 C: hand ( world -- hand )
-    0 0 <point> <gadget> <box>
+    0 0 <point> <gadget>
     over set-hand-delegate
     [ set-gadget-parent ] keep ;
 

library/ui/layouts.factor

@@ -3,11 +3,14 @@
 IN: gadgets
 USING: generic hashtables kernel lists math namespaces ;
 
+GENERIC: layout* ( gadget -- )
+M: gadget layout* drop ;
+
 ! A pile is a box that lays out its contents vertically.
 TUPLE: pile delegate ;
 
-C: pile ( gadget -- pile )
+C: pile ( shape -- pile )
-    [ >r <box> r> set-pile-delegate ] keep ;
+    [ >r <gadget> r> set-pile-delegate ] keep ;
 
 M: pile layout* ( pile -- )
     dup gadget-children run-heights >r >r
@@ -19,8 +22,8 @@ M: pile layout* ( pile -- )
 ! A shelf is a box that lays out its contents horizontally.
 TUPLE: shelf delegate ;
 
-C: shelf ( gadget -- pile )
+C: shelf ( shape -- pile )
-    [ >r <box> r> set-shelf-delegate ] keep ;
+    [ >r <gadget> r> set-shelf-delegate ] keep ;
 
 M: shelf layout* ( pile -- )
     dup gadget-children run-widths >r >r
@@ -28,3 +31,24 @@ M: shelf layout* ( pile -- )
     gadget-children r> zip [
         uncons 0 rot move-gadget
     ] each ;
+
+: relayout ( gadget -- )
+    #! Relayout a gadget before the next iteration of the event
+    #! loop. Since relayout also implies the visual
+    #! representation changed, we redraw the gadget too.
+    t over set-gadget-redraw?
+    t over set-gadget-relayout?
+    gadget-parent [ relayout ] when* ;
+
+: layout ( gadget -- )
+    #! Set the gadget's width and height to its preferred width
+    #! and height. The gadget's children are laid out first.
+    #! Note that nothing is done if the gadget does not need to
+    #! be laid out.
+    dup gadget-relayout? [
+        f over set-gadget-relayout?
+        dup gadget-children [ layout ] each
+        layout*
+    ] [
+        drop
+    ] ifte ;

library/ui/paint.factor

@@ -84,3 +84,20 @@ M: bevel-rect draw-shape ( rect -- )
         [[ color [ 160 160 160 ] ]]
         [[ font [[ "Monospaced" 12 ]] ]]
     }} ;
+
+: draw-gadget ( gadget -- )
+    #! All drawing done inside draw-shape is done with the
+    #! gadget's paint. If the gadget does not have any custom
+    #! paint, just call the quotation.
+    dup gadget-paint [
+        dup draw-shape
+        dup [
+            gadget-children [ draw-gadget ] each
+        ] with-translation
+    ] bind ;
+
+: redraw ( gadget -- )
+    #! Redraw a gadget before the next iteration of the event
+    #! loop.
+    t over set-gadget-redraw?
+    gadget-parent [ redraw ] when* ;

library/ui/world.factor

@@ -11,8 +11,7 @@ TUPLE: world running? hand delegate ;
 
 : <world-box> ( -- box )
     0 0 0 0 <plain-rect> <everywhere> <gadget>
-    dup [ 216 216 216 ] color set-paint-property
+    dup [ 216 216 216 ] color set-paint-property ;
-    <box> ;
 
 C: world ( -- world )
     <world-box> over set-world-delegate