;;;
;;;   ###########################################################
;;;   ### NYQUIST-- A Language for Composition and Synthesis. ###
;;;   ###                                                     ###
;;;   ### Copyright (c) 1994 by Roger B. Dannenberg           ###
;;;   ###########################################################
;;;

(prog ()
   (setq lppp -12.0) (setq lpp -9.0)  (setq lp -6.0)    (setq lmp -3.0)
   (setq lfff 12.0) (setq lff 9.0)  (setq lf 6.0)    (setq lmf 3.0)
   (setq dB0 1.00)  (setq dB1 1.122) (setq dB10 3.1623)

   (setq s 0.25) (setq sd 0.375) (setq st (/ 0.5 3.0))
   (setq i 0.5)  (setq id 0.75)  (setq it (* st 2.0))
   (setq q 1.0)  (setq qd 1.5)   (setq qt (* st 4.0))
   (setq h 2.0)  (setq hd 3.0)   (setq ht (* st 8.0))
   (setq w 4.0)  (setq wd 6.0)   (setq wt (* st 16.0))
)

(if (not (boundp '*A4-Hertz*))
    (setf *A4-Hertz* 440.0))

; next pitch, for initializations below
; 
(defun np () (incf nyq:next-pitch))

(defun set-pitch-names ()
   (setq no-pitch 116.0)
   ; note: 58.0 is A4 - (C0 - 1) = 69 - (12 - 1)
   (setf nyq:next-pitch (- (hz-to-step *A4-Hertz*) 58.0))

   (setf nyq:pitch-names
    '(c0 (cs0 df0) d0 (ds0 ef0) e0 f0 (fs0 gf0) g0 (gs0 af0) a0
      (as0 bf0) b0
      c1 (cs1 df1) d1 (ds1 ef1) e1 f1 (fs1 gf1) g1 (gs1 af1) a1
      (as1 bf1) b1
      c2 (cs2 df2) d2 (ds2 ef2) e2 f2 (fs2 gf2) g2 (gs2 af2) a2
      (as2 bf2) b2
      c3 (cs3 df3) d3 (ds3 ef3) e3 f3 (fs3 gf3) g3 (gs3 af3) a3
      (as3 bf3) b3
      c4 (cs4 df4) d4 (ds4 ef4) e4 f4 (fs4 gf4) g4 (gs4 af4) a4
      (as4 bf4) b4
      c5 (cs5 df5) d5 (ds5 ef5) e5 f5 (fs5 gf5) g5 (gs5 af5) a5
      (as5 bf5) b5
      c6 (cs6 df6) d6 (ds6 ef6) e6 f6 (fs6 gf6) g6 (gs6 af6) a6
      (as6 bf6) b6
      c7 (cs7 df7) d7 (ds7 ef7) e7 f7 (fs7 gf7) g7 (gs7 af7) a7
      (as7 bf7) b7))

   (dolist (p nyq:pitch-names)
     (cond ((atom p) (set p (np)))
	   (t (let ((pitch (np)))
		(dolist (s p) (set s pitch)))))))


(set-pitch-names)

(if (not (boundp '*DEFAULT-SOUND-SRATE*))
  (setf *DEFAULT-SOUND-SRATE* 44100.0))
(if (not (boundp '*DEFAULT-CONTROL-SRATE*))
  (setf *DEFAULT-CONTROL-SRATE* 2205.0))

(setf *environment-variables*
      '(*WARP* *SUSTAIN* *START* *LOUD* *TRANSPOSE* 
        *STOP* *CONTROL-SRATE* *SOUND-SRATE*))

(setfn environment-time car)
(setfn environment-stretch cadr)

; ENVIRONMENT-MAP - map virtual time using an environment
;
;(defun environment-map (env tim)
;  (+ (environment-time env)
;     (* (environment-stretch env) tim)))


(defun nyq:the-environment () (mapcar 'eval *environment-variables*))


;; GLOBAL ENVIRONMENT VARIABLES and their startup values:
(defun nyq:environment-init ()
  (setq *WARP*		'(0.0 1.0 nil))
  (setq *LOUD*	0.0)   ; now in dB
  (setq *TRANSPOSE*	0.0)
  (setq *SUSTAIN*	        1.0)
  (setq *START*       MIN-START-TIME)
  (setq *STOP*        MAX-STOP-TIME)
  (setq *CONTROL-SRATE*  *DEFAULT-CONTROL-SRATE*)
  (setq *SOUND-SRATE* *DEFAULT-SOUND-SRATE*)
  t)				; return nothing in particular

(nyq:environment-init)

(defun get-duration (dur)
  (* (get-sustain) (- (local-to-global dur) (local-to-global 0))))

(defun get-loud ()
  (cond ((numberp *loud*) *loud*)
        ((soundp *loud*)
         (sref *loud* (local-to-global 0)))
        (t
         (error (format t "*LOUD* should be a number or sound: ~A" *LOUD*)))))


(defun get-sustain ()
  (cond ((numberp *SUSTAIN*) *SUSTAIN*)
	((soundp *SUSTAIN*)
         ;(display "get-sustain: lookup " (local-to-global 0)(sref *SUSTAIN*
         ;    (local-to-global 0)))
	 (sref *SUSTAIN* (local-to-global 0)))
	(t
	 (error (format t "*SUSTAIN* should be a number or sound: ~A" *SUSTAIN*)))))


(defun get-tempo ()
  (slope (snd-inverse (get-warp) (local-to-global 0)
		      *control-srate*)))

(defun get-transpose ()
  (cond ((numberp *TRANSPOSE*) *TRANSPOSE*)
	((soundp *TRANSPOSE*)
         ; (display "get-transpose: lookup " (local-to-global 0))
         ; (format t "samples: ~A~%" (snd-samples *TRANSPOSE* 100))
	 (sref *TRANSPOSE* (local-to-global 0)))
	(t
	 (error (format t "*TRANSPOSE* should be a number or sound: ~A" *TRANSPOSE*)))))


(defun get-warp ()
  (let ((f (warp-function *WARP*)))
    (cond ((null f) (error "Null warp function"))
        (t
         (shift-time (scale-srate f (/ (warp-stretch *WARP*)))
                     (- (warp-time *WARP*)))))))


;;;;;;;;;;;;;;;;;;;;;;
;; OSCILATORS
;;;;;;;;;;;;;;;;;;;;;;

(defun build-harmonic (n table-size) (snd-sine 0 n table-size 1))

(setf *SINE-TABLE* (list (build-harmonic 1 2048)
			 (hz-to-step 1.0)
			 T))
(setf *TABLE* *SINE-TABLE*)


;; AMOSC
;;
(defun amosc (pitch modulation &optional (sound *table*) (phase 0.0))
  (let ((modulation-srate (snd-srate modulation)))
    (cond ((> *SOUND-SRATE* modulation-srate)
	   (setf modulation (snd-up *SOUND-SRATE* modulation)))
	  ((< *SOUND-SRATE* modulation-srate)
	   (format t "Warning: down-sampling AM modulation in amosc~%")
	   (setf modulation (snd-down *SOUND-SRATE* modulation))))
    (scale-db (get-loud)
      (snd-amosc
	(car sound)	; samples for table
	(cadr sound)	; step represented by table
	*SOUND-SRATE*	; output sample rate
	(step-to-hz (+ pitch (get-transpose))) ;  output hz
	(local-to-global 0)	; starting time
	modulation	; modulation
	phase))))	; phase


;; FMOSC
;;
;; modulation rate must be less than or equal to sound-srate, so
;; force resampling and issue a warning if necessary. snd-fmosc can
;; handle upsampling cases internally.
;;
(defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0))
  (let ((modulation-srate (snd-srate modulation)))
    (cond ((< *SOUND-SRATE* modulation-srate)
	   (format t "Warning: down-sampling FM modulation in fmosc~%")
	   (setf modulation (snd-down *SOUND-SRATE* modulation))))
    (scale-db (get-loud)
      (snd-fmosc 
	(car sound)		; samples for table
	(cadr sound)		; step represented by table
	*SOUND-SRATE*		; output sample rate
	(step-to-hz (+ pitch (get-transpose))) ;  output hz
	(local-to-global 0)	; starting time
	modulation		; modulation
	phase))))		; phase


;; LFO -- freq &optional duration sound phase)
;;
;; Default duration is 1.0 sec, default sound is *TABLE*, 
;; default phase is 0.0.
;;
(defun lfo (freq &optional (duration 1.0)
		 (sound *TABLE*) (phase 0.0))
  (let ((start (local-to-global 0))
	(stop (local-to-global duration)))
    (if (> start stop) (setf stop start))
    (snd-osc
	(car sound)		; samples for table
	(cadr sound)		; step represented by table
	*CONTROL-SRATE*		; output sample rate
	freq			; output hz
	start			; starting time
	(- stop start)		; duration
	phase)))		; phase


;; OSC - table lookup oscillator
;;
(defun osc (pitch &optional (duration 1.0) 
		  (sound *TABLE*) (phase 0.0))
  (let ((global-start (local-to-global 0))
	(global-stop (local-to-global duration))
        actual-dur)
    (setf actual-dur (* (- global-stop global-start)
                        (get-sustain)))
    ;(display "osc" *warp* global-start global-stop actual-dur  
    ;         (get-transpose))
    (set-logical-stop
     (scale-db (get-loud)
               (snd-osc 
                (car sound)		; samples for table
                (cadr sound)		; step represented by table
                *SOUND-SRATE*		; output sample rate
                (step-to-hz (+ pitch (get-transpose))) ; output hz
                global-start            ; starting time
                actual-dur	        ; duration
                phase))                 ; phase
     duration)))


;; PARTIAL -- sine osc with built-in envelope scaling
;;
(defun partial (steps env)
  (snd-partial *sound-srate*
            (step-to-hz (+ steps (get-transpose))) 
	    (local-to-global 0)
	    env))


;; SAMPLER -- simple attack + sustain sampler
;;
(defun sampler (pitch modulation 
                &optional (sample *table*) (npoints 2))
  (let ((samp (car sample))
        (samp-pitch (cadr sample))
        (samp-loop-start (caddr sample)))
    ; make a waveform table look like a sample with no attack:
    (cond ((not (numberp samp-loop-start))
           (setf samp-loop-start 0.0)))
    (scale-db (get-loud)
       (snd-sampler 
	samp		; samples for table
	samp-pitch		; step represented by table
        samp-loop-start         ; time to start loop
	*SOUND-SRATE*		; output sample rate
	(step-to-hz (+ pitch (get-transpose))) ;  output hz
	(local-to-global 0)	; starting time
	modulation		; modulation
	npoints))))		; number of interpolation points


;; SINE -- simple sine oscillator
;;
(defun sine (steps &optional (duration 1.0))
  (snd-sine (local-to-global 0)
            (step-to-hz (+ steps *transpose*)) 
            *sound-srate*
	    (local-to-global duration)))


;; abs-env -- restore the standard environment
;;
(defmacro abs-env (s)
  `(progv '(*WARP* *LOUD* *TRANSPOSE* *SUSTAIN* 
            *START* *STOP* *CONTROL-SRATE* *SOUND-SRATE*)
          (list '(0.0 1.0 NIL) 0.0 0.0 1.0
            -1e+9 1e+9 *DEFAULT-CONTROL-SRATE* *DEFAULT-SOUND-SRATE*)
          ,s))


; nyq:add2 - add two arguments
; 
(defun nyq:add2 (s1 s2)
    (cond ((and (arrayp s1) (not (arrayp s2)))
	   (setf s2 (vector s2)))
	  ((and (arrayp s2) (not (arrayp s1)))
	   (setf s1 (vector s1))))
    (cond ((arrayp s1)
	   (sum-of-arrays s1 s2))
	  (t
	   (nyq:add-2-sounds s1 s2))))


; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound (or number) arguments
; 
(defun nyq:add-2-sounds (s1 s2)
  (cond ((numberp s1)
         (cond ((numberp s2)
                (+ s1 s2))
               (t
                (snd-offset s2 s1))))
        ((numberp s2)
         (snd-offset s1 s2))
        (t
         (let ((s1sr (snd-srate s1))
               (s2sr (snd-srate s2)))
;    (display "nyq:add-2-sounds" s1sr s2sr)
           (cond ((> s1sr s2sr)
                  (snd-add s1 (snd-up s1sr s2)))
                 ((< s1sr s2sr)
                  (snd-add (snd-up s2sr s1) s2))
                 (t
                  (snd-add s1 s2)))))))




(defmacro at (x s)
 `(progv '(*WARP*) (list (list (+ (warp-time *WARP*) 
				  (* (warp-stretch *WARP*) ,x))
			       (warp-stretch *WARP*)
			       (warp-function *WARP*)))
      ,s))


;; (AT-ABS t behavior) evaluate behavior at global time t
;;
;; *WARP* is the triple (d s f) denoting the function f(st+d),
;; a mapping from local to global time.
;; We want (d' s f) such that f(s*0 + d') = t
;; (Note that we keep the same s and f, and only change the offset.
;; To eliminate the warp and stretch use "(abs-env (at t behavior))")
;; Applying the inverse of f, d' = f-1(t), or (sref (snd-inverse f ...) t)
;; Rather than invert the entire function just to evaluate at one point,
;; we use SREF-INVERSE to find d'.
;;
(defmacro at-abs (x s)
 `(progv '(*WARP*)
         (if (warp-function *WARP*)
		       (list (list (sref-inverse (warp-function *WARP*) ,x)
			       (warp-stretch *WARP*)
			       (warp-function *WARP*)))
		       (list (list ,x (warp-stretch *WARP*) NIL)))
         ,s))



;; (NYQ:COERCE-TO S1 S2) - expand sound s1 to type of s2
; 
(defun nyq:coerce-to (s1 s2)
  (cond ((soundp s1)
	 (cond ((arrayp s2)
		(nyq:sound-to-array s1 (length s2)))
	       (t s1)))
	(t s1)))


(defmacro continuous-control-warp (beh)
  `(snd-compose (warp-abs nil ,beh)
		(snd-inverse (get-warp)
		 (local-to-global 0) *control-srate*)))

(defmacro continuous-sound-warp (beh)
  `(snd-compose (warp-abs nil ,beh)
		(snd-inverse (get-warp)
		 (local-to-global 0) *sound-srate*)))


(defmacro control-srate-abs (r s)
  `(progv '(*CONTROL-SRATE*) (list ,r)
      ,s))

; db = 20log(ratio)
; db = 20 ln(ratio)/ln(10)
; db/20 = ln(ratio)/ln(10)
; db ln(10)/20 = ln(ratio)
; e^(db ln(10)/20) = ratio
;
(setf ln10over20 (/ (log 10.0) 20))

(defun db-to-linear (x) 
  (cond ((numberp x)
	 (exp (* ln10over20 x)))
	((arrayp x)
	 (let* ((len (length x))
	        (result (make-array len)))
	    (dotimes (i len)
		(setf (aref result i) 
		      (snd-exp (snd-scale ln10over20 (aref snd i)))))
	    result))
	(t
	 (snd-exp (snd-scale ln10over20 x)))))


(defun linear-to-db (x) 
  (cond ((numberp x)
	 (/ (log (float x)) ln10over20))
	((arrayp x)
	 (let* ((len (length x))
	        (result (make-array len)))
	    (dotimes (i len)
		(setf (aref result i) 
		      (snd-scale (/ 1.0 ln10over20) (snd-log (aref snd i)))))
	    result))
	(t
	 (snd-scale (/ 1.0 ln10over20) (snd-log x)))))


; extract - start is stretched and shifted as is stop
;  result is shifted to start at local time zero
(defun extract (start stop sound)
  (snd-xform sound (snd-srate sound) (local-to-global 0) 
             (local-to-global start) (local-to-global stop) 1.0))

(defun extract-abs (start stop sound)
  (snd-xform sound (snd-srate sound) 0 start stop 1.0))
         

;(defmacro extract (start stop sound)
;  `(let ($newsound)
;     (progv '(*START* *STOP*)
;            (list (local-to-global ,start)
;		  (local-to-global ,stop))
;            (setf $newsound ,sound)
;            (setf $newsound 
;                  (loud-abs 0 (cue (set-logical-stop-abs $newsound *STOP*)))))
;     $newsound))


;(defmacro extract-abs (start stop sound)
;  `(let ($newsound $newstart)
;     (progv '(*START* *STOP*)
;            (list ,start ,stop)
;	    (setf $newstart *START*)
;            (setf $newsound ,sound)            
;            (setf $newsound (set-logical-stop-abs $newsound *STOP*)))
;     (snd-xform $newsound (snd-srate $newsound) ,start ,stop 1.0)))


(defun local-to-global (local-time)
  (let ((d (warp-time *WARP*))
	(s (warp-stretch *WARP*))
	(w (warp-function *WARP*))
	global-time)
    (setf global-time (+ (* s local-time) d))
    (if w (sref w global-time) global-time)))


(defmacro loud (x s)
 `(progv '(*LOUD*) (list (sum *LOUD* ,x))
         ,s))


(defmacro loud-abs (x s)
 `(progv '(*LOUD*) (list ,x)
         ,s))

(defun must-be-sound (x)
 (cond ((soundp x) x)
       (t
	(error "SOUND type expected" x))))

;; SCALE-DB -- same as scale, but argument is in db
;;
(defun scale-db (factor sound)
  (scale (db-to-linear factor) sound))

(defun set-control-srate (rate)
  (setf *default-control-srate* (float rate))
  (nyq:environment-init))

(defun set-sound-srate (rate) 
  (setf *default-sound-srate* (float rate))
  (nyq:environment-init))


; s-plot -- compute and write n data points for plotting
; 
(defun s-plot (snd &optional (n 1000))
  (prog ((points (snd-samples snd (1+ n)))
	 (filename (soundfilename *default-plot-file*))
	 outf
	 (period (/ 1.0 (snd-srate snd)))
         len 
         (maximum 1.0))
    (setf outf (open filename :direction :output))
    (cond ((null outf)
	   (format t "s-plot: could not open ~A!~%" filename)
	   (return nil)))
    (format t "s-plot: writing ~A ... ~%" filename)
    (setf len (length points))
    (cond ((> len n)
           (setf len n)
	   (format t "WARNING: SOUND TRUNCATED TO ~A POINTS~%" len)))
    (dotimes (i len)
      (cond ((< (abs maximum) (abs (aref points i)))
             (setf maximum (aref points i))))
      (format outf "~A ~A~%" (* i period) (aref points i)))
    (close outf)
    (cond ((> (abs maximum) 1.0)
           (format t "WARNING: MAXIMUM AMPLITUDE IS ~A~%" maximum)))
    (format t "~A points from ~A to ~A~%"
	 len (snd-t0 snd) (+ (snd-t0 snd) (* len period)))))

; run something like this to plot the points:
; graph < points.dat | plot -Ttek


(defmacro sound-srate-abs (r s)
  `(progv '(*SOUND-SRATE*) (list ,r)
      ,s))


(defmacro stretch (x s)
 `(progv '(*WARP*) (list (list (warp-time *WARP*) 
			       (* (warp-stretch *WARP*) ,x)
			       (warp-function *WARP*)))
			 ,s))


