Nance walk animations

5 files changed, 254 insertions, 38 deletions

diff --git a/README.org b/README.org
index dd98eee..c64086b 100644
--- a/README.org
+++ b/README.org
@@ -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))