diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +## 0.1.0.0 + +Initial version. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2020, Marek Materzok +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/main.hs b/benchmarks/main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/main.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeApplications #-} + +import Gauge.Main +import qualified Data.Vector.Storable as V +import Data.Functor.Identity (runIdentity) +import Data.MonadicStreamFunction +import Data.MonadicStreamFunction.InternalCore(unMSF) +import Vocoder.Dunai + +reactimateN :: Monad m => Int -> MSF m () a -> m a +reactimateN 0 msf = fst <$> unMSF msf () +reactimateN n msf = unMSF msf () >>= reactimateN (n-1) . snd + +benchFramesOfS :: Int -> Int -> Int -> Int -> Benchmarkable +benchFramesOfS inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size -> + runIdentity $ reactimateN size + $ count + >>> arr (V.replicate @Int inputChunkSize) + >>> framesOfS chunkSize hopSize + >>> arr (sum . fmap V.sum) + >>> accumulateWith (+) 0 + +benchSumFramesS :: Int -> Int -> Int -> Int -> Benchmarkable +benchSumFramesS inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size -> + runIdentity $ reactimateN (size `div` k) + $ count + >>> arr (replicate k . V.replicate @Int inputChunkSize) + >>> sumFramesS chunkSize hopSize + >>> arr V.sum + >>> accumulateWith (+) 0 + where k = chunkSize `div` hopSize + +main :: IO () +main = defaultMain + [ bench "framesOfS" $ benchFramesOfS 128 512 32 size0 + , bench "sumFramesS" $ benchSumFramesS 512 128 32 size0 + ] + where + size0 = 1000 :: Int + diff --git a/example/MVarClock.hs b/example/MVarClock.hs new file mode 100644 --- /dev/null +++ b/example/MVarClock.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module MVarClock where + +import Data.Time.Clock +import Control.Concurrent.MVar +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import FRP.Rhine + +type EventMVarT event m = ReaderT (MVar event) m + +withEventMVar :: MVar event -> EventMVarT event m a -> m a +withEventMVar = flip runReaderT + +withEventMVarS :: Monad m => MVar event -> ClSF (EventMVarT event m) cl a b -> ClSF m cl a b +withEventMVarS = flip runReaderS_ + +data MVarClock event = MVarClock + +instance Semigroup (MVarClock event) where + (<>) _ _ = MVarClock + +instance MonadIO m => Clock (EventMVarT event m) (MVarClock event) where + type Time (MVarClock event) = UTCTime + type Tag (MVarClock event) = event + initClock _ = do + initialTime <- liftIO getCurrentTime + return + ( constM $ do + mvar <- ask + event <- liftIO $ takeMVar mvar + time <- liftIO $ getCurrentTime + return (time, event) + , initialTime + ) + +instance GetClockProxy (MVarClock event) + +mVarClockOn :: MonadIO m => MVar event -> HoistClock (EventMVarT event m) m (MVarClock event) +mVarClockOn mvar = HoistClock + { unhoistedClock = MVarClock + , monadMorphism = withEventMVar mvar + } + diff --git a/example/ProcessingTree.hs b/example/ProcessingTree.hs new file mode 100644 --- /dev/null +++ b/example/ProcessingTree.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ProcessingTree where + +import Control.Monad.Writer +import Control.Monad.Except +import FRP.Rhine +import Vocoder +import Vocoder.Filter + +type STFTMSF m = MSF m [[STFTFrame]] [STFTFrame] + +data ProcessingTree m = PTSource Int + | PTNamed String + | PTBind String (ProcessingTree m) + | PTMSF (MSF m [STFTFrame] [STFTFrame]) (ProcessingTree m) + | PTFilter (Filter m) (ProcessingTree m) + | PTBinary (STFTFrame -> STFTFrame -> STFTFrame) (ProcessingTree m) (ProcessingTree m) + +elaboratePT :: forall m. Monad m + => m FreqStep + -> ProcessingTree m + -> Maybe (STFTMSF m) +elaboratePT mfs t0 = either (const Nothing) Just r where + (r, e0) = runWriter $ runExceptT $ g e0 t0 + g :: [(String, STFTMSF m)] + -> ProcessingTree m + -> ExceptT () (Writer [(String, STFTMSF m)]) (STFTMSF m) + g _ (PTSource k) = return $ arr (!! k) + g e (PTNamed n) | Just v <- lookup n e = return v + | otherwise = throwError () + g e (PTBind n t) = g e t >>= (\v -> tell [(n, v)] >> return v) + g e (PTMSF f t) = (>>> f) <$> g e t + g e (PTFilter f t) = (>>> arrM (\x -> mfs >>= forM x . f)) <$> g e t + g e (PTBinary f t1 t2) = (\m1 m2 -> zipWith f <$> m1 <*> m2) <$> g e t1 <*> g e t2 + +numSourcesPT :: (ProcessingTree m) -> Int +numSourcesPT (PTSource k) = k+1 +numSourcesPT (PTNamed _) = 0 +numSourcesPT (PTBind _ t) = numSourcesPT t +numSourcesPT (PTMSF _ t) = numSourcesPT t +numSourcesPT (PTFilter _ t) = numSourcesPT t +numSourcesPT (PTBinary _ t1 t2) = numSourcesPT t1 `max` numSourcesPT t2 + diff --git a/example/VocoderJack.hs b/example/VocoderJack.hs new file mode 100644 --- /dev/null +++ b/example/VocoderJack.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE TypeFamilies, RankNTypes, PatternSynonyms, ViewPatterns #-} +module Main where + +import qualified Sound.JACK as JACK +import Sound.JACK.Exception +import qualified Sound.JACK.Audio as Audio +import qualified Data.Vector.Storable as V +import Data.Array.Storable as A +import Data.List.Split +import Text.Read hiding (lift) +import Control.Monad.Trans.Class(lift) +import Control.Monad.Trans.Reader(ReaderT(..)) +import Control.Monad.Exception.Synchronous(ExceptionalT) +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad +import Control.Arrow +import Options.Applicative +import Vocoder +import Vocoder.Filter +import Vocoder.Window +import Vocoder.Dunai +import FRP.Rhine +import MVarClock +import ProcessingTree + +type AudioV = V.Vector Audio.Sample + +type EventIO = EventMVarT [AudioV] IO + +type MyClock = HoistClock EventIO IO (MVarClock [AudioV]) + +type MyMonad = ReaderT (TimeInfo MyClock) IO + +data WindowType = BoxWindow | HammingWindow | HannWindow | BlackmanWindow | FlatTopWindow deriving (Read, Show) + +data Cmd = SourceCmd Int | MSFCmd (MSF MyMonad [STFTFrame] [STFTFrame]) | FilterCmd (Filter MyMonad) | NamedCmd String | BindCmd String | BinaryCmd (STFTFrame -> STFTFrame -> STFTFrame) + +data Options = Options { + optClientName :: String, + optMaybeFrameSize :: Maybe Length, + optWindowSize :: Length, + optHopSize :: HopSize, + optWindowType :: WindowType, + optProcessingTree :: ProcessingTree MyMonad +} + +optFrameSize :: Options -> Length +optFrameSize opts = maybe (optWindowSize opts) id $ optMaybeFrameSize opts + +optWindow :: Options -> Window +optWindow opts = windowFun (optWindowType opts) (optWindowSize opts) + +optSources :: Options -> Int +optSources opts = numSourcesPT $ optProcessingTree opts + +windowFun :: WindowType -> Length -> Window +windowFun BoxWindow = boxWindow +windowFun HammingWindow = hammingWindow +windowFun HannWindow = hannWindow +windowFun BlackmanWindow = blackmanWindow +windowFun FlatTopWindow = flatTopWindow + +paramsFor :: Options -> VocoderParams +paramsFor opts = vocoderParams (optFrameSize opts) (optHopSize opts) (optWindow opts) + +auto2 :: (Read a, Read b) => ReadM (a, b) +auto2 = maybeReader $ f . splitOn "," + where + f [a,b] = (,) <$> readMaybe a <*> readMaybe b + f _ = Nothing + +auto3 :: (Read a, Read b, Read c) => ReadM (a, b, c) +auto3 = maybeReader $ f . splitOn "," + where + f [a,b,c] = (,,) <$> readMaybe a <*> readMaybe b <*> readMaybe c + f _ = Nothing + +uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) +uncurry3 f (a,b,c) = f a b c + +processingP :: Parser (ProcessingTree MyMonad) +processingP = parseCommands <$> many commandP + +ptht :: [ProcessingTree MyMonad] -> [ProcessingTree MyMonad] +ptht (h:t) = h:t +ptht [] = [PTSource 0] + +infixr :? + +pattern (:?) :: ProcessingTree MyMonad + -> [ProcessingTree MyMonad] + -> [ProcessingTree MyMonad] +pattern h :? t <- (ptht -> h:t) + +parseCommands :: [Cmd] -> ProcessingTree MyMonad +parseCommands cmds = p [] cmds + where + p (h :? _) [] = h + p s (SourceCmd k : t) = p (PTSource k : s) t + p s (NamedCmd n : t) = p (PTNamed n : s) t + p (h :? s) (MSFCmd f : t) = p (PTMSF f h : s) t + p (h :? s) (FilterCmd f : t) = p (PTFilter f h : s) t + p (h :? i :? s) (BinaryCmd f : t) = p (PTBinary f i h : s) t + p (h :? s) (BindCmd n : t) = p (PTBind n h : s) t + +mkBinary :: (Double -> Double -> Double) + -> (Double -> Double -> Double) + -> STFTFrame -> STFTFrame -> STFTFrame +mkBinary op1 op2 (mag1, ph_inc1) (mag2, ph_inc2) = (V.zipWith op1 mag1 mag2, V.zipWith op2 ph_inc1 ph_inc2) + +commandP :: Parser Cmd +commandP = FilterCmd <$> filterP + <|> MSFCmd <$> msfP + <|> (SourceCmd <$> option auto + ( long "source" + <> metavar "NUM" + <> help "Source from JACK input")) + <|> (NamedCmd <$> option auto + ( long "named" + <> metavar "NAME" + <> help "Source from named stream")) + <|> (BindCmd <$> option auto + ( long "bind" + <> metavar "NAME" + <> help "Bind stream to name")) + <|> (flag' (BinaryCmd $ mkBinary (*) (+)) + ( long "multiply" + <> help "Multiply two streams")) + <|> (flag' (BinaryCmd $ mkBinary (/) (-)) + ( long "divide" + <> help "Divide two streams")) + <|> (flag' (BinaryCmd addFrames) + ( long "add" + <> help "Add two streams")) + +delayMSF :: Int -> MSF MyMonad [STFTFrame] [STFTFrame] +delayMSF k = mealy f [] + where + f i s = (take (length i) s', drop (length s' - k) s') where s' = s ++ i + +msfP :: Parser (MSF MyMonad [STFTFrame] [STFTFrame]) +msfP = (delayMSF <$> option auto + ( long "delay" + <> metavar "HOPS" + <> help "Delay the signal by some number of STFT hops")) + +filterP :: Parser (Filter MyMonad) +filterP = (lowpassBrickwall <$> option auto + ( long "lowpassBrickwall" + <> metavar "FREQ" + <> help "Low-pass brickwall filter")) + <|> (highpassBrickwall <$> option auto + ( long "highpassBrickwall" + <> metavar "FREQ" + <> help "High-pass brickwall filter")) + <|> (uncurry bandpassBrickwall <$> option auto2 + ( long "bandpassBrickwall" + <> metavar "FREQ,FREQ" + <> help "Band-pass brickwall filter")) + <|> (uncurry bandstopBrickwall <$> option auto2 + ( long "bandstopBrickwall" + <> metavar "FREQ,FREQ" + <> help "Band-stop brickwall filter")) + <|> (uncurry lowpassButterworth <$> option auto2 + ( long "lowpassButterworth" + <> metavar "DEG,FREQ" + <> help "Low-pass Butterworth-style filter")) + <|> (uncurry highpassButterworth <$> option auto2 + ( long "highpassButterworth" + <> metavar "DEG,FREQ" + <> help "High-pass Butterworth-style filter")) + <|> (uncurry3 bandpassButterworth <$> option auto3 + ( long "bandpassButterworth" + <> metavar "DEG,FREQ,FREQ" + <> help "Band-pass Butterworth-style filter")) + <|> (uncurry3 bandstopButterworth <$> option auto3 + ( long "bandstopButterworth" + <> metavar "DEG,FREQ,FREQ" + <> help "Band-stop Butterworth-style filter")) + <|> (amplify <$> option auto + ( long "amplify" + <> metavar "COEFF" + <> help "Change amplitude")) + <|> (pitchShiftInterpolate <$> option auto + ( long "pitchShiftInterpolate" + <> metavar "COEFF" + <> help "Interpolative pitch-shift")) + <|> (envelopeFilter <$> option auto + ( long "envelope" + <> metavar "KSIZE" + <> help "Calculate spectral envelope")) + <|> (flag' (randomPhaseFilter) + ( long "randomPhase" + <> help "Randomize phases (Paulstretch effect)")) + +options :: Parser Options +options = Options + <$> option auto + ( long "clientName" + <> metavar "NAME" + <> value "vocoder-jack" + <> help "JACK client name") + <*> optional (option auto + ( long "frameSize" + <> metavar "SIZE" + <> help "Size of zero-padded FFT frame, must be >= windowSize")) + <*> option auto + ( long "windowSize" + <> metavar "SIZE" + <> value 1024 + <> showDefault + <> help "Size of STFT window, must be divisible by hopSize") + <*> option auto + ( long "hopSize" + <> metavar "SIZE" + <> value 128 + <> showDefault + <> help "STFT hop size, must be a power of 2") + <*> option auto + ( long "windowType" + <> metavar "TYPE" + <> value BlackmanWindow + <> showDefault + <> help "Type of STFT window") + <*> processingP + +runFilter :: JACK.Client -> Options -> ClSF IO MyClock [[STFTFrame]] [STFTFrame] +runFilter client opts = ret + where + freqStep = do + rate <- liftIO $ JACK.getSampleRate client + return $ fromIntegral rate / fromIntegral (optFrameSize opts) + (Just ret) = elaboratePT freqStep (optProcessingTree opts) + +processing :: JACK.Client -> Options -> MVar AudioV -> ClSF IO MyClock () () +processing client opts omvar = + tagS + >>> arr (map $ V.map realToFrac) + >>> ((analysisSrcs srcs >>> runFilter client opts >>> synthesis par (zeroPhase par)) &&& arr (V.length . head)) + >>> sumFramesWithLengthS (vocHopSize par) >>> volumeFix par + >>> arr (V.map realToFrac) + >>> arrMCl (liftIO . fmap (const ()) . tryPutMVar omvar) + where + par = paramsFor opts + srcs = optSources opts + analysisSrcs 0 = pure [] + analysisSrcs k = (:) <$> (arr (!! (srcs-k)) >>> framesOfS (vocInputFrameLength par) (vocHopSize par) >>> analysis par (zeroPhase par)) <*> analysisSrcs (k-1) + +main :: IO () +main = execParser opts >>= run + where + opts = info (options <**> helper) + ( fullDesc + <> progDesc "Process JACK stream" + <> header "Phase vocoder audio processing") + +withInputPorts :: (ThrowsPortRegister e, ThrowsErrno e) + => JACK.Client + -> Options + -> ([Audio.Port JACK.Input] -> ExceptionalT e IO a) + -> ExceptionalT e IO a +withInputPorts client opts cont = f (optSources opts) [] where + f 0 l = cont l + f k l = JACK.withPort client ("input" ++ show k) $ \iport -> f (k-1) (iport:l) + +run :: Options -> IO () +run opts = do + imvar <- newEmptyMVar + omvar <- newEmptyMVar + JACK.handleExceptions $ + JACK.withClientDefault (optClientName opts) $ \client -> + withInputPorts client opts $ \iports -> + JACK.withPort client "output" $ \oport -> + JACK.withProcess client (lift . processJack imvar omvar iports oport) $ + JACK.withActivation client $ do + _ <- lift $ forkIO $ flow $ processing client opts omvar @@ mVarClockOn imvar + lift $ JACK.waitForBreak + +processJack :: MVar [AudioV] -> MVar AudioV -> [Audio.Port JACK.Input] -> Audio.Port JACK.Output -> JACK.NFrames -> IO () +processJack imvar omvar iports oport nframes@(JACK.NFrames frames) = do + iArrs <- forM iports $ \iport -> Audio.getBufferArray iport nframes + oArr <- Audio.getBufferArray oport nframes + iVecs <- forM iArrs $ \iArr -> V.generateM (fromIntegral frames) $ \i -> fmap realToFrac $ A.readArray iArr $ JACK.NFrames $ fromIntegral i + _ <- tryPutMVar imvar iVecs + moVec <- tryTakeMVar omvar + case moVec of + Just oVec -> + forM_ (JACK.nframesIndices nframes) $ \ni@(JACK.NFrames i) -> + writeArray oArr ni $ realToFrac $ oVec V.! fromIntegral i + Nothing -> + forM_ (JACK.nframesIndices nframes) $ \ni -> + writeArray oArr ni 0 + diff --git a/src/Vocoder/Dunai.hs b/src/Vocoder/Dunai.hs new file mode 100644 --- /dev/null +++ b/src/Vocoder/Dunai.hs @@ -0,0 +1,86 @@ +{-| + Module : Vocoder.Dunai + Description : Phase vocoder in Dunai + Copyright : (c) Marek Materzok, 2021 + License : BSD2 + +This module wraps phase vocoder algorithms for use in Dunai and Rhine. +-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +module Vocoder.Dunai ( + volumeFix, + analysis, + synthesis, + processFrames, + process, + framesOfS, + sumFramesS, + sumFramesWithLengthS + ) where + +import Data.MonadicStreamFunction +import Data.Tuple(swap) +import Data.Maybe(fromMaybe) +import qualified Data.Vector.Storable as V +import Vocoder + +-- | Perform the phase vocoder analysis phase. +analysis :: (Traversable t, Monad m) => VocoderParams -> Phase -> MSF m (t Frame) (t STFTFrame) +analysis par = mealy $ \a s -> swap $ analysisStage par s a + +-- | Perform the phase vocoder synthesis phase. +synthesis :: (Traversable t, Monad m) => VocoderParams -> Phase -> MSF m (t STFTFrame) (t Frame) +synthesis par = mealy $ \a s -> swap $ synthesisStage par s a + +-- | Perform frequency domain processing on overlapping frames. +processFrames :: (Traversable t, Monad m) => VocoderParams -> MSF m (t STFTFrame) (t STFTFrame) -> MSF m (t Frame) (t Frame) +processFrames par msf = analysis par (zeroPhase par) >>> msf >>> synthesis par (zeroPhase par) + +-- | Corrects for volume change introduced by STFT processing. +volumeFix :: Monad m => VocoderParams -> MSF m Frame Frame +volumeFix par = arr $ V.map (* volumeCoeff par) + +-- | Perform frequency domain processing on a chunked stream. +-- The chunks' size must be a multiple of the vocoder's hop size. +process :: Monad m => VocoderParams -> MSF m [STFTFrame] [STFTFrame] -> MSF m Frame Frame +process par msf = (framesOfS (vocInputFrameLength par) (vocHopSize par) >>> processFrames par msf) &&& arr V.length + >>> sumFramesWithLengthS (vocHopSize par) >>> volumeFix par + +data P a = P {-# UNPACK #-} !Length {-# UNPACK #-} !(V.Vector a) + +mapP :: (Length -> Length) -> (V.Vector a1 -> V.Vector a2) -> P a1 -> P a2 +mapP f g (P n c) = P (f n) (g c) + +-- | Splits a chunked input stream into overlapping frames of constant size +-- suitable for STFT processing. +-- The input and output chunks' size must be a multiple of the vocoder's hop size. +framesOfS :: forall a m. (V.Storable a, Num a, Monad m) => Length -> HopSize -> MSF m (V.Vector a) [V.Vector a] +framesOfS chunkSize hopSize = mealy f $ V.replicate bufLen 0 + where + bufHops = (chunkSize-1) `div` hopSize + bufLen = bufHops * hopSize + f :: V.Vector a -> V.Vector a -> ([V.Vector a], V.Vector a) + f nextv q = (outs, q') + where + len = V.length nextv + newBuf = q V.++ nextv + q' = V.drop len newBuf + outs = [V.take chunkSize $ V.drop (k * hopSize) newBuf | k <- [0 .. len `div` hopSize - 1]] + +-- | Builds a chunked output stream from a stream of overlapping frames. +-- The input and output chunks's size must be a multiple of the vocoder's hop size. +sumFramesS :: forall a m. (V.Storable a, Num a, Monad m) => Length -> HopSize -> MSF m [V.Vector a] (V.Vector a) +sumFramesS chunkSize hopSize = arr (id &&& const chunkSize) >>> sumFramesWithLengthS hopSize + +sumFramesWithLengthS :: forall a m. (V.Storable a, Num a, Monad m) => HopSize -> MSF m ([V.Vector a], Length) (V.Vector a) +sumFramesWithLengthS hopSize = mealy f [] + where + f :: ([V.Vector a], Length) -> [P a] -> (V.Vector a, [P a]) + f (nexts, chunkSize) q = (nextv, q'') + where + ith i (P n c0) = fromMaybe 0 $ c0 V.!? (i - n) + q' = q ++ zipWith P [0, hopSize..] nexts + nextv = V.generate chunkSize $ \i -> sum $ fmap (ith i) q' + q'' = map (mapP (+ (-chunkSize)) id) $ dropWhile (\(P n c) -> V.length c + n <= chunkSize) q' + diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TypeApplications #-} + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Data.Functor.Identity (Identity, runIdentity) +import Data.MonadicStreamFunction +import qualified Data.Vector.Storable as V +import Vocoder.Dunai + +shrinkOne :: (a -> [a]) -> [a] -> [[a]] +shrinkOne _ [] = [] +shrinkOne shr (x:xs) = [ x':xs | x' <- shr x ] + ++ [ x:xs' | xs' <- shrinkOne shr xs ] + +runMSFList :: MSF Identity a b -> [a] -> [b] +runMSFList m l = runIdentity $ embed m l + +--equivToList :: Eq b => ([a] -> [b]) -> MSF Identity a b -> [a] -> Bool +--equivToList f c xs = f xs == runMSFList c xs + +equivToListA :: ([[Int]] -> [[Int]]) -> MSF Identity (V.Vector Int) [V.Vector Int] -> [[Int]] -> Bool +equivToListA f c xs = f xs == concat (map (map V.toList) . runMSFList c . map V.fromList $ xs) + +equivToListB :: ([[Int]] -> [[Int]]) -> MSF Identity [V.Vector Int] (V.Vector Int) -> [[[Int]]] -> Bool +equivToListB f c xs = f (concat xs) == (map V.toList . runMSFList c . map (map V.fromList) $ xs) + +listFramesOf :: Int -> Int -> [[Int]] -> [[Int]] +listFramesOf chunkSize hopSize input = + map (\i -> take chunkSize $ drop i cInput) [0, hopSize .. length cInput - chunkSize] + where + cInput = concat input + +listSumFrames :: Int -> Int -> [[Int]] -> [[Int]] +listSumFrames chunkSize hopSize input = map (\i -> take chunkSize $ drop i cOutput) [0, chunkSize .. lastLength] + where + cOutput = foldl1 (zipWith (+)) $ zipWith (\k l -> replicate k 0 ++ l ++ repeat 0) [0, hopSize..] input + lastLength = maximum $ -1 : zipWith (\k l -> k + length l - 1) [0, hopSize..] input + +genBlocks :: Arbitrary a => Int -> Gen [[a]] +genBlocks blockSize = resize (maximum [5, 1000 `div` blockSize]) $ listOf $ vector blockSize + +shrinkBlocks :: [[Int]] -> [[[Int]]] +shrinkBlocks = shrinkList $ shrinkOne shrink + +genChunks :: Arbitrary a => Int -> Int -> Gen [[[a]]] +genChunks blockM chunkSize = resize (maximum [5, 1000 `div` blockM `div` chunkSize]) $ listOf $ vectorOf blockM $ vector chunkSize + +shrinkChunks :: [[[Int]]] -> [[[[Int]]]] +shrinkChunks = shrinkList $ shrinkOne $ shrinkOne shrink + +main :: IO () +main = hspec $ do + prop "framesOfS" $ \(Positive (Small chunkM)) (Positive (Small blockM)) (Positive (Small hopSize)) -> + let blockSize = blockM * hopSize + chunkSize = chunkM * hopSize + in forAllShrink (genBlocks blockSize) shrinkBlocks $ + equivToListA (listFramesOf chunkSize hopSize . (replicate (chunkSize - hopSize) 0 :)) (framesOfS chunkSize hopSize) + prop "sumFramesS" $ \(Positive (Small chunkM)) (Positive (Small blockM)) (Positive (Small hopSize)) -> + let blockSize = blockM * hopSize + chunkSize = chunkM * hopSize + in forAllShrink (genChunks blockM chunkSize) shrinkChunks $ \l -> + equivToListB (take (length l) . listSumFrames blockSize hopSize) (sumFramesS blockSize hopSize) l + + diff --git a/vocoder-dunai.cabal b/vocoder-dunai.cabal new file mode 100644 --- /dev/null +++ b/vocoder-dunai.cabal @@ -0,0 +1,72 @@ +name: vocoder-dunai +version: 0.1.0.0 +homepage: https://github.com/tilk/vocoder +synopsis: Phase vocoder for Dunai and Rhine +description: + This package wraps the algorithms provided by the vocoder package + for use with Dunai and Rhine FRP libraries. This allows convenient + (soft) real-time frequency domain signal processing. +license: BSD2 +license-file: LICENSE +author: Marek Materzok +maintainer: tilk@tilk.eu +-- copyright: +category: Sound +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +flag buildExamples + description: Build example executables + default: False + +library + exposed-modules: Vocoder.Dunai + -- other-modules: + -- other-extensions: + build-depends: base >=4.11 && <4.15, + vector >= 0.12.1.0 && <0.13, + vector-fftw >= 0.1.3.8 && < 0.2, + dunai >= 0.7.0 && < 0.8, + vocoder >= 0.1.0.0 && < 0.2 + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 + +executable vocoder-jack + main-is: VocoderJack.hs + other-modules: MVarClock, ProcessingTree + hs-source-dirs: example + if flag(buildExamples) + build-depends: base, vocoder, vocoder-dunai, transformers, vector, array, time, + explicit-exception, + mtl >= 2.2.2 && < 2.3, + rhine >= 0.7.0 && < 0.8, + jack >= 0.7.1.4 && < 0.8, + optparse-applicative >= 0.16.0.0 && < 0.17, + split >= 0.2.3.4 && < 0.3 + else + buildable: False + ghc-options: -Wall -threaded + default-language: Haskell2010 + +test-suite test-vocoder-dunai + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: main.hs + build-depends: base, vector, vector-fftw, dunai, vocoder, vocoder-dunai, + hspec >= 2.7, + QuickCheck >= 2.14 && < 2.15 + ghc-options: -Wall + +benchmark bench-vocoder-dunai + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: main.hs + build-depends: base, vector, vector-fftw, dunai, vocoder, vocoder-dunai, + gauge >= 0.2.5 + ghc-options: -Wall -rtsopts + +