You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

analog-filter.scm 18KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490
  1. ;;; various even order analog filters, based primarily on Anders Johansson's (GPL'd) code
  2. ;;;
  3. ;;; butterworth-lowpass|highpass|bandstop|bandpass
  4. ;;; chebyshev-lowpass|highpass|bandstop|bandpass
  5. ;;; inverse-chebyshev-lowpass|highpass|bandstop|bandpass
  6. ;;;
  7. ;;; if GSL included in Snd:
  8. ;;; bessel-lowpass|highpass|bandstop|bandpass
  9. ;;; elliptic-lowpass|highpass|bandstop|bandpass
  10. ;;;
  11. ;;; build Snd with gsl for best results
  12. (provide 'snd-analog-filter.scm)
  13. (define* (analog->digital n num den fz)
  14. (let ((g 1.0)
  15. (Q 1.0)
  16. (wc (tan (* pi fz)))
  17. (c (make-float-vector (* 2 n))))
  18. (define (cascade->canonical A)
  19. ;; (cascade->canonical A) converts cascade filter coeffs to canonical form
  20. ;; from Orfanidis "Introduction to Signal Processing"
  21. (define (conv M h L x y)
  22. ;; x * h -> y
  23. (do ((n 0 (+ n 1)))
  24. ((= n (+ L M)))
  25. (let ((sum 0.0)
  26. (start (max 0 (- n L 1)))
  27. (end (min n M)))
  28. (do ((m start (+ m 1)))
  29. ((> m end))
  30. (set! sum (+ sum (* (h m) (x (- n m))))))
  31. (set! (y n) sum))))
  32. (let ((K (length A)))
  33. (let ((d (make-float-vector (+ 1 (* 2 K))))
  34. (a1 (make-float-vector (+ 1 (* 2 K)))))
  35. (set! (a1 0) 1.0)
  36. (do ((i 0 (+ i 1)))
  37. ((= i K))
  38. (conv 2 (A i) (+ 1 (* 2 i)) a1 d)
  39. (copy d a1 0 (+ 3 (* 2 i))))
  40. a1)))
  41. (do ((i 0 (+ i 2))
  42. (j 0 (+ j 3))
  43. (k 0 (+ k 4)))
  44. ((>= i n))
  45. (let* ((nt0 (/ (num j) (* wc wc)))
  46. (nt1 (/ (num (+ j 1)) wc))
  47. (nt2 (num (+ j 2)))
  48. (dt0 (/ (den j) (* wc wc)))
  49. (dt1 (/ (den (+ j 1)) (* wc Q)))
  50. (dt2 (den (+ j 2))))
  51. (let ((kd (+ dt0 dt1 dt2))
  52. (kn (+ nt0 nt1 nt2)))
  53. (set! (c k ) (/ (- (* 2.0 dt2) (* 2.0 dt0)) kd))
  54. (set! (c (+ k 1)) (/ (- (+ dt0 dt2) dt1) kd))
  55. (set! (c (+ k 2)) (/ (- (* 2.0 nt2) (* 2.0 nt0)) kn))
  56. (set! (c (+ k 3)) (/ (- (+ nt0 nt2) nt1) kn))
  57. (set! g (* g (/ kn kd))))))
  58. (do ((a ())
  59. (b ())
  60. (i 0 (+ i 2))
  61. (k 0 (+ k 4))) ; c
  62. ((>= i n)
  63. (list (float-vector-scale! (cascade->canonical a) g) ; scale entire numerator because this is the convolved form
  64. (cascade->canonical b)))
  65. (set! a (cons (float-vector (c (+ k 3)) (c (+ k 2)) (c (+ k 3))) a))
  66. (set! b (cons (float-vector 1.0 (c k) (c (+ k 1))) b)))))
  67. (define (prototype->highpass n proto)
  68. (let ((num (car proto))
  69. (den (cadr proto)))
  70. (do ((g 1.0)
  71. (numt (make-float-vector (length num)))
  72. (dent (make-float-vector (length den)))
  73. (k 0 (+ k 2))
  74. (i 0 (+ i 3)))
  75. ((>= k n)
  76. (set! (numt 0) g)
  77. (list numt dent))
  78. (set! g (* g (/ (num (+ i 2)) (den (+ i 2)))))
  79. (set! (numt i ) 1.0)
  80. (set! (numt (+ i 1)) (/ (num (+ i 1)) (num (+ i 2))))
  81. (set! (numt (+ i 2)) (/ (num i) (num (+ i 2))))
  82. (set! (dent i ) 1.0)
  83. (set! (dent (+ i 1)) (/ (den (+ i 1)) (den (+ i 2))))
  84. (set! (dent (+ i 2)) (/ (den i) (den (+ i 2)))))))
  85. ;;; ---------------- Butterworth ----------------
  86. (define (butterworth-prototype n)
  87. (let ((len (/ (* n 3) 2)))
  88. (do ((num (make-float-vector len))
  89. (den (make-float-vector len))
  90. (w 1 (+ w 2))
  91. (j 0 (+ j 3)))
  92. ((>= w n)
  93. (list num den))
  94. (set! (num j) 0.0)
  95. (set! (num (+ j 1)) 0.0)
  96. (set! (num (+ j 2)) 1.0)
  97. (set! (den j) 1.0)
  98. (set! (den (+ j 1)) (* 2.0 (cos (/ (* w pi) (* 2.0 n)))))
  99. (set! (den (+ j 2)) 1.0))))
  100. (define make-butterworth-lowpass
  101. (let ((documentation "(make-butterworth-lowpass n fc) returns a lowpass Buttterworth filter; n = order, fc = cutoff \
  102. freq (srate = 1.0): (make-butterworth-lowpass 8 .1)"))
  103. (lambda (n fc)
  104. ;; identical to make-butter-lp except for fc (freq->1.0) fixup
  105. (if (odd? n) (set! n (+ n 1)))
  106. (let ((coeffs (let ((proto (butterworth-prototype n)))
  107. (analog->digital n (car proto) (cadr proto) fc))))
  108. (make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
  109. (define make-butterworth-highpass
  110. (let ((documentation "(make-butterworth-highpass n fc) returns a highpass Butterworth filter; n = order, fc = cutoff \
  111. freq (srate = 1.0): (make-butterworth-highpass 8 .1)"))
  112. (lambda (n fc)
  113. (if (odd? n) (set! n (+ n 1)))
  114. (let ((coeffs (let ((hproto (prototype->highpass n (butterworth-prototype n))))
  115. (analog->digital n (car hproto) (cadr hproto) fc))))
  116. (make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
  117. (define make-butterworth-bandpass
  118. (let ((documentation "(make-butterworth-bandpass n fl fh) returns a bandpass Butterworth filter; n = order, fl and fh \
  119. are (1.0-based) edge freqs: (make-butterworth-bandpass 4 .1 .2)"))
  120. (lambda (n fl fh)
  121. (if (odd? n) (set! n (+ n 1)))
  122. (let ((lp (make-butterworth-lowpass n fh))
  123. (hp (make-butterworth-highpass n fl)))
  124. (lambda (y)
  125. (filter lp (filter hp y)))))))
  126. (define make-butterworth-bandstop
  127. (let ((documentation "(make-butterworth-bandstop n fl fh) returns a bandstop Butterworth filter; n = order, fl and fh \
  128. are (1.0-based) edge freqs: (make-butterworth-bandstop 4 .1 .2)"))
  129. (lambda (n fl fh)
  130. (if (odd? n) (set! n (+ n 1)))
  131. (let ((lp (make-butterworth-lowpass n fl))
  132. (hp (make-butterworth-highpass n fh)))
  133. (lambda (y)
  134. (+ (filter lp y) (filter hp y)))))))
  135. ;;; ---------------- Chebyshev ----------------
  136. (define* (chebyshev-prototype n (ripple 1.0)) ; ripple in dB (positive)
  137. (let ((len (/ (* n 3) 2)))
  138. (do ((v0 (let ((e (sqrt (- (expt 10.0 (* 0.1 ripple)) 1.0))))
  139. (/ (asinh (/ 1.0 e)) n)))
  140. (num (make-float-vector len))
  141. (den (make-float-vector len))
  142. (k 1.0 (+ k 2.0))
  143. (j 0 (+ j 3)))
  144. ((>= k n)
  145. (set! (num 2) (/ (expt 2.0 (- 2 n))
  146. (expt 3.2 (log ripple 10.0)))) ; whatever works...
  147. (list num den))
  148. (let ((u (- (* (sinh v0) (sin (/ (* k pi) (* 2.0 n))))))
  149. (w (* (cosh v0) (cos (/ (* k pi) (* 2.0 n))))))
  150. (set! (num j ) 0.0)
  151. (set! (num (+ j 1)) 0.0)
  152. (set! (num (+ j 2)) 1.0)
  153. (set! (den j ) 1.0)
  154. (set! (den (+ j 1)) (* -2.0 u))
  155. (set! (den (+ j 2)) (+ (* u u) (* w w)))))))
  156. (define make-chebyshev-lowpass
  157. (let ((documentation "(make-chebyshev-lowpass n fc (ripple 1.0)) returns a lowpass Chebyshev filter; n = order, \
  158. fc = cutoff freq (srate = 1.0): (make-chebyshev-lowpass 8 .1)"))
  159. (lambda* (n fc (ripple 1.0))
  160. (if (odd? n) (set! n (+ n 1)))
  161. (let ((coeffs (let ((proto (chebyshev-prototype n ripple)))
  162. (analog->digital n (car proto) (cadr proto) fc))))
  163. (make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
  164. (define make-chebyshev-highpass
  165. (let ((documentation "(make-chebyshev-highpass n fc (ripple 1.0)) returns a highpass Chebyshev filter; n = order, \
  166. fc = cutoff freq (srate = 1.0): (make-chebyshev-highpass 8 .1 .01)"))
  167. (lambda* (n fc (ripple 1.0))
  168. (if (odd? n) (set! n (+ n 1)))
  169. (let ((coeffs (let ((hproto (prototype->highpass n (chebyshev-prototype n ripple))))
  170. (analog->digital n (car hproto) (cadr hproto) fc))))
  171. (make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
  172. (define make-chebyshev-bandpass
  173. (let ((documentation "(make-chebyshev-bandpass n fl fh (ripple 1.0)) returns a bandpass Chebyshev filter; n = order, \
  174. fl and fh = edge freqs (srate = 1.0): (make-chebyshev-bandpass 4 .1 .2)"))
  175. (lambda* (n fl fh (ripple 1.0))
  176. (if (odd? n) (set! n (+ n 1)))
  177. (let ((lp (make-chebyshev-lowpass n fh ripple))
  178. (hp (make-chebyshev-highpass n fl ripple)))
  179. (lambda (y)
  180. (filter lp (filter hp y)))))))
  181. (define make-chebyshev-bandstop
  182. (let ((documentation "(make-chebyshev-bandstop n fl fh (ripple 1.0)) returns a bandstop Chebyshev filter; n = order, \
  183. fl and fh = edge freqs (srate = 1.0): (make-chebyshev-bandstop 8 .1 .4 .01)"))
  184. (lambda* (n fl fh (ripple 1.0))
  185. (if (odd? n) (set! n (+ n 1)))
  186. (let ((lp (make-chebyshev-lowpass n fl ripple))
  187. (hp (make-chebyshev-highpass n fh ripple)))
  188. (lambda (y)
  189. (+ (filter lp y) (filter hp y)))))))
  190. ;;; ---------------- inverse Chebyshev ----------------
  191. (define* (inverse-chebyshev-prototype n (loss-dB 60.0)) ; stopband loss
  192. (let ((len (/ (* n 3) 2)))
  193. (do ((v0 (let ((e (sqrt (/ 1.0 (- (expt 10.0 (* 0.1 loss-dB)) 1.0)))))
  194. (/ (asinh (/ 1.0 e)) n)))
  195. (num (make-float-vector len))
  196. (den (make-float-vector len))
  197. (pl 0.0)
  198. (L 1.0 (+ L 2.0))
  199. (j 0 (+ j 3)))
  200. ((>= L n)
  201. (list num den
  202. (expt 1.122 (- loss-dB)))) ; argh
  203. (let ((u (- (* (sinh v0) (sin (/ (* L pi) (* 2.0 n))))))
  204. (w (* (cosh v0) (cos (/ (* L pi) (* 2.0 n)))))
  205. (t (/ 1.0 (sin (/ (* (+ L pl) pi) (* 2.0 n))))))
  206. (set! (num j ) 1.0)
  207. (set! (num (+ j 1)) 0.0)
  208. (set! (num (+ j 2)) (* t t))
  209. (set! (den j ) 1.0)
  210. (set! (den (+ j 1)) (/ (* -2.0 u) (+ (* u u) (* w w))))
  211. (set! (den (+ j 2)) (/ 1.0 (+ (* u u) (* w w))))))))
  212. (define make-inverse-chebyshev-lowpass
  213. (let ((documentation "(make-inverse-chebyshev-lowpass n fc (loss-dB 60.0)) returns a lowpass inverse-Chebyshev filter; n = order, \
  214. fc = cutoff freq (srate = 1.0): (make-inverse-chebyshev-lowpass 10 .4 120)"))
  215. (lambda* (n fc (loss-dB 60.0))
  216. (if (odd? n) (set! n (+ n 1)))
  217. (let* ((proto (inverse-chebyshev-prototype n loss-dB))
  218. (coeffs (analog->digital n (car proto) (cadr proto) fc)))
  219. (make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
  220. (define make-inverse-chebyshev-highpass
  221. (let ((documentation "(make-inverse-chebyshev-highpass n fc (loss-dB 60.0)) returns a highpass inverse-Chebyshev filter; n = order, \
  222. fc = cutoff freq (srate = 1.0): (make-inverse-chebyshev-highpass 10 .1 120)"))
  223. (lambda* (n fc (loss-dB 60.0))
  224. (if (odd? n) (set! n (+ n 1)))
  225. (let* ((proto (inverse-chebyshev-prototype n loss-dB))
  226. (coeffs (let ((hproto (prototype->highpass n proto)))
  227. (analog->digital n (car hproto) (cadr hproto) fc))))
  228. (make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
  229. (define make-inverse-chebyshev-bandpass
  230. (let ((documentation "(make-inverse-chebyshev-bandpass n fl fh (loss-dB 60.0)) returns a bandpass inverse-Chebyshev filter; n = order, \
  231. fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandpass 8 .1 .4)"))
  232. (lambda* (n fl fh (loss-dB 60.0))
  233. (if (odd? n) (set! n (+ n 1)))
  234. (let ((lp (make-inverse-chebyshev-lowpass n fh loss-dB))
  235. (hp (make-inverse-chebyshev-highpass n fl loss-dB)))
  236. (lambda (y) (filter lp (filter hp y)))))))
  237. (define make-inverse-chebyshev-bandstop
  238. (let ((documentation "(make-inverse-chebyshev-bandstop n fl fh (loss-dB 60.0)) returns a bandstop inverse-Chebyshev filter; n = order, \
  239. fl and fh are edge freqs (srate=1.0): (make-inverse-chebyshev-bandstop 8 .1 .4 90)"))
  240. (lambda* (n fl fh (loss-dB 60.0))
  241. (if (odd? n) (set! n (+ n 1)))
  242. (let ((lp (make-inverse-chebyshev-lowpass n fl loss-dB))
  243. (hp (make-inverse-chebyshev-highpass n fh loss-dB)))
  244. (lambda (y) (+ (filter lp y) (filter hp y)))))))
  245. ;;; ---------------- Bessel (-Thompson) ----------------
  246. (define (bessel-prototype n)
  247. (define (bessel-i n)
  248. (define (fact n)
  249. (do ((x 1)
  250. (i 2 (+ i 1)))
  251. ((> i n) x)
  252. (set! x (* x i))))
  253. ;; this form overflows if we don't have bignums
  254. ;; (define (bessel-i n)
  255. ;; (let ((cs (make-float-vector (+ n 1))))
  256. ;; (do ((i 0 (+ i 1)))
  257. ;; ((> i n))
  258. ;; (set! (cs i) (/ (fact (- (* 2 n) i))
  259. ;; (* (expt 2 (- n i))
  260. ;; (fact i)
  261. ;; (fact (- n i))))))
  262. ;; cs))
  263. (do ((cs (make-float-vector (+ n 1)))
  264. (i 0 (+ i 1)))
  265. ((> i n) cs)
  266. (do ((val (/ 1.0 (* (fact i) (expt 2 (- n i)))))
  267. (k 1 (+ k 1))
  268. (f (- n i -1) (+ f 1))) ; (f (+ 1 (- n i)) (+ 1 f))
  269. ((> k n)
  270. (set! (cs i) val))
  271. (set! val (* val f)))))
  272. (let ((len (/ (* n 3) 2)))
  273. (let ((num (make-float-vector len))
  274. (den (make-float-vector len))
  275. (b2 (bessel-i n)))
  276. (let ((p (gsl-roots (copy b2 (make-vector (length b2))))))
  277. (do ((i 0 (+ i 1)))
  278. ((= i n))
  279. (set! (p i) (/ (p i) (expt (b2 0) (/ 1.0 n)))))
  280. (do ((j 0 (+ j 3))
  281. (i 0 (+ i 2)))
  282. ((>= i n))
  283. (set! (num j ) 0.0)
  284. (set! (num (+ j 1)) 0.0)
  285. (set! (num (+ j 2)) 1.0)
  286. (set! (den j ) 1.0)
  287. (set! (den (+ j 1)) (* -2.0 (real-part (p i))))
  288. (set! (den (+ j 2)) (real-part (* (p i) (p (+ i 1)))))))
  289. (list num den))))
  290. (define make-bessel-lowpass
  291. (let ((documentation "(make-bessel-lowpass n fc) returns a lowpass Bessel filter; n = order, fc = cutoff freq (srate = 1.0): (make-bessel-lowpass 4 .1)"))
  292. (lambda (n fc)
  293. (if (odd? n) (set! n (+ n 1)))
  294. (let ((coeffs (let ((proto (bessel-prototype n)))
  295. (analog->digital n (car proto) (cadr proto) fc))))
  296. (make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
  297. (define make-bessel-highpass
  298. (let ((documentation "(make-bessel-highpass n fc) returns a highpass Bessel filter; n = order, fc = cutoff freq (srate = 1.0): (make-bessel-highpass 8 .1)"))
  299. (lambda* (n fc)
  300. (if (odd? n) (set! n (+ n 1)))
  301. (let ((coeffs (let ((hproto (prototype->highpass n (bessel-prototype n))))
  302. (analog->digital n (car hproto) (cadr hproto) fc))))
  303. (make-filter :xcoeffs (car coeffs) :ycoeffs (cadr coeffs))))))
  304. (define make-bessel-bandpass
  305. (let ((documentation "(make-bessel-bandpass n fl fh) returns a bandpass Bessel filter; n = order, fl and fh are edge freqs (srate=1.0): (make-bessel-bandpass 4 .1 .2)"))
  306. (lambda* (n fl fh)
  307. (if (odd? n) (set! n (+ n 1)))
  308. (let ((lp (make-bessel-lowpass n fh))
  309. (hp (make-bessel-highpass n fl)))
  310. (lambda (y)
  311. (filter lp (filter hp y)))))))
  312. (define make-bessel-bandstop
  313. (let ((documentation "(make-bessel-bandstop n fl fh) returns a bandstop Bessel filter; n = order, fl and fh are edge freqs (srate=1.0): (make-bessel-bandstop 8 .1 .2)"))
  314. (lambda* (n fl fh)
  315. (if (odd? n) (set! n (+ n 1)))
  316. (let ((lp (make-bessel-lowpass n fl))
  317. (hp (make-bessel-highpass n fh)))
  318. (lambda (y)
  319. (+ (filter lp y) (filter hp y)))))))
  320. ;;; ---------------- Elliptic ----------------
  321. (define* (elliptic-prototype n (ripple 1.0) (loss-dB 60.0))
  322. (define* (minimize-function f xmin xmax arg1 arg2)
  323. (let* ((n 20)
  324. (x (make-float-vector n))
  325. (fx (f xmin arg1 arg2)))
  326. (do ((i 0 (+ i 1)))
  327. ((= i n))
  328. (do ((step (/ (- xmax xmin) (- n 1.0)))
  329. (j 0 (+ j 1))
  330. (s xmin (+ s step)))
  331. ((= j (- n 1)))
  332. (float-vector-set! x j s))
  333. (set! (x (- n 1)) xmax)
  334. (do ((j 0 (+ j 1)))
  335. ((= j n))
  336. (let ((ft (f (x j) arg1 arg2)))
  337. (if (< ft fx)
  338. (begin
  339. (set! fx ft)
  340. (set! xmax (x (if (< j (- n 1)) (+ j 1) (- n 1))))
  341. (set! xmin (x (if (> j 0) (- j 1) 0))))))))
  342. (/ (+ xmax xmin) 2.0)))
  343. (define (findm m arg1 arg2)
  344. (abs (- (/ (gsl-ellipk m) (gsl-ellipk (- 1.0 m))) arg1)))
  345. (define (findv u arg1 arg2)
  346. (let ((vals (gsl-ellipj u arg1)))
  347. (abs (- arg2 (/ (car vals) (cadr vals))))))
  348. (let ((e (sqrt (- (expt 10.0 (* 0.1 ripple)) 1.0))))
  349. (let ((k1 (/ e (sqrt (- (expt 10.0 (* 0.1 loss-dB)) 1.0))))
  350. (len (/ (* n 3) 2)))
  351. (let ((k1p (sqrt (- 1.0 (* k1 k1))))
  352. (m 0.0)
  353. (num (make-float-vector len))
  354. (den (make-float-vector len))
  355. (g 1.0))
  356. (let ((eps 0.0000001)
  357. (kr 0.0))
  358. (if (> (abs (- 1.0 (* k1p k1p))) eps)
  359. (set! kr (* n (/ (gsl-ellipk (* k1 k1)) (gsl-ellipk (* k1p k1p))))))
  360. (set! m (minimize-function findm 0.001 0.999 kr)))
  361. (let ((k (gsl-ellipk m))
  362. (cv (make-float-vector (floor (* 0.5 3 (+ n 1))))))
  363. (do ((i 0 (+ i 2))
  364. (j 0 (+ j 3)))
  365. ((>= i n))
  366. (let ((vals (gsl-ellipj (/ (* (+ i 1) k) (* 1.0 n)) m)))
  367. (let ((sn (car vals))
  368. (cn (cadr vals))
  369. (dn (caddr vals)))
  370. (set! (cv j ) sn)
  371. (set! (cv (+ j 1)) cn)
  372. (set! (cv (+ j 2)) dn)
  373. (let* ((z (/ 0.0-i (* (sqrt m) sn)))
  374. (pz (real-part (* z (complex (real-part z) (- (imag-part z)))))))
  375. (set! g (/ g pz))
  376. (set! (num j ) 1.0)
  377. (set! (num (+ j 1)) (* -2.0 (real-part z)))
  378. (set! (num (+ j 2)) pz)))))
  379. (let ((vals (let ((v0 (let ((minf (minimize-function findv 0.0 (/ 1.0 e) (* k1p k1p) (/ 1.0 e))))
  380. (/ (* k minf)
  381. (* n (gsl-ellipk (* k k1)))))))
  382. (gsl-ellipj v0 (- 1.0 m)))))
  383. (do ((sn (car vals))
  384. (cn (cadr vals))
  385. (dn (caddr vals))
  386. (i 0 (+ i 2))
  387. (j 0 (+ j 3)))
  388. ((>= i n))
  389. (let* ((p (/ (- (+ (* (cv (+ j 1)) (cv (+ j 2)) sn cn)
  390. (* 0.0+i (cv j) dn)))
  391. (- 1.0 (* (cv (+ j 2)) sn
  392. (cv (+ j 2)) sn))))
  393. (pp (real-part (* p (complex (real-part p) (- (imag-part p)))))))
  394. (set! g (* g pp))
  395. (set! (den j ) 1.0)
  396. (set! (den (+ j 1)) (* -2.0 (real-part p)))
  397. (set! (den (+ j 2)) pp)))))
  398. (list num den (abs (/ g (sqrt (+ 1.0 (* e e))))))))))
  399. (define make-elliptic-lowpass
  400. (let ((documentation "(make-elliptic-lowpass n fc (ripple 1.0) (loss-dB 60.0)) returns a lowpass elliptic filter; n = order, \
  401. fc = cutoff freq (srate = 1.0): (make-elliptic-lowpass 8 .25 .01 90)"))
  402. (lambda* (n fc (ripple 1.0) (loss-dB 60.0))
  403. (if (odd? n) (set! n (+ n 1)))
  404. (let* ((proto (elliptic-prototype n ripple loss-dB))
  405. (coeffs (analog->digital n (car proto) (cadr proto) fc)))
  406. (make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
  407. (define make-elliptic-highpass
  408. (let ((documentation "(make-elliptic-highpass n fc (ripple 1.0) (loss-dB 60.0)) returns a highpass elliptic filter; n = order, \
  409. fc = cutoff freq (srate = 1.0): (make-elliptic-highpass 8 .25 .01 90)"))
  410. (lambda* (n fc (ripple 1.0) (loss-dB 60.0))
  411. (if (odd? n) (set! n (+ n 1)))
  412. (let* ((proto (elliptic-prototype n ripple loss-dB))
  413. (coeffs (let ((hproto (prototype->highpass n proto)))
  414. (analog->digital n (car hproto) (cadr hproto) fc))))
  415. (make-filter :xcoeffs (float-vector-scale! (car coeffs) (caddr proto)) :ycoeffs (cadr coeffs))))))
  416. (define make-elliptic-bandpass
  417. (let ((documentation "(make-elliptic-bandpass n fl fh (ripple 1.0) (loss-dB 60.0)) returns a bandpass elliptic filter; n = order, \
  418. fl and fh are edge freqs (srate=1.0): (make-elliptic-bandpass 6 .1 .2 .1 90)"))
  419. (lambda* (n fl fh (ripple 1.0) (loss-dB 60.0))
  420. (if (odd? n) (set! n (+ n 1)))
  421. (let ((lp (make-elliptic-lowpass n fh ripple loss-dB))
  422. (hp (make-elliptic-highpass n fl ripple loss-dB)))
  423. (lambda (y)
  424. (filter lp (filter hp y)))))))
  425. (define make-elliptic-bandstop
  426. (let ((documentation "(make-elliptic-bandstop n fl fh (ripple 1.0) (loss-dB 60.0)) returns a bandstop elliptic filter; n = order, \
  427. fl and fh are edge freqs (srate=1.0): (make-elliptic-bandstop 6 .1 .2 .1 90)"))
  428. (lambda* (n fl fh (ripple 1.0) (loss-dB 60.0))
  429. (if (odd? n) (set! n (+ n 1)))
  430. (let ((lp (make-elliptic-lowpass n fl ripple loss-dB))
  431. (hp (make-elliptic-highpass n fh ripple loss-dB)))
  432. (lambda (y)
  433. (+ (filter lp y) (filter hp y)))))))