diff --git a/DSP/Basic.hs b/DSP/Basic.hs new file mode 100644 --- /dev/null +++ b/DSP/Basic.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Basic +-- Copyright : (c) Matthew Donadio 1998 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Basic functions for manipulating signals +-- +----------------------------------------------------------------------------- + +module DSP.Basic where + +import Data.Array + +import DSP.Source.Basic + +-- * Functions + +-- | @z@ is the unit delay function, eg, +-- +-- @z [ 1, 2, 3 ] == [ 0, 1, 2, 3 ]@ + +z :: (Num a) => [a] -> [a] +z a = 0 : a + +-- | zn is the n sample delay function, eg, +-- +-- @zn 3 [ 1, 2, 3 ] == [ 0, 0, 0, 1, 2, 3 ]@ + +zn :: (Num a) => Int -> [a] -> [a] +zn 0 a = a +zn n a = 0 : zn (n - 1) a + +-- | @downsample@ throws away every n'th sample, eg, +-- +-- @downsample 2 [ 1, 2, 3, 4, 5, 6 ] == [ 1, 3, 5 ]@ + +downsample :: (Num a) => Int -> [a] -> [a] +downsample n [] = [] +downsample n (x:xs) = x : downsample n (drop (n - 1) xs) + +-- | @upsample@ inserts n-1 zeros between each sample, eg, +-- +-- @upsample 2 [ 1, 2, 3 ] == [ 1, 0, 2, 0, 3, 0 ]@ + +upsample :: (Num a) => Int -> [a] -> [a] +upsample _ [] = [] +upsample n (x:xs) = x : zero n n xs + where zero n 1 xs = upsample n xs + zero n i xs = 0 : zero n (i-1) xs + +-- | @upsampleAndHold@ replicates each sample n times, eg, +-- +-- @upsampleAndHold 3 [ 1, 2, 3 ] == [ 1, 1, 1, 2, 2, 2, 3, 3, 3 ]@ + +upsampleAndHold :: (Num a) => Int -> [a] -> [a] +upsampleAndHold n xs = hold' n n xs + where hold' _ _ [] = [] + hold' n 1 (x:xs) = x : hold' n n xs + hold' n i (x:xs) = x : hold' n (i-1) (x:xs) + +-- | pad a sequence with zeros to length n +-- +-- @pad [ 1, 2, 3 ] 6 == [ 1, 2, 3, 0, 0, 0 ]@ + +pad :: (Ix a, Integral a, Num b) => Array a b -> a -> Array a b +pad x n = listArray (0,n-1) $ elems x ++ zeros diff --git a/DSP/Convolution.hs b/DSP/Convolution.hs new file mode 100644 --- /dev/null +++ b/DSP/Convolution.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Convolution +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module to perform the linear convolution of two sequences +-- +----------------------------------------------------------------------------- + +module DSP.Convolution (conv) where + +import Data.Array + +-- * Functions + +-- | @conv@ convolves two finite sequences + +conv :: (Ix a, Integral a, Num b) => Array a b -> Array a b -> Array a b +conv h1 h2 = h3 + where m1 = snd $ bounds h1 + m2 = snd $ bounds h2 + m3 = m1 + m2 + h3 = listArray (0,m3) [ sum [ h1!k * h2!(n-k) | k <- [max 0 (n-m2)..min n m1] ] | n <- [0..m3] ] + +-- Test vectors. Linear convolution is also equivalent to polynomial +-- multiplication. + +h1 = listArray (0,3) [ 1, 2, 3, 4 ] +h2 = listArray (0,4) [ 1, 2, 3, 4, 5 ] +h3 = listArray (0,7) [ 1, 4, 10, 20, 30, 34, 31, 20 ] diff --git a/DSP/Correlation.hs b/DSP/Correlation.hs new file mode 100644 --- /dev/null +++ b/DSP/Correlation.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Correlation +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains routines to perform cross- and auto-correlation. +-- These formulas can be found in most DSP textbooks. +-- +-- In the following routines, x and y are assumed to be of the same +-- length. +-- +----------------------------------------------------------------------------- + +module DSP.Correlation (rxy, rxy_b, rxy_u, rxx, rxx_b, rxx_u) where + +import Data.Array +import Data.Complex + +-- * Functions + +-- TODO: fix these routines to handle the case were x and y are different +-- lengths. + +-- | raw cross-correllation + +rxy :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> Array a (Complex b) -- ^ y + -> a -- ^ k + -> Complex b -- ^ R_xy[k] + +rxy x y k | k >= 0 = sum [ x!(i+k) * (conjugate (y!i)) | i <- [0..(n-1-k)] ] + | k < 0 = conjugate (rxy y x (-k)) + where n = snd (bounds x) + 1 + +-- | biased cross-correllation + +rxy_b :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> Array a (Complex b) -- ^ y + -> a -- ^ k + -> Complex b -- ^ R_xy[k] \/ N + +rxy_b x y k = (rxy x y k) / (fromIntegral n) + where n = snd (bounds x) + 1 + +-- | unbiased cross-correllation + +rxy_u :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> Array a (Complex b) -- ^ y + -> a -- ^ k + -> Complex b -- ^ R_xy[k] \/ (N-k) + +rxy_u x y k = (rxy x y k) / (fromIntegral (n-(abs k))) + where n = snd (bounds x) + 1 + +-- autocorrellation + +-- We define autocorrelation in terms of the cross correlation routines. + +-- | raw auto-correllation + +rxx :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ k + -> Complex b -- ^ R_xx[k] + +rxx x k = rxy x x k + +-- | biased auto-correllation + +rxx_b :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ k + -> Complex b -- ^ R_xx[k] \/ N + +rxx_b x k = rxy_b x x k + +-- | unbiased auto-correllation + +rxx_u :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ k + -> Complex b -- ^ R_xx[k] \/ (N-k) + +rxx_u x k = rxy_u x x k + +---------------------------------------------------------------------------- +-- test routines +---------------------------------------------------------------------------- + +x = array (0,4) [ (0, 1 :+ 0), + (1, 0 :+ 1), + (2, (-1) :+ 0), + (3, 0 :+ (-1)), + (4, 1 :+ 0) ] + +y = array (0,4) [ (0, 1 :+ 0), + (1, (-1) :+ 0), + (2, 1 :+ 0), + (3, (-1) :+ 0), + (4, 1 :+ 0) ] + +r = map (rxy_b x y) [ 0, 1, 2 ] + +verify = r == [ (0.2 :+ 0.0), (0.0 :+ 0.0), (0.0 :+ 0.2) ] diff --git a/DSP/Covariance.hs b/DSP/Covariance.hs new file mode 100644 --- /dev/null +++ b/DSP/Covariance.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Covariance +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains routines to perform cross- and auto-covariance +-- These formulas can be found in most DSP textbooks. +-- +-- In the following routines, x and y are assumed to be of the same +-- length. +-- +----------------------------------------------------------------------------- + + +-- TODO: fix these routines to handle the case were x and y are different +-- lengths. + +-- TODO: Cxx(X) = Var(X), but I'm not sure how the lag works into that + +module DSP.Covariance (cxy, cxy_b, cxy_u, cxx, cxx_b, cxx_u) where + +import Data.Array +import Data.Complex + +import DSP.Correlation +import Numeric.Statistics.Moment + +-- | raw cross-covariance +-- +-- We define covariance in terms of correlation. +-- +-- Cxy(X,Y) = E[(X - E[X])(Y - E[Y])] +-- = E[XY] - E[X]E[Y] +-- = Rxy(X,Y) - E[X]E[Y] + +-- cxy x y k | k >= 0 = sum [ (x!(i+k) - xm) * ((conjugate (y!i)) - ym) | i <- [0..(n-1-k)] ] + +cxy :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> Array a (Complex b) -- ^ y + -> a -- ^ k + -> Complex b -- ^ C_xy[k] + +cxy x y k | k >= 0 = rxy x y k - xm * ym + | k < 0 = conjugate (cxy y x (-k)) + where xm = mean (elems x) + ym = mean (map conjugate (elems y)) + n = snd (bounds x) + 1 + +-- | raw auto-covariance +-- +-- Cxx(X,X) = E[(X - E[X])(X - E[X])] +-- = E[XX] - E[X]E[X] +-- = Rxy(X,X) - E[X]^2 + +-- We define this explicitly to prevent the mean from being calculated +-- twice. + +-- cxx x k | k >= 0 = sum [ (x!(i+k) - xm) * (conjugate (x!i - xm)) | i <- [0..(n-1-k)] ] + +cxx :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ k + -> Complex b -- ^ C_xx[k] + +cxx x k | k >= 0 = rxx x k - xm^2 + | k < 0 = conjugate (cxx x (-k)) + where xm = mean (elems x) + n = snd (bounds x) + 1 + +-- Define the biased and unbiased versions in terms of the above. + +-- | biased cross-covariance + +cxy_b :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> Array a (Complex b) -- ^ y + -> a -- ^ k + -> Complex b -- ^ C_xy[k] \/ N + +cxy_b x y k = (cxy x y k) / (fromIntegral n) + where n = snd (bounds x) + 1 + +-- | unbiased cross-covariance + +cxy_u :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> Array a (Complex b) -- ^ y + -> a -- ^ k + -> Complex b -- ^ C_xy[k] \/ (N-k) + +cxy_u x y k = (cxy x y k) / (fromIntegral (n-(abs k))) + where n = snd (bounds x) + 1 + +-- | biased auto-covariance + +cxx_b :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ k + -> Complex b -- ^ C_xx[k] \/ N + +cxx_b x k = (cxx x k) / (fromIntegral n) + where n = snd (bounds x) + 1 + +-- | unbiased auto-covariance + +cxx_u :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ k + -> Complex b -- ^ C_xx[k] \/ (N-k) + +cxx_u x k = (cxx x k) / (fromIntegral (n-(abs k))) + where n = snd (bounds x) + 1 diff --git a/DSP/Estimation/Frequency/FCI.hs b/DSP/Estimation/Frequency/FCI.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Frequency/FCI.hs @@ -0,0 +1,121 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Frequency.FCI +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains a few simple algorithms for interpolating the +-- peak location of a DFT\/FFT. +-- +----------------------------------------------------------------------------- + +-- TODO: confirm that quinn2 needs log10 and not ln + +module DSP.Estimation.Frequency.FCI (quinn1, quinn2, quinn3, jacobsen, macleod3, macleod5, rv) where + +import Data.Array +import Data.Complex + +log10 x = log x / log 10 + +-- | Quinn's First Estimator (FCI1) + +quinn1 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +quinn1 x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where d | dp > 0 && dm > 0 = dp + | otherwise = dm + dp = -ap / (1 - ap) + dm = am / (1 - am) + ap = magnitude (x!(k+1)) / magnitude (x!k) + am = magnitude (x!(k-1)) / magnitude (x!k) + n = snd (bounds x) + 1 + +-- | Quinn's Second Estimator (FCI2) + +quinn2 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +quinn2 x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where d = (dp + dm) / 2 + tau(dp^2) - tau(dm^2) + dp = -ap / (1 - ap) + dm = am / (1 - am) + ap = magnitude (x!(k+1)) / magnitude (x!k) + am = magnitude (x!(k-1)) / magnitude (x!k) + tau x = 0.25 * log10(3*x^2 + 6 * x + 1) - (sqrt 6) / 24 * log10 ((x + 1 - sqrt (2/3)) / (x + 1 + sqrt (2/3))) + n = snd (bounds x) + 1 + +-- | Quinn's Third Estimator (FCI3) + +quinn3 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +quinn3 x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where d = (dm + dp) / 2 + (dp - dm) * (3*dt^3 + 2*dt) / (3*dt^4+6*dt^2+1) + dt | dm > 0 && dp > 0 = dp + | otherwise = dm + dp = -ap / (1 - ap) + dm = am / (1 - am) + ap = magnitude (x!(k+1)) / magnitude (x!k) + am = magnitude (x!(k-1)) / magnitude (x!k) + n = snd (bounds x) + 1 + +-- | Eric Jacobsen's Estimator + +jacobsen :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +jacobsen x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where d = realPart ((x!(k-1) - x!(k+1)) / (2 * x!k - x!(k-1) - x!(k+1))) + n = snd (bounds x) + 1 + +-- | MacLeod's Three Point Estimator + +macleod3 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +macleod3 x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where rm1 = realPart (x!(k-1) * conjugate (x!k)) + r = realPart (x!k * conjugate (x!k)) + rp1 = realPart (x!(k+1) * conjugate (x!k)) + d = (sqrt (1 + 8 * g^2) - 1) / 4 / g + g = (rm1 - rp1) / (2 * r + rm1 + rp1) + n = snd (bounds x) + 1 + +-- | MacLeod's Three Point Estimator + +macleod5 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +macleod5 x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where rm2 = realPart (x!(k-2) * conjugate (x!k)) + rm1 = realPart (x!(k-1) * conjugate (x!k)) + r = realPart (x!k * conjugate (x!k)) + rp1 = realPart (x!(k+1) * conjugate (x!k)) + rp2 = realPart (x!(k+2) * conjugate (x!k)) + d = 0.4041 * atan (2.93 * g) + g = (4 * (rm1 - rp1) + 2 * (rm2 - rp2)) / (12 * r + 8 * (rm1 + rp1) + rm2 + rp2) + n = snd (bounds x) + 1 + +-- | Rife and Vincent's Estimator + +rv :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +rv x k = 2 * pi * ((fromIntegral k) + d) / (fromIntegral n) + where d = fromIntegral at * magnitude (x!(k+at) / x!k) / (1 + magnitude (x!(k+at) / x!k)) + at | (magnitude (x!(k+1)))^2 > (magnitude (x!(k-1)))^2 = 1 + | otherwise = -1 + n = snd (bounds x) + 1 diff --git a/DSP/Estimation/Frequency/PerMax.hs b/DSP/Estimation/Frequency/PerMax.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Frequency/PerMax.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Frequency.PerMax +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module implements an algorithm to maximize the peak value of a +-- DFT\/FFT. It is based off an aticle by Mark Sullivan from Personal +-- Engineering Magazine. +-- +-- Maximizes +-- +-- @S(w) = 1\/N * sum(k=0,N-1) |x[k] * e^(-jwk)|^2@ +-- +-- which is equivalent to solving +-- +-- @S'(w) = Im{X(w) * ~Y(w)} = 0@ +-- +-- where +-- +-- @X(w) = sum(k=0,N-1) (x[k] * e^(-jwk))@ +-- @Y(w) = X'(w) = sum(k=0,N-1) (k * x[k] * e^(-jwk))@ +-- +-- This algorithm used the bisection method for finding the zero of a +-- function. The search area is +- half a bin width. +-- +-- Regula falsi requires an additional (x,f(x)) pair which is expensive +-- in this case. Newton's method could be used but requires S''(w), +-- which takes twice as long to caculate as S'(w). Brent's method may be +-- best here, but it also requires three (x,f(x)) pairs +-- +----------------------------------------------------------------------------- + +module DSP.Estimation.Frequency.PerMax (permax) where + +import Data.Array +import Data.Complex + +-- TODO: could we use sinc interpolation instead of calc_x,calc_y for +-- the off-bin values? + +-- TODO: the twiddle factor in calc_x,calc_y can be computed +-- recursively + +-- TODO: the twiddle factor in calc_x,calc_y can be shared + +sign x | x < 0 = -1 + | x == 0 = 0 + | x > 0 = 1 + +-- calc_x x w = sum [ x!k * cis (-w * fromIntegral k) | k <- [0..(n-1)] ] +-- where n = snd (bounds x) + 1 + +calc_x x w = sum $ zipWith (*) (elems x) (iterate (cis (-w) *) 1) + +calc_y x w = sum [ fromIntegral k * x!k * cis (-w * fromIntegral k) | k <- [0..(n-1)] ] + where n = snd (bounds x) + 1 + +-- | Discrete frequency periodigram maximizer + +permax :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> a -- ^ k + -> b -- ^ w + +permax x k = permax' x (w-d) (w+d) + where w = 2 * pi * fromIntegral k / fromIntegral n + d = 1 / fromIntegral (2*n) -- half a bin width + n = snd (bounds x) + 1 + +permax' x w0 w1 | w1-w0 < eps = wmid + | otherwise = if sign t0 == sign tm + then permax' x wmid w1 + else permax' x w0 wmid + where t0 = imagPart ((calc_x x w0) * (conjugate (calc_y x w0))) + tm = imagPart ((calc_x x wmid) * (conjugate (calc_y x wmid))) + t1 = imagPart ((calc_x x w1) * (conjugate (calc_y x w1))) + wmid = (w0 + w1) / 2 -- bisection method +-- wmid = w1 - t1 * (w1 - w0) / (t1 - t0) -- regula falsi + eps = 1.0e-6 + n = snd (bounds x) + 1 diff --git a/DSP/Estimation/Frequency/Pisarenko.hs b/DSP/Estimation/Frequency/Pisarenko.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Frequency/Pisarenko.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Pisarenko +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains an implementation of Pisarenko Harmonic +-- Decomposition for a single real sinusoid. For this case, eigenvalues +-- do not need to be computed. +-- +----------------------------------------------------------------------------- + +-- This implmentation is based off of a Matlab version by Peter +-- Kootsookos (p.kootsookos@ieee.org). + +module DSP.Estimation.Frequency.Pisarenko (pisarenko) where + +import Data.Array + +rss x k = sum [ x!(i+k) * x!i | i <- [0..(n-1-k)] ] + where n = snd (bounds x) + 1 + +-- | Pisarenko's method for a single sinusoid + +pisarenko :: (Ix a, Integral a, Floating b) => Array a b -- ^ x + -> b -- ^ w + +pisarenko x = acos (alpha / 2) + where alpha = (rss2 + sqrt (rss2^2 + 8*rss1^2)) / (rss1 + eps) / 2 + rss1 = rss x 1 + rss2 = rss x 2 + eps = 1.0e-15 diff --git a/DSP/Estimation/Frequency/QuinnFernandes.hs b/DSP/Estimation/Frequency/QuinnFernandes.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Frequency/QuinnFernandes.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Frequency.QuinnFernandes +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This is an implementation of the Quinn-Fernandes algorithm for +-- estimating the frequency of a real sinusoid in noise. +-- +----------------------------------------------------------------------------- + +module DSP.Estimation.Frequency.QuinnFernandes (qf) where + +import Data.Array + +-- | The Quinn-Fernandes algorithm + +qf :: (Ix a, Integral a, RealFloat b) => Array a b -- ^ y + -> b -- ^ initial w estimate + -> b -- ^ w + +qf y w = qf' y (2 * cos w) + +qf' y a | abs (a-b) < eps = acos(0.5 * b) + | otherwise = qf' y b + where z = array (-2,n-1) ([ (-2, 0), (-1, 0) ] ++ [ (i, y!i + a * z!(i-1) - z!(i-2)) | i <- [0..(n-1)] ]) + b = sum [ (z!i + z!(i-2)) * z!(i-1) | i <- [0..(n-1)] ] / sum [ (z!(i-1))^2 | i <- [0..(n-1)] ] + eps = 1.0e-6 + n = snd (bounds y) + 1 diff --git a/DSP/Estimation/Frequency/WLP.hs b/DSP/Estimation/Frequency/WLP.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Frequency/WLP.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Frequency.WLP +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains a few algorithms for weighted linear predictors +-- for estimating the frequency of a complex sinusoid in noise. +-- +----------------------------------------------------------------------------- + +-- Boy, fromIntegral makes these look really messy. + +module DSP.Estimation.Frequency.WLP where + +import Data.Array +import Data.Complex + +-- | The weighted linear predictor form of the frequency estimator + +wlp :: (Ix a, Integral a, RealFloat b) => Array a b -- ^ window + -> Array a (Complex b) -- ^ z + -> b -- ^ w + +wlp w z = phase (sum [ (w!t :+ 0) * z!t * conjugate (z!(t-1)) | t <- [1..(n-1)] ]) + where n = snd (bounds z) + 1 + +-- | WLP using Lank, Reed, and Pollon's window + +lrp :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ z + -> b -- ^ w + +lrp z = wlp (array (1,n-1) [ (t, 1 / fromIntegral (n-1)) | t <- [1..(n-1)] ]) z + where n = snd (bounds z) + 1 + +-- | WLP using kay's window + +kay :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ z + -> b -- ^ w + +kay z = wlp (array (1,n-1) [ (t, fromIntegral (6*t*(n-t)) / fromIntegral (n*(n^2-1))) | t <- [1..(n-1)] ]) z + where n = snd (bounds z) + 1 + +-- | WLP using Lovell and Williamson's window + +lw :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ z + -> b -- ^ w + +lw z = wlp (array (1,n-1) [ (t, fromIntegral (6*t*(n-t)) / (fromIntegral (n*(n^2-1)) * magnitude (z!t) * magnitude (conjugate (z!(t-1))))) | t <- [1..(n-1)] ]) z + where n = snd (bounds z) + 1 + +-- | WLP using Clarkson, Kootsookos, and Quinn's window + +ckq :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ z + -> b -- ^ rho + -> b -- ^ sigma + -> b -- ^ w + +ckq z rho sig = wlp (array (1,n-1) [ (t, num t / den) | t <- [1..(n-1)] ]) z + where num t = sinh (fromIntegral n * th) - sinh (fromIntegral t * th) - sinh (fromIntegral (n-t) * th) + den = fromIntegral (n-1) * sinh (fromIntegral n * th) - 2 * sinh (0.5 * fromIntegral n * th) * sinh (0.5 * fromIntegral (n-1) * th) / sinh (0.5 * th) + th = log (1 + sig^2 / rho^2 + sqrt (sig^4 / rho^4 + sig^2 / rho^2)) + n = snd (bounds z) + 1 diff --git a/DSP/Estimation/Spectral/AR.hs b/DSP/Estimation/Spectral/AR.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Spectral/AR.hs @@ -0,0 +1,122 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Spectral.AR +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains a few algorithms for AR parameter estimation. +-- Algorithms are taken from Steven M. Kay, /Modern Spectral Estimation: +-- Theory and Application/, which is one of the standard texts on the +-- subject. When possible, variable conventions are the same in the code +-- as they are found in the text. +-- +----------------------------------------------------------------------------- + +module DSP.Estimation.Spectral.AR where + +import Data.Array +import Data.Complex + +import DSP.Correlation +import Matrix.Levinson +import Matrix.Cholesky + +-- * Functions + +------------------------------------------------------------------------------- +-- ar_yw x p +------------------------------------------------------------------------------- + +-- Section 7.3 in Kay + +-- | Computes an AR(p) model estimate from x using the Yule-Walker method + +ar_yw :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ p + -> (Array a (Complex b), b) -- ^ (a,rho) + +ar_yw x p = levinson r p + where r = array (0,p) [ (k, rxx_b x k) | k <- [0..p] ] + +------------------------------------------------------------------------------- +-- ar_cov x p +------------------------------------------------------------------------------- + +-- Section 7.4 in Kay, but I factored out the 1/(N-p) term, and only +-- generate the lower triangle of cxx + +-- TODO: use modified Prony method instead of matrix solver + +-- | Computes an AR(p) model estimate from x using the covariance method + +ar_cov :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ p + -> (Array a (Complex b), b) -- ^ (a,rho) + +ar_cov x p = (a, sig2 / (fromIntegral (n-p))) + where a = cholesky m v + sig2 = realPart ((cxx 0 0) + sum [ a!k * (cxx 0 k) | k <- [1..p] ]) + m = array ((1,1),(p,p)) [ ((j,k), cxx j k) | j <- [1..p], k <- [1..j] ] + v = array (1,p) [ (j, -(cxx j 0)) | j <- [1..p] ] + cxx j k = sum [ (conjugate (x!(i-j))) * x!(i-k) | i <- [p..(n-1)] ] + n = snd (bounds x) + 1 + +------------------------------------------------------------------------------- +-- ar_mcov x p +------------------------------------------------------------------------------- + +-- Section 7.5 in Kay, but I factored out the 1/(2(N-p)) term, and only +-- generate the lower triangle of cxx + +-- | Computes an AR(p) model estimate from x using the modified covariance method + +ar_mcov :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ p + -> (Array a (Complex b), b) -- ^ (a,rho) + +ar_mcov x p = (a, sig2 / (fromIntegral (2*(n-p)))) + where a = cholesky m v + sig2 = realPart ((cxx 0 0) + sum [ a!k * (cxx 0 k) | k <- [1..p] ]) + m = array ((1,1),(p,p)) [ ((j,k), cxx j k) | j <- [1..p], k <- [1..j] ] + v = array (1,p) [ (j, -(cxx j 0)) | j <- [1..p] ] + cxx j k = (sum [ (conjugate (x!(i-j))) * x!(i-k) | i <- [p..(n-1)] ] + sum [ x!(i+j) * (conjugate (x!(i+k))) | i <- [0..(n-1-p)] ]) + n = snd (bounds x) + 1 + +------------------------------------------------------------------------------- +-- ar_burg x p +------------------------------------------------------------------------------- + +-- Section 7.6 in Kay + +-- TODO: rho doesn't need to be an array +-- TODO: kk doesn't need to be an array +-- TODO: ef and eb don't need to be 2-D arrays + +-- | Computes an AR(p) model estimate from x using the Burg' method + +ar_burg :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ p + -> (Array a (Complex b), b) -- ^ (a,rho) + +ar_burg x p = (array (1,p) [ (k, a!(p,k)) | k <- [1..p] ], realPart (rho!p)) + where a = array ((1,1),(p,p)) [ ((k,i), ak k i) | k <- [1..p], i <- [1..k] ] + ak k i | i==k = kk!k + | otherwise = a!(k-1,i) + kk!k * (conjugate (a!(k-1,k-i))) + kk = array (1,p) [ (k, -2 * sum [ ef!((k-1),i) * (conjugate (eb!(k-1,i-1))) | i <- [k..(n-1)] ] / sum [ (abs (ef!(k-1,i)))^2 + (abs (eb!(k-1,i-1)))^2 | i <- [k..(n-1)] ]) | k <- [1..p] ] + rho = array (0,p) ((0, rxx_b x 0) : [ (k, (1 - ((abs (kk!k))^2)) * rho!(k-1)) | k <- [1..p] ]) + ef = array ((0,1),(p,n-1)) [ ((k,i), efki k i) | k <- [0..p], i <- [(k+1)..(n-1)] ] + eb = array ((0,0),(p,n-2)) [ ((k,i), ebki k i) | k <- [0..p], i <- [k..(n-2)] ] + efki 0 i = x!i + efki k i = ef!(k-1,i) + kk!k * eb!(k-1,i-1) + ebki 0 i = x!i + ebki k i = eb!(k-1,i-1) + (conjugate (kk!k)) * ef!(k-1,i) + n = snd (bounds x) + 1 + +------------------------------------------------------------------------------- +-- ar_rmle x p +------------------------------------------------------------------------------- + diff --git a/DSP/Estimation/Spectral/ARMA.hs b/DSP/Estimation/Spectral/ARMA.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Spectral/ARMA.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Spectral.ARMA +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains a few algorithms for ARMA parameter estimation. +-- Algorithms are taken from Steven M. Kay, _Modern Spectral Estimation: +-- Theory and Application_, which is one of the standard texts on the +-- subject. When possible, variable conventions are the same in the code +-- as they are found in the text. +-- +-- BROKEN: DO NOT USE +-- +----------------------------------------------------------------------------- + +module DSP.Estimation.Spectral.ARMA (arma_mywe) where + +import Data.Array +import Data.Complex + +import DSP.Correlation +import DSP.Estimation.Spectral.MA + +import Matrix.LU + +-- * Functions + +-- THIS DOES NOT WORK + +arma_mywe x p q = a' + where r = array (q-2*p+1,q+p) [ (k, rxx_u x k) | k <- [(q-2*p+1)..(q+p)] ] + a' = array (1,p) [ (k, a!(p,k)) | k <- [1..p] ] + a = array ((1,1),(p,p)) [ ((k,i), ak k i) | k <- [1..p], i <- [1..k] ] + b = array ((1,1),(p-1,p-1)) [ ((k,i), bk k i) | k <- [1..(p-1)], i <- [1..k] ] + rho = array (1,p-1) [ (k, rhok k) | k <- [1..(p-1)] ] + ak 1 1 = -r!(q+1) / r!q + ak k i | i==k = -(r!(q+k) + sum [ a!(k-1,l) * r!(q+k-l) | l <- [1..(k-1)] ] ) / rho!(k-1) + | otherwise = a!(k-1,i) + a!(k,k) * b!(k-1,k-i) + bk 1 1 = -r!(q-1) / r!q + bk k i | i==k = -(r!(q-k) + sum [ b!(k-1,l) * r!(q-k-l) | l <- [1..(k-1)] ] ) / rho!(k-1) + | otherwise = b!(k-1,i) + b!(k,k) * a!(k-1,k-i) + rhok 1 = (1 - a!(1,1) * b!(1,1)) * r!q + rhok k = (1 - a!(k,k) * b!(k,k)) * rho!(k-1) diff --git a/DSP/Estimation/Spectral/KayData.hs b/DSP/Estimation/Spectral/KayData.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Spectral/KayData.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Spectral.KayData +-- Copyright : (c) Matthew Donadio 2002 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Test vectors from Kay, /Modern Spectral Estimation/ +-- +----------------------------------------------------------------------------- + +module DSP.Estimation.Spectral.KayData (xc,xr) where + +import Data.Array +import Data.Complex + +-- | Complex test data + +xc :: Array Int (Complex Double) +xc = array (0,31) [ (0, (( 6.3307) :+ (-0.174915))), + (1, ((-1.33539) :+ (-0.03044))), + (2, (( 3.61896) :+ (-0.260459))), + (3, (( 1.87513) :+ (-0.323974))), + (4, ((-1.08561) :+ (-0.136055))), + (5, (( 3.99114) :+ (-0.101864))), + (6, ((-4.10184) :+ ( 0.130571))), + (7, (( 1.55399) :+ ( 0.0977916))), + (8, ((-2.1258) :+ (-0.306485))), + (9, ((-3.27873) :+ (-0.0544436))), + (10, (( 0.241218) :+ ( 0.0962379))), + (11, ((-5.74708 ) :+ ( 0.0186908))), + (12, ((-0.0165977) :+ ( 0.237493))), + (13, ((-3.28921) :+ (-0.188478))), + (14, ((-1.31227) :+ (-0.120636))), + (15, (( 0.745251) :+ (-0.0679575))), + (16, ((-1.77199) :+ (-0.416229))), + (17, (( 2.56419) :+ (-0.270373))), + (18, (( 0.21325) :+ (-0.232544))), + (19, (( 2.23409) :+ ( 0.236383))), + (20, (( 2.2949) :+ ( 0.173061))), + (21, (( 1.09186) :+ ( 0.140938))), + (22, (( 2.29353) :+ ( 0.442044))), + (23, (( 0.695823) :+ ( 0.509325))), + (24, (( 0.759858) :+ ( 0.417967))), + (25, ((-0.354267) :+ ( 0.506891))), + (26, ((-0.594517) :+ ( 0.39708))), + (27, ((-1.88618) :+ ( 0.649179))), + (28, ((-1.39041) :+ ( 0.867086))), + (29, ((-3.06381) :+ ( 0.422965))), + (30, ((-2.0433) :+ ( 0.0825514))), + (31, ((-2.1628) :+ (-0.0933218))) ] +-- | Real test data + +xr :: Array Int Double +xr = array (0,31) [ (0, 6.46768), + (1, -1.28024), + (2, 3.74788), + (3, 1.96092), + (4, -0.768349), + (5, 4.14569), + (6, -4.05277), + (7, 1.65836), + (8, -2.06405), + (9, -3.33397), + (10, 0.085145), + (11, -6.06562), + (12, -0.411658), + (13, -3.61831), + (14, -1.53352), + (15, 0.481522), + (16, -1.93653), + (17, 2.35532), + (18, 0.145624), + (19, 2.21991), + (20, 2.25884), + (21, 1.07373), + (22, 2.26531), + (23, 0.685007), + (24, 0.762859), + (25, -0.501008), + (26, -0.640518), + (27, -1.99263), + (28, -1.60416), + (29, -3.22751), + (30, -2.21946), + (31, -2.42246) ] diff --git a/DSP/Estimation/Spectral/MA.hs b/DSP/Estimation/Spectral/MA.hs new file mode 100644 --- /dev/null +++ b/DSP/Estimation/Spectral/MA.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Estimation.Spectral.MA +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains one algorithm for MA parameter estimation. It +-- is taken from Steven M. Kay, _Modern Spectral Estimation: Theory and +-- Application_, which is one of the standard texts on the subject. When +-- possible, variable conventions are the same in the code as they are +-- found in the text. +-- +----------------------------------------------------------------------------- + + +module DSP.Estimation.Spectral.MA (ma_durbin) where + +import Data.Array +import Data.Complex + +import DSP.Estimation.Spectral.AR + +-- * Functions + +------------------------------------------------------------------------------- +-- ma_durbin x q l +------------------------------------------------------------------------------- + +-- Section 8.4 in Kay + +-- | Computes an MA(q) model estimate from x using the Durbin's method +-- where l is the order of the AR process used in the algorithm + +ma_durbin :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x + -> a -- ^ q + -> a -- ^ l + -> (Array a (Complex b), b) -- ^ (a,rho) + +ma_durbin x q l = (b, sig2) + where (b,_) = ar_yw a' q + a' = array (0,l) ((0,1) : [ (i, a''!i) | i <- [1..l] ]) + (a'', sig2) = ar_yw x l + n = snd (bounds x) + 1 diff --git a/DSP/FastConvolution.hs b/DSP/FastConvolution.hs new file mode 100644 --- /dev/null +++ b/DSP/FastConvolution.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.FastConvolution +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module to perform fast linear convolution of two sequences +-- +----------------------------------------------------------------------------- + +module DSP.FastConvolution (fast_conv) where + +import Data.Array +import Data.Complex + +import Numeric.Transform.Fourier.FFT + +-- * Functions + +-- | @fast_conv@ convolves two finite sequences using DFT relationships + +fast_conv :: (RealFloat b) => Array Int (Complex b) -> Array Int (Complex b) -> Array Int (Complex b) +fast_conv h1 h2 = h3 + where m1 = snd $ bounds h1 + m2 = snd $ bounds h2 + m3 = m1 + m2 + h1' = fft $ listArray (0,m3) $ elems h1 ++ replicate m2 0 + h2' = fft $ listArray (0,m3) $ elems h2 ++ replicate m1 0 + h3' = listArray (0,m3) $ zipWith (*) (elems h1') (elems h2') + h3 = ifft h3' diff --git a/DSP/Filter/Analog/Prototype.hs b/DSP/Filter/Analog/Prototype.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/Analog/Prototype.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.Analog.Prototype +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module for generating analog filter prototypes +-- +----------------------------------------------------------------------------- + +-- Notes (mainly for self): + +-- The gain of an analog filter is + +-- gain = abs $ realPart $ product zeros / product poles +-- = abs $ b_m / a_n + +-- For a Butterworth filter, the product of the poles is one, so we don't +-- have to worry about any gain. + +-- For a Chebyshev 1 filter, the product of the poles is a_n, which is +-- the head of the polynomial. We make this b_0 to set the gain in the +-- passband. + +-- For a Chebyshev 2 filter, we use the full gain formula because we want +-- to set the gain to unity at DC. + +-- TODO: Do we want to include Bessel filters? + +module DSP.Filter.Analog.Prototype where + +import Data.Complex + +import Polynomial.Basic + +-- | Generates Butterworth filter prototype + +butterworth :: Int -- ^ N + -> ([Double],[Double]) -- ^ (b,a) + +butterworth n = (num, den) + where poles = [ (-u k) :+ (w k) | k <- [0..(n-1)] ] + u k = sin (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + w k = cos (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + num = [ 1 ] + den = map realPart $ roots2poly $ poles + +-- | Generates Chebyshev filter prototype + +chebyshev1 :: Double -- ^ epsilon + -> Int -- ^ N + -> ([Double],[Double]) -- ^ (b,a) + +chebyshev1 eps n = (num, den) + where poles = [ (-u k) :+ (w k) | k <- [0..(n-1)] ] + u k = sinh v0 * sin (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + w k = cosh v0 * cos (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + num = [ gain ] + den = map realPart $ roots2poly $ poles + v0 = asinh (1/eps) / fromIntegral n + gain | even n = abs $ head den / sqrt (1 + eps^2) + | odd n = abs $ head den + +-- | Generates Inverse Chebyshev filter prototype + +chebyshev2 :: Double -- ^ epsilon + -> Int -- ^ N + -> ([Double],[Double]) -- ^ (b,a) + +chebyshev2 eps n = (num, den) + where zeros = [ 0 :+ 1 / wz k | k <- [0..(n-1)], 2*k+1 /= n ] + poles = [ 1 / ((-u k) :+ (w k)) | k <- [0..(n-1)] ] + wz k = cos (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + u k = sinh v0 * sin (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + w k = cosh v0 * cos (fromIntegral (2*k+1) * pi / fromIntegral (2*n)) + num = map (*gain) $ map realPart $ roots2poly $ zeros + den = map realPart $ roots2poly $ poles + v0 = asinh (1/eps) / fromIntegral n + gain = abs $ realPart $ product poles / product zeros diff --git a/DSP/Filter/Analog/Response.hs b/DSP/Filter/Analog/Response.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/Analog/Response.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.Analog.Response +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module for generating analog filter responses +-- +-- Formulas are from Oppenheim and Schafer, Appendix B +-- +----------------------------------------------------------------------------- + +module DSP.Filter.Analog.Response where + +import Polynomial.Basic +import Polynomial.Chebyshev + +-- | Butterworth filter response function + +butterworth_H :: Int -- ^ N + -> Double -- ^ w_c + -> Double -- ^ w + -> Double -- ^ |H_c(w)|^2 + +butterworth_H n wc w = 1 / (1 + (w/wc)^(2*n)) + +-- | Chebyshev filter response function + +chebyshev1_H :: Int -- ^ N + -> Double -- ^ epsilon + -> Double -- ^ w_c + -> Double -- ^ w + -> Double -- ^ |H_c(w)|^2 + +chebyshev1_H n eps wc w = 1 / (1 + eps^2 * vn(w/wc)^2) + where vn w = polyeval (cheby n) w + +-- | Inverse Chebyshev filter response function +-- +-- Note that @w_c@ is a property of the stopband for this filter + +chebyshev2_H :: Int -- ^ N + -> Double -- ^ epsilon + -> Double -- ^ w_c + -> Double -- ^ w + -> Double -- ^ |H_c(w)|^2 + +chebyshev2_H n eps wc w = 1 / (1 + (eps^2 * vn(wc/w)^2)**(-1)) + where vn w = polyeval (cheby n) w diff --git a/DSP/Filter/Analog/Transform.hs b/DSP/Filter/Analog/Transform.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/Analog/Transform.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.Analog.Transform +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Analog prototype filter transforms +--- +-- Reference: R&G, pg 258; P&M, pg 698 +-- +----------------------------------------------------------------------------- + +module DSP.Filter.Analog.Transform (a_lp2lp, a_lp2hp, a_lp2bp, a_lp2bs) where + +import Data.Complex + +import Polynomial.Basic + +-- Normalizes a filter + +normalize (num,den) = (num',den') + where a0 = last den + num' = map (/ a0) num + den' = map (/ a0) den + +-- | Lowpass to lowpass: @s --> s\/wc@ + +a_lp2lp :: Double -- ^ wc + -> ([Double],[Double]) -- ^ (b,a) + -> ([Double],[Double]) -- ^ (b',a') + +a_lp2lp wu (num,den) = normalize (num',den') + where num' = polysubst [ 0, 1/wu ] num + den' = polysubst [ 0, 1/wu ] den + +-- | Lowpass to highpass: @s --> wc\/s@ + +a_lp2hp :: Double -- ^ wc + -> ([Double],[Double]) -- ^ (b,a) + -> ([Double],[Double]) -- ^ (b',a') + +a_lp2hp wu (num,den) = normalize (num',den') + where nn = length num + nd = length den + n = max nn nd + num' = polysubst [ 0, 1/wu ] $ reverse $ num ++ replicate (n-nn) 0 + den' = polysubst [ 0, 1/wu ] $ reverse $ den ++ replicate (n-nd) 0 + +-- | Lowpass to bandpass: @s --> (s^2 + wl*wu) \/ (s(wu-wl))@ + +a_lp2bp :: Double -- ^ wl + -> Double -- ^ wu + -> ([Double],[Double]) -- ^ (b,a) + -> ([Double],[Double]) -- ^ (b',a') + +a_lp2bp wl wu (num,den) = normalize (num',den') + where n = max (length num - 1) (length den - 1) + num' = step3 $ step2 n [ 0, wu-wl ] $ step1 0 [ wl*wu, 0, 1 ] $ num + den' = step3 $ step2 n [ 0, wu-wl ] $ step1 0 [ wl*wu, 0, 1 ] $ den + step1 _ _ [] = [] + step1 n w (x:xs) = map (x*) (polypow w n) : step1 (n+1) w xs + step2 _ _ [] = [] + step2 n w (x:xs) = polymult (polypow w n) x : step2 (n-1) w xs + step3 x = foldr polyadd [0] x + +-- | Lowpass to bandstop: @s --> (s(wu-wl)) \/ (s^2 + wl*wu)@ + +a_lp2bs :: Double -- ^ wl + -> Double -- ^ wu + -> ([Double],[Double]) -- ^ (b,a) + -> ([Double],[Double]) -- ^ (b',a') + +a_lp2bs wl wu (num,den) = normalize (num',den') + where n = max (length num - 1) (length den - 1) + num' = step3 $ step2 n [ wu*wl, 0, 1 ] $ step1 0 [ 0, wu-wl ] $ num + den' = step3 $ step2 n [ wu*wl, 0, 1 ] $ step1 0 [ 0, wu-wl ] $ den + step1 _ _ [] = [] + step1 n w (x:xs) = map (x*) (polypow w n) : step1 (n+1) w xs + step2 _ _ [] = [] + step2 n w (x:xs) = polymult (polypow w n) x : step2 (n-1) w xs + step3 x = foldr polyadd [0] x diff --git a/DSP/Filter/FIR/FIR.hs b/DSP/Filter/FIR/FIR.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/FIR.hs @@ -0,0 +1,204 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.FIR +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Finite Impuse Response filtering functions +-- +----------------------------------------------------------------------------- + +module DSP.Filter.FIR.FIR (fir) where + +import Data.Array + +-- | Implements the following function, which is a FIR filter +-- +-- @y[n] = sum(k=0,M) h[k]*x[n-k]@ +-- +-- We implement the fir function with five helper functions, depending on +-- the type of the filter. In the following functions, we use the O&S +-- convention that m is the order of the filter, which is equal to the +-- number of taps minus one. + +{-# specialize fir :: Array Int Float -> [Float] -> [Float] #-} +{-# specialize fir :: Array Int Double -> [Double] -> [Double] #-} + +fir :: Num a => Array Int a -- ^ h[n] + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +fir h (x:xs) | isFIRType1 h = fir'1 h w xs + | isFIRType2 h = fir'2 h w xs + | isFIRType3 h = fir'3 h w xs + | isFIRType4 h = fir'4 h w xs + | otherwise = fir'0 h w xs + where w = listArray (0,m) $ x : replicate m 0 + m = snd $ bounds h + +-- This is for testing the symetric helpers. + +fir0 h (x:xs) = fir'0 h w xs + where w = listArray (0,m) $ x : replicate m 0 + m = snd $ bounds h + +-- Asymetric FIR + +{-# specialize fir'0 :: Array Int Float -> Array Int Float -> [Float] -> [Float] #-} +{-# specialize fir'0 :: Array Int Double -> Array Int Double -> [Double] -> [Double] #-} + +fir'0 :: Num a => Array Int a -> Array Int a -> [a] -> [a] +fir'0 h w [] = y : [] + where y = sum [ h!i * w!i | i <- [0..m] ] + m = snd $ bounds h +fir'0 h w (x:xs) = y : fir'0 h w' xs + where y = sum [ h!i * w!i | i <- [0..m] ] + w' = listArray (0,m) $ x : elems w + m = snd $ bounds h + +-- Type 1: symetric FIR, even order / odd length + +{-# specialize fir'1 :: Array Int Float -> Array Int Float -> [Float] -> [Float] #-} +{-# specialize fir'1 :: Array Int Double -> Array Int Double -> [Double] -> [Double] #-} + +fir'1 :: Num a => Array Int a -> Array Int a -> [a] -> [a] +fir'1 h w [] = y : [] + where y = h!m2 * w!m2 + sum [ h!i * (w!i + w!(m-i)) | i <- [0..m2-1] ] + m = snd $ bounds h + m2 = m `div` 2 +fir'1 h w (x:xs) = y : fir'1 h w' xs + where y = h!m2 * w!m2 + sum [ h!i * (w!i + w!(m-i)) | i <- [0..m2-1] ] + w' = listArray (0,m) $ x : elems w + m = snd $ bounds h + m2 = m `div` 2 + +-- Type 2: symetric FIR, odd order / even length + +{-# specialize fir'2 :: Array Int Float -> Array Int Float -> [Float] -> [Float] #-} +{-# specialize fir'2 :: Array Int Double -> Array Int Double -> [Double] -> [Double] #-} + +fir'2 :: Num a => Array Int a -> Array Int a -> [a] -> [a] +fir'2 h w [] = y : [] + where y = sum [ h!i * (w!i + w!(m-i)) | i <- [0..m2] ] + m = snd $ bounds h + m2 = m `div` 2 +fir'2 h w (x:xs) = y : fir'2 h w' xs + where y = sum [ h!i * (w!i + w!(m-i)) | i <- [0..m2] ] + w' = listArray (0,m) $ x : elems w + m = snd $ bounds h + m2 = m `div` 2 + +-- Type 3: anti-symetric FIR, even order / odd length + +{-# specialize fir'3 :: Array Int Float -> Array Int Float -> [Float] -> [Float] #-} +{-# specialize fir'3 :: Array Int Double -> Array Int Double -> [Double] -> [Double] #-} + +fir'3 :: Num a => Array Int a -> Array Int a -> [a] -> [a] +fir'3 h w [] = y : [] + where y = h!m2 * w!m2 + sum [ h!i * (w!i - w!(m-i)) | i <- [0..m2-1] ] + m = snd $ bounds h + m2 = m `div` 2 +fir'3 h w (x:xs) = y : fir'3 h w' xs + where y = h!m2 * w!m2 + sum [ h!i * (w!i - w!(m-i)) | i <- [0..m2-1] ] + w' = listArray (0,m) $ x : elems w + m = snd $ bounds h + m2 = m `div` 2 + +-- Type 4: anti-symetric FIR, off order / even length + +{-# specialize fir'4 :: Array Int Float -> Array Int Float -> [Float] -> [Float] #-} +{-# specialize fir'4 :: Array Int Double -> Array Int Double -> [Double] -> [Double] #-} + +fir'4 :: Num a => Array Int a -> Array Int a -> [a] -> [a] +fir'4 h w [] = y : [] + where y = sum [ h!i * (w!i - w!(m-i)) | i <- [0..m2] ] + m = snd $ bounds h + m2 = m `div` 2 +fir'4 h w (x:xs) = y : fir'4 h w' xs + where y = sum [ h!i * (w!i - w!(m-i)) | i <- [0..m2] ] + w' = listArray (0,m) $ x : elems w + m = snd $ bounds h + m2 = m `div` 2 + +-- Aux functions. Note that the tap numbers go from [0..m], so if m is +-- even, then the filter has odd length, and vice versa. + +{-# specialize isFIRType1 :: Array Int Float -> Bool #-} +{-# specialize isFIRType1 :: Array Int Double -> Bool #-} + +isFIRType1 :: Num a => Array Int a -> Bool +isFIRType1 h = even m && (h' == (reverse h')) + where m = snd $ bounds h + h' = elems h + +{-# specialize isFIRType2 :: Array Int Float -> Bool #-} +{-# specialize isFIRType2 :: Array Int Double -> Bool #-} + +isFIRType2 :: Num a => Array Int a -> Bool +isFIRType2 h = odd m && (h' == (reverse h')) + where m = snd $ bounds h + h' = elems h + +{-# specialize isFIRType3 :: Array Int Float -> Bool #-} +{-# specialize isFIRType3 :: Array Int Double -> Bool #-} + +isFIRType3 :: Num a => Array Int a -> Bool +isFIRType3 h = even m && h1 == reverse h2 + where m = snd $ bounds h + h' = elems h + h1 = take n h' + h2 = map negate (drop (n+1) h') + n = m `div` 2 + +{-# specialize isFIRType4 :: Array Int Float -> Bool #-} +{-# specialize isFIRType4 :: Array Int Double -> Bool #-} + +isFIRType4 :: Num a => Array Int a -> Bool +isFIRType4 h = odd m && h1 == reverse h2 + where m = snd $ bounds h + h1 = elems h + h2 = fmap negate $ h1 + +-- Test routines + +-- This tests out fir'0 + +h :: Array Int Double +h = listArray (0,4) [ 1, 2, 0, -1, 1 ] + +x :: [Double] +x = [1, 3, -1, -2, 0, 0, 0, 0 ] + +y :: [Double] +y = [1, 5, 5, -5, -6, 4, 1, -2] + +y' = fir h x + +-- This checks the symetric routines against fir'0 + +h1 :: Array Int Double +h1 = listArray (0,4) [ 1, 2, 3, 2, 1 ] +h2 :: Array Int Double +h2 = listArray (0,5) [ 1, 2, 3, 3, 2, 1 ] +h3 :: Array Int Double +h3 = listArray (0,4) [ 1, 2, 3, -2, -1 ] +h4 :: Array Int Double +h4 = listArray (0,5) [ 1, 2, 3, -3, -2, -1 ] + +y1 = fir0 h1 x +y2 = fir0 h2 x +y3 = fir0 h3 x +y4 = fir0 h4 x + +y1' = fir h1 x +y2' = fir h2 x +y3' = fir h3 x +y4' = fir h4 x + +-- If everything works, then test == True + +test = foldr (&&) True [ y == y', y1 == y1', y2 == y2', y3 == y3', y4 == y4' ] diff --git a/DSP/Filter/FIR/Kaiser.hs b/DSP/Filter/FIR/Kaiser.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/Kaiser.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.Kaiser +-- Copyright : (c) Matthew Donadio 1998 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module implements the Kaiser Window Method for designing FIR +-- filters. +-- +----------------------------------------------------------------------------- + +-- Reference: +-- +-- @Book{dsp, +-- author = "Alan V. Oppenheim and Ronald W. Schafer", +-- title = "Discrete-Time Signal Processing", +-- publisher = "Pretice-Hall", +-- year = 1989, +-- address = "Englewood Cliffs", +-- series = {Pretice-Hall Signal Processing Series} +-- } + +module DSP.Filter.FIR.Kaiser (kaiser_lpf, kaiser_hpf) where + +import Data.Array + +import DSP.Filter.FIR.Window +import DSP.Filter.FIR.Taps + +-- Set the cutoff frequency to the middle of the transition band. This +-- equation isn't numbered. + +calc_wc wp ws = (wp + ws) / 2 + +-- Equation 7.90 + +calc_dw wp ws = abs (ws - wp) + +-- Equation 7.91 + +calc_A d1 d2 = -20 * logBase 10 (min d1 d2) + +-- xEquation 7.92 + +calc_beta a | a > 50 = 0.1102 * (a - 8.7) + | a >= 21 = 0.5842 * ((a-21) ** 0.4) + 0.07886 * (a-21) + | otherwise = 0.0 + +-- Equation 7.93 + +calc_M a dw = ceiling ((a - 8) / (2.285 * dw)) + +-- Procedure on pg 455. We should really check the peak approximation +-- error and then increase M if necessary. + +-- | Designs a lowpass Kaiser filter + +kaiser_lpf :: Double -- ^ wp + -> Double -- ^ ws + -> Double -- ^ dp + -> Double -- ^ ds + -> Array Int Double -- ^ h[n] + +kaiser_lpf wp ws d1 d2 = window (kaiser beta m) (lpf wc m) + where wc = calc_wc wp ws + dw = calc_dw wp ws + a = calc_A d1 d2 + beta = calc_beta a + m = calc_M a dw + +-- The weird case for m below is because highpass (or bandstop) filters +-- should only be Type I. Linear phase forces a null at w=pi for Type II +-- filters, which doesn't fit well with these kinds of filters. Again, +-- we should really check the peak approximation error and then increase +-- M (by two) if necessary. + +-- | Designs a highpass Kaiser filter + +kaiser_hpf :: Double -- ^ wp + -> Double -- ^ ws + -> Double -- ^ dp + -> Double -- ^ ds + -> Array Int Double -- ^ h[n] + +kaiser_hpf wp ws d1 d2 = window (kaiser beta m) (hpf wc m) + where wc = calc_wc wp ws + dw = calc_dw wp ws + a = calc_A d1 d2 + beta = calc_beta a + m | odd (calc_M a dw) = (calc_M a dw) + 1 + | otherwise = (calc_M a dw) diff --git a/DSP/Filter/FIR/PolyInterp.hs b/DSP/Filter/FIR/PolyInterp.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/PolyInterp.hs @@ -0,0 +1,528 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.PolyInterp +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Polynomial interpolators. Taken from: +-- +-- Olli Niemitalo (ollinie\@freenet.hut.fi), "Polynomial Interpolators for +-- High-Quality Resampling of Oversampled Audio" Search for "deip.pdf" with +-- Google and you will find it. +-- +----------------------------------------------------------------------------- + +-- TODO: limit the export list + +-- TODO: figure out better way to create the coeficeints where you don't +-- have to explicitly state the number of interpolation points. + +module DSP.Filter.FIR.PolyInterp where + +import Data.Array + +import Polynomial.Basic + +-- | 'mkcoef' takes the continuous impluse response function (one of the +-- functions below, @f@) and number of points in the interpolation, @p@, time +-- shifts it by @x@, samples it, and creates an array with the interpolation +-- coeficients that can be used as a FIR filter. + +mkcoef :: (Num a, Ix b, Integral b) => (a -> a) -- ^ f + -> b -- ^ p + -> a -- ^ x + -> Array b a -- ^ h[n] + +mkcoef f p x = listArray (0,p-1) $ map f [ x - fromIntegral i | i <- [p1..p2] ] + where p1 = -(p `div` 2 - 1) + p2 = p `div` 2 + +--------------------------------------------------------------------------------- + +-- The impulse responses, centered around zero + +-- The following functions are named like + +-- blah_ApBo or optimal_ApBoCx + +-- A = number of points in the interpolation +-- B = the polynomial order +-- C = the oversampling rate that the function is designed for + +--------------------------------------------------------------------------------- + +-- B-Splines + +bspline_1p0o :: (Ord a, Fractional a) => a -> a +bspline_1p0o x | 0 <= x && x < 1 = polyeval [ 1 ] x + | otherwise = 0 + +bspline_2p1o :: (Ord a, Fractional a) => a -> a +bspline_2p1o x | 0 <= x && x < 1 = polyeval [ 1, -1 ] x + | 1 <= x = 0 + | otherwise = bspline_2p1o (-x) + +bspline_4p3o :: (Ord a, Fractional a) => a -> a +bspline_4p3o x | 0 <= x && x < 1 = polyeval [ 2/3, 0, -1, 1/2 ] x + | 1 <= x && x < 2 = polyeval [ 4/3, -2, 1, -1/6 ] x + | 2 <= x = 0 + | otherwise = bspline_4p3o (-x) + +bspline_6p5o :: (Ord a, Fractional a) => a -> a +bspline_6p5o x | 0 <= x && x < 1 = polyeval [ 11/20, 0, -1/2, 0, 1/4, -1/12 ] x + | 1 <= x && x < 2 = polyeval [ 17/40, 5/8, -7/4, 5/4, -3/8, 1/24 ] x + | 2 <= x && x < 3 = polyeval [ 81/40, -27/8, 9/4, -3/4, 1/8, -1/120 ] x + | 3 <= x = 0 + | otherwise = bspline_6p5o (-x) + +--------------------------------------------------------------------------------- + +-- Lagrange polynomials + +lagrange_4p3o :: (Ord a, Fractional a) => a -> a +lagrange_4p3o x | 0 <= x && x < 1 = polyeval [ 1, -1/2, -1, 1/2 ] x + | 1 <= x && x < 2 = polyeval [ 1, -11/6, 1, -1/6 ] x + | 2 <= x = 0 + | otherwise = lagrange_4p3o (-x) + +lagrange_6p5o :: (Ord a, Fractional a) => a -> a +lagrange_6p5o x | 0 <= x && x < 1 = polyeval [ 1, -1/3, -5/4, 5/12, 1/4, -1/12 ] x + | 1 <= x && x < 2 = polyeval [ 1, -13/12, -5/8, 25/24, -3/8, 1/24 ] x + | 2 <= x && x < 3 = polyeval [ 1, -137/60, 15/8, -17/24, 1/8, -1/120 ] x + | 3 <= x = 0 + | otherwise = lagrange_6p5o (-x) + +--------------------------------------------------------------------------------- + +-- Hermite (1st-order-osculating) polynomials + +hermite_4p3o :: (Ord a, Fractional a) => a -> a +hermite_4p3o x | 0 <= x && x < 1 = polyeval [ 1, 0, -5/2, 3/2 ] x + | 1 <= x && x < 2 = polyeval [ 2, -4, 5/2, -1/2 ] x + | 2 <= x = 0 + | otherwise = hermite_4p3o (-x) + +hermite_6p3o :: (Ord a, Fractional a) => a -> a +hermite_6p3o x | 0 <= x && x < 1 = polyeval [ 1, 0, -7/3, 4/3 ] x + | 1 <= x && x < 2 = polyeval [ 5/2, -59/12, 3, -7/12 ] x + | 2 <= x && x < 3 = polyeval [ -3/2, 7/4, -2/3, 1/12 ] x + | 3 <= x = 0 + | otherwise = hermite_6p3o (-x) + +hermite_6p5o :: (Ord a, Fractional a) => a -> a +hermite_6p5o x | 0 <= x && x < 1 = polyeval [ 1, 0, -25/12, 5/12, 13/12, -5/12 ] x + | 1 <= x && x < 2 = polyeval [ 1, 5/12, -35/8, 35/8, -13/8, 5/24 ] x + | 2 <= x && x < 3 = polyeval [ 3, -29/4, 155/24, -65/24, 13/24, -1/24 ] x + | 3 <= x = 0 + | otherwise = hermite_6p5o (-x) + +--------------------------------------------------------------------------------- + +-- 2nd-order-osculating polynomials + +sndosc_4p5o :: (Ord a, Fractional a) => a -> a +sndosc_4p5o x | 0 <= x && x < 1 = polyeval [ 1, 0, -1, -9/2, 15/2, -3 ] x + | 1 <= x && x < 2 = polyeval [ -4, 18, -29, 43/2, -15/2, 1 ] x + | 2 <= x = 0 + | otherwise = sndosc_4p5o (-x) + +sndosc_6p5o :: (Ord a, Fractional a) => a -> a +sndosc_6p5o x | 0 <= x && x < 1 = polyeval [ 1, 0, -5/4, -35/12, 21/4, -25/12 ] x + | 1 <= x && x < 2 = polyeval [ -4, 75/4, -245/8, 545/24, -63/8, 25/24 ] x + | 2 <= x && x < 3 = polyeval [ 18, -153/4, 255/8, -313/24, 21/8, -5/24 ] x + | 3 <= x = 0 + | otherwise = sndosc_6p5o (-x) + +--------------------------------------------------------------------------------- + +-- Misc + +watte_4p2o :: (Ord a, Fractional a) => a -> a +watte_4p2o x | 0 <= x && x < 1 = polyeval [ 1, -1/2, -1/2 ] x + | 1 <= x && x < 2 = polyeval [ 1, -3/2, 1/2 ] x + | 2 <= x = 0 + | otherwise = watte_4p2o (-x) + +parabolic2x_4p2o :: (Ord a, Fractional a) => a -> a +parabolic2x_4p2o x | 0 <= x && x < 1 = polyeval [ 1/2, 0, -1/4 ] x + | 1 <= x && x < 2 = polyeval [ 1, -1, 1/4 ] x + | 2 <= x = 0 + | otherwise = parabolic2x_4p2o (-x) + +--------------------------------------------------------------------------------- + +-- Optimal designs + +optimal_2p3o2x :: (Ord a, Fractional a) => a -> a +optimal_2p3o2x x | 0 <= x && x < 1 = polyeval [ 0.80607906469176971, 0.17594740788514596, + -2.35977550974341630, 1.57015627178718420 ] x + | 1 <= x = 0 + | otherwise = optimal_2p3o2x (-x) + +optimal_2p3o4x :: (Ord a, Fractional a) => a -> a +optimal_2p3o4x x | 0 <= x && x < 1 = polyeval [ 0.88207975731800936, -0.10012219395448523, + -1.99054787320203810, 1.32598918957298410 ] x + | 1 <= x = 0 + | otherwise = optimal_2p3o4x (-x) + +optimal_2p3o8x :: (Ord a, Fractional a) => a -> a +optimal_2p3o8x x | 0 <= x && x < 1 = polyeval [ 0.94001491168487883, -0.51213628865925998, + -1.10319974084152170, 0.73514591836770027 ] x + | 1 <= x = 0 + | otherwise = optimal_2p3o8x (-x) + +optimal_2p3o16x :: (Ord a, Fractional a) => a -> a +optimal_2p3o16x x | 0 <= x && x < 1 = polyeval [ 0.96964782067188493, -0.74617479745643256, + -0.57923093055631791, 0.38606621963374965 ] x + | 1 <= x = 0 + | otherwise = optimal_2p3o16x (-x) + +optimal_2p3o32x :: (Ord a, Fractional a) => a -> a +optimal_2p3o32x x | 0 <= x && x < 1 = polyeval [ 0.98472017575676363, -0.87053863725307623, + -0.29667081825572522, 0.19775766248673177 ] x + | 1 <= x = 0 + | otherwise = optimal_2p3o32x (-x) + +optimal_4p2o2x :: (Ord a, Fractional a) => a -> a +optimal_4p2o2x x | 0 <= x && x < 1 = polyeval [ 0.50061662213752656, -0.04782068534965925, + -0.21343978756177684 ] x + | 1 <= x && x < 2 = polyeval [ 0.92770135528027386, -0.88689658749623701, + 0.21303593243799016 ] x + | 2 <= x = 0 + | otherwise = optimal_4p2o2x (-x) + +optimal_4p2o4x :: (Ord a, Fractional a) => a -> a +optimal_4p2o4x x | 0 <= x && x < 1 = polyeval [ 0.33820365736567115, 0.2114449807519728, + -0.22865399531858188 ] x + | 1 <= x && x < 2 = polyeval [ 1.12014639874555470, -1.01414466618792900, + 0.22858390767180370 ] x + | 2 <= x = 0 + | otherwise = optimal_4p2o4x (-x) + +optimal_4p2o8x :: (Ord a, Fractional a) => a -> a +optimal_4p2o8x x | 0 <= x && x < 1 = polyeval [ 0.09224718574204172, 0.59257579283164508, + -0.24005206207889518 ] x + | 1 <= x && x < 2 = polyeval [ 1.38828036063664320, -1.17126532964206100, + 0.24004281672637814 ] x + | 2 <= x = 0 + | otherwise = optimal_4p2o8x (-x) + +optimal_4p2o16x :: (Ord a, Fractional a) => a -> a +optimal_4p2o16x x | 0 <= x && x < 1 = polyeval [ -0.41849525763976203, 1.36361593203840510, + -0.24506117865474364 ] x + | 1 <= x && x < 2 = polyeval [ 1.90873339502208310, -1.44144384373471430, + 0.24506002360805534 ] x + | 2 <= x = 0 + | otherwise = optimal_4p2o16x (-x) + +optimal_4p2o32x :: (Ord a, Fractional a) => a -> a +optimal_4p2o32x x | 0 <= x && x < 1 = polyeval [ -1.42170796824052890, 2.87083485132510450, + -0.24755243839713828 ] x + | 1 <= x && x < 2 = polyeval [ 2.91684291662070860, -1.95043794419108290, + 0.24755229501840223 ] x + | 2 <= x = 0 + | otherwise = optimal_4p2o32x (-x) + +optimal_4p3o2x :: (Ord a, Fractional a) => a -> a +optimal_4p3o2x x | 0 <= x && x < 1 = polyeval [ 0.59244492420272321, 0.03573669883299365, + -0.78664888597764893, 0.36030925263849456 ] x + | 1 <= x && x < 2 = polyeval [ 1.20220428331406090, -1.60101160971478710, + 0.70401463131621556, -0.10174985775982505 ] x + | 2 <= x = 0 + | otherwise = optimal_4p3o2x (-x) + +optimal_4p3o4x :: (Ord a, Fractional a) => a -> a +optimal_4p3o4x x | 0 <= x && x < 1 = polyeval [ 0.60304009430474115, 0.05694012453786401, + -0.89223007211175309, 0.42912649274763925 ] x + | 1 <= x && x < 2 = polyeval [ 1.31228823423882930, -1.85072890189700660, + 0.87687351895686727, -0.13963062613760227 ] x + | 2 <= x = 0 + | otherwise = optimal_4p3o4x (-x) + +optimal_4p3o8x :: (Ord a, Fractional a) => a -> a +optimal_4p3o8x x | 0 <= x && x < 1 = polyeval [ 0.60658368706046584, 0.07280793921972525, + -0.95149675410360302, 0.46789242171187317 ] x + | 1 <= x && x < 2 = polyeval [ 1.35919815911169020, -1.95618744839533010, + 0.94949311590826524, -0.15551896027602030 ] x + | 2 <= x = 0 + | otherwise = optimal_4p3o8x (-x) + +optimal_4p3o16x :: (Ord a, Fractional a) => a -> a +optimal_4p3o16x x | 0 <= x && x < 1 = polyeval [ 0.60844825096346644, 0.07980169577604959, + -0.97894238166068270, 0.48601256046234864 ] x + | 1 <= x && x < 2 = polyeval [ 1.37724137476464990, -1.99807048591354810, + 0.97870442828560433, -0.16195131297091253 ] x + | 2 <= x = 0 + | otherwise = optimal_4p3o16x (-x) + +optimal_4p3o32x :: (Ord a, Fractional a) => a -> a +optimal_4p3o32x x | 0 <= x && x < 1 = polyeval [ 0.60908264223655417, 0.08298544053689563, + -0.99052586766084594, 0.49369595780454456 ] x + | 1 <= x && x < 2 = polyeval [ 1.38455689452848450, -2.01496368680360890, + 0.99049753216621961, -0.16455902278580614 ] x + | 2 <= x = 0 + | otherwise = optimal_4p3o32x (-x) + +optimal_4p4o2x :: (Ord a, Fractional a) => a -> a +optimal_4p4o2x x | 0 <= x && x < 1 = polyeval [ 0.58448510036125145, 0.04442540676862300, + -0.7586487041827807, 0.29412762852131868, + 0.04252164479749607 ] x + | 1 <= x && x < 2 = polyeval [ 1.06598379704160570, -1.16581445347275190, + 0.21256821036268256, 0.13781898240764315, + -0.04289144034653719 ] x + | 2 <= x = 0 + | otherwise = optimal_4p4o2x (-x) + +optimal_4p4o4x :: (Ord a, Fractional a) => a -> a +optimal_4p4o4x x | 0 <= x && x < 1 = polyeval [ 0.61340295990566229, 0.06128937679587994, + -0.94057832565094635, 0.44922093286355397, + 0.00986988334359864 ] x + | 1 <= x && x < 2 = polyeval [ 1.30835018075821670, -1.82814511658458520, + 0.81943257721092366, -0.09642760567543440, + -0.00989340017126506 ] x + | 2 <= x = 0 + | otherwise = optimal_4p4o4x (-x) + +optimal_4p4o8x :: (Ord a, Fractional a) => a -> a +optimal_4p4o8x x | 0 <= x && x < 1 = polyeval [ 0.62095991632974834, 0.06389302461261143, + -0.98489647972932193, 0.48698871865064902, + 0.00255074537015887 ] x + | 1 <= x && x < 2 = polyeval [ 1.35943398999940390, -1.97277963497287720, + 0.95410568622888214, -0.14868053358928229, + -0.00255226912537286 ] x + | 2 <= x = 0 + | otherwise = optimal_4p4o8x (-x) + +optimal_4p4o16x :: (Ord a, Fractional a) => a -> a +optimal_4p4o16x x | 0 <= x && x < 1 = polyeval [ 0.62293049365660191, 0.06443376638262904, + -0.99620011474430481, 0.49672182806667398, + 0.00064264050033187 ] x + | 1 <= x && x < 2 = polyeval [ 1.37216269878963180, -2.00931632449031920, + 0.98847675044522398, -0.16214364417487748, + -0.00064273459469381 ] x + | 2 <= x = 0 + | otherwise = optimal_4p4o16x (-x) + +optimal_4p4o32x :: (Ord a, Fractional a) => a -> a +optimal_4p4o32x x | 0 <= x && x < 1 = polyeval [ 0.62342449465938121, 0.06456923251842608, + -0.99904509583176049, 0.49917660509564427, + 0.00016095224137360 ] x + | 1 <= x && x < 2 = polyeval [ 1.37534629142898650, -2.01847637982642340, + 0.99711292321092770, -0.16553360612350931, + -0.00016095810460478 ] x + | 2 <= x = 0 + | otherwise = optimal_4p4o32x (-x) + +optimal_6p4o2x :: (Ord a, Fractional a) => a -> a +optimal_6p4o2x x | 0 <= x && x < 1 = polyeval [ 0.42640922432669054, -0.0052558029434142, + -0.20486985491012843, 0.00255494211547300, + 0.03134095684084392 ] x + | 1 <= x && x < 2 = polyeval [ 0.30902529029941583, 0.37868437559565432, + -0.70564644117967990, 0.31182026815653541, + -0.04385804833432710 ] x + | 2 <= x && x < 3 = polyeval [ 1.51897639740576910, -1.83761742915820410, + 0.83217835730406542, -0.16695522597587154, + 0.01249475765486819 ] x + | 3 <= x = 0 + | otherwise = optimal_6p4o2x (-x) + +optimal_6p4o4x :: (Ord a, Fractional a) => a -> a +optimal_6p4o4x x | 0 <= x && x < 1 = polyeval [ 0.20167941634921072, -0.06119274485321008, + 0.56468711069379207, -0.42059475673758634, + 0.02881527997393852 ] x + | 1 <= x && x < 2 = polyeval [ -0.64579641436229407, 2.33580825807694700, + -1.85350543411307390, 0.51926458031522660, + -0.04250898918476453 ] x + | 2 <= x && x < 3 = polyeval [ 2.76228852293285200, -3.09936092833253300, + 1.27147464005834010, -0.22283280665600644, + 0.01369173779618459 ] x + | 3 <= x = 0 + | otherwise = optimal_6p4o4x (-x) + +optimal_6p4o8x :: (Ord a, Fractional a) => a -> a +optimal_6p4o8x x | 0 <= x && x < 1 = polyeval [ -0.17436452172055789, -0.15190225510786248, + 1.87551558979819120, -1.15976496200057480, + 0.03401038103941584 ] x + | 1 <= x && x < 2 = polyeval [ -2.26955357035241170, 5.73320660746477540, + -3.92391712129699590, 0.93463067895166918, + -0.05090907029392906 ] x + | 2 <= x && x < 3 = polyeval [ 4.84834508915762540, -5.25661448354449060, + 2.04584149450148180, -0.32814290420019698, + 0.01689861603514873 ] x + | 3 <= x = 0 + | otherwise = optimal_6p4o8x (-x) + +optimal_6p4o16x :: (Ord a, Fractional a) => a -> a +optimal_6p4o16x x | 0 <= x && x < 1 = polyeval [ -0.94730014688427577, -0.33649680079382827, + 4.53807483241466340, -2.64598691215356660, + 0.03755086455339280 ] x + | 1 <= x && x < 2 = polyeval [ -5.55035312316726960, 12.52871168241192600, + -7.98288364772738750, 1.70665858343069510, + -0.05631219122315393 ] x + | 2 <= x && x < 3 = polyeval [ 8.94785524286246310, -9.37021675593126700, + 3.44447036756440590, -0.49470749109917245, + 0.01876132424143207 ] x + | 3 <= x = 0 + | otherwise = optimal_6p4o16x (-x) + +optimal_6p4o32x :: (Ord a, Fractional a) => a -> a +optimal_6p4o32x x | 0 <= x && x < 1 = polyeval [ -2.44391738331193720, -0.69468212315980082, + 9.67889243081689440, -5.50592307590218160, + 0.03957507923965987 ] x + | 1 <= x && x < 2 = polyeval [ -11.87524595267807600, 25.58633277328986500, + -15.73068663442630400, 3.15288929279855570, + -0.05936083498715066 ] x + | 2 <= x && x < 3 = polyeval [ 16.79403235763479100, -17.17264148794549100, + 6.05175140696421730, -0.79053754554850286, + 0.01978575568000696 ] x + | 3 <= x = 0 + | otherwise = optimal_6p4o32x (-x) + +optimal_6p5o2x :: (Ord a, Fractional a) => a -> a +optimal_6p5o2x x | 0 <= x && x < 1 = polyeval [ 0.48217702203158502, -0.00127577239632662, + -0.3267507171395277, -0.02014846731685776, + 0.14640674192652170, -0.04317950185225609 ] x + | 1 <= x && x < 2 = polyeval [ 0.35095903476754237, 0.53534756396439365, + -1.22477236472789920, 0.74995484587342742, + -0.19234043023690772, 0.01802814255926417 ] x + | 2 <= x && x < 3 = polyeval [ 1.62814578813495040, -2.26168360510917840, + 1.22220278720010690, -0.31577407091450355, + 0.03768876199398620, -0.00152170021558204 ] x + | 3 <= x = 0 + | otherwise = optimal_6p5o2x (-x) + +optimal_6p5o4x :: (Ord a, Fractional a) => a -> a +optimal_6p5o4x x | 0 <= x && x < 1 = polyeval [ 0.50164509338655083, -0.00256790184606694, + -0.36229943140977111, -0.04512026308730401, + 0.20620318519804220, -0.06607747864416924 ] x + | 1 <= x && x < 2 = polyeval [ 0.30718330223223800, 0.78336433172501685, + -1.66940481896969310, 1.08365113099941970, + -0.30560854964737405, 0.03255079211953620 ] x + | 2 <= x && x < 3 = polyeval [ 2.05191571792256240, -3.19403437421534920, + 1.99766476840488070, -0.62765808573554227, + 0.09909173357642603, -0.00628989632244913 ] x + | 3 <= x = 0 + | otherwise = optimal_6p5o4x (-x) + +optimal_6p5o8x :: (Ord a, Fractional a) => a -> a +optimal_6p5o8x x | 0 <= x && x < 1 = polyeval [ 0.50513183702821474, -0.00368143670114908, + -0.36434084624989699, -0.06070462616102962, + 0.22942797169644802, -0.07517133281176167 ] x + | 1 <= x && x < 2 = polyeval [ 0.28281884957695946, 0.88385964850687193, + -1.82581238657617080, 1.19588167464050650, + -0.34363487882262922, 0.03751837438141215 ] x + | 2 <= x && x < 3 = polyeval [ 2.15756386503245070, -3.42137079071284810, + 2.18592382088982260, -0.70370361187427199, + 0.11419603882898799, -0.00747588873055296 ] x + | 3 <= x = 0 + | otherwise = optimal_6p5o8x (-x) + +optimal_6p5o16x :: (Ord a, Fractional a) => a -> a +optimal_6p5o16x x | 0 <= x && x < 1 = polyeval [ 0.50819303579369868, -0.00387117789818541, + -0.36990908725555449, -0.06616250180411522, + 0.24139298776307896, -0.07990500783668089 ] x + | 1 <= x && x < 2 = polyeval [ 0.27758734130911511, 0.91870010875159547, + -1.89281840112089440, 1.24834464824612510, + -0.36203450650610985, 0.03994519162531633 ] x + | 2 <= x && x < 3 = polyeval [ 2.19284545406407450, -3.50786533926449100, + 2.26228244623301580, -0.73559668875725392, + 0.12064126711558003, -0.00798609327859495 ] x + | 3 <= x = 0 + | otherwise = optimal_6p5o16x (-x) + +optimal_6p5o32x :: (Ord a, Fractional a) => a -> a +optimal_6p5o32x x | 0 <= x && x < 1 = polyeval [ 0.52558916128536759, 0.00010896283126635, + -0.42682321682847008, -0.04095676092513167, + 0.25041444762720882, -0.08349799235675044 ] x + | 1 <= x && x < 2 = polyeval [ 0.33937904183610190, 0.80946953063234006, + -1.86228986389877100, 1.27215033630638800, + -0.37562266426589430, 0.04174912841630993 ] x + | 2 <= x && x < 3 = polyeval [ 2.13606003964474490, -3.48774662195185850, + 2.28912105276248390, -0.75510203509083995, + 0.12520821766375972, -0.00834987866042734 ] x + | 3 <= x = 0 + | otherwise = optimal_6p5o32x (-x) + +--------------------------------------------------------------------------------- + +{------------------- + +Test routines + +y = [ sin $ 0.345 + 0.1234 * fromIntegral i | i <- [0..10] ] + +h1 = mkcoef bspline_4p3o 4 0.2 +h2 = mkcoef hermite_4p3o 4 0.2 +h3 = mkcoef lagrange_4p3o 4 0.2 +h4 = mkcoef hermite_4p3o 4 0.2 +h5 = mkcoef sndosc_4p5o 4 0.2 +h6 = mkcoef watte_4p2o 4 0.2 +h7 = mkcoef parabolic2x_4p2o 4 0.2 + +h8 = mkcoef bspline_6p5o 6 0.2 +h9 = mkcoef lagrange_6p5o 6 0.2 +h10 = mkcoef hermite_6p3o 6 0.2 +h11 = mkcoef hermite_6p5o 6 0.2 +h12 = mkcoef sndosc_6p5o 6 0.2 + +h2p3o2x = mkcoef optimal_2p3o2x 2 0.2 +h2p3o4x = mkcoef optimal_2p3o4x 2 0.2 +h2p3o8x = mkcoef optimal_2p3o8x 2 0.2 +h2p3o16x = mkcoef optimal_2p3o16x 2 0.2 +h2p3o32x = mkcoef optimal_2p3o32x 2 0.2 + +h4p2o2x = mkcoef optimal_4p2o2x 4 0.2 +h4p2o4x = mkcoef optimal_4p2o4x 4 0.2 +h4p2o8x = mkcoef optimal_4p2o8x 4 0.2 +h4p2o16x = mkcoef optimal_4p2o16x 4 0.2 +h4p2o32x = mkcoef optimal_4p2o32x 4 0.2 + +h4p3o2x = mkcoef optimal_4p3o2x 4 0.2 +h4p3o4x = mkcoef optimal_4p3o4x 4 0.2 +h4p3o8x = mkcoef optimal_4p3o8x 4 0.2 +h4p3o16x = mkcoef optimal_4p3o16x 4 0.2 +h4p3o32x = mkcoef optimal_4p3o32x 4 0.2 + +h4p4o2x = mkcoef optimal_4p4o2x 4 0.2 +h4p4o4x = mkcoef optimal_4p4o4x 4 0.2 +h4p4o8x = mkcoef optimal_4p4o8x 4 0.2 +h4p4o16x = mkcoef optimal_4p4o16x 4 0.2 +h4p4o32x = mkcoef optimal_4p4o32x 4 0.2 + +h6p4o2x = mkcoef optimal_6p4o2x 4 0.2 +h6p4o4x = mkcoef optimal_6p4o4x 4 0.2 +h6p4o8x = mkcoef optimal_6p4o8x 4 0.2 +h6p4o16x = mkcoef optimal_6p4o16x 4 0.2 +h6p4o32x = mkcoef optimal_6p4o32x 4 0.2 + +h6p5o2x = mkcoef optimal_6p5o2x 4 0.2 +h6p5o4x = mkcoef optimal_6p5o4x 4 0.2 +h6p5o8x = mkcoef optimal_6p5o8x 4 0.2 +h6p5o16x = mkcoef optimal_6p5o16x 4 0.2 +h6p5o32x = mkcoef optimal_6p5o32x 4 0.2 + +interpolate y h = sum $ zipWith (*) y (elems h) + +x1 = sin $ 0.345 + 0.1234 * 1.2 +x1' = map (interpolate y) [ h1, h2, h3, h4, h5, h6, h7 ] + +x2 = sin $ 0.345 + 0.1234 * 2.2 +x2' = map (interpolate y) [ h8, h9, h10, h11, h12 ] + +The values of all these lists should be one, or nearly one. They +aren't for the 6p4o optimal designs, but I'm not sure why. Olli's +paper states that these are a little screwy, though. + +h_test = map (sum . elems) [ h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12 ] +h2p3o_test = map (sum . elems) [ h2p3o2x, h2p3o4x, h2p3o8x, h2p3o16x, h2p3o32x ] +h4p2o_test = map (sum . elems) [ h4p2o2x, h4p2o4x, h4p2o8x, h4p2o16x, h4p2o32x ] +h4p3o_test = map (sum . elems) [ h4p4o2x, h4p4o4x, h4p4o8x, h4p4o16x, h4p4o32x ] +h4p4o_test = map (sum . elems) [ h4p4o2x, h4p4o4x, h4p4o8x, h4p4o16x, h4p4o32x ] +h6p4o_test = map (sum . elems) [ h6p4o2x, h6p4o4x, h6p4o8x, h6p4o16x, h6p4o32x ] +h6p5o_test = map (sum . elems) [ h6p5o2x, h6p5o4x, h6p5o8x, h6p5o16x, h6p5o32x ] + +-------------------} diff --git a/DSP/Filter/FIR/Sharpen.hs b/DSP/Filter/FIR/Sharpen.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/Sharpen.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.Sharpen +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module to sharpen FIR filters +-- +-- Reference: Hamming, Sect 6.6 +-- +-- @H'(z) = 3 * H(z)^2 - s * H(z)^3@ +-- @ = H(z)^2 * (3 - 2 * H(z))@ +-- +-- Procedure: +-- +-- (1) Filter the signal once with H(z) +-- +-- 2. Double this +-- +-- 3. Subtract this from 3x +-- +-- 4. Filter this twice by H(z) or once by H(z)^2 +-- +----------------------------------------------------------------------------- + +module DSP.Filter.FIR.Sharpen where + +import Data.Array + +import DSP.Basic +import DSP.Convolution +import DSP.Filter.FIR.FIR + +-- | Filter shaprening routine + +sharpen :: (Num a) => Array Int a -- ^ h[n] + -> ([a] -> [a]) -- ^ function that implements the sharpened filter + +sharpen h x = step4 + where step1 = fir h x + step2 = map (2*) step1 + step3 = zipWith (-) (map (3*) (zn delay x)) step2 + step4 = fir h $ fir h $ step3 + -- step4 = fir $ conv h h $ step3 + m = snd $ bounds h + delay = m `div` 2 diff --git a/DSP/Filter/FIR/Smooth.hs b/DSP/Filter/FIR/Smooth.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/Smooth.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.Smooth +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Herrmann type smooth FIR filters, from Hamming, Chapter 7, also +-- known as maximally flat FIR filters +-- +-- If x is the -3 dB point, then p\/q = -(x+1)\/(x-1) +-- +----------------------------------------------------------------------------- + +-- TODO: function for rational fraction approximation + +-- TODO: input parameters in the style of sect53.f + +module DSP.Filter.FIR.Smooth (smoothfir) where + +import Data.Array + +import Polynomial.Basic + +-- Normalize is the step to set g(1) = 1 (pg 123) + +normalize x = map (/ a) x + where a = sum x + +-- Expand performs the algorithm in Sect 7.3 + +expand (x1:x2:[]) = [ x1, x2 ] +expand (x:xs) = expand' x $ expand xs + +expand' x ys = zipWith (+) (m1 x ys) (p1 ys) + where m1 x (y:ys) = x : y : map (0.5*) ys + p1 (y:ys) = map (0.5*) ys ++ [ 0, 0 ] + +-- Reflect makes the filter symetric (not sure where this is stated) + +reflect (x:xs) = (map (0.5*) $ reverse xs) ++ x : (map (0.5*) xs) + +-- The actual function. Note that we use (1+t)^p * (1-t)^q directly +-- since we have a polynomial library. + +-- | designs smooth FIR filters + +smoothfir :: (Ix a, Integral a, Fractional b) => a -- ^ p + -> a -- ^ q + -> Array a b -- ^ h[n] + +smoothfir p q = listArray (0,n-1) $ reflect $ expand $ b + where b' = polymult (polypow [ 1, 1 ] p) (polypow [ 1, -1 ] q) + b1 = polyinteg b' 0 + c = -polyeval b1 (-1) + b = normalize $ c : tail b1 + n = 2 * (p+1 + q+1) - 1 + +-- Test + +-- map (256*) $ elems $ smoothfir 3 1 == [ -1, -5, -5, 20, 70, 98, 70, 20, -5, -5, -1 ] diff --git a/DSP/Filter/FIR/Taps.hs b/DSP/Filter/FIR/Taps.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/Taps.hs @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.Taps +-- Copyright : (c) Matthew Donadio 1998 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Functions for creating rectangular windowed FIR filters +-- +----------------------------------------------------------------------------- + +{- +Reference: + +@Book{dsp, + author = "Alan V. Oppenheim and Ronald W. Schafer", + title = "Discrete-Time Signal Processing", + publisher = "Pretice-Hall", + year = 1989, + address = "Englewood Cliffs", + series = {Pretice-Hall Signal Processing Series} +} +-} + +module DSP.Filter.FIR.Taps (lpf, hpf, bpf, bsf, mbf, rc) where + +import Data.Array + +-- indexes generates the list of indexes that we will map the prototype +-- functions onto + +indexes m = [ 0 .. fromIntegral m ] + +-- the _tap functions generate one tap for the given function + +-- wc = cutoff frequency in normalized radians +-- m = the order of the filter (length - 1) +-- n = the tap number + +-- Lowpass tap function + +lpf_tap wc m n | n-a == 0 = wc / pi + | otherwise = sin (wc * (n-a)) / (pi * (n-a)) + where a = (fromIntegral m) / 2 + +-- Highpass tap function + +hpf_tap wc m n | n-a == 0 = 1 - wc / pi + | otherwise = sin (pi * (n-a)) / (pi * (n-a)) - lpf_tap wc m n + where a = (fromIntegral m) / 2 + +-- Multiband tap function + +mbf_tap (g:[]) (w:[]) m n = g * lpf_tap w m n +mbf_tap (g1:g2:gs) (w:ws) m n = (g1-g2) * lpf_tap w m n + mbf_tap (g2:gs) ws m n + +-- Raised-cosine tap function. This does _not_ have 0 dB DC gain. + +-- ws = symbol rate in normalized radians +-- b = filter beta + +rc_tap ws b m n | n-a == 0 = 1 + | den == 0 = 0 + | otherwise = sin sarg / sarg * cos carg / den + where sarg = ws * (n-a) / 2 + carg = b * ws * (n-a) / 2 + den = 1 - 4 * ((b*ws*(n-a)) / (2*pi)) ^ 2 + a = (fromIntegral m) / 2 + +-- The following functions generate a list of the taps for a given set of +-- parameter. + +-- | Lowpass filter + +lpf :: (Ix a, Integral a, Enum b, Floating b) => b -- ^ wc + -> a -- ^ M + -> Array a b -- ^ h[n] + +lpf wc m = listArray (0,m) $ map (lpf_tap wc m) (indexes m) + +-- | Highpass filter + +hpf :: (Ix a, Integral a, Enum b, Floating b) => b -- ^ wc + -> a -- ^ M + -> Array a b -- ^ h[n] + +hpf wc m = listArray (0,m) $ map (hpf_tap wc m) (indexes m) + +-- | Bandpass filter + +bpf :: (Ix a, Integral a, Enum b, Floating b) => b -- ^ wl + -> b -- ^ wu + -> a -- ^ M + -> Array a b -- ^ h[n] + +bpf wl wu m = listArray (0,m) $ zipWith (+) (elems $ lpf wu m) (elems $ hpf wl m) + +-- | Bandstop filter + +bsf :: (Ix a, Integral a, Enum b, Floating b) => b -- ^ wl + -> b -- ^ wu + -> a -- ^ M + -> Array a b -- ^ h[n] + +bsf wl wu m = listArray (0,m) $ zipWith (+) (elems $ lpf wl m) (elems $ hpf wu m) + +-- | Multiband filter + +mbf :: (Ix a, Integral a, Enum b, Floating b) => [b] -- ^ [mags] + -> [b] -- ^ [w] + -> a -- ^ M + -> Array a b -- ^ h[n] + +mbf g w m = listArray (0,m) $ map (mbf_tap g w m) (indexes m) + +-- | Raised-cosine filter + +rc :: (Ix a, Integral a, Enum b, Floating b) => b -- ^ ws + -> b -- ^ beta + -> a -- ^ M + -> Array a b -- ^ h[n] + +rc ws b m = listArray (0,m) $ map (rc_tap ws b m) (indexes m) diff --git a/DSP/Filter/FIR/Window.hs b/DSP/Filter/FIR/Window.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/FIR/Window.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.FIR.Window +-- Copyright : (c) Matthew Donadio 1998 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Commonly used window functions. Except for the Parzen window, the +-- results of all of these /look/ right, but I have to check them against +-- either Matlab or my C code. +-- +-- More windowing functions exist, but I have to dig through my papers to +-- find the equations. +-- +----------------------------------------------------------------------------- + +-- TODO: These functions should probably be reworked to use list +-- comprehensions... + +{- + +Reference: + +@Book{dsp, + author = "Alan V. Oppenheim and Ronald W. Schafer", + title = "Discrete-Time Signal Processing", + publisher = "Pretice-Hall", + year = 1989, + address = "Englewood Cliffs", + series = {Pretice-Hall Signal Processing Series} +} + +@Book{kay, + author = "Steven M. Kay", + title = "Modern Spectral Estimation: Theory \& Application", + publisher = "Prentice Hall", + year = 1988, + address = "Englewood Cliffs", + series = {Pretice-Hall Signal Processing Series} +} + +-} + +module DSP.Filter.FIR.Window (window, rectangular, bartlett, hanning, hamming, blackman, + kaiser, gen_hamming, parzen) where + +import Data.Array + +-- | Applys a window, @w@, to a sequence @x@ + +window :: Array Int Double -- ^ w[n] + -> Array Int Double -- ^ x[n] + -> Array Int Double -- ^ w[n] * x[n] + +window w x = listArray (0,m) [ w!i * x!i | i <- [0..m] ] + where m = snd $ bounds w + +-- | rectangular window + +rectangular :: Int -- ^ M + -> Array Int Double -- ^ w[n] + +rectangular m = listArray (0,m) $ replicate (m+1) 1.0 + +-- | Bartlett window + +bartlett :: Int -- ^ M + -> Array Int Double -- ^ w[n] + +bartlett m = listArray (0,m) $ map (bartlett' md) [ 0.0 .. md ] + where bartlett' m n | n <= m / 2 = 2 * n / m + | otherwise = 2 - 2 * n / m + md = fromIntegral m + +-- | Hanning window + +hanning :: Int -- ^ M + -> Array Int Double -- ^ w[n] + +hanning m = listArray (0,m) $ map (hanning' md) [ 0.0 .. md ] + where hanning' m n = 0.5 - 0.5 * cos(2 * pi * n / m) + md = fromIntegral m + +-- | Hamming window + +hamming :: Int -- ^ M + -> Array Int Double -- ^ w[n] + +hamming m = listArray (0,m) $ map (hamming' md) [ 0.0 .. md ] + where hamming' m n = 0.54 - 0.46 * cos(2 * pi * n / m) + md = fromIntegral m + +-- | Blackman window + +blackman :: Int -- ^ M + -> Array Int Double -- ^ w[n] + +blackman m = listArray (0,m) $ map (blackman' md) [ 0.0 .. md ] + where blackman' m n = 0.42 - 0.5 * cos(2 * pi * n / m) + + 0.08 * cos (4 * pi * n / m) + md = fromIntegral m + +-- | Generalized Hamming window + +gen_hamming :: Double -- ^ alpha + -> Int -- ^ M + -> Array Int Double -- ^ w[n] + +gen_hamming a m = listArray (0,m) $ map (hamming' a md) [ 0.0 .. md ] + where hamming' a m n = a - (1 - a) * cos(2 * pi * n / m) + md = fromIntegral m + +-- | rectangular window + +kaiser :: Double -- ^ beta + -> Int -- ^ M + -> Array Int Double -- ^ w[n] + +kaiser b m = listArray (0,m) $ map (kaiser' b md) [ 0.0 .. md ] + where kaiser' b m n = i0 (b * sqrt (1 -((n-a)/a)^2)) / i0 b + md = fromIntegral m + a = md / 2 + +-- Recursive computation of I0, the zeroth-order modified Bessel function +-- of the first kind. + +i0 :: Double -> Double +i0 x = i0' x 2 1 + +i0' :: Double -> Double -> Double -> Double +i0' x d ds | ds < 1.0e-30 = 1 + | otherwise = ds * x^2 / d^2 + (i0' x (d+2) (ds * x^2 / d^2)) + +-- I don't think this one is correct. Kay's book uses different variable +-- conventions and I haven't deciphered them yet... + +-- | rectangular window + +parzen :: Int -- ^ M + -> Array Int Double -- ^ w[n] + +parzen m = listArray (0,m) $ map (parzen' md) [ 0.0 .. md ] + where parzen' m n | n <= m / 2 = 2 * (1-n/m) ^ 3 - (1-2*n/m) ^ 3 + | otherwise = 2 * (1-n/m) ^ 3 + md = fromIntegral m diff --git a/DSP/Filter/IIR/Bilinear.hs b/DSP/Filter/IIR/Bilinear.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/Bilinear.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.IIR.Bilinear +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- The module contains a function for performing the bilinear transform. +-- +-- The input is a rational polynomial representation of the s-domain +-- function to be transformed. +-- +-- In the bilinear transform, we substitute +-- +-- @ 2 1 - z^-1@ +-- +-- @s \<-- -- * --------@ +-- +-- @ ts 1 + z^-1@ +-- +-- into the rational polynomial, where ts is the sampling period. To get +-- a rational polynomial back, we use the following method: +-- +-- (1) Substitute s^n with (2\/ts * (1-z^-1))^n == [ -2\/ts, 2\/ts ]^n +-- +-- 2. Multiply the results by (1+z^-1)^n == [ 1, 1 ]^n +-- +-- 3. Add up all of the common terms +-- +-- 4. Normalize all of the coeficients by a0 +-- +-- where n is the maximum order of the numerator and denominator +-- +----------------------------------------------------------------------------- + +-- TODO: Rework to replace roots2poly using the fact that most poles +-- and\/or zeros are either complex conjugate pairs, or real only. + +-- TODO: Do we want to include prewarping? + +module DSP.Filter.IIR.Bilinear (bilinear, prewarp) where + +import Polynomial.Basic + +-- Computes (2\/ts * (1-z^-1))^n == [ -2\/ts, 2\/ts ]^n + +zm ts n = polypow [ -2/ts, 2/ts ] n + +-- Computes (1+z^-1)^n == [ 1, 1 ]^n + +zp n = polypow [ 1, 1 ] n + +-- Step 1: Substitute s^n with (2\/ts * (1-z^-1))^n == [ -2\/ts, 2\/ts ]^n +-- in num and den + +step1 ts x = step1' ts 0 x + where step1' _ _ [] = [] + step1' ts n (x:xs) = map (x*) (zm ts n) : step1' ts (n+1) xs + +-- Step 2: Multiply the num and den by (1+z^-1)^n == [ 1, 1 ]^n + +step2 _ [] = [] +step2 n (x:xs) = polymult (zp n) x : step2 (n-1) xs + +-- Step 3: Add up all of the common terms + +step3 x = foldr polyadd [0] x + +-- Step 4: Normalize all of the coeficients by a0 + +step4 a0 x = map (/a0) x + +-- Glue it all together + +-- | Performs the bilinear transform + +bilinear :: Double -- ^ T_s + -> ([Double],[Double]) -- ^ (b,a) + -> ([Double],[Double]) -- ^ (b',a') + +bilinear ts (num,den) = (num'', den'') + where n = max (length num - 1) (length den - 1) + num' = step3 $ step2 n $ step1 ts $ num + den' = step3 $ step2 n $ step1 ts $ den + a0 = last den' + num'' = step4 a0 num' + den'' = step4 a0 den' + +-- | Function for frequency prewarping + +prewarp :: Double -- ^ w_c + -> Double -- ^ T_s + -> Double -- ^ W_c + +prewarp wc ts = 2/ts * tan (wc / 2) + +{- + +-- Test, section 6.5.1 from Lyon's book + +num1 = [ 17410.145 ] +den1 = [ 17410.145, 137.94536, 1 ] + +(num1',den1') = bilinear 0.01 (num1,den1) + +-- Test, from O&S, p 421 + +num2 = [ 0.202238 ] +den2 = polymult (polymult [ 0.5871, 0.3996, 1 ] [ 0.5871, 1.0836, 1 ] ) [ 0.5871, 1.4802, 1 ] + +(num2',den2') = bilinear 1 (num2,den2) + +bilinear ([0, 0, 0, 0, 1], reverse [ 1, 158881.5000000000000000000000, 6734684542.320000000000000000, 33433292062222.63200000000000, 26749649944094120.95199999999, 5301498365227355432.219999999, 308666240537082938598.7999999 ]) 48000 + +> num3 = [ 0, 0, 0, 0, 72687672654.5 ] +> den3 = reverse [ 1, 158881.5000000000000000000000, 6734684542.320000000000000000, 33433292062222.63200000000000, 26749649944094120.95199999999, 5301498365227355432.219999999, 308666240537082938598.7999999 ] + +num31 = [ 0.0, 519.2365 ] +den31 = polypow [ 129.4, 1.0 ] 2 + +num32 = [ 0.0, 519.2365 ] +den32 = [ 676.7, 1.0 ] + +num33 = [ 0.0, 519.2365 ] +den33 = [ 4636.0, 1.0 ] + +num34 = [ 0.0, 519.2365 ] +den34 = polypow [ 76655.0, 1.0 ] 2 + +-} diff --git a/DSP/Filter/IIR/Cookbook.lhs b/DSP/Filter/IIR/Cookbook.lhs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/Cookbook.lhs @@ -0,0 +1,340 @@ +Haskell implementation of rb-j's IIR cookbook. I have turned his text +file into a literate Haskell file. You can find the original at: + +http://www.harmony-central.com/Computer/Programming/Audio-EQ-Cookbook.txt + +--Matt Donadio (m.p.donadio@ieee.org) + +> ----------------------------------------------------------------------------- +> -- | +> -- Module : DSP.Filter.IIR.IIR +> -- Copyright : (c) Matthew Donadio 2003 +> -- License : GPL +> -- +> -- Maintainer : m.p.donadio@ieee.org +> -- Stability : experimental +> -- Portability : portable +> -- +> -- Cookbook formulae for audio EQ biquad filter coefficients +> -- by Robert Bristow-Johnson +> -- +> -- +> -- +> ----------------------------------------------------------------------------- + + +> module DSP.Filter.IIR.Cookbook where + +> import DSP.Filter.IIR.IIR + + Cookbook formulae for audio EQ biquad filter coefficients +----------------------------------------------------------------------------- + by Robert Bristow-Johnson + +All filter transfer functions were derived from analog prototypes (that +are shown below for each EQ filter type) and had been digitized using the +Bilinear Transform. BLT frequency warping has been taken into account +for both significant frequency relocation and for bandwidth readjustment. + +First, given a biquad transfer function defined as: + + b0 + b1*z^-1 + b2*z^-2 + H(z) = ------------------------ (Eq 1) + a0 + a1*z^-1 + a2*z^-2 + +This shows 6 coefficients instead of 5 so, depending on your +architechture, you will likely normalize a0 to be 1 and perhaps also +b0 to 1 (and collect that into an overall gain coefficient). Then +your transfer function would look like: + + (b0/a0) + (b1/a0)*z^-1 + (b2/a0)*z^-2 + H(z) = --------------------------------------- (Eq 2) + 1 + (a1/a0)*z^-1 + (a2/a0)*z^-2 + +or + + 1 + (b1/b0)*z^-1 + (b2/b0)*z^-2 + H(z) = (b0/a0) * --------------------------------- (Eq 3) + 1 + (a1/a0)*z^-1 + (a2/a0)*z^-2 + + +The most straight forward implementation would be the Direct I form +(using Eq 2): + + y[n] = (b0/a0)*x[n] + (b1/a0)*x[n-1] + (b2/a0)*x[n-2] + - (a1/a0)*y[n-1] - (a2/a0)*y[n-2] (Eq 4) + +This is probably both the best and the easiest method to implement in +the 56K. + +Now, given: + + sampleRate (the sampling frequency) + + frequency ("wherever it's happenin', man." "center" frequency + or "corner" (-3 dB) frequency, or shelf midpoint frequency, + depending on which filter type) + + dBgain (used only for peaking and shelving filters) + + bandwidth in octaves (between -3 dB frequencies for BPF and notch + or between midpoint (dBgain/2) gain frequencies for peaking EQ) + + _or_ Q (the EE kind of definition, except for peakingEQ in which A*Q + is the classic EE Q. That adjustment in definition was done so + that a boost of N dB followed by a cut of N dB for identical Q and + frequency results in a perfectly flat unity gain filter or "wire".) + + _or_ S, a "shelf slope" parameter (for shelving EQ only). When S = 1, + the shelf slope is as steep as it can be and remain monotonically + increasing or decreasing gain with frequency. The shelf slope, in + dB/octave, remains proportional to S for all other values. + + + +First compute a few intermediate variables: + + A = sqrt[ 10^(dBgain/20) ] + = 10^(dBgain/40) (for peaking and shelving EQ filters only) + + omega = 2*pi*frequency/sampleRate + + sin = sin(omega) + cos = cos(omega) + + + alpha = sin/(2*Q) (if Q is specified) + = sin*sinh[ ln(2)/2 * bandwidth * omega/sin ] (if bandwidth is specified) + + The relationship between bandwidth and Q is + 1/Q = 2*sinh[ln(2)/2*bandwidth*omega/sin] (digital filter using BLT) + or 1/Q = 2*sinh[ln(2)/2*bandwidth]) (analog filter prototype) + + + beta = sqrt(A)/Q (for shelving EQ filters only) + = sqrt(A)*sqrt[ (A + 1/A)*(1/S - 1) + 2 ] (if shelf slope is specified) + = sqrt[ (A^2 + 1)/S - (A-1)^2 ] + + The relationship between shelf slope and Q is + 1/Q = sqrt[(A + 1/A)*(1/S - 1) + 2] + + +Then compute the coefficients for whichever filter type you want: + + The analog prototypes are shown for normalized frequency. + The bilinear transform substitutes: + + 1 1 - z^-1 + s <- -------------- * ---------- + tan(omega/2) 1 + z^-1 + + and makes use of these trig identities: + + sin(w) 1 - cos(w) + tan(w/2) = ------------ (tan(w/2))^2 = ------------ + 1 + cos(w) 1 + cos(w) + + + +LPF: H(s) = 1 / (s^2 + s/Q + 1) + + b0 = (1 - cos)/2 + b1 = 1 - cos + b2 = (1 - cos)/2 + a0 = 1 + alpha + a1 = -2*cos + a2 = 1 - alpha + +> {-# specialize lpf :: Float -> Float -> [Float] -> [Float] #-} +> {-# specialize lpf :: Double -> Double -> [Double] -> [Double] #-} + +> lpf :: Floating a => a -> a -> [a] -> [a] +> lpf bw w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = (1 - cos w) / 2 +> b1 = 1 - cos w +> b2 = (1 - cos w) / 2 +> a0 = 1 + alpha +> a1 = -2 * cos w +> a2 = 1 - alpha +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) + +HPF: H(s) = s^2 / (s^2 + s/Q + 1) + + b0 = (1 + cos)/2 + b1 = -(1 + cos) + b2 = (1 + cos)/2 + a0 = 1 + alpha + a1 = -2*cos + a2 = 1 - alpha + +> {-# specialize hpf :: Float -> Float -> [Float] -> [Float] #-} +> {-# specialize hpf :: Double -> Double -> [Double] -> [Double] #-} + +> hpf :: Floating a => a -> a -> [a] -> [a] +> hpf bw w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = (1 + cos w) / 2 +> b1 = -(1 + cos w) +> b2 = (1 + cos w) / 2 +> a0 = 1 + alpha +> a1 = -2 * cos w +> a2 = 1 - alpha +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) + +BPF: H(s) = s / (s^2 + s/Q + 1) (constant skirt gain, peak gain = Q) + + b0 = sin/2 = Q*alpha + b1 = 0 + b2 = -sin/2 = -Q*alpha + a0 = 1 + alpha + a1 = -2*cos + a2 = 1 - alpha + +> {-# specialize bpf_csg :: Float -> Float -> [Float] -> [Float] #-} +> {-# specialize bpf_csg :: Double -> Double -> [Double] -> [Double] #-} + +> bpf_csg :: Floating a => a -> a -> [a] -> [a] +> bpf_csg bw w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = sin w / 2 +> b1 = 0 +> b2 = -sin w / 2 +> a0 = 1 + alpha +> a1 = -2 * cos w +> a2 = 1 - alpha +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) + +BPF: H(s) = (s/Q) / (s^2 + s/Q + 1) (constant 0 dB peak gain) + + b0 = alpha + b1 = 0 + b2 = -alpha + a0 = 1 + alpha + a1 = -2*cos + a2 = 1 - alpha + +> {-# specialize bpf_cpg :: Float -> Float -> [Float] -> [Float] #-} +> {-# specialize bpf_cpg :: Double -> Double -> [Double] -> [Double] #-} + +> bpf_cpg :: Floating a => a -> a -> [a] -> [a] +> bpf_cpg bw w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = alpha +> b1 = 0 +> b2 = -alpha +> a0 = 1 + alpha +> a1 = -2 * cos w +> a2 = 1 - alpha +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) + +notch: H(s) = (s^2 + 1) / (s^2 + s/Q + 1) + + b0 = 1 + b1 = -2*cos + b2 = 1 + a0 = 1 + alpha + a1 = -2*cos + a2 = 1 - alpha + +> {-# specialize notch :: Float -> Float -> [Float] -> [Float] #-} +> {-# specialize notch :: Double -> Double -> [Double] -> [Double] #-} + +> notch :: Floating a => a -> a -> [a] -> [a] +> notch bw w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = 1 +> b1 = -2 * cos w +> b2 = 1 +> a0 = 1 + alpha +> a1 = -2 * cos w +> a2 = 1 - alpha +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) + +APF: H(s) = (s^2 - s/Q + 1) / (s^2 + s/Q + 1) + + b0 = 1 - alpha + b1 = -2*cos + b2 = 1 + alpha + a0 = 1 + alpha + a1 = -2*cos + a2 = 1 - alpha + +> {-# specialize apf :: Float -> Float -> [Float] -> [Float] #-} +> {-# specialize apf :: Double -> Double -> [Double] -> [Double] #-} + +> apf :: Floating a => a -> a -> [a] -> [a] +> apf bw w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = 1 - alpha +> b1 = -2 * cos w +> b2 = 1 + alpha +> a0 = 1 + alpha +> a1 = -2 * cos w +> a2 = 1 - alpha +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) + +peakingEQ: H(s) = (s^2 + s*(A/Q) + 1) / (s^2 + s/(A*Q) + 1) + + b0 = 1 + alpha*A + b1 = -2*cos + b2 = 1 - alpha*A + a0 = 1 + alpha/A + a1 = -2*cos + a2 = 1 - alpha/A + +> {-# specialize peakingEQ :: Float -> Float -> Float -> [Float] -> [Float] #-} +> {-# specialize peakingEQ :: Double -> Double -> Double -> [Double] -> [Double] #-} + +> peakingEQ :: Floating a => a -> a -> a -> [a] -> [a] +> peakingEQ bw dBgain w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = 1 + alpha * a +> b1 = -2 * cos w +> b2 = 1 - alpha * a +> a0 = 1 + alpha / a +> a1 = -2 * cos w +> a2 = 1 - alpha / a +> alpha = sin w * sinh (log 2 / 2 * bw * w / sin w) +> a = 10 ** (dBgain / 40) + +lowShelf: H(s) = A * (s^2 + (sqrt(A)/Q)*s + A) / (A*s^2 + (sqrt(A)/Q)*s + 1) + + b0 = A*[ (A+1) - (A-1)*cos + beta*sin ] + b1 = 2*A*[ (A-1) - (A+1)*cos ] + b2 = A*[ (A+1) - (A-1)*cos - beta*sin ] + a0 = (A+1) + (A-1)*cos + beta*sin + a1 = -2*[ (A-1) + (A+1)*cos ] + a2 = (A+1) + (A-1)*cos - beta*sin + +> {-# specialize lowShelf :: Float -> Float -> Float -> Float -> [Float] -> [Float] #-} +> {-# specialize lowShelf :: Double -> Double -> Double -> Double -> [Double] -> [Double] #-} + +> lowShelf :: Floating a => a -> a -> a -> a -> [a] -> [a] +> lowShelf bw s dBgain w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = a*( (a+1) - (a-1) * cos w + beta * sin w) +> b1 = 2*a*( (a-1) - (a+1) * cos w ) +> b2 = a*( (a+1) - (a-1) * cos w - beta * sin w) +> a0 = (a+1) + (a-1) * cos w + beta * sin w +> a1 = -2*( (a-1) + (a+1) * cos w ) +> a2 = (a+1) + (a-1) * cos w - beta * sin w +> beta = sqrt ((a^2 + 1) / s - (a-1)^2) +> a = 10 ** (dBgain / 40) + +highShelf: H(s) = A * (A*s^2 + (sqrt(A)/Q)*s + 1) / (s^2 + (sqrt(A)/Q)*s + A) + + b0 = A*[ (A+1) + (A-1)*cos + beta*sin ] + b1 = -2*A*[ (A-1) + (A+1)*cos ] + b2 = A*[ (A+1) + (A-1)*cos - beta*sin ] + a0 = (A+1) - (A-1)*cos + beta*sin + a1 = 2*[ (A-1) - (A+1)*cos ] + a2 = (A+1) - (A-1)*cos - beta*sin + +> {-# specialize highShelf :: Float -> Float -> Float -> Float -> [Float] -> [Float] #-} +> {-# specialize highShelf :: Double -> Double -> Double -> Double -> [Double] -> [Double] #-} + +> highShelf :: Floating a => a -> a -> a -> a -> [a] -> [a] +> highShelf bw s dBgain w = biquad_df1 (a1/a0) (a2/a0) (b0/a0) (b1/a0) (b2/a0) +> where b0 = a*( (a+1) - (a-1) * cos w + beta * sin w) +> b1 = -2*a*( (a-1) - (a+1) * cos w ) +> b2 = a*( (a+1) - (a-1) * cos w - beta * sin w) +> a0 = (a+1) + (a-1) * cos w + beta * sin w +> a1 = -2*( (a-1) + (a+1) * cos w ) +> a2 = (a+1) + (a-1) * cos w - beta * sin w +> beta = sqrt ((a^2 + 1) / s - (a-1)^2) +> a = 10 ** (dBgain / 40) + +(This text-only file is best viewed or printed with a mono-spaced font.) diff --git a/DSP/Filter/IIR/Design.hs b/DSP/Filter/IIR/Design.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/Design.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.IIR.Design +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Lowpass IIR design functions +-- +-- Method: +-- +-- (1) Design analog prototype +-- +-- 2. Perform analog-to-analog frequency transformation +-- +-- 3. Perform bilinear transform +-- +----------------------------------------------------------------------------- + +module DSP.Filter.IIR.Design where + +import Data.Array + +import DSP.Filter.Analog.Prototype +import DSP.Filter.Analog.Transform +import DSP.Filter.IIR.Bilinear + +poly2iir (b,a) = (b',a') + where b' = listArray (0,m) $ reverse $ b + a' = listArray (0,n) $ reverse $ a + m = length b - 1 + n = length a - 1 + +-- | Generates lowpass Butterworth IIR filters + +mkButterworth :: (Double, Double) -- ^ (wp,dp) + -> (Double, Double) -- ^ (ws,ds) + -> (Array Int Double, Array Int Double) -- ^ (b,a) + +mkButterworth (wp,dp) (ws,ds) = poly2iir $ + bilinear 1 $ + a_lp2lp wc $ + butterworth n + where n = ceiling $ log (((1/ds)^2-1) / ((1/(1-dp))^2-1)) / 2 / log (ws' / wp') + wc = ws' / ((1/ds)^2-1)**(1/2/fromIntegral n) + wp' = prewarp wp 1 + ws' = prewarp ws 1 + +-- | Generates lowpass Chebyshev IIR filters + +mkChebyshev1 :: (Double, Double) -- ^ (wp,dp) + -> (Double, Double) -- ^ (ws,ds) + -> (Array Int Double, Array Int Double) -- ^ (b,a) + +mkChebyshev1 (wp,dp) (ws,ds) = poly2iir $ + bilinear 1 $ + a_lp2lp wp' $ + chebyshev1 eps n + where wp' = prewarp wp 1 + ws' = prewarp ws 1 + eps = sqrt ((2 - dp)*dp) / (1 - dp) + a = 1 / ds + k1 = eps / sqrt (a^2 - 1) + k = wp' / ws' + n = ceiling $ acosh (1/k1) / log ((1 + sqrt (1 - k^2)) / k) + +-- | Generates lowpass Inverse Chebyshev IIR filters + +mkChebyshev2 :: (Double, Double) -- ^ (wp,dp) + -> (Double, Double) -- ^ (ws,ds) + -> (Array Int Double, Array Int Double) -- ^ (b,a) + +mkChebyshev2 (wp,dp) (ws,ds) = poly2iir $ + bilinear 1 $ + a_lp2lp ws' $ + chebyshev2 eps n + where wp' = prewarp wp 1 + ws' = prewarp ws 1 + eps = ds / sqrt (1 - ds^2) + g = 1 - dp + n = ceiling $ acosh (g / eps / sqrt (1 - g^2)) / acosh (ws' / wp') diff --git a/DSP/Filter/IIR/IIR.hs b/DSP/Filter/IIR/IIR.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/IIR.hs @@ -0,0 +1,315 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.IIR.IIR +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- IIR functions +-- +-- IMPORTANT NOTE: +-- +-- Except in integrator, we use the convention that +-- +-- @y[n] = sum(k=0..M) b_k*x[n-k] - sum(k=1..N) a_k*y[n-k]@ +-- +-- +-- +-- @ sum(k=0..M) b_k*z^-1@ +-- +-- @H(z) = ------------------------@ +-- +-- @ 1 + sum(k=1..N) a_k*z^-1@ +-- +----------------------------------------------------------------------------- + +-- TODO: Should these use Arrays for a and b? Tuples? + +{- + +Reference: + +@Book{dsp, + author = "Alan V. Oppenheim and Ronald W. Schafer", + title = "Discrete-Time Signal Processing", + publisher = "Pretice-Hall", + year = 1989, + address = "Englewood Cliffs", + series = {Pretice-Hall Signal Processing Series} +} + +However, we differ in the convention of the sign of the poles, as +noted in the module header. + +-} + +module DSP.Filter.IIR.IIR (integrator, + fos_df1, fos_df2, fos_df2t, + biquad_df1, biquad_df2, biquad_df2t, + iir_df1, iir_df2) where + +import Data.Array + +import DSP.Filter.FIR.FIR + +-- | This is an integrator when a==1, and a leaky integrator when @0 \< a \< 1@. +-- +-- @y[n] = a * y[n-1] + x[n]@ + +{-# specialize integrator :: Float -> [Float] -> [Float] #-} +{-# specialize integrator :: Double -> [Double] -> [Double] #-} + +integrator :: Num a => a -- ^ a + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +integrator a x = integrator' a 0 x + + +integrator' :: Num a => a -> a-> [a] -> [a] +integrator' _ _ [] = [] +integrator' a y1 (x:xs) = y : integrator' a y xs + where y = a * y1 + x + +-- | First order section, DF1 +-- +-- @v[n] = b0 * x[n] + b1 * x[n-1]@ +-- +-- @y[n] = v[n] - a1 * y[n-1]@ + +{-# specialize fos_df1 :: Float -> Float -> Float -> [Float] -> [Float] #-} +{-# specialize fos_df1 :: Double -> Double -> Double -> [Double] -> [Double] #-} + +fos_df1 :: Num a => a -- ^ a_1 + -> a -- ^ b_0 + -> a -- ^ b_1 + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +fos_df1 a1 b0 b1 x = fos_df1' a1 b0 b1 0 0 x + +fos_df1' :: Num a => a -> a -> a -> a -> a -> [a] -> [a] +fos_df1' _ _ _ _ _ [] = [] +fos_df1' a1 b0 b1 x1 y1 (x:xs) = y : fos_df1' a1 b0 b1 x y xs + where v = b0 * x + b1 * x1 + y = v - a1 * y1 + + +-- | First order section, DF2 +-- +-- @w[n] = -a1 * w[n-1] + x[n]@ +-- +-- @y[n] = b0 * w[n] + b1 * w[n-1]@ + +{-# specialize fos_df2 :: Float -> Float -> Float -> [Float] -> [Float] #-} +{-# specialize fos_df2 :: Double -> Double -> Double -> [Double] -> [Double] #-} + +fos_df2 :: Num a => a -- ^ a_1 + -> a -- ^ b_0 + -> a -- ^ b_1 + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +fos_df2 a1 b0 b1 x = fos_df2' a1 b0 b1 0 x + +fos_df2' :: Num a => a -> a -> a -> a -> [a] -> [a] +fos_df2' _ _ _ _ [] = [] +fos_df2' a1 b0 b1 w1 (x:xs) = y : fos_df2' a1 b0 b1 w xs + where w = x - a1 * w1 + y = b0 * w + b1 * w1 + +-- | First order section, DF2T +-- +-- @v0[n] = b0 * x[n] + v1[n-1]@ +-- +-- @y[n] = v0[n]@ +-- +-- @v1[n] = -a1 * y[n] + b1 * x[n]@ + +{-# specialize fos_df2t :: Float -> Float -> Float -> [Float] -> [Float] #-} +{-# specialize fos_df2t :: Double -> Double -> Double -> [Double] -> [Double] #-} + +fos_df2t :: Num a => a -- ^ a_1 + -> a -- ^ b_0 + -> a -- ^ b_1 + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +fos_df2t a1 b0 b1 x = fos_df2t' a1 b0 b1 0 x + +fos_df2t' :: Num a => a -> a -> a -> a -> [a] -> [a] +fos_df2t' _ _ _ _ [] = [] +fos_df2t' a1 b0 b1 v11 (x:xs) = y : fos_df2t' a1 b0 b1 v1 xs + where v0 = b0 * x + v11 + y = v0 + v1 = -a1 * y + b1 * x + +-- | Direct Form I for a second order section +-- +-- @v[n] = b0 * x[n] + b1 * x[n-1] + b2 * x[n-2]@ +-- +-- @y[n] = v[n] - a1 * y[n-1] - a2 * y[n-2]@ + +{-# specialize biquad_df1 :: Float -> Float -> Float -> Float -> Float -> [Float] -> [Float] #-} +{-# specialize biquad_df1 :: Double -> Double -> Double -> Double -> Double -> [Double] -> [Double] #-} + +biquad_df1 :: Num a => a -- ^ a_1 + -> a -- ^ a_2 + -> a -- ^ b_0 + -> a -- ^ b_1 + -> a -- ^ b_2 + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +biquad_df1 a1 a2 b0 b1 b2 x = df1 a1 a2 b0 b1 b2 0 0 0 0 x + +df1 :: Num a => a -> a -> a -> a -> a -> a -> a -> a -> a -> [a] -> [a] +df1 _ _ _ _ _ _ _ _ _ [] = [] +df1 a1 a2 b0 b1 b2 x1 x2 y1 y2 (x:xs) = y : df1 a1 a2 b0 b1 b2 x x1 y y1 xs + where v = b0 * x + b1 * x1 + b2 * x2 + y = v - a1 * y1 - a2 * y2 + + +-- | Direct Form II for a second order section (biquad) +-- +-- @w[n] = -a1 * w[n-1] - a2 * w[n-2] + x[n]@ +-- +-- @y[n] = b0 * w[n] + b1 * w[n-1] + b2 * w[n-2]@ + +{-# specialize biquad_df2 :: Float -> Float -> Float -> Float -> Float -> [Float] -> [Float] #-} +{-# specialize biquad_df2 :: Double -> Double -> Double -> Double -> Double -> [Double] -> [Double] #-} + +biquad_df2 :: Num a => a -- ^ a_1 + -> a -- ^ a_2 + -> a -- ^ b_0 + -> a -- ^ b_1 + -> a -- ^ b_2 + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +biquad_df2 a1 a2 b0 b1 b2 x = df2 a1 a2 b0 b1 b2 0 0 x + +df2 :: Num a => a -> a -> a -> a -> a -> a -> a -> [a] -> [a] +df2 _ _ _ _ _ _ _ [] = [] +df2 a1 a2 b0 b1 b2 w1 w2 (x:xs) = y : df2 a1 a2 b0 b1 b2 w w1 xs + where w = x - a1 * w1 - a2 * w2 + y = b0 * w + b1 * w1 + b2 * w2 + +-- | Transposed Direct Form II for a second order section +-- +-- @v0[n] = b0 * x[n] + v1[n-1]@ +-- +-- @y[n] = v0[n]@ +-- +-- @v1[n] = -a1 * y[n] + b1 * x[n] + v2[n-1]@ +-- +-- @v2[n] = -a2 * y[n] + b2 * x[n]@ + +{-# specialize biquad_df2t :: Float -> Float -> Float -> Float -> Float -> [Float] -> [Float] #-} +{-# specialize biquad_df2t :: Double -> Double -> Double -> Double -> Double -> [Double] -> [Double] #-} + +biquad_df2t :: Num a => a -- ^ a_1 + -> a -- ^ a_2 + -> a -- ^ b_0 + -> a -- ^ b_1 + -> a -- ^ b_2 + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +biquad_df2t a1 a2 b0 b1 b2 x = df2t a1 a2 b0 b1 b2 0 0 x + +df2t :: Num a => a -> a -> a -> a -> a -> a -> a -> [a] -> [a] +df2t _ _ _ _ _ _ _ [] = [] +df2t a1 a2 b0 b1 b2 v11 v21 (x:xs) = y : df2t a1 a2 b0 b1 b2 v1 v2 xs + where v0 = b0 * x + v11 + y = v0 + v1 = -a1 * y + b1 * x + v21 + v2 = -a2 * y + b2 * x + +-- | Direct Form I IIR +-- +-- @v[n] = sum(k=0..M) b_k*x[n-k]@ +-- +-- @y[n] = v[n] - sum(k=1..N) a_k*y[n-k]@ +-- +-- @v[n]@ is calculated with 'fir' + +{- specialize iir_df1 :: (Array Int Float, Array Int Float) -> [Float] -> [Float] -} +{- specialize iir_df1 :: (Array Int Double, Array Int Double) -> [Double] -> [Double] -} + +iir_df1 :: (Num a) => (Array Int a, Array Int a) -- ^ (b,a) + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +iir_df1 (b,a) x = y + where v = fir b x + y = iir'df1 a w v + w = listArray (1,n) $ repeat 0 + n = snd $ bounds a + +{- specialize iir'df1 :: Array Int Float -> Array Int Float -> [Float] -> [Float] -} +{- specialize iir'df1 :: Array Int Double -> Array Int Double -> [Double] -> [Double] -} + +iir'df1 :: (Num a) => Array Int a -> Array Int a -> [a] -> [a] +iir'df1 a w [] = [] +iir'df1 a w (v:vs) = y : iir'df1 a w' vs + where y = v - sum [ a!i * w!i | i <- [1..n] ] + w' = listArray (1,n) $ y : elems w + n = snd $ bounds a + +-- | Direct Form II IIR +-- +-- @w[n] = x[n] - sum(k=1..N) a_k*w[n-k]@ +-- +-- @y[n] = sum(k=0..M) b_k*w[n-k]@ + +{- specialize iir_df2 :: (Array Int Float, Array Int Float) -> [Float] -> [Float] -} +{- specialize iir_df2 :: (Array Int Double, Array Int Double) -> [Double] -> [Double] -} + +iir_df2 :: (Num a) => (Array Int a, Array Int a) -- ^ (b,a) + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +iir_df2 (b,a) x = y + where y = iir'df2 (b,a) w x + w = listArray (0,mn) $ repeat 0 + m = snd $ bounds b + n = snd $ bounds a + mn = max m n + +{- specialize iir'df2 :: Array Int Float -> Array Int Float -> [Float] -> [Float] -} +{- specialize iir'df2 :: Array Int Double -> Array Int Double -> [Double] -> [Double] -} + +iir'df2 :: (Num a) => (Array Int a,Array Int a) -> Array Int a -> [a] -> [a] +iir'df2 (b,a) w [] = [] +iir'df2 (b,a) w (x:xs) = y : iir'df2 (b,a) w' xs + where y = sum [ b!i * w'!i | i <- [0..m] ] + w0 = x - sum [ a!i * w'!i | i <- [1..m] ] + w' = listArray (0,mn) $ w0 : elems w + m = snd $ bounds b + n = snd $ bounds a + mn = snd $ bounds w + +--------- + +-- test + +x = [ 1, 0, 0, 0, 0, 0, 0, 0 ] :: [Double] + +y = integrator 0.5 x + +f1 x = biquad_df1 (-0.4) 0.3 0.5 0.4 (-0.3) x + +f2 x = biquad_df2 (-0.4) 0.3 0.5 0.4 (-0.3) x + +f3 x = biquad_df2t (-0.4) 0.3 0.5 0.4 (-0.3) x + +a = listArray (1,2) [ -0.4, 0.3 ] +b = listArray (0,2) [ 0.5, 0.4, -0.3 ] + +f4 x = iir_df1 (b,a) x + +f5 x = iir_df2 (b,a) x diff --git a/DSP/Filter/IIR/Matchedz.hs b/DSP/Filter/IIR/Matchedz.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/Matchedz.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.IIR.Matchedz +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Matched-z transform +-- +-- References: Proakis and Manolakis, Rabiner and Gold +-- +----------------------------------------------------------------------------- + + +module DSP.Filter.IIR.Matchedz (matchedz) where + +import Polynomial.Basic +import Polynomial.Roots + +import Data.Complex + +-- | Performs the matched-z transform + +matchedz :: Double -- ^ T_s + -> ([Double],[Double]) -- ^ (b,a) + -> ([Double],[Double]) -- ^ (b',a') + +matchedz ts (num,den) = (num',den') + where zeros = roots 1.0e-12 1000 $ map (:+ 0) $ num + poles = roots 1.0e-12 1000 $ map (:+ 0) $ den + zeros' = map exp $ map (* (ts :+ 0)) $ zeros + poles' = map exp $ map (* (ts :+ 0)) $ poles + num' = map realPart $ roots2poly zeros' + den' = map realPart $ roots2poly poles' diff --git a/DSP/Filter/IIR/Prony.hs b/DSP/Filter/IIR/Prony.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/Prony.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.IIR.Prony +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- General case of Prony's Method where K > p+q +-- +-- References: L&I, Sect 8.1; P&B, Sect 7.5; P&M, Sect 8.5.2 +-- +-- Notation follows L&I +-- +----------------------------------------------------------------------------- + +-- TODO: Handle rank deficiencies of G3 gracefully. Can/should we +-- generate a (K/2+1) by (K/2+1) G2, and set p=q=rank(G2)? Need SVD to +-- compute rank, though. + +module DSP.Filter.IIR.Prony (prony) where + +import Data.Array + +import Matrix.Matrix +import Matrix.LU + +{------------------------------------------------------------------------------ + +Case 1: K=p+q + +a = array (0,p) +b = array (0,q) + +g1 : q+1 by p+1 +g2 : p by p+1 +g3 : p by p + +We do not define G1 and G2, but + +mg2 = array ((1,1),(p,p+1)) [ ((i,j), g!(p+i+1-j)) | j <- [1..p+1], i <- [1..p] ] + +prony p q g = (a,b) + where mg3 = array ((1,1),(p,p)) [ ((i,j), g!(p+i-j)) | j <- [1..p], i <- [1..p] ] + g1 = array (1,p) [ (i, g!(p+i)) | i <- [1..p] ] + a' = solve mg3 (fmap negate g1) + a = array (0,p) $ (0,1) : [ (i,a'!i) | i <- [1..p] ] + b = listArray (0,q) [ sum [ a!j * g!(i-j) | j <- [0..(min i p)] ] | i <- [0..q] ] + +Test case, pg 422 + +g = listArray (0,6) [ 1, 18, 9, 2, 1, 2/9, 1/9 ] :: Array Int Double + +------------------------------------------------------------------------------} + +-- Case 2: K>p+q + +-- a = array (0,p) +-- b = array (0,q) + +-- g1 : q+1 by p+1 +-- g2 : K-q by p+1 +-- g3 : K-q by p + +-- We need gi for the q

Int -- ^ q + -> Array Int Double -- ^ g[n] + -> (Array Int Double, Array Int Double) -- ^ (b,a) + +prony p q g = (b,a) + where k = snd $ bounds g + gi i | i < 0 = 0 + | i > k = 0 + | otherwise = g!i + mg3 = array ((1,1),(k-q,p)) [ ((i,j), gi (q+i-j)) | j <- [1..p], i <- [1..k-q] ] + g1 = array (1,k-q) [ (i, gi (q+i)) | i <- [1..k-q] ] + a' = solve (mm_mult (m_trans mg3) mg3) (fmap negate (mv_mult (m_trans mg3) g1)) + a = array (0,p) $ (0,1) : [ (i,a'!i) | i <- [1..p] ] + b = listArray (0,q) [ sum [ a!j * gi (i-j) | j <- [0..(min i p)] ] | i <- [0..q] ] diff --git a/DSP/Filter/IIR/Transform.hs b/DSP/Filter/IIR/Transform.hs new file mode 100644 --- /dev/null +++ b/DSP/Filter/IIR/Transform.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Filter.IIR.Transform +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Digital IIR filter transforms +-- +-- Reference: R&G, pg 260; O&S, pg 434; P&M, pg 699 +-- +-- Notation follows O&S +-- +----------------------------------------------------------------------------- + +-- TODO: These need more testing. I checked the lp2hp case against O&S +-- which verifies substitute and lp2hp,nd I triple checked the parameters +-- for the others. I need to find test vectors for the other cases for +-- proper testing, though. + +module DSP.Filter.IIR.Transform (d_lp2lp, d_lp2hp, d_lp2bp, d_lp2bs) where + +import Data.Complex + +import Polynomial.Basic + +normalize :: ([Double],[Double]) -> ([Double],[Double]) +normalize (num,den) = (num',den') + where a0 = last den + num' = map (/ a0) num + den' = map (/ a0) den + +substitute :: ([Double],[Double]) -> ([Double],[Double]) -> ([Double],[Double]) +substitute (nsub,dsub) (num,den) = normalize (num',den') + where n = max (length num - 1) (length den - 1) + num' = step3 $ step2 0 dsub $ step1 n nsub $ num + den' = step3 $ step2 0 dsub $ step1 n nsub $ den + step1 _ _ [] = [] + step1 n w (x:xs) = map (x*) (polypow w n) : step1 (n-1) w xs + step2 _ _ [] = [] + step2 n w (x:xs) = polymult (polypow w n) x : step2 (n+1) w xs + step3 x = foldr polyadd [0] x + +-- Cotangent + +cot :: Double -> Double +cot x = 1 / tan x + +-- | Lowpass to lowpass: @z^-1 --> (z^-1 - a)\/(1 - a*z^-1)@ + +d_lp2lp :: Double -- ^ theta_p + -> Double -- ^ omega_p + -> ([Double], [Double]) -- ^ (b,a) + -> ([Double], [Double]) -- ^ (b',a') + +d_lp2lp tp wp (num,den) = substitute (nsub,dsub) (num,den) + where nsub = [1, -a] + dsub = [-a, 1] + a = sin ((tp-wp)/2) / sin ((tp+wp)/2) + +-- | Lowpass to Highpass: @z^-1 --> -(z^-1 + a)\/(1 + a*z^-1)@ + +d_lp2hp :: Double -- ^ theta_p + -> Double -- ^ omega_p + -> ([Double], [Double]) -- ^ (b,a) + -> ([Double], [Double]) -- ^ (b',a') + +d_lp2hp tp wp (num,den) = substitute (nsub,dsub) (num,den) + where nsub = [-1, -a] + dsub = [a, 1] + a = -cos ((tp+wp)/2) / cos ((tp-wp)/2) + +-- | Lowpass to Bandpass: z^-1 --> + +d_lp2bp :: Double -- ^ theta_p + -> Double -- ^ omega_p1 + -> Double -- ^ omega_p2 + -> ([Double], [Double]) -- ^ (b,a) + -> ([Double], [Double]) -- ^ (b',a') + +d_lp2bp tp wp1 wp2 (num,den) = substitute (nsub,dsub) (num,den) + where nsub = [ 1, -2*a*k/(k+1), (k-1)/(k+1) ] + dsub = [ (k-1)/(k+1), -2*a*k/(k+1), 1 ] + a = cos ((wp2+wp1)/2) / cos ((wp2-wp1)/2) + k = cot ((wp2-wp1)/2) * tan (tp/2) + +-- | Lowpass to Bandstop: z^-1 --> + +d_lp2bs :: Double -- ^ theta_p + -> Double -- ^ omega_p1 + -> Double -- ^ omega_p2 + -> ([Double], [Double]) -- ^ (b,a) + -> ([Double], [Double]) -- ^ (b',a') + +d_lp2bs tp wp1 wp2 (num,den) = substitute (nsub,dsub) (num,den) + where nsub = [ 1, -2*a/(1+k), (1-k)/(1+k) ] + dsub = [ (1-k)/(1+k), -2*a/(1+k), 1 ] + a = cos ((wp2+wp1)/2) / cos ((wp2-wp1)/2) + k = cot ((wp2-wp1)/2) * tan (tp/2) + +{- + +Test vectors + +O&S, pg 435 + + num = polypow [ 0.001836, 0.001836 ] 4 + den = polymult [ 0.6493, -1.5548, 1 ] [ 0.8482, -1.4996, 1 ] + +-} diff --git a/DSP/Flowgraph.hs b/DSP/Flowgraph.hs new file mode 100644 --- /dev/null +++ b/DSP/Flowgraph.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Flowgraph +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Flowgraph functions +-- +-- DO NOT USE YET +-- +----------------------------------------------------------------------------- + +module DSP.Flowgraph where + +----------------------------------------------------------------------------- + +-- | Cascade of functions, eg +-- +-- @cascade [ f1, f2, f3 ] x == (f3 . f2 . f1) x@ + +cascade :: Num a => [[a] -> [a]] -- ^ [f_n(x)] + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +cascade [] = id +cascade (f:fs) = cascade fs . f + +----------------------------------------------------------------------------- + +-- | Gain node +-- +-- @y[n] = a * x[n]@ + +gain :: Num a => a -- ^ a + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +gain x = map (x*) + +----------------------------------------------------------------------------- + +-- | Bias node +-- +-- @y[n] = x[n] + a@ + +bias :: Num a => a -- ^ a + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +bias x = map (x+) + +----------------------------------------------------------------------------- + +-- | Adder node +-- +-- @z[n] = x[n] + y[n]@ + +adder :: Num a => [a] -- ^ x[n] + -> [a] -- ^ y[n] + -> [a] -- ^ z[n] + +adder = zipWith (+) diff --git a/DSP/Multirate/CIC.hs b/DSP/Multirate/CIC.hs new file mode 100644 --- /dev/null +++ b/DSP/Multirate/CIC.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Multirate.CIC +-- Copyright : (c) Matthew Donadio 1998 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- CIC filters +-- +-- R = rate change +-- +-- M = differential delay in combs +-- +-- N = number of stages +-- +----------------------------------------------------------------------------- + +{- + +An implementation in Haskell of the description of CIC decimator and +interpolators as described in: + +@Article{Hogenauer_AnEcon_ASSP81, + journal = "{IEEE} Trans. Acoustics, Speech and Signal + Processing", + author = "E. B. Hogenauer", + title = "An Economical Class of Digital Filters for Decimation + and Interpolation", + year = "1981", + volume = "{ASSP-29}", + number = "2", + pages = "155", +} + +Note that this implementation does not account for the overflow +handling, bit growth, etc., described in the paper, but this does not +matter for real or complex data. + +-} + +module DSP.Multirate.CIC (cic_interpolate, cic_decimate) where + +import DSP.Basic + +-- apply returns a function of n applications of a function, eg, + +-- apply f 3 = f . f . f + +-- We will use this to create a cascade of integrators and combs + +apply :: (a -> a) -> Int -> (a -> a) +apply f 1 = f +apply f n = f . apply f (n - 1) + +-- integrate implements a discrte integrator, ie, the output is the sum +-- of all previous samples and the current one, eg + +-- integrate [ 1, 1, 1, 1 ] = [ 1, 2, 3, 4 ] + +integrate :: (Num a) => [a] -> [a] +integrate a = zipWith (+) a (z (integrate a)) + +-- comb implements the comb function described in the paper above. The m +-- parameter is the length of the delay in the feed-forward element. + +comb :: (Num a) => Int -> [a] -> [a] +comb m a = zipWith (-) a (zn m a) + +{- + +It is now simple to create a CIC imterpolator or decimator. In the +functions below + + r is the rate change + m is the length of the delay in the feed-forward element of the combs + n is the number of stages (the number of integrators and combs) + +integrate_chain and comb_chain are the cascade of integrator and combs +(hence the name CIC filter). We then just slap the functions together +with the application operator. There is a non unity gain that I +should probably account for, but that cound be swallowed up in another +function. + +-} + +-- | CIC interpolator + +cic_interpolate :: (Num a) => Int -- ^ R + -> Int -- ^ M + -> Int -- ^ N + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +cic_interpolate r m n = integrate_chain . (upsample r) . comb_chain + where integrate_chain = apply integrate n + comb_chain = apply (comb m) n + +-- | CIC interpolator + +cic_decimate :: (Num a) => Int -- ^ R + -> Int -- ^ M + -> Int -- ^ N + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +cic_decimate r m n = comb_chain . (downsample r) . integrate_chain + where integrate_chain = apply integrate n + comb_chain = apply (comb m) n diff --git a/DSP/Multirate/Halfband.hs b/DSP/Multirate/Halfband.hs new file mode 100644 --- /dev/null +++ b/DSP/Multirate/Halfband.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Multirate.Halfband +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Halfband interpolators and decimators +-- +-- Reference: C&R +-- +----------------------------------------------------------------------------- + +module DSP.Multirate.Halfband (hb_interp, hb_decim) where + +import Data.Array + +import DSP.Basic +import DSP.Filter.FIR.FIR + +mkhalfband :: Num a => Array Int a -> Array Int a +mkhalfband h = listArray (0,m `div` 2) [ h!n | n <- [0..m], even n ] + where m = snd $ bounds h + +demux :: Num a => [a] -> ([a],[a]) +demux (x:xs) = (demux' (x:xs), demux' xs) + where demux' [] = [] + demux' (x:[]) = x : [] + demux' (x:_:xs) = x : demux' xs + +mux :: Num a => [a] -> [a] -> [a] +mux [] [] = [] +mux [] _ = [] +mux _ [] = [] +mux (x:xs) (y:ys) = x : y : mux xs ys + +-- | Halfband interpolator + +hb_interp :: (Num a) => Array Int a -- ^ h[n] + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +hb_interp h x = mux y1 y2 + where (x1,x2) = demux x + y1 = fir (mkhalfband h) x1 + y2 = map (h!m2 *) $ zn m2 $ x2 + m2 = (snd $ bounds h) `div` 2 + +-- | Halfband decimator + +hb_decim :: (Num a) => Array Int a -- ^ h[n] + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +hb_decim h x = zipWith (+) y1 y2 + where (x1,x2) = demux x + y1 = fir (mkhalfband h) x1 + y2 = map (h!m2 *) $ zn m2 $ x2 + m2 = (snd $ bounds h) `div` 2 diff --git a/DSP/Multirate/Polyphase.hs b/DSP/Multirate/Polyphase.hs new file mode 100644 --- /dev/null +++ b/DSP/Multirate/Polyphase.hs @@ -0,0 +1,61 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Multirate.Polyphase +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Polyphase interpolators and decimators +-- +-- Reference: C&R +-- +----------------------------------------------------------------------------- + +module DSP.Multirate.Polyphase (poly_interp) where + +import Data.Array + +import DSP.Filter.FIR.FIR + +-- mkpoly turns a single filter into a list of l subfilters + +mkpoly :: Num a => Array Int a -> Int -> Int -> Array Int a +mkpoly h l k = listArray (0,m) [ h!(k+n*l) | n <- [0..m] ] + where m = ((snd $ bounds h) + 1) `div` l - 1 + +-- | Polyphase interpolator + +poly_interp :: Num a => Int -- ^ L + -> Array Int a -- ^ h[n] + -> [a] -- ^ x[n] + -> [a] -- ^ y[n] + +poly_interp l h x = commutate y + where g = map (fir . mkpoly h l) [0..(l-1)] + y = map (\f -> f x) g + commutate [] = [] + commutate xs = [h | (h:t) <- xs] ++ commutate [t | (h:t) <- xs] + +{- + +gZipWith :: Eq a => (a -> a -> a) -> [[a]] -> [a] +gZipWith f xs | any (== []) xs = [] + | otherwise = foldl1 f (map head xs) : gZipWith f (map tail xs) + +poly_decim :: Num a => Int -> Array Int a -> [a] -> [a] + +poly_decim l h x = gZipWith (+) g + where g = map (fir . mkpoly h l) [0..(l-1)] + +Test + +> h :: Array Int Double +> h = listArray (0,15) [1..16] + +> x :: [Double] +> x = [ 1, 0, 0, 0 ] + +-} diff --git a/DSP/Source/Basic.hs b/DSP/Source/Basic.hs new file mode 100644 --- /dev/null +++ b/DSP/Source/Basic.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Source.Basic +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Basic signals +-- +----------------------------------------------------------------------------- + +module DSP.Source.Basic where + +-- | all zeros + +zeros :: (Num a) => [a] +zeros = 0 : zeros + +-- | single impulse + +impulse :: (Num a) => [a] +impulse = 1 : zeros + +-- | unit step + +step :: (Num a) => [a] +step = 1 : step + +-- | ramp + +ramp :: (Num a) => [a] +ramp = 0 : zipWith (+) ramp (repeat 1) diff --git a/DSP/Source/Oscillator.hs b/DSP/Source/Oscillator.hs new file mode 100644 --- /dev/null +++ b/DSP/Source/Oscillator.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Source.Oscillator +-- Copyright : (c) Matthew Donadio 1998,2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- NCO and NCOM functions +-- +----------------------------------------------------------------------------- + +module DSP.Source.Oscillator (nco, ncom, + quadrature_nco, complex_ncom, + quadrature_ncom) where + +import Data.Complex + +-- | 'nco' creates a sine wave with normalized frequency wn (numerically +-- controlled oscillator, or NCO) using the recurrence relation y[n] = +-- 2cos(wn)*y[n-1] - y[n-2]. Eventually, cumlative errors will creep +-- into the data. This is unavoidable since performing AGC on this type +-- of real data is hard. The good news is that the error is small with +-- floating point data. + +nco :: RealFloat a => a -- ^ w + -> a -- ^ phi + -> [a] -- ^ y + +nco wn phi = y + where a0 = 2 * cos wn + y1 = -(sin (wn + phi)) : y + y2 = -(sin (2 * wn + phi)) : y1 + y = zipWith (-) (map (a0 *) y1) y2 + +-- | 'ncom' mixes (multiplies) x by a real sine wave with normalized +-- frequency wn. This is usually called an NCOM: Numerically Controlled +-- Oscillator and Modulator. + +ncom :: RealFloat a => a -- ^ w + -> a -- ^ phi + -> [a] -- ^ x + -> [a] -- ^ y + +ncom wn phi x = zipWith (*) x (nco wn phi) + +-- agc is used in quadrature_nco (below) to scale a complex phasor to +-- have length as close to 1 as possible, ie perform some automatic gain +-- control. Since we aren't computing sin and cos for each sample, not +-- using AGC would results in cumulative errors (small one with floating +-- point data). The Complex class includes the signum function which +-- will do what we want, but we will use the approximation 1/sqrt(x) ~= +-- (3-x)/2 for x ~= 1 to eliminate doing a sqrt for every point. + +agc :: RealFloat a => Complex a -> Complex a +agc z@(x:+y) = x * r :+ y * r + where r = (3 - x * x - y * y) / 2 + +-- | 'quadrature_nco' returns an infinite list representing a complex phasor +-- with a phase step of wn radians, ie a quadrature nco with normalized +-- frequency wn radians\/sample. Since Haskell uses lazy evaluation, +-- rotate will only be computed once, so this NCO uses only one sin and +-- one cos for the entire list, at the expense of 4 mults, 1 add, and 1 +-- subtract per point. + +quadrature_nco :: RealFloat a => a -- ^ w + -> a -- ^ phi + -> [ Complex a ] -- ^ y + +quadrature_nco wn phi = (cis phi) : map ((*) (cis wn)) (quadrature_nco wn phi) + +-- | 'complex_ncom' mixes the complex input x with a quardatue nco with +-- normalized frequency wn radians\/sample using complex multiplies +-- (perform a complex spectral shift) + +complex_ncom :: RealFloat a => a -- ^ w + -> a -- ^ phi + -> [ Complex a ] -- ^ x + -> [ Complex a ] -- ^ y + +complex_ncom _ _ [] = [] +complex_ncom wn phi x = zipWith (*) (quadrature_nco wn phi) x + +-- quadrature_mults returns the sum of the real parts and the imagimary +-- parts of two complex numbers (dot product) + +quadrature_mult :: RealFloat a => Complex a -> Complex a -> a +quadrature_mult (x1:+y1) (x2:+y2) = x1 * x2 + y1 * y2 + +-- | 'quadrature_ncom' mixes the complex input x with a quadrature nco with +-- normalized frequency wn radians\/sample in quadrature (I\/Q modulation) + +quadrature_ncom :: RealFloat a => a -- ^ w + -> a -- ^ phi + -> [Complex a] -- ^ x + -> [a] -- ^ y + +quadrature_ncom wn phi x = zipWith quadrature_mult x (quadrature_nco wn phi) diff --git a/DSP/Unwrap.hs b/DSP/Unwrap.hs new file mode 100644 --- /dev/null +++ b/DSP/Unwrap.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Unwrap +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple phase unwrapping algorithm +-- +----------------------------------------------------------------------------- + +-- O&S, pg 790 + +module DSP.Unwrap (unwrap) where + +import Data.Array + +-- * Functions + +-- | This is the simple phase unwrapping algorithm from Oppenheim and +-- Schafer. + +unwrap :: (Ix a, Integral a, Ord b, Floating b) => b -- ^ epsilon + -> Array a b -- ^ ARG + -> Array a b -- ^ arg + +unwrap eps phi = listArray b [ phi!i + 2 * pi * r!i | i <- range b ] + where r = listArray b [ ri i | i <- range b ] + ri 0 = 0 + ri i | phi!i - phi!(i-1) > (2*pi-eps) = r!(i-1) - 1 + | phi!i - phi!(i-1) < -(2*pi-eps) = r!(i-1) + 1 + | otherwise = r!(i-1) + b = bounds phi diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,117 @@ +LIBS= Matrix +LIBS+= Polynomial +LIBS+= Numeric +LIBS+= DSP + +APPS= FFTBench +APPS+= FFTTest +APPS+= Article +APPS+= IIRDemo +APPS+= FreqDemo +APPS+= NoiseDemo + +#OPT= -O -funbox-strict-fields +#OPT+= -fvia-C -O2-for-C + +#PROF= -prof -auto-all + +#WARN= -W +#WARN= -Wall + +#HEAP= -H128m + +HC= ghc-5.04.3 +#HC= ghc-6.0 + +GC= green-card + +GC_PATH= /usr/local/lib/green-card +GC_LIBS= $(GC_PATH)/StdDIS.o + +GSL_PATH= /usr/local/lib +GSL_INC= /usr/local/include +#GSL_LIBS= -lgsl -lgslcblas +GSL_LIBS= -lgsl -lcblas -latlas + +TARGET= ffi + +GCSRCS= Numeric/Special/Airy.gc +GCSRCS+= Numeric/Special/Bessel.gc +GCSRCS+= Numeric/Special/Clausen.gc +GCSRCS+= Numeric/Special/Ellint.gc +GCSRCS+= Numeric/Special/Elljac.gc +GCSRCS+= Numeric/Special/Erf.gc + +GCOBJS= $(GCSRCS:.gc=.o) + +HSFLAGS= -fno-glasgow-exts ${OPT} ${PROF} ${WARN} ${HEAP} +HSFLAGS+= -cpp -fffi -package lang -I$(GSL_INC) -i$(GC_PATH) + +INSTALLDIR= /usr/home/donadio/lib/hs + +URL= http://haskelldsp.sourceforge.net/ + +.SUFFIXES: +.SUFFIXES: .o .hs .gc + +.gc.o: + $(GC) -t $(TARGET) -i $(GC_PATH) $< + $(HC) $(HSFLAGS) -I. -I$(GSL_INC) -i$(GC_PATH) -package-name=Numeric -package lang -c $*.hs -o $*_hs.o + $(HC) $(HSFLAGS) -I. -I$(GSL_INC) -i$(GC_PATH) -package-name=Numeric -package lang -c $*_stub_$(TARGET).c -o $*_stub_$(TARGET).o + $(LD) -r -o $@ $*_hs.o $*_stub_$(TARGET).o +# $(RM) $*.hs + $(RM) $*_stub_$(TARGET).c $*_stub_$(TARGET).h + $(RM) $*_hs.o $*_stub_$(TARGET).o + +all: foreign libs + +apps: + for f in ${APPS}; do \ + $(HC) --make ${HSFLAGS} -o $$f demo/$$f.hs ;\ + done + +foreign: $(GCOBJS) + +libs: + for f in ${LIBS}; do \ + find $$f \( -name "*.lhs" -or -name "*.hs" \) -print | xargs $(HC) --make -package-name=$$f ${HSFLAGS} ;\ + done + +docs: + find ${LIBS} -name "*.hs" -print | xargs haddock -h -o doc -t "Haskell DSP Library" -s "${URL}" + +install: #libs + for f in ${LIBS}; do \ + rm -f libHS$$f.a HS$$f.o ;\ + find $$f -name "*.o" -print | xargs ar cqs libHS$$f.a ;\ + ld -r --whole-archive -o HS$$f.o libHS$$f.a ;\ + for i in `find $$f -name "*.hi" -print`; do \ + mkdir -p `dirname ${INSTALLDIR}/imports/$$i` ;\ + install -m 644 $$i ${INSTALLDIR}/imports/$$i ;\ + done ;\ + install -m 644 libHS$$f.a ${INSTALLDIR} ;\ + install -m 644 HS$$f.o ${INSTALLDIR} ;\ + installdir=${INSTALLDIR} ghc-pkg -f mpd.conf -u < pkg/$$f.pkg ;\ + done + +test: test.hs + $(HC) -cpp -package lang -i$(GC_PATH) -L$(GSL_PATH) $(GSL_LIBS) --make -o test test.hs + +snapshot: + tar cfz haskelldsp-snapshot.tar.gz ${LIBS} demo doc \ + COPYING README TODO Makefile + +clean: + find . -name "*.o" -print | xargs rm -f + find . -name "*.hi" -print | xargs rm -f + find . -name "*~" -print | xargs rm -f + rm -f $(GCSRCS:.gc=.hs) + rm -f $(GCSRCS:.gc=_stub_$(TARGET).c) + rm -f $(GCSRCS:.gc=_stub_$(TARGET).h) + rm -f *.a + rm -f *.prof + +realclean: clean + rm -f ${APPS} + rm -f *.core + rm -f haskelldsp-snapshot.tar.gz diff --git a/Matrix/Cholesky.hs b/Matrix/Cholesky.hs new file mode 100644 --- /dev/null +++ b/Matrix/Cholesky.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Matrix.Cholesky +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains a routine that solves the system Ax=b, where A +-- is positive definite, using Cholesky decomposition. +-- +----------------------------------------------------------------------------- + + +module Matrix.Cholesky (cholesky) where + +import Data.Array +import Data.Complex + +-- * Functions + +-- Formulas 2.53--2.55 in Kay + +cholesky :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -- ^ A + -> Array a (Complex b) -- ^ b + -> Array a (Complex b) -- ^ x +cholesky a b = x + where y = array (1,n) ((1,b!1) : [ (k, b!k - sum [ l!(k,j) * y!j | j <- [1..(k-1)] ] ) | k <- [2..n] ]) + x = array (1,n) ((n, y!n / d!n) : [ (k, y!k / d!k - sum [ (conjugate (l!(j,k))) * x!j | j <- [(k+1)..n] ] ) | k <- (reverse [1..(n-1)]) ]) + l = array ((1,1),(n,n)) [ ((i,j), lij i j) | i <- [2..n], j <- [1..(i-1)] ] + lij i j | j==1 = a!(i,1) / d!1 + | otherwise = a!(i,j) / d!j - sum [ l!(i,k) * d!k * (conjugate (l!(j,k))) / d!j | k <- [1..(j-1)] ] + d = array (1,n) ((1, a!(1,1)) : [ (i, a!(i,i) - sum [ d!k * ((abs (l!(i,k)))^2) | k <- [1..(i-1)] ] ) | i <- [2..n]]) + ((_,_),(n,_)) = bounds a diff --git a/Matrix/LU.hs b/Matrix/LU.hs new file mode 100644 --- /dev/null +++ b/Matrix/LU.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Matrix.LU +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module implementing LU decomposition and related functions +-- +----------------------------------------------------------------------------- + +module Matrix.LU (lu, lu_solve, improve, inverse, lu_det, solve, det) where + +import Data.Array + +-- | LU decomposition via Crout's Algorithm + +-- TODO: modify for partial pivoting / permutation matrix +-- TODO: add singularity check + +-- I am sure these are in G&VL, but the two cases of function f below are +-- formulas (2.3.13) and (2.3.12) from NRIC with some variable renaming + +lu :: Array (Int,Int) Double -- ^ A + -> Array (Int,Int) Double -- ^ LU(A) + +lu a = a' + where a' = array bnds [ ((i,j), luij i j) | (i,j) <- range bnds ] + luij i j | i>j = (a!(i,j) - sum [ a'!(i,k) * a'!(k,j) | k <- [1 ..(j-1)] ]) / a'!(j,j) + | i<=j = a!(i,j) - sum [ a'!(i,k) * a'!(k,j) | k <- [1 ..(i-1)] ] + bnds = bounds a + +-- | Solution to Ax=b via LU decomposition + +-- forward is forumla (2.3.6) in NRIC, but remebering that a11=1 +-- backward is forumla (2.3.7) in NRIC + +lu_solve :: Array (Int,Int) Double -- ^ LU(A) + -> Array Int Double -- ^ b + -> Array Int Double -- ^ x + +lu_solve a b = x + where x = array (1,n) ([(n,xn)] ++ [ (i, backward i) | i <- (reverse [1..(n-1)]) ]) + y = array (1,n) ([(1,y1)] ++ [ (i, forward i) | i <- [2..n] ]) + y1 = b!1 + forward i = (b!i - sum [ a!(i,j) * y!j | j <- [1..(i-1)] ]) + xn = y!n / a!(n,n) + backward i = (y!i - sum [ a!(i,j) * x!j | j <- [(i+1)..n] ]) / a!(i,i) + ((_,_),(n,_)) = bounds a + +-- | Improve a solution to Ax=b via LU decomposition + +-- formula (2.7.4) from NRIC + +improve :: Array (Int,Int) Double -- ^ A + -> Array (Int,Int) Double -- ^ LU(A) + -> Array Int Double -- ^ b + -> Array Int Double -- ^ x + -> Array Int Double -- ^ x' + +improve a a_lu b x = array (1,n) [ (i, x!i - err!i) | i <- [1..n] ] + where err = lu_solve a_lu rhs + rhs = array (1,n) [ (i, sum [ a!(i,j) * x!j | j <- [1..n] ] - b!i) | i <- [1..n] ] + ((_,_),(n,_)) = bounds a + +-- | Matrix inversion via LU decomposition + +-- Section (2.4) from NRIC + +-- TODO: build in improve + +inverse :: Array (Int,Int) Double -- ^ A + -> Array (Int,Int) Double -- ^ A^-1 + +inverse a = a' + where a' = array (bounds a) (arrange (makecols (lu a)) 1) + makecol i n = array (1,n) [ (j, (\i j->if i == j then 1.0 else 0.0) i j) | j <- [1..n] ] + makecols a = [ lu_solve a (makecol i n) | i <- [1..n] ] + ((_,_),(n,_)) = bounds a + arrange [] _ = [] + arrange (m:ms) j = (flatten m j) ++ (arrange ms (j+1)) + flatten m j = map (\(i,x) -> ((i,j),x)) (assocs m) + +-- | Determinant of a matrix via LU decomposition + +-- Formula (2.5.1) from NRIC + +lu_det :: Array (Int,Int) Double -- ^ LU(A) + -> Double -- ^ det(A) + +lu_det a = product [ a!(i,i) | i <- [ 1 .. n] ] + where ((_,_),(n,_)) = bounds a + + +-- | LU solver using original matrix + +solve :: Array (Int,Int) Double -- ^ A + -> Array Int Double -- ^ b + -> Array Int Double -- ^ x + +solve a b = (lu_solve . lu) a b + +-- | determinant using original matrix + +det :: Array (Int,Int) Double -- ^ A + -> Double -- ^ det(A) + +det a = (lu_det . lu) a + +------------------------------------------------------------------------------- +-- tests +------------------------------------------------------------------------------- + +{- + +a = array ((1,1),(3,3)) [ ((1,1), 1.0), ((1,2), 2.0), ((1,3), 3.0), + ((2,1), 2.0), ((2,2), 5.0), ((2,3), 3.0), + ((3,1), 1.0), ((3,2), 0.0), ((3,3), 8.0) ] +a' = array ((1,1),(3,3)) [ ((1,1), -40.0), ((1,2), 16.0), ((1,3), 9.0), + ((2,1), 13.0), ((2,2), -5.0), ((2,3), -3.0), + ((3,1), 5.0), ((3,2), -2.0), ((3,3), -1.0) ] + +a_lu = lu a +b = array (1,3) [ (1, 1.0), (2, 2.0), (3, 5.0) ] +x = lu_solve a_lu b +x' = improve a a_lu b x +x'' = improve a a_lu b x' + +verify = a' == inverse a && -- tests lu, lu_solve, and inverse + det a == -1 && -- tests lu_det + x == x' && -- tests improve + x' == x'' + +-} diff --git a/Matrix/Levinson.hs b/Matrix/Levinson.hs new file mode 100644 --- /dev/null +++ b/Matrix/Levinson.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Matrix.Cholesky +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This module contains an implementation of Levinson-Durbin recursion. +-- +----------------------------------------------------------------------------- + +module Matrix.Levinson (levinson) where + +import Data.Array +import Data.Complex + +-- * Functions + +-- Section 6.3.3 in Kay, formulas 6.46--6.48 + +-- TODO: rho is typing as complex, but it is real +-- TODO: add stepdown function +-- TODO: some applications may want all model estimations from [1..p] + +-- | levinson takes an array, r, of autocorrelation values, and a +-- model order, p, and returns an array, a, of the model estimate and +-- rho, the noise power. + +levinson :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ r + -> a -- ^ p + -> (Array a (Complex b),b) -- ^ (a,rho) + +levinson r p = (array (1,p) [ (k, a!(p,k)) | k <- [1..p] ], realPart (rho!p)) + where a = array ((1,1),(p,p)) [ ((k,i), ak k i) | k <- [1..p], i <- [1..k] ] + rho = array (1,p) [ (k, rhok k) | k <- [1..p] ] + ak 1 1 = -r!1 / r!0 + ak k i | k==i = -(r!k + sum [ a!(k-1,l) * r!(k-l) | l <- [1..(k-1)] ]) / rho!(k-1) + | otherwise = a!(k-1,i) + a!(k,k) * (conjugate (a!(k-1,k-i))) + rhok 1 = (1 - (abs (a!(1,1)))^2) * r!0 + rhok k = (1 - (abs (a!(k,k)))^2) * rho!(k-1) + +-- r = array (0,2) [ (0, (2.0 :+ 0.0)), (1, ((-1.0) :+ 1.0)), (2, (0.0 :+ 0.0)) ] +-- a = fst (levinson r 2) + +-- verify = a == array (1,2) [(1,1.0 :+ (-1.0)),(2,0.0 :+ (-1.0))] diff --git a/Matrix/Matrix.hs b/Matrix/Matrix.hs new file mode 100644 --- /dev/null +++ b/Matrix/Matrix.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Matrix.Matrix +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Basic matrix routines +-- +----------------------------------------------------------------------------- + +module Matrix.Matrix where + +import Data.Array +import Data.Complex + +-- | Matrix-matrix multiplication: A x B = C + +mm_mult :: (Ix a, Integral a, Num b) => Array (a,a) b -- ^ A + -> Array (a,a) b -- ^ B + -> Array (a,a) b -- ^ C + +mm_mult a b = if ac /= br + then error "mm_mult: inside dimensions inconsistent" + else array bnds [ ((i,j), mult i j) | (i,j) <- range bnds ] + where mult i j = sum [ a!(i,k) * b!(k,j) | k <- [1..ac] ] + ((_,_),(ar,ac)) = bounds a + ((_,_),(br,bc)) = bounds b + bnds = ((1,1),(ar,bc)) + +-- | Matrix-vector multiplication: A x b = c + +mv_mult :: (Ix a, Integral a, Num b) => Array (a,a) b -- ^ A + -> Array a b -- ^ b + -> Array a b -- ^ c + +mv_mult a b = if ac /= br + then error "mv_mult: dimensions inconsistent" + else array bnds [ (i, mult i) | i <- range bnds ] + where mult i = sum [ a!(i,k) * b!(k) | k <- [1..ac] ] + ((_,_),(ar,ac)) = bounds a + (_,br) = bounds b + bnds = (1,ar) + +-- | Transpose of a matrix + +m_trans :: (Ix a, Integral a, Num b) => Array (a,a) b -- ^ A + -> Array (a,a) b -- ^ A^T + +m_trans a = array bnds [ ((i,j), a!(j,i)) | (i,j) <- range bnds ] + where (_,(m,n)) = bounds a + bnds = ((1,1),(n,m)) + +-- | Hermitian transpose (conjugate transpose) of a matrix + +m_hermit :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -- ^ A + -> Array (a,a) (Complex b) -- ^ A^H + +m_hermit a = array bnds [ ((i,j), conjugate (a!(j,i))) | (i,j) <- range bnds ] + where (_,(m,n)) = bounds a + bnds = ((1,1),(n,m)) diff --git a/Matrix/Simplex.hs b/Matrix/Simplex.hs new file mode 100644 --- /dev/null +++ b/Matrix/Simplex.hs @@ -0,0 +1,202 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DSP.Matrix.Simplex +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Two-step simplex algorithm +-- +-- I only guarantee that this module wastes inodes +-- +----------------------------------------------------------------------------- + +-- Originally based off the code in Sedgewick, but modified to match the +-- conventions from Papadimitriou and Steiglitz. + +-- TODO: Is our column/row selection the same as Bland's anti-cycle +-- algorithm? + +-- TODO: Add check for redundant rows in two-phase algorithm + +-- TODO: Lots of testing + +module Matrix.Simplex (Simplex(..), simplex, twophase) where + +import Data.Array + +eps :: Double +eps = 1.0e-10 + +------------------------------------------------------------------------------- + +-- Pivot around a!(p,q) + +pivot :: Int -> Int -> Array (Int,Int) Double -> Array (Int,Int) Double +pivot p q a = step4 p q $ step3 p q $ step2 p q $ step1 p q $ a + where step1 p q a = a // [ ((j,k), a!(j,k) - a!(p,k) * a!(j,q) / a!(p,q)) | k <- [0..m], j <- [ph..n], j /= p && k /= q ] + step2 p q a = a // [ ((j,q),0) | j <- [ph..n], j /= p ] + step3 p q a = a // [ ((p,k), a!(p,k) / a!(p,q)) | k <- [0..m], k /= q ] + step4 p q a = a // [ ((p,q),1) ] + ((ph,_),(n,m)) = bounds a + +-- chooseq picks the lowest numbered favorable column. If there are no +-- favorable columns, then q==m is returned, and we have reached an +-- optimum. + +chooseq a = chooseq' 1 a + where chooseq' q a | q > m = q + | a!(0,q) < -eps = q + | otherwise = chooseq' (q+1) a + ((_,_),(n,m)) = bounds a + +-- choosep picks a row with a positive element in column q. If no such +-- element exists, then the p==n is returned, and the problem is +-- unfeasible. + +choosep q a = choosep' 1 q a + where choosep' p q a | p > n = p + | a!(p,q) > eps = p + | otherwise = choosep' (p+1) q a + ((_,_),(n,m)) = bounds a + +-- refinep picks the row using the ratio test. + +refinep p q a = refinep' (p+1) p q a + where refinep' i p q a | i > n = p + | a!(i,q) > eps && a!(i,0) / a!(i,q) < a!(p,0) / a!(p,q) = refinep' (i+1) i q a + | otherwise = refinep' (i+1) p q a + ((_,_),(n,m)) = bounds a + +-- * Types + +-- | Type for results of the simplex algorithm + +data Simplex a = Unbounded | Infeasible | Optimal a deriving (Read,Show) + +gettab (Optimal a) = a + +-- * Functions + +-- | The simplex algorithm for standard form: +-- +-- min c'x +-- +-- where Ax = b, x >= 0 +-- +-- a!(0,0) = -z +-- +-- a!(0,j) = c' +-- +-- a!(i,0) = b +-- +-- a!(i,j) = A_ij + +simplex :: Array (Int,Int) Double -- ^ stating tableau + -> Simplex (Array (Int,Int) Double) -- ^ solution + +simplex a | q > m = Optimal a + | p > n = Unbounded + | otherwise = simplex $ pivot p' q $ a + where q = chooseq a + p = choosep q a + p' = refinep p q a + ((_,_),(n,m)) = bounds a + +------------------------------------------------------------------------------- + +addart a = array ((-1,0),(n,m+n)) $ z ++ xsi ++ b ++ art ++ x + where z = ((-1,0), a!(0,0)) : [ ((-1,j),0) | j <- [1..n] ] ++ [ ((-1,j+n),a!(0,j)) | j <- [1..m] ] + xsi = ((0,0), -colsum a 0) : [ ((0,j),0) | j <- [1..n] ] ++ [ ((0,j+n), -colsum a j) | j <- [1..m] ] + b = [ ((i,0), a!(i,0)) | i <- [1..n] ] + art = [ ((i,j), if i == j then 1 else 0) | i <- [1..n], j <- [1..n] ] + x = [ ((i,j+n), a!(i,j)) | i <- [1..n], j <- [1..m] ] + ((_,_),(n,m)) = bounds a + +colsum a j = sum [ a!(i,j) | i <- [1..n] ] + where ((_,_),(n,m)) = bounds a + +delart a a' = array ((0,0),(n,m)) $ z ++ b ++ x + where z = ((0,0), a'!(-1,0)) : [ ((0,j), a!(0,j)) | j <- [1..m] ] + b = [ ((i,0), a'!(i,0)) | i <- [1..n] ] + x = [ ((i,j), a'!(i,j+n)) | i <- [1..n], j <- [1..m] ] + ((_,_),(n,m)) = bounds a + +-- | The two-phase simplex algorithm + +twophase :: Array (Int,Int) Double -- ^ stating tableau + -> Simplex (Array (Int,Int) Double) -- ^ solution + +twophase a | cost a' > eps = Infeasible + | otherwise = simplex $ delart a (gettab a') + where a' = simplex $ addart $ a + +cost (Optimal a) = negate $ a!(0,0) + where ((_,_),(n,m)) = bounds a + +------------------------------------------------------------------------------- + +{- + +Test vectors + +This is from Sedgewick + +> x1 = listArray ((0,0),(5,8)) [ 0, -1, -1, -1, 0, 0, 0, 0, 0, +> 5, -1, 1, 0, 1, 0, 0, 0, 0, +> 45, 1, 4, 0, 0, 1, 0, 0, 0, +> 27, 2, 1, 0, 0, 0, 1, 0, 0, +> 24, 3, -4, 0, 0, 0, 0, 1, 0, +> 4, 0, 0, 1, 0, 0, 0, 0, 1 ] :: Array (Int,Int) Double + +P&S, Example 2.6 + +> x2 = listArray ((0,0),(3,5)) [ 0, 1, 1, 1, 1, 1, +> 1, 3, 2, 1, 0, 0, +> 3, 5, 1, 1, 1, 0, +> 4, 2, 5, 1, 0, 1 ] :: Array (Int,Int) Double + +P&S, Example 2.6 (after BFS selection) + +> x2' = listArray ((0,0),(3,5)) [ -6, -3, -3, 0, 0, 0, +> 1, 3, 2, 1, 0, 0, +> 2, 2, -1, 0, 1, 0, +> 3, -1, 3, 0, 0, 1 ] :: Array (Int,Int) Double + +P&S, Example 2.2 / Section 2.9 + +> x3 = listArray ((0,0),(4,7)) [ -34, -1, -14, -6, 0, 0, 0, 0, +> 4, 1, 1, 1, 1, 0, 0, 0, +> 2, 1, 0, 0, 0, 1, 0, 0, +> 3, 0, 0, 1, 0, 0, 1, 0, +> 6, 0, 3, 1, 0, 0, 0, 1 ] :: Array (Int,Int) Double + +P&S, Example 2.7 + +> x4 = listArray ((0,0),(3,7)) [ 3, -3/4, 20, -1/2, 6, 0, 0, 0, +> 0, 1/4, -8, -1, 9, 1, 0, 0, +> 0, 1/2, -12, -1/2, 3, 0, 1, 0, +> 1, 0, 0, 1, 0, 0, 0, 1 ] :: Array (Int,Int) Double + +These come in handy for testing + +> row j a = listArray (0,m) [ a!(j,k) | k <- [0..m] ] +> where ((_,_),(n,m)) = bounds a + +> column k a = listArray (0,n) [ a!(j,k) | j <- [0..n] ] +> where ((_,_),(n,m)) = bounds a + +> solution (Optimal a) = listArray (1,m) $ [ find a j | j <- [1..m] ] +> where ((_,_),(n,m)) = bounds a + +> find a j = findone' a 1 j +> where findone' a i j | i > n = 0 +> | a!(i,j) == 1.0 = b!i +> | otherwise = findone' a (i+1) j +> b = listArray (1,n) [ a!(i,0) | i <- [1..n] ] +> ((_,_),(n,m)) = bounds a + +-} diff --git a/Numeric/Approximation/Chebyshev.hs b/Numeric/Approximation/Chebyshev.hs new file mode 100644 --- /dev/null +++ b/Numeric/Approximation/Chebyshev.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Approximation.Chebyshev +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Function approximation using Chebyshev polynomials +-- +-- @ f(x) = ( sum (k=0..N-1) c_k * T_k(x) ) - 0.5 * c_0 @ +-- +-- over the interval @ [a,b] @ +-- +-- Reference: NRiC +-- +----------------------------------------------------------------------------- + +module Numeric.Approximation.Chebyshev (cheby_approx, + cheby_eval) where + +import Data.Array + +-- | Calculates the Chebyshev approximation to @f(x)@ over @[a,b]@ + +cheby_approx :: (Double -> Double) -- ^ f(x) + -> Double -- ^ a + -> Double -- ^ b + -> Int -- ^ N + -> [Double] -- ^ c_n + +cheby_approx f a b n = f'' + where a' = 0.5 * (b - a) + b' = 0.5 * (b + a) + y = [ a' * cos (pi * (fromIntegral k + 0.5) / fromIntegral n) + b' | k <- [0..n-1] ] + f' = map f y + f'' = [ 2 * sum (zipWith (*) f' [ cos (pi * fromIntegral j * (fromIntegral k + 0.5) / fromIntegral n) | k <- [0..n-1] ]) / fromIntegral n | j <- [0..n-1] ] + +-- | Evaluates the Chebyshev approximation to @f(x)@ over @[a,b]@ at @x@ + +cheby_eval :: [Double] -- ^ c_n + -> Double -- ^ a + -> Double -- ^ b + -> Double -- ^ x + -> Double -- ^ f(x) + +cheby_eval f a b x = y * d!1 - d!2 + 0.5 * c!0 + where y = (2 * x - a - b) / (b - a) + c = listArray (0,n) f + d = array (1,n+2) ((n+2,0) : (n+1,0) : [ (j,2*y*d!(j+1) - d!(j+2) + c!j) | j <- [1..n] ]) + n = length f - 1 diff --git a/Numeric/Random/Distribution/Binomial.hs b/Numeric/Random/Distribution/Binomial.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Binomial.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Binomial +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED +-- +-- Module for transforming a list of uniform random variables into a +-- list of binomial random variables. +-- +-- Reference: Ross +-- +---------------------------------------------------------------------------- + +module Numeric.Random.Distribution.Binomial (binomial) where + +-- * Functions + +-- | Generates a list of binomial random variables from a list +-- of uniforms + +binomial :: Int -- ^ n + -> Double -- ^ p + -> [Double] -- ^ U + -> [Double] -- ^ X + +binomial n p us = sum xi : binomial n p (drop n us) + where xi = map (\u -> if u < p then 1 else 0) (take n us) + + diff --git a/Numeric/Random/Distribution/Exponential.hs b/Numeric/Random/Distribution/Exponential.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Exponential.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Exponential +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED +-- +-- Module for transforming a list of uniform random variables into a +-- list of exponential random variables. +-- +-- @ f(x) = lambda * exp(-lambda*x) @ +-- +-- @ F(x) = 1 - exp(-lambda*x) @ +-- +-- @ lambda = 1 \/ mu @ +-- +-- Reference: Ross +-- +---------------------------------------------------------------------------- + +-- TODO: Marsaglia's ziggurat method + +module Numeric.Random.Distribution.Exponential (exponential_inv) where + +-- * Functions + +-- | Generates a list of exponential random variables from a list +-- of uniforms via the inverse transformation method +-- +-- @ F(x) = 1 - exp(-lambda*x) @ +-- +-- @ F^-1(x) = -log(1 - x) \/ lambda@ + +exponential_inv :: Double -- ^ lambda + -> [Double] -- ^ U + -> [Double] -- ^ X + +exponential_inv lambda us = map (\u -> -log (1 - u) / lambda) us diff --git a/Numeric/Random/Distribution/Gamma.hs b/Numeric/Random/Distribution/Gamma.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Gamma.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Gamma +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED +-- +-- Module for transforming a list of uniform random variables into a +-- list of gamma random variables. +-- +-- @ f(x) = lambda * exp(-lambda*x) * (lambda * x)^(t-1) \/ Gamma(t) @ +-- +-- Reference: Ross +-- +---------------------------------------------------------------------------- + +module Numeric.Random.Distribution.Gamma (gamma) where + +-- * Functions + +-- | Generates a list of gamma random variables from a list +-- of uniforms via the inverse transformation method + +gamma :: Int -- ^ n + -> Double -- ^ lambda + -> [Double] -- ^ U + -> [Double] -- ^ X + +gamma n lambda u = x : gamma n lambda u' + where x = -log (product (take n u)) / lambda + u' = drop n u diff --git a/Numeric/Random/Distribution/Geometric.hs b/Numeric/Random/Distribution/Geometric.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Geometric.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Geometric +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED +-- +-- Module for transforming a list of uniform random variables into a +-- list of geometric random variables. +-- +-- @ P{X=n} = (1-p)^(n-1)*p @ +-- +-- Reference: Ross +-- +---------------------------------------------------------------------------- + +module Numeric.Random.Distribution.Geometric (geometric) where + +-- * Functions + +-- | Generates a list of geometric random variables from a list +-- of uniforms + +geometric :: Double -- ^ p + -> [Double] -- ^ U + -> [Double] -- ^ X + +geometric p us = map (\u -> 1 + log u / log (1 - p)) us + diff --git a/Numeric/Random/Distribution/Normal.hs b/Numeric/Random/Distribution/Normal.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Normal.hs @@ -0,0 +1,104 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Normal +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Module for transforming a list of uniform random variables into a +-- list of normal random variables. +-- +----------------------------------------------------------------------------- + +-- TODO: The speedup from Ross for the A-R method + +-- TODO: Marsaglia's ziggurat method + +-- TODO: Leva' method + +-- TODO: Ahrens-Dieter method + +module Numeric.Random.Distribution.Normal (normal_clt, normal_bm, + normal_ar, normal_r) where + +-- * Functions + +-- adjust takes a unit normal random variable and sets the mean and +-- variance to whatever is needed. + +adjust :: (Double,Double) -> Double -> Double +adjust (mu,sigma) x = mu + sigma * x + +-- | Normal random variables via the Central Limit Theorm (not explicity +-- given, but see Ross) +-- +-- If mu=0 and sigma=1, then this will generate numbers in the range +-- [-n/2,n/2] + +normal_clt :: Int -- ^ Number of uniforms to sum + -> (Double,Double) -- ^ (mu,sigma) + -> [Double] -- ^ U + -> [Double] -- ^ X + +normal_clt n (mu,sigma) u = map (adjust (mu,sigma)) $ normal' u + where normal' us = var_adj * ((sum $ take n us) - mean_adj) : (normal' $ drop n us) + var_adj = sqrt $ 12 / fromIntegral n + mean_adj = fromIntegral n / 2 + +-- | Normal random variables via the Box-Mueller Polar Method (Ross, pp +-- 450--452) +-- +-- If mu=0 and sigma=1, then this will generate numbers in the range +-- [-8.57,8.57] assuing that the uniform RNG is really giving full +-- precision for doubles. + +normal_bm :: (Double,Double) -- ^ (mu,sigma) + -> [Double] -- ^ U + -> [Double] -- ^ X + +normal_bm (mu,sigma) u = map (adjust (mu,sigma)) $ normal' u + where normal' (u1:u2:us) | w <= 1 = x : y : normal' us + | otherwise = normal' us + where v1 = 2 * u1 - 1 + v2 = 2 * u2 - 1 + w = v1 * v1 + v2 * v2 + x = v1 * sqrt (-2 * log w / w) + y = v2 * sqrt (-2 * log w / w) + +-- | Acceptance-Rejection Method (Ross, pp 448--450) +-- +-- If mu=0 and sigma=1, then this will generate numbers in the range +-- [-36.74,36.74] assuming that the uniform RNG is really giving full +-- precision for doubles. + +normal_ar :: (Double,Double) -- ^ (mu,sigma) + -> [Double] -- ^ U + -> [Double] -- ^ X + +normal_ar (mu,sigma) u = map (adjust (mu,sigma)) $ normal' u + where normal' (u1:u2:u3:us) | y > 0 = z : normal' us + | otherwise = normal' (u3:us) + where y1 = -log u1 + y2 = -log u2 + y = y2 - (y1 - 1)^2 / 2 + z | u3 <= 0.5 = y1 + | u3 > 0.5 = -y1 + +-- | Ratio Method (Kinderman-Monahan) (Knuth, v2, 2ed, pp 125--127) +-- +-- If mu=0 and sigma=1, then this will generate numbers in the range +-- [-1e15,1e15] (?) assuming that the uniform RNG is really giving full +-- precision for doubles. + +normal_r :: (Double,Double) -- ^ (mu,sigma) + -> [Double] -- ^ U + -> [Double] -- ^ X + +normal_r (mu,sigma) u = map (adjust (mu,sigma)) $ normal' u + where normal' (u:v:us) | x^2 <= -4 * log u = x : normal' us + | otherwise = normal' us + where x = a * (v - 0.5) / u + a = 1.71552776992141359295 -- sqrt $ 8 / e diff --git a/Numeric/Random/Distribution/Poisson.hs b/Numeric/Random/Distribution/Poisson.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Poisson.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Poisson +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED +-- +-- Module for transforming a list of uniform random variables into a +-- list of Poisson random variables. +-- +-- Reference: Ross +-- +---------------------------------------------------------------------------- + +module Numeric.Random.Distribution.Poisson (poisson) where + +-- * Functions + +-- | Generates a list of poisson random variables from a list +-- of uniforms + +poisson :: Double -- ^ lambda + -> [Double] -- ^ U + -> [Double] -- ^ X + +poisson lambda (u:us) = poisson' u us + where poisson' n (u:us) | n < e = n-1 : poisson lambda (u:us) + | otherwise = poisson' (n*u) us + e = exp (-lambda) diff --git a/Numeric/Random/Distribution/Uniform.hs b/Numeric/Random/Distribution/Uniform.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Distribution/Uniform.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Distribution.Uniform +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Functions for turning a list of random integers (as 'Word32') in a list +-- of Uniform RV's +-- +----------------------------------------------------------------------------- + +module Numeric.Random.Distribution.Uniform where + +import Data.Word + +-- Float : 1 sign, 8 exp, 23 fraction +-- Double : 1 sign, 11 exp, 52 fraction + +-- | 32 bits in [0,1] + +-- 4294967295 = 2^32 - 1 + +uniform32cc :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform32cc xs = map ((/ 4294967295.0) . fromIntegral) $ xs + +-- | 32 bits in [0,1) + +-- 4294967296 = 2^32 + +uniform32co :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform32co xs = map ((/ 4294967296.0) . fromIntegral) $ xs + +-- | 32 bits in (0,1] + +uniform32oc :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform32oc xs = filter (/= 0) $ uniform32cc $ xs + +-- | 32 bits in (0,1) + +uniform32oo :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform32oo xs = filter (/= 1) $ uniform32oc $ xs + +-- | 53 bits in [0,1], ie 64-bit IEEE 754 in [0,1] + +-- 67108864 = 2^26 +-- 9007199254740991 = 2^53 - 1 + +uniform53cc :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform53cc xs = uniform' $ xs + where uniform' (u1:u2:us) = (a * 67108864.0 + b) / 9007199254740991.0 : uniform' us + where a = fromIntegral u1 / 32.0 -- 27 bits + b = fromIntegral u2 / 64.0 -- 26 bits + +-- | 53 bits in [0,1), ie 64-bit IEEE 754 in [0,1) + +-- 67108864 = 2^26 +-- 9007199254740992 = 2^53 + +uniform53co :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform53co xs = uniform' $ xs + where uniform' (u1:u2:us) = (a * 67108864.0 + b) / 9007199254740992.0 : uniform' us + where a = fromIntegral u1 / 32.0 -- 27 bits + b = fromIntegral u2 / 64.0 -- 26 bits + +-- | 53 bits in (0,1] + +uniform53oc :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform53oc xs = filter (/= 0) $ uniform53cc $ xs + +-- | 53 bits in (0,1) + +uniform53oo :: [Word32] -- ^ X + -> [Double] -- ^ U + +uniform53oo xs = filter (/= 1) $ uniform53oc $ xs + +-- | transforms uniform [0,1] to [a,b] + +uniform :: Double -- ^ a + -> Double -- ^ b + -> [Double] -- ^ U + -> [Double] -- ^ U' + +uniform a b us = map (\u -> (b-a)*u + a) us diff --git a/Numeric/Random/Generator/MT19937.hs b/Numeric/Random/Generator/MT19937.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Generator/MT19937.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Generator.MT19937 +-- Copyright : (c) Matt Harden 1999 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- A Haskell program for MT19937 pseudorandom number generator +-- +----------------------------------------------------------------------------- + +-- The original source was found at +-- +-- http://members.primary.net/~matth/mt19937.hs +-- +-- but I can't get to the site anymore. As much as the orginal +-- formatting has been retained as possible. --mpd + + +{- + Function genrand generates an infinite list of pseudorandom + unsigned integers (32bit) which are uniformly distributed + among 0 to 2^32-1. sgenrand(seed) uses an algorithm of Knuth + to provide 624 initial values to genrand(). + + Rewritten in Haskell by Matt Harden + from original code in C by Takuji Nishimura. + + This program relies upon the GHC/Hugs extensions to Haskell. + These are very likely to be available in any Haskell + environment, and performance would suffer greatly without them. +-} + +{- + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later + version. + This library 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 Library General Public License for more details. + You should have received a copy of the GNU Library General + Public License along with this library; if not, write to the + Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA +-} + +-- Copyright (C) 1999 Matt Harden +-- The original C code contained the following notice: +-- When you use this, send an email to: matumoto@math.keio.ac.jp +-- with an appropriate reference to your work. + +{- REFERENCE - + M. Matsumoto and T. Nishimura, + "Mersenne Twister: A 623-Dimensionally Equidistributed Uniform + Pseudo-Random Number Generator", + ACM Transactions on Modeling and Computer Simulation, + Vol. 8, No. 1, January 1998, pp 3--30. +-} + +module Numeric.Random.Generator.MT19937 (W, genrand) where + +import Data.Word +import Data.Bits + +infixl 8 .<<., .>>. + +(.<<.), (.>>.) :: (Bits a) => (a -> Int -> a) +(.<<.) = shiftL +(.>>.) = shiftR + +type W = Word32 + +-- Period parameters +parm_N = 624 :: Int +parm_M = 397 :: Int +parm_A = 0x9908b0df :: W +uPPER_MASK = (bit 31) :: W +lOWER_MASK = (complement uPPER_MASK) :: W + +-- Tempering parameters +tEMPERING_MASK_B = (.&. 0x9d2c5680) :: W -> W +tEMPERING_MASK_C = (.&. 0xefc60000) :: W -> W +tEMPERING_SHIFT_U = (.>>. 11) :: W -> W +tEMPERING_SHIFT_S = (.<<. 7) :: W -> W +tEMPERING_SHIFT_T = (.<<. 15) :: W -> W +tEMPERING_SHIFT_L = (.>>. 18) :: W -> W + +-- A Knuth algorithm just to seed the seed... +-- Line 25 of table 1 +-- in [KNUTH 1981, The Art of Computer Programming Vol. 2 (2nd Ed.), pp102] +sgenrand :: W -> [W] +sgenrand 0 = sgenrand 4357 -- 0 not acceptable. Why 4357? I dunno. +sgenrand seed = take parm_N (iterate (69069 *) seed) + +mag01 :: W -> W +mag01 0 = 0 +mag01 1 = parm_A + +tempering :: W -> W +tempering = let (^=) x f = xor x (f x) in + (^= (tEMPERING_SHIFT_L)) . + (^= (tEMPERING_MASK_C . tEMPERING_SHIFT_T)) . + (^= (tEMPERING_MASK_B . tEMPERING_SHIFT_S)) . + (^= (tEMPERING_SHIFT_U)) + +-- parameter to rand MUST be a list of (_N) words! +rand :: [W] -> [W] +rand init = map tempering r2 where + r = init ++ r2 + r2 = zipWith xor (map f r3) (drop parm_M r) + r3 = zipWith (\x y -> (x .&. uPPER_MASK) .|. (y .&. lOWER_MASK)) r (tail r) + f y = (y .>>. 1) `xor` (mag01 (y .&. 1)) + +genrand :: W -> [W] +genrand = rand . sgenrand + +test = sequence $ map print $ take 1000 $ genrand 4357 diff --git a/Numeric/Random/Spectrum/Brown.hs b/Numeric/Random/Spectrum/Brown.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Spectrum/Brown.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Spectrum.Brown +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Function for brown noise, which is integrated white noise +-- +----------------------------------------------------------------------------- + +module Numeric.Random.Spectrum.Brown (brown) where + +brown :: [Double] -- ^ noise + -> [Double] -- ^ brown noise + +brown = scanl1 (+) + diff --git a/Numeric/Random/Spectrum/Pink.hs b/Numeric/Random/Spectrum/Pink.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Spectrum/Pink.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Spectrum.Pink +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Functions for pinking noise +-- +-- +-- +----------------------------------------------------------------------------- + +module Numeric.Random.Spectrum.Pink (kellet, + voss) where + +------------------------------------------------------------------------------- + +-- rb-j filter + +-- pole zero +-- ---- ---- +-- 0.99572754 0.98443604 +-- 0.94790649 0.83392334 +-- 0.53567505 0.07568359 + +------------------------------------------------------------------------------- + +-- | Kellet's filter + +-- b0 = 0.99886 * b0 + white * 0.0555179; +-- b1 = 0.99332 * b1 + white * 0.0750759; +-- b2 = 0.96900 * b2 + white * 0.1538520; +-- b3 = 0.86650 * b3 + white * 0.3104856; +-- b4 = 0.55000 * b4 + white * 0.5329522; +-- b5 = -0.7616 * b5 - white * 0.0168980; +-- pink = b0 + b1 + b2 + b3 + b4 + b5 + b6 + white * 0.5362; +-- b6 = white * 0.115926; + +kellet :: [Double] -- ^ noise + -> [Double] -- ^ pinked noise + +kellet w = kellet' w 0 0 0 0 0 0 0 + where kellet' [] _ _ _ _ _ _ _ = [] + kellet' (white:ws) b0 b1 b2 b3 b4 b5 b6 = pink : kellet' ws b0' b1' b2' b3' b4' b5' b6' + where b0' = 0.99886 * b0 + white * 0.0555179 + b1' = 0.99332 * b1 + white * 0.0750759 + b2' = 0.96900 * b2 + white * 0.1538520 + b3' = 0.86650 * b3 + white * 0.3104856 + b4' = 0.55000 * b4 + white * 0.5329522 + b5' = -0.7616 * b5 - white * 0.0168980 + pink = b0 + b1 + b2 + b3 + b4 + b5 + b6 + white * 0.5362 + b6' = white * 0.115926 + +------------------------------------------------------------------------------- + +-- voss algorithm + +add :: Num a => [[a]] -> [a] +add xs | any (== []) xs = [] + | otherwise = foldl1 (+) (map head xs) : add (map tail xs) + +hold :: Int -> [a] -> [a] +hold n xs = hold' n n xs + where hold' _ _ [] = [] + hold' n 1 (x:xs) = x : hold' n n xs + hold' n i (x:xs) = x : hold' n (i-1) (x:xs) + +split :: Int -> [a] -> [[a]] +split n xs = split' n n xs + where split' _ 0 _ = [] + split' n i (x:xs) = split'' n (x:xs) : split' n (i-1) xs + split'' _ [] = [] + split'' n (x:xs) = x : split'' n (drop n (x:xs)) + + +mkOctaves :: [[a]] -> [[a]] +mkOctaves xss = mkOctaves' 1 xss + where mkOctaves' _ [] = [] + mkOctaves' n (xs:xss) = hold n xs : mkOctaves' (2*n) xss + +-- | Voss's algorithm +-- +-- UNTESTED, but the algorithm looks like it is working based on my hand +-- tests. + +voss :: Int -- ^ number of octaves to sum + -> [Double] -- ^ noise + -> [Double] -- ^ pinked noise + +voss n w = add $ mkOctaves $ split n w + +------------------------------------------------------------------------------- + +-- voss-mccartney algorithm + +------------------------------------------------------------------------------- + +-- vm w = diff --git a/Numeric/Random/Spectrum/Purple.hs b/Numeric/Random/Spectrum/Purple.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Spectrum/Purple.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Spectrum.Purple +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Function for purple noise, which is differentiated white noise +-- +-- This currently just does a simple first-order difference. This is +-- equivalent to filtering the white noise with @ h[n] = [1,-1] @ +-- A better solution would be to use a proper FIR differentiator. +-- +----------------------------------------------------------------------------- + +module Numeric.Random.Spectrum.Purple (purple) where + +purple :: [Double] -- ^ noise + -> [Double] -- ^ purple noise + +purple xs = zipWith (-) xs (0:xs) diff --git a/Numeric/Random/Spectrum/White.hs b/Numeric/Random/Spectrum/White.hs new file mode 100644 --- /dev/null +++ b/Numeric/Random/Spectrum/White.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Random.Spectrum.White +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Function for white noise +-- +-- This is pretty useless, but it is here to be comprehensive +-- +----------------------------------------------------------------------------- + +module Numeric.Random.Spectrum.White (white) where + +white :: [Double] -- ^ noise + -> [Double] -- ^ white noise + +white = id diff --git a/Numeric/Special/Airy.gc b/Numeric/Special/Airy.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Airy.gc @@ -0,0 +1,276 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Airy +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Airy functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Airy (airy_Ai, airy_Ai_e, + airy_Ai_scaled, airy_Ai_scaled_e, + airy_Ai_deriv, airy_Ai_deriv_e, + airy_Ai_deriv_scaled, airy_Ai_deriv_scaled_e, + airy_zero_Ai, airy_zero_Ai_e, + airy_zero_Ai_deriv, airy_zero_Ai_deriv_e, + airy_Bi, airy_Bi_e, + airy_Bi_scaled, airy_Bi_scaled_e, + airy_Bi_deriv, airy_Bi_deriv_e, + airy_Bi_deriv_scaled, airy_Bi_deriv_scaled_e, + airy_zero_Bi, airy_zero_Bi_e, + airy_zero_Bi_deriv, airy_zero_Bi_deriv_e + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun airy_Ai :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Ai(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Ai_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Ai_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Ai_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Ai_scaled(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Ai_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Ai_scaled_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Ai_deriv :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Ai_deriv(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Ai_deriv_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Ai_deriv_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Ai_deriv_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Ai_deriv_scaled(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Ai_deriv_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Ai_deriv_scaled_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_zero_Ai :: Int -> Double +%call (int s) +%code double z; +% z = gsl_sf_airy_zero_Ai(s); +%result (double z) + +%fun airy_zero_Ai_e :: Int -> (Double, Double) +%call (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_zero_Ai_e(s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_zero_Ai_deriv :: Int -> Double +%call (int s) +%code double z; +% z = gsl_sf_airy_zero_Ai_deriv(s); +%result (double z) + +%fun airy_zero_Ai_deriv_e :: Int -> (Double, Double) +%call (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_zero_Ai_deriv_e(s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Bi :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Bi(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Bi_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Bi_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Bi_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Bi_scaled(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Bi_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Bi_scaled_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Bi_deriv :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Bi_deriv(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Bi_deriv_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Bi_deriv_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_Bi_deriv_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_airy_Bi_deriv_scaled(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun airy_Bi_deriv_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_Bi_deriv_scaled_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_zero_Bi :: Int -> Double +%call (int s) +%code double z; +% z = gsl_sf_airy_zero_Bi(s); +%result (double z) + +%fun airy_zero_Bi_e :: Int -> (Double, Double) +%call (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_zero_Bi_e(s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun airy_zero_Bi_deriv :: Int -> Double +%call (int s) +%code double z; +% z = gsl_sf_airy_zero_Bi_deriv(s); +%result (double z) + +%fun airy_zero_Bi_deriv_e :: Int -> (Double, Double) +%call (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_airy_zero_Bi_deriv_e(s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) diff --git a/Numeric/Special/Bessel.gc b/Numeric/Special/Bessel.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Bessel.gc @@ -0,0 +1,874 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Bessel +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Bessel functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Bessel (bessel_J0, bessel_J0_e, + bessel_J1, bessel_J1_e, + bessel_Jn, bessel_Jn_e, + + bessel_Y0, bessel_Y0_e, + bessel_Y1, bessel_Y1_e, + bessel_Yn, bessel_Yn_e, + + bessel_I0, bessel_I0_e, + bessel_I1, bessel_I1_e, + bessel_In, bessel_In_e, + + bessel_I0_scaled, bessel_I0_scaled_e, + bessel_I1_scaled, bessel_I1_scaled_e, + bessel_In_scaled, bessel_In_scaled_e, + + bessel_K0, bessel_K0_e, + bessel_K1, bessel_K1_e, + bessel_Kn, bessel_Kn_e, + + bessel_K0_scaled, bessel_K0_scaled_e, + bessel_K1_scaled, bessel_K1_scaled_e, + bessel_Kn_scaled, bessel_Kn_scaled_e, + + bessel_j0, bessel_j0_e, + bessel_j1, bessel_j1_e, + bessel_jl, bessel_jl_e, + + bessel_y0, bessel_y0_e, + bessel_y1, bessel_y1_e, + bessel_yl, bessel_yl_e, + + bessel_i0_scaled, bessel_i0_scaled_e, + bessel_i1_scaled, bessel_i1_scaled_e, + bessel_il_scaled, bessel_il_scaled_e, + + bessel_k0_scaled, bessel_k0_scaled_e, + bessel_k1_scaled, bessel_k1_scaled_e, + bessel_kl_scaled, bessel_kl_scaled_e, + + bessel_Jnu, bessel_Jnu_e, + bessel_Ynu, bessel_Ynu_e, + bessel_Inu, bessel_Inu_e, + bessel_Inu_scaled, bessel_Inu_scaled_e, + bessel_Knu, bessel_Knu_e, + bessel_Knu_scaled, bessel_Knu_scaled_e, + bessel_lnKnu, bessel_lnKnu_e, + + bessel_zero_J0, bessel_zero_J0_e, + bessel_zero_J1, bessel_zero_J1_e, + bessel_zero_Jnu, bessel_zero_Jnu_e + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun bessel_J0 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_J0(x); +%result (double y) + +%fun bessel_J0_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_J0_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_J1 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_J1(x); +%result (double y) + +%fun bessel_J1_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_J1_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Jn :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_Jn(n, x); +%result (double y) + +%fun bessel_Jn_e :: Int -> Double -> (Double, Double) +%call (int n) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Jn_e(n, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Y0 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_Y0(x); +%result (double y) + +%fun bessel_Y0_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Y0_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Y1 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_Y1(x); +%result (double y) + +%fun bessel_Y1_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Y1_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Yn :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_Yn(n, x); +%result (double y) + +%fun bessel_Yn_e :: Int -> Double -> (Double, Double) +%call (int n) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Yn_e(n, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_I0 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_I0(x); +%result (double y) + +%fun bessel_I0_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_I0_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_I1 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_I1(x); +%result (double y) + +%fun bessel_I1_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_I1_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_In :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_In(n, x); +%result (double y) + +%fun bessel_In_e :: Int -> Double -> (Double, Double) +%call (int n) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_In_e(n, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_I0_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_I0_scaled(x); +%result (double y) + +%fun bessel_I0_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_I0_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_I1_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_I1_scaled(x); +%result (double y) + +%fun bessel_I1_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_I1_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_In_scaled :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_In_scaled(n, x); +%result (double y) + +%fun bessel_In_scaled_e :: Int -> Double -> (Double, Double) +%call (int n) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_In_scaled_e(n, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_K0 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_K0(x); +%result (double y) + +%fun bessel_K0_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_K0_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_K1 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_K1(x); +%result (double y) + +%fun bessel_K1_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_K1_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Kn :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_Kn(n, x); +%result (double y) + +%fun bessel_Kn_e :: Int -> Double -> (Double, Double) +%call (int n) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Kn_e(n, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) +------------------------------------------------------------------------------- + +%fun bessel_K0_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_K0_scaled(x); +%result (double y) + +%fun bessel_K0_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_K0_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_K1_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_K1_scaled(x); +%result (double y) + +%fun bessel_K1_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_K1_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Kn_scaled :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_Kn_scaled(n, x); +%result (double y) + +%fun bessel_Kn_scaled_e :: Int -> Double -> (Double, Double) +%call (int n) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Kn_scaled_e(n, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_j0 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_j0(x); +%result (double y) + +%fun bessel_j0_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_j0_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_j1 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_j1(x); +%result (double y) + +%fun bessel_j1_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_j1_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_jl :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_jl(n, x); +%result (double y) + +%fun bessel_jl_e :: Int -> Double -> (Double, Double) +%call (int l) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_jl_e(l, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_y0 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_y0(x); +%result (double y) + +%fun bessel_y0_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_y0_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_y1 :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_y1(x); +%result (double y) + +%fun bessel_y1_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_y1_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_yl :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_yl(n, x); +%result (double y) + +%fun bessel_yl_e :: Int -> Double -> (Double, Double) +%call (int l) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_yl_e(l, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_i0_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_i0_scaled(x); +%result (double y) + +%fun bessel_i0_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_i0_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_i1_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_i1_scaled(x); +%result (double y) + +%fun bessel_i1_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_i1_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_il_scaled :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_il_scaled(n, x); +%result (double y) + +%fun bessel_il_scaled_e :: Int -> Double -> (Double, Double) +%call (int l) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_il_scaled_e(l, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_k0_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_k0_scaled(x); +%result (double y) + +%fun bessel_k0_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_k0_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_k1_scaled :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_bessel_k1_scaled(x); +%result (double y) + +%fun bessel_k1_scaled_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_k1_scaled_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_kl_scaled :: Int -> Double -> Double +%call (int n) (double x) +%code double y; +% y = gsl_sf_bessel_kl_scaled(n, x); +%result (double y) + +%fun bessel_kl_scaled_e :: Int -> Double -> (Double, Double) +%call (int l) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_kl_scaled_e(l, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Jnu :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_Jnu(nu, x); +%result (double y) + +%fun bessel_Jnu_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Jnu_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Ynu :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_Ynu(nu, x); +%result (double y) + +%fun bessel_Ynu_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Ynu_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Inu :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_Inu(nu, x); +%result (double y) + +%fun bessel_Inu_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Inu_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Inu_scaled :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_Inu_scaled(nu, x); +%result (double y) + +%fun bessel_Inu_scaled_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Inu_scaled_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Knu :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_Knu(nu, x); +%result (double y) + +%fun bessel_Knu_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Knu_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_Knu_scaled :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_Knu_scaled(nu, x); +%result (double y) + +%fun bessel_Knu_scaled_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_Knu_scaled_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_lnKnu :: Double -> Double -> Double +%call (double nu) (double x) +%code double y; +% y = gsl_sf_bessel_lnKnu(nu, x); +%result (double y) + +%fun bessel_lnKnu_e :: Double -> Double -> (Double, Double) +%call (double nu) (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_lnKnu_e(nu, x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_zero_J0 :: Int -> Double +%call (int s) +%code double y; +% y = gsl_sf_bessel_zero_J0(s); +%result (double y) + +%fun bessel_zero_J0_e :: Int -> (Double, Double) +%call (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_zero_J0_e(s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_zero_J1 :: Int -> Double +%call (int s) +%code double y; +% y = gsl_sf_bessel_zero_J1(s); +%result (double y) + +%fun bessel_zero_J1_e :: Int -> (Double, Double) +%call (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_zero_J1_e(s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun bessel_zero_Jnu :: Double -> Int -> Double +%call (double nu) (int s) +%code double y; +% y = gsl_sf_bessel_zero_Jnu(nu, s); +%result (double y) + +%fun bessel_zero_Jnu_e :: Double -> Int -> (Double, Double) +%call (double nu) (int s) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_bessel_zero_Jnu_e(nu, s, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) diff --git a/Numeric/Special/Clausen.gc b/Numeric/Special/Clausen.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Clausen.gc @@ -0,0 +1,45 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Clausen +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Clausen functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Clausen (clausen, clausen_e, + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun clausen :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_clausen(x); +%result (double y) + +%fun clausen_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_clausen_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) diff --git a/Numeric/Special/Ellint.gc b/Numeric/Special/Ellint.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Ellint.gc @@ -0,0 +1,234 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Ellint +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Ellint functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Ellint (ellint_Kcomp, ellint_Kcomp_e, + ellint_Ecomp, ellint_Ecomp_e, + ellint_F, ellint_F_e, + ellint_E, ellint_E_e, + ellint_P, ellint_P_e, + ellint_D, ellint_D_e, + ellint_RC, ellint_RC_e, + ellint_RD, ellint_RD_e, + ellint_RF, ellint_RF_e, + ellint_RJ, ellint_RJ_e + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun ellint_Kcomp :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_ellint_Kcomp(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun ellint_Kcomp_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_Kcomp_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_Ecomp :: Double -> Double +%call (double k) +%code double y; +% y = gsl_sf_ellint_Ecomp(k, GSL_PREC_DOUBLE); +%result (double y) + +%fun ellint_Ecomp_e :: Double -> (Double, Double) +%call (double k) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_Ecomp_e(k, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_F :: Double -> Double -> Double +%call (double phi) (double k) +%code double y; +% y = gsl_sf_ellint_F(phi, k, GSL_PREC_DOUBLE); +%result (double y) + +%fun ellint_F_e :: Double -> Double -> (Double, Double) +%call (double phi) (double k) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_F_e(phi, k, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_E :: Double -> Double -> Double +%call (double phi) (double k) +%code double y; +% y = gsl_sf_ellint_E(phi, k, GSL_PREC_DOUBLE); +%result (double y) + +%fun ellint_E_e :: Double -> Double -> (Double, Double) +%call (double phi) (double k) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_E_e(phi, k, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_P :: Double -> Double -> Double -> Double +%call (double phi) (double k) (double n) +%code double y; +% y = gsl_sf_ellint_P(phi, k, n, GSL_PREC_DOUBLE); +%result (double y) + +%fun ellint_P_e :: Double -> Double -> Double -> (Double, Double) +%call (double phi) (double k) (double n) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_P_e(phi, k, n, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_D :: Double -> Double -> Double -> Double +%call (double phi) (double k) (double n) +%code double y; +% y = gsl_sf_ellint_D(phi, k, n, GSL_PREC_DOUBLE); +%result (double y) + +%fun ellint_D_e :: Double -> Double -> Double -> (Double, Double) +%call (double phi) (double k) (double n) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_D_e(phi, k, n, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_RC :: Double -> Double -> Double +%call (double x) (double y) +%code double it; +% it = gsl_sf_ellint_RC(x, y, GSL_PREC_DOUBLE); +%result (double it) + +%fun ellint_RC_e :: Double -> Double -> (Double, Double) +%call (double x) (double y) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_RC_e(x, y, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_RD :: Double -> Double -> Double -> Double +%call (double x) (double y) (double z) +%code double it; +% it = gsl_sf_ellint_RD(x, y, z, GSL_PREC_DOUBLE); +%result (double it) + +%fun ellint_RD_e :: Double -> Double -> Double -> (Double, Double) +%call (double x) (double y) (double z) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_RD_e(x, y, z, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_RF :: Double -> Double -> Double -> Double +%call (double x) (double y) (double z) +%code double it; +% it = gsl_sf_ellint_RF(x, y, z, GSL_PREC_DOUBLE); +%result (double it) + +%fun ellint_RF_e :: Double -> Double -> Double -> (Double, Double) +%call (double x) (double y) (double z) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_RF_e(x, y, z, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun ellint_RJ :: Double -> Double -> Double -> Double -> Double +%call (double x) (double y) (double z) (double p) +%code double it; +% it = gsl_sf_ellint_RJ(x, y, z, p, GSL_PREC_DOUBLE); +%result (double it) + +%fun ellint_RJ_e :: Double -> Double -> Double -> Double -> (Double, Double) +%call (double x) (double y) (double z) (double p) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_ellint_RJ_e(x, y, z, p, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) diff --git a/Numeric/Special/Elljac.gc b/Numeric/Special/Elljac.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Elljac.gc @@ -0,0 +1,93 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Elljac +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Elljac functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Elljac (elljac_e, + elljac_sn_e, elljac_cn_e, elljac_dn_e, + elljac_cd_e, elljac_dc_e, elljac_ns_e, + elljac_sd_e, elljac_nc_e, elljac_ds_e, + elljac_nd_e, elljac_sc_e, elljac_cs_e + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun elljac_e :: Double -> Double -> (Double, Double, Double) +%call (double u) (double m) +%code int status; +% double sn; +% double cn; +% double dn; +% status = gsl_sf_elljac_e(u, m, &sn, &cn, &dn); +%fail {status != 0} {gsl_strerror(status)} +%result (double sn, double cn, double dn) + +------------------------------------------------------------------------------- + +-- Abramowitz & Stegun, Sec 16.3 + +elljac_sn_e :: Double -> Double -> Double +elljac_sn_e u m = sn + where (sn,_,_) = elljac_e u m + +elljac_cn_e :: Double -> Double -> Double +elljac_cn_e u m = cn + where (_,cn,_) = elljac_e u m + +elljac_dn_e :: Double -> Double -> Double +elljac_dn_e u m = dn + where (_,_,dn) = elljac_e u m + +elljac_cd_e :: Double -> Double -> Double +elljac_cd_e u m = cn / dn + where (_,cn,dn) = elljac_e u m + +elljac_sd_e :: Double -> Double -> Double +elljac_sd_e u m = sn / dn + where (sn,_,dn) = elljac_e u m + +elljac_nd_e :: Double -> Double -> Double +elljac_nd_e u m = 1 / dn + where (_,_,dn) = elljac_e u m + +elljac_dc_e :: Double -> Double -> Double +elljac_dc_e u m = dn / cn + where (_,cn,dn) = elljac_e u m + +elljac_nc_e :: Double -> Double -> Double +elljac_nc_e u m = 1 / cn + where (_,cn,_) = elljac_e u m + +elljac_sc_e :: Double -> Double -> Double +elljac_sc_e u m = sn / cn + where (sn,cn,_) = elljac_e u m + +elljac_ns_e :: Double -> Double -> Double +elljac_ns_e u m = 1 / sn + where (sn,_,_) = elljac_e u m + +elljac_ds_e :: Double -> Double -> Double +elljac_ds_e u m = dn / sn + where (sn,_,dn) = elljac_e u m + +elljac_cs_e :: Double -> Double -> Double +elljac_cs_e u m = cn / sn + where (sn,cn,_) = elljac_e u m diff --git a/Numeric/Special/Erf.gc b/Numeric/Special/Erf.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Erf.gc @@ -0,0 +1,129 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Erf +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Erf functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Erf (erfc, erfc_e, + log_erfc, log_erfc_e, + erf, erf_e, + erf_Z, erf_Z_e, + erf_Q, erf_Q_e, + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun erfc :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_erfc(x); +%result (double y) + +%fun erfc_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_erfc_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun log_erfc :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_log_erfc(x); +%result (double y) + +%fun log_erfc_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_log_erfc_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun erf :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_erf(x); +%result (double y) + +%fun erf_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_erf_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun erf_Z :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_erf_Z(x); +%result (double y) + +%fun erf_Z_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_erf_Z_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) + +------------------------------------------------------------------------------- + +%fun erf_Q :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_erf_Q(x); +%result (double y) + +%fun erf_Q_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_erf_Q_e(x, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) diff --git a/Numeric/Special/Foo.gc b/Numeric/Special/Foo.gc new file mode 100644 --- /dev/null +++ b/Numeric/Special/Foo.gc @@ -0,0 +1,45 @@ +{-# OPTIONS -fffi -fvia-C #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Special.Foo +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFI to GSL for the Foo functions +-- +----------------------------------------------------------------------------- + +module Numeric.Special.Foo (foo_Bar, foo_Bar_e, + ) where + +import StdDIS + +import Foreign + +%#include +%#include + +------------------------------------------------------------------------------- + +%fun foo_Bar :: Double -> Double +%call (double x) +%code double y; +% y = gsl_sf_foo_Bar(x, GSL_PREC_DOUBLE); +%result (double y) + +%fun foo_Bar_e :: Double -> (Double, Double) +%call (double x) +%code int status; +% double val; +% double err; +% gsl_sf_result result; +% status = gsl_sf_foo_Bar_e(x, GSL_PREC_DOUBLE, &result); +% val = result.val; +% err = result.err; +%fail {status != 0} {gsl_strerror(status)} +%result (double val, double err) diff --git a/Numeric/Special/Trigonometric.hs b/Numeric/Special/Trigonometric.hs new file mode 100644 --- /dev/null +++ b/Numeric/Special/Trigonometric.hs @@ -0,0 +1,81 @@ +module Numeric.Special.Trigonometric (csc, sec, cot, + acsc, asec, acot, + csch, sech, coth, + acsch, asech, acoth + ) where + +import Data.Complex + +-- Circular functions + +csc :: Floating a => a -> a +csc z = 1 / sin z + +sec :: Floating a => a -> a +sec z = 1 / cos z + +cot :: Floating a => a -> a +cot z = 1 / tan z + +-- Inverse circular functions + +acsc :: Floating a => a -> a +acsc z = asin $ 1 / z + +asec :: Floating a => a -> a +asec z = acos $ 1 / z + +acot :: Floating a => a -> a +acot z = atan $ 1 / z + +-- Hyperbolic functions + +csch :: Floating a => a -> a +csch z = 1 / sinh z + +sech :: Floating a => a -> a +sech z = 1 / cosh z + +coth :: Floating a => a -> a +coth z = 1 / tanh z + +-- Inverse hyperbolic functions + +acsch :: Floating a => a -> a +acsch z = asinh $ 1 / z + +asech :: Floating a => a -> a +asech z = acosh $ 1 / z + +acoth :: Floating a => a -> a +acoth z = atanh $ 1 / z + +-- Specialization pragmas + +{-# specialize csc :: Double -> Double #-} +{-# specialize csc :: Complex Double -> Complex Double #-} +{-# specialize sec :: Double -> Double #-} +{-# specialize sec :: Complex Double -> Complex Double #-} +{-# specialize cot :: Double -> Double #-} +{-# specialize cot :: Complex Double -> Complex Double #-} + +{-# specialize acsc :: Double -> Double #-} +{-# specialize acsc :: Complex Double -> Complex Double #-} +{-# specialize asec :: Double -> Double #-} +{-# specialize asec :: Complex Double -> Complex Double #-} +{-# specialize acot :: Double -> Double #-} +{-# specialize acot :: Complex Double -> Complex Double #-} + +{-# specialize csch :: Double -> Double #-} +{-# specialize csch :: Complex Double -> Complex Double #-} +{-# specialize sech :: Double -> Double #-} +{-# specialize sech :: Complex Double -> Complex Double #-} +{-# specialize coth :: Double -> Double #-} +{-# specialize coth :: Complex Double -> Complex Double #-} + +{-# specialize acsch :: Double -> Double #-} +{-# specialize acsch :: Complex Double -> Complex Double #-} +{-# specialize asech :: Double -> Double #-} +{-# specialize asech :: Complex Double -> Complex Double #-} +{-# specialize acoth :: Double -> Double #-} +{-# specialize acoth :: Complex Double -> Complex Double #-} diff --git a/Numeric/Statistics/Covariance.hs b/Numeric/Statistics/Covariance.hs new file mode 100644 --- /dev/null +++ b/Numeric/Statistics/Covariance.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Statistics.Covariance +-- Copyright : (c) Matthew Donadio 2002 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED +-- +-- Simple module for computing the covariance of two lists +-- +-- @ Cov(X1,X2) = 1\/(N-1) * sum (i=1..N) ((x1_i - mu1)(x2_i - mu2)) @ +-- +-- Reference: Ross, NRiC +-- +----------------------------------------------------------------------------- + +module Numeric.Statistics.Covariance (cov) where + +import Data.List + +import Numeric.Statistics.Moment + +cov :: (Fractional a) => [a] -> [a] -> a +cov x1 x2 = Prelude.sum (zipWith (*) (map f1 x1) (map f2 x2)) / (n - 1) + where mu1 = mean x1 + mu2 = mean x2 + n = fromIntegral $ length $ x1 + f1 = \x -> (x - mu1)^2 + f2 = \x -> (x - mu2)^2 diff --git a/Numeric/Statistics/Median.hs b/Numeric/Statistics/Median.hs new file mode 100644 --- /dev/null +++ b/Numeric/Statistics/Median.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Statistics.Median +-- Copyright : (c) Matthew Donadio 2002 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple module for computing the median on a list +-- +-- Reference: Ross, NRiC +-- +----------------------------------------------------------------------------- + +module Numeric.Statistics.Median (median) where + +import Data.List + +-- | Compute the median of a list + +median :: (Ord a, Fractional a) => [a] -> a +median x | odd n = sort x !! (n `div` 2) + | even n = ((sort x !! (n `div` 2 - 1)) + (sort x !! (n `div` 2))) / 2 + where n = length x diff --git a/Numeric/Statistics/Moment.hs b/Numeric/Statistics/Moment.hs new file mode 100644 --- /dev/null +++ b/Numeric/Statistics/Moment.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Statistics.Moment +-- Copyright : (c) Matthew Donadio 2002 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple module for computing the various moments of a list +-- +-- Reference: Ross, NRiC +-- +----------------------------------------------------------------------------- + +module Numeric.Statistics.Moment (mean, var, + stddev, avgdev, + skew, kurtosis) where + +-- TODO: does mean pass though the list twice? once to compute the sum, +-- and the second to compute the length? + +-- TODO: does var passes through the list twice, once to compute the mean of +-- the squares, and the other to compute the mean? + +import Data.List + +-- * Functions + +-- | Compute the mean of a list +-- +-- @Mean(X) = 1\/N sum(i=1..N) x_i @ + +-- We need to use Prelude.sum intead of sum because of a buglet in the +-- Data.List library that effects nhc98 + +mean :: (Fractional a) => [a] -> a +mean x = Prelude.sum x / (fromIntegral.length) x + +-- | Compute the variance of a list +-- +-- @Var(X) = sigma^2@ +-- +-- @ = 1\/N-1 sum(i=1..N) (x_i-mu)^2 @ + +-- This is an approximation +-- var x = (mean $ map (^2) x) - mu^2 +-- where mu = mean x + +var :: (Fractional a) => [a] -> a +var xs = Prelude.sum (map (\x -> (x - mu)^2) xs) / (n - 1) + where mu = mean xs + n = fromIntegral $ length $ xs + +-- | Compute the standard deviation of a list +-- +-- @ StdDev(X) = sigma = sqrt (Var(X)) @ + +stddev :: (RealFloat a) => [a] -> a +stddev x = sqrt $ var x + +-- | Compute the average deviation of a list +-- +-- @ AvgDev(X) = 1\/N sum(i=1..N) |x_i-mu| @ + +avgdev :: (RealFloat a) => [a] -> a +avgdev xs = Prelude.sum (map (\x -> abs (x - mu)) xs) / n + where mu = mean xs + n = fromIntegral $ length $ xs + +-- | Compute the skew of a list +-- +-- @ Skew(X) = 1\/N sum(i=1..N) ((x_i-mu)\/sigma)^3 @ + +skew :: (RealFloat a) => [a] -> a +skew xs = Prelude.sum (map (\x -> ((x - mu) / sigma)^3) xs) / n + where mu = mean xs + sigma = stddev xs + n = fromIntegral $ length $ xs + +-- | Compute the kurtosis of a list +-- +-- @ Kurt(X) = ( 1\/N sum(i=1..N) ((x_i-mu)\/sigma)^4 ) - 3@ + +kurtosis :: (RealFloat a) => [a] -> a +kurtosis xs = Prelude.sum (map (\x -> ((x - mu) / sigma)^4) xs) / n - 3 + where mu = mean xs + sigma = stddev xs + n = fromIntegral $ length $ xs diff --git a/Numeric/Statistics/TTest.hs b/Numeric/Statistics/TTest.hs new file mode 100644 --- /dev/null +++ b/Numeric/Statistics/TTest.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Statistics.TTest +-- Copyright : (c) Matthew Donadio 2002 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- UNTESTED: DO NOT USE +-- +-- Student's t-test functions +-- +-- Reference: NRiC +-- +----------------------------------------------------------------------------- + +module Numeric.Statistics.TTest (ttest, tutest, tptest) where + +import Data.List + +import Numeric.Statistics.Covariance +import Numeric.Statistics.Moment + +ttest :: [Double] -- ^ X1 + -> [Double] -- ^ X2 + -> Double -- ^ t + +ttest x1 x2 = t + where t = (mu1 - mu2) / s_d + mu1 = Prelude.sum x1 / n1 + mu2 = Prelude.sum x2 / n2 + v1 = Prelude.sum (map (\x -> (x - mu1)^2) x1) + v2 = Prelude.sum (map (\x -> (x - mu2)^2) x2) + n1 = fromIntegral $ length $ x1 + n2 = fromIntegral $ length $ x2 + s_d = sqrt (((v1 + v2) / (n1+n2-2)) * (1/n1 + 1/n2)) + +tutest :: [Double] -- ^ X1 + -> [Double] -- ^ X2 + -> Double -- ^ t + +tutest x1 x2 = t + where t = (mu1 - mu2) / sqrt (var1 / n1 + var2 / n2) + mu1 = mean x1 + mu2 = mean x2 + var1 = var x1 + var2 = var x2 + n1 = fromIntegral $ length $ x1 + n2 = fromIntegral $ length $ x2 + +tptest :: [Double] -- ^ X1 + -> [Double] -- ^ X2 + -> Double -- ^ t + +tptest x1 x2 = t + where t = (mu1 - mu2) / s_d + mu1 = mean x1 + mu2 = mean x2 + var1 = var x1 + var2 = var x2 + s_d = sqrt ((var1 + var2 - 2 * cov x1 x2) / n) + n = fromIntegral $ length $ x1 + + diff --git a/Numeric/Transform/Fourier/CT.hs b/Numeric/Transform/Fourier/CT.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/CT.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.CT +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Cooley-Tukey algorithm for computing the FFT +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.CT (fft_ct1, fft_ct2) where + +import Data.List +import Data.Array +import Data.Complex + +-- | Cooley-Tukey algorithm doing row FFT's then column FFT's + +{-# specialize fft_ct1 :: Array Int (Complex Float) -> Int -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_ct1 :: Array Int (Complex Double) -> Int -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_ct1 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ nrows + -> a -- ^ ncols + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_ct1 a l m fft = array (0,n-1) $ zip ks (elems x') + where x = listArray ((0,0),(l-1,m-1)) [ a!i | i <- xs ] + f = listArray ((0,0),(l-1,m-1)) (flatten_rows $ map fft $ rows x) + g = listArray ((0,0),(l-1,m-1)) [ f!(i,j) * w!(i*j) | i <- [0..(l-1)], j <- [0..(m-1)] ] + x' = listArray ((0,0),(l-1,m-1)) (flatten_cols $ map fft $ cols g) + wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + (xs,ks) = ct_index_map1 l m + n = l * m + +-- | Cooley-Tukey algorithm doing column FFT's then row FFT's + +{-# specialize fft_ct2 :: Array Int (Complex Float) -> Int -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_ct2 :: Array Int (Complex Double) -> Int -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_ct2 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ nrows + -> a -- ^ ncols + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ fft function + -> Array a (Complex b) -- ^ X[k] + +fft_ct2 a l m fft = array (0,n-1) $ zip ks (elems x') + where x = listArray ((0,0),(l-1,m-1)) [ a!i | i <- xs ] + f = listArray ((0,0),(l-1,m-1)) (flatten_cols $ map fft $ cols x) + g = listArray ((0,0),(l-1,m-1)) [ f!(i,j) * w!(i*j) | i <- [0..(l-1)], j <- [0..(m-1)] ] + x' = listArray ((0,0),(l-1,m-1)) (flatten_rows $ map fft $ rows g) + wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + (xs,ks) = ct_index_map2 l m + n = l * m + +-- Index maps + +{-# specialize ct_index_map1 :: Int -> Int -> ([Int],[Int]) #-} + +ct_index_map1 :: (Integral a) => a -> a -> ([a],[a]) +ct_index_map1 l m = (n,k) + where n = [ n1 + l * n2 | n1 <- [0..(l-1)], n2 <- [0..(m-1)] ] + k = [ m * k1 + k2 | k1 <- [0..(l-1)], k2 <- [0..(m-1)] ] + +{-# specialize ct_index_map2 :: Int -> Int -> ([Int],[Int]) #-} + +ct_index_map2 :: (Integral a) => a -> a -> ([a],[a]) +ct_index_map2 l m = (n,k) + where n = [ m * n1 + n2 | n1 <- [0..(l-1)], n2 <- [0..(m-1)] ] + k = [ k1 + l * k2 | k1 <- [0..(l-1)], k2 <- [0..(m-1)] ] + +-- Auxilary functions (also used for PFA) + +{-# specialize rows :: Array (Int,Int) (Complex Float) -> [Array Int (Complex Float)] #-} +{-# specialize rows :: Array (Int,Int) (Complex Double) -> [Array Int (Complex Double)] #-} + +rows :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -> [Array a (Complex b)] +rows x = [ listArray (0,m) [ x!(i,j) | j <- [0..m] ] | i <- [0..l] ] + where ((_,_),(l,m)) = bounds x + +{-# specialize cols :: Array (Int,Int) (Complex Float) -> [Array Int (Complex Float)] #-} +{-# specialize cols :: Array (Int,Int) (Complex Double) -> [Array Int (Complex Double)] #-} + +cols :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -> [Array a (Complex b)] +cols x = [ listArray (0,l) [ x!(i,j) | i <- [0..l] ] | j <- [0..m] ] + where ((_,_),(l,m)) = bounds x + +{-# specialize flatten_rows :: [Array Int (Complex Float)] -> [(Complex Float)] #-} +{-# specialize flatten_rows :: [Array Int (Complex Double)] -> [(Complex Double)] #-} + +flatten_rows :: (Ix a, Integral a, RealFloat b) => [Array a (Complex b)] -> [(Complex b)] +flatten_rows a = foldr (++) [] $ map elems a + +{-# specialize flatten_cols :: [Array Int (Complex Float)] -> [(Complex Float)] #-} +{-# specialize flatten_cols :: [Array Int (Complex Double)] -> [(Complex Double)] #-} + +flatten_cols :: (Ix a, Integral a, RealFloat b) => [Array a (Complex b)] -> [(Complex b)] +flatten_cols a = foldr (++) [] $ transpose $ map elems a diff --git a/Numeric/Transform/Fourier/DFT.hs b/Numeric/Transform/Fourier/DFT.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/DFT.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.DFT +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Not so naive implementation of a Discrete Fourier Transform. +-- +----------------------------------------------------------------------------- + +{- +We cheat in three ways from a direct translation of the DFT equation: + + X(k) = sum(n=0..N-1) x(n) * e^(-2*j*pi*n*k/N) + +1. We precompute all values of W_N, and exploit the periodicity. +This is just to cut down on the number of sin/cos calls. + +2. We calculate X(0) seperately to prevent multiplication by 1 + +3. We factor out x(0) to prevent multiplication by 1 +-} + +module Numeric.Transform.Fourier.DFT (dft) where + +import Data.Array +import Data.Complex + +-- We use a helper function here because we may want to have special +-- cases for small DFT's and we want to precompute the suspension all of +-- the twiddle factors. + +{-# specialize dft :: Array Int (Complex Float) -> Array Int (Complex Float) #-} +{-# specialize dft :: Array Int (Complex Double) -> Array Int (Complex Double) #-} + +dft :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> Array a (Complex b) -- ^ X[k] +dft a = dft' a w n + where w = listArray (0,n-1) [ cis (-2 * pi * fromIntegral i / fromIntegral n) | i <- [0..(n-0)] ] + n = snd (bounds a) + 1 + +{-# specialize dft' :: Array Int (Complex Float) -> Array Int (Complex Float) -> Int -> Array Int (Complex Float) #-} +{-# specialize dft' :: Array Int (Complex Double) -> Array Int (Complex Double) -> Int -> Array Int (Complex Double) #-} + +dft' :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -> Array a (Complex b) -> a -> Array a (Complex b) +dft' a w 1 = a +dft' a w n = listArray (0,n-1) (sum [ a!k | k <- [0..(n-1)] ] : [ a!0 + sum [ a!k * wik i k | k <- [1..(n-1)] ] | i <- [1..(n-1)] ]) + where wik 0 k = 1 + wik i 0 = 1 + wik i k = w!(i*k `mod` n) diff --git a/Numeric/Transform/Fourier/FFT.hs b/Numeric/Transform/Fourier/FFT.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/FFT.hs @@ -0,0 +1,188 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.FFT +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- FFT driver functions +-- +----------------------------------------------------------------------------- + +-- TODO: unify the notation and methods in this file + +module Numeric.Transform.Fourier.FFT (fft, ifft, rfft, irfft, r2fft) where + +import Data.List +import Data.Array +import Data.Complex + +import Numeric.Transform.Fourier.FFTHard +import Numeric.Transform.Fourier.R2DIF +import Numeric.Transform.Fourier.R2DIT +import Numeric.Transform.Fourier.R4DIF +import Numeric.Transform.Fourier.SRDIF +import Numeric.Transform.Fourier.CT +import Numeric.Transform.Fourier.PFA +import Numeric.Transform.Fourier.Rader + +------------------------------------------------------------------------------- + +-- | This is the driver routine for calculating FFT's. All of the +-- recursion in the various algorithms are defined in terms of 'fft'. + +-- The logic is based on FFTW. + +{-# specialize fft :: Array Int (Complex Float) -> Array Int (Complex Float) #-} +{-# specialize fft :: Array Int (Complex Double) -> Array Int (Complex Double) #-} + +fft :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> Array a (Complex b) -- ^ X[k] +fft a | n == 1 = a + | n == 2 = fft'2 a + | n == 3 = fft'3 a + | n == 4 = fft'4 a + | l == 1 && n <= 11 = fft_rader1 a n + | l == 1 && n > 11 = fft_rader2 a n fft + | gcd l m == 1 = fft_pfa a l m fft + | n `mod` 4 == 0 = fft_r4dif a n fft + | n `mod` 2 == 0 = fft_r2dif a n fft + | otherwise = fft_ct1 a l m fft + where l = choose_factor n + m = n `div` l + n = snd (bounds a) + 1 + +-- choose_factor is borrowed from FFTW + +{-# specialize choose1 :: Int -> Int #-} + +choose1 :: (Integral a) => a -> a +choose1 n = loop1 1 1 + where loop1 i f | i * i > n = f + | (n `mod` i) == 0 && gcd i (n `div` i) == 1 = loop1 (i+1) i + | otherwise = loop1 (i+1) f + +{-# specialize choose2 :: Int -> Int #-} + +choose2 :: (Integral a) => a -> a +choose2 n = loop2 1 1 + where loop2 i f | i * i > n = f + | n `mod` i == 0 = loop2 (i+1) i + | otherwise = loop2 (i+1) f + +{-# specialize choose_factor :: Int -> Int #-} + +choose_factor :: (Integral a) => a -> a +choose_factor n | i > 1 = i + | otherwise = choose2 n + where i = choose1 n + +------------------------------------------------------------------------------- + +-- We want to define the inverse and real valued FFT's based on the +-- forward complex Numeric.Transform.Fourier. This way, if we implement a speedup, we only +-- have to do it in one place. Personally, I don't like adding a sign +-- argument to the FFT for signify forward and inverse. + +-- x(n) = 1/N * ~(fft ~X(k)) +-- where X(k) = fft(x(n)) +-- x = conjugate x +-- N = length x + +-- P&M and Rick Lyon's books have the derivation. + +-- ifft a = fmap (/ fromIntegral n) $ fmap conjugate $ fft $ fmap conjugate a +-- where n = snd (bounds a) + 1 + +-- We can also replace complex conjugation by swapping the real and +-- imaginary parts and get the same result. Rick Lyon's book has the +-- derivation. + +{-# specialize ifft :: Array Int (Complex Float) -> Array Int (Complex Float) #-} +{-# specialize ifft :: Array Int (Complex Double) -> Array Int (Complex Double) #-} + +-- | Inverse FFT, including scaling factor, defined in terms of 'fft' + +ifft :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> Array a (Complex b) -- ^ x[n] +ifft a = fmap (/ fromIntegral n) $ fmap swap $ fft $ fmap swap a + where swap (x:+y) = (y:+x) + n = snd (bounds a) + 1 + +------------------------------------------------------------------------------- + +-- | This is the algorithm for computing 2N-point real FFT with an N-point +-- complex FFT, defined in terms of 'fft' + +-- This formulation is from Rick's book. + +{-# specialize rfft :: Array Int Float -> Array Int (Complex Float) #-} +{-# specialize rfft :: Array Int Double -> Array Int (Complex Double) #-} + +rfft :: (Ix a, Integral a, RealFloat b) => Array a b -- ^ x[n] + -> Array a (Complex b) -- ^ X[k] + +rfft a = listArray (0,n-1) $ [ xa1 m | m <- [0..(n2-1)] ] ++ [ xa2 m | m <- [0..(n2-1)] ] + where x = fft $ listArray (0,n2-1) $ rfft_unzip (elems a) + xpr = listArray (0,n2-1) (xr!0 : [ (xr!m + xr!(n2-m)) / 2 | m <- [1..(n2-1)] ]) + xmr = listArray (0,n2-1) (0 : [ (xr!m - xr!(n2-m)) / 2 | m <- [1..(n2-1)] ]) + xpi = listArray (0,n2-1) (xi!0 : [ (xi!m + xi!(n2-m)) / 2 | m <- [1..(n2-1)] ]) + xmi = listArray (0,n2-1) (0 : [ (xi!m - xi!(n2-m)) / 2 | m <- [1..(n2-1)] ]) + xr = fmap realPart x + xi = fmap imagPart x + xa1 m = (xpr!m + cos w * xpi!m - sin w * xmr!m) :+ + (xmi!m - sin w * xpi!m - cos w * xmr!m) + where w = pi * fromIntegral m / fromIntegral n2 + xa2 m = (xpr!m - cos w * xpi!m + sin w * xmr!m) :+ + (xmi!m + sin w * xpi!m + cos w * xmr!m) + where w = pi * fromIntegral m / fromIntegral n2 + rfft_unzip [] = [] + rfft_unzip (x1:x2:xs) = (x1:+x2) : rfft_unzip xs + n = (snd (bounds a) + 1) + n2 = n `div` 2 + +------------------------------------------------------------------------------- + +-- | This is the algorithm for computing a 2N-point real inverse FFT with an +-- N-point complex FFT, defined in terms of 'ifft' + +{-# specialize irfft :: Array Int (Complex Float) -> Array Int Float #-} +{-# specialize irfft :: Array Int (Complex Double) -> Array Int Double #-} + +irfft :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ X[k] + -> Array a b -- ^ x[n] + +irfft f = listArray (0,n-1) $ irfft_unzip $ elems $ ifft $ z + where fe = listArray (0,n2-1) [ 0.5 * (f!k + f!(n2+k)) | k <- [0..n2-1] ] + fo = listArray (0,n2-1) [ 0.5 * (f!k - f!(n2+k)) * w k | k <- [0..n2-1] ] + w k = cis $ 2 * pi * fromIntegral k / fromIntegral n + z = listArray (0,n2-1) [ fe!k + j * fo!k | k <- [0..n2-1] ] + j = 0 :+ 1 + n = snd (bounds f) + 1 + n2 = n `div` 2 + irfft_unzip [] = [] + irfft_unzip ((xr:+xi):xs) = xr : xi : irfft_unzip xs + +------------------------------------------------------------------------------- + +-- | Algorithm for 2 N-point real FFT's computed with N-point complex +-- FFT, defined in terms of 'fft' + +{-# specialize r2fft :: Array Int Float -> Array Int Float -> (Array Int (Complex Float),Array Int (Complex Float)) #-} +{-# specialize r2fft :: Array Int Double -> Array Int Double -> (Array Int (Complex Double),Array Int (Complex Double)) #-} + +r2fft :: (Ix a, Integral a, RealFloat b) => Array a b -- ^ x1[n] + -> Array a b -- ^ x2[n] + -> (Array a (Complex b), Array a (Complex b)) -- ^ (X1[k],X2[k]) + +r2fft x1 x2 = (x1',x2') + where x = listArray (0,n-1) $ zipWith (:+) (elems x1) (elems x2) + x' = fft x + x1' = listArray (0,n-1) (x1'0 : [ (0.5 :+ 0.0) * (x'!k + conjugate (x'!(n-k))) | k <- [1..(n-1)] ]) + x2' = listArray (0,n-1) (x2'0 : [ (0.0 :+ (-0.5)) * (x'!k - conjugate (x'!(n-k))) | k <- [1..(n-1)] ]) + x1'0 = realPart (x'!0) :+ 0 + x2'0 = imagPart (x'!0) :+ 0 + n = snd (bounds x1) + 1 diff --git a/Numeric/Transform/Fourier/FFTHard.hs b/Numeric/Transform/Fourier/FFTHard.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/FFTHard.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.FFTHard +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Hard-coded FFT transforms +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.FFTHard where + +import Data.Array +import Data.Complex + +-- These are the hard coded DFT's borrowed from FFTW + +{-# specialize fft'2 :: Array Int (Complex Float) -> Array Int (Complex Float) #-} +{-# specialize fft'2 :: Array Int (Complex Double) -> Array Int (Complex Double) #-} + +-- | Length 2 FFT + +fft'2 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> Array a (Complex b) -- ^ X[k] + +fft'2 a = array (0,1) [ (0, ((tmp1 + tmp2) :+ (tmp3 + tmp4))), + (1, ((tmp1 - tmp2) :+ (tmp3 - tmp4) )) ] + where tmp1 = realPart (a!0) + tmp3 = imagPart (a!0) + tmp2 = realPart (a!1) + tmp4 = imagPart (a!1) + +{-# specialize fft'3 :: Array Int (Complex Float) -> Array Int (Complex Float) #-} +{-# specialize fft'3 :: Array Int (Complex Double) -> Array Int (Complex Double) #-} + +-- | Length 3 FFT + +fft'3 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> Array a (Complex b) -- ^ X[k] + +fft'3 a = array (0,2) [ (0, ((tmp1 + tmp4) :+ (tmp10 + tmp11))), + (1, ((tmp5 + tmp8) :+ (tmp9 + tmp12))), + (2, ((tmp5 - tmp8) :+ (tmp12 - tmp9))) ] + where k866025403 = sqrt 3 / 2 + k500000000 = 0.5 + tmp1 = realPart (a!0) + tmp10 = imagPart (a!0) + tmp2 = realPart (a!1) + tmp6 = imagPart (a!1) + tmp3 = realPart (a!2) + tmp7 = imagPart (a!2) + tmp4 = tmp2 + tmp3 + tmp9 = k866025403 * (tmp3 - tmp2) + tmp8 = k866025403 * (tmp6 - tmp7) + tmp11 = tmp6 + tmp7 + tmp5 = tmp1 - (k500000000 * tmp4) + tmp12 = tmp10 - (k500000000 * tmp11) + +{-# specialize fft'4 :: Array Int (Complex Float) -> Array Int (Complex Float) #-} +{-# specialize fft'4 :: Array Int (Complex Double) -> Array Int (Complex Double) #-} + +-- | Length 4 FFT + +fft'4 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> Array a (Complex b) -- ^ X[k] + +fft'4 a = array (0,3) [ (0, (tmp3 + tmp6) :+ (tmp15 + tmp16)), + (1, (tmp11 + tmp14) :+ (tmp9 - tmp10)), + (2, (tmp3 - tmp6) :+ (tmp15 - tmp16)), + (3, (tmp11 - tmp14) :+ (tmp10 + tmp9)) ] + where tmp1 = realPart (a!0) + tmp7 = imagPart (a!0) + tmp4 = realPart (a!1) + tmp12 = imagPart (a!1) + tmp2 = realPart (a!2) + tmp8 = imagPart (a!2) + tmp5 = realPart (a!3) + tmp13 = imagPart (a!3) + tmp3 = tmp1 + tmp2 + tmp11 = tmp1 - tmp2 + tmp9 = tmp7 - tmp8 + tmp15 = tmp7 + tmp8 + tmp6 = tmp4 + tmp5 + tmp10 = tmp4 - tmp5 + tmp14 = tmp12 - tmp13 + tmp16 = tmp12 + tmp13 + +------------------------------------------------------------------------------- + diff --git a/Numeric/Transform/Fourier/FFTUtils.hs b/Numeric/Transform/Fourier/FFTUtils.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/FFTUtils.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.FFTUtils +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Utility functions based on the FFT +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.FFTUtils (fft_mag, fft_db, fft_phase, fft_grd, fft_info, + rfft_mag, rfft_db, rfft_phase, rfft_grd, rfft_info, + write_fft_info, write_rfft_info) where + +import System.IO +import Data.Array +import Data.Complex + +import Numeric.Transform.Fourier.FFT +import DSP.Unwrap + +magsq (x:+y) = x*x + y*y + +log10 0 = -1.0e9 +log10 x = logBase 10 x + +dot a b = realPart a * realPart b + imagPart a * imagPart b + +eps = 1.0e-1 :: Double + +-- General functions + +fft_mag x = fmap magnitude $ fft $ x + +fft_db x = fmap (10 *) $ fmap log10 $ fmap magsq $ fft $ x + +fft_phase x = unwrap eps $ fmap phase $ fft $ x + +fft_grd x = listArray (bounds x') [ dot (x'!i) (dx'!i) / magsq (x'!i) | i <- indices x' ] + where x' = fft x + dx' = fft $ listArray (bounds x) [ fromIntegral i * x!i | i <- indices x ] + +fft_info x = (mag,db,arg,grd) + where x' = fft x + dx' = fft $ listArray (bounds x) [ fromIntegral i * x!i | i <- indices x ] + mag = fmap magnitude $ x' + db = fmap (10 *) $ fmap log10 $ fmap magsq $ x' + arg = unwrap eps $ fmap phase $ x' + grd = listArray (bounds x') [ dot (x'!i) (dx'!i) / magsq (x'!i) | i <- indices x' ] + +rfft_mag x = fmap magnitude $ rfft $ x + +rfft_db x = fmap (10 *) $ fmap log10 $ fmap magsq $ rfft $ x + +rfft_phase x = unwrap eps $ fmap phase $ rfft $ x + +rfft_grd x = listArray (bounds x') [ dot (x'!i) (dx'!i) / magsq (x'!i) | i <- indices x' ] + where x' = rfft x + dx' = rfft $ listArray (bounds x) [ fromIntegral i * x!i | i <- indices x ] + dot a b = realPart a * realPart b + imagPart a * imagPart b + +-- I/O + +rfft_info x = (mag,db,arg,grd) + where x' = rfft x + dx' = rfft $ listArray (bounds x) [ fromIntegral i * x!i | i <- indices x ] + mag = fmap magnitude $ x' + db = fmap (10 *) $ fmap log10 $ fmap magsq $ x' + arg = unwrap eps $ fmap phase $ x' + grd = listArray (bounds x') [ dot (x'!i) (dx'!i) / magsq (x'!i) | i <- indices x' ] + +hPrintIndex h n (i,x) = do + hPutStr h $ show (fromIntegral i / fromIntegral n) + hPutStr h $ " " + hPutStrLn h $ show x + +write_cvector f x = do + let n = (snd $ bounds x) + 1 + h <- openFile f WriteMode + sequence $ map (hPrintIndex h n) $ assocs $ x + hClose h + +write_fft_info b x = do + let (mag,db,arg,grd) = fft_info x + write_cvector (b ++ "_mag.out") mag + write_cvector (b ++ "_db.out") mag + write_cvector (b ++ "_arg.out") mag + write_cvector (b ++ "_grd.out") mag + +write_rvector f x = do + let n = (snd $ bounds x) + 1 + h <- openFile f WriteMode + sequence $ map (hPrintIndex h n) $ take (n `div` 2) $ assocs $ x + hClose h + +write_rfft_info b x = do + let (mag,db,arg,grd) = rfft_info x + write_rvector (b ++ "_mag.out") mag + write_rvector (b ++ "_db.out") db + write_rvector (b ++ "_arg.out") arg + write_rvector (b ++ "_grd.out") grd diff --git a/Numeric/Transform/Fourier/Goertzel.hs b/Numeric/Transform/Fourier/Goertzel.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/Goertzel.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.Goertzel +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- This is an implementation of Goertzel's algorithm, which computes on +-- bin of a DFT. A description can be found in Oppenheim and Schafer's +-- /Discrete Time Signal Processing/, pp 585-587. +-- +----------------------------------------------------------------------------- + +-- TODO: do the cipherin' to figure out the best simplification for the +-- cgoertzel_power case + +-- TODO: Bonzanigo's phase correction + +module Numeric.Transform.Fourier.Goertzel where + +import Data.Array +import Data.Complex + +-- | Goertzel's algorithm for complex inputs + +cgoertzel :: (RealFloat a, Ix b, Integral b) => Array b (Complex a) -- ^ x[n] + -> b -- ^ k + -> Complex a -- ^ X[k] + +cgoertzel x k = g (elems x) 0 0 + where w = 2 * pi * fromIntegral k / fromIntegral n + a = 2 * cos w + g [] x1 x2 = x1 * cis w - x2 + g (x:xs) x1@(x1r:+x1i) x2 = g xs (x + (a*x1r:+a*x1i) - x2) x1 + n = (snd $ bounds x) - 1 + +-- | Power via Goertzel's algorithm for complex inputs + +cgoertzel_power :: (RealFloat a, Ix b, Integral b) => Array b (Complex a) -- ^ x[n] + -> b -- ^ k + -> a -- ^ |X[k]|^2 + +cgoertzel_power x k = (magnitude $ cgoertzel x k)^2 + +-- | Goertzel's algorithm for real inputs + +rgoertzel :: (RealFloat a, Ix b, Integral b) => Array b a -- ^ x[n] + -> b -- ^ k + -> Complex a -- ^ X[k] + +rgoertzel x k = g (elems x) 0 0 + where w = 2 * pi * fromIntegral k / fromIntegral n + a = 2 * cos w + g [] x1 x2 = ((x1 - cos w * x2) :+ x2 * sin w) + g (x:xs) x1 x2 = g xs (x + a * x1 - x2) x1 + n = (snd $ bounds x) - 1 + +-- | Power via Goertzel's algorithm for real inputs + +rgoertzel_power :: (RealFloat a, Ix b, Integral b) => Array b a -- ^ x[n] + -> b -- ^ k + -> a -- ^ |X[k]|^2 + +rgoertzel_power x k = g (elems x) 0 0 + where w = 2 * pi * fromIntegral k / fromIntegral n + a = 2 * cos w + g [] x1 x2 = x1^2 + x2^2 - a * x1 * x2 + g (x:xs) x1 x2 = g xs (x + a * x1 - x2) x1 + n = (snd $ bounds x) - 1 diff --git a/Numeric/Transform/Fourier/PFA.hs b/Numeric/Transform/Fourier/PFA.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/PFA.hs @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.PFA +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Prime Factor Algorithm +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.PFA (fft_pfa) where + +import Data.List +import Data.Array +import Data.Complex + +{-# specialize fft_pfa :: Array Int (Complex Float) -> Int -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_pfa :: Array Int (Complex Double) -> Int -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +-- | Prime Factor Algorithm doing row FFT's then column FFT's + +fft_pfa :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ nrows + -> a -- ^ ncols + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_pfa a l m fft = array (0,n-1) $ zip ks (elems x') + where x = listArray ((0,0),(l-1,m-1)) [ a!i | i <- xs ] + f = listArray ((0,0),(l-1,m-1)) (flatten_rows $ map fft $ rows x) + x' = listArray ((0,0),(l-1,m-1)) (flatten_cols $ map fft $ cols f) + (xs,ks) = pfa_index_map l m + n = l * m + +{-# specialize pfa_index_map :: Int -> Int -> ([Int],[Int]) #-} + +pfa_index_map :: (Integral a) => a -> a -> ([a],[a]) +pfa_index_map l m = (ns,ks) + where ns = [ (m * n1 + l * n2) `mod` n | n1 <- [0..(l-1)], n2 <- [0..(m-1)] ] + ks = [ (c * m * k1 + d * l * k2) `mod` n | k1 <- [0..(l-1)], k2 <- [0..(m-1)] ] + c = find_inverse m l + d = find_inverse l m + n = l * m + +{-# specialize find_inverse :: Int -> Int -> Int #-} + +find_inverse :: (Integral a) => a -> a -> a +find_inverse a n = find_inverse' a n 1 + where find_inverse' a n a' | (a*a') `mod` n == 1 = a' + | otherwise = find_inverse' a n (a'+1) + +{-# specialize rows :: Array (Int,Int) (Complex Float) -> [Array Int (Complex Float)] #-} +{-# specialize rows :: Array (Int,Int) (Complex Double) -> [Array Int (Complex Double)] #-} + +rows :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -> [Array a (Complex b)] +rows x = [ listArray (0,m) [ x!(i,j) | j <- [0..m] ] | i <- [0..l] ] + where ((_,_),(l,m)) = bounds x + +{-# specialize cols :: Array (Int,Int) (Complex Float) -> [Array Int (Complex Float)] #-} +{-# specialize cols :: Array (Int,Int) (Complex Double) -> [Array Int (Complex Double)] #-} + +cols :: (Ix a, Integral a, RealFloat b) => Array (a,a) (Complex b) -> [Array a (Complex b)] +cols x = [ listArray (0,l) [ x!(i,j) | i <- [0..l] ] | j <- [0..m] ] + where ((_,_),(l,m)) = bounds x + +{-# specialize flatten_rows :: [Array Int (Complex Float)] -> [(Complex Float)] #-} +{-# specialize flatten_rows :: [Array Int (Complex Double)] -> [(Complex Double)] #-} + +flatten_rows :: (Ix a, Integral a, RealFloat b) => [Array a (Complex b)] -> [(Complex b)] +flatten_rows a = foldr (++) [] $ map elems a + +{-# specialize flatten_cols :: [Array Int (Complex Float)] -> [(Complex Float)] #-} +{-# specialize flatten_cols :: [Array Int (Complex Double)] -> [(Complex Double)] #-} + +flatten_cols :: (Ix a, Integral a, RealFloat b) => [Array a (Complex b)] -> [(Complex b)] +flatten_cols a = foldr (++) [] $ transpose $ map elems a diff --git a/Numeric/Transform/Fourier/R2DIF.hs b/Numeric/Transform/Fourier/R2DIF.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/R2DIF.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.R2DIF +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Radix-2 Decimation in Frequency FFT +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.R2DIF (fft_r2dif) where + +import Data.List +import Data.Array +import Data.Complex + +------------------------------------------------------------------------------- + +-- | Radix-2 Decimation in Frequency FFT + +{-# specialize fft_r2dif :: Array Int (Complex Float) -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_r2dif :: Array Int (Complex Double) -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_r2dif :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ N + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_r2dif a n fft = y + where wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + ae = listArray (0,n2-1) [ a!k + a!(k+n2) | k <- [0..(n2-1)] ] + ao = listArray (0,n2-1) [ (a!k - a!(k+n2)) * w!k | k <- [0..(n2-1)] ] + ye = fft ae + yo = fft ao + y = listArray (0,n-1) (interleave (elems ye) (elems yo)) + interleave [] [] = [] + interleave (e:es) (o:os) = e : o : interleave es os + n2 = n `div` 2 diff --git a/Numeric/Transform/Fourier/R2DIT.hs b/Numeric/Transform/Fourier/R2DIT.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/R2DIT.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.R2DIT +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Radix-2 Decimation in Time FFT +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.R2DIT (fft_r2dit) where + +import Data.List +import Data.Array +import Data.Complex + +------------------------------------------------------------------------------- + +-- This a recursive implementation of a FFT. I believe this is +-- equivalent to a radix-2 decimation-in-time (DIT) FFT, which is a +-- special case of the Cooley-Tukey algorithm for N=2^v. + +-- This algorithm was taken from Cormen, Leiserson, and Rivest's +-- Introduction to Algorithms. + +-- | Radix-2 Decimation in Time FFT + +{-# specialize fft_r2dit :: Array Int (Complex Float) -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_r2dit :: Array Int (Complex Double) -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_r2dit :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ N + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_r2dit a n fft = y + where wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + a0 = listArray (0,n2-1) [ a!k | k <- [0..(n-1)], even k ] + a1 = listArray (0,n2-1) [ a!k | k <- [0..(n-1)], odd k ] + y0 = fft a0 + y1 = fft a1 + y = array (0,n-1) ([ (k, y0!k + w!k * y1!k) | k <- [0..(n2-1)] ] ++ [ (k + n2, y0!k - w!k * y1!k) | k <- [0..(n2-1)] ]) + n2 = n `div` 2 diff --git a/Numeric/Transform/Fourier/R4DIF.hs b/Numeric/Transform/Fourier/R4DIF.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/R4DIF.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.R4DIF +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Radix-4 Decimation in Frequency FFT +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.R4DIF (fft_r4dif) where + +import Data.List +import Data.Array +import Data.Complex + +------------------------------------------------------------------------------- + +-- | Radix-4 Decimation in Frequency FFT + +{-# specialize fft_r4dif :: Array Int (Complex Float) -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_r4dif :: Array Int (Complex Double) -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_r4dif :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ N + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_r4dif x n fft = listArray (0,n-1) $ c + where c4k0 = elems $ fft $ listArray (0,n4-1) x4k0 + c4k1 = elems $ fft $ listArray (0,n4-1) x4k1 + c4k2 = elems $ fft $ listArray (0,n4-1) x4k2 + c4k3 = elems $ fft $ listArray (0,n4-1) x4k3 + c = interleave (interleave c4k0 c4k2) (interleave c4k1 c4k3) + x4k0 = [ x!i + x!(i+n2) + x!(i+n4) + x!(i+n34) | i <- [0..n4-1] ] + x4k1 = [ (x!i - x!(i+n2) - j * (x!(i+n4) - x!(i+n34))) * w!i | i <- [0..n4-1] ] + x4k2 = [ (x!i + x!(i+n2) - x!(i+n4) - x!(i+n34)) * w!(2*i) | i <- [0..n4-1] ] + x4k3 = [ (x!i - x!(i+n2) + j * (x!(i+n4) - x!(i+n34))) * w!(3*i) | i <- [0..n4-1] ] + j = 0 :+ 1 + wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + interleave [] [] = [] + interleave (e:es) (o:os) = e : o : interleave es os + n2 = n `div` 2 + n4 = n `div` 4 + n34 = 3 * n4 diff --git a/Numeric/Transform/Fourier/Rader.hs b/Numeric/Transform/Fourier/Rader.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/Rader.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.Rader +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Rader's Algorithm for computing prime length FFT's +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.Rader (fft_rader1, fft_rader2) where + +import Data.List +import Data.Array +import Data.Complex + +------------------------------------------------------------------------------- + +-- Rader's Algorithm. We define this two ways: using direct circular +-- convolution, and FFT circular convolution. The algorithms and +-- implementations, are esentially the same, except for how hg is +-- computed. + +-- | Rader's Algorithm using direct convolution + +fft_rader1 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ N + -> Array a (Complex b) -- ^ X[k] + +fft_rader1 f n = f' + where h = listArray (0,n-2) [ f!(a ^* (n-(1+n'))) | n' <- [0..(n-2)] ] + g = listArray (0,n-2) [ w!(a ^* n') | n' <- [0..(n-2)] ] + hg = listArray (0,n-2) [ sum [ h!j * g!((i-j)`mod`(n-1)) | j <- [0..(n-2)] ] | i <- [0..(n-2)] ] + f' = array (0,n-1) ((0, sum [ f!i | i <- [0..(n-1)] ]) : [ (a ^* i, f!0 + hg!i) | i <- [0..(n-2)] ]) + wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + i ^* 0 = 1 + i ^* j = (i * (i ^* (j-1))) `mod` n + a = generator n + +-- | Rader's Algorithm using FFT convolution + +{-# specialize fft_rader2 :: Array Int (Complex Float) -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_rader2 :: Array Int (Complex Double) -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_rader2 :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ N + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_rader2 f n fft = f' + where h = listArray (0,n-2) [ f!(a ^* (n-(1+n'))) | n' <- [0..(n-2)] ] + g = listArray (0,n-2) [ w!(a ^* n') | n' <- [0..(n-2)] ] + h' = fft h + g' = fft g + hg' = listArray (0,n-2) [ h'!i * g'!i | i <- [0..(n-2)] ] + hg = ifft hg' + f' = array (0,n-1) ((0, sum [ f!i | i <- [0..(n-1)] ]) : [ (a ^* i, f!0 + hg!i) | i <- [0..(n-2)] ]) + wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + i ^* 0 = 1 + i ^* j = (i * (i ^* (j-1))) `mod` n + a = generator n + ifft a = fmap (/ fromIntegral (n-1)) $ fmap swap $ fft $ fmap swap a + swap (x:+y) = (y:+x) + +-- Haskell translation of find_generator from FFTW + +{-# specialize generator :: Int -> Int #-} + +generator :: (Integral a) => a -> a +generator p = findgen 1 + where findgen 0 = error "rader: generator: no primative root?" + findgen x | (period x x) == (p - 1) = x + | otherwise = findgen ((x + 1) `mod` p) + period x 1 = 1 + period x prod = 1 + (period x (prod * x `mod` p)) diff --git a/Numeric/Transform/Fourier/SRDIF.hs b/Numeric/Transform/Fourier/SRDIF.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/SRDIF.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.SRDIF +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Split-Radix Decimation in Frequency FFT +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.SRDIF (fft_srdif) where + +import Data.List +import Data.Array +import Data.Complex + +------------------------------------------------------------------------------- + +-- | Split-Radix Decimation in Frequency FFT + +{-# specialize fft_srdif :: Array Int (Complex Float) -> Int -> (Array Int (Complex Float) -> Array Int (Complex Float)) -> Array Int (Complex Float) #-} +{-# specialize fft_srdif :: Array Int (Complex Double) -> Int -> (Array Int (Complex Double) -> Array Int (Complex Double)) -> Array Int (Complex Double) #-} + +fft_srdif :: (Ix a, Integral a, RealFloat b) => Array a (Complex b) -- ^ x[n] + -> a -- ^ N + -> (Array a (Complex b) -> Array a (Complex b)) -- ^ FFT function + -> Array a (Complex b) -- ^ X[k] + +fft_srdif x n fft = listArray (0,n-1) $ c + where c2k = elems $ fft $ listArray (0,n2-1) x2k + c4k1 = elems $ fft $ listArray (0,n4-1) x4k1 + c4k3 = elems $ fft $ listArray (0,n4-1) x4k3 + c = interleave c2k $ interleave c4k1 c4k3 + x2k = [ x!i + x!(i+n2) | i <- [0..n2-1] ] + x4k1 = [ (x!i - x!(i+n2) - j * (x!(i+n4) - x!(i+n34))) * w!i | i <- [0..n4-1] ] + x4k3 = [ (x!i - x!(i+n2) + j * (x!(i+n4) - x!(i+n34))) * w!(3*i) | i <- [0..n4-1] ] + j = 0 :+ 1 + wn = cis (-2 * pi / fromIntegral n) + w = listArray (0,n-1) $ iterate (* wn) 1 + interleave [] [] = [] + interleave (e:es) (o:os) = e : o : interleave es os + n2 = n `div` 2 + n4 = n `div` 4 + n34 = 3 * n4 diff --git a/Numeric/Transform/Fourier/SlidingFFT.hs b/Numeric/Transform/Fourier/SlidingFFT.hs new file mode 100644 --- /dev/null +++ b/Numeric/Transform/Fourier/SlidingFFT.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.Transform.Fourier.SlidingFFT +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Sliding FFT Algorithm +-- +----------------------------------------------------------------------------- + +module Numeric.Transform.Fourier.SlidingFFT (sfft) where + +import Data.Array +import Data.Complex + +import Numeric.Transform.Fourier.FFT + +-- Sliding FFT algorithm. We assume that the head of the list is the +-- oldest sample, and the last element is the newest sample. This is why +-- we need the reverse. By doing this we can abstract things like A/D +-- converters as infinite lists. + +-- The only published reference I have seen for this is the TI TMS320C3x +-- General-Purpose Applications (SPRU194). You can also check out +-- comp.dsp. The author, Keith Larson, hangs out there. + +-- The type of (!!) forces the type signatures to use Int instead of +-- (Integral a) + +{-# specialize sfft :: Int -> [Complex Float] -> [Array Int (Complex Float)] #-} +{-# specialize sfft :: Int -> [Complex Double] -> [Array Int (Complex Double)] #-} + +-- | Sliding FFT + +sfft :: RealFloat a => Int -- ^ N + -> [Complex a] -- ^ x[n] + -> [Array Int (Complex a)] -- ^ [X[k]] + +sfft n (x:xs) = x' : sfft' n x xs x' + where x' = fft $ listArray (0,n-1) $ reverse $ take n (x:xs) + +{-# specialize sfft' :: Int -> Complex Float -> [Complex Float] -> Array Int (Complex Float) -> [Array Int (Complex Float)] #-} +{-# specialize sfft' :: Int -> Complex Double -> [Complex Double] -> Array Int (Complex Double) -> [Array Int (Complex Double)] #-} + +sfft' :: RealFloat a => Int -> Complex a -> [Complex a] -> Array Int (Complex a) -> [Array Int (Complex a)] +sfft' n xn (x:xs) x' | enough n (x:xs) = x'' : sfft' n x xs x'' + | otherwise = [] + where x'' = listArray (0,n-1) [ x0 - xn + x'!i * w i | i <- [0..(n-1)] ] + x0 = xs !! (n-2) + w i = cis $ -2 * pi * fromIntegral i / fromIntegral n + +-- We can't use Prelude.length because we may be operating on infinite, +-- or ginormous lists. So enough will return True is there is enough +-- data to perform the next FFT update, or False if there is not enough. + +enough _ [] = False +enough 1 (x:_) = True +enough n (x:xs) = enough (n-1) xs diff --git a/Polynomial/Basic.hs b/Polynomial/Basic.hs new file mode 100644 --- /dev/null +++ b/Polynomial/Basic.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Polynomial.Basic +-- Copyright : (c) Matthew Donadio 2002 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple module for handling polynomials. +-- +----------------------------------------------------------------------------- + +-- TODO: We should really create a datatype for polynomials... + +-- TODO: Should polydiv return the quotient and the remainder as a tuple? + +module Polynomial.Basic where + +-- * Types + +-- | Polynomials are lists of numbers: +-- [ a0, a1, ... , an ] == an*x^n + ... + a1*x + a0 +-- and negative exponents are currently verboten. + +-- * Functions + +-- | Evaluate a polynomial using Horner's method. + +polyeval :: Num a => [a] -> a -> a +polyeval [] x = 0 +polyeval (p:ps) x = p + x * polyeval ps x + +-- | Add two polynomials + +polyadd :: Num a => [a] -> [a] -> [a] +polyadd [] [] = [] +polyadd [] ys = ys +polyadd xs [] = xs +polyadd (x:xs) (y:ys) = (x+y) : polyadd xs ys + +-- | Subtract two polynomials + +polysub :: Num a => [a] -> [a] -> [a] +polysub [] [] = [] +polysub [] ys = map negate ys +polysub xs [] = xs +polysub (x:xs) (y:ys) = (x-y) : polysub xs ys + +-- | Scale a polynomial + +polyscale :: Num a => a -> [a] -> [a] +polyscale a x = map (a*) x + +-- | Multiply two polynomials + +polymult :: Num a => [a] -> [a] -> [a] +polymult (x:[]) ys = map (x*) ys +polymult (x:xs) ys = polyadd (map (x*) ys) (polymult xs (0:ys)) + +-- | Divide two polynomials + +polydiv :: Fractional a => [a] -> [a] -> [a] +polydiv x y = reverse $ polydiv' (reverse x) (reverse y) + where polydiv' (x:xs) y | length (x:xs) < length y = [] + | otherwise = z : (polydiv' (tail (polysub (x:xs) (polymult [z] y))) y) + where z = x / head y + +-- | Modulus of two polynomials (remainder of division) + +polymod :: Fractional a => [a] -> [a] -> [a] +polymod x y = reverse $ polymod' (reverse x) (reverse y) + where polymod' (x:xs) y | length (x:xs) < length y = (x:xs) + | otherwise = polymod' (tail (polysub (x:xs) (polymult [z] y))) y + where z = x / head y + +-- | Raise a polynomial to a non-negative integer power + +polypow :: (Num a, Integral b) => [a] -> b -> [a] +polypow x 0 = [ 1 ] +polypow x 1 = x +polypow x 2 = polymult x x +polypow x n | even n = polymult x2 x2 + | odd n = polymult x (polymult x2 x2) + where x2 = polypow x (n `div` 2) + +-- | Polynomial substitution y(n) = x(w(n)) + +polysubst :: Num a => [a] -> [a] -> [a] +polysubst w x = foldr polyadd [0] (polysubst' 0 w x ) + where polysubst' _ _ [] = [] + polysubst' n w (x:xs) = map (x*) (polypow w n) : polysubst' (n+1) w xs + +-- | Polynomial derivative + +polyderiv :: Num a => [a] -> [a] +polyderiv (x:xs) = polyderiv' 1 xs + where polyderiv' _ [] = [] + polyderiv' n (x:xs) = n * x : polyderiv' (n+1) xs + +-- | Polynomial integration + +polyinteg :: Fractional a => [a] -> a -> [a] +polyinteg x c = c : polyinteg' 1 x + where polyinteg' _ [] = [] + polyinteg' n (x:xs) = x / n : polyinteg' (n+1) xs + +-- | Convert roots to a polynomial + +roots2poly :: Num a => [a] -> [a] +roots2poly (r:[]) = [-r, 1] +roots2poly (r:rs) = polymult [-r, 1] (roots2poly rs) diff --git a/Polynomial/Chebyshev.hs b/Polynomial/Chebyshev.hs new file mode 100644 --- /dev/null +++ b/Polynomial/Chebyshev.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Polynomial.Chebyshev +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple module for generating Chebyshev polynomials +-- +-- @T_0(x) = 1@ +-- +-- @T_1(x) = x@ +-- +-- @T_N+1(x) = 2x T_N(x) - T_N-1(x)@ +-- +----------------------------------------------------------------------------- + +module Polynomial.Chebyshev (cheby) where + +import Polynomial.Basic + +-- | generates Chebyshev polynomials + +{-# specialize cheby :: Int -> [Int] #-} +{-# specialize cheby :: Int -> [Double] #-} + +cheby :: (Integral a, Num b) => a -- ^ N + -> [b] -- ^ T_N(x) + +-- the cases for n=2.. aren't needed for the recursion, but I added +-- them anyway + +cheby 0 = [ 1 ] +cheby 1 = [ 0, 1 ] +cheby 2 = [ -1, 0, 2 ] +cheby 3 = [ 0, -3, 0, 4 ] +cheby 4 = [ 1, 0, -8, 0, 8 ] +cheby 5 = [ 0, 5, 0, -20, 0, 16] +cheby 6 = [ -1, 0, 18, 0, -48, 0, 32 ] +cheby n = polysub (polymult [ 0, 2 ] (cheby (n-1))) (cheby (n-2)) diff --git a/Polynomial/Maclaurin.hs b/Polynomial/Maclaurin.hs new file mode 100644 --- /dev/null +++ b/Polynomial/Maclaurin.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Polynomial.Maclaurin +-- Copyright : (c) Matthew Donadio 2003 +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Simple module for generating Maclaurin series representation of a few +-- functions: +-- +-- @f(x) = sum [ a_i * x^i | i \<- [0..] ]@ +-- +-- The @Int@ parameter for all functions is the /order/ of the polynomial, +-- eg: +-- +-- @[ a_i | i \<- [0..N] ]@ +-- +-- and not the number of non-zero terms +-- +----------------------------------------------------------------------------- + +module Polynomial.Maclaurin (polyexp, polyln1, + polycos, polysin, polyatan, + polycosh, polysinh, polyatanh) where + +import Polynomial.Basic + +-- A few utility lists + +ifacs :: [Double] +ifacs = map (1/) $ scanl (*) 1 [1..] + +inverses :: [Double] +inverses = map (1/) $ 1:[1..] + +-- Exponential and logarithm + +-- | e^x + +polyexp :: Int -> [Double] +polyexp n = take (n+1) ifacs + +-- | ln (1+x), 0 \<= x \<= 1 + +polyln1 :: Int -> [Double] +polyln1 n = 0 : (take n $ zipWith (*) i $ map (1/) [1..]) + where i = [ 1, -1 ] ++ i + +-- Trig functions + +-- | cos x + +polycos :: Int -> [Double] +polycos n = take (n+1) $ zipWith (*) i ifacs + where i = [ 1, 0, -1, 0 ] ++ i + +-- | sin x + +polysin :: Int -> [Double] +polysin n = take (n+1) $ zipWith (*) i ifacs + where i = [ 0, 1, 0, -1 ] ++ i + +-- | atan x, -1 \< x \< 1 + +polyatan :: Int -> [Double] +polyatan n = take (n+1) $ zipWith (*) i inverses + where i = [ 0, 1, 0, -1 ] ++ i + +-- Hyperbolic functions + +-- | cosh x + +polycosh :: Int -> [Double] +polycosh n = take (n+1) $ zipWith (*) i ifacs + where i = [ 1, 0 ] ++ i + +-- | sinh x + +polysinh :: Int -> [Double] +polysinh n = take (n+1) $ zipWith (*) i ifacs + where i = [ 0, 1 ] ++ i + +-- | atanh x + +polyatanh :: Int -> [Double] +polyatanh n = take (n+1) $ zipWith (*) i inverses + where i = [ 0, 1 ] ++ i diff --git a/Polynomial/Roots.hs b/Polynomial/Roots.hs new file mode 100644 --- /dev/null +++ b/Polynomial/Roots.hs @@ -0,0 +1,159 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Polynomial.Roots +-- Copyright : (c) 1998 Numeric Quest Inc., All rights reserved +-- License : GPL +-- +-- Maintainer : m.p.donadio@ieee.org +-- Stability : experimental +-- Portability : portable +-- +-- Root finder using Laguerre's method +-- +----------------------------------------------------------------------------- + +-- This file was sucked out of the Wayback Machine at www.archive.org. +-- This was orginally a HTML files containing literate Haskell. It has +-- been modified to use the Polynomial library, and Haddock style comments +-- have been added. As much as the original formatting has been retained +-- as possible. --mpd + +-- Original comments are below + +{- + Literate Haskell module Roots.lhs + + Jan Skibinski, + Numeric Quest Inc., Huntsville, Ontario, Canada + + 1998.09.05, last modified 1998.09.24 + + This module implements Laguerre's method for finding complex + roots of polynomials. According to [1], it is by far the most + straightforward of these sure-fire methods. It does require that you + perform complex arithmetic (even while converging to real roots), but + it is guaranteed to converge to a root from any starting point. In + some instances the complex arithmetic is no disadvantage, since the + polynomial itself may have complex coefficients. + + [1] Numerical Recipes in Pascal, W.H. Press, B.P. Flannery, + S.A. Teukolsky, W.T. Vetterling, Cambridge University Press, + ISBN 0-521-37516-9 + + See also some other variations of the same book by the same authors: + Numerical Recipes in C, Fortran, etc. I just happen to own [1], although + I have never programmed in Pascal. :-) + + Example + + To solve the equation + + x^2 - 3 x + 2 = 0 + + form the list of coefficients [2, -3, 1] (notice the reverse + order of coefficients) and execute + + roots 1.0e-6 300 [2,-3, 1] + -- where + -- 1.0e-6 is a required accuracy + -- 300 is a count of permitted iterations + -- (You set it to small number just in case you + -- do not trust the algorithm. But if you do, + -- then set it to something big, say 300) + + The answer is [2.0 :+ 0.0, 1.0 :+ 0.0]; that is, both roots are + real and equal to 2 and 1: + + x^2 - 3 x + 2 = (x - 2) (x - 1) = 0 +-} + +module Polynomial.Roots (roots) where + +import Data.Complex + +import Polynomial.Basic + +-- * Functions + +-- | Root finder using Laguerre's method + +roots :: RealFloat a => a -- ^ epsilon + -> Int -- ^ iteration limit + -> [Complex a] -- ^ the polynomial + -> [Complex a] -- ^ the roots +roots eps count as = + -- + -- List of complex roots of a polynomial + -- a0 + a1*x + a2*x^2... + -- represented by the list as=[a0,a1,a2...] + -- where + -- eps is a desired accuracy + -- count is a maximum count of iterations allowed + -- Require: list 'as' must have at least two elements + -- and the last element must not be zero + roots' eps count as [] + where + roots' eps count as xs + | length as <= 2 = x:xs + | otherwise = + roots' eps count (deflate x bs [last as]) (x:xs) + where + x = laguerre eps count as 0 + bs = drop 1 (reverse (drop 1 as)) + deflate z bs cs + | bs == [] = cs + | otherwise = + deflate z (tail bs) (((head bs)+z*(head cs)):cs) + + +laguerre :: RealFloat a => a -> Int -> [Complex a] -> Complex a -> Complex a +laguerre eps count as x + -- + -- One of the roots of the polynomial 'as', + -- where + -- eps is a desired accuracy + -- count is a maximum count of iterations allowed + -- x is initial guess of the root + -- This method is due to Laguerre. + -- + | count <= 0 = x + | magnitude (x - x') < eps = x' + | otherwise = laguerre eps (count - 1) as x' + where x' = laguerre2 eps as as' as'' x + as' = polyderiv as + as'' = polyderiv as' + laguerre2 eps as as' as'' x + -- One iteration step + | magnitude b < eps = x + | magnitude gp < magnitude gm = + if gm == 0 then x - 1 else x - n/gm + | otherwise = + if gp == 0 then x - 1 else x - n/gp + where gp = g + delta + gm = g - delta + g = d/b + delta = sqrt ((n-1)*(n*h - g2)) + h = g2 - f/b + b = polyeval as x + d = polyeval as' x + f = polyeval as'' x + g2 = g^2 + n = fromIntegral (length as) + +-- Original Copyright Notice + +----------------------------------------------------------------------------- +-- +-- Copyright: +-- +-- (C) 1998 Numeric Quest Inc., All rights reserved +-- +-- Email: +-- +-- jans@numeric-quest.com +-- +-- License: +-- +-- GNU General Public License, GPL +-- +----------------------------------------------------------------------------- diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/demo/Article.hs b/demo/Article.hs new file mode 100644 --- /dev/null +++ b/demo/Article.hs @@ -0,0 +1,32 @@ +-- This program was used to generate the data for +-- +-- Matthew Donadio, "Lost Knowledge Refound: Sharpened FIR Filters," +-- IEEE Signal Processing Magazine, to appear + +module Main where + +import Data.Array + +import DSP.Filter.FIR.FIR +import DSP.Filter.FIR.Sharpen +import DSP.Source.Basic + +import Numeric.Transform.Fourier.FFTUtils + +n :: Int +n = 1000 + +h :: Array Int Double +h = listArray (0,16) [ -0.016674, -0.022174, 0.015799, 0.047422, -0.013137, + -0.090271, 0.021409, 0.31668, 0.48352, 0.31668, + 0.021409, -0.090271, -0.013137, 0.047422, 0.015799, + -0.022174, -0.016674 ] + +y1 = fir h $ impulse +y2 = fir h $ fir h $ impulse +y3 = sharpen h $ impulse + +main = do + write_rfft_info "y1" $ listArray (0,999) $ y1 + write_rfft_info "y2" $ listArray (0,999) $ y2 + write_rfft_info "y3" $ listArray (0,999) $ y3 diff --git a/demo/FFTBench.hs b/demo/FFTBench.hs new file mode 100644 --- /dev/null +++ b/demo/FFTBench.hs @@ -0,0 +1,100 @@ +module Main where + +import Data.Array +import Data.Complex + +import Numeric.Transform.Fourier.FFT +import Numeric.Transform.Fourier.FFTHard +import Numeric.Transform.Fourier.R2DIF +import Numeric.Transform.Fourier.R2DIT +import Numeric.Transform.Fourier.R4DIF +import Numeric.Transform.Fourier.SRDIF +import Numeric.Transform.Fourier.CT +import Numeric.Transform.Fourier.PFA +import Numeric.Transform.Fourier.Rader +import Numeric.Transform.Fourier.DFT + +import Numeric.Random.Generator.MT19937 +import Numeric.Random.Distribution.Uniform + +len = 2048 :: Int +iter = 100 :: Int + +m1 x = x - 1 + +real = map m1 $ map (2*) $ uniform53cc $ genrand 42 +imag = map m1 $ map (2*) $ uniform53cc $ genrand 43 + +x = zipWith (:+) real imag + +gendata :: [Complex Double] -> Int -> [Array Int (Complex Double)] +gendata xs n = map (listArray (0,n-1)) $ gendata' xs n + where gendata' xs n = take n xs : gendata' (drop n xs) n + +calc f xs iter = magnitude $ sum $ map sum $ map elems $ map f $ take iter xs + +f1 xs | n == 2 = fft'2 xs + | n == 4 = fft'4 xs + | otherwise = fft_r2dit xs n f1 + where n = (snd $ bounds xs) + 1 + +f2 xs | n == 2 = fft'2 xs + | n == 4 = fft'4 xs + | otherwise = fft_r2dif xs n f2 + where n = (snd $ bounds xs) + 1 + +f3 xs | n == 2 = fft'2 xs + | n == 4 = fft'4 xs + | otherwise = fft_r4dif xs n f3 + where n = (snd $ bounds xs) + 1 + +f4 xs | n == 2 = fft'2 xs + | n == 4 = fft'4 xs + | otherwise = fft_srdif xs n f4 + where n = (snd $ bounds xs) + 1 + +choose1 :: Int -> Int +choose1 n = loop1 1 1 + where loop1 i f | i * i > n = f + | (n `mod` i) == 0 && gcd i (n `div` i) == 1 = loop1 (i+1) i + | otherwise = loop1 (i+1) f + +choose2 :: Int -> Int +choose2 n = loop2 1 1 + where loop2 i f | i * i > n = f + | n `mod` i == 0 = loop2 (i+1) i + | otherwise = loop2 (i+1) f + +choose_factor :: Int -> Int +choose_factor n | i > 1 = i + | otherwise = choose2 n + where i = choose1 n + +f5 xs | n == 2 = fft'2 xs + | n == 4 = fft'4 xs + | otherwise = fft_ct1 xs l m f5 + where n = (snd $ bounds xs) + 1 + l = choose_factor n + m = n `div` l + +f6 xs | n == 2 = fft'2 xs + | n == 4 = fft'4 xs + | otherwise = fft_ct2 xs l m f6 + where n = (snd $ bounds xs) + 1 + l = choose_factor n + m = n `div` l + +f7 xs = fft_rader1 xs n + where n = (snd $ bounds xs) + 1 + +f8 xs = fft_rader2 xs n fft + where n = (snd $ bounds xs) + 1 + +main = do + let xs = (gendata x len) + print $ calc f1 xs iter + print $ calc f2 xs iter + print $ calc f3 xs iter + print $ calc f4 xs iter + print $ calc f5 xs iter + print $ calc f6 xs iter diff --git a/demo/FFTTest.hs b/demo/FFTTest.hs new file mode 100644 --- /dev/null +++ b/demo/FFTTest.hs @@ -0,0 +1,97 @@ +-- $Id: FFTTest.hs,v 1.2 2003/04/11 21:57:04 donadio Exp donadio $ + +-- Ergun's method for testing FFT routines + +-- borrowed from FFTW, orig reference is + +-- Funda Ergun, "Testing multivariate linear functions: Overcoming the +-- generator bottleneck, Proc. 27th ACM Symposium on the Theory of +-- Computing, 407-416 (1995). + +module Main where + +import System.Environment +import Data.Array +import Data.Complex + +import Numeric.Random.Generator.MT19937 +import Numeric.Random.Distribution.Uniform + +import Numeric.Transform.Fourier.FFT + +-- Generates random test vectors + +gendata :: Int -> W -> Array Int (Complex Double) +gendata n s = listArray (0,n-1) $ zipWith (:+) (uniform53cc $ genrand s) (uniform53cc $ genrand (s+1)) + +-- A few functions over arrays + +aadd x y = listArray (0,n) [ x!i + y!i | i <- [0..n] ] + where n = snd $ bounds x + +asub x y = listArray (0,n) [ x!i - y!i | i <- [0..n] ] + where n = snd $ bounds x + +arot x = listArray (0,n) $ xs' ++ [x'] + where xs' = tail $ elems x + x' = head $ elems x + n = snd $ bounds x + +ascale a x = fmap (a*) x + +-- linearity test: aFFT(x) + bFFT(y) == FFT(ax+by) + +lin_test n = acomp z1 z2 + where x = gendata n 42 + y = gendata n 44 + a = u !! 0 :+ u !! 1 + b = u !! 2 :+ u !! 3 + u = uniform53cc $ genrand 46 + x' = ascale a $ fft x + y' = ascale b $ fft y + z1 = aadd x' y' + z2 = fft $ aadd (ascale a x) (ascale b y) + +-- impulse response test: rect == FFT(x) + FFT(impulse - x) + +imp_test n = acomp a' (aadd b' c') + where zeros = 0 : zeros + a = listArray (0,n-1) $ (1 :+ 0) : zeros + b = gendata n 42 + c = asub a b + a' = listArray (0,n-1) $ replicate n (1 :+ 0) + b' = fft b + c' = fft c + +-- shift test: x[n-m] <-> W_N^km X[k] + +shift_test n = acomp a' c' + where a = gendata n 42 + b = arot a + a' = fft a + b' = fft b + c' = listArray (0,n-1) $ [ b'!i * cis (-2 * pi * fromIntegral i / fromIntegral n) | i <- [0..n-1] ] + +-- determines peak error (from FFTW) + +acomp x y = (maximum $ zipWith (/) a mag) + where a = zipWith calc_a (elems x) (elems y) + mag = zipWith calc_mag (elems x) (elems y) + calc_a (xr:+xi) (yr:+yi) = sqrt $ (xr - yr)^2 + (xi - yi)^2 + calc_mag (xr:+xi) (yr:+yi) = 0.5 * (sqrt (xr^2+xi^2) + sqrt (yr^2+yi^2)) + tol + tol = 1.0e-6 + + +--glue it all together + +test1fft :: Int -> IO () +test1fft n = do putStr $ show n ++ ":\t" + putStr $ if ok then "OK\n" else "ERROR\n" + where ok = lin_test n < tol && imp_test n < tol && shift_test n < tol + tol = 1.0e-6 + +testfft :: Int -> Int -> IO [()] +testfft n1 n2 = sequence $ map test1fft [n1..n2] + +main = do args <- getArgs + testfft (read $ args !! 0) (read $ args !! 1) diff --git a/demo/FreqDemo.hs b/demo/FreqDemo.hs new file mode 100644 --- /dev/null +++ b/demo/FreqDemo.hs @@ -0,0 +1,114 @@ +-- Copyright (c) 2003 Matthew P. Donadio (m.p.donadio@ieee.org) +-- +-- This program is free software; you can redistribute it and/or 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. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +module Main where + +import Data.Array +import Data.Complex + +import Numeric + +import Numeric.Random.Generator.MT19937 +import Numeric.Random.Distribution.Normal +import Numeric.Random.Distribution.Uniform + +import DSP.Source.Oscillator + +import Numeric.Transform.Fourier.FFT + +import DSP.Estimation.Frequency.Pisarenko +import DSP.Estimation.Frequency.PerMax +import DSP.Estimation.Frequency.FCI +import DSP.Estimation.Frequency.QuinnFernandes +import DSP.Estimation.Frequency.WLP + +-- Parameters + +rho :: Double +rho = 4.0 + +w :: Double +w = 0.12345 + +phi :: Double +phi = 0.23456 + +snr :: Double +snr = 10 + +n :: Int +n = 256 + +-- Vectors + +y :: Array Int Double +y = listArray (0,n-1) $ zipWith (+) noise $ map (rho *) $ nco w phi + where noise = normal_ar (0, sig2) $ uniform53oc $ genrand 42 + sig2 = (rho^2 / 2) / (10 ** (snr / 10)) + +z :: Array Int (Complex Double) +z = listArray (0,n-1) $ zipWith (+) noise $ map ((rho :+ 0) *) $ quadrature_nco w phi + where noise = zipWith (:+) (normal_ar (0, sig2) $ uniform53oc $ genrand 42) (normal_ar (0, sig2) $ uniform53oc $ genrand 43) + sig2 = (rho^2 / 2) / (10 ** (snr / 10)) + +-- The tests + +dfp z = [ ("Periodigram Maximizer\t\t\t", permax z k) ] + where k = round $ w / 2 / pi * fromIntegral n + +fci y = [ ("Quinn's First Estimator\t\t\t", quinn1 y' k / 2), + ("Quinn's Second Estimator\t\t", quinn2 y' k / 2), + ("Quinn's Third Estimator\t\t\t", quinn3 y' k / 2), + ("Jacobsen's Third Estimator\t\t", jacobsen y' k / 2), + ("MacLeod's Three Point Estimator\t\t", macleod3 y' k / 2), + ("MacLeod's Five Point Estimator\t\t", macleod5 y' k / 2), + ("Rife and Vincent's Estimator\t\t", rv y' k / 2) ] + where y' = rfft y + k = round $ w / 2 / pi * fromIntegral n + +scm y = [ ("Pisarenko's Method\t\t\t", pisarenko y) ] + +offline y = [ ("Quinn-Fernandes\t\t\t\t", qf y w') ] + where k = round $ w / 2 / pi * fromIntegral n + w' = 2 * pi * fromIntegral k / fromIntegral n + +fastblock z = [ ("Lank, Reed, and Pollon\t\t\t", lrp z), + ("Kay\t\t\t\t\t", kay z), + ("Lovell and Williamson\t\t\t", lw z) ] +-- ("Clarkson, Kootsookos, and Quinn\t\t", ckq z rho sig) ] +-- where sig = sqrt $ (rho^2 / 2) / (10 ** (snr / 10)) + +-- Glue it all together + +showone (s,w') = putStrLn $ s ++ ": w=" ++ (showFFloat (Just 6) w' $ " err=" ++ showFFloat (Just 6) (abs (w-w')) "") + +main = do + putStrLn "==> Parameters" + putStrLn $ "rho=\t" ++ show rho + putStrLn $ "w=\t" ++ show w + putStrLn $ "phi=\t" ++ show phi + putStrLn $ "snr=\t" ++ show snr + putStrLn $ "n=\t" ++ show n + putStrLn "==> Periodigram Techniques" + sequence $ map showone $ dfp z + putStrLn "==> Fourier Coefficient Interpolation Techniques" + sequence $ map showone $ fci y + putStrLn "==> Sample Covariance Methods" + sequence $ map showone $ scm y + putStrLn "==> Offline Filtering Techniques" + sequence $ map showone $ offline y + putStrLn "==> Fast Block Techniques" + sequence $ map showone $ fastblock z diff --git a/demo/IIRDemo.hs b/demo/IIRDemo.hs new file mode 100644 --- /dev/null +++ b/demo/IIRDemo.hs @@ -0,0 +1,42 @@ +-- Copyright (c) 2003 Matthew P. Donadio (m.p.donadio@ieee.org) +-- +-- This program is free software; you can redistribute it and/or 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. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +module Main where + +import Data.Array + +import DSP.Filter.IIR.IIR +import DSP.Filter.IIR.Design + +import Numeric.Transform.Fourier.FFTUtils + +import DSP.Source.Basic + +-- Examples from Oppenheim and Schafer + +ex7'3 = mkButterworth (0.2 * pi, 1 - 0.89125) (0.3 * pi, 0.17783) +ex7'8 = mkChebyshev1 (0.2 * pi, 1 - 0.89125) (0.3 * pi, 0.17783) + +ex7'5 = mkButterworth (0.4 * pi, 0.01) (0.6 * pi, 0.001) +ex7'6a = mkChebyshev1 (0.4 * pi, 0.01) (0.6 * pi, 0.001) +ex7'6b = mkChebyshev2 (0.4 * pi, 0.01) (0.6 * pi, 0.001) + +main = do + write_rfft_info "ex-7.3" $ listArray (0,999) $ iir_df1 ex7'3 $ impulse + write_rfft_info "ex-7.8" $ listArray (0,999) $ iir_df1 ex7'8 $ impulse + write_rfft_info "ex-7.5" $ listArray (0,999) $ iir_df1 ex7'5 $ impulse + write_rfft_info "ex-7.6a" $ listArray (0,999) $ iir_df1 ex7'6a $ impulse + write_rfft_info "ex-7.6b" $ listArray (0,999) $ iir_df1 ex7'6b $ impulse diff --git a/demo/NoiseDemo.hs b/demo/NoiseDemo.hs new file mode 100644 --- /dev/null +++ b/demo/NoiseDemo.hs @@ -0,0 +1,138 @@ +-- Simple demo that demonstrates colored Gaussian noise + +module Main (main) where + +-- Import the System functions that we need + +import System.Environment +import System.IO +import System.Exit + +-- We need support for complex numbers and arrays + +import Data.Complex +import Data.Array + +-- Import a portion of the Numeric.Random library + +import Numeric.Random.Generator.MT19937 +import Numeric.Random.Distribution.Uniform +import Numeric.Random.Distribution.Normal +import Numeric.Random.Spectrum.White +import Numeric.Random.Spectrum.Pink +import Numeric.Random.Spectrum.Purple +import Numeric.Random.Spectrum.Brown + +-- We do some simple FFT analysis + +import Numeric.Transform.Fourier.FFT + +-- Noise parameters + +mu :: Double +mu = 0 + +sigma :: Double +sigma = 1 + +-- u is our list of uniforms over (0,1] + +u :: [Double] +u = uniform53oc $ genrand 42 + +-- x is our list of normal random variables + +x :: [Double] +x = normal_ar (mu,sigma) u + +-- white: flat power spectrum + +white_gn :: [Double] +white_gn = white $ x + +-- pink: -3 dB/octave or -10 dB/decade + +pink_gn :: [Double] +pink_gn = kellet $ white_gn + +-- brown: -6 dB/octave or -20 dB/decade + +brown_gn :: [Double] +brown_gn = brown $ white_gn + +-- purple: +6 dB/octave or +20 dB/decade + +purple_gn :: [Double] +purple_gn = purple $ white_gn + +-- dbrfft caluclates the magnitude response of the input, and subtracts +-- out the power of the integration window + +dbrfft :: Array Int Double -> Array Int Double +dbrfft xs = fmap db $ rfft $ xs + where db (r:+i) = 10 * log10 (r*r+i*i) - 10 * log10 n + log10 = logBase 10 + n = fromIntegral $ snd (bounds xs) + 1 + +-- avg averages a list of arrays pointwise + +avg :: [Array Int Double] -> Array Int Double +avg xs = fmap (/ n) xs' + where xs' = foldl1 add xs + add as bs = listArray (bounds as) $ zipWith (+) (elems as) (elems bs) + n = fromIntegral $ length xs + +-- chunk creates n3 sublists from xs of n1 elemets, and overlapping +-- n2 points + +chunk :: Int -> Int -> Int -> [Double] -> [[Double]] +chunk n1 n2 n3 xs = take n1 xs : chunk n1 n2 n3 (drop (n1-n2) xs) + +-- avg calculates an averaged RFFT using a rectangular window +-- n1 is the length of each FFT +-- n2 is the overlap +-- n3 is the number of FFTs to average + +avgrfft :: Int -> Int -> Int -> [Double] -> Array Int Double +avgrfft n1 n2 n3 xs = avg $ take n3 $ map dbrfft $ map (listArray (0,n1-1)) $ chunk n1 n2 n3 xs + +-- simple function to write out an array to a file + +dump :: String -> Array Int Double -> IO () +dump filename xs = do h <- openFile filename WriteMode + sequence $ map (dump' h) $ assocs $ xs + hClose h + where dump' h (f,m) = do hPutStr h $ show f + hPutStr h $ " " + hPutStrLn h $ show m + +-- usage function + +usage :: IO a +usage = do self <- getProgName + putStrLn $ "usage: " ++ self ++ " n1 n2 n3" + putStrLn $ " where n1 = FFT length" + putStrLn $ " n2 = overlap" + putStrLn $ " n3 = number of FFTs to average" + exitFailure + +-- simple function to parse the command line + +parseargs :: IO (Int,Int,Int) +parseargs = do args <- getArgs + if length args == 3 + then do let n1 = read $ args !! 0 + n2 = read $ args !! 1 + n3 = read $ args !! 2 + return (n1,n2,n3) + else usage + +-- glue it all together + +main :: IO () +main = do (n1,n2,n3) <- parseargs + dump "white.out" $ avgrfft n1 n2 n3 $ white_gn + dump "pink.out" $ avgrfft n1 n2 n3 $ pink_gn + dump "brown.out" $ avgrfft n1 n2 n3 $ brown_gn + dump "purple.out" $ avgrfft n1 n2 n3 $ purple_gn + return () diff --git a/dsp.cabal b/dsp.cabal new file mode 100644 --- /dev/null +++ b/dsp.cabal @@ -0,0 +1,117 @@ +Name: dsp +Version: 0.1 +License: GPL +Copyright: Matt Donadio, 2003 +Author: Matt Donadio +Maintainer: Henning Thielemann +Stability: Experimental +Homepage: http://haskelldsp.sourceforge.net/ +Synopsis: Haskell Digital Signal Processing +Description: Digital Signal Processing, Fourier Transform, Linear Algebra, Interpolation +Category: Sound +Tested-With: GHC +Build-Depends: base +GHC-Options: -O2 +-- -Wall +Exposed-modules: + DSP.Basic + DSP.Convolution + DSP.Correlation + DSP.Covariance + DSP.Estimation.Frequency.FCI + DSP.Estimation.Frequency.PerMax + DSP.Estimation.Frequency.Pisarenko + DSP.Estimation.Frequency.QuinnFernandes + DSP.Estimation.Frequency.WLP + DSP.Estimation.Spectral.AR + DSP.Estimation.Spectral.ARMA + DSP.Estimation.Spectral.KayData + DSP.Estimation.Spectral.MA + DSP.FastConvolution + DSP.Filter.Analog.Prototype + DSP.Filter.Analog.Response + DSP.Filter.Analog.Transform + DSP.Filter.FIR.FIR + DSP.Filter.FIR.Kaiser + DSP.Filter.FIR.PolyInterp + DSP.Filter.FIR.Sharpen + DSP.Filter.FIR.Smooth + DSP.Filter.FIR.Taps + DSP.Filter.FIR.Window + DSP.Filter.IIR.Bilinear + DSP.Filter.IIR.Design + DSP.Filter.IIR.IIR + DSP.Filter.IIR.Matchedz + DSP.Filter.IIR.Prony + DSP.Filter.IIR.Transform + DSP.Flowgraph + DSP.Multirate.CIC + DSP.Multirate.Halfband + DSP.Multirate.Polyphase + DSP.Source.Basic + DSP.Source.Oscillator + DSP.Unwrap + Matrix.Cholesky + Matrix.LU + Matrix.Levinson + Matrix.Matrix + Matrix.Simplex + Numeric.Approximation.Chebyshev + Numeric.Random.Distribution.Binomial + Numeric.Random.Distribution.Exponential + Numeric.Random.Distribution.Gamma + Numeric.Random.Distribution.Geometric + Numeric.Random.Distribution.Normal + Numeric.Random.Distribution.Poisson + Numeric.Random.Distribution.Uniform + Numeric.Random.Generator.MT19937 + Numeric.Random.Spectrum.Brown + Numeric.Random.Spectrum.Pink + Numeric.Random.Spectrum.Purple + Numeric.Random.Spectrum.White + Numeric.Special.Trigonometric + Numeric.Statistics.Covariance + Numeric.Statistics.Median + Numeric.Statistics.Moment + Numeric.Statistics.TTest + Numeric.Transform.Fourier.CT + Numeric.Transform.Fourier.DFT + Numeric.Transform.Fourier.FFT + Numeric.Transform.Fourier.FFTHard + Numeric.Transform.Fourier.FFTUtils + Numeric.Transform.Fourier.Goertzel + Numeric.Transform.Fourier.PFA + Numeric.Transform.Fourier.R2DIF + Numeric.Transform.Fourier.R2DIT + Numeric.Transform.Fourier.R4DIF + Numeric.Transform.Fourier.Rader + Numeric.Transform.Fourier.SRDIF + Numeric.Transform.Fourier.SlidingFFT + Polynomial.Basic + Polynomial.Chebyshev + Polynomial.Maclaurin + Polynomial.Roots + DSP.Filter.IIR.Cookbook +Data-Files: + Numeric/Special/Airy.gc + Numeric/Special/Erf.gc + Numeric/Special/Foo.gc + Numeric/Special/Clausen.gc + Numeric/Special/Bessel.gc + Numeric/Special/Elljac.gc + Numeric/Special/Ellint.gc + demo/Article.hs + demo/FFTBench.hs + demo/FFTTest.hs + demo/FreqDemo.hs + demo/IIRDemo.hs + demo/NoiseDemo.hs + Makefile + +-- Executable: +-- Article.hs +-- FFTBench.hs +-- FFTTest.hs +-- FreqDemo.hs +-- IIRDemo.hs +-- NoiseDemo.hs