1 ! Copyright (C) 2010 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types arrays classes.struct fry kernel
4 literals locals make math math.bitwise multiline sequences
5 slots.syntax ui.backend.windows vocabs.loader windows.errors
6 windows.gdi32 windows.kernel32 windows.types windows.user32
10 : hwnd>hmonitor ( HWND -- HMONITOR )
11 MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ;
13 : desktop-hmonitor ( -- HMONITOR )
14 GetDesktopWindow hwnd>hmonitor ;
16 :: (monitor-info>devmodes) ( monitor-info n -- )
18 DEVMODE heap-size >>dmSize
19 flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
22 monitor-info szDevice>>
25 EnumDisplaySettings 0 = [
27 monitor-info n 1 + (monitor-info>devmodes)
30 : monitor-info>devmodes ( monito-info -- devmodes )
31 [ 0 (monitor-info>devmodes) ] { } make ;
33 : hmonitor>monitor-info ( HMONITOR -- monitor-info )
34 MONITORINFOEX <struct>
35 MONITORINFOEX heap-size >>cbSize
36 [ GetMonitorInfo win32-error=0/f ] keep ;
38 : hwnd>monitor-info ( HWND -- monitor-info )
39 hwnd>hmonitor hmonitor>monitor-info ;
41 : hmonitor>devmodes ( HMONITOR -- devmodes )
42 hmonitor>monitor-info monitor-info>devmodes ;
44 : desktop-devmodes ( -- DEVMODEs )
45 desktop-hmonitor hmonitor>devmodes ;
47 : desktop-monitor-info ( -- monitor-info )
48 desktop-hmonitor hmonitor>monitor-info ;
50 : desktop-RECT ( -- RECT )
51 GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
53 ERROR: display-change-error n ;
55 : fullscreen-mode ( monitor-info devmode -- )
56 [ szDevice>> ] dip f CDS_FULLSCREEN f
57 ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
58 [ drop ] [ display-change-error ] if ;
60 : non-fullscreen-mode ( monitor-info devmode -- )
61 [ szDevice>> ] dip f 0 f
62 ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
63 [ drop ] [ display-change-error ] if ;
65 : get-style ( hwnd n -- style )
66 GetWindowLongPtr [ win32-error=0/f ] keep ;
68 : set-style ( hwnd n style -- )
69 SetWindowLongPtr win32-error=0/f ;
71 : change-style ( hwnd n quot -- )
72 [ 2dup get-style ] dip call set-style ; inline
74 : set-fullscreen-styles ( hwnd -- )
75 [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
76 [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ;
78 : set-non-fullscreen-styles ( hwnd -- )
79 [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
80 [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ;
82 ERROR: unsupported-resolution triple ;
84 :: find-devmode ( triple hwnd -- devmode )
85 hwnd hwnd>hmonitor hmonitor>devmodes
87 slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
89 ] find nip [ triple unsupported-resolution ] unless* ;
91 :: set-fullscreen-window-position ( hwnd triple -- )
93 desktop-monitor-info rcMonitor>> slots{ left top } first2
96 SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
97 SWP_NOREPOSITION SWP_NOZORDER
99 SetWindowPos win32-error=0/f ;
101 :: enable-fullscreen ( triple hwnd -- rect )
102 hwnd hwnd>RECT :> rect
105 triple GetDesktopWindow find-devmode
106 hwnd set-fullscreen-styles
109 hwnd triple set-fullscreen-window-position
112 :: set-window-position ( hwnd rect -- )
113 hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED
114 SetWindowPos win32-error=0/f ;
116 :: disable-fullscreen ( rect triple hwnd -- )
119 GetDesktopWindow find-devmode non-fullscreen-mode
120 hwnd set-non-fullscreen-styles
121 hwnd rect set-window-position ;
123 : enable-factor-fullscreen ( triple -- rect )
124 GetForegroundWindow enable-fullscreen ;
126 : disable-factor-fullscreen ( rect triple -- )
127 GetForegroundWindow disable-fullscreen ;
129 :: (set-fullscreen) ( world triple fullscreen? -- )
130 world fullscreen?>> fullscreen? xor [
132 world handle>> hWnd>>
134 enable-fullscreen world saved-position<<
136 [ world saved-position>> ] 2dip disable-fullscreen
138 fullscreen? world fullscreen?<<
141 : set-fullscreen ( gadget triple fullscreen? -- )
142 [ find-world ] 2dip (set-fullscreen) ;