From 867703d82c6e8b7a2b424845fcb30537061de45a Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Fri, 1 Jul 2022 09:47:16 -0500
Subject: [add] frameset class and an [exmaple] using it

---
 src/interactive/frameset.lisp | 142 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 142 insertions(+)
 create mode 100644 src/interactive/frameset.lisp

(limited to 'src/interactive/frameset.lisp')

diff --git a/src/interactive/frameset.lisp b/src/interactive/frameset.lisp
new file mode 100644
index 0000000..521b73c
--- /dev/null
+++ b/src/interactive/frameset.lisp
@@ -0,0 +1,142 @@
+;;;; frameset.lisp
+
+(in-package #:wheelwork)
+
+(defclass/std frameset (unit interactive)
+  ((frames :with :doc "an array of renderable frames")
+   (sequence :with :doc "an array of indices into frames")
+   (runningp  :std t)
+   (wait-time :std (/ 1000.0 2) :with :doc "milliseconds between frames")
+   (count index next-time :with :std 0 :a)))
+
+(defmethod (setf fps) (newval (fs frameset))
+  (setf (frameset-wait-time fs) (/ 1000.0 newval)))
+
+(defmethod (setf frameset-index) :before (newval (fs frameset))
+  (setf (unit-visiblep (current-frame-unit fs)) nil))
+
+(defmethod (setf frameset-index) :after (newval (fs frameset))
+  (with-slots (count index) fs 
+    (setf (unit-visiblep (current-frame-unit fs)) t
+          index (mod index count))))
+
+(defmethod (setf runningp) :after (newval (fs frameset))
+  ;; to prevent speedup after restart
+  (setf (frameset-next-time fs) (sdl2:get-ticks)))
+
+(defhandler check-advance-frameset-index
+    (on-perframe (target time)
+      (when (and (runningp target)
+                 (<= (frameset-next-time target) time))
+        (incf (frameset-index target))
+        (incf (frameset-next-time target) (frameset-wait-time target)))))
+
+(defmethod cleanup ((frameset frameset))
+  (loop for frame across (frameset-frames frameset) do (cleanup frame)))
+
+(defmethod initialize-instance :after ((fs frameset) &key)
+  (add-handler fs #'check-advance-frameset-index)
+  (with-slots (index sequence count frames) fs 
+    (setf index 0
+          count (length sequence))
+    (loop for frame across frames
+          when frame
+            do (setf (unit-container frame) fs
+                     (unit-visiblep frame) nil))))
+
+(defun current-frame-unit (fs)
+  "Returns the unit  be currently displaayed as the animation's frame."
+  (with-slots (index sequence count frames) fs
+    (aref frames (aref sequence (mod index count )))))
+
+(defmethod render ((fs frameset))
+  (render (current-frame-unit fs)))
+
+(defmethod x ((fs frameset))
+  (x (current-frame-unit fs)))
+
+(defmethod (setf x) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (x frame) newval)))
+  newval)
+
+(defmethod y ((frameset frameset))
+  (y (current-frame-unit frameset)))
+
+(defmethod (setf y) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (y frame) newval)))
+  newval)
+
+(defmethod scale-x ((frameset frameset))
+  (scale-x (current-frame-unit frameset)))
+
+(defmethod (setf scale-x) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (scale-x frame) newval)))
+  newval)
+
+(defmethod scale-y ((frameset frameset))
+  (scale-y (current-frame-unit frameset)))
+
+(defmethod (setf scale-y) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (scale-y frame) newval)))
+  newval)
+
+(defmethod rotation ((frameset frameset))
+  (rotation (current-frame-unit frameset)))
+
+(defmethod (setf rotation) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (rotation frame) newval)))
+  newval)
+
+(defmethod width ((frameset frameset))
+  (width (current-frame-unit frameset)))
+
+(defmethod (setf width) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (width frame) newval)))
+  newval)
+
+(defmethod height ((frameset frameset))
+  (height (current-frame-unit frameset)))
+
+(defmethod (setf height) (newval (frameset frameset))
+  (with-slots (frames) frameset
+    (loop for frame across frames
+          when frame
+            do (setf (height frame) newval)))
+  newval)
+
+
+(defun make-frameset (sequenced-assets &key (fps 2) asset-args)
+  (let* ((asset-names
+           (remove-duplicates sequenced-assets :test #'equal))
+         (assets
+           (loop for name in asset-names
+                 collect
+                 (make-instance
+                  'bitmap
+                  :texture (get-asset name :asset-args asset-args))))
+         (sequence
+           (loop for name in sequenced-assets
+                 collect (position name asset-names :test #'equal))))
+    (make-instance
+     'frameset
+     :frames (make-array (length assets) :initial-contents assets)
+     :sequence (make-array (length sequence) :initial-contents sequence)
+     :wait-time (/ 1000.0 fps))))
-- 
cgit v1.2.3