--- /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
+++ /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 / commitdiff