Add x-height and cap-height metrics

diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor
index 81bd1c9973499e024a073fb19b469a656b69e386..39d298476ddcd1cb9036c1c8f83812de1abddfad 100644 (file)
--- a/basis/core-text/core-text.factor
+++ b/basis/core-text/core-text.factor
@@ -48,14 +48,26 @@ ERROR: not-a-string object ;
 
 TUPLE: line font line metrics image disposed ;
 
-: compute-line-metrics ( line -- line-metrics )
+: compute-line-metrics ( open-font line -- line-metrics )
+    [
+        [ metrics new ] dip
+        [ CTFontGetCapHeight >>cap-height ]
+        [ CTFontGetXHeight >>x-height ]
+        bi
+    ] dip
     0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
-    [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@
-    <metrics> ;
+    [ CTLineGetTypographicBounds ] 3keep
+    {
+        [ >>width ]
+        [ *CGFloat >>ascent ]
+        [ *CGFloat >>descent ]
+        [ *CGFloat >>leading ]
+    } spread
+    dup compute-height ;
 
 : bounds>dim ( bounds -- dim )
     [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
-    [ ceiling >fixnum ]
+    [ ceiling >integer ]
     bi@ 2array ;
 
 : fill-background ( context font dim -- )
@@ -81,7 +93,7 @@ TUPLE: line font line metrics image disposed ;
     [
         [let* | open-font [ font cache-font CFRetain |CFRelease ]
                 line [ string open-font font foreground>> <CTLine> |CFRelease ]
-                metrics [ line compute-line-metrics ]
+                metrics [ open-font line compute-line-metrics ]
                 dim [ metrics bounds>dim ] |
             open-font line metrics
             dim [

diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor
index 87b8c95a15c64d278b6ebe3908aaf79996f89f48..9bf448e7b069eed593520fb74b868341015f1291 100644 (file)
--- a/basis/core-text/fonts/fonts.factor
+++ b/basis/core-text/fonts/fonts.factor
@@ -70,6 +70,10 @@ FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font ) ;
 
 FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font ) ;
 
+FUNCTION: CGFloat CTFontGetCapHeight ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetXHeight ( CTFontRef font ) ;
+
 CONSTANT: font-names
     H{
         { "monospace" "Monaco" }
@@ -106,12 +110,15 @@ MEMO: (cache-font) ( font -- open-font )
     strip-font-colors (cache-font) ;
 
 MEMO: (cache-font-metrics) ( font -- metrics )
+    [ metrics new ] dip
     (cache-font) {
-        [ drop 0 ]
-        [ CTFontGetAscent ]
-        [ CTFontGetDescent ]
-        [ CTFontGetLeading ]
-    } cleave <metrics> ;
+        [ CTFontGetAscent >>ascent ]
+        [ CTFontGetDescent >>descent ]
+        [ CTFontGetLeading >>leading ]
+        [ CTFontGetCapHeight >>cap-height ]
+        [ CTFontGetXHeight >>x-height ]
+    } cleave
+    dup compute-height ;
 
 : cache-font-metrics ( font -- metrics )
     strip-font-colors (cache-font-metrics) ;

diff --git a/basis/fonts/fonts.factor b/basis/fonts/fonts.factor
index 34c8cf63e2ce6e14273dcdf90ec53b8d492c2abd..aa689d194fdc39b36c40ba0a8647d946ab9acd32 100644 (file)
--- a/basis/fonts/fonts.factor
+++ b/basis/fonts/fonts.factor
@@ -58,10 +58,10 @@ italic?
 : strip-font-colors ( font -- font' )
     clone f >>background f >>foreground ;
 
-TUPLE: metrics width ascent descent height leading ;
+TUPLE: metrics width ascent descent height leading cap-height x-height ;
 
-: <metrics> ( width ascent descent leading -- metrics )
-    [ 2dup + ] dip metrics boa ;
+: compute-height ( metrics -- )
+    dup [ ascent>> ] [ descent>> ] bi + >>height drop ;
 
 TUPLE: selection string start end color ;