! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
+! See https://factorcode.org/license.txt for BSD license.
+
USING: accessors alien.c-types alien.data arrays assocs
-byte-arrays cache classes.struct colors colors.constants
-combinators destructors fonts images init io.encodings.string
-io.encodings.utf16n kernel literals locals math math.bitwise
-namespaces sequences specialized-arrays windows.errors
-windows.fonts windows.gdi32 windows.offscreen windows.ole32
-windows.types windows.usp10 ;
+byte-arrays cache classes.struct colors combinators destructors
+fonts images init io.encodings.string io.encodings.utf16 kernel
+literals locals math math.bitwise math.functions namespaces
+sequences specialized-arrays windows.errors windows.fonts
+windows.gdi32 windows.offscreen windows.ole32 windows.types
+windows.usp10 ;
+
SPECIALIZED-ARRAY: uint32_t
IN: windows.uniscribe
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
+<PRIVATE
+
+CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
+
+:: >codepoint-index ( str utf16-index -- codepoint-index )
+ 0 utf16-index 2 * str utf16n encode subseq utf16n decode length ;
+
+:: >utf16-index ( str codepoint-index -- utf16-index )
+ 0 codepoint-index str subseq utf16n encode length 2 /i ;
+
+PRIVATE>
+
+:: line-offset>x ( n script-string -- x )
+ script-string string>> n >utf16-index :> n-utf16
+ script-string ssa>> ! ssa
+ n script-string string>> length = [
+ n-utf16 1 - ! icp
TRUE ! fTrailing
] [
- ssa>>
- swap ! icp
+ n-utf16 ! icp
FALSE ! fTrailing
] if
{ int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
-: x>line-offset ( x script-string -- n trailing )
- ssa>> ! ssa
- swap ! iX
- { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters ;
+:: x>line-offset ( x script-string -- n trailing )
+ script-string ssa>> ! ssa
+ x ! iX
+ { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters
+ swap dup 0 < [ script-string string>> swap >codepoint-index ] unless
+ swap ;
<PRIVATE
-CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
-
: make-ssa ( dc script-string -- ssa )
dup selection? [ string>> ] when
- [ utf16n encode ] ! pString
- [ length ] bi ! cString
+ utf16n encode ! pString
+ dup length 2 /i ! cString
dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
-1 ! iCharset -- Unicode
ssa-dwFlags
ETO_OPAQUE ! uOptions
]
[ [ { 0 0 } ] dip <RECT> ]
- [ selection-start/end ] tri*
+ [
+ [let :> str str selection-start/end
+ [
+ str string>> dup selection? [ string>> ] when
+ swap >utf16-index
+ ] bi@
+ ]
+ ] tri*
! iMinSel
! iMaxSel
FALSE ! fDisabled
! transparency.
:: color-to-alpha ( image color -- image' )
color >rgba-components :> alpha
- [ 255 * >integer ] tri@ 3byte-array uint32_t deref 24 bits :> rgb
+ [ 255 * round >integer ] tri@ 3byte-array uint32_t deref 24 bits :> rgb
image bitmap>> uint32_t cast-array
alpha 1 <
[ [ 0xff bitand alpha * >integer 24 shift rgb bitor ] map! ]
[ cx>> ] [ cy>> ] bi 2array ;
: dc-metrics ( dc -- metrics )
- TEXTMETRICW <struct>
+ TEXTMETRICW new
[ GetTextMetrics drop ] keep
TEXTMETRIC>metrics ;
] with-memory-dc
] unless image>> ;
-[ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-startup-hook
+STARTUP-HOOK: [ <cache-assoc> cached-script-strings set-global ]