split-record 0.1 → 0.1.1
raw patch · 2 files changed
+90/−114 lines, 2 filesdep ~storablevector
Dependency ranges changed: storablevector
Files
- split-record.cabal +3/−3
- src/Main.hs +87/−111
split-record.cabal view
@@ -1,5 +1,5 @@ Name: split-record-Version: 0.1+Version: 0.1.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -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,
src/Main.hs view
@@ -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 ()