{-# LANGUAGE RebindableSyntax #-} {- | Very much inspired by NoiseReduction. -} module SoundCollage ( testChopCompose, runDecompose, runAssociate, runCompose, Parameters(..), defltParams, chunkSizeFromPool, ) where import qualified Sound.SoxLib as SoxLib import qualified Sound.Frame as Sample import qualified Math.FFT as FFT import qualified Synthesizer.Storable.Signal as SigSt import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG import qualified Synthesizer.Basic.Binary as Bin import qualified Data.StorableVector as SV import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector.CArray as SVCArr import qualified System.Directory as Dir import qualified System.FilePath as FilePath import qualified System.IO as IO import System.FilePath ((), ) import Foreign.Storable (Storable, peek, ) import Control.Monad (forM, forM_, zipWithM_, ) import Data.Maybe (fromMaybe, ) import qualified Data.List.Key as Key import qualified Data.List.HT as ListHT import qualified Data.List as List import Data.Tuple.HT (mapPair, ) import Data.List (isSuffixOf, ) import qualified Data.Complex as Complex98 import Data.Int (Int16, ) import Text.Printf (printf, ) import qualified Algebra.Transcendental as Trans import qualified Algebra.RealRing as Real import qualified Algebra.Additive as Additive import NumericPrelude.Numeric import NumericPrelude.Base import qualified Prelude as P pillow :: (Trans.C a, Storable a) => Int -> SV.Vector a pillow n = SV.sample n (\i -> sin (pi * fromIntegral i / fromIntegral n)) chop :: (Additive.C a, Storable a) => Int -> Int -> SVL.Vector a -> [SVL.Vector a] chop numOverlap shift = takeWhile (not . SVL.null) . iterate (SVL.drop shift) . SVL.append (SVL.fromChunks [SV.replicate ((numOverlap-1) * shift) zero]) {- | The chunks in the chunks list must have length numOverlap*shift. This is not checked. If you use the result of 'chop' then you are safe. -} compose :: (Additive.C a, Storable a) => Int -> Int -> [SVL.Vector a] -> SVL.Vector a compose numOverlap shift = foldl1 SigSt.mix . zipWith SVL.drop [0, shift ..] . reverse . map SVL.concat . ListHT.sliceHorizontal numOverlap {- | test reconstruction -} testChopCompose :: IO () testChopCompose = let shift = 42 overlap = 5 chunkSize = shift*overlap pilPre = SVL.fromChunks [pillow chunkSize] pilPost = SVL.map (2 / fromIntegral overlap *) pilPre xs :: SVL.Vector Float xs = SVL.fromChunks [SV.sample 10000 (\i -> cos (pi * fromIntegral i / 10000))] in SVL.writeFile "/tmp/test.f32" $ SVL.zipWith (\_ y -> y) xs $ compose overlap shift $ map (FiltNRG.envelope pilPost) $ map (FiltNRG.envelope pilPre) $ chop overlap shift $ SVL.append xs $ SVL.fromChunks [SV.replicate chunkSize zero] data Parameters = Parameters { paramShift, paramOverlap :: Int } defltParams :: Parameters defltParams = Parameters { paramShift = 1024, paramOverlap = 2 } maxCoeff :: SV.Vector Float -> Int maxCoeff ys = Key.maximum (SV.index ys) $ take (SV.length ys) [0..] featuresFromChunk :: Parameters -> SV.Vector Float -> SV.Vector Float featuresFromChunk _params = SV.map Complex98.magnitude . SVCArr.from . FFT.dftRC . SVCArr.to chopChannel :: Parameters -> SVL.Vector Float -> [SV.Vector Float] chopChannel params input = let shift = paramShift params overlap = paramOverlap params chunkSize = shift*overlap pilPre = pillow chunkSize in takeWhile ((chunkSize==) . SV.length) $ map (FiltNRG.envelope pilPre . SV.concat . SVL.chunks) $ chop overlap shift $ SVL.append input $ SVL.fromChunks [SV.replicate chunkSize zero] spectrumSuffix, chunkSuffix :: String spectrumSuffix = "-spec.f32" chunkSuffix = "-chunk.s16" runDecompose :: Parameters -> FilePath -> FilePath -> IO () runDecompose params src dst = SoxLib.withRead SoxLib.defaultReaderInfo src $ \fmtInPtr -> do fmtIn <- peek fmtInPtr let numChan = fromMaybe 1 $ SoxLib.channels $ SoxLib.signalInfo fmtIn inputs <- fmap (SVL.deinterleave numChan . SVL.map Bin.toCanonical) $ SoxLib.readStorableVectorLazy fmtInPtr (SVL.ChunkSize 16384) let write n (spec,chunk) = do let path = printf dst (maxCoeff spec) (n::Int) Dir.createDirectoryIfMissing True $ FilePath.takeDirectory path SV.writeFile (path ++ spectrumSuffix) spec SV.writeFile (path ++ chunkSuffix) $ (SV.map (Bin.fromCanonicalWith Real.roundSimple) chunk :: SV.Vector Int16) zipWithM_ write [0..] $ uncurry zip $ mapPair (foldl1 (zipWith (SV.zipWith (+))), map SV.concat . List.transpose) $ unzip $ map ((\chunks -> (map (featuresFromChunk params) chunks, chunks)) . chopChannel params) inputs getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents = fmap (filter (not . flip elem [".", ".."])) . Dir.getDirectoryContents replaceSuffix :: FilePath -> FilePath replaceSuffix name = take (length name - length spectrumSuffix) name ++ chunkSuffix fileSize :: FilePath -> IO Integer fileSize path = IO.withFile path IO.ReadMode IO.hFileSize divByteSize :: (Sample.C a) => a -> Integer -> Integer divByteSize x n = div n (fromIntegral (Sample.sizeOfElement x)) chunkSizeFromPool :: FilePath -> IO Int chunkSizeFromPool dir = do dirs <- getDirectoryContents dir firstBucket <- case dirs of [] -> ioError $ userError "chunk size determination: no bucket" bucket:_ -> return bucket files <- fmap (filter (isSuffixOf spectrumSuffix)) $ getDirectoryContents (dir firstBucket) case files of [] -> ioError $ userError "chunk size determination: empty pool" file:_ -> do let path = dir firstBucket file specSize <- fmap (divByteSize (0::Float)) $ fileSize path chunkSize <- fmap (divByteSize (0::Int16)) $ fileSize $ replaceSuffix path return $ fromInteger $ if mod chunkSize (specSize-1) == 0 then (specSize-1)*2 else specSize*2-1 loadSpectra :: FilePath -> IO [(SV.Vector Float, FilePath)] loadSpectra dir = do files <- fmap (filter (isSuffixOf spectrumSuffix)) $ getDirectoryContents dir forM files $ \file -> do spec <- SV.readFile $ dir file return (spec, file) norm2 :: SV.Vector Float -> Float norm2 = sqrt . SV.foldl' (+) 0 . SV.map (\x -> x*x) createSpectrumMap :: Parameters -> FilePath -> IO [(SV.Vector Float, (Float, FilePath))] createSpectrumMap _params poolDir = do files <- loadSpectra poolDir return $ flip map files $ \(spec, file) -> let norm = norm2 spec in (SV.map (/norm) spec, (norm, file)) matchSpectrum :: SV.Vector Float -> SV.Vector Float -> Float matchSpectrum spec dict = SV.foldl' (+) 0 $ SV.zipWith (*) spec dict asVector16 :: SV.Vector Int16 -> SV.Vector Int16 asVector16 = id clip16 :: Float -> Float clip16 = min (fromIntegral (maxBound::Int16)) . max (fromIntegral (minBound::Int16)) associateBucket :: Parameters -> FilePath -> FilePath -> FilePath -> IO () associateBucket params poolDir src dst = do dict <- createSpectrumMap params poolDir files <- loadSpectra src forM_ files $ \(spec, file) -> do let srcNorm = norm2 spec let (poolNorm, matching) = snd $ Key.maximum (matchSpectrum spec . fst) dict SV.writeFile (dst replaceSuffix file) . asVector16 . SV.map (Real.roundSimple . clip16 . (*(srcNorm/poolNorm)) . fromIntegral) . asVector16 =<< SV.readFile (poolDir replaceSuffix matching) merge :: (Ord a) => [a] -> [a] -> [(a,a)] merge = let go (x:xs) yt@(y0:ys0) = if x <= y0 then (x,y0) : go xs yt else case ys0 of [] -> (x,y0) : [] y1:_ys1 -> if x < y1 then (x,y0) : go xs ys0 else go (x:xs) ys0 go [] _ = [] go (_:_) [] = error "merge: second list empty" in go runAssociate :: Parameters -> FilePath -> FilePath -> FilePath -> IO () runAssociate params poolDir src dst = do Dir.createDirectoryIfMissing True dst srcDirs <- fmap List.sort $ getDirectoryContents src poolDirs <- fmap List.sort $ getDirectoryContents poolDir forM_ (merge srcDirs poolDirs) $ \(sdir,pdir) -> associateBucket params (poolDir pdir) (src sdir) dst sliceVertical :: Int -> SV.Vector Float -> [SV.Vector Float] sliceVertical n xs = map (SV.take n . flip SV.drop xs) $ takeWhile (< SV.length xs) $ iterate (n+) 0 runCompose :: Parameters -> FilePath -> FilePath -> IO () runCompose params src dst = do let shift = paramShift params overlap = paramOverlap params chunkSize = shift*overlap pilPost = pillow chunkSize chunks <- mapM (SV.readFile . (src )) . List.sort =<< getDirectoryContents src SVL.writeFile dst $ SVL.interleaveFirstPattern $ map (compose overlap shift) $ List.transpose $ map (map (SVL.fromChunks . (:[]) . FiltNRG.envelope pilPost) . sliceVertical chunkSize . SV.map (Bin.toCanonical :: Int16 -> Float)) $ chunks