sound-collage (empty) → 0.0
raw patch · 5 files changed
+430/−0 lines, 5 filesdep +arraydep +basedep +carraysetup-changed
Dependencies added: array, base, carray, directory, fft, filepath, numeric-prelude, sample-frame, soxlib, storablevector, storablevector-carray, synthesizer-core, temporary, transformers, utility-ht
Files
- LICENSE +26/−0
- Setup.lhs +3/−0
- sound-collage.cabal +44/−0
- src/Main.hs +48/−0
- src/SoundCollage.hs +309/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2014 Henning Thielemann+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the University nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ sound-collage.cabal view
@@ -0,0 +1,44 @@+Name: sound-collage+Version: 0.0+License: BSD3+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+Category: Sound+Synopsis: Approximate a song from other pieces of sound+Description: Approximate a song from other pieces of sound+Tested-With: GHC==7.4.1+Cabal-Version: >=1.6+Build-Type: Simple++Source-Repository this+ Tag: 0.0+ Type: darcs+ Location: http://code.haskell.org/~thielema/sound-collage/++Source-Repository head+ Type: darcs+ Location: http://code.haskell.org/~thielema/sound-collage/++Executable sound-collage+ Build-Depends:+ fft >=0.1.8 && <0.2,+ carray >=0.1.3 && <0.2,+ array >=0.1 && <0.6,+ storablevector-carray >=0.0 && <0.1,+ storablevector >=0.2 && <0.3,+ synthesizer-core >=0.7 && <0.8,+ soxlib >=0.0.1 && <0.1,+ sample-frame >=0.0 && <0.1,+ numeric-prelude >=0.4.1 && <0.5,+ filepath >=1.3 && <1.4,+ temporary >=1.1 && <1.3,+ directory >=1.1 && <1.3,+ transformers >=0.3 && <0.5,+ utility-ht >=0.0.1 && <0.1,+ base >= 3 && <5++ GHC-Options: -Wall+ Hs-source-dirs: src+ Main-Is: Main.hs+ Other-Modules: SoundCollage
+ src/Main.hs view
@@ -0,0 +1,48 @@+module Main where++import qualified SoundCollage++import qualified System.Exit as Exit+import qualified System.IO as IO+import System.Environment (getArgs, )+import System.FilePath ((</>), )+import System.IO.Temp (withSystemTempDirectory, )+++exitFailureMsg :: String -> IO a+exitFailureMsg msg = do+ IO.hPutStrLn IO.stderr msg+ Exit.exitFailure++main :: IO ()+main = do+ args <- getArgs+ case args of+ [] -> exitFailureMsg "action, source and destination missing"+ [_] -> exitFailureMsg "source and destination missing"+ [_,_] -> exitFailureMsg "destination missing"+ ["--decompose", src, dst] ->+ SoundCollage.runDecompose SoundCollage.defltParams src dst+ ["--compose", src, dst] ->+ SoundCollage.runCompose SoundCollage.defltParams src dst+ ["--associate", pool, src, dst] ->+ SoundCollage.runAssociate SoundCollage.defltParams pool src dst+ [pool, src, dst] ->+ withSystemTempDirectory "sound-chunks" $ \chunkDir ->+ withSystemTempDirectory "sound-collage" $ \collDir -> do+ chunkSize <- SoundCollage.chunkSizeFromPool pool+ let params =+ SoundCollage.defltParams {+ SoundCollage.paramShift =+ div chunkSize+ (SoundCollage.paramOverlap SoundCollage.defltParams)+ }+ putStrLn $ "determined chunk size: " ++ show chunkSize+ putStrLn $ "decompose to " ++ chunkDir+ SoundCollage.runDecompose params src+ (chunkDir </> "%06d/%06d")+ putStrLn $ "associate to " ++ collDir+ SoundCollage.runAssociate params pool chunkDir collDir+ putStrLn "compose"+ SoundCollage.runCompose params collDir dst+ _ -> exitFailureMsg "too many arguments"
+ src/SoundCollage.hs view
@@ -0,0 +1,309 @@+{-# 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