steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

pong: Un-closurify

db4
Eduardo Cavazos 2008-12-10 13:54:41 -06:00
parent 195acdd600
commit 22fb541856
1 changed files with 66 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
extra/pong/pong.factor
View File

@ -15,6 +15,13 @@ USING: kernel accessors locals math math.intervals math.order
IN: pong 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 ) : 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 USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
! by multi-methods ! 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 } ; : pong ( -- gadget )
M: <pong> draw-gadget* ( <pong> -- ) draw>> call ; <pong> new-gadget
M: <pong> ungraft* ( <pong> -- ) t >>closed drop ; 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 | FIELD [ GADGET field>> ]
BALL [ GADGET ball>> ]
[let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ] PLAYER [ GADGET player>> ]
BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ] COMPUTER [ GADGET computer>> ] |
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 [ ( -- ) [wlet | align-player-with-mouse [ ( -- )
PLAYER PLAY-FIELD align-paddle-with-mouse ] PLAYER FIELD align-paddle-with-mouse ]
move-ball [ ( -- ) BALL 1 move-for ] move-ball [ ( -- ) BALL 1 move-for ]
@ -127,69 +143,52 @@ M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ] BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
bounce-off-wall? [ ( -- ? ) 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'. BALL FIELD in-bounds?
! This closure is intended to be placed in the 'draw' slot of a
! <pong> gadget.
[ [
BALL PLAY-FIELD in-bounds? align-player-with-mouse
[
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 move-ball
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 reaction
COMPUTER draw
PLAYER draw
BALL draw
]
when
] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround. BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
! The stack effects in the wlet expression throw BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
! off the effect for the whole word, so we reset
! it to the correct one here. ! 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 -- ? ) :: start-pong-thread ( GADGET -- )
PONG closed>> f GADGET (>>paused)
[ f ] [
[ PONG relayout-1 25 milliseconds sleep t ] [
if ; GADGET paused>>
[ f ]
:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ; [ 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 : 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