"Fossies" - the Fresh Open Source Software Archive

Member "snd-20.9/rubber.scm" (11 Apr 2018, 9423 Bytes) of package /linux/misc/snd-20.9.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ;;; rubber.scm: rubber-sound stretches or contracts a sound (in time)
    2 ;;;   (rubber-sound 1.5) makes it 50% longer
    3 ;;;   rubber-sound looks for stable portions and either inserts or deletes periods 
    4 ;;;     period length is determined via autocorrelation
    5 
    6 (provide 'snd-rubber.scm)
    7 
    8 (define zeros-checked 8)
    9 (define extension 10.0)
   10 (define show-details #f)
   11 
   12 ;;; remove anything below 16Hz
   13 ;;; extend (src by 1/extension)
   14 ;;; collect upward zero-crossings
   15 ;;;   collect weights for each across next zeros-checked crossings
   16 ;;;   sort by least weight
   17 ;;;   ramp (out or in) and check if done
   18 
   19 (define rubber-sound 
   20   ;; prepare sound (get rid of low freqs, resample)
   21   (let ()
   22     (define* (add-named-mark samp name snd chn)
   23       (let ((m (add-mark samp snd chn)))
   24     (set! (mark-name m) name)
   25     m))
   26     
   27     (define* (derumble-sound snd chn)
   28       (let ((old-length (framples snd chn)))
   29     (let ((fftlen (floor (expt 2 (ceiling (log (min old-length (srate snd)) 2)))))
   30           (flt-env (list 0.0 0.0 (/ (* 2 16.0) (srate snd)) 0.0 (/ (* 2 20.0) (srate snd)) 1.0 1.0 1.0)))
   31       (filter-sound flt-env fftlen snd chn)
   32       (set! (framples snd chn) old-length))))
   33     
   34     (define* (sample-sound snd chn)
   35       (if (not (= extension 1.0))
   36       (src-sound (/ 1.0 extension) 1.0 snd chn)))
   37     
   38     (define* (unsample-sound snd chn)
   39       ;; undo earlier interpolation
   40       (if (not (= extension 1.0))
   41       (src-sound extension 1.0 snd chn)))
   42     
   43     (define (crossings)
   44       ;; return number of upward zero crossings that don't look like silence
   45       (let ((sr0 (make-sampler 0)))
   46     (do ((samp0 (next-sample sr0))
   47          (crosses 0)
   48          (len (framples))
   49          (sum 0.0)
   50          (last-cross 0)
   51          (silence (* extension .001))
   52          (i 0 (+ i 1)))
   53         ((= i len)
   54          crosses)
   55       (let ((samp1 (next-sample sr0)))
   56         (if (and (<= samp0 0.0)
   57              (> samp1 0.0)
   58              (> (- i last-cross) 4)
   59              (> sum silence))
   60         (begin
   61           (set! crosses (+ crosses 1))
   62           (set! last-cross i)
   63           (set! sum 0.0)))
   64         (set! sum (+ sum (abs samp0)))
   65         (set! samp0 samp1)))))
   66     
   67     (define (env-add s0 s1 samps)
   68       (let ((data (make-float-vector samps))
   69         (x 1.0)
   70         (xinc (/ 1.0 samps))
   71         (sr0 (make-sampler (floor s0)))
   72         (sr1 (make-sampler (floor s1))))
   73     (do ((i 0 (+ i 1)))
   74         ((= i samps))
   75       (set! (data i) (+ (* x (next-sample sr0))
   76                 (* (- 1.0 x) (next-sample sr1))))
   77       (set! x (+ x xinc)))
   78     data))
   79 
   80     (lambda* (stretch snd chn)
   81       (as-one-edit
   82        (lambda ()
   83      (derumble-sound snd chn)
   84      (sample-sound snd chn)
   85      
   86      (let ((crosses (crossings)))
   87        (let ((cross-samples (make-float-vector crosses))
   88          (cross-weights (make-float-vector crosses))
   89          (cross-marks (make-float-vector crosses))
   90          (cross-periods (make-float-vector crosses)))
   91          (let ((sr0 (make-sampler 0 snd chn))) ;; get cross points (sample numbers)
   92            (do ((samp0 (next-sample sr0))
   93             (len (framples))
   94             (sum 0.0)
   95             (last-cross 0)
   96             (cross 0)
   97             (silence (* extension .001))
   98             (i 0 (+ i 1)))
   99            ((= i len))
  100          (let ((samp1 (next-sample sr0)))
  101            (if (and (<= samp0 0.0)
  102                 (> samp1 0.0)
  103                 (> (- i last-cross) 40)
  104                 (> sum silence))
  105                (begin
  106              (set! last-cross i)
  107              (set! sum 0.0)
  108              (set! (cross-samples cross) i)
  109              (set! cross (+ cross 1))))
  110            (set! sum (+ sum (abs samp0)))
  111            (set! samp0 samp1))))
  112          
  113          ;; now run through crosses getting period match info
  114          (do ((i 0 (+ i 1)))
  115          ((= i (- crosses 1)))
  116            (let ((start (floor (cross-samples i)))
  117              (autolen 0))
  118          (let ((fftlen (floor (expt 2 (ceiling (log (* extension (/ (srate snd) 40.0)) 2))))))
  119            (let ((len4 (/ fftlen 4))
  120              (data (samples (floor start) fftlen)))
  121              (autocorrelate data)
  122              (set! autolen 0)
  123              (do ((happy #f)
  124               (j 1 (+ 1 j)))
  125              ((or happy (= j len4)))
  126                (when (and (< (data j) (data (+ j 1)))
  127                   (> (data (+ j 1)) (data (+ j 2))))
  128              (set! autolen (* j 2))
  129              (set! happy #t)))))
  130          (let* ((next-start (+ start autolen))
  131             (min-i (+ i 1))
  132             (min-samps (floor (abs (- (cross-samples min-i) next-start))))
  133             (mink (min crosses (+ i zeros-checked))))
  134            (do ((k (+ i 2) (+ k 1)))
  135                ((= k mink))
  136              (let ((dist (floor (abs (- (cross-samples k) next-start)))))
  137                (if (< dist min-samps)
  138                (begin
  139                  (set! min-samps dist)
  140                  (set! min-i k)))))
  141            (let ((current-mark min-i)
  142              (current-min 0.0))
  143              
  144              (let ((ampsum (make-one-pole 1.0 -1.0))
  145                (diffsum (make-one-pole 1.0 -1.0)))
  146                (do ((sr0 (make-sampler (floor start)))
  147                 (sr1 (make-sampler (floor (cross-samples current-mark))))
  148                 (samp0 0.0)
  149                 (i 0 (+ i 1)))
  150                ((= i autolen))
  151              (set! samp0 (next-sample sr0))
  152              (one-pole ampsum (abs samp0))
  153              (one-pole diffsum (abs (- (next-sample sr1) samp0))))
  154                (set! diffsum (one-pole diffsum 0.0))
  155                (set! ampsum (one-pole ampsum 0.0))
  156                (set! current-min (if (= diffsum 0.0) 0.0 (/ diffsum ampsum))))
  157              
  158              (set! min-samps (round (* 0.5 current-min)))
  159              (do ((top (min (- crosses 1) current-mark (+ i zeros-checked)))
  160               (k (+ i 1) (+ k 1))
  161               (wgt 0.0 0.0))
  162              ((= k top))
  163                (let ((ampsum (make-one-pole 1.0 -1.0))
  164                  (diffsum (make-one-pole 1.0 -1.0)))
  165              (do ((sr0 (make-sampler (floor start)))
  166                   (sr1 (make-sampler (floor (cross-samples k))))
  167                   (samp0 0.0)
  168                   (i 0 (+ i 1)))
  169                  ((= i autolen))
  170                (set! samp0 (next-sample sr0))
  171                (one-pole ampsum (abs samp0))
  172                (one-pole diffsum (abs (- (next-sample sr1) samp0))))
  173              (set! diffsum (one-pole diffsum 0.0))
  174              (set! ampsum (one-pole ampsum 0.0))
  175              (set! wgt (if (= diffsum 0.0) 0.0 (/ diffsum ampsum))))
  176                
  177                (if (< wgt min-samps)
  178                (begin
  179                  (set! min-samps (floor wgt))
  180                  (set! min-i k))))
  181              
  182              (if (not (= current-mark min-i))
  183              (set! (cross-weights i) 1000.0) ; these are confused, so effectively erase them
  184              (begin
  185                (set! (cross-weights i) current-min)
  186                (set! (cross-marks i) current-mark)
  187                (set! (cross-periods i) (- (cross-samples current-mark) (cross-samples i)))
  188                ))))))
  189          ;; now sort weights to scatter the changes as evenly as possible
  190          (let ((len (framples snd chn)))
  191            (let ((adding (> stretch 1.0))
  192              (samps (floor (* (abs (- stretch 1.0)) len)))
  193              (weights (length cross-weights)))
  194          (let ((needed-samps (if adding samps (min len (* samps 2))))
  195                (handled 0)
  196                (mult 1)
  197                (curs 0)
  198                (edits (make-float-vector weights)))
  199            (do ((best-mark -1 -1)
  200             (old-handled handled handled))
  201                ((or (= curs weights) (>= handled needed-samps)))
  202              ;; need to find (more than) enough splice points to delete samps
  203              (let ((cur 0)
  204                (curmin (cross-weights 0))
  205                (len (length cross-weights)))
  206                (do ((i 0 (+ i 1)))
  207                ((= i len))
  208              (if (< (cross-weights i) curmin)
  209                  (begin
  210                    (set! cur i)
  211                    (set! curmin (cross-weights i)))))
  212                (set! best-mark cur))
  213              (set! handled (+ handled (floor (cross-periods best-mark))))
  214              (if (or (< handled needed-samps)
  215                  (< (- handled needed-samps) (- needed-samps old-handled)))
  216              (begin
  217                (set! (edits curs) best-mark)
  218                (set! curs (+ 1 curs))))
  219              (set! (cross-weights best-mark) 1000.0))
  220            
  221            (if (>= curs weights)
  222                (set! mult (ceiling (/ needed-samps handled))))
  223            
  224            (do ((changed-len 0)
  225             (weights (length cross-weights))
  226             (i 0 (+ i 1)))
  227                ((or (= i curs) 
  228                 (> changed-len samps))
  229             (if show-details
  230                 (snd-print (format #f "wanted: ~D, got ~D~%" (floor samps) (floor changed-len)))))
  231              (let* ((best-mark (floor (edits i)))
  232                 (beg (floor (cross-samples best-mark)))
  233                 (next-beg (floor (cross-samples (floor (cross-marks best-mark)))))
  234                 (len (floor (cross-periods best-mark))))
  235                (when (> len 0)
  236              (if adding
  237                  (let ((new-samps
  238                     (env-add beg next-beg len)))
  239                    (if show-details
  240                    (add-named-mark beg (format #f "~D:~D" i (floor (/ len extension)))))
  241                    (insert-samples beg len new-samps)
  242                    (if (> mult 1)
  243                    (do ((k 1 (+ k 1)))
  244                        ((= k mult))
  245                      (insert-samples (+ beg (* k len)) len new-samps)))
  246                    (set! changed-len (+ changed-len (* mult len)))
  247                    (do ((j 0 (+ 1 j)))
  248                    ((= j weights))
  249                  (let ((curbeg (floor (cross-samples j))))
  250                    (if (> curbeg beg)
  251                        (set! (cross-samples j) (+ curbeg len))))))
  252                  (begin
  253                    (if (>= beg (framples))
  254                    (snd-print (format #f "trouble at ~D: ~D of ~D~%" i beg (framples))))
  255                    (if show-details
  256                    (add-named-mark (- beg 1) (format #f "~D:~D" i (floor (/ len extension)))))
  257                    (delete-samples beg len)
  258                    (set! changed-len (+ changed-len len))
  259                    (do ((end (+ beg len))
  260                     (j 0 (+ 1 j)))
  261                    ((= j weights))
  262                  (let ((curbeg (floor (cross-samples j))))
  263                    (if (> curbeg beg)
  264                        (if (< curbeg end)
  265                        (set! (cross-periods j) 0)
  266                        (set! (cross-samples j) (- curbeg len)))))))))))
  267            )))))
  268      ;; and return to original srate
  269      (unsample-sound snd chn)
  270      (if show-details
  271          (snd-print (format #f "~A -> ~A (~A)~%" (framples snd chn 0) (framples snd chn) (floor (* stretch (framples snd chn 0))))))
  272      ) ; end of as-one-edit thunk
  273        (format #f "rubber-sound ~A" stretch)))))
  274