diff options
Diffstat (limited to 'tween.scm')
| -rw-r--r-- | tween.scm | 410 |
1 files changed, 205 insertions, 205 deletions
@@ -1,207 +1,207 @@ (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 - repeat ;; -1 = infinite, 0 = no more repeats, N = N repeats remaining - yoyo?) ;; swap starts/ends on each repeat cycle - -;; ── 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) (repeat 0) (yoyo? #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)) - (unless (and (integer? repeat) (>= repeat -1)) - (error "make-tween: repeat must be -1 (infinite) or a non-negative integer" repeat)) - (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 - repeat: repeat - yoyo?: yoyo?))) - -;; 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 (tw-with-elapsed tw elapsed) - (make-tw starts: (tw-starts tw) ends: (tw-ends tw) - duration: (tw-duration tw) delay: (tw-delay tw) - ease-fn: (tw-ease-fn tw) elapsed: elapsed - done?: #f callback: (tw-callback tw) - repeat: (tw-repeat tw) yoyo?: (tw-yoyo? tw))) - -(define (tw-finish tw elapsed) - (make-tw starts: (tw-starts tw) ends: (tw-ends tw) - duration: (tw-duration tw) delay: (tw-delay tw) - ease-fn: (tw-ease-fn tw) elapsed: elapsed - done?: #t callback: #f - repeat: 0 yoyo?: (tw-yoyo? tw))) - -(define (tw-next-cycle tw overflow) - (let* ((yoyo? (tw-yoyo? tw)) - (starts (tw-starts tw)) - (ends (tw-ends tw))) - (make-tw starts: (if yoyo? ends starts) - ends: (if yoyo? starts ends) - duration: (tw-duration tw) delay: 0 - ease-fn: (tw-ease-fn tw) elapsed: overflow + (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 + repeat ;; -1 = infinite, 0 = no more repeats, N = N repeats remaining + yoyo?) ;; swap starts/ends on each repeat cycle + + ;; ── 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) (repeat 0) (yoyo? #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)) + (unless (and (integer? repeat) (>= repeat -1)) + (error "make-tween: repeat must be -1 (infinite) or a non-negative integer" repeat)) + (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 + repeat: repeat + yoyo?: yoyo?))) + + ;; 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 (tw-with-elapsed tw elapsed) + (make-tw starts: (tw-starts tw) ends: (tw-ends tw) + duration: (tw-duration tw) delay: (tw-delay tw) + ease-fn: (tw-ease-fn tw) elapsed: elapsed done?: #f callback: (tw-callback tw) - repeat: (let ((r (tw-repeat tw))) (if (= r -1) -1 (- r 1))) - yoyo?: yoyo?))) - -(define (tween-complete tw entity elapsed) - (let ((final (apply-props entity (tw-starts tw) (tw-ends tw) 1.0))) - (if (zero? (tw-repeat tw)) - (begin - (when (tw-callback tw) ((tw-callback tw) final)) - (values (tw-finish tw elapsed) final)) - (let ((overflow (- (- elapsed (tw-delay tw)) (tw-duration tw)))) - (values (tw-next-cycle tw overflow) final))))) - -(define (tween-interpolate tw entity elapsed) - (let* ((t0 (- elapsed (tw-delay tw))) - (u (min 1.0 (max 0.0 (/ t0 (tw-duration tw))))) - (eased ((tw-ease-fn tw) u)) - (ent2 (apply-props entity (tw-starts tw) (tw-ends tw) eased))) - (if (>= u 1.0) - (tween-complete tw entity elapsed) - (values (tw-with-elapsed tw elapsed) ent2)))) - -(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))) - (if (< elapsed (tw-delay tw)) - (values (tw-with-elapsed tw elapsed) entity) - (tween-interpolate tw entity elapsed))))) - -;; ── Pipeline step ────────────────────────────────────────────────────────── -;; Auto-advance #:tween on an entity. Call from update: as part of the -;; per-entity pipeline, e.g. (step-tweens entity dt). Removes #:tween -;; when the tween finishes. - -(define-pipeline (step-tweens tweens) (scene entity dt) - guard: (entity-ref entity #:tween #f) - (let ((tw (entity-ref entity #:tween))) - (receive (tw2 ent2) (tween-step tw entity dt) - (if (tween-finished? tw2) - (entity-set ent2 #:tween #f) - (entity-set ent2 #:tween tw2))))) - -) ;; end module + repeat: (tw-repeat tw) yoyo?: (tw-yoyo? tw))) + + (define (tw-finish tw elapsed) + (make-tw starts: (tw-starts tw) ends: (tw-ends tw) + duration: (tw-duration tw) delay: (tw-delay tw) + ease-fn: (tw-ease-fn tw) elapsed: elapsed + done?: #t callback: #f + repeat: 0 yoyo?: (tw-yoyo? tw))) + + (define (tw-next-cycle tw overflow) + (let* ((yoyo? (tw-yoyo? tw)) + (starts (tw-starts tw)) + (ends (tw-ends tw))) + (make-tw starts: (if yoyo? ends starts) + ends: (if yoyo? starts ends) + duration: (tw-duration tw) delay: 0 + ease-fn: (tw-ease-fn tw) elapsed: overflow + done?: #f callback: (tw-callback tw) + repeat: (let ((r (tw-repeat tw))) (if (= r -1) -1 (- r 1))) + yoyo?: yoyo?))) + + (define (tween-complete tw entity elapsed) + (let ((final (apply-props entity (tw-starts tw) (tw-ends tw) 1.0))) + (if (zero? (tw-repeat tw)) + (begin + (when (tw-callback tw) ((tw-callback tw) final)) + (values (tw-finish tw elapsed) final)) + (let ((overflow (- (- elapsed (tw-delay tw)) (tw-duration tw)))) + (values (tw-next-cycle tw overflow) final))))) + + (define (tween-interpolate tw entity elapsed) + (let* ((t0 (- elapsed (tw-delay tw))) + (u (min 1.0 (max 0.0 (/ t0 (tw-duration tw))))) + (eased ((tw-ease-fn tw) u)) + (ent2 (apply-props entity (tw-starts tw) (tw-ends tw) eased))) + (if (>= u 1.0) + (tween-complete tw entity elapsed) + (values (tw-with-elapsed tw elapsed) ent2)))) + + (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))) + (if (< elapsed (tw-delay tw)) + (values (tw-with-elapsed tw elapsed) entity) + (tween-interpolate tw entity elapsed))))) + + ;; ── Pipeline step ────────────────────────────────────────────────────────── + ;; Auto-advance #:tween on an entity. Call from update: as part of the + ;; per-entity pipeline, e.g. (step-tweens entity dt). Removes #:tween + ;; when the tween finishes. + + (define-pipeline (step-tweens tweens) (scene entity dt) + guard: (entity-ref entity #:tween #f) + (let ((tw (entity-ref entity #:tween))) + (receive (tw2 ent2) (tween-step tw entity dt) + (if (tween-finished? tw2) + (entity-set ent2 #:tween #f) + (entity-set ent2 #:tween tw2))))) + + ) ;; end module |