From 0c4c0410ef1189d4c0a94c4e5516b2c65a2ad643 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Feb 2009 02:13:16 -0600
Subject: [PATCH] Add x-height and cap-height metrics

---
 basis/core-text/core-text.factor   | 22 +++++++++++++++++-----
 basis/core-text/fonts/fonts.factor | 17 ++++++++++++-----
 basis/fonts/fonts.factor           |  6 +++---
 3 files changed, 32 insertions(+), 13 deletions(-)

diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor
index 81bd1c9973..39d298476d 100644
--- 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 87b8c95a15..9bf448e7b0 100644
--- 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 34c8cf63e2..aa689d194f 100644
--- 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 ;