Paint selection, and create bitmap with power of 2 size as an optimizaion
U-SLAVA-DFB8FF805\Slava
parent
0dcb38d86a
commit
7f4784151c
|
|
@ -1,79 +1,13 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! 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 images.normalization alien.c-types locals
|
||||
io.encodings.utf16n accessors arrays combinators destructors locals
|
||||
cache namespaces init images.normalization fonts alien.c-types
|
||||
windows windows.usp10 windows.offscreen windows.gdi32
|
||||
windows.ole32 windows.types windows.fonts ;
|
||||
windows.ole32 windows.types windows.fonts opengl.textures ;
|
||||
IN: windows.uniscribe
|
||||
|
||||
TUPLE: script-string metrics ssa size image string disposed ;
|
||||
|
||||
: make-script-string ( dc string -- script-string )
|
||||
[ utf16n encode ] ! pString
|
||||
[ length ] bi ! cString
|
||||
dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
|
||||
-1 ! iCharset -- Unicode
|
||||
SSA_GLYPHS ! dwFlags
|
||||
0 ! iReqWidth
|
||||
f ! psControl
|
||||
f ! psState
|
||||
f ! piDx
|
||||
f ! pTabdef
|
||||
f ! pbInClass
|
||||
f <void*> ! pssa
|
||||
[ ScriptStringAnalyse ] keep
|
||||
[ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
|
||||
|
||||
: draw-script-string ( script-string -- )
|
||||
! ssa
|
||||
0 ! iX
|
||||
0 ! iY
|
||||
0 ! uOptions
|
||||
f ! prc
|
||||
0 ! iMinSel
|
||||
0 ! iMaxSel
|
||||
FALSE ! fDisabled
|
||||
ScriptStringOut ole32-error ;
|
||||
|
||||
: set-dc-font ( dc font -- )
|
||||
[ cache-font SelectObject win32-error=0/f ]
|
||||
[ background>> color>RGB SetBkColor drop ]
|
||||
[ foreground>> color>RGB SetTextColor drop ] 2tri ;
|
||||
|
||||
: script-string-size ( ssa -- dim )
|
||||
ScriptString_pSize
|
||||
dup win32-error=0/f
|
||||
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
|
||||
|
||||
: dc-metrics ( dc -- metrics )
|
||||
"TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
|
||||
TEXTMETRIC>metrics ;
|
||||
|
||||
:: <script-string> ( font string -- script-string )
|
||||
#! Comments annotate BOA constructor arguments
|
||||
[| dc |
|
||||
dc font set-dc-font
|
||||
dc dc-metrics ! metrics
|
||||
dc string make-script-string dup :> ssa ! ssa
|
||||
dup script-string-size ! size
|
||||
dup dc [ ssa draw-script-string ] make-bitmap-image
|
||||
normalize-image ! image
|
||||
string ! string
|
||||
f script-string boa
|
||||
] with-memory-dc ;
|
||||
|
||||
: text-position ( script-string -- loc ) drop { 0 0 } ;
|
||||
|
||||
M: script-string dispose* ssa>> <void*> ScriptStringFree ole32-error ;
|
||||
|
||||
SYMBOL: cached-script-strings
|
||||
|
||||
: cached-script-string ( string font -- script-string )
|
||||
cached-script-strings get-global [ <script-string> ] 2cache ;
|
||||
|
||||
[ <cache-assoc> cached-script-strings set-global ]
|
||||
"windows.uniscribe" add-init-hook
|
||||
TUPLE: script-string font string metrics ssa size image disposed ;
|
||||
|
||||
: line-offset>x ( n script-string -- x )
|
||||
2dup string>> length = [
|
||||
|
|
@ -92,4 +26,93 @@ SYMBOL: cached-script-strings
|
|||
swap ! iX
|
||||
0 <int> ! pCh
|
||||
0 <int> ! piTrailing
|
||||
[ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
|
||||
[ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: make-script-string ( dc string -- script-string )
|
||||
dup selection? [ string>> ] when
|
||||
[ utf16n encode ] ! pString
|
||||
[ length ] bi ! cString
|
||||
dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
|
||||
-1 ! iCharset -- Unicode
|
||||
SSA_GLYPHS ! dwFlags
|
||||
0 ! iReqWidth
|
||||
f ! psControl
|
||||
f ! psState
|
||||
f ! piDx
|
||||
f ! pTabdef
|
||||
f ! pbInClass
|
||||
f <void*> ! pssa
|
||||
[ ScriptStringAnalyse ] keep
|
||||
[ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
|
||||
|
||||
: set-dc-colors ( dc font -- )
|
||||
[ background>> color>RGB SetBkColor drop ]
|
||||
[ foreground>> color>RGB SetTextColor drop ] 2bi ;
|
||||
|
||||
: selection-start/end ( script-string -- iMinSel iMaxSel )
|
||||
string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
|
||||
|
||||
: (draw-script-string) ( script-string -- )
|
||||
[
|
||||
ssa>> ! ssa
|
||||
0 ! iX
|
||||
0 ! iY
|
||||
0 ! uOptions
|
||||
f ! prc
|
||||
]
|
||||
[ selection-start/end ] bi
|
||||
! iMinSel
|
||||
! iMaxSel
|
||||
FALSE ! fDisabled
|
||||
ScriptStringOut ole32-error ;
|
||||
|
||||
: draw-script-string ( dc script-string -- )
|
||||
[ font>> set-dc-colors ] keep (draw-script-string) ;
|
||||
|
||||
: script-string-bitmap-size ( script-string -- dim )
|
||||
size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
|
||||
|
||||
:: make-script-string-image ( dc script-string -- image )
|
||||
script-string script-string-bitmap-size dc
|
||||
[ dc 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
|
||||
dup win32-error=0/f
|
||||
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
|
||||
|
||||
: dc-metrics ( dc -- metrics )
|
||||
"TEXTMETRICW" <c-object>
|
||||
[ GetTextMetrics drop ] keep
|
||||
TEXTMETRIC>metrics ;
|
||||
|
||||
: <script-string> ( font string -- script-string )
|
||||
[ script-string new ] 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 ]
|
||||
} cleave
|
||||
] with-memory-dc ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: script-string dispose*
|
||||
ssa>> <void*> ScriptStringFree ole32-error ;
|
||||
|
||||
SYMBOL: cached-script-strings
|
||||
|
||||
: cached-script-string ( string font -- script-string )
|
||||
cached-script-strings get-global [ <script-string> ] 2cache ;
|
||||
|
||||
[ <cache-assoc> cached-script-strings set-global ]
|
||||
"windows.uniscribe" add-init-hook
|
||||
Loading…
Reference in New Issue