Imported Upstream version 16.1

1 files changed, 476 insertions, 481 deletions

diff --git a/singer.scm b/singer.scm
index cb6cdb4..ba6b6fa 100644
--- a/singer.scm
+++ b/singer.scm
@@ -17,515 +17,510 @@
 ;;; translated from CLM singer.ins
 
 (provide 'snd-singer.scm)
-(if (not (provided? 'snd-ws.scm)) (load "ws.scm"))
+(if (provided? 'snd)
+    (require snd-ws.scm)
+    (require sndlib-ws.scm))
 
+(define two-pi (* 2 pi))
 
 (definstrument (singer beg amp data)
   ;; data is a list of lists very similar to the sequence of synthesize calls in Perry's original implementation.
   ;;    Each imbedded list has the form: dur shape glot pitch glotamp noiseamps vibramt.
   ;;    See below for examples.
+
   (let* ((setup (car data))
 	 (durs (map car data))
 	 (dur (apply + durs))
 	 (begs (let ((bg beg))
 		 (append (list beg)
 			 (map (lambda (x)
-				(set! bg (+ bg x))
-				bg)
+				(set! bg (+ bg x)))
 			      durs))))
-	 (beg-samps (map seconds->samples begs))
-	 (change-times (let* ((len (length beg-samps))
-			      (nbegs (append beg-samps (list (list-ref beg-samps (- len 1))))))
-			 (list->vct nbegs)))
-	 (shps (map cadr data))
-	 (glts (map caddr data))
+	 (beg-samps (map seconds->samples begs)))
+
+    (let ((change-times (let* ((len (length beg-samps))
+			       (nbegs (append beg-samps (list (beg-samps (- len 1))))))
+			  (apply vector nbegs)))
+	  
+	  (shps (map cadr data))
+	  (glts (map caddr data))
+	  
+	  (pfun (let ((init (list 0.0 (* .8 (setup 3)))))
+		  (for-each (lambda (b dat)
+			      (set! init (append init (list (- b beg))))
+			      (set! init (append init (list (* 1.0 (dat 3))))))
+			    (cdr begs)
+			    data)
+		  init))
+	  (gfun (let ((init (list 0.0 0.0)))
+		  (for-each (lambda (b dat)
+			      (set! init (append init (list (- b beg))))
+			      (set! init (append init (list (* 1.0 (dat 4))))))
+			    (cdr begs)
+			    data)
+		  init))
+	  (nfun (let ((init (list 0.0 (* 1.0 (setup 5)))))
+		  (for-each (lambda (b dat)
+			      (set! init (append init (list (- b beg))))
+			      (set! init (append init (list (* 1.0 (dat 5))))))
+			    (cdr begs)
+			    data)
+		  init))
+	  (vfun (let ((init (list 0.0 (* 1.0 (setup 6)))))
+		  (for-each (lambda (b dat)
+			      (set! init (append init (list (- b beg))))
+			      (set! init (append init (list (* 1.0 (dat 6))))))
+			    (cdr begs)
+			    data)
+		  init))
+	  (noiseamps (let* ((len (length data))
+			    (v (make-float-vector len 0.0)))
+		       (do ((i 0 (+ i 1)))
+			   ((= i len))
+			 (set! (v i) (* 1.0 ((data i) 5))))
+		       v))
+	  (tractlength 9))		;length of vocal tract
+
+      (let ((frq-env (make-env pfun :duration dur))
+	    (vib-env (make-env vfun :duration dur))
+	    (vib-osc (make-oscil 6.0))
+	    (glot-env (make-env gfun :duration dur))
+	    (noise-env (make-env nfun :duration dur))
+	    (ran-vib (make-rand-interp :frequency 10 :amplitude .02))
+	    
+	    (glot-datai (make-float-vector (* 2 (length glts)) 0.0))
+	    (glot-datar (make-float-vector (* 2 (length glts)) 0.0))
+	    
+	    (tractlength+8 (+ tractlength 8))
+	    (tractlength+1 (+ tractlength 1))
+	    (tractlength-1 (- tractlength 1))
+	    (tractlength-2 (- tractlength 2))
+	    
+	    (noselength 6)
+	    (table-size 1000)		; size of glottis wave-table
+	    (dpole 0.998)
+	    (bg (seconds->samples beg))
+	    (tong-hump-pole 0.998)
+	    (tong-tip-pole 0.998))
+
+	(let ((shape-data (make-float-vector (* (length shps) tractlength+8) 0.0))
+	      
+	      (noselength-1 (- noselength 1))
+	      (noselength-2 (- noselength 2))
+	      (nose-ring-time 1000)	; naso pharynx response decay time
+	      (table-size-over-sampling-rate (/ table-size *clm-srate*))
+	      (dgain (- 1.0 dpole))
+	      (tong-hump-gain (- 1.0 tong-hump-pole))
+	      (tong-tip-gain (- 1.0 tong-tip-pole))
+	      
+	      (last-sfd -1)
+	      (last-gfd -1)
+
+	      (glot-table (make-float-vector (+ 1 table-size) 0.0))
+	      (glot-table2 (make-float-vector (+ 1 table-size) 0.0))
+	      ;; (gn-table (make-float-vector (+ 1 table-size) 0.0)) ;(gn-gain 0.0) ;(gn-out 0.0) ;(gn-del (make-float-vector 4 0.0))
+	      ;; (gn-coeffs (make-float-vector 4 0.0)) ; in Perry's C code, these were set in setGlotNoiseFilter but it was never called!
+	      (table-increment 0.0)
+	      (glot-refl-gain 0.7)
+	      (pitch 400.0)
+	      (last-lip-in 0.0)		;for lip reflection/transmission filter
+	      (last-lip-out 0.0)
+	      (last-lip-refl 0.0)
+	      (lip-refl-gain -0.45)
+	      (noise-gain 0.0)		;for vocal tract noise generator
+	      (noise-input 0.0)
+	      (noise-output 0.0)
+	      (noisef (make-fir-filter 4 :xcoeffs (make-float-vector 4)))
+	      (noisev #f)
+	      (noise-pos 0)
+	      (fnoiseamp 0.0)
+	      (inz1 0.0)
+	      (inz2 0.0)
+	      ;; nasal tract acoustic tube structure
+	      (nose-coeffs (make-float-vector noselength 0.0))
+	      (nose1 (make-float-vector noselength 0.0))
+	      (nose2 (make-float-vector noselength 0.0))
+	      (velum-pos 0.0)
+	      (nose-last-minus-refl 0.0)
+	      (nose-last-plus-refl 0.0)
+	      (nose-last-output 0.0)
+	      (nose-filt 0.0)
+	      (nose-filt1 0.0)
+	      (time-nose-closed 1000)	; this is a hack used to determine if we need to calculate the nasal acoustics
+	      ;; vocal tract acoustic tube structure
+	      
+	      ;; throat radiation low-pass filter
+	      (lt1 0.0)
+	      (lp (make-one-pole 0.05 (* -0.05 .9995)))
 
-	 (pfun (let ((init (list 0.0 (* .8 (list-ref setup 3)))))
-		 (map (lambda (b dat)
-			(set! init (append init (list (- b beg))))
-			(set! init (append init (list (exact->inexact (list-ref dat 3))))))
-		      (cdr begs)
-		      data)
-		 init))
-	 (gfun (let ((init (list 0.0 0.0)))
-		 (map (lambda (b dat)
-			(set! init (append init (list (- b beg))))
-			(set! init (append init (list (exact->inexact (list-ref dat 4))))))
-		      (cdr begs)
-		      data)
-		 init))
-	 (nfun (let ((init (list 0.0 (exact->inexact (list-ref setup 5)))))
-		 (map (lambda (b dat)
-			(set! init (append init (list (- b beg))))
-			(set! init (append init (list (exact->inexact (list-ref dat 5))))))
-		      (cdr begs)
-		      data)
-		 init))
-	 (vfun (let ((init (list 0.0 (exact->inexact (list-ref setup 6)))))
-		 (map (lambda (b dat)
-			(set! init (append init (list (- b beg))))
-			(set! init (append init (list (exact->inexact (list-ref dat 6))))))
-		      (cdr begs)
-		      data)
-		 init))
-	 (noiseamps (let* ((len (length data))
-			   (v (make-vct len)))
-		      (do ((i 0 (+ 1 i)))
-			  ((= i len))
-			(set! (v i) (exact->inexact (list-ref (list-ref data i) 5))))
-		      v))
-	 (frq-env (make-env pfun :duration dur))
-	 (vib-env (make-env vfun :duration dur))
-	 (vib-osc (make-oscil 6.0))
-	 (glot-env (make-env gfun :duration dur))
-	 (noise-env (make-env nfun :duration dur))
-	 (ran-vib (make-rand-interp :frequency 10 :amplitude .02))
+	      (lip-radius   0.0)
+	      (s-glot-mix 0.0)
+	      (s-noise 0.0)
+	      (initial-noise-position 0.0)
+	      (formant-shift 1.0)
+	      (change-radii #f) 
+	      (delta 0.0) 
+	      (new-tract #t)
+	      (first-tract #t)
+	      (offset -1)
+	      (nd (floor (change-times (- (length change-times) 1))))
+	      (next-offset bg)
 
-	 (tractlength 9)		;length of vocal tract
-	 (tractlength+8 (+ tractlength 8))
-	 (tractlength+1 (+ tractlength 1))
-	 (tractlength-1 (- tractlength 1))
-	 (tractlength-2 (- tractlength 2))
-	 (shape-data (make-vct (* (length shps) tractlength+8)))
-	 (glot-datai (make-vct (* 2 (length glts))))
-	 (glot-datar (make-vct (* 2 (length glts)))))
+	      (table-location 0.0)
+	      (glotsamp 0.0)
+	      (last-tract-plus 0.0)
+	      (alpha1 0.0)
+	      (alpha2 0.0)
+	      (alpha3 0.0)
+	      (noseposition 3)
 
-    (do ((k 0 (+ 1 k))
-	 (i 0 (+ i tractlength+8)))
-	((= k (length shps)))
-      (let ((shp (cdr (list-ref shps k))))
-	(do ((j i (+ 1 j))
-	     (m 0 (+ 1 m)))
-	    ((= m (length shp)))
-	  (set! (shape-data j) (list-ref shp m)))))
-	     
-    (do ((k 0 (+ 1 k))
-	 (i 0 (+ i 2)))
-	((= k (length glts)))
-      (let ((glt (list-ref glts k)))
-	(set! (glot-datai i) 0.0)
-	(set! (glot-datai (+ 1 i)) (car glt))
-	(set! (glot-datar i) (cadr glt))
-	(set! (glot-datar (+ 1 i)) (caddr glt))))
-    (let* ((table-size 1000)		; size of glottis wave-table
-	   (noseposition 3)
-	   (noselength 6)
-	   (noselength-1 (- noselength 1))
-	   (noselength-2 (- noselength 2))
-	   (nose-ring-time 1000)	; naso pharynx response decay time
-	   (two-pi (* 2 pi))
-	   (one-over-two-pi  0.159154943)
-	   (two-pi-over-table-size (/ two-pi table-size))
-	   (table-size-over-sampling-rate (/ table-size (mus-srate)))
-	   (dpole 0.998)
-	   (dgain (- 1.0 dpole))
-	   (tong-hump-pole 0.998)
-	   (tong-hump-gain (- 1.0 tong-hump-pole))
-	   (tong-tip-pole 0.998)
-	   (tong-tip-gain (- 1.0 tong-tip-pole))
-	   (glot-table (make-vct (+ 1 table-size)))
-	   (glot-table2 (make-vct (+ 1 table-size)))
-	   (gn-table (make-vct (+ 1 table-size)))
-	   (gn-gain 0.0)
-	   (gn-out 0.0)
-	   (gn-del (make-vct 4))
-	   (gn-coeffs (make-vct 4))
-	   (sines (make-vct 200))
-	   (cosines (make-vct 200))
-	   (table-increment 0.0)
-	   (table-location 0.0)
-	   (glot-refl-gain 0.7)
-	   (pitch 400.0)
-	   (vibr-amt 0.0)
-	   (last-lip-in 0.0)		;for lip reflection/transmission filter
-	   (last-lip-out 0.0)
-	   (last-lip-refl 0.0)
-	   (lip-refl-gain -0.45)
-	   (noise-gain 0.0)		;for vocal tract noise generator
-	   (noise-input 0.0)
-	   (noise-output 0.0)
-	   (noise-c (make-vct 4)) ; net coefficients on delayed outputs
-	   (noise-pos 0)
-	   (fnoiseamp 0.0)
-	   (inz1 0.0)
-	   (inz2 0.0)
-	   (outz (make-vct 4)) ; delayed versions of input and output
-	   ;; nasal tract acoustic tube structure
-	   (nose-coeffs (make-vct noselength))
-	   (nose1 (make-vct noselength))
-	   (nose2 (make-vct noselength))
-	   (velum-pos 0.0)
-	   (alpha (make-vct 4))
-	   (nose-last-minus-refl 0.0)
-	   (nose-last-plus-refl 0.0)
-	   (nose-last-output 0.0)
-	   (nose-filt 0.0)
-	   (nose-filt1 0.0)
-	   (time-nose-closed 1000)	; this is a hack used to determine if we need to calculate the nasal acoustics
-	   ;; vocal tract acoustic tube structure
-	   (radii (make-vct tractlength+8))
+	      (target-radii (make-float-vector tractlength+8 0.0))
+	      (target-temp (make-float-vector tractlength+8 0.0))
+	      (radii-poles (make-float-vector tractlength+8 0.0))
+	      (radii-pole-gains (make-float-vector tractlength+8 0.0))
+	      (radii (make-float-vector tractlength+8 0.0))
 					; the radii array contains the vocal tract section radii
 					; (tractlength-1 of them), then glottal reflection gain
 					; then lip reflection gain, then noise position, then noise gain,
 					; then noise pole angle, then noise pole radius, 
 					; then noise pole angle2, then noise pole radius2, then velum opening radius
-	   (coeffs (make-vct tractlength))
-	   (dline1 (make-vct tractlength))
-	   (dline2 (make-vct tractlength))
-	   ;; throat radiation low-pass filter
-	   (lt (make-vct 2))
-	   (ltcoeff .9995)
-	   (ltgain .05)			; a low order iir filter
-	   (lip-radius   0.0)
-	   (s-glot 0.0)
-	   (s-glot-mix 0.0)
-	   (s-noise 0.0)
-	   (last-tract-plus 0.0)
-	   (initial-noise-position 0.0)
-	   (formant-shift 1.0)
-	   (target-radii (make-vct tractlength+8))
-	   (radii-poles (make-vct tractlength+8))
-	   (radii-pole-gains (make-vct tractlength+8))
-	   (change-radii 0) 
-	   (glotsamp 0.0)
-	   (delta 0.0) 
-	   (temp-arr (make-vct tractlength+1))
-	   (new-glot 1)
-	   (first-glot 1)
-	   (new-tract 1)
-	   (first-tract 1)
-	   (offset -1)
-	   (bg (seconds->samples beg))
-	   (nd (floor (change-times (- (length change-times) 1))))
-	   (next-offset bg)
-	   (last-sfd -1)
-	   (last-gfd -1))
-      
-      (set! (nose-coeffs 0) 0.0)
-      (set! (nose-coeffs 1) -0.29)
-      (set! (nose-coeffs 2) -0.22)
-      (set! (nose-coeffs 3) 0.0)
-      (set! (nose-coeffs 4) 0.24)
-      (set! (nose-coeffs 5) 0.3571)
+	      (coeffs (make-float-vector tractlength 0.0))
+	      (dline1 (make-float-vector tractlength 0.0))
+	      (dline2 (make-float-vector tractlength 0.0)))
+
+	  (set! noisev (mus-xcoeffs noisef))
+
+	  (do ((k 0 (+ k 1))
+	       (i 0 (+ i tractlength+8)))
+	      ((= k (length shps)))
+	    (let ((shp (cdr (shps k))))
+	      (do ((j i (+ j 1))
+		   (m 0 (+ 1 m)))
+		  ((= m (length shp)))
+		(float-vector-set! shape-data j (shp m)))))
+	  
+	  (do ((k 0 (+ k 1))
+	       (i 0 (+ i 2)))
+	      ((= k (length glts)))
+	    (let ((glt (glts k)))
+	      (set! (glot-datai i) 0.0)
+	      (set! (glot-datai (+ i 1)) (car glt))
+	      (set! (glot-datar i) (cadr glt))
+	      (set! (glot-datar (+ i 1)) (caddr glt))))
+	  
+	  (set! (nose-coeffs 0) 0.0)
+	  (set! (nose-coeffs 1) -0.29)
+	  (set! (nose-coeffs 2) -0.22)
+	  (set! (nose-coeffs 3) 0.0)
+	  (set! (nose-coeffs 4) 0.24)
+	  (set! (nose-coeffs 5) 0.3571)
+	  
+	  (fill! radii 1.0) ;(do ((i 0 (+ i 1))) ((= i 8)) (set! (radii i) 1.0))
+	  (set! (radii 8) 0.7)
+	  (set! (radii 9) -0.5)
+	  (fill! target-radii 1.0) ;(do ((i 0 (+ i 1))) ((= i 8)) (set! (target-radii i) 1.0))
+	  (set! (target-radii 8) 0.7)
+	  (set! (target-radii 9) -0.5)
+	  
+	  (fill! radii-poles dpole) ;(do ((i 0 (+ i 1))) ((= i tractlength+8)) (set! (radii-poles i) dpole))
+	  (set! (radii-poles 2) tong-hump-pole)
+	  (set! (radii-poles 3) tong-hump-pole)
+	  (set! (radii-poles 4) tong-hump-pole)
+	  (set! (radii-poles 5) tong-tip-pole)
+	  
+	  (fill! radii-pole-gains dgain) ;(do ((i 0 (+ i 1))) ((= i tractlength+8)) (set! (radii-pole-gains i) dgain))
+	  (set! (radii-pole-gains 2) tong-hump-gain)
+	  (set! (radii-pole-gains 3) tong-hump-gain)
+	  (set! (radii-pole-gains 4) tong-hump-gain)
+	  (set! (radii-pole-gains 5) tong-tip-gain)
+
+	  ;; ---------------- make glot ----------------
+	  (let ((harms (floor (glot-datai 1)))
+		(temp1 0.0)
+		(temp 0.0)
+		(sines (make-float-vector 200 0.0))
+		(cosines (make-float-vector 200 0.0))
+		(one-over-two-pi  0.159154943)
+		(two-pi-over-table-size (/ two-pi table-size))
+		(a (glot-datar 0))
+		(b (glot-datar 1)))
+	    (let ((a2 (* two-pi a))
+		  (b2 (* two-pi b))
+		  (b-a (- b a)))
+	      (let ((sa2 (sin a2))
+		    (ca2 (cos a2)))
+		(fill! sines 0.0)
+		(fill! cosines 0.0)
+		(if (not (= b a))
+		    (begin
+		      (set! temp (/ one-over-two-pi b-a))
+		      (set! temp1 (- 1.0 ca2))
+		      (set! (sines 1) (* (+ ca2 (* (- sa2 (sin b2)) temp)) temp1 one-over-two-pi))
+		      (set! (cosines 1) (* (+ (- sa2) (* (- ca2 (cos b2)) temp)) temp1 one-over-two-pi))))
+		(set! (sines 1) (+ (sines 1) (* (+ 0.75 (- ca2) (* (cos (* 2 a2)) 0.25)) one-over-two-pi)))
+		(set! (cosines 1) (+ (cosines 1) (- (* (- sa2 (* (sin (* 2 a2)) 0.25)) one-over-two-pi) (* a 0.5))))
+		(do ((k 2 (+ k 1))
+		     (ka2 (* 2 a2) (+ ka2 a2))
+		     (ka1 a2 (+ ka1 a2))
+		     (ka3 (* 3 a2) (+ ka3 a2)))
+		    ((> k harms))
+		  (if (not (= b a))
+		      (begin
+			(set! temp (/ one-over-two-pi (* b-a k)))
+			(set! (sines k) (* (+ (cos ka2) (* (- (sin ka2) (sin (* k b2))) temp)) (/ temp1 k)))
+			(set! (cosines k) (* (+ (- (sin ka2)) (* (- (cos ka2) (cos (* k b2))) temp)) (/ temp1 k)))))
+		  (set! (sines k) (+ (sines k) 
+				     (/ (- 1.0 (cos ka2)) k)
+				     (/ (* (- (cos ka1) 1.0) 0.5) (- k 1))
+				     (/ (* (- (cos ka3) 1.0) 0.5) (+ k 1))))
+		  (set! (sines k) (* (sines k) one-over-two-pi))
+		  (set! (cosines k) (+ (cosines k) (- (/ (sin ka2) k) (/ (* (sin ka1) 0.5) (- k 1)) (/ (* (sin ka3) 0.5) (+ k 1)))))
+		  (set! (cosines k) (* (cosines k) one-over-two-pi)))
+		(fill! glot-table 0.0)
+		(do ((j 0 (+ j 1))
+		     (x 0.0 (+ x two-pi-over-table-size)))
+		    ((> j table-size))
+		  (do ((k 1 (+ k 1))
+		       (kx x (+ kx x)))
+		      ((> k harms))
+		    (float-vector-set! glot-table j (+ (float-vector-ref glot-table j) 
+					    (* (float-vector-ref cosines k) (cos kx))
+					    (* (float-vector-ref sines k) (sin kx)))))))))
+	  (set! s-glot-mix 1.0)
+	  (copy glot-table glot-table2)
+	  ;; ---------------- end make glot ----------------
+
+	  
+	  (do ((i bg (+ i 1)))
+	      ((= i nd))
+	    (if (= i next-offset)
+		(begin
+		  ;; time to check for new tract shapes, glottal pulse shapes etc.
+		  (set! offset (+ offset 1))
+		  (set! fnoiseamp (noiseamps offset))
+		  (if (= last-sfd -1)
+		      (set! last-sfd 0)
+		      (let ((new-sfd (+ last-sfd 8 tractlength)))
+			(do ((j last-sfd (+ j 1))
+			     (k new-sfd (+ k 1)))
+			    ((= j new-sfd))
+			  (if (> (abs (- (shape-data j) (shape-data k))) .001)
+			      (set! new-tract #t)))
+			(set! last-sfd new-sfd)))
+		  (if (= last-gfd -1)
+		      (set! last-gfd 0)
+		      (let ((new-gfd (+ last-gfd 2)))
+			(set! last-gfd new-gfd)))
+		  (set! next-offset (floor (change-times (+ offset 1))))
+		  (set! delta (/ 1.0 (- next-offset i)))))
+	    
+	    (if new-tract
+		(begin
+		  (copy shape-data target-radii last-sfd)
 
-      (do ((i 0 (+ 1 i))) ((= i 8)) (set! (radii i) 1.0))
-      (set! (radii 8) 0.7)
-      (set! (radii 9) -0.5)
-      (do ((i 0 (+ 1 i))) ((= i 8)) (set! (target-radii i) 1.0))
-      (set! (target-radii 8) 0.7)
-      (set! (target-radii 9) -0.5)
+		  (if first-tract
+		      (copy target-radii radii))
+		  (set! change-radii #f)
+		  (set! initial-noise-position (radii tractlength+1))
+		  (do ((j 0 (+ j 1)))
+		      ((or (= j tractlength+8)
+			   change-radii))
+		    (if (> (abs (- (target-radii j) (radii j))) 0.001)
+			(set! change-radii #t)))))
+	    
+	    (if (or first-tract change-radii)
+		(begin
+		  (if (not new-tract)
+		      (begin
+			(float-vector-multiply! radii radii-poles)
+			(copy target-radii target-temp)
+			(float-vector-multiply! target-temp radii-pole-gains)
+			(float-vector-add! radii target-temp)
+			;; (do ((j 0 (+ j 1))) ((= j tractlength+8))
+			;;   (float-vector-set! radii j (+ (* (float-vector-ref radii j) (float-vector-ref radii-poles j))
+			;; 		                   (* (float-vector-ref target-radii j) (float-vector-ref radii-pole-gains j)))))
+			))
+		  ;; set tract shape
+		  (let ((tj 1.0)
+			(tk 0.0))
+		    (do ((k 0 (+ k 1))
+			 (j 1 (+ j 1)))
+			((= j tractlength))
+		      (set! tk tj)
+		      (if (zero? (float-vector-ref radii j))
+			  (set! tj 1e-10)
+			  (set! tj (* (float-vector-ref radii k) (float-vector-ref radii k))))
+		      (float-vector-set! coeffs j (/ (- tk tj) (+ tk tj)))))
 
-      (do ((i 0 (+ 1 i))) ((= i tractlength+8)) (set! (radii-poles i) dpole))
-      (set! (radii-poles 2) tong-hump-pole)
-      (set! (radii-poles 3) tong-hump-pole)
-      (set! (radii-poles 4) tong-hump-pole)
-      (set! (radii-poles 5) tong-tip-pole)
+		  (set! glot-refl-gain (radii tractlength-1))
+		  (set! lip-refl-gain (radii tractlength))
+		  (set! noise-pos (floor (radii tractlength+1)))
+		  (set! noise-gain (radii (+ tractlength 2)))
 
-      (do ((i 0 (+ 1 i))) ((= i tractlength+8)) (set! (radii-pole-gains i) dgain))
-      (set! (radii-pole-gains 2) tong-hump-gain)
-      (set! (radii-pole-gains 3) tong-hump-gain)
-      (set! (radii-pole-gains 4) tong-hump-gain)
-      (set! (radii-pole-gains 5) tong-tip-gain)
+		  (let ((temp1 (radii (+ tractlength 3)))
+			(r (radii (+ tractlength 4)))
+			(t2 (radii (+ tractlength 5)))
+			(r2 (radii (+ tractlength 6))))
+		    (let (;; fricative noise generator (set noise angle and radius)
+			  (noise-angle (hz->radians temp1))
+			  (noise-angle2 (hz->radians t2))
+			  (noise-radius r)
+			  (noise-radius2 r2))
+		      (let ((noise-a (* -2.0 (cos (/ noise-angle formant-shift)) noise-radius))
+			    (noise-b (* noise-radius noise-radius))
+			    (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) noise-radius2))
+			    (noise-b2 (* noise-radius2 noise-radius2)))
+			(set! (noisev 0) (+ noise-a noise-a2))
+			(set! (noisev 1) (+ noise-b noise-b2 (* noise-a noise-a2)))
+			(set! (noisev 2) (+ (* noise-a2 noise-b) (* noise-b2 noise-a)))
+			(set! (noisev 3) (* noise-b2 noise-b)))))
+		  
+		  (set! lip-radius (radii tractlength-2))
+		  (set! velum-pos (radii (+ tractlength 7)))
+		  (let ((leftradius (radii (- noseposition 2)))
+			(velumradius velum-pos)
+			(rightradius (radii (- noseposition 1))))
+		    (let ((temp1 0.0) 
+			  (temp 0.0))
+		      ;; nasal tract (set nasal shape)
+		      (set! temp (- rightradius velumradius))
+		      (if (< temp 0.0) (set! temp 0.0))
+		      (set! alpha1 (* leftradius leftradius))
+		      (set! alpha2 (* temp temp))
+		      (set! alpha3 (* velumradius velumradius))
+		      (set! temp1 (/ 2.0 (+ alpha1 alpha2 alpha3)))
+		      (set! alpha1 (* alpha1 temp1))
+		      (set! alpha2 (* alpha2 temp1))
+		      (set! alpha3 (* alpha3 temp1))))))
+	    
+	    (if new-tract
+		(begin
+		  (set! new-tract #f)
+		  (set! first-tract #f)
+		  (if (or (< s-noise 1.0) (< fnoiseamp 0.0001))
+		      (set! (target-radii tractlength+1) initial-noise-position))))
+
+	    (set! s-glot-mix (- s-glot-mix delta))
+	    (set! s-noise (env noise-env))
+	    (set! pitch (env frq-env))
+	    (set! table-increment (* pitch (+ 1.0 (* (env vib-env) (oscil vib-osc)) (rand-interp ran-vib)) table-size-over-sampling-rate))
+	    (set! last-lip-out (+ last-lip-in last-tract-plus))
+	    (set! last-lip-refl (* (+ last-lip-in last-tract-plus) lip-refl-gain))
+	    (set! last-lip-in last-tract-plus)
+	    ;; next glot tick
+	    (set! glotsamp (* (dline2 1) glot-refl-gain))
+	    (if (not (= table-increment 0.0))
+		(begin
+		  (set! table-location (+ table-location table-increment))
+		  (if (>= table-location table-size)
+		      (set! table-location (- table-location table-size)))
+		  (let ((int-loc (floor table-location)))
+		    (let ((table1 (glot-table int-loc)))
+		      (set! glotsamp (+ glotsamp (* (env glot-env) (+ table1 (* s-glot-mix (- (glot-table2 int-loc) table1))))))))))
+	    
+	    ;; next tract tick
+	    (let ((j 0)
+		  ;(temp1 0.0)
+		  (temp (dline2 2)))
+	      (set! lt1 (one-pole lp (+ (dline1 2) temp)))
+
+	      (set! (dline2 1) (+ temp (* (coeffs 1) (- glotsamp temp))))
+	      (set! temp (+ glotsamp (- (dline2 1) temp)))
+	      (set! temp (singer-filter 1 noseposition temp dline1 dline2 coeffs))
+#|
+	      (let ((x 0.0))
+		(do ((j 2 (+ j 1))
+		     (k 1 (+ k 1)))
+		    ((= j noseposition))
+		  (set! x (float-vector-ref dline2 (+ j 1)))
+		  (float-vector-set! dline2 j (+ x (* (float-vector-ref coeffs j) (- (float-vector-ref dline1 k) x))))
+		  (set! temp1 temp)
+		  (set! temp (+ (float-vector-ref dline1 k) (- (float-vector-ref dline2 j) x)))
+		  (float-vector-set! dline1 k temp1)))
+|#
+	      (set! j noseposition)	;added
+	      ;;next nasal tick
+	      (let ((plussamp (dline1 (- j 1)))
+		    (minussamp (dline2 (+ j 1)))
+		    (nose-reftemp 0.0))
+		(if (and (= velum-pos 0.0)
+			 (>= time-nose-closed nose-ring-time))
+		    (let ((nose2-1 (float-vector-ref nose2 1)))
+		      (set! nose-reftemp (+ (* alpha1 plussamp) (* alpha2 minussamp) (* alpha3 nose2-1)))
+		      (set! nose-last-minus-refl (- nose-reftemp plussamp))
+		      (set! nose-last-plus-refl (- nose-reftemp minussamp)))
+		    (begin
+		      (if (not (= velum-pos 0.0))
+			  (set! time-nose-closed 0)
+			  (set! time-nose-closed (+ time-nose-closed 1))) ; added 1 bil 17-Apr-11 but didn't test it
+		      ;; nasal tick
+		      (let ((nose-reftemp (+ (* alpha1 plussamp) (* alpha2 minussamp) (* alpha3 (nose2 1)))))
+			(let (;(nose-t1 0.0)
+			      (nose-temp 0.0)
+			      (plus-in (* velum-pos (- nose-reftemp (nose2 1)))))
+			  (set! nose-last-minus-refl (- nose-reftemp plussamp))
+			  (set! nose-last-plus-refl (- nose-reftemp minussamp))
+			  (set! nose-reftemp (* (nose-coeffs 1) (- plus-in (nose2 2))))
+			  (set! (nose2 1) (+ (nose2 2) nose-reftemp))
+			  (set! nose-temp (+ plus-in nose-reftemp))
+			  
+			  (set! nose-temp (singer-nose-filter noselength-1 nose-temp nose1 nose2 nose-coeffs))
+#|
+			  (do ((j 2 (+ j 1))
+			       (k 1 (+ k 1)))
+			      ((= j noselength-1))
+			    (set! nose-reftemp (* (nose-coeffs j) (- (nose1 k) (nose2 (+ j 1)))))
+			    (set! (nose2 j) (+ (nose2 (+ j 1)) nose-reftemp))
+			    (set! nose-t1 nose-temp)
+			    (set! nose-temp (+ (nose1 k) nose-reftemp))
+			    (set! (nose1 k) nose-t1))
+|#
+
+			  (set! nose-reftemp (* (nose-coeffs noselength-1) (- (nose1 noselength-2) (* nose-last-output 0.25))))
+			  (set! (nose2 noselength-1) (+ (* nose-last-output 0.25) nose-reftemp))
+			  (set! (nose1 noselength-1) (+ (nose1 noselength-2) nose-reftemp))
+			  (set! (nose1 noselength-2) nose-temp)
+			  (set! nose-filt1 nose-filt)
+			  (set! nose-filt (nose1 noselength-1))
+			  (set! nose-last-output (* (+ nose-filt nose-filt1) 0.5))))))
+		(set! (dline2 j) nose-last-minus-refl))
+		
+	      (set! (dline1 (- j 1)) temp)
+	      (set! temp nose-last-plus-refl)
+	      
+	      ;; j always starts at 4, goes to 8 so this loop can be unrolled, but doing so doesn't make a big difference
+	      (set! temp (singer-filter noseposition tractlength-1 temp dline1 dline2 coeffs))
+#|
+	      (let ((x 0.0))
+		(do ((j (+ noseposition 1) (+ j 1))
+		     (k noseposition (+ k 1)))
+		    ((= j tractlength-1))
+		  (set! x (float-vector-ref dline2 (+ j 1)))
+		  (float-vector-set! dline2 j (+ x (* (float-vector-ref coeffs j) (- (float-vector-ref dline1 k) x))))
+		  (set! temp1 temp)
+		  (set! temp (+ (float-vector-ref dline1 k) (- (float-vector-ref dline2 j) x)))
+		  (float-vector-set! dline1 k temp1)))
+|#
 
-      (run
-       (do ((i bg (+ 1 i)))
-	   ((= i nd))
-	 (if (= i next-offset)
-	     (begin
-	       ;; time to check for new tract shapes, glottal pulse shapes etc.
-	       (set! offset (+ 1 offset))
-	       (set! fnoiseamp (noiseamps offset))
-	       (if (= last-sfd -1)
-		   (set! last-sfd 0)
-		   (let ((new-sfd (+ last-sfd 8 tractlength)))
-		     (do ((j last-sfd (+ 1 j))
-			  (k new-sfd (+ 1 k)))
-			 ((= j new-sfd))
-		       (if (> (abs (- (shape-data j) (shape-data k))) .001)
-			   (set! new-tract 1)))
-		     (set! last-sfd new-sfd)))
-	       (if (= last-gfd -1)
-		   (set! last-gfd 0)
-		   (let ((new-gfd (+ last-gfd 2)))
-		     (set! last-gfd new-gfd)))
-	       (set! next-offset (floor (change-times (+ offset 1))))))
-	 
-	 (if (not (= new-tract 0))
-	     (begin
-	       (do ((j last-sfd (+ 1 j))
-		    (k 0 (+ 1 k)))
-		   ((= k tractlength+8))
-		 (set! (target-radii k) (shape-data j)))
-	       (if (= first-tract 1)
-		   (begin
-		     (do ((k 0 (+ 1 k)))
-			 ((= k tractlength+8))
-		       (set! (radii k) (target-radii k)))))
-	       (set! change-radii 0)
-	       (set! initial-noise-position (radii tractlength+1))
-	       (do ((j 0 (+ 1 j)))
-		   ((= j tractlength+8))
-		 (if (> (abs (- (target-radii j) (radii j))) 0.001)
-		     (set! change-radii 1)))))
-	 
-	 (if (or (= first-tract 1) (not (= change-radii 0)))
-	     (begin
-	       (if (= new-tract 0)
-		   (begin
-		     (do ((j 0 (+ 1 j)))
-			 ((= j tractlength+8))
-		       (set! (radii j) (+ (* (radii j) (radii-poles j))
-					  (* (target-radii j) (radii-pole-gains j)))))))
-	       ;; set tract shape
-	       (set! (temp-arr 0) 1.0)
-	       (do ((j 1 (+ 1 j)))
-		   ((= j tractlength))
-		 (set! (temp-arr j) (* (radii (- j 1)) (radii (- j 1))))
-		 (if (= (temp-arr j) 0.0) 
-		     (set! (temp-arr j) 1e-10)))
-	       (do ((j 1 (+ 1 j)))
-		   ((= j tractlength))
-		 (set! (coeffs j) (/ (- (temp-arr (- j 1)) (temp-arr j))
-				     (+ (temp-arr (- j 1)) (temp-arr j)))))
-	       (set! glot-refl-gain (radii tractlength-1))
-	       (set! lip-refl-gain (radii tractlength))
-	       (set! noise-pos (floor (radii tractlength+1)))
-	       (set! noise-gain (radii (+ tractlength 2)))
-	       (let* ((temp1 (radii (+ tractlength 3)))
-		      (r (radii (+ tractlength 4)))
-		      (t2 (radii (+ tractlength 5)))
-		      (r2 (radii (+ tractlength 6)))
-		      ;; fricative noise generator (set noise angle and radius)
-		      (noise-angle (hz->radians temp1))
-		      (noise-radius r)
-		      (noise-a (* -2.0 (cos (/ noise-angle formant-shift)) noise-radius))
-		      (noise-b (* noise-radius noise-radius))
-		      (noise-angle2 (hz->radians t2))
-		      (noise-radius2 r2)
-		      (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) noise-radius2))
-		      (noise-b2 (* noise-radius2 noise-radius2)))
-		 (set! (noise-c 0) (+ noise-a noise-a2))
-		 (set! (noise-c 1) (+ noise-b noise-b2 (* noise-a noise-a2)))
-		 (set! (noise-c 2) (+ (* noise-a2 noise-b) (* noise-b2 noise-a)))
-		 (set! (noise-c 3) (* noise-b2 noise-b)))
-	       (set! lip-radius (radii tractlength-2))
-	       (set! velum-pos (radii (+ tractlength 7)))
-	       (let ((leftradius (radii (- noseposition 2)))
-		     (velumradius velum-pos)
-		     (rightradius (radii (- noseposition 1))))
-		 (let ((temp1 0.0) 
-		       (temp 0.0))
-		   ;; nasal tract (set nasal shape)
-		   (set! temp (- rightradius velumradius))
-		   (if (< temp 0.0) (set! temp 0.0))
-		   (set! (alpha 1) (* leftradius leftradius))
-		   (set! (alpha 2) (* temp temp))
-		   (set! (alpha 3) (* velumradius velumradius))
-		   (set! temp1 (/ 2.0 (+ (alpha 1) (alpha 2) (alpha 3))))
-		   (set! (alpha 1) (* (alpha 1) temp1))
-		   (set! (alpha 2) (* (alpha 2) temp1))
-		   (set! (alpha 3) (* (alpha 3) temp1))))))
-	 
-	 (if (not (= new-tract 0))
-	     (begin
-	       (set! new-tract 0)
-	       (set! first-tract 0)
-	       (if (or (< s-noise 1.0) (< fnoiseamp 0.0001))
-		   (set! (target-radii tractlength+1) initial-noise-position))))
-	 (if (not (= new-glot 0))
-	     (begin
-	       (if (= first-glot 0)
-		   (begin
-		     (do ((i 0 (+ 1 i)))
-			 ((> i table-size))
-		       (set! (glot-table2 i) (glot-table i)))))
-	       (let* ((harms (floor (glot-datai (+ last-gfd 1))))
-		      (temp1 0.0)
-		      (temp 0.0)
-		      (a (glot-datar last-gfd))
-		      (b (glot-datar (+ last-gfd 1)))
-		      (a2 (* two-pi a))
-		      (b2 (* two-pi b)))
-		 (vct-fill! sines 0.0)
-		 (vct-fill! cosines 0.0)
-					;(set! (sines 1) 0.0)
-					;(set! (cosines 1) 0.0)
-		 (if (not (= b a))
-		     (begin
-		       (set! temp (/ one-over-two-pi (- b a)))
-		       (set! temp1 (- 1.0 (cos a2)))
-		       (set! (sines 1) (* (+ (cos a2) (* (- (sin a2) (sin b2)) temp)) temp1 one-over-two-pi))
-		       (set! (cosines 1) (* (+ (- (sin a2)) (* (- (cos a2) (cos b2)) temp)) temp1 one-over-two-pi))))
-		 (set! (sines 1) (+ (sines 1) (* (+ 0.75 (- (cos a2)) (* (cos (* 2 a2)) 0.25)) one-over-two-pi)))
-		 (set! (cosines 1) (+ (cosines 1) (- (* (- (sin a2) (* (sin (* 2 a2)) 0.25)) one-over-two-pi) (* a 0.5))))
-		 (do ((k 2 (+ 1 k))
-		      (ka2 (* 2 a2) (+ ka2 a2))
-		      (ka1 a2 (+ ka1 a2))
-		      (ka3 (* 3 a2) (+ ka3 a2)))
-		     ((> k harms))
-					;(set! (sines k) 0.0)
-					;(set! (cosines k) 0.0)
-		   (if (not (= b a))
-		       (begin
-			 (set! temp (/ one-over-two-pi (* (- b a) k)))
-			 (set! (sines k) (* (+ (cos ka2) (* (- (sin ka2) (sin (* k b2))) temp)) (/ temp1 k)))
-			 (set! (cosines k) (* (+ (- (sin ka2)) (* (- (cos ka2) (cos (* k b2))) temp)) (/ temp1 k)))))
-		   (set! (sines k) (+ (sines k) (+ (/ (- 1.0 (cos ka2)) k) (/ (* (- (cos ka1) 1.0) 0.5) (- k 1))
-						   (/ (* (- (cos ka3) 1.0) 0.5) (+ k 1)))))
-		   (set! (sines k) (* (sines k) one-over-two-pi))
-		   (set! (cosines k) (+ (cosines k) (- (/ (sin ka2) k) (/ (* (sin ka1) 0.5) (- k 1)) (/ (* (sin ka3) 0.5) (+ k 1)))))
-		   (set! (cosines k) (* (cosines k) one-over-two-pi)))
-		 (vct-fill! glot-table 0.0)
-		 (do ((j 0 (+ 1 j))
-		      (x 0.0 (+ x two-pi-over-table-size)))
-		     ((> j table-size))
-					;(set! (glot-table j) 0.0)
-		   (do ((k 1 (+ 1 k)))
-		       ((> k harms))
-		     (set! (glot-table j) (+ (glot-table j) (+ (* (cosines k) (cos (* k x)))
-							       (* (sines k) (sin (* k x)))))))))
-	       (set! s-glot-mix 1.0)
-	       (set! delta (/ 1.0 (- next-offset i)))
-	       (if (not (= first-glot 0))
-		   (begin
-		     (do ((i 0 (+ 1 i)))
-			 ((> i table-size))
-		       (set! (glot-table2 i) (glot-table i)))
-		     (set! first-glot 0)))
-	       (set! new-glot 0)))
-	 
-	 (set! s-glot-mix (- s-glot-mix delta))
-	 (set! s-glot (env glot-env))
-	 (set! s-noise (env noise-env))
-	 (set! pitch (env frq-env))
-	 (set! vibr-amt (env vib-env))
-	 (set! table-increment (* pitch (+ 1.0 (* vibr-amt (oscil vib-osc)) (rand-interp ran-vib)) table-size-over-sampling-rate))
-	 (set! last-lip-out (+ last-lip-in last-tract-plus))
-	 (set! last-lip-refl (* (+ last-lip-in last-tract-plus) lip-refl-gain))
-	 (set! last-lip-in last-tract-plus)
-	 ;; next glot tick
-	 (let ((table1 0.0)
-	       (table2 0.0)
-	       (int-loc 0))
-	   (set! glotsamp (* (dline2 1) glot-refl-gain))
-	   (if (not (= table-increment 0.0))
-	       (begin
-		 (set! table-location (+ table-location table-increment))
-		 (if (>= table-location table-size)
-		     (set! table-location (- table-location table-size)))
-		 (set! int-loc (floor table-location))
-		 (set! table1 (glot-table int-loc))
-		 (set! table2 (glot-table2 int-loc))
-		 (set! glotsamp (+ glotsamp (* s-glot (+ table1 (* s-glot-mix (- table2 table1))))))
-		 ;; glot noise tick
-		 (if (and (not (= (gn-table int-loc) 0.0))
-			  (not (= gn-gain 0.0)))
-		     (begin
-		       (set! gn-out (- (* gn-gain s-glot (- 1.0 (random 2.0))) ;guessing here about random()
-				       (* (gn-coeffs 3) (gn-del 3)) 
-				       (* (gn-coeffs 2) (gn-del 2))
-				       (* (gn-coeffs 1) (gn-del 1))
-				       (* (gn-coeffs 0) (gn-del 0))))
-		       (do ((j 3 (- j 1))
-			    (k 2 (- k 1)))
-			   ((< j 1))
-			 (set! (gn-del j) (gn-del k)))
-		       (set! (gn-del 0) gn-out)))
-		 (set! glotsamp (+ glotsamp (* gn-out (gn-table int-loc)))))))
-	 
-	 ;; next tract tick
-	 (let ((j 0)
-	       (temp1 0.0)
-	       (temp 0.0))
-	   (set! (lt 0) (+ (dline1 2) (dline2 2)))
-	   (set! (dline2 1) (+ (dline2 2) (* (coeffs 1) (- glotsamp (dline2 2)))))
-	   (set! temp (+ glotsamp (- (dline2 1) (dline2 2))))
-	   (do ((j 2 (+ 1 j)))
-	       ((= j noseposition))
-	     (set! (dline2 j) (+ (dline2 (+ j 1)) (* (coeffs j) (- (dline1 (- j 1)) (dline2 (+ j 1))))))
-	     (set! temp1 temp)
-	     (set! temp (+ (dline1 (- j 1)) (- (dline2 j) (dline2 (+ j 1)))))
-	     (set! (dline1 (- j 1)) temp1))
-	   (set! j noseposition)	;added
-	   ;;next nasal tick
-	   (let ((plussamp (dline1 (- j 1)))
-		 (minussamp (dline2 (+ j 1)))
-		 (nose-reftemp 0.0))
-	     (if (and (= velum-pos 0.0)
-		      (>= time-nose-closed nose-ring-time))
-		 (begin
-		   (set! nose-reftemp (+ (* (alpha 1) plussamp) (* (alpha 2) minussamp) (* (alpha 3) (nose2 1))))
-		   (set! nose-last-minus-refl (- nose-reftemp plussamp))
-		   (set! nose-last-plus-refl (- nose-reftemp minussamp)))
-		 (begin
-		   (if (not (= velum-pos 0.0))
-		       (set! time-nose-closed 0)
-		       (set! time-nose-closed (+ time-nose-closed)))
-		   ;; nasal tick
-		   (let* ((nose-t1 0.0)
-			  (nose-temp 0.0)
-			  (nose-reftemp (+ (* (alpha 1) plussamp) (* (alpha 2) minussamp) (* (alpha 3) (nose2 1))))
-			  (plus-in (* velum-pos (- nose-reftemp (nose2 1)))))
-		     (set! nose-last-minus-refl (- nose-reftemp plussamp))
-		     (set! nose-last-plus-refl (- nose-reftemp minussamp))
-		     (set! nose-reftemp (* (nose-coeffs 1) (- plus-in (nose2 2))))
-		     (set! (nose2 1) (+ (nose2 2) nose-reftemp))
-		     (set! nose-temp (+ plus-in nose-reftemp))
-		     (do ((j 2 (+ 1 j)))
-			 ((= j noselength-1))
-		       (set! nose-reftemp (* (nose-coeffs j) (- (nose1 (- j 1)) (nose2 (+ j 1)))))
-		       (set! (nose2 j) (+ (nose2 (+ j 1)) nose-reftemp))
-		       (set! nose-t1 nose-temp)
-		       (set! nose-temp (+ (nose1 (- j 1)) nose-reftemp))
-		       (set! (nose1 (- j 1)) nose-t1))
-		     (set! nose-reftemp (* (nose-coeffs noselength-1)
-					   (- (nose1 noselength-2) (* nose-last-output 0.25))))
-		     (set! (nose2 noselength-1) (+ (* nose-last-output 0.25) nose-reftemp))
-		     (set! (nose1 noselength-1) (+ (nose1 noselength-2) nose-reftemp))
-		     (set! (nose1 noselength-2) nose-temp)
-		     (set! nose-filt1 nose-filt)
-		     (set! nose-filt (nose1 noselength-1))
-		     (set! nose-last-output (* (+ nose-filt nose-filt1) 0.5)))))
-	     (set! (dline2 j) nose-last-minus-refl))
-	   
-	   (set! temp1 temp)
-	   (set! temp nose-last-plus-refl)
-	   (set! (dline1 (- j 1)) temp1)
-	   (do ((j (+ noseposition 1) (+ 1 j)))
-	       ((= j tractlength-1))
-	     (set! (dline2 j) (+ (dline2 (+ j 1)) (* (coeffs j) (- (dline1 (- j 1)) (dline2 (+ j 1))))))
-	     (set! temp1 temp)
-	     (set! temp (+ (dline1 (- j 1)) (- (dline2 j) (dline2 (+ j 1)))))
-	     (set! (dline1 (- j 1)) temp1))
-	   (set! (dline2 tractlength-1) (+ last-lip-refl (* (coeffs tractlength-1) 
-							    (- (dline1 tractlength-2) last-lip-refl))))
-	   (set! (dline1 tractlength-1) (+ (dline1 tractlength-2) 
-					   (- (dline2 tractlength-1) last-lip-refl)))
-	   (set! (dline1 tractlength-2) temp)
-	   (if (not (= noise-gain 0.0))
-	       (begin
-		 (set! noise-input (- 1.0 (random 2.0))) ;a guess
-		 (do ((j 3 (- j 1))
-		      (k 2 (- k 1)))
-		     ((< j 1))
-		   (set! (outz j) (outz k)))
-		 (set! (outz 0) noise-output)
-		 (set! noise-output (- noise-input inz2))
-		 (do ((i 0 (+ 1 i)))
-		     ((= i 4))
-		   (set! noise-output (- noise-output (* (noise-c i) (outz i)))))
-		 (set! inz2 inz1)
-		 (set! inz1 noise-input)
-		 (set! (dline1 noise-pos) (+ (dline1 noise-pos) (* noise-output noise-gain s-noise)))))
-	   (set! last-tract-plus (* (dline1 tractlength-1) lip-radius)))
-	 (set! (lt 1) (* ltgain (+ (lt 0) (* ltcoeff (lt 1)))))
-	 (outa i (* amp (+ last-lip-out nose-last-output (lt 1))) *output*)
-	 )))))
+	      (set! (dline2 tractlength-1) (+ last-lip-refl (* (coeffs tractlength-1) (- (dline1 tractlength-2) last-lip-refl))))
+	      (set! (dline1 tractlength-1) (+ (dline1 tractlength-2) (- (dline2 tractlength-1) last-lip-refl)))
+	      (set! (dline1 tractlength-2) temp)
+	      (if (not (= noise-gain 0.0))
+		  (begin
+		    (set! noise-input (mus-random 1.0)) ;a guess
+		    (set! noise-output (- noise-input inz2 (fir-filter noisef noise-output)))
+		    (set! inz2 inz1)
+		    (set! inz1 noise-input)
+		    (set! (dline1 noise-pos) (+ (dline1 noise-pos) (* noise-output noise-gain s-noise)))))
+	      (set! last-tract-plus (* (dline1 tractlength-1) lip-radius)))
+	    (outa i (* amp (+ last-lip-out nose-last-output lt1)))
+	    ))))))
 
 #|
-(with-sound () (singer 0 .1 (list (list .4 ehh.shp test.glt 523.0 .8 0.0 .01) (list .6 oo.shp test.glt 523.0 .7 .1 .01))))
+(with-sound (:statistics #t) 
+  (singer 0 .1 (list (list .4 ehh.shp test.glt 523.0 .8 0.0 .01) (list .6 oo.shp test.glt 523.0 .7 .1 .01))))
 
-(with-sound ()
+(with-sound (:statistics #t)
 	    (singer 0 .1 (list (list .05 ehh.shp test.glt 523.0 0.8 0.0 .01) 
 			       (list .15 ehh.shp test.glt 523.0 0.8 0.0 .01) 
 			       (list .05 kkk.shp test.glt 523.0 0.0 0.0 .01)