flappy-ball/flappy-ball.lisp

(defpackage :flappy-ball
  (:use :cl :sketch)
  (:export :flappy-ball :on-click :on-key :setup
           :make-ball :ball-x :ball-y :ball-velocity :ball-size :ball-move :ball-flap :ball-draw
           :make-pipe :pipe-x :pipe-height :pipe-gap :pipe-width :pipe-draw :pipe-collides))

(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))))))

;; -------------------------------------------------------------

(defun draw_image_layer(resource scroll-x)
  (let ((pic (load-resource resource))
        (offset (mod scroll-x 960))
        )
    (draw (crop pic offset 0 960 540) 
          :x 0 :y 0 :width 960 :height 540)))


(defun draw_background (scroll-x)
  (draw_image_layer "assets/level1/sky.png" 0)
  (draw_image_layer "assets/level1/clouds.png" (* -0.15 scroll-x))
  (draw_image_layer "assets/level1/far.png" (* 0.25 scroll-x))
  (draw_image_layer "assets/level1/middle.png" (* 0.6 scroll-x)))

(defun draw_foreground (pipes scroll-x pipe-pen height)
  (dolist (pipe pipes)
    (pipe-draw pipe pipe-pen scroll-x height))
  (draw_image_layer "assets/level1/ground.png" scroll-x))

(defun random-pipes (n spacing max-height gap width)
  (let ((padding 25))
    (loop repeat n
          for x from spacing by (+ spacing )
          collect (make-pipe x (+ padding (random (- max-height gap padding padding))) gap width)))
  )


(defsketch flappy-ball
    ((title "Flappy Ball")
     (width 960)
     (height 540)
     (ground-level 440)
     (copy-pixels nil)
     (ball (make-ball (/ width 10) (/ height 3) 0 10))
     (gravity 0.025)
     (flap-speed -1)
     (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 (random-pipes 15 200 ground-level 100 20))
     (scroll-x 0.0)
     (scroll-speed 0.2))

  (draw_background scroll-x)
  (draw_foreground pipes scroll-x pipe-pen height)
  
  (ball-draw ball
             (if (some (lambda (pipe) (pipe-collides pipe ball scroll-x)) pipes)
                 collision-pen
                 ball-pen))
  
  (setf scroll-x (+ scroll-x scroll-speed))
  (setf ball (ball-move ball gravity ground-level)))

(defmethod on-click ((instance flappy-ball) x y)
  (with-slots (ball flap-speed) instance
    (setf ball (ball-flap ball flap-speed))))

(defmethod on-key ((instance flappy-ball) key state)
  (with-slots (ball flap-speed) instance
    (setf ball (ball-flap ball flap-speed))))

(defmethod setup ((instance flappy-ball) &key &allow-other-keys)
  (background (gray 1)))