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 locals
5 cache namespaces init images.normalization fonts alien.c-types
6 windows windows.usp10 windows.offscreen windows.gdi32
7 windows.ole32 windows.types windows.fonts opengl.textures ;
10 TUPLE: script-string font string metrics ssa size image disposed ;
12 : line-offset>x ( n script-string -- x )
13 2dup string>> length = [
22 0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
24 : x>line-offset ( x script-string -- n trailing )
29 [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
33 : make-script-string ( dc string -- script-string )
34 dup selection? [ string>> ] when
35 [ utf16n encode ] ! pString
36 [ length ] bi ! cString
37 dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
38 -1 ! iCharset -- Unicode
47 [ ScriptStringAnalyse ] keep
48 [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
50 : set-dc-colors ( dc font -- )
51 [ background>> color>RGB SetBkColor drop ]
52 [ foreground>> color>RGB SetTextColor drop ] 2bi ;
54 : selection-start/end ( script-string -- iMinSel iMaxSel )
55 string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
57 : (draw-script-string) ( script-string -- )
65 [ selection-start/end ] bi
69 ScriptStringOut ole32-error ;
71 : draw-script-string ( dc script-string -- )
72 [ font>> set-dc-colors ] keep (draw-script-string) ;
74 : script-string-bitmap-size ( script-string -- dim )
75 size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
77 :: make-script-string-image ( dc script-string -- image )
78 script-string script-string-bitmap-size dc
79 [ dc script-string draw-script-string ] make-bitmap-image ;
81 : set-dc-font ( dc font -- )
82 cache-font SelectObject win32-error=0/f ;
84 : script-string-size ( script-string -- dim )
85 ssa>> ScriptString_pSize
87 [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
89 : dc-metrics ( dc -- metrics )
90 "TEXTMETRICW" <c-object>
91 [ GetTextMetrics drop ] keep
94 : <script-string> ( font string -- script-string )
95 [ script-string new ] 2dip
96 [ >>font ] [ >>string ] bi*
99 [ over font>> set-dc-font ]
100 [ dc-metrics >>metrics ]
101 [ over string>> make-script-string >>ssa ]
102 [ drop dup script-string-size >>size ]
103 [ over make-script-string-image >>image ]
109 M: script-string dispose*
110 ssa>> <void*> ScriptStringFree ole32-error ;
112 SYMBOL: cached-script-strings
114 : cached-script-string ( string font -- script-string )
115 cached-script-strings get-global [ <script-string> ] 2cache ;
117 [ <cache-assoc> cached-script-strings set-global ]
118 "windows.uniscribe" add-init-hook