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 ( -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ; USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided ! by multi-methods -TUPLE: < gadget draw closed ; +TUPLE: < gadget paused field ball player computer ; -M: pref-dim* ( -- dim ) drop { 400 400 } ; -M: draw-gadget* ( -- ) draw>> call ; -M: ungraft* ( -- ) t >>closed drop ; +: pong ( -- gadget ) + new-gadget + T{ { pos { 0 0 } } { dim { 400 400 } } } clone >>field + T{ { pos { 50 50 } } { vel { 3 4 } } } clone >>ball + T{ { pos { 200 396 } } { dim { 75 4 } } } clone >>player + T{ { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ; + +M: pref-dim* ( -- dim ) drop { 400 400 } ; +M: ungraft* ( -- ) t >>paused drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: 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{ { pos { 0 0 } } { dim { 400 400 } } } ] - BALL [ T{ { pos { 50 50 } } { vel { 3 4 } } } ] - - PLAYER [ T{ { pos { 200 396 } } { dim { 75 4 } } } ] - COMPUTER [ T{ { 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: ungraft* ( -- ) 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 - ! 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 ; - 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