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) ( name size bold? italic? -- HFONT )
  23     size neg ! nHeight
  24     0 0 0 ! nWidth, nEscapement, nOrientation
  25     bold? FW_BOLD FW_NORMAL ? ! fnWeight
  26     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     name windows-font-name
  35     CreateFont
  36     dup win32-error=0/f ;
  37
  38 : cache-font ( font -- HFONT )
  39     { [ name>> ] [ size>> ] [ bold?>> ] [ italic?>> ] } cleave
  40     (cache-font) ;
  41
  42 [
  43     \ (cache-font) reset-memoized
  44     \ windows-fonts reset-memoized
  45 ] "windows.fonts" add-startup-hook
  46
  47 : TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
  48     [ metrics new 0 >>width ] dip {
  49         [ tmHeight>> >>height ]
  50         [ tmAscent>> >>ascent ]
  51         [ tmDescent>> >>descent ]
  52     } cleave ;