;; lisp/envutil.lisp
;; Version 00.00.02 04-Aug-2007
;; Version 00.00.01 03-Aug-2007
;;
;; Provides common envelopes and envelope manipulation for CLM. Envelopes are
;; mostly defined as list of break-point pairs (t0 v0 t1 v1 ... tn vn) where
;; vi is value at time ti. Time values MUST be monotonically increasing. By
;; convention tn is normalized to 1 second.



(defpackage "ENVUTIL"
  (:use "COMMON-LISP" "COMMON-LISP-USER" "CLM")
  (:export "DX7" "ADSR" "ASR" "DASR" "RAMP-UP" "RAMP-DOWN" "EXP-DOWN" "EXP-UP")
  )

(in-package "ENVUTIL")
(provide "ENVUTIL")







;; [Constant] 
;; envutil:+min-segment-time+
;; Break-point time values should be monotonically increasing. The value of
;; +min-segment-time+ is the minimum time difference between adjacent
;; breakpoints.
;;
(defconstant +MIN-SEGMENT-TIME+ (/ 1.0 *srate*))


;; Some normalized envelope breakpoint list.
;; 
;; ramp-up, linearly increase from 0 to 1 over 1 second.
;; ramp-down, linearly decrease over 1 second
;; exp-down, exponential decay.
;; exp-up, exponential increase.
;;
(defvar ramp-up '(0 0 1 1))
(defvar ramp-down '(0 1 1 0))
(defvar exp-down '(0 1 1/4 1/4 1/2 1/16 3/4 1/32 1 0))
(defvar exp-up   '(0 0 1/4 1/32 1/2 1/16 3/4 1/4 1 1))





;; [Function] 
;; (extract-breakpoint-times bplist)
;; Create list of times from breakpoint list
;;
;; bplist - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; return - List of times (t0 t1 ... tn)
;;
(defun extract-breakpoint-times (bplist)
  (pick-every bplist 2))


;; [Function]
;; (extract-breakpoint-values bplist)
;; Create list of values from breakpoint list.
;;
;; bplist - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; return - List of values (v0 v1 ... vn)
;;
(defun extract-breakpoint-values (bplist)
  (pick-every bplist 2 1))


;; [Function]
;; (shift-breakpoint-times bplist offset)
;; Add constant value to each breakpoint time.
;;
;; bplist - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; offset - Real, The time shift offset >= 0.
;; return - List of time-shifted breakpoints (t0+offset v0 t1+offset v1 ... tn+offset vn)
;;
(defun shift-breakpoint-times (bplist offset)
  (zip (mapcar #'(lambda (n)(+ offset n))(extract-breakpoint-times bplist))
       (extract-breakpoint-values bplist)))


;; [Function]
;; (push-breakpoint offset value bplist)
;; Push new breakpoint onto list of breakpoints.
;; 
;; offset - Real, the time offset to be added to each existing breakpoint.
;; value  - Real, the value of the new breakpoint.
;; bplist - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; return - New breakpoint list (0 value t0+offset v0 t1+offset v1 ... tn+offset vn)
;;
(defun push-breakpoint (offset value bplist)
  (append (list 0 value)(shift-breakpoint-times bplist offset)))

;; [Function]
;; (stretch-breakpoints bplist factor)
;; Multiply each breakpoint time by factor.
;;
;; bplist - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; factor - real, factor > 0.
;; return - New breakpoint list (t0*f v0 t1*f v1 ... tn*f vn) 
;;          where f=factor.
;;
(defun stretch-breakpoints (bplist factor)
  (zip (mapcar #'(lambda (n)(* factor n))(extract-breakpoint-times bplist))
       (extract-breakpoint-values bplist)))


;; [Function]
;; (get-breakpoint-list-duration bplist)
;; Determine maximum breakpoint time.
;;
;; bplist - List of the form (t0 v0 t1 v1 ... tn vn)
;; return - Real, the value tn.
;;
(defun get-breakpoint-list-duration (bplist)
  (let ((len (list-length bplist)))
    (cond ((< len 2) nil)
	  (t (nth (- len 2) bplist)))))


;; {Function]
;; (normalize-breakpoint-times bplist &optional (endtime 1.0))
;; Multiply each breakpoint time such that the final time is endtime.
;;
;; bplist  - List of the form (t0 v0 t1 v1 ... tn vn)
;; endtime - Real or nil, optional endtime value, default 1.0 
;;           If norm > 0 normalize list. 
;;           If norm is nil, return bplist unchanged.
;;           Any other value for norm is an error.
;; return  - List of the form (t0*f v0 t1*f v1 ... tn*f vn)
;;           Where tn != 0 and f = endtime/tn
;;

(defun normalize-breakpoint-times (bplist &optional (endtime 1.0))
  (let ((d1 (get-breakpoint-list-duration bplist)) f)
	
    (cond ((zerop d1)
	   (error (format nil "ENVUTIL:NORMALIZE-BREAKPOINT-TIMES, Division by zero. Breakpoint list duration is 0: ~A~%" bplist)))
	  ((null endtime) bplist)
	  ((and (numberp endtime)(plusp endtime))
	   (setq f (/ endtime d1))
	   (zip (mapcar #'(lambda (n)(* n f))
			(extract-breakpoint-times bplist))
		(extract-breakpoint-values bplist)))
	  (t (error (format nil "ENVUTIL:NORMALIZE-BREAKPOINT-TIMES, type error endtime is not a positive number: ~A~%" endtime))))))





;; [Function]
;; (scale-breakpoint-list-values (bplist gain))
;; Multiply each breakpoint value by gain.
;;
;; bplist - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; gain   - Real. 
;; return - List (t0 v0*g t1 v1*g ... tn vn*g)
;;
(defun scale-breakpoint-list-values (bplist gain)
  (zip (extract-breakpoint-times bplist) 
       (mapcar #'(lambda (n)(* gain n))(extract-breakpoint-values bplist))))


;; [Function]
;; (get-max-breakpoint-value bplist)
;; Determine maximum breakpoint value.
;;
;; bplist - List (t0 v0 t1 v1 ... tn vn)
;; return - Real vq such that vq >= every other v in bplist.
;;
(defun get-max-breakpoint-value (bplist)
  (let ((mx -1e6))  ;; ISSUE: Should use maximum FIXNUM value ?
    (dolist (v (extract-breakpoint-values bplist))
      (if (> v mx)(setq mx v)))
    mx))


;; [Function]
;; (push-breakpoint-delay (dtime bplist &key (norm 1)(ivalue 0))
;; Add initial delay to breakpoint list.
;;
;; dtimne  - Real, the delay time.
;; bplist  - List of breakpoints (t0 v0 t1 v1 ... tn vn)
;; :norm   - Real or nil. If norm is numeric and positive, normalize
;;           breakpoint duration to norm seconds. If norm is nil
;;           skip normalization. 
;; :ivalue - Real, initial value. 
;; return  - list of breakpoints (0 ivalue t0' v0 t1' v1 ... tn' vn)
;;           Where ti' = (ti+dtime)*f 
;;
(defun push-breakpoint-delay (dtime bplist &key (norm 1)(ivalue 0))
  (let ((lst (push-breakpoint dtime ivalue bplist)))
    (if norm 
	(normalize-breakpoint-times lst norm)
	lst)))




;; (defun display-breakpoint-list (bplist)
;;   (if bplist
;;       (progn 
;; 	(format t "~A  ~A~%" (car bplist)(car (cdr bplist)))
;; 	(display-breakpoint-list (cdr (cdr bplist))))
;;       (format t "~%")))



;; [Function]
;; dx7 (&key t1 t2 t3 t4 v0 v1 v2 v3 v4 v5 sl norm)
;; Generate breakpoint list for dx7 style envelope with 4 time and 6 value
;; parameters.
;;
;; :t1   - Real, relative time 1, default 0.
;; :t2   - Real, relative time 2, default 0.
;; :t3   - Real, relative time 3, default 0.
;; :t4   - Real, relative time 4, default 0.
;; :v0   - Real, initial amplitude, default 0.
;; :v1   - Real, amplitude after time t1, default 1.
;; :v2   - Real, amplitude after time t1+t2, default 1.
;; :v3   - Real, amplitude after time t1+t2+t3, default 1.
;; :v4   - Real, amplitude at time 1-t4, default v3.
;; :v5   - Real, final amplitude, default v0.
;; :sl   - Real, Convenience parameter to set sustain level v3 and v4.
;; :norm - Real or nil. Stretch envelope time values to duration norm. 
;;         norm must be either a positive number or nil. 
;; return - List of breakpoints (0 v0 t1 v1 t1+t2 v2 t1+t2+t3 v3 1-t4 v4 1 v5)
;;
;;                                                                         
;;                                                                         
;;                v1                                                       
;;            __/\                                                         
;;         __/    \                                                        
;;     v1_/        \                                                       
;;     /            \                                                      
;;    /              \ v2                           v3                     
;;   /                \------------------------------                      
;;  /                                                \                     
;; /v0                                                \ v4                 
;; |<t1>|<  t2  >|<t3>|                            |t4|                    
;;                                                                         
;;                                                                         
;;                                                                         
(defun dx7 (&key t1 t2 t3 t4 v0 v1 v2 v3 v4 v5 sl norm)
  (setq t1 (clamp (or t1 0) 0 1))
  (setq t2 (clamp (or t2 0) 0 (- 1 t1)))
  (setq t3 (clamp (or t3 0) 0 (- 1 t1 t2)))
  (setq t4 (clamp (or t4 0) 0 (- 1 t1 t2 t3)))
  (setq v0 (or v0 0))
  (setq v1 (or v1 1))
  (setq v2 (or v2 1))
  (setq v3 (or v3 sl 1))
  (setq v4 (or v4 v3))
  (setq v5 (or v5 v0))
  (let ((p0 0) p1 p2 p3 p4 (p5 1) acc)
    (setq p1 (clamp t1 +min-segment-time+
		    (- 1 (* 4 +min-segment-time+))))
    (setq p2 (clamp (+ p1 t2)(+ p1 +min-segment-time+)
		    (- 1 (* 3 +min-segment-time+))))
    (setq p3 (clamp (+ p2 t3)(+ p2 +min-segment-time+)
		    (- 1 (* 2 +min-segment-time+))))
    (setq p4 (clamp (- p5 t4)
		    (+ p3 +min-segment-time+)
		    (- 1 (* 1 +min-segment-time+))))
    (setq acc (normalize-breakpoint-times 
	       (list p0 v0 p1 v1 p2 v2 p3 v3 p4 v4 p5 v5)
	       (or norm 1)))
    ;(display-breakpoint-list acc)
    acc))
    

;; [Function]
;; (adsr (&key (a 0)(d 0)(r 0)(sl 1)(norm 1)))
;; Create breakpoint list for ADSR style envelope.
;;
;; :a     - Real, attack time 0<=a<= 1, default 0.
;; :d     - Real, initial decay time, 0<=d<=1, default 0.
;; :r     - Real, final release time, 0<=r<=1, default 0
;;          Where the sum a+d+r<=1.
;; :sl    - Real, sustain level, default 1.
;; :norm  - Real or nil. See normalize-breakpoint-times, default 1.
;; return - List of breakpoints (0 0 a 1 a+d sl 1-r sl 1 0)
;;
(defun adsr (&key (a 0)(d 0)(r 0)(sl 1)(norm 1))
  (dx7 :t1 a :t2 0 :t3 d :t4 r :v2 1 :sl sl :norm norm)) 
      


;; [Function]
;; (asr (&key (a 0)(r 0)(norm 1))
;; Create breakpoint list of ASR style envelope.
;;
;; :a     - Real, attack time 0<=a<=1, default 0.
;; :r     - Real, release time 0<=r<=1, default 0.
;;          Where sum a+r<=1.
;; :norm  - Real or nil. See normalize-breakpoint-times, default 1.
;; return - List of breakpoints (0 0 a 1 0 1 1-r 1 0)
;;
(defun asr (&key (a 0)(r 0)(norm 1))
  (adsr :a a :d 0 :r r :sl 1 :norm norm))



;; [Function]
;; Create breakpoint list for ASR style envelope with initial delay.
;;
;; :delay - Real, initial delay, 0<=delay<=1, default 0.
;; :a     - Real, attack time, 0<=a<=1, default 0.
;; :r     - Real, release time, 0<=r<=1, default 0.
;;          Where sum delay+a+r<=1.
;; :norm  - Real or nil. See normalize-breakpoint-times, default 1.
;; return -List of breakpoints (0 0 delay 0 delay+a 1 1-r 1 1 0)
;;
(defun dasr (&key (delay 0)(a 0)(r 0)(norm 1))
  (dx7 :t1 delay :t2 a :t3 0 :t4 r
       :v0 0 :v1 0 :v2 1 :v3 1 :v4 1 :v5 0
       :norm norm))