Split off baseline alignment code into ui.baseline-alignment, and add cap-height generic word

basis/ui/baseline-alignment/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/baseline-alignment/baseline-alignment-tests.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math kernel sets generic
+ui.baseline-alignment ui.baseline-alignment.private ;
+IN: ui.baseline-alignment.tests
+
+! Test baseline calculations
+[ 10 ] [ 0 10 0 combine-metrics + ] unit-test
+[ 15 ] [ 0 10 5 combine-metrics + ] unit-test
+[ 30 ] [ 30 0 0 combine-metrics + ] unit-test
+[ 35 ] [ 10 0 30 combine-metrics + ] unit-test
+[ 20 ] [ 5 10 10 combine-metrics + ] unit-test
+[ 20 ] [ 20 10 0 combine-metrics + ] unit-test
+[ 55 ] [ 20 10 40 combine-metrics + ] unit-test
+
+[ t ] [ \ baseline \ cap-height [ order ] bi@ set= ] unit-test 

basis/ui/baseline-alignment/baseline-alignment.factor

@@ -0,0 +1,68 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel locals math math.order math.vectors
+sequences ui.gadgets accessors ;
+IN: ui.baseline-alignment
+
+SYMBOL: +baseline+
+
+GENERIC: baseline ( gadget -- y )
+
+M: gadget baseline drop f ;
+
+GENERIC: cap-height ( gadget -- y )
+
+M: gadget cap-height drop f ;
+
+<PRIVATE
+
+! Text has ascent/descent/cap-height slots, graphics does not.
+TUPLE: gadget-metrics height ascent descent cap-height ;
+
+: <gadget-metrics> ( gadget dim -- metrics )
+    second swap [ baseline ] [ cap-height ] bi
+    [ dup [ 2dup - ] [ f ] if ] dip
+    gadget-metrics boa ; inline
+
+: max-ascent ( seq -- n )
+    0 [ ascent>> [ max ] when* ] reduce ; inline
+
+: max-descent ( seq -- n )
+    0 [ descent>> [ max ] when* ] reduce ; inline
+
+: max-text-height ( seq -- y )
+    0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
+
+: max-graphics-height ( seq -- y )
+    0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
+
+: combine-metrics ( graphics-height ascent descent -- ascent' descent' )
+    [ [ [-] 2 /i ] keep ] dip [ + ] [ max ] bi-curry* bi ;
+
+PRIVATE>
+
+:: align-baselines ( gadgets -- ys )
+    gadgets [ dup pref-dim <gadget-metrics> ] map
+    dup max-ascent :> max-ascent
+    dup max-graphics-height :> max-height
+    max-height max-ascent [-] 2 /i :> offset-text
+    max-ascent max-height [-] 2 /i :> offset-graphics
+    [
+        dup ascent>> [
+            ascent>>
+            max-ascent
+            offset-text
+        ] [
+            height>>
+            max-height
+            offset-graphics
+        ] if [ swap - ] dip +
+    ] map ;
+
+: measure-metrics ( children sizes -- ascent descent )
+    [ <gadget-metrics> ] 2map
+    [ max-graphics-height ] [ max-ascent ] [ max-descent ] tri
+    combine-metrics ;
+
+: measure-height ( children sizes -- height )
+    measure-metrics + ;

basis/ui/gadgets/borders/borders.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets kernel math fry
+USING: accessors arrays ui.gadgets ui.baseline-alignment kernel math fry
 namespaces vectors sequences math.vectors math.rectangles ;
 IN: ui.gadgets.borders
 
@@ -26,10 +26,6 @@ TUPLE: border < gadget
 M: border pref-dim*
     dup gadget-child pref-dim border-pref-dim ;
 
-M: border baseline
-    [ size>> second ] [ gadget-child baseline ] bi
-    dup [ + ] [ nip ] if ;
-
 <PRIVATE
 
 : border-major-dim ( border -- dim )
@@ -51,8 +47,16 @@ M: border baseline
 : border-child-rect ( border -- rect )
     dup border-dim [ border-loc ] keep <rect> ;
 
+: border-metric ( border quot -- n )
+    [ drop size>> second ] [ [ gadget-child ] dip call ] 2bi
+    dup [ + ] [ nip ] if ; inline
+
 PRIVATE>
 
+M: border baseline [ baseline ] border-metric ;
+
+M: border cap-height [ cap-height ] border-metric ;
+
 M: border layout*
     [ border-child-rect ] [ gadget-child ] bi set-rect-bounds ;
 

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

