Imported Upstream version 16.5~dfsg

1 files changed, 144 insertions, 160 deletions

diff --git a/env.scm b/env.scm
index 80496b4..0c043f5 100644
--- a/env.scm
+++ b/env.scm
@@ -28,7 +28,7 @@
 end: (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) -> '(1.0 0.2 3.0 0.6)"))
     (lambda (beg end e)
       (let ((nenv ())
-	    (lasty (if e (cadr e) 0.0))
+	    (lasty (if (pair? e) (cadr e) 0.0))
 	    (len (length e)))
 	(call-with-exit
 	 (lambda (return-early)               
@@ -37,21 +37,19 @@ end: (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) -> '(1.0 0.2 3.0 0.6)"))
 	     (let ((x (e i))
 		   (y (e (+ i 1))))
 	       (set! lasty y)
-	       (if (null? nenv)
-		   (if (>= x beg)
-		       (begin
-			 (set! nenv (append nenv (list beg (envelope-interp beg e))))
-			 (if (not (= x beg))
-			     (if (>= x end)
-				 (return-early (append nenv (list end (envelope-interp end e))))
-				 (set! nenv (append nenv (list x y)))))))
-		   (if (<= x end)
-		       (begin
-			 (set! nenv (append nenv (list x y)))
-			 (if (= x end)
-			     (return-early nenv)))
-		       (if (> x end)
-			   (return-early (append nenv (list end (envelope-interp end e)))))))))
+	       (cond ((null? nenv)
+		      (when (>= x beg)
+			(set! nenv (append nenv (list beg (envelope-interp beg e))))
+			(if (not (= x beg))
+			    (if (>= x end)
+				(return-early (append nenv (list end (envelope-interp end e))))
+				(set! nenv (append nenv (list x y)))))))
+		     ((<= x end)
+		      (set! nenv (append nenv (list x y)))
+		      (if (= x end) (return-early nenv)))
+		     ((> x end)
+		      (return-early
+		       (append nenv (list end (envelope-interp end e))))))))
 	   (append nenv (list end lasty))))))))
 
 
