{-# LANGUAGE NoImplicitPrelude #-} module Main where import Synthesizer.LLVM.Server.Common (Real) import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Sound.Sox.Write as SoxWrite import qualified Graphics.Gnuplot.Advanced as Plot import qualified Graphics.Gnuplot.Terminal.WXT as WXT import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR import Synthesizer.LLVM.Causal.Process (($*), ($<), ($<#)) import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG import qualified Synthesizer.Generic.Fourier as Fourier import qualified Synthesizer.Generic.Analysis as Analysis import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.Generic.Piece as Piece import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.State.Signal as SigS import Synthesizer.Piecewise ((#|-), (-|#), (#|), (|#)) import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import Control.Arrow (arr, (<<<), (^<<)) import Control.Category ((.), id) import Control.Applicative ((<$>)) import Control.Functor.HT (void) import qualified Data.List.HT as ListHT import qualified Data.List as List import Data.Foldable (forM_) import Data.Maybe.HT (toMaybe) import Data.Maybe (catMaybes) import Data.Tuple.HT (mapSnd) import Data.Ord.HT (comparing) import Data.Monoid (mempty, mappend) import qualified System.Path.PartClass as PathClass import qualified System.Path as Path import System.Path ((), (<.>)) import qualified Number.Complex as Complex import NumericPrelude.Numeric import NumericPrelude.Base hiding (id, (.)) sampleRateInt :: Int sampleRateInt = 44100 sampleRate :: Real sampleRate = fromIntegral sampleRateInt spectrum :: SVL.Vector Real -> SVL.Vector Real spectrum xs = SVL.map Complex.magnitude $ SVL.take (div (SVL.length xs) 2) $ Fourier.transformBackward $ SVL.map Complex.fromReal xs timeDomain :: SVL.Vector Real -> SVL.Vector (Complex.T Real) timeDomain xs = Fourier.transformForward $ SVL.append (SVL.map Complex.fromReal xs) (SVL.replicate SVL.defaultChunkSize (SVL.length xs) 0) chop :: Int -> SVL.Vector Real -> [SVL.Vector Real] chop n = map (SVL.take n) . takeWhile (not . SVL.null) . iterate (SVL.drop n) spectrumPlot :: SVL.Vector Real -> Plot2D.T Real Real spectrumPlot xs = let k = sampleRate / fromIntegral (SVL.length xs) step = 16 avg chunk = SVL.foldl (+) zero chunk / fromIntegral step in Plot2D.list Graph2D.lines $ zip (iterate (fromIntegral step * k +) 0) $ map avg $ chop step $ spectrum xs plotSpectrum :: SVL.Vector Real -> IO () plotSpectrum xs = void $ Plot.plot WXT.cons $ spectrumPlot xs saveSound :: (PathClass.AbsRel ar) => Path.File ar -> SVL.Vector Real -> IO () saveSound path xs = void $ SoxWrite.simple SVL.hPut mempty (Path.toString path) sampleRateInt xs tmpWave :: String -> Path.AbsFile tmpWave name = Path.absDir "/tmp" Path.relFile name <.> "wav" phonemeWave :: String -> Path.RelFile phonemeWave name = Path.relDir "phoneme" Path.relFile name <.> "wav" maskWave :: String -> Path.RelFile maskWave name = Path.relDir "mask" Path.relFile name <.> "wav" loadPhoneme :: String -> IO (SVL.Vector Real) loadPhoneme name = do putStrLn name Sample.load $ phonemeWave name -- * modelling formants using bandpass filters type Formant a = (UniFilter.Result a -> a, Pole Real, Real) formants_a_noise :: [Formant a] formants_a_noise = (UniFilter.bandpass, Pole 20 900, 1) : (UniFilter.bandpass, Pole 20 1200, 0.4) : (UniFilter.bandpass, Pole 10 2600, 0.07) : [] formants_f :: [Formant a] formants_f = (UniFilter.lowpass, Pole 2 4000, 0.6) : (UniFilter.lowpass, Pole 2 11000, 0.3) : [] formants_sch :: [Formant a] formants_sch = (UniFilter.bandpass, Pole 5 1500, 1.3) : (UniFilter.lowpass, Pole 2 3000, 0.6) : [] synthesis :: IO (SVL.ChunkSize -> () -> SVL.Vector Real) synthesis = SigP.runChunky $ (sum (map (\(typ, Pole q f, amp) -> CausalP.amplify (return amp) <<< typ ^<< CtrlP.process $< (SigP.constant $ return $ UniFilter.parameter $ Pole q $ f / sampleRate)) formants_sch) $* SigP.noise 174373 0.02) compareSpec ::IO () compareSpec = do sampled <- Sample.load (phonemeWave "sch") synthesized <- synthesis void $ Plot.plot WXT.cons $ spectrumPlot sampled `mappend` spectrumPlot (SVL.take (SVL.length sampled) $ synthesized (SVL.chunkSize 4096) ()) render ::IO () render = do synthesized <- synthesis saveSound (Path.relFile "sch-synth.wav") $ SVL.take sampleRateInt $ synthesized (SVL.chunkSize 4096) () -- * purification of sampled periods -- ** using a comb filter type Comb = (Real, Int) -> SVL.Vector Real -> SVL.Vector Real makeComb :: IO Comb makeComb = CausalP.runStorableChunky $ CausalP.comb (arr fst) (arr snd) makeHighComb :: IO Comb makeHighComb = CausalP.runStorableChunky $ CausalP.comb (arr fst) (arr snd) . (Filt1.highpassCausal $<# FirstOrder.parameter (1000/sampleRate)) scorePeriod :: Comb -> Real -> Int -> SVL.Vector Real -> (Real, SVL.Vector Real) scorePeriod comb gain period sig = let end = SVL.takeEnd (3*period) $ comb (gain, period) sig in (Analysis.volumeEuclideanSqr end, end) vowelNames :: [String] vowelNames = ["a", "e", "i", "o", "on", "u", "un", "oe", "ue", "ae"] tonalNames :: [String] tonalNames = vowelNames ++ ["l", "m", "n", "ng", "r", "j"] sibilantNames :: [String] sibilantNames = ["f", "h", "w", "s", "sch", "th", "ich", "ach"] stopConsonantNames :: [String] stopConsonantNames = ["p", "k", "t", "b", "g", "d"] scanPeriods ::IO () scanPeriods = do comb <- makeComb forM_ tonalNames $ \name -> do sampled <- loadPhoneme name let scores = flip map [350 .. 400] $ \period -> (period, flip map [0.9, 0.99, 0.999] $ \gain -> fst $ scorePeriod comb gain period sampled) -- mapM_ print scores putStrLn $ "maximum: " ++ show (List.maximumBy (comparing snd) $ map (mapSnd maximum) scores) normalize :: SVL.Vector Real -> SVL.Vector Real normalize = FiltNRG.normalize ((4*) . Analysis.volumeEuclidean) {- We use the zero with the least derivative in order to reduce jumps at the loop point. In order to further reduce jumps, we cross-fade two adjacent periods. It must be @length period3 = 3*len@. @period3@ must contain a zero in the center chunk of size @len@. -} bestRotation :: Int -> SVL.Vector Real -> SVL.Vector Real bestRotation len period3 = let start = fst $ List.minimumBy (comparing snd) $ catMaybes $ zipWith (fmap . (,)) [0..] $ ListHT.mapAdjacent (\x y -> toMaybe (signum x /= signum y) (abs(x-y))) $ SVL.unpack $ SVL.take len $ SVL.drop (len-1) period3 in Causal.apply (Causal.applyFst (FiltNRC.crossfade len) (SVL.drop (start+len) period3)) (SVL.drop start period3) findPeriod :: Comb -> SVL.Vector Real -> SVL.Vector Real findPeriod comb sampled = normalize $ uncurry bestRotation $ mapSnd snd $ List.maximumBy (comparing (fst . snd)) $ flip map [350 .. 400] $ \period -> (period, scorePeriod comb 0.99 period sampled) extractPeriods ::IO () extractPeriods = do comb <- makeHighComb forM_ tonalNames $ \name -> saveSound (maskWave name) . findPeriod comb =<< loadPhoneme name -- ** using the frequency spectrum makeFilter :: IO (SV.Vector Real -> SVL.Vector Real -> SVL.Vector Real) makeFilter = CausalP.runStorableChunky $ FiltNR.convolve id normalizeMax :: SVL.Vector Real -> SVL.Vector Real normalizeMax = FiltNRG.normalize Analysis.volumeMaximum envelope :: Int -> SVL.Vector Real envelope sizeInt = let size = fromIntegral sizeInt rampSize = size / 8 in Piece.run SigG.defaultLazySize $ 0 |# (rampSize, Piece.cosine) #|- 1 -|# (size-2*rampSize, Piece.step) #|- 1 -|# (rampSize, Piece.cosine) #| (0::Float) data Transfer = Transfer { transferSpectrum, transferShrunkenSpectrum, transferEnvelope, transferWindow :: SVL.Vector Real } transfer :: SVL.Vector Real -> Transfer transfer sampled = let halfResponseSize = 256 responseSize = 2*halfResponseSize halfShrink = div (SVL.length sampled) (2*responseSize) shrink = 2*halfShrink spec = spectrum $ SVL.take (shrink*responseSize) sampled shrunkenSpec = SigG.fromState SigG.defaultLazySize $ SigS.init $ SigS.cons 0 $ SigS.map SigG.sum $ SigG.sliceVertical shrink $ SVL.drop halfShrink spec env = envelope responseSize window = FiltNRG.envelope env $ uncurry (flip SVL.append) $ SVL.splitAt halfResponseSize $ normalizeMax $ SVL.map Complex.real $ timeDomain shrunkenSpec in Transfer { transferSpectrum = spec, transferShrunkenSpectrum = shrunkenSpec, transferEnvelope = env, transferWindow = window } testTransfer ::IO () testTransfer = do trans <- transfer <$> Sample.load (phonemeWave "o-noise") filt <- makeFilter saveSound (tmpWave "spectrum") $ normalizeMax $ transferSpectrum trans saveSound (tmpWave "shrunkenspectrum") $ normalizeMax $ transferShrunkenSpectrum trans saveSound (tmpWave "envelope") $ transferEnvelope trans saveSound (tmpWave "window") $ transferWindow trans let window = SV.concat $ SVL.chunks $ transferWindow trans saveSound (tmpWave "filtered") $ filt window $ SVL.concat $ replicate 100 $ SVL.cons 1 $ SVL.replicate SVL.defaultChunkSize 380 0 saveSound (tmpWave "chirp") $ filt window $ SVL.concat $ map (\n -> SVL.cons 1 $ SVL.replicate SVL.defaultChunkSize n 0) $ [350..450] transferMasks ::IO () transferMasks = do -- forM_ (map (++"-noise") vowelNames) $ \name -> do forM_ (tonalNames++sibilantNames++stopConsonantNames) $ \name -> do trans <- transfer <$> loadPhoneme name saveSound (maskWave name) $ normalize $ transferWindow trans let spectrumPath = tmpWave $ "spec-" ++ name saveSound spectrumPath $ normalizeMax $ transferShrunkenSpectrum trans main :: IO () main = transferMasks