;;; -*- Lisp -*-
;;;
;;; this is an expansion of the fusion instrument given in ins.lisp.

(defun fix-env (e start-time duration e-start e-dur)
  ;; given envelope (list) "e", global instrument start-time and duration, extend "e" with
  ;; flat segments at the start and end (where necessary) to get the local start and duration
  (if (= start-time e-start)
      (if (= duration e-dur)
	  e				;easy case -- both times coincide
	(if (> e-dur duration)
	    (error "global duration is too short!  Global end=~1,3F, but local end=~1,3F"
		   (+ start-time duration)
		   (+ e-start e-dur))
	  (let* ((last-x (env-last-x e))
		 (new-last-x (float (* last-x (/ duration e-dur))))
		 (last-y (first (last e))))
	    (append e (list new-last-x last-y)))))
    (if (< e-start start-time)
	(error "global start, ~1,3F, is after local start, ~1,3F!" start-time e-start)
      (if (= (+ duration start-time) (+ e-start e-dur))
	  (let* ((first-y (second e))
		 (last-x (env-last-x e))
		 (first-offset (float (* last-x (/ (- e-start start-time) e-dur)))))
	    (append (list 0 first-y)
		    (loop for x in e by #'cddr and y in (cdr e) by #'cddr
		       collect (+ x first-offset) collect y)))
	(let* ((first-y (second e))
	       (last-y (first (last e)))
	       (last-x (env-last-x e))
	       (first-offset (float (* last-x (/ (- e-start start-time) e-dur))))
	       (new-last-x (float (+ last-x first-offset (* last-x (/ (- (+ start-time duration) (+ e-start e-dur)) e-dur))))))
	  (append
	   (list 0 first-y)
	   (loop for x in e by #'cddr and y in (cdr e) by #'cddr
	     collect (+ x first-offset) collect y)
	   (list new-last-x last-y)))))))

	
(definstrument Fusion (start-times durations frequencies amplitudes ampfs indices mf-ratios indfs vib-amps vib-frqs 
		       fusef glissf gliss-amp global-vib-amp global-vib-frq noise-amp deg dist rev-amp)
  (let* ((notes (length frequencies)) 
	 (start-time (loop for st in start-times minimize st))
	 (duration (loop for dur in durations and st in start-times maximize (- (+ st dur) start-time)))
	 (car-oscs (make-array notes :element-type 'osc))
	 (mod-oscs (make-array notes :element-type 'osc))
	 (amp-envs (make-array notes :element-type 'envelope))
	 (fm-envs (make-array notes :element-type 'envelope))
	 (fm-rats (make-array notes :element-type 'short-float))
	 (min-freq (loop for x in frequencies minimize x))
	 (frqscl (in-Hz min-freq))
	 (fuse-env (make-env :envelope fusef :scaler 1.0 :start-time start-time :duration duration))
	 (global-per-vib (make-triangle-wave :frequency global-vib-frq :amplitude (* frqscl global-vib-amp)))
	 (global-ran-vib (make-randi :frequency (+ global-vib-frq 3) :amplitude (* frqscl global-vib-amp)))
	 (global-vib-val 0.0)
	 (global-noise 0.0)
	 (global-noise-source (make-randh :frequency 1000 :amplitude (* two-pi noise-amp)))
	 (local-per-vibs (make-array notes :element-type 'sw))
	 (local-ran-vibs (make-array notes :element-type 'noi)) 
	 (car-vib-scalers (make-array notes :element-type 'short-float))
	 (mod-vib-scalers (make-array notes :element-type 'short-float))
	 (sum 0.0)
	 (global-glissf (make-env :envelope glissf :scaler (* frqscl gliss-amp) :start-time start-time :duration duration))
	 (global-gliss-val 0.0)
	 (beg (floor (* start-time sampling-rate)))
	 (end (+ beg (floor (* duration sampling-rate))))
	 (locs (make-locsig :degree deg :distance dist :revscale rev-amp))
	 (global-vib-amount 0.0)
	 (local-vib-amount 0.0))

    (loop for i from 0 below notes and
	      start in start-times and
	      dur in durations and
              frequency in frequencies and 
              amplitude in amplitudes and
	      fm-index in indices and
              ampf in ampfs and
	      mf-ratio in mf-ratios and
              indf in indfs and
	      vib-frq in vib-frqs and
	      vib-amp in vib-amps do
      (setf (aref car-oscs i) (make-oscil :frequency frequency))
      (setf (aref mod-oscs i) (make-oscil :frequency (* frequency mf-ratio)))
      (setf (aref fm-rats i) (float mf-ratio))
      (setf (aref car-vib-scalers i) (float (/ frequency min-freq)))
      (setf (aref mod-vib-scalers i) (float (/ (* mf-ratio frequency) min-freq)))
      (setf (aref local-per-vibs i) (make-triangle-wave :frequency vib-frq :amplitude (in-Hz (* frequency vib-amp))))
      (setf (aref local-ran-vibs i) (make-randi :frequency (+ vib-frq 3) :amplitude (in-Hz (* frequency vib-amp))))
      (setf (aref amp-envs i) (make-env :envelope (fix-env ampf start-time duration start dur)
					:scaler amplitude :start-time start-time :duration duration))
      (setf (aref fm-envs i) (make-env :envelope (fix-env indf start-time duration start dur)
				       :scaler fm-index :start-time start-time :duration duration)))
      
    (Run				
     (loop for i from beg to end do 
       (setf sum 0.0)
       (setf global-noise (randh global-noise-source))
       (setf global-vib-amount (env fuse-env))
       (setf local-vib-amount (- 1.0 global-vib-amount))
       
       (setf global-vib-val (* global-vib-amount (+ (triangle-wave global-per-vib) (randi global-ran-vib))))
       (setf global-gliss-val (env global-glissf))
       
       (loop for j from 0 below notes do
	 (let ((local-vib-val (+ (triangle-wave (aref local-per-vibs j))
				 (randi (aref local-ran-vibs j)))))
	   (incf sum (* (env (aref amp-envs j))
			(oscil (aref car-oscs j) 
			       (+ (* (aref car-vib-scalers j) (+ global-vib-val global-gliss-val))
				  (* local-vib-amount local-vib-val)
				  (* (env (aref fm-envs j))
				     (oscil (aref mod-oscs j)
					    (+ (* (aref mod-vib-scalers j) (+ global-vib-val global-gliss-val))
					       (* local-vib-amount local-vib-val (aref fm-rats j))
					       global-noise)))))))))
       (locsig locs i sum)))))
			       

#|
(with-sound () 
  (fusion '(0 0) '(2 2) '(440 550) '(.1 .1) 
     '((0 0 20 1 100 0) (0 0 80 1 100 0)) '(.1 .25) '(1 2) 
     '((0 0 50 1 100 0) (0 0 50 1 100 0)) '(.01 .01) '(5 6) 
     '(0 0 50 1 100 0) '(0 0 100 1) 0.1 .01 6 0 0 0 0))

|#