blob: c9b4edbe14b3ba8a01afbdaff04ef68405307aec (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
;;;; examples/08-pong.lisp
(defpackage #:ww.examples/8
(:use #:cl)
(:export #:start)
(:import-from #:defclass-std #:defclass/std))
(in-package #:ww.examples/8)
(defclass/std solo-pong (ww::application)
((paddle ball game-over)))
(defclass/std mobile ()
((dx dy dr :std 0)))
(defclass/std paddle (ww::bitmap mobile) ())
(defclass/std ball (ww::bitmap mobile) ())
(defun random-velocity (&optional (size 1.0))
(* size (if (< 0.5 (random 1.0))
(random 1.0)
(* -1 (random 1.0)))))
(defun advance-pos (thing)
(with-accessors ((dr dr) (dx dx) (dy dy) (x ww::x) (y ww::y) (r ww::rotation)) thing
(incf x dx)
(incf y dy)
(incf r dr)
(setf dr (decay dr)))) ;; rotation diminishes every round, just aesthetic.
(defun decay (val &optional (amount 0.01))
(cond
((zerop val)
val)
((plusp val)
(- val amount))
((minusp val)
(+ val amount))))
(defun avg (&rest args)
(loop for x in args
sum x into total
sum 1 into count
finally (return (/ total count))))
(defun sqrt+ (val)
(if (plusp val) (sqrt val)
(* -1 (sqrt (abs val)))))
(ww::defhandler pong-perframe
(ww::on-perframe (app)
(with-slots (paddle ball game-over) app
(when (ww::units-intersect-p paddle ball)
(setf
;; dy just reverses direction
(dy ball) (* -1 (dy ball))
;; average dx of the two
(dx ball) (avg (dx ball) (dx paddle))
;; no logic to it dr change, just aesthetic
(dr ball) (avg (sqrt+ (sqrt+ (dx paddle))) (dr ball)))
;; its a good idea to advance the ball position after every collision
;; this prevents the ball from "getting stuck" contstantly colliding
;; with an object / wall.
(advance-pos ball))
;; since the dx of the paddle only changes when the paddle
;; moves we should have it decay if its just been sitting
;; still. Mostly for aesthetics. It looks funny if a
;; stationary paddle speeds up the ball.
(setf (dx paddle) (decay (dx paddle) 1))
;; here we just check the bounds, bounce when the ball hits the top left or right
;; and signal game over if it hits the bottom.
(with-accessors
((dx dx) (dy dy) (bx ww::x) (by ww::y) (w ww::width) (h ww::height)) ball
(cond
((<= 600 (+ by h))
(setf dy (* -1 dy)
by (- 600 h))
(advance-pos ball))
((<= 800 (+ bx w))
(setf dx (* -1 dx)
bx (- 800 w))
(advance-pos ball))
((<= bx 0)
(setf dx (* -1 dx)
x 0))
((<= by 0)
(setf (ww::unit-visiblep game-over) t)))
;; and whatever else happens, advance the ball position.
(advance-pos ball)))))
(ww::defhandler pong-mousemove
(ww::on-mousemotion (app)
(setf (ww::x (paddle app))
(- x (* 0.5 (ww::width (paddle app))))
;; using dx to store some motion informaton
;; used to chagne dx and dr in the ball
(dx (paddle app)) xrel))) ; xrel is supplied by default by on-mousedown
(defmethod ww::boot ((app solo-pong))
(let* ((ball
(make-instance
'ball
:texture (ww::get-asset "Fezghoul.png")
:x 400 :y 300
:dr (random-velocity)
:dx (random-velocity 10)
:dy 8))
(paddle
(make-instance
'paddle
:texture (ww::get-asset "GelatinousCube.png")
:x 400
:y 0))
(game-over
(make-instance
'ww::text
:font (ww::get-asset "Ticketing.ttf")
:content "Game Over"
:visiblep nil
:x 300
:y 300
:scale-x 3.0
:scale-y 3.0)))
(setf (ww::width paddle) 120
(ww::height paddle) 20
(paddle app) paddle
(ball app) ball
(game-over app) game-over)
(ww::add-unit app ball)
(ww::add-unit app paddle)
(ww::add-unit app game-over)
(ww::add-handler app #'pong-mousemove)
(ww::add-handler app #'pong-perframe )))
(defun start ()
(ww::start
(make-instance
'solo-pong
:fps 60
:width 800
:height 600
:refocus-on-mousedown-p nil
:title "Now the lonely can enjoy pong."
:asset-root
(merge-pathnames
"examples/"
(asdf:system-source-directory :wheelwork)))))
|
