basis/windows/fonts/fonts.factor

   1 USING: assocs memoize locals kernel accessors init fonts math
   2 combinators system-info.windows windows.errors windows.types
   3 windows.gdi32 ;
   4 IN: windows.fonts
   5
   6 MEMO: windows-fonts ( -- fonts )
   7     windows-major 6 >=
   8     H{
   9         { "sans-serif" "Segoe UI" }
  10         { "serif" "Cambria" }
  11         { "monospace" "Consolas" }
  12     }
  13     H{
  14         { "sans-serif" "Tahoma" }
  15         { "serif" "Times New Roman" }
  16         { "monospace" "Courier New" }
  17     } ? ;
  18
  19 : windows-font-name ( string -- string' )
  20     windows-fonts ?at drop ;
  21
  22 MEMO:: (cache-font) ( font -- HFONT )
  23     font size>> neg ! nHeight
  24     0 0 0 ! nWidth, nEscapement, nOrientation
  25     font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
  26     font italic?>> TRUE FALSE ? ! fdwItalic
  27     FALSE ! fdwUnderline
  28     FALSE ! fdWStrikeOut
  29     DEFAULT_CHARSET ! fdwCharSet
  30     OUT_OUTLINE_PRECIS ! fdwOutputPrecision
  31     CLIP_DEFAULT_PRECIS ! fdwClipPrecision
  32     DEFAULT_QUALITY ! fdwQuality
  33     DEFAULT_PITCH ! fdwPitchAndFamily
  34     font name>> windows-font-name
  35     CreateFont
  36     dup win32-error=0/f ;
  37
  38 : cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
  39
  40 [ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
  41
  42 : TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
  43     [ metrics new 0 >>width ] dip {
  44         [ tmHeight>> >>height ]
  45         [ tmAscent>> >>ascent ]
  46         [ tmDescent>> >>descent ]
  47     } cleave ;