Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
a02b8521dd
|
|
@ -75,3 +75,7 @@ IN: dlists.tests
|
|||
dup clone 3 over push-back
|
||||
[ dlist>seq ] bi@
|
||||
] unit-test
|
||||
|
||||
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
|
||||
|
||||
[ V{ } ] [ <dlist> dlist>seq ] unit-test
|
||||
|
|
|
|||
|
|
@ -154,7 +154,7 @@ M: dlist clear-deque ( dlist -- )
|
|||
[ obj>> ] prepose dlist-each-node ; inline
|
||||
|
||||
: dlist>seq ( dlist -- seq )
|
||||
[ ] pusher [ dlist-each ] dip ;
|
||||
[ drop t ] pusher [ dlist-each ] dip ;
|
||||
|
||||
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -28,9 +28,6 @@ M: linked-assoc set-at
|
|||
[ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
|
||||
assoc>> set-at ;
|
||||
|
||||
: dlist>seq ( dlist -- seq )
|
||||
[ ] pusher [ dlist-each ] dip ;
|
||||
|
||||
M: linked-assoc >alist
|
||||
dlist>> dlist>seq ;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
|
|||
[ first ] [ ] bi exec-with-path ;
|
||||
|
||||
: exec-args-with-env ( seq seq -- int )
|
||||
>r [ first ] [ ] bi r> exec-with-env ;
|
||||
[ [ first ] [ ] bi ] dip exec-with-env ;
|
||||
|
||||
: with-fork ( child parent -- )
|
||||
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
|
||||
|
|
|
|||
|
|
@ -31,8 +31,8 @@ C-STRUCT: statvfs
|
|||
{ "uid_t" "f_owner" }
|
||||
{ { "uint32_t" 4 } "f_spare" }
|
||||
{ { "char" _VFS_NAMELEN } "f_fstypename" }
|
||||
{ { "char" _VFS_NAMELEN } "f_mntonname" }
|
||||
{ { "char" _VFS_NAMELEN } "f_mntfromname" } ;
|
||||
{ { "char" _VFS_MNAMELEN } "f_mntonname" }
|
||||
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
|
||||
|
||||
FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -198,10 +198,10 @@ FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
|
|||
: PATH_MAX 1024 ; inline
|
||||
|
||||
: read-symbolic-link ( path -- path )
|
||||
PATH_MAX <byte-array> dup >r
|
||||
PATH_MAX
|
||||
[ readlink ] unix-system-call
|
||||
r> swap head-slice >string ;
|
||||
PATH_MAX <byte-array> dup [
|
||||
PATH_MAX
|
||||
[ readlink ] unix-system-call
|
||||
] dip swap head-slice >string ;
|
||||
|
||||
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
|
||||
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
|
||||
|
|
|
|||
|
|
@ -6,18 +6,18 @@ USING: kernel namespaces
|
|||
math.order
|
||||
math.vectors
|
||||
math.trig
|
||||
math.physics.pos
|
||||
math.physics.vel
|
||||
math.ranges
|
||||
combinators arrays sequences random vars
|
||||
combinators.lib
|
||||
combinators.short-circuit
|
||||
accessors ;
|
||||
accessors
|
||||
flatland ;
|
||||
|
||||
IN: boids
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: boid < vel ;
|
||||
TUPLE: boid < <vel> ;
|
||||
|
||||
C: <boid> boid
|
||||
|
||||
|
|
@ -62,11 +62,9 @@ VAR: separation-radius
|
|||
! random-boid and random-boids
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: random-range ( a b -- n ) 1+ over - random + ;
|
||||
|
||||
: random-pos ( -- pos ) world-size> [ random ] map ;
|
||||
|
||||
: random-vel ( -- vel ) 2 [ drop -10 10 random-range ] map ;
|
||||
: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ;
|
||||
|
||||
: random-boid ( -- boid ) random-pos random-vel <boid> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
|
||||
USING: combinators.cleave fry kernel macros parser quotations ;
|
||||
|
||||
IN: combinators.cleave.enhanced
|
||||
|
||||
: \\
|
||||
scan-word literalize parsed
|
||||
scan-word literalize parsed ; parsing
|
||||
|
||||
MACRO: bi ( p q -- quot )
|
||||
[ >quot ] dip
|
||||
>quot
|
||||
'[ _ _ [ keep ] dip call ] ;
|
||||
|
||||
MACRO: tri ( p q r -- quot )
|
||||
[ >quot ] 2dip
|
||||
[ >quot ] dip
|
||||
>quot
|
||||
'[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
|
||||
|
||||
MACRO: bi* ( p q -- quot )
|
||||
[ >quot ] dip
|
||||
>quot
|
||||
'[ _ _ [ dip ] dip call ] ;
|
||||
|
||||
MACRO: tri* ( p q r -- quot )
|
||||
[ >quot ] 2dip
|
||||
[ >quot ] dip
|
||||
>quot
|
||||
'[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
|
||||
|
||||
|
|
@ -0,0 +1,178 @@
|
|||
|
||||
USING: accessors arrays fry kernel math math.vectors sequences
|
||||
math.intervals
|
||||
multi-methods
|
||||
combinators.cleave.enhanced
|
||||
multi-method-syntax ;
|
||||
|
||||
IN: flatland
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Two dimensional world protocol
|
||||
|
||||
GENERIC: x ( obj -- x )
|
||||
GENERIC: y ( obj -- y )
|
||||
|
||||
GENERIC: (x!) ( x obj -- )
|
||||
GENERIC: (y!) ( y obj -- )
|
||||
|
||||
: x! ( obj x -- obj ) over (x!) ;
|
||||
: y! ( obj y -- obj ) over (y!) ;
|
||||
|
||||
GENERIC: width ( obj -- width )
|
||||
GENERIC: height ( obj -- height )
|
||||
|
||||
GENERIC: (width!) ( width obj -- )
|
||||
GENERIC: (height!) ( height obj -- )
|
||||
|
||||
: width! ( obj width -- obj ) over (width!) ;
|
||||
: height! ( obj height -- obj ) over (width!) ;
|
||||
|
||||
! Predicates on relative placement
|
||||
|
||||
GENERIC: to-the-left-of? ( obj obj -- ? )
|
||||
GENERIC: to-the-right-of? ( obj obj -- ? )
|
||||
|
||||
GENERIC: below? ( obj obj -- ? )
|
||||
GENERIC: above? ( obj obj -- ? )
|
||||
|
||||
GENERIC: in-between-horizontally? ( obj obj -- ? )
|
||||
|
||||
GENERIC: horizontal-interval ( obj -- interval )
|
||||
|
||||
GENERIC: move-to ( obj obj -- )
|
||||
|
||||
GENERIC: move-by ( obj delta -- )
|
||||
|
||||
GENERIC: move-left-by ( obj obj -- )
|
||||
GENERIC: move-right-by ( obj obj -- )
|
||||
|
||||
GENERIC: left ( obj -- left )
|
||||
GENERIC: right ( obj -- right )
|
||||
GENERIC: bottom ( obj -- bottom )
|
||||
GENERIC: top ( obj -- top )
|
||||
|
||||
GENERIC: distance ( a b -- c )
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Some of the above methods work on two element sequences.
|
||||
! A two element sequence may represent a point in space or describe
|
||||
! width and height.
|
||||
|
||||
METHOD: x ( sequence -- x ) first ;
|
||||
METHOD: y ( sequence -- y ) second ;
|
||||
|
||||
METHOD: (x!) ( number sequence -- ) set-first ;
|
||||
METHOD: (y!) ( number sequence -- ) set-second ;
|
||||
|
||||
METHOD: width ( sequence -- width ) first ;
|
||||
METHOD: height ( sequence -- height ) second ;
|
||||
|
||||
: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
|
||||
: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
|
||||
|
||||
METHOD: move-to ( sequence sequence -- ) [ x x! ] [ y y! ] bi drop ;
|
||||
METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
|
||||
|
||||
METHOD: move-left-by ( sequence number -- ) '[ _ - ] changed-x ;
|
||||
METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
|
||||
|
||||
! METHOD: move-left-by ( sequence number -- ) neg 0 2array move-by ;
|
||||
! METHOD: move-right-by ( sequence number -- ) 0 2array move-by ;
|
||||
|
||||
! METHOD:: move-left-by ( SEQ:sequence X:number -- )
|
||||
! SEQ { X 0 } { -1 0 } v* move-by ;
|
||||
|
||||
METHOD: distance ( sequence sequence -- dist ) v- norm ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! A class for objects with a position
|
||||
|
||||
TUPLE: <pos> pos ;
|
||||
|
||||
METHOD: x ( <pos> -- x ) pos>> first ;
|
||||
METHOD: y ( <pos> -- y ) pos>> second ;
|
||||
|
||||
METHOD: (x!) ( number <pos> -- ) pos>> set-first ;
|
||||
METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
|
||||
|
||||
METHOD: to-the-left-of? ( <pos> number -- ? ) [ x ] dip < ;
|
||||
METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
|
||||
|
||||
METHOD: move-left-by ( <pos> number -- ) [ pos>> ] dip move-left-by ;
|
||||
METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
|
||||
|
||||
METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
|
||||
METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
|
||||
|
||||
METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
|
||||
|
||||
METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! A class for objects with velocity. It inherits from <pos>. Hey, if
|
||||
! it's moving it has a position right? Unless it's some alternate universe...
|
||||
|
||||
TUPLE: <vel> < <pos> vel ;
|
||||
|
||||
: moving-up? ( obj -- ? ) vel>> y 0 > ;
|
||||
: moving-down? ( obj -- ? ) vel>> y 0 < ;
|
||||
|
||||
: step-size ( vel time -- dist ) [ vel>> ] dip v*n ;
|
||||
: move-for ( vel time -- ) dupd step-size move-by ;
|
||||
|
||||
: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! The 'pos' slot indicates the lower left hand corner of the
|
||||
! rectangle. The 'dim' is holds the width and height.
|
||||
|
||||
TUPLE: <rectangle> < <pos> dim ;
|
||||
|
||||
METHOD: width ( <rectangle> -- width ) dim>> first ;
|
||||
METHOD: height ( <rectangle> -- height ) dim>> second ;
|
||||
|
||||
METHOD: left ( <rectangle> -- x ) x ;
|
||||
METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
|
||||
METHOD: bottom ( <rectangle> -- y ) y ;
|
||||
METHOD: top ( <rectangle> -- y ) \\ y height bi + ;
|
||||
|
||||
: bottom-left ( rectangle -- pos ) pos>> ;
|
||||
|
||||
: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ;
|
||||
: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
|
||||
|
||||
: center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
|
||||
|
||||
METHOD: to-the-left-of? ( <pos> <rectangle> -- ? ) \\ x left bi* < ;
|
||||
METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
|
||||
|
||||
METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
|
||||
METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top bi* > ;
|
||||
|
||||
METHOD: horizontal-interval ( <rectangle> -- interval )
|
||||
\\ left right bi [a,b] ;
|
||||
|
||||
METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
|
||||
\\ x horizontal-interval bi* interval-contains? ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <extent> left right bottom top ;
|
||||
|
||||
METHOD: left ( <extent> -- left ) left>> ;
|
||||
METHOD: right ( <extent> -- right ) right>> ;
|
||||
METHOD: bottom ( <extent> -- bottom ) bottom>> ;
|
||||
METHOD: top ( <extent> -- top ) top>> ;
|
||||
|
||||
METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
|
||||
METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
|
||||
|
||||
! METHOD: to-extent ( <rectangle> -- <extent> )
|
||||
! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
|
||||
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
|
||||
USING: accessors effects.parser kernel lexer multi-methods
|
||||
parser sequences words ;
|
||||
|
||||
IN: multi-method-syntax
|
||||
|
||||
! A nicer specializer syntax to hold us over till multi-methods go in
|
||||
! officially.
|
||||
!
|
||||
! Use both 'multi-methods' and 'multi-method-syntax' in that order.
|
||||
|
||||
: scan-specializer ( -- specializer )
|
||||
|
||||
scan drop ! eat opening parenthesis
|
||||
|
||||
")" parse-effect in>> [ search ] map ;
|
||||
|
||||
: CREATE-METHOD ( -- method )
|
||||
scan-word scan-specializer swap create-method-in ;
|
||||
|
||||
: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
|
||||
|
||||
: METHOD: (METHOD:) define ; parsing
|
||||
|
|
@ -0,0 +1,195 @@
|
|||
|
||||
USING: kernel accessors locals math math.intervals math.order
|
||||
namespaces sequences threads
|
||||
ui
|
||||
ui.gadgets
|
||||
ui.gestures
|
||||
ui.render
|
||||
calendar
|
||||
multi-methods
|
||||
multi-method-syntax
|
||||
combinators.short-circuit.smart
|
||||
combinators.cleave.enhanced
|
||||
processing.shapes
|
||||
flatland ;
|
||||
|
||||
IN: pong
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: clamp-to-interval ( x interval -- x )
|
||||
[ from>> first max ] [ to>> first min ] bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <play-field> < <rectangle> ;
|
||||
TUPLE: <paddle> < <rectangle> ;
|
||||
|
||||
TUPLE: <computer> < <paddle> { speed initial: 10 } ;
|
||||
|
||||
: computer-move-left ( computer -- ) dup speed>> move-left-by ;
|
||||
: computer-move-right ( computer -- ) dup speed>> move-right-by ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <ball> < <vel>
|
||||
{ diameter initial: 20 }
|
||||
{ bounciness initial: 1.2 }
|
||||
{ max-speed initial: 10 } ;
|
||||
|
||||
: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
|
||||
: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
|
||||
|
||||
: in-bounds? ( ball field -- ? )
|
||||
{
|
||||
[ above-lower-bound? ]
|
||||
[ below-upper-bound? ]
|
||||
} && ;
|
||||
|
||||
:: bounce-change-vertical-velocity ( BALL -- )
|
||||
|
||||
BALL vel>> y neg
|
||||
BALL bounciness>> *
|
||||
|
||||
BALL max-speed>> min
|
||||
|
||||
BALL vel>> (y!) ;
|
||||
|
||||
:: bounce-off-paddle ( BALL PADDLE -- )
|
||||
|
||||
BALL bounce-change-vertical-velocity
|
||||
|
||||
BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
|
||||
|
||||
PADDLE top BALL pos>> (y!) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: mouse-x ( -- x ) hand-loc get first ;
|
||||
|
||||
:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
|
||||
|
||||
PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
|
||||
|
||||
:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
|
||||
|
||||
mouse-x
|
||||
|
||||
PADDLE PLAY-FIELD valid-paddle-interval
|
||||
|
||||
clamp-to-interval
|
||||
|
||||
PADDLE pos>> (x!) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Protocol for drawing PONG objects
|
||||
|
||||
GENERIC: draw ( obj -- )
|
||||
|
||||
METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
|
||||
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 ;
|
||||
|
||||
M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
|
||||
M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
|
||||
M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-draw-closure ( -- closure )
|
||||
|
||||
! 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 ...
|
||||
|
||||
[wlet | align-player-with-mouse [ ( -- )
|
||||
PLAYER PLAY-FIELD align-paddle-with-mouse ]
|
||||
|
||||
move-ball [ ( -- ) BALL 1 move-for ]
|
||||
|
||||
player-blocked-ball? [ ( -- ? )
|
||||
BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
|
||||
|
||||
computer-blocked-ball? [ ( -- ? )
|
||||
BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
|
||||
|
||||
bounce-off-wall? [ ( -- ? )
|
||||
BALL PLAY-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.
|
||||
|
||||
[
|
||||
|
||||
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
|
||||
|
||||
! 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
|
||||
|
||||
! draw the objects
|
||||
|
||||
COMPUTER draw
|
||||
PLAYER draw
|
||||
BALL draw
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
] ] ] ( -- 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.
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: 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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: play-pong ( -- )
|
||||
|
||||
<pong> new-gadget
|
||||
make-draw-closure >>draw
|
||||
dup "PONG" open-window
|
||||
|
||||
start-pong-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: play-pong-main ( -- ) [ play-pong ] with-ui ;
|
||||
|
||||
MAIN: play-pong-main
|
||||
Loading…
Reference in New Issue