win32 support for window-controls

basis/game-input/dinput/dinput.factor

@@ -190,7 +190,7 @@ TUPLE: window-rect < rect window-loc ;
     DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
 
 : create-device-change-window ( -- )
-    <zero-window-rect> create-window
+    <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
     [
         (device-notification-filter)
         DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor

basis/math/bitwise/bitwise-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax math sequences ;
+USING: assocs help.markup help.syntax math sequences ;
 IN: math.bitwise
 
 HELP: bitfield
@@ -145,6 +145,25 @@ HELP: flags
     }
 } ;
 
+HELP: symbols>flags
+{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
+{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
+{ $examples
+    { $example "USING: math.bitwise prettyprint ui.gadgets.worlds ;"
+        "IN: scratchpad"
+        "CONSTANT: window-controls>flags H{"
+        "    { close-button 1 }"
+        "    { minimize-button 2 }"
+        "    { maximize-button 4 }"
+        "    { resize-handles 8 }"
+        "    { small-title-bar 16 }"
+        "    { normal-title-bar 32 }"
+        "}"
+        "{ resize-handles close-button small-title-bar } window-controls>flags symbols>flags ."
+        "25"
+    }
+} ;
+
 HELP: mask
 { $values
      { "x" integer } { "n" integer }

basis/math/bitwise/bitwise.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences accessors math.bits
+USING: arrays assocs kernel math sequences accessors
-sequences.private words namespaces macros hints
+math.bits sequences.private words namespaces macros
-combinators fry io.binary combinators.smart ;
+hints combinators fry io.binary combinators.smart ;
 IN: math.bitwise
 
 ! utilities
@@ -44,6 +44,10 @@ IN: math.bitwise
 MACRO: flags ( values -- )
     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
 
+: symbols>flags ( symbols assoc -- flag-bits )
+    [ at ] curry map
+    0 [ bitor ] reduce ;
+
 ! bitfield
 <PRIVATE
 

basis/ui/backend/cocoa/cocoa.factor

@@ -6,7 +6,7 @@ cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
 cocoa.views cocoa.windows combinators command-line
 core-foundation core-foundation.run-loop core-graphics
 core-graphics.types destructors fry generalizations io.thread
-kernel libc literals locals math math.rectangles memory
+kernel libc literals locals math math.bitwise math.rectangles memory
 namespaces sequences specialized-arrays.int threads ui
 ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
 ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
@@ -120,7 +120,7 @@ CONSTANT: window-control>styleMask
     }
 
 : world>styleMask ( world -- n )
-    window-controls>> [ window-control>styleMask at ] map 0 [ bitor ] reduce ;
+    window-controls>> window-control>styleMask symbols>flags ;
 
 M:: cocoa-ui-backend (open-window) ( world -- )
     world [ [ dim>> ] dip <FactorView> ]

basis/ui/backend/windows/windows.factor

@@ -9,7 +9,7 @@ windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
 windows.messages windows.types windows.offscreen windows.nt
 threads libc combinators fry combinators.short-circuit continuations
 command-line shuffle opengl ui.render math.bitwise locals
-accessors math.rectangles math.order calendar ascii
+accessors math.rectangles math.order calendar ascii sets
 io.encodings.utf16n windows.errors literals ui.pixel-formats 
 ui.pixel-formats.private memoize classes struct-arrays ;
 IN: ui.backend.windows
@@ -223,8 +223,36 @@ M: pasteboard set-clipboard-contents drop copy ;
 
 SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 
-: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
+CONSTANT: window-control>style
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+    H{
+        { close-button 0 }
+        { minimize-button $ WS_MINIMIZEBOX }
+        { maximize-button $ WS_MAXIMIZEBOX }
+        { resize-handles $ WS_THICKFRAME }
+        { small-title-bar $ WS_CAPTION }
+        { normal-title-bar $ WS_CAPTION }
+    }
+
+CONSTANT: window-control>ex-style
+    H{
+        { close-button 0 }
+        { minimize-button 0 }
+        { maximize-button 0 }
+        { resize-handles $ WS_EX_WINDOWEDGE }
+        { small-title-bar $ WS_EX_TOOLWINDOW }
+        { normal-title-bar $ WS_EX_APPWINDOW }
+    }
+
+: needs-sysmenu? ( controls -- ? )
+    { close-button minimize-button maximize-button } intersects? ;
+
+: world>style ( world -- n )
+    window-controls>>
+    [ window-control>style symbols>flags ]
+    [ needs-sysmenu? [ WS_SYSMENU bitor ] when ] bi ;
+
+: world>ex-style ( world -- n )
+    window-controls>> window-control>ex-style symbols>flags ;
 
 : get-RECT-top-left ( RECT -- x y )
     [ RECT-left ] keep RECT-top ;
@@ -571,8 +599,8 @@ M: windows-ui-backend do-events
         RegisterClassEx win32-error=0/f
     ] [ drop ] if ;
 
-: adjust-RECT ( RECT -- )
+: adjust-RECT ( RECT style ex-style -- )
-    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+    [ 0 ] dip AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
     [ window-loc>> ] [ dim>> ] bi <RECT> ;
@@ -584,10 +612,12 @@ M: windows-ui-backend do-events
     CW_USEDEFAULT over set-RECT-left
     CW_USEDEFAULT swap set-RECT-top ;
 
-: make-adjusted-RECT ( rect -- RECT )
+: make-adjusted-RECT ( rect style ex-style -- RECT )
+    [
         make-RECT
         dup get-RECT-top-left [ zero? ] both? swap
-    dup adjust-RECT
+        dup
+    ] 2dip adjust-RECT
     swap [ dup default-position-RECT ] when ;
 
 : get-window-class ( -- class-name )
@@ -597,12 +627,12 @@ M: windows-ui-backend do-events
         dup
     ] change-global ;
 
