+++ /dev/null
-
-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
\ No newline at end of file
projects / factor.git / blobdiff