; Shepard tones and paradoxes

; to use try
; (playscale (majorscale 60))
; (playscale (minorscale 60))
; (playscale (chromascale 60))
; (playparadoxscale (chromascale 60))

; for shepard sweeps, try
; (play (sheptone-sweep 60 60 2 72 60 12 4))

; the signature of sheptone-sweep should tell what the parameters do
; (defun sheptone-sweep (pitch-1 centerpitch-1 duration pitch-2 centerpitch-2
;                     overtonesemi overtones
;                     &optional (wavetable *sine-table*))

; Some notes about how this works:
; Shepard tones consist of harmonics that are an octave apart, thus
; the ratios are 1, 2, 4, 8, 16, etc. Note that the pitch is ambiguous
; in the sense that there could be a missing fundamental at 0.5, 0.25, etc.
; The other trick is that the spectral shape is constant. The amplitude
; of each harmonic is a function of its absolute frequency. Here, the
; shape is triangular so that as the frequency sweeps upward, harmonics
; (which are ramping up in frequency) fade in, reach a maximum, and fade out.
; 
; In this implementation, each harmonic is generated using an FM oscillator
; controlled by a frequency ramp. The harmonic is multiplied by an envelope
; to implement the spectral shape function. The envelope is computed by
; running the frequency control (with some scaling) into a SHAPE function
; that uses a triangular table to implement the spectral shape.
;
; Warning: Although I have not analyzed this code too carefully, I (RBD)
; believe that the oscillators keep sweeping up to higher and higher
; frequencies even after the amplitude drops to zero. This is not only
; wasteful, but when oscillators start to alias, they run slower. If you
; generate a very long Shepard tone with harmonics spanning many octaves,
; the run time could get to be very large. A better implementation would
; start the harmonics when they enter the non-zero part of the spectral
; envelope and end them when they leave it. 


(setf *onepi* 3.141592654)
(setf *twopi* (* 2 pi))
(setf *halfpi* (/ pi 2))


; envshaper is a raised cosine curve used to control
; the spectral shape. Its domain is 0 to 2
; it transforms (0 2) into 0 1
; it has to be used like
; (shape s (envshaper) 1)

(defun envshaper ()
  (mult (sum 1 (hzosc (const (/ 1.0 2.0) 2) *table* 270)) 0.5))


; some utility functions

;; ISEQ-HELPER -- generates an integer sequence
(defun iseq-helper (a b)
  (let ((mylist '()))
    (dotimes (i (1+ (- b a)) (reverse mylist))
	     (setf mylist (cons (+ a i) mylist)))))

;; ISEQ -- sequence of integers from a to b
(defun iseq (a b)
  (if (> a b) (reverse (iseq-helper b a))
              (iseq-helper a b)))


(defun floor (x)
       (if (< x 0)
           (1- (truncate x))
           (truncate x)))



; the main part

(defun sheptone-sweep-helper (pitch-1 centerpitch-1
                             duration
                             pitch-2 centerpitch-2
                             overtonesemi overtones
			     &optional (wavetable *sine-table*))
  (let ((mytone (const 0 duration))
	(maxovertones (+ (floor (/ (float (max (abs (- pitch-1 centerpitch-2))
					       (abs (- pitch-1 centerpitch-2))))
				   overtonesemi))
			 overtones 2))
	(ampshaper (envshaper)))
    ;; synthesize and sum maxovertones partials
    (dolist (i (iseq (-  maxovertones) maxovertones) mytone)
	    (progn
	      ;; partials start at pitch-1, spaced by overtonesemi (normally 12)
	      (setf startpitch (+ pitch-1 (* i overtonesemi)))
	      ;; partials end at pitch-2 + offset
	      (setf endpitch (+ pitch-2 (* i overtonesemi)))
	      ;; f is the frequency modulation (in hz)
	      (setf f (pwe 0 (step-to-hz startpitch)
			   duration (step-to-hz endpitch)))
	      ;; p is the pitch in steps
	      (setf p (pwl 0 startpitch duration endpitch))
	      ;; c is the centerpitch curve
	      ;;   (probably we could compute this outside the loop)
	      (setf c (pwl 0 centerpitch-1 duration centerpitch-2))
	      ;; normwidthfactor is used to map pitch curves into the spectral shape
	      ;;  function (range 0 to 2)
	      (setf normwidthfactor (/ 1.0 (* overtones overtonesemi)))
	      ;; a is the amplitude envelope: f(p - c)
	      (setf a (shape (mult (diff p c) normwidthfactor)
			     ampshaper 1))
	      ;; voice is one partial
	      (setf voice  (mult a (hzosc f wavetable)))
	      ;; sum the partials into mytone
	      (setf mytone (sum mytone voice))
	      )
	    )))


(defun sheptone-sweep (pitch-1 centerpitch-1 duration pitch-2 centerpitch-2
			       overtonesemi overtones
			       &optional (wavetable *sine-table*))
  (normalize ;; note: you might not want to normalize as is done here
   ;; use an envelope to get a smooth start and stop
   (mult (sheptone-sweep-helper pitch-1  centerpitch-1
				duration
				pitch-2 centerpitch-2
				overtonesemi overtones wavetable)
	 (env 0.05 0 0.05 1 1 1 duration))))


;; SHEPTONE is a special case of  sheptone-sweep. 
;;   The spectral centroid and pitch is constant.
(defun sheptone (pitch centerpitch duration
		       overtonesemi overtones
		       &optional (wavetable *sine-table*))
  (sheptone-sweep pitch centerpitch duration pitch centerpitch
		  overtonesemi overtones
		  wavetable))

(defun majorscale (basepitch)
  (mapcar (lambda (x) (+ basepitch x)) '(0 2 4 5 7 9 11 12)))

(defun minorscale (basepitch)
  (mapcar (lambda (x) (+ basepitch x)) '(0 2 3 5 7 8 10 12)))

(defun chromascale (basepitch)
  (mapcar (lambda (x) (+ basepitch x)) (iseq 0 12)))


;; MAKE-TABLE turns a function of 0-1 into a lookup table
(defun make-table (func-exp points)
  (let ((table (make-array points)))
    (dotimes (i points)
	     (setf (aref table i)
		   (funcall func-exp (/ (float i) (float points)))))
    (list (snd-from-array 0.0 points table) (hz-to-step 1) T)
    ))


(defun erich-wave (skew)
  (make-table
   (lambda (x) (if (< (abs skew) 0.000001) (sin (* *twopi* x))
		 (*
		  (/ (sin (* *twopi* x)) (- (/ 1.0 skew)
					    (cos (* *twopi* x))))
		  (/ (sqrt (- 1.0 (* skew skew))) skew))))
   2048))


;; NORMALIZE -- normalize a sound
;;
(defun normalize (s &optional (maxvol 0.8) (maxlen  44100))
  (let* ((mysound s)
	 (vol (peak mysound maxlen)))
    (scale (/ (float maxvol) vol) mysound)))

(defun playsafe (s)
  (play (normalize s)))

;; PLAYSCALE uses SHEPTONE to synthesize a scale that goes up on every
;;  step, but never actually ends up an octave higher
;;
(defun playscale (scaleseq  &optional (duration 1)  (wavetable *sine-table*))
  (mapcar (lambda (x) (play (sheptone x 60 duration 12 4 wavetable)))
	  scaleseq))


;; PLAYPARADOXSCALE uses sheptone to go up by half steps, yet end up
;;   an octave lower than it starts
;;
(defun playparadoxscale (scaleseq
			 &optional (duration 1) (wavetable *sine-table*))
  (mapcar (lambda (x y) (play (sheptone x y duration 12 4 wavetable)))
	  scaleseq (reverse scaleseq)))
 