1\ rubber.fs -- rubber.scm --> rubber.fs
2
3\ Translator: Michael Scholz <mi-scholz@users.sourceforge.net>
4\ Created: 06/01/06 05:32:57
5\ Changed: 17/12/02 03:19:40
6\
7\ @(#)rubber.fs	1.16 12/2/17
8
9\ original comments are taken from rubber.scm [ms]
10\
11\ ;;; rubber.scm: rubber-sound stretches or contracts a sound (in time)
12\ ;;;   (rubber-sound 1.5) makes it 50% longer
13\ ;;;   rubber-sound looks for stable portions and either inserts or deletes
14\ ;;;     periods period length is determined via autocorrelation
15
16require clm
17require marks
18
198             value zeros-checked
2010.0          value extension
21*fth-verbose* value show-details
22
23hide
24\ ;;; remove anything below 16Hz
25\ ;;; extend (src by 1/extension)
26\ ;;; collect upward zero-crossings
27\ ;;;   collect weights for each across next zeros-checked crossings
28\ ;;;   sort by least weight
29\ ;;;   ramp (out or in) and check if done
30
31: derumble-sound { snd chn -- }
32	\ ;; remove rumbles and DC etc (since we're using zero crossings
33	\ ;;   to find period starts)
34	snd chn #f framples { old-len }
35	snd srate { sr }
36	#( 0.0 0.0
37	   16.0 f2* sr f/ 0.0
38	   20.0 f2* sr f/ 1.0
39	   1.0 1.0 ) ( flt-lst )
40	    2.0 old-len sr min flog 2.0 flog f/ fceil ( pow2 )
41	    f** f>s ( fftlen ) snd chn #f undef filter-sound drop
42	old-len snd chn set-framples drop
43;
44
45: sample-sound { snd chn -- }
46	\ ;; prepare sound for analysis by interpolating samples
47	extension 1.0 f<> if
48		extension 1/f 1.0 snd chn #f src-sound drop
49	then
50;
51
52: unsample-sound { snd chn -- }
53	\ ;; undo earlier interpolation
54	extension 1.0 f<> if
55		extension 1.0 snd chn #f src-sound drop
56	then
57;
58
59: crossings { snd chn -- n }
60	\ ;; return number of upward zero crossings that don't look like silence
61	0 0 { crosses last-cross }
62	0 snd chn 1 #f make-sampler { sr0 }
63	sr0 next-sample { samp0 }
64	0.0 { sum }
65	extension 0.001 f* { silence }
66	snd chn #f framples 0 ?do
67		sr0 next-sample { samp1 }
68		samp0 f0<=
69		samp1 f0>          &&
70		i last-cross - 4 > &&
71		sum silence f>     && if
72			crosses 1+ to crosses
73			i to last-cross
74			0.0 to sum
75		then
76		samp0 fabs sum f+ to sum
77		samp1 to samp0
78	loop
79	crosses
80;
81
82: env-add { s0 s1 samps snd chn -- vct }
83	1.0 { x }
84	samps 1/f { xinc }
85	s0 snd chn 1 #f make-sampler { sr0 }
86	s1 snd chn 1 #f make-sampler { sr1 }
87	samps 0.0 make-vct map!
88		sr0 next-sample x f*
89		    sr1 next-sample  1.0 x f-  f*  f+ ( val )
90		x xinc f+ to x
91		( val )
92	end-map ( data )
93;
94
95: rubber-cb { stretch snd chn -- prc; self -- }
96	0 proc-create ( prc ) chn , snd , stretch ,
97 does> { self -- }
98	self @ { chn }
99	self cell+ @ { snd }
100	self 2 cells + @ { stretch }
101	\ ;; prepare sound (get rid of low freqs, resample)
102	snd chn derumble-sound
103	snd chn sample-sound
104	snd chn crossings { crosses }
105	crosses :initial-element 0 make-array { cross-samples }
106	crosses :initial-element 0 make-array { cross-weights }
107	crosses :initial-element 0 make-array { cross-marks }
108	crosses :initial-element 0 make-array { cross-periods }
109	\ ;; get cross points (sample numbers)
110	0 snd chn 1 #f make-sampler { sr0 }
111	sr0 next-sample { samp0 }
112	0.0 { sum }
113	0 { last-cross }
114	extension 0.001 f* { silence }
115	snd chn #f framples 0 ?do
116		sr0 next-sample { samp1 }
117		samp0 f0<=
118		samp1 f0>           &&
119		i last-cross - 40 > &&
120		sum silence f>      && if
121			i to last-cross
122			0.0 to sum
123			cross-samples i cycle-set!
124		then
125		samp0 fabs sum f+ to sum
126		samp1 to samp0
127	loop
128	\ ;; now run through crosses getting period match info
129	crosses 1- 0 ?do
130		cross-samples i array-ref { start }
131		0 { autolen }
132		2.0 extension snd srate 40.0 f/ f*
133		flog 2.0 flog f/ fceil ( pow2 ) f** f>s { fftlen }
134		fftlen 4 / { len4 }
135		start snd chn 1 #f make-sampler { rd }
136		fftlen 0.0 make-vct map! rd next-sample end-map { data }
137		data autocorrelate drop
138		len4 1 ?do
139			data i    vct-ref data i 1+  vct-ref f<
140			data i 1+ vct-ref data i 2 + vct-ref f> && if
141				i 2* to autolen
142				leave
143			then
144		loop
145		start autolen + { next-start }
146		i 1+ { min-i }
147		cross-samples min-i array-ref next-start - abs { min-samps }
148		crosses i zeros-checked + min i 2 + ?do
149			cross-samples i array-ref next-start - abs { dist }
150			dist min-samps < if
151				dist to min-samps
152				i to min-i
153			then
154		loop
155		min-i { current-mark }
156		0.0 { current-min }
157		cross-samples current-mark array-ref { s1 }
158		start snd chn 1 #f make-sampler { sr0 }
159		s1 snd chn 1 #f make-sampler { sr1 }
160		0.0 0.0 { ampsum diffsum }
161		autolen 0 ?do
162			sr0 next-sample { samp0 }
163			sr1 next-sample { samp1 }
164			samp0 fabs ampsum f+ to ampsum
165			samp1 samp0 f- fabs diffsum f+ to diffsum
166		loop
167		diffsum f0= if
168			0.0
169		else
170			diffsum ampsum f/
171		then to current-min
172		current-min f2/ fround->s to min-samps
173		current-mark zeros-checked i + min crosses 1- min { top }
174		top i 1+ ?do
175			0.0 { wgt }
176			cross-samples i array-ref { s1 }
177			start snd chn 1 #f make-sampler { sr0 }
178			s1 snd chn 1 #f make-sampler { sr1 }
179			0.0 0.0 { ampsum diffsum }
180			autolen 0 ?do
181				sr0 next-sample { samp0 }
182				sr1 next-sample { samp1 }
183				samp0 fabs ampsum f+ to ampsum
184				samp1 samp0 f- fabs diffsum f+ to diffsum
185			loop
186			diffsum f0= if
187				0.0
188			else
189				diffsum ampsum f/
190			then to wgt
191			wgt min-samps f< if
192				wgt f>s to min-samps
193				i to min-i
194			then
195		loop
196		current-mark min-i <> if
197			\ ;; these are confused, so effectively erase them
198			cross-weights i 1000.0 array-set!
199		else
200			cross-weights i current-min array-set!
201			cross-marks i current-mark array-set!
202			cross-periods i cross-samples current-mark array-ref
203			cross-samples i array-ref -  array-set!
204		then
205	loop
206	\ ;; now sort weights to scatter the changes as evenly as possible
207	snd chn #f framples { len }
208	stretch 1.0 f> { adding }
209	stretch 1.0 f- fabs len f* floor f>s { samps }
210	adding if
211		samps
212	else
213		len samps 2* min
214	then { needed-samps }
215	0 { handled }
216	#() { edits }
217	begin
218		\ ;; need to find (more than) enough splice pts to delete samps
219		-1      { best-mark }
220		handled { old-handled }
221		0       { cur }
222		cross-weights 0 array-ref { curmin }
223		cross-weights each { val }
224			val curmin f< if
225				i to cur
226				val to curmin
227			then
228		end-each
229		cur to best-mark
230		cross-periods best-mark array-ref handled + to handled
231		handled needed-samps <
232		handled needed-samps - needed-samps old-handled - < || if
233			edits best-mark array-push drop
234		then
235		cross-weights best-mark 1000.0 array-set!
236		edits length crosses =
237		handled needed-samps >= ||
238	until
239	edits length crosses >= if
240		needed-samps handled f/ fceil f>s
241	else
242		1
243	then { mult }
244	0 { changed-len }
245	edits each { best-mark }
246		changed-len samps > ?leave
247		cross-samples best-mark array-ref { beg }
248		cross-samples
249		    cross-marks best-mark array-ref
250		    array-ref { next-beg }
251		cross-periods best-mark array-ref { len }
252		len 0> if
253			adding if
254				beg next-beg len snd chn env-add { new-samps }
255				show-details if
256					beg "%d:%d" #( i len extension f/ f>s )
257					    string-format
258					    snd chn add-named-mark drop
259				then
260				beg len new-samps snd chn #f insert-samples drop
261				mult 1 ?do
262					beg len i * + len new-samps
263					    snd chn #f insert-samples drop
264				loop
265				len mult * changed-len + to changed-len
266				cross-samples each { curbeg }
267					curbeg beg > if
268						cross-samples i
269						    curbeg len + array-set!
270					then
271				end-each
272			else
273				beg snd chn #f framples >= if
274					"trouble at %d: %d of %d"
275					    #( i beg snd chn #f framples )
276					    clm-message
277				then
278				show-details if
279					beg 1- "%d:%d"
280					    #( i len extension f/ f>s )
281					    string-format
282					    snd chn add-named-mark drop
283				then
284				beg len snd chn #f delete-samples drop
285				changed-len len + to changed-len
286				beg len + { end }
287				cross-samples each { curbeg }
288					curbeg beg > if
289						curbeg end < if
290							cross-periods i 0
291							    array-set!
292						else
293							cross-samples i
294							    curbeg len -
295							    array-set!
296						then
297					then
298				end-each
299			then
300		then
301	end-each
302	show-details if
303		"wanted: %d, got %d" #( samps changed-len ) clm-message
304	then
305	\ ;; and return to original srate
306	snd chn unsample-sound
307	show-details if
308		snd chn 0 framples { frms0 }
309		snd chn undef framples { frms }
310		"%d -> %d (%d)"
311		    #( frms0  frms  frms0 stretch f* floor f>s ) clm-message
312	then
313;
314set-current
315
316: rubber-sound { stretch snd chn -- res }
317	"%s %s" #( stretch get-func-name ) string-format { origin }
318	stretch snd chn rubber-cb origin as-one-edit
319;
320previous
321
322\ rubber.fs ends here
323