;;; rubber.scm: rubber-sound stretches or contracts a sound (in time)
;;;   (rubber-sound 1.5) makes it 50% longer
;;;   rubber-sound looks for stable portions and either inserts or deletes periods 
;;;     period length is determined via autocorrelation

(provide 'snd-rubber.scm)

(define zeros-checked 8)
(define extension 10.0)
(define show-details #f)

;;; remove anything below 16Hz
;;; extend (src by 1/extension)
;;; collect upward zero-crossings
;;;   collect weights for each across next zeros-checked crossings
;;;   sort by least weight
;;;   ramp (out or in) and check if done

(define* (rubber-sound stretch snd chn)
  ;; prepare sound (get rid of low freqs, resample)
  
  (define* (add-named-mark samp name snd chn)
    (let ((m (add-mark samp snd chn)))
      (set! (mark-name m) name)
      m))

  (define* (derumble-sound snd chn)
    (let* ((old-length (frames snd chn))
	   (pow2 (ceiling (/ (log (min old-length (srate snd))) (log 2))))
	   (fftlen (floor (expt 2 pow2)))
	   (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)))
      (filter-sound flt-env fftlen snd chn)
      (set! (frames snd chn) old-length)))
  
  (define* (sample-sound snd chn)
    (if (not (= extension 1.0))
	(src-sound (/ 1.0 extension) 1.0 snd chn)))
  
  (define* (unsample-sound snd chn)
    ;; undo earlier interpolation
    (if (not (= extension 1.0))
	(src-sound extension 1.0 snd chn)))
  
  (define (crossings)
    ;; return number of upward zero crossings that don't look like silence
    (let* ((crosses 0)
	   (sr0 (make-sampler 0))
	   (samp0 (next-sample sr0))
	   (len (frames))
	   (sum 0.0)
	   (last-cross 0)
	   (silence (* extension .001)))
      (run
       (do ((i 0 (+ 1 i)))
	   ((= i len))
	 (let ((samp1 (next-sample sr0)))
	   (if (and (<= samp0 0.0)
		    (> samp1 0.0))
	       (if (and (> (- i last-cross) 4)
			(> sum silence))
		   (begin
		     (set! crosses (+ crosses 1))
		     (set! last-cross i)
		     (set! sum 0.0))))
	   (set! sum (+ sum (abs samp0)))
	   (set! samp0 samp1))))
      crosses))
  
  (define (env-add s0 s1 samps)
    (let ((data (make-vct samps))
	  (x 1.0)
	  (xinc (/ 1.0 samps))
	  (sr0 (make-sampler (floor s0)))
	  (sr1 (make-sampler (floor s1))))
      (run
       (do ((i 0 (+ 1 i)))
	   ((= i samps))
	 (vct-set! data i (+ (* x (next-sample sr0))
			     (* (- 1.0 x) (next-sample sr1))))
	 (set! x (+ x xinc))))
      data))
  
  (as-one-edit
   (lambda ()
     (derumble-sound snd chn)
     (sample-sound snd chn)
     
     (let* ((crosses (crossings))
	    (cross-samples (make-vct crosses))
	    (cross-weights (make-vct crosses))
	    (cross-marks (make-vct crosses))
	    (cross-periods (make-vct crosses)))
       (run
	(let* ((sr0 (make-sampler 0 snd chn)) ;; get cross points (sample numbers)
	       (samp0 (next-sample sr0))
	       (len (frames))
	       (sum 0.0)
	       (last-cross 0)
	       (cross 0)
	       (silences 0)
	       (silence (* extension .001)))
	  (do ((i 0 (+ 1 i)))
	      ((= i len))
	    (let ((samp1 (next-sample sr0)))
	      (if (and (<= samp0 0.0)
		       (> samp1 0.0)
		       (> (- i last-cross) 40)
		       (> sum silence))
		  (begin
		    (set! last-cross i)
		    (set! sum 0.0)
		    (vct-set! cross-samples cross i)
		    (set! cross (+ cross 1))))
	      (set! sum (+ sum (abs samp0)))
	      (set! samp0 samp1)))))
       
       ;; now run through crosses getting period match info
       (run
	(do ((i 0 (+ 1 i)))
	    ((= i (- crosses 1)))
	  (let* ((start (floor (vct-ref cross-samples i)))
		 (autolen 0))
	    (let* ((s0 start)
		   (pow2 (ceiling (/ (log (* extension (/ (srate snd) 40.0))) (log 2))))
		   (fftlen (floor (expt 2 pow2)))
		   (len4 (/ fftlen 4))
		   (data (make-vct fftlen))
		   (reader (make-sampler (floor s0))))
	      (do ((j 0 (+ 1 j)))
		  ((= j fftlen))
		(let ((val (next-sample reader)))
		  (vct-set! data j val)))
	      (autocorrelate data)
	      (set! autolen 0)
	      (let ((happy #f))
		(do ((j 1 (+ 1 j)))
		    ((or happy (= j len4)))
		  (if (and (< (vct-ref data j) (vct-ref data (+ j 1)))
			   (> (vct-ref data (+ j 1)) (vct-ref data (+ j 2))))
		      (begin
			(set! autolen (* j 2))
			(set! happy #t))))))
	    (let* ((next-start (+ start autolen))
		   (min-i (+ i 1))
		   (min-samps (floor (abs (- (vct-ref cross-samples min-i) next-start)))))
	      (do ((k (+ i 2) (+ 1 k)))
		  ((= k (min crosses (+ i zeros-checked))))
		(let ((dist (floor (abs (- (vct-ref cross-samples k) next-start)))))
		  (if (< dist min-samps)
		      (begin
			(set! min-samps dist)
			(set! min-i k)))))
	      (let* ((current-mark min-i)
		     (current-min 0.0))
		(let* ((s0 start)
		       (s1 (floor (vct-ref cross-samples current-mark)))
		       (len autolen)
		       (sr0 (make-sampler (floor s0)))
		       (sr1 (make-sampler (floor s1)))
		       (ampsum 0.0)
		       (diffsum 0.0))
		  (do ((i 0 (+ 1 i)))
		      ((= i len))
		    (let ((samp0 (next-sample sr0))
			  (samp1 (next-sample sr1)))
		      (set! ampsum (+ ampsum (abs samp0)))
		      (set! diffsum (+ diffsum (abs (- samp1 samp0))))))
		  (if (= diffsum 0.0)
		      (set! current-min 0.0)
		      (set! current-min (/ diffsum ampsum))))
		(set! min-samps (round (* 0.5 current-min)))
		(let ((top (min (- crosses 1) current-mark (+ i zeros-checked))))
		  (do ((k (+ i 1) (+ 1 k)))
		      ((= k top))
		    (let ((wgt 0.0))
		      (let* ((s0 start)
			     (s1 (floor (vct-ref cross-samples k)))
			     (len autolen)
			     (sr0 (make-sampler (floor s0)))
			     (sr1 (make-sampler (floor s1)))
			     (ampsum 0.0)
			     (diffsum 0.0))
			(do ((i 0 (+ 1 i)))
			    ((= i len))
			  (let ((samp0 (next-sample sr0))
				(samp1 (next-sample sr1)))
			    (set! ampsum (+ ampsum (abs samp0)))
			    (set! diffsum (+ diffsum (abs (- samp1 samp0))))))
			(if (= diffsum 0.0)
			    (set! wgt 0.0)
			    (set! wgt (/ diffsum ampsum))))
		      (if (< wgt min-samps)
			  (begin
			    (set! min-samps (floor wgt))
			    (set! min-i k))))))
		(if (not (= current-mark min-i))
		    (begin
		      ;; these are confused, so effectively erase them
		      (vct-set! cross-weights i 1000.0)
		      )
		    (begin
		      (vct-set! cross-weights i current-min)
		      (vct-set! cross-marks i current-mark)
		      (vct-set! cross-periods i (- (vct-ref cross-samples current-mark) (vct-ref cross-samples i)))
		      ))
		))
	    )))
       ;; now sort weights to scatter the changes as evenly as possible
       (let* ((len (frames snd chn))
	      (adding (> stretch 1.0))
	      (samps (floor (* (abs (- stretch 1.0)) len)))
	      (needed-samps (if adding samps (min len (* samps 2))))
	      (handled 0)
	      (mult 1)
	      (curs 0)
	      (weights (length cross-weights))
	      (edits (make-vct weights)))
	 (run
	  (do ()
	      ((or (= curs weights) (>= handled needed-samps)))
	    ;; need to find (more than) enough splice points to delete samps
	    (let ((best-mark -1)
		  (old-handled handled))
	      (let ((cur 0)
		    (curmin (vct-ref cross-weights 0))
		    (len (length cross-weights)))
		(do ((i 0 (+ 1 i)))
		    ((= i len))
		  (if (< (vct-ref cross-weights i) curmin)
		      (begin
			(set! cur i)
			(set! curmin (vct-ref cross-weights i)))))
		(set! best-mark cur))
	      (set! handled (+ handled (floor (vct-ref cross-periods best-mark))))
	      (if (or (< handled needed-samps)
		      (< (- handled needed-samps) (- needed-samps old-handled)))
		  (begin
		    (vct-set! edits curs best-mark)
		    (set! curs (+ 1 curs))))
	      (vct-set! cross-weights best-mark 1000.0)))
	  )
	 (if (>= curs weights)
	     (set! mult (ceiling (/ needed-samps handled))))
	 
	 (let ((changed-len 0)
	       (weights (length cross-weights)))
	   (do ((i 0 (+ 1 i)))
	       ((or (= i curs) (> changed-len samps)))
	     (let* ((best-mark (floor (vct-ref edits i)))
		    (beg (floor (vct-ref cross-samples best-mark)))
		    (next-beg (floor (vct-ref cross-samples (floor (vct-ref cross-marks best-mark)))))
		    (len (floor (vct-ref cross-periods best-mark))))
	       (if (> len 0)
		   (if adding
		       (let ((new-samps
			      (env-add beg next-beg len)))
			 (if show-details
			     (add-named-mark beg (format #f "~D:~D" i (floor (/ len extension)))))
			 (insert-samples beg len new-samps)
			 (if (> mult 1)
			     (do ((k 1 (+ 1 k)))
				 ((= k mult))
			       (insert-samples (+ beg (* k len)) len new-samps)))
			 (set! changed-len (+ changed-len (* mult len)))
			 (do ((j 0 (+ 1 j)))
			     ((= j weights))
			   (let ((curbeg (floor (vct-ref cross-samples j))))
			     (if (> curbeg beg)
				 (vct-set! cross-samples j (+ curbeg len))))))
		       (begin
			 (if (>= beg (frames))
			     (snd-print (format #f "trouble at ~D: ~D of ~D~%" i beg (frames))))
			 (if show-details
			     (add-named-mark (- beg 1) (format #f "~D:~D" i (floor (/ len extension)))))
			 (delete-samples beg len)
			 (set! changed-len (+ changed-len len))
			 (let ((end (+ beg len)))
			   (do ((j 0 (+ 1 j)))
			       ((= j weights))
			     (let ((curbeg (floor (vct-ref cross-samples j))))
			       (if (> curbeg beg)
				   (if (< curbeg end)
				       (vct-set! cross-periods j 0)
				       (vct-set! cross-samples j (- curbeg len))))))))))))
	   (if show-details
	       (snd-print (format #f "wanted: ~D, got ~D~%" (floor samps) (floor changed-len)))))
	 ))
     ;; and return to original srate
     (unsample-sound snd chn)
     (if show-details
	 (snd-print (format #f "~A -> ~A (~A)~%" (frames snd chn 0) (frames snd chn) (floor (* stretch (frames snd chn 0))))))
     ) ; end of as-one-edit thunk
   (format #f "rubber-sound ~A" stretch)))