diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor
index 3786a82b55..eaf217af62 100644
--- a/basis/io/unix/files/freebsd/freebsd.factor
+++ b/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 ]
diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor
index 3e4e1c043a..c30855c3ee 100644
--- a/basis/io/unix/files/linux/linux.factor
+++ b/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 ]
diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor
index 23717b41a4..82ac3dc70d 100644
--- a/basis/io/unix/files/netbsd/netbsd.factor
+++ b/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
-grouping sequences io.encodings.utf8 ;
+io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays
+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 ]
diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor
index 8c8f7c154b..e5e18b29ea 100644
--- a/basis/io/unix/files/openbsd/openbsd.factor
+++ b/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 ]
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
index 128fdceeb4..7bb9679132 100644
--- a/basis/ui/cocoa/views/views.factor
+++ b/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 [
- r> set-pasteboard-string 1
- ] [
- r> 2drop 0
- ] if
- ] [
- 3drop 0
- ] if
+ [ drop window-focus gadget-selection ] dip over
+ [ set-pasteboard-string 1 ] [ 2drop 0 ] if
+ ] [ 3drop 0 ] if
]
}
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
- [ drop window-focus ] dip swap user-input 1
- ] [
- 3drop 0
- ] if
+ [ drop window ] dip swap user-input 1
+ ] [ 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" }
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 5faaa93292..123a7620d1 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/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 ;
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 88f0a353b9..d9ff287014 100644
--- a/basis/ui/ui.factor
+++ b/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 ( -- )
[
diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor
index 0510e21f17..10539df8e7 100755
--- a/basis/ui/windows/windows.factor
+++ b/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 ;
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index a532a13b69..b4a0427ccd 100755
--- a/basis/ui/x11/x11.factor
+++ b/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-gesture drop ]
+ [ propagate-key-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" }
diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor
index c98c5a6c57..72d9e50a9d 100644
--- a/extra/flatland/flatland.factor
+++ b/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&& ;
diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor
index befb64a7a7..3f7626074a 100644
--- a/extra/pong/pong.factor
+++ b/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 ;
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
-M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
+: 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> ungraft* ( <pong> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <pong> draw-gadget* ( PONG -- )
+
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: make-draw-closure ( -- closure )
+:: iterate-system ( GADGET -- )
- ! Establish some bindings
-
- [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 } } } ]
- 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,69 +143,52 @@ 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.
- ! 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.
-
+ stop-game [ ( -- ) t GADGET (>>paused) ] |
+
+ BALL FIELD in-bounds?
[
- BALL PLAY-FIELD in-bounds?
- [
- align-player-with-mouse
-
- move-ball
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+ align-player-with-mouse
- ! check if ball bounced off something
-
- 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
+ move-ball
- ! draw the objects
-
- COMPUTER draw
- PLAYER draw
- BALL draw
-
- ]
- when
+ ! computer reaction
- ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
- ! The stack effects in the wlet expression throw
- ! off the effect for the whole word, so we reset
- ! it to the correct one here.
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ 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
+ ]
+ [ stop-game ]
+ if
+
+ ] ] ( gadget -- ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-:: pong-loop-step ( PONG -- ? )
- PONG closed>>
- [ f ]
- [ PONG relayout-1 25 milliseconds sleep t ]
- if ;
-
-:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+:: start-pong-thread ( GADGET -- )
+ f GADGET (>>paused)
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: play-pong ( -- )
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
- <pong> new-gadget
- make-draw-closure >>draw
- dup "PONG" open-window
-
- start-pong-thread ;
+: pong-main ( -- ) [ pong-window ] with-ui ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: play-pong-main ( -- ) [ play-pong ] with-ui ;
-
-MAIN: play-pong-main
\ No newline at end of file
+MAIN: pong-window
\ No newline at end of file