;;; -*- syntax: common-lisp; base: 10; mode: lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; File:             formants.ins
;;;
;;; Purpose:          Apply an arbitrary number of formant filters to an
;;;                   optionally transposed sound file.  The parameters of the
;;;                   filters can be changed dynamically via envelopes.
;;;
;;; Author:           Michael Edwards - m@michael-edwards.org
;;;
;;; $$ Last modified: 11:55:05 Tue Jul  5 2011 BST
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :clm)

(defmacro get-formant-amp (focus voice num-voices &key (min 0.1) (expt 1.0))
  `(let* ((voice-val (* ,voice (/ 1.0 (1- ,num-voices))))
          (diff (abs (- ,focus voice-val)))
          (val (+ ,min (* (- 1.0 diff) (- 1.0 ,min)))))
     (if (= ,expt 1.0) val (expt val ,expt))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun compute-radius (bw) ;; bw in Hz
  (exp (/ (* (- pi) bw) *srate*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun bw-env->radius-env (bw-env)
  (loop for x in bw-env by #'cddr and y in (cdr bw-env) by #'cddr 
        collect x
        collect (compute-radius y)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun formant-chord-morph (chord1 chord2 &optional (envelope '(0 0 100 1)))
  (unless (= (length chord1) (length chord2))
    (error "There must be the same number of notes in each chord: ~%~a ~%~a"
           chord1 chord2))
  (loop for f1 in chord1 and f2 in chord2 collect
        (loop for x in envelope by #'cddr and y in (cdr envelope) by #'cddr 
              collect x collect (+ f1 (* y (- f2 f1))))))

;;; (formant-chord-morph '(100 200 300) '(200 400 600) '(0 .5 50 0 100 1))
;;; => ((0 150.0 50 100 100 200) (0 300.0 50 200 100 400)
;;;     (0 450.0 50 300 100 600))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(definstrument formants ;; (formants :c-file "~/ins/.cins/formants.c")
    (file time &key
          (duration 0)
          (start 0) 
          (srt 1.0) 
          (srt-scaler 1.0)
          (src-width 5)
          (mix '(0 1 100 1))            ; 0 is all original, 1 is all filtered
          (mix-scaler 1.0)
          (amp 1.0) 
          ;; a list of either freqs in herz or envelopes; the length of this
          ;; list determines the number of formant filters.
          (freqs '())
          ;; Hz, can be an envelope too whereupon this is the default envelope
          ;; for every formant.
          (default-bandwidth 100) 
          ;; Each formant can have its own bandwidth too, by specifying the
          ;; formant number (1-based) and the bandwidth or envelope.
          ;; e.g. (1 300 2 10 4 (0 200 100 5)), the rest of the formants will
          ;; have the default.
          (bandwidths '())
          (focus-env '())
          (focus-env-min 0.1)
          (focus-env-expt 1.0)
          (amp-env '(0 1 100 1))
          (rev-amt 0))
  (unless (= (sound-chans file) (mus-channels *output*))
    (warn "Input channels ~a, output channels ~a?"
          (sound-chans file) (mus-channels *output*)))
  (let* ((st (floor (* time *srate*)))
         (input-chans (sound-chans file))
         (files (loop for i below input-chans collect
                      (open-input* file :channel i 
                                   :start (floor (* start *srate*)))))
         ;; (stereo (= 2 (sound-chans file)))
         ;; use in-any if we don't need to src
         (do-src (/= srt 1.0))
         (src-gens (when do-src
                     (make-array input-chans :initial-contents
                                 (loop for i below input-chans collect
                                       (make-src :input (nth i files) 
                                                 :srate srt 
                                                 :width src-width)))))
         (readins (unless do-src
                    (make-array input-chans :initial-contents
                                (loop for i below input-chans collect
                                      (make-readin :file (nth i files))))))
         (dur (if (zerop duration)
                  (sound-duration file) 
                duration))
         (ampf (make-env :envelope amp-env :scaler amp :duration dur)) 
         (mix-env (make-env :envelope mix :scaler mix-scaler :duration dur))
         (num-formants (length freqs))
         (fe (when focus-env
               (make-env :envelope focus-env :duration dur)))
         (frqs (make-array num-formants :initial-contents
                           (loop for fr in freqs collect
                                 (if (numberp fr)
                                     fr
                                   (make-env :envelope fr :duration dur)))))
         (default-radius (if (numberp default-bandwidth)
                             (compute-radius default-bandwidth)
                           .99))
         (radii 
          (make-array num-formants :initial-contents
                      (loop repeat num-formants collect
                            (if (numberp default-bandwidth)
                                default-radius
                              (make-env :envelope 
                                        (bw-env->radius-env default-bandwidth)
                                        :duration dur)))))
         ;; any old radius and frequency is fine for now as it will be changed
         ;; in the run loop.  
         (formant-filters 
          (make-array (list input-chans num-formants)
                      :initial-contents
                      (loop for i below input-chans collect
                            (loop for i below num-formants collect
                                  (make-formant default-radius 100)))))
         (count 0.0)
         (mix-val 0.0)
         (fe-val 0.0)
         (formant-amp-scaler 0.0)
         (pure-sigs (make-array input-chans))
         ;; (pure-sig2 0.0)
         (filtered-sigs (make-array input-chans))
         ;; (filtered-sig2 0.0)
         (freq 0.0)
         (temp nil)
         (amp-val 0.0)
         (radius 0.0)
         (nd (+ st (floor (* *srate* dur)))))
    (when bandwidths
      (loop for fmt in bandwidths by #'cddr 
          and bw in (cdr bandwidths) by #'cddr do 
            (when (or (< fmt 1) (> fmt num-formants))
              (error "Illegal formant reference: ~a" fmt))
            (setf (aref radii (1- fmt))
              (if (numberp bw)
                  (compute-radius bw)
                (make-env :envelope (bw-env->radius-env bw) 
                          :duration dur)))))
    (format t "~&Start time = ~f~%" time)
    (run
     (loop for i from st to nd do
           (when (= count *srate*) 
             (setf count 0)
             (print (round (/ i *srate*))))
           (incf count)
           (setf mix-val (env mix-env)
                 amp-val (env ampf)
                 fe-val (when focus-env 
                          (env fe)))
           (loop for j below input-chans do
                 (setf (aref pure-sigs j) (if do-src
                                              (src (aref src-gens j))
                                            (readin (aref readins j)))
                       (aref filtered-sigs j) 0.0))
           (dotimes (j num-formants)
             (setf temp (aref frqs j)
                   freq (if (numberp temp) 
                            temp 
                          (env (aref frqs j)))
                   temp (aref radii j)
                   radius (if (numberp temp) 
                              temp 
                            (env (aref radii j)))
                   formant-amp-scaler 
                   (if focus-env
                       (get-formant-amp fe-val j num-formants 
                                        :min focus-env-min
                                        :expt focus-env-expt)
                     1.0))
             (loop for chan below input-chans do
                   (setf (mus-frequency (aref formant-filters chan j)) freq
                         (mus-formant-radius (aref formant-filters chan j))
                         radius)
                   (incf (aref filtered-sigs chan)
                         (* formant-amp-scaler
                            (formant (aref formant-filters chan j)
                                     (aref pure-sigs chan))))))
           (loop 
               for c below input-chans 
               for fs = (aref filtered-sigs c)
               for pure-sig = (aref pure-sigs c)
               do
                 (out-any i (* amp-val (+ (* mix-val fs)
                                          (* (- 1.0 mix-val) pure-sig)))
                          c))))
    (loop for file in files do
          (close-input file))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|

(with-sound (:statistics t :scaled-to .99 :channels 4 :play nil :srate 88200
                         :output "/temp/test.wav")
  (formants
   ;; "/music/24-7/splinter/88/24-7-spl-trash-00m52.553-to-00m53.101.wav"
   "c:\\music\\24-7\\splinter\\88\\24-7-spl-trash-00m52.553-to-00m53.101.wav"
   ;; "/snd/samples/slippery/clarinet/bass/bass-keys-breath1.wav"
   0
   :duration 5
                      ;;;:freqs '(100 1000 (0 100 100 5000))
   :freqs '(100 1000 3000)
   ;;:mix '(0 .99 .99)
   ;;:focus-env '(0 1 100 0)
   :focus-env-min 0
   :default-bandwidth '(0 10 100 1000)
   :bandwidths '(3 (0 10 100 1000))
   ))

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; EOF formants.ins

