basis/windows/fonts/fonts.factor

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