From 50035adb08e82c240209ab6b53ba70e741ea58b0 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Fri, 8 Jul 2022 08:22:09 -0500
Subject: [example] [modify] pong, made it a bit more dynamic

---
 examples/08-pong.lisp | 75 ++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 60 insertions(+), 15 deletions(-)

(limited to 'examples')

diff --git a/examples/08-pong.lisp b/examples/08-pong.lisp
index 1eed260..c9b4edb 100644
--- a/examples/08-pong.lisp
+++ b/examples/08-pong.lisp
@@ -25,38 +25,83 @@
   (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)))
-
+    (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 ball) (* -1 (dy ball))
-                (dr ball) (* -1 (dr ball)))
-          (incf (ww::x ball) (dx ball))
-          (incf (ww::y ball) (dy ball)))
-
-        (with-accessors ((dx dx) (dy dy) (bx ww::x) (by ww::y) (w ww::width) (h ww::height)) 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))
+             (setf dy (* -1 dy)
+                   by (- 600 h))
              (advance-pos ball))
 
-            ((or (<= 800 (+ bx w)) (<= bx 0))
-             (setf dx (* -1 dx))
+            ((<= 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 x)
+    (ww::on-mousemotion (app)
       (setf (ww::x (paddle app))
-            (- x (* 0.5 (ww::width (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
@@ -66,7 +111,7 @@
             :x 400 :y 300
             :dr (random-velocity)
             :dx (random-velocity 10)
-            :dy (random-velocity 10)))
+            :dy 8))
          (paddle
            (make-instance
             'paddle
-- 
cgit v1.2.3