Add support for Joe's "graphics baseline" idea

basis/ui/gadgets/borders/borders.factor

@@ -25,7 +25,8 @@ M: border pref-dim*
     [ min-dim>> ] bi vmax ;
 
 M: border baseline
-    [ size>> second ] [ gadget-child baseline ] bi + ;
+    [ size>> second ] [ gadget-child baseline ] bi
+    dup [ + ] [ nip ] if ;
 
 : border-major-dim ( border -- dim )
     [ dim>> ] [ size>> 2 v*n ] bi v- ;

basis/ui/gadgets/gadgets-tests.factor

@@ -164,3 +164,12 @@ M: mock-gadget ungraft*
 
 \ graft* must-infer
 \ ungraft* must-infer
+
+! Test baseline calculations
+[ 10 ] [ 0 10 0 combine-baseline-metrics + ] unit-test
+[ 15 ] [ 0 10 5 combine-baseline-metrics + ] unit-test
+[ 30 ] [ 30 0 0 combine-baseline-metrics + ] unit-test
+[ 35 ] [ 10 0 30 combine-baseline-metrics + ] unit-test
+[ 20 ] [ 5 10 10 combine-baseline-metrics + ] unit-test
+[ 20 ] [ 20 10 0 combine-baseline-metrics + ] unit-test
+[ 55 ] [ 20 10 40 combine-baseline-metrics + ] unit-test

basis/ui/gadgets/gadgets.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays hashtables kernel models math namespaces
 make sequences quotations math.vectors combinators sorting
 binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry ;
+concurrency.flags math.order math.rectangles fry locals ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -197,19 +197,49 @@ SYMBOL: +baseline+
 
 GENERIC: baseline ( gadget -- y )
 
-M: gadget baseline pref-dim second ;
+M: gadget baseline drop f ;
 
-: (baseline-align) ( baselines -- ys )
-    [ { } ] [ [ supremum ] keep [ - ] with map ] if-empty ;
+: (max-ascent-and-descent) ( accum baseline height -- accum' )
+    over [ over - 2array vmax ] [ 2drop ] if ;
 
-: baseline-align ( gadgets -- ys )
-    [ baseline ] map (baseline-align) ;
+: max-ascent-and-descent ( baselines heights -- ascent descent )
+    { 0 0 } [ (max-ascent-and-descent) ] 2reduce first2 ;
 
-: (baseline-metrics) ( baselines sizes -- ascent descent )
-    { 0 0 } [ second over - 2array vmax ] 2reduce first2 ;
+: max-height-with-baseline ( baselines heights -- y )
+    0 [ swap [ max ] [ drop ] if ] 2reduce ;
+
+: max-height-without-baseline ( baselines heights -- y )
+    0 [ swap [ drop ] [ max ] if ] 2reduce ;
+
+:: baseline-align ( gadgets -- ys )
+    gadgets [ [ baseline ] map ] [ [ pref-dim second ] map ] bi
+    over 0 [ [ max ] when* ] reduce :> max-baseline
+    2dup max-height-without-baseline :> max-height-without-baseline
+    max-height-without-baseline max-baseline [-] 2 /i :> offset-with-baseline
+    max-baseline max-height-without-baseline [-] 2 /i :> offset-without-baseline
+    [
+        over [
+            drop
+            max-baseline
+            offset-with-baseline
+        ] [
+            nip
+            max-height-without-baseline
+            offset-without-baseline
+        ] if [ swap - ] dip +
+    ] 2map ;
+
+: combine-baseline-metrics ( height ascent descent -- ascent' descent' )
+    [ [ [-] 2 /i ] keep ] dip [ + ] [ max ] bi-curry* bi ;
 
 : baseline-metrics ( children sizes -- ascent descent )
-    [ [ baseline ] map ] dip (baseline-metrics) ;
+    #! Consider gadgets with a baseline and those without separately.
+    [ [ baseline ] map ] [ [ second ] map ] bi*
+    [ max-height-without-baseline ] [ max-ascent-and-descent ] 2bi
+    combine-baseline-metrics ;
+
+: baseline-height ( children sizes -- height )
+    baseline-metrics + ;
 
 GENERIC: layout* ( gadget -- )
 

basis/ui/gadgets/grids/grids.factor

@@ -50,7 +50,7 @@ TUPLE: grid-layout grid gap fill? row-heights column-widths ;
 : row-heights ( grid-layout -- heights )
     [ grid>> ] [ fill?>> ] bi
     [ [ second ] iterate-cell-dims ]
-    [ [ dup [ pref-dim>> ] map baseline-metrics + ] map ]
+    [ [ dup [ pref-dim>> ] map baseline-height ] map ]
     if ;
 
 : column-widths ( grid-layout -- widths )

basis/ui/gadgets/packs/packs-tests.factor

@@ -20,6 +20,7 @@ IN: ui.gadgets.packs.tests
     orient
 ] unit-test
 