(defmacro stretch-abs (x s)
 `(progv '(*WARP*) (list (list (local-to-global 0)
			       ,x
			       nil))
			 ,s))


(defmacro sustain (x s)
 `(progv '(*SUSTAIN*) (list (prod *SUSTAIN* ,x))
      ,s))


(defmacro sustain-abs (x s)
 `(progv '(*SUSTAIN*) (list ,x)
      ,s))


;; (WARP-FUNCTION *WARP*) - extracts function field of warp triple
;;
(setfn warp-function caddr)


;; (WARP-STRETCH *WARP*) - extracts stretch field of warp triple
;;
(setfn warp-stretch cadr)


;; (WARP-TIME *WARP*) - extracts time field of warp triple
;;
(setfn warp-time car)


(defmacro transpose (x s)
 `(progv '(*TRANSPOSE*) (list (sum *TRANSPOSE* ,x))
      ,s))


(defmacro transpose-abs (x s)
 `(progv '(*TRANSPOSE*) (list ,x)
      ,s))


;; COMPUTE-DEFAULT-SOUND-FILE -- construct and set *default-sound-file*
;;
;; (this is harder than it might seem because the default place for
;;  sound files is in /tmp, which is shared by users, so we'd like to
;;  use a user-specific name to avoid collisions)
;;
;; Assumes that this is a Unix system.
;;
(defun compute-default-sound-file () 
  (let (inf user)
    (system "echo $USER > ny_username.tmp")
    (setf inf (open "ny_username.tmp"))
    (setf user (read inf))
    (close inf)
    (system "rm ny_username.tmp")
    (cond ((null user)           
           (format t 
"Please type your user-id so that I can construct a default 
sound-file name.  To avoid this message in the future, add
this to your .login file:
        setenv USER <your id here>
or add this to your init.lsp file:
        (setf *default-sound-file* \"<your filename here>\")
        (setf *default-sf-dir* \"<full pathname of desired directory here>\")

Your id please: ")
           (setf user (read))))
    (setf *default-sound-file* 
          (format nil "~A-temp.snd" (string-downcase (symbol-name user)))))
    (format t "Default sound file is ~A.~%" *default-sound-file*))


;; CONTROL-WARP -- apply a warp function to a control function
;; 
(defun control-warp (warp-fn control)
  (snd-compose control
        (snd-inverse warp-fn (local-to-global 0) *control-srate*)))


;; (cue sound)
;;    Cues the given sound; that is, it applies the current *WARP*, *LOUD*,
;; *START*, and *STOP* values to the argument.  The logical start time is at
;; local time 0.
(defun cue (sound)
  (snd-xform sound
             (snd-srate sound)
             (local-to-global 0) *START* *STOP* (db-to-linear (get-loud))))
; (s-plot (progv '(*TIME* *START*)'(0.0 0.5)(cue (snd-sine 20 1 100 1)))1000)
;(s-plot(progv'(*TIME* *START*)'(0.0 0.5)(cue(cue (snd-sine 20 1 100 1))))1000)

;; (sound sound)
;;    Same as (cue sound), except also warps the sound.
;; Note that the *WARP* can change the pitch of the
;; sound as a result of resampling.
;; Here's the derivation for the warping code:
;; *WARP* is a triple: (d s f) which denotes that the warp from local to
;; global time is: f(st+d)
;; We need to compose sound with the inverse of this to get a function
;; of global time
;; Let f-1 be the inverse of f.  Then the inverse of f(st+d) is 
;; (f-1(t) - d)/s
;; The composition gives us: (snd-compose sound (f-1(t) - d)/s)
;; Eliminate the 1/s term by changing the sample rate of sound:
;;  = (snd-compose (snd-scale-srate sound s) (f-1(t) - d))
;; Eliminate the -d term by shifting f before taking the inverse:
;;  = (snd-compose (scale-srate sound s) ((inverse f) - d))
;;  = (snd-compose (scale-srate sound s) (inverse f(t + d)))
;;  = (snd-compose (scale-srate sound s) (inverse (shift f -d)))
;; snd-inverse takes a time and sample rate.  For time, use zero.
;; The sample rate of inverse determines the final sample rate of
;; this function, so use *SOUND-SRATE*:
;;  = (snd-compose (scale-srate sound s) (snd-inverse (shift-time f (- d))
;;                                              0 *SOUND-SRATE*))
;;
(defun sound (sound)
   (cond ((null (warp-function *WARP*))
	  (snd-xform sound (/ (snd-srate sound) (warp-stretch *WARP*))
		     (local-to-global 0)
		     *START* *STOP* (db-to-linear (get-loud))))
	 (t
	  (snd-compose (scale-srate sound (warp-stretch *WARP*))
		       (snd-inverse (shift-time (warp-function *WARP*)
						(- (warp-time *WARP*)))
				    0 *SOUND-SRATE*)))))


;; (SCALE-SRATE SOUND SCALE)
;; multiplies the sample rate by scale
(defun scale-srate (sound scale)
  (let ((new-srate (* scale (snd-srate sound))))
    (snd-xform sound new-srate (snd-time sound) 
	       MIN-START-TIME MAX-STOP-TIME 1.0)))


;; (SHIFT-TIME SOUND SHIFT)
;; shift the time of a function by SHIFT, i.e. if SOUND is f(t),
;; then (shift-time SOUND SHIFT) is f(t - SHIFT).  Note that if
;; you look at plots, the shifted sound will move *right* when SHIFT
;; is positive.  
(defun shift-time (sound shift)
  (snd-xform sound (snd-srate sound) (+ (snd-t0 sound) shift)
	     MIN-START-TIME MAX-STOP-TIME 1.0))


;; (NYQ:SOUND-TO-ARRAY SOUND N) - duplicate SOUND to N channels
;;
(defun nyq:sound-to-array (sound n)
  (let ((result (make-array n)))
    (dotimes (i n)
      (setf (aref result i) sound))
    result))


;; (control sound)
;;    Same as (sound sound), except this is used for control signals.  
;;    This code is identical to sound.
(setfn control sound)


;; (cue-file string)
;;    Loads a sound file with the given name, returning a sound which is
;; transformed to the current environment.
;(defun cue-file (name)
;   (cue (snd-load  name *SOUND-SRATE*)))


;; (env t1 t2 t4 l1 l2 l3 &optional duration)
;; Creates a 4-phase envelope.
;;	tN is the duration of phase N, and lN is the final level of
;;	phase N.  t3 is implied by the duration, and l4 is 0.0.
;;	If dur is not supplied, then 1.0 is assumed.  The envelope
;;	duration is the product of dur, *STRETCH*, and *SUSTAIN*.  If 
;;	t1 + t2 + 2ms + t4 > duration, then a two-phase envelope is
;;	substituted that has an attack/release time ratio = t1/t4.
;;	The sample rate of the returned sound is *CONTROL-SRATE*.
;;
;; Time transformation: the envelope is not warped; the start time and
;; stop times are warped to global time.  Then the value of *SUSTAIN* at
;; the begining of the envelope is used to determing absolute duration.
;; Since PWL is ultimately called to create the envelope, we must use
;; ABS-ENV to prevent any further transforms inside PWL.  We use
;; (AT global-start ...) inside ABS-ENV so that the final result has 
;; the proper starting time.
;;
(defun env (t1 t2 t4 l1 l2 l3 &optional (duration 1.0))
  (let (actual-dur min-dur ratio t3 
	(global-start (local-to-global 0))
	(global-stop (local-to-global duration)))
    (setf actual-dur (* (- global-stop global-start)
			(get-sustain)))
    (setf min-dur (+ t1 t2 t4 0.002))
    (cond ((< actual-dur min-dur)
	   (setf ratio (/ t1 (+ t1 t4)))
	   (setf t1 (* ratio actual-dur))
	   (setf t2 (- actual-dur t1))
	   (setf t3 0.0)
	   (setf t4 0.0)
	   (setf l2 0.0)
	   (setf l3 0.0))
	  (t
	   (setf t3 (- actual-dur t1 t2 t4))))
    (set-logical-stop
     (abs-env (at global-start
                  (pwl t1 l1 (+ t1 t2) l2 (- actual-dur t4) l3 actual-dur)))
     duration)))


;; (osc-note step &optional duration env sust volume sound)
;;   Creates a note using table-lookup osc, but with an envelope.
;; The ENV parameter may be a parameter list for the env function,
;; or it may be a sound.
;;
(defun osc-note (pitch &optional (duration 1.0) 
		       (env-spec '(0.02 0.1 0.3 1.0 .8 .7))
		       (volume 0.0)
		       (table *TABLE*))
  (set-logical-stop
   (mult (loud volume (osc pitch duration table))
         (if (listp env-spec)
           (apply 'env env-spec)
           env-spec))
   duration))


;; force-srate -- resample snd if necessary to get sample rate
;
(defun force-srate (sr snd)
  (cond ((not (numberp sr))
	 (error "force-srate: SR should be a number")))
  (cond ((arrayp snd)
	 (let* ((len (length snd))
	        (result (make-array len)))
           (dotimes (i len)
                    (setf (aref result i) 
                          (force-srate sr (aref snd i))))
           result))
        (t
         (let ((snd-sr (snd-srate snd)))
           (cond ((> sr snd-sr) (snd-up sr snd))
                 ((< sr snd-sr) (snd-down sr snd))
                 (t snd))))))


(defun force-srates (srs snd)
  (cond ((and (numberp srs) (soundp snd))
         (force-srate srs snd))
	((and (arrayp srs) (arrayp snd))
	 (let* ((len (length snd))
	        (result (make-array len)))
           (dotimes (i len)
                    (setf (aref result i) 
                          (force-srate (aref srs i) (aref snd i))))
           result))
        (t (error "arguments not compatible"))))


;; (breakpoints-convert (t1 x1 t2 x2 ... tn) t0)
;;   converts times to sample numbers and scales amplitudes
;;   t0 is the global (after warping) start time
;;
;; NOTE: there were some stack overflow problems with the original
;; recursive version (in comments now), so it was rewritten as an
;; iteration.
;;
(defun breakpoints-convert (list t0)
  (prog (sample-count result sust (last-count 0))
    (setf sust (get-sustain))
 loop
    (setf sample-count 
	  (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0)
                             *control-srate*))))
    ; now we have a new sample count to put into result list
    ; make sure result is non-decreasing
    (cond ((< sample-count last-count)
	   (setf sample-count last-count)))
    (setf last-count sample-count)
    (push sample-count result)
    (cond ((cdr list)
           (setf list (cdr list))
           (push (float (car list)) result)))
    (setf list (cdr list))
    (cond (list
           (go loop)))
    (return (reverse result))))

;(defun breakpoints-convert (list t0)
;  (prog (prev-sample-count last-amplitude-skipped sample-count result sust)
;    (setf prev-sample-count 0) ; sample number of last output
;    (setf sust (get-sustain))
; loop
;    (setf sample-count 
;	  (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0)
;                             *control-srate*))))
;    ; skip until we can advance at least one sample
;    (cond ((>= prev-sample-count sample-count)
;	   (setf last-amplitude-skipped (cadr list))
;           (setf list (cddr list))
;           (cond (list (go loop))
;                 ; oops, we pushed a value on the list, but the pwl function
;                 ; went to zero before the  next sample, put the zero at the
;		 ; next sample
;                 (t
;                  (setf sample-count (1+ sample-count))))))
;    ; now we have a new sample count to put into result list
;    ; first, see if we need to insert previously skipped breakpoint:
;    (cond ((and last-amplitude-skipped
;		(> sample-count (1+ prev-sample-count)))
;	   (push (1+ prev-sample-count) result)
;	   (push (* (db-to-linear *volume*) last-amplitude-skipped) result)
;	   (setf last-amplitude-skipped nil)))
; 
;    (setf prev-sample-count sample-count)
;    (push sample-count result)
;    (cond ((cdr list)
;           (setf list (cdr list))
;           (push (* (db-to-linear *volume*) (car list)) result)))
;    (setf list (cdr list))
;    (cond (list
;           (go loop)))
;    (return (reverse result))))
; 
;  (let ((sample-count 
;	 (truncate (+ 0.5 (* (- (local-to-global (* (car list) *sust*)) t0)
;                             *control-srate*)))))
;    (if (null (cdr list))
;	(cons sample-count 'nil)
;	(cons sample-count
;	      (cons (* (db-to-linear *volume*) (cadr list))
;		    (breakpoints-convert (cddr list) t0))))))
 
          
 
;; (pwl t1 l1 t2 l2 ... tn)
;;   Creates a piece-wise linear envelope from breakpoint data.
;;
(defun pwl (&rest breakpoints) (pwl-list breakpoints))

(defun pwlr (&rest breakpoints) (pwlr-list breakpoints))

;; (breakpoints-relative list)
;;  converts list, which has the form (value dur value dur value ...)
;;  into the form (value time value time value ...)
;;  the list may have an even or odd length
;;
(defun breakpoints-relative (breakpoints)
  (prog (result (sum 0.0))
 loop
     (cond (breakpoints
	    (push (car breakpoints) result)
	    (setf breakpoints (cdr breakpoints))
	    (cond (breakpoints
		   (setf sum (+ sum (car breakpoints)))
		   (push sum result)
		   (setf breakpoints (cdr breakpoints))
		   (go loop)))))
     (return (reverse result))))


(defun breakpoints-relative (breakpoints)
  (prog (result (sum 0.0))
 loop
    (setf sum (+ sum (car breakpoints)))
    (push sum result)
    (cond ((cdr breakpoints)
           (setf breakpoints (cdr breakpoints))
           (push (car breakpoints) result)))
    (setf breakpoints (cdr breakpoints))
    (cond (breakpoints
           (go loop)))
    (return (reverse result))))


(defun pwlr-list (breakpoints)
  (pwl-list (breakpoints-relative breakpoints)))

(defun pwl-list (breakpoints)
  (let ((t0 (local-to-global 0)))
    (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0))))

;; (pwlv l1 t1 l2 t2 ... ln)
;; Creates a piece-wise linear envelope from breakpoint data;
;; the function initial and final values are explicit
;;
(defun pwlv (&rest breakpoints)
  ;use pwl, modify breakpoints with initial and final changes
  ;need to put initial time of 0, and final time of 0
  (pwlv-list breakpoints))

(defun pwlv-list (breakpoints)
    (pwl-list (cons 0.0 (append breakpoints '(0.0)))))

(defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints))

(defun pwlvr-list (breakpoints)
  (pwlr-list (cons 0.0 (append breakpoints '(0.0)))))

(defun pwe (&rest breakpoints)
  (pwe-list breakpoints))

(defun pwe-list (breakpoints)
  (pwev-list (cons 1.0 (append breakpoints '(1.0)))))

(defun pwer (&rest breakpoints) (pwer-list breakpoints))

(defun pwer-list (breakpoints)
  (pwe-list (breakpoints-relative breakpoints)))

(defun pwev (&rest breakpoints)
  (pwev-list breakpoints))

(defun pwev-list (breakpoints)
  (let ((lis (breakpoints-log breakpoints)))
    (s-exp (pwl-list lis))))

(defun pwevr (&rest breakpoints) (pwevr-list breakpoints))

(defun pwevr-list (breakpoints)
  (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints)))))


(defun breakpoints-log (breakpoints)
  (prog ((result '(0.0)) val tim)
loop
    (cond (breakpoints
           (setf val (float (car breakpoints)))
           (setf breakpoints (cdr breakpoints))
           (cond (breakpoints
                  (setf tim (car breakpoints))
                  (setf breakpoints (cdr breakpoints))))
	   (setf result (cons tim (cons (log val) result)))
	   (cond ((null breakpoints)
		  (return (reverse result))))
	   (go loop))
          (t
           (error "Expected odd number of elements in breakpoint list")))))


;; SOUND-WARP -- apply warp function to a sound
;; 
(defun sound-warp (warp-fn signal)
  (snd-compose signal 
	(snd-inverse warp-fn (local-to-global 0) *sound-srate*))) 

(defun snd-extent (sound maxsamples) 
    (list (snd-t0 sound)
          (+ (snd-t0 sound) (/ (snd-length sound maxsamples)
                               (snd-srate sound)))))

;; (maketable sound)
;;   Creates a table for osc, lfo, etc. by assuming that the samples
;;   in sound represent one period.  The sound must start at time 0.

(defun maketable (sound)
  (list sound
	(hz-to-step 
	 (/ 1.0
	    (cadr (snd-extent sound 1000000))))
	T))


;(defmacro endTime (sound)
;   `(get-logical-stop ,sound))


