;;; 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 (framples snd chn))
	   (pow2 (ceiling (log (min old-length (srate snd)) 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! (framples 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 (framples))
	   (sum 0.0)
	   (last-cross 0)
	   (silence (* extension .001)))
       (do ((i 0 (+ i 1)))
	   ((= i len))
	 (let ((samp1 (next-sample sr0)))
	   (if (and (<= samp0 0.0)
		    (> samp1 0.0)
		    (> (- 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-float-vector samps))
	  (x 1.0)
	  (xinc (/ 1.0 samps))
	  (sr0 (make-sampler (floor s0)))
	  (sr1 (make-sampler (floor s1))))
       (do ((i 0 (+ i 1)))
	   ((= i samps))
	 (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-float-vector crosses))
	    (cross-weights (make-float-vector crosses))
	    (cross-marks (make-float-vector crosses))
	    (cross-periods (make-float-vector crosses)))
	(let* ((sr0 (make-sampler 0 snd chn)) ;; get cross points (sample numbers)
	       (samp0 (next-sample sr0))
	       (len (framples))
	       (sum 0.0)
	       (last-cross 0)
	       (cross 0)
	       (silence (* extension .001)))
	  (do ((i 0 (+ i 1)))
	      ((= 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)
		    (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
	(do ((i 0 (+ i 1)))
	    ((= i (- crosses 1)))
	  (let ((start (floor (cross-samples i)))
		(autolen 0))
	    (let* ((s0 start)
		   (pow2 (ceiling (log (* extension (/ (srate snd) 40.0)) 2)))
		   (fftlen (floor (expt 2 pow2)))
		   (len4 (/ fftlen 4))
		   (data (samples (floor s0) fftlen)))
	      (autocorrelate data)
	      (set! autolen 0)
	      (let ((happy #f))
		(do ((j 1 (+ 1 j)))
		    ((or happy (= j len4)))
		  (if (and (< (data j) (data (+ j 1)))
			   (> (data (+ j 1)) (data (+ j 2))))
		      (begin
			(set! autolen (* j 2))
			(set! happy #t))))))
	    (let* ((next-start (+ start autolen))
		   (min-i (+ i 1))
		   (min-samps (floor (abs (- (cross-samples min-i) next-start))))
		   (mink (min crosses (+ i zeros-checked))))
	      (do ((k (+ i 2) (+ k 1)))
		  ((= k mink))
		(let ((dist (floor (abs (- (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 (cross-samples current-mark)))
		       (len autolen)
		       (sr0 (make-sampler (floor s0)))
		       (sr1 (make-sampler (floor s1)))
		       (ampsum (make-one-pole 1.0 -1.0))
		       (diffsum (make-one-pole 1.0 -1.0))
		       (samp0 0.0))
		  (do ((i 0 (+ i 1)))
		      ((= i len))
		    (set! samp0 (next-sample sr0))
		    (one-pole ampsum (abs samp0))
		    (one-pole diffsum (abs (- (next-sample sr1) samp0))))
		  (set! diffsum (one-pole diffsum 0.0))
		  (set! ampsum (one-pole ampsum 0.0))
		  (set! current-min (if (= diffsum 0.0) 0.0 (/ diffsum ampsum))))
		(set! min-samps (round (* 0.5 current-min)))
		(let ((top (min (- crosses 1) current-mark (+ i zeros-checked))))
		  (do ((k (+ i 1) (+ k 1)))
		      ((= k top))
		    (let ((wgt 0.0))
		      (let* ((s0 start)
			     (s1 (floor (cross-samples k)))
			     (len autolen)
			     (sr0 (make-sampler (floor s0)))
			     (sr1 (make-sampler (floor s1)))
			     (ampsum (make-one-pole 1.0 -1.0))
			     (diffsum (make-one-pole 1.0 -1.0))
			     (samp0 0.0))
			(do ((i 0 (+ i 1)))
			    ((= i len))
			  (set! samp0 (next-sample sr0))
			  (one-pole ampsum (abs samp0))
			  (one-pole diffsum (abs (- (next-sample sr1) samp0))))
			(set! diffsum (one-pole diffsum 0.0))
			(set! ampsum (one-pole ampsum 0.0))
			(set! wgt (if (= diffsum 0.0) 0.0 (/ diffsum ampsum))))
		      (if (< wgt min-samps)
			  (begin
			    (set! min-samps (floor wgt))
			    (set! min-i k))))))
		(if (not (= current-mark min-i))
		    (set! (cross-weights i) 1000.0) ; these are confused, so effectively erase them
		    (begin
		      (set! (cross-weights i) current-min)
		      (set! (cross-marks i) current-mark)
		      (set! (cross-periods i) (- (cross-samples current-mark) (cross-samples i)))
		      ))
		))
	    ))
       ;; now sort weights to scatter the changes as evenly as possible
       (let* ((len (framples 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-float-vector weights)))
	  (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 (cross-weights 0))
		    (len (length cross-weights)))
		(do ((i 0 (+ i 1)))
		    ((= i len))
		  (if (< (cross-weights i) curmin)
		      (begin
			(set! cur i)
			(set! curmin (cross-weights i)))))
		(set! best-mark cur))
	      (set! handled (+ handled (floor (cross-periods best-mark))))
	      (if (or (< handled needed-samps)
		      (< (- handled needed-samps) (- needed-samps old-handled)))
		  (begin
		    (set! (edits curs) best-mark)
		    (set! curs (+ 1 curs))))
	      (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 (+ i 1)))
	       ((or (= i curs) (> changed-len samps)))
	     (let* ((best-mark (floor (edits i)))
		    (beg (floor (cross-samples best-mark)))
		    (next-beg (floor (cross-samples (floor (cross-marks best-mark)))))
		    (len (floor (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 (+ k 1)))
				 ((= 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 (cross-samples j))))
			     (if (> curbeg beg)
				 (set! (cross-samples j) (+ curbeg len))))))
		       (begin
			 (if (>= beg (framples))
			     (snd-print (format #f "trouble at ~D: ~D of ~D~%" i beg (framples))))
			 (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 (cross-samples j))))
			       (if (> curbeg beg)
				   (if (< curbeg end)
				       (set! (cross-periods j) 0)
				       (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)~%" (framples snd chn 0) (framples snd chn) (floor (* stretch (framples snd chn 0))))))
     ) ; end of as-one-edit thunk
   (format #f "rubber-sound ~A" stretch)))