-: create-window ( rect -- hwnd )
+:: create-window ( rect style ex-style -- hwnd )
-    make-adjusted-RECT
+    rect style ex-style make-adjusted-RECT
     [ get-window-class f ] dip
     [
         [ ex-style ] 2dip
-        { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+        WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor
     ] dip get-RECT-dimensions
     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 
@@ -636,8 +666,21 @@ M: windows-ui-backend do-events
     [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
     with-world-pixel-format ;
 
+: disable-close-button ( hwnd -- )
+    0 GetSystemMenu
+    SC_CLOSE MF_BYCOMMAND MF_GRAYED bitor EnableMenuItem drop ;
+
+: ?disable-close-button ( world hwnd -- )
+    swap window-controls>> close-button swap member? not
+    [ disable-close-button ] [ drop ] if ;
+
 M: windows-ui-backend (open-window) ( world -- )
-    [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
+    [
+        dup
+        [ ] [ world>style ] [ world>ex-style ] tri create-window
+        [ ?disable-close-button ]
+        [ [ f f ] dip f f <win> >>handle setup-gl ] 2bi
+    ]
     [ dup handle>> hWnd>> register-window ]
     [ handle>> hWnd>> show-window ] tri ;
 
@@ -743,13 +786,9 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
     } cleave ;
 
 : exit-fullscreen ( world -- )
-    handle>> hWnd>>
+    dup handle>> hWnd>>
     {
-        [
+        [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
-            GWL_STYLE GetWindowLong
-            fullscreen-flags bitor
-        ]
-        [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
         [
             f
             over hwnd>RECT get-RECT-dimensions

basis/windows/user32/user32.factor

@@ -582,6 +582,28 @@ CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER
 CONSTANT: SWP_DEFERERASE 8192
 CONSTANT: SWP_ASYNCWINDOWPOS 16384
 
+CONSTANT: MF_ENABLED         HEX: 0000
+CONSTANT: MF_GRAYED          HEX: 0001
+CONSTANT: MF_DISABLED        HEX: 0002
+CONSTANT: MF_STRING          HEX: 0000
+CONSTANT: MF_BITMAP          HEX: 0004
+CONSTANT: MF_UNCHECKED       HEX: 0000
+CONSTANT: MF_CHECKED         HEX: 0008
+CONSTANT: MF_POPUP           HEX: 0010
+CONSTANT: MF_MENUBARBREAK    HEX: 0020
+CONSTANT: MF_MENUBREAK       HEX: 0040
+CONSTANT: MF_UNHILITE        HEX: 0000
+CONSTANT: MF_HILITE          HEX: 0080
+CONSTANT: MF_OWNERDRAW       HEX: 0100
+CONSTANT: MF_USECHECKBITMAPS HEX: 0200
+CONSTANT: MF_BYCOMMAND       HEX: 0000
+CONSTANT: MF_BYPOSITION      HEX: 0400
+CONSTANT: MF_SEPARATOR       HEX: 0800
+CONSTANT: MF_DEFAULT         HEX: 1000
+CONSTANT: MF_SYSMENU         HEX: 2000
+CONSTANT: MF_HELP            HEX: 4000
+CONSTANT: MF_RIGHTJUSTIFY    HEX: 4000
+CONSTANT: MF_MOUSESELECT     HEX: 8000
 
 LIBRARY: user32
 
@@ -807,7 +829,7 @@ FUNCTION: BOOL DrawIcon ( HDC hDC, int X, int Y, HICON hIcon ) ;
 ! FUNCTION: DrawTextW
 ! FUNCTION: EditWndProc
 FUNCTION: BOOL EmptyClipboard ( ) ;
-! FUNCTION: EnableMenuItem
+FUNCTION: BOOL EnableMenuItem ( HMENU hMenu, UINT uIDEnableItem, UINT uEnable ) ;
 ! FUNCTION: EnableScrollBar
 ! FUNCTION: EnableWindow
 ! FUNCTION: EndDeferWindowPos
@@ -975,7 +997,7 @@ FUNCTION: int GetPriorityClipboardFormat ( UINT* paFormatPriorityList, int cForm
 ! FUNCTION: GetSubMenu
 ! FUNCTION: GetSysColor
 FUNCTION: HBRUSH GetSysColorBrush ( int nIndex ) ;
-! FUNCTION: GetSystemMenu
+FUNCTION: HMENU GetSystemMenu ( HWND hWnd, BOOL bRevert ) ;
 ! FUNCTION: GetSystemMetrics
 ! FUNCTION: GetTabbedTextExtentA
 ! FUNCTION: GetTabbedTextExtentW

extra/window-controls-demo/window-controls-demo.factor

@@ -7,9 +7,10 @@ CONSTANT: window-control-sets-to-test
     H{
         { "No controls" { } }
         { "Normal title bar" { normal-title-bar } }
-        { "Small title bar" { small-title-bar } }
+        { "Small title bar" { small-title-bar close-button } }
         { "Close button" { normal-title-bar close-button } }
         { "Close and minimize buttons" { normal-title-bar close-button minimize-button } }
+        { "Minimize button" { normal-title-bar minimize-button } }
         { "Close, minimize, and maximize buttons" { normal-title-bar close-button minimize-button maximize-button } }
         { "Resizable" { normal-title-bar close-button minimize-button maximize-button resize-handles } }
     }