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 check-ole32-error ] with-out-parameters ;
25 : x>line-offset ( x script-string -- n trailing )
28 { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters ;
32 : make-ssa ( dc script-string -- ssa )
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 [ check-ole32-error ] [ |ScriptStringFree void* deref ] 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 ( ssa size script-string -- )
62 [ [ { 0 0 } ] dip <RECT> ]
63 [ selection-start/end ] tri*
67 ScriptStringOut check-ole32-error ;
69 :: render-image ( dc ssa script-string -- image )
70 script-string size>> :> size
72 [ ssa size script-string draw-script-string ] make-bitmap-image ;
74 : set-dc-font ( dc font -- )
75 cache-font SelectObject win32-error=0/f ;
77 : ssa-size ( ssa -- dim )
80 [ cx>> ] [ cy>> ] bi 2array ;
82 : dc-metrics ( dc -- metrics )
84 [ GetTextMetrics drop ] keep
87 ! DC limit is default soft-limited to 10,000 per process.
88 : <script-string> ( font string -- script-string )
89 [ script-string new-disposable ] 2dip
90 [ >>font ] [ >>string ] bi*
93 [ over font>> set-dc-font ]
94 [ dc-metrics >>metrics ]
95 [ over string>> make-ssa [ >>ssa ] [ ssa-size >>size ] bi ]
101 M: script-string dispose*
102 ssa>> void* <ref> ScriptStringFree check-ole32-error ;
104 SYMBOL: cached-script-strings
106 : cached-script-string ( font string -- script-string )
107 cached-script-strings get-global [ <script-string> ] 2cache ;
109 : script-string>image ( script-string -- image )
113 [ over font>> [ set-dc-font ] [ set-dc-colors ] 2bi ]
115 dup pick string>> make-ssa
116 dup void* <ref> &ScriptStringFree drop
117 pick render-image >>image
123 [ <cache-assoc> &dispose cached-script-strings set-global ]
124 "windows.uniscribe" add-startup-hook