basis/windows/fonts/fonts.factor

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