1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel assocs math sequences fry io.encodings.string
4 io.encodings.utf16n accessors arrays combinators destructors
5 cache namespaces init fonts alien.c-types alien.data
6 windows.usp10 windows.offscreen windows.gdi32 windows.ole32
7 windows.types windows.fonts opengl.textures locals
8 windows.errors classes.struct ;
11 TUPLE: script-string < disposable font string metrics ssa size image ;
13 : line-offset>x ( n script-string -- x )
14 2dup string>> length = [
23 { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
25 : x>line-offset ( x script-string -- n trailing )
28 { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
32 : make-script-string ( dc string -- script-string )
33 dup selection? [ string>> ] when
34 [ utf16n encode ] ! pString
35 [ length ] bi ! cString
36 dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
37 -1 ! iCharset -- Unicode
46 [ ScriptStringAnalyse ] keep
47 [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
49 : set-dc-colors ( dc font -- )
50 [ background>> color>RGB SetBkColor drop ]
51 [ foreground>> color>RGB SetTextColor drop ] 2bi ;
53 : selection-start/end ( script-string -- iMinSel iMaxSel )
54 string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
56 : (draw-script-string) ( script-string -- )
63 [ [ { 0 0 } ] dip size>> <RECT> ]
64 [ selection-start/end ] tri
68 ScriptStringOut ole32-error ;
70 : draw-script-string ( dc script-string -- )
71 [ font>> set-dc-colors ] keep (draw-script-string) ;
73 :: make-script-string-image ( dc script-string -- image )
74 script-string size>> dc
75 [ dc script-string draw-script-string ] make-bitmap-image ;
77 : set-dc-font ( dc font -- )
78 cache-font SelectObject win32-error=0/f ;
80 : script-string-size ( script-string -- dim )
81 ssa>> ScriptString_pSize
83 [ cx>> ] [ cy>> ] bi 2array ;
85 : dc-metrics ( dc -- metrics )
87 [ GetTextMetrics drop ] keep
90 : <script-string> ( font string -- script-string )
91 [ script-string new-disposable ] 2dip
92 [ >>font ] [ >>string ] bi*
95 [ over font>> set-dc-font ]
96 [ dc-metrics >>metrics ]
97 [ over string>> make-script-string >>ssa ]
98 [ drop dup script-string-size >>size ]
99 [ over make-script-string-image >>image ]
105 M: script-string dispose*
106 ssa>> <void*> ScriptStringFree ole32-error ;
108 SYMBOL: cached-script-strings
110 : cached-script-string ( font string -- script-string )
111 cached-script-strings get-global [ <script-string> ] 2cache ;
113 [ <cache-assoc> &dispose cached-script-strings set-global ]
114 "windows.uniscribe" add-startup-hook