1 USING: accessors arrays calendar colors
2 combinators.short-circuit fonts fry kernel literals locals math
3 math.order ranges math.vectors namespaces opengl random
4 sequences timers ui ui.commands ui.gadgets ui.gadgets.worlds
5 ui.gestures ui.pens.solid ui.render ui.text ;
11 CONSTANT: BALL-SIZE 10
12 CONSTANT: BALL-DIM ${ BALL-SIZE BALL-SIZE }
13 CONSTANT: PADDLE-SIZE 80
14 CONSTANT: PADDLE-DIM ${ PADDLE-SIZE 10 }
18 COLOR: red >>foreground
19 COLOR: gray95 >>background
24 TUPLE: pong-gadget < gadget timer ball player computer game-over? ;
26 : initial-state ( gadget -- gadget )
27 T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
34 : <pong-gadget> ( -- gadget )
35 pong-gadget new initial-state
36 COLOR: gray95 <solid> >>interior
37 dup '[ _ on-tick ] f 16 milliseconds <timer> >>timer ;
39 M: pong-gadget pref-dim* drop { 400 400 } ;
41 M: pong-gadget ungraft*
42 [ timer>> stop-timer ] [ call-next-method ] bi ;
44 M:: pong-gadget draw-gadget* ( PONG -- )
45 COLOR: gray80 gl-color
47 197 2array { 10 6 } gl-fill-rect
51 { 0 0 } { 10 400 } gl-fill-rect
52 { 390 0 } { 10 400 } gl-fill-rect
54 PONG computer>> 0 2array PADDLE-DIM gl-fill-rect
55 PONG player>> 390 2array PADDLE-DIM gl-fill-rect
56 PONG ball>> pos>> BALL-DIM gl-fill-rect
60 PONG ball>> pos>> second 200 <
61 "YOU WIN!" "YOU LOSE!" ?
62 [ text-width 390 swap - 2 / 100 2array ]
63 [ '[ _ _ draw-text ] with-translation ] 2bi
65 PONG timer>> thread>> [
67 { " N - New Game" "SPACE - Pause" }
68 [ text-width 390 swap - 2 / 100 2array ]
69 [ '[ _ _ draw-text ] with-translation ] 2bi
73 :: move-player ( GADGET -- )
74 hand-loc get first PADDLE-SIZE 2 / -
75 10 390 PADDLE-SIZE - clamp GADGET player<< ;
77 :: move-ball ( GADGET -- )
80 ! minimum movement to hit wall or paddle
81 BALL vel>> first dup 0 > 380 10 ?
82 BALL pos>> first - swap / 1 min
83 BALL vel>> second dup 0 > 380 10 ?
84 BALL pos>> second - swap / 1 min min :> movement
86 movement 0 > [ movement throw ] unless
87 BALL pos>> BALL vel>> movement v*n v+ BALL pos<< ;
89 : move-computer-by ( GADGET N -- )
90 '[ _ + 10 390 PADDLE-SIZE - clamp ] change-computer drop ;
92 :: move-computer ( GADGET -- )
93 GADGET ball>> pos>> first :> X
94 GADGET computer>> PADDLE-SIZE 2/ + :> COMPUTER
97 X BALL-SIZE + COMPUTER - dup 0 < [
98 >integer -10 max 0 [a..b] random
99 GADGET swap move-computer-by
103 X COMPUTER - dup 0 > [
104 >integer 10 min [0..b] random
105 GADGET swap move-computer-by
108 :: bounce-off-paddle ( BALL PADDLE -- )
109 BALL pos>> first BALL-SIZE 2 / +
110 PADDLE PADDLE-SIZE 2 / + - 1/4 *
111 BALL vel>> second neg BOUNCE * MAX-SPEED min 2array
114 :: ?bounce-off-paddle ( BALL GADGET PADDLE -- )
115 BALL pos>> first dup BALL-SIZE +
116 PADDLE dup PADDLE-SIZE + '[ _ _ between? ] either? [
117 BALL PADDLE bounce-off-paddle
119 GADGET t >>game-over? timer>> stop-timer
122 : bounce-off-wall ( BALL -- )
123 0 swap vel>> [ neg ] change-nth ;
125 :: on-tick ( GADGET -- )
130 GADGET ball>> :> BALL
131 GADGET player>> :> PLAYER
132 GADGET computer>> :> COMPUTER
134 BALL pos>> first2 :> ( X Y )
135 BALL vel>> first2 :> ( DX DY )
137 { [ DY 0 > ] [ Y 380 >= ] } 0&&
138 [ BALL GADGET PLAYER ?bounce-off-paddle ] when
140 { [ DY 0 < ] [ Y 10 <= ] } 0&&
141 [ BALL GADGET COMPUTER ?bounce-off-paddle ] when
143 X { [ 10 <= ] [ 380 >= ] } 1||
144 [ BALL bounce-off-wall ] when
148 : com-new-game ( gadget -- )
149 initial-state timer>> start-timer ;
151 : com-pause ( gadget -- )
153 dup timer>> dup thread>>
154 [ stop-timer ] [ restart-timer ] if
155 ] unless relayout-1 ;
157 pong-gadget "gestures" f {
158 { T{ key-down { sym "n" } } com-new-game }
159 { T{ key-down { sym " " } } com-pause }
162 MAIN-WINDOW: pong-window {
165 { normal-title-bar close-button minimize-button } }
166 } <pong-gadget> >>gadgets ;