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-amount 1)
     (pipes-spacing 200)
     (pipes-width 20)
     (pipes (random-pipes pipes-amount pipes-spacing ground-level 100 pipes-width))
     (scroll-x 0.0)
     (scroll-speed 0.2)
     (target-x (- (* pipes-amount pipes-spacing) 720))
     (state 'new))

  (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)
                 (progn
                   (when (eq state 'running)
                     (setf state 'died))
                   collision-pen)
                 ball-pen))

  (when (eq state 'new)
    (setf scroll-x 0.0)
    (text "Click to Start" 350 250 200 40))
  (when (eq state 'won)
    (text "You Won" 400 100 120 40))
  (when (eq state 'died)
    (text "You Died" 400 250 120 40))

  (if (>= scroll-x target-x)
      (let ((pic (load-resource "assets/level1/prize.png")))
        (draw pic :x (- (+ 960 target-x) scroll-x) :y 0 )))

  (when (eq state 'running)
    (setf scroll-x (+ scroll-x scroll-speed))
    (setf ball (ball-move ball gravity ground-level))
    (when (> scroll-x (+ (* pipes-amount pipes-spacing) pipes-width))
      (setf state 'won)))  
  )

(defmethod on-click ((instance flappy-ball) x y)
  (with-slots (ball flap-speed state) instance
    (setf ball (ball-flap ball flap-speed))
    (when (eq state 'new)
      (setf state 'running))
    (when (eq state 'died)
      (setf state 'new))
    (when (eq state 'won)
      (setf state 'new))
    ))

(defmethod on-key ((instance flappy-ball) key state)
  (with-slots (ball flap-speed state) instance
    (setf ball (ball-flap ball flap-speed))
    (when (eq state 'new)
      (setf state 'running))
    (when (eq state 'died)
      (setf state 'new))
    (when (eq state 'won)
      (setf state 'new))
    ))

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