[add] fps control

1 files changed, 16 insertions, 5 deletions

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)))