basis/windows/uniscribe/uniscribe.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data arrays assocs cache
   4 classes.struct colors colors.constants combinators destructors
   5 fonts images init io.encodings.string io.encodings.utf16n kernel
   6 literals locals math namespaces sequences windows.errors
   7 windows.fonts windows.gdi32 windows.offscreen windows.ole32
   8 windows.types windows.usp10 ;
   9 IN: windows.uniscribe
  10
  11 TUPLE: script-string < disposable font string metrics ssa size image ;
  12
  13 : line-offset>x ( n script-string -- x )
  14     2dup string>> length = [
  15         ssa>> ! ssa
  16         swap 1 - ! icp
  17         TRUE ! fTrailing
  18     ] [
  19         ssa>>
  20         swap ! icp
  21         FALSE ! fTrailing
  22     ] if
  23     { int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
  24
  25 : x>line-offset ( x script-string -- n trailing )
  26     ssa>> ! ssa
  27     swap ! iX
  28     { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters ;
  29
  30 <PRIVATE
  31
  32 CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
  33
  34 : make-ssa ( dc script-string -- ssa )
  35     dup selection? [ string>> ] when
  36     [ utf16n encode ] ! pString
  37     [ length ] bi ! cString
  38     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
  39     -1 ! iCharset -- Unicode
  40     ssa-dwFlags
  41     0 ! iReqWidth
  42     f ! psControl
  43     f ! psState
  44     f ! piDx
  45     f ! pTabdef
  46     f ! pbInClass
  47     f void* <ref> ! pssa
  48     [ ScriptStringAnalyse ] keep
  49     [ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
  50
  51 : set-dc-colors ( dc font -- )
  52     dup background>> >rgba alpha>> 1 number= [
  53         ! No transparency needed, set colors from the font.
  54         [ background>> color>RGB SetBkColor drop ]
  55         [ foreground>> color>RGB SetTextColor drop ] 2bi
  56     ] [
  57         ! Draw white text on black background. The resulting grayscale
  58         ! image will be used as transparency mask for the actual color.
  59         drop
  60         [ COLOR: black color>RGB SetBkColor drop ]
  61         [ COLOR: white color>RGB SetTextColor drop ] bi
  62     ] if ;
  63
  64 : selection-start/end ( script-string -- iMinSel iMaxSel )
  65     string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
  66
  67 : draw-script-string ( ssa size script-string -- )
  68     [
  69         0 ! iX
  70         0 ! iY
  71         ETO_OPAQUE ! uOptions
  72     ]
  73     [ [ { 0 0 } ] dip <RECT> ]
  74     [ selection-start/end ] tri*
  75     ! iMinSel
  76     ! iMaxSel
  77     FALSE ! fDisabled
  78     ScriptStringOut check-ole32-error ;
  79
  80 ! The image is a grayscale rendering of a text string. We want the text to
  81 ! have the given color. Move the blue channel of the image (any color
  82 ! channel will do, since it's grayscale) into its alpha channel, and make
  83 ! the entire image a rectangle of the given color with varying
  84 ! transparency.
  85 :: color-to-alpha ( image color -- image' )
  86     image color >rgba-components drop [ 255 * >integer ] tri@ 3array [
  87         swap first suffix -rot image set-pixel-at
  88     ] curry each-pixel image RGBA >>component-order ;
  89
  90 :: render-image ( dc ssa script-string -- image )
  91     script-string size>> :> size
  92     size dc
  93     [ ssa size script-string draw-script-string ] make-bitmap-image
  94     script-string font>> [ foreground>> ] [ background>> ] bi
  95     >rgba alpha>> 1 number= [ drop ] [ color-to-alpha ] if ;
  96
  97 : set-dc-font ( dc font -- )
  98     cache-font SelectObject win32-error=0/f ;
  99
 100 : ssa-size ( ssa -- dim )
 101     ScriptString_pSize
 102     dup win32-error=0/f
 103     [ cx>> ] [ cy>> ] bi 2array ;
 104
 105 : dc-metrics ( dc -- metrics )
 106     TEXTMETRICW <struct>
 107     [ GetTextMetrics drop ] keep
 108     TEXTMETRIC>metrics ;
 109
 110 ! DC limit is default soft-limited to 10,000 per process.
 111 : <script-string> ( font string -- script-string )
 112     [ script-string new-disposable ] 2dip
 113         [ >>font ] [ >>string ] bi*
 114     [
 115         {
 116             [ over font>> set-dc-font ]
 117             [ dc-metrics >>metrics ]
 118             [ over string>> make-ssa [ >>ssa ] [ ssa-size >>size ] bi ]
 119         } cleave
 120     ] with-memory-dc ;
 121
 122 PRIVATE>
 123
 124 M: script-string dispose*
 125     ssa>> void* <ref> ScriptStringFree check-ole32-error ;
 126
 127 SYMBOL: cached-script-strings
 128
 129 : cached-script-string ( font string -- script-string )
 130     cached-script-strings get-global [ <script-string> ] 2cache ;
 131
 132 : script-string>image ( script-string -- image )
 133     dup image>> [
 134         [
 135             {
 136                 [ over font>> [ set-dc-font ] [ set-dc-colors ] 2bi ]
 137                 [
 138                     dup pick string>> make-ssa
 139                     dup void* <ref> &ScriptStringFree drop
 140                     pick render-image >>image
 141                 ]
 142             } cleave
 143         ] with-memory-dc
 144     ] unless image>> ;
 145
 146 [ <cache-assoc> &dispose cached-script-strings set-global ]
 147 "windows.uniscribe" add-startup-hook