ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
ui.private windows.dwmapi windows.errors windows.gdi32
windows.kernel32 windows.messages windows.offscreen windows.opengl32
-windows.types windows.user32 assocs.extras byte-arrays ;
+windows.types windows.user32 assocs.extras byte-arrays
+io.encodings.string ;
+FROM: unicode => upper-surrogate? under-surrogate? ;
SPECIALIZED-ARRAY: POINT
QUALIFIED-WITH: alien.c-types c
IN: ui.backend.windows
: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
\ send-key-down (handle-wm-keydown/up) ;
+SYMBOL: upper-surrogate-wm-char
+
:: handle-wm-char ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-char? [
- ctrl? alt? xor [ ! enable AltGr combination inputs
- wParam 1string hWnd window user-input
- ] unless
+ ctrl? alt? xor [ ! enable AltGr combination inputs
+ wParam {
+ { [ dup upper-surrogate? ] [
+ upper-surrogate-wm-char set-global ]
+ }
+ { [ dup under-surrogate? ] [
+ drop
+ upper-surrogate-wm-char get-global [
+ 1string wParam 1string 2array "" join
+ utf16n encode utf16n decode hWnd window user-input
+ ] when* ]
+ }
+ [ 1string hWnd window user-input
+ f upper-surrogate-wm-char set-global ]
+ } cond
+ ] unless
] unless ;
: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
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 / >integer ;
+
+PRIVATE>
+
:: line-offset>x ( n script-string -- x )
- n script-string
- 2dup string>> length = [
- ssa>> ! ssa
- ! swap 1 - ! icp
- swap 0 swap script-string string>> subseq
- utf16n encode length 2 / >integer 1 - ! icp
+ 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
- swap 0 swap script-string string>> subseq
- utf16n encode length 2 / >integer ! icp
+ n-utf16 ! icp
FALSE ! fTrailing
] if
{ int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
:: x>line-offset ( x script-string -- n trailing )
- x script-string
- ssa>> ! ssa
- swap ! iX
+ script-string ssa>> ! ssa
+ x ! iX
{ int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters
- swap 2 * 0 swap script-string string>> utf16n encode subseq
- utf16n decode length
+ swap dup 0 < [ script-string string>> swap >codepoint-index ] unless
swap ;
+<PRIVATE
+
: make-ssa ( dc script-string -- ssa )
dup selection? [ string>> ] when
- ! [ utf16n encode ] ! pString
- ! [ length ] bi ! cString
utf16n encode ! pString
dup length 2 / >integer ! cString
dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
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
] with-memory-dc
] unless image>> ;
-[ <cache-assoc> cached-script-strings set-global ]
+[ <cache-assoc> &dispose cached-script-strings set-global ]
"windows.uniscribe" add-startup-hook