diff options
| -rw-r--r-- | README.org | 4 | ||||
| -rw-r--r-- | assets.lisp | 46 | ||||
| -rw-r--r-- | macros.lisp | 71 | ||||
| -rw-r--r-- | the-price-of-a-cup-of-coffee.asd | 1 | ||||
| -rw-r--r-- | the-price-of-a-cup-of-coffee.lisp | 170 |
5 files changed, 254 insertions, 38 deletions
@@ -5,8 +5,8 @@ + Design and Code by :: [[https://github.com/thegoofist/][The Goofist]] under the [[./LICENSE][GNU Public License version 3]]. - + Art by :: *Ct* under a [[https://creativecommons.org/licenses/by-nc-sa/4.0/legalcode][Attribution NonCommercial ShareAlike]] Createive Commons License. + + Art by :: *Ct* under a [[https://creativecommons.org/licenses/by-nc-sa/4.0/legalcode][Attribution NonCommercial ShareAlike]] Creative Commons License. + - diff --git a/assets.lisp b/assets.lisp index 0adf417..37d05d3 100644 --- a/assets.lisp +++ b/assets.lisp @@ -1,14 +1,51 @@ +;;;; assets.lisp (in-package #:the-price-of-a-cup-of-coffee) +;;; Utility Functions + +(defun make-source-rects (tile-defs) + "Accepts a TILE-DEFS list and adds an SDL2:RECT instance to each keyed to :RECT" + (mapcar + (lambda (tl) + (list* :rect + (sdl2:make-rect (getf tl :x) + (getf tl :y) + (getf tl :width) + (getf tl :height)) + tl)) + tile-defs)) + +(defun find-tile-rect (tile-defs name) + "Return the rect for the tile with NAME in TILE-DEFS list." + (let-when (tl (find name tile-defs + :key (lambda (tl) (getf tl :name)) + :test #'string-equal)) + (getf tl :rect))) + +(defun select-tile-rects (tile-defs &rest names) + (map 'vector ($ #'find-tile-rect tile-defs _) names)) + + +(defun create-sprite-faces (defs) + (list :facing-down (select-tile-rects defs "front") + :walking-down (select-tile-rects defs "front" "walkforward1" "front" "walkforward2") + :facing-up (select-tile-rects defs "back") + :walking-up (select-tile-rects defs "back" "walkback1" "back" "walkback2") + :facing-left (select-tile-rects defs "profileleft") + :walking-left (select-tile-rects defs "profileleft" "walkleft1" "profileleft" "walkleft2") + :facing-right (select-tile-rects defs "profileright") + :walking-right (select-tile-rects defs "profileright" "walkright1" "profileright" "walkright1"))) + +;;; Nance Assets (defparameter +nance-sheet-image+ "assets/Nance.png") -(defparameter +nance-tiles+ +(defvar *nance-tile-defs* '((:NAME "Back" :X 256 :Y 128 :WIDTH 64 :HEIGHT 128) (:NAME "Front" :X 320 :Y 0 :WIDTH 64 :HEIGHT 128) - (:NAME "ProfileLeft" :X 192 :Y 128 :PATH :WIDTH 64 :HEIGHT 128) - (:NAME "ProfileRight" :X 256 :Y 0 :PATH :WIDTH 64 :HEIGHT 128) + (:NAME "ProfileLeft" :X 192 :Y 128 :WIDTH 64 :HEIGHT 128) + (:NAME "ProfileRight" :X 256 :Y 0 :WIDTH 64 :HEIGHT 128) (:NAME "WalkBack1" :X 64 :Y 128 :WIDTH 64 :HEIGHT 128) (:NAME "WalkBack2" :X 128 :Y 128 :WIDTH 64 :HEIGHT 128) (:NAME "WalkForward1" :X 0 :Y 256 :WIDTH 64 :HEIGHT 128) @@ -19,3 +56,6 @@ (:NAME "WalkRight2" :X 0 :Y 0 :WIDTH 64 :HEIGHT 128))) + + + diff --git a/macros.lisp b/macros.lisp new file mode 100644 index 0000000..8f44e68 --- /dev/null +++ b/macros.lisp @@ -0,0 +1,71 @@ +(in-package :the-price-of-a-cup-of-coffee) + +(defun make-keyword-symbol (s) + "Makes a keyword from a string or symbol." + (let ((s (format nil "~a" s))) + (read-from-string + (format nil ":~a" + (substitute #\- #\Space s))))) + + +(defmacro def-normal-class (name super &rest slots) + "Defines a class with the given name and slots, with accessors and initargs for each slot." + `(defclass ,name ,super + (,@(loop :for slot :in slots + :when (consp slot) + :collect (list (car slot) + :accessor (car slot) + :initform (cadr slot) + :initarg (make-keyword-symbol (car slot))) + :else + :collect (list slot + :accessor slot + :initform nil + :initarg (make-keyword-symbol slot)))))) + +(defmacro let-cond (&body forms) + (let ((tmp-var (gensym))) + `(let (,tmp-var) + (cond + ,@(loop :for (var test . body) :in forms + :if (eq var t) + :collect (list* t (cons test body)) + :else + :collect `((setf ,tmp-var ,test) + (let ((,var ,tmp-var)) + ,@body))))))) +(defmacro match-key (key &body clauses) + "Each clause is of the form (:scancode-xxx expr1 expr2 ...)" + `(cond ,@(loop :for (scancode . actions) :in clauses + :collect `((sdl2:scancode= ,key ,scancode) ,@actions)))) + +(defmacro let-when ((var test) &body body) + `(let ((,var ,test)) + (when ,var ,@body))) + +(defmacro let-if ((var test) then &optional else) + `(let ((,var ,test)) + (if ,var ,then ,else))) + + +(defmacro $ (f &rest args) + (let* ((new-args (loop :for a :in args :when (eql a '_) :collect (gensym))) + (copy-new (copy-seq new-args)) + (call-args (loop :for a :in args + :when (eql a '_) :collect (pop copy-new) + :else :collect a))) + `(lambda ,new-args (funcall ,f ,@call-args)))) + +(defmacro with-surface-from-file ((var path) &body body) + `(let ((,var (sdl2-image:load-image ,path))) + (unwind-protect + (progn ,@body) + (sdl2:free-surface ,var)))) + + +(defmacro with-surface ((var surf) &body body) + `(let ((,var ,surf)) + (unwind-protect + (progn ,@body) + (sdl2:free-surface ,var)))) + diff --git a/the-price-of-a-cup-of-coffee.asd b/the-price-of-a-cup-of-coffee.asd index 59de235..7d53563 100644 --- a/the-price-of-a-cup-of-coffee.asd +++ b/the-price-of-a-cup-of-coffee.asd @@ -8,5 +8,6 @@ :serial t :depends-on (#:animise #:sdl2 #:sdl2-image #:harmony) :components ((:file "package") + (:file "macros") (:file "assets") (:file "the-price-of-a-cup-of-coffee"))) diff --git a/the-price-of-a-cup-of-coffee.lisp b/the-price-of-a-cup-of-coffee.lisp index af7e73a..36de32d 100644 --- a/the-price-of-a-cup-of-coffee.lisp +++ b/the-price-of-a-cup-of-coffee.lisp @@ -2,31 +2,42 @@ (in-package #:the-price-of-a-cup-of-coffee) -(defun make-keyword-symbol (s) - "Makes a keyword from a string or symbol." - (let ((s (format nil "~a" s))) - (read-from-string - (format nil ":~a" - (substitute #\- #\Space s))))) - - -(defmacro def-normal-class (name super &rest slots) - "Defines a class with the given name and slots, with accessors and initargs for each slot." - `(defclass ,name ,super - (,@(loop :for slot :in slots - :when (consp slot) - :collect (list (car slot) - :accessor (car slot) - :initform (cadr slot) - :initarg (make-keyword-symbol (car slot))) - :else - :collect (list slot - :accessor slot - :initform nil - :initarg (make-keyword-symbol slot)))))) - - -(def-normal-class pedestrian () +(defvar *human-fps* 3) + +(def-normal-class human () + pos + sheet + faces + (face :facing-down) + (frame 0) + (next-frame-at 0)) + +(defmethod initialize-instance :after ((human human) &key) + (with-slots (faces pos) human + (let ((rect (aref (getf faces :facing-down) 0))) + (setf pos + (sdl2:make-rect 0 0 + (sdl2:rect-width rect) + (sdl2:rect-height rect)))))) + +(defgeneric render (sprite renderer)) +(defgeneric update (thing time)) + +(defmethod update ((human human) ticks) + (with-slots (frame next-frame-at faces face) human + (when (<= next-frame-at ticks) + (incf next-frame-at (/ 1000 *human-fps*)) + (setf next-frame-at (max next-frame-at ticks)) + (setf frame (mod (1+ frame) (length (getf faces face))))))) + +(defmethod render ((human human) renderer) + (with-slots (pos sheet faces face frame) human + (sdl2:render-copy renderer sheet + :dest-rect pos + :source-rect (aref (getf faces face) frame)))) + + +(def-normal-class pedestrian (human) (walk-vec (list 2 0)) (comfort-rad 60) (react-per-sec 1) @@ -35,27 +46,120 @@ (generosity 0.25) (vulnerability 3)) - -(def-normal-class () +(def-normal-class hero (human) (stress 0) (money 0) (coldness 0) (sick-p nil) - (speed 5) - (relax-rate 1) + (walking-speed 5) + (relax-rate 1)) + + +(defvar *nance* nil) + +(defun boot-up (renderer) + (setf *nance-tile-defs* (make-source-rects *nance-tile-defs*)) + + (with-surface-from-file (surf +nance-sheet-image+) + (setf *nance* + (make-instance 'hero + :sheet (sdl2:create-texture-from-surface renderer surf) + :faces (create-sprite-faces *nance-tile-defs*))))) + + +(defparameter +frame-delay+ (round (/ 1000 24))) + +(defparameter +action-key+ :scancode-space) + +(defun action-key-pressed () + (print "Action")) + + +(defun walking-face (dir) + (case dir + (:left :walking-left) + (:right :walking-right) + (:up :walking-up) + (:down :walking-down))) + +(defun standing-face (dir) + (case dir + (:left :facing-left) + (:right :facing-right) + (:up :facing-up) + (:down :facing-down))) + +(defun facing-p (human dir) + (equal dir + (case (face human) + ((:facing-down :walking-down) :down) + ((:facing-up :walking-up) :up) + ((:facing-left :walking-left) :left) + ((:facing-right :walking-right) :right)))) + +(defun walk-hero (dir) + (unless (facing-p *nance* dir) + (setf (face *nance*) (walking-face dir)) + (setf (frame *nance*) 0))) + +(defun stop-hero (dir) + (setf (face *nance*) + (standing-face dir)) + (setf (frame *nance*) 0)) + +(defun handle-keydown (keysym) + (let ((key (sdl2:scancode-value keysym))) + (match-key key + (:scancode-left (walk-hero :left)) + (:scancode-right (walk-hero :right)) + (:scancode-up (walk-hero :up)) + (:scancode-down (walk-hero :down))))) + + +(defun handle-keyup (keysym) + (let ((key (sdl2:scancode-value keysym))) + (match-key key + (+action-key+ (action-key-pressed)) + (:scancode-left (stop-hero :left)) + (:scancode-right (stop-hero :right)) + (:scancode-up (stop-hero :up)) + (:scancode-down (stop-hero :down))))) + + +(defmethod render ((game (eql :game)) renderer) + (sdl2:render-clear renderer) + (render *nance* renderer) + (sdl2:render-present renderer)) (defun main () (sdl2:with-init (:everything) (sdl2:with-window (win :w 800 :h 600 :title "The Price Of A Cup Of Coffee" :flags '(:shown)) - (sdl2:with-renderer (rndr win :flags '(:accelerated)) + (sdl2:with-renderer (renderer win :flags '(:accelerated)) + + (boot-up renderer) + (sdl2:with-event-loop (:method :poll) (:keydown (:keysym keysym) (if (sdl2:scancode= (sdl2:scancode-value keysym) :scancode-escape) - (sdl2:push-event :quit))) - (:idle ()) + (sdl2:push-event :quit) + (handle-keydown keysym))) + + (:keyup (:keysym keysym) (handle-keyup keysym)) + + (:idle () + ;; update sprites + (update *nance* (sdl2:get-ticks)) + ;; update tweens + ;; render + (render :game renderer) + (sdl2:delay +frame-delay+)) - (:quit () t)))))) + (:quit () + (free-assets) + t)))))) +(defun free-assets () + (setf (sheet *nance*) nil)) |