Merge branch 'master' of git://factorcode.org/git/factor

diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 0ecf543baa3af001569e254dcf08b34b00aad55c..6cd161bd28686e3dbaf36fa03e2b25dbeb5013a7 100755 (executable)
--- a/basis/game-input/dinput/dinput.factor
+++ b/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

diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor
index ba1da393b1f6fa50f5fc08664b733f8a821cb755..b954d561fa13fd2b5db1e23c5e00f854feebb214 100755 (executable)
--- a/basis/literals/literals.factor
+++ b/basis/literals/literals.factor
@@ -19,3 +19,7 @@ PRIVATE>
 SYNTAX: $ scan-word expand-literal >vector ;
 SYNTAX: $[ parse-quotation with-datastack >vector ;
 SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
+
+SYNTAX: $$
+    scan-word execute( accum -- accum ) dup pop [ >quotation ] keep
+    [ output>sequence ] 2curry call( -- object ) parsed ;

diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor
old mode 100644 (file)
new mode 100755 (executable)
index fca0652..38bccd1
--- a/basis/math/bitwise/bitwise-docs.factor
+++ b/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 }

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index ff4806348b5ade12deb50c130e3cd2197133e3e5..cea944a6e8eebef23a355176152b5b754a5ed9bc 100755 (executable)
--- a/basis/math/bitwise/bitwise.factor
+++ b/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
-sequences.private words namespaces macros hints
-combinators fry io.binary combinators.smart ;
+USING: arrays assocs kernel math sequences accessors
+math.bits sequences.private words namespaces macros
+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
 

diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index 7e78fcc8b893d4e37ec9f76b118a793d3943d2d9..e05704e623288f72edf218d3c8aedb74fb60d32d 100755 (executable)
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/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> ]

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 551d89b66c6335c1be51791301e390b45da3a336..a63837a0da6a7f94641e0401aab7c0e726825f44 100755 (executable)
--- a/basis/ui/backend/windows/windows.factor
+++ b/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
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+CONSTANT: window-control>style
+    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 -- )
-    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+: adjust-RECT ( RECT style ex-style -- )
+    [ 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-RECT
-    dup get-RECT-top-left [ zero? ] both? swap
-    dup adjust-RECT
+: make-adjusted-RECT ( rect style ex-style -- RECT )
+    [
+        make-RECT
+        dup get-RECT-top-left [ zero? ] both? swap
+        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 )
-    make-adjusted-RECT
+:: create-window ( rect style ex-style -- hwnd )
+    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 GetWindowLong
-            fullscreen-flags bitor
-        ]
-        [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
+        [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
         [
             f
             over hwnd>RECT get-RECT-dimensions

diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
index c12c6b93aac42c983b2cedc1df80ed30bc08130b..d0fd169871eb9deca394f5e796ef93cf0df8d46e 100755 (executable)
--- a/basis/ui/gadgets/worlds/worlds-docs.factor
+++ b/basis/ui/gadgets/worlds/worlds-docs.factor
@@ -56,6 +56,7 @@ HELP: world
         { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
         { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
         { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
+        { { $snippet "window-controls" } " - the set of " { $link "ui.gadgets.worlds-window-controls" } " with which the world window was created." }
     }
 } ;
 
@@ -113,3 +114,4 @@ $nl
 { $subsection "ui.gadgets.worlds-subclassing" }
 { $subsection "gl-utilities" }
 { $subsection "text-rendering" } ;
+

diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index 7e832659264aa1c68e083f79ad35bc8365baceb3..b381c4e677d3d51725ebed397621626b0756c219 100644 (file)
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -14,6 +14,10 @@ HELP: open-window
 { $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
 { $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
 
+HELP: close-window
+{ $values { "gadget" gadget } }
+{ $description "Close the native window containing " { $snippet "gadget" } "." } ;
+
 HELP: world-attributes
 { $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
 { $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
@@ -23,6 +27,7 @@ HELP: world-attributes
     { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
     { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
     { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
+    { { $snippet "window-controls" } " is a sequence of " { $link "ui.gadgets.worlds-window-controls" } " that will be placed in the window." }
 } ;
 
 HELP: set-fullscreen
@@ -262,3 +267,31 @@ ARTICLE: "ui" "UI framework"
 { $subsection "ui-backend" } ;
 
 ABOUT: "ui"
+
+HELP: close-button
+{ $description "Asks for a close button to be available for a window. Without a close button, a window cannot be closed by the user and must be closed by the program using " { $link close-window } "." } ;
+
+HELP: minimize-button
+{ $description "Asks for a minimize button to be available for a window." } ;
+
+HELP: maximize-button
+{ $description "Asks for a maximize button to be available for a window." } ;
+
+HELP: resize-handles
+{ $description "Asks for resize controls to be available for a window. Without resize controls, the window size will not be changeable by the user." } ;
+
+HELP: small-title-bar
+{ $description "Asks for a window to have a small title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available. A small title bar may have other side effects in the window system, such as causing the window to not show up in the system task switcher and to float over other Factor windows." } ;
+
+HELP: normal-title-bar
+{ $description "Asks for a window to have a title bar. Without a title bar, the " { $link close-button } ", " { $link minimize-button } ", and " { $link maximize-button } " controls will not be available." } ;
+
+ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
+"The following window controls can be placed in a " { $link world } " window:"
+{ $subsection close-button }
+{ $subsection minimize-button }
+{ $subsection maximize-button }
+{ $subsection resize-handles }
+{ $subsection small-title-bar }
+{ $subsection normal-title-bar }
+"Provide a sequence of these values in the " { $snippet "window-controls" } " slot of the " { $link world-attributes } " tuple you pass to " { $link open-window } "." ;

diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor
index 227269595335e215a89b6da9cb18a517d7e825f8..40c10d0f5b69a59d984501ba0461f05a2d8311f5 100755 (executable)
--- a/basis/windows/user32/user32.factor
+++ b/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

diff --git a/extra/half-floats/half-floats-tests.factor b/extra/half-floats/half-floats-tests.factor
index d026ca2933696b854c3cf9f79dd55983292eaf0c..001cc6200b57141968c5f702e9ad7f4a524b763c 100644 (file)
--- a/extra/half-floats/half-floats-tests.factor
+++ b/extra/half-floats/half-floats-tests.factor
@@ -25,7 +25,7 @@ IN: half-floats.tests
 [ -1.5  ] [ HEX: be00 bits>half ] unit-test
 [  1/0. ] [ HEX: 7c00 bits>half ] unit-test
 [ -1/0. ] [ HEX: fc00 bits>half ] unit-test
-[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+[    t  ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
 
 C-STRUCT: halves
     { "half" "tom" }

diff --git a/extra/window-controls-demo/authors.txt b/extra/window-controls-demo/authors.txt
new file mode 100755 (executable)
index 0000000..f13c9c1
--- /dev/null
+++ b/extra/window-controls-demo/authors.txt
@@ -0,0 +1 @@
+Joe Groff

diff --git a/extra/window-controls-demo/summary.txt b/extra/window-controls-demo/summary.txt
new file mode 100755 (executable)
index 0000000..e84535a
--- /dev/null
+++ b/extra/window-controls-demo/summary.txt
@@ -0,0 +1 @@
+Open windows with different control sets

diff --git a/extra/window-controls-demo/window-controls-demo.factor b/extra/window-controls-demo/window-controls-demo.factor
new file mode 100755 (executable)
index 0000000..89e4c70
--- /dev/null
+++ b/extra/window-controls-demo/window-controls-demo.factor
@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs kernel locals sequences ui
+ui.gadgets ui.gadgets.worlds ;
+IN: window-controls-demo
+
+CONSTANT: window-control-sets-to-test
+    H{
+        { "No controls" { } }
+        { "Normal title bar" { normal-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 } }
+    }
+
+TUPLE: window-controls-demo-world < world
+    windows ;
+
+M: window-controls-demo-world end-world
+    windows>> [ close-window ] each ;
+
+M: window-controls-demo-world pref-dim*
+    drop { 400 400 } ;
+
+: attributes-template ( -- x )
+    T{ world-attributes
+        { world-class window-controls-demo-world }
+    } clone ;
+
+: window-controls-demo ( -- )
+    attributes-template V{ } clone window-control-sets-to-test
+    [| title attributes windows controls |
+        f attributes
+            title >>title
+            controls >>window-controls
+        open-window*
+            windows >>windows
+            windows push
+    ] with with assoc-each ;
+
+MAIN: window-controls-demo