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
   :make-high-score :high-score-value :high-score-time :main))

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


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

(defun make-high-score (score time)
  (cons score time))

(defun high-score-value (high-score)
  (car high-score))

(defun high-score-time (high-score)
  (cdr high-score))

(defun high-scores-path (fname)
  (let* ((folder (or (uiop:getenv "XDG_DATA_HOME")
                     (merge-pathnames (make-pathname :directory '(:relative ".local" "share" "flappy-ball")) (user-homedir-pathname))))
         (path (merge-pathnames (make-pathname :name fname :type "txt") folder)))
    (ensure-directories-exist path)
    path))

(defun load-high-scores (fname)
  (let ((path (high-scores-path fname)))
    (if (probe-file path)
        (with-open-file (stream path :direction :input)
          (read stream))
        nil)))

(defun save-high-scores (fname high-scores)
  (let ((path (high-scores-path fname)))
    (with-open-file (stream path :direction :output :if-exists :supersede)
      (print high-scores stream))))

(defun high-score-betterp (a b)
  (or (> (high-score-value a) (high-score-value b))
      (and (= (high-score-value a) (high-score-value b))
           (< (high-score-time a) (high-score-time b)))))

(defun high-scores-add (high-scores score)
  (let* ((hs (make-high-score (floor score) (get-universal-time)))
         (new-scores (sort (append high-scores (list hs)) #'high-score-betterp)))
    (if (< (length new-scores) 10)
        new-scores
        (subseq new-scores 0 10))))

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

(defparameter *resources* (serapeum:dict)
  "Resources for our game
Hash-table with level name => file name => resource.")

(defparameter *asset-folder* (merge-pathnames "assets/" 
                                              (asdf:system-source-directory :flappy-ball)))

(defun read-level-assets (level)
  (let ((level-dict (serapeum:dict))
        (folder (merge-pathnames (format nil "~a~a" level "/") *asset-folder*)))
    (loop for file in (list "sky.png" "clouds.png" "far.png" "middle.png" "ground.png" "prize.png")
          for content = (load-resource (namestring (merge-pathnames file folder)))
          do (setf (gethash file level-dict) content)
          finally (setf (gethash level *resources*) level-dict))))

(defun %read-static-files-in-memory ()
  "load all resources for all levels in memory"
  (setf *resources* (serapeum:dict))
  (loop for level in (list "level1" "level2" "level3" "level4")
        do (read-level-assets level)
        finally (return *resources*)))


(defun draw-image-layer(level resource scroll-x)
  (let ((pic (serapeum:href *resources* level resource))
        (offset (mod scroll-x 960)))
    (draw (crop pic offset 0 960 540) 
          :x 0 :y 0 :width 960 :height 540)))


(defun draw-background (level scroll-x)
  (draw-image-layer level "sky.png" 0)
  (draw-image-layer level "clouds.png" (* -0.15 scroll-x))
  (draw-image-layer level "far.png" (* 0.25 scroll-x))
  (draw-image-layer level "middle.png" (* 0.6 scroll-x)))

(defun draw-foreground (level pipes scroll-x pipe-pen height)
  (dolist (pipe pipes)
    (pipe-draw pipe pipe-pen scroll-x height))
  (draw-image-layer level "ground.png" scroll-x))

(defun draw-prize (level scroll-x target-x width)
  (if (>= scroll-x target-x)
      (let ((pic (serapeum:href *resources* level "prize.png")))
        (draw pic :x (- (+ 60 width target-x) scroll-x) :y 0 ))))

(defun draw-hud (state score high-scores)
  (when (eq state 'new)
    (text "Click to Start" 50 250 200 40)
    (text "High Scores" 300 30 280 40)
    (loop for (score . time) in high-scores
          for i from 0
          do (text (format nil "~3,'0d" (floor score)) 300 (+ 70 (* i 40)) 80 30)
          do (text (local-time:format-timestring nil (local-time:universal-to-timestamp time) :format '(:year "-" :month "-" :day)) 400 (+ 70 (* i 40)) 200 30)
          ))
  (when (eq state 'won)
    (text "You Won" 380 100 160 60)
    (text "Return to Restart" 300 150 320 40)
    )
  (when (eq state 'died)
    (text "You Died" 380 100 160 60)
    (text "Return to Restart" 300 150 320 40))

  (text (format nil "~3,'0d" (floor score)) 820 20 100 40)

  )
;; -------------------------------------------------------------


(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.1)
     (flap-speed -3)
     (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 10)
     (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.8)
     (target-x (- (* pipes-amount pipes-spacing) 720))
     (state 'new)
     (score 0)
     (high-scores (load-high-scores "highscores"))
     (on-exit (lambda () ()))
     (play-level 1)
     )

  (let ((ball-collides (some (lambda (pipe) (pipe-collides pipe ball scroll-x)) pipes))
        (level (format nil "level~a" play-level)))
    
    (draw-background level scroll-x)
    (draw-foreground level pipes scroll-x pipe-pen height)
    
    (if ball-collides
        (ball-draw ball collision-pen)
        (ball-draw ball ball-pen))

    (draw-prize level scroll-x target-x width)

    (draw-hud state score high-scores)

    (when (eq state 'new)
      (setf scroll-x 0.0))
    (when (eq state 'running)
      (while-running sketch::*sketch*))
    ;; has to come after checking for the new state or stuck in death
    (when ball-collides
      (on-death sketch::*sketch*))
    )
  )


(defmethod while-running ((instance flappy-ball))
  (with-slots (score state
               width ground-level
               scroll-x scroll-speed
               pipes pipes-width pipes-spacing pipes-amount
               ball gravity
               play-level
               high-scores) instance
    (setf score (1+ (/ (- scroll-x pipes-width (/ width 10)) pipes-spacing)))
    (setf scroll-x (+ scroll-x scroll-speed))
    (setf ball (ball-move ball gravity ground-level))
    (when (> (round score) pipes-amount)
      (if (eq play-level 4) 
          (progn 
            (setf state 'won)
            (setf high-scores (high-scores-add high-scores score))
            (save-high-scores "highscores" high-scores))
          (progn 
            (setf play-level (1+ play-level))
            (setf pipes (random-pipes pipes-amount pipes-spacing ground-level 100 pipes-width))
            (setf scroll-x 0.0)
            (setf scroll-speed (* 0.8 scroll-speed)))))))


(defmethod on-death ((instance flappy-ball))
  (with-slots (state high-scores score) instance
    (setf high-scores (high-scores-add high-scores score))
    (save-high-scores "highscores" high-scores)
    (setf state 'died)))

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

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

(defmethod setup ((instance flappy-ball) &key &allow-other-keys)
  (%read-static-files-in-memory)
  (background (gray 1)))

;; override underlying sdl2kit method to intercept closing the window
(defmethod kit.sdl2:close-window :after ((instance flappy-ball))
  (with-slots (on-exit) instance
    (print "close window called")
    (apply on-exit ())))



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

(defun main ()
  (let ((is_running t))
    (print "Starting...")
    (make-instance 'flappy-ball :on-exit (lambda () (progn
                                                      (print "exiting...")
                                                      (setf is_running nil))))
    (loop
      while is_running
      do (sleep 1))))

;; --------------- deploy instructions ---------------------

;; add static resources to the deploy folder
(deploy:define-resource-directory assets (make-pathname :directory '(:relative "assets")))