extra/windows/fullscreen/fullscreen.factor

   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
   7 ui.gadgets.worlds ;
   8 IN: windows.fullscreen
   9
  10 : hwnd>hmonitor ( HWND -- HMONITOR )
  11     MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ;
  12
  13 : desktop-hmonitor ( -- HMONITOR )
  14     GetDesktopWindow hwnd>hmonitor ;
  15
  16 :: (monitor-info>devmodes) ( monitor-info n -- )
  17     DEVMODE <struct>
  18         DEVMODE heap-size >>dmSize
  19         flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
  20     :> devmode
  21
  22     monitor-info szDevice>>
  23     n
  24     devmode
  25     EnumDisplaySettings 0 = [
  26         devmode ,
  27         monitor-info n 1 + (monitor-info>devmodes)
  28     ] unless ;
  29
  30 : monitor-info>devmodes ( monito-info -- devmodes )
  31     [ 0 (monitor-info>devmodes) ] { } make ;
  32
  33 : hmonitor>monitor-info ( HMONITOR -- monitor-info )
  34     MONITORINFOEX <struct>
  35         MONITORINFOEX heap-size >>cbSize
  36     [ GetMonitorInfo win32-error=0/f ] keep ;
  37
  38 : hwnd>monitor-info ( HWND -- monitor-info )
  39     hwnd>hmonitor hmonitor>monitor-info ;
  40
  41 : hmonitor>devmodes ( HMONITOR -- devmodes )
  42     hmonitor>monitor-info monitor-info>devmodes ;
  43
  44 : desktop-devmodes ( -- DEVMODEs )
  45     desktop-hmonitor hmonitor>devmodes ;
  46
  47 : desktop-monitor-info ( -- monitor-info )
  48     desktop-hmonitor hmonitor>monitor-info ;
  49
  50 : desktop-RECT ( -- RECT )
  51     GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
  52
  53 ERROR: display-change-error n ;
  54
  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 ;
  59
  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 ;
  64
  65 : get-style ( hwnd n -- style )
  66     GetWindowLongPtr [ win32-error=0/f ] keep ;
  67
  68 : set-style ( hwnd n style -- )
  69     SetWindowLongPtr win32-error=0/f ;
  70
  71 : change-style ( hwnd n quot -- )
  72     [ 2dup get-style ] dip call set-style ; inline
  73
  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 ;
  77
  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 ;
  81
  82 ERROR: unsupported-resolution triple ;
  83
  84 :: find-devmode ( triple hwnd -- devmode )
  85     hwnd hwnd>hmonitor hmonitor>devmodes
  86     [
  87         slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
  88         triple =
  89     ] find nip [ triple unsupported-resolution ] unless* ;
  90
  91 :: set-fullscreen-window-position ( hwnd triple -- )
  92     hwnd f
  93     desktop-monitor-info rcMonitor>> slots{ left top } first2
  94     triple first2
  95     flags{
  96         SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
  97         SWP_NOREPOSITION SWP_NOZORDER
  98     }
  99     SetWindowPos win32-error=0/f ;
 100
 101 :: enable-fullscreen ( triple hwnd -- rect )
 102     hwnd hwnd>RECT :> rect
 103
 104     desktop-monitor-info
 105     triple GetDesktopWindow find-devmode
 106     hwnd set-fullscreen-styles
 107     fullscreen-mode
 108
 109     hwnd triple set-fullscreen-window-position
 110     rect ;
 111
 112 :: set-window-position ( hwnd rect -- )
 113     hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED
 114     SetWindowPos win32-error=0/f ;
 115
 116 :: disable-fullscreen ( rect triple hwnd -- )
 117     desktop-monitor-info
 118     triple
 119     GetDesktopWindow find-devmode non-fullscreen-mode
 120     hwnd set-non-fullscreen-styles
 121     hwnd rect set-window-position ;
 122
 123 : enable-factor-fullscreen ( triple -- rect )
 124     GetForegroundWindow enable-fullscreen ;
 125
 126 : disable-factor-fullscreen ( rect triple -- )
 127     GetForegroundWindow disable-fullscreen ;
 128
 129 :: (set-fullscreen) ( world triple fullscreen? -- )
 130     world fullscreen?>> fullscreen? xor [
 131         triple
 132         world handle>> hWnd>>
 133         fullscreen? [
 134             enable-fullscreen world saved-position<<
 135         ] [
 136             [ world saved-position>> ] 2dip disable-fullscreen
 137         ] if
 138         fullscreen? world fullscreen?<<
 139     ] when ;
 140
 141 : set-fullscreen ( gadget triple fullscreen? -- )
 142     [ find-world ] 2dip (set-fullscreen) ;