diff --git a/split-record.cabal b/split-record.cabal --- a/split-record.cabal +++ b/split-record.cabal @@ -1,5 +1,5 @@ Name: split-record -Version: 0.1 +Version: 0.1.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -13,7 +13,7 @@ Build-Type: Simple Source-Repository this - Tag: 0.1 + Tag: 0.1.1 Type: darcs Location: http://code.haskell.org/~thielema/split-record/ @@ -28,7 +28,7 @@ Build-Depends: synthesizer-core >=0.5.1 && <0.6, soxlib >=0.0 && <0.1, - storablevector >=0.2 && <0.3, + storablevector >=0.2.8 && <0.3, transformers >=0.2 && <0.4, utility-ht >=0.0.1 && <0.1, numeric-prelude >=0.3 && <0.4, diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,18 +1,17 @@ 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.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 @@ -23,6 +22,7 @@ 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 @@ -81,6 +81,7 @@ data Params = Params { sampleRate :: SoxLib.Rate, + numChannels :: Int, smooth, humFreq :: Float, pauseVolume :: Float, minPause, preStart :: Int @@ -176,19 +177,7 @@ -- * 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 -> Causal.T Float Float dehum params = Filt1.highpass_ ^<< @@ -196,13 +185,16 @@ <<< Causal.feedConstFst (Filt1.parameter (humFreq params)) -trackEnvelope :: Params -> Causal.T (Stereo.T Float) Float +trackEnvelope :: Params -> [SVL.Vector Float] -> SVL.Vector Float trackEnvelope params = - Filt1.lowpassCausal - <<< - Causal.feedConstFst (Filt1.parameter (smooth params)) - <<< - Causal.map (\x -> sqrt (Stereo.left x^2 + Stereo.right x^2)) + 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) @@ -225,16 +217,29 @@ evalReturn x = MS.gets (\n -> seq n x) -pieceDurations :: Params -> SVL.Vector (Stereo.T Int32) -> [Int] +pieceDurations :: Params -> SVL.Vector 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 + (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) = @@ -243,93 +248,54 @@ else (s-n) : ss chop, chopLazy :: - Params -> SVL.Vector (Stereo.T Int32) -> [SVL.Vector (Stereo.T Int32)] + Params -> SVL.Vector Int32 -> [SVL.Vector Int32] chop params sig0 = - snd $ List.mapAccumL (\sig n -> swap $ SVL.splitAt n sig) sig0 $ + snd $ + List.mapAccumL (\sig n -> swap $ SVL.splitAt n sig) sig0 $ + map (numChannels params *) . 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 +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 (Stereo.T Int32) -> IO b) -> + Params -> SVL.Vector 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) + 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) shorten :: (Storable a) => SVL.Vector a -> SVL.Vector a @@ -365,10 +331,15 @@ (writerInfoFromFormat fmtIn params) output $ \fmtOut -> SoxLib.writeStorableVectorLazy fmtOut $ - interleavedFromStereoLazy $ - Causal.apply - (stereoIntFromFloat <<< dehum params <<< stereoFloatFromInt) - sig + 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 = @@ -378,10 +349,16 @@ output $ \fmtOut -> SoxLib.writeStorableVectorLazy fmtOut $ Causal.apply - (arr (Bin.fromCanonicalWith Real.roundSimple) <<< - trackEnvelope params <<< dehum params <<< - stereoFloatFromInt) - sig + (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 = @@ -412,8 +389,7 @@ SoxLib.withWrite (writerInfoFromFormat fmtIn params) (printf output n) $ \fmtOut -> - SoxLib.writeStorableVectorLazy fmtOut $ - interleavedFromStereoLazy piece + SoxLib.writeStorableVectorLazy fmtOut piece main :: IO ()