@@ -61,26 +59,24 @@ end: (window-envelope 1.0 3.0 '(0.0 0.0 5.0 1.0)) -> '(1.0 0.2 3.0 0.6)"))
   (let ((documentation "(map-envelopes func env1 env2) maps func over the breakpoints in env1 and env2 returning a new envelope"))
     (lambda (op e1 e2)
       (let ((xs ()))
-	(letrec ((at0 
-		  (lambda (e)
-		    (let* ((diff (car e))
-			   (len (length e))
-			   (lastx (e (- len 2)))
-			   (newe (copy e)))
-		      (do ((i 0 (+ i 2)))
-			  ((>= i len) newe)
-			(let ((x (/ (- (newe i) diff) lastx)))
-			  (set! xs (cons x xs))
-			  (set! (newe i) x))))))
-		 (remove-duplicates
-		  (lambda (lst)
-		    (letrec ((rem-dup
-			      (lambda (lst nlst)
-				(cond ((null? lst) nlst)
-				      ((member (car lst) nlst) (rem-dup (cdr lst) nlst))
-				      (else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
-		      (rem-dup lst ())))))
-	  
+	(let ((at0 
+	       (lambda (e)
+		 (let* ((diff (car e))
+			(len (length e))
+			(lastx (e (- len 2)))
+			(newe (copy e)))
+		   (do ((i 0 (+ i 2)))
+		       ((>= i len) newe)
+		     (let ((x (/ (- (newe i) diff) lastx)))
+		       (set! xs (cons x xs))
+		       (set! (newe i) x))))))
+	      (remove-duplicates
+	       (lambda (lst)
+		 (let rem-dup ((lst lst)
+			       (nlst ()))
+		   (cond ((null? lst) nlst)
+			 ((member (car lst) nlst) (rem-dup (cdr lst) nlst))
+			 (else (rem-dup (cdr lst) (cons (car lst) nlst))))))))
 	  (if (null? e1)
 	      (at0 e2)
 	      (if (null? e2)
@@ -116,36 +112,33 @@ envelope: (multiply-envelopes '(0 0 2 .5) '(0 0 1 2 2 1)) -> '(0 0 0.5 0.5 1.0 0
 (define max-envelope 
   (let ((documentation "(max-envelope env) -> max y value in env"))
     (lambda (env1)
-      (define (max-envelope-1 e mx)
-	(if (null? e)
-	    mx
-	    (max-envelope-1 (cddr e) (max mx (cadr e)))))
-      (max-envelope-1 (cddr env1) (cadr env1)))))
-
+      (let max-envelope-1 ((e (cddr env1))
+                           (mx (cadr env1)))
+        (if (null? e)
+            mx
+            (max-envelope-1 (cddr e) (max mx (cadr e))))))))
 
 ;;; -------- min-envelope
 
 (define min-envelope 
   (let ((documentation "(min-envelope env) -> min y value in env"))
     (lambda (env1)
-      (define (min-envelope-1 e mx)
-	(if (null? e)
-	    mx
-	    (min-envelope-1 (cddr e) (min mx (cadr e)))))
-      (min-envelope-1 (cddr env1) (cadr env1)))))
-
+      (let min-envelope-1 ((e (cddr env1))
+                           (mx (cadr env1)))
+        (if (null? e)
+            mx
+            (min-envelope-1 (cddr e) (min mx (cadr e))))))))
 
 ;;; -------- integrate-envelope
 
 (define integrate-envelope 
   (let ((documentation "(integrate-envelope env) -> area under env"))
     (lambda (env1)
-      (define (integrate-envelope-1 e sum)
-	(if (or (null? e) (null? (cddr e)))
-	    sum
-	    (integrate-envelope-1 (cddr e) (+ sum (* (+ (cadr e) (cadddr e)) .5 (- (caddr e) (car e)))))))
-      (integrate-envelope-1 env1 0.0))))
-
+      (let integrate-envelope-1 ((e env1)
+                                 (sum 0.0000))
+        (if (or (null? e) (null? (cddr e)))
+            sum
+            (integrate-envelope-1 (cddr e) (+ sum (* (+ (cadr e) (cadddr e)) 0.5 (- (caddr e) (car e))))))))))
 
 ;;; -------- envelope-last-x
 
@@ -170,64 +163,56 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
   (stretch-envelope '(0 0 1 1 2 0) .1 .2 1.5 1.6) -> (0 0 0.2 0.1 1.1 1 1.6 0.5 2.0 0)"))
     (lambda* (fn old-att new-att old-dec new-dec)
       
-      (if (and old-att
-	       (not new-att))
-	  (error 'wrong-number-of-args (list "stretch-envelope" 
-					     old-att
-					     "old-attack but no new-attack?"))
-	  (if (not new-att)
-	      fn
-	      (if (and old-dec
-		       (not new-dec))
-		  (error 'wrong-number-of-args (list "stretch-envelope" 
-						     old-att new-att old-dec
-						     "old-decay but no new-decay?"))
-		  (let* ((x0 (car fn))
-			 (new-x x0)
-			 (last-x (fn (- (length fn) 2)))
-			 (y0 (cadr fn))
-			 (new-fn (list y0 x0))
-			 (scl (/ (- new-att x0) (max .0001 (- old-att x0)))))
-		    (define (stretch-envelope-1 new-fn old-fn)
-		      (if (null? old-fn)
-			  new-fn
-			  (let ((x1 (car old-fn))
-				(y1 (cadr old-fn)))
-			    (if (and (< x0 old-att)
-				     (>= x1 old-att))
-				(begin
-				  (if (= x1 old-att)
-				      (set! y0 y1)
-				      (set! y0 (+ y0 (* (- y1 y0) (/ (- old-att x0) (- x1 x0))))))
-				  (set! x0 old-att)
-				  (set! new-x new-att)
-				  (set! new-fn (cons y0 (cons new-x new-fn)))
-				  (set! scl (if old-dec 
-						(/ (- new-dec new-att) (- old-dec old-att))
-						(/ (- last-x new-att) (- last-x old-att))))))
-			    (if (and old-dec
-				     (< x0 old-dec)
-				     (>= x1 old-dec))
-				(begin
-				  (if (= x1 old-dec)
-				      (set! y0 y1)
-				      (set! y0 (+ y0 (* (- y1 y0) (/ (- old-dec x0) (- x1 x0))))))
-				  (set! x0 old-dec)
-				  (set! new-x new-dec)
-				  (set! new-fn (cons y0 (cons new-x new-fn)))
-				  (set! scl (/ (- last-x new-dec) (- last-x old-dec)))))
-			    (if (not (= x0 x1))
-				(begin
-				  (set! new-x (+ new-x (* scl (- x1 x0))))
-				  (set! new-fn (cons y1 (cons new-x new-fn)))
-				  (set! x0 x1)
-				  (set! y0 y1)))
-			    (stretch-envelope-1 new-fn (cddr old-fn)))))
-		    
-		    (if (and old-dec 
-			     (= old-dec old-att)) 
-			(set! old-dec (* .000001 last-x)))
-		    (reverse (stretch-envelope-1 new-fn (cddr fn))))))))))
+      (cond ((not new-att)
+	     (if old-att
+		 (error 'wrong-number-of-args "stretch-envelope: ~A, old-attack but no new-attack?" old-att)
+		 fn))
+	    ((and old-dec (not new-dec))
+	     (error 'wrong-number-of-args "stretch-envelope:~A ~A ~A, old-decay but no new-decay?" old-att new-att old-dec))
+	    (else
+	     (let* ((x0 (car fn))
+		    (new-x x0)
+		    (last-x (fn (- (length fn) 2)))
+		    (y0 (cadr fn))
+		    (new-fn (list y0 x0))
+		    (scl (/ (- new-att x0) (max .0001 (- old-att x0)))))
+	       
+	       (if (and (number? old-dec)
+			(= old-dec old-att))
+		   (set! old-dec (* 1e-06 last-x)))
+	       (reverse
+		(let stretch-envelope-1 ((new-fn new-fn)
+					 (old-fn (cddr fn)))
+		  (if (null? old-fn)
+		      new-fn
+		      (let ((x1 (car old-fn))
+			    (y1 (cadr old-fn)))
+			(when (and (< x0 old-att) (>= x1 old-att))
+			  (set! y0 (if (= x1 old-att)
+				       y1
+				       (+ y0 (* (- y1 y0) (/ (- old-att x0) (- x1 x0))))))
+			  (set! x0 old-att)
+			  (set! new-x new-att)
+			  (set! new-fn (cons y0 (cons new-x new-fn)))
+			  (set! scl (if old-dec
+					(/ (- new-dec new-att) (- old-dec old-att))
+					(/ (- last-x new-att) (- last-x old-att)))))
+			(when (and old-dec
+				   (< x0 old-dec)
+				   (>= x1 old-dec))
+			  (set! y0 (if (= x1 old-dec)
+				       y1
+				       (+ y0 (* (- y1 y0) (/ (- old-dec x0) (- x1 x0))))))
+			  (set! x0 old-dec)
+			  (set! new-x new-dec)
+			  (set! new-fn (cons y0 (cons new-x new-fn)))
+			  (set! scl (/ (- last-x new-dec) (- last-x old-dec))))
+			(unless (= x0 x1)
+			  (set! new-x (+ new-x (* scl (- x1 x0))))
+			  (set! new-fn (cons y1 (cons new-x new-fn)))
+			  (set! x0 x1)
+			  (set! y0 y1))
+			(stretch-envelope-1 new-fn (cddr old-fn))))))))))))
 
 
 ;;; -------- scale-envelope
@@ -257,8 +242,7 @@ divseg in early versions of CLM and its antecedents in Sambox and Mus10 (linen).
       (let ((len (length e)))
 	(if (memv len '(0 2))
 	    e
-	    (let ((xmax (e (- len 2))))
-	      (reverse-env-1 e () xmax)))))))
+	    (reverse-env-1 e () (e (- len 2))))))))
 
 
 ;;; -------- concatenate-envelopes
