259 lines
7.8 KiB
Common Lisp
259 lines
7.8 KiB
Common 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))
|
|
|
|
(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)))
|
|
)
|
|
|
|
;; -------------------------------------------------------------
|
|
|
|
(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)))
|
|
(print "Saving high scores")
|
|
(print high-scores)
|
|
(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))))
|
|
|
|
;; -------------------------------------------------------------
|
|
|
|
|
|
(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 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.2)
|
|
(target-x (- (* pipes-amount pipes-spacing) 720))
|
|
(state 'new)
|
|
(score 0)
|
|
(high-scores (load-high-scores "highscores"))
|
|
)
|
|
|
|
(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 high-scores (high-scores-add high-scores score))
|
|
(save-high-scores "highscores" high-scores)
|
|
(setf state 'died))
|
|
collision-pen)
|
|
ball-pen))
|
|
|
|
(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 'new)
|
|
(setf scroll-x 0.0)
|
|
(text "Click to Start" 50 250 200 40)
|
|
(loop for (score . time) in high-scores
|
|
for i from 0
|
|
do (text (format nil "~3,'0d" (floor score)) 300 (+ 30 (* i 40)) 80 30)
|
|
do (text (local-time:format-timestring nil (local-time:universal-to-timestamp time) :format '(:year "-" :month "-" :day)) 400 (+ 30 (* 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)
|
|
|
|
(when (eq state 'running)
|
|
(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)
|
|
(setf state 'won)
|
|
(setf high-scores (high-scores-add high-scores score))
|
|
(save-high-scores "highscores" high-scores)))
|
|
)
|
|
|
|
(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)
|
|
(background (gray 1)))
|
|
|