packages feed

split-record (empty) → 0.1.1.4

raw patch · 4 files changed

Files

+ 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,53 @@+Cabal-Version:  2.2+Name:           split-record+Version:        0.1.1.4+License:        BSD-3-Clause+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.+  You can use this to split a recording of multiple songs into single songs.+  .+  > $ split-record recording.wav "part%03d.wav"+  .+  You can also calculate split positions only. They are computed lazily.+  They can be loaded into Audacity for further fine tuning+  and to perform the actual split.+  For generating only labels, run:+  .+  > $ split-record recording.wav > labels.txt+Tested-With:    GHC==6.12.3+Build-Type:     Simple++Source-Repository this+  Tag:         0.1.1.4+  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++  Default-Language: Haskell98+  Build-Depends:+    synthesizer-core >=0.5.1 && <0.9,+    soxlib >=0.0 && <0.1,+    storablevector >=0.2.8 && <0.3,+    shell-utility >=0.0 && <0.2,+    transformers >=0.2 && <0.7,+    utility-ht >=0.0.1 && <0.1,+    numeric-prelude >=0.3 && <0.5,+    base >=4 && <5++  GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind
+ src/Main.hs view
@@ -0,0 +1,410 @@+module Main where++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.ChunkySize.Cut as CutCS+import qualified Synthesizer.ChunkySize as ChunkySize+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.Basic.Binary as Bin++import qualified Sound.SoxLib as SoxLib++import qualified Data.StorableVector.Lazy as SVL+import Foreign.Storable (peek, )++import qualified Control.Monad.Trans.State as MS+import Control.Monad (when, )+import Control.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 Data.Maybe (fromMaybe, )++import qualified System.Console.GetOpt as Opt+import System.Console.GetOpt+          (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), )+import System.Environment (getArgs, getProgName, )+import Text.Printf (printf, )++import qualified System.Exit as Exit+import Shell.Utility.Exit (exitFailureMsg)++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,+      numChannels :: Int,+      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"+++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++dehum :: Params -> Causal.T Float Float+dehum params =+   Filt1.highpass_+   ^<<+   Filt1.causal+   <<<+   Causal.feedConstFst (Filt1.parameter (humFreq params))++trackEnvelope :: Params -> [SVL.Vector Float] -> SVL.Vector Float+trackEnvelope params =+   Causal.apply+      (Filt1.lowpassCausal+       <<<+       Causal.feedConstFst (Filt1.parameter (smooth params))+       <<<+       arr sqrt)+   .+   foldl SigSt.mix SVL.empty++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 Int32 -> [Int]+pieceDurations params =+--   catMaybes . Sig.toList .+   Sig.foldR (maybe id (:)) [] .+   Causal.apply+      (measurePauses <<< findStarts params <<< threshold params) .+   Sig.fromStorableSignal .+   trackEnvelope params .+   map (Causal.apply (arr (^2) <<< dehum params <<< arr Bin.toCanonical)) .+   SVL.deinterleave (numChannels params)++pieceDurationsPrefetchLazy :: Params -> SVL.Vector Int32 -> [ChunkySize.T]+pieceDurationsPrefetchLazy params sig =+   flip Cut.chopChunkySize (CutCS.length sig) .+   flip Sig.append (Sig.repeat False) .+   Sig.drop (preStart params) .+   Causal.apply (findStarts params <<< threshold params) .+   Sig.fromStorableSignal .+   trackEnvelope params .+   map (Causal.apply (arr (^2) <<< dehum params <<< arr Bin.toCanonical)) .+   SVL.deinterleave (numChannels params) $ sig+++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 Int32 -> [SVL.Vector Int32]+chop params sig0 =+   snd $+   List.mapAccumL (\sig n -> swap $ SVL.splitAt n sig) sig0 $+   map (numChannels params *) .+   prefetch (preStart params) $ pieceDurations params sig0++chopLazy params sig0 =+   snd $+   List.mapAccumL (\sig n -> swap $ CutCS.splitAt n sig) sig0 $+   map (fromIntegral (numChannels params) *) .+   pieceDurationsPrefetchLazy params $ sig0++++-- * driver++withSound ::+   Flags -> FilePath ->+   (SoxLib.Format SoxLib.ReadMode ->+    Params -> SVL.Vector Int32 -> IO b) ->+   IO b+withSound flags path act =+   SoxLib.withRead SoxLib.defaultReaderInfo path $ \fmtPtr -> do+      fmt <- peek fmtPtr+      let numChan =+             fromMaybe 1 $ SoxLib.channels $ SoxLib.signalInfo fmt+          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,+                numChannels = numChan,+                smooth = freq rate flagSmooth flags,+                humFreq = freq rate flagHumFreq flags,+                pauseVolume = flagPauseVolume flags,+                minPause = time rate flagMinPause flags,+                preStart = time rate flagPreStart flags+             }+      act fmt params =<<+         SoxLib.readStorableVectorLazy fmtPtr+            (case flagBlocksize flags of+               SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size)+++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 $+         SVL.interleaveFirstPattern $+         map+            (Causal.apply+               (arr (Bin.fromCanonicalWith Real.roundSimple)+                <<<+                dehum params+                <<<+                arr Bin.toCanonical)) $+         SVL.deinterleave (numChannels params) 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 $+         map+            (Causal.apply+               (arr (^2)+                <<<+                dehum params+                <<<+                arr Bin.toCanonical)) $+         SVL.deinterleave (numChannels params) 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+         -- FIXME: the comma is certainly only correct in German locale+         (seconds,micros) ->+            printf "%d,%06d" seconds (micros::Integer) :: String) $+   scanl (+) 0 $+   prefetch (preStart params) $+   pieceDurations params sig++{- |+> runChop flags "in.wav" "%03d.wav"+-}+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 piece+++main :: IO ()+main = SoxLib.formatWith $ 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"