@@ -30,8 +30,6 @@ T{ foo-gadget } <toolbar> "t" set
 
 \ <radio-buttons> must-infer
 
-\ <toggle-buttons> must-infer
-
 \ <checkbox> must-infer
 
 [ 0 ] [

basis/ui/gadgets/debug/debug.factor

@@ -1,12 +1,15 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors ui ui.gadgets ui.gadgets.buttons ui.render ;
+USING: kernel accessors sequences ui ui.gadgets ui.gadgets.buttons
+ui.baseline-alignment ui.render ;
 IN: ui.gadgets.debug
 
 TUPLE: baseline-gadget < gadget baseline ;
 
 M: baseline-gadget baseline baseline>> ;
 
+M: baseline-gadget cap-height dim>> second ;
+
 : <baseline-gadget> ( baseline dim -- gadget )
     baseline-gadget new
         swap >>dim

basis/ui/gadgets/editors/editors.factor

@@ -6,8 +6,8 @@ opengl.gl sequences strings math.vectors math.functions sorting colors
 colors.constants combinators assocs math.order fry calendar alarms
 continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
 ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.menus ui.gadgets.wrappers ui.render
+ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
-ui.pens.solid ui.gadgets.line-support ui.text ui.gestures
+ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment
 math.rectangles splitting unicode.categories fonts grouping ;
 IN: ui.gadgets.editors
 
@@ -199,8 +199,9 @@ M: editor draw-gadget*
 M: editor pref-dim*
     [ font>> ] [ control-value ] bi text-dim ;
 
-M: editor baseline
+M: editor baseline font>> font-metrics ascent>> ;
-    font>> font-metrics ascent>> ;
+
+M: editor cap-height font>> font-metrics cap-height>> ;
 
 : contents-changed ( model editor -- )
     swap
@@ -482,7 +483,7 @@ TUPLE: multiline-editor < editor ;
 
 <PRIVATE
 
-: page-elt ( editor -- editor element ) dup visible-lines <page-elt> ;
+: page-elt ( editor -- editor element ) dup visible-lines 1- <page-elt> ;
 
 PRIVATE>
 

basis/ui/gadgets/gadgets-tests.factor

@@ -1,7 +1,8 @@
 USING: accessors ui.gadgets ui.gadgets.private ui.gadgets.packs
 ui.gadgets.worlds tools.test namespaces models kernel dlists deques
 math sets math.parser ui sequences hashtables assocs io arrays
-prettyprint io.streams.string math.rectangles ui.gadgets.private ;
+prettyprint io.streams.string math.rectangles ui.gadgets.private
+sets generic ;
 IN: ui.gadgets.tests
 
 [ { 300 300 } ]
@@ -163,13 +164,4 @@ M: mock-gadget ungraft*
 \ pref-dim must-infer
 
 \ graft* must-infer
-\ ungraft* 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 locals ;
+concurrency.flags math.order math.rectangles fry ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -191,54 +191,6 @@ GENERIC: pref-dim* ( gadget -- dim )
 
 M: gadget pref-dim* dim>> ;
 
-SYMBOL: +baseline+
-
-GENERIC: baseline ( gadget -- y )
-
-M: gadget baseline drop f ;
-
-: (max-ascent-and-descent) ( accum baseline height -- accum' )
-    over [ over - 2array vmax ] [ 2drop ] if ;
-
-: max-ascent-and-descent ( baselines heights -- ascent descent )
-    { 0 0 } [ (max-ascent-and-descent) ] 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 )
-    #! 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 -- )
 
 M: gadget layout* drop ;

basis/ui/gadgets/grids/grids.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.order namespaces make sequences words io
-math.vectors ui.gadgets columns accessors strings.tables
+math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
 math.rectangles fry ;
 IN: ui.gadgets.grids
 
@@ -36,12 +36,15 @@ PRIVATE>
 : cross-zip ( seq1 seq2 -- seq1xseq2 )
     [ [ 2array ] with map ] curry map ;
 
-TUPLE: cell pref-dim baseline ;
+TUPLE: cell pref-dim baseline cap-height ;
 
-: <cell> ( gadget -- cell ) [ pref-dim ] [ baseline ] bi cell boa ;
+: <cell> ( gadget -- cell )
+    [ pref-dim ] [ baseline ] [ cap-height ] tri cell boa ;
 
 M: cell baseline baseline>> ;
 
+M: cell cap-height cap-height>> ;
+
 TUPLE: grid-layout grid gap fill? row-heights column-widths ;
 
 : iterate-cell-dims ( cells quot -- seq )
@@ -50,7 +53,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-height ] map ]
+    [ [ dup [ pref-dim>> ] map measure-height ] map ]
     if ;
 
 : column-widths ( grid-layout -- widths )
