From 08aa27a112aebede856ae6c94e2d09b65093b0c4 Mon Sep 17 00:00:00 2001
From: KUSUMOTO Norio <norio@mac-mini.local>
Date: Wed, 3 Apr 2019 22:00:45 +0900
Subject: [PATCH] windows.factor KUSUMOTO Norio plan 2

bug fix for issue #1

Review of the structure of words

NUMPAD&OEM-keydown-codes

plugable keyboard info

keyboard auto detect

conflict

ToUnicode version

resolve conflicts

ui.backend.windows: fix whitespace
---
 basis/ui/backend/windows/windows.factor | 57 +++++++++++++------------
 basis/windows/user32/user32.factor      |  4 +-
 2 files changed, 31 insertions(+), 30 deletions(-)

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index ab21fb7936..7ebd24deea 100644
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -9,7 +9,7 @@ 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 ;
+windows.types windows.user32 assocs.extras byte-arrays ;
 SPECIALIZED-ARRAY: POINT
 QUALIFIED-WITH: alien.c-types c
 IN: ui.backend.windows
@@ -321,40 +321,41 @@ CONSTANT: exclude-keys-wm-char
 : send-key-up ( sym action? hWnd -- )
     [ [ <key-up> ] ] dip send-key-gesture ;
 
-: key-sym ( wParam -- string/f action? )
-    {
-        {
-            [ dup LETTER? ]
-            [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
-        }
-        { [ dup digit? ] [ 1string f ] }
-        [ wm-keydown-codes at t ]
-    } cond ;
+: key-sym ( wParam -- string/f )
+    wm-keydown-codes at ; inline
 
-:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+:: (handle-wm-keydown/up) ( hWnd uMsg wParam lParam send-key-down/up -- )
     wParam exclude-key-wm-keydown? [
-        wParam key-sym over [
-            dup ctrl? alt? xor or [
-                hWnd send-key-down
-            ] [ 2drop ] if
-        ] [ 2drop ] if
-    ] unless ;
+        wParam key-sym [
+            t hWnd send-key-down/up execute( sym action? hWnd -- )
+        ] [
+            256 <byte-array> :> keyboard-state
+            4 <byte-array> :> chars
+            lParam -16 shift 0xff bitand :> scan-code
+            keyboard-state GetKeyboardState win32-error<>0
+            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 <=  [
+                1 chars nth 8 shift 0 chars nth bitor
+            ] [
+                3 chars nth 8 shift 2 chars nth bitor ! dead-key
+            ] if
+            1string f hWnd send-key-down/up execute( sym action? hWnd -- )
+        ] if*
+    ] unless ; inline
+
+: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+    \ send-key-down (handle-wm-keydown/up) ;
 
 :: handle-wm-char ( hWnd uMsg wParam lParam -- )
     wParam exclude-key-wm-char? [
-        ctrl? alt? xor [
-            wParam 1string
-            [ f hWnd send-key-down ]
-            [ hWnd window user-input ] bi
-        ] unless
+       ctrl? alt? xor [ ! enable AltGr combination inputs
+           wParam 1string hWnd window user-input
+       ] unless
     ] unless ;
 
-:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
-    wParam exclude-key-wm-keydown? [
-        wParam key-sym over [
-            hWnd send-key-up
-        ] [ 2drop ] if
-    ] unless ;
+: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+    \ send-key-up (handle-wm-keydown/up) ;
 
 :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
     ? hwnd window active?<<
diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor
index bc706fecd7..e57d9a566c 100644
--- a/basis/windows/user32/user32.factor
+++ b/basis/windows/user32/user32.factor
@@ -1643,7 +1643,7 @@ FUNCTION: HKL GetKeyboardLayout ( DWORD idThread )
 ! FUNCTION: GetKeyboardLayoutList
 ! FUNCTION: GetKeyboardLayoutNameA
 ! FUNCTION: GetKeyboardLayoutNameW
-! FUNCTION: GetKeyboardState
+FUNCTION: BOOL GetKeyboardState ( BYTE *lpKeyState )
 FUNCTION: int GetKeyboardType ( int nTypeFlag )
 ! FUNCTION: GetKeyNameTextA
 ! FUNCTION: GetKeyNameTextW
@@ -2129,7 +2129,7 @@ ALIAS: SystemParametersInfo SystemParametersInfoW
 ! FUNCTION: TileWindows
 ! FUNCTION: ToAscii
 ! FUNCTION: ToAsciiEx
-! FUNCTION: ToUnicode
+FUNCTION: int ToUnicode ( UINT wVirtKey, UINT wScanCode, BYTE *lpKeyState, LPWSTR pwszBuff, int cchBuff, UINT wFlags )
 ! FUNCTION: ToUnicodeEx
 FUNCTION: BOOL TrackMouseEvent ( LPTRACKMOUSEEVENT lpEventTrack )
 ! FUNCTION: TrackPopupMenu
-- 
2.34.1