diff options
| -rw-r--r-- | examples/02-moving-bitmp.lisp | 2 | ||||
| -rw-r--r-- | wheelwork.lisp | 21 |
2 files changed, 17 insertions, 6 deletions
diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp index 8e5f55b..3a7fbc9 100644 --- a/examples/02-moving-bitmp.lisp +++ b/examples/02-moving-bitmp.lisp @@ -88,8 +88,8 @@ (defun start () (ww::start (make-instance 'bitmap-display :scale 2.0 + :fps 30 :asset-root #P"~/projects/wheelwork/examples/"))) - diff --git a/wheelwork.lisp b/wheelwork.lisp index d0982cb..d23cd7f 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -91,8 +91,14 @@ order). Makes sure to remove the unit from its current container if necessary." (window :with :a) (refocus-on-mousedown-p :std t) (focus last-motion-target :with :a) - (frame-wait :std (/ 1000 30) :doc "Frames Per Second" :a))) + (fps :with :std 30 :doc "Frames Per Second") + (frame-wait :r))) +(defun fps (&optional (app *application*)) + (application-fps app)) + +(defun (setf fps) (new-val &optional (app *application*)) + (setf (application-fps app) new-val)) (defun can-set-projection-p (app) (and (slot-boundp app 'width) @@ -111,9 +117,14 @@ order). Makes sure to remove the unit from its current container if necessary." (defmethod (setf closer-mop:slot-value-using-class) :after (new-value class (app application) slot) - (when (member (closer-mop:slot-definition-name slot) - '(scale width height)) - (set-projection app))) + (let ((slot-name + (closer-mop:slot-definition-name slot))) + (cond + ((member slot-name '(scale width height)) + (set-projection app)) + ((eql slot-name 'fps) + (setf (slot-value app 'frame-wait) (/ 1.0 new-value)))))) + (defgeneric boot (app) (:documentation "Specialized for each subclass of @@ -190,7 +201,7 @@ order). Makes sure to remove the unit from its current container if necessary." (dolist (thing (container-units app)) (render thing)) (sdl2:gl-swap-window (application-window app)) - (sleep (/ 1.0 30) )) + (sleep (frame-wait app))) |