;(defmacro beginTime (sound)
;   `(car (snd-extent ,sound)))


; simple stereo pan: as where goes from 0 to 1, sound
; is linearly panned from left to right
;
(defun pan (sound where)
  (vector (mult sound (sum 1 (mult -1 where)))
	  (mult sound where)))


(defun prod (&rest snds)
  (cond ((null snds)
	 (snd-zero (local-to-global 0) *sound-srate*))
	((null (cdr snds))
	 (car snds))
	((null (cddr snds))
	 (nyq:prod2 (car snds) (cadr snds)))
	(t
	 (nyq:prod2 (car snds) (apply #'prod (cdr snds))))))

(setfn mult prod)


;; (NYQ:PROD-OF-ARRAYS S1 S2) - form pairwise products
;
(defun nyq:prod-of-arrays (s1 s2)
  (let* ((n (length s1))
	 (p (make-array n)))
    (cond ((/= n (length s2))
	   (error "unequal number of channels in prod")))
    (dotimes (i n)
      (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i))))
    p))


; nyq:prod2 - multiply two arguments
; 
(defun nyq:prod2 (s1 s2)
  (setf s1 (nyq:coerce-to s1 s2))
  (setf s2 (nyq:coerce-to s2 s1))
  (cond ((arrayp s1)
	 (nyq:prod-of-arrays s1 s2))
	(t
	 (nyq:prod-2-sounds s1 s2))))


; (PROD-2-SOUNDS S1 S2) - multiply two sound arguments
; 
(defun nyq:prod-2-sounds (s1 s2)
  (cond ((numberp s1)
	 (cond ((numberp s2)
		(* s1 s2))
	       (t
		(scale s1 s2))))
	((numberp s2)
	 (scale s2 s1))
	(t
	 (let ((s1sr (snd-srate s1))
	       (s2sr (snd-srate s2)))
;    (display "nyq:prod-2-sounds" s1sr s2sr)
	    (cond ((> s1sr s2sr)
		   (snd-prod s1 (snd-up s1sr s2)))
		  ((< s1sr s2sr)
		   (snd-prod (snd-up s2sr s1) s2))
		  (t
		   (snd-prod s1 s2)))))))


;; RAMP -- linear ramp from 0 to x
;;
(defun ramp (&optional (x 1))
  (let* ((start (local-to-global 0))
	 (duration (- (local-to-global x) start)))
    (warp-abs nil 
	(at start
	    (sustain-abs 1
		(pwl duration 1 (+ duration (/ *control-srate*))))))))


(defun scale (amt snd)
  (cond ((arrayp snd)
	 (let* ((len (length snd))
	        (result (make-array len)))
	    (dotimes (i len)
		(setf (aref result i) (snd-scale amt (aref snd i))))
	    result))
	(t
	 (snd-scale amt snd))))


(setfn s-print-tree snd-print-tree)

;; s-read -- reads a file
(defun s-read (filename &key (time-offset 0) (srate *sound-srate*)
	(dur 10000.0) (nchans 1) (format *default-sf-format*)
	(mode *default-sf-mode*) (bits *default-sf-bits*))
  (snd-read (soundfilename filename) time-offset
            (local-to-global 0) format nchans mode bits srate
            dur))


;; SOUNDFILENAME -- add default directory to name to get filename
;;
(defun soundfilename (filename)
  (cond ((= 0 (length filename))
	 (break "filename must be at least one character long" filename))
	((or (eq (char filename 0) #\/)
             (eq (char filename 0) #\.)))
	(t
	 ; if sf-dir nonempty and does not end with "/", append one
	 (cond ((and (< 0 (length *default-sf-dir*))
		     (not (eq (char *default-sf-dir* 
				    (1- (length *default-sf-dir*)))
			      #\/)))
		(setf *default-sf-dir* (strcat *default-sf-dir* "/"))
		(format t "Warning: appending \"/\" to *default-sf-dir*~%")))
	 (setf filename (strcat *default-sf-dir* filename))))
  filename)


(defmacro s-max (expression maxlen)
   `(snd-max ',expression ,maxlen))


;; s-save -- saves a file
(setf NY:ALL 1000000000)	; 1GIG constant for maxlen
(defmacro s-save (expression maxlen filename &key (format '*default-sf-format*)
		(mode '*default-sf-mode*) (bits '*default-sf-bits*))
  `(let ((ny:fname (soundfilename ,filename)))
     (format t "Saving sound file to ~A~%" ny:fname)
     (snd-save ',expression ,maxlen ny:fname ,format ,mode ,bits)))

; sequence macros SEQ and SEQREP are now in seq.lsp:
; 
(load "seq" :verbose NIL)

;(defmacro with%environment (env &rest expr)
;  `(progv ',*environment-variables* ',env ,@expr))
; 
;(defmacro seq (&rest list)
;  (display "seq" list)
;  (cond ((null list)
;         (snd-zero *time* *sound-srate*))
;        ((null (cdr list))
;         (car list))
;	((null (cddr list))
;	 `(let* ((first%sound ,(car list))
;		 (s%rate (snd-srate first%sound)))
;	    (snd-seq first%sound
;	 	     #'(lambda (t0) 
;	                 (with%environment
;			   ,(the%environment) (setf *time* t0)     
;			   (force-srate s%rate ,(cadr list)))))))
;	(t
;	 `(let* ((first%sound ,(car list))
;		 (s%rate (snd-srate first%sound)))
;	    (snd-seq first%sound
;		     #'(lambda (t0)
;			 (format t "snd-seq applying lambda")
;			 (with%environment
;			   ,(the%environment) (setf *time* t0)     
;			   (seq (force-srate s%rate ,(cadr list))
;				,@(cddr list))))) ))))
; 
; 
;(defmacro seqrep (pair sound)
;  `(let ((,(car pair) 0)
;         ($loop-count (1- ,(cadr pair))))
;     (cond ((< 0 $loop-count)
;            (seqrep2 ,(car pair) ,sound))
;           ((= 0 $loop-count)
;            ,sound)
;           (t
;            (snd-zero *time* *sound-srate*)))))
; 
; 
;(defmacro seqrep2 (var sound)
;  `(cond ((< ,var $loop-count)
;          (seq (prog1 ,sound (setf ,var (1+ ,var)))
;               (seqrep2 ,var ,sound)))
;         ((= ,var $loop-count)
;          ,sound)))


; set-logical-stop - modify the sound and return it, time is shifted and
;			 stretched
(defun set-logical-stop (snd tim)
  ; (display "set-logical-stop" *warp* tim (local-to-global tim))
  (multichan-expand #'set-logical-stop-abs snd (local-to-global tim)))

; set-logical-stop-abs - modify the sound and return it
; 
(defun set-logical-stop-abs (snd tim) (snd-set-logical-stop snd tim) snd)


(defmacro simrep (pair sound)
  `(let (_snds)
     (dotimes ,pair (push ,sound _snds))
     (sim-list _snds)))

(defun sim (&rest snds)
  (sim-list snds))

(setfn sum sim)

(defun sim-list (snds)
  (cond ((null snds)
         (snd-zero (local-to-global 0) *sound-srate*))
        ((null (cdr snds))
         (car snds))
        ((null (cddr snds))
         (nyq:add2 (car snds) (cadr snds)))
        (t
         (nyq:add2 (car snds) (sim-list (cdr snds))))))


;(defun rest (&optional (dur 1.0))
;  (cue (set-Logical-stop (* dur *stretch*) (s-create))))
(defun s-rest (&optional (dur 1.0))
  (let ((start (local-to-global 0))
	(stop (local-to-global dur)))
    (snd-const 0.0 start *SOUND-SRATE* (- stop start))))


(defun tempo (warpfn)
  (slope (snd-inverse warpfn (local-to-global 0) *control-srate*)))



;; (SUM-OF-ARRAYS S1 S2) - add multichannel sounds
; 
; result has as many channels the largest of s1, s2
; corresponding channels are added, extras are copied
; 
(defun sum-of-arrays (s1 s2)
  (let* ((n1 (length s1))
	 (n2 (length s2))
	 (n (min n1 n2))
	 (m (max n1 n2))
	 (result (make-array m))
	 (big-s (if (> n1 n2) s1 s2)))
    
    (dotimes (i n)
      (setf (aref result i) (snd-add (aref s1 i) (aref s2 i))))
    (dotimes (i (- m n))
      (setf (aref result (+ n i)) (aref big-s (+ n i))))
    result))


;; (WARP fn behavior) - warp behavior according to fn
;;
;; fn is a map from behavior time to local time, and *WARP* expresses
;; a map from local to global time.
;; To produce a new *WARP* for the environment, we want to compose the
;; effect of the current *WARP* with fn.  Note that fn is also a behavior.
;; It is evaluated in the current environment first, then it is used to
;; modify the environment seen by behavior.
;; *WARP* is a triple: (d s f) denoting the function f(st+d).
;; Letting g represent the new warp function fn, we want f(st+d) o g, or
;; f(s*g(t) + d) in the form (d' s' f').
;; Let's do this one step at a time:
;; f(s*g(t) + d) = f(scale(s, g) + d)
;;               = (shift f -d)(scale(s, g))
;;               = (snd-compose (shift-time f (- d)) (scale s g))
;;
;; If f in NIL, it denotes the identity mapping f(t)=t, so we can
;; simplify:
;; f(scale(s, g) + d) = scale(s, g) + d
;;                    = (snd-offset (scale s g) d)

(defmacro warp (x s)
 `(progv '(*WARP*) (list 
		    (list 0.0 1.0
			  (if (warp-function *WARP*)
			      (snd-compose (shift-time (warp-function *WARP*) 
						       (- (warp-time *WARP*)))
					   (scale (warp-stretch *WARP*) 
						  (must-be-sound ,x)))
			      (snd-offset (scale (warp-stretch *WARP*) 
						 (must-be-sound ,x))
					  (warp-time *WARP*)))))
	 ,s))


(defmacro warp-abs (x s)
 `(progv '(*WARP*) (list (list 0.0 1.0 ,x))
         ,s))


;; MULTICHAN-EXPAND -- construct and return array according to args
;;
;; arrays are used in Nyquist to represent multiple channels
;; if any argument is an array, make sure all array arguments
;; have the same length.  Then, construct a multichannel result
;; by calling fn once for each channel.  The arguments passed to
;; fn for the i'th channel are either the i'th element of an array
;; argument, or just a copy of a non-array argument.
;;
(defun multichan-expand (fn &rest args)
  (let (len newlen result) ; len is a flag as well as a count
    (dolist (a args)
            (cond ((arrayp a)
                   (setf newlen (length a))
                   (cond ((and len (/= len newlen))
                          (error (format nil "In ~A, two arguments are vectors of differing length." fn))))
                   (setf len newlen))))
    (cond (len
           (setf result (make-array len))
           ; for each channel, call fn with args
           (dotimes (i len)
               (setf (aref result i)
                     (apply fn
                        (mapcar
                            #'(lambda (a)
                                ; take i'th entry or replicate:
                                (cond ((arrayp a) (aref a i))
                                      (t a)))
                            args))))
           result)
          (t
           (apply fn args)))))


;; SELECT-IMPLEMENTATION-? -- apply an implementation according to args
;;
;; There is a different Nyquist primitive for each combination of 
;; constant (NUMBERP) and time-variable (SOUNDP) arguments.  E.g.
;; a filter with fixed parameters differs from one with varying
;; parameters.  In most cases, the user just calls one function,
;; and the arguments are decoded here:


;; SELECT-IMPLEMENTATION-1-1 -- 1 sound arg, 1 selector
;;
(defun select-implementation-1-1 (fns snd sel1 &rest others)
  (if (numberp sel1)
    (apply (aref fns 0) (cons snd (cons sel1 others)))
    (apply (aref fns 1) (cons snd (cons sel1 others)))))


;; SELECT-IMPLEMENTATION-1-2 -- 1 sound arg, 2 selectors
;;
;; choose implemenation according to args 2 and 3
;;
(defun select-implementation-1-2 (fns snd sel1 sel2 &rest others)
  (if (numberp sel2)
    (if (numberp sel1)
      (apply (aref fns 0) (cons snd (cons sel1 (cons sel2 others))))
      (apply (aref fns 1) (cons snd (cons sel1 (cons sel2 others)))))
    (if (numberp sel1)
      (apply (aref fns 2) (cons snd (cons sel1 (cons sel2 others))))
      (apply (aref fns 3) (cons snd (cons sel1 (cons sel2 others)))))))




