windows: Fix user32/shcore DPI functions.

[factor.git] / basis / ui / backend / windows / windows.factor

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 7ebd24deeaf02e029a59b6b115b92b7fcb6b5da4..0982ae37704214c4a54d6d9636725edfe6d7009f 100644 (file)
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -9,7 +9,9 @@ threads ui ui.backend ui.clipboards ui.event-loop ui.gadgets
 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
@@ -189,7 +191,7 @@ CONSTANT: window-control>ex-style
         { minimize-button 0 }
         { maximize-button 0 }
         { resize-handles $ WS_EX_WINDOWEDGE }
-        { small-title-bar $[ WS_EX_TOOLWINDOW WS_EX_TOPMOST bitor ] }
+        { small-title-bar flags{ WS_EX_TOOLWINDOW WS_EX_TOPMOST } }
         { normal-title-bar $ WS_EX_APPWINDOW }
         { dialog-window 0 }
     }
@@ -332,7 +334,7 @@ CONSTANT: exclude-keys-wm-char
             256 <byte-array> :> keyboard-state
             4 <byte-array> :> chars
             lParam -16 shift 0xff bitand :> scan-code
-            keyboard-state GetKeyboardState win32-error<>0
+            keyboard-state GetKeyboardState win32-error=0/f
             VK_CONTROL VK_CAPITAL [ 0 swap keyboard-state set-nth ] bi@
             wParam scan-code keyboard-state chars 2 0 ToUnicode dup win32-error=0/f
             1 <=  [
@@ -347,11 +349,26 @@ CONSTANT: exclude-keys-wm-char
 : 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 [
+                          wParam "" 2sequence
+                          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 -- )
@@ -516,6 +533,9 @@ SYMBOL: wm-handlers
 wm-handlers [
     H{
         ${ WM_CLOSE [ handle-wm-close 0 ] }
+        ! ${ WM_NCCREATE [ [ 3drop EnableNonClientDpiScaling drop ] [ DefWindowProc ] 4bi ] }
+        ! ${ WM_GETDPISCALEDSIZE [ DefWindowProc ] }
+        ! ${ WM_DPICHANGED [ DefWindowProc ] }
         ${ WM_PAINT [ 4dup handle-wm-paint DefWindowProc ] }
 
         ${ WM_SIZE [ handle-wm-size 0 ] }
@@ -586,6 +606,7 @@ M: windows-ui-backend do-events
     ] [ drop ] if ;
 
 : adjust-RECT ( RECT style ex-style -- )
+    ! [ 0 ] dip GetDpiForSystem AdjustWindowRectExForDpi win32-error=0/f ;
     [ 0 ] dip AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
@@ -613,12 +634,20 @@ M: windows-ui-backend do-events
         dup
     ] change-global ;
 
+: get-device-caps ( handle -- x y )
+    GetDC
+    [ LOGPIXELSX GetDeviceCaps ]
+    [ LOGPIXELSY GetDeviceCaps ] bi ;
+
+: get-default-device-caps ( -- x y )
+    f get-device-caps ;
+
 :: create-window ( rect style ex-style -- hwnd )
     rect style ex-style make-adjusted-RECT
     [ get-window-class f ] dip
     [
         [ ex-style ] 2dip
-        WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
+        flags{ WS_CLIPSIBLINGS WS_CLIPCHILDREN } style bitor
     ] dip get-RECT-dimensions
     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;