Beef up borders, fix roll button apperance

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

@@ -0,0 +1,25 @@
+IN: ui.gadgets.borders.tests
+USING: tools.test accessors namespaces kernel
+ui.gadgets ui.gadgets.borders ;
+
+[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
+
+[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
+
+[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 0 0 } >>align drop ] unit-test
+
+[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
+
+[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
+
+[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test

extra/ui/gadgets/borders/borders.factor

@@ -4,47 +4,44 @@ USING: accessors arrays ui.gadgets kernel math
 namespaces vectors sequences math.vectors ;
 IN: ui.gadgets.borders
 
-TUPLE: border < gadget size fill ;
+TUPLE: border < gadget
+{ size initial: { 0 0 } }
+{ fill initial: { 0 0 } }
+{ align initial: { 1/2 1/2 } } ;
 
 : new-border ( child class -- border )
-    new-gadget
+    new-gadget [ add-gadget ] keep ; inline
-        { 0 0 } >>size
-        { 0 0 } >>fill
-        [ add-gadget ] keep ; inline
 
 : <border> ( child gap -- border )
     swap border new-border
         swap dup 2array >>size ;
 
 M: border pref-dim*
-    [ border-size 2 v*n ] keep
+    [ size>> 2 v*n ] keep
     gadget-child pref-dim v+ ;
 
-: border-major-rect ( border -- rect )
+: border-major-dim ( border -- dim )
-    dup border-size swap rect-dim over 2 v*n v- <rect> ;
+    [ dim>> ] [ size>> 2 v*n ] bi v- ;
 
-: border-minor-rect ( major border -- rect )
+: border-minor-dim ( border -- dim )
-    gadget-child pref-dim
+    gadget-child pref-dim ;
-    [ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
-    <rect> ;
 
-: scale-rect ( rect vec -- loc dim )
+: scale ( a b s -- c )
-    [ v* ] curry >r rect-bounds r> bi@ ;
+    tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
 
-: average-rects ( rect1 rect2 weight -- rect )
+: border-dim ( border -- dim )
-    tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
+    [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
-    swapd v+ >r v+ r> <rect> ;
+
+: border-loc ( border dim -- loc )
+    [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
 
 : border-child-rect ( border -- rect )
-    dup border-major-rect
+    dup border-dim [ border-loc ] keep <rect> ;
-    dup pick border-minor-rect
-    rot border-fill
-    average-rects ;
 
 M: border layout*
     dup border-child-rect swap gadget-child
-    over rect-loc over set-rect-loc
+    over loc>> over set-rect-loc
-    swap rect-dim swap set-layout-dim ;
+    swap dim>> swap set-layout-dim ;
 
 M: border focusable-child*
     gadget-child ;

extra/ui/gadgets/buttons/buttons.factor

@@ -68,7 +68,8 @@ M: button-paint draw-boundary
     button-paint draw-boundary ;
 
 : roll-button-theme ( button -- button )
-    f black <solid> dup f <button-paint> >>boundary ; inline
+    f black <solid> dup f <button-paint> >>boundary
+    { 0 1/2 } >>align ; inline
 
 : <roll-button> ( label quot -- button )
     <button> roll-button-theme ;