packages feed

dsp (empty) → 0.1

raw patch · 94 files changed

+9429/−0 lines, 94 filesdep +basebuild-type:Customsetup-changed

Dependencies added: base

Files

+ DSP/Basic.hs view
@@ -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
+ DSP/Convolution.hs view
@@ -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 ]
+ DSP/Correlation.hs view
@@ -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) ]
+ DSP/Covariance.hs view
@@ -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
+ DSP/Estimation/Frequency/FCI.hs view
@@ -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
+ DSP/Estimation/Frequency/PerMax.hs view
@@ -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
+ DSP/Estimation/Frequency/Pisarenko.hs view
@@ -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
+ DSP/Estimation/Frequency/QuinnFernandes.hs view
@@ -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
+ DSP/Estimation/Frequency/WLP.hs view
@@ -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
+ DSP/Estimation/Spectral/AR.hs view
@@ -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+-------------------------------------------------------------------------------+
+ DSP/Estimation/Spectral/ARMA.hs view
@@ -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)
+ DSP/Estimation/Spectral/KayData.hs view
@@ -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) ]
+ DSP/Estimation/Spectral/MA.hs view
@@ -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
+ DSP/FastConvolution.hs view
@@ -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'
+ DSP/Filter/Analog/Prototype.hs view
@@ -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
+ DSP/Filter/Analog/Response.hs view
@@ -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
+ DSP/Filter/Analog/Transform.hs view
@@ -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
+ DSP/Filter/FIR/FIR.hs view
@@ -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' ]
+ DSP/Filter/FIR/Kaiser.hs view
@@ -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)
+ DSP/Filter/FIR/PolyInterp.hs view
@@ -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 ]++-------------------}
+ DSP/Filter/FIR/Sharpen.hs view
@@ -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
+ DSP/Filter/FIR/Smooth.hs view
@@ -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 ]
+ DSP/Filter/FIR/Taps.hs view
@@ -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)
+ DSP/Filter/FIR/Window.hs view
@@ -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
+ DSP/Filter/IIR/Bilinear.hs view
@@ -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++-}
+ DSP/Filter/IIR/Cookbook.lhs view
@@ -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  <robert@wavemechanics.com>+> --+> -- <http://www.harmony-central.com/Computer/Programming/Audio-EQ-Cookbook.txt>+> --+> -----------------------------------------------------------------------------+++> module DSP.Filter.IIR.Cookbook where++> import DSP.Filter.IIR.IIR++          Cookbook formulae for audio EQ biquad filter coefficients+-----------------------------------------------------------------------------+            by Robert Bristow-Johnson  <robert@wavemechanics.com>++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.)
+ DSP/Filter/IIR/Design.hs view
@@ -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')
+ DSP/Filter/IIR/IIR.hs view
@@ -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
+ DSP/Filter/IIR/Matchedz.hs view
@@ -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'
+ DSP/Filter/IIR/Prony.hs view
@@ -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<p cases because these generate zero elements in+-- G3, and this is the easiest way to take care of that.++-- mg1 = array ((1,1),(q+1,p+1)) [ ((i,j), gi (i-j)) | j <- [1..p+1], i <- [1..q+1] ]+-- mg2 = array ((1,1),(k-q,p+1)) [ ((i,j), gi (q+i-j+1)) | j <- [1..p+1], i <- [1..k-q] ]++-- | Implementation of Prony's method++prony :: Int -- ^ p+      -> 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] ]
+ DSP/Filter/IIR/Transform.hs view
@@ -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 ]++-}
+ DSP/Flowgraph.hs view
@@ -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 (+)
+ DSP/Multirate/CIC.hs view
@@ -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
+ DSP/Multirate/Halfband.hs view
@@ -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
+ DSP/Multirate/Polyphase.hs view
@@ -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 ]++-}
+ DSP/Source/Basic.hs view
@@ -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)
+ DSP/Source/Oscillator.hs view
@@ -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)
+ DSP/Unwrap.hs view
@@ -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
+ Makefile view
@@ -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
+ Matrix/Cholesky.hs view
@@ -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
+ Matrix/LU.hs view
@@ -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''++-}
+ Matrix/Levinson.hs view
@@ -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))]
+ Matrix/Matrix.hs view
@@ -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))
+ Matrix/Simplex.hs view
@@ -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++-}
+ Numeric/Approximation/Chebyshev.hs view
@@ -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
+ Numeric/Random/Distribution/Binomial.hs view
@@ -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)++
+ Numeric/Random/Distribution/Exponential.hs view
@@ -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
+ Numeric/Random/Distribution/Gamma.hs view
@@ -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
+ Numeric/Random/Distribution/Geometric.hs view
@@ -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+
+ Numeric/Random/Distribution/Normal.hs view
@@ -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
+ Numeric/Random/Distribution/Poisson.hs view
@@ -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)
+ Numeric/Random/Distribution/Uniform.hs view
@@ -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
+ Numeric/Random/Generator/MT19937.hs view
@@ -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
+ Numeric/Random/Spectrum/Brown.hs view
@@ -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 (+)+
+ Numeric/Random/Spectrum/Pink.hs view
@@ -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+--+-- <http://www.firstpr.com.au/dsp/pink-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 =
+ Numeric/Random/Spectrum/Purple.hs view
@@ -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)
+ Numeric/Random/Spectrum/White.hs view
@@ -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
+ Numeric/Special/Airy.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_airy.h>++-------------------------------------------------------------------------------++%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)
+ Numeric/Special/Bessel.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_bessel.h>++-------------------------------------------------------------------------------++%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)
+ Numeric/Special/Clausen.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_clausen.h>++-------------------------------------------------------------------------------++%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)
+ Numeric/Special/Ellint.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_ellint.h>++-------------------------------------------------------------------------------++%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)
+ Numeric/Special/Elljac.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_elljac.h>++-------------------------------------------------------------------------------++%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
+ Numeric/Special/Erf.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_erf.h>++-------------------------------------------------------------------------------++%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)
+ Numeric/Special/Foo.gc view
@@ -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 <gsl/gsl_errno.h>+%#include <gsl/gsl_sf_foo.h>++-------------------------------------------------------------------------------++%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)
+ Numeric/Special/Trigonometric.hs view
@@ -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 #-}
+ Numeric/Statistics/Covariance.hs view
@@ -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
+ Numeric/Statistics/Median.hs view
@@ -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
+ Numeric/Statistics/Moment.hs view
@@ -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
+ Numeric/Statistics/TTest.hs view
@@ -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++
+ Numeric/Transform/Fourier/CT.hs view
@@ -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
+ Numeric/Transform/Fourier/DFT.hs view
@@ -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)
+ Numeric/Transform/Fourier/FFT.hs view
@@ -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
+ Numeric/Transform/Fourier/FFTHard.hs view
@@ -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++-------------------------------------------------------------------------------+
+ Numeric/Transform/Fourier/FFTUtils.hs view
@@ -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
+ Numeric/Transform/Fourier/Goertzel.hs view
@@ -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
+ Numeric/Transform/Fourier/PFA.hs view
@@ -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
+ Numeric/Transform/Fourier/R2DIF.hs view
@@ -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
+ Numeric/Transform/Fourier/R2DIT.hs view
@@ -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
+ Numeric/Transform/Fourier/R4DIF.hs view
@@ -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
+ Numeric/Transform/Fourier/Rader.hs view
@@ -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))
+ Numeric/Transform/Fourier/SRDIF.hs view
@@ -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
+ Numeric/Transform/Fourier/SlidingFFT.hs view
@@ -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
+ Polynomial/Basic.hs view
@@ -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)
+ Polynomial/Chebyshev.hs view
@@ -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))
+ Polynomial/Maclaurin.hs view
@@ -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
+ Polynomial/Roots.hs view
@@ -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 <i>Roots.lhs</i>++	Jan Skibinski, <a href="http://www.numeric-quest.com/news/">+	Numeric Quest Inc.</a>, Huntsville, Ontario, Canada++	1998.09.05, last modified 1998.09.24++	This module implements <i>Laguerre's</i> method for finding complex+	roots of polynomials. According to [1], it <i> 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. </i>++	[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+-- +-----------------------------------------------------------------------------
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ demo/Article.hs view
@@ -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
+ demo/FFTBench.hs view
@@ -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
+ demo/FFTTest.hs view
@@ -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)
+ demo/FreqDemo.hs view
@@ -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
+ demo/IIRDemo.hs view
@@ -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
+ demo/NoiseDemo.hs view
@@ -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 ()
+ dsp.cabal view
@@ -0,0 +1,117 @@+Name:             dsp+Version:          0.1+License:          GPL+Copyright:        Matt Donadio, 2003+Author:           Matt Donadio <m.p.donadio@ieee.org>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+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