basis/windows/uniscribe/uniscribe.factor

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