split-record (empty) → 0.1
raw patch · 4 files changed
+516/−0 lines, 4 filesdep +basedep +numeric-preludedep +soxlibsetup-changed
Dependencies added: base, numeric-prelude, soxlib, storablevector, synthesizer-core, transformers, utility-ht
Files
- LICENSE +31/−0
- Setup.lhs +3/−0
- split-record.cabal +42/−0
- src/Main.hs +440/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2012, 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:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER 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
+ split-record.cabal view
@@ -0,0 +1,42 @@+Name: split-record+Version: 0.1+License: BSD3+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+Homepage: http://code.haskell.org/~thielema/split-record/+Category: Sound+Synopsis: Split a big audio file into pieces at positions of silence+Description: Split a big audio file into pieces at positions of silence+Tested-With: GHC==6.12.3+Cabal-Version: >=1.6+Build-Type: Simple++Source-Repository this+ Tag: 0.1+ Type: darcs+ Location: http://code.haskell.org/~thielema/split-record/++Source-Repository head+ Type: darcs+ Location: http://code.haskell.org/~thielema/split-record/++Executable split-record+ Main-Is: Main.hs+ Hs-Source-Dirs: src++ Build-Depends:+ synthesizer-core >=0.5.1 && <0.6,+ soxlib >=0.0 && <0.1,+ storablevector >=0.2 && <0.3,+ transformers >=0.2 && <0.4,+ utility-ht >=0.0.1 && <0.1,+ numeric-prelude >=0.3 && <0.4,+ base >=4 && <5++ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates++ If impl(ghc>=7.0)+ GHC-Options: -fwarn-unused-do-bind+ CPP-Options: -DNoImplicitPrelude=RebindableSyntax+ Extensions: CPP
+ src/Main.hs view
@@ -0,0 +1,440 @@+module Main where++import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Cut as Cut+import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Frame.Stereo as Stereo+import qualified Synthesizer.Basic.Binary as Bin++import qualified Sound.SoxLib as SoxLib++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector.Base as SVB+import qualified Data.StorableVector as SV+import Foreign.ForeignPtr (castForeignPtr, )+import Foreign.Storable (Storable, peek, )++import qualified Control.Monad.Trans.State as MS+import Control.Monad (when, )+import Control.Arrow (Arrow, arr, (<<<), (^<<), )++import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Tuple.HT (swap, )+import Data.Foldable (forM_, )++import qualified System.Console.GetOpt as Opt+import System.Console.GetOpt+ (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), )+import System.Environment (getArgs, getProgName, )+import qualified System.Exit as Exit+import qualified System.IO as IO+import Text.Printf (printf, )++import qualified Algebra.RealRing as Real+import NumericPrelude.Numeric+import NumericPrelude.Base++import Data.Int (Int32, )++import Prelude ()+++-- * parameters++newtype Time = Time Float+ deriving (Eq, Show)++newtype Freq = Freq Float+ deriving (Eq, Show)++data Flags =+ Flags {+ flagComputeEnvelope :: Bool,+ flagSampleRate :: Maybe SoxLib.Rate,+ flagSmooth, flagHumFreq :: Freq,+ flagPauseVolume :: Float,+ flagMinPause, flagPreStart :: Time,+ flagBlocksize :: SVL.ChunkSize+ }++defltFlags :: Flags+defltFlags =+ Flags {+ flagComputeEnvelope = False,+ flagSampleRate = Nothing,+ flagSmooth = Freq 1,+ flagHumFreq = Freq 100,+ flagPauseVolume = 0.02,+ flagMinPause = Time 2,+ {-+ Sometimes a piece starts with breath which is almost undetectable.+ Thus we start a little bit earlier than necessary.+ -}+ -- flagPreStart = Time 1.5,+ flagPreStart = Time 0.05,+ flagBlocksize = SVL.chunkSize 65536+ }+++data Params =+ Params {+ sampleRate :: SoxLib.Rate,+ smooth, humFreq :: Float,+ pauseVolume :: Float,+ minPause, preStart :: Int+ }+++defaultSampleRate :: SoxLib.Rate+defaultSampleRate = 44100++freq :: SoxLib.Rate -> (Flags -> Freq) -> (Flags -> Float)+freq sr acc flags =+ (case acc flags of Freq f -> f) / realToFrac sr++time :: SoxLib.Rate -> (Flags -> Time) -> (Flags -> Int)+time sr acc flags =+ round ((case acc flags of Time t -> t) * realToFrac sr)++formatFreq :: Freq -> String+formatFreq (Freq t) = show t -- ++ "Hz"++formatTime :: Time -> String+formatTime (Time t) = show t -- ++ "s"+++exitFailureMsg :: String -> IO a+exitFailureMsg msg = do+ IO.hPutStrLn IO.stderr msg+ Exit.exitFailure++parseCard :: (Read a, Real.C a) => String -> String -> IO a+parseCard name str =+ case reads str of+ [(n,"")] ->+ case compare n zero of+ GT -> return n+ EQ -> exitFailureMsg $ name ++ " must not be zero"+ LT -> exitFailureMsg $ "negative " ++ name ++ ": " ++ str+ _ -> exitFailureMsg $ "could not parse " ++ name ++ " " ++ show str++numberArg ::+ (Read a, Real.C a) =>+ String -> (a -> Flags -> IO Flags) ->+ Opt.ArgDescr (Flags -> IO Flags)+numberArg name update =+ flip ReqArg name $ \str flags ->+ flip update flags =<< parseCard name str++description :: [ Opt.OptDescr (Flags -> IO Flags) ]+description =+ Opt.Option ['h'] ["help"]+ (NoArg $ \ _flags -> do+ programName <- getProgName+ putStrLn $+ usageInfo ("Usage: " ++ programName ++ " [OPTIONS] INPUT [OUTPUT]") $+ description+ Exit.exitSuccess)+ "show options" :+ Opt.Option ['r'] ["rate"]+ (numberArg "SAMPLERATE" $ \n flags ->+ return $ flags{flagSampleRate = Just n})+ ("sample rate, default " ++ show defaultSampleRate) :+ Opt.Option [] ["pause-volume"]+ (numberArg "AMPLITUDE" $ \n flags ->+ return $ flags{flagPauseVolume = n})+ ("required maximum amplitude in pauses between pieces, default " ++ show (flagPauseVolume defltFlags)) :+ Opt.Option [] ["smooth"]+ (numberArg "FREQUENCY" $ \n flags ->+ return $ flags{flagSmooth = Freq n})+ ("cutoff frequency for smoothing envelope, default " ++ formatFreq (flagSmooth defltFlags)) :+ Opt.Option [] ["hum-frequency"]+ (numberArg "FREQUENCY" $ \n flags ->+ return $ flags{flagHumFreq = Freq n})+ ("cutoff frequency for hum elimination, default " ++ formatFreq (flagHumFreq defltFlags)) :+ Opt.Option [] ["min-pause"]+ (numberArg "TIME" $ \n flags ->+ return $ flags{flagMinPause = Time n})+ ("minimal required pause between pieces, default " ++ formatTime (flagMinPause defltFlags)) :+ Opt.Option [] ["pre-start"]+ (numberArg "TIME" $ \n flags ->+ return $ flags{flagPreStart = Time n})+ ("time to start before threshold is exceeded, default " ++ formatTime (flagPreStart defltFlags)) :+ Opt.Option [] ["blocksize"]+ (numberArg "NUMSAMPLES" $ \n flags ->+ return $ flags{flagBlocksize = SVL.chunkSize n})+ ("size of processing chunks, default " +++ case flagBlocksize defltFlags of SVL.ChunkSize size -> show size) :+ Opt.Option [] ["compute-envelope"]+ (NoArg $ \ flags -> do+ return $ flags{flagComputeEnvelope = True})+ "compute envelope for assistance in finding appropriate parameters" :+ []+++-- * computation++stereoFloatFromInt ::+ (Arrow arrow) =>+ arrow (Stereo.T Int32) (Stereo.T Float)+stereoFloatFromInt =+ arr $ fmap Bin.toCanonical++stereoIntFromFloat ::+ (Arrow arrow) =>+ arrow (Stereo.T Float) (Stereo.T Int32)+stereoIntFromFloat =+ arr $ fmap (Bin.fromCanonicalWith Real.roundSimple)++dehum :: Params -> Causal.T (Stereo.T Float) (Stereo.T Float)+dehum params =+ Filt1.highpass_+ ^<<+ Filt1.causal+ <<<+ Causal.feedConstFst (Filt1.parameter (humFreq params))++trackEnvelope :: Params -> Causal.T (Stereo.T Float) Float+trackEnvelope params =+ Filt1.lowpassCausal+ <<<+ Causal.feedConstFst (Filt1.parameter (smooth params))+ <<<+ Causal.map (\x -> sqrt (Stereo.left x^2 + Stereo.right x^2))++threshold :: Params -> Causal.T Float Bool+threshold params = Causal.map (< pauseVolume params)++findStarts :: Params -> Causal.T Bool Bool+findStarts params =+ flip Causal.fromState 0 $ \b ->+ if b+ then MS.modify succ >> evalReturn False+ else do n <- MS.get; MS.put 0; return (n >= minPause params)++measurePauses :: Causal.T Bool (Maybe Int)+measurePauses =+ flip Causal.fromState 0 $ \b ->+ if b+ then do n <- MS.get; MS.put 1; return (Just n)+ else MS.modify succ >> evalReturn Nothing++evalReturn :: a -> MS.State Int a+evalReturn x =+ MS.gets (\n -> seq n x)++pieceDurations :: Params -> SVL.Vector (Stereo.T Int32) -> [Int]+pieceDurations params =+-- catMaybes . Sig.toList .+ Sig.foldR (maybe id (:)) [] .+ Causal.apply+ (measurePauses <<< findStarts params <<<+ threshold params <<< trackEnvelope params <<< dehum params <<<+ stereoFloatFromInt) .+ Sig.fromStorableSignal++prefetch :: Int -> [Int] -> [Int]+prefetch _ [] = []+prefetch n (s:ss) =+ if s <= n+ then prefetch (n-s) ss+ else (s-n) : ss++chop, chopLazy ::+ Params -> SVL.Vector (Stereo.T Int32) -> [SVL.Vector (Stereo.T Int32)]+chop params sig0 =+ snd $ List.mapAccumL (\sig n -> swap $ SVL.splitAt n sig) sig0 $+ prefetch (preStart params) $ pieceDurations params sig0++chopLazy params sig =+ flip Cut.chopStorable sig .+ flip Sig.append (Sig.repeat False) .+ Sig.drop (preStart params) .+ Causal.apply+ (findStarts params <<< threshold params <<<+ trackEnvelope params <<< dehum params <<<+ stereoFloatFromInt) .+ Sig.fromStorableSignal $ sig+++-- * driver++withSound ::+ Flags -> FilePath ->+ (SoxLib.Format SoxLib.ReadMode ->+ Params -> SVL.Vector (Stereo.T Int32) -> IO b) ->+ IO b+withSound flags path act =+ SoxLib.withRead SoxLib.defaultReaderInfo path $ \fmtPtr -> do+ fmt <- peek fmtPtr+ case SoxLib.channels $ SoxLib.signalInfo fmt of+ Nothing ->+ ioError $ userError "could not determine number of channels"+ Just numChan ->+ if numChan/=2+ then ioError $ userError "currently we support only stereo signals"+ else+ let rate =+ case flagSampleRate flags of+ Just r -> r+ Nothing ->+ case SoxLib.rate $ SoxLib.signalInfo fmt of+ Just r -> r+ Nothing -> defaultSampleRate+ params =+ Params {+ sampleRate = rate,+ smooth = freq rate flagSmooth flags,+ humFreq = freq rate flagHumFreq flags,+ pauseVolume = flagPauseVolume flags,+ minPause = time rate flagMinPause flags,+ preStart = time rate flagPreStart flags+ }+ in act fmt params . stereoFromInterleavedLazy =<<+ SoxLib.readStorableVectorLazy fmtPtr+ (case flagBlocksize flags of+ SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size)++stereoFromInterleavedLazy ::+ (Storable a) =>+ SVL.Vector a -> SVL.Vector (Stereo.T a)+stereoFromInterleavedLazy =+ SVL.fromChunks .+ map stereoFromInterleaved .+ SVL.chunks++stereoFromInterleaved ::+ (Storable a) =>+ SV.Vector a -> SV.Vector (Stereo.T a)+stereoFromInterleaved v =+ let d = 2+ (fptr,s,l) = SVB.toForeignPtr v+ in case (divMod s d, divMod l d) of+ ((sd,0), (ld,0)) -> SVB.SV (castForeignPtr fptr) sd ld+ _ -> error "stereoFromInterleaved: length and start must be even"++interleavedFromStereoLazy ::+ (Storable a) =>+ SVL.Vector (Stereo.T a) -> SVL.Vector a+interleavedFromStereoLazy =+ SVL.fromChunks .+ map interleavedFromStereo .+ SVL.chunks++interleavedFromStereo ::+ (Storable a) =>+ SV.Vector (Stereo.T a) -> SV.Vector a+interleavedFromStereo v =+ let d = 2+ (fptr,s,l) = SVB.toForeignPtr v+ in SVB.SV (castForeignPtr fptr) (s*d) (l*d)+++shorten :: (Storable a) => SVL.Vector a -> SVL.Vector a+shorten = SVL.take (25*10^6)++monoInfoFromFormat ::+ SoxLib.Format mode -> Params -> SoxLib.WriterInfo+monoInfoFromFormat fmtIn params =+ SoxLib.defaultWriterInfo {+ SoxLib.writerSignalInfo = Just $+ (SoxLib.signalInfo fmtIn) {+ SoxLib.channels = Just 1,+ SoxLib.rate = Just $ sampleRate params+ },+ SoxLib.writerEncodingInfo = Just $ SoxLib.encodingInfo fmtIn+ }++writerInfoFromFormat ::+ SoxLib.Format mode -> Params -> SoxLib.WriterInfo+writerInfoFromFormat fmtIn params =+ SoxLib.defaultWriterInfo {+ SoxLib.writerSignalInfo = Just $+ (SoxLib.signalInfo fmtIn) {+ SoxLib.rate = Just $ sampleRate params+ },+ SoxLib.writerEncodingInfo = Just $ SoxLib.encodingInfo fmtIn+ }++runDehum :: Flags -> FilePath -> FilePath -> IO ()+runDehum flags input output =+ withSound flags input $ \fmtIn params sig ->+ SoxLib.withWrite+ (writerInfoFromFormat fmtIn params)+ output $ \fmtOut ->+ SoxLib.writeStorableVectorLazy fmtOut $+ interleavedFromStereoLazy $+ Causal.apply+ (stereoIntFromFloat <<< dehum params <<< stereoFloatFromInt)+ sig++runEnvelope :: Flags -> FilePath -> FilePath -> IO ()+runEnvelope flags input output =+ withSound flags input $ \fmtIn params sig ->+ SoxLib.withWrite+ (monoInfoFromFormat fmtIn params)+ output $ \fmtOut ->+ SoxLib.writeStorableVectorLazy fmtOut $+ Causal.apply+ (arr (Bin.fromCanonicalWith Real.roundSimple) <<<+ trackEnvelope params <<< dehum params <<<+ stereoFloatFromInt)+ sig++runSizes :: Flags -> FilePath -> IO ()+runSizes flags input =+ withSound flags input $ \_fmt params sig ->+ mapM_ print $ pieceDurations params sig++runLabels :: Flags -> FilePath -> IO ()+runLabels flags input =+ withSound flags input $ \_fmt params sig ->+ mapM_ (\(n, (from,to)) -> printf "%s\t%s\t%d\n" from to n) $+ zip [(0::Int) ..] $+ ListHT.mapAdjacent (,) $+ map (\t ->+ case divMod (Real.roundSimple (fromIntegral t * 10^6 / sampleRate params)) (10^6) of+ (seconds,micros) ->+ printf "%d,%06d" seconds (micros::Integer) :: String) $+ scanl (+) 0 $+ prefetch (preStart params) $+ pieceDurations params sig++{- |+> runChop "in.wav" "%03d.wav" flags+-}+runChop :: Flags -> FilePath -> FilePath -> IO ()+runChop flags input output =+ withSound flags input $ \fmtIn params sig ->+ forM_ (zip [(0::Int)..] $ chopLazy params sig) $ \(n,piece) ->+ SoxLib.withWrite+ (writerInfoFromFormat fmtIn params)+ (printf output n) $ \fmtOut ->+ SoxLib.writeStorableVectorLazy fmtOut $+ interleavedFromStereoLazy piece+++main :: IO ()+main = do+ argv <- getArgs+ let (opts, files, errors) =+ getOpt Opt.RequireOrder description argv+ when (not $ null errors) $+ exitFailureMsg (init (concat errors))++ flags <- foldl (>>=) (return defltFlags) opts++ if flagComputeEnvelope flags+ then+ case files of+ [input,output] -> runEnvelope flags input output+ [] -> exitFailureMsg "need input and output file envelope computation"+ _ -> exitFailureMsg "more than two file names given"+ else+ case files of+ [input,output] -> runChop flags input output+ [input] -> runLabels flags input+ [] -> exitFailureMsg "no input or output given"+ _ -> exitFailureMsg "more than two file names given"