2 USING: kernel accessors locals math math.intervals math.order
3 namespaces sequences threads
11 combinators.short-circuit.smart
12 combinators.cleave.enhanced
18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
20 : clamp-to-interval ( x interval -- x )
21 [ from>> first max ] [ to>> first min ] bi ;
23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
25 TUPLE: <play-field> < <rectangle> ;
26 TUPLE: <paddle> < <rectangle> ;
28 TUPLE: <computer> < <paddle> { speed initial: 10 } ;
30 : computer-move-left ( computer -- ) dup speed>> move-left-by ;
31 : computer-move-right ( computer -- ) dup speed>> move-right-by ;
33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
36 { diameter initial: 20 }
37 { bounciness initial: 1.2 }
38 { max-speed initial: 10 } ;
40 : above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
41 : below-upper-bound? ( ball field -- ? ) top 50 + below? ;
43 : in-bounds? ( ball field -- ? )
45 [ above-lower-bound? ]
46 [ below-upper-bound? ]
49 :: bounce-change-vertical-velocity ( BALL -- )
58 :: bounce-off-paddle ( BALL PADDLE -- )
60 BALL bounce-change-vertical-velocity
62 BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
64 PADDLE top BALL pos>> (y!) ;
66 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
68 : mouse-x ( -- x ) hand-loc get first ;
70 :: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
72 PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
74 :: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
78 PADDLE PLAY-FIELD valid-paddle-interval
84 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
86 ! Protocol for drawing PONG objects
88 GENERIC: draw ( obj -- )
90 METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
91 METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
95 USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
98 TUPLE: <pong> < gadget draw closed ;
100 M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
101 M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
102 M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
104 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
106 : make-draw-closure ( -- closure )
108 ! Establish some bindings
110 [let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
111 BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
113 PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
114 COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
116 ! Define some internal words in terms of those bindings ...
118 [wlet | align-player-with-mouse [ ( -- )
119 PLAYER PLAY-FIELD align-paddle-with-mouse ]
121 move-ball [ ( -- ) BALL 1 move-for ]
123 player-blocked-ball? [ ( -- ? )
124 BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
126 computer-blocked-ball? [ ( -- ? )
127 BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
129 bounce-off-wall? [ ( -- ? )
130 BALL PLAY-FIELD in-between-horizontally? not ] |
132 ! Note, we're returning a quotation.
133 ! The quotation closes over the bindings established by the 'let'.
134 ! Thus the name of the word 'make-draw-closure'.
135 ! This closure is intended to be placed in the 'draw' slot of a
140 BALL PLAY-FIELD in-bounds?
142 align-player-with-mouse
148 BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
149 BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
151 ! check if ball bounced off something
153 player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
154 computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
155 bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
166 ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
167 ! The stack effects in the wlet expression throw
168 ! off the effect for the whole word, so we reset
169 ! it to the correct one here.
171 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
173 :: pong-loop-step ( PONG -- ? )
176 [ PONG relayout-1 25 milliseconds sleep t ]
179 :: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
181 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
186 make-draw-closure >>draw
187 dup "PONG" open-window
191 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
193 : play-pong-main ( -- ) [ play-pong ] with-ui ;