packages feed

vocoder-conduit (empty) → 0.1.0.0

raw patch · 9 files changed

+414/−0 lines, 9 filesdep +QuickCheckdep +basedep +conduitsetup-changed

Dependencies added: QuickCheck, base, conduit, gauge, hspec, mono-traversable, vector, vector-fftw, vocoder, vocoder-conduit

Files

+ 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,32 @@+import Gauge.Main+import qualified Data.Vector.Storable as V+import Data.Conduit ((.|))+import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import Vocoder.Conduit.Frames++benchFramesOfE :: Int -> Int -> Int -> Int -> Benchmarkable+benchFramesOfE inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size ->+        C.runConduitPure+      $ CC.enumFromTo 1 size+     .| CC.map (V.replicate inputChunkSize)+     .| framesOfE chunkSize hopSize+     .| CC.sumE++benchSumFramesE :: Int -> Int -> Int -> Int -> Benchmarkable+benchSumFramesE inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size ->+        C.runConduitPure+      $ CC.enumFromTo 1 size+     .| CC.map (V.replicate inputChunkSize)+     .| sumFramesE chunkSize hopSize+     .| CC.sumE++main :: IO ()+main = defaultMain +    [ bench "framesOfE" $ benchFramesOfE 100 512 21 size0+    , bench "sumFramesE" $ benchSumFramesE 512 100 21 size0+    ]+    where+    size0 = 1000 :: Int+    +
+ src/Vocoder/Conduit.hs view
@@ -0,0 +1,65 @@+{-| +    Module      : Vocoder.Conduit+    Description : Phase vocoder in Conduit+    Copyright   : (c) Marek Materzok, 2021+    License     : BSD2++This module wraps phase vocoder algorithms for use in Conduit.+Two variants are provided, one for single channel processing,+and another for processing multiple channels synchronously.+-}+module Vocoder.Conduit(+      -- * Single-channel functions+      volumeFix,+      analysis,+      synthesis,+      processFrames,+      -- * Multi-channel functions+      volumeFixF,+      analysisF,+      synthesisF,+      processFramesF+    ) where++import Data.Conduit+import qualified Data.Conduit.List as DCL+import qualified Data.List.NonEmpty as DLN+import qualified Data.Vector.Storable as V+import Control.Arrow+import Vocoder++-- | Corrects for volume change introduced by STFT processing.+volumeFix :: Monad m => VocoderParams -> ConduitT STFTFrame STFTFrame m ()+volumeFix par = DCL.map $ V.map (* volumeCoeff par) *** id++-- | Perform the phase vocoder analysis phase.+analysis :: Monad m => VocoderParams -> Phase -> ConduitT Frame STFTFrame m Phase+analysis par ph = DCL.mapAccum (flip $ analysisBlock par) ph++-- | Perform the phase vocoder synthesis phase.+synthesis :: Monad m => VocoderParams -> Phase -> ConduitT STFTFrame Frame m Phase+synthesis par ph = DCL.mapAccum (flip $ synthesisBlock par) ph++-- | Perform frequency domain processing.+processFrames :: Monad m => VocoderParams -> (Phase, Phase) -> ConduitT STFTFrame STFTFrame m r -> ConduitT Frame Frame m (r, (Phase, Phase))+processFrames par (p1, p2) c = (\((p1', r), p2') -> (r, (p1', p2'))) <$> analysis par p1 `fuseBoth` (volumeFix par .| c) `fuseBoth` synthesis par p2++app_help :: Applicative f => (a -> s -> (s, b)) -> f a -> f s -> (f s, f b)+app_help f a b = DLN.unzip $ fmap (uncurry f) ((,) <$> a <*> b)++-- | Corrects for volume change introduced by STFT processing. +volumeFixF :: (Applicative f, Monad m) => VocoderParams -> ConduitT (f STFTFrame) (f STFTFrame) m ()+volumeFixF par = DCL.map $ fmap $ V.map (* volumeCoeff par) *** id++-- | Perform the phase vocoder analysis phase.+analysisF :: (Applicative f, Monad m) => VocoderParams -> f Phase -> ConduitT (f Frame) (f STFTFrame) m (f Phase)+analysisF par ph = DCL.mapAccum (app_help $ flip $ analysisBlock par) ph++-- | Perform the phase vocoder synthesis phase.+synthesisF :: (Applicative f, Monad m) => VocoderParams -> f Phase -> ConduitT (f STFTFrame) (f Frame) m (f Phase)+synthesisF par ph = DCL.mapAccum (app_help $ flip $ synthesisBlock par) ph++-- | Perform frequency domain processing.+processFramesF :: (Applicative f, Monad m) => VocoderParams -> (f Phase, f Phase) -> ConduitT (f STFTFrame) (f STFTFrame) m r -> ConduitT (f Frame) (f Frame) m (r, (f Phase, f Phase))+processFramesF par (p1, p2) c = (\((p1', r), p2') -> (r, (p1', p2'))) <$> analysisF par p1 `fuseBoth` (volumeFixF par .| c) `fuseBoth` synthesisF par p2+
+ src/Vocoder/Conduit/Filter.hs view
@@ -0,0 +1,137 @@+{-| +    Module      : Vocoder.Conduit.Filter+    Description : Frequency-domain filters in Conduit+    Copyright   : (c) Marek Materzok, 2021+    License     : BSD2++This module defines some useful frequency-domain filters as conduits.+It includes convenience wrappers for filters defined in the vocoder package.+-}+{-# LANGUAGE RankNTypes #-}+module Vocoder.Conduit.Filter(+      Filter,+      runFilter,+      idFilter,+      composeFilters,+      realtimeFilter,+      amplitudeFilter,+      linearAmplitudeFilter,+      amplify,+      lowpassBrickwall,+      highpassBrickwall,+      bandpassBrickwall,+      bandstopBrickwall,+      lowpassButterworth,+      highpassButterworth,+      bandpassButterworth,+      bandstopButterworth,+      pitchShiftInterpolate,+      convolutionFilter,+      envelopeFilter,+      randomPhaseFilter,+      playSpeed+    ) where++import Vocoder+import qualified Vocoder.Filter as F+import Data.Conduit+import Control.Monad.IO.Class+import qualified Data.Vector.Storable as V+import qualified Data.Conduit.Combinators as DCC++-- | Conduit frequency-domain filter type. A conduit filter extends +--   basic frequency-domain filters by using a conduit instead of a+--   pure function. This enables time transformation filters.+newtype Filter m = Filter { runFilter :: forall f. Traversable f => F.FreqStep -> ConduitT (f STFTFrame) (f STFTFrame) m () }++-- | Identity filter+idFilter :: Monad m => Filter m+idFilter = Filter $ \_ -> awaitForever yield++-- | Sequential filter composition.+composeFilters :: Monad m => Filter m -> Filter m -> Filter m+composeFilters (Filter f1) (Filter f2) = Filter $ \step -> f1 step .| f2 step++-- | Use a basic frequency-domain filter as a conduit filter.+realtimeFilter :: Monad m => F.Filter m -> Filter m+realtimeFilter f = Filter (\step -> DCC.mapM $ mapM $ f step)++-- | Creates a conduit filter which transforms only amplitudes, leaving+--   phase increments unchanged.+amplitudeFilter :: Monad m => (F.FreqStep -> Moduli -> Moduli) -> Filter m+amplitudeFilter = realtimeFilter . F.amplitudeFilter++-- | Creates a filter which scales amplitudes depending on frequency.+linearAmplitudeFilter :: Monad m => (Double -> Double) -> Filter m+linearAmplitudeFilter = realtimeFilter . F.linearAmplitudeFilter++-- | Creates an "amplifier" which scales all frequencies.+amplify :: Monad m => Double -> Filter m+amplify = realtimeFilter . F.amplify++-- | Creates a brickwall lowpass filter.+lowpassBrickwall :: Monad m => Double -> Filter m+lowpassBrickwall t = realtimeFilter $ F.lowpassBrickwall t++-- | Creates a brickwall highpass filter.+highpassBrickwall :: Monad m => Double -> Filter m+highpassBrickwall t = realtimeFilter $ F.highpassBrickwall t++-- | Creates a brickwall bandpass filter.+bandpassBrickwall :: Monad m => Double -> Double -> Filter m+bandpassBrickwall t u = realtimeFilter $ F.bandpassBrickwall t u++-- | Creates a brickwall bandstop filter.+bandstopBrickwall :: Monad m => Double -> Double -> Filter m+bandstopBrickwall t u = realtimeFilter $ F.bandstopBrickwall t u++-- | Creates an n-th degree Butterworth-style lowpass filter.+lowpassButterworth :: Monad m => Double -> Double -> Filter m+lowpassButterworth n t = realtimeFilter $ F.lowpassButterworth n t++-- | Creates an n-th degree Butterworth-style highpass filter.+highpassButterworth :: Monad m => Double -> Double -> Filter m+highpassButterworth n t = realtimeFilter $ F.highpassButterworth n t++-- | Creates an n-th degree Butterworth-style bandpass filter.+bandpassButterworth :: Monad m => Double -> Double -> Double -> Filter m+bandpassButterworth n t u = realtimeFilter $ F.bandpassButterworth n t u++-- | Creates an n-th degree Butterworth-style bandstop filter.+bandstopButterworth :: Monad m => Double -> Double -> Double -> Filter m+bandstopButterworth n t u = realtimeFilter $ F.bandstopButterworth n t u++-- | Creates an interpolative pitch-shifting filter.+pitchShiftInterpolate :: Monad m => Double -> Filter m+pitchShiftInterpolate n = realtimeFilter $ F.pitchShiftInterpolate n++-- | Creates a filter which convolves the spectrum using a kernel.+convolutionFilter :: Monad m => V.Vector Double -> Filter m+convolutionFilter ker = realtimeFilter $ F.convolutionFilter ker++-- | Creates a filter which replaces the amplitudes with their envelope.+envelopeFilter :: Monad m => Length -> Filter m+envelopeFilter ksize = realtimeFilter $ F.envelopeFilter ksize++-- | Sets the phase increments so that the bins have horizontal consistency.+--   This erases the phase information, introducing "phasiness".+randomPhaseFilter :: MonadIO m => Filter m+randomPhaseFilter = realtimeFilter $ F.randomPhaseFilter++-- | Changes play speed by replicating or dropping frames.+playSpeed :: Monad m => Rational -> Filter m+playSpeed coeff = Filter $ \_ -> f [] 0+    where+    f l c+        | c < 1 = do+            next <- await+            case next of+                Nothing -> mapM_ leftover $ reverse l+                Just i -> f (i:l) (c + coeff)+        | otherwise = g l c+    g l c+        | c >= 1 = do+            yield $ l !! 0+            g l (c - 1)+        | otherwise = f [] c+
+ src/Vocoder/Conduit/Frames.hs view
@@ -0,0 +1,60 @@+{-| +    Module      : Vocoder.Conduit.Frames+    Description : Frame processing+    Copyright   : (c) Marek Materzok, 2021+    License     : BSD2+-}+{-# LANGUAGE BangPatterns, FlexibleContexts #-}+module Vocoder.Conduit.Frames (+    framesOfE,+    genFramesOfE,+    sumFramesE+    ) where++import Control.Arrow+import Data.Conduit+import Data.MonoTraversable+import Data.Maybe(fromMaybe)+import qualified Data.Sequences as Seq++-- | Splits a chunked input stream into overlapping frames of constant size+--   suitable for STFT processing.+framesOfE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> Seq.Index seq -> ConduitT seq seq m ()+framesOfE chunkSize hopSize = genFramesOfE chunkSize hopSize (Seq.fromList []) >> return ()++-- | More general version of framesOfE, suitable for processing multiple inputs.+genFramesOfE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> Seq.Index seq -> seq -> ConduitT seq seq m seq+genFramesOfE chunkSize hopSize q = do+    mnextv <- await+    case mnextv of+        Nothing -> return q+        Just nextv -> do+            let newBuf = q `mappend` nextv+            let newBufLen = Seq.lengthIndex newBuf+            mapM_ yield [Seq.take chunkSize $ Seq.drop k newBuf+                        | k <- [0, hopSize .. newBufLen - chunkSize]]+            let dropcnt = ((newBufLen - chunkSize) `div` hopSize) * hopSize + hopSize+            let q' = Seq.drop dropcnt newBuf+            genFramesOfE chunkSize hopSize q'++-- | Builds a chunked output stream from a stream of overlapping frames.+sumFramesE :: (Monad m, Seq.IsSequence seq, Num (Element seq)) => Seq.Index seq -> Seq.Index seq -> ConduitT seq seq m ()+sumFramesE chunkSize hopSize = process 0 []+    where+        ith i (n, c0) = fromMaybe 0 $ Seq.index c0 (i - n)+        publish q = yield $ Seq.fromList $ map (\i -> sum $ fmap (ith i) q) [0 .. chunkSize-1]+        publishRest q | null q    = return ()+                      | otherwise = publish q >> publishRest (nextq q)+        nextq q = fmap ((+ (-chunkSize)) *** id) $ dropWhile (\(n, c) -> Seq.lengthIndex c + n <= chunkSize) q+        process2 sofar q+            | sofar >= chunkSize = do+                publish q+                process2 (sofar - chunkSize) $ nextq q+            | otherwise = process (sofar + hopSize) q+        process sofar q = do+            next <- await+            case next of+                Nothing -> publishRest q+                Just next' -> process2 sofar (q ++ [(sofar, next')])++
+ test/main.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TypeApplications #-}++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Data.Functor.Identity (Identity)+import Data.Conduit ((.|), ConduitT)+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Vocoder.Conduit.Frames++runConduitList :: ConduitT a b Identity () -> [a] -> [b]+runConduitList c l = C.runConduitPure $ CL.sourceList l .| c .| CL.consume++equivToList :: Eq b => ([a] -> [b]) -> ConduitT a b Identity () -> [a] -> Bool+equivToList f c xs = f xs == runConduitList c xs++listFramesOfE :: Int -> Int -> [[a]] -> [[a]]+listFramesOfE chunkSize hopSize input = +    map (\i -> take chunkSize $ drop i cInput) [0, hopSize .. length cInput - chunkSize] +    where +    cInput = concat input++listSumFramesE :: Int -> Int -> [[Int]] -> [[Int]]+listSumFramesE 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++main :: IO ()+main = hspec $ do+    prop "framesOfE" $ \(NonNegative chunkSizeP) (Positive hopSize) -> let chunkSize = hopSize + chunkSizeP in equivToList (listFramesOfE @Int chunkSize hopSize) (framesOfE chunkSize hopSize)+    prop "sumFramesE" $ \(Positive chunkSize) (Positive hopSize) -> equivToList (listSumFramesE chunkSize hopSize) (sumFramesE chunkSize hopSize) . map getNonEmpty++
+ vocoder-conduit.cabal view
@@ -0,0 +1,53 @@+name:                vocoder-conduit+version:             0.1.0.0+homepage:            https://github.com/tilk/vocoder+synopsis:            Phase vocoder for Conduit+description:+    This package wraps the algorithms provided by the vocoder package+    for use with Conduit. This allows convenient off-line and on-line frequency+    domain signal processing, including time transformations (e.g.+    speeding up or slowing down sounds without changing pitch).+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++library+  exposed-modules: Vocoder.Conduit, Vocoder.Conduit.Frames, Vocoder.Conduit.Filter+  -- 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,+                       conduit >= 1.3.2 && < 1.4,+                       vocoder >= 0.1.0.0 && < 0.2,+                       mono-traversable >= 1.0.15.1 && < 1.1+  hs-source-dirs:      src+  ghc-options:         -Wall+  default-language:    Haskell2010++test-suite  test-vocoder-conduit+  default-language:  Haskell2010+  type:              exitcode-stdio-1.0+  hs-source-dirs:    test+  main-is:           main.hs+  build-depends:     base, vector, vector-fftw, conduit, vocoder, vocoder-conduit,+                     hspec >= 2.7,+                     QuickCheck >= 2.14 && < 2.15+  ghc-options:       -Wall++benchmark  bench-vocoder-conduit+  default-language:  Haskell2010+  type:              exitcode-stdio-1.0+  hs-source-dirs:    benchmarks+  main-is:           main.hs+  build-depends:     base, vector, vector-fftw, conduit, vocoder, vocoder-conduit,+                     gauge >= 0.2.5+  ghc-options:       -Wall -rtsopts+  +