From da2ecd60702ef76e5e59fe80ca20a9cbdecfe7d6 Mon Sep 17 00:00:00 2001
From: Peter Tillemans <pti@melexis.com>
Date: Sat, 27 Apr 2024 08:50:33 +0200
Subject: [PATCH] added pipe collision detection

refactored ball and pipes as separate entities.
Added collision detection for the ball and pipes.
Ball now turns red when colliding with pipes.
---
 .gitignore       |   1 +
 flappy-ball.lisp | 125 +++++++++++++++++++++++++++++++++++++++--------
 2 files changed, 105 insertions(+), 21 deletions(-)
 create mode 100644 .gitignore

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..be303db
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+*.fasl
diff --git a/flappy-ball.lisp b/flappy-ball.lisp
index 4441c20..ecd1025 100644
--- a/flappy-ball.lisp
+++ b/flappy-ball.lisp
@@ -4,45 +4,128 @@
 
 (in-package :flappy-ball)
 
+
+
+;; Create a new ball entity
+;; (make-ball 10 20 -5.6)
+(defun make-ball (x y velocity size)
+  (list x y velocity size))
+
+(defun ball-x (ball)
+  (car ball))
+
+(defun ball-y (ball)
+  (cadr ball))
+
+(defun ball-velocity (ball)
+  (caddr ball))
+
+(defun ball-size (ball)
+  (cadddr ball))
+
+
+(defun ball-move (ball gravity max-height)
+  (let ((size (ball-size ball))
+        (velocity (ball-velocity ball)))
+    (make-ball
+     (ball-x ball)
+     (alexandria:clamp (+ (ball-y ball) velocity) size (- max-height size))
+     (+ velocity gravity)
+     size)))
+
+(defun ball-flap (ball flap-speed)
+  (list
+   (ball-x ball)
+   (ball-y ball)
+   flap-speed
+   (ball-size ball)))
+
+(defun ball-draw (ball pen)
+  (with-pen pen
+    (circle (ball-x ball) (ball-y ball) (ball-size ball))))
+
+;; -------------------------------------------------------------
+
+;; Create a new pipe entity
+;; (setf pipe (make-pipe 10 200 100 20))
+(defun make-pipe (x height gap width)
+  (list x height gap width))
+
+;; Accessors
+
+;; (pipe-x pipe)
+(defun pipe-x (pipe)
+  (car pipe))
+
+;; (pipe-height pipe)
+(defun pipe-height (pipe)
+  (cadr pipe))
+
+;; (pipe-gap pipe)
+(defun pipe-gap (pipe)
+  (caddr pipe))
+
+;; (pipe-width pipe)
+(defun pipe-width (pipe)
+  (cadddr pipe))
+
+(defun pipe-draw (pipe pen scroll-x height)
+  (let ((x (- (pipe-x pipe) scroll-x))
+        (h (pipe-height pipe))
+        (gap (pipe-gap pipe))
+        (w (pipe-width pipe)))
+    (with-pen pen
+      (rect x 0 w h)
+      (rect x (+ h gap) w (- height h gap)))))
+
+(defun pipe-collides (pipe ball scroll-x)
+  (let ((x (- (pipe-x pipe) scroll-x))
+        (h (pipe-height pipe))
+        (gap (pipe-gap pipe))
+        (w (pipe-width pipe))
+        (bx (ball-x ball))
+        (by (ball-y ball))
+        (bs (ball-size ball)))
+    (and (<= (- x bs) bx  (+ x w bs))
+         (not (<= (+ h bs) by (- (+ h gap) bs))))))
+
+;; -------------------------------------------------------------
+
 (defsketch flappy-ball
     ((title "Flappy Ball")
      (width 800)
      (height 600)
      (copy-pixels nil)
-     (ball (list (/ width 10) (/ height 3) 0))
+     (ball (make-ball (/ width 10) (/ height 3) 0 10))
      (gravity 0.05)
      (flap-speed -2.5)
      (ball-pen (make-pen :stroke (gray 0.5) :fill sketch:+yellow+ :weight 1))
+     (collision-pen (make-pen :stroke (gray 0.5) :fill sketch:+red+ :weight 1))
      (pipe-pen (make-pen :stroke (gray 0.5) :fill sketch:+green+ :weight 1))
-     (pipes '((200 200 100) (400 300 100) (600 400 100)))
+     (pipes (list
+             (make-pipe 200 200 100 20)
+             (make-pipe 400 300 100 20)
+             (make-pipe 600 400 100 20)))
      (scroll-x 0.0)
      (scroll-speed 0.2))
+
+  (dolist (pipe pipes)
+    (pipe-draw pipe pipe-pen scroll-x height))
+  (ball-draw ball
+             (if (some (lambda (pipe) (pipe-collides pipe ball scroll-x)) pipes)
+                 collision-pen
+                 ball-pen))
   
-  (flet ((move (b)
-           (list
-            (car b)
-            (alexandria:clamp (+ (cadr b) (caddr b)) 10 (- height 10))
-            (+ (caddr b) gravity)))) 
-    (with-pen ball-pen
-      (circle (car ball) (cadr ball) 10))
-    (with-pen pipe-pen
-      (dolist (pipe pipes)
-        (let ((x (- (car pipe) scroll-x))
-              (h (cadr pipe))
-              (gap (caddr pipe)))
-          (rect x 0 20 h)
-          (rect x (+ h gap) 20 (- height h gap)))))
-    (setf scroll-x (+ scroll-x scroll-speed))
-    (setf ball (move ball)))
-  )
+  (setf scroll-x (+ scroll-x scroll-speed))
+  (setf ball (ball-move ball gravity height)))
 
 (defmethod on-click ((instance flappy-ball) x y)
   (with-slots (ball flap-speed) instance
-    (setf (caddr ball) flap-speed)))
+    (setf ball (ball-flap ball flap-speed))))
 
 (defmethod on-key ((instance flappy-ball) key state)
   (with-slots (ball flap-speed) instance
-    (setf (caddr ball) flap-speed)))
+    (setf ball (ball-flap ball flap-speed))))
 
 (defmethod setup ((instance flappy-ball) &key &allow-other-keys)
   (background (gray 1)))