diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/application.lisp | 4 | ||||
| -rw-r--r-- | src/interactive/button.lisp | 8 | ||||
| -rw-r--r-- | src/interactive/frameset.lisp | 142 |
3 files changed, 150 insertions, 4 deletions
diff --git a/src/application.lisp b/src/application.lisp index 2f6747e..d38cd8a 100644 --- a/src/application.lisp +++ b/src/application.lisp @@ -18,7 +18,7 @@ (window :with :a) (refocus-on-mousedown-p :std t) (focus last-motion-target :with :a) - (fps :with :std 30 :doc "Frames Per Second") + (fps :std 30 :doc "Frames Per Second") (frame-wait :r))) @@ -82,7 +82,7 @@ "Runs all of the handlers objects listening for perframe events, if those objects are currently part of the scene tree." (let ((table (perframe-table (listener app))) - (time (get-universal-time))) + (time (sdl2:get-ticks))) (loop for target being the hash-key of table for handlers = (slot-value (listener target) 'perframe) ;; only fire perframe when target is in scene 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)))) |