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"