diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,15 +1,27 @@ CABALOPTS = -run-test: - runhaskell Setup configure --user +run-test: run-test-plain run-test-blas run-test-lapack + +run-test-plain: update-test + runhaskell Setup configure --user --enable-tests runhaskell Setup build runhaskell Setup haddock + ./dist/build/align-audio-test/align-audio-test - runhaskell Setup configure --user -fblas +run-test-blas: update-test + runhaskell Setup configure --user --enable-tests -fblas runhaskell Setup build + ./dist/build/align-audio-test/align-audio-test - runhaskell Setup configure --user -flapack +run-test-lapack: update-test + runhaskell Setup configure --user --enable-tests -flapack runhaskell Setup build + ./dist/build/align-audio-test/align-audio-test + +update-test: + doctest-extract-0.1 -i src/ -o test/ --import-tested --executable-main=Test.hs \ + Correlate CorrelateResample + align-audio.deb: cabal v2-install $(CABALOPTS) \ diff --git a/align-audio.cabal b/align-audio.cabal --- a/align-audio.cabal +++ b/align-audio.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: align-audio -Version: 0.0.0.1 +Version: 0.0.0.2 License: BSD-3-Clause License-File: LICENSE Author: Henning Thielemann @@ -19,6 +19,21 @@ . The program can handle sources of different sample rates if the sample rates are integers. + . + You can specify the precision of the displacement using the @--rate@ option, + which must be a positive integer: + . + > align-audio --rate 1000 orig.wav video.wav + . + For reading of audio files, @libsox@ is used + and thus you can use all audio formats supported by SoX. + . + Cabal-Flags: + . + * @blas@ for running with 'comfort-blas' (more memory consumption) + . + * @lapack@ for running with 'lapack' (heavier dependency) + Tested-With: GHC==8.6.5 Build-Type: Simple Extra-Source-Files: @@ -35,7 +50,7 @@ Default: False Source-Repository this - Tag: 0.0.0.1 + Tag: 0.0.0.2 Type: darcs Location: http://hub.darcs.net/thielema/align-audio/ @@ -43,22 +58,14 @@ Type: darcs Location: http://hub.darcs.net/thielema/align-audio/ -Executable align-audio +Common Vector Build-Depends: comfort-fftw >=0.0 && <0.1, comfort-array >=0.5 && <0.6, + storablevector >=0.2 && <0.3, netlib-ffi >=0.1.1 && <0.2, - containers >=0.2 && <0.7, Stream >=0.4.7 && <0.5, - storablevector >=0.2 && <0.3, - synthesizer-core >=0.7 && <0.9, - soxlib >=0.0.1 && <0.1, numeric-prelude >=0.4.1 && <0.5, - shell-utility >=0.0 && <0.2, - optparse-applicative >=0.11 && <0.19, - utility-ht >=0.0.12 && <0.1, - base >= 3 && <5 - If flag(lapack) Hs-Source-Dirs: src/lapack Build-Depends: @@ -70,7 +77,19 @@ comfort-blas >=0.0 && <0.1, Else Hs-Source-Dirs: src/plain + Other-Modules: Vector +Executable align-audio + Import: Vector + Build-Depends: + containers >=0.2 && <0.9, + synthesizer-core >=0.7 && <0.10, + soxlib >=0.0.1 && <0.1, + shell-utility >=0.0 && <0.2, + optparse-applicative >=0.11 && <0.20, + utility-ht >=0.0.12 && <0.1, + base >=3 && <5 + Default-Language: Haskell98 GHC-Options: -Wall Hs-Source-Dirs: src @@ -79,5 +98,23 @@ Correlate CorrelateResample Common - Vector Option + +Test-Suite align-audio-test + Import: Vector + Type: exitcode-stdio-1.0 + Default-Language: Haskell98 + GHC-Options: -Wall + Hs-source-dirs: src, test + Main-Is: Test.hs + Other-Modules: + Test.Correlate + Test.CorrelateResample + Correlate + CorrelateResample + Common + Build-Depends: + doctest-exitcode-stdio >=0.0 && <0.1, + doctest-lib >=0.1 && <0.2, + QuickCheck >=2 && <3, + base >=3 && <5 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -1,10 +1,15 @@ module Common where +import qualified Numeric.FFTW.Shape as Spectrum +import qualified Numeric.FFTW.Rank1 as Trafo1 +import qualified Numeric.Netlib.Class as Class + import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import Data.Array.Comfort.Storable (Array) +import Data.Complex (Complex) import Foreign.Storable (Storable) @@ -17,3 +22,8 @@ pad :: (Storable a, Num a) => Int -> SVL.Vector a -> SVL.Vector a pad n xs = SVL.append xs $ SVL.replicate SVL.defaultChunkSize (n - SVL.length xs) 0 + +fourierRC :: + (Class.Real a) => + Int -> SVL.Vector a -> Array (Spectrum.Half Int) (Complex a) +fourierRC n = Trafo1.fourierRC . cyclicFromVector . pad n diff --git a/src/Correlate.hs b/src/Correlate.hs --- a/src/Correlate.hs +++ b/src/Correlate.hs @@ -1,7 +1,7 @@ module Correlate where import Vector (findPeak, mulConj) -import Common (cyclicFromVector, pad) +import Common (fourierRC) import qualified Numeric.FFTW.Rank1 as Trafo1 import qualified Numeric.Netlib.Class as Class @@ -13,23 +13,31 @@ import qualified Data.Stream as Stream +{- $setup +>>> import qualified Test.QuickCheck as QC +>>> import qualified Data.StorableVector.Lazy as SVL +>>> import Data.Monoid ((<>)) +-} + + {- | Round to next higher number of the form m*2^n with m<16. This size contains almost only factor 2 and at most one ugly factor < 16 -and we add at most 7% pad data. +and we add at most 1/8 pad data. >>> map ceilingFFTSize [1..40] [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,18,18,20,20,22,22,24,24,26,26,28,28,30,30,32,32,36,36,36,36,40,40,40,40] prop> \n -> n <= ceilingFFTSize n -prop> \n -> ceilingFFTSize n <= div (n * 107) 100 +prop> \(QC.Positive n) -> ceilingFFTSize n * 8 <= n * 9 -} ceilingFFTSize :: Int -> Int ceilingFFTSize n = - case Stream.dropWhile ((>=16).fst) $ - Stream.zip - (Stream.iterate (\k -> div (k+1) 2) n) - (Stream.iterate (2*) 1) of - Stream.Cons (m,p) _ -> m*p + uncurry (*) $ + Stream.head $ + Stream.dropWhile ((>=16).fst) $ + Stream.zip + (Stream.iterate (\k -> div (k+1) 2) n) + (Stream.iterate (2*) 1) correlate :: @@ -39,11 +47,24 @@ let nx = SVL.length xs ny = SVL.length ys n = ceilingFFTSize (nx+ny) - in Trafo1.fourierCR $ - mulConj - (Trafo1.fourierRC (cyclicFromVector (pad n xs))) - (Trafo1.fourierRC (cyclicFromVector (pad n ys))) + in Trafo1.fourierCR $ mulConj (fourierRC n xs) (fourierRC n ys) +{- | +prop> :{ + \(QC.NonNegative preX, QC.NonNegative postX) -> + \(QC.NonNegative preY, QC.NonNegative postY) -> + \(QC.NonEmpty xs) -> + all (0/=) xs QC.==> + + preX - preY + QC.=== + let v = SVL.pack SVL.defaultChunkSize xs in + let pad n = SVL.replicate SVL.defaultChunkSize n (0::Float) in + determineLag + (pad preX <> v <> pad postX) + (pad preY <> v <> pad postY) +:} +-} determineLag :: (Class.Real a) => SVL.Vector a -> SVL.Vector a -> Int determineLag xs ys = let zs = correlate xs ys diff --git a/src/CorrelateResample.hs b/src/CorrelateResample.hs --- a/src/CorrelateResample.hs +++ b/src/CorrelateResample.hs @@ -1,7 +1,7 @@ module CorrelateResample where import Vector (findPeak, mulConj) -import Common (cyclicFromVector, pad) +import Common (fourierRC) import qualified Numeric.FFTW.Shape as Spectrum import qualified Numeric.FFTW.Rank1 as Trafo1 @@ -16,6 +16,13 @@ import Algebra.IntegralDomain (divUp) +{- $setup +>>> import qualified Test.QuickCheck as QC +>>> import qualified Data.StorableVector.Lazy as SVL +>>> import Data.Monoid ((<>)) +-} + + adjust :: (Shape.C sh0, Shape.C sh1, Class.Floating a) => sh1 -> Array sh0 a -> Array sh1 a @@ -48,11 +55,30 @@ shz = Spectrum.Half $ paddedAtRate dstRate in Trafo1.fourierCR $ mulConj - (adjust shz $ Trafo1.fourierRC $ - cyclicFromVector $ pad (paddedAtRate xrate) xs) - (adjust shz $ Trafo1.fourierRC $ - cyclicFromVector $ pad (paddedAtRate yrate) ys) + (adjust shz $ fourierRC (paddedAtRate xrate) xs) + (adjust shz $ fourierRC (paddedAtRate yrate) ys) +{- | +For rates different from one the test fails occasionally. + +prop> :{ + QC.forAll (QC.choose (1,1)) $ \rateX -> + QC.forAll (QC.choose (1,1)) $ \rateY -> + \(QC.NonNegative preX, QC.NonNegative postX) -> + \(QC.NonNegative preY, QC.NonNegative postY) -> + \(QC.NonEmpty xs) -> + all (0/=) xs QC.==> + + preX - preY + QC.=== + let pack rate = + SVL.pack SVL.defaultChunkSize $ concatMap (replicate rate) xs in + let pad rate n = SVL.replicate SVL.defaultChunkSize (rate*n) (0::Float) in + determineLag 1 + (fromIntegral rateX, pad rateX preX <> pack rateX <> pad rateX postX) + (fromIntegral rateY, pad rateY preY <> pack rateY <> pad rateY postY) +:} +-} determineLag :: (Class.Real a) => Integer -> (Integer, SVL.Vector a) -> (Integer, SVL.Vector a) -> Int diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -61,7 +61,8 @@ exitFailureMsg "sample rates are fractional and differ" let (ref,lag) = absLag $ Correlate.determineLag audio0 audio1 printf - "you must delay the %s source by %d samples at %f, i.e. %.6f seconds\n" + ("you must delay the %s source by %d samples at rate %f Hz, " + ++ "i.e. %.6f seconds\n") ref lag rate0 (fromIntegral lag / rate0) Just (irate0,irate1) -> do let dstRate = Option.rate opt @@ -69,5 +70,7 @@ CorrelateResample.determineLag dstRate (irate0,audio0) (irate1,audio1) printf - "you must delay the %s source by %d samples at %d, i.e. %.3f seconds\n" - ref lag dstRate (fromIntegral lag / fromInteger dstRate :: Double) + ("you must delay the %s source by %d samples at rate %d Hz, " + ++ "i.e. %.3f seconds\n") + ref lag dstRate + (fromIntegral lag / fromInteger dstRate :: Double) diff --git a/src/Option.hs b/src/Option.hs --- a/src/Option.hs +++ b/src/Option.hs @@ -29,7 +29,7 @@ <> metavar "0..3" <> help "verbosity" ) <*> OP.option - (OP.eitherReader $ parseNumber "sample rate" (0<=) "non-negative") + (OP.eitherReader $ parseNumber "sample rate" (0<) "positive") ( value 1000 <> short 'r' <> long "rate" diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,12 @@ +-- Do not edit! Automatically created with doctest-extract. +module Main where + +import qualified Test.Correlate +import qualified Test.CorrelateResample + +import qualified Test.DocTest.Driver as DocTest + +main :: IO () +main = DocTest.run $ do + Test.Correlate.test + Test.CorrelateResample.test diff --git a/test/Test/Correlate.hs b/test/Test/Correlate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Correlate.hs @@ -0,0 +1,53 @@ +-- Do not edit! Automatically created with doctest-extract from src/Correlate.hs +{-# LINE 16 "src/Correlate.hs" #-} + +module Test.Correlate where + +import Correlate +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 17 "src/Correlate.hs" #-} +import qualified Test.QuickCheck as QC +import qualified Data.StorableVector.Lazy as SVL +import Data.Monoid ((<>)) + +test :: DocTest.T () +test = do + DocTest.printPrefix "Correlate:28: " +{-# LINE 28 "src/Correlate.hs" #-} + DocTest.example( +{-# LINE 28 "src/Correlate.hs" #-} + map ceilingFFTSize [1..40] + ) + [ExpectedLine [LineChunk "[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,18,18,20,20,22,22,24,24,26,26,28,28,30,30,32,32,36,36,36,36,40,40,40,40]"]] + DocTest.printPrefix "Correlate:30: " +{-# LINE 30 "src/Correlate.hs" #-} + DocTest.property( +{-# LINE 30 "src/Correlate.hs" #-} + \n -> n <= ceilingFFTSize n + ) + DocTest.printPrefix "Correlate:31: " +{-# LINE 31 "src/Correlate.hs" #-} + DocTest.property( +{-# LINE 31 "src/Correlate.hs" #-} + \(QC.Positive n) -> ceilingFFTSize n * 8 <= n * 9 + ) + DocTest.printPrefix "Correlate:53: " +{-# LINE 53 "src/Correlate.hs" #-} + DocTest.property( +{-# LINE 53 "src/Correlate.hs" #-} + + \(QC.NonNegative preX, QC.NonNegative postX) -> + \(QC.NonNegative preY, QC.NonNegative postY) -> + \(QC.NonEmpty xs) -> + all (0/=) xs QC.==> + + preX - preY + QC.=== + let v = SVL.pack SVL.defaultChunkSize xs in + let pad n = SVL.replicate SVL.defaultChunkSize n (0::Float) in + determineLag + (pad preX <> v <> pad postX) + (pad preY <> v <> pad postY) + ) diff --git a/test/Test/CorrelateResample.hs b/test/Test/CorrelateResample.hs new file mode 100644 --- /dev/null +++ b/test/Test/CorrelateResample.hs @@ -0,0 +1,36 @@ +-- Do not edit! Automatically created with doctest-extract from src/CorrelateResample.hs +{-# LINE 19 "src/CorrelateResample.hs" #-} + +module Test.CorrelateResample where + +import CorrelateResample +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 20 "src/CorrelateResample.hs" #-} +import qualified Test.QuickCheck as QC +import qualified Data.StorableVector.Lazy as SVL +import Data.Monoid ((<>)) + +test :: DocTest.T () +test = do + DocTest.printPrefix "CorrelateResample:64: " +{-# LINE 64 "src/CorrelateResample.hs" #-} + DocTest.property( +{-# LINE 64 "src/CorrelateResample.hs" #-} + + QC.forAll (QC.choose (1,1)) $ \rateX -> + QC.forAll (QC.choose (1,1)) $ \rateY -> + \(QC.NonNegative preX, QC.NonNegative postX) -> + \(QC.NonNegative preY, QC.NonNegative postY) -> + \(QC.NonEmpty xs) -> + all (0/=) xs QC.==> + + preX - preY + QC.=== + let pack rate = + SVL.pack SVL.defaultChunkSize $ concatMap (replicate rate) xs in + let pad rate n = SVL.replicate SVL.defaultChunkSize (rate*n) (0::Float) in + determineLag 1 + (fromIntegral rateX, pad rateX preX <> pack rateX <> pad rateX postX) + (fromIntegral rateY, pad rateY preY <> pack rateY <> pad rateY postY) + )