+! Test baseline alignment
 <shelf> +baseline+ >>align
     5 { 10 10 } <baseline-gadget> add-gadget
     10 { 10 10 } <baseline-gadget> add-gadget
@@ -33,4 +34,44 @@ IN: ui.gadgets.packs.tests
     "g" get
     dup layout
     children>> [ loc>> ] map
+] unit-test
+
+! Test mixed baseline and ordinary alignment
+<shelf> +baseline+ >>align
+    <gadget> { 20 20 } >>dim add-gadget
+    10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ { 30 20 } ] [ "g" get pref-dim ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 20 5 } } ] [
+    "g" get children>> [ loc>> ] map
+] unit-test
+
+<shelf> +baseline+ >>align
+    <gadget> { 15 15 } >>dim add-gadget
+    5 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ { 25 15 } ] [ "g" get pref-dim ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 15 5 } } ] [
+    "g" get children>> [ loc>> ] map
+] unit-test
+
+<shelf> +baseline+ >>align
+    <gadget> { 20 20 } >>dim add-gadget
+    30 { 10 50 } <baseline-gadget> add-gadget
+"g" set
+
+[ { 30 50 } ] [ "g" get pref-dim ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 5 } { 20 0 } } ] [
+    "g" get children>> [ loc>> ] map
 ] unit-test

basis/ui/gadgets/packs/packs.factor

@@ -66,7 +66,7 @@ PRIVATE>
 
 : max-pack-dim ( pack sizes -- dim )
     over align>> +baseline+ eq?
-    [ [ children>> ] dip baseline-metrics + 0 swap 2array ] [ nip max-dim ] if ;
+    [ [ children>> ] dip baseline-height 0 swap 2array ] [ nip max-dim ] if ;
 
 : pack-pref-dim ( pack sizes -- dim )
     [ max-pack-dim ]
@@ -81,7 +81,7 @@ M: pack pref-dim*
     children>> [ 0 ] [ first baseline ] if-empty ;
 
 : horizontal-baseline ( pack -- y )
-    children>> [ baseline ] [ max ] map-reduce ;
+    children>> dup pref-dims baseline-metrics drop ;
 
 PRIVATE>
 

basis/ui/gadgets/paragraphs/paragraphs.factor

@@ -29,10 +29,10 @@ TUPLE: paragraph < gadget margin ;
 : gadget>word ( gadget -- word )
     [ ] [ pref-dim first ] [ word-break? ] tri <word> ;
 
-TUPLE: line words ascent descent ;
+TUPLE: line words height ;
 
 : <line> ( words -- line )
-    dup [ key>> ] map dup pref-dims baseline-metrics line boa ;
+    dup [ key>> ] map dup pref-dims baseline-height line boa ;
 
 : wrap-paragraph ( paragraph -- wrapped-paragraph )
     [ children>> [ gadget>word ] map ] [ margin>> ] bi
@@ -44,17 +44,14 @@ TUPLE: line words ascent descent ;
 : max-line-width ( wrapped-paragraph -- x )
     [ words>> line-width ] [ max ] map-reduce ;
 
-: line-height ( wrapped-line -- ys )
-    [ ascent>> ] [ descent>> ] bi + ;
-
 : sum-line-heights ( wrapped-paragraph -- y )
-    [ line-height ] sigma ;
+    [ height>> ] sigma ;
 
 M: paragraph pref-dim*
     wrap-paragraph [ max-line-width ] [ sum-line-heights ] bi 2array ;
 
 : line-y-coordinates ( wrapped-paragraph -- ys )
-    0 [ line-height + ] accumulate nip ;
+    0 [ height>> + ] accumulate nip ;
 
 : word-x-coordinates ( wrapped-line -- xs )
     0 [ width>> + ] accumulate nip ;
@@ -75,8 +72,11 @@ M: paragraph layout*
     [ layout-line ] 2each ;
 
 M: paragraph baseline
-    children>> [ 0 ] [
-        first [ loc>> second ] [ baseline ] bi +
+    wrap-paragraph [ f ] [
+        first words>>
+        [ key>> ] map
+        dup [ pref-dim ] map
+        baseline-metrics drop
     ] if-empty ;
 
 PRIVATE>

basis/ui/tools/listener/completion/completion.factor

@@ -146,7 +146,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
         monospace-font >>font
         t >>selection-required?
         transparent >>column-line-color
-        0 >>gap
+        2 >>gap
         dup '[ _ accept-completion ] >>action ;
 
 : <completion-scroller> ( completion-popup -- scroller )