Windows UI backend now saves window positions

db4
Slava Pestov 2008-02-25 04:17:28 -06:00
parent bd110c9f03
commit 4e0323f64a
1 changed files with 37 additions and 23 deletions
extra/ui/windows

View File

@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
: enum-clipboard ( -- seq )
0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
{ } unfold nip ;
0
[ EnumClipboardFormats win32-error dup dup 0 > ]
[ ]
[ drop ]
unfold nip ;
: with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f
@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ;
: copy ( str -- )
lf>crlf [
string>u16-alien
f OpenClipboard win32-error=0/f
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
rot dup length memcpy
swapd byte-array>memory
dup GlobalUnlock win32-error=0/f
CF_UNICODETEXT swap SetClipboardData win32-error=0/f
] with-clipboard ;
@ -72,31 +74,29 @@ SYMBOL: mouse-captured
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
: adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( width height -- RECT )
"RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
: make-adjusted-RECT ( width height -- RECT )
make-RECT dup adjust-RECT ;
: get-RECT-dimensions ( RECT -- width height )
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
: get-RECT-top-left ( RECT -- x y )
[ RECT-left ] keep RECT-top ;
: get-RECT-dimensions ( RECT -- x y width height )
[ get-RECT-top-left ] keep
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
#! only paint if width/height both > 0
3drop window draw-world ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
2nip
[ lo-word ] keep hi-word 2array
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
swap window set-world-loc ;
: wm-keydown-codes ( -- key )
H{
{ 8 "BACKSPACE" }
@ -240,7 +240,7 @@ M: windows-ui-backend (close-window)
: mouse-absolute>relative ( lparam handle -- array )
>r >lo-hi r>
0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
: mouse-event>gesture ( uMsg -- button )
@ -317,6 +317,7 @@ M: windows-ui-backend (close-window)
{ [ dup WM_PAINT = ]
[ drop 4dup handle-wm-paint DefWindowProc ] }
{ [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] }
{ [ dup WM_MOVE = ] [ drop handle-wm-move 0 ] }
! Keyboard events
{ [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
@ -383,13 +384,26 @@ M: windows-ui-backend (close-window)
RegisterClassEx dup win32-error=0/f
] when ;
: create-window ( width height -- hwnd )
: adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
dup world-loc { 40 40 } vmax dup rot rect-dim v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
: make-adjusted-RECT ( rect -- RECT )
make-RECT dup adjust-RECT ;
: create-window ( rect -- hwnd )
make-adjusted-RECT
>r class-name-ptr get-global f r>
>r >r >r ex-style r> r>
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
CW_USEDEFAULT dup r>
get-RECT-dimensions
r> get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- )
@ -424,7 +438,7 @@ M: windows-ui-backend (close-window)
get-dc dup setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- )
[ rect-dim first2 create-window dup setup-gl ] keep
[ create-window dup setup-gl ] keep
[ f <win> ] keep
[ swap win-hWnd register-window ] 2keep
dupd set-world-handle