diff options
Diffstat (limited to 'tween.scm')
| -rw-r--r-- | tween.scm | 168 |
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 |