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