Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
0f9b894519
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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&& ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
MAIN: pong-window
|
||||
Loading…
Reference in New Issue