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