;;; **********************************************************************
;;; Copyright (C) 2003 Heinrich Taube (taube@uiuc.edu) 
;;; This program is free software; you can redistribute it and
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; **********************************************************************

;;; generated by scheme->cltl from spectral.scm on 23-Mar-2005 12:21:18

(in-package :cm)

(defun rm-spectrum (set1 set2 &key (spectrum nil) (minimum nil)
                    (maximum nil) (hz nil) (scale-order :up)
                    (remove-duplicates nil))
  (flet ((sums-and-diffs (f1 f2)
           (if (= f1 f2) (list) (list (abs (- f1 f2)) (+ f1 f2)))))
    (let* ((type
            (cond ((not spectrum)
                   (if hz
                       ':hertz
                       (if (or (and set1 (symbolp set1))
                               (let
                                ((t8 (car set1)))
                                (and t8 (symbolp t8))))
                           ':note
                           ':keynum)))
                  ((member spectrum '(:note :keynum :hertz))
                   spectrum)
                  (t
                   (error "Spectrum ~S not one of: :note :keynum :hertz."
                          spectrum))))
           (spec
            (if (consp set1)
                (if (consp set2)
                    (loop with l2 = (hertz set2 :hz hz)
                          for f1 in (hertz set1 :hz hz)
                          append (loop for f2 in l2
                                  append (sums-and-diffs f1 f2)))
                                 (loop with f2 = (hertz set2 :hz hz)
                                  for f1 in (hertz set1 :hz hz)
                                  append (sums-and-diffs f1 f2)))
                                 (if
                                  (consp set2)
                                  (loop with f1 = (hertz set1 :hz hz)
                                   for f2 in (hertz set2 :hz hz)
                                   append (sums-and-diffs f1 f2))
                                   (sums-and-diffs
                                    (hertz set1 :hz hz)
                                    (hertz set2 :hz hz))))))
                    (when minimum
                      (do ((freq
                            (hertz minimum :hz (eq type ':hertz)))
                           (tail spec (cdr tail)))
                          ((null tail) nil)
                        (do ()
                            ((not (< (car tail) freq)))
                          (rplaca tail (* (car tail) 2)))))
                    (when maximum
                      (do ((freq
                            (hertz maximum :hz (eq type ':hertz)))
                           (tail spec (cdr tail)))
                          ((null tail) nil)
                        (do ()
                            ((not (> (car tail) freq)))
                          (rplaca tail (/ (car tail) 2)))))
                    (cond ((eq scale-order ':up)
                           (setf spec (sort spec #'<)))
                          ((eq scale-order ':down)
                           (setf spec (sort spec #'>)))
                          ((eq scale-order ':random)
                           (setf spec (shuffle spec))))
                    (cond ((eq type ':note)
                           (setf spec (note spec :hz t)))
                          ((eq type ':keynum)
                           (setf spec (keynum spec :hz t)))
                          ((eq type ':hertz) nil))
                    (if (and remove-duplicates
                             (do
                              ((tail spec (cdr tail)) (flag nil))
                              ((or (null tail) flag) flag)
                              (setf
                               flag
                               (member (car tail) (cdr tail)))))
                        (do ((tail spec (cdr tail))
                             (resl (list nil)))
                            ((null tail) (cdr resl))
                          (if (member (car tail) resl)
                              nil
                              (setf
                               resl
                               (nconc resl (list (car tail))))))
                        spec))))

(defun fm-spectrum (carrier mratio index &key (spectrum nil)
                    (minimum nil) (maximum nil) invert
                    (ignore-zero nil izp)
                    (amplitudes (eq spectrum ':raw)) all-sidebands
                    scale-order (remove-duplicates t))
  (let ((data nil) (type nil) (bot nil) (top nil))
    (case spectrum
      ((nil) (setf type spectrum))
      ((:hertz) (setf type spectrum)
       (unless izp (setf ignore-zero t)))
      ((:keynum) (setf type spectrum)
       (unless izp (setf ignore-zero t)))
      ((:note) (setf type spectrum)
       (unless izp (setf ignore-zero t)))
      (t
       (error "Spectrum ~s not one of: false :note :keynum :hertz."
              spectrum)))
    (when spectrum
      (if minimum (setf bot (hertz minimum :hz (eq type ':hertz))))
      (if maximum (setf top (hertz maximum :hz (eq type ':hertz)))))
    (setf data
          (fm-spectrum1 carrier mratio index (eq type nil) nil
           all-sidebands))
    (when ignore-zero
      (setf data (delete-if #'zerop data :key #'first)))
    (when invert
      (dolist (s data)
        (let ((f (first s)))
          (unless (= f 0.0)
            (rplaca s (abs (hz-invert (hz-ify carrier) f))))))
      (setf data (sort data (lambda (x y) (< (first x) (first y))))))
    (when (or (eq type ':note) (eq type ':keynum))
      (if (or top bot)
          (let ((f nil) (k nil) (e nil) (l (list)))
            (dolist (s data)
              (setf f (abs (first s)))
              (when (not (= f 0.0))
                (do () ((<= f top) nil)  (setf f (* f 0.5)))
                (do () ((>= f bot) nil)  (setf f (* f 2.0))))
              (setf k
                    (if (= f 0.0)
                        'r
                        (if (eq type ':keynum)
                            (keynum f :hz t)
                            (note f :hz t))))
              (setf e (find k l :key #'first))
              (if (and e remove-duplicates)
                  (rplaca (cdr e) (+ (cadr e) (second s)))
                  (progn (rplaca s k) (push s l))))
            (setf data (nreverse l)))
          (do ((low (hertz 0)) (tail data (cdr tail)))
              ((null tail) nil)
            (unless (< (caar tail) low)
              (setf (caar tail)
                    (if (eq type ':note)
                        (note (caar tail) :hz t)
                        (keynum (caar tail) :hz t)))))))
    (unless (eq type nil)
      (setf data
            (cond ((not scale-order)
                   (if (or top bot)
                       (sort data
                             (lambda
                              (a b)
                              (scale< (first a) (first b))))
                       data))
                  ((eq scale-order :up)
                   (sort data
                         (lambda (a b)
                           (scale< (first a) (first b)))))
                  ((eq scale-order :down)
                   (sort data
                         (lambda (a b)
                           (scale> (first a) (first b)))))
                  ((eq scale-order :random) (shuffle data))
                  (t
                   (error "Not a valid :scale-order: ~s."
                          scale-order)))))
    (cond ((not amplitudes)
           (do ((tail data (cdr tail)))
               ((null tail) nil)
             (rplaca tail (car (car tail)))))
          ((eq amplitudes :normalized)
           (dolist (s data) (rplaca (cdr s) (abs (second s)))))
          ((eq amplitudes :weights)
           (dolist (s data)
             (rplaca (cdr s) (abs (second s)))
             (rplacd s (cons ':weight (cdr s)))))
          ((eq amplitudes t) nil)
          (t (error "Not an amplitude value: ~s." amplitudes)))
    data))

(defun sidebands-to-cm (low high lb ub)
  (let* ((m (/ (- high low) (- ub lb))) (c (- high (* ub m))))
    (values c m (/ m c))))

(defmacro bes-jn (unn ux)
  `(let ((nn ,unn) (x ,ux))
     (let* ((n (floor (abs nn)))
            (besn
             (if (= n 0)
                 (bes-j0 x)
                 (if (= n 1)
                     (bes-j1 x)
                     (if (zerop x)
                         0.0
                         (let ((iacc 40)
                               (ans 0.0)
                               (bigno 1.0E+10)
                               (bigni 1.0E-10))
                           (if (> (abs x) n)
                               (do
                                ((tox (/ 2.0 (abs x)))
                                 (bjm (bes-j0 (abs x)))
                                 (bj (bes-j1 (abs x)))
                                 (j 1 (+ j 1))
                                 (bjp 0.0))
                                ((= j n) (setf ans bj))
                                (setf bjp (- (* j tox bj) bjm))
                                (setf bjm bj)
                                (setf bj bjp))
                               (let
                                ((tox (/ 2.0 (abs x)))
                                 (m
                                  (*
                                   2
                                   (floor
                                    (/ (+ n (sqrt (* iacc n))) 2))))
                                 (jsum 0.0)
                                 (bjm 0.0)
                                 (sum 0.0)
                                 (bjp 0.0)
                                 (bj 1.0))
                                (do
                                 ((j m (- j 1)))
                                 ((= j 0))
                                 (setf bjm (- (* j tox bj) bjp))
                                 (setf bjp bj)
                                 (setf bj bjm)
                                 (when
                                  (> (abs bj) bigno)
                                  (setf bj (* bj bigni))
                                  (setf bjp (* bjp bigni))
                                  (setf ans (* ans bigni))
                                  (setf sum (* sum bigni)))
                                 (if (not (= 0 jsum)) (incf sum bj))
                                 (setf jsum (- 1 jsum))
                                 (if (= j n) (setf ans bjp)))
                                (setf sum (- (* 2.0 sum) bj))
                                (setf ans (/ ans sum))))
                           (if (and (minusp x) (oddp n))
                               (- ans)
                               ans)))))))
       (if (and (minusp nn) (oddp nn)) (- besn) besn))))

(defun fm-spectrum1 (carrier mratio index neg-freq? pos-amp?
                     sideband-scaler)
  (setf carrier (hz-ify carrier))
  (let ((mfreq (* carrier mratio))
        (nsides
         (if sideband-scaler
             (round (* sideband-scaler index))
             (1+ (round index))))
        (spectrum '()))
    (setf spectrum
          (loop for k from (- nsides) to nsides
                for a = (bes-jn k index)
                unless (= a 0.0)
                  collect (list (+ carrier (* mfreq k)) a)))
                (unless neg-freq?
                  (do ((neg nil) (pos nil))
                      ((not (minusp (caar spectrum))) nil)
                    (setf neg (pop spectrum))
                    (setf pos (abs (first neg)))
                    (rplaca neg pos)
                    (rplaca (cdr neg) (- (second neg)))
                    (let ((side (assoc (first neg) spectrum)))
                      (if side
                          (rplaca (cdr side)
                                  (+ (cadr side) (second neg)))
                          (let ((p
                                 (position-if
                                  #'(lambda (x) (< x pos))
                                  spectrum
                                  :key
                                  #'first
                                  :from-end
                                  t)))
                            (if (not p)
                                (push neg spectrum)
                                (let
                                 ((tail (nthcdr p spectrum)))
                                 (setf neg (list neg))
                                 (rplacd neg (cdr tail))
                                 (rplacd tail neg))))))))
                (when pos-amp?
                  (dolist (s spectrum)
                    (rplaca (cdr s) (abs (second s)))))
                spectrum))

(defun hz-ify (x) (if (and x (symbolp x)) (hertz x) (* x 1.0)))

(defun hz-invert (f1 f2)
  (let ((l1 (log f1)) (l2 (log f2))) (exp (+ l1 (- l1 l2)))))

(defun bes-j0 (x)
  (if (< (abs x) 8.0)
      (let* ((y (* x x))
             (ans1
              (+ 5.756849E+10
                 (* y
                    (+ -1.3362591E+10
                       (* y
                          (+ 6.5161965E+8
                             (*
                              y
                              (+
                               -1.1214424E+7
                               (*
                                y
                                (+
                                 77392.33
                                 (* y -184.90524)))))))))))
             (ans2
              (+ 5.756849E+10
                 (* y
                    (+ 1.029533E+9
                       (* y
                          (+ 9494681.0
                             (*
                              y
                              (+
                               59272.65
                               (* y (+ 267.85327 y)))))))))))
        (/ ans1 ans2))
      (let* ((ax (abs x))
             (z (/ 8.0 ax))
             (y (* z z))
             (xx (- ax 0.7853982))
             (ans1
              (+ 1.0
                 (* y
                    (+ -0.0010986286
                       (* y
                          (+ 2.7345104E-5
                             (*
                              y
                              (+
                               -2.0733708E-6
                               (* y 2.0938872E-7)))))))))
             (ans2
              (+ -0.015625
                 (* y
                    (+ 1.4304888E-4
                       (* y
                          (+ -6.9111475E-6
                             (*
                              y
                              (+
                               7.621095E-7
                               (* y -9.349451E-8))))))))))
        (* (sqrt (/ 0.63661975 ax))
           (- (* (cos xx) ans1) (* z (sin xx) ans2))))))

(defun bes-j1 (x)
  (if (< (abs x) 8.0)
      (let* ((y (* x x))
             (ans1
              (* x
                 (+ 7.2362615E+10
                    (* y
                       (+ -7.8950595E+9
                          (* y
                             (+
                              2.4239685E+8
                              (*
                               y
                               (+
                                -2972611.5
                                (*
                                 y
                                 (+
                                  15704.482
                                  (* y -30.160366))))))))))))
             (ans2
              (+ 1.4472523E+11
                 (* y
                    (+ 2.3005353E+9
                       (* y
                          (+ 1.8583304E+7
                             (*
                              y
                              (+
                               99447.44
                               (* y (+ 376.99915 y)))))))))))
        (/ ans1 ans2))
      (let* ((ax (abs x))
             (z (/ 8.0 ax))
             (y (* z z))
             (xx (- ax 2.3561945))
             (ans1
              (+ 1.0
                 (* y
                    (+ 0.00183105
                       (* y
                          (+ -3.5163965E-5
                             (*
                              y
                              (+
                               2.4575202E-6
                               (* y -2.4033702E-7)))))))))
             (ans2
              (+ 0.046875
                 (* y
                    (+ -2.0026909E-4
                       (* y
                          (+ 8.449199E-6
                             (*
                              y
                              (+
                               -8.822899E-7
                               (* y 1.05787414E-7))))))))))
        (* (signum x)
           (sqrt (/ 0.63661975 ax))
           (- (* (cos xx) ans1) (* z (sin xx) ans2))))))
