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