diff --git a/sound-collage.cabal b/sound-collage.cabal --- a/sound-collage.cabal +++ b/sound-collage.cabal @@ -1,47 +1,145 @@ Name: sound-collage -Version: 0.1 +Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann 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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Option.hs b/src/Option.hs --- a/src/Option.hs +++ b/src/Option.hs @@ -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 diff --git a/src/PathFormat.hs b/src/PathFormat.hs new file mode 100644 --- /dev/null +++ b/src/PathFormat.hs @@ -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 diff --git a/src/SoundCollage.hs b/src/SoundCollage.hs --- a/src/SoundCollage.hs +++ b/src/SoundCollage.hs @@ -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