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

ui.backend.windows: fix resize-window to use "adjusted" dimensions.

windows-high-dpi
John Benediktsson 2018-03-05 14:57:50 -08:00
parent 1386489bbc
commit 6ca7703831
1 changed files with 17 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/ui/backend/windows/windows.factor
View File

@ -659,7 +659,7 @@ M: windows-ui-backend do-events
swap window-controls>> close-button swap member? not swap window-controls>> close-button swap member? not
[ disable-close-button ] [ drop ] if ; [ disable-close-button ] [ drop ] if ;
M: windows-ui-backend (open-window) ( world -- ) M: windows-ui-backend (open-window)
[ [
dup dup
[ ] [ world>style ] [ world>ex-style ] tri create-window [ ] [ world>style ] [ world>ex-style ] tri create-window
@ -670,11 +670,11 @@ M: windows-ui-backend (open-window) ( world -- )
[ dup handle>> hWnd>> register-window ] [ dup handle>> hWnd>> register-window ]
[ handle>> hWnd>> show-window ] tri ; [ handle>> hWnd>> show-window ] tri ;
M: win-base select-gl-context ( handle -- ) M: win-base select-gl-context
[ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
GdiFlush drop ; GdiFlush drop ;
M: win-base flush-gl-context ( handle -- ) M: win-base flush-gl-context
hDC>> SwapBuffers win32-error=0/f ; hDC>> SwapBuffers win32-error=0/f ;
! Windows 32-bit bitmaps don't actually use the alpha byte of ! Windows 32-bit bitmaps don't actually use the alpha byte of
@ -688,10 +688,10 @@ M: win-base flush-gl-context ( handle -- )
: (opaque-pixels) ( world -- pixels ) : (opaque-pixels) ( world -- pixels )
[ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ; [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
M: windows-ui-backend raise-window* ( world -- ) M: windows-ui-backend raise-window*
handle>> [ hWnd>> SetFocus drop ] when* ; handle>> [ hWnd>> SetFocus drop ] when* ;
M: windows-ui-backend set-title ( string world -- ) M: windows-ui-backend set-title
handle>> handle>>
dup title>> [ free ] when* dup title>> [ free ] when*
swap utf16n malloc-string swap utf16n malloc-string
@ -706,7 +706,7 @@ M: windows-ui-backend (with-ui)
event-loop event-loop
] [ cleanup-win32-ui ] [ ] cleanup ; ] [ cleanup-win32-ui ] [ ] cleanup ;
M: windows-ui-backend beep ( -- ) M: windows-ui-backend beep
0 MessageBeep drop ; 0 MessageBeep drop ;
M: windows-ui-backend system-alert M: windows-ui-backend system-alert
@ -727,11 +727,11 @@ M: windows-ui-backend system-alert
: hwnd>RECT ( hwnd -- RECT ) : hwnd>RECT ( hwnd -- RECT )
RECT <struct> [ GetWindowRect win32-error=0/f ] keep ; RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
M: windows-ui-backend (grab-input) ( handle -- ) M: windows-ui-backend (grab-input)
0 ShowCursor drop 0 ShowCursor drop
hWnd>> client-area>RECT ClipCursor drop ; hWnd>> client-area>RECT ClipCursor drop ;
M: windows-ui-backend (ungrab-input) ( handle -- ) M: windows-ui-backend (ungrab-input)
drop drop
f ClipCursor drop f ClipCursor drop
1 ShowCursor drop ; 1 ShowCursor drop ;
@ -769,17 +769,21 @@ CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
[ drop SW_RESTORE ShowWindow win32-error=0/f ] [ drop SW_RESTORE ShowWindow win32-error=0/f ]
} 2cleave ; } 2cleave ;
M: windows-ui-backend (set-fullscreen) ( ? world -- ) M: windows-ui-backend (set-fullscreen)
[ enter-fullscreen ] [ exit-fullscreen ] if ; [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: windows-ui-backend (fullscreen?) ( world -- ? ) M: windows-ui-backend (fullscreen?)
handle>> hWnd>> handle>> hWnd>>
[ hwnd>RECT ] [ fullscreen-RECT ] bi [ hwnd>RECT ] [ fullscreen-RECT ] bi
[ get-RECT-dimensions 2array 2nip ] same? ; [ get-RECT-dimensions 2array 2nip ] same? ;
M: windows-ui-backend resize-window ( world dim -- ) M:: windows-ui-backend resize-window ( world dim -- )
[ handle>> hWnd>> dup hwnd>RECT get-RECT-top-left ] world handle>> hWnd>>
[ first2 FALSE ] bi* MoveWindow win32-error=0/f ; world window-loc>> dim <RECT> dup
world world>style
world world>ex-style
adjust-RECT get-RECT-dimensions FALSE
MoveWindow win32-error=0/f ;
M: windows-ui-backend ui-backend-available? M: windows-ui-backend ui-backend-available?
t ; t ;