sound-collage 0.1 → 0.2
raw patch · 5 files changed
+762/−194 lines, 5 filesdep +Cabaldep +containersdep +pathtypedep −directorydep ~filepathdep ~optparse-applicativedep ~synthesizer-core
Dependencies added: Cabal, containers, pathtype
Dependencies removed: directory
Dependency ranges changed: filepath, optparse-applicative, synthesizer-core, transformers, utility-ht
Files
- sound-collage.cabal +110/−12
- src/Main.hs +97/−40
- src/Option.hs +112/−40
- src/PathFormat.hs +25/−0
- src/SoundCollage.hs +418/−102
sound-collage.cabal view
@@ -1,47 +1,145 @@ Name: sound-collage-Version: 0.1+Version: 0.2 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+Description:+ This program allows you to decompose a set of audio files into chunks+ and use these chunks for building a new audio file+ that matches another given audio file.+ This is very similar to constructing an image+ from small images that are layed out in a rectangular grid.+ .+ The simplest way to use the program consists of the following two steps:+ .+ Step 1: Add chunks from an audio file to the pool:+ .+ > sound-collage --chunksize=8192 decompose track00.wav pool/%06d+ > sound-collage --chunksize=8192 decompose track01.wav pool/%06d+ .+ Attention:+ The chunk size and the number of (stereo) channels+ must be the same for all added files.+ These parameters are not stored in the pool itself+ and thus consistency cannot be checked.+ .+ Adding the same set of audio files to the chunk pool again+ will fool the automatic chunk size determination in the composition step.+ You should not add an audio file twice anyway,+ since it increases disk usage and computation time+ and has no effect to the result.+ .+ Step 2: Compose an approximation of an audio file+ using chunks from the pool+ .+ > sound-collage auto pool/ music.wav collage.f32+ .+ It performs four steps:+ .+ 1. Decompose @music.wav@ into chunks+ .+ 2. Find best matching chunk from the pool+ for every chunk in the audio file.+ .+ 3. Check where it is better to take an+ originally adjacent chunk from the pool.+ .+ 4. Compose matching chunks to a single file.+ .+ You can run these steps manually in order to inspect the results,+ repeat individual steps or omit them (e.g. step 3).+ Here an example for stereo music file:+ .+ > sound-collage --chunksize=8192 decompose music.wav music/%06d+ .+ > sound-collage --chunksize=8192 --channels=2 associate pool/ music/ collage/%06d+ .+ > sound-collage --chunksize=8192 --channels=2 adjacent pool/ music/ collage/+ .+ > sound-collage --chunksize=8192 --channels=2 compose collage/ collage.f32+ .+ For the @adjacent@ step there is the @--cohesion@ option.+ It specifies how much adjacent chunks shall be prefered to the best matching chunk.+ (Please note, that the best matching chunk is not actually the best matching one,+ but only an approximatively best one. See below for details.)+ If cohesion is 1 then an adjacent chunk is only prefered+ if it matches better than the best matching chunk.+ If cohesion is larger then adjacent chunks are more often prefered+ to the best matching one.+ If cohesion is zero, then always the best matching chunk is chosen.+ This is like skipping the @--adjacent@ step completely.+ .+ You can use any input format supported by SoX,+ but output is always raw @Float@ format, i.e. @.f32@.+ Spectra are computed and stored in @Float@+ (single precision floating point)+ and chunks in the pool are stored in @Int16@.+ .+ This is how it works:+ Since there is a lot of data to process+ I have chosen the following optimization+ that however influences the result.+ I group all chunks according to the index of the largest Fourier coefficient.+ All chunks with the same index are stored in one file.+ For the search of matching chunks I traverse the Fourier indices.+ Then e.g. for Fourier index 10 I load all chunks from the pool+ and all chunks from the decomposed music+ and find best matching chunks only within this group.+ This way I may miss the best matching chunk,+ but save a lot of computation (I hope so).+ .+ Btw. if you also add @music.wav@ to the pool,+ then @music.wav@ will not be restored by the collage algorithm+ since the audio files are decomposed into overlapping chunks.+ .+ Approximation is done using simple L2 norm.+ It is well-known that this does not match human perception very good.+ Maybe it is a good idea to work with lossily compressed audio files+ where all non-audible waves are already eliminated.+ In this case the L2 norm might better match+ the human idea of similarity of audio chunks. Tested-With: GHC==7.4.1 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository this- Tag: 0.1+ Tag: 0.2 Type: darcs- Location: http://code.haskell.org/~thielema/sound-collage/+ Location: http://hub.darcs.net/thielema/sound-collage/ Source-Repository head Type: darcs- Location: http://code.haskell.org/~thielema/sound-collage/+ Location: http://hub.darcs.net/thielema/sound-collage/ Executable sound-collage Build-Depends: fft >=0.1.8 && <0.2, carray >=0.1.3 && <0.2,+ containers >=0.2 && <0.6, array >=0.1 && <0.6, storablevector-carray >=0.0 && <0.1, storablevector >=0.2 && <0.3,- synthesizer-core >=0.7 && <0.8,+ synthesizer-core >=0.7 && <0.9, soxlib >=0.0.1 && <0.1, sample-frame >=0.0 && <0.1, numeric-prelude >=0.4.1 && <0.5,- optparse-applicative >=0.11 && <0.12,- filepath >=1.3 && <1.4,+ Cabal >=1.14 && <3,+ optparse-applicative >=0.11 && <0.14,+ pathtype >=0.8 && <0.9,+ filepath >=1.3 && <1.5, temporary >=1.1 && <1.3,- directory >=1.1 && <1.3,- transformers >=0.3 && <0.5,- utility-ht >=0.0.1 && <0.1,+ transformers >=0.4 && <0.6,+ utility-ht >=0.0.12 && <0.1, base >= 3 && <5 + GHC-Prof-Options: -fprof-auto -rtsopts GHC-Options: -Wall- Hs-source-dirs: src+ Hs-Source-Dirs: src Main-Is: Main.hs Other-Modules: SoundCollage Option+ PathFormat
src/Main.hs view
@@ -4,17 +4,24 @@ import qualified Option import qualified Options.Applicative as OP -import qualified System.Exit as Exit-import qualified System.IO as IO-import System.FilePath ((</>), )-import System.IO.Temp (withSystemTempDirectory, )+import qualified Sound.SoxLib as SoxLib +import qualified Distribution.Simple.Utils as Shell -exitFailureMsg :: String -> IO a-exitFailureMsg msg = do- IO.hPutStrLn IO.stderr msg- Exit.exitFailure+import qualified PathFormat as PathFmt+import qualified System.IO.Temp as Temp+import qualified System.Path as Path +import Control.Monad (liftM2, )+import Control.Applicative (pure, (<*>), )+import Data.Monoid ((<>), )+import Data.Maybe (isNothing, )+++withSystemTempDirectory :: String -> (Path.AbsDir -> IO a) -> IO a+withSystemTempDirectory name f =+ Temp.withSystemTempDirectory name (f . Path.absDir)+ setChunkSize :: Int -> SoundCollage.Parameters -> SoundCollage.Parameters setChunkSize chunkSize params = params {@@ -22,37 +29,87 @@ div chunkSize (SoundCollage.paramOverlap params) } -makeParams :: Maybe Int -> SoundCollage.Parameters-makeParams maybeChunkSize =- maybe- SoundCollage.defltParams- (flip setChunkSize SoundCollage.defltParams)- maybeChunkSize+setNumChannels :: Int -> SoundCollage.Parameters -> SoundCollage.Parameters+setNumChannels numChannels params =+ params {+ SoundCollage.paramChannels = numChannels+ } +setParams ::+ Maybe Int -> Maybe Int ->+ SoundCollage.Parameters -> SoundCollage.Parameters+setParams maybeChunkSize maybeChannels =+ maybe id setNumChannels maybeChannels .+ maybe id setChunkSize maybeChunkSize++makeParams :: Option.T -> SoundCollage.Parameters+makeParams (Option.Cons _verbosity maybeChunkSize maybeChannels) =+ setParams maybeChunkSize maybeChannels SoundCollage.defltParams++commandParser :: Option.Command (Option.T -> IO ())+commandParser =+ Option.decompose+ (pure (\flags -> SoundCollage.runDecompose (makeParams flags)))+ <>+ Option.decomposeSlow+ (pure (\flags -> SoundCollage.runDecomposeSlow (makeParams flags)))+ <>+ Option.compose+ (pure (\flags -> SoundCollage.runCompose (makeParams flags)))+ <>+ Option.associate+ (pure (\pool flags -> SoundCollage.runAssociate (makeParams flags) pool)+ <*> Option.pool)+ <>+ Option.adjacent+ (pure+ (\cohesion pool flags ->+ SoundCollage.runAdjacent (Option.verbosity flags)+ (makeParams flags) cohesion pool)+ <*> Option.cohesion+ <*> Option.pool)+ <>+ Option.auto+ (pure+ (\cohesion pool+ (Option.Cons verbosity maybeChunkSize maybeChannels) src dst ->+ withSystemTempDirectory "sound-chunks" $ \chunkDir ->+ withSystemTempDirectory "sound-collage" $ \collDir -> do+ params <-+ fmap (setParams maybeChunkSize maybeChannels) $+ if isNothing $ liftM2 (,) maybeChunkSize maybeChannels+ then do+ (chunkSize, numChannels) <-+ SoundCollage.parametersFromPool pool+ return $+ setNumChannels numChannels $+ setChunkSize chunkSize SoundCollage.defltParams+ else return SoundCollage.defltParams+ Shell.notice verbosity $+ "chunk size: " +++ show (SoundCollage.paramChunkSize params)+ Shell.notice verbosity $+ "number of channels: " +++ show (SoundCollage.paramChannels params)+ Shell.notice verbosity $ "decompose to " ++ Path.toString chunkDir+ SoundCollage.runDecompose params src+ (PathFmt.File chunkDir "%06d")+ Shell.notice verbosity $ "associate to " ++ Path.toString collDir+ SoundCollage.runAssociate params+ pool chunkDir (PathFmt.File collDir "%06d")+ Shell.notice verbosity $ "update adjacent"+ SoundCollage.runAdjacent verbosity params cohesion+ pool chunkDir collDir+ Shell.notice verbosity $ "compose"+ SoundCollage.runCompose params collDir dst)+ <*> Option.cohesion+ <*> Option.pool)+ main :: IO ()-main = do- Option.Cons maybeChunkSize action src dst <- OP.execParser Option.info- case action of- Option.Decompose ->- SoundCollage.runDecompose (makeParams maybeChunkSize) src dst- Option.Compose ->- SoundCollage.runCompose (makeParams maybeChunkSize) src dst- Option.Associate pool ->- SoundCollage.runAssociate (makeParams maybeChunkSize) pool src dst- Option.Batch pool ->- withSystemTempDirectory "sound-chunks" $ \chunkDir ->- withSystemTempDirectory "sound-collage" $ \collDir -> do- chunkSize <-- maybe- (SoundCollage.chunkSizeFromPool pool)- return- maybeChunkSize- let params = setChunkSize chunkSize 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+main = SoxLib.formatWith $ do+ action <-+ OP.execParser $+ OP.info+ (OP.helper <*> (OP.subparser commandParser <*> Option.parseFlags))+ Option.desc+ action
src/Option.hs view
@@ -1,65 +1,137 @@ module Option where +import qualified Distribution.Verbosity as Verbosity+import qualified Distribution.ReadE as ReadE+import Distribution.Verbosity (Verbosity)++import qualified PathFormat as PathFmt+import qualified System.Path.PartClass as PathC+import qualified System.Path as Path+ import qualified Options.Applicative as OP import Options.Applicative- (Parser, long, help, flag', metavar, strOption, option, strArgument, )+ (Parser, long, short, help, metavar, option, argument, ) -import Control.Applicative (pure, (<*>), (<|>), (<$>), )+import Control.Applicative (pure, (<*>), ) import Data.Monoid ((<>), ) -data Action =- Decompose- | Compose- | Associate FilePath- | Batch FilePath- deriving (Show)- data T = Cons {+ verbosity :: Verbosity, chunkSize :: Maybe Int,- action :: Action,- src, dst :: FilePath+ channels :: Maybe Int } deriving (Show) -parseAction :: Parser Action-parseAction =- (flag' Decompose- ( long "decompose"- <> help "Chop audio file in chunks and add them to the pool" ))- <|>- (Associate <$>- strOption- ( long "associate"- <> metavar "POOL"- <> help "Associate chunks with chunks from the pool" ))- <|>- (flag' Compose- ( long "compose"- <> help "Compose audio file from selected pool chunks" ))- <|>- (Batch <$>- strArgument- ( metavar "POOL"- <> help "Automatically perform 'decompose', 'associate', 'compose'" ))+path :: (PathC.FileDir fd) => OP.ReadM (Path.AbsRel fd)+path = OP.eitherReader Path.parse -parseAll :: Parser T-parseAll =+type Command = OP.Mod OP.CommandFields++simpleAction :: String -> String -> Parser a -> Command a+simpleAction name helpText act =+ OP.command name $ OP.info (OP.helper <*> act) (OP.progDesc helpText)++pool :: Parser Path.AbsRelDir+pool = argument path (metavar "POOL")++src, dst :: (PathC.FileDir fd) => Parser (Path.AbsRel fd)+src = argument path (metavar "SRC")+dst = argument path (metavar "DST")++dstFmt :: Parser PathFmt.AbsRelFile+dstFmt = argument (OP.eitherReader PathFmt.parse) (metavar "DST")++transferAction ::+ (PathC.FileDir fd) =>+ Parser dst ->+ String -> String ->+ Parser (T -> Path.AbsRel fd -> dst -> a) ->+ Command (T -> a)+transferAction dstp name helpText act =+ OP.command name $+ OP.info+ (OP.helper <*> (pure (\f s d opt -> f opt s d) <*> act <*> src <*> dstp))+ (OP.progDesc helpText)++cohesion :: Parser Float+cohesion =+ option OP.auto+ ( OP.value 1+ <> long "cohesion"+ <> metavar "FACTOR"+ <> help "preference of adjacent chunks" )+++decompose, decomposeSlow, associate ::+ (PathC.FileDir fd) =>+ Parser (T -> Path.AbsRel fd -> PathFmt.AbsRelFile -> a) ->+ Command (T -> a)++adjacent, compose, auto ::+ (PathC.FileDir fd0, PathC.FileDir fd1) =>+ Parser (T -> Path.AbsRel fd0 -> Path.AbsRel fd1 -> a) ->+ Command (T -> a)++decompose =+ transferAction dstFmt "decompose"+ "Chop audio file in chunks and add them to the pool"++decomposeSlow =+ transferAction dstFmt "decompose-slow"+ ("Chop audio file in chunks and add them to the pool. " +++ "Requires less memory but more file accesses.")++associate =+ transferAction dstFmt "associate"+ "Associate chunks with chunks from the pool"++adjacent =+ transferAction dst "adjacent"+ "Replace selected chunks if originally adjacent chunks match better"++compose =+ transferAction dst "compose"+ "Compose audio file from selected pool chunks"++auto =+ transferAction dst "auto"+ "Automatically perform 'decompose', 'associate', 'adjacent', 'compose'"+++optionVerbosity :: OP.ReadM Verbosity+optionVerbosity =+ either OP.readerError return+ . ReadE.runReadE Verbosity.flagToVerbosity =<< OP.str++parseFlags :: Parser T+parseFlags = pure Cons+ <*> option optionVerbosity+ ( OP.value Verbosity.normal+ <> short 'v'+ <> long "verbose"+ <> metavar "0..3"+ <> help "verbosity" ) <*> option (fmap Just OP.auto) ( OP.value Nothing <> long "chunksize" <> metavar "NUMSAMPLES" <> help "size of decomposed chunks" )- <*> parseAction- <*> strArgument ( metavar "SRC" )- <*> strArgument ( metavar "DST" )+ <*> option (fmap Just OP.auto)+ ( OP.value Nothing+ <> long "channels"+ <> metavar "NUMBER"+ <> help "number of channels" ) +desc :: OP.InfoMod a+desc =+ OP.fullDesc+ <>+ OP.progDesc "Approximate an audio file by a collection of chunks"+ info :: OP.ParserInfo T-info =- OP.info (OP.helper <*> parseAll)- ( OP.fullDesc- <> OP.progDesc "Approximate an audio file by a collection of chunks" )+info = OP.info (OP.helper <*> parseFlags) desc
+ src/PathFormat.hs view
@@ -0,0 +1,25 @@+module PathFormat where++import qualified System.FilePath as StrPath+import qualified System.Path.PartClass as PathC+import qualified System.Path.Part as PathPart+import qualified System.Path as Path+import System.Path ((</>), )++import qualified Text.Printf as Pf+++data File ar = File (Path.Dir ar) FilePath++type AbsRelFile = File PathPart.AbsRel+++printf :: (PathC.AbsRel ar) => File ar -> Int -> Path.File ar+printf (File dir fmt) arg =+ dir </> Path.relFile (Pf.printf fmt arg)++parse :: (PathC.AbsRel ar) => String -> Either String (File ar)+parse str = do+ let (dir, file) = StrPath.splitFileName str+ dirPath <- Path.parse dir+ return $ File dirPath file
src/SoundCollage.hs view
@@ -1,10 +1,54 @@ {-# LANGUAGE RebindableSyntax #-} {- | Very much inspired by NoiseReduction.++A refined algorithm may increase the clusters for the full scans.+E.g. if a block in the original song+has highest Fourier coefficient at frequency k,+then we might not only scan chunks from the pool with dominant frequency k,+but instead scan some frequencies around k, too.+This way we can hold a subset of the pool chunks in memory for some time.+It would also solve the current problem+of not finding a pool chunk with matching maximum frequency.++An alternative algorithm may use a full-table scan+for searching the best matching chunk+but perform the scan only on some spectral coefficients.+For instance we could choose the spectral coefficients+with the largest variance across all spectra in the pool.+Then we choose a number of indices,+such that all feature vectors fit in memory.+Then we could choose the best matching spectrum+from a number of vectors that best match the selected Fourier coefficients.++Another alternative is to keep only the n largest Fourier coefficients+of each chunk from the pool.+The other coefficients are treated as zero.+This is simpler than the above method and probably maintains more information.+We could measure the ratio of the largest to smallest kept frequency+and we could measure the sum of suppressed frequencies+in order to get an idea of the loss of information.++A variation of the above approach is to approximate the frequency spectrum+by a piecewise constant function.+A hierarchical cluster algorithm could divide the spectrum+into ranges of balanced area.++Both of these strategies allow to hold a compressed form+of the whole pool in memory,+but the detailed search at the second stage requires lot of disk accesses.+Optimally, the first stage is good enough+such that we do not need the second stage, at all.++Every one of these approaches could be complemented+with a lossy audio compression+that reduces the spectral information+to the ones that the human auditory system can perceive. -} module SoundCollage (- testChopCompose, runDecompose, runAssociate, runCompose,- Parameters(..), defltParams, chunkSizeFromPool,+ testChopCompose,+ runDecompose, runDecomposeSlow, runAssociate, runAdjacent, runCompose,+ Parameters(..), paramChunkSize, defltParams, parametersFromPool, ) where import qualified Sound.SoxLib as SoxLib@@ -16,23 +60,40 @@ 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 Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable, peek, sizeOf, ) -import qualified System.Directory as Dir-import qualified System.FilePath as FilePath+import qualified Distribution.Simple.Utils as Shell+import Distribution.Verbosity (Verbosity)++import qualified PathFormat as PathFmt+import qualified System.Path.Directory as Dir+import qualified System.Path.IO as PathIO+import qualified System.Path.PartClass as PathC+import qualified System.Path as Path 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 System.Path ((</>), (<++>), ) +import Control.Monad.Trans.Except (Except, throwE, runExcept, )+import Control.Monad (forM_, zipWithM_, (<=<), )++import qualified Data.Sequence as Seq+import qualified Data.Map as Map+import Data.Map (Map, )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold 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 Data.Tuple.HT (mapPair, mapFst, mapSnd, swap, )+import Data.Ord.HT (comparing, )+import Data.Maybe.HT (toMaybe, )+import Data.Maybe (fromMaybe, mapMaybe, )+import Data.Bool.HT (if', )+import Data.Monoid (mappend, ) import qualified Data.Complex as Complex98 import Data.Int (Int16, )@@ -45,7 +106,7 @@ import NumericPrelude.Numeric import NumericPrelude.Base-import qualified Prelude as P+import Prelude () @@ -103,17 +164,24 @@ data Parameters = Parameters {- paramShift, paramOverlap :: Int+ paramShift, paramOverlap, paramChannels :: Int } defltParams :: Parameters defltParams = Parameters {- paramShift = 1024,- paramOverlap = 2+ paramShift = 4096,+ paramOverlap = 2,+ paramChannels = 1 } +paramChunkSize :: Parameters -> Int+paramChunkSize params =+ let shift = paramShift params+ overlap = paramOverlap params+ in shift*overlap+ maxCoeff :: SV.Vector Float -> Int maxCoeff ys = Key.maximum (SV.index ys) $ take (SV.length ys) [0..]@@ -142,13 +210,21 @@ -spectrumSuffix, chunkSuffix :: String+spectrumSuffix, chunkSuffix, indexSuffix, originSuffix, targetSuffix :: String spectrumSuffix = "-spec.f32" chunkSuffix = "-chunk.s16"+indexSuffix = "-index.txt"+originSuffix = "-origin.txt"+targetSuffix = "-target.txt" -runDecompose :: Parameters -> FilePath -> FilePath -> IO ()-runDecompose params src dst =- SoxLib.withRead SoxLib.defaultReaderInfo src $ \fmtInPtr -> do++withChopped ::+ (PathC.AbsRel ar) =>+ Parameters -> Path.File ar ->+ ([(SV.Vector Float, SV.Vector Float)] -> IO ()) ->+ IO ()+withChopped params src f =+ withFilePath (SoxLib.withRead SoxLib.defaultReaderInfo) src $ \fmtInPtr -> do fmtIn <- peek fmtInPtr let numChan = fromMaybe 1 $ SoxLib.channels $ SoxLib.signalInfo fmtIn@@ -157,81 +233,212 @@ 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 $+ f $ uncurry zip $ mapPair (foldl1 (zipWith (SV.zipWith (+))),- map SV.concat . List.transpose) $+ map SV.interleave . 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+createDirectoriesFor :: (PathC.AbsRel ar) => Path.File ar -> IO ()+createDirectoriesFor =+ Dir.createDirectoryIfMissing True . Path.takeDirectory -fileSize :: FilePath -> IO Integer-fileSize path = IO.withFile path IO.ReadMode IO.hFileSize+runDecomposeSlow ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1) =>+ Parameters -> Path.File ar0 -> PathFmt.File ar1 -> IO ()+runDecomposeSlow params src dst =+ withChopped params src $ \chopped -> + let write n (spec,chunk) = do+ let path = PathFmt.printf dst (maxCoeff spec)+ createDirectoriesFor path+ PathIO.appendFile (path <++> indexSuffix) $+ show (Path.toString src, n::Int) ++ "\n"+ withFilePath SV.appendFile (path <++> spectrumSuffix) spec+ withFilePath SV.appendFile (path <++> chunkSuffix) $+ (SV.map (Bin.fromCanonicalWith Real.roundSimple) chunk+ :: SV.Vector Int16)++ in zipWithM_ write [0..] chopped++runDecompose ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1) =>+ Parameters -> Path.File ar0 -> PathFmt.File ar1 -> IO ()+runDecompose params src dst =+ withChopped params src $ \chopped ->++ let keyValue n (spec,chunk) =+ (maxCoeff spec,+ (Seq.singleton n,+ Seq.singleton spec,+ Seq.singleton+ (SV.map (Bin.fromCanonicalWith Real.roundSimple) chunk+ :: SV.Vector Int16)))++ write maxi (index, specs, chunks) = do+ let path = PathFmt.printf dst maxi+ createDirectoriesFor path+ PathIO.appendFile (path <++> indexSuffix) $ unlines $+ map (\n -> show (Path.toString src, n::Int)) $ Fold.toList index+ withFilePath SVL.appendFile (path <++> spectrumSuffix) $+ SVL.fromChunks $ Fold.toList specs+ withFilePath SVL.appendFile (path <++> chunkSuffix) $+ SVL.fromChunks $ Fold.toList chunks++ in Fold.sequence_ $ Map.mapWithKey write $+ Map.fromListWith (flip mappend) $+ zipWith keyValue [0..] chopped++getDirectoryContents ::+ (PathC.AbsRel ar) => Path.Dir ar -> IO [Path.RelFile]+getDirectoryContents = fmap snd . Dir.relDirectoryContents++fileSize :: (PathC.AbsRel ar) => Path.File ar -> IO Integer+fileSize path = PathIO.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+maybeSuffix ::+ (PathC.AbsRel ar) =>+ String -> Path.File ar -> Maybe (Path.File ar)+maybeSuffix suffix =+ Path.mapFileNameF $ ListHT.maybeSuffixOf suffix -loadSpectra :: FilePath -> IO [(SV.Vector Float, FilePath)]-loadSpectra dir = do- files <-- fmap (filter (isSuffixOf spectrumSuffix)) $+maybeSpectrumSuffix ::+ (PathC.AbsRel ar) => Path.File ar -> Maybe (Path.File ar)+maybeSpectrumSuffix = maybeSuffix spectrumSuffix++isSuffixOf :: (PathC.AbsRel ar) => String -> Path.File ar -> Bool+isSuffixOf suffix path = List.isSuffixOf suffix $ Path.toString path+++parametersFromPool :: (PathC.AbsRel ar) => Path.Dir ar -> IO (Int, Int)+parametersFromPool dir = do+ (specFiles, chunkFiles) <-+ fmap+ (unzip .+ mapMaybe+ (\file ->+ fmap ((,) (dir </> file)) $+ fmap ((dir </>) . (<++> chunkSuffix)) $+ maybeSpectrumSuffix file)) $ getDirectoryContents dir- forM files $ \file -> do- spec <- SV.readFile $ dir </> file- return (spec, file)+ specSize <-+ fmap (divByteSize (0::Float) . foldl gcd 0) $ mapM fileSize specFiles+ chunkSize <-+ fmap (divByteSize (0::Int16) . foldl gcd 0) $ mapM fileSize chunkFiles+ let evenSize = (specSize-1)*2+ let oddSize = specSize*2-1+ let (evenQuot, evenRem) = divMod chunkSize evenSize+ let (oddQuot, oddRem) = divMod chunkSize oddSize+ fmap (mapPair (fromInteger, fromInteger)) $+ if' (evenRem == 0) (return (evenSize, evenQuot)) $+ if' (oddRem == 0) (return (oddSize, oddQuot)) $+ ioError $ userError "inconsistent file sizes in pool" ++withFilePath ::+ (PathC.AbsRel ar) => (FilePath -> a) -> (Path.File ar -> a)+withFilePath f = f . Path.toString++data SplitPath ar = SplitPath (Path.Dir ar) Path.RelFile+ deriving (Eq, Ord, Show)++loadSpectra ::+ (PathC.AbsRel ar) =>+ Parameters -> SplitPath ar -> IO [(SV.Vector Float, Int)]+loadSpectra params (SplitPath dir name) =+ fmap (flip zip [0..]) $+ PathIO.withFile (dir </> name <++> spectrumSuffix) IO.ReadMode $ \h ->+ let chunkSize = div (paramChunkSize params) 2 + 1+ go = do+ spec <- SV.hGet h chunkSize+ let actualSize = SV.length spec+ in if' (actualSize == chunkSize) (fmap (spec:) go) $+ if' (actualSize == 0) (return []) $+ ioError $ userError "loading spectra: bucket size not multiple of chunk size"+ in go++loadIndex :: (PathC.AbsRel ar) => Path.File ar -> IO [(Path.AbsRelFile, Int)]+loadIndex path =+ fmap (map (mapFst Path.path . read) . lines) $ PathIO.readFile path++success :: a -> Except e a+success = return++keyClash :: key -> Except key a -> Except key a -> Except key a+keyClash key _ _ = throwE key++catchKeyClash ::+ (Show key) => String -> Map key (Except key a) -> IO (Map key a)+catchKeyClash name em =+ case runExcept $ Trav.sequenceA em of+ Right m -> return m+ Left key ->+ ioError $ userError $ name ++ ": duplicate key " ++ show key++loadOriginMap ::+ (PathC.AbsRel ar) =>+ SplitPath ar -> IO (Map (Path.RelFile, Int) (Path.AbsRelFile, Int))+loadOriginMap (SplitPath dir name) = do+ index <- loadIndex $ dir </> name <++> indexSuffix+ catchKeyClash "load origin map" $+ Map.fromListWithKey keyClash $+ zipWith (\n orig -> ((name, n), success orig)) [0..] index++loadOriginIndex ::+ (PathC.AbsRel ar) => Path.File ar -> IO (Float, (Path.RelFile, Int))+loadOriginIndex = fmap (mapSnd $ mapFst Path.path) . readIO <=< PathIO.readFile++loadTargetIndex ::+ (PathC.AbsRel ar) => Path.File ar -> IO (Path.RelFile, Int)+loadTargetIndex = fmap (mapFst Path.path) . readIO <=< PathIO.readFile+++loadChunk ::+ (PathC.AbsRel ar) =>+ Parameters -> Path.File ar -> Int -> IO (SV.Vector Int16)+loadChunk params path offset =+ PathIO.withFile path IO.ReadMode $ \h -> do+ let chanChunkSize = paramChannels params * paramChunkSize params+ IO.hSeek h IO.AbsoluteSeek $+ fromIntegral (offset * chanChunkSize * sizeOf (0::Int16))+ SV.hGet h chanChunkSize++loadSpectrum ::+ (PathC.AbsRel ar) =>+ Int -> Path.File ar -> Int -> IO (SV.Vector Float)+loadSpectrum chunkSize path offset =+ PathIO.withFile path IO.ReadMode $ \h -> do+ let specSize = div chunkSize 2 + 1+ IO.hSeek h IO.AbsoluteSeek $+ fromIntegral (offset * specSize * sizeOf (0::Float))+ SV.hGet h specSize++ 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))+ (PathC.AbsRel ar) =>+ Parameters -> SplitPath ar -> IO [(SV.Vector Float, (Float, Int))]+createSpectrumMap params poolBucket = do+ files <- loadSpectra params poolBucket+ return $ flip map files $ \(spec, pos) ->+ case normalizeSpectrum spec of+ (normedSpec, norm) -> (normedSpec, (norm, pos)) +normalizeSpectrum :: SV.Vector Float -> (SV.Vector Float, Float)+normalizeSpectrum spec =+ let norm = norm2 spec+ in (SV.map (/norm) spec, norm)+ matchSpectrum :: SV.Vector Float -> SV.Vector Float -> Float matchSpectrum spec dict = SV.foldl' (+) 0 $ SV.zipWith (*) spec dict@@ -244,21 +451,37 @@ 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+copyChunk ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1) =>+ Parameters -> Float -> Float ->+ SplitPath ar0 -> Int -> Path.File ar1 -> IO ()+copyChunk params amp scalProd (SplitPath poolDir poolName) offset dstPath = do+ PathIO.writeFile (dstPath <++> originSuffix) $+ show (scalProd, (Path.toString poolName, offset))+ withFilePath SV.writeFile (dstPath <++> chunkSuffix)+ . asVector16+ . SV.map (Real.roundSimple . clip16 . (*amp) . fromIntegral)+ =<< loadChunk params (poolDir </> poolName <++> chunkSuffix) offset++associateBucket ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1, PathC.AbsRel ar2) =>+ Parameters -> SplitPath ar0 -> SplitPath ar1 -> PathFmt.File ar2 -> IO ()+associateBucket params poolBucket srcBucket@(SplitPath srcDir srcName) dst = do++ dict <- createSpectrumMap params poolBucket+ files <- loadSpectra params srcBucket+ srcIndex <- loadIndex $ srcDir </> srcName <++> indexSuffix+ forM_ (zip files (map snd srcIndex)) $ \((spec, specIx), pos) -> 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)+ let (scalProd, (poolNorm, matchingOffset)) =+ List.maximumBy (comparing fst) $+ map (mapFst (matchSpectrum spec)) dict+ let dstPath = PathFmt.printf dst pos+ createDirectoriesFor dstPath+ PathIO.writeFile (dstPath <++> targetSuffix) $+ show (Path.toString srcName, specIx)+ copyChunk params (srcNorm/poolNorm)+ scalProd poolBucket matchingOffset dstPath merge :: (Ord a) => [a] -> [a] -> [(a,a)] merge =@@ -276,34 +499,127 @@ go (_:_) [] = error "merge: second list empty" in go -runAssociate :: Parameters -> FilePath -> FilePath -> FilePath -> IO ()+runAssociate ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1, PathC.AbsRel ar2) =>+ Parameters -> Path.Dir ar0 -> Path.Dir ar1 -> PathFmt.File ar2 -> 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+ let getSpectra :: (PathC.AbsRel ar) => Path.Dir ar -> IO [Path.RelFile]+ getSpectra =+ fmap (List.sort . mapMaybe maybeSpectrumSuffix) . getDirectoryContents+ srcDirs <- getSpectra src+ poolDirs <- getSpectra poolDir+ forM_ (merge srcDirs poolDirs) $ \(sdir,pdir) -> do+ associateBucket params (SplitPath poolDir pdir) (SplitPath 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+mapUnionsWithKey ::+ (Ord k) => (k -> a -> a -> a) -> [Map k a] -> Map k a+mapUnionsWithKey f =+ foldl (Map.unionWithKey f) Map.empty -runCompose :: Parameters -> FilePath -> FilePath -> IO ()+mapInverse :: (Ord a, Ord b, Show b) => Map a b -> Map b (Except b a)+mapInverse =+ Map.fromListWithKey keyClash .+ map (mapSnd success . swap) . Map.toList++runAdjacent ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1, PathC.AbsRel ar2) =>+ Verbosity -> Parameters -> Float ->+ Path.Dir ar0 -> Path.Dir ar1 -> Path.Dir ar2 -> IO ()+runAdjacent verbosity params cohesion poolDir srcDir dstDir = do+ originMap <-+ catchKeyClash "unions of origin maps" . mapUnionsWithKey keyClash+ =<< mapM (fmap (fmap success) . loadOriginMap . SplitPath poolDir)+ . mapMaybe maybeSpectrumSuffix+ =<< getDirectoryContents poolDir++ indexMap <- catchKeyClash "index inversion" $ mapInverse originMap++ chunkNames <-+ fmap (List.sort . mapMaybe (maybeSuffix chunkSuffix)) $+ getDirectoryContents dstDir++ case chunkNames of+ [] -> ioError $ userError "no index file found"+ name0 : remIndices ->+ let chunkSize = paramChunkSize params+ maybeNextBetter srcName srcOffset srcSpec dstName scalProd jx =+ case Map.lookup jx indexMap of+ Nothing -> return Nothing+ Just (nextName, nextOffset) -> do+ (nextSpec, nextNorm) <-+ fmap normalizeSpectrum $+ loadSpectrum chunkSize+ (poolDir </> nextName <++> spectrumSuffix) nextOffset+ let nextScalProd = matchSpectrum srcSpec nextSpec+ Shell.debug verbosity $+ printf "%s: %s+%d %s+%d %f %f\n"+ (Path.toString dstName)+ (Path.toString $ srcDir </> srcName) srcOffset+ (Path.toString $ poolDir </> nextName) nextOffset+ nextScalProd scalProd+ return $+ toMaybe (cohesion*nextScalProd > scalProd)+ (nextName, nextOffset, nextScalProd, nextNorm)++ lookupOrigin ix =+ case Map.lookup ix originMap of+ Just n -> return n+ Nothing ->+ ioError $ userError $+ "original chunk for " ++ show ix ++ " not found"++ go _ [] = return ()+ go jx0 (dstName : is) = do+ (scalProd, origIx) <-+ loadOriginIndex $ dstDir </> dstName <++> originSuffix++ (srcName, srcOffset) <-+ loadTargetIndex $ dstDir </> dstName <++> targetSuffix++ srcSpec <-+ loadSpectrum chunkSize+ (srcDir </> srcName <++> spectrumSuffix) srcOffset++ m <- maybeNextBetter srcName srcOffset srcSpec dstName scalProd jx0+ jx1 <-+ case m of+ Nothing -> lookupOrigin origIx+ Just (nextName, nextOffset, nextScalProd, nextNorm) -> do+ Shell.info verbosity $ "replace " ++ Path.toString dstName+ let dstPath = dstDir </> dstName+ copyChunk params (norm2 srcSpec / nextNorm)+ nextScalProd (SplitPath poolDir nextName)+ nextOffset dstPath+ return jx0+ go (mapSnd succ jx1) is++ in do (_scalProd, origIx) <-+ loadOriginIndex $ dstDir </> name0 <++> originSuffix+ ix <- lookupOrigin origIx+ go (mapSnd succ ix) remIndices+++runCompose ::+ (PathC.AbsRel ar0, PathC.AbsRel ar1) =>+ Parameters -> Path.Dir ar0 -> Path.File ar1 -> IO () runCompose params src dst = do let shift = paramShift params overlap = paramOverlap params chunkSize = shift*overlap+ deinterleave xs =+ SV.deinterleave (div (SV.length xs) chunkSize) xs pilPost = pillow chunkSize chunks <-- mapM (SV.readFile . (src </>)) . List.sort =<< getDirectoryContents src- SVL.writeFile dst $ SVL.interleaveFirstPattern $+ mapM (withFilePath SV.readFile . (src </>)) . List.sort+ . filter (isSuffixOf chunkSuffix)+ =<< getDirectoryContents src++ withFilePath 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)) $+ deinterleave . SV.map (Bin.toCanonical :: Int16 -> Float)) $ chunks