More progress on Uniscribe

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

diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
new file mode 100755 (executable)
index 0000000..b9fb48d
--- /dev/null
+++ b/basis/windows/fonts/fonts.factor
@@ -0,0 +1,37 @@
+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