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
13 TUPLE: script-string < disposable font string metrics ssa size image ;
17 CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
19 :: >codepoint-index ( str utf16-index -- codepoint-index )
20 0 utf16-index 2 * str utf16n encode subseq utf16n decode length ;
22 :: >utf16-index ( str codepoint-index -- utf16-index )
23 0 codepoint-index str subseq utf16n encode length 2 / >integer ;
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 = [
37 { int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
39 :: x>line-offset ( x script-string -- n trailing )
40 script-string ssa>> ! ssa
42 { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters
43 swap dup 0 < [ script-string string>> swap >codepoint-index ] unless
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
62 [ ScriptStringAnalyse ] keep
63 [ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
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
71 ! Draw white text on black background. The resulting grayscale
72 ! image will be used as transparency mask for the actual color.
74 [ COLOR: black color>RGB SetBkColor drop ]
75 [ COLOR: white color>RGB SetTextColor drop ] bi
78 : selection-start/end ( script-string -- iMinSel iMaxSel )
79 string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
81 : draw-script-string ( ssa size script-string -- )
87 [ [ { 0 0 } ] dip <RECT> ]
89 [let :> str str selection-start/end
91 str string>> dup selection? [ string>> ] when
99 ScriptStringOut check-ole32-error ;
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
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
111 [ [ 0xff bitand alpha * >integer 24 shift rgb bitor ] map! ]
112 [ [ 0xff bitand 24 shift rgb bitor ] map! ]
114 image RGBA >>component-order ;
116 :: render-image ( dc ssa script-string -- image )
117 script-string size>> :> size
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 ;
123 : set-dc-font ( dc font -- )
124 cache-font SelectObject win32-error=0/f ;
126 : ssa-size ( ssa -- dim )
129 [ cx>> ] [ cy>> ] bi 2array ;
131 : dc-metrics ( dc -- metrics )
133 [ GetTextMetrics drop ] keep
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*
142 [ over font>> set-dc-font ]
143 [ dc-metrics >>metrics ]
144 [ over string>> make-ssa [ >>ssa ] [ ssa-size >>size ] bi ]
150 M: script-string dispose*
151 ssa>> void* <ref> ScriptStringFree check-ole32-error ;
153 SYMBOL: cached-script-strings
155 : cached-script-string ( font string -- script-string )
156 cached-script-strings get-global [ <script-string> ] 2cache ;
158 : script-string>image ( script-string -- image )
162 [ over font>> [ set-dc-font ] [ set-dc-colors ] 2bi ]
164 dup pick string>> make-ssa
165 dup void* <ref> &ScriptStringFree drop
166 pick render-image >>image
172 [ <cache-assoc> &dispose cached-script-strings set-global ]
173 "windows.uniscribe" add-startup-hook