;;; -*- Lisp -*-

;;; FM VIOLIN ----------------------------------------------

(defun v-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 (+ 2 (ceiling (/ (log maxval) (log 2))))))
    ;; 2 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))

(defun bit20 (x)			;modifier got 2's complement 20 bit interpreted as fraction 
  (if (>= x (expt 2 19))
      (float (/ (- x (expt 2 20)) (expt 2 19)))
    (float (/ x (expt 2 19)))))

(defun make-frobber-function (beg end frobl)
  (let ((result (list beg))
	(val (bit20 (cadr frobl))))
    (loop for x in frobl by #'cddr and 
              y in (cdr frobl) by #'cddr do
      (when (and (>= x beg)
		 (<= x end))
	(push val result)
	(push x result)
	(setf val (bit20 y))))
    (push val result)
    (push end result)
    (push val result)
    (nreverse result)))

(defvar fm-violin-fm-index 1.0)
(defvar fm-violin-amp-env '(0 0  25 1  75 1  100 0))
(defvar fm-violin-periodic-vibrato-rate 5.0)
(defvar fm-violin-random-vibrato-rate 16.0)
(defvar fm-violin-periodic-vibrato-amplitude 0.0025)
(defvar fm-violin-random-vibrato-amplitude 0.005)
(defvar fm-violin-noise-amount 0.0)
(defvar fm-violin-noise-freq 1000.0)
(defvar fm-violin-ind-noise-amount 0.0)
(defvar fm-violin-ind-noise-freq 10.0)
(defvar fm-violin-amp-noise-amount 0.0)
(defvar fm-violin-amp-noise-freq 20.0)
(defvar fm-violin-gliss-env '(0 0  100 0))
(defvar fm-violin-glissando-amount 0.0)
(defvar fm-violin-fm1-env '(0 1  25 .4  75 .6  100 0))
(defvar fm-violin-fm2-env fm-violin-fm1-env)
(defvar fm-violin-fm3-env fm-violin-fm1-env)
(defvar fm-violin-fm1-rat 1.0)
(defvar fm-violin-fm2-rat 3.0)
(defvar fm-violin-fm3-rat 4.0)
(defvar fm-violin-base nil)
(defvar fm-violin-frobber nil)
(defvar fm-violin-reverb-amount 0.01)
#-mcl (defvar fm-violin-noise-type 'Sambox-random)
#+mcl (defvar fm-violin-noise-type nil)
(defvar fm-violin-index-type :violin)
(defvar fm-violin-denoise nil)
(defvar fm-violin-index1 nil)
(defvar fm-violin-index2 nil)
(defvar fm-violin-index3 nil)

(defun restore-fm-violin-defaults ()
  (setf fm-violin-fm-index 1.0)
  (setf fm-violin-amp-env '(0 0  25 1  75 1  100 0))
  (setf fm-violin-periodic-vibrato-rate 5.0)
  (setf fm-violin-random-vibrato-rate 16.0)
  (setf fm-violin-periodic-vibrato-amplitude 0.0025)
  (setf fm-violin-random-vibrato-amplitude 0.005)
  (setf fm-violin-noise-amount 0.0)
  (setf fm-violin-noise-freq 1000.0)
  (setf fm-violin-ind-noise-amount 0.0)
  (setf fm-violin-ind-noise-freq 10.0)
  (setf fm-violin-gliss-env '(0 0  100 0))
  (setf fm-violin-glissando-amount 0.0)
  (setf fm-violin-fm1-env '(0 1  25 .4  75 .6  100 0))
  (setf fm-violin-fm2-env fm-violin-fm1-env)
  (setf fm-violin-fm3-env fm-violin-fm1-env)
  (setf fm-violin-fm1-rat 1.0)
  (setf fm-violin-fm2-rat 3.0)
  (setf fm-violin-fm3-rat 4.0)
  (setf fm-violin-base nil)
  (setf fm-violin-frobber nil)
  (setf fm-violin-reverb-amount 0.01)
  (setf fm-violin-noise-type 'Sambox-random)
  (setf fm-violin-index-type :violin)
  (setf fm-violin-denoise nil)
  (setf fm-violin-index1 nil)
  (setf fm-violin-index2 nil)
  (setf fm-violin-index3 nil))

(definstrument FM-violin
	       (start-time duration frequency amplitude
		&key (fm-index                   fm-violin-fm-index)
		     (amp-env                    fm-violin-amp-env)
		     (periodic-vibrato-rate      fm-violin-periodic-vibrato-rate)
		     (random-vibrato-rate        fm-violin-random-vibrato-rate)
		     (periodic-vibrato-amplitude fm-violin-periodic-vibrato-amplitude)
		     (random-vibrato-amplitude   fm-violin-random-vibrato-amplitude)
		     (noise-amount               fm-violin-noise-amount)
		     (ind-noise-freq             fm-violin-ind-noise-freq)
		     (ind-noise-amount           fm-violin-ind-noise-amount)
		     (amp-noise-freq             fm-violin-amp-noise-freq)
		     (amp-noise-amount           fm-violin-amp-noise-amount)
		     (noise-freq                 fm-violin-noise-freq)
		     (gliss-env                  fm-violin-gliss-env)
		     (glissando-amount           fm-violin-glissando-amount)
		     (fm1-env                    fm-violin-fm1-env)
		     (fm2-env                    fm-violin-fm2-env)
		     (fm3-env                    fm-violin-fm3-env)
		     (fm1-rat                    fm-violin-fm1-rat)
		     (fm2-rat                    fm-violin-fm2-rat)
		     (fm3-rat                    fm-violin-fm3-rat)
		     (fm1-index                  fm-violin-index1)
		     (fm2-index                  fm-violin-index2)
		     (fm3-index                  fm-violin-index3)
		     (base                       fm-violin-base)
		     (frobber                    fm-violin-frobber)
		     (reverb-amount              fm-violin-reverb-amount)
		     (noise-type                 fm-violin-noise-type)
		     (index-type                 fm-violin-index-type)
		     (degree                     nil)
		     (distance                   1.0)
		     (no-waveshaping             nil)
		     (denoise                    fm-violin-denoise)
		     (denoise-dur                .1) ;used to be .5 
		     (denoise-amp                .005)
		&allow-other-keys)
  (if (> (abs amplitude) 1.0) (error "amplitude = ~A?" amplitude))
  (if (< (abs frequency) 1.0) (error "frequency = ~A?" frequency))
  (let* ((beg (floor (* start-time sampling-rate)))
	 (end (+ beg (floor (* duration sampling-rate))))
	 
	 (frq-scl (in-Hz frequency))
	 (modulate (not (zerop fm-index)))
	 (maxdev (* frq-scl fm-index))
	 (vln (not (eq index-type :cello)))
	 (easy-case (and (not no-waveshaping)
			 (zerop noise-amount)
			 (eq fm1-env fm2-env)
			 (eq fm1-env fm3-env)
			 (zerop (- fm1-rat (floor fm1-rat)))
			 (zerop (- fm2-rat (floor fm2-rat)))
			 (zerop (- fm3-rat (floor fm3-rat)))))
	 ;; if the envelopes are all the same, and each ratio is an integer, we can use
	 ;; waveshaping to get the modulation very cheaply -- i.e. around 10 instructions 
	 ;; as opposed to 200 instructions used by 3 sine calcs, 3 envelopes,
	 ;; and 6 double-precision multiplies. (And it is extremely cheap to add more 
	 ;; moduators here because each is just a multiply-add at run time!)
	 ;; The drawback is that waveshaping as implemented in the 56000 is noisier
	 ;;  than the equivalent 3 sinewaves added together.

	 (logfreq (log frequency))
	 (sqrtfreq (sqrt frequency))
	 (index1 (or fm1-index (min one-pi (* maxdev (/ (if vln 5.0 7.5) logfreq)))))
	 (index2 (or fm2-index (min one-pi (* maxdev 3.0 (if vln 
							     (/ (- 8.5 logfreq) (+ 3.0 (* frequency .001)))
							   (/ 15.0 sqrtfreq))))))
	 (index3 (or fm3-index (min one-pi (* maxdev (/ (if vln 4.0 8.0) sqrtfreq)))))

	 (coeffs (and easy-case modulate
		      (get-chebychev-coefficients 
		       (list fm1-rat index1
			     fm2-rat index2
			     fm3-rat index3))))
	 (norm (or (and easy-case modulate (v-normalize-to-power-of-two coeffs)) index1))
	 
	 (carrier (make-oscil :frequency frequency))
	 (fmosc1  (and modulate (make-oscil :frequency (* fm1-rat frequency))))
	 (fmosc2  (and modulate (or easy-case (make-oscil :frequency (* fm2-rat frequency)))))
	 (fmosc3  (and modulate (or easy-case (make-oscil :frequency (* fm3-rat frequency)))))
	 (ampf  (make-env :envelope (if denoise 
					(reduce-amplitude-quantization-noise amp-env duration amplitude denoise-dur denoise-amp)
				      amp-env)
			  :base base
			  :start-time start-time :duration duration 
			  :scaler amplitude))
	 (indf1 (and modulate
		     (make-env :envelope fm1-env 
			       :start-time start-time :duration duration :scaler norm)))
	 (indf2 (and modulate
		     (or easy-case
			 (make-env :envelope fm2-env 
				   :start-time start-time :duration duration :scaler index2))))
	 (indf3 (and modulate
		     (or easy-case 
			 (make-env :envelope fm3-env 
				   :start-time start-time :duration duration :scaler index3))))
	 (frqf (make-env :envelope gliss-env
			 :start-time start-time :duration duration 
			 :scaler (* glissando-amount frq-scl)))
	 (pervib (make-triangle-wave :frequency periodic-vibrato-rate 
				     :amplitude (* periodic-vibrato-amplitude frq-scl)))
	 (ranvib (make-randi :frequency random-vibrato-rate 
			     :amplitude (* random-vibrato-amplitude frq-scl)))
	 (fm-noi (if (and (/= 0.0 noise-amount)
			  (null frobber))
		     (make-randh :frequency noise-freq
				 :amplitude (* one-pi noise-amount)
				 :type noise-type)))
	 (ind-noi (if (and (/= 0.0 ind-noise-amount) (/= 0.0 ind-noise-freq))
		      (make-randi :frequency ind-noise-freq
				  :amplitude ind-noise-amount)))
	 (amp-noi (if (and (/= 0.0 amp-noise-amount) (/= 0.0 amp-noise-freq))
		      (make-randi :frequency amp-noise-freq
				  :amplitude amp-noise-amount)))
	 (frb-env (if (and (/= 0.0 noise-amount)
			   frobber)
		      (make-env :envelope (make-frobber-function start-time (+ start-time duration) frobber)
				:base 0
				:scaler (* two-pi noise-amount)
				:start-time start-time
				:duration duration)))
	 (vib 0.0) 
	 (modulation 0.0)
	 (loc (make-locsig :degree (or degree (random 90.0)) :revscale reverb-amount :distance distance))
	 (fuzz 0.0)
	 (ind-fuzz 1.0)
	 (amp-fuzz 1.0))
    (Run
     (loop for i from beg to end do
       (if (/= 0.0 noise-amount)
	   (if (null frobber)
	       (setf fuzz (randh fm-noi))
	     (setf fuzz (env frb-env))))
       (setf vib (+ (env frqf) (triangle-wave pervib) (randi ranvib)))
       (if ind-noi (setf ind-fuzz (+ 1.0 (randi ind-noi))))
       (if amp-noi (setf amp-fuzz (+ 1.0 (randi amp-noi))))
       (if modulate
	   (if easy-case
	       (setf modulation
		 (* (env indf1) 
		    (polynomial coeffs (oscil fmosc1 vib))))
	     (setf modulation
	       (+ (* (env indf1) (oscil fmosc1 (+ (* fm1-rat vib) fuzz)))
		  (* (env indf2) (oscil fmosc2 (+ (* fm2-rat vib) fuzz)))
		  (* (env indf3) (oscil fmosc3 (+ (* fm3-rat vib) fuzz)))))))
       (locsig loc i
	     (* (env ampf) amp-fuzz
		(oscil carrier (+ vib (* ind-fuzz modulation)))))))))


;;; the "fuzz" term is not scaled to fit each modulator (this is the way the SAM version worked)
