dom
/
tonalisa
Obserwuj 1
Polub 0
Forkuj 0
Kod Zgłoszenia 0 Oczekujące zmiany 0 Wydania 0 Wiki Aktywność
Nie możesz wybrać więcej, niż 25 tematów Tematy muszą się zaczynać od litery lub cyfry, mogą zawierać myślniki ('-') i mogą mieć do 35 znaków.
1 Commit
1 Gałąź
Gałąź: master
Gałęzie Tagi
${ item.name }
Utwórz gałąź ${ searchTerm }
z 'master'
${ noResults }
tonalisa/lib/sndlib/singer.scm

566 lines
29KB
Czysty Bezpośredni odnośnik Wina Historia 

  1. ;;; Perry Cook's physical model of the vocal tract as described in:

  2. ;;;

  3. ;;; Cook, Perry R. "Synthesis of the Singing Voice Using a Physically Parameterized Model of the Human Vocal Tract"

  4. ;;;     Published in the Proceedings of the International Computer Music Conference, Ohio 1989 

  5. ;;;     and as Stanford University Department of Music Technical Report Stan-M-57, August 1989.

  6. ;;; 

  7. ;;; ---- "Identification of Control Parameters in an Articulatory Vocal Tract Model, with Applications 

  8. ;;;    to the Synthesis of Singing," Ph.D. Thesis, Stanford University Department of Music Technical Report 

  9. ;;;    Stan-M-68, December 1990.

  10. ;;;

  11. ;;; ----  "SPASM, a Real-time Vocal Tract Physical Model Controller; and Singer, the Companion Software 

  12. ;;;    Synthesis System", Computer Music Journal, vol 17 no 1 Spring 1993.

  13. ;;;

  14. ;;; This code is a translation of Perry Cook's singer implementation originally in C.

  15. ;;; Apparently all Perry's data is aimed at srate=22050.

  16. ;;;

  17. ;;; translated from CLM singer.ins

  18. 

  19. (provide 'snd-singer.scm)

  20. (if (provided? 'snd)

  21.     (require snd-ws.scm)

  22.     (require sndlib-ws.scm))

  23. 

  24. (define two-pi (* 2 pi))

  25. 

  26. (definstrument (singer beg amp data)

  27.   ;; data is a list of lists very similar to the sequence of synthesize calls in Perry's original implementation.

  28.   ;;    Each imbedded list has the form: dur shape glot pitch glotamp noiseamps vibramt.

  29.   ;;    See below for examples.

  30. 

  31.   (let* ((durs (map car data))

  32. 	 (dur (apply + durs))

  33. 	 (begs (let ((bg beg))

  34. 		 (cons beg

  35. 		       (map (lambda (x)

  36. 			      (set! bg (+ bg x)))

  37. 			    durs)))))

  38.     (let ((setup (car data))

  39. 	  (beg-samps (map seconds->samples begs)))

  40.       

  41.       (let ((change-times (apply vector (append beg-samps (list (beg-samps (- (length beg-samps) 1))))))

  42. 	    

  43. 	    (shps (map cadr data))

  44. 	    (glts (map caddr data))

  45. 	    

  46. 	    (pfun (let ((init (list 0.0 (* .8 (setup 3)))))

  47. 		    (for-each (lambda (b dat)

  48. 				(set! init (append init (list (- b beg) (* 1.0 (dat 3))))))

  49. 			      (cdr begs)

  50. 			      data)

  51. 		    init))

  52. 	    (gfun (let ((init (list 0.0 0.0)))

  53. 		    (for-each (lambda (b dat)

  54. 				(set! init (append init (list (- b beg) (* 1.0 (dat 4))))))

  55. 			      (cdr begs)

  56. 			      data)

  57. 		    init))

  58. 	    (nfun (let ((init (list 0.0 (* 1.0 (setup 5)))))

  59. 		    (for-each (lambda (b dat)

  60. 				(set! init (append init (list (- b beg) (* 1.0 (dat 5))))))

  61. 			      (cdr begs)

  62. 			      data)

  63. 		    init))

  64. 	    (vfun (let ((init (list 0.0 (* 1.0 (setup 6)))))

  65. 		    (for-each (lambda (b dat)

  66. 				(set! init (append init (list (- b beg) (* 1.0 (dat 6))))))

  67. 			      (cdr begs)

  68. 			      data)

  69. 		    init))

  70. 	    (noiseamps (let* ((len (length data))

  71. 			      (v (make-float-vector len)))

  72. 			 (do ((i 0 (+ i 1)))

  73. 			     ((= i len))

  74. 			   (set! (v i) (* 1.0 ((data i) 5))))

  75. 			 v))

  76. 	    (tractlength 9))		;length of vocal tract

  77. 	

  78. 	(let ((frq-env (make-env pfun :duration dur))

  79. 	      (vib-env (make-env vfun :duration dur))

  80. 	      (vib-osc (make-oscil 6.0))

  81. 	      (glot-env (make-env gfun :duration dur))

  82. 	      (noise-env (make-env nfun :duration dur))

  83. 	      (ran-vib (make-rand-interp :frequency 10 :amplitude .02))

  84. 	      

  85. 	      (glot-datai (make-float-vector (* 2 (length glts))))

  86. 	      (glot-datar (make-float-vector (* 2 (length glts))))

  87. 	      

  88. 	      (tractlength+8 (+ tractlength 8))

  89. 	      (tractlength+1 (+ tractlength 1))

  90. 	      (tractlength-1 (- tractlength 1))

  91. 	      (tractlength-2 (- tractlength 2))

  92. 	      

  93. 	      (noselength 6)

  94. 	      (table-size 1000)		; size of glottis wave-table

  95. 	      (dpole 0.998)

  96. 	      (bg (seconds->samples beg))

  97. 	      (tong-hump-pole 0.998)

  98. 	      (tong-tip-pole 0.998))

  99. 	  

  100. 	  (let ((shape-data (make-float-vector (* (length shps) tractlength+8)))

  101. 		

  102. 		(noselength-1 (- noselength 1))

  103. 		(noselength-2 (- noselength 2))

  104. 		(nose-ring-time 1000)	; naso pharynx response decay time

  105. 		(table-size-over-sampling-rate (/ table-size *clm-srate*))

  106. 		(dgain (- 1.0 dpole))

  107. 		(tong-hump-gain (- 1.0 tong-hump-pole))

  108. 		(tong-tip-gain (- 1.0 tong-tip-pole))

  109. 		

  110. 		(last-sfd -1)

  111. 		(last-gfd -1)

  112. 		

  113. 		(glot-table (make-float-vector (+ 1 table-size)))

  114. 		(glot-table2 (make-float-vector (+ 1 table-size)))

  115. 		;; (gn-table (make-float-vector (+ 1 table-size))) ;(gn-gain 0.0) ;(gn-out 0.0) ;(gn-del (make-float-vector 4))

  116. 		;; (gn-coeffs (make-float-vector 4)) ; in Perry's C code, these were set in setGlotNoiseFilter but it was never called!

  117. 		(table-increment 0.0)

  118. 		(glot-refl-gain 0.7)

  119. 		(pitch 400.0)

  120. 		(last-lip-in 0.0)		;for lip reflection/transmission filter

  121. 		(last-lip-out 0.0)

  122. 		(last-lip-refl 0.0)

  123. 		(lip-refl-gain -0.45)

  124. 		(noise-gain 0.0)		;for vocal tract noise generator

  125. 		(noise-input 0.0)

  126. 		(noise-output 0.0)

  127. 		(noisef (make-fir-filter 4 :xcoeffs (make-float-vector 4)))

  128. 		(noisev #f)

  129. 		(noise-pos 0)

  130. 		(fnoiseamp 0.0)

  131. 		(inz1 0.0)

  132. 		(inz2 0.0)

  133. 		;; nasal tract acoustic tube structure

  134. 		(nose-coeffs (make-float-vector noselength))

  135. 		(nose1 (make-float-vector noselength))

  136. 		(nose2 (make-float-vector noselength))

  137. 		(velum-pos 0.0)

  138. 		(nose-last-minus-refl 0.0)

  139. 		(nose-last-plus-refl 0.0)

  140. 		(nose-last-output 0.0)

  141. 		(nose-filt 0.0)

  142. 		(nose-filt1 0.0)

  143. 		(time-nose-closed 1000)	; this is a hack used to determine if we need to calculate the nasal acoustics

  144. 		;; vocal tract acoustic tube structure

  145. 		

  146. 		;; throat radiation low-pass filter

  147. 		(lt1 0.0)

  148. 		(lp (make-one-pole 0.05 (* -0.05 .9995)))

  149. 		

  150. 		(lip-radius   0.0)

  151. 		(s-glot-mix 1.0)

  152. 		(s-noise 0.0)

  153. 		(initial-noise-position 0.0)

  154. 		(formant-shift 1.0)

  155. 		(change-radii #f) 

  156. 		(delta 0.0) 

  157. 		(new-tract #t)

  158. 		(first-tract #t)

  159. 		(offset -1)

  160. 		(nd (floor (change-times (- (length change-times) 1))))

  161. 		(next-offset bg)

  162. 		

  163. 		(table-location 0.0)

  164. 		(glotsamp 0.0)

  165. 		(last-tract-plus 0.0)

  166. 		(alpha1 0.0)

  167. 		(alpha2 0.0)

  168. 		(alpha3 0.0)

  169. 		(noseposition 3)

  170. 		

  171. 		(target-radii (make-float-vector tractlength+8))

  172. 		(target-temp (make-float-vector tractlength+8))

  173. 		(radii-poles (make-float-vector tractlength+8))

  174. 		(radii-pole-gains (make-float-vector tractlength+8))

  175. 		(radii (make-float-vector tractlength+8))

  176. 					; the radii array contains the vocal tract section radii

  177. 					; (tractlength-1 of them), then glottal reflection gain

  178. 					; then lip reflection gain, then noise position, then noise gain,

  179. 					; then noise pole angle, then noise pole radius, 

  180. 					; then noise pole angle2, then noise pole radius2, then velum opening radius

  181. 		(coeffs (make-float-vector tractlength))

  182. 		(dline1 (make-float-vector tractlength))

  183. 		(dline2 (make-float-vector tractlength)))

  184. 	    

  185. 	    (set! noisev (mus-xcoeffs noisef))

  186. 	    

  187. 	    (do ((k 0 (+ k 1))

  188. 		 (i 0 (+ i tractlength+8)))

  189. 		((= k (length shps)))

  190. 	      (let ((shp (cdr (shps k))))

  191. 		(do ((j i (+ j 1))

  192. 		     (m 0 (+ 1 m)))

  193. 		    ((= m (length shp)))

  194. 		  (float-vector-set! shape-data j (shp m)))))

  195. 	    

  196. 	    (do ((k 0 (+ k 1))

  197. 		 (i 0 (+ i 2)))

  198. 		((= k (length glts)))

  199. 	      (let ((glt (glts k)))

  200. 		(set! (glot-datai i) 0.0)

  201. 		(set! (glot-datai (+ i 1)) (car glt))

  202. 		(set! (glot-datar i) (cadr glt))

  203. 		(set! (glot-datar (+ i 1)) (caddr glt))))

  204. 	    

  205. 	    (set! (nose-coeffs 0) 0.0)

  206. 	    (set! (nose-coeffs 1) -0.29)

  207. 	    (set! (nose-coeffs 2) -0.22)

  208. 	    (set! (nose-coeffs 3) 0.0)

  209. 	    (set! (nose-coeffs 4) 0.24)

  210. 	    (set! (nose-coeffs 5) 0.3571)

  211. 	    

  212. 	    (fill! radii 1.0) ;(do ((i 0 (+ i 1))) ((= i 8)) (set! (radii i) 1.0))

  213. 	    (set! (radii 8) 0.7)

  214. 	    (set! (radii 9) -0.5)

  215. 	    (fill! target-radii 1.0) ;(do ((i 0 (+ i 1))) ((= i 8)) (set! (target-radii i) 1.0))

  216. 	    (set! (target-radii 8) 0.7)

  217. 	    (set! (target-radii 9) -0.5)

  218. 	    

  219. 	    (fill! radii-poles dpole) ;(do ((i 0 (+ i 1))) ((= i tractlength+8)) (set! (radii-poles i) dpole))

  220. 	    (set! (radii-poles 2) tong-hump-pole)

  221. 	    (set! (radii-poles 3) tong-hump-pole)

  222. 	    (set! (radii-poles 4) tong-hump-pole)

  223. 	    (set! (radii-poles 5) tong-tip-pole)

  224. 	    

  225. 	    (fill! radii-pole-gains dgain) ;(do ((i 0 (+ i 1))) ((= i tractlength+8)) (set! (radii-pole-gains i) dgain))

  226. 	    (set! (radii-pole-gains 2) tong-hump-gain)

  227. 	    (set! (radii-pole-gains 3) tong-hump-gain)

  228. 	    (set! (radii-pole-gains 4) tong-hump-gain)

  229. 	    (set! (radii-pole-gains 5) tong-tip-gain)

  230. 	    

  231. 	    ;; ---------------- make glot ----------------

  232. 	    (let ((harms (floor (glot-datai 1)))

  233. 		  (temp1 0.0)

  234. 		  (temp 0.0)

  235. 		  (sines (make-float-vector 200))

  236. 		  (cosines (make-float-vector 200))

  237. 		  (one-over-two-pi  0.159154943)

  238. 		  (two-pi-over-table-size (/ two-pi table-size))

  239. 		  (a (glot-datar 0))

  240. 		  (b (glot-datar 1)))

  241. 	      (let ((a2 (* two-pi a))

  242. 		    (b2 (* two-pi b))

  243. 		    (b-a (- b a)))

  244. 		(let ((sa2 (sin a2))

  245. 		      (ca2 (cos a2)))

  246. 		  (fill! sines 0.0)

  247. 		  (fill! cosines 0.0)

  248. 		  (if (not (= b a))

  249. 		      (begin

  250. 			(set! temp (/ one-over-two-pi b-a))

  251. 			(set! temp1 (- 1.0 ca2))

  252. 			(set! (sines 1) (* (+ ca2 (* (- sa2 (sin b2)) temp)) temp1 one-over-two-pi))

  253. 			(set! (cosines 1) (* (- (* (- ca2 (cos b2)) temp) sa2) temp1 one-over-two-pi))))

  254. 		  (set! (sines 1) (+ (sines 1) (* (- (+ 0.75 (* (cos (* 2 a2)) 0.25)) ca2) one-over-two-pi)))

  255. 		  (set! (cosines 1) (- (+ (cosines 1) (* (- sa2 (* (sin (* 2 a2)) 0.25)) one-over-two-pi)) (* a 0.5)))

  256. 		  (do ((k 2 (+ k 1))

  257. 		       (ka2 (* 2 a2) (+ ka2 a2))

  258. 		       (ka1 a2 (+ ka1 a2))

  259. 		       (ka3 (* 3 a2) (+ ka3 a2)))

  260. 		      ((> k harms))

  261. 		    (if (not (= b a))

  262. 			(begin

  263. 			  (set! temp (/ one-over-two-pi (* b-a k)))

  264. 			  (set! (sines k) (* (+ (cos ka2) (* (- (sin ka2) (sin (* k b2))) temp)) (/ temp1 k)))

  265. 			  (set! (cosines k) (* (- (* (- (cos ka2) (cos (* k b2))) temp) (sin ka2)) (/ temp1 k)))))

  266. 		    (set! (sines k) (+ (sines k) 

  267. 				       (/ (- 1.0 (cos ka2)) k)

  268. 				       (/ (* (- (cos ka1) 1.0) 0.5) (- k 1))

  269. 				       (/ (* (- (cos ka3) 1.0) 0.5) (+ k 1))))

  270. 		    (set! (sines k) (* (sines k) one-over-two-pi))

  271. 		    (set! (cosines k) (- (+ (cosines k) (/ (sin ka2) k)) (/ (* (sin ka1) 0.5) (- k 1)) (/ (* (sin ka3) 0.5) (+ k 1))))

  272. 		    (set! (cosines k) (* (cosines k) one-over-two-pi)))

  273. 		  (fill! glot-table 0.0)

  274. 		  (do ((j 0 (+ j 1))

  275. 		       (x 0.0 (+ x two-pi-over-table-size)))

  276. 		      ((> j table-size))

  277. 		    (do ((k 1 (+ k 1))

  278. 			 (kx x (+ kx x)))

  279. 			((> k harms))

  280. 		      (float-vector-set! glot-table j (+ (float-vector-ref glot-table j) 

  281. 							 (* (float-vector-ref cosines k) (cos kx))

  282. 							 (* (float-vector-ref sines k) (sin kx)))))))))

  283. 	    (copy glot-table glot-table2)

  284. 	    ;; ---------------- end make glot ----------------

  285. 	    

  286. 	    

  287. 	    (do ((i bg (+ i 1)))

  288. 		((= i nd))

  289. 	      (if (= i next-offset)

  290. 		  (begin

  291. 		    ;; time to check for new tract shapes, glottal pulse shapes etc.

  292. 		    (set! offset (+ offset 1))

  293. 		    (set! fnoiseamp (noiseamps offset))

  294. 		    (if (= last-sfd -1)

  295. 			(set! last-sfd 0)

  296. 			(let ((new-sfd (+ last-sfd 8 tractlength)))

  297. 			  (do ((j last-sfd (+ j 1))

  298. 			       (k new-sfd (+ k 1)))

  299. 			      ((= j new-sfd))

  300. 			    (if (> (abs (- (shape-data j) (shape-data k))) .001)

  301. 				(set! new-tract #t)))

  302. 			  (set! last-sfd new-sfd)))

  303. 		    (set! last-gfd (if (= last-gfd -1) 0 (+ last-gfd 2)))

  304. 		    (set! next-offset (floor (change-times (+ offset 1))))

  305. 		    (set! delta (/ 1.0 (- next-offset i)))))

  306. 	      

  307. 	      (if new-tract

  308. 		  (begin

  309. 		    (copy shape-data target-radii last-sfd)

  310. 		    

  311. 		    (if first-tract

  312. 			(copy target-radii radii))

  313. 		    (set! change-radii #f)

  314. 		    (set! initial-noise-position (radii tractlength+1))

  315. 		    (do ((j 0 (+ j 1)))

  316. 			((or (= j tractlength+8)

  317. 			     change-radii))

  318. 		      (if (> (abs (- (target-radii j) (radii j))) 0.001)

  319. 			  (set! change-radii #t)))))

  320. 	      

  321. 	      (when (or first-tract change-radii)

  322. 		(if (not new-tract)

  323. 		    (begin

  324. 		      (float-vector-multiply! radii radii-poles)

  325. 		      (copy target-radii target-temp)

  326. 		      (float-vector-multiply! target-temp radii-pole-gains)

  327. 		      (float-vector-add! radii target-temp)

  328. 		      ;; (do ((j 0 (+ j 1))) ((= j tractlength+8))

  329. 		      ;;   (float-vector-set! radii j (+ (* (float-vector-ref radii j) (float-vector-ref radii-poles j))

  330. 		      ;; 		                   (* (float-vector-ref target-radii j) (float-vector-ref radii-pole-gains j)))))

  331. 		      ))

  332. 		;; set tract shape

  333. 		(do ((tj 1.0)

  334. 		     (tk 0.0)

  335. 		     (k 0 (+ k 1))

  336. 		     (j 1 (+ j 1)))

  337. 		    ((= j tractlength))

  338. 		  (set! tk tj)

  339. 		  (set! tj (if (zero? (float-vector-ref radii j))

  340. 			       1e-10

  341. 			       (* (float-vector-ref radii k) (float-vector-ref radii k))))

  342. 		  (float-vector-set! coeffs j (/ (- tk tj) (+ tk tj))))

  343. 		

  344. 		(set! glot-refl-gain (radii tractlength-1))

  345. 		(set! lip-refl-gain (radii tractlength))

  346. 		(set! noise-pos (floor (radii tractlength+1)))

  347. 		(set! noise-gain (radii (+ tractlength 2)))

  348. 		

  349. 		(let ((temp1 (radii (+ tractlength 3)))

  350. 		      (r (radii (+ tractlength 4)))

  351. 		      (t2 (radii (+ tractlength 5)))

  352. 		      (r2 (radii (+ tractlength 6))))

  353. 		  (let ((noise-angle (hz->radians temp1))     ; fricative noise generator (set noise angle and radius)

  354. 			(noise-angle2 (hz->radians t2)))

  355. 		    (let ((noise-a (* -2.0 (cos (/ noise-angle formant-shift)) r))

  356. 			  (noise-b (* r r))

  357. 			  (noise-a2 (* -2.0 (cos (/ noise-angle2 formant-shift)) r2))

  358. 			  (noise-b2 (* r2 r2)))

  359. 		      (set! (noisev 0) (+ noise-a noise-a2))

  360. 		      (set! (noisev 1) (+ noise-b noise-b2 (* noise-a noise-a2)))

  361. 		      (set! (noisev 2) (+ (* noise-a2 noise-b) (* noise-b2 noise-a)))

  362. 		      (set! (noisev 3) (* noise-b2 noise-b)))))

  363. 		

  364. 		(set! lip-radius (radii tractlength-2))

  365. 		(set! velum-pos (radii (+ tractlength 7)))

  366. 		(let ((leftradius (radii (- noseposition 2)))

  367. 		      (rightradius (radii (- noseposition 1))))

  368. 		  (let ((temp (max (- rightradius velum-pos) 0.0)))

  369. 		    ;; nasal tract (set nasal shape)

  370. 		    (set! alpha1 (* leftradius leftradius))

  371. 		    (set! alpha2 (* temp temp)))

  372. 		  (set! alpha3 (* velum-pos velum-pos)))

  373. 		(let ((temp1 (/ 2.0 (+ alpha1 alpha2 alpha3))))

  374. 		  (set! alpha1 (* alpha1 temp1))

  375. 		  (set! alpha2 (* alpha2 temp1))

  376. 		  (set! alpha3 (* alpha3 temp1))))

  377. 	      

  378. 	      (if new-tract

  379. 		  (begin

  380. 		    (set! new-tract #f)

  381. 		    (set! first-tract #f)

  382. 		    (if (or (< s-noise 1.0) (< fnoiseamp 0.0001))

  383. 			(set! (target-radii tractlength+1) initial-noise-position))))

  384. 	      

  385. 	      (set! s-glot-mix (- s-glot-mix delta))

  386. 	      (set! s-noise (env noise-env))

  387. 	      (set! pitch (env frq-env))

  388. 	      (set! table-increment (* pitch (+ 1.0 (* (env vib-env) (oscil vib-osc)) (rand-interp ran-vib)) table-size-over-sampling-rate))

  389. 	      (set! last-lip-out (+ last-lip-in last-tract-plus))

  390. 	      (set! last-lip-refl (* (+ last-lip-in last-tract-plus) lip-refl-gain))

  391. 	      (set! last-lip-in last-tract-plus)

  392. 	      ;; next glot tick

  393. 	      (set! glotsamp (* (dline2 1) glot-refl-gain))

  394. 	      (if (not (= table-increment 0.0))

  395. 		  (begin

  396. 		    (set! table-location (+ table-location table-increment))

  397. 		    (if (>= table-location table-size)

  398. 			(set! table-location (- table-location table-size)))

  399. 		    (let* ((int-loc (floor table-location))

  400. 			   (table1 (glot-table int-loc)))

  401. 		      (set! glotsamp (+ glotsamp (* (env glot-env) (+ table1 (* s-glot-mix (- (glot-table2 int-loc) table1)))))))))

  402. 	      

  403. 	      ;; next tract tick

  404. 	      (let ((j 0)

  405. 					;(temp1 0.0)

  406. 		    (temp (dline2 2)))

  407. 		(set! lt1 (one-pole lp (+ (dline1 2) temp)))

  408. 		

  409. 		(set! (dline2 1) (+ temp (* (coeffs 1) (- glotsamp temp))))

  410. 		(set! temp (- (+ glotsamp (dline2 1)) temp))

  411. 		(set! temp (singer-filter 1 noseposition temp dline1 dline2 coeffs))

  412. 		(set! j noseposition)	;added

  413. 		;;next nasal tick

  414. 		(let ((plussamp (dline1 (- j 1)))

  415. 		      (minussamp (dline2 (+ j 1)))

  416. 		      (nose-reftemp 0.0))

  417. 		  (if (and (= velum-pos 0.0)

  418. 			   (>= time-nose-closed nose-ring-time))

  419. 		      (let ((nose2-1 (float-vector-ref nose2 1)))

  420. 			(set! nose-reftemp (+ (* alpha1 plussamp) (* alpha2 minussamp) (* alpha3 nose2-1)))

  421. 			(set! nose-last-minus-refl (- nose-reftemp plussamp))

  422. 			(set! nose-last-plus-refl (- nose-reftemp minussamp)))

  423. 		      (begin

  424. 			(set! time-nose-closed 

  425. 			      (if (= velum-pos 0.0)

  426. 				  (+ time-nose-closed 1) ; added 1 bil 17-Apr-11 but didn't test it

  427. 				  0))

  428. 			;; nasal tick

  429. 			(let ((nose-reftemp (+ (* alpha1 plussamp) (* alpha2 minussamp) (* alpha3 (nose2 1)))))

  430. 			  (let (;(nose-t1 0.0)

  431. 				(nose-temp 0.0)

  432. 				(plus-in (* velum-pos (- nose-reftemp (nose2 1)))))

  433. 			    (set! nose-last-minus-refl (- nose-reftemp plussamp))

  434. 			    (set! nose-last-plus-refl (- nose-reftemp minussamp))

  435. 			    (set! nose-reftemp (* (nose-coeffs 1) (- plus-in (nose2 2))))

  436. 			    (set! (nose2 1) (+ (nose2 2) nose-reftemp))

  437. 			    

  438. 			    (set! nose-temp (singer-nose-filter noselength-1 (+ plus-in nose-reftemp) nose1 nose2 nose-coeffs))

  439. 			    (set! nose-reftemp (* (nose-coeffs noselength-1) (- (nose1 noselength-2) (* nose-last-output 0.25))))

  440. 			    (set! (nose2 noselength-1) (+ (* nose-last-output 0.25) nose-reftemp))

  441. 			    (set! (nose1 noselength-1) (+ (nose1 noselength-2) nose-reftemp))

  442. 			    (set! (nose1 noselength-2) nose-temp)

  443. 			    (set! nose-filt1 nose-filt)

  444. 			    (set! nose-filt (nose1 noselength-1))

  445. 			    (set! nose-last-output (* (+ nose-filt nose-filt1) 0.5))))))

  446. 		  (set! (dline2 j) nose-last-minus-refl))

  447. 		(set! (dline1 (- j 1)) temp)

  448. 		

  449. 		;; j always starts at 4, goes to 8 so this loop can be unrolled, but doing so doesn't make a big difference

  450. 		(set! temp (singer-filter noseposition tractlength-1 nose-last-plus-refl dline1 dline2 coeffs))

  451. 		(set! (dline2 tractlength-1) (+ last-lip-refl (* (coeffs tractlength-1) (- (dline1 tractlength-2) last-lip-refl))))

  452. 		(set! (dline1 tractlength-1) (- (+ (dline1 tractlength-2) (dline2 tractlength-1)) last-lip-refl))

  453. 		(set! (dline1 tractlength-2) temp)

  454. 		(if (not (= noise-gain 0.0))

  455. 		    (begin

  456. 		      (set! noise-input (mus-random 1.0)) ;a guess

  457. 		      (set! noise-output (- noise-input inz2 (fir-filter noisef noise-output)))

  458. 		      (set! inz2 inz1)

  459. 		      (set! inz1 noise-input)

  460. 		      (set! (dline1 noise-pos) (+ (dline1 noise-pos) (* noise-output noise-gain s-noise)))))

  461. 		(set! last-tract-plus (* (dline1 tractlength-1) lip-radius)))

  462. 	      (outa i (* amp (+ last-lip-out nose-last-output lt1))))))))))

  463. 

  464. #|

  465. (with-sound (:statistics #t) 

  466.   (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))))

  467. 

  468. (with-sound (:statistics #t)

  469. 	    (singer 0 .1 (list (list .05 ehh.shp test.glt 523.0 0.8 0.0 .01) 

  470. 			       (list .15 ehh.shp test.glt 523.0 0.8 0.0 .01) 

  471. 			       (list .05 kkk.shp test.glt 523.0 0.0 0.0 .01) 

  472. 			       (list .05 kkk.shp test.glt 523.0 0.0 0.0 .01) 

  473. 			       (list .02 kk+.shp test.glt 523.0 0.0 1.0 .01) 

  474. 			       (list .08 kk+.shp test.glt 523.0 0.0 0.2 .01) 

  475. 			       (list .05 ooo.shp test.glt 523.0 0.8 0.0 .01) 

  476. 			       (list .15 ooo.shp test.glt 523.0 0.8 0.0 .01) 

  477. 			       (list .05 eee.shp test.glt 523.0 0.8 0.0 .01) 

  478. 			       (list .15 eee.shp test.glt 523.0 0.8 0.0 .01) 

  479. 			       (list .05 ehh.shp test.glt 523.0 0.8 0.0 .01) 

  480. 			       (list .15 ehh.shp test.glt 523.0 0.8 0.0 .01) 

  481. 			       (list .05 mmm.shp test.glt 523.0 0.8 0.0 .01) 

  482. 			       (list .15 mmm.shp test.glt 523.0 0.8 0.0 .01) 			      

  483. 			       (list .10 mmm.shp test.glt 523.0 0.0 0.0 .01) )))

  484. |#

  485. 

  486. (define test.glt (list 10 .65 .65))

  487. (define loud.glt (list 13 .6 .6))

  488. (define soft.glt (list 13 0.65 0.73))

  489. (define wide4.glt (list 18 0.534 0.56))

  490. (define wide5.glt (list 10 0.65 0.65))

  491. (define greekdefault.glt (list 20 0.65 0.672472))

  492. (define lowbass.glt (list 99 0.5 0.17737593))

  493. 

  494. 

  495. (define aa.shp (list 8 0.63110816 0.94615144 1.0756062 0.9254686 0.9928594 0.98307705 1.4507878 0.95167005 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  496. (define hh2.shp (list 8 0.928177 0.61326 0.39779 0.530387 0.679558 0.961326 1.44199 1.09392 0.7 -0.203125 1.0 0.0 554.1667 0.8 2000.0 0.772222 0.0))

  497. (define dhh.shp (list 8 0.828729 1.45856 0.9882353 0.662983 0.9352941 1.2529411 0.40588236 1.1740758 0.7 -0.140625 7.0 0.023333002 3039.613 0.691692 1264.1677 0.404788 0.0))

  498. (define aah.shp (list 8 0.8214024 0.7839217 1.0981537 0.9937591 0.817757 1.1907763 1.3149668 1.0705689 0.7 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  499. (define hhh.shp (list 8 0.928177 0.61326 0.39779 0.530387 0.679558 0.961326 1.44199 1.09392 0.7 -0.203125 1.0 0.046296295 554.1667 0.8 2000.0 0.7722222 0.0))

  500. (define ohh.shp (list 8 1.02762 0.696133 0.39779 0.513812 0.6371682 1.4070797 1.80663 0.5044248 0.7 -0.2 1.0 0.0 1000.0 0.0 0.0 0.0 0.0))

  501. (define ah.shp (list 8 0.7162393 0.6389201 0.8881412 0.6060006 1.293248 1.4140776 1.8503952 0.8622935 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  502. (define oo.shp (list 8 0.46043858 1.0865723 0.33916336 0.88724023 0.9989101 1.224445 0.39867023 0.506609 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  503. (define ahh.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 1.65746 1.62431 0.944751 0.7 -0.45 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  504. (define ee-.shp (list 8 0.928177 1.37569 1.37569 0.679558 0.629834 0.24817872 0.56896555 0.662983 0.7 -0.403125 1.0 0.0 0.0 0.0 0.0 0.0 0.09677419))

  505. (define hoo.shp (list 8 1.32597 1.29282 0.39779 0.530387 1.32597 1.34254 1.78182 0.46408796 0.7 -0.4 1.0 0.031045755 2215.7856 0.82698005 1026.6984 0.96960765 0.0))

  506. (define ooo.shp (list 8 1.32597 1.29282 0.39779 0.530387 1.32597 1.34254 1.78182 0.464088 0.7 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  507. (define ee.shp (list 8 1.02 1.637 1.67 1.558 0.952 0.501 0.681 0.675 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  508. (define ih.shp (list 8 0.72092783 1.2719809 1.3881364 0.6532612 0.7501422 0.65654784 0.8194081 0.6556785 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  509. (define ee2.shp (list 8 0.9180887 1.3481673 1.3433423 0.74573994 0.593326 0.5647744 0.6692766 0.7419633 0.7 -0.405254 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  510. (define ihh.shp (list 8 0.7906788 1.272475 1.4089537 0.68072784 0.62673146 0.7479623 0.7506758 0.7054355 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  511. (define open.shp (list 8 3.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0 0.7 -0.45 1.0 0.0 0.0 0.0 1.0 0.0 0.0))

  512. (define thh.shp (list 8 0.828729 1.45856 0.9882353 0.662983 0.9352941 1.2529411 0.40588236 1.1740758 0.7 -0.140625 7.0 0.101764 3039.613 0.691692 1264.1677 0.404788 0.0))

  513. (define aw.shp (list 8 1.0525645 0.643587 0.935229 0.4901642 1.0743295 1.1822895 1.4161918 0.82537806 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  514. (define eee.shp (list 8 0.928177 1.37569 1.37569 0.679558 0.629834 0.646409 0.56896555 0.662983 0.7 -0.403125 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  515. (define tt+.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.18584079 1.62431 0.944751 0.7 -0.45 6.0 0.388889 10514.583 0.854335 1315.2043 0.280428 0.0))

  516. (define aww.shp (list 8 1.02762 0.696133 0.563536 0.513812 0.977901 1.37569 1.80663 0.712707 0.7 -0.2 1.0 0.0 1000.0 0.0 0.0 0.0 0.0))

  517. (define eee2.shp (list 8 0.928177 1.37569 1.37569 0.679558 0.629834 0.646409 0.5117647 0.662983 0.7 -0.203125 7.3688526 0.0 5214.53 0.975806 0.0 0.0 0.0))

  518. (define jjj.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.1592921 1.1464338 0.944751 0.7 -0.45 6.0 0.098039 2315.7278 0.7089554 3066.7 0.7983351 0.0))

  519. (define ttt.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.0 1.62431 0.944751 0.7 -0.45 6.0 0.388889 10514.583 0.854335 1315.2043 0.280428 0.0))

  520. (define bb2.shp (list 8 1.0 1.0 0.46902645 0.5486725 0.65486723 1.079646 1.3982301 0.0 0.7 -0.2 8.0 0.03 500.0 0.98 0.0 0.0 0.0))

  521. (define eh.shp (list 8 0.7866194 1.1630946 1.2335452 0.93186677 0.94121367 0.7586716 1.3509308 0.8279036 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  522. (define kk+.shp (list 8 0.8214024 0.7839217 1.0981537 0.1592921 1.061947 1.1907763 1.3149668 1.0705689 0.7 -0.4 4.0 0.4 2000.0 0.93 0.0 0.0 0.0))

  523. (define pipe1.shp (list 8 1.0 1.0 1.0 0.7 0.7 0.7 0.7 0.7 0.0 0.0 1.0 0.0 100.0 0.0 0.0 0.0 0.0))

  524. (define tzz.shp (list 8 0.828729 1.45856 0.9882353 0.662983 0.9352941 1.2529411 0.40588236 1.1740758 0.7 -0.140625 7.0 0.101764 3039.613 0.691692 1264.1677 0.404788 0.0))

  525. (define bbb.shp (list 8 1.0 1.0 0.46902645 0.5486725 0.65486723 1.079646 1.3982301 0.0 0.7 -0.2 8.0 0.03 500.0 0.98 0.0 0.0 0.0))

  526. (define ehh.shp (list 8 0.682 1.554 1.581 1.367 1.315 1.579 0.843 1.476 0.7 -0.24507 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  527. (define kk2.shp (list 8 0.82140243 0.7839217 1.0981537 0.0 1.061947 1.1907763 1.3149668 1.0705689 0.7 -0.4 5.0 0.01 2000.0 0.93 0.0 0.0 0.0))

  528. (define pp+.shp (list 8 1.0 1.0 0.3362832 0.49557513 0.7079646 1.2389379 1.1327434 0.29203534 0.7 -0.2 8.0 0.040740736 0.0 0.89649165 2082.2144 0.8713607 0.0))

  529. (define uhh.shp (list 8 0.928177 0.61326 0.39779 0.530387 0.679558 0.961326 1.44199 1.09392 0.7 -0.203125 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  530. (define big.shp (list 8 3.0 3.0 3.0 3.0 3.0 3.0 3.0 3.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0))

  531. (define euu.shp (list 8 0.9285748 1.3756071 1.3747121 0.6794088 0.60398144 0.43471563 0.8356653 0.7158814 0.7 -0.403122 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  532. (define kkk.shp (list 8 0.8214024 0.7839217 1.0981537 0.0 1.061947 1.1907763 1.3149668 1.0705689 0.7 -0.4 4.0 0.09444445 2000.0 0.93 0.0 0.0 0.0))

  533. (define ppp.shp (list 8 1.0 1.0 0.3362832 0.49557513 0.7079646 1.2389379 1.1327434 0.0 0.7 -0.2 8.0 0.05 500.0 0.98 0.0 0.0 0.0))

  534. (define uu.shp (list 8 0.45291674 1.0539645 0.39576897 0.8116293 1.0510263 1.1789232 0.47529656 0.62563825 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  535. (define fff.shp (list 8 0.93787295 0.70496833 0.8969878 0.60815966 0.9375178 0.7412625 1.1285298 0.2665695 0.7 -0.202603 8.0 0.10341219 8236.909 0.945306 79.28094 0.498648 0.0))

  536. (define ll2.shp (list 8 0.928177 0.779006 0.71772796 0.807417 1.02762 1.65746 0.36206907 0.86510503 0.7 -0.258055 1.0 0.0 0.0 0.0 0.0 0.0 0.20806663))

  537. (define uuu.shp (list 8 0.55 0.943094 1.035 0.434071 1.14681 1.487 0.555 0.656 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  538. (define lll.shp (list 8 0.928177 0.779006 0.7330638 0.8156748 1.02762 1.65746 0.3620689 0.944751 0.7 -0.103125 1.0 0.0 0.0 0.0 0.0 0.0 0.21774194))

  539. (define rolledr.shp (list 8 0.3365169 0.9244819 1.0542682 0.4485168 1.0597233 0.054845095 0.66896766 0.8336522 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  540. (define vvv.shp (list 8 0.9400966 0.6775904 0.88759726 0.59890866 0.9485658 0.737778 1.1542239 0.23893797 0.7 -0.2 8.0 0.5 8500.0 0.95 0.0 0.5 0.0))

  541. (define rolledrc.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.0 1.62431 0.944751 0.7 -0.45 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  542. (define mmm.shp (list 8 1.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.7 -0.2 1.0 0.0 0.0 0.0 0.0 0.0 0.503268))

  543. (define rolledro.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.42477876 1.62431 0.944751 0.7 -0.45 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  544. (define breath.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 1.65746 1.62431 0.944751 0.7 -0.45 1.0 0.018518519 2588.6013 0.90612125 812.6343 0.9814815 0.0))

  545. (define moo.shp (list 8 1.32597 1.29282 0.39779 0.530387 1.32597 1.34254 1.78182 0.0 0.7 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.30645162))

  546. (define rr2.shp (list 8 0.3365169 0.9244819 1.0542682 0.4485168 1.0597233 0.71856207 0.66896766 0.7274576 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 32.000004 0.0))

  547. (define chh.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.1592921 1.1464338 0.944751 0.7 -0.45 6.0 0.098039 2315.7278 0.7089554 3066.7 0.7983351 0.0))

  548. (define gg2.shp (list 8 0.8214024 0.4122405 0.40788835 0.0 0.8495575 0.7129002 0.7308959 0.7785335 0.7 -0.4 4.0 0.05 2000.0 0.9 0.0 0.0 0.0))

  549. (define nng.shp (list 8 1.0 1.0 1.0333333 0.0 1.0 0.99999994 0.9568965 1.3189656 0.7 -0.2 1.0 0.0 0.0 0.0 0.0 0.0 1.0))

  550. (define rrr.shp (list 8 0.3365169 0.9244819 1.0542682 0.4485168 1.0597233 0.71856207 0.66896766 0.7274576 0.9 -0.4 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  551. (define wsp.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 1.65746 1.62431 0.944751 0.7 -0.45 1.0 0.018518519 0.0 0.97 0.0 0.0 0.0))

  552. (define ggg.shp (list 8 0.8214024 0.7839217 1.0981537 0.0 0.8495575 0.7129002 0.7308959 0.7785335 0.7 -0.4 4.0 0.05 2000.0 0.9 0.0 0.0 0.0))

  553. (define nnn.shp (list 8 1.0 1.0 1.0 1.4579439 1.0 0.0 0.9568965 1.3189656 0.7 -0.2 1.0 0.0 0.0 0.0 0.0 0.0 0.503268))

  554. (define sh2.shp (list 8 0.828729 1.45856 0.9882353 0.662983 0.9352941 1.2529411 0.40588236 0.9882353 0.7 -0.140625 7.0 0.0 2451.5984 0.928097 2957.0518 0.883636 0.0))

  555. (define xx2.shp (list 8 0.928177 1.37569 1.37569 0.8495575 0.3451327 0.646409 0.56896555 0.662983 0.7 -0.403125 5.0 0.022222 2102.0833 0.805556 1735.4166 0.759259 0.0))

  556. (define dd2.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.0 0.72165513 0.5996184 0.7 -0.45 6.0 0.02 4851.6665 0.953704 2500.0 0.966296 0.0))

  557. (define ggg1.shp (list 8 0.8214024 0.7839217 1.0981537 0.18584079 1.061947 1.1907763 1.3149668 1.0705689 0.7 -0.4 4.0 0.4 2000.0 0.9 0.0 0.0 0.0))

  558. (define noisahh.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 1.65746 1.62431 0.944751 0.7 -0.45 1.0 0.005 0.0 0.787037 3777.0835 0.759259 0.0))

  559. (define shh.shp (list 8 0.828729 1.45856 0.9882353 0.662983 0.9352941 1.2529411 0.40588236 0.9882353 0.7 -0.140625 7.0 0.023333 2451.5984 0.9280972 2957.0518 0.88363576 0.0))

  560. (define xxx.shp (list 8 0.928177 1.37569 1.37569 0.3451327 0.6371682 0.646409 0.56896555 0.662983 0.7 -0.403125 4.0 0.022222219 2102.0833 0.8055556 612.5 0.7592593 0.0))

  561. (define ddd.shp (list 8 0.928177 0.779006 0.629834 0.629834 1.02762 0.0 0.72165513 0.5996184 0.7 -0.45 6.0 0.02 4851.6665 0.953704 2500.0 0.966296 0.0))

  562. (define gxx.shp (list 8 0.928177 1.37569 1.37569 0.3451327 0.6371682 0.646409 0.56896555 0.662983 0.7 -0.403125 4.0 0.022222 2102.0833 0.805556 612.5 0.759259 0.0))

  563. (define none.shp (list 8 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0))

  564. (define sss.shp (list 8 0.928177 1.3588235 1.3588235 0.679558 0.61764705 0.63529414 0.31764707 0.65294117 0.7 -0.103125 7.0 0.105292 1500.0 0.916452 4943.75 0.97222227 0.0))

  565. (define zzz.shp (list 8 0.928177 1.3588235 1.3588235 0.679558 0.61764705 0.63529414 0.31764707 0.65294117 0.7 -0.103125 7.0 0.016 1500.0 0.9257112 4943.75 0.925926 0.0))