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

basis/core-graphics/core-graphics.factor

@@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
 
 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
 
+FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
+
+FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
+FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
+
+FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
+
+FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
+
 <PRIVATE
 
 : bitmap-flags ( -- flags )

basis/core-graphics/types/types.factor

@@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
 TYPEDEF: uint CGBitmapInfo
 
 TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
 TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
+TYPEDEF: int CGLContextParameter

basis/math/rectangles/rectangles.factor

@@ -21,6 +21,8 @@ M: rect pprint*
 
 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
 
+: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
+
 : with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
     [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
 

basis/ui/backend/backend.factor

@@ -31,4 +31,8 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
     '[ select-gl-context @ ]
     [ flush-gl-context gl-error ] bi ; inline
 
-HOOK: (with-ui) ui-backend ( quot -- )
+HOOK: (with-ui) ui-backend ( quot -- )
+
+HOOK: (grab-input) ui-backend ( handle -- )
+
+HOOK: (ungrab-input) ui-backend ( handle -- )

basis/ui/backend/cocoa/cocoa.factor

@@ -122,6 +122,17 @@ M:: cocoa-ui-backend (open-window) ( world -- )
 M: cocoa-ui-backend (close-window) ( handle -- )
     window>> -> release ;
 
+M: cocoa-ui-backend (grab-input) ( handle -- )
+    0 CGAssociateMouseAndMouseCursorPosition drop
+    CGMainDisplayID CGDisplayHideCursor drop
+    window>> -> frame CGRect>rect rect-center
+    first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+
+M: cocoa-ui-backend (ungrab-input) ( handle -- )
+    drop
+    CGMainDisplayID CGDisplayShowCursor drop
+    1 CGAssociateMouseAndMouseCursorPosition drop ;
+
 M: cocoa-ui-backend close-window ( gadget -- )
     find-world [
         handle>> [

basis/ui/backend/windows/windows.factor

@@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
 command-line shuffle opengl ui.render ascii math.bitwise locals
 accessors math.rectangles math.order ascii calendar
 io.encodings.utf16n windows.errors literals ui.pixel-formats 
-ui.pixel-formats.private memoize classes ;
+ui.pixel-formats.private memoize classes struct-arrays ;
 IN: ui.backend.windows
 
 SINGLETON: windows-ui-backend
@@ -703,9 +703,23 @@ M: windows-ui-backend beep ( -- )
     "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
     [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
 
+: client-area>RECT ( hwnd -- RECT )
+    "RECT" <c-object>
+    [ GetClientRect win32-error=0/f ]
+    [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+    [ nip ] 2tri ;
+
 : hwnd>RECT ( hwnd -- RECT )
     "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
 
+M: windows-ui-backend (grab-input) ( handle -- )
+    0 ShowCursor drop
+    hWnd>> client-area>RECT ClipCursor drop ;
+M: windows-ui-backend (ungrab-input) ( handle -- )
+    drop
+    f ClipCursor drop
+    1 ShowCursor drop ;
+
 : fullscreen-flags ( -- n )
     { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
 

basis/ui/gadgets/worlds/worlds.factor

@@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes
     { windowed double-buffered T{ depth-bits { value 16 } } }
 
 TUPLE: world < track
-    active? focused?
+    active? focused? grab-input?
     layers
     title status status-owner
     text-handle handle images
@@ -20,6 +20,7 @@ TUPLE: world < track
 
 TUPLE: world-attributes
     { world-class initial: world }
+    grab-input?
     title
     status
     gadgets
@@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- )
     vertical swap new-track
         t >>root?
         t >>active?
-        { 0 0 } >>window-loc ;
+        { 0 0 } >>window-loc
+        f >>grab-input? ;
 
 : apply-world-attributes ( world attributes -- world )
     {
         [ title>> >>title ]
         [ status>> >>status ]
         [ pixel-format-attributes>> >>pixel-format-attributes ]
+        [ grab-input?>> >>grab-input? ]
         [ gadgets>> [ 1 track-add ] each ]
     } cleave ;
 

basis/ui/ui.factor

@@ -41,14 +41,23 @@ SYMBOL: windows
     lose-focus swap each-gesture
     gain-focus swap each-gesture ;
 
+: ?grab-input ( world -- )
+    dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
+
+: ?ungrab-input ( world -- )
+    dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
+
 : focus-world ( world -- )
     t >>focused?
-    dup raised-window
+    [ ?grab-input ] [
-    focus-path f focus-gestures ;
+        dup raised-window
+        focus-path f focus-gestures
+    ] bi ;
 
 : unfocus-world ( world -- )
     f >>focused?
-    focus-path f swap focus-gestures ;
+    [ ?ungrab-input ]
+    [ focus-path f swap focus-gestures ] bi ;
 
 : try-to-open-window ( world -- )
     {

basis/windows/user32/user32.factor

@@ -652,9 +652,9 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ;
 FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
 ! FUNCTION: ChildWindowFromPointEx
 ! FUNCTION: ClientThreadSetup
-! FUNCTION: ClientToScreen
+FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ;
 ! FUNCTION: CliImmSetHotKey
-! FUNCTION: ClipCursor
+FUNCTION: int ClipCursor ( RECT* clipRect ) ;
 FUNCTION: BOOL CloseClipboard ( ) ;
 ! FUNCTION: CloseDesktop
 ! FUNCTION: CloseWindow
@@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f
 ! FUNCTION: SetWindowWord
 ! FUNCTION: SetWinEventHook
 ! FUNCTION: ShowCaret
-! FUNCTION: ShowCursor
+FUNCTION: int ShowCursor ( BOOL show ) ;
 ! FUNCTION: ShowOwnedPopups
 ! FUNCTION: ShowScrollBar
 ! FUNCTION: ShowStartGlass

extra/game-input/game-input-docs.factor

@@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input"
 { $subsection mouse-state } ;
 
 HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
 
 HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
 
 HELP: game-input-opened?
 { $values { "?" "a boolean" } }

extra/game-input/game-input.factor

@@ -1,34 +1,57 @@
-USING: arrays accessors continuations kernel system
+USING: arrays accessors continuations kernel math system
 sequences namespaces init vocabs vocabs.loader combinators ;
 IN: game-input
 
 SYMBOLS: game-input-backend game-input-opened ;
 
+game-input-opened [ 0 ] initialize
+
 HOOK: (open-game-input)  game-input-backend ( -- )
 HOOK: (close-game-input) game-input-backend ( -- )
 HOOK: (reset-game-input) game-input-backend ( -- )
 
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
 : game-input-opened? ( -- ? )
-    game-input-opened get ;
+    game-input-opened get zero? not ;
 
 <PRIVATE
 
 M: f (reset-game-input) ;
 
 : reset-game-input ( -- )
-    game-input-opened off
     (reset-game-input) ;
 
 [ reset-game-input ] "game-input" add-init-hook
 
 PRIVATE>
 
+ERROR: game-input-not-open ;
+
 : open-game-input ( -- )
     game-input-opened? [
         (open-game-input) 
-        game-input-opened on
+    ] unless
-    ] unless ;
+    game-input-opened [ 1+ ] change-global
+    reset-mouse ;
 : close-game-input ( -- )
+    game-input-opened [
+        dup zero? [ game-input-not-open ] when
+        1-
+    ] change-global
     game-input-opened? [
         (close-game-input) 
         reset-game-input
@@ -48,12 +71,6 @@ SYMBOLS:
     pov-up pov-up-right pov-right pov-down-right
     pov-down pov-down-left pov-left pov-up-left ;
 
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
 : find-controller-products ( product-id -- sequence )
     get-controllers [ product-id = ] with filter ;
 : find-controller-instance ( product-id instance-id -- controller/f )
@@ -63,25 +80,16 @@ HOOK: instance-id game-input-backend ( controller -- id )
         [ instance-id = ] 2bi* and
     ] with with find nip ;
 
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
 TUPLE: keyboard-state keys ;
 
 M: keyboard-state clone
     call-next-method dup keys>> clone >>keys ;
 
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-
 TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
 
 M: mouse-state clone
     call-next-method dup buttons>> clone >>buttons ;
 
-HOOK: read-mouse game-input-backend ( -- mouse-state )
-
-HOOK: reset-mouse game-input-backend ( -- )
-
 {
     { [ os windows? ] [ "game-input.dinput" require ] }
     { [ os macosx? ] [ "game-input.iokit" require ] }

extra/key-caps/key-caps.factor

@@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
     relayout-1 ;
 
 M: key-caps-gadget graft*
+    open-game-input
     dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
     drop ;
 
 M: key-caps-gadget ungraft*
-    alarm>> [ cancel-alarm ] when* ;
+    alarm>> [ cancel-alarm ] when*
+    close-game-input ;
 
 M: key-caps-gadget handle-gesture
     drop [ key-down? ] [ key-up? ] bi or not ;
 
 : key-caps ( -- )
     [
-        open-game-input
         <key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
     ] with-ui ;
 

extra/terrain/terrain.factor

@@ -10,7 +10,7 @@ IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
 CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
-CONSTANT: FAR-PLANE 1.0
+CONSTANT: FAR-PLANE 2.0
 CONSTANT: EYE-START { 0.5 0.5 1.2 }
 CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
 CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
@@ -111,6 +111,7 @@ TUPLE: terrain-world < world
     key-s keys nth [ world move-backward ] when 
     key-a keys nth [ world move-leftward ] when 
     key-d keys nth [ world move-rightward ] when 
+    key-escape keys nth [ world close-window ] when
     world read-mouse rotate-with-mouse
     reset-mouse ;
 
@@ -126,8 +127,8 @@ M: terrain-world draw*
     GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
-    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ;
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
 
 M: terrain-world begin-world
     "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
@@ -146,10 +147,11 @@ M: terrain-world begin-world
     >>terrain-program
     vertex-array >vertex-buffer >>terrain-vertex-buffer
     TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
-    reset-mouse
+    open-game-input
     drop ;
 
 M: terrain-world end-world
+    close-game-input
     {
         [ game-loop>> stop-loop ]
         [ terrain-vertex-buffer>> delete-gl-buffer ]
@@ -177,7 +179,6 @@ M: terrain-world pref-dim* drop { 640 480 } ;
 
 : terrain-window ( -- )
     [
-        open-game-input
         f T{ world-attributes
             { world-class terrain-world }
             { title "Terrain" }
@@ -186,5 +187,6 @@ M: terrain-world pref-dim* drop { 640 480 } ;
                 double-buffered
                 T{ depth-bits { value 24 } }
             } }
+            { grab-input? t }
         } open-window
     ] with-ui ;