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"