├── .github └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── README.md ├── cabal.project ├── vocoder-audio ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── example │ └── VocoderFile.hs ├── src │ └── Vocoder │ │ └── Audio.hs └── vocoder-audio.cabal ├── vocoder-conduit ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── benchmarks │ └── main.hs ├── src │ └── Vocoder │ │ ├── Conduit.hs │ │ └── Conduit │ │ ├── Filter.hs │ │ └── Frames.hs ├── test │ └── main.hs └── vocoder-conduit.cabal ├── vocoder-dunai ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── benchmarks │ └── main.hs ├── example │ ├── MVarClock.hs │ ├── ProcessingTree.hs │ └── VocoderJack.hs ├── src │ └── Vocoder │ │ └── Dunai.hs ├── test │ └── main.hs └── vocoder-dunai.cabal └── vocoder ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── src ├── Vocoder.hs └── Vocoder │ ├── Filter.hs │ └── Window.hs └── vocoder.cabal /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [pull_request, push] 4 | 5 | jobs: 6 | cabal: 7 | name: CI 8 | runs-on: ubuntu-latest 9 | strategy: 10 | matrix: 11 | ghc: ['8.4', '8.6', '8.8', '8.10'] 12 | steps: 13 | - uses: actions/checkout@v2 14 | - uses: haskell/actions/setup@v1 15 | with: 16 | ghc-version: ${{ matrix.ghc }} 17 | - name: install required packages 18 | run: sudo apt-get install libfftw3-dev libsndfile1-dev libjack-jackd2-dev 19 | - name: build 20 | run: cabal v2-build all --enable-tests --enable-benchmarks --enable-documentation 21 | - name: test 22 | run: cabal v2-test all 23 | - name: bench 24 | run: cabal v2-bench all 25 | - name: archive artifacts 26 | uses: actions/upload-artifact@v2 27 | with: 28 | name: dist 29 | path: dist-newstyle 30 | 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | *.swp 4 | dist/ 5 | dist-newstyle/ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Marek Materzok 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # vocoder 2 | 3 | This repository contains a collection of Haskell libraries implementing a phase vocoder - an algorithm for processing time-varying signals in frequency domain. 4 | It consists of the following libraries: 5 | 6 | * `vocoder` is the core library. It implements the algorithms in the form of pure functions. 7 | It has minimal dependencies -- it depends only on `vector` and `vector-fftw`. 8 | It can be used directly, but for most uses it's preferrable to use one of the abstractions provided by other libraries. 9 | * `vocoder-conduit` wraps the algorithms provided by `vocoder` for use with the [conduit](https://github.com/snoyberg/conduit) streaming library. 10 | This library is suitable for both off-line and on-line processing, including time transformations (e.g. time stretching). 11 | * `vocoder-audio` is a convenience library which allows to easily use `vocoder-conduit` with audio streams provided by `conduit-audio`. 12 | * `vocoder-dunai` wraps the algorithms provided by `vocoder` for use with [dunai](https://github.com/ivanperez-keera/dunai) and [rhine](https://github.com/turion/rhine) FRP libraries. 13 | This library is suitable for real-time signal processing. 14 | 15 | ## Short tutorial 16 | 17 | The phase vocoder algorithm consists of several stages: 18 | 19 | * Splitting the input signal into overlapping frames of certain size, and applying a window function. 20 | * Computing the FFT of the frames. 21 | * Analysing the phases, which involves comparing the phases of the current frame to the previous one, and computing phase increments. 22 | * Processing of the spectrum. This is the part which depends on the application. This phase is also responsible for the correctness of phase increments after the processing. 23 | * Synthesizing the phases, which involves accumulating the phase increments. 24 | * Computing the IFFT. 25 | * Combining the overlapping frames into the output signal. 26 | 27 | The analysis and synthesis phases are implemented in the `vocoder` library. 28 | The convenience libraries `vocoder-conduit` and `vocoder-dunai` make it easy to write the application-specific processing stage and to use it to create the full vocoder pipeline. 29 | 30 | ### vocoder-conduit 31 | 32 | The processing function has the type of `Monad m => ConduitT STFTFrame STFTFrame m r`, which means it is a conduit that accepts STFT frames (consisting of amplitudes and phase increments) and produces STFT frames. 33 | To use it, the simplest way is to use the `process` function, of the type `Monad m => VocoderParams -> ConduitT STFTFrame STFTFrame m r -> ConduitT Frame Frame m r`. 34 | The result is a conduit, which accepts a chunked stream of input data, and produces a chunked stream of output data. 35 | 36 | For more complex usage, there is the `processFrames` function, of the type `Monad m => VocoderParams -> (Phase, Phase) -> ConduitT STFTFrame STFTFrame m r -> ConduitT Frame Frame m (r, (Phase, Phase))`. 37 | Its arguments are: the vocoder configuration, the initial phases (for analysis and synthesis), and the processing function. 38 | The result is a conduit, which accepts overlapped, windowed signal frames (of arbitrary size), produces overlapped signal frames (of the same size as the vocoder's hop size), and returns the result of the processing function and the final phases (for analysis and synthesis). 39 | Initial phases can be constructed using the function `zeroPhase`. 40 | The returned final phases can be used to seamlessly continue processing using a different processing function. 41 | To use this function with chunked streams, `framesOfE` and `sumFramesE` can be used. 42 | 43 | Because the `conduit` abstraction doesn't allow zipping, the library includes additional functions for simulteaneously processing multiple channels (e.g. stereo). 44 | To do that, one should use the `processFrames` function, of the type `(Monad m, Applicative f) => (f Phase, f Phase) -> ConduitT (f STFTFrame) (f STFTFrame) m r -> ConduitT (f Frame) (f Frame) m (r, (f Phase, f Phase))`. 45 | The applicative functor `f` should be a data structure for the channels, with a ,,zipping'' (field-wise) applicative instance. 46 | Therefore using lists as `f` is not correct (but `ZipList` is). 47 | 48 | ### vocoder-dunai 49 | 50 | The processing function has the type of `MSF m [STFTFrame] [STFTFrame]`, which means it accepts sequences of STFT frames and produces sequences of STFT frames (of the same length). 51 | The need for using sequences comes from the fact that processing in `dunai` is synchronous: for every input frame, exactly one output frame has to be produced, and every part of the processing chain works at the same rate. 52 | Therefore, for hop sizes smaller than the input frame size, several STFT frames will be produced for one time-domain input frame. 53 | To use the processing function, the simplest way is to use the `process` function, of the type `MSF m [STFTFrame] [STFTFrame] -> MSF m Frame Frame`. 54 | 55 | ## Example programs 56 | 57 | Two example programs are provided to demonstrate the use of the libraries: `vocoder-file` in package `vocoder-audio`, and `vocoder-jack` in package `vocoder-dunai`. 58 | 59 | ### vocoder-file 60 | 61 | This program uses `vocoder-conduit` for off-line audio file processing. 62 | It takes a number of input files and effect specifications for each of the files, and produces an output file which is the result of processing the input files in sequence. 63 | The inputs are joined seamlessly. 64 | 65 | Example usage: 66 | 67 | * `vocoder-file output.wav input.wav --lowpassBrickwall 1000` 68 | 69 | Low-pass filters the `input.wav` file, leaving only the frequencies below 1000 Hz. 70 | 71 | * `vocoder-file output.wav input1.wav --pitchShiftInterpolate 2 input2.wav --playSpeed 2` 72 | 73 | Changes the pitch of `input1.wav` by one octave, and slows down the tempo of `input2.wav` two times. 74 | 75 | * `vocoder-file output.wav input.wav --playSpeed 10 --randomPhase` 76 | 77 | Slows down the tempo of `input.wav` ten times and randomises the STFT phases, introducing Paulstretch-style effect. 78 | 79 | * `vocoder-file output.wav input.wav --envelope 32 --randomPhase` 80 | 81 | Takes spectral envelope of `input.wav` and randomises the STFT phases, which makes speech sound more like a whisper. 82 | 83 | ### vocoder-jack 84 | 85 | This program uses `vocoder-dunai` for processing audio in real-time through the [JACK](https://jackaudio.org/) real-time audio framework. 86 | It allows combining multiple sound inputs using a filter tree, which allows constructing interesting effects, including those known from vocoder pedals. 87 | 88 | The filter tree is specified using postfix notation. If a filter argument is missing, input stream 0 is assumed. 89 | 90 | Example usage: 91 | 92 | * `vocoder-jack --lowpassButterworth 2,1000` 93 | 94 | Low-pass filters the input using a filter with second-order Butterworth-like characteristics and a cut-off frequency of 1000 Hz. 95 | 96 | * `vocoder-jack --windowSize 128 --randomPhase` 97 | 98 | Randomizes STFT phase with small window size, reducing sound clarity and creating a "distorted anonymous voice" effect. 99 | 100 | * `vocoder-jack --envelope 32 --randomPhase` 101 | 102 | Take spectral envelope of the input and randomize the STFT phases, producing a whisper-like effect. 103 | 104 | * `vocoder-jack --pitchShiftInterpolate 2 --add` 105 | 106 | Adds the spectrum of the input signal to the spectrum lowered by one octave, creating a harmonizer effect. 107 | 108 | * `vocoder-jack --envelope 32 --divide --source 1 --envelope 32 --multiply` 109 | 110 | Creates a talkbox-like vocoder effect. 111 | The first input's spectrum is divided by its own envelope, and multiplied by the envelope of the second input's spectrum. 112 | 113 | * `vocoder-jack --delay 10 --amplify 0.5 --add` 114 | 115 | Create an echo effect by delaying the input by 10 STFT hops, reducing amplitude and adding to the original signal. 116 | 117 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: vocoder/ 2 | vocoder-conduit/ 3 | vocoder-audio/ 4 | vocoder-dunai/ 5 | 6 | -------------------------------------------------------------------------------- /vocoder-audio/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1.0.0 2 | 3 | Initial version. 4 | 5 | -------------------------------------------------------------------------------- /vocoder-audio/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Marek Materzok 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /vocoder-audio/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /vocoder-audio/example/VocoderFile.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Options.Applicative 4 | import Data.Semigroup ((<>)) 5 | import Data.List.Split 6 | import Text.Read 7 | import Vocoder 8 | import Vocoder.Window 9 | import Vocoder.Audio 10 | import Vocoder.Conduit.Filter 11 | import Sound.File.Sndfile 12 | import Data.Conduit.Audio.Sndfile 13 | import Control.Monad 14 | import Control.Monad.IO.Class 15 | import Control.Monad.Trans.Resource 16 | import System.Random 17 | import qualified Data.Vector.Storable as V 18 | 19 | data WindowType = BoxWindow | HammingWindow | HannWindow | BlackmanWindow | FlatTopWindow deriving (Read, Show) 20 | 21 | data Options = Options { 22 | optFrameSize :: Maybe Length, 23 | windowSize :: Length, 24 | hopSizeO :: HopSize, 25 | windowType :: WindowType, 26 | initPhaseRandom :: Bool, 27 | destFile :: String, 28 | sources :: [(String, Filter (ResourceT IO))] 29 | } 30 | 31 | initPhase :: Options -> IO Phase 32 | initPhase opts | initPhaseRandom opts = V.replicateM (vocFreqFrameLength $ vocoderParamsFor opts) $ randomRIO (0, 2*pi) 33 | | otherwise = return $ zeroPhase $ vocoderParamsFor opts 34 | 35 | frameSize :: Options -> Length 36 | frameSize opts = maybe (windowSize opts) id $ optFrameSize opts 37 | 38 | windowFor :: Options -> Window 39 | windowFor opts = windowFun (windowType opts) (windowSize opts) 40 | 41 | windowFun :: WindowType -> Length -> Window 42 | windowFun BoxWindow = boxWindow 43 | windowFun HammingWindow = hammingWindow 44 | windowFun HannWindow = hannWindow 45 | windowFun BlackmanWindow = blackmanWindow 46 | windowFun FlatTopWindow = flatTopWindow 47 | 48 | vocoderParamsFor :: Options -> VocoderParams 49 | vocoderParamsFor opts = vocoderParams (frameSize opts) (hopSizeO opts) (windowFor opts) 50 | 51 | auto2 :: (Read a, Read b) => ReadM (a, b) 52 | auto2 = maybeReader $ f . splitOn "," 53 | where 54 | f [a,b] = (,) <$> readMaybe a <*> readMaybe b 55 | f _ = Nothing 56 | 57 | auto3 :: (Read a, Read b, Read c) => ReadM (a, b, c) 58 | auto3 = maybeReader $ f . splitOn "," 59 | where 60 | f [a,b,c] = (,,) <$> readMaybe a <*> readMaybe b <*> readMaybe c 61 | f _ = Nothing 62 | 63 | uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) 64 | uncurry3 f (a,b,c) = f a b c 65 | 66 | sourceP :: MonadIO m => Parser (String, Filter m) 67 | sourceP = (,) 68 | <$> argument str (metavar "SRC") 69 | <*> filtersP 70 | 71 | filtersP :: MonadIO m => Parser (Filter m) 72 | filtersP = (\l -> if null l then idFilter else foldr1 composeFilters l) <$> many filterP 73 | 74 | filterP :: MonadIO m => Parser (Filter m) 75 | filterP = (lowpassBrickwall <$> option auto 76 | ( long "lowpassBrickwall" 77 | <> metavar "FREQ" 78 | <> help "Low-pass brickwall filter")) 79 | <|> (highpassBrickwall <$> option auto 80 | ( long "highpassBrickwall" 81 | <> metavar "FREQ" 82 | <> help "High-pass brickwall filter")) 83 | <|> (uncurry bandpassBrickwall <$> option auto2 84 | ( long "bandpassBrickwall" 85 | <> metavar "FREQ,FREQ" 86 | <> help "Band-pass brickwall filter")) 87 | <|> (uncurry bandstopBrickwall <$> option auto2 88 | ( long "bandstopBrickwall" 89 | <> metavar "FREQ,FREQ" 90 | <> help "Band-stop brickwall filter")) 91 | <|> (uncurry lowpassButterworth <$> option auto2 92 | ( long "lowpassButterworth" 93 | <> metavar "DEG,FREQ" 94 | <> help "Low-pass Butterworth-style filter")) 95 | <|> (uncurry highpassButterworth <$> option auto2 96 | ( long "highpassButterworth" 97 | <> metavar "DEG,FREQ" 98 | <> help "High-pass Butterworth-style filter")) 99 | <|> (uncurry3 bandpassButterworth <$> option auto3 100 | ( long "bandpassButterworth" 101 | <> metavar "DEG,FREQ,FREQ" 102 | <> help "Band-pass Butterworth-style filter")) 103 | <|> (uncurry3 bandstopButterworth <$> option auto3 104 | ( long "bandstopButterworth" 105 | <> metavar "DEG,FREQ,FREQ" 106 | <> help "Band-stop Butterworth-style filter")) 107 | <|> (amplify <$> option auto 108 | ( long "amplify" 109 | <> metavar "COEFF" 110 | <> help "Change amplitude")) 111 | <|> (pitchShiftInterpolate <$> option auto 112 | ( long "pitchShiftInterpolate" 113 | <> metavar "COEFF" 114 | <> help "Interpolative pitch-shift")) 115 | <|> (envelopeFilter <$> option auto 116 | ( long "envelope" 117 | <> metavar "KSIZE" 118 | <> help "Calculate spectral envelope")) 119 | <|> (playSpeed <$> option (toRational <$> (auto :: ReadM Double)) 120 | ( long "playSpeed" 121 | <> metavar "COEFF" 122 | <> help "Change speed by coefficient")) 123 | <|> (flag' (randomPhaseFilter) 124 | ( long "randomPhase" 125 | <> help "Randomize phases (Paulstretch effect)")) 126 | 127 | options :: Parser Options 128 | options = Options 129 | <$> optional (option auto 130 | ( long "frameSize" 131 | <> metavar "SIZE" 132 | <> help "Size of zero-padded FFT frame, must be >= windowSize")) 133 | <*> option auto 134 | ( long "windowSize" 135 | <> metavar "SIZE" 136 | <> value 1024 137 | <> showDefault 138 | <> help "Size of STFT window") 139 | <*> option auto 140 | ( long "hopSize" 141 | <> metavar "SIZE" 142 | <> value 128 143 | <> showDefault 144 | <> help "STFT hop size") 145 | <*> option auto 146 | ( long "windowType" 147 | <> metavar "TYPE" 148 | <> value BlackmanWindow 149 | <> showDefault 150 | <> help "Type of STFT window") 151 | <*> switch 152 | ( long "randomInitPhase" 153 | <> help "Randomize initial phase") 154 | <*> argument str (metavar "DST") 155 | <*> some sourceP 156 | 157 | myFormat :: Format 158 | myFormat = Format {headerFormat = HeaderFormatWav, sampleFormat = SampleFormatPcm16, endianFormat = EndianFile} 159 | 160 | main :: IO () 161 | main = execParser opts >>= process 162 | where 163 | opts = info (options <**> helper) 164 | ( fullDesc 165 | <> progDesc "Process audio file" 166 | <> header "Phase vocoder audio processing") 167 | 168 | process :: Options -> IO () 169 | process opts = do 170 | let par = vocoderParamsFor opts 171 | iphs <- initPhase opts 172 | srcs <- forM (sources opts) $ \(n, f) -> processVocoderAudio par f <$> sourceSnd n 173 | runResourceT $ sinkSnd (destFile opts) myFormat $ sourceVocoderWithPhase iphs $ foldl1 concatenateV srcs 174 | 175 | -------------------------------------------------------------------------------- /vocoder-audio/src/Vocoder/Audio.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder.Audio 3 | Description : Frequency-domain filters 4 | Copyright : (c) Marek Materzok, 2021 5 | License : BSD2 6 | 7 | This module allows easy frequency-domain processing on audio streams 8 | created in @conduit-audio@. 9 | -} 10 | module Vocoder.Audio( 11 | VocoderAudioSource(..), 12 | concatenateV, 13 | sourceVocoder, 14 | sourceVocoderWithPhase, 15 | processAudio, 16 | processAudioWithPhase, 17 | processVocoderAudio 18 | ) where 19 | 20 | import Data.Conduit 21 | import Data.Conduit.Audio 22 | import qualified Data.Conduit.Combinators as DCC 23 | import Control.Applicative 24 | import Control.Monad 25 | import Vocoder 26 | import Vocoder.Conduit 27 | import Vocoder.Conduit.Filter 28 | import Vocoder.Conduit.Frames 29 | import qualified Data.Vector.Storable as V 30 | 31 | data VocoderAudioSource m = VocoderAudioSource { 32 | sourceV :: (Frame, (ZipList Phase, ZipList Phase)) 33 | -> ConduitT () Frame m (V.Vector Double, (ZipList Phase, ZipList Phase)), 34 | rateV :: Rate, 35 | channelsV :: Channels, 36 | framesV :: Frames, 37 | vocoderParamsV :: VocoderParams 38 | } 39 | 40 | -- | Applies a conduit filter to an audio stream, producing a vocoder stream. 41 | -- This allows to seamlessly concatenate audio streams for vocoder processing. 42 | processVocoderAudio 43 | :: Monad m 44 | => VocoderParams 45 | -> Filter m 46 | -> AudioSource m Double 47 | -> VocoderAudioSource m 48 | processVocoderAudio par c src = VocoderAudioSource newSource (rate src) (channels src) (frames src) par where 49 | freqStep = rate src / fromIntegral (vocFrameLength par) 50 | newSource (q, ps) = 51 | (source src .| genFramesOfE (vocInputFrameLength par * channels src) (vocHopSize par * channels src) q) 52 | `fuseBoth` 53 | (DCC.map (ZipList . deinterleave (channels src)) .| (snd <$> processFramesF par ps (runFilter c freqStep))) 54 | `fuseUpstream` 55 | DCC.map (interleave . getZipList) 56 | 57 | -- | Connects the end of the first vocoder source to the beginning of the second. 58 | -- The two sources must have the same sample rate, channel count, vocoder hop size 59 | -- and frame length. 60 | concatenateV :: Monad m 61 | => VocoderAudioSource m 62 | -> VocoderAudioSource m 63 | -> VocoderAudioSource m 64 | concatenateV src1 src2 65 | | rateV src1 /= rateV src2 = error "Vocoder.Audio.concatenateV: mismatched rates" 66 | | channelsV src1 /= channelsV src2 = error "Vocoder.Audio.concatenateV: mismatched channels" 67 | | vocHopSize par1 /= vocHopSize par2 = error "Vocoder.Audio.concatenateV: mismatched hop size" 68 | | vocFrameLength par1 /= vocFrameLength par2 = error "Vocoder.Audio.concatenateV: mismatched frame length" 69 | | otherwise = VocoderAudioSource (sourceV src1 >=> sourceV src2) (rateV src1) (channelsV src1) (framesV src1 + framesV src2) (vocoderParamsV src1) 70 | where 71 | par1 = vocoderParamsV src1 72 | par2 = vocoderParamsV src2 73 | 74 | -- | Creates an audio source from a vocoder source. 75 | sourceVocoder :: Monad m 76 | => VocoderAudioSource m 77 | -> AudioSource m Double 78 | sourceVocoder src = sourceVocoderWithPhase (zeroPhase $ vocoderParamsV src) src 79 | 80 | -- | Creates an audio source from a vocoder source, with initial phase provided. 81 | sourceVocoderWithPhase 82 | :: Monad m 83 | => Phase 84 | -> VocoderAudioSource m 85 | -> AudioSource m Double 86 | sourceVocoderWithPhase iphs src = AudioSource newSource (rateV src) (channelsV src) (framesV src) 87 | where 88 | par = vocoderParamsV src 89 | phs = ZipList $ replicate (channelsV src) iphs 90 | newSource = (sourceV src (V.empty, (phs, phs)) >> return ()) 91 | .| sumFramesE (chunkSize * channelsV src) (vocHopSize par * channelsV src) 92 | 93 | -- | Applies a conduit filter to an audio stream. 94 | processAudio 95 | :: Monad m 96 | => VocoderParams 97 | -> Filter m 98 | -> AudioSource m Double 99 | -> AudioSource m Double 100 | processAudio par = processAudioWithPhase par (zeroPhase par) 101 | 102 | -- | Applies a conduit filter to an audio stream, with initial phase provided. 103 | processAudioWithPhase 104 | :: Monad m 105 | => VocoderParams 106 | -> Phase 107 | -> Filter m 108 | -> AudioSource m Double 109 | -> AudioSource m Double 110 | processAudioWithPhase par iphs c src = sourceVocoderWithPhase iphs $ processVocoderAudio par c src 111 | 112 | 113 | 114 | -------------------------------------------------------------------------------- /vocoder-audio/vocoder-audio.cabal: -------------------------------------------------------------------------------- 1 | name: vocoder-audio 2 | version: 0.1.0.0 3 | homepage: https://github.com/tilk/vocoder 4 | synopsis: Phase vocoder for conduit-audio 5 | description: 6 | This module allows to easily use frequency domain processing on audio 7 | streams created by @conduit-audio@. 8 | license: BSD2 9 | license-file: LICENSE 10 | author: Marek Materzok 11 | maintainer: tilk@tilk.eu 12 | -- copyright: 13 | category: Sound 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | flag buildExamples 19 | description: Build example executables 20 | default: False 21 | 22 | library 23 | exposed-modules: Vocoder.Audio 24 | -- other-modules: 25 | -- other-extensions: 26 | build-depends: base >=4.11 && <4.15, 27 | vector >= 0.12.1.0 && <0.13, 28 | vector-fftw >= 0.1.3.8 && < 0.2, 29 | conduit >= 1.3.2 && < 1.4, 30 | vocoder >= 0.1.0.0 && < 0.2, 31 | vocoder-conduit >= 0.1.0.0 && < 0.2, 32 | containers >= 0.6.3.1 && < 0.7, 33 | mono-traversable >= 1.0.15.1 && < 1.1, 34 | conduit-audio >= 0.2.0.3 && < 0.3 35 | hs-source-dirs: src 36 | default-language: Haskell2010 37 | ghc-options: -Wall 38 | 39 | executable vocoder-file 40 | main-is: VocoderFile.hs 41 | hs-source-dirs: example 42 | -- other-modules: 43 | if flag(buildExamples) 44 | build-depends: base, 45 | vector, 46 | conduit, 47 | vocoder, 48 | vocoder-conduit, 49 | vocoder-audio, 50 | hsndfile >= 0.8.0 && < 0.9, 51 | conduit-audio, 52 | conduit-audio-sndfile >= 0.1.2.2 && < 0.2, 53 | resourcet >= 1.2.2 && < 1.3, 54 | optparse-applicative >= 0.16.0.0 && < 0.17, 55 | split >= 0.2.3.4 && < 0.3, 56 | random >= 1.2.0 && < 1.3 57 | else 58 | buildable: False 59 | default-language: Haskell2010 60 | ghc-options: -Wall 61 | 62 | 63 | -------------------------------------------------------------------------------- /vocoder-conduit/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1.0.0 2 | 3 | Initial version. 4 | 5 | -------------------------------------------------------------------------------- /vocoder-conduit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Marek Materzok 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /vocoder-conduit/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /vocoder-conduit/benchmarks/main.hs: -------------------------------------------------------------------------------- 1 | import Gauge.Main 2 | import qualified Data.Vector.Storable as V 3 | import Data.Conduit ((.|)) 4 | import qualified Data.Conduit as C 5 | import qualified Data.Conduit.Combinators as CC 6 | import Vocoder.Conduit.Frames 7 | 8 | benchFramesOfE :: Int -> Int -> Int -> Int -> Benchmarkable 9 | benchFramesOfE inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size -> 10 | C.runConduitPure 11 | $ CC.enumFromTo 1 size 12 | .| CC.map (V.replicate inputChunkSize) 13 | .| framesOfE chunkSize hopSize 14 | .| CC.sumE 15 | 16 | benchSumFramesE :: Int -> Int -> Int -> Int -> Benchmarkable 17 | benchSumFramesE inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size -> 18 | C.runConduitPure 19 | $ CC.enumFromTo 1 size 20 | .| CC.map (V.replicate inputChunkSize) 21 | .| sumFramesE chunkSize hopSize 22 | .| CC.sumE 23 | 24 | main :: IO () 25 | main = defaultMain 26 | [ bench "framesOfE" $ benchFramesOfE 100 512 21 size0 27 | , bench "sumFramesE" $ benchSumFramesE 512 100 21 size0 28 | ] 29 | where 30 | size0 = 1000 :: Int 31 | 32 | 33 | -------------------------------------------------------------------------------- /vocoder-conduit/src/Vocoder/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder.Conduit 3 | Description : Phase vocoder in Conduit 4 | Copyright : (c) Marek Materzok, 2021 5 | License : BSD2 6 | 7 | This module wraps phase vocoder algorithms for use in Conduit. 8 | Two variants are provided, one for single channel processing, 9 | and another for processing multiple channels synchronously. 10 | -} 11 | module Vocoder.Conduit( 12 | -- * Single-channel functions 13 | volumeFix, 14 | analysis, 15 | synthesis, 16 | processFrames, 17 | process, 18 | -- * Multi-channel functions 19 | volumeFixF, 20 | analysisF, 21 | synthesisF, 22 | processFramesF 23 | ) where 24 | 25 | import Data.Conduit 26 | import qualified Data.Conduit.List as DCL 27 | import qualified Data.List.NonEmpty as DLN 28 | import qualified Data.Vector.Storable as V 29 | import Control.Arrow 30 | import Vocoder 31 | import Vocoder.Conduit.Frames 32 | 33 | -- | Corrects for volume change introduced by STFT processing. 34 | volumeFix :: Monad m => VocoderParams -> ConduitT STFTFrame STFTFrame m () 35 | volumeFix par = DCL.map $ V.map (* volumeCoeff par) *** id 36 | 37 | -- | Perform the phase vocoder analysis phase. 38 | analysis :: Monad m => VocoderParams -> Phase -> ConduitT Frame STFTFrame m Phase 39 | analysis par ph = DCL.mapAccum (flip $ analysisBlock par) ph 40 | 41 | -- | Perform the phase vocoder synthesis phase. 42 | synthesis :: Monad m => VocoderParams -> Phase -> ConduitT STFTFrame Frame m Phase 43 | synthesis par ph = DCL.mapAccum (flip $ synthesisBlock par) ph 44 | 45 | -- | Perform frequency domain processing on overlapping frames. 46 | processFrames :: Monad m => VocoderParams -> (Phase, Phase) -> ConduitT STFTFrame STFTFrame m r -> ConduitT Frame Frame m (r, (Phase, Phase)) 47 | processFrames par (p1, p2) c = (\((p1', r), p2') -> (r, (p1', p2'))) <$> analysis par p1 `fuseBoth` (volumeFix par .| c) `fuseBoth` synthesis par p2 48 | 49 | -- | Perform frequency domain processing on a chunked stream. 50 | process :: Monad m => VocoderParams -> ConduitT STFTFrame STFTFrame m r -> ConduitT Frame Frame m r 51 | process par c0 = (\(r, _, _) -> r) <$> processWith V.empty (zeroPhase par, zeroPhase par) c0 52 | where 53 | processWith q phs c = (\(q', (r, ph)) -> (r, q', ph)) <$> (genFramesOfE (vocInputFrameLength par) (vocHopSize par) q `fuseBoth` processFrames par phs c) `fuseUpstream` sumFramesE (vocHopSize par) (vocHopSize par) 54 | 55 | app_help :: Applicative f => (a -> s -> (s, b)) -> f a -> f s -> (f s, f b) 56 | app_help f a b = DLN.unzip $ fmap (uncurry f) ((,) <$> a <*> b) 57 | 58 | -- | Corrects for volume change introduced by STFT processing. 59 | volumeFixF :: (Applicative f, Monad m) => VocoderParams -> ConduitT (f STFTFrame) (f STFTFrame) m () 60 | volumeFixF par = DCL.map $ fmap $ V.map (* volumeCoeff par) *** id 61 | 62 | -- | Perform the phase vocoder analysis phase. 63 | analysisF :: (Applicative f, Monad m) => VocoderParams -> f Phase -> ConduitT (f Frame) (f STFTFrame) m (f Phase) 64 | analysisF par ph = DCL.mapAccum (app_help $ flip $ analysisBlock par) ph 65 | 66 | -- | Perform the phase vocoder synthesis phase. 67 | synthesisF :: (Applicative f, Monad m) => VocoderParams -> f Phase -> ConduitT (f STFTFrame) (f Frame) m (f Phase) 68 | synthesisF par ph = DCL.mapAccum (app_help $ flip $ synthesisBlock par) ph 69 | 70 | -- | Perform frequency domain processing on overlapping frames. 71 | 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)) 72 | processFramesF par (p1, p2) c = (\((p1', r), p2') -> (r, (p1', p2'))) <$> analysisF par p1 `fuseBoth` (volumeFixF par .| c) `fuseBoth` synthesisF par p2 73 | 74 | 75 | -------------------------------------------------------------------------------- /vocoder-conduit/src/Vocoder/Conduit/Filter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder.Conduit.Filter 3 | Description : Frequency-domain filters in Conduit 4 | Copyright : (c) Marek Materzok, 2021 5 | License : BSD2 6 | 7 | This module defines some useful frequency-domain filters as conduits. 8 | It includes convenience wrappers for filters defined in the vocoder package. 9 | -} 10 | {-# LANGUAGE RankNTypes #-} 11 | module Vocoder.Conduit.Filter( 12 | Filter, 13 | runFilter, 14 | idFilter, 15 | composeFilters, 16 | realtimeFilter, 17 | amplitudeFilter, 18 | linearAmplitudeFilter, 19 | amplify, 20 | lowpassBrickwall, 21 | highpassBrickwall, 22 | bandpassBrickwall, 23 | bandstopBrickwall, 24 | lowpassButterworth, 25 | highpassButterworth, 26 | bandpassButterworth, 27 | bandstopButterworth, 28 | pitchShiftInterpolate, 29 | convolutionFilter, 30 | envelopeFilter, 31 | randomPhaseFilter, 32 | playSpeed 33 | ) where 34 | 35 | import Vocoder 36 | import qualified Vocoder.Filter as F 37 | import Data.Conduit 38 | import Control.Monad.IO.Class 39 | import qualified Data.Vector.Storable as V 40 | import qualified Data.Conduit.Combinators as DCC 41 | 42 | -- | Conduit frequency-domain filter type. A conduit filter extends 43 | -- basic frequency-domain filters by using a conduit instead of a 44 | -- pure function. This enables time transformation filters. 45 | newtype Filter m = Filter { runFilter :: forall f. Traversable f => F.FreqStep -> ConduitT (f STFTFrame) (f STFTFrame) m () } 46 | 47 | -- | Identity filter 48 | idFilter :: Monad m => Filter m 49 | idFilter = Filter $ \_ -> awaitForever yield 50 | 51 | -- | Sequential filter composition. 52 | composeFilters :: Monad m => Filter m -> Filter m -> Filter m 53 | composeFilters (Filter f1) (Filter f2) = Filter $ \step -> f1 step .| f2 step 54 | 55 | -- | Use a basic frequency-domain filter as a conduit filter. 56 | realtimeFilter :: Monad m => F.Filter m -> Filter m 57 | realtimeFilter f = Filter (\step -> DCC.mapM $ mapM $ f step) 58 | 59 | -- | Creates a conduit filter which transforms only amplitudes, leaving 60 | -- phase increments unchanged. 61 | amplitudeFilter :: Monad m => (F.FreqStep -> Moduli -> Moduli) -> Filter m 62 | amplitudeFilter = realtimeFilter . F.amplitudeFilter 63 | 64 | -- | Creates a filter which scales amplitudes depending on frequency. 65 | linearAmplitudeFilter :: Monad m => (Double -> Double) -> Filter m 66 | linearAmplitudeFilter = realtimeFilter . F.linearAmplitudeFilter 67 | 68 | -- | Creates an "amplifier" which scales all frequencies. 69 | amplify :: Monad m => Double -> Filter m 70 | amplify = realtimeFilter . F.amplify 71 | 72 | -- | Creates a brickwall lowpass filter. 73 | lowpassBrickwall :: Monad m => Double -> Filter m 74 | lowpassBrickwall t = realtimeFilter $ F.lowpassBrickwall t 75 | 76 | -- | Creates a brickwall highpass filter. 77 | highpassBrickwall :: Monad m => Double -> Filter m 78 | highpassBrickwall t = realtimeFilter $ F.highpassBrickwall t 79 | 80 | -- | Creates a brickwall bandpass filter. 81 | bandpassBrickwall :: Monad m => Double -> Double -> Filter m 82 | bandpassBrickwall t u = realtimeFilter $ F.bandpassBrickwall t u 83 | 84 | -- | Creates a brickwall bandstop filter. 85 | bandstopBrickwall :: Monad m => Double -> Double -> Filter m 86 | bandstopBrickwall t u = realtimeFilter $ F.bandstopBrickwall t u 87 | 88 | -- | Creates an n-th degree Butterworth-style lowpass filter. 89 | lowpassButterworth :: Monad m => Double -> Double -> Filter m 90 | lowpassButterworth n t = realtimeFilter $ F.lowpassButterworth n t 91 | 92 | -- | Creates an n-th degree Butterworth-style highpass filter. 93 | highpassButterworth :: Monad m => Double -> Double -> Filter m 94 | highpassButterworth n t = realtimeFilter $ F.highpassButterworth n t 95 | 96 | -- | Creates an n-th degree Butterworth-style bandpass filter. 97 | bandpassButterworth :: Monad m => Double -> Double -> Double -> Filter m 98 | bandpassButterworth n t u = realtimeFilter $ F.bandpassButterworth n t u 99 | 100 | -- | Creates an n-th degree Butterworth-style bandstop filter. 101 | bandstopButterworth :: Monad m => Double -> Double -> Double -> Filter m 102 | bandstopButterworth n t u = realtimeFilter $ F.bandstopButterworth n t u 103 | 104 | -- | Creates an interpolative pitch-shifting filter. 105 | pitchShiftInterpolate :: Monad m => Double -> Filter m 106 | pitchShiftInterpolate n = realtimeFilter $ F.pitchShiftInterpolate n 107 | 108 | -- | Creates a filter which convolves the spectrum using a kernel. 109 | convolutionFilter :: Monad m => V.Vector Double -> Filter m 110 | convolutionFilter ker = realtimeFilter $ F.convolutionFilter ker 111 | 112 | -- | Creates a filter which replaces the amplitudes with their envelope. 113 | envelopeFilter :: Monad m => Length -> Filter m 114 | envelopeFilter ksize = realtimeFilter $ F.envelopeFilter ksize 115 | 116 | -- | Sets the phase increments so that the bins have horizontal consistency. 117 | -- This erases the phase information, introducing "phasiness". 118 | randomPhaseFilter :: MonadIO m => Filter m 119 | randomPhaseFilter = realtimeFilter $ F.randomPhaseFilter 120 | 121 | -- | Changes play speed by replicating or dropping frames. 122 | playSpeed :: Monad m => Rational -> Filter m 123 | playSpeed coeff = Filter $ \_ -> f [] 0 124 | where 125 | f l c 126 | | c < 1 = do 127 | next <- await 128 | case next of 129 | Nothing -> mapM_ leftover $ reverse l 130 | Just i -> f (i:l) (c + coeff) 131 | | otherwise = g l c 132 | g l c 133 | | c >= 1 = do 134 | yield $ l !! 0 135 | g l (c - 1) 136 | | otherwise = f [] c 137 | 138 | -------------------------------------------------------------------------------- /vocoder-conduit/src/Vocoder/Conduit/Frames.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder.Conduit.Frames 3 | Description : Frame processing 4 | Copyright : (c) Marek Materzok, 2021 5 | License : BSD2 6 | -} 7 | {-# LANGUAGE BangPatterns, FlexibleContexts #-} 8 | module Vocoder.Conduit.Frames ( 9 | framesOfE, 10 | genFramesOfE, 11 | sumFramesE 12 | ) where 13 | 14 | import Control.Arrow 15 | import Data.Conduit 16 | import Data.MonoTraversable 17 | import Data.Maybe(fromMaybe) 18 | import qualified Data.Sequences as Seq 19 | 20 | -- | Splits a chunked input stream into overlapping frames of constant size 21 | -- suitable for STFT processing. 22 | framesOfE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> Seq.Index seq -> ConduitT seq seq m () 23 | framesOfE chunkSize hopSize = genFramesOfE chunkSize hopSize (Seq.fromList []) >> return () 24 | 25 | -- | More general version of framesOfE, suitable for processing multiple inputs. 26 | genFramesOfE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> Seq.Index seq -> seq -> ConduitT seq seq m seq 27 | genFramesOfE chunkSize hopSize q = do 28 | mnextv <- await 29 | case mnextv of 30 | Nothing -> return q 31 | Just nextv -> do 32 | let newBuf = q `mappend` nextv 33 | let newBufLen = Seq.lengthIndex newBuf 34 | mapM_ yield [Seq.take chunkSize $ Seq.drop k newBuf 35 | | k <- [0, hopSize .. newBufLen - chunkSize]] 36 | let dropcnt = ((newBufLen - chunkSize) `div` hopSize) * hopSize + hopSize 37 | let q' = Seq.drop dropcnt newBuf 38 | genFramesOfE chunkSize hopSize q' 39 | 40 | -- | Builds a chunked output stream from a stream of overlapping frames. 41 | sumFramesE :: (Monad m, Seq.IsSequence seq, Num (Element seq)) => Seq.Index seq -> Seq.Index seq -> ConduitT seq seq m () 42 | sumFramesE chunkSize hopSize = process 0 [] 43 | where 44 | ith i (n, c0) = fromMaybe 0 $ Seq.index c0 (i - n) 45 | publish q = yield $ Seq.fromList $ map (\i -> sum $ fmap (ith i) q) [0 .. chunkSize-1] 46 | publishRest q | null q = return () 47 | | otherwise = publish q >> publishRest (nextq q) 48 | nextq q = fmap ((+ (-chunkSize)) *** id) $ dropWhile (\(n, c) -> Seq.lengthIndex c + n <= chunkSize) q 49 | process2 sofar q 50 | | sofar >= chunkSize = do 51 | publish q 52 | process2 (sofar - chunkSize) $ nextq q 53 | | otherwise = process (sofar + hopSize) q 54 | process sofar q = do 55 | next <- await 56 | case next of 57 | Nothing -> publishRest q 58 | Just next' -> process2 sofar (q ++ [(sofar, next')]) 59 | 60 | 61 | -------------------------------------------------------------------------------- /vocoder-conduit/test/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | import Test.Hspec 4 | import Test.Hspec.QuickCheck 5 | import Test.QuickCheck 6 | import Data.Functor.Identity (Identity) 7 | import Data.Conduit ((.|), ConduitT) 8 | import qualified Data.Conduit as C 9 | import qualified Data.Conduit.List as CL 10 | import Vocoder.Conduit.Frames 11 | 12 | runConduitList :: ConduitT a b Identity () -> [a] -> [b] 13 | runConduitList c l = C.runConduitPure $ CL.sourceList l .| c .| CL.consume 14 | 15 | equivToList :: Eq b => ([a] -> [b]) -> ConduitT a b Identity () -> [a] -> Bool 16 | equivToList f c xs = f xs == runConduitList c xs 17 | 18 | listFramesOfE :: Int -> Int -> [[a]] -> [[a]] 19 | listFramesOfE chunkSize hopSize input = 20 | map (\i -> take chunkSize $ drop i cInput) [0, hopSize .. length cInput - chunkSize] 21 | where 22 | cInput = concat input 23 | 24 | listSumFramesE :: Int -> Int -> [[Int]] -> [[Int]] 25 | listSumFramesE chunkSize hopSize input = map (\i -> take chunkSize $ drop i cOutput) [0, chunkSize .. lastLength] 26 | where 27 | cOutput = foldl1 (zipWith (+)) $ zipWith (\k l -> replicate k 0 ++ l ++ repeat 0) [0, hopSize..] input 28 | lastLength = maximum $ -1 : zipWith (\k l -> k + length l - 1) [0, hopSize..] input 29 | 30 | main :: IO () 31 | main = hspec $ do 32 | prop "framesOfE" $ \(NonNegative chunkSizeP) (Positive hopSize) -> let chunkSize = hopSize + chunkSizeP in equivToList (listFramesOfE @Int chunkSize hopSize) (framesOfE chunkSize hopSize) 33 | prop "sumFramesE" $ \(Positive chunkSize) (Positive hopSize) -> equivToList (listSumFramesE chunkSize hopSize) (sumFramesE chunkSize hopSize) . map getNonEmpty 34 | 35 | 36 | -------------------------------------------------------------------------------- /vocoder-conduit/vocoder-conduit.cabal: -------------------------------------------------------------------------------- 1 | name: vocoder-conduit 2 | version: 0.1.0.0 3 | homepage: https://github.com/tilk/vocoder 4 | synopsis: Phase vocoder for Conduit 5 | description: 6 | This package wraps the algorithms provided by the vocoder package 7 | for use with Conduit. This allows convenient off-line and on-line frequency 8 | domain signal processing, including time transformations (e.g. 9 | speeding up or slowing down sounds without changing pitch). 10 | license: BSD2 11 | license-file: LICENSE 12 | author: Marek Materzok 13 | maintainer: tilk@tilk.eu 14 | -- copyright: 15 | category: Sound 16 | build-type: Simple 17 | extra-source-files: ChangeLog.md 18 | cabal-version: >=1.10 19 | 20 | library 21 | exposed-modules: Vocoder.Conduit, Vocoder.Conduit.Frames, Vocoder.Conduit.Filter 22 | -- other-modules: 23 | -- other-extensions: 24 | build-depends: base >=4.11 && <4.15, 25 | vector >= 0.12.1.0 && <0.13, 26 | vector-fftw >= 0.1.3.8 && < 0.2, 27 | conduit >= 1.3.2 && < 1.4, 28 | vocoder >= 0.1.0.0 && < 0.2, 29 | mono-traversable >= 1.0.15.1 && < 1.1 30 | hs-source-dirs: src 31 | ghc-options: -Wall 32 | default-language: Haskell2010 33 | 34 | test-suite test-vocoder-conduit 35 | default-language: Haskell2010 36 | type: exitcode-stdio-1.0 37 | hs-source-dirs: test 38 | main-is: main.hs 39 | build-depends: base, vector, vector-fftw, conduit, vocoder, vocoder-conduit, 40 | hspec >= 2.7, 41 | QuickCheck >= 2.14 && < 2.15 42 | ghc-options: -Wall 43 | 44 | benchmark bench-vocoder-conduit 45 | default-language: Haskell2010 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: benchmarks 48 | main-is: main.hs 49 | build-depends: base, vector, vector-fftw, conduit, vocoder, vocoder-conduit, 50 | gauge >= 0.2.5 51 | ghc-options: -Wall -rtsopts 52 | 53 | 54 | -------------------------------------------------------------------------------- /vocoder-dunai/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1.0.0 2 | 3 | Initial version. 4 | 5 | -------------------------------------------------------------------------------- /vocoder-dunai/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Marek Materzok 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /vocoder-dunai/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /vocoder-dunai/benchmarks/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | import Gauge.Main 4 | import qualified Data.Vector.Storable as V 5 | import Data.Functor.Identity (runIdentity) 6 | import Data.MonadicStreamFunction 7 | import Data.MonadicStreamFunction.InternalCore(unMSF) 8 | import Vocoder.Dunai 9 | 10 | reactimateN :: Monad m => Int -> MSF m () a -> m a 11 | reactimateN 0 msf = fst <$> unMSF msf () 12 | reactimateN n msf = unMSF msf () >>= reactimateN (n-1) . snd 13 | 14 | benchFramesOfS :: Int -> Int -> Int -> Int -> Benchmarkable 15 | benchFramesOfS inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size -> 16 | runIdentity $ reactimateN size 17 | $ count 18 | >>> arr (V.replicate @Int inputChunkSize) 19 | >>> framesOfS chunkSize hopSize 20 | >>> arr (sum . fmap V.sum) 21 | >>> accumulateWith (+) 0 22 | 23 | benchSumFramesS :: Int -> Int -> Int -> Int -> Benchmarkable 24 | benchSumFramesS inputChunkSize chunkSize hopSize size0 = flip whnf size0 $ \size -> 25 | runIdentity $ reactimateN (size `div` k) 26 | $ count 27 | >>> arr (replicate k . V.replicate @Int inputChunkSize) 28 | >>> sumFramesS chunkSize hopSize 29 | >>> arr V.sum 30 | >>> accumulateWith (+) 0 31 | where k = chunkSize `div` hopSize 32 | 33 | main :: IO () 34 | main = defaultMain 35 | [ bench "framesOfS" $ benchFramesOfS 128 512 32 size0 36 | , bench "sumFramesS" $ benchSumFramesS 512 128 32 size0 37 | ] 38 | where 39 | size0 = 1000 :: Int 40 | 41 | -------------------------------------------------------------------------------- /vocoder-dunai/example/MVarClock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module MVarClock where 5 | 6 | import Data.Time.Clock 7 | import Control.Concurrent.MVar 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Trans.Reader 10 | import FRP.Rhine 11 | 12 | type EventMVarT event m = ReaderT (MVar event) m 13 | 14 | withEventMVar :: MVar event -> EventMVarT event m a -> m a 15 | withEventMVar = flip runReaderT 16 | 17 | withEventMVarS :: Monad m => MVar event -> ClSF (EventMVarT event m) cl a b -> ClSF m cl a b 18 | withEventMVarS = flip runReaderS_ 19 | 20 | data MVarClock event = MVarClock 21 | 22 | instance Semigroup (MVarClock event) where 23 | (<>) _ _ = MVarClock 24 | 25 | instance MonadIO m => Clock (EventMVarT event m) (MVarClock event) where 26 | type Time (MVarClock event) = UTCTime 27 | type Tag (MVarClock event) = event 28 | initClock _ = do 29 | initialTime <- liftIO getCurrentTime 30 | return 31 | ( constM $ do 32 | mvar <- ask 33 | event <- liftIO $ takeMVar mvar 34 | time <- liftIO $ getCurrentTime 35 | return (time, event) 36 | , initialTime 37 | ) 38 | 39 | instance GetClockProxy (MVarClock event) 40 | 41 | mVarClockOn :: MonadIO m => MVar event -> HoistClock (EventMVarT event m) m (MVarClock event) 42 | mVarClockOn mvar = HoistClock 43 | { unhoistedClock = MVarClock 44 | , monadMorphism = withEventMVar mvar 45 | } 46 | 47 | -------------------------------------------------------------------------------- /vocoder-dunai/example/ProcessingTree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module ProcessingTree where 3 | 4 | import Control.Monad.Writer 5 | import Control.Monad.Except 6 | import FRP.Rhine 7 | import Vocoder 8 | import Vocoder.Filter 9 | 10 | type STFTMSF m = MSF m [[STFTFrame]] [STFTFrame] 11 | 12 | data ProcessingTree m = PTSource Int 13 | | PTNamed String 14 | | PTBind String (ProcessingTree m) 15 | | PTMSF (MSF m [STFTFrame] [STFTFrame]) (ProcessingTree m) 16 | | PTFilter (Filter m) (ProcessingTree m) 17 | | PTBinary (STFTFrame -> STFTFrame -> STFTFrame) (ProcessingTree m) (ProcessingTree m) 18 | 19 | elaboratePT :: forall m. Monad m 20 | => m FreqStep 21 | -> ProcessingTree m 22 | -> Maybe (STFTMSF m) 23 | elaboratePT mfs t0 = either (const Nothing) Just r where 24 | (r, e0) = runWriter $ runExceptT $ g e0 t0 25 | g :: [(String, STFTMSF m)] 26 | -> ProcessingTree m 27 | -> ExceptT () (Writer [(String, STFTMSF m)]) (STFTMSF m) 28 | g _ (PTSource k) = return $ arr (!! k) 29 | g e (PTNamed n) | Just v <- lookup n e = return v 30 | | otherwise = throwError () 31 | g e (PTBind n t) = g e t >>= (\v -> tell [(n, v)] >> return v) 32 | g e (PTMSF f t) = (>>> f) <$> g e t 33 | g e (PTFilter f t) = (>>> arrM (\x -> mfs >>= forM x . f)) <$> g e t 34 | g e (PTBinary f t1 t2) = (\m1 m2 -> zipWith f <$> m1 <*> m2) <$> g e t1 <*> g e t2 35 | 36 | numSourcesPT :: (ProcessingTree m) -> Int 37 | numSourcesPT (PTSource k) = k+1 38 | numSourcesPT (PTNamed _) = 0 39 | numSourcesPT (PTBind _ t) = numSourcesPT t 40 | numSourcesPT (PTMSF _ t) = numSourcesPT t 41 | numSourcesPT (PTFilter _ t) = numSourcesPT t 42 | numSourcesPT (PTBinary _ t1 t2) = numSourcesPT t1 `max` numSourcesPT t2 43 | 44 | -------------------------------------------------------------------------------- /vocoder-dunai/example/VocoderJack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, RankNTypes, PatternSynonyms, ViewPatterns #-} 2 | module Main where 3 | 4 | import qualified Sound.JACK as JACK 5 | import Sound.JACK.Exception 6 | import qualified Sound.JACK.Audio as Audio 7 | import qualified Data.Vector.Storable as V 8 | import Data.Array.Storable as A 9 | import Data.List.Split 10 | import Text.Read hiding (lift) 11 | import Control.Monad.Trans.Class(lift) 12 | import Control.Monad.Trans.Reader(ReaderT(..)) 13 | import Control.Monad.Exception.Synchronous(ExceptionalT) 14 | import Control.Concurrent.MVar 15 | import Control.Concurrent 16 | import Control.Monad 17 | import Control.Arrow 18 | import Options.Applicative 19 | import Vocoder 20 | import Vocoder.Filter 21 | import Vocoder.Window 22 | import Vocoder.Dunai 23 | import FRP.Rhine 24 | import MVarClock 25 | import ProcessingTree 26 | 27 | type AudioV = V.Vector Audio.Sample 28 | 29 | type EventIO = EventMVarT [AudioV] IO 30 | 31 | type MyClock = HoistClock EventIO IO (MVarClock [AudioV]) 32 | 33 | type MyMonad = ReaderT (TimeInfo MyClock) IO 34 | 35 | data WindowType = BoxWindow | HammingWindow | HannWindow | BlackmanWindow | FlatTopWindow deriving (Read, Show) 36 | 37 | data Cmd = SourceCmd Int | MSFCmd (MSF MyMonad [STFTFrame] [STFTFrame]) | FilterCmd (Filter MyMonad) | NamedCmd String | BindCmd String | BinaryCmd (STFTFrame -> STFTFrame -> STFTFrame) 38 | 39 | data Options = Options { 40 | optClientName :: String, 41 | optMaybeFrameSize :: Maybe Length, 42 | optWindowSize :: Length, 43 | optHopSize :: HopSize, 44 | optWindowType :: WindowType, 45 | optProcessingTree :: ProcessingTree MyMonad 46 | } 47 | 48 | optFrameSize :: Options -> Length 49 | optFrameSize opts = maybe (optWindowSize opts) id $ optMaybeFrameSize opts 50 | 51 | optWindow :: Options -> Window 52 | optWindow opts = windowFun (optWindowType opts) (optWindowSize opts) 53 | 54 | optSources :: Options -> Int 55 | optSources opts = numSourcesPT $ optProcessingTree opts 56 | 57 | windowFun :: WindowType -> Length -> Window 58 | windowFun BoxWindow = boxWindow 59 | windowFun HammingWindow = hammingWindow 60 | windowFun HannWindow = hannWindow 61 | windowFun BlackmanWindow = blackmanWindow 62 | windowFun FlatTopWindow = flatTopWindow 63 | 64 | paramsFor :: Options -> VocoderParams 65 | paramsFor opts = vocoderParams (optFrameSize opts) (optHopSize opts) (optWindow opts) 66 | 67 | auto2 :: (Read a, Read b) => ReadM (a, b) 68 | auto2 = maybeReader $ f . splitOn "," 69 | where 70 | f [a,b] = (,) <$> readMaybe a <*> readMaybe b 71 | f _ = Nothing 72 | 73 | auto3 :: (Read a, Read b, Read c) => ReadM (a, b, c) 74 | auto3 = maybeReader $ f . splitOn "," 75 | where 76 | f [a,b,c] = (,,) <$> readMaybe a <*> readMaybe b <*> readMaybe c 77 | f _ = Nothing 78 | 79 | uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) 80 | uncurry3 f (a,b,c) = f a b c 81 | 82 | processingP :: Parser (ProcessingTree MyMonad) 83 | processingP = parseCommands <$> many commandP 84 | 85 | ptht :: [ProcessingTree MyMonad] -> [ProcessingTree MyMonad] 86 | ptht (h:t) = h:t 87 | ptht [] = [PTSource 0] 88 | 89 | infixr :? 90 | 91 | pattern (:?) :: ProcessingTree MyMonad 92 | -> [ProcessingTree MyMonad] 93 | -> [ProcessingTree MyMonad] 94 | pattern h :? t <- (ptht -> h:t) 95 | 96 | parseCommands :: [Cmd] -> ProcessingTree MyMonad 97 | parseCommands cmds = p [] cmds 98 | where 99 | p (h :? _) [] = h 100 | p s (SourceCmd k : t) = p (PTSource k : s) t 101 | p s (NamedCmd n : t) = p (PTNamed n : s) t 102 | p (h :? s) (MSFCmd f : t) = p (PTMSF f h : s) t 103 | p (h :? s) (FilterCmd f : t) = p (PTFilter f h : s) t 104 | p (h :? i :? s) (BinaryCmd f : t) = p (PTBinary f i h : s) t 105 | p (h :? s) (BindCmd n : t) = p (PTBind n h : s) t 106 | 107 | mkBinary :: (Double -> Double -> Double) 108 | -> (Double -> Double -> Double) 109 | -> STFTFrame -> STFTFrame -> STFTFrame 110 | mkBinary op1 op2 (mag1, ph_inc1) (mag2, ph_inc2) = (V.zipWith op1 mag1 mag2, V.zipWith op2 ph_inc1 ph_inc2) 111 | 112 | commandP :: Parser Cmd 113 | commandP = FilterCmd <$> filterP 114 | <|> MSFCmd <$> msfP 115 | <|> (SourceCmd <$> option auto 116 | ( long "source" 117 | <> metavar "NUM" 118 | <> help "Source from JACK input")) 119 | <|> (NamedCmd <$> option auto 120 | ( long "named" 121 | <> metavar "NAME" 122 | <> help "Source from named stream")) 123 | <|> (BindCmd <$> option auto 124 | ( long "bind" 125 | <> metavar "NAME" 126 | <> help "Bind stream to name")) 127 | <|> (flag' (BinaryCmd $ mkBinary (*) (+)) 128 | ( long "multiply" 129 | <> help "Multiply two streams")) 130 | <|> (flag' (BinaryCmd $ mkBinary (/) (-)) 131 | ( long "divide" 132 | <> help "Divide two streams")) 133 | <|> (flag' (BinaryCmd addFrames) 134 | ( long "add" 135 | <> help "Add two streams")) 136 | 137 | delayMSF :: Int -> MSF MyMonad [STFTFrame] [STFTFrame] 138 | delayMSF k = mealy f [] 139 | where 140 | f i s = (take (length i) s', drop (length s' - k) s') where s' = s ++ i 141 | 142 | msfP :: Parser (MSF MyMonad [STFTFrame] [STFTFrame]) 143 | msfP = (delayMSF <$> option auto 144 | ( long "delay" 145 | <> metavar "HOPS" 146 | <> help "Delay the signal by some number of STFT hops")) 147 | 148 | filterP :: Parser (Filter MyMonad) 149 | filterP = (lowpassBrickwall <$> option auto 150 | ( long "lowpassBrickwall" 151 | <> metavar "FREQ" 152 | <> help "Low-pass brickwall filter")) 153 | <|> (highpassBrickwall <$> option auto 154 | ( long "highpassBrickwall" 155 | <> metavar "FREQ" 156 | <> help "High-pass brickwall filter")) 157 | <|> (uncurry bandpassBrickwall <$> option auto2 158 | ( long "bandpassBrickwall" 159 | <> metavar "FREQ,FREQ" 160 | <> help "Band-pass brickwall filter")) 161 | <|> (uncurry bandstopBrickwall <$> option auto2 162 | ( long "bandstopBrickwall" 163 | <> metavar "FREQ,FREQ" 164 | <> help "Band-stop brickwall filter")) 165 | <|> (uncurry lowpassButterworth <$> option auto2 166 | ( long "lowpassButterworth" 167 | <> metavar "DEG,FREQ" 168 | <> help "Low-pass Butterworth-style filter")) 169 | <|> (uncurry highpassButterworth <$> option auto2 170 | ( long "highpassButterworth" 171 | <> metavar "DEG,FREQ" 172 | <> help "High-pass Butterworth-style filter")) 173 | <|> (uncurry3 bandpassButterworth <$> option auto3 174 | ( long "bandpassButterworth" 175 | <> metavar "DEG,FREQ,FREQ" 176 | <> help "Band-pass Butterworth-style filter")) 177 | <|> (uncurry3 bandstopButterworth <$> option auto3 178 | ( long "bandstopButterworth" 179 | <> metavar "DEG,FREQ,FREQ" 180 | <> help "Band-stop Butterworth-style filter")) 181 | <|> (amplify <$> option auto 182 | ( long "amplify" 183 | <> metavar "COEFF" 184 | <> help "Change amplitude")) 185 | <|> (pitchShiftInterpolate <$> option auto 186 | ( long "pitchShiftInterpolate" 187 | <> metavar "COEFF" 188 | <> help "Interpolative pitch-shift")) 189 | <|> (envelopeFilter <$> option auto 190 | ( long "envelope" 191 | <> metavar "KSIZE" 192 | <> help "Calculate spectral envelope")) 193 | <|> (flag' (randomPhaseFilter) 194 | ( long "randomPhase" 195 | <> help "Randomize phases (Paulstretch effect)")) 196 | 197 | options :: Parser Options 198 | options = Options 199 | <$> option auto 200 | ( long "clientName" 201 | <> metavar "NAME" 202 | <> value "vocoder-jack" 203 | <> help "JACK client name") 204 | <*> optional (option auto 205 | ( long "frameSize" 206 | <> metavar "SIZE" 207 | <> help "Size of zero-padded FFT frame, must be >= windowSize")) 208 | <*> option auto 209 | ( long "windowSize" 210 | <> metavar "SIZE" 211 | <> value 1024 212 | <> showDefault 213 | <> help "Size of STFT window, must be divisible by hopSize") 214 | <*> option auto 215 | ( long "hopSize" 216 | <> metavar "SIZE" 217 | <> value 128 218 | <> showDefault 219 | <> help "STFT hop size, must be a power of 2") 220 | <*> option auto 221 | ( long "windowType" 222 | <> metavar "TYPE" 223 | <> value BlackmanWindow 224 | <> showDefault 225 | <> help "Type of STFT window") 226 | <*> processingP 227 | 228 | runFilter :: JACK.Client -> Options -> ClSF IO MyClock [[STFTFrame]] [STFTFrame] 229 | runFilter client opts = ret 230 | where 231 | freqStep = do 232 | rate <- liftIO $ JACK.getSampleRate client 233 | return $ fromIntegral rate / fromIntegral (optFrameSize opts) 234 | (Just ret) = elaboratePT freqStep (optProcessingTree opts) 235 | 236 | processing :: JACK.Client -> Options -> MVar AudioV -> ClSF IO MyClock () () 237 | processing client opts omvar = 238 | tagS 239 | >>> arr (map $ V.map realToFrac) 240 | >>> ((analysisSrcs srcs >>> runFilter client opts >>> synthesis par (zeroPhase par)) &&& arr (V.length . head)) 241 | >>> sumFramesWithLengthS (vocHopSize par) >>> volumeFix par 242 | >>> arr (V.map realToFrac) 243 | >>> arrMCl (liftIO . fmap (const ()) . tryPutMVar omvar) 244 | where 245 | par = paramsFor opts 246 | srcs = optSources opts 247 | analysisSrcs 0 = pure [] 248 | analysisSrcs k = (:) <$> (arr (!! (srcs-k)) >>> framesOfS (vocInputFrameLength par) (vocHopSize par) >>> analysis par (zeroPhase par)) <*> analysisSrcs (k-1) 249 | 250 | main :: IO () 251 | main = execParser opts >>= run 252 | where 253 | opts = info (options <**> helper) 254 | ( fullDesc 255 | <> progDesc "Process JACK stream" 256 | <> header "Phase vocoder audio processing") 257 | 258 | withInputPorts :: (ThrowsPortRegister e, ThrowsErrno e) 259 | => JACK.Client 260 | -> Options 261 | -> ([Audio.Port JACK.Input] -> ExceptionalT e IO a) 262 | -> ExceptionalT e IO a 263 | withInputPorts client opts cont = f (optSources opts) [] where 264 | f 0 l = cont l 265 | f k l = JACK.withPort client ("input" ++ show k) $ \iport -> f (k-1) (iport:l) 266 | 267 | run :: Options -> IO () 268 | run opts = do 269 | imvar <- newEmptyMVar 270 | omvar <- newEmptyMVar 271 | JACK.handleExceptions $ 272 | JACK.withClientDefault (optClientName opts) $ \client -> 273 | withInputPorts client opts $ \iports -> 274 | JACK.withPort client "output" $ \oport -> 275 | JACK.withProcess client (lift . processJack imvar omvar iports oport) $ 276 | JACK.withActivation client $ do 277 | _ <- lift $ forkIO $ flow $ processing client opts omvar @@ mVarClockOn imvar 278 | lift $ JACK.waitForBreak 279 | 280 | processJack :: MVar [AudioV] -> MVar AudioV -> [Audio.Port JACK.Input] -> Audio.Port JACK.Output -> JACK.NFrames -> IO () 281 | processJack imvar omvar iports oport nframes@(JACK.NFrames frames) = do 282 | iArrs <- forM iports $ \iport -> Audio.getBufferArray iport nframes 283 | oArr <- Audio.getBufferArray oport nframes 284 | iVecs <- forM iArrs $ \iArr -> V.generateM (fromIntegral frames) $ \i -> fmap realToFrac $ A.readArray iArr $ JACK.NFrames $ fromIntegral i 285 | _ <- tryPutMVar imvar iVecs 286 | moVec <- tryTakeMVar omvar 287 | case moVec of 288 | Just oVec -> 289 | forM_ (JACK.nframesIndices nframes) $ \ni@(JACK.NFrames i) -> 290 | writeArray oArr ni $ realToFrac $ oVec V.! fromIntegral i 291 | Nothing -> 292 | forM_ (JACK.nframesIndices nframes) $ \ni -> 293 | writeArray oArr ni 0 294 | 295 | -------------------------------------------------------------------------------- /vocoder-dunai/src/Vocoder/Dunai.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder.Dunai 3 | Description : Phase vocoder in Dunai 4 | Copyright : (c) Marek Materzok, 2021 5 | License : BSD2 6 | 7 | This module wraps phase vocoder algorithms for use in Dunai and Rhine. 8 | -} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE BangPatterns #-} 11 | module Vocoder.Dunai ( 12 | volumeFix, 13 | analysis, 14 | synthesis, 15 | processFrames, 16 | process, 17 | framesOfS, 18 | sumFramesS, 19 | sumFramesWithLengthS 20 | ) where 21 | 22 | import Data.MonadicStreamFunction 23 | import Data.Tuple(swap) 24 | import Data.Maybe(fromMaybe) 25 | import qualified Data.Vector.Storable as V 26 | import Vocoder 27 | 28 | -- | Perform the phase vocoder analysis phase. 29 | analysis :: (Traversable t, Monad m) => VocoderParams -> Phase -> MSF m (t Frame) (t STFTFrame) 30 | analysis par = mealy $ \a s -> swap $ analysisStage par s a 31 | 32 | -- | Perform the phase vocoder synthesis phase. 33 | synthesis :: (Traversable t, Monad m) => VocoderParams -> Phase -> MSF m (t STFTFrame) (t Frame) 34 | synthesis par = mealy $ \a s -> swap $ synthesisStage par s a 35 | 36 | -- | Perform frequency domain processing on overlapping frames. 37 | processFrames :: (Traversable t, Monad m) => VocoderParams -> MSF m (t STFTFrame) (t STFTFrame) -> MSF m (t Frame) (t Frame) 38 | processFrames par msf = analysis par (zeroPhase par) >>> msf >>> synthesis par (zeroPhase par) 39 | 40 | -- | Corrects for volume change introduced by STFT processing. 41 | volumeFix :: Monad m => VocoderParams -> MSF m Frame Frame 42 | volumeFix par = arr $ V.map (* volumeCoeff par) 43 | 44 | -- | Perform frequency domain processing on a chunked stream. 45 | -- The chunks' size must be a multiple of the vocoder's hop size. 46 | process :: Monad m => VocoderParams -> MSF m [STFTFrame] [STFTFrame] -> MSF m Frame Frame 47 | process par msf = (framesOfS (vocInputFrameLength par) (vocHopSize par) >>> processFrames par msf) &&& arr V.length 48 | >>> sumFramesWithLengthS (vocHopSize par) >>> volumeFix par 49 | 50 | data P a = P {-# UNPACK #-} !Length {-# UNPACK #-} !(V.Vector a) 51 | 52 | mapP :: (Length -> Length) -> (V.Vector a1 -> V.Vector a2) -> P a1 -> P a2 53 | mapP f g (P n c) = P (f n) (g c) 54 | 55 | -- | Splits a chunked input stream into overlapping frames of constant size 56 | -- suitable for STFT processing. 57 | -- The input and output chunks' size must be a multiple of the vocoder's hop size. 58 | framesOfS :: forall a m. (V.Storable a, Num a, Monad m) => Length -> HopSize -> MSF m (V.Vector a) [V.Vector a] 59 | framesOfS chunkSize hopSize = mealy f $ V.replicate bufLen 0 60 | where 61 | bufHops = (chunkSize-1) `div` hopSize 62 | bufLen = bufHops * hopSize 63 | f :: V.Vector a -> V.Vector a -> ([V.Vector a], V.Vector a) 64 | f nextv q = (outs, q') 65 | where 66 | len = V.length nextv 67 | newBuf = q V.++ nextv 68 | q' = V.drop len newBuf 69 | outs = [V.take chunkSize $ V.drop (k * hopSize) newBuf | k <- [0 .. len `div` hopSize - 1]] 70 | 71 | -- | Builds a chunked output stream from a stream of overlapping frames. 72 | -- The input and output chunks's size must be a multiple of the vocoder's hop size. 73 | sumFramesS :: forall a m. (V.Storable a, Num a, Monad m) => Length -> HopSize -> MSF m [V.Vector a] (V.Vector a) 74 | sumFramesS chunkSize hopSize = arr (id &&& const chunkSize) >>> sumFramesWithLengthS hopSize 75 | 76 | sumFramesWithLengthS :: forall a m. (V.Storable a, Num a, Monad m) => HopSize -> MSF m ([V.Vector a], Length) (V.Vector a) 77 | sumFramesWithLengthS hopSize = mealy f [] 78 | where 79 | f :: ([V.Vector a], Length) -> [P a] -> (V.Vector a, [P a]) 80 | f (nexts, chunkSize) q = (nextv, q'') 81 | where 82 | ith i (P n c0) = fromMaybe 0 $ c0 V.!? (i - n) 83 | q' = q ++ zipWith P [0, hopSize..] nexts 84 | nextv = V.generate chunkSize $ \i -> sum $ fmap (ith i) q' 85 | q'' = map (mapP (+ (-chunkSize)) id) $ dropWhile (\(P n c) -> V.length c + n <= chunkSize) q' 86 | 87 | -------------------------------------------------------------------------------- /vocoder-dunai/test/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | import Test.Hspec 4 | import Test.Hspec.QuickCheck 5 | import Test.QuickCheck 6 | import Data.Functor.Identity (Identity, runIdentity) 7 | import Data.MonadicStreamFunction 8 | import qualified Data.Vector.Storable as V 9 | import Vocoder.Dunai 10 | 11 | shrinkOne :: (a -> [a]) -> [a] -> [[a]] 12 | shrinkOne _ [] = [] 13 | shrinkOne shr (x:xs) = [ x':xs | x' <- shr x ] 14 | ++ [ x:xs' | xs' <- shrinkOne shr xs ] 15 | 16 | runMSFList :: MSF Identity a b -> [a] -> [b] 17 | runMSFList m l = runIdentity $ embed m l 18 | 19 | --equivToList :: Eq b => ([a] -> [b]) -> MSF Identity a b -> [a] -> Bool 20 | --equivToList f c xs = f xs == runMSFList c xs 21 | 22 | equivToListA :: ([[Int]] -> [[Int]]) -> MSF Identity (V.Vector Int) [V.Vector Int] -> [[Int]] -> Bool 23 | equivToListA f c xs = f xs == concat (map (map V.toList) . runMSFList c . map V.fromList $ xs) 24 | 25 | equivToListB :: ([[Int]] -> [[Int]]) -> MSF Identity [V.Vector Int] (V.Vector Int) -> [[[Int]]] -> Bool 26 | equivToListB f c xs = f (concat xs) == (map V.toList . runMSFList c . map (map V.fromList) $ xs) 27 | 28 | listFramesOf :: Int -> Int -> [[Int]] -> [[Int]] 29 | listFramesOf chunkSize hopSize input = 30 | map (\i -> take chunkSize $ drop i cInput) [0, hopSize .. length cInput - chunkSize] 31 | where 32 | cInput = concat input 33 | 34 | listSumFrames :: Int -> Int -> [[Int]] -> [[Int]] 35 | listSumFrames chunkSize hopSize input = map (\i -> take chunkSize $ drop i cOutput) [0, chunkSize .. lastLength] 36 | where 37 | cOutput = foldl1 (zipWith (+)) $ zipWith (\k l -> replicate k 0 ++ l ++ repeat 0) [0, hopSize..] input 38 | lastLength = maximum $ -1 : zipWith (\k l -> k + length l - 1) [0, hopSize..] input 39 | 40 | genBlocks :: Arbitrary a => Int -> Gen [[a]] 41 | genBlocks blockSize = resize (maximum [5, 1000 `div` blockSize]) $ listOf $ vector blockSize 42 | 43 | shrinkBlocks :: [[Int]] -> [[[Int]]] 44 | shrinkBlocks = shrinkList $ shrinkOne shrink 45 | 46 | genChunks :: Arbitrary a => Int -> Int -> Gen [[[a]]] 47 | genChunks blockM chunkSize = resize (maximum [5, 1000 `div` blockM `div` chunkSize]) $ listOf $ vectorOf blockM $ vector chunkSize 48 | 49 | shrinkChunks :: [[[Int]]] -> [[[[Int]]]] 50 | shrinkChunks = shrinkList $ shrinkOne $ shrinkOne shrink 51 | 52 | main :: IO () 53 | main = hspec $ do 54 | prop "framesOfS" $ \(Positive (Small chunkM)) (Positive (Small blockM)) (Positive (Small hopSize)) -> 55 | let blockSize = blockM * hopSize 56 | chunkSize = chunkM * hopSize 57 | in forAllShrink (genBlocks blockSize) shrinkBlocks $ 58 | equivToListA (listFramesOf chunkSize hopSize . (replicate (chunkSize - hopSize) 0 :)) (framesOfS chunkSize hopSize) 59 | prop "sumFramesS" $ \(Positive (Small chunkM)) (Positive (Small blockM)) (Positive (Small hopSize)) -> 60 | let blockSize = blockM * hopSize 61 | chunkSize = chunkM * hopSize 62 | in forAllShrink (genChunks blockM chunkSize) shrinkChunks $ \l -> 63 | equivToListB (take (length l) . listSumFrames blockSize hopSize) (sumFramesS blockSize hopSize) l 64 | 65 | 66 | -------------------------------------------------------------------------------- /vocoder-dunai/vocoder-dunai.cabal: -------------------------------------------------------------------------------- 1 | name: vocoder-dunai 2 | version: 0.1.0.0 3 | homepage: https://github.com/tilk/vocoder 4 | synopsis: Phase vocoder for Dunai and Rhine 5 | description: 6 | This package wraps the algorithms provided by the vocoder package 7 | for use with Dunai and Rhine FRP libraries. This allows convenient 8 | (soft) real-time frequency domain signal processing. 9 | license: BSD2 10 | license-file: LICENSE 11 | author: Marek Materzok 12 | maintainer: tilk@tilk.eu 13 | -- copyright: 14 | category: Sound 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md 17 | cabal-version: >=1.10 18 | 19 | flag buildExamples 20 | description: Build example executables 21 | default: False 22 | 23 | library 24 | exposed-modules: Vocoder.Dunai 25 | -- other-modules: 26 | -- other-extensions: 27 | build-depends: base >=4.11 && <4.15, 28 | vector >= 0.12.1.0 && <0.13, 29 | vector-fftw >= 0.1.3.8 && < 0.2, 30 | dunai >= 0.7.0 && < 0.8, 31 | vocoder >= 0.1.0.0 && < 0.2 32 | hs-source-dirs: src 33 | ghc-options: -Wall 34 | default-language: Haskell2010 35 | 36 | executable vocoder-jack 37 | main-is: VocoderJack.hs 38 | other-modules: MVarClock, ProcessingTree 39 | hs-source-dirs: example 40 | if flag(buildExamples) 41 | build-depends: base, vocoder, vocoder-dunai, transformers, vector, array, time, 42 | explicit-exception, 43 | mtl >= 2.2.2 && < 2.3, 44 | rhine >= 0.7.0 && < 0.8, 45 | jack >= 0.7.1.4 && < 0.8, 46 | optparse-applicative >= 0.16.0.0 && < 0.17, 47 | split >= 0.2.3.4 && < 0.3 48 | else 49 | buildable: False 50 | ghc-options: -Wall -threaded 51 | default-language: Haskell2010 52 | 53 | test-suite test-vocoder-dunai 54 | default-language: Haskell2010 55 | type: exitcode-stdio-1.0 56 | hs-source-dirs: test 57 | main-is: main.hs 58 | build-depends: base, vector, vector-fftw, dunai, vocoder, vocoder-dunai, 59 | hspec >= 2.7, 60 | QuickCheck >= 2.14 && < 2.15 61 | ghc-options: -Wall 62 | 63 | benchmark bench-vocoder-dunai 64 | default-language: Haskell2010 65 | type: exitcode-stdio-1.0 66 | hs-source-dirs: benchmarks 67 | main-is: main.hs 68 | build-depends: base, vector, vector-fftw, dunai, vocoder, vocoder-dunai, 69 | gauge >= 0.2.5 70 | ghc-options: -Wall -rtsopts 71 | 72 | 73 | -------------------------------------------------------------------------------- /vocoder/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1.0.0 2 | 3 | Initial version. 4 | 5 | -------------------------------------------------------------------------------- /vocoder/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020, Marek Materzok 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /vocoder/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /vocoder/src/Vocoder.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder 3 | Description : Phase vocoder 4 | Copyright : (c) Celina Pawlińska, 2020 5 | Marek Materzok, 2021 6 | License : BSD2 7 | 8 | This module implements the phase vocoder algorithms. 9 | The implementation is designed to be used directly or to be integrated 10 | into some convenient abstraction (streaming or FRP). 11 | -} 12 | module Vocoder ( 13 | Moduli, 14 | Phase, 15 | PhaseInc, 16 | Frame, 17 | Window, 18 | HopSize, 19 | Length, 20 | STFTFrame, 21 | FFTOutput, 22 | VocoderParams, 23 | vocoderParams, 24 | vocFrameLength, 25 | vocInputFrameLength, 26 | vocFreqFrameLength, 27 | vocHopSize, 28 | vocWindow, 29 | doFFT, 30 | doIFFT, 31 | analysisBlock, 32 | analysisStep, 33 | analysisStage, 34 | synthesisBlock, 35 | synthesisStep, 36 | synthesisStage, 37 | zeroPhase, 38 | volumeCoeff, 39 | frameFromComplex, 40 | frameToComplex, 41 | addFrames 42 | ) where 43 | 44 | import Data.List 45 | import Data.Complex 46 | import Data.Fixed 47 | import Data.Tuple 48 | import Control.Arrow 49 | import Numeric.FFT.Vector.Invertible as FFT 50 | import Numeric.FFT.Vector.Plan as FFTp 51 | import qualified Data.Vector.Storable as V 52 | 53 | -- | Complex moduli of FFT frames. Represent signal amplitudes. 54 | type Moduli = V.Vector Double 55 | 56 | -- | Complex arguments of FFT frames. Represent signal phases. 57 | type Phase = V.Vector Double 58 | 59 | -- | Phase increments. Represent the deviation of the phase difference 60 | -- between successive frames from the expected difference for the center 61 | -- frequencies of the FFT bins. 62 | type PhaseInc = V.Vector Double 63 | 64 | -- | Time domain frame. 65 | type Frame = V.Vector Double 66 | 67 | -- | Sampled STFT window function. 68 | type Window = Frame 69 | 70 | -- | Offset between successive STFT frames, in samples. 71 | type HopSize = Int 72 | 73 | -- | Size in samples. 74 | type Length = Int 75 | 76 | -- | STFT processing unit. 77 | type STFTFrame = (Moduli, PhaseInc) 78 | 79 | -- | Frequency domain frame. 80 | type FFTOutput = V.Vector (Complex Double) 81 | 82 | -- | Type of FFT plans for real signals. 83 | type FFTPlan = FFTp.Plan Double (Complex Double) 84 | 85 | -- | Type of IFFT plans for real signals. 86 | type IFFTPlan = FFTp.Plan (Complex Double) Double 87 | 88 | -- | Configuration parameters for the phase vocoder algorithm. 89 | data VocoderParams = VocoderParams{ 90 | -- | FFT plan used in analysis stage. 91 | vocFFTPlan :: FFTPlan, 92 | -- | FFT plan used in synthesis stage. 93 | vocIFFTPlan :: IFFTPlan, 94 | -- | STFT hop size. 95 | vocHopSize :: HopSize, 96 | -- | Window function used during analysis and synthesis. 97 | vocWindow :: Window 98 | -- TODO thread safety? 99 | } 100 | 101 | -- | FFT frequency frame length. 102 | vocFreqFrameLength :: VocoderParams -> Length 103 | vocFreqFrameLength par = planOutputSize $ vocFFTPlan par 104 | 105 | -- | FFT frame length. Can be larger than `vocInputFrameLength` for zero-padding. 106 | vocFrameLength :: VocoderParams -> Length 107 | vocFrameLength par = planInputSize $ vocFFTPlan par 108 | 109 | -- | STFT frame length. 110 | vocInputFrameLength :: VocoderParams -> Length 111 | vocInputFrameLength par = V.length $ vocWindow par 112 | 113 | -- | Create a vocoder configuration. 114 | vocoderParams :: Length -> HopSize -> Window -> VocoderParams 115 | vocoderParams len hs wnd = VocoderParams (plan dftR2C len) (plan dftC2R len) hs wnd 116 | 117 | -- | Apply a window function on a time domain frame. 118 | applyWindow :: Window -> Frame -> Frame 119 | applyWindow = V.zipWith (*) 120 | 121 | -- | Change the vector indexing so that the sample at the middle has the number 0. 122 | -- This is done so that the FFT of the window has zero phase, and therefore does not 123 | -- introduce phase shifts in the signal. 124 | rewind :: (V.Storable a) => V.Vector a -> V.Vector a 125 | rewind vec = uncurry (V.++) $ swap $ V.splitAt (V.length vec `div` 2) vec 126 | 127 | -- | Zero-pad the signal symmetrically from both sides. 128 | addZeroPadding :: Length 129 | -> Frame 130 | -> Frame 131 | addZeroPadding len v 132 | | diff < 0 = error $ "addZeroPadding: input is " ++ (show diff) ++ " samples longer than target length" 133 | | diff == 0 = v 134 | | otherwise = res 135 | where 136 | l = V.length v 137 | diff = len - l 138 | halfdiff = diff - (diff `div` 2) 139 | res = (V.++) ((V.++) (V.replicate halfdiff 0) v) (V.replicate (diff-halfdiff) 0) 140 | 141 | -- | Perform FFT processing, which includes the actual FFT, rewinding, zero-paddding 142 | -- and windowing. 143 | doFFT :: VocoderParams -> Frame -> FFTOutput 144 | doFFT par = 145 | FFT.execute (vocFFTPlan par) . rewind . addZeroPadding (vocFrameLength par) . applyWindow (vocWindow par) 146 | 147 | -- | Perform analysis on a sequence of frames. This consists of FFT processing 148 | -- and performing analysis on frequency domain frames. 149 | analysisStage :: Traversable t => VocoderParams -> Phase -> t Frame -> (Phase, t STFTFrame) 150 | analysisStage par ph = mapAccumL (analysisBlock par) ph 151 | 152 | -- | Perform FFT transform and frequency-domain analysis. 153 | analysisBlock :: VocoderParams -> Phase -> Frame -> (Phase, STFTFrame) 154 | analysisBlock par prev_ph vec = analysisStep (vocHopSize par) (vocFrameLength par) prev_ph (doFFT par vec) 155 | 156 | -- | Analyze a frequency domain frame. Phase from a previous frame must be supplied. 157 | -- It returns the phase of the analyzed frame and the result. 158 | analysisStep :: HopSize -> Length -> Phase -> FFTOutput -> (Phase, STFTFrame) 159 | analysisStep h eN prev_ph vec = 160 | (ph,(mag,ph_inc)) 161 | where 162 | (mag, ph) = frameFromComplex vec 163 | ph_inc = V.imap (calcPhaseInc eN h) $ V.zipWith (-) ph prev_ph 164 | 165 | -- | Wraps an angle (in radians) to the range [-pi : pi]. 166 | wrap :: Double -> Double 167 | wrap e = (e+pi) `mod'` (2*pi) - pi 168 | 169 | calcPhaseInc :: Length -> HopSize -> Int -> Double -> Double 170 | calcPhaseInc eN hop k ph_diff = 171 | (omega + wrap (ph_diff - omega)) / fromIntegral hop 172 | where 173 | omega = (2*pi*fromIntegral k*fromIntegral hop) / fromIntegral eN 174 | 175 | -- | Perform synthesis on a sequence of frames. This consists of performing 176 | -- synthesis and IFFT processing. 177 | synthesisStage :: Traversable t => VocoderParams -> Phase -> t STFTFrame -> (Phase, t Frame) 178 | synthesisStage par ph frs = mapAccumL (synthesisBlock par) ph frs 179 | 180 | -- | Perform frequency-domain synthesis and IFFT transform. 181 | synthesisBlock :: VocoderParams -> Phase -> STFTFrame -> (Phase, Frame) 182 | synthesisBlock par ph fr = (id *** doIFFT par) $ synthesisStep (vocHopSize par) ph fr 183 | 184 | -- | Synthesize a frequency domain frame. Phase from the previously synthesized frame 185 | -- must be supplied. It returns the phase of the synthesized frame and the result. 186 | synthesisStep :: HopSize -> Phase -> STFTFrame -> (Phase, FFTOutput) 187 | synthesisStep hop ph (mag, ph_inc) = 188 | (new_ph, frameToComplex (mag, new_ph)) 189 | where 190 | new_ph = V.zipWith (+) ph $ V.map (* fromIntegral hop) ph_inc 191 | 192 | -- | Perform IFFT processing, which includes the actual IFFT, rewinding, removing padding 193 | -- and windowing. 194 | doIFFT :: VocoderParams -> FFTOutput -> Frame 195 | doIFFT par = 196 | applyWindow (vocWindow par) . cutCenter (vocInputFrameLength par) . rewind . FFT.execute (vocIFFTPlan par) 197 | 198 | -- | Cut the center of a time domain frame, discarding zero padding. 199 | cutCenter :: (V.Storable a) => Length -> V.Vector a -> V.Vector a 200 | cutCenter len vec = V.take len $ V.drop ((V.length vec - len) `div` 2) vec 201 | 202 | -- | Zero phase for a given vocoder configuration. 203 | -- Can be used to initialize the synthesis stage. 204 | zeroPhase :: VocoderParams -> Phase 205 | zeroPhase par = V.replicate (vocFreqFrameLength par) 0 206 | 207 | -- | An amplitude change coefficient for the processing pipeline. 208 | -- Can be used to ensure that the output has the same volume as the input. 209 | volumeCoeff :: VocoderParams -> Double 210 | volumeCoeff par = fromIntegral (vocHopSize par) / V.sum (V.map (**2) $ vocWindow par) 211 | 212 | -- | Converts frame representation to complex numbers. 213 | frameToComplex :: STFTFrame -> FFTOutput 214 | frameToComplex = uncurry $ V.zipWith mkPolar 215 | 216 | -- | Converts frame representation to magnitude and phase. 217 | frameFromComplex :: FFTOutput -> STFTFrame 218 | frameFromComplex = V.map magnitude &&& V.map phase 219 | 220 | -- | Adds STFT frames. 221 | addFrames :: STFTFrame -> STFTFrame -> STFTFrame 222 | addFrames f1 f2 = frameFromComplex $ V.zipWith (+) (frameToComplex f1) (frameToComplex f2) 223 | 224 | -------------------------------------------------------------------------------- /vocoder/src/Vocoder/Filter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-| 3 | Module : Vocoder.Filter 4 | Description : Frequency-domain filters 5 | Copyright : (c) Marek Materzok, 2021 6 | License : BSD2 7 | 8 | This module defines some useful frequency-domain filters for use in 9 | the vocoder framework. 10 | -} 11 | module Vocoder.Filter ( 12 | FreqStep, 13 | Filter, 14 | composeFilters, 15 | addFilters, 16 | idFilter, 17 | amplitudeFilter, 18 | linearAmplitudeFilter, 19 | amplify, 20 | lowpassBrickwall, 21 | highpassBrickwall, 22 | bandpassBrickwall, 23 | bandstopBrickwall, 24 | lowpassButterworth, 25 | highpassButterworth, 26 | bandpassButterworth, 27 | bandstopButterworth, 28 | pitchShiftInterpolate, 29 | convolution, 30 | convolutionFilter, 31 | envelope, 32 | envelopeFilter, 33 | randomPhaseFilter 34 | ) where 35 | 36 | import Vocoder 37 | import Vocoder.Window 38 | import Control.Monad 39 | import Control.Monad.IO.Class 40 | import System.Random 41 | import qualified Data.Vector.Storable as V 42 | 43 | -- | A frequency step is a coefficient relating physical frequency (in Hz) 44 | -- to FFT bin numbers. It is used to define filters independently of the 45 | -- FFT window size. 46 | type FreqStep = Double 47 | 48 | -- | The type of frequency-domain filters. A frequency-domain filter is 49 | -- a function transforming STFT frames which can depend on the 50 | -- frequency step. 51 | type Filter m = FreqStep -> STFTFrame -> m STFTFrame 52 | 53 | -- | Sequential composition of filters. 54 | composeFilters :: Monad m => Filter m -> Filter m -> Filter m 55 | composeFilters f1 f2 step = f1 step >=> f2 step 56 | 57 | -- | Addition of filters. 58 | addFilters :: Monad m => Filter m -> Filter m -> Filter m 59 | addFilters f1 f2 step fr = addFrames <$> f1 step fr <*> f2 step fr 60 | 61 | -- | Identity filter. 62 | idFilter :: Monad m => Filter m 63 | idFilter _ = return 64 | 65 | -- | Creates a filter which transforms only amplitudes, leaving phase 66 | -- increments unchanged. 67 | amplitudeFilter :: Monad m => (FreqStep -> Moduli -> Moduli) -> Filter m 68 | amplitudeFilter f step (mag, ph_inc) = return (f step mag, ph_inc) 69 | 70 | -- | Creates a filter which transforms amplitudes and zeroes the phase 71 | -- increments. 72 | amplitudeFilter0 :: Monad m => (FreqStep -> Moduli -> Moduli) -> Filter m 73 | amplitudeFilter0 f step (mag, ph_inc) = return (f step mag, V.replicate (V.length ph_inc) 0) 74 | 75 | -- | Creates a filter which scales amplitudes depending on frequency. 76 | linearAmplitudeFilter :: Monad m => (Double -> Double) -> Filter m 77 | linearAmplitudeFilter f = amplitudeFilter $ \step mag -> V.zipWith (*) mag $ V.generate (V.length mag) $ \k -> f (step * fromIntegral k) 78 | 79 | -- | Creates an "amplifier" which scales all frequencies. 80 | amplify :: Monad m => Double -> Filter m 81 | amplify k = linearAmplitudeFilter (const k) 82 | 83 | -- | Creates a brickwall lowpass filter. 84 | lowpassBrickwall :: Monad m => Double -> Filter m 85 | lowpassBrickwall t = linearAmplitudeFilter $ \x -> if x <= t then 1.0 else 0.0 86 | 87 | -- | Creates a brickwall highpass filter. 88 | highpassBrickwall :: Monad m => Double -> Filter m 89 | highpassBrickwall t = linearAmplitudeFilter $ \x -> if x >= t then 1.0 else 0.0 90 | 91 | -- | Creates a brickwall bandpass filter. 92 | bandpassBrickwall :: Monad m => Double -> Double -> Filter m 93 | bandpassBrickwall t u = linearAmplitudeFilter $ \x -> if x >= t && x <= u then 1.0 else 0.0 94 | 95 | -- | Creates a brickwall bandstop filter. 96 | bandstopBrickwall :: Monad m => Double -> Double -> Filter m 97 | bandstopBrickwall t u = linearAmplitudeFilter $ \x -> if x <= t || x >= u then 1.0 else 0.0 98 | 99 | butterworthGain :: Double -> Double -> Double -> Double 100 | butterworthGain n t x = 1 / sqrt (1 + (x / t)**(2 * n)) 101 | 102 | -- | Creates an n-th degree Butterworth-style lowpass filter. 103 | lowpassButterworth :: Monad m => Double -> Double -> Filter m 104 | lowpassButterworth n t = linearAmplitudeFilter $ butterworthGain n t 105 | 106 | -- | Creates an n-th degree Butterworth-style highpass filter. 107 | highpassButterworth :: Monad m => Double -> Double -> Filter m 108 | highpassButterworth n t = linearAmplitudeFilter $ butterworthGain (-n) t 109 | 110 | -- | Creates an n-th degree Butterworth-style bandpass filter. 111 | bandpassButterworth :: Monad m => Double -> Double -> Double -> Filter m 112 | bandpassButterworth n t u = linearAmplitudeFilter $ \x -> butterworthGain n u x * butterworthGain (-n) t x 113 | 114 | -- | Creates an n-th degree Butterworth-style bandstop filter. 115 | bandstopButterworth :: Monad m => Double -> Double -> Double -> Filter m 116 | bandstopButterworth n t u = linearAmplitudeFilter $ \x -> butterworthGain (-n) t x + butterworthGain n u x 117 | 118 | interpolate :: Double -> V.Vector Double -> V.Vector Double 119 | interpolate n v = V.generate (V.length v) f 120 | where 121 | f x | i + 1 >= V.length v = 0 122 | | otherwise = (1-k) * v V.! i + k * v V.! (i+1) where 123 | x' = n * fromIntegral x 124 | i = floor x' 125 | k = x' - fromIntegral i 126 | 127 | -- | Creates an interpolative pitch-shifting filter. 128 | pitchShiftInterpolate :: Monad m => Double -> Filter m 129 | pitchShiftInterpolate n _ (mag, ph_inc) = return (interpolate n mag, V.map (/n) $ interpolate n ph_inc) 130 | 131 | -- | Convolves the amplitude spectrum using a kernel. 132 | convolution :: V.Vector Double -> Moduli -> Moduli 133 | convolution ker mag = V.generate (V.length mag) $ \k -> V.sum $ flip V.imap ker $ \i v -> v * gmag V.! (i + k) / s 134 | where 135 | h = V.length ker `div` 2 136 | gmag = V.replicate h 0 V.++ mag V.++ V.replicate h 0 137 | s = V.sum ker 138 | 139 | -- | Creates a filter which convolves the spectrum using a kernel. 140 | convolutionFilter :: Monad m => V.Vector Double -> Filter m 141 | convolutionFilter ker = amplitudeFilter0 $ \_ -> convolution ker 142 | 143 | -- | Calculates the envelope of an amplitude spectrum using convolution. 144 | envelope :: Length -> Moduli -> Moduli 145 | envelope ksize = V.map ((+(-ee)) . exp) . convolution ker . V.map (log . (+ee)) 146 | where 147 | ee = 2**(-24) 148 | ker = if ksize <= 3 then boxWindow ksize else blackmanWindow ksize 149 | 150 | -- | Creates a filter which replaces the amplitudes with their envelope. 151 | envelopeFilter :: Monad m => Length -> Filter m 152 | envelopeFilter ksize = amplitudeFilter0 $ \_ -> envelope ksize 153 | 154 | -- | Sets the phase increments so that the bins have horizontal consistency. 155 | -- This erases the phase information, introducing "phasiness". 156 | randomPhaseFilter :: MonadIO m => Filter m 157 | randomPhaseFilter _ (mag, ph_inc) = (mag, ) <$> V.replicateM (V.length ph_inc) (randomRIO (0, 2*pi)) 158 | 159 | -------------------------------------------------------------------------------- /vocoder/src/Vocoder/Window.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Vocoder.Window 3 | Description : Window functions 4 | Copyright : (c) Marek Materzok, 2021 5 | License : BSD2 6 | 7 | This module defines popular window functions for use in the vocoder 8 | framework. 9 | -} 10 | module Vocoder.Window ( 11 | makeWindow, 12 | boxWindow, 13 | triangleWindow, 14 | hammingWindow, 15 | hannWindow, 16 | generalizedBlackmanWindow, 17 | blackmanWindow, 18 | exactBlackmanWindow, 19 | lanczosWindow, 20 | flatTopWindow 21 | ) where 22 | 23 | import Vocoder 24 | import qualified Data.Vector.Storable as V 25 | 26 | -- | Creates a window of given length by sampling a function 27 | -- on the interval [0,1]. 28 | makeWindow :: (Double -> Double) -> Length -> Window 29 | makeWindow f n = V.generate n $ \k -> f (fromIntegral k / (fromIntegral n - 1)) 30 | 31 | -- | Creates a box window. 32 | boxWindow :: Length -> Window 33 | boxWindow = makeWindow $ const 1 34 | 35 | -- | Creates a triangular window. 36 | triangleWindow :: Length -> Window 37 | triangleWindow = makeWindow $ \x -> 2 * (0.5 - abs (x - 0.5)) 38 | 39 | -- | Creates a Hamming window. 40 | hammingWindow :: Length -> Window 41 | hammingWindow = makeWindow $ \x -> alpha - beta * cos (2 * pi * x) 42 | where 43 | alpha = 25.0/46.0 44 | beta = 21.0/46.0 45 | 46 | -- | Creates a Hann window. 47 | hannWindow :: Length -> Window 48 | hannWindow = makeWindow $ \x -> 0.5 * (1 - cos (2 * pi * x)) 49 | 50 | -- | Creates a generalized Blackman window for a given alpha value. 51 | generalizedBlackmanWindow :: Double -> Length -> Window 52 | generalizedBlackmanWindow a = makeWindow $ \x -> let p = 2 * pi * x in a0 - a1 * cos p + a2 * cos (2 * p) 53 | where 54 | a0 = (1 - a) / 2 55 | a1 = 0.5 56 | a2 = a / 2 57 | 58 | -- | Creates a Blackman window (with alpha=0.16). 59 | blackmanWindow :: Length -> Window 60 | blackmanWindow = generalizedBlackmanWindow 0.16 61 | 62 | -- | Creates an exact Blackman window. 63 | exactBlackmanWindow :: Length -> Window 64 | exactBlackmanWindow = makeWindow $ \x -> let p = 2 * pi * x in a0 - a1 * cos p + a2 * cos (2 * p) 65 | where 66 | a0 = 7938.0/18608.0 67 | a1 = 9240.0/18608.0 68 | a2 = 1430.0/18608.0 69 | 70 | -- | Creates a Lanczos window. 71 | lanczosWindow :: Length -> Window 72 | lanczosWindow = makeWindow $ \x -> sinc $ 2 * x - 1 73 | where 74 | sinc 0 = 1 75 | sinc x = sin (pi*x) / (pi*x) 76 | 77 | -- | Creates a flat top window. 78 | flatTopWindow :: Length -> Window 79 | flatTopWindow = makeWindow $ \x -> a0 - a1 * cos (2 * pi * x) + a2 * cos (4 * pi * x) - a3 * cos (6 * pi * x) + a4 * cos (8 * pi * x) 80 | where 81 | a0 = 0.21557895 82 | a1 = 0.41663158 83 | a2 = 0.277263158 84 | a3 = 0.083578947 85 | a4 = 0.006947368 86 | 87 | -------------------------------------------------------------------------------- /vocoder/vocoder.cabal: -------------------------------------------------------------------------------- 1 | name: vocoder 2 | version: 0.1.0.0 3 | homepage: https://github.com/tilk/vocoder 4 | synopsis: Phase vocoder 5 | description: 6 | This package is an implementation of phase vocoder frequency domain 7 | processing algorithms. It has minimal dependencies on external 8 | libraries. It can be used directly, but for most uses it's more 9 | convenient to use a streaming or FRP library wrapper. 10 | Packages vocoder-conduit and vocoder-dunai are provided for this 11 | purpose. 12 | license: BSD2 13 | license-file: LICENSE 14 | author: Marek Materzok 15 | maintainer: tilk@tilk.eu 16 | -- copyright: 17 | category: Sound 18 | build-type: Simple 19 | extra-source-files: ChangeLog.md 20 | cabal-version: >=1.10 21 | 22 | library 23 | exposed-modules: Vocoder, Vocoder.Window, Vocoder.Filter 24 | -- other-modules: 25 | -- other-extensions: 26 | build-depends: base >=4.11 && <4.15, 27 | vector >= 0.12.1.0 && <0.13, 28 | vector-fftw >= 0.1.3.8 && < 0.2, 29 | random >= 1.2.0 && < 1.3 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | ghc-options: -Wall 33 | 34 | --------------------------------------------------------------------------------