;;; -*- syntax: common-lisp; base: 10; mode: lisp -*-
;;;
;;; Jan Mattox's fm drum:

(definstrument fm-drum (start-time duration frequency amplitude index 
			&optional (high nil) (degree 0.0) (distance 1.0) (reverb-amount 0.01))
  (let* ((beg (floor (* start-time sampling-rate)))
	 (end (+ beg (floor (* duration sampling-rate))))
	 ;; many of the following variables were originally passed as arguments
	 (casrat (if high 8.525 3.515))
	 (fmrat (if high 3.414 1.414))
	 (glsfun '(0 0  25 0  75 1  100 1))
	 (glsf (make-env :envelope glsfun :scaler (if high (in-hz 66) 0.0)))
	 (ampfun '(0 0  3 .05  5 .2  7 .8  8 .95  10 1.0  12 .95  20 .3  30 .1  100 0))
	 (atdrpt (* 100 (/ (if high .01 .015) duration)))
	 (ampf (make-env :envelope (divseg ampfun 
					   10 atdrpt 
					   15 (max (+ atdrpt 1) 
						   (- 100 (* 100 (/ (- duration .2) duration)))))
		  :scaler amplitude))
	 (indxfun '(0  0     5  .014  10 .033  15 .061  20 .099  
		    25 .153  30 .228  35 .332  40 .477  
		    45 .681  50 .964  55 .681  60 .478  65 .332  
		    70 .228  75 .153  80 .099  85 .061  
		    90 .033  95 .0141 100 0))
	 (indxpt (- 100 (* 100 (/ (- duration .1) duration))))
	 (divindxf (divseg indxfun 50 atdrpt 65 indxpt))
	 (indxf (make-env :envelope divindxf :scaler (min (in-hz (* index fmrat frequency)) pi)))
	 (mindxf (make-env :envelope divindxf :scaler (min (in-hz (* index casrat frequency)) pi)))
	 (devf (make-env :envelope (divseg ampfun 
					   10 atdrpt 
					   90 (max (+ atdrpt 1) 
						   (- 100 (* 100 (/ (- duration .05) duration)))))
			 :scaler (min pi (in-hz 7000))))
	 (loc (make-locsig :degree degree :distance distance :revscale reverb-amount))
	 (rn (make-randh :frequency 7000 :amplitude 1.0))
	 (carrier (make-oscil :frequency frequency))
	 (fmosc (make-oscil :frequency (* frequency fmrat)))
	 (cascade (make-oscil :frequency (* frequency casrat))))
    (run
     (loop for i from beg to end do
       (let ((gls (env glsf)))
	 (locsig loc i (* (env ampf) 
			  (oscil carrier 
				 (+ gls 
				    (* (env indxf)
				       (oscil fmosc 
					      (+ (* gls fmrat)
						 (* (env mindxf) (oscil cascade 
									(+ (* gls casrat)
									   (* (env devf) (randh rn)))))))))))))))))
#|			
(with-sound ()
  (fm-drum 0 1.5 55 .3 5 nil)
  (fm-drum 2 1.5 66 .3 4 t))
|#