@@ -90,7 +93,7 @@ M: grid pref-dim* <grid-layout> grid-pref-dim ;
     bi cross-zip flip ;
 
 : adjust-for-baseline ( row-locs row-cells -- row-locs' )
-    baseline-align [ 0 swap 2array v+ ] 2map ;
+    align-baselines [ 0 swap 2array v+ ] 2map ;
 
 : cell-locs ( grid-layout -- locs )
     dup fill?>>

basis/ui/gadgets/labels/labels.factor

@@ -3,7 +3,8 @@
 USING: accessors arrays hashtables io kernel math math.functions
 namespaces make opengl sequences strings splitting ui.gadgets
 ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
-ui.text colors colors.constants models combinators ;
+ui.baseline-alignment ui.text colors colors.constants models
+combinators ;
 IN: ui.gadgets.labels
 
 ! A label gadget draws a string.
@@ -51,9 +52,18 @@ M: label (>>string) ( string label -- )
 M: label pref-dim*
     >label< text-dim ;
 
+<PRIVATE
+
+: label-metrics ( label -- metrics )
+    >label< dup string? [ first ] unless line-metrics ;
+
+PRIVATE>
+
 M: label baseline
-    >label< dup string? [ first ] unless
+    label-metrics ascent>> round ;
-    line-metrics ascent>> round ;
+
+M: label cap-height
+    label-metrics cap-height>> round ;
 
 M: label draw-gadget*
     >label<

basis/ui/gadgets/line-support/line-support.factor

@@ -82,4 +82,4 @@ M: line-gadget pref-viewport-dim
     2bi 2array ;
 
 : visible-lines ( gadget -- n )
-    [ visible-dim second ] [ line-height ] bi /i 1- ;
+    [ visible-dim second ] [ line-height ] bi /i ;

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

@@ -1,5 +1,6 @@
 USING: ui.gadgets help.markup help.syntax generic kernel
-classes.tuple quotations ui.gadgets.packs.private ;
+classes.tuple quotations ui.gadgets.packs.private
+ui.baseline-alignment ;
 IN: ui.gadgets.packs
 
 ARTICLE: "ui-pack-layout" "Pack layouts"

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

@@ -1,6 +1,7 @@
-USING: ui.gadgets.packs ui.gadgets.packs.private ui.gadgets.labels
+USING: ui.gadgets.packs ui.gadgets.packs.private
-ui.gadgets ui.gadgets.debug ui.render kernel namespaces tools.test
+ui.gadgets.labels ui.gadgets ui.gadgets.debug ui.render
-math.parser sequences math.rectangles accessors ;
+ui.baseline-alignment kernel namespaces tools.test math.parser
+sequences math.rectangles accessors ;
 IN: ui.gadgets.packs.tests
 
 [ t ] [

basis/ui/gadgets/packs/packs.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets kernel math math.functions
+USING: sequences ui.gadgets ui.baseline-alignment kernel math
-math.vectors math.order math.rectangles namespaces accessors
+math.functions math.vectors math.order math.rectangles namespaces
-fry combinators arrays ;
+accessors fry combinators arrays ;
 IN: ui.gadgets.packs
 
 TUPLE: pack < gadget
@@ -26,7 +26,7 @@ TUPLE: pack < gadget
     [ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- [ * >integer ] with map ] map ;
 
 : baseline-aligned-locs ( pack -- seq )
-    children>> baseline-align [ 0 swap 2array ] map ;
+    children>> align-baselines [ 0 swap 2array ] map ;
 
 : aligned-locs ( sizes pack -- seq )
     dup align>> +baseline+ eq?
@@ -66,7 +66,7 @@ PRIVATE>
 
 : max-pack-dim ( pack sizes -- dim )
     over align>> +baseline+ eq?
-    [ [ children>> ] dip baseline-height 0 swap 2array ] [ nip max-dim ] if ;
+    [ [ children>> ] dip measure-height 0 swap 2array ] [ nip max-dim ] if ;
 
 : pack-pref-dim ( pack sizes -- dim )
     [ max-pack-dim ]
@@ -78,10 +78,13 @@ M: pack pref-dim*
     dup children>> pref-dims pack-pref-dim ;
 
 : vertical-baseline ( pack -- y )
-    children>> [ 0 ] [ first baseline ] if-empty ;
+    children>> [ f ] [ first baseline ] if-empty ;
 
 : horizontal-baseline ( pack -- y )
-    children>> dup pref-dims baseline-metrics drop ;
+    children>> dup pref-dims measure-metrics drop ;
+
+: pack-cap-height ( pack -- n )
+    children>> [ f ] [ first cap-height ] if-empty ;
 
 PRIVATE>
 
@@ -91,6 +94,8 @@ M: pack baseline
         { horizontal [ horizontal-baseline ] }
     } case ;
 
+M: pack cap-height pack-cap-height ;
+
 M: pack layout*
     dup children>> pref-dims pack-layout ;
 

basis/ui/gadgets/panes/panes.factor

@@ -9,7 +9,8 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
 ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
 ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
-ui.gadgets.icons ui.gadgets.grid-lines colors call io.styles ;
+ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
+colors call io.styles ;
 IN: ui.gadgets.panes
 
 TUPLE: pane < pack

basis/ui/gadgets/paragraphs/paragraphs.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math math.order sequences wrap wrap.words
-arrays fry ui.gadgets ui.gadgets.labels ui.render ;
+arrays fry ui.gadgets ui.gadgets.labels ui.gadgets.packs.private
+ui.render ui.baseline-alignment ;
 IN: ui.gadgets.paragraphs
 
 MIXIN: word-break
@@ -32,7 +33,7 @@ TUPLE: paragraph < gadget margin ;
 TUPLE: line words height ;
 
 : <line> ( words -- line )
-    dup [ key>> ] map dup pref-dims baseline-height line boa ;
+    dup [ key>> ] map dup pref-dims measure-height line boa ;
 
 : wrap-paragraph ( paragraph -- wrapped-paragraph )
     [ children>> [ gadget>word ] map ] [ margin>> ] bi
@@ -64,7 +65,7 @@ M: paragraph pref-dim*
         words>>
         [ ]
         [ word-x-coordinates ]
-        [ [ key>> ] map baseline-align ] tri
+        [ [ key>> ] map align-baselines ] tri
     ] dip '[ _ + layout-word ] 3each ;
 
 M: paragraph layout*
