borders of various kinds

library/ui/layouts.factor

@@ -6,6 +6,27 @@ USING: generic hashtables kernel lists math namespaces ;
 GENERIC: layout* ( gadget -- )
 M: gadget layout* drop ;
 
+: 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 ;
+
 ! A pile is a box that lays out its contents vertically.
 TUPLE: pile delegate ;
 
@@ -32,23 +53,39 @@ M: shelf layout* ( pile -- )
         uncons 0 rot move-gadget
     ] each ;
 
-: relayout ( gadget -- )
+! A border lays out its children on top of each other, all with
-    #! Relayout a gadget before the next iteration of the event
+! a 5-pixel padding.
-    #! loop. Since relayout also implies the visual
+TUPLE: border size delegate ;
-    #! representation changed, we redraw the gadget too.
-    t over set-gadget-redraw?
-    t over set-gadget-relayout?
-    gadget-parent [ relayout ] when* ;
 
-: layout ( gadget -- )
+C: border ( delegate size -- border )
-    #! Set the gadget's width and height to its preferred width
+    [ set-border-size ] keep [ set-border-delegate ] keep ;
-    #! and height. The gadget's children are laid out first.
+
-    #! Note that nothing is done if the gadget does not need to
+: standard-border ( child delegate -- border )
-    #! be laid out.
+    5 <border> [ box+ ] keep ;
-    dup gadget-relayout? [
+
-        f over set-gadget-relayout?
+: empty-border ( child -- border )
-        dup gadget-children [ layout ] each
+    0 0 0 0 <rectangle> <gadget> standard-border ;
-        layout*
+
-    ] [
+: bevel-border ( child -- border )
-        drop
+    3 0 0 0 0 <bevel-rect> <gadget> standard-border ;
-    ] ifte ;
+
+: size-border ( border -- )
+    dup gadget-children
+    dup max-width pick border-size 2 * +
+    swap max-height pick border-size 2 * +
+    rot resize-gadget ;
+
+: layout-border-x/y ( border -- )
+    dup gadget-children [
+        >r border-size dup r> move-gadget
+    ] each-with ;
+
+: layout-border-w/h ( border -- )
+    [
+        dup shape-h over border-size - >r
+        dup shape-w swap border-size - r>
+    ] keep
+    gadget-children [ >r 2dup r> resize-gadget ] each 2drop ;
+
+M: border layout* ( border -- )
+    dup size-border dup layout-border-x/y layout-border-w/h ;