synthesizer-core 0.4.1 → 0.4.2
raw patch · 10 files changed
+552/−14 lines, 10 files
Files
- src-3/Synthesizer/Causal/Process.hs +25/−3
- src-4/Synthesizer/Causal/Process.hs +25/−3
- src/Synthesizer/Causal/Spatial.hs +3/−3
- src/Synthesizer/CausalIO/Process.hs +217/−0
- src/Synthesizer/PiecewiseConstant/Signal.hs +202/−0
- src/Synthesizer/Plain/Effect/Fly.hs +1/−1
- src/Synthesizer/Plain/Miscellaneous.hs +1/−1
- src/Synthesizer/State/Miscellaneous.hs +2/−1
- src/Synthesizer/Zip.hs +71/−0
- synthesizer-core.cabal +5/−2
src-3/Synthesizer/Causal/Process.hs view
@@ -15,7 +15,7 @@ and avoid the ST monad here? -} module Synthesizer.Causal.Process (- T,+ T(Cons), fromStateMaybe, fromState, fromSimpleModifier,@@ -44,6 +44,7 @@ applyConst, apply2, apply3,+ applyStorableChunk, feed, feedFst,@@ -74,10 +75,13 @@ import qualified Synthesizer.Plain.Modifier as Modifier --- import qualified Control.Arrow as Arrow+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV +import Foreign.Storable (Storable, )+ import Control.Arrow- (Arrow(..), returnA, (<<<), (^>>), {- ArrowApply(..), -} ArrowLoop(..),+ (Arrow(..), returnA, (<<<), (^>>), ArrowLoop(..), Kleisli(Kleisli), runKleisli, ) import Control.Monad.Trans.State (State, state, runState,@@ -291,6 +295,24 @@ T (a,b,c) d -> sig a -> sig b -> sig c -> sig d apply3 f x y z = apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-+A generalized version could be of type++Transform sig a b => Causal.T a b -> Causal.T (sig a) (sig b)++but we cannot implement that,+since crochetL does not return the final state.+-}+applyStorableChunk ::+ (Storable a, Storable b) =>+ T a b -> T (SV.Vector a) (SV.Vector b)+applyStorableChunk (Cons next start) = Cons+ (\a -> StateT $ \ms ->+ flip fmap ms $ \s ->+ SVL.crochetLChunk (runStateT . next) s a)+ (Just start) {-# INLINE feed #-}
src-4/Synthesizer/Causal/Process.hs view
@@ -15,7 +15,7 @@ and avoid the ST monad here? -} module Synthesizer.Causal.Process (- T,+ T(Cons), fromStateMaybe, fromState, fromSimpleModifier,@@ -44,6 +44,7 @@ applyConst, apply2, apply3,+ applyStorableChunk, feed, feedFst,@@ -74,11 +75,14 @@ import qualified Synthesizer.Plain.Modifier as Modifier --- import qualified Control.Arrow as Arrow+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV +import Foreign.Storable (Storable, )+ import qualified Control.Category as Cat import Control.Arrow- (Arrow(..), returnA, (<<<), (>>>), (^>>), {- ArrowApply(..), -} ArrowLoop(..),+ (Arrow(..), returnA, (<<<), (>>>), (^>>), ArrowLoop(..), Kleisli(Kleisli), runKleisli, ) import Control.Monad.Trans.State (State, state, runState,@@ -297,6 +301,24 @@ T (a,b,c) d -> sig a -> sig b -> sig c -> sig d apply3 f x y z = apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-+A generalized version could be of type++Transform sig a b => Causal.T a b -> Causal.T (sig a) (sig b)++but we cannot implement that,+since crochetL does not return the final state.+-}+applyStorableChunk ::+ (Storable a, Storable b) =>+ T a b -> T (SV.Vector a) (SV.Vector b)+applyStorableChunk (Cons next start) = Cons+ (\a -> StateT $ \ms ->+ flip fmap ms $ \s ->+ SVL.crochetLChunk (runStateT . next) s a)+ (Just start) {-# INLINE feed #-}
src/Synthesizer/Causal/Spatial.hs view
@@ -13,12 +13,12 @@ {-| simulate an moving sounding object -convert the way of the object through 3D space+convert the way of the object through 2D or 3D space into a delay and attenuation information, sonicDelay is the reciprocal of the sonic velocity -}-receive3Dsound ::+moveAround :: (Field.C a, Euc.C a v, Arrow arrow) => a -> a -> v -> arrow v (a,a)-receive3Dsound att sonicDelay ear =+moveAround att sonicDelay ear = arr ((\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . Euc.norm . subtract ear)
+ src/Synthesizer/CausalIO/Process.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE ExistentialQuantification #-}+{- |+Process chunks of data in the IO monad.+Typical inputs are strict storable vectors and piecewise constant values,+and typical outputs are strict storable vectors.+You may also combine several of these types using the Zip type constructor.++We may substitute IO by ST in the future, but I am uncertain about that.+-}+module Synthesizer.CausalIO.Process where++import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Zip as Zip++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import Foreign.Storable (Storable, )++import Control.Monad.Trans.State (runStateT, )++import qualified Control.Arrow as Arr+import qualified Control.Category as Cat++import Control.Arrow ((^<<), (&&&), )+import Control.Monad (mplus, )++import Data.Monoid (Monoid, mempty, mappend, )++import Data.Tuple.HT (mapSnd, )++import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )+++data T p a b =+ forall state context.+ Cons+ {-+ If the transition function returns a chunk+ that is shorter than the input,+ then this is the last chunk.+ This way we do not need a MaybeT IO.+ -}+ (a -> state -> IO (b, state))+ (p -> IO state)+ {-+ The delete function must not do anything serious,+ e.g. close files,+ because it might not be called.+ Something like 'touchForeignPtr' is reasonable.+ -}+ (state -> IO ())+++instance Cat.Category (T p) where+ id = Arr.arr id+ (Cons nextB createB deleteB) .+ (Cons nextA createA deleteA) = Cons+ (\a (sa0,sb0) -> do+ (b,sa1) <- nextA a sa0+ (c,sb1) <- nextB b sb0+ return (c,(sa1,sb1)))+ (\p -> do+ sa <- createA p+ sb <- createB p+ return (sa,sb))+ (\(sa,sb) ->+ deleteA sa >> deleteB sb)++instance Arr.Arrow (T p) where+ arr f = Cons+ (\ a () -> return (f a, ()))+ (\ _p -> return ())+ (\ () -> return ())+ first (Cons next create delete) = Cons+ (\(b,d) sa0 ->+ do (c,sa1) <- next b sa0+ return ((c,d), sa1))+ create+ delete++fromCausal ::+ (Monoid b) =>+ Causal.T a b -> T p a b+fromCausal (Causal.Cons next start) = Cons+ (\a s0 ->+ return $+ case runStateT (next a) s0 of+ Nothing -> (mempty, s0)+ Just (b,s1) -> (b,s1))+ (\ _p -> return $ start)+ (\ _ -> return ())++mapAccum ::+ (p -> a -> state -> (b, state)) ->+ (p -> state) ->+ T p a b+mapAccum next start =+ Cons+ (\a (p,s) -> return $ mapSnd ((,) p) $ next p a s)+ (\p -> return (p, start p))+ (\ _p -> return ())+++runStorableChunkyCont ::+ (Storable a, Storable b) =>+ T p (SV.Vector a) (SV.Vector b) ->+ IO ((SVL.Vector a -> SVL.Vector b) ->+ p ->+ SVL.Vector a -> SVL.Vector b)+runStorableChunkyCont (Cons next create delete) =+ return $+ \ procRest p sig ->+ SVL.fromChunks $ unsafePerformIO $ do+ state <- create p++ let go xt s0 =+ unsafeInterleaveIO $+ case xt of+ [] -> delete s0 >> return []+ x:xs -> do+ (y,s1) <- next x s0+ (if SV.length y > 0+ then fmap (y:)+ else id) $+ (if SV.length y < SV.length x+ then return $ SVL.chunks $+ procRest $ SVL.fromChunks $+ SV.drop (SV.length y) x : xs+ else go xs s1)+ go (SVL.chunks sig) state+++zip ::+ (Arr.Arrow arrow) =>+ arrow a b -> arrow a c -> arrow a (Zip.T b c)+zip ab ac =+ uncurry Zip.Cons ^<< ab &&& ac+++{- |+@mappend@ should be used sparingly.+In a loop it will have to construct types at runtime+which is rather expensive.+-}+instance (CutG.Transform a, CutG.Read b, Monoid b) => Monoid (T p a b) where+ mempty = Cons+ (\ _a () -> return (mempty, ()))+ (\ _p -> return ())+ (\() -> return ())+ mappend+ (Cons nextB createB deleteB)+ (Cons nextA createA deleteA) = Cons+ (\a s ->+ case s of+ Left (p,s0) -> do+ (b1,s1) <- nextA a s0+ let lenA = CutG.length a+ lenB = CutG.length b1+ case compare lenA lenB of+ LT -> error "CausalIO.Process.mappend: output chunk is larger than input chunk"+ EQ -> return (b1, Left (p,s1))+ GT -> do+ deleteA s1+ s2 <- createB p+ (b3,s3) <- nextB (CutG.drop lenB a) s2+ return (b3, Right s3)+ Right s0 -> do+ (b1,s1) <- nextB a s0+ return (b1, Right s1))+ (\p -> do+ sa <- createA p+ return (Left (p,sa)))+ (\s ->+ case s of+ Left (_p,s0) -> deleteA s0+ Right s0 -> deleteB s0)+++continue ::+ (CutG.Transform a, SigG.Transform sig b) =>+ T p a (sig b) -> T (p,b) a (sig b) -> T p a (sig b)+continue+ (Cons nextA createA deleteA)+ (Cons nextB createB deleteB) = Cons+ (\a s ->+ case s of+ Left (p, lastB0, s0) -> do+ (b1,s1) <- nextA a s0+ let lenA = CutG.length a+ lenB = CutG.length b1+ lastB1 =+ mplus (fmap snd $ SigG.viewR b1) lastB0+ case compare lenA lenB of+ LT -> error "CausalIO.Process.mappend: output chunk is larger than input chunk"+ EQ -> return (b1, Left (p,lastB1,s1))+ GT ->+ case lastB1 of+ Nothing -> return (mempty, Left (p,lastB1,s1))+ Just lastB -> do+ deleteA s1+ s2 <- createB (p, lastB)+ (b3,s3) <- nextB (CutG.drop lenB a) s2+ return (b3, Right s3)+ Right s0 -> do+ (b1,s1) <- nextB a s0+ return (b1, Right s1))+ (\p -> do+ sa <- createA p+ return (Left (p, Nothing, sa)))+ (\s ->+ case s of+ Left (_p,_lastB,s0) -> deleteA s0+ Right s0 -> deleteB s0)
+ src/Synthesizer/PiecewiseConstant/Signal.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.PiecewiseConstant.Signal (+ T,+ StrictTime,+ ShortStrictTime,+ LazyTime,+ subdivideLazy,+ subdivideLazyToShort,+ subdivideLongStrict,+ chopLongTime,+ zipWith,+ ) where++import qualified Data.EventList.Relative.TimeTime as EventListTT+-- import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.BodyTime as EventListBT+-- import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky+import Numeric.NonNegative.Class ((-|), )++import Control.Monad.Trans.State (evalState, get, put, )+import Data.Traversable (traverse, )++import qualified Data.List as List+import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (zipWith, )+import qualified Prelude as P+++type StrictTime = NonNegW.Integer+type ShortStrictTime = NonNegW.Int+type LazyTime = NonNegChunky.T StrictTime++type T = EventListBT.T StrictTime+++{-# INLINE subdivideLazy #-}+subdivideLazy ::+ (NonNeg.C time) =>+ EventListBT.T (NonNegChunky.T time) body ->+ EventListBT.T time body+subdivideLazy =+ EventListBT.foldrPair+ (\y lt r ->+ List.foldr+ (\dt ->+ EventListMT.consBody y .+ EventListMT.consTime dt) r $+ NonNegChunky.toChunks (NonNegChunky.normalize lt))+ EventListBT.empty++{- |+Subdivide lazy times into chunks that fit into the number range+representable by @Int@.+-}+{-# INLINE subdivideLazyToShort #-}+subdivideLazyToShort ::+ EventListBT.T LazyTime y -> EventListBT.T ShortStrictTime y+subdivideLazyToShort =+ subdivideLazy .+ EventListBT.mapTime+ (NonNegChunky.fromChunks .+ List.concatMap chopLongTime .+ NonNegChunky.toChunks)++{- |+Returns a list of non-zero times.+-}+{-# INLINE chopLongTime #-}+chopLongTime :: StrictTime -> [ShortStrictTime]+chopLongTime n =+ let d = fromIntegral (maxBound :: Int)+ (q,r) = P.divMod (NonNegW.toNumber n) d+ in map (NonNegW.fromNumberMsg "chopLongTime" . fromInteger) $+ List.genericReplicate q d +++ if not $ isZero r then [r] else []+++{-# INLINE subdivideLongStrict #-}+subdivideLongStrict ::+ EventListBT.T StrictTime y -> EventListBT.T ShortStrictTime y+subdivideLongStrict =+ subdivideLazy .+ EventListBT.mapTime+ (NonNegChunky.fromChunks . chopLongTime)+++_subdivideMaybe ::+ EventListBT.T LazyTime y -> EventListBT.T StrictTime (Maybe y)+_subdivideMaybe =+ EventListBT.foldrPair+ (\y lt r ->+ case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+ [] -> r+ (t:ts) ->+ EventListBT.cons (Just y) t $+ List.foldr (EventListBT.cons Nothing) r ts)+ EventListBT.empty++{- |+When a lazy time value is split into chunks+then do not just replicate the sample for the whole time,+but insert 'Nothing's.+-}+{-# INLINE subdivideMaybe #-}+subdivideMaybe ::+ EventListTT.T LazyTime y ->+ EventListTT.T StrictTime (Maybe y)+subdivideMaybe =+ EventListTT.foldr+ (\lt r ->+ uncurry EventListMT.consTime $+ case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+ [] ->+ (NonNegW.fromNumber zero, r)+ (t:ts) ->+ (t, List.foldr (EventListBT.cons Nothing) r ts))+ (\y r -> EventListMT.consBody (Just y) r)+ EventListBT.empty++{-# INLINE unionMaybe #-}+unionMaybe ::+ EventListTT.T StrictTime (Maybe y) ->+ EventListTT.T LazyTime y+unionMaybe =+ EventListTT.foldr+ (\t ->+ EventListMT.mapTimeHead+ (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks))+ (\my ->+ case my of+ Nothing -> id+ Just y ->+ EventListMT.consTime NonNegChunky.zero .+ EventListMT.consBody y)+ (EventListTT.pause NonNegChunky.zero)++zipWithCore ::+ (a -> b -> c) ->+ a -> b ->+ EventListTT.T StrictTime (Maybe a) ->+ EventListTT.T StrictTime (Maybe b) ->+ EventListTT.T StrictTime (Maybe c)+zipWithCore f =+ let switch ac ar g =+ flip (EventListMT.switchBodyL EventListBT.empty) ar $ \am ar1 ->+ g (maybe (False,ac) ((,) True) am) ar1+ cont j ac bc as bs =+ EventListMT.consBody (toMaybe j $ f ac bc) $+ recourse ac bc as bs+ recourse ac bc as bs =+ flip EventListMT.switchTimeL as $ \at ar ->+ flip EventListMT.switchTimeL bs $ \bt br ->+ let ct = min at bt+ in -- ToDo: redundant comparison of 'at' and 'bt'+ EventListMT.consTime ct $+ case compare at bt of+ LT ->+ switch ac ar $ \(ab,a) ar1 ->+ cont ab a bc ar1 (EventListMT.consTime (bt-|ct) br)+ GT ->+ switch bc br $ \(bb,b) br1 ->+ cont bb ac b (EventListMT.consTime (at-|ct) ar) br1+ EQ ->+ switch ac ar $ \(ab,a) ar1 ->+ switch bc br $ \(bb,b) br1 ->+ cont (ab||bb) a b ar1 br1+ in recourse++zipWith ::+ (a -> b -> c) ->+ EventListBT.T StrictTime a ->+ EventListBT.T StrictTime b ->+ EventListBT.T StrictTime c+zipWith f as0 bs0 =+ flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->+ flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->+ let c0 = f a0 b0+ in EventListMT.consBody c0 $+ flip evalState c0 $+ traverse (\mc -> maybe (return ()) put mc >> get) $+ zipWithCore f a0 b0 (fmap Just as1) (fmap Just bs1)++_zipWithLazy ::+ (a -> b -> c) ->+ EventListBT.T LazyTime a ->+ EventListBT.T LazyTime b ->+ EventListBT.T LazyTime c+_zipWithLazy f as0 bs0 =+ flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->+ flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->+ EventListMT.consBody (f a0 b0) $ unionMaybe $+ zipWithCore f a0 b0 (subdivideMaybe as1) (subdivideMaybe bs1)+{-+*Synthesizer.PiecewiseConstant.ALSA.MIDI Data.EventList.Relative.MixedTime> zipWithLazy (,) ('a' ./ 2 /. 'b' ./ 7 /. EventListBT.empty) ('c' ./ (1 P.+ 1) /. 'd' ./ 1 /. EventListBT.empty)+-}
src/Synthesizer/Plain/Effect/Fly.hs view
@@ -52,7 +52,7 @@ channel ear = let (phase,volumes) =- unzip $ Causal.apply (Spatial.receive3Dsound 1 0.1 ear) trajectory+ unzip $ Causal.apply (Spatial.moveAround 1 0.1 ear) trajectory -- (*sampleRate) in 'speed' and -- (/sampleRate) in 'freqs' neutralizes speeds = map (\v -> 250/sampleRate + 2 * Euc.norm v)
src/Synthesizer/Plain/Miscellaneous.hs view
@@ -23,4 +23,4 @@ -} receive3Dsound :: (Field.C a, Euc.C a v) => a -> a -> v -> [v] -> ([a],[a]) receive3Dsound att sonicDelay ear =- unzip . Causal.apply (Spatial.receive3Dsound att sonicDelay ear)+ unzip . Causal.apply (Spatial.moveAround att sonicDelay ear)
src/Synthesizer/State/Miscellaneous.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.State.Miscellaneous where+module Synthesizer.State.Miscellaneous+ {-# DEPRECATED "Use Synthesizer.Causal.Spatial instead" #-} where import qualified Synthesizer.State.Signal as Signal
+ src/Synthesizer/Zip.hs view
@@ -0,0 +1,71 @@+module Synthesizer.Zip where++import qualified Synthesizer.Generic.Cut as CutG++import Data.Monoid (Monoid, mempty, mappend, )+++{- |+Parallel combination of two signals of equal length.+-}+data T a b = Cons a b+++instance (Monoid a, Monoid b) => Monoid (T a b) where+ mempty = Cons mempty mempty+ mappend (Cons a0 b0) (Cons a1 b1) =+ Cons (mappend a0 a1) (mappend b0 b1)++instance (CutG.Read a, CutG.Read b) => CutG.Read (T a b) where+ {-# INLINE null #-}+ null (Cons a b) =+ case (CutG.null a, CutG.null b) of+ (False, False) -> False+ (True, True) -> True+ _ -> error "Zipped signals: one is empty and the other one is not"+ {-# INLINE length #-}+ length (Cons a b) =+ let lenA = CutG.length a+ lenB = CutG.length b+ in if lenA == lenB+ then lenA+ else error "Zipped signals: the lengths differ"++{-+Parallel combination of two signals+where the combined signal has the length of the shorter member.+This is like in zipWith.++instance (CutG.Read a, CutG.Read b) => CutG.Read (Parallel a b) where+ null (Parallel a b) = CutG.null a || CutG.null b+ length (Parallel a b) = min (CutG.length a) (CutG.length b)+-}++instance (CutG.NormalForm a, CutG.NormalForm b) => CutG.NormalForm (T a b) where+ {-# INLINE evaluateHead #-}+ evaluateHead (Cons a b) =+ case (CutG.evaluateHead a, CutG.evaluateHead b) of+ ((), ()) -> ()++instance (CutG.Transform a, CutG.Transform b) => CutG.Transform (T a b) where+ {-# INLINE take #-}+ take n (Cons a b) =+ Cons (CutG.take n a) (CutG.take n b)+ {-# INLINE drop #-}+ drop n (Cons a b) =+ Cons (CutG.drop n a) (CutG.drop n b)+ {-# INLINE splitAt #-}+ splitAt n (Cons a b) =+ let (a0,a1) = CutG.splitAt n a+ (b0,b1) = CutG.splitAt n b+ in (Cons a0 b0, Cons a1 b1)+ {-# INLINE dropMarginRem #-}+ dropMarginRem n m (Cons a0 b0) =+ let (ka,a1) = CutG.dropMarginRem n m a0+ (kb,b1) = CutG.dropMarginRem n m b0+ in if ka==kb+ then (ka, Cons a1 b1)+ else error "Zip.dropMarginRem: margins differ"+ {-# INLINE reverse #-}+ reverse (Cons a b) =+ Cons (CutG.reverse a) (CutG.reverse b)
synthesizer-core.cabal view
@@ -1,5 +1,5 @@ Name: synthesizer-core-Version: 0.4.1+Version: 0.4.2 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -52,7 +52,7 @@ Source-Repository this- Tag: 0.4.1+ Tag: 0.4.2 Type: darcs Location: http://code.haskell.org/synthesizer/core/ @@ -108,6 +108,7 @@ Synthesizer.Format Synthesizer.RandomKnuth Synthesizer.Piecewise+ Synthesizer.Zip Synthesizer.Basic.Binary Synthesizer.Basic.Distortion Synthesizer.Basic.DistortionControlled@@ -199,6 +200,7 @@ Synthesizer.Causal.Spatial Synthesizer.Causal.Filter.NonRecursive Synthesizer.Causal.Filter.Recursive.Integration+ Synthesizer.CausalIO.Process Synthesizer.Generic.Analysis Synthesizer.Generic.Cut Synthesizer.Generic.Control@@ -218,6 +220,7 @@ Synthesizer.Generic.Signal Synthesizer.Generic.Signal2 Synthesizer.Generic.Wave+ Synthesizer.PiecewiseConstant.Signal -- that's only exposed for Haddock Synthesizer.Plain.Tutorial