Fixes #2966

[factor.git] / basis / windows / fonts / fonts.factor

diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
old mode 100755 (executable)
new mode 100644 (file)
index b9fb48d..8b09cd2
--- a/basis/windows/fonts/fonts.factor
+++ b/basis/windows/fonts/fonts.factor
@@ -1,37 +1,52 @@
-USING: assocs memoize locals kernel accessors init fonts\r
-combinators windows windows.types windows.gdi32 ;\r
-IN: windows.fonts\r
-\r
-: windows-font-name ( string -- string' )\r
-    H{\r
-        { "sans-serif" "Tahoma" }\r
-        { "serif" "Times New Roman" }\r
-        { "monospace" "Courier New" }\r
-    } at-default ;\r
-    \r
-MEMO:: (cache-font) ( font -- HFONT )\r
-    font size>> ! nHeight\r
-    0 0 0 ! nWidth, nEscapement, nOrientation\r
-    font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight\r
-    font italic?>> TRUE FALSE ? ! fdwItalic\r
-    FALSE ! fdwUnderline\r
-    FALSE ! fdWStrikeOut\r
-    DEFAULT_CHARSET ! fdwCharSet\r
-    OUT_OUTLINE_PRECIS ! fdwOutputPrecision\r
-    CLIP_DEFAULT_PRECIS ! fdwClipPrecision\r
-    DEFAULT_QUALITY ! fdwQuality\r
-    DEFAULT_PITCH ! fdwPitchAndFamily\r
-    font name>> windows-font-name\r
-    CreateFont\r
-    dup win32-error=0/f ;\r
-\r
-: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;\r
-\r
-[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook\r
-\r
-: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )\r
-    [ metrics new 0 >>width ] dip {\r
-        [ TEXTMETRICW-tmHeight >>height ]\r
-        [ TEXTMETRICW-tmAscent >>ascent ]\r
-        [ TEXTMETRICW-tmDescent >>descent ]\r
-    } cleave ;\r
+USING: assocs memoize locals kernel accessors init fonts math
+combinators system-info.windows windows.errors windows.types
+windows.gdi32 ;
+IN: windows.fonts
+
+MEMO: windows-fonts ( -- fonts )
+    windows-major 6 >=
+    H{
+        { "sans-serif" "Segoe UI" }
+        { "serif" "Cambria" }
+        { "monospace" "Consolas" }
+    }
+    H{
+        { "sans-serif" "Tahoma" }
+        { "serif" "Times New Roman" }
+        { "monospace" "Courier New" }
+    } ? ;
+
+: windows-font-name ( string -- string' )
+    windows-fonts ?at drop ;
+
+MEMO:: (cache-font) ( name size bold? italic? -- HFONT )
+    size neg ! nHeight
+    0 0 0 ! nWidth, nEscapement, nOrientation
+    bold? FW_BOLD FW_NORMAL ? ! fnWeight
+    italic? TRUE FALSE ? ! fdwItalic
+    FALSE ! fdwUnderline
+    FALSE ! fdWStrikeOut
+    DEFAULT_CHARSET ! fdwCharSet
+    OUT_OUTLINE_PRECIS ! fdwOutputPrecision
+    CLIP_DEFAULT_PRECIS ! fdwClipPrecision
+    DEFAULT_QUALITY ! fdwQuality
+    DEFAULT_PITCH ! fdwPitchAndFamily
+    name windows-font-name
+    CreateFont
+    dup win32-error=0/f ;
+
+: cache-font ( font -- HFONT )
+    { [ name>> ] [ size>> ] [ bold?>> ] [ italic?>> ] } cleave
+    (cache-font) ;
+
+STARTUP-HOOK: [
+    \ (cache-font) reset-memoized
+    \ windows-fonts reset-memoized
+]
+
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
+    [ metrics new 0 >>width ] dip {
+        [ tmHeight>> >>height ]
+        [ tmAscent>> >>ascent ]
+        [ tmDescent>> >>descent ]
+    } cleave ;