1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
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
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
|
