-USING: assocs memoize locals kernel accessors init fonts math\r
-combinators windows.errors 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>> neg ! 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) ;
+
+[
+ \ (cache-font) reset-memoized
+ \ windows-fonts reset-memoized
+] "windows.fonts" add-startup-hook
+
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
+ [ metrics new 0 >>width ] dip {
+ [ tmHeight>> >>height ]
+ [ tmAscent>> >>ascent ]
+ [ tmDescent>> >>descent ]
+ } cleave ;