module Sound.Hommage.Signal
(
Mono
, Stereo (..)
, leftStereo
, rightStereo
, stereoToMono
, monoToStereo
, balance
, Signal (..)
, readWavSignal
, openWavSignal
, writeWavMono
, writeWavStereo
, writeWavSignal
, writeTracks
, signalToMono
, signalToStereo
, eitherSignal
, liftSignal
, mergeSignal
, mergeSignals
, multSignal
, infiniteSignal
)
where
import Sound.Hommage.WavFile
import Sound.Hommage.Misc
import System.IO.Unsafe
import Data.List
type Mono = Double
data Stereo = !Double :><: !Double
deriving (Eq, Show)
leftStereo :: Stereo -> Mono
leftStereo (x :><: _) = x
rightStereo :: Stereo -> Mono
rightStereo (_ :><: x) = x
instance Num Stereo where
(l1:><:r1) + (l2:><:r2) = (l1+l2) :><: (r1+r2)
(l1:><:r1) (l2:><:r2) = (l1l2) :><: (r1r2)
(l1:><:r1) * (l2:><:r2) = (l1*l2) :><: (r1*r2)
negate (l:><:r) = negate l :><: negate r
abs (l:><:r) = abs l :><: abs r
signum (l:><:r) = signum l :><: signum r
fromInteger i = fromInteger i :><: fromInteger i
instance Fractional Stereo where
(l1:><:r1) / (l2:><:r2) = (l1/l2) :><: (r1/r2)
fromRational x = fromRational x :><: fromRational x
stereoToMono :: Stereo -> Mono
stereoToMono (x:><:y) = (x+y) / 2.0
monoToStereo :: Mono -> Stereo
monoToStereo x = x :><: x
balance :: Double -> Stereo -> Stereo
balance p (l :><: r) | p == 0.0 = l :><: r
| p > 0.0 = l :><: ((1.0 p) * r)
| p < 0.0 = ((1.0 + p) * l) :><: r
data Signal = Mono [Mono]
| Stereo [Stereo]
eitherSignal :: ([Mono] -> a) -> ([Stereo] -> a) -> Signal -> a
eitherSignal f g (Mono xs) = f xs
eitherSignal f g (Stereo xs) = g xs
liftSignal :: ([Mono] -> [Mono]) -> Signal -> Signal
liftSignal f (Mono xs) = Mono $ f xs
liftSignal f (Stereo xs) = Stereo $ zipWith (:><:)
(f $ map leftStereo xs) (f $ map rightStereo xs)
readWavSignal :: FilePath -> IO Signal
readWavSignal fp = readWavFile fp >>=
return . either
(Mono . map wavInt16ToDouble)
(Stereo . map (\(l,r) -> (wavInt16ToDouble l :><: wavInt16ToDouble r)))
openWavSignal :: FilePath -> Signal
openWavSignal fp = unsafePerformIO $ readWavSignal fp
writeWavMono :: FilePath -> [Mono] -> IO ()
writeWavMono fp = writeWavFileMono fp . map wavDoubleToInt16
writeWavStereo :: FilePath -> [Stereo] -> IO ()
writeWavStereo fp = writeWavFileStereo fp . map
(\(l :><: r) -> (wavDoubleToInt16 l, wavDoubleToInt16 r))
writeWavSignal :: FilePath -> Signal -> IO ()
writeWavSignal fp (Mono xs) = writeWavMono fp xs
writeWavSignal fp (Stereo xs) = writeWavStereo fp xs
writeTracks :: FilePath -> [Signal] -> IO ()
writeTracks fp s = writeWavFiles fp "" strs
where
strs = map foo s
foo (Mono xs) = Left $ map wavDoubleToInt16 xs
foo (Stereo xs) = Right $ map (\(l:><:r)->(wavDoubleToInt16 l, wavDoubleToInt16 r)) xs
signalToMono :: Signal -> [Mono]
signalToMono (Mono xs) = xs
signalToMono (Stereo xs) = map stereoToMono xs
signalToStereo :: Signal -> [Stereo]
signalToStereo (Mono xs) = map monoToStereo xs
signalToStereo (Stereo xs) = xs
mergeSignals :: [Signal] -> Signal
mergeSignals ss = fun
where
loop (Mono x : xs) = let (l,r) = loop xs in (x:l,r)
loop (Stereo x : xs) = let (l,r) = loop xs in (l,x:r)
loop [] = ([],[])
fun = case loop ss of
([],[]) -> Mono []
(ls,[]) -> Mono $ map sum $ transpose ls
([],rs) -> Stereo $ map sum $ transpose rs
(ls,rs) -> Stereo $ map sum $ transpose (map (monoToStereo . sum) (transpose ls) : rs)
mergeSignal :: Signal -> Signal -> Signal
mergeSignal (Stereo xs) (Stereo ys) = Stereo $ merge (+) xs ys
mergeSignal (Stereo xs) (Mono ys) = Stereo $ merge (+) xs (map monoToStereo ys)
mergeSignal (Mono xs) (Stereo ys) = Stereo $ merge (+) (map monoToStereo xs) ys
mergeSignal (Mono xs) (Mono ys) = Mono $ merge (+) xs ys
infiniteSignal :: Double -> Signal -> Signal
infiniteSignal d (Mono a) = Mono (map (+d) a ++ repeat d)
infiniteSignal d (Stereo a) = Stereo (map (+(d:><:d)) a ++ repeat (d:><:d))
multSignal :: Signal -> Signal -> Signal
multSignal (Mono a) (Mono b) = Mono $ zipWith (*) a b
multSignal (Mono a) (Stereo b) = Stereo $ zipWith (\x y -> monoToStereo x * y) a b
multSignal (Stereo a) (Stereo b) = Stereo $ zipWith (*) a b
multSignal (Stereo a) (Mono b) = Stereo $ zipWith (\x y -> x * monoToStereo y) a b