From c4e3482783c239491b67b2cf2dbce44e5f0daeac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 11 Jul 2008 01:33:20 -0500
Subject: [PATCH] Beef up borders, fix roll button apperance

---
 extra/ui/gadgets/borders/borders-tests.factor | 25 +++++++++++
 extra/ui/gadgets/borders/borders.factor       | 43 +++++++++----------
 extra/ui/gadgets/buttons/buttons.factor       |  3 +-
 3 files changed, 47 insertions(+), 24 deletions(-)
 create mode 100644 extra/ui/gadgets/borders/borders-tests.factor

diff --git a/extra/ui/gadgets/borders/borders-tests.factor b/extra/ui/gadgets/borders/borders-tests.factor
new file mode 100644
index 0000000000..268d1ab0a3
--- /dev/null
+++ b/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
diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor
index 83bb4f3c3f..55d1993b1d 100644
--- a/extra/ui/gadgets/borders/borders.factor
+++ b/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
-        { 0 0 } >>size
-        { 0 0 } >>fill
-        [ add-gadget ] keep ; inline
+    new-gadget [ 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 )
-    dup border-size swap rect-dim over 2 v*n v- <rect> ;
+: border-major-dim ( border -- dim )
+    [ dim>> ] [ size>> 2 v*n ] bi v- ;
 
-: border-minor-rect ( major border -- rect )
-    gadget-child pref-dim
-    [ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
-    <rect> ;
+: border-minor-dim ( border -- dim )
+    gadget-child pref-dim ;
 
-: scale-rect ( rect vec -- loc dim )
-    [ v* ] curry >r rect-bounds r> bi@ ;
+: scale ( a b s -- c )
+    tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
 
-: average-rects ( rect1 rect2 weight -- rect )
-    tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
-    swapd v+ >r v+ r> <rect> ;
+: border-dim ( border -- dim )
+    [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
+
+: 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 pick border-minor-rect
-    rot border-fill
-    average-rects ;
+    dup border-dim [ border-loc ] keep <rect> ;
 
 M: border layout*
     dup border-child-rect swap gadget-child
-    over rect-loc over set-rect-loc
-    swap rect-dim swap set-layout-dim ;
+    over loc>> over set-rect-loc
+    swap dim>> swap set-layout-dim ;
 
 M: border focusable-child*
     gadget-child ;
diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor
index 770e0b9f15..96a89e8aa6 100755
--- a/extra/ui/gadgets/buttons/buttons.factor
+++ b/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 ;