Real at-rate function and init values in reactive context

[gacela.git] / gacela / react.scm

diff --git a/gacela/react.scm b/gacela/react.scm
index e9d0668b323e29764440362b9f9e5b5f16206110..76c76f55a83906034a003f445b42376fd1b35a66 100644 (file)
--- a/gacela/react.scm
+++ b/gacela/react.scm
@@ -20,20 +20,63 @@
   #:export (context
             at-rate))
 
+
+;; Time Stack
+
+(define time-stack '())
+
+(define (push-init-time init-time)
+  (set! time-stack (cons init-time time-stack)))
+
+(define (pop-init-time)
+  (set! time-stack (cdr time-stack)))
+
+(define (head-init-time)
+  (car time-stack))
+
+
+;; Reactive context
+
 (define-syntax context
-  (syntax-rules ()
-    ((_ ((variable value)
-         ...)
-        scene)
-     (make-scene
-      "context"
-      (let* ((variable value)
-             ...)
-        (lambda ()
-          (begin
-            (set! variable value)
-            ...)
-          (display-scene scene)))))))
+  (lambda (x)
+    (define (transform vars)
+      (let ((datum (map (lambda (v) (syntax->datum v)) vars)))
+        (map (lambda (v) (datum->syntax x v))
+             (map (lambda (v)
+                    (cond ((and (= (length v) 4) (equal? (caddr v) '<=))
+                           (list (car v) (cadr v) (cadddr v)))
+                          ((= (length v) 2)
+                           (list (car v) (cadr v) 0))
+                          (else
+                           v)))
+                  datum))))
+    (syntax-case x (<=)
+      ((_ ((variable value <= init-value)
+           ...)
+          scene)
+       #'(make-scene
+          "context"
+          (let* ((variable init-value)
+                 ...
+                 (?init-time (get-internal-real-time)))
+            (lambda ()
+              (push-init-time ?init-time)
+              (begin
+                (set! variable value)
+                ...)
+              (display-scene scene)
+              (pop-init-time)))))
+      ((_ ((variable value value* ...)
+           ...)
+          scene)
+       (with-syntax ((((variable1 value1 init-value1) ...) (transform #'((variable value value* ...) ...))))
+         #'(context ((variable1 value1 <= init-value1)
+                     ...)
+                    scene))))))
+
+
+;; Rate based functions
 
 (define (at-rate value)
-  0)
+  (let ((delta (- (get-internal-real-time) (head-init-time))))
+    (* value (/ delta 1000.0))))