[add] frameset class and an [exmaple] using it

2 files changed, 148 insertions, 2 deletions

diff --git a/src/interactive/button.lisp b/src/interactive/button.lisp
index 1c546ba..a885ef0 100644
--- a/src/interactive/button.lisp
+++ b/src/interactive/button.lisp
@@ -27,6 +27,12 @@
         (when on-press
           (funcall on-press target)))))
 
+(defmethod (setf closer-mop:slot-value-using-class) :before
+    (newval class (button button) slot)
+  (case (closer-mop:slot-definition-name slot)
+    ((up down bg)
+     (error "Swapping Button Faces Not Presently Supported"))))
+
 (defmethod initialize-instance :after ((button button) &key)
   (add-handler button #'button-pressed)
   (add-handler button #'button-released)
@@ -123,8 +129,6 @@
     (setf (height up) newval
           (height down) newval)))
 
-
-
 (defun make-texture-button (up down &key pressed released)
   "UP and DOWN should be strings naming assets to use as the up and
   down images for the button."
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))))