;;; -*- syntax: common-lisp; base: 10; mode: lisp -*-
;;;
;;; Peter Commons' bagpipe

(definstrument canter (beg dur pitch amp-1 deg dis pcrev ampfun ranfun skewfun
		       skewpc ranpc ranfreq indexfun atdr dcdr
		       ampfun1 indfun1 fmtfun1
		       ampfun2 indfun2 fmtfun2
		       ampfun3 indfun3 fmtfun3
		       ampfun4 indfun4 fmtfun4)
  (let* ((start (floor (* beg sampling-rate)))
	 (end (+ start (floor (* dur sampling-rate))))
	 (amp (* amp-1 .25))		;pvc's amplitudes in bag.clm are very high (overflows)
	 (rangetop 910.0)
	 (rangebot 400.0)
	 (k (floor (* 100 (/ (log (/ pitch rangebot)) (log (/ rangetop rangebot))))))
	 (mfq pitch)
	 (atpt (* 100 (/ atdr dur)))
	 (dcpt (- 100 (* 100 (/ dcdr dur))))
	 (lfmt1 (list-interp k fmtfun1))
	 (harm1 (floor (+ .5 (/ lfmt1 pitch))))
	 (dev11 (in-hz (* (list-interp k indfun1) mfq)))
	 (dev01 (* dev11 .5))
	 (lamp1 (* (list-interp k ampfun1) amp (- 1 (abs (- harm1 (/ lfmt1 pitch))))))
	 (lfmt2 (list-interp k fmtfun2))
	 (harm2 (floor (+ .5 (/ lfmt2 pitch))))
	 (dev12 (in-hz (* (list-interp k indfun2) mfq)))
	 (dev02 (* dev12 .5))
	 (lamp2 (* (list-interp k ampfun2) amp (- 1 (abs (- harm2 (/ lfmt2 pitch))))))
	 (lfmt3 (list-interp k fmtfun3))
	 (harm3 (floor (+ .5 (/ lfmt3 pitch))))
	 (dev13 (in-hz (* (list-interp k indfun3) mfq)))
	 (dev03 (* dev13 .5))
	 (lamp3 (* (list-interp k ampfun3) amp (- 1 (abs (- harm3 (/ lfmt3 pitch))))))
	 (lfmt4 (list-interp k fmtfun4))
	 (harm4 (floor (+ .5 (/ lfmt4 pitch))))
	 (dev14 (in-hz (* (list-interp k indfun4) mfq)))
	 (dev04 (* dev14 .5))
	 (lamp4 (* (list-interp k ampfun4) amp (- 1 (abs (- harm4 (/ lfmt4 pitch))))))
	 (tampfun (make-env :envelope (divseg ampfun 25 atpt 75 dcpt)))
	 (tskwfun (make-env :envelope (divseg skewfun 25 atpt 75 dcpt) :scaler (in-hz (* pitch skewpc))))
	 (tranfun (make-env :envelope (divseg ranfun 25 atpt 75 dcpt)))
	 (tidxfun (make-env :envelope (divseg indexfun 25 atpt 75 dcpt)))
	 (modgen (make-oscil :frequency pitch))
	 (gen1 (make-oscil :frequency (* pitch harm1)))
	 (gen2 (make-oscil :frequency (* pitch harm2)))
	 (gen3 (make-oscil :frequency (* pitch harm3)))
	 (gen4 (make-oscil :frequency (* pitch harm4)))
	 (ranvib (make-randh :frequency ranfreq :amplitude (in-hz (* ranpc pitch))))
	 (frqval 0.0)
	 (modval 0.0)
	 (ampval 0.0)
	 (indval 0.0)
	 (loc (make-locsig :degree deg :revscale pcrev :distance dis)))
    (run
     (loop for i from start to end do
       (setf frqval (+ (env tskwfun) (* (env tranfun) (randh ranvib))))
       (setf modval (oscil modgen frqval))
       (setf ampval (env tampfun))
       (setf indval (env tidxfun))
       (locsig loc i 
	       (+ (* lamp1 ampval (oscil gen1 (* (+ (* (+ dev01 (* indval dev11)) modval) frqval) harm1)))
		  (* lamp2 ampval (oscil gen2 (* (+ (* (+ dev02 (* indval dev12)) modval) frqval) harm2)))
		  (* lamp3 ampval (oscil gen3 (* (+ (* (+ dev03 (* indval dev13)) modval) frqval) harm3)))
		  (* lamp4 ampval (oscil gen4 (* (+ (* (+ dev04 (* indval dev14)) modval) frqval) harm4)))))))))