! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math sequences fry io.encodings.string
io.encodings.utf16n accessors arrays combinators destructors
-cache namespaces init fonts alien.c-types windows.usp10
-windows.offscreen windows.gdi32 windows.ole32 windows.types
-windows.fonts opengl.textures locals windows.errors ;
+cache namespaces init fonts alien.c-types alien.data
+windows.usp10 windows.offscreen windows.gdi32 windows.ole32
+windows.types windows.fonts opengl.textures locals
+windows.errors classes.struct ;
IN: windows.uniscribe
-TUPLE: script-string font string metrics ssa size image disposed ;
+TUPLE: script-string < disposable font string metrics ssa size image ;
: line-offset>x ( n script-string -- x )
2dup string>> length = [
ssa>> ! ssa
- swap 1- ! icp
+ swap 1 - ! icp
TRUE ! fTrailing
] [
ssa>>
swap ! icp
FALSE ! fTrailing
] if
- 0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+ { int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
: x>line-offset ( x script-string -- n trailing )
ssa>> ! ssa
swap ! iX
- 0 <int> ! pCh
- 0 <int> ! piTrailing
- [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
+ { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters ;
<PRIVATE
-: make-script-string ( dc string -- script-string )
+: make-ssa ( dc script-string -- ssa )
dup selection? [ string>> ] when
[ utf16n encode ] ! pString
[ length ] bi ! cString
f ! piDx
f ! pTabdef
f ! pbInClass
- f <void*> ! pssa
+ f void* <ref> ! pssa
[ ScriptStringAnalyse ] keep
- [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+ [ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
: set-dc-colors ( dc font -- )
[ background>> color>RGB SetBkColor drop ]
: selection-start/end ( script-string -- iMinSel iMaxSel )
string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
-: (draw-script-string) ( script-string -- )
+: draw-script-string ( ssa size script-string -- )
[
- ssa>> ! ssa
0 ! iX
0 ! iY
ETO_OPAQUE ! uOptions
]
- [ [ { 0 0 } ] dip size>> <RECT> ]
- [ selection-start/end ] tri
+ [ [ { 0 0 } ] dip <RECT> ]
+ [ selection-start/end ] tri*
! iMinSel
! iMaxSel
FALSE ! fDisabled
- ScriptStringOut ole32-error ;
-
-: draw-script-string ( dc script-string -- )
- [ font>> set-dc-colors ] keep (draw-script-string) ;
+ ScriptStringOut check-ole32-error ;
-:: make-script-string-image ( dc script-string -- image )
- script-string size>> dc
- [ dc script-string draw-script-string ] make-bitmap-image ;
+:: render-image ( dc ssa script-string -- image )
+ script-string size>> :> size
+ size dc
+ [ ssa size script-string draw-script-string ] make-bitmap-image ;
: set-dc-font ( dc font -- )
cache-font SelectObject win32-error=0/f ;
-: script-string-size ( script-string -- dim )
- ssa>> ScriptString_pSize
+: ssa-size ( ssa -- dim )
+ ScriptString_pSize
dup win32-error=0/f
- [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
+ [ cx>> ] [ cy>> ] bi 2array ;
: dc-metrics ( dc -- metrics )
- "TEXTMETRICW" <c-object>
+ TEXTMETRICW <struct>
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
+! DC limit is default soft-limited to 10,000 per process.
: <script-string> ( font string -- script-string )
- [ script-string new ] 2dip
+ [ script-string new-disposable ] 2dip
[ >>font ] [ >>string ] bi*
[
{
[ over font>> set-dc-font ]
[ dc-metrics >>metrics ]
- [ over string>> make-script-string >>ssa ]
- [ drop dup script-string-size >>size ]
- [ over make-script-string-image >>image ]
+ [ over string>> make-ssa [ >>ssa ] [ ssa-size >>size ] bi ]
} cleave
] with-memory-dc ;
PRIVATE>
M: script-string dispose*
- ssa>> <void*> ScriptStringFree ole32-error ;
+ ssa>> void* <ref> ScriptStringFree check-ole32-error ;
SYMBOL: cached-script-strings
: cached-script-string ( font string -- script-string )
cached-script-strings get-global [ <script-string> ] 2cache ;
-[ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-init-hook
+: script-string>image ( script-string -- image )
+ dup image>> [
+ [
+ {
+ [ over font>> [ set-dc-font ] [ set-dc-colors ] 2bi ]
+ [
+ dup pick string>> make-ssa
+ dup void* <ref> &ScriptStringFree drop
+ pick render-image >>image
+ ]
+ } cleave
+ ] with-memory-dc
+ ] unless image>> ;
+
+[ <cache-assoc> &dispose cached-script-strings set-global ]
+"windows.uniscribe" add-startup-hook