steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Matthew Willis 2009-06-19 03:02:30 +09:00
parent 89cb818dfb 5f2bced2e3
commit b11656f4a3
13 changed files with 197 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/game-input/dinput/dinput.factor
View File

@ -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

4
basis/literals/literals.factor
View File

@ -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 ;

21
basis/math/bitwise/bitwise-docs.factor Normal file → Executable file
View File

@ -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 }

10
basis/math/bitwise/bitwise.factor
View File

@ -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

4
basis/ui/backend/cocoa/cocoa.factor
View File

@ -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> ]

77
basis/ui/backend/windows/windows.factor
View File

@ -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

2
basis/ui/gadgets/worlds/worlds-docs.factor
View File

@ -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" } ;

33
basis/ui/ui-docs.factor
View File

@ -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 } "." ;

26
basis/windows/user32/user32.factor
View File

@ -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

2
extra/half-floats/half-floats-tests.factor
View File

@ -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" }

1
extra/window-controls-demo/authors.txt Executable file
View File

@ -0,0 +1 @@
Joe Groff

1
extra/window-controls-demo/summary.txt Executable file
View File

@ -0,0 +1 @@
Open windows with different control sets

43
extra/window-controls-demo/window-controls-demo.factor Executable file
View File

@ -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