module Sound.Hommage.Osc
(
osc
, sinus
, cosinus
, rect
, saw
, tri
, randomList
, sampleAndHold
, average
, terminateAt
, follow
, compress
, noteToFrequency
, adjustFrequency
, splitWaves
, crossfade
)
where
import Sound.Hommage.Misc
import System.Random
randomList :: Random a => (a,a) -> [a]
randomList = toList . return . randomRIO
osc :: [Double]
-> [Double]
-> [Double]
osc = loop 0.0
where
loop p [] _ = []
loop p vs (d:ds) = let v = interpol p vs
p' = p + abs d
i = floor p'
in v : loop (p' fromIntegral i) (drop (floor p') vs) ds
loop p _ _ = []
interpol p ds = if p == 0.0 then head ds else
case ds of
(d1 : d2 : r) -> d1 * (1.0 p) + d2 * p
[d1] -> d1 * (1.0 p)
integrate :: Num a => [a] -> [a]
integrate [] = []
integrate (x:xs) = loop x xs
where
loop v (a:as) = let k = v + a in seq k (v : loop k as)
loop v [] = [v]
sinus :: [Double] -> [Double]
sinus = map (sin . (*f)) . integrate
where
f = pi / 512.0
cosinus :: [Double] -> [Double]
cosinus = map (cos . (*f)) . integrate
where
f = pi / 512.0
rect :: [Double] -> [Double]
rect = map signum . sinus
saw :: [Double] -> [Double]
saw = loop 1.0
where
loop _ [] = []
loop v (d:dr) | v <= 1.0 = loop 1.0 (d:dr)
| otherwise = v : loop (v abs (d / 512.0)) dr
tri :: [Double] -> [Double]
tri = osc (let k = 0.0 : 1.0 : 0.0 : 1.0 : k in k) . map (/256.0)
adjustFrequency :: Double
-> Double
-> Double
-> Double
adjustFrequency periode basefreq = let k = periode * basefreq / 44100.0 in (*k)
noteToFrequency :: Double
-> Double
-> Double
noteToFrequency base note = 2.0 ** (note / base)
splitWaves :: [Double] -> [[Double]]
splitWaves = loop
where
next l (x:xs) | l <= 0.0 && x > 0.0 = ([], x:xs)
| otherwise = let (a,r) = next x xs in (x:a,r)
next l [] = ([],[])
loop (x:xs) = let (a,r) = next x xs in ((x:a) : loop r)
loop [] = []
crossfade :: [Double]
-> [Double]
-> [Double]
crossfade xs1 xs2 = fun
where
l1 = length xs1
l2 = length xs2
fun | l1 < l2 = let (i,r) = splitAt l1 xs2
d = 1.0 / fromIntegral l1
in (zipWith3 (\v x y -> (1.0v)*x + v*y) (iterate (+d) 0.0) xs1 i) ++ r
| l1 > l2 = let (i,r) = splitAt (l1l2) xs1
d = 1.0 / fromIntegral l2
in i ++ (zipWith3 (\v x y -> (1.0v)*x + v*y) (iterate (+d) 0.0) r xs2)
| otherwise = let d = 1.0 / fromIntegral l1
in (zipWith3 (\v x y -> (1.0v)*x + v*y) (iterate (+d) 0.0) xs1 xs2)
compress :: Double -> Double -> Double
compress 0.0 x = signum x
compress p x = x / (abs p + abs x)
sampleAndHold :: (Ord a, Num a) => b -> [a] -> [b] -> [b]
sampleAndHold y xs ys = loop y 0 xs ys
where
loop s o (a:as) (b:bs) | o <= 0 && a > 0 = b : loop b a as bs
| otherwise = s : loop s a as bs
loop _ _ _ _ = []
follow :: Double -> [Double] -> [Double] -> [Double]
follow p = loop 0.0
where
loop pos (f:fs) (x:xs) | pos > x = pos : loop (pos p * abs f) fs xs
| otherwise = pos : loop (pos + p * abs f) fs xs
loop _ _ _ = []
average :: Fractional a => Int -> [a] -> [a]
average n as = loop 0 as (replicate n 0 ++ as)
where
dy = 1.0 / fromIntegral n
loop i (x:xs) (y:ys) = (i * dy) : loop (i+xy) xs ys
loop _ _ _ = []
varydelay :: Int -> [Int] -> [a] -> [a]
varydelay len (l:ls) (d:ds) | len > l = d : varydelay (len 1) ls (tail ds)
| len < l = d : d : varydelay (len + 1) ls ds
| otherwise = d : varydelay len ls ds
varydelay _ _ _ = []
variableDelay :: Int -> [Double] -> [Double] -> [Double]
variableDelay initLen pitch inp = outp
where
len0 = fromIntegral initLen
lengths = map (floor.(len0/). max 0.001 . abs) pitch
outp = varydelay initLen lengths (replicate initLen 0.0 ++ inp)
terminateAt :: Int -> (a -> Bool) -> [a] -> [a]
terminateAt n test = loop n
where
loop 0 (x:xs) = if test x then [] else x : loop n xs
loop k (x:xs) = if test x then x : loop (k1) xs else x : loop n xs