Beginning of a real fullscreen library

extra/fullscreen/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/fullscreen/fullscreen.factor

@@ -0,0 +1,142 @@
+! 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
+        { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>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 [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+
+: set-non-fullscreen-styles ( hwnd -- )
+    [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
+    [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags 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
+    {
+        SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
+        SWP_NOREPOSITION SWP_NOZORDER
+    } flags
+    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) ;

extra/fullscreen/platforms.txt

@@ -0,0 +1 @@
+windows