Added tweens

1 files changed, 168 insertions, 0 deletions

diff --git a/tween.scm b/tween.scm
new file mode 100644
index 0000000..eb8abc3
--- /dev/null
+++ b/tween.scm
@@ -0,0 +1,168 @@
+(module downstroke-tween *
+  (import scheme
+          (chicken base)
+          (chicken keyword)
+          (only srfi-1 fold)
+          defstruct
+          downstroke-entity)
+
+  ;; ── Easing: t in [0,1] → eased factor in [0,1] for linear interpolation ──
+
+  (define (ease-linear t) t)
+
+  (define (ease-quad-in t) (* t t))
+
+  (define (ease-quad-out t)
+    (- 1 (* (- 1 t) (- 1 t))))
+
+  (define (ease-quad-in-out t)
+    (if (< t 0.5)
+        (* 2 t t)
+        (- 1 (* 2 (- 1 t) (- 1 t)))))
+
+  (define (ease-cubic-in t) (* t t t))
+
+  (define (ease-cubic-out t)
+    (- 1 (expt (- 1 t) 3)))
+
+  (define (ease-cubic-in-out t)
+    (if (< t 0.5)
+        (* 4 t t t)
+        (- 1.0 (/ (expt (- 2 (* 2 t)) 3) 2))))
+
+  (define (ease-sine-in-out t)
+    (- 0.5 (* 0.5 (cos (* 3.14159265358979323846 t)))))
+
+  (define (ease-expo-in t)
+    (if (zero? t) 0.0 (expt 2 (* 10 (- t 1)))))
+
+  (define (ease-expo-out t)
+    (if (>= t 1) 1.0 (- 1.0 (expt 2 (* -10 t)))))
+
+  (define (ease-expo-in-out t)
+    (cond ((<= t 0) 0.0)
+          ((>= t 1) 1.0)
+          ((< t 0.5) (/ (expt 2 (- (* 20 t) 10)) 2))
+          (else (- 1 (/ (expt 2 (+ (* -20 t) 10)) 2)))))
+
+  ;; Overshoots past 1 then settles (Robert Penner back-out, s ≈ 1.70158)
+  (define (ease-back-out t)
+    (let ((s 1.70158)
+          (u (- t 1)))
+      (+ 1 (* (+ 1 s) (expt u 3)) (* s (expt u 2)))))
+
+  ;; ── Symbol → ease procedure ───────────────────────────────────────────────
+
+  (define *ease-table*
+    `((linear . ,ease-linear)
+      (quad-in . ,ease-quad-in)
+      (quad-out . ,ease-quad-out)
+      (quad-in-out . ,ease-quad-in-out)
+      (cubic-in . ,ease-cubic-in)
+      (cubic-out . ,ease-cubic-out)
+      (cubic-in-out . ,ease-cubic-in-out)
+      (sine-in-out . ,ease-sine-in-out)
+      (expo-in . ,ease-expo-in)
+      (expo-out . ,ease-expo-out)
+      (expo-in-out . ,ease-expo-in-out)
+      (back-out . ,ease-back-out)))
+
+  (define (ease-named sym)
+    (cond ((assq sym *ease-table*) => cdr)
+          (else (error "ease-named: unknown ease symbol" sym))))
+
+  (define (ease-resolve ease)
+    (cond ((procedure? ease) ease)
+          ((symbol? ease) (ease-named ease))
+          (else (error "ease-resolve: expected symbol or procedure" ease))))
+
+  ;; ── Tween struct (internal) ───────────────────────────────────────────────
+
+  (defstruct tw
+    starts          ;; alist: (key . start-num)
+    ends            ;; alist: (key . end-num)
+    duration        ;; ms, > 0
+    delay           ;; ms, >= 0
+    ease-fn         ;; number → number
+    elapsed         ;; ms since tween started (includes delay period)
+    done?           ;; boolean
+    callback)       ;; (entity → unspecified) or #f; invoked once at completion
+
+  ;; ── Public API ────────────────────────────────────────────────────────────
+
+  (define (tween-finished? t) (tw-done? t))
+
+  (define (tween-active? t) (not (tw-done? t)))
+
+  ;; props: alist of (keyword . target-number), e.g. ((#:x . 200) (#:y . 40))
+  (define (make-tween entity #!key props (duration 500) (delay 0) (ease 'linear)
+                      (on-complete #f))
+    (unless (and (integer? duration) (> duration 0))
+      (error "make-tween: duration must be a positive integer (ms)" duration))
+    (unless (and (integer? delay) (>= delay 0))
+      (error "make-tween: delay must be a non-negative integer (ms)" delay))
+    (unless (pair? props)
+      (error "make-tween: props must be a non-empty alist" props))
+    (let ((ease-fn (ease-resolve ease))
+          (starts (map (lambda (p)
+                         (let ((k (car p)))
+                           (unless (keyword? k)
+                             (error "make-tween: property keys must be keywords" k))
+                           (cons k (entity-ref entity k 0))))
+                       props)))
+      (make-tw starts: starts
+               ends: props
+               duration: duration
+               delay: delay
+               ease-fn: ease-fn
+               elapsed: 0
+               done?: #f
+               callback: on-complete)))
+
+  ;; Linear interpolation with eased factor u in [0,1]
+  (define (lerp a b u)
+    (+ a (* (- b a) u)))
+
+  (define (apply-props entity starts ends u)
+    (fold (lambda (end-pair ent)
+            (let* ((k (car end-pair))
+                   (end (cdr end-pair))
+                   (start (cdr (assq k starts))))
+              (entity-set ent k (lerp start end u))))
+          entity
+          ends))
+
+  (define (tween-step tw entity dt)
+    (unless (tw? tw) (error "tween-step: expected tween struct" tw))
+    (if (tw-done? tw)
+        (values tw entity)
+        (let* ((elapsed (+ (tw-elapsed tw) dt))
+               (delay (tw-delay tw))
+               (duration (tw-duration tw))
+               (ease-fn (tw-ease-fn tw))
+               (starts (tw-starts tw))
+               (ends (tw-ends tw)))
+          (cond ((< elapsed delay)
+                 (values (make-tw starts: starts ends: ends duration: duration
+                                  delay: delay ease-fn: ease-fn
+                                  elapsed: elapsed done?: #f callback: (tw-callback tw))
+                         entity))
+                (else
+                 (let* ((t0 (- elapsed delay))
+                        (u-raw (/ t0 duration))
+                        (u (min 1.0 (max 0.0 u-raw)))
+                        (eased (ease-fn u))
+                        (ent2 (apply-props entity starts ends eased)))
+                   (if (>= u 1.0)
+                       (let* ((final (apply-props entity starts ends 1.0))
+                              (cb (tw-callback tw))
+                              (_ (when cb (cb final)))
+                              (tw2 (make-tw starts: starts ends: ends duration: duration
+                                             delay: delay ease-fn: ease-fn
+                                             elapsed: elapsed done?: #t callback: #f)))
+                         (values tw2 final))
+                       (values (make-tw starts: starts ends: ends duration: duration
+                                        delay: delay ease-fn: ease-fn
+                                        elapsed: elapsed done?: #f callback: (tw-callback tw))
+                               ent2))))))))
+) ;; end module