;;; -*- Lisp -*-
;;;
;;; translation from MUS10 of MLB's waveshaping voice instrument (using phase quadrature waveshaping)
;;;

(defvar formants 
    '((I 390 1990 2550)  (E 530 1840 2480)  (AE 660 1720 2410)
      (UH 520 1190 2390) (A 730 1090 2440)  (OW 570 840 2410)
      (U 440 1020 2240)  (OO 300 870 2240)  (ER 490 1350 1690)
      (W 300 610 2200)   (LL 380 880 2575)  (R 420 1300 1600)
      (Y 300 2200 3065)  (EE 260 3500 3800) (LH 280 1450 1600)
      (L 300 1300 3000)  (I2 350 2300 3340) (B 200 800 1750)
      (D 300 1700 2600)  (G 250 1350 2000)  (M 280 900 2200)
      (N 280 1700 2600)  (NG 280 2300 2750) (P 300 800 1750)
      (T 200 1700 2600)  (K 350 1350 2000)  (F 175 900 4400)
      (TH 200 1400 2200) (S 200 1300 2500)  (SH 200 1800 2000)
      (V 175 1100 2400)  (THE 200 1600 2200)(Z 200 1300 2500)
      (ZH 175 1800 2000) (ZZ 900 2400 3800) (VV 565 1045 2400)))
                   ;;formant center frequencies for a male speaker

(defun find-phoneme (phoneme form)
  (loop for i in form do
    (if (eq phoneme (first i))
	(return-from find-phoneme (rest i)))))

(defun vox-fun (phons which)
  (let ((phdata nil)
	(f1 nil))
    (loop for x in phons by #'cddr and
              phoneme in (cdr phons) by #'cddr do
      (setf phdata (find-phoneme phoneme formants))
      (push x f1)
      (push (nth which phdata) f1))
    (nreverse f1)))

(defun pqwvox-normalize-to-power-of-two (coeffs)
  (let ((maxval (abs (aref coeffs 0)))
	(arrsiz (array-total-size coeffs))
	(scaler 0.0))
    (loop for i from 1 below arrsiz do
      (setf maxval (max maxval (abs (aref coeffs i)))))
    (setf maxval (expt 2 (+ 3 (ceiling (/ (log maxval) (log 2))))))
    ;; 3 here to give us plenty of headroom (to accomodate fractional arithmetic on 56000)
    (setf scaler (/ 1.0 maxval))
    (loop for i from 0 below arrsiz do
      (setf (aref coeffs i) (* scaler (aref coeffs i))))
    maxval))

