steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

win32 keystroke handling fix. space invaders works now

erg 2006-03-30 23:45:52 +00:00
parent d7928befda
commit a3beb28620
2 changed files with 40 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
library/windows/load.factor
View File

@ -32,4 +32,4 @@ USING: alien compiler kernel namespaces parser sequences words ;
] when ] when
IN: kernel IN: kernel
: default-shell "tty" ; : default-shell "ui" ;

77
library/windows/ui.factor
View File

@ -64,24 +64,20 @@ TUPLE: gadget-window world hWnd hDC hRC ;
{ 46 "DELETE" } { 46 "DELETE" }
} ; } ;
: wm-char-exclude-keys
H{
{ 8 "BACKSPACE" }
{ 13 "RETURN" }
} ;
: key-state-down? : key-state-down?
GetKeyState 1 16 shift bitand 0 > ; GetKeyState 1 16 shift bitand 0 > ;
: left-shift? ( -- bool ) VK_LSHIFT key-state-down? ; : left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
: left-ctrl? ( -- bool ) VK_LCONTROL key-state-down? ; : left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
: left-alt? ( -- bool ) VK_LMENU key-state-down? ; : left-alt? ( -- ? ) VK_LMENU key-state-down? ;
: right-shift? ( -- bool ) VK_RSHIFT key-state-down? ; : right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
: right-ctrl? ( -- bool ) VK_RCONTROL key-state-down? ; : right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
: right-alt? ( -- bool ) VK_RMENU key-state-down? ; : right-alt? ( -- ? ) VK_RMENU key-state-down? ;
: shift? ( -- bool ) left-shift? right-shift? or ; : shift? ( -- ? ) left-shift? right-shift? or ;
: ctrl? ( -- bool ) left-ctrl? right-ctrl? or ; : ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
: alt? ( -- bool ) left-alt? right-alt? or ; : alt? ( -- ? ) left-alt? right-alt? or ;
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
: key-modifiers ( -- list ) : key-modifiers ( -- list )
[ [
@ -90,11 +86,15 @@ TUPLE: gadget-window world hWnd hDC hRC ;
alt? [ "ALT" , ] when alt? [ "ALT" , ] when
] V{ } make ; ] V{ } make ;
: handle-key-as-gesture? ( n -- bool ) : wm-char-exclude-keys
wm-keydown-codes hash* nip key-modifiers empty? not or ; H{
{ 8 "BACKSPACE" }
{ 9 "TAB" }
{ 13 "RETURN" }
} ;
: exclude-key? ( n -- bool ) : exclude-key? ( n -- bool ) wm-char-exclude-keys hash* nip ;
wm-char-exclude-keys hash* nip ; : handle-key? ( n -- bool ) wm-keydown-codes hash* nip ;
: keystroke>gesture ( n -- list ) : keystroke>gesture ( n -- list )
dup wm-keydown-codes hash* [ nip ] [ drop ch>string ] if dup wm-keydown-codes hash* [ nip ] [ drop ch>string ] if
@ -105,19 +105,30 @@ SYMBOL: wParam
SYMBOL: uMsg SYMBOL: uMsg
SYMBOL: hWnd SYMBOL: hWnd
! wparam = keystroke, lparam = parameters
: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) : handle-wm-keydown ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set lParam set wParam set uMsg set hWnd set
wParam get handle-key-as-gesture? [ wParam get handle-key? [
wParam get keystroke>gesture wParam get hWnd get get-world world-focus
hWnd get get-world world-focus handle-gesture 0 2dup >r keystroke>gesture r> handle-gesture [
>r ch>string r> user-input
] [ ] [
hWnd get uMsg get wParam get lParam get DefWindowProc 2drop
] if ; ] if
] when 0 ;
: handle-wm-char ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set
wParam get exclude-key? [
wParam get ch>string hWnd get get-world world-focus
2dup >r unit r> handle-gesture [
user-input
] [
2drop
] if
] unless 0 ;
: handle-wm-destroy ( hWnd uMsg wParam lParam -- ) : handle-wm-destroy ( hWnd uMsg wParam lParam -- )
3drop 3drop
[ [
get-gadget-window get-gadget-window
dup gadget-window-world close-world dup gadget-window-world close-world
@ -126,22 +137,6 @@ SYMBOL: hWnd
windows get remove-hash windows get remove-hash
0 PostQuitMessage ; 0 PostQuitMessage ;
: handle-wm-char ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set
! "WM_CHAR" print
wParam get exclude-key? [
hWnd get uMsg get wParam get lParam get DefWindowProc
] [
wParam get ch>string hWnd get get-world world-focus user-input
0 ! retval
] if ;
! TODO: handle alt keystrokes as gestures
: handle-wm-syschar ( hWnd uMsg wParam lParam -- )
lParam set wParam set uMsg set hWnd set
handle-wm-keydown ;
: mouse-button ( uMsg -- n ) : mouse-button ( uMsg -- n )
{ {
{ [ dup WM_LBUTTONDOWN = ] [ drop 1 ] } { [ dup WM_LBUTTONDOWN = ] [ drop 1 ] }