From 4641997e0f89cdda9ef4b3c17c0a30888b6908f2 Mon Sep 17 00:00:00 2001
From: Boutade <thegoofist@protonmail.com>
Date: Fri, 11 Oct 2019 15:21:35 -0500
Subject: Nance walk animations

---
 the-price-of-a-cup-of-coffee.lisp | 170 ++++++++++++++++++++++++++++++--------
 1 file changed, 137 insertions(+), 33 deletions(-)

(limited to 'the-price-of-a-cup-of-coffee.lisp')

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))
 
-- 
cgit v1.2.3