(definstrument pqw-vox (beg dur freq spacing-freq amp ampfun freqfun freqscl phonemes formant-amps formant-shapes &optional (vibscl .1) (deg 0) (pcrev 0))
  (let* ((start (floor (* sampling-rate beg)))
	 (end (+ start (floor (* sampling-rate dur))))
	 (car-sin (make-oscil :frequency 0))
	 (car-cos (make-oscil :frequency 0 :initial-phase half-pi))
	 (fs (length formant-amps))
	 (sin-evens (make-array fs :element-type 'osc))
	 (cos-evens (make-array fs :element-type 'osc))
	 (sin-odds (make-array fs :element-type 'osc))
	 (cos-odds (make-array fs :element-type 'osc))
	 (amps (make-array fs :element-type 'short-float))
	 (frmfs (make-array fs :element-type 'envelope))
	 (shape nil)
	 (sin-coeffs (make-array fs))
	 (cos-coeffs (make-array fs))
	 (sin-norms (make-array fs))
	 (cos-norms (make-array fs))
	 (ampf (make-env :envelope ampfun 
			 :scaler amp
			 :start-time beg :duration dur))
	 (freqf (make-env :envelope freqfun
			  :scaler (* freqscl freq)
			  :offset freq
			  :start-time beg :duration dur))
	 (frq 0.0)
	 (frq-ratio (/ spacing-freq freq))
	 (frqscl 0.0)
	 (fax 0.0)
	 (yfax 0.0)
	 (carsin 0.0)
	 (carcos 0.0)
	 (frm 0.0)
	 (frm-int 0)
	 (frm0 0.0)
	 (even-amp 0.0)
	 (odd-amp 0.0)
	 (even-freq 0.0)
	 (odd-freq 0.0)
	 (sum 0.0)
	 (loc (make-locsig :degree deg :distance 1.0 :revscale pcrev))
	 (per-vib (make-triangle-wave :frequency 6 :amplitude (* freq vibscl)))
	 (ran-vib (make-randi :frequency 20 :amplitude (* freq .5 vibscl))))
    (loop for i from 0 below fs and
              amp in formant-amps and
              fshape in formant-shapes do
      (setf (aref sin-evens i) (make-oscil :frequency 0))
      (setf (aref sin-odds i) (make-oscil :frequency 0))
      (setf (aref cos-evens i) (make-oscil :frequency 0 :initial-phase half-pi))
      (setf (aref cos-odds i) (make-oscil :frequency 0 :initial-phase half-pi))
      (setf (aref amps i) amp)
      (setf shape (normalize-partials fshape))
      (setf (aref cos-coeffs i) (get-chebychev-coefficients shape 1))
      (setf (aref sin-coeffs i) (get-chebychev-coefficients shape 0))
      (setf (aref sin-norms i) (pqwvox-normalize-to-power-of-two (aref sin-coeffs i)))
      (setf (aref cos-norms i) (pqwvox-normalize-to-power-of-two (aref cos-coeffs i)))
      (setf (aref frmfs i) (make-env :envelope (vox-fun phonemes i)
				     :scaler 1.0 :offset 0.0
				     :start-time beg :duration dur)))
    (Run
     (loop for i from start to end do
       (setf frq (+ (env freqf) (triangle-wave per-vib) (randi ran-vib)))
       (setf frqscl (in-Hz (* frq frq-ratio)))
       (setf carsin (oscil car-sin frqscl))
       (setf carcos (oscil car-cos frqscl))
       (setf sum 0.0)
       (dotimes (k fs)
	 (setf frm (env (aref frmfs k)))
	 (setf frm0 (/ frm frq))
	 (setf frm-int (floor frm0))
	 (if (evenp frm-int)
	     (progn
	       (setf even-freq (in-Hz (* frm-int frq)))
	       (setf odd-freq (in-Hz (* (+ frm-int 1) frq)))
	       (setf odd-amp (- frm0 frm-int))
	       (setf even-amp (- 1.0 odd-amp)))
	   (progn
	     (setf odd-freq (in-Hz (* frm-int frq)))
	     (setf even-freq (in-Hz (* (+ frm-int 1) frq)))
	     (setf even-amp (- frm0 frm-int))
	     (setf odd-amp (- 1.0 even-amp))))
	 (setf fax (* (aref cos-norms k) (polynomial (aref cos-coeffs k) carcos)))
	 (setf yfax (* carsin (aref sin-norms k) (polynomial (aref sin-coeffs k) carcos)))
	 (incf sum (* (aref amps k) (+ (* even-amp (- (* yfax (oscil (aref sin-evens k) even-freq))
						      (* fax (oscil (aref cos-evens k) even-freq))))
				       (* odd-amp (- (* yfax (oscil (aref sin-odds k) odd-freq))
						     (* fax (oscil (aref cos-odds k) odd-freq))))))))
       (locsig loc i (* (env ampf) sum))))))


;;; (with-sound () (pqw-vox 0 1 300 300 .1 '(0 0 50 1 100 0) '(0 0 100 0) 0 '(0 L 100 L) '(.33 .33 .33) '((1 1 2 .5) (1 .5 2 .5 3 1) (1 1 4 .5))))
;;; (a test to see if the cancellation is working -- sounds like a mosquito)

;;; (with-sound () (pqw-vox 0 2 100 100 .1 '(0 0 50 1 100 0) '(0 0 100 1) .1 '(0 UH 100 ER) '(.8 .15 .05) '((1 1 2 .5) (1 1 2 .5 3 .2 4 .1) (1 1 3 .1 4 .5))))
;;; (with-sound () (pqw-vox 0 2 100 314 .1 '(0 0 50 1 100 0) '(0 0 100 1) .1 '(0 UH 100 ER) '(.8 .15 .05) '((1 1 2 .5) (1 1 2 .5 3 .2 4 .1) (1 1 3 .1 4 .5))))
;;; (with-sound () (pqw-vox 0 2 200 314 .1 '(0 0 50 1 100 0) '(0 0 100 1) .01 '(0 UH 100 ER) '(.8 .15 .05) '((1 1 2 .5) (1 1 4 .1) (1 1 2 .1 4 .05)) .01))
;;; (with-sound () (pqw-vox 0 2 100 414 .2 '(0 0 50 1 100 0) '(0 0 100 1) .01 '(0 OW 50 E 100 ER) '(.8 .15 .05) '((1 1 2 .5 3 .1 4 .01) (1 1 4 .1) (1 1 2 .1 4 .05)) .01))