@@ -299,7 +283,8 @@ to have the same extent as the original's. 'reflected' causes every other
 repetition to be in reverse."))
     (lambda* (ur-env repeats reflected normalized)
       (let* ((times (if reflected (floor (/ repeats 2)) repeats))
-	     (e (if reflected
+	     (e (if (not reflected)
+		    ur-env
 		    (let ((lastx (ur-env (- (length ur-env) 2)))
 			  (rev-env (cddr (reverse ur-env)))
 			  (new-env (reverse ur-env)))
@@ -307,24 +292,23 @@ repetition to be in reverse."))
 			     (set! new-env (cons (+ lastx (- lastx (cadr rev-env))) new-env))
 			     (set! new-env (cons (car rev-env) new-env))
 			     (set! rev-env (cddr rev-env)))
-		      (reverse new-env))
-		    ur-env))
+		      (reverse new-env))))
 	     (first-y (cadr e))
 	     (x-max (e (- (length e) 2)))
 	     (x (car e))
 	     (first-y-is-last-y (= first-y (e (- (length e) 1))))
-	     (new-env (list first-y x))
-	     (len (length e)))
-	(do ((i 0 (+ i 1)))
-	    ((= i times))
-	  (do ((j 2 (+ j 2)))
-	      ((>= j len))
-	    (set! x (+ x (- (e j) (e (- j 2)))))
-	    (set! new-env (cons (e (+ j 1)) (cons x new-env))))
-	  (if (and (< i (- times 1)) (not first-y-is-last-y))
-	      (begin
-		(set! x (+ x (/ x-max 100.0)))
-		(set! new-env (cons first-y (cons x new-env))))))
+	     (new-env (list first-y x)))
+	(let ((len (length e)))
+	  (do ((i 0 (+ i 1)))
+	      ((= i times))
+	    (do ((j 2 (+ j 2)))
+		((>= j len))
+	      (set! x (+ x (- (e j) (e (- j 2)))))
+	      (set! new-env (cons (e (+ j 1)) (cons x new-env))))
+	    (if (and (< i (- times 1)) (not first-y-is-last-y))
+		(begin
+		  (set! x (+ x (/ x-max 100.0)))
+		  (set! new-env (cons first-y (cons x new-env)))))))
 	(set! new-env (reverse new-env))
 	(if normalized
 	    (let ((scl (/ x-max x))
@@ -482,36 +466,36 @@ each segment: (powenv-channel '(0 0 .325  1 1 32.0 2 0 32.0))"))
 		      (mus-sound-framples file)))
 	     (rms (make-moving-average incrsamps)) ; this could use make-moving-rms from dsp.scm
 	     (rms-val 0.0)
-	     (jend 0))
-	(let* ((len (+ 1 (- end start)))
-	       (data (make-float-vector len)))
-	  (do ((i 0 (+ i 1)))
-	      ((= i len))
-	    (float-vector-set! data i (next-sample reader)))
-	  (float-vector-multiply! data data)
-	  (do ((i 0 (+ i incrsamps)))
-	      ((>= i end) 
-	       (reverse e))
-	    (set! jend (min end (+ i incrsamps)))
-	    (do ((j i (+ j 1)))
-		((= j jend))
-	      (moving-average rms (float-vector-ref data j)))
-	    (set! e (cons (* 1.0 (/ i fsr)) e))
-	    (set! rms-val (sqrt (* (mus-scaler rms) (mus-increment rms))))
-	    (if db 
-		(if (< rms-val .00001)
-		    (set! e (cons -100.0 e))
-		    (set! e (cons (* 20.0 (log rms-val 10.0)) e)))
-		(set! e (cons rms-val e)))))))))
+	     (jend 0)
+	     (len (+ 1 (- end start)))
+	     (data (make-float-vector len)))
+	(do ((i 0 (+ i 1)))
+	    ((= i len))
+	  (float-vector-set! data i (next-sample reader)))
+	(float-vector-multiply! data data)
+	(do ((i 0 (+ i incrsamps)))
+	    ((>= i end) 
+	     (reverse e))
+	  (set! jend (min end (+ i incrsamps)))
+	  (do ((j i (+ j 1)))
+	      ((= j jend))
+	    (moving-average rms (float-vector-ref data j)))
+	  (set! e (cons (* 1.0 (/ i fsr)) e))
+	  (set! rms-val (sqrt (* (mus-scaler rms) (mus-increment rms))))
+	  (set! e (cons (if db 
+			    (if (< rms-val 1e-05) -100.0 (* 20.0 (log rms-val 10.0)))
+			    rms-val)
+			e)))))))
 
 
 (define* (normalize-envelope env1 (new-max 1.0))
-  (define (abs-max-envelope-1 e mx)
-    (if (null? e)
-	mx
-	(abs-max-envelope-1 (cddr e) (max mx (abs (cadr e))))))
-  (let ((peak (abs-max-envelope-1 (cddr env1) (abs (cadr env1)))))
-    (scale-envelope env1 (/ new-max peak))))
+  (scale-envelope env1
+		  (/ new-max
+		     (let abs-max-envelope-1 ((e (cddr env1))
+					      (mx (abs (cadr env1))))
+		       (if (null? e)
+			   mx
+			   (abs-max-envelope-1 (cddr e) (max mx (abs (cadr e)))))))))
 
 
 ;;; simplify-envelope
@@ -543,8 +527,9 @@ each segment: (powenv-channel '(0 0 .325  1 1 32.0 2 0 32.0))"))
 		 (if (or (< px qx tx) (< py qy ty) (< tx qx px) (< ty qy py)) 
 		     :after
 		     :within)))))
-  (if (and env1
-	   (> (length env1) 4))
+  (if (not (and env1
+		(> (length env1) 4)))
+      env1
       (let ((new-env (list (cadr env1) (car env1)))
 	    (ymax (max-envelope env1))
 	    (ymin (min-envelope env1))
@@ -578,5 +563,4 @@ each segment: (powenv-channel '(0 0 .325  1 1 32.0 2 0 32.0))"))
 		  (set! qtx ttx)
 		  (set! qty tty)))
 	      (set! new-env (cons qty (cons qtx new-env)))
-	      (reverse new-env))))
-      env1))
+	      (reverse new-env))))))