vocoder-dunai (empty) → 0.1.0.0
raw patch · 10 files changed
+678/−0 lines, 10 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, dunai, explicit-exception, gauge, hspec, jack, mtl, optparse-applicative, rhine, split, time, transformers, vector, vector-fftw, vocoder, vocoder-dunai
Files
- ChangeLog.md +4/−0
- LICENSE +26/−0
- Setup.hs +2/−0
- benchmarks/main.hs +40/−0
- example/MVarClock.hs +46/−0
- example/ProcessingTree.hs +43/−0
- example/VocoderJack.hs +294/−0
- src/Vocoder/Dunai.hs +86/−0
- test/main.hs +65/−0
- vocoder-dunai.cabal +72/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+## 0.1.0.0++Initial version.+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/main.hs view
@@ -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+
+ example/MVarClock.hs view
@@ -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+ }+
+ example/ProcessingTree.hs view
@@ -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+
+ example/VocoderJack.hs view
@@ -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+
+ src/Vocoder/Dunai.hs view
@@ -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'+
+ test/main.hs view
@@ -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++
+ vocoder-dunai.cabal view
@@ -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++