143 lines
4.3 KiB
Factor
Executable File
143 lines
4.3 KiB
Factor
Executable File
! Copyright (C) 2010 Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors alien.c-types arrays classes.struct fry kernel
|
|
literals locals make math math.bitwise multiline sequences
|
|
slots.syntax ui.backend.windows vocabs.loader windows.errors
|
|
windows.gdi32 windows.kernel32 windows.types windows.user32
|
|
ui.gadgets.worlds ;
|
|
IN: fullscreen
|
|
|
|
: hwnd>hmonitor ( HWND -- HMONITOR )
|
|
MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ;
|
|
|
|
: desktop-hmonitor ( -- HMONITOR )
|
|
GetDesktopWindow hwnd>hmonitor ;
|
|
|
|
:: (monitor-info>devmodes) ( monitor-info n -- )
|
|
DEVMODE <struct>
|
|
DEVMODE heap-size >>dmSize
|
|
flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
|
|
:> devmode
|
|
|
|
monitor-info szDevice>>
|
|
n
|
|
devmode
|
|
EnumDisplaySettings 0 = [
|
|
devmode ,
|
|
monitor-info n 1 + (monitor-info>devmodes)
|
|
] unless ;
|
|
|
|
: monitor-info>devmodes ( monito-info -- devmodes )
|
|
[ 0 (monitor-info>devmodes) ] { } make ;
|
|
|
|
: hmonitor>monitor-info ( HMONITOR -- monitor-info )
|
|
MONITORINFOEX <struct>
|
|
MONITORINFOEX heap-size >>cbSize
|
|
[ GetMonitorInfo win32-error=0/f ] keep ;
|
|
|
|
: hwnd>monitor-info ( HWND -- monitor-info )
|
|
hwnd>hmonitor hmonitor>monitor-info ;
|
|
|
|
: hmonitor>devmodes ( HMONITOR -- devmodes )
|
|
hmonitor>monitor-info monitor-info>devmodes ;
|
|
|
|
: desktop-devmodes ( -- DEVMODEs )
|
|
desktop-hmonitor hmonitor>devmodes ;
|
|
|
|
: desktop-monitor-info ( -- monitor-info )
|
|
desktop-hmonitor hmonitor>monitor-info ;
|
|
|
|
: desktop-RECT ( -- RECT )
|
|
GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
|
|
|
|
ERROR: display-change-error n ;
|
|
|
|
: fullscreen-mode ( monitor-info devmode -- )
|
|
[ szDevice>> ] dip f CDS_FULLSCREEN f
|
|
ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
|
|
[ drop ] [ display-change-error ] if ;
|
|
|
|
: non-fullscreen-mode ( monitor-info devmode -- )
|
|
[ szDevice>> ] dip f 0 f
|
|
ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
|
|
[ drop ] [ display-change-error ] if ;
|
|
|
|
: get-style ( hwnd n -- style )
|
|
GetWindowLongPtr [ win32-error=0/f ] keep ;
|
|
|
|
: set-style ( hwnd n style -- )
|
|
SetWindowLongPtr win32-error=0/f ;
|
|
|
|
: change-style ( hwnd n quot -- )
|
|
[ 2dup get-style ] dip call set-style ; inline
|
|
|
|
: set-fullscreen-styles ( hwnd -- )
|
|
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
|
|
[ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ;
|
|
|
|
: set-non-fullscreen-styles ( hwnd -- )
|
|
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
|
|
[ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ;
|
|
|
|
ERROR: unsupported-resolution triple ;
|
|
|
|
:: find-devmode ( triple hwnd -- devmode )
|
|
hwnd hwnd>hmonitor hmonitor>devmodes
|
|
[
|
|
slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
|
|
triple =
|
|
] find nip [ triple unsupported-resolution ] unless* ;
|
|
|
|
:: set-fullscreen-window-position ( hwnd triple -- )
|
|
hwnd f
|
|
desktop-monitor-info rcMonitor>> slots{ left top } first2
|
|
triple first2
|
|
flags{
|
|
SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
|
|
SWP_NOREPOSITION SWP_NOZORDER
|
|
}
|
|
SetWindowPos win32-error=0/f ;
|
|
|
|
:: enable-fullscreen ( triple hwnd -- rect )
|
|
hwnd hwnd>RECT :> rect
|
|
|
|
desktop-monitor-info
|
|
triple GetDesktopWindow find-devmode
|
|
hwnd set-fullscreen-styles
|
|
fullscreen-mode
|
|
|
|
hwnd triple set-fullscreen-window-position
|
|
rect ;
|
|
|
|
:: set-window-position ( hwnd rect -- )
|
|
hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED
|
|
SetWindowPos win32-error=0/f ;
|
|
|
|
:: disable-fullscreen ( rect triple hwnd -- )
|
|
desktop-monitor-info
|
|
triple
|
|
GetDesktopWindow find-devmode non-fullscreen-mode
|
|
hwnd set-non-fullscreen-styles
|
|
hwnd rect set-window-position ;
|
|
|
|
: enable-factor-fullscreen ( triple -- rect )
|
|
GetForegroundWindow enable-fullscreen ;
|
|
|
|
: disable-factor-fullscreen ( rect triple -- )
|
|
GetForegroundWindow disable-fullscreen ;
|
|
|
|
:: (set-fullscreen) ( world triple fullscreen? -- )
|
|
world fullscreen?>> fullscreen? xor [
|
|
triple
|
|
world handle>> hWnd>>
|
|
fullscreen? [
|
|
enable-fullscreen world saved-position<<
|
|
] [
|
|
[ world saved-position>> ] 2dip disable-fullscreen
|
|
] if
|
|
fullscreen? world fullscreen?<<
|
|
] when ;
|
|
|
|
: set-fullscreen ( gadget triple fullscreen? -- )
|
|
[ find-world ] 2dip (set-fullscreen) ;
|