├── .gitignore ├── README.md ├── assets ├── RobotoMono-Regular.ttf └── pong.gif ├── pong.asd └── src ├── game.lisp ├── package.lisp ├── pong.lisp ├── ui.lisp └── vars.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | .#* 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pong 2 | Common Lisp implementation of pong. Built using [trivial-gamekit]. 3 | 4 | ![Pong](https://raw.githubusercontent.com/mark-gerarts/cl-pong/master/assets/pong.gif) 5 | 6 | ## Running 7 | 1. Follow the [trivial-gamekit install instructions]. 8 | 1. Clone this project somewhere where quicklisp can find it 9 | 1. `(ql:quickload :pong)` 10 | 1. `(pong:start-pong)` 11 | 12 | [trivial-gamekit]: https://borodust.org/projects/trivial-gamekit/ 13 | [trivial-gamekit install instructions]: https://borodust.github.io/projects/trivial-gamekit/#installation-and-loading 14 | -------------------------------------------------------------------------------- /assets/RobotoMono-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mark-gerarts/cl-pong/70dff3e6e9d6064739af69ed34ec797be50147af/assets/RobotoMono-Regular.ttf -------------------------------------------------------------------------------- /assets/pong.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mark-gerarts/cl-pong/70dff3e6e9d6064739af69ed34ec797be50147af/assets/pong.gif -------------------------------------------------------------------------------- /pong.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :pong 2 | :description "Pong implementation in Common Lisp using trivial-gamekit" 3 | :author "Mark Gerarts " 4 | :license "MIT" 5 | :serial t 6 | :depends-on (:trivial-gamekit 7 | :cl-bodge) 8 | :components ((:module "src" 9 | :components ((:file "package") 10 | (:file "vars") 11 | (:file "ui") 12 | (:file "game") 13 | (:file "pong"))))) 14 | -------------------------------------------------------------------------------- /src/game.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pong) 2 | 3 | ;; Objects 4 | 5 | (defclass object () 6 | ((location 7 | :initarg :location 8 | :accessor location))) 9 | 10 | (defgeneric get-edges (object) 11 | (:documentation "Should return the top, right, bottom and left edge, in that 12 | order")) 13 | 14 | (defclass movable (object) 15 | ((velocity 16 | :initarg :velocity 17 | :initform (vec2 0 0) 18 | :accessor velocity))) 19 | 20 | (defmethod apply-velocity ((movable movable)) 21 | (setf (location movable) (add (location movable) (velocity movable)))) 22 | 23 | ;; Paddle 24 | 25 | (defclass paddle (movable) 26 | ((movement-speed 27 | :initarg :speed 28 | :initform *default-movement-speed* 29 | :accessor movement-speed 30 | :documentation "The vertical velocity")) 31 | (:documentation "Location is the coordinate of the bottom left corner")) 32 | 33 | (defun make-paddle (location) 34 | (make-instance 'paddle :location location)) 35 | 36 | (defmethod display ((paddle paddle)) 37 | (draw-rect (location paddle) 38 | *paddle-width* 39 | *paddle-height* 40 | :fill-paint *primary*)) 41 | 42 | (defmethod get-edges ((paddle paddle)) 43 | (let* ((location (location paddle)) 44 | (left (x location)) 45 | (bottom (y location)) 46 | (top (+ bottom *paddle-height*)) 47 | (right (+ left *paddle-width*))) 48 | (values top right bottom left))) 49 | 50 | (defmethod check-edges ((paddle paddle)) 51 | (let* ((bottomy (y (location paddle))) 52 | (topy (+ *paddle-height* bottomy))) 53 | (cond 54 | ((< bottomy 0) 55 | (setf (y (location paddle)) 0)) 56 | ((> topy *height*) 57 | (setf (y (location paddle)) (- *height* *paddle-height*)))))) 58 | 59 | (defmethod update-paddle ((paddle paddle)) 60 | (apply-velocity paddle) 61 | (check-edges paddle)) 62 | 63 | (defmethod get-center ((paddle paddle)) 64 | (let* ((x (x (location paddle))) 65 | (x (+ x (/ *paddle-width* 2))) 66 | (y (y (location paddle))) 67 | (y (+ y (/ *paddle-height* 2)))) 68 | (vec2 x y))) 69 | 70 | (defmethod move ((paddle paddle) direction) 71 | (let* ((vy (movement-speed paddle)) 72 | (velocity (case direction 73 | (:up (vec2 0 vy)) 74 | (:down (vec2 0 (- vy)))))) 75 | (setf (velocity paddle) velocity))) 76 | 77 | (defmethod halt ((paddle paddle)) 78 | (setf (velocity paddle) (vec2 0 0))) 79 | 80 | ;; Player 81 | 82 | (defclass player () 83 | ((paddle 84 | :initarg :paddle 85 | :accessor paddle) 86 | (score 87 | :initform 0 88 | :accessor score))) 89 | 90 | (defun make-player (paddle) 91 | (make-instance 'player :paddle paddle)) 92 | 93 | (defmethod display ((player player)) 94 | (display (paddle player))) 95 | 96 | (defmethod add-point ((player player)) 97 | (incf (score player))) 98 | 99 | ;; Ball 100 | 101 | (defclass ball (movable) ()) 102 | 103 | (defun make-ball () 104 | ;; We create a random starting velocity that will never point to the bottom or 105 | ;; top edge. We do this by creating a random poing on the left or right edge 106 | ;; and make the velocity have this direction. 107 | (let* ((py (random *height*)) 108 | (px (if (= 1 (random 2)) 0 *width*)) 109 | (center (vec2 *center-x* *center-y*)) 110 | (velocity (subt (vec2 px py) center)) 111 | (velocity (normalize velocity)) 112 | (velocity (mult velocity *ball-speed*)) 113 | (location (vec2 *center-x* *center-y*))) 114 | (make-instance 'ball :velocity velocity :location location))) 115 | 116 | (defmethod display ((ball ball)) 117 | (draw-circle (location ball) *ball-radius* :fill-paint *primary*)) 118 | 119 | (defmethod get-edges ((ball ball)) 120 | (let* ((location (location ball)) 121 | (x (x location)) 122 | (y (y location)) 123 | (r *ball-radius*) 124 | (top (+ y r)) 125 | (right (+ x r)) 126 | (bottom (- y r)) 127 | (left (- x r))) 128 | (values top right bottom left))) 129 | 130 | (defmethod reverse-direction ((ball ball) direction) 131 | (case direction 132 | (:x (setf (x (velocity ball)) (- (x (velocity ball))))) 133 | (:y (setf (y (velocity ball)) (- (y (velocity ball))))))) 134 | 135 | (defmethod collides-with-p ((ball ball) (paddle paddle)) 136 | (let* ((r *ball-radius*) 137 | (location (location ball)) 138 | (leftx (- (x location) r)) 139 | (lefty (- (y location) r)) 140 | (rightx (+ (x location) r)) 141 | (righty (+ (y location) r))) 142 | (multiple-value-bind (ptop pright pbottom pleft) (get-edges paddle) 143 | (and (< leftx pright) (> rightx pleft) 144 | (< lefty ptop) (> righty pbottom))))) 145 | 146 | (defmethod check-for-paddle-collision ((ball ball) (paddle paddle)) 147 | (when (collides-with-p ball paddle) 148 | (progn 149 | (reverse-direction ball :x) 150 | ;; Increase the ball velocity if the paddle is moving. 151 | (incf (y (velocity ball)) (/ (y (velocity paddle)) 2))))) 152 | 153 | (defmethod check-for-collision ((ball ball) paddle-l paddle-r) 154 | (multiple-value-bind (top right bottom left) (get-edges ball) 155 | (declare (ignore right left)) 156 | ;; The ball hits the top of the screen. 157 | (when (> top *height*) 158 | (progn 159 | (setf (y (location ball)) (- *height* *ball-radius*)) 160 | (reverse-direction ball :y))) 161 | ;; The ball hits the bottom of the screen. 162 | (when (minusp bottom) 163 | (progn 164 | (setf (y (location ball)) *ball-radius*) 165 | (reverse-direction ball :y))) 166 | ;; Collision with either paddle. 167 | (check-for-paddle-collision ball paddle-r) 168 | (check-for-paddle-collision ball paddle-l))) 169 | 170 | (defmethod update-ball ((ball ball) paddle-l paddle-r) 171 | (apply-velocity ball) 172 | (check-for-collision ball paddle-l paddle-r)) 173 | 174 | (defmethod update-computer ((paddle paddle) (ball ball)) 175 | ;; Naive AI implementation. The paddle moves according to the y-position of 176 | ;; the ball, limited to a maximum velocity. 177 | (let* ((paddley (y (get-center paddle))) 178 | (bally (y (location ball))) 179 | (dir (if (> paddley bally) 180 | (vec2 0 (- *ai-max-movement-speed*)) 181 | (vec2 0 *ai-max-movement-speed*)))) 182 | (setf (velocity paddle) dir))) 183 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :pong 2 | (:use :cl :trivial-gamekit) 3 | (:import-from :cl-bodge :vector-length :normalize) 4 | (:export :start-pong)) 5 | -------------------------------------------------------------------------------- /src/pong.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pong) 2 | 3 | (defgame pong () 4 | ((player 5 | :accessor player) 6 | (computer 7 | :accessor computer) 8 | (ball 9 | :accessor ball)) 10 | (:viewport-width *width*) 11 | (:viewport-height *height*) 12 | (:viewport-title "Pong")) 13 | 14 | (defmethod handle-score ((this pong) (player player)) 15 | (add-point player) 16 | (sleep 1) 17 | (setf (ball this) (make-ball))) 18 | 19 | (defmethod check-point-score ((this pong)) 20 | (multiple-value-bind (top right bottom left) (get-edges (ball this)) 21 | (declare (ignore top bottom)) 22 | (when (< left 0) 23 | (handle-score this (computer this))) 24 | (when (> right *width*) 25 | (handle-score this (player this))))) 26 | 27 | (defmethod post-initialize ((this pong)) 28 | ;; Initialize the players. 29 | (let* ((paddle-l (make-paddle (vec2 *paddle-offset* *center-y*))) 30 | (player-l (make-player paddle-l)) 31 | (paddle-r (make-paddle (vec2 32 | (- *width* *paddle-offset* *paddle-width*) 33 | *center-y*))) 34 | (player-r (make-player paddle-r))) 35 | (setf (player this) player-l) 36 | (setf (computer this) player-r)) 37 | ;; Initialize the ball 38 | (setf (ball this) (make-ball)) 39 | ;; Bind movement keys. 40 | (bind-button :up :pressed (lambda () (move (paddle (player this)) :up))) 41 | (bind-button :up :released (lambda () (halt (paddle (player this))))) 42 | (bind-button :down :pressed (lambda () (move (paddle (player this)) :down))) 43 | (bind-button :down :released (lambda () (halt (paddle (player this)))))) 44 | 45 | (defmethod act ((this pong)) 46 | (let ((paddle-l (paddle (player this))) 47 | (paddle-r (paddle (computer this))) 48 | (ball (ball this))) 49 | (update-computer paddle-r ball) 50 | (update-paddle paddle-l) 51 | (update-paddle paddle-r) 52 | (update-ball ball paddle-l paddle-r) 53 | (check-point-score this))) 54 | 55 | (defmethod draw ((this pong)) 56 | (draw-background) 57 | (draw-center-line) 58 | (display (player this)) 59 | (display (computer this)) 60 | (display (ball this)) 61 | ;; Draw the scores. 62 | (draw-score (score (player this)) :left) 63 | (draw-score (score (computer this)) :right)) 64 | 65 | (defun start-pong () 66 | (start 'pong)) 67 | -------------------------------------------------------------------------------- /src/ui.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pong) 2 | 3 | ;; Register resources 4 | (register-resource-package 'pong 5 | (asdf:system-relative-pathname :pong "assets/")) 6 | (define-font 'pong::fonts-default "RobotoMono-Regular.ttf") 7 | 8 | (defun draw-background () 9 | (draw-rect (vec2 0 0) *width* *height* :fill-paint *background*)) 10 | 11 | (defun draw-center-line () 12 | (let* ((block-height 25) 13 | (block-width 10) 14 | (block-padding 20) 15 | (segment-length (+ block-height block-padding)) 16 | (x (- *center-x* (/ block-width 2))) 17 | (n (/ *height* segment-length))) 18 | (loop for i upto n do 19 | (draw-rect (vec2 x (* i segment-length)) 20 | block-width 21 | block-height 22 | :fill-paint *primary*)))) 23 | 24 | (defun draw-score (score location) 25 | (let* ((posy (- *height* 100)) 26 | (posx (if (eq location :left) 27 | (- *center-x* 140) 28 | (+ *center-x* 100))) 29 | (pos (vec2 posx posy))) 30 | (draw-text (write-to-string score) pos 31 | :fill-color *primary* 32 | :font (make-font 'pong::fonts-default 100)))) 33 | -------------------------------------------------------------------------------- /src/vars.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pong) 2 | 3 | ;; Dimensions 4 | (defvar *width* 800) 5 | (defvar *height* 600) 6 | (defvar *center-x* (/ *width* 2)) 7 | (defvar *center-y* (/ *height* 2)) 8 | 9 | ;; Paddle 10 | (defvar *paddle-width* 10) 11 | (defvar *paddle-height* 60) 12 | (defvar *paddle-offset* 20) 13 | (defvar *default-movement-speed* 4) 14 | 15 | ;; AI 16 | (defvar *ai-max-movement-speed* *default-movement-speed*) 17 | 18 | ;; Ball 19 | (defvar *ball-radius* 7) 20 | (defvar *ball-speed* 4) 21 | 22 | ;; Colours 23 | (defvar *background* (vec4 0 0 0 1)) 24 | (defvar *primary* (vec4 1 1 1 1)) 25 | --------------------------------------------------------------------------------