;;; test suite for CLM generators and various control options

(definstrument s1a (beg dur) 
  (let ((o1 (make-oscil 440.0)) (o2 nil) (oa (make-array 3 :initial-element nil)))
    (setf (aref oa 1) (make-oscil :frequency 660))
    (run
     (loop for i from beg to (+ beg dur) do
       (declare (type :mus-any o1 o2)
		(type :mus-any* oa))
       (let ((sum (+ (if o1 (oscil o1) 0.0)
		     (if o2 (oscil o2) 0.0))))
	 (dotimes (k 3) (if (aref oa k) (incf sum (oscil (aref oa k)))))
	 (outa i (* .1 sum)))))))

(definstrument s2 (beg dur)
  (let ((o1 (make-oscil 440.0))
	(o2 (make-oscil :frequency 1200)))
    (run
     (loop for i from beg to (+ beg dur) do
       (if (= i beg) (setf (mus-phase o1) 0.0))
       (if (= (- i beg) 5000) (setf (mus-frequency o2) 660.0))
       (outa i (* .1 (+ (oscil o1) (oscil o2))))))))

(definstrument s4 (beg dur)
  (let ((sw1 (make-sawtooth-wave :frequency 440.0))
	(sw2 (make-square-wave :frequency 440.0))
	(sw3 (make-triangle-wave :frequency 440.0))
	(sw4 (make-pulse-train :frequency 440.0))
	(sw5 nil)
	(swa (make-array 3 :initial-element nil))
	(ctr 0)
	(stp 0)
	(lim (floor dur 5)))
    (setf (aref swa 2) (make-square-wave :frequency 660))
    (run
     (loop for i from beg to (+ beg dur) do
       (declare (type :mus-any sw1 sw5))
       (let ((val (case ctr
		    (0 (+ (if sw1 (sawtooth-wave sw1) 0.0) (if sw5 (sawtooth-wave sw5) 0.0)))
		    (1 (square-wave sw2))
		    (2 (triangle-wave sw3))
		    (3 (pulse-train sw4))
		    (otherwise (do ((sum 0.0) 
				    (k 0 (+ k 1))) 
				   ((= k 3) sum) 
				 (if (aref swa k) 
				     (incf sum (square-wave (aref swa k)))))))))
	 (outa i (* .1 val))
	 (incf stp)
	 (when (= stp lim)
	   (incf ctr)
	   (setf stp 0)))))))

(definstrument s5 (beg dur)
  (let ((o1 (make-square-wave :frequency 440))
	(stp 0)
	(lim (floor dur 10)))
    (run
     (loop for i from beg to (+ beg dur) do
       (if (= i beg) (setf (mus-phase o1) 0.0))
       (if (= (- i beg) 5000) (setf (mus-frequency o1) 660.0))
       (when (= stp lim)
	 (decf (mus-scaler o1) .1)
	 (setf stp 0))
       (incf stp)
       (outa i (* .1 (square-wave o1)))))))

(definstrument s7 (beg dur)
  (let ((o1 (make-rand :envelope '(0 0 1 1)))
	(o2 (make-rand :frequency 10)))
    (run
     (loop for i from beg to (+ beg dur) do
       (tagbody
	 (if (= i beg) (setf (mus-phase o1) 0.0))
	 (if (= (- i beg) 5000) (setf (mus-frequency o2) (* 3 660.0)))
	 (go test)
	 (warn "ignored a label?")
	test
	 (outa i (* .1 (+ (rand o1) (rand o2)))))))))

(definstrument s9 (beg dur)
  (let* ((waveform (partials->wave '(1 .5  2 1  3 .5  4 .1  5 .01)))
	 (s (make-table-lookup :frequency 440.0 :wave waveform))
	 (s1 (make-table-lookup :frequency 440.0))
	 (loc (make-locsig :degree 0))
	 (x (aref waveform 123))
	 (chans (mus-channels *output*)))
    (setf (aref (mus-data s1) 100) (double .95))
    (run
     (loop for i from beg to (+ beg dur) do
       (when (= (- i beg) 5000)
	 (setf (locsig-ref loc 0) .125)
	 (if (> chans 1) (setf (locsig-ref loc 1) .875)))
       (when (= (- i beg) 10000)
	 (setf (locsig-ref loc 0) .875)
	 (if (> chans 1) (setf (locsig-ref loc 1) .125)))
       (unless (< (abs (- (aref (mus-data s) 123) x)) .0001) (clm-print "x: ~F " (aref (mus-data s) 123)))
       (setf (aref (mus-data s1) 100) .1)
       (locsig loc i 
	     (block hi-mom
	       (if (= (- i beg) 5000) (setf (mus-frequency s) (/ (* 660.0 512) 22050.0)))
	       (if (/= (mus-length s) 512) (progn (print "hunh?") (return-from hi-mom 0.0)))
	       (* (aref (mus-data s1) 100) (+ (table-lookup s) (table-lookup s1)))))))))

(definstrument s11 (beg dur)
  (let* ((amp .1)
         (f (make-formant 1000 .995))
	 (fs (make-array 3 :initial-element nil))
	 (ns (make-array 3 :initial-element nil))
         (noi (make-rand :frequency 5000 :amplitude 1.0)))
    (setf (aref fs 0) (make-formant 1000 .995))
    (setf (aref ns 1) (make-rand-interp :frequency 6000 :amplitude 1.0))
    (setf (aref ns 2) (make-rand-interp :frequency 6000 :amplitude 1.0 :envelope '(-1 1 0 0 1 1)))
    (run
      (loop for i from beg to (+ beg dur) do
	(declare (type :mus-any* fs))
	(if (= (- i beg) 5000) (setf (mus-frequency noi) 1000))
        (outa i (* amp (+ (formant f (rand noi)))
			  (do* ((sum 0.0) 
				(k 0 (+ k 1))) 
			      ((= k 3) sum) 
			    (if (aref fs k) 
				(incf sum (formant (aref fs k) 
						  (do* ((sum 0.0) 
							(k 0 (+ k 1))) 
						      ((= k 3) sum) 
						    (if (aref ns k) 
							(incf sum (rand-interp (aref ns k)))))))))))))))

(definstrument s12b (beg dur) 
  (let ((oa (make-array 3 :initial-element nil))
	(aa (make-double-array 3 :initial-element 0.0))
	(aw (make-double-array 3 :initial-element 0.1)))
    (setf (aref oa 0) (make-oscil :frequency 660))
    (setf (aref oa 1) (make-oscil :frequency 440))
    (setf (aref oa 2) (make-oscil :frequency 220))
    (run
     (loop for i from beg to (+ beg dur) do
       (dotimes (k 3) (setf (aref aa k) (oscil (aref oa k))))
       (outa i (* .1 (+ (amplitude-modulate (aref aa 0) (aref aa 1) (aref aa 2))
			(dot-product aa aw)
			(ring-modulate (aref aa 1) (aref aa 2)))))))))

(definstrument s12a (beg dur) 
  (let ((aa (make-double-array 3 :initial-element 0.2))
	(aw (make-double-array 3 :initial-element 0.1)))
    (run
     (loop for i from beg to (+ beg dur) do
       (let ((sum (dot-product aa aw)))
	 (if (> (abs (- sum (* 3 .02))) 0.001) (clm-print "dot-product: ~F" sum))
	 (outa i 0.0))))))

(definstrument s13 (beg dur)
  (let* ((srcC (make-readin :file "pistol.snd" :start 0))
	 (ctr 0))
    (run
     (loop for i from beg to (+ beg dur) do
       (let ((val (+ (* 2 (readin srcC)))))
	 (when (> ctr 5000)
	   (setq ctr 0)
	   (setf (mus-location srcC) 0))
	 (incf ctr)
	 (if (/= (mus-channel srcC) 0) (print "oops"))
	 (outa i (* .1 val))
	 (if (not (= (mus-channels *output*) 1)) (outb i (* .1 val)))
	 (when (= (mus-channels *output*) 4) (outc i (* .1 val)) (outd i (* .1 val))))))))

(definstrument s14 (beg dur)
  (let ((dl (make-delay 12))
	(cm (make-comb .5 4))
	(al (make-all-pass .5 .5 12))
	(nt (make-notch .9 9))
	(zl (make-delay 12 :max-size 128))
	(pl (make-one-pole .9 .1))
	(ozl (make-one-zero .5 .5))
	(tpl (make-two-pole .1 .1 .1))
	(tzl (make-two-zero .1 .1 .1))
	(ppl (make-two-pole :radius .99 :frequency 2000))
	(zpl (make-two-zero :radius .99 :frequency 2000))
	(ol (make-oscil 440.0)))
    (run
     (loop for i from beg to (+ beg dur) do
       (let ((val (oscil ol)))
	 (if (/= (mus-length dl) 12) (print "dl size"))
	 (if (/= (mus-length cm) 4) (print "cm size"))
	 (if (/= (mus-length al) 12) (print "al size"))
	 (if (> (abs (- (mus-feedback al) .5)) .00001) (clm-print "al fbck: ~F " (mus-feedback al)))
	 (if (> (abs (- (mus-feedforward al) .5)) .00001) (clm-print "al ffwd: ~F " (mus-feedforward al)))
	 (outa i (* .01 (+ (delay dl val) (comb cm val) (all-pass al val) (notch nt val) (delay zl val) (one-pole pl val)
			   (one-zero ozl val) (two-pole tpl val) (two-zero tzl val) (two-pole ppl val) (two-zero zpl val)
			   (aref (mus-data dl) 0) (- (aref (mus-data zl) 0))))))))))


(definstrument s15 (beg dur)
  (let* ((os (make-oscil 440.0))
	 (en (make-env :envelope '(0 0 50 1 100 0) :length 5001 :scaler .1))
	 (j 0))
    (run
     (loop for i from beg to (+ beg dur) do 
       (let ((val (* (env en) (oscil os))))
	 (incf j)
	 (when (> j 5000)
	   (setf j 0)
	   (mus-reset en))
	 (outa i val))))))

(definstrument f17 (beg dur amp &key (x-coeffs '(.5 .2 .1)) (y-coeffs nil))
  (let* ((st (floor (* beg *srate*)))
	 (noi (make-rand :frequency (* .5 *srate*) :amplitude amp))
	 (flA (make-filter :x-coeffs x-coeffs :y-coeffs y-coeffs))
	 (flB (make-filter :x-coeffs x-coeffs :y-coeffs y-coeffs))
	 (nd (+ st (floor (* *srate* dur)))))
    (run
     (loop for i from st to nd do
       (outa i (+ (filter flA (rand noi))
		  (filter flB (rand noi))))))))

(definstrument f18 (beg dur)
  (let ((o1 (make-oscil 440.0)) (o2 (make-oscil 440.0)) (o3 nil))
    (run
     (loop for i from beg to (+ beg dur) do
       (declare (type :mus-any o1 o2 o3))
       (if (and o1 o2)
	   (outa i (+ (* .1 (oscil o1) (oscil o2))
		      (if (and o2 o3) (* .5 (oscil o3)) 0.0))))))))

#|
;;; tests of some of the documentation
(defun gadcompand ()
  (let ((compander (make-array 256)))
    (loop for i from 0 to 255 do (setf (aref compander i) (float (/ i 255))))
    (loop for i from 0 to 100 collect
      (let ((in-val (- (float (/ i 50)) 1.0))
	    (func-len (length compander)))  ; size of array
	(* (signum in-val) (array-interp compander (abs (* in-val (1- func-len))) func-len))))))

(defmacro gaussian-noise (r)
  ;; r=a rand generator allocated via make-rand
  `(let ((val 0.0))
     (dotimes (i 12) (incf val (rand ,r)))
     val))

(definstrument gadgauss (freq)
  ;; make a histogram of gaussian noise output
  (let ((r (make-rand :frequency freq))
	(a (make-double-array 2001))
	(first t)
	(j 0))
    (run 
     (loop for i from 0 to 2000 do
       (when first
	 (setf first nil)
	 (dotimes (k 100000)
	   (let ((val (round (* 2000 (min 1.0 (abs (* .05 (gaussian-noise r))))))))
	     (incf (aref a val) .001))))
       (outa i (aref a j))
       (incf j)))))

(defun make-1f-noise (n)
  ;; returns an array of rand's ready for the 1f-noise generator
  (let ((rans (make-array n)))
    (dotimes (i n) (setf (aref rans i) (make-rand :frequency (/ *srate* (expt 2 i)))))
    rans))

(defmacro 1f-noise (rans)
  `(let ((val 0.0)
         (len (length ,rans)))
     (dotimes (i len) (incf val (rand (aref ,rans i))))
     (/ val len)))

(definstrument gad1f (freq)
  (let ((rns (make-1f-noise 16)))
    (run
     (loop for i from 0 to 3000 do
       (outa i (1f-noise rns))))))
|#

(def-clm-struct asdf x)
(definstrument asdf-arr-inst ()
  (let* ((asdf-arr (make-array 2 :element-type 'asdf :initial-contents (list (make-asdf :x .1) (make-asdf :x .2)))))
    (run
     (loop for i from 0 to 1 do
       (if (> (abs (- (+ (asdf-x (aref asdf-arr 0)) (asdf-x (aref asdf-arr 1))) .3)) .001) (error "oops asdf"))
       (outa i (+ (asdf-x (aref asdf-arr 0)) (asdf-x (aref asdf-arr 1))))))))

(def-clm-struct test-cds a (b 0.0) (c 'integer) (d 'single-float))

(definstrument f19 (beg dur)
  (let* ((f3 (open-input "pistol.snd"))
	 (rd (make-readin f3 :direction -1 :start (sound-frames "pistol.snd"))))
    (run
     (loop for i from beg to (+ beg dur) do
       (outa i (* .2 (contrast-enhancement (readin rd) 2.0)))))))


(definstrument hi0 (beg dur)
  (let ((o (make-oscil 660)))
    (run 
     (let ((j beg)) 
       (dotimes (i dur) 
	 (outa (+ i j) (* .1 (oscil o))))))))

(definstrument ho0 (beg dur)
  (let ((o (make-oscil 440))
	(j 3))
    (run 
     (loop for i from beg to (+ beg dur) do
	(outa (+ i j) (* .1 (oscil o)))))))

#-clisp
(definstrument ha0 (beg dur)
  (let ((o (make-oscil 660)))
    (run 
     (let ((j beg)) 
       (loop for i from 0 below dur do
	 (outa (+ i j) (* .1 (oscil o))))))))

(definstrument ha1 (beg dur)
  (let ((os (make-oscil 440)))
    (run
     (dotimes (k (floor (* dur *srate*)))
       (outa (+ k (floor (* beg *srate*))) (* .25 (oscil os)))))))

(definstrument stick (beg attack-time decay-time stickiness)
  (let* ((start (floor (* *srate* beg)))
	 (e (make-env :envelope '(0 0 1 1 2 1 3 0) :duration (+ attack-time decay-time)))
	 ;; this envelope represents only the constant portion independent of the stuck portion
	 (attack (floor (* attack-time *srate*)))
	 (decay (floor (* decay-time *srate*)))
	 (val 0.0)
	 (stuck t)
	 (i start))
    (run
     (tagbody
       loop-start
       (if (> attack 0)
	   (progn
	     (setf val (env e))
	     (decf attack))
	 (if stuck
	     (setf stuck (> (random stickiness) .5))
	   (progn
	     (setf val (env e))
	     (decf decay)
	     (if (= decay 0) (go loop-end)))))
       (outa i val)
       (incf i)
       (go loop-start)
       loop-end))))

;;; same thing but use loop with no end point
;;; It might be easier to understand if we used two envelopes (one for attack, one for decay)
;;; ("stick" terminology comes from the musicKit)

#-clisp
(definstrument stick1 (beg attack-time decay-time stickiness)
  (let* ((start (floor (* *srate* beg)))
	 (e (make-env :envelope '(0 0 1 1 2 1 3 0) :duration (+ attack-time decay-time)))
	 ;; this envelope represents only the constant portion independent of the stuck portion
	 (attack (floor (* attack-time *srate*)))
	 (decay (floor (* decay-time *srate*)))
	 (val 0.0)
	 (stuck t))
    (run
     (loop for i from start do
       (if (> attack 0)
	   (progn
	     (setf val (env e))
	     (decf attack))
	 (if stuck
	     (setf stuck (> (random stickiness) .5))
	   (progn
	     (setf val (env e))
	     (decf decay)
	     (if (= decay 0) (loop-finish)))))
       (outa i val)))))

#-clisp
(definstrument envr (beg dur resetp resete)
  (let ((e (make-env '(0 0 1 .95 2 0 3 .5 4 0) :duration dur))
	(start (floor (* *srate* beg)))
	(samples (floor (* dur *srate*)))
	(ctr 0))
    (run
     (loop for i from start do
       (outa i (env e))
       (when (>= (mus-location e) samples) (loop-finish))
       (incf ctr)   
       (when (= ctr resetp) 
	 (clm-print "position: ~A" (mus-location e))
	 (setf (mus-location e) resete))))))

#-clisp
(definstrument s2b (beg dur)
  (let ((o1 (make-oscil 440.0))
	(k 0)
	(o2 (make-oscil :frequency 1200)))
    (run
     (loop for i from beg to (+ beg dur) do
       (setf k (loop for j from 0 to 4 sum j))
       (let ((kk k))
	 (case kk
	   (0 (clm-print "0"))
	   (10 (clm-print "10!"))
	   (otherwise (clm-print "~D?" k))))
       (if (= i beg) (setf (mus-phase o1) 0.0))
       (if (= (- i beg) 5000) (setf (mus-frequency o2) 660.0))
       (outa i (* .1 (+ (oscil o1) (oscil o2))))))))

(definstrument echo (beg dur scaler secs file)
  (let ((del (make-delay (round (* secs *srate*))))
	(inf (open-input file))
	(j 0))
    (run
     (loop for i from beg below (+ beg dur) do
       (let ((inval (ina j inf)))
	 (outa i (+ inval (delay del (* scaler (+ (tap del) inval)))))
	 (incf j))))
    (close-input inf)))

;;; (with-sound () (echo 0 60000 .5 1.0 "pistol.snd"))

(definstrument ctst (samps)
  (let* ((data (make-double-array 8 :initial-contents '(1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))
	 (signal (make-double-array 8 :initial-contents '(0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0)))
	 (j 0))
    (run
     (loop for i from 0 to samps do
       (if (= i 0)
	   (convolution data signal 8))
       (outa i (* .5 (aref data j)))
       (incf j)
       (if (>= j 8) (setf j 0))))))