@@ -76,7 +77,9 @@ M: paragraph baseline
         first words>>
         [ key>> ] map
         dup [ pref-dim ] map
-        baseline-metrics drop
+        measure-metrics drop
     ] if-empty ;
 
+M: paragraph cap-height pack-cap-height ;
+    
 PRIVATE>

basis/ui/gadgets/search-tables/search-tables.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel delegate fry sequences models models.search
+USING: accessors kernel delegate fry sequences models
-models.delay calendar locals ui.pens ui.pens.image ui.gadgets.editors
+models.search models.delay calendar locals ui.pens ui.pens.image
-ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.tables
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.tracks ui.gadgets.borders ui.gadgets.buttons ui.gadgets ;
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.buttons ui.baseline-alignment ui.gadgets ;
 IN: ui.gadgets.search-tables
 
 TUPLE: search-field < track field ;

basis/ui/gadgets/tables/tables.factor

@@ -306,7 +306,7 @@ PRIVATE>
     dup control-value length 1- select-row ;
 
 : prev/next-page ( table n -- )
-    over visible-lines * prev/next-row ;
+    over visible-lines 1- * prev/next-row ;
 
 : previous-page ( table -- )
     -1 prev/next-page ;

basis/ui/gadgets/wrappers/wrappers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.gadgets kernel ;
+USING: accessors kernel ui.gadgets ui.baseline-alignment ;
 IN: ui.gadgets.wrappers
 
 TUPLE: wrapper < gadget ;
@@ -14,6 +14,8 @@ M: wrapper pref-dim* gadget-child pref-dim ;
 
 M: wrapper baseline gadget-child baseline ;
 
+M: wrapper cap-height gadget-child cap-height ;
+
 M: wrapper layout* [ gadget-child ] [ dim>> ] bi >>dim drop ;
 
 M: wrapper focusable-child* gadget-child ;

basis/ui/tools/profiler/profiler.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel quotations accessors fry
+USING: kernel quotations accessors fry assocs present math.order
-assocs present math.order math.vectors arrays locals
+math.vectors arrays locals models.search models.sort models
-models.search models.sort models sequences vocabs
+sequences vocabs tools.profiler words prettyprint ui ui.commands
-tools.profiler words prettyprint ui ui.commands ui.gadgets
+ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons
-ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
+ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
-ui.gadgets.labeled ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
-ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.status-bar
+ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
-ui.gadgets.borders ui.tools.browser ui.tools.common ;
+ui.tools.browser ui.tools.common ui.baseline-alignment ;
 FROM: models.filter => <filter> ;
 FROM: models.compose => <compose> ;
 IN: ui.tools.profiler