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

basis/io/unix/files/freebsd/freebsd.factor

@@ -3,7 +3,8 @@
 USING: accessors alien.c-types alien.syntax combinators
 io.backend io.files io.unix.files kernel math system unix
 unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
-sequences grouping alien.strings io.encodings.utf8 ;
+sequences grouping alien.strings io.encodings.utf8
+specialized-arrays.direct.uint arrays ;
 IN: io.unix.files.freebsd
 
 TUPLE: freebsd-file-system-info < unix-file-system-info
@@ -32,7 +33,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
         [ statfs-f_asyncreads >>asyncreads ]
         [ statfs-f_namemax >>name-max ]
         [ statfs-f_owner >>owner ]
-        [ statfs-f_fsid >>id ]
+        [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
         [ statfs-f_fstypename utf8 alien>string >>type ]
         [ statfs-f_mntfromname utf8 alien>string >>device-name ]
         [ statfs-f_mntonname utf8 alien>string >>mount-point ]

basis/io/unix/files/linux/linux.factor

@@ -3,7 +3,8 @@
 USING: accessors alien.c-types alien.syntax combinators csv
 io.backend io.encodings.utf8 io.files io.streams.string
 io.unix.files kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux ;
+system unix unix.statfs.linux unix.statvfs.linux
+specialized-arrays.direct.uint arrays ;
 IN: io.unix.files.linux
 
 TUPLE: linux-file-system-info < unix-file-system-info
@@ -23,7 +24,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
         [ statfs64-f_bavail >>blocks-available ]
         [ statfs64-f_files >>files ]
         [ statfs64-f_ffree >>files-free ]
-        [ statfs64-f_fsid >>id ]
+        [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
         [ statfs64-f_namelen >>namelen ]
         [ statfs64-f_frsize >>preferred-block-size ]
         ! [ statfs64-f_spare >>spare ]

basis/io/unix/files/netbsd/netbsd.factor

@@ -3,8 +3,8 @@
 USING: alien.syntax kernel unix.stat math unix
 combinators system io.backend accessors alien.c-types
 io.encodings.utf8 alien.strings unix.types io.unix.files
-io.files unix.statvfs.netbsd unix.getfsstat.netbsd
+io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8 ;
+grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ;
 IN: io.unix.files.netbsd
 
 TUPLE: netbsd-file-system-info < unix-file-system-info
@@ -35,7 +35,7 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
         [ statvfs-f_syncwrites >>sync-writes ]
         [ statvfs-f_asyncreads >>async-reads ]
         [ statvfs-f_asyncwrites >>async-writes ]
-        [ statvfs-f_fsidx >>idx ]
+        [ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
         [ statvfs-f_fsid >>id ]
         [ statvfs-f_namemax >>name-max ]
         [ statvfs-f_owner >>owner ]

basis/io/unix/files/openbsd/openbsd.factor

@@ -3,7 +3,8 @@
 USING: accessors alien.c-types alien.strings alien.syntax
 combinators io.backend io.files io.unix.files kernel math
 sequences system unix unix.getfsstat.openbsd grouping
-unix.statfs.openbsd unix.statvfs.openbsd unix.types ;
+unix.statfs.openbsd unix.statvfs.openbsd unix.types
+specialized-arrays.direct.uint arrays ;
 IN: io.unix.files.openbsd
 
 TUPLE: freebsd-file-system-info < unix-file-system-info
@@ -30,7 +31,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
         [ statfs-f_syncreads >>sync-reads ]
         [ statfs-f_asyncwrites >>async-writes ]
         [ statfs-f_asyncreads >>async-reads ]
-        [ statfs-f_fsid >>id ]
+        [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
         [ statfs-f_namemax >>name-max ]
         [ statfs-f_owner >>owner ]
         ! [ statfs-f_spare >>spare ]

basis/ui/cocoa/views/views.factor

@@ -60,7 +60,7 @@ IN: ui.cocoa.views
     dup event-modifiers swap key-code ;
 
 : send-key-event ( view gesture -- )
-    swap window-focus propagate-gesture ;
+    swap window propagate-key-gesture ;
 
 : interpret-key-event ( view event -- )
     NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
@@ -266,30 +266,23 @@ CLASS: {
 { "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
     [
         CF>string-array NSStringPboardType swap member? [
-            >r drop window-focus gadget-selection dup [
+            [ drop window-focus gadget-selection ] dip over
-                r> set-pasteboard-string 1
+            [ set-pasteboard-string 1 ] [ 2drop 0 ] if
-            ] [
+        ] [ 3drop 0 ] if
-                r> 2drop 0
-            ] if
-        ] [
-            3drop 0
-        ] if
     ]
 }
 
 { "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
     [
         pasteboard-string dup [
-            [ drop window-focus ] dip swap user-input 1
+            [ drop window ] dip swap user-input 1
-        ] [
+        ] [ 3drop 0 ] if
-            3drop 0
-        ] if
     ]
 }
 
 ! Text input
 { "insertText:" "void" { "id" "SEL" "id" }
-    [ nip CF>string swap window-focus user-input ]
+    [ nip CF>string swap window user-input ]
 }
 
 { "hasMarkedText" "char" { "id" "SEL" }

basis/ui/gestures/gestures.factor

@@ -41,13 +41,25 @@ M: propagate-gesture send-queued-gesture
 : propagate-gesture ( gesture gadget -- )
     \ propagate-gesture queue-gesture ;
 
-TUPLE: user-input string gadget ;
+TUPLE: propagate-key-gesture gesture world ;
+
+: world-focus ( world -- gadget )
+    dup focus>> [ world-focus ] [ ] ?if ;
+
+M: propagate-key-gesture send-queued-gesture
+    [ gesture>> ] [ world>> world-focus ] bi
+    [ handle-gesture ] with each-parent drop ;
+
+: propagate-key-gesture ( gesture world -- )
+    \ propagate-key-gesture queue-gesture ;
+
+TUPLE: user-input string world ;
 
 M: user-input send-queued-gesture
-    [ string>> ] [ gadget>> ] bi
+    [ string>> ] [ world>> world-focus ] bi
     [ user-input* ] with each-parent drop ;
 
-: user-input ( string gadget -- )
+: user-input ( string world -- )
     '[ _ \ user-input queue-gesture ] unless-empty ;
 
 ! Gesture objects
@@ -261,9 +273,6 @@ SYMBOL: drag-timer
     scroll-direction set-global
     T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
 
-: world-focus ( world -- gadget )
-    dup focus>> [ world-focus ] [ ] ?if ;
-
 : send-action ( world gesture -- )
     swap world-focus propagate-gesture ;
 

basis/ui/ui.factor

@@ -140,7 +140,7 @@ SYMBOL: ui-hook
     graft-queue [ notify ] slurp-deque ;
 
 : send-queued-gestures ( -- )
-    gesture-queue [ send-queued-gesture ] slurp-deque ;
+    gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
 
 : update-ui ( -- )
     [

basis/ui/windows/windows.factor

@@ -181,7 +181,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 
 : send-key-gesture ( sym action? quot hWnd -- )
     [ [ key-modifiers ] 3dip call ] dip
-    window-focus propagate-gesture ; inline
+    window propagate-key-gesture ; inline
 
 : send-key-down ( sym action? hWnd -- )
     [ [ <key-down> ] ] dip send-key-gesture ;
@@ -213,7 +213,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
         ctrl? alt? xor [
             wParam 1string
             [ f hWnd send-key-down ]
-            [ hWnd window-focus user-input ] bi
+            [ hWnd window user-input ] bi
         ] unless
     ] unless ;
 

basis/ui/x11/x11.factor

@@ -83,8 +83,7 @@ M: world configure-event
 
 M: world key-down-event
     [ key-down-event>gesture ] keep
-    world-focus
+    [ propagate-key-gesture drop ]
-    [ propagate-gesture drop ]
     [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
     3bi ;
 
@@ -92,7 +91,7 @@ M: world key-down-event
     dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
 
 M: world key-up-event
-    [ key-up-event>gesture ] dip world-focus propagate-gesture ;
+    [ key-up-event>gesture ] dip propagate-key-gesture ;
 
 : mouse-event>gesture ( event -- modifiers button loc )
     [ event-modifiers ]
@@ -138,7 +137,7 @@ M: world focus-out-event
 
 M: world selection-notify-event
     [ handle>> window>> selection-from-event ] keep
-    world-focus user-input ;
+    world user-input ;
 
 : supported-type? ( atom -- ? )
     { "UTF8_STRING" "STRING" "TEXT" }

extra/flatland/flatland.factor

@@ -2,6 +2,7 @@
 USING: accessors arrays fry kernel math math.vectors sequences
        math.intervals
        multi-methods
+       combinators.short-circuit
        combinators.cleave.enhanced
        multi-method-syntax ;
 
@@ -218,3 +219,16 @@ USING: locals combinators ;
   cond
 
   2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: within? ( a b -- ? )
+
+METHOD: within? ( <pos> <rectangle> -- ? )
+  {
+    [ left   to-the-right-of? ]
+    [ right  to-the-left-of?  ]
+    [ bottom above?           ]
+    [ top    below?           ]
+  }
+  2&& ;

extra/pong/pong.factor

@@ -15,6 +15,13 @@ USING: kernel accessors locals math math.intervals math.order
 
 IN: pong
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 
+! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
+!
+! Which was based on this Nodebox version: http://billmill.org/pong.html
+! by Bill Mill.
+! 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : clamp-to-interval ( x interval -- x )
@@ -95,28 +102,37 @@ METHOD: draw ( <ball>   -- ) [ pos>>       ] [ diameter>> 2 / ] bi circle    ;
 USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
             ! by multi-methods
 
-TUPLE: <pong> < gadget draw closed ;
+TUPLE: <pong> < gadget paused field ball player computer ;
+
+: pong ( -- gadget )
+  <pong> new-gadget
+  T{ <play-field> { pos {   0   0 } } { dim { 400 400 } } } clone >>field
+  T{ <ball>       { pos {  50  50 } } { vel {   3   4 } } } clone >>ball
+  T{ <paddle>     { pos { 200 396 } } { dim {  75   4 } } } clone >>player
+  T{ <computer>   { pos { 200   0 } } { dim {  75   4 } } } clone >>computer ;
 
 M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> draw-gadget* ( <pong> --     ) draw>> call      ;
+M: <pong> ungraft*  ( <pong> --     ) t >>paused drop  ;
-M: <pong> ungraft*     ( <pong> --     ) t >>closed drop  ;
     
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: make-draw-closure ( -- closure )
+M:: <pong> draw-gadget* ( PONG -- )
 
-  ! Establish some bindings
+  PONG computer>> draw
+  PONG player>>   draw
+  PONG ball>>     draw ;
 
-  [let | PLAY-FIELD [ T{ <play-field> { pos {  0  0 } } { dim { 400 400 } } } ]
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-         BALL       [ T{ <ball>       { pos { 50 50 } } { vel {   3   4 } } } ]
 
-         PLAYER   [ T{ <paddle>   { pos { 200 396 } } { dim { 75 4 } } } ]
+:: iterate-system ( GADGET -- )
-         COMPUTER [ T{ <computer> { pos { 200   0 } } { dim { 75 4 } } } ] |
 
-    ! Define some internal words in terms of those bindings ...
+  [let | FIELD    [ GADGET field>>    ]
+         BALL     [ GADGET ball>>     ]
+         PLAYER   [ GADGET player>>   ]
+         COMPUTER [ GADGET computer>> ] |
 
     [wlet | align-player-with-mouse [ ( -- )
-              PLAYER PLAY-FIELD align-paddle-with-mouse ]
+              PLAYER FIELD align-paddle-with-mouse ]
 
             move-ball [ ( -- ) BALL 1 move-for ]
 
@@ -127,18 +143,13 @@ M: <pong> ungraft*     ( <pong> --     ) t >>closed drop  ;
               BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
 
             bounce-off-wall? [ ( -- ? )
-              BALL PLAY-FIELD in-between-horizontally? not ] |
+              BALL FIELD in-between-horizontally? not ]
 
-      ! Note, we're returning a quotation.
+            stop-game [ ( -- ) t GADGET (>>paused) ] |
-      ! The quotation closes over the bindings established by the 'let'.
-      ! Thus the name of the word 'make-draw-closure'.
-      ! This closure is intended to be placed in the 'draw' slot of a
-      ! <pong> gadget.
 
+      BALL FIELD in-bounds?
       [
 
-        BALL PLAY-FIELD in-bounds?
-          [
         align-player-with-mouse
 
         move-ball
@@ -153,43 +164,31 @@ M: <pong> ungraft*     ( <pong> --     ) t >>closed drop  ;
         player-blocked-ball?   [ BALL PLAYER   bounce-off-paddle  ] when
         computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle  ] when
         bounce-off-wall?       [ BALL reverse-horizontal-velocity ] when
-
-            ! draw the objects
-              
-            COMPUTER draw
-            PLAYER   draw
-            BALL     draw
-  
       ]
-        when
+      [ stop-game ]
+      if
 
-      ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
+  ] ] ( gadget -- ) ;
-                             ! The stack effects in the wlet expression throw
-                             ! off the effect for the whole word, so we reset
-                             ! it to the correct one here.
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-:: pong-loop-step ( PONG -- ? )
+:: start-pong-thread ( GADGET -- )
-  PONG closed>>
+  f GADGET (>>paused)
+  [
+    [
+      GADGET paused>>
       [ f ]
-    [ PONG relayout-1 25 milliseconds sleep t ]
+      [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
-  if ;
+      if
-
+    ]
-:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+    loop
+  ]
+  in-thread ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: play-pong ( -- )
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
 
-  <pong> new-gadget
+: pong-main ( -- ) [ pong-window ] with-ui ;
-    make-draw-closure >>draw
-  dup "PONG" open-window
 
-  start-pong-thread ;
+MAIN: pong-window
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: play-pong-main ( -- ) [ play-pong ] with-ui ;
-
-MAIN: play-pong-main