summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHenningThielemann <>2019-08-13 14:26:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-08-13 14:26:00 (GMT)
commitdbe3169bc5a2fa9dd31365c36e25e760f32e4dc2 (patch)
tree2286e53c4a17de094302c97ee977149574b7ce21
parent59ce11bb0bdfd7edaef22f94f33e0639873e5e62 (diff)
version 0.8.2HEAD0.8.2master
-rw-r--r--alsa/Synthesizer/LLVM/Server/Packed/Run.hs24
-rw-r--r--example/Synthesizer/LLVM/Test.hs42
-rw-r--r--render/Synthesizer/LLVM/Server/Render.hs31
-rw-r--r--server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs2
-rw-r--r--server/Synthesizer/LLVM/Server/OptionCommon.hs9
-rw-r--r--src/Synthesizer/LLVM/Causal/Process.hs13
-rw-r--r--src/Synthesizer/LLVM/Causal/ProcessPrivate.hs14
-rw-r--r--src/Synthesizer/LLVM/Causal/ProcessValue.hs12
-rw-r--r--src/Synthesizer/LLVM/CausalParameterized/Functional.hs67
-rw-r--r--src/Synthesizer/LLVM/CausalParameterized/Helix.hs20
-rw-r--r--src/Synthesizer/LLVM/CausalParameterized/Process.hs38
-rw-r--r--src/Synthesizer/LLVM/ConstantPiece.hs14
-rw-r--r--src/Synthesizer/LLVM/Filter/Allpass.hs15
-rw-r--r--src/Synthesizer/LLVM/Filter/FirstOrder.hs163
-rw-r--r--src/Synthesizer/LLVM/Filter/SecondOrder.hs18
-rw-r--r--src/Synthesizer/LLVM/Filter/Universal.hs4
-rw-r--r--src/Synthesizer/LLVM/ForeignPtr.hs4
-rw-r--r--src/Synthesizer/LLVM/Frame/Stereo.hs5
-rw-r--r--src/Synthesizer/LLVM/Parameter.hs90
-rw-r--r--src/Synthesizer/LLVM/Parameterized/Signal.hs61
-rw-r--r--src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs60
-rw-r--r--src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs80
-rw-r--r--src/Synthesizer/LLVM/Server/Packed/Instrument.hs183
-rw-r--r--src/Synthesizer/LLVM/Server/Parameter.hs106
-rw-r--r--src/Synthesizer/LLVM/Simple/Signal.hs60
-rw-r--r--src/Synthesizer/LLVM/Simple/SignalPrivate.hs64
-rw-r--r--src/Synthesizer/LLVM/Storable/ChunkIterator.hs2
-rw-r--r--src/Synthesizer/LLVM/Storable/Signal.hs6
-rw-r--r--src/Synthesizer/LLVM/Storable/Vector.hs2
-rw-r--r--src/Synthesizer/LLVM/Wave.hs8
-rw-r--r--synthesizer-llvm.cabal60
-rw-r--r--testsuite/Test/Synthesizer/LLVM/Filter.hs186
-rw-r--r--testsuite/Test/Synthesizer/LLVM/Generator.hs64
-rw-r--r--testsuite/Test/Synthesizer/LLVM/Helix.hs57
-rw-r--r--testsuite/Test/Synthesizer/LLVM/Packed.hs164
-rw-r--r--testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs119
-rw-r--r--testsuite/Test/Synthesizer/LLVM/Utility.hs44
37 files changed, 1275 insertions, 636 deletions
diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs
index fc2c46d..ba9cf69 100644
--- a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs
+++ b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs
@@ -44,7 +44,7 @@ import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified System.Path.PartClass as PathClass
import qualified System.Path as Path
-import Control.Applicative.HT (liftA4, liftA5, liftA6, )
+import qualified Control.Applicative.HT as App
import Control.Arrow ((<<<), (^<<), arr, )
import Control.Applicative (pure, liftA2, liftA3, (<*>), )
import Control.Monad.Trans.State (evalState, )
@@ -257,7 +257,7 @@ keyboardDetuneFMCore smpDir = do
fmap (EventListMT.switchBodyL
(error "empty controller stream") const)
flt = evalState $
- liftA6 (\rel -> flt0 (4*rel) rel)
+ App.lift6 (\rel -> flt0 (4*rel) rel)
(evHead $
PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
(PCS.controllerLinear controllerDetune (0,0.005) 0.001)
@@ -273,7 +273,7 @@ keyboardDetuneFMCore smpDir = do
(evHead $
PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
pngFM = evalState $
- liftA6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs)
+ App.lift6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs)
(evHead $
PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
(PCS.controllerLinear controllerDetune (0,0.005) 0.001)
@@ -283,7 +283,7 @@ keyboardDetuneFMCore smpDir = do
(pure vcsize)
(PCS.bendWheelPressure 2 0.04 0.03)
sqr = evalState $
- liftA6 (\rel -> sqr0 (4*rel) rel)
+ App.lift6 (\rel -> sqr0 (4*rel) rel)
(evHead $
PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
(PCS.controllerLinear controllerDetune (0,0.005) 0.001)
@@ -298,7 +298,7 @@ keyboardDetuneFMCore smpDir = do
(pure vcsize)
(PCS.bendWheelPressure 2 0.04 0.03)
tnc = evalState $
- liftA6 (\rel -> tnc0 (4*rel) rel)
+ App.lift6 (\rel -> tnc0 (4*rel) rel)
(evHead $
PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
(PCS.controllerLinear controllerDetune (0,0.005) 0.001)
@@ -344,14 +344,14 @@ keyboardDetuneFMCore smpDir = do
<*> (pure vcsize)
<*> (PCS.bendWheelPressure 2 0.04 0.03)
bel = evalState $
- liftA4 (\rel -> bel0 (2*rel) rel)
+ App.lift4 (\rel -> bel0 (2*rel) rel)
(evHead $
PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)
(PCS.controllerLinear controllerDetune (0,0.005) 0.001)
(pure vcsize)
(PCS.bendWheelPressure 2 0.05 0.02)
ben = evalState $
- liftA5 (\rel -> ben0 (2*rel) rel)
+ App.lift5 (\rel -> ben0 (2*rel) rel)
(evHead $
PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)
(PCS.controllerLinear controllerTimbre0 (0,1) 0.3)
@@ -365,14 +365,14 @@ keyboardDetuneFMCore smpDir = do
(PCS.controllerLinear controllerDetune (0,0.01) 0.005)
(PCS.bendWheelPressure 2 0.04 0.03)
ssh = evalState $
- liftA4 ssh0
+ App.lift4 ssh0
(evHead $
PCS.controllerExponential controllerAttack (0.02,2) 0.5)
(PCS.controllerLinear controllerDetune (0,0.01) 0.005)
(PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05)
(PCS.bendWheelPressure 2 0.04 0.03)
makeArc gen = evalState $
- liftA4 gen
+ App.lift4 gen
(evHead $
PCS.controllerExponential controllerAttack (0.02,2) 0.5)
(PCS.controllerLinear controllerDetune (0,0.01) 0.005)
@@ -384,7 +384,7 @@ keyboardDetuneFMCore smpDir = do
asq = makeArc asq0
atr = makeArc atr0
fms = evalState $
- liftA5 fms0
+ App.lift5 fms0
(evHead $
PCS.controllerExponential controllerAttack (0.02,2) 0.5)
(PCS.controllerLinear controllerDetune (0,0.01) 0.005)
@@ -398,7 +398,7 @@ keyboardDetuneFMCore smpDir = do
(PCS.controllerExponential controllerTimbre1 (1,1000) 100)
(PCS.bendWheelPressure 12 0.8 0)
wnp = evalState $
- liftA5 wnp0
+ App.lift5 wnp0
(evHead $
PCS.controllerExponential controllerAttack (0.02,2) 0.5)
(PCS.controllerLinear controllerTimbre0 (0,1) 0.5)
@@ -406,7 +406,7 @@ keyboardDetuneFMCore smpDir = do
(PCS.controllerExponential controllerTimbre1 (1,1000) 100)
(PCS.bendWheelPressure 12 0.8 0)
brs = evalState $
- liftA6
+ App.lift6
(\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0)
(evHead $
PCS.controllerExponential controllerAttack (0.01,0.1) 0.01)
diff --git a/example/Synthesizer/LLVM/Test.hs b/example/Synthesizer/LLVM/Test.hs
index 8b7dd27..084ec6e 100644
--- a/example/Synthesizer/LLVM/Test.hs
+++ b/example/Synthesizer/LLVM/Test.hs
@@ -1045,13 +1045,12 @@ snd = arr P.snd
{-# NOINLINE makePing #-}
makePing :: IO ((Float,Float) -> SVL.Vector Float)
makePing =
- let freq = snd
- halfLife = fst
- in fmap ($tonesChunkSize) $
- SigP.runChunky
- (SigP.envelope
- (SigP.exponential2 halfLife 1)
- (SigP.osciSaw 0.5 freq))
+ fmap ($tonesChunkSize) $
+ SigP.runChunky $
+ Param.withTuple1 $ \(halfLife, freq) ->
+ SigP.envelope
+ (SigP.exponential2 halfLife 1)
+ (SigP.osciSaw 0.5 freq)
tonesDown :: IO ()
tonesDown = do
@@ -1821,11 +1820,11 @@ helixSpeechStaticSpeed speed word =
helixSpeechStatic :: IO ()
helixSpeechStatic = do
- let speed = fst
- word = snd . snd
- period = fst . snd
smp <- loadTomato
- stretched <- SigP.runChunky $ helixSpeechStaticSpeed speed word period
+ stretched <-
+ SigP.runChunky $
+ Param.withTuple1 $ \(speed, (period, word)) ->
+ helixSpeechStaticSpeed speed word period
SVL.writeFile "speech-stretched.f32" $ asMono $
stretched SVL.defaultChunkSize (0.5, smp)
@@ -1853,22 +1852,21 @@ helixSpeechDynamicSpeed speed =
helixSpeechDynamic :: IO ()
helixSpeechDynamic = do
- let speed = fst
- word = snd . snd
- period = fst . snd
smp <- loadTomato
- stretched <- SigP.runChunky $ helixSpeechDynamicSpeed speed word period
+ stretched <-
+ SigP.runChunky $
+ Param.withTuple1 $ \(speed, (period, word)) ->
+ helixSpeechDynamicSpeed speed word period
SVL.writeFile "speech-stretched.f32" $ asMono $
stretched SVL.defaultChunkSize (0.5, smp)
helixSpeechCompare :: IO ()
helixSpeechCompare = do
- let speed = fst
- word = snd . snd
- period = fst . snd
smp <- loadTomato
stretched <-
- SigP.runChunky $ sequenceA $
+ SigP.runChunky $
+ Param.withTuple1 $ \(speed, (period, word)) ->
+ sequenceA $
Stereo.cons
(helixSpeechStaticSpeed speed word period)
(helixSpeechDynamicSpeed speed word period)
@@ -1877,11 +1875,11 @@ helixSpeechCompare = do
helixSpeechVariCompare :: IO ()
helixSpeechVariCompare = do
- let word = snd
- period = fst
smp <- loadTomato
stretched <-
- SigP.runChunky $ sequenceA $
+ SigP.runChunky $
+ Param.withTuple1 $ \(period, word) ->
+ sequenceA $
let speed =
Func.fromSignal $ SigP.cycle $
SigP.fromStorableVector $ pure $
diff --git a/render/Synthesizer/LLVM/Server/Render.hs b/render/Synthesizer/LLVM/Server/Render.hs
index 02ef413..8b929ed 100644
--- a/render/Synthesizer/LLVM/Server/Render.hs
+++ b/render/Synthesizer/LLVM/Server/Render.hs
@@ -12,6 +12,8 @@ import Synthesizer.LLVM.Server.Common
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.PiecewiseConstant.Signal as PC
+import Shell.Utility.Exit (exitFailureMsg)
+
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.EventList.Relative.TimeBody as EventList
@@ -35,7 +37,6 @@ import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified System.Exit as Exit
-import qualified System.IO as IO
import Prelude hiding (Real, id, )
@@ -94,28 +95,22 @@ handleSoxExit sox = do
soxResult <- sox
case soxResult of
Exit.ExitSuccess -> return ()
- Exit.ExitFailure n -> do
- IO.hPutStrLn IO.stderr $
- "'sox' aborted with exit code " ++ show n
- Exit.exitFailure
+ Exit.ExitFailure n ->
+ exitFailureMsg $ "'sox' aborted with exit code " ++ show n
main :: IO ()
main = do
(opt, midiPath, mWavePath) <- Option.get
case Option.sampleRate opt of
- SampleRate rate ->
+ SampleRate rate -> do
+ audio <- render opt <*> Load.fromFile midiPath
case mWavePath of
Nothing ->
- handleSoxExit $
- SoxPlay.simple SVL.hPut mempty rate =<<
- (render opt <*> Load.fromFile midiPath)
- -- Rendering to SoX ends with an error code 13, but why?
- Just wavePath ->
- handleSoxExit $
- SoxWrite.simple SVL.hPut mempty wavePath rate =<<
- (render opt <*> Load.fromFile midiPath)
-{-
+ handleSoxExit $ SoxPlay.simple SVL.hPut mempty rate audio
Just wavePath ->
- SVL.writeFile wavePath =<<
- (render opt <*> Load.fromFile midiPath)
--}
+ if True
+ then
+ -- Rendering to SoX ends with an error code 13, but why?
+ handleSoxExit $
+ SoxWrite.simple SVL.hPut mempty wavePath rate audio
+ else SVL.writeFile wavePath audio
diff --git a/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs
index 805f45b..89ef3e9 100644
--- a/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs
+++ b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs
@@ -475,7 +475,7 @@ voderSplit chan =
fmap
(ListHT.unzipEithers .
fmap (\ev ->
- case Check.note chan ev of
+ case Check.noteExplicitOff chan ev of
Nothing -> Right ev
Just (v,p,b) ->
if p >= VoiceMsg.toPitch 36
diff --git a/server/Synthesizer/LLVM/Server/OptionCommon.hs b/server/Synthesizer/LLVM/Server/OptionCommon.hs
index ebd3328..b511a82 100644
--- a/server/Synthesizer/LLVM/Server/OptionCommon.hs
+++ b/server/Synthesizer/LLVM/Server/OptionCommon.hs
@@ -17,6 +17,7 @@ import qualified Data.StorableVector.Lazy as SVL
import qualified System.Path.PartClass as PathClass
import qualified System.Path as Path
+import qualified Shell.Utility.ParseArgument as ParseArg
import qualified Options.Applicative as OP
import Control.Applicative ((<$>), (<*>), )
import Data.Monoid ((<>), )
@@ -79,13 +80,7 @@ parseNumber ::
(Read a) =>
String -> (a -> Bool) -> String -> OP.ReadM a
parseNumber name constraint constraintName =
- OP.eitherReader $ \str ->
- case reads str of
- [(n, "")] ->
- if constraint n
- then return n
- else Left $ name ++ " must be a " ++ constraintName ++ " number"
- _ -> Left $ name ++ " must be a number, but is '" ++ str ++ "'"
+ OP.eitherReader $ ParseArg.parseNumber name constraint constraintName
sampleRate :: OP.Parser (Maybe (SampleRate Int))
sampleRate =
diff --git a/src/Synthesizer/LLVM/Causal/Process.hs b/src/Synthesizer/LLVM/Causal/Process.hs
index d49b3a7..1f14ec0 100644
--- a/src/Synthesizer/LLVM/Causal/Process.hs
+++ b/src/Synthesizer/LLVM/Causal/Process.hs
@@ -37,6 +37,7 @@ module Synthesizer.LLVM.Causal.Process (
mapProc,
zipProcWith,
mix,
+ takeWhile,
pipeline,
stereoFromVector,
vectorize,
@@ -113,7 +114,7 @@ import Foreign.Ptr (Ptr, )
import Control.Exception (bracket, )
import qualified System.Unsafe as Unsafe
-import Prelude hiding (and, map, zip, zipWith, init, )
+import Prelude hiding (and, map, zip, zipWith, init, takeWhile, )
@@ -659,10 +660,10 @@ runStorableIO (Cons next alloca start createIOContext deleteIOContext) = do
AllocUtil.with params $ \paramPtr ->
fmap (fromIntegral :: Word32 -> Int) $
fill
- (Memory.castStorablePtr paramPtr)
+ (Memory.castTuplePtr paramPtr)
(fromIntegral len)
- (Memory.castStorablePtr aPtr)
- (Memory.castStorablePtr bPtr)
+ (Memory.castTuplePtr aPtr)
+ (Memory.castTuplePtr bPtr)
foreign import ccall safe "dynamic" derefStartPtr ::
@@ -742,8 +743,8 @@ traverseChunks fill paramFPtr statePtr =
SVB.createAndTrim size $
fmap (fromIntegral :: Word32 -> Int) .
fill paramPtr sptr (fromIntegral size)
- (Memory.castStorablePtr aPtr) .
- Memory.castStorablePtr
+ (Memory.castTuplePtr aPtr) .
+ Memory.castTuplePtr
(if SV.length v > 0
then fmap (v:)
else id) $
diff --git a/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs b/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs
index c95836b..3038f9f 100644
--- a/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs
+++ b/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs
@@ -14,7 +14,7 @@ import qualified LLVM.Extra.Memory as Memory
import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, )
import LLVM.Util.Loop (Phi, )
-import LLVM.Core (CodeGenFunction, )
+import LLVM.Core (CodeGenFunction, Value, )
import Foreign.Storable (Storable, )
@@ -195,6 +195,18 @@ zipProcWith ::
zipProcWith f x y = zipWith f <<< x&&&y
+takeWhile ::
+ (C process) =>
+ (forall r. a -> CodeGenFunction r (Value Bool)) ->
+ process a a
+takeWhile p =
+ simple
+ (\a () -> do
+ MaybeCont.guard =<< MaybeCont.lift (p a)
+ return (a,()))
+ (return ())
+
+
compose :: T a b -> T b c -> T a c
compose
(Cons nextA allocaA startA createIOContextA deleteIOContextA)
diff --git a/src/Synthesizer/LLVM/Causal/ProcessValue.hs b/src/Synthesizer/LLVM/Causal/ProcessValue.hs
index 98db44f..7321537 100644
--- a/src/Synthesizer/LLVM/Causal/ProcessValue.hs
+++ b/src/Synthesizer/LLVM/Causal/ProcessValue.hs
@@ -6,17 +6,18 @@ This way you can use common arithmetic operators
instead of LLVM assembly functions.
-}
module Synthesizer.LLVM.Causal.ProcessValue (
- map, zipWith, mapAccum,
+ map, zipWith, mapAccum, takeWhile,
) where
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified LLVM.Extra.Memory as Memory
+import qualified LLVM.Core as LLVM
import Foreign.Storable.Tuple ()
-import Prelude ()
+import Prelude (Bool)
map ::
@@ -42,3 +43,10 @@ mapAccum next start =
Causal.mapAccum
(Value.unlift2 next)
(Value.unlift0 start)
+
+takeWhile ::
+ (Causal.C process) =>
+ (Value.T a -> Value.T (LLVM.Value Bool)) ->
+ process a a
+takeWhile p =
+ Causal.takeWhile (Value.unlift1 p)
diff --git a/src/Synthesizer/LLVM/CausalParameterized/Functional.hs b/src/Synthesizer/LLVM/CausalParameterized/Functional.hs
index 0957fce..b9d6497 100644
--- a/src/Synthesizer/LLVM/CausalParameterized/Functional.hs
+++ b/src/Synthesizer/LLVM/CausalParameterized/Functional.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.CausalParameterized.Functional (
@@ -11,11 +13,15 @@ module Synthesizer.LLVM.CausalParameterized.Functional (
withArgs, MakeArguments, Arguments, makeArgs,
AnyArg(..),
+ Ground(Ground),
+ withGroundArgs, MakeGroundArguments, GroundArguments,
+ makeGroundArgs,
+
Atom(..), atom,
withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments,
makeGuidedArgs,
- PrepareArguments, withPreparedArgs, withPreparedArgs2,
+ PrepareArguments(PrepareArguments), withPreparedArgs, withPreparedArgs2,
atomArg, stereoArgs, pairArgs, tripleArgs,
) where
@@ -348,6 +354,65 @@ instance MakeArguments (AnyArg a) where
+{- |
+This is similar to 'withArgs'
+but it requires to specify the decomposition depth
+using constructors in the arguments.
+-}
+withGroundArgs ::
+ (MakeGroundArguments (T p inp) args,
+ GroundArguments args ~ inp) =>
+ (args -> T p inp out) -> CausalP.T p inp out
+withGroundArgs f = withId $ f . makeGroundArgs
+
+
+data Ground f a = Ground (f a)
+
+
+type family GroundArguments args
+
+class (Functor f) => MakeGroundArguments f args where
+ makeGroundArgs :: f (GroundArguments args) -> args
+
+
+type instance GroundArguments (Ground f a) = a
+instance (Functor f, f ~ g) => MakeGroundArguments f (Ground g a) where
+ makeGroundArgs = Ground
+
+type instance GroundArguments (Stereo.T a) = Stereo.T (GroundArguments a)
+instance MakeGroundArguments f a => MakeGroundArguments f (Stereo.T a) where
+ makeGroundArgs f =
+ Stereo.cons
+ (makeGroundArgs $ fmap Stereo.left f)
+ (makeGroundArgs $ fmap Stereo.right f)
+
+type instance GroundArguments () = ()
+instance (Functor f) => MakeGroundArguments f () where
+ makeGroundArgs _ = ()
+
+
+type instance
+ GroundArguments (a,b) =
+ (GroundArguments a, GroundArguments b)
+instance
+ (MakeGroundArguments f a, MakeGroundArguments f b) =>
+ MakeGroundArguments f (a,b) where
+ makeGroundArgs f =
+ (makeGroundArgs $ fmap fst f,
+ makeGroundArgs $ fmap snd f)
+
+type instance
+ GroundArguments (a,b,c) =
+ (GroundArguments a, GroundArguments b, GroundArguments c)
+instance
+ (MakeGroundArguments f a, MakeGroundArguments f b, MakeGroundArguments f c) =>
+ MakeGroundArguments f (a,b,c) where
+ makeGroundArgs f =
+ (makeGroundArgs $ fmap fst3 f,
+ makeGroundArgs $ fmap snd3 f,
+ makeGroundArgs $ fmap thd3 f)
+
+
{- |
This is similar to 'withArgs'
diff --git a/src/Synthesizer/LLVM/CausalParameterized/Helix.hs b/src/Synthesizer/LLVM/CausalParameterized/Helix.hs
index 8a4ae6a..051592b 100644
--- a/src/Synthesizer/LLVM/CausalParameterized/Helix.hs
+++ b/src/Synthesizer/LLVM/CausalParameterized/Helix.hs
@@ -562,6 +562,19 @@ combineMargins marginLeap marginStep periodInt =
}
+{- |
+@zigZagLong loopStart loopLength@
+creates a curve that starts at 0
+and is linear until it reaches @loopStart+loopLength@.
+Then it begins looping in a ping-pong manner
+between @loopStart+loopLength@ and @loopStart@.
+It is useful as @shape@ control for looping a sound.
+Input of the causal process is the slope (or frequency) control.
+Slope values must not be negative.
+
+*Main> Sig.renderChunky SVL.defaultChunkSize (Causal.take 25 <<< Helix.zigZagLong 6 10 $* 2) () :: SVL.Vector Float
+VectorLazy.fromChunks [Vector.pack [0.0,1.999999,3.9999995,6.0,8.0,10.0,12.0,14.0,15.999999,14.000001,12.0,10.0,7.999999,6.0,8.0,10.0,12.0,14.0,16.0,14.0,11.999999,9.999998,7.999998,6.0000024,8.000002]]
+-}
zigZagLong ::
(Storable a, MakeValueTuple a, ValueTuple a ~ Value a,
Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,
@@ -600,6 +613,13 @@ zigZagLongGen constant zz prefix loop =
<<<
id / constant loop
+{- |
+@zigZag start@ creates a zig-zag curve with values between 0 and 1, inclusively,
+that is useful as @shape@ control for looping a sound.
+Input of the causal process is the slope (or frequency) control.
+Slope values must not be negative.
+The start value must be at most 2 and may be negative.
+-}
zigZag ::
(Storable a, MakeValueTuple a, ValueTuple a ~ Value a,
Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,
diff --git a/src/Synthesizer/LLVM/CausalParameterized/Process.hs b/src/Synthesizer/LLVM/CausalParameterized/Process.hs
index 6cd3947..634f982 100644
--- a/src/Synthesizer/LLVM/CausalParameterized/Process.hs
+++ b/src/Synthesizer/LLVM/CausalParameterized/Process.hs
@@ -24,6 +24,7 @@ module Synthesizer.LLVM.CausalParameterized.Process (
feedbackControlled,
Causal.feedbackControlledZero,
Causal.fromModifier,
+ fromInitializedModifier,
stereoFromMono,
stereoFromMonoControlled,
stereoFromMonoParameterized,
@@ -87,6 +88,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.RingBuffer as RingBuffer
import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigPPriv
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv
+import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified Synthesizer.LLVM.Interpolation as Interpolation
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame as Frame
@@ -96,6 +98,7 @@ import Synthesizer.LLVM.Parameter (($#), )
import qualified Synthesizer.Causal.Class as CausalClass
import qualified Synthesizer.Generic.Cut as Cut
+import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
@@ -119,6 +122,7 @@ import qualified Type.Data.Num.Decimal as TypeNum
import Type.Data.Num.Decimal (D1, )
import qualified Control.Category as Cat
+import Control.Monad.Trans.State (runState, )
import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&), )
import Control.Monad (liftM, when, )
import Control.Applicative (liftA2, liftA3, pure, (<*>), )
@@ -187,6 +191,24 @@ mapAccumSimple ::
mapAccumSimple f s =
mapAccum (\() -> f) (\() -> s) (return ()) (return ())
+fromInitializedModifier ::
+ (Value.Flatten ah, Value.Registers ah ~ al,
+ Value.Flatten bh, Value.Registers bh ~ bl,
+ Value.Flatten ch, Value.Registers ch ~ cl,
+ Value.Flatten sh, Value.Registers sh ~ sl, Memory.C sl,
+ Value.Flatten ih, Value.Registers ih ~ il, Memory.C il,
+ Storable i, MakeValueTuple i, ValueTuple i ~ il) =>
+ Modifier.Initialized sh ih ch ah bh -> Param.T p i -> T p (cl,al) bl
+fromInitializedModifier (Modifier.Initialized initF step) =
+ mapAccum
+ (\() (c,a) s ->
+ Value.flatten $
+ runState
+ (step (Value.unfold c) (Value.unfold a))
+ (Value.unfold s))
+ (Value.flattenFunction initF)
+ (return ())
+
replicateParallel ::
(Undefined b, Phi b) =>
@@ -762,10 +784,10 @@ runStorable (Cons next alloca start stop createIOContext deleteIOContext) = do
SVB.createAndTrim len $ \ bPtr ->
Alloc.with params $ \paramPtr ->
fmap fromIntegral $
- fill (Memory.castStorablePtr paramPtr)
+ fill (Memory.castTuplePtr paramPtr)
(fromIntegral len)
- (Memory.castStorablePtr aPtr)
- (Memory.castStorablePtr bPtr)
+ (Memory.castTuplePtr aPtr)
+ (Memory.castTuplePtr bPtr)
applyStorable ::
(Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,
@@ -958,8 +980,8 @@ runStorableChunkyCont
fmap fromIntegral .
fill sptr
(fromIntegral size)
- (Memory.castStorablePtr aPtr) .
- Memory.castStorablePtr
+ (Memory.castTuplePtr aPtr) .
+ Memory.castTuplePtr
touchForeignPtr ioContextPtr
(if SV.length v > 0
then fmap (v:)
@@ -1027,8 +1049,8 @@ processIOCore
AllocUtil.with paramOut $ \outptr ->
fill paramPtr
(fromIntegral maximumSize)
- (Memory.castStorablePtr inptr)
- (Memory.castStorablePtr outptr)
+ (Memory.castTuplePtr inptr)
+ (Memory.castTuplePtr outptr)
deleteIn contextIn
b <- deleteOut (fromIntegral actualSize) contextOut
return (b, s))
@@ -1040,7 +1062,7 @@ processIOCore
contextStatePtr <-
AllocUtil.with param
- (startFunc . Memory.castStorablePtr)
+ (startFunc . Memory.castTuplePtr)
return (ioContext, contextStatePtr))
(\(ioContext, contextStatePtr) -> do
diff --git a/src/Synthesizer/LLVM/ConstantPiece.hs b/src/Synthesizer/LLVM/ConstantPiece.hs
index 4ac00f3..a911024 100644
--- a/src/Synthesizer/LLVM/ConstantPiece.hs
+++ b/src/Synthesizer/LLVM/ConstantPiece.hs
@@ -49,15 +49,11 @@ instance (Phi a) => Phi (T a) where
addPhis bb (Cons lenA ya) (Cons lenB yb) =
addPhis bb lenA lenB >> addPhis bb ya yb
-instance (Undefined a) =>
- Undefined (T a) where
- undefTuple =
- Cons Class.undefTuple Class.undefTuple
+instance (Undefined a) => Undefined (T a) where
+ undefTuple = Cons Class.undefTuple Class.undefTuple
-instance (Class.Zero a) =>
- Class.Zero (T a) where
- zeroTuple =
- Cons Class.zeroTuple Class.zeroTuple
+instance (Class.Zero a) => Class.Zero (T a) where
+ zeroTuple = Cons Class.zeroTuple Class.zeroTuple
type Struct a = LLVM.Struct (Word32, (a, ()))
@@ -84,7 +80,7 @@ flatten ::
flatten = Sig.alter (\(Sig.Core next start stop) ->
Sig.Core
(\context state0 -> do
- (Cons length1 y1, s1) <-
+ ~(Cons length1 y1, s1) <-
Maybe.fromBool $
whileLoop (valueOf True, state0)
(\(cont, (Cons len _y, _s)) ->
diff --git a/src/Synthesizer/LLVM/Filter/Allpass.hs b/src/Synthesizer/LLVM/Filter/Allpass.hs
index 1bce77c..9e24f9f 100644
--- a/src/Synthesizer/LLVM/Filter/Allpass.hs
+++ b/src/Synthesizer/LLVM/Filter/Allpass.hs
@@ -113,6 +113,7 @@ instance (MultiValue.C a) => MultiValue.C (Allpass.Parameter a) where
(plainFromParamValue b)
instance (MultiVector.C a) => MultiVector.C (Allpass.Parameter a) where
+ cons = paramFromPlainVector . MultiVector.cons . fmap Allpass.getParameter
undef = paramFromPlainVector MultiVector.undef
zero = paramFromPlainVector MultiVector.zero
@@ -125,10 +126,9 @@ instance (MultiVector.C a) => MultiVector.C (Allpass.Parameter a) where
(plainFromParamVector a)
(plainFromParamVector b)
- shuffleMatch is a =
+ shuffle is a b =
fmap paramFromPlainVector $
- MultiVector.shuffleMatch is $
- plainFromParamVector a
+ MultiVector.shuffle is (plainFromParamVector a) (plainFromParamVector b)
extract i v =
fmap paramFromPlainValue $
MultiVector.extract i $
@@ -241,6 +241,9 @@ instance (MultiValue.C a) => MultiValue.C (CascadeParameter n a) where
(paramFromCascadeValue b)
instance (MultiVector.C a) => MultiVector.C (CascadeParameter n a) where
+ cons =
+ cascadeFromParamVector . MultiVector.cons .
+ fmap (\(CascadeParameter a) -> a)
undef = cascadeFromParamVector MultiVector.undef
zero = cascadeFromParamVector MultiVector.zero
@@ -253,10 +256,10 @@ instance (MultiVector.C a) => MultiVector.C (CascadeParameter n a) where
(paramFromCascadeVector a)
(paramFromCascadeVector b)
- shuffleMatch is a =
+ shuffle is a b =
fmap cascadeFromParamVector $
- MultiVector.shuffleMatch is $
- paramFromCascadeVector a
+ MultiVector.shuffle is
+ (paramFromCascadeVector a) (paramFromCascadeVector b)
extract i v =
fmap cascadeFromParamValue $
MultiVector.extract i $
diff --git a/src/Synthesizer/LLVM/Filter/FirstOrder.hs b/src/Synthesizer/LLVM/Filter/FirstOrder.hs
index 157bfbc..8be68b8 100644
--- a/src/Synthesizer/LLVM/Filter/FirstOrder.hs
+++ b/src/Synthesizer/LLVM/Filter/FirstOrder.hs
@@ -4,11 +4,15 @@
module Synthesizer.LLVM.Filter.FirstOrder (
Result(Result,lowpass_,highpass_), Parameter, parameter,
causal, lowpassCausal, highpassCausal,
+ causalInit, lowpassCausalInit, highpassCausalInit,
+ causalInitPacked, lowpassCausalInitPacked, highpassCausalInitPacked,
causalPacked, lowpassCausalPacked, highpassCausalPacked,
causalRecursivePacked, -- for Allpass
causalP, lowpassCausalP, highpassCausalP,
+ causalInitP, lowpassCausalInitP, highpassCausalInitP,
causalPackedP, lowpassCausalPackedP, highpassCausalPackedP,
+ causalInitPackedP, lowpassCausalInitPackedP, highpassCausalInitPackedP,
causalRecursivePackedP, -- for Allpass
) where
@@ -21,6 +25,7 @@ import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
+import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified LLVM.Extra.Memory as Memory
@@ -31,6 +36,8 @@ import LLVM.Extra.Class (Undefined, undefTuple, )
import qualified LLVM.Core as LLVM
import LLVM.Util.Loop (Phi, phis, addPhis, )
+import Foreign.Storable (Storable, )
+
import Control.Arrow (arr, (&&&), (<<<), )
import Control.Monad (liftM2, foldM, )
@@ -112,7 +119,45 @@ lowpassCausal, highpassCausal ::
lowpassCausal = CausalP.fromModifier lowpassModifier
highpassCausal = CausalP.fromModifier highpassModifier
-lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked ::
+
+modifierInit ::
+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>
+ Modifier.Initialized
+ (Value.T v) (Value.T v)
+ (Parameter (Value.T a))
+ (Value.T v) (Result (Value.T v))
+modifierInit = FirstOrder.modifierInit
+
+lowpassModifierInit, highpassModifierInit ::
+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>
+ Modifier.Initialized
+ (Value.T v) (Value.T v)
+ (Parameter (Value.T a))
+ (Value.T v) (Value.T v)
+lowpassModifierInit = FirstOrder.lowpassModifierInit
+highpassModifierInit = FirstOrder.highpassModifierInit
+
+causalInit ::
+ (Causal.C process,
+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>
+ v -> process (Parameter a, v) (Result v)
+causalInit =
+ Causal.fromModifier . Modifier.initialize modifierInit . Value.unfold
+
+lowpassCausalInit, highpassCausalInit ::
+ (Causal.C process,
+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>
+ v -> process (Parameter a, v) v
+lowpassCausalInit =
+ CausalP.fromModifier .
+ Modifier.initialize lowpassModifierInit . Value.unfold
+highpassCausalInit =
+ CausalP.fromModifier .
+ Modifier.initialize highpassModifierInit . Value.unfold
+
+
+lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked,
+ preampPacked ::
(Causal.C process,
Serial.C v, Serial.Element v ~ a,
Memory.C a, A.IntegerConstant a,
@@ -121,11 +166,30 @@ lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked ::
highpassCausalPacked =
Causal.zipWith A.sub <<< arr snd &&& lowpassCausalPacked
lowpassCausalPacked =
- causalRecursivePacked <<<
- (arr fst &&&
- Causal.map
- (\(FirstOrder.Parameter k, x) ->
- A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k))
+ causalRecursivePacked <<< (arr fst &&& preampPacked)
+
+causalRecursivePacked =
+ causalRecursiveInitPacked A.zero
+
+lowpassCausalInitPacked, highpassCausalInitPacked, causalRecursiveInitPacked ::
+ (Causal.C process,
+ A.PseudoRing v, Serial.C v, Serial.Element v ~ a,
+ A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>
+ a -> process (Parameter a, v) v
+causalRecursiveInitPacked a =
+ Causal.mapAccum causalRecursivePackedStep (return a)
+
+highpassCausalInitPacked a =
+ Causal.zipWith A.sub <<< arr snd &&& lowpassCausalInitPacked a
+lowpassCausalInitPacked a =
+ causalRecursiveInitPacked a <<< (arr fst &&& preampPacked)
+
+preampPacked =
+ Causal.map
+ (\(FirstOrder.Parameter k, x) ->
+ A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k)
+
+
{-
x = [x0, x1, x2, x3]
@@ -141,9 +205,11 @@ f0x = insert 0 (k*y1) x
f1x = f0x + k * f0x->1
f2x = f1x + k^2 * f1x->2
-}
-causalRecursivePacked =
- Causal.mapAccum
- (\(FirstOrder.Parameter k, xk0) y1 -> do
+causalRecursivePackedStep ::
+ (A.PseudoRing v, Serial.C v, Serial.Element v ~ a, A.PseudoRing a) =>
+ (Parameter a, v) -> a -> LLVM.CodeGenFunction r (v,a)
+causalRecursivePackedStep =
+ \(Parameter k, xk0) y1 -> do
y1k <- A.mul k y1
xk1 <- Serial.modify A.zero (A.add y1k) xk0
let size = Serial.size xk0
@@ -174,8 +240,7 @@ causalRecursivePacked =
(takeWhile (< size) $ iterate (2*) 1)
-}
y0 <- Serial.extract (LLVM.valueOf $ fromIntegral $ size - 1) xk2
- return (xk2, y0))
- (return A.zero)
+ return (xk2, y0)
{-
We can also optimize filtering with time-varying filter parameter.
@@ -217,35 +282,43 @@ as first order filtering with matrix coefficients.
+addHighpass ::
+ (Causal.C process, A.Additive v) =>
+ process (param, v) v -> process (param, v) (Result v)
+addHighpass lowpass =
+{-
+Before we added sharing to Simple.Value,
+only this implementation allowed sharing
+and using CausalP.fromModifier did not.
+-}
+ Causal.map (\(l,x) -> do
+ h <- A.sub x l
+ return (Result{FirstOrder.lowpass_ = l,
+ FirstOrder.highpass_ = h}))
+ <<< (lowpass &&& arr snd)
+
causalPacked ::
(Causal.C process,
Serial.C v, Serial.Element v ~ a,
Memory.C a, A.IntegerConstant a,
A.PseudoRing v, A.PseudoRing a) =>
process (Parameter a, v) (Result v)
-causalPacked =
- Causal.map (\(l,x) -> do
- h <- A.sub x l
- return (Result{FirstOrder.lowpass_ = l,
- FirstOrder.highpass_ = h}))
- <<< (lowpassCausalPacked &&& arr snd)
+causalPacked = addHighpass lowpassCausalPacked
+
+causalInitPacked ::
+ (Causal.C process,
+ Serial.C v, Serial.Element v ~ a,
+ Memory.C a, A.IntegerConstant a,
+ A.PseudoRing v, A.PseudoRing a) =>
+ a -> process (Parameter a, v) (Result v)
+causalInitPacked a = addHighpass (lowpassCausalInitPacked a)
causalP ::
(A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>
CausalP.T p (Parameter a, v) (Result v)
-{-
-Before we added sharing to Simple.Value,
-only this implementation allowed sharing
-and using CausalP.fromModifier did not.
--}
-causalP =
- Causal.map (\(l,x) -> do
- h <- A.sub x l
- return (Result{FirstOrder.lowpass_ = l,
- FirstOrder.highpass_ = h}))
- <<< (lowpassCausalP &&& arr snd)
+causalP = addHighpass lowpassCausalP
lowpassCausalP, highpassCausalP ::
(A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>
@@ -253,6 +326,19 @@ lowpassCausalP, highpassCausalP ::
lowpassCausalP = lowpassCausal
highpassCausalP = highpassCausal
+causalInitP ::
+ (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,
+ Storable vh, Class.MakeValueTuple vh, Class.ValueTuple vh ~ v) =>
+ Param.T p vh -> CausalP.T p (Parameter a, v) (Result v)
+causalInitP = CausalP.fromInitializedModifier modifierInit
+
+lowpassCausalInitP, highpassCausalInitP ::
+ (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,
+ Storable vh, Class.MakeValueTuple vh, Class.ValueTuple vh ~ v) =>
+ Param.T p vh -> CausalP.T p (Parameter a, v) v
+lowpassCausalInitP = CausalP.fromInitializedModifier lowpassModifierInit
+highpassCausalInitP = CausalP.fromInitializedModifier highpassModifierInit
+
lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP ::
(Serial.C v, Serial.Element v ~ a,
Memory.C a, A.IntegerConstant a,
@@ -262,6 +348,20 @@ highpassCausalPackedP = highpassCausalPacked
lowpassCausalPackedP = lowpassCausalPacked
causalRecursivePackedP = causalRecursivePacked
+lowpassCausalInitPackedP, highpassCausalInitPackedP,
+ causalRecursiveInitPackedP ::
+ (A.PseudoRing v, Serial.C v, Serial.Element v ~ a,
+ A.PseudoRing a, A.IntegerConstant a, Memory.C a,
+ Storable ah, Class.MakeValueTuple ah, Class.ValueTuple ah ~ a) =>
+ Param.T p ah -> CausalP.T p (Parameter a, v) v
+causalRecursiveInitPackedP a =
+ CausalP.mapAccum (\() -> causalRecursivePackedStep) return (return ()) a
+
+highpassCausalInitPackedP a =
+ Causal.zipWith A.sub <<< arr snd &&& lowpassCausalInitPackedP a
+lowpassCausalInitPackedP a =
+ causalRecursiveInitPackedP a <<< (arr fst &&& preampPacked)
+
causalPackedP ::
(Serial.C v, Serial.Element v ~ a,
Memory.C a, A.IntegerConstant a,
@@ -269,6 +369,13 @@ causalPackedP ::
CausalP.T p (Parameter a, v) (Result v)
causalPackedP = causalPacked
+causalInitPackedP ::
+ (A.PseudoRing v, Serial.C v, Serial.Element v ~ a,
+ A.PseudoRing a, A.IntegerConstant a, Memory.C a,
+ Storable ah, Class.MakeValueTuple ah, Class.ValueTuple ah ~ a) =>
+ Param.T p ah -> CausalP.T p (Parameter a, v) (Result v)
+causalInitPackedP a = addHighpass (lowpassCausalInitPackedP a)
+
{-# DEPRECATED causalP "use 'causal' instead" #-}
{-# DEPRECATED lowpassCausalP "use 'lowpassCausal' instead" #-}
diff --git a/src/Synthesizer/LLVM/Filter/SecondOrder.hs b/src/Synthesizer/LLVM/Filter/SecondOrder.hs
index 517700c..dc983b0 100644
--- a/src/Synthesizer/LLVM/Filter/SecondOrder.hs
+++ b/src/Synthesizer/LLVM/Filter/SecondOrder.hs
@@ -25,7 +25,6 @@ import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Arithmetic as A
-import qualified LLVM.Extra.Monad as M
import LLVM.Extra.Class (Undefined, undefTuple, )
import qualified LLVM.Core as LLVM
@@ -35,10 +34,11 @@ import LLVM.Util.Loop (Phi, phis, addPhis, )
import qualified Type.Data.Num.Decimal as TypeNum
import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, )
+import qualified Control.Monad.HT as M
+import qualified Control.Applicative.HT as App
import Control.Arrow (arr, (<<<), (&&&), )
import Control.Monad (liftM2, foldM, )
import Control.Applicative (pure, (<*>), )
-import Control.Applicative.HT (liftA4, liftA5, )
import NumericPrelude.Numeric
import NumericPrelude.Base
@@ -70,7 +70,7 @@ parameterMemory ::
(Memory.C a) =>
Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a)
parameterMemory =
- liftA5 Parameter
+ App.lift5 Parameter
(Memory.element Filt2.c0 d0)
(Memory.element Filt2.c1 d1)
(Memory.element Filt2.c2 d2)
@@ -129,7 +129,7 @@ stateMemory ::
(Memory.C a) =>
Memory.Record r (StateStruct (Memory.Struct a)) (Filt2.State a)
stateMemory =
- liftA4 Filt2.State
+ App.lift4 Filt2.State
(Memory.element Filt2.u1 d0)
(Memory.element Filt2.u2 d1)
(Memory.element Filt2.y1 d2)
@@ -286,7 +286,7 @@ causalRecursivePacked =
(\(y,(a,b)) d ->
liftM2 (,)
(A.add y =<<
- M.liftR2 A.add
+ M.liftJoin2 A.add
{-
Possibility for optimization:
In the last step the second operand is a zero vector
@@ -297,7 +297,7 @@ causalRecursivePacked =
(Serial.shiftUpMultiZero d =<< A.mul y a)
(Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $
liftM2 (,)
- (M.liftR2 A.sub
+ (M.liftJoin2 A.sub
(A.mul a a)
(A.mul b (A.fromInteger' 2)))
(A.mul b b))
@@ -316,7 +316,7 @@ _causalRecursivePackedAlt =
Serial.modify (valueOf 0)
(\u0 ->
A.add u0 =<<
- M.liftR2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<<
+ M.liftJoin2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<<
Serial.modify (valueOf 1)
(\u1 -> A.add u1 =<< A.mul (Filt2.d2 p) x1)
x0
@@ -330,11 +330,11 @@ _causalRecursivePackedAlt =
(\(y,(a,b)) d ->
liftM2 (,)
(A.add y =<<
- M.liftR2 A.add
+ M.liftJoin2 A.add
(Serial.shiftUpMultiZero d =<< A.mul y a)
(Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $
liftM2 (,)
- (M.liftR2 A.sub
+ (M.liftJoin2 A.sub
(A.mul a a)
(A.mul b (A.fromInteger' 2)))
(A.mul b b))
diff --git a/src/Synthesizer/LLVM/Filter/Universal.hs b/src/Synthesizer/LLVM/Filter/Universal.hs
index 323fcc7..686bd3c 100644
--- a/src/Synthesizer/LLVM/Filter/Universal.hs
+++ b/src/Synthesizer/LLVM/Filter/Universal.hs
@@ -29,7 +29,7 @@ import LLVM.Util.Loop (Phi, phis, addPhis, )
import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, d5, )
-import Control.Applicative.HT (liftA6, )
+import qualified Control.Applicative.HT as App
instance (Phi a) => Phi (Parameter a) where
@@ -46,7 +46,7 @@ parameterMemory ::
(Memory.C a) =>
Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a)
parameterMemory =
- liftA6 Parameter
+ App.lift6 Parameter
(Memory.element Universal.k1 d0)
(Memory.element Universal.k2 d1)
(Memory.element Universal.ampIn d2)
diff --git a/src/Synthesizer/LLVM/ForeignPtr.hs b/src/Synthesizer/LLVM/ForeignPtr.hs
index 2e39b23..8247f1b 100644
--- a/src/Synthesizer/LLVM/ForeignPtr.hs
+++ b/src/Synthesizer/LLVM/ForeignPtr.hs
@@ -46,7 +46,7 @@ newParam ::
(Ptr (Memory.Struct (ValueTuple b)) -> IO (Ptr a)) ->
b -> IO (ForeignPtr a)
newParam stop start b =
- newInit stop (Marshal.with b (start . Memory.castStorablePtr))
+ newInit stop (Marshal.with b (start . Memory.castTuplePtr))
new :: Storable a => IO () -> a -> IO (ForeignPtr a)
new finalizer a = do
@@ -59,4 +59,4 @@ with ::
(Storable a, MakeValueTuple a, Memory.C (ValueTuple a)) =>
ForeignPtr a -> (Ptr (Memory.Struct (ValueTuple a)) -> IO b) -> IO b
with fp func =
- withForeignPtr fp (func . Memory.castStorablePtr)
+ withForeignPtr fp (func . Memory.castTuplePtr)
diff --git a/src/Synthesizer/LLVM/Frame/Stereo.hs b/src/Synthesizer/LLVM/Frame/Stereo.hs
index 993855c..b9d5252 100644
--- a/src/Synthesizer/LLVM/Frame/Stereo.hs
+++ b/src/Synthesizer/LLVM/Frame/Stereo.hs
@@ -127,3 +127,8 @@ instance (A.Additive a) => A.Additive (Stereo.T a) where
add x y = Trav.sequence $ liftA2 A.add x y
sub x y = Trav.sequence $ liftA2 A.sub x y
neg x = Trav.sequence $ fmap A.neg x
+
+type instance A.Scalar (Stereo.T a) = A.Scalar a
+
+instance (A.PseudoModule a) => A.PseudoModule (Stereo.T a) where
+ scale a = Trav.sequence . fmap (A.scale a)
diff --git a/src/Synthesizer/LLVM/Parameter.hs b/src/Synthesizer/LLVM/Parameter.hs
index 267b167..04f5a60 100644
--- a/src/Synthesizer/LLVM/Parameter.hs
+++ b/src/Synthesizer/LLVM/Parameter.hs
@@ -9,6 +9,11 @@ module Synthesizer.LLVM.Parameter (
value,
with,
+ Tuple(..),
+ withTuple,
+ withTuple1,
+ withTuple2,
+
-- * for implementation of new processes
word32,
) where
@@ -27,13 +32,14 @@ import qualified Algebra.Additive as Additive
import qualified Control.Category as Cat
import qualified Control.Arrow as Arr
import qualified Control.Applicative as App
-import Control.Applicative (pure, liftA2, )
+import Control.Applicative (pure, liftA2, (<$>), )
+import qualified Data.Tuple.HT as TupleHT
import Data.Tuple.HT (mapFst, )
import Data.Word (Word32, )
import NumericPrelude.Numeric
-import Prelude (Functor, Monad, fmap, error, (.), const, id, )
+import Prelude (Functor, Monad, fmap, error, (.), ($), const, id, )
import qualified Prelude as P
@@ -231,3 +237,83 @@ instance P.Num a => P.Num (T p a) where
instance P.Fractional a => P.Fractional (T p a) where
(/) = liftA2 (P./)
fromRational = pure . P.fromRational
+
+instance P.Floating a => P.Floating (T p a) where
+ pi = pure P.pi
+ exp = fmap P.exp
+ sqrt = fmap P.sqrt
+ log = fmap P.log
+ (**) = liftA2 (P.**)
+ logBase = liftA2 P.logBase
+ sin = fmap P.sin
+ tan = fmap P.tan
+ cos = fmap P.cos
+ asin = fmap P.asin
+ atan = fmap P.atan
+ acos = fmap P.acos
+ sinh = fmap P.sinh
+ tanh = fmap P.tanh
+ cosh = fmap P.cosh
+ asinh = fmap P.asinh
+ atanh = fmap P.atanh
+ acosh = fmap P.acosh
+
+
+
+class Tuple tuple where
+ type Composed tuple :: *
+ type Source tuple :: *
+ decompose :: T (Source tuple) (Composed tuple) -> tuple
+
+instance Tuple (T p a) where
+ type Composed (T p a) = a
+ type Source (T p a) = p
+ decompose = id
+
+instance (Tuple a, Tuple b, Source a ~ Source b) => Tuple (a,b) where
+ type Composed (a,b) = (Composed a, Composed b)
+ type Source (a,b) = Source a
+ decompose p = (decompose $ P.fst <$> p, decompose $ P.snd <$> p)
+
+instance
+ (Tuple a, Tuple b, Tuple c, Source a ~ Source b, Source b ~ Source c) =>
+ Tuple (a,b,c) where
+ type Composed (a,b,c) = (Composed a, Composed b, Composed c)
+ type Source (a,b,c) = Source a
+ decompose p =
+ (decompose $ TupleHT.fst3 <$> p,
+ decompose $ TupleHT.snd3 <$> p,
+ decompose $ TupleHT.thd3 <$> p)
+
+{- |
+Provide all elements of a nested tuple as separate parameters.
+
+If you do not use one of the tuple elements,
+you will get a type error like
+@Couldn't match type `Param.Composed t0' with `Int'@.
+The problem is that the type checker cannot infer
+that an element is a @Parameter.T@ if it remains unused.
+-}
+withTuple ::
+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>
+ (tuple -> f p) -> f p
+withTuple f = idFromFunctor $ f . decompose
+
+idFromFunctor :: (T p p -> f p) -> f p
+idFromFunctor f = f Cat.id
+
+withTuple1 ::
+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>
+ (tuple -> f p a) -> f p a
+withTuple1 f = idFromFunctor1 $ f . decompose
+
+idFromFunctor1 :: (T p p -> f p a) -> f p a
+idFromFunctor1 f = f Cat.id
+
+withTuple2 ::
+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>
+ (tuple -> f p a b) -> f p a b
+withTuple2 f = idFromFunctor2 $ f . decompose
+
+idFromFunctor2 :: (T p p -> f p a b) -> f p a b
+idFromFunctor2 f = f Cat.id
diff --git a/src/Synthesizer/LLVM/Parameterized/Signal.hs b/src/Synthesizer/LLVM/Parameterized/Signal.hs
index 4d3e252..b7c382e 100644
--- a/src/Synthesizer/LLVM/Parameterized/Signal.hs
+++ b/src/Synthesizer/LLVM/Parameterized/Signal.hs
@@ -10,6 +10,7 @@ module Synthesizer.LLVM.Parameterized.Signal (
adjacentNodes13,
amplify,
amplifyStereo,
+ Sig.empty,
append,
cycle,
drop,
@@ -24,6 +25,7 @@ module Synthesizer.LLVM.Parameterized.Signal (
mapSimple,
mapAccum,
Sig.mix,
+ Sig.mixExt,
noise,
noiseCore,
osci,
@@ -97,7 +99,6 @@ import qualified Numeric.NonNegative.Wrapper as NonNeg
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.MaybeContinuation as MaybeCont
-import qualified LLVM.Extra.Either as Either
import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Extra.Memory as Memory
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )
@@ -115,7 +116,7 @@ import LLVM.Core
import qualified Type.Data.Num.Decimal as TypeNum
import Control.Monad.HT ((<=<), )
-import Control.Monad (liftM2, when, )
+import Control.Monad (when, )
import Control.Arrow ((^<<), )
import Control.Applicative (liftA2, liftA3, pure, (<$>), )
import Control.Functor.HT (void, )
@@ -201,55 +202,6 @@ drop n (Cons next alloca start stop createIOContext deleteIOContext) =
return (ioContext, (param, getN p)))
deleteIOContext
-{- |
-Appending many signals is inefficient,
-since in cascadingly appended signals the parts are counted in an unary way.
-Concatenating infinitely many signals is impossible.
-If you want to concatenate a lot of signals,
-please render them to lazy storable vectors first.
--}
-{-
-We might save a little space by using a union
-for the states of the first and the second signal generator.
-If the concatenated generators allocate memory,
-we could also save some memory by calling @startB@
-only after the first generator finished.
-However, for correct deallocation
-we would need to track which of the @start@ blocks
-have been executed so far.
-This in turn might be difficult in connection with the garbage collector.
--}
-append ::
- (Loop.Phi a, Undefined a) =>
- T p a -> T p a -> T p a
-append
- (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)
- (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =
- Cons
- (\parameterB (localA, localB) ecs0 -> MaybeCont.fromMaybe $ do
- ecs1 <-
- Either.run ecs0
- (\(ca, sa0) ->
- MaybeCont.resolve
- (nextA ca localA sa0)
- (fmap Either.right $ startB parameterB)
- (\(a1,sa1) -> return (Either.left (a1, (ca, sa1)))))
- (return . Either.right)
-
- Either.run ecs1
- (\(a1,cs1) ->
- return (Maybe.just (a1, Either.left cs1)))
- (\(cb,sb0) ->
- MaybeCont.toMaybe $
- fmap (\(b,sb1) -> (b, Either.right (cb,sb1))) $
- nextB cb localB sb0))
- (liftM2 (,) allocaA allocaB)
- (\(parameterA, parameterB) -> do
- cs <- startA parameterA
- return (parameterB, Either.left cs))
- (\ _parameterB s -> Either.run s (uncurry stopA) (uncurry stopB))
- (combineCreate createIOContextA createIOContextB)
- (combineDelete deleteIOContextA deleteIOContextB)
cycle ::
(Loop.Phi a, Undefined a) =>
@@ -344,6 +296,7 @@ adjacentNodes13 yp0 =
(pure ()) yp0
+
-- * signal generators
@@ -733,8 +686,8 @@ run (Cons next alloca start stop createIOContext deleteIOContext) =
SVB.createAndTrim len $ \ ptr ->
Alloc.with params $ \paramPtr ->
fmap fromIntegral $
- fill (Memory.castStorablePtr paramPtr)
- (fromIntegral len) (Memory.castStorablePtr ptr)
+ fill (Memory.castTuplePtr paramPtr)
+ (fromIntegral len) (Memory.castTuplePtr ptr)
{- |
This is not really a function, see 'renderChunky'.
@@ -922,7 +875,7 @@ runChunkyPattern
SVB.createAndTrim size $
fmap fromIntegral .
fill sptr (fromIntegral size) .
- Memory.castStorablePtr
+ Memory.castTuplePtr
touchForeignPtr ioContextPtr
(if SV.length v > 0
then fmap (v:)
diff --git a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs
index cd2af79..836f211 100644
--- a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs
+++ b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs
@@ -7,12 +7,14 @@ module Synthesizer.LLVM.Parameterized.SignalPrivate where
import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig
import qualified Synthesizer.LLVM.Parameter as Param
-import qualified LLVM.Extra.MaybeContinuation as Maybe
+import qualified LLVM.Extra.MaybeContinuation as MaybeCont
+import qualified LLVM.Extra.Either as Either
+import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )
+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, )
import LLVM.Core (CodeGenFunction, )
import LLVM.Util.Loop (Phi, )
@@ -24,6 +26,9 @@ import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )
import Foreign.Ptr (Ptr, )
+import Data.Monoid (Monoid, mempty, mappend, )
+import Data.Semigroup (Semigroup, (<>), )
+
import qualified Number.Ratio as Ratio
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
@@ -71,7 +76,7 @@ data T p a =
Cons
(forall r c.
(Phi c) =>
- context -> local -> state -> Maybe.T r c (a, state))
+ context -> local -> state -> MaybeCont.T r c (a, state))
-- compute next value
(forall r.
CodeGenFunction r local)
@@ -173,7 +178,7 @@ simple ::
Memory.C state) =>
(forall r c.
(Phi c) =>
- context -> state -> Maybe.T r c (al, state)) ->
+ context -> state -> MaybeCont.T r c (al, state)) ->
(forall r.
ValueTuple parameters ->
CodeGenFunction r (context, state)) ->
@@ -228,10 +233,10 @@ zip (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)
Cons
(\(parameterA, parameterB) (localA, localB) (sa0,sb0) -> do
(a,sa1) <-
- Maybe.onFail (stopB parameterB sb0) $
+ MaybeCont.onFail (stopB parameterB sb0) $
nextA parameterA localA sa0
(b,sb1) <-
- Maybe.onFail (stopA parameterA sa1) $
+ MaybeCont.onFail (stopA parameterA sa1) $
nextB parameterB localB sb0
return ((a,b), (sa1,sb1)))
(liftM2 (,) allocaA allocaB)
@@ -299,6 +304,47 @@ instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T p a) whe
(/) = zipWithSimple A.fdiv
+{- |
+For restrictions see 'Sig.append'.
+-}
+append :: (Phi a, Undefined a) => T p a -> T p a -> T p a
+append
+ (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)
+ (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =
+ Cons
+ (\parameterB (localA, localB) ecs0 -> MaybeCont.fromMaybe $ do
+ ecs1 <-
+ Either.run ecs0
+ (\(ca, sa0) ->
+ MaybeCont.resolve
+ (nextA ca localA sa0)
+ (fmap Either.right $ startB parameterB)
+ (\(a1,sa1) -> return (Either.left (a1, (ca, sa1)))))
+ (return . Either.right)
+
+ Either.run ecs1
+ (\(a1,cs1) ->
+ return (Maybe.just (a1, Either.left cs1)))
+ (\(cb,sb0) ->
+ MaybeCont.toMaybe $
+ fmap (\(b,sb1) -> (b, Either.right (cb,sb1))) $
+ nextB cb localB sb0))
+ (liftM2 (,) allocaA allocaB)
+ (\(parameterA, parameterB) -> do
+ cs <- startA parameterA
+ return (parameterB, Either.left cs))
+ (\ _parameterB s -> Either.run s (uncurry stopA) (uncurry stopB))
+ (combineCreate createIOContextA createIOContextB)
+ (combineDelete deleteIOContextA deleteIOContextB)
+
+instance (Phi a, Undefined a) => Semigroup (T p a) where
+ (<>) = append
+
+instance (Phi a, Undefined a) => Monoid (T p a) where
+ mempty = Sig.empty
+ mappend = append
+
+
iterate ::
(Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl,
Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) =>
@@ -307,7 +353,7 @@ iterate ::
Param.T p a -> T p al
iterate f param initial = simple
(\pl al0 ->
- Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))
+ MaybeCont.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))
return
(param &&& initial)
diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs
index e8f3d6a..63eaa13 100644
--- a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs
+++ b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs
@@ -32,9 +32,12 @@ module Synthesizer.LLVM.Server.CausalPacked.Instrument (
frequencyControl, zipEnvelope,
) where
+import qualified Synthesizer.LLVM.Server.Parameter as ParamS
import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise, )
import Synthesizer.LLVM.Server.CommonPacked
import Synthesizer.LLVM.Server.Common hiding (Instrument, )
+import Synthesizer.LLVM.Server.Parameter
+ (Number(Number), VectorTime(VectorTime), Signal(Signal))
import qualified Synthesizer.LLVM.Server.SampledSound as Sample
import qualified Synthesizer.LLVM.Storable.Process as PSt
@@ -76,19 +79,18 @@ import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
-import qualified LLVM.Extra.Monad as LM
-
import qualified LLVM.Core as LLVM
import qualified Type.Data.Num.Decimal as TypeNum
-import qualified Data.Traversable as Trav
+import qualified Control.Monad.HT as M
import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<), )
import Control.Category (id, (.), )
import Control.Monad (liftM2, liftM3, liftM4, (<=<), )
import Control.Applicative (pure, liftA2, liftA3, )
+
+import qualified Data.Traversable as Trav
import Data.Monoid (mappend, )
-import Data.Tuple.HT (fst3, snd3, thd3, )
import qualified Number.DimensionTerm as DN
@@ -214,18 +216,14 @@ pingReleaseEnvelope =
.
Gate.allToChunkySize))
(CausalP.processIO $
- let vel = number snd
- decay = vectorTime fst
- in CausalP.fromSignal $
- SigPS.exponential2 decay
- (fmap amplitudeFromVelocity vel))
+ ParamS.withTuple2 $ \(VectorTime decay, Number vel) ->
+ CausalP.fromSignal $
+ SigPS.exponential2 decay (fmap amplitudeFromVelocity vel))
(CausalP.processIO $
- let level = number snd
- release = time fst
- in CausalP.take (fmap round (vectorTime (const 1)))
- .
- CausalP.fromSignal
- (SigPS.exponential2 release level))
+ ParamS.withTuple2 $ \(ParamS.Time release, Number level) ->
+ CausalP.take (fmap round (vectorTime (const 1)))
+ .
+ CausalP.fromSignal (SigPS.exponential2 release level))
pingRelease :: IO (Real -> Real -> Instrument Real Chunk)
pingRelease =
@@ -681,7 +679,7 @@ arcStringStereoFM ::
arcStringStereoFM wave =
softStringShapeCore
(\k p ->
- LM.liftR2 Frame.amplifyMono
+ M.liftJoin2 Frame.amplifyMono
(WaveL.approxSine4 =<< WaveL.halfEnvelope p)
(wave =<< WaveL.replicate k p))
@@ -902,11 +900,10 @@ makeHelix ::
IO ((SampleRate Real, ((Real, Real), SigSt.T Real)) ->
PIO.T (Zip.T Chunk StereoChunk) StereoChunk)
makeHelix =
- CausalP.processIO
- (let amp = number (fst.fst)
- per = number (snd.fst)
- smp = signal snd
- in CausalPS.amplifyStereo amp
+ CausalP.processIO $
+ ParamS.withTuple2 $
+ \((Number amp, Number per), Signal smp) ->
+ CausalPS.amplifyStereo amp
.
CausalP.stereoFromMono
(Helix.staticPacked
@@ -917,36 +914,31 @@ makeHelix =
.
second (CausalPS.osciCore $< 0))
.
- arr (\(shape, freq) -> fmap ((,) shape) freq))
+ arr (\(shape, freq) -> fmap ((,) shape) freq)
makeZigZag ::
IO ((SampleRate Real, (Real, Real, Real)) ->
PIO.T (Control Real) Chunk)
makeZigZag =
- CausalP.processIO
- (let start = number fst3
- loopStart = number snd3
- loopLength = number thd3
-
- in CausalPS.raise start
- .
- -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)
- Helix.zigZagLongPacked (loopStart-start) loopLength
- .
- CausalP.mapSimple Serial.upsample)
+ CausalP.processIO $
+ ParamS.withTuple2 $
+ \(Number start, Number loopStart, Number loopLength) ->
+ CausalPS.raise start
+ .
+ -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)
+ Helix.zigZagLongPacked (loopStart-start) loopLength
+ .
+ CausalP.mapSimple Serial.upsample
makeIntegrate ::
IO ((SampleRate Real, (Real, Real)) ->
PIO.T (Control Real) Chunk)
makeIntegrate =
- CausalP.processIO
- (let start = number fst
- stop = number snd
-
- in CausalPV.takeWhile
- (\s v -> s %> Value.lift1 Serial.subsample v)
- stop
- .
- CausalPS.integrate start
- .
- CausalP.mapSimple Serial.upsample)
+ CausalP.processIO $
+ ParamS.withTuple2 $
+ \(Number start, Number stop) ->
+ CausalPV.takeWhile (\s v -> s %> Value.lift1 Serial.subsample v) stop
+ .
+ CausalPS.integrate start
+ .
+ CausalP.mapSimple Serial.upsample
diff --git a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs
index c7edfb6..3450e56 100644
--- a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs
+++ b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs
@@ -117,8 +117,11 @@ module Synthesizer.LLVM.Server.Packed.Instrument (
adsr,
) where
+import qualified Synthesizer.LLVM.Server.Parameter as ParamS
import Synthesizer.LLVM.Server.CommonPacked
import Synthesizer.LLVM.Server.Common
+import Synthesizer.LLVM.Server.Parameter
+ (Number(Number), Signal(Signal), Control(Control))
import qualified Synthesizer.LLVM.Server.SampledSound as Sample
import qualified Synthesizer.LLVM.MIDI.BendModulation as BM
@@ -148,7 +151,6 @@ import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )
import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )
import Synthesizer.LLVM.Parameter (($#), )
-import qualified LLVM.Extra.Monad as LM
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
import qualified Type.Data.Num.Decimal as TypeNum
@@ -160,6 +162,7 @@ import qualified Data.StorableVector.Lazy as SVL
import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter
+import qualified Control.Monad.HT as M
import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, )
import Control.Category (id, )
import Control.Applicative (liftA2, liftA3, )
@@ -191,6 +194,15 @@ modulation param =
arr (\(sr, p) ->
(\(fm,freq) -> transposeModulation sr freq fm) $ param p)
+newtype Modulation p = Modulation (Param p (PC.T (BM.T Real)))
+
+instance ParamS.Tuple (Modulation p) where
+ type Composed (Modulation p) = (PC.T (BM.T Real), Real)
+ type Source (Modulation p) = p
+ decompose sampleRate x =
+ Modulation $
+ liftA2 (\sr (fm,freq) -> transposeModulation sr freq fm) sampleRate x
+
detuneModulation ::
(p -> (PC.T Real, PC.T (BM.T Real), Real)) ->
Param p (PC.T Real, PC.T (BM.T Real))
@@ -199,6 +211,20 @@ detuneModulation param =
case param p of
(det,fm,freq) -> (det, transposeModulation sr freq fm)
+newtype
+ DetuneModulation p =
+ DetuneModulation (Param p (PC.T Real, PC.T (BM.T Real)))
+
+instance ParamS.Tuple (DetuneModulation p) where
+ type Composed (DetuneModulation p) = (PC.T Real, PC.T (BM.T Real), Real)
+ type Source (DetuneModulation p) = p
+ decompose sampleRate x =
+ DetuneModulation $
+ liftA2
+ (\sr (det,fm,freq) -> (det, transposeModulation sr freq fm))
+ sampleRate x
+
+
frequencyFromBendModulation ::
{-
@@ -300,19 +326,18 @@ pingStereoReleaseFM =
osc
(sr, ((phase, phaseDecay), shape, (detune,fm,freq)))
(env dec rel vcsize sr vel dur))
- (CausalP.runStorableChunky
- (let phase = number (fst.fst3) :: Param ((Real,a), b, c) Real
- decay = time (snd.fst3) :: Param ((a,Real), b, c) Real
- shape = control snd3 :: Param (a, PC.T Real, c) (PC.T Real)
- fm = detuneModulation thd3 :: Param (a, b, (PC.T Real, PC.T (BM.T Real), Real)) (PC.T Real, PC.T (BM.T Real))
- in CausalP.envelopeStereo $>
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \((Number phase, ParamS.Time decay),
+ Control shape, DetuneModulation fm) ->
+ CausalP.envelopeStereo $>
((CausalP.stereoFromMonoControlled
(CausalPS.shapeModOsci WaveL.rationalApproxSine1)
$< piecewiseConstantVector shape)
<<^ Stereo.interleave
$< (liftA2 Stereo.cons id (Additive.negate id)
$* SigPS.exponential2 decay phase)
- $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)))
+ $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm))
pingReleaseEnvelope
{- |
@@ -333,11 +358,9 @@ squareStereoReleaseFM =
osc
(sr, ((phase, shape), (detune,fm,freq)))
(env dec rel vcsize sr vel dur))
- (CausalP.runStorableChunky
- (let phs = control (fst.fst)
- shp = control (snd.fst)
- fm = detuneModulation snd
- chanOsci ::
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $ \((Control phs, Control shp), DetuneModulation fm) ->
+ (let chanOsci ::
CausalP p
((VectorValue, VectorValue), VectorValue)
VectorValue
@@ -373,12 +396,10 @@ bellStereoFM =
(env (dec/4) rel vcsize sr vel dur,
env (dec/7) rel vcsize sr vel dur)))
(env dec rel vcsize sr vel dur))
- (CausalP.runStorableChunky
- (let fm = detuneModulation fst3
- vel = number snd3
- env4 = signal (fst.thd3)
- env7 = signal (snd.thd3)
- osci ::
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \(DetuneModulation fm, Number vel, (Signal env4, Signal env7)) ->
+ (let osci ::
(Triple VectorValue -> VectorValue) ->
Param.T p Real ->
Param.T p Real ->
@@ -428,15 +449,12 @@ bellNoiseStereoFM =
env (dec/4) rel vcsize sr vel dur,
env (dec/7) rel vcsize sr vel dur)))
(env dec rel vcsize sr vel dur))
- (CausalP.runStorableChunky
- (let fm = modulation fst3
- noiseAmp = control (fst.snd3)
- noiseReson = control (snd.snd3)
- vel = number (fst3.thd3)
- env4 = signal (snd3.thd3)
- env7 = signal (thd3.thd3)
-
- osci ::
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \(Modulation fm,
+ (Control noiseAmp, Control noiseReson),
+ (Number vel, Signal env4, Signal env7)) ->
+ (let osci ::
(Triple VectorValue -> VectorValue) ->
Param.T p Real ->
Param.T p Real ->
@@ -454,14 +472,15 @@ bellNoiseStereoFM =
CausalPS.amplify d))
noise ::
+ (p ~
+ ((PC.T (BM.T Real), Real),
+ (PC.T Real, PC.T Real),
+ (Real, SigSt.T Vector, SigSt.T Vector))) =>
(Triple VectorValue -> VectorValue) ->
- Param (a, (PC.T Real, PC.T Real), c) Real ->
- CausalP (a, (PC.T Real, PC.T Real), c)
- (Triple VectorValue, VectorValue)
- VectorValue
+ Param p Real ->
+ CausalP p (Triple VectorValue, VectorValue) VectorValue
noise sel d =
- (CausalP.envelope $<
- piecewiseConstantVector noiseAmp)
+ (CausalP.envelope $< piecewiseConstantVector noiseAmp)
<<<
CausalP.envelope
<<<
@@ -527,7 +546,8 @@ tine =
(2*freq)))))
pingReleaseEnvelope
-tineStereo :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))
+tineStereo ::
+ IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))
tineStereo =
liftA2
(\osc env dec rel vcsize sr vel freq dur ->
@@ -586,8 +606,7 @@ softString =
(\osc env sr vel freq dur ->
osc (sr, freq) (env 1 sr vel dur))
(let freq = frequency id
- osci d =
- SigPS.osciSimple WaveL.saw zero (d * freq)
+ osci d = SigPS.osciSimple WaveL.saw zero (d * freq)
in CausalP.runStorableChunky $
(CausalP.envelopeStereo $>
(liftA2 Stereo.cons
@@ -596,9 +615,7 @@ softString =
softStringReleaseEnvelope
-softStringFM ::
- IO (PC.T (BM.T Real) ->
- Instrument Real (Stereo.T Vector))
+softStringFM :: IO (PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector))
softStringFM =
liftA2
(\osc env fm sr vel freq dur ->
@@ -705,14 +722,12 @@ tineControlledFM =
osc
(sr, ((index, depth), vel, (detune,fm,freq)))
(env dec rel vcsize sr 0 dur))
- (CausalP.runStorableChunky
- (let index = control (fst.fst3)
- depth = control (snd.fst3)
- vel = number snd3
- fm = detuneModulation thd3
- in CausalP.envelopeStereo $>
- (tineControlledFnProc index depth vel $*
- stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \((Control index, Control depth), Number vel, DetuneModulation fm) ->
+ CausalP.envelopeStereo $>
+ (tineControlledFnProc index depth vel $*
+ stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))
pingReleaseEnvelope
@@ -786,15 +801,13 @@ fenderFM =
osc
(sr, (((index, depth), fade), vel, (detune,fm,freq)))
(env dec rel vcsize sr 0 dur))
- (CausalP.runStorableChunky
- (let index = control (fst.fst.fst3)
- depth = control (snd.fst.fst3)
- fade = control (snd.fst3)
- vel = number snd3
- fm = detuneModulation thd3
- in CausalP.envelopeStereo $>
- (fenderProc fade index depth vel $*
- stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \(((Control index, Control depth), Control fade),
+ Number vel, DetuneModulation fm) ->
+ CausalP.envelopeStereo $>
+ (fenderProc fade index depth vel $*
+ stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))
pingReleaseEnvelope
@@ -830,16 +843,13 @@ tineModulatorBankFM =
depth1 depth2 depth3 depth4
vcsize fm sr vel freq dur ->
osc
- (sr, ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq)))
+ (sr, ((depth1,(depth2,(depth3,(depth4)))), vel, (detune,fm,freq)))
(env dec rel vcsize sr 0 dur))
- (CausalP.runStorableChunky
- (let depth1 = control (fst.fst3)
- depth2 = control (fst.snd.fst3)
- depth3 = control (fst.snd.snd.fst3)
- depth4 = control (fst.snd.snd.snd.fst3)
- vel = number snd3
- fm = detuneModulation thd3
- in CausalP.envelopeStereo $>
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \((Control depth1, (Control depth2, (Control depth3, Control depth4))),
+ Number vel, DetuneModulation fm) ->
+ (CausalP.envelopeStereo $>
(CausalP.stereoFromMono
(CausalPS.osciSimple WaveL.approxSine2)
<<<
@@ -872,22 +882,17 @@ tineBankFM =
vcsize fm sr vel freq dur ->
osc
(sr,
- ((depth1,(depth2,(depth3,(depth4,())))),
- (partial1,(partial2,(partial3,(partial4,())))),
+ ((depth1,(depth2,(depth3,(depth4)))),
+ (partial1,(partial2,(partial3,(partial4)))),
(vel, (detune,fm,freq))))
(env dec rel vcsize sr 0 dur))
- (CausalP.runStorableChunky
- (let depth1 = control (fst.fst3)
- depth2 = control (fst.snd.fst3)
- depth3 = control (fst.snd.snd.fst3)
- depth4 = control (fst.snd.snd.snd.fst3)
- partial1 = control (fst.snd3)
- partial2 = control (fst.snd.snd3)
- partial3 = control (fst.snd.snd.snd3)
- partial4 = control (fst.snd.snd.snd.snd3)
- vel = number (fst.thd3)
- fm = detuneModulation (snd.thd3)
- partial ::
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \((Control depth1, (Control depth2, (Control depth3, Control depth4))),
+ (Control partial1,(Control partial2, (Control partial3, Control partial4))),
+ (Number vel, DetuneModulation fm)) ->
+
+ (let partial ::
VectorValue -> Int -> VectorValue ->
LLVM.CodeGenFunction r VectorValue
partial amp n t =
@@ -979,15 +984,13 @@ resonantFMSynth =
osc
(sr, ((reson, index, depth), vel, (detune,fm,freq)))
(env dec rel vcsize sr 0 dur))
- (CausalP.runStorableChunky
- (let reson = control (fst3.fst3)
- index = control (snd3.fst3)
- depth = control (thd3.fst3)
- vel = number snd3
- fm = detuneModulation thd3
- in CausalP.envelopeStereo $>
- (resonantFMSynthProc reson index depth vel $*
- stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))
+ (CausalP.runStorableChunky $
+ ParamS.withTuple2 $
+ \((Control reson, Control index, Control depth),
+ Number vel, DetuneModulation fm) ->
+ CausalP.envelopeStereo $>
+ (resonantFMSynthProc reson index depth vel $*
+ stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))
pingReleaseEnvelope
@@ -1067,7 +1070,7 @@ arcStringStereoFM ::
arcStringStereoFM wave =
softStringShapeCore
(\k p ->
- LM.liftR2 Frame.amplifyMono
+ M.liftJoin2 Frame.amplifyMono
(WaveL.approxSine4 =<< WaveL.halfEnvelope p)
(wave =<< WaveL.replicate k p))
diff --git a/src/Synthesizer/LLVM/Server/Parameter.hs b/src/Synthesizer/LLVM/Server/Parameter.hs
new file mode 100644
index 0000000..54fb8e0
--- /dev/null
+++ b/src/Synthesizer/LLVM/Server/Parameter.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE TypeFamilies #-}
+module Synthesizer.LLVM.Server.Parameter (
+ Tuple(..),
+ Frequency(..), Time(..), VectorTime(..), Number(..), Control(..), Signal(..),
+ withTuple2,
+ ) where
+
+import Synthesizer.LLVM.Server.CommonPacked (vectorSize)
+import Synthesizer.LLVM.Server.Common (Param, Real, SampleRate(SampleRate))
+
+import qualified Synthesizer.PiecewiseConstant.Signal as PC
+import qualified Synthesizer.LLVM.Parameter as Param
+
+import qualified Synthesizer.Storable.Signal as SigSt
+
+import qualified Control.Category as Cat
+import Control.Applicative ((<$>), )
+
+import qualified Data.Tuple.HT as TupleHT
+
+import Prelude hiding (Real, )
+
+
+class Tuple tuple where
+ type Composed tuple :: *
+ type Source tuple :: *
+ decompose ::
+ Param (Source tuple) (SampleRate Real) ->
+ Param (Source tuple) (Composed tuple) -> tuple
+
+
+newtype Number p = Number (Param p Real)
+
+instance Tuple (Number p) where
+ type Composed (Number p) = Real
+ type Source (Number p) = p
+ decompose _sr t = Number t
+
+
+deconsSampleRate :: Param p (SampleRate a) -> Param p a
+deconsSampleRate = fmap (\(SampleRate sr) -> sr)
+
+newtype Time p = Time (Param p Real)
+
+instance Tuple (Time p) where
+ type Composed (Time p) = Real
+ type Source (Time p) = p
+ decompose sr t = Time (t * deconsSampleRate sr)
+
+newtype VectorTime p = VectorTime (Param p Real)
+
+instance Tuple (VectorTime p) where
+ type Composed (VectorTime p) = Real
+ type Source (VectorTime p) = p
+ decompose sr t =
+ VectorTime (t * deconsSampleRate sr / fromIntegral vectorSize)
+
+newtype Frequency p = Frequency (Param p Real)
+
+instance Tuple (Frequency p) where
+ type Composed (Frequency p) = Real
+ type Source (Frequency p) = p
+ decompose sr freq = Frequency (freq / deconsSampleRate sr)
+
+
+newtype Control p = Control (Param p (PC.T Real))
+
+instance Tuple (Control p) where
+ type Composed (Control p) = PC.T Real
+ type Source (Control p) = p
+ decompose _sr x = Control x
+
+
+newtype Signal p a = Signal (Param p (SigSt.T a))
+
+instance Tuple (Signal p a) where
+ type Composed (Signal p a) = SigSt.T a
+ type Source (Signal p a) = p
+ decompose _sr x = Signal x
+
+
+instance (Tuple a, Tuple b, Source a ~ Source b) => Tuple (a,b) where
+ type Composed (a,b) = (Composed a, Composed b)
+ type Source (a,b) = Source a
+ decompose sr p = (decompose sr $ fst <$> p, decompose sr $ snd <$> p)
+
+instance
+ (Tuple a, Tuple b, Tuple c, Source a ~ Source b, Source b ~ Source c) =>
+ Tuple (a,b,c) where
+ type Composed (a,b,c) = (Composed a, Composed b, Composed c)
+ type Source (a,b,c) = Source a
+ decompose sr p =
+ (decompose sr $ TupleHT.fst3 <$> p,
+ decompose sr $ TupleHT.snd3 <$> p,
+ decompose sr $ TupleHT.thd3 <$> p)
+
+
+withTuple2 ::
+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>
+ (tuple -> f (SampleRate Real, p) a b) -> f (SampleRate Real, p) a b
+withTuple2 f =
+ idFromFunctor2 $ \param -> f $ decompose (fst<$>param) (snd<$>param)
+
+-- cf. Param.idFromFunctor2
+idFromFunctor2 :: (Param.T p p -> f p a b) -> f p a b
+idFromFunctor2 f = f Cat.id
diff --git a/src/Synthesizer/LLVM/Simple/Signal.hs b/src/Synthesizer/LLVM/Simple/Signal.hs
index cbda33e..2ea6e15 100644
--- a/src/Synthesizer/LLVM/Simple/Signal.hs
+++ b/src/Synthesizer/LLVM/Simple/Signal.hs
@@ -17,6 +17,10 @@ module Synthesizer.LLVM.Simple.Signal (
map,
mapAccum,
mix,
+ mixExt,
+ takeWhile,
+ empty,
+ append,
osci,
osciPlain,
osciSaw,
@@ -51,7 +55,7 @@ import qualified LLVM.Extra.MaybeContinuation as MaybeCont
import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )
-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, valueTupleOf, )
+import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, valueTupleOf, )
import qualified LLVM.Core as LLVM
import LLVM.Util.Loop (Phi, )
@@ -60,7 +64,9 @@ import LLVM.Core
IsSized, IsConst, IsArithmetic)
import Control.Monad (liftM2, )
-import Control.Applicative (pure, liftA3, (<$>), )
+import Control.Applicative (pure, liftA2, liftA3, (<$>), )
+
+import Data.Monoid (Monoid, mappend, )
import qualified Algebra.Transcendental as Trans
@@ -73,7 +79,7 @@ import Data.Word (Word32, )
import Control.Exception (bracket, )
import NumericPrelude.Numeric
-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )
+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, takeWhile, )
constant :: (C signal, IsConst a) => a -> signal (Value a)
@@ -95,11 +101,55 @@ mapAccum f startS = alter (\(Core next start stop) ->
(stop . fst))
+{- |
+Warning:
+This shortens the result to the shorter input signal.
+This is consistent with @Causal.mix@ but it may not be what you expect.
+Consider using 'mixExt' instead.
+-}
mix ::
(C signal, A.Additive a) =>
signal a -> signal a -> signal a
mix = zipWith Frame.mix
+{- |
+The result of mixing is as long as the longer of the two input signals.
+-}
+mixExt ::
+ (C signal, Monoid (signal (Value Bool, a)),
+ A.Additive a, Phi a, Undefined a) =>
+ signal a -> signal a -> signal a
+mixExt xs ys =
+ let ext zs =
+ mappend
+ ((,) (valueOf True) <$> zs)
+ (pure (valueOf False, A.zero))
+ in fmap snd $ takeWhile (return . fst) $
+ zipWith
+ (\(cx,x) (cy,y) -> liftA2 (,) (A.or cx cy) (A.add x y))
+ (ext xs) (ext ys)
+
+
+{-
+You can apply Causal.takeWhile instead,
+but this requires a pretty complex type signature
+including a 'process' variable that is not of interest for the user.
+-}
+takeWhile ::
+ (C signal) =>
+ (forall r. a -> CodeGenFunction r (Value Bool)) ->
+ signal a -> signal a
+takeWhile p =
+ alter
+ (\(Core next start stop) ->
+ Core
+ (\context sa0 -> do
+ (a,sa1) <- next context sa0
+ MaybeCont.guard =<< MaybeCont.lift (p a)
+ return (a,sa1))
+ start
+ stop)
+
envelope ::
(C signal, A.PseudoRing a) =>
@@ -260,7 +310,7 @@ render (Cons next alloca start createIOContext deleteIOContext) len =
compile
(next $ valueTupleOf params) alloca (start $ valueTupleOf params)
fmap (fromIntegral :: Word32 -> Int) $
- fill (fromIntegral len) (Memory.castStorablePtr ptr)
+ fill (fromIntegral len) (Memory.castTuplePtr ptr)
foreign import ccall safe "dynamic" derefStartPtr ::
@@ -336,7 +386,7 @@ runChunky (Cons next alloca start createIOContext deleteIOContext)
SVB.createAndTrim size $
fmap (fromIntegral :: Word32 -> Int) .
fill sptr (fromIntegral size) .
- Memory.castStorablePtr
+ Memory.castTuplePtr
touchForeignPtr ioContextPtr
(if SV.length v > 0
then fmap (v:)
diff --git a/src/Synthesizer/LLVM/Simple/SignalPrivate.hs b/src/Synthesizer/LLVM/Simple/SignalPrivate.hs
index 82d0abc..d3b9b7b 100644
--- a/src/Synthesizer/LLVM/Simple/SignalPrivate.hs
+++ b/src/Synthesizer/LLVM/Simple/SignalPrivate.hs
@@ -3,16 +3,17 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
module Synthesizer.LLVM.Simple.SignalPrivate where
import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.MaybeContinuation as MaybeCont
+import qualified LLVM.Extra.Either as Either
+import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Control (ifThen, )
-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )
+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, )
import qualified LLVM.Core as LLVM
import LLVM.Util.Loop (Phi, )
@@ -26,6 +27,8 @@ import Foreign.Storable (Storable, )
import Foreign.StablePtr (StablePtr, )
import Foreign.Ptr (Ptr, nullPtr, )
+import Data.Monoid (Monoid, mempty, mappend, )
+import Data.Semigroup (Semigroup, (<>), )
import Data.Word (Word32, )
import qualified Number.Ratio as Ratio
@@ -239,6 +242,63 @@ instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where
+empty :: (C signal) => signal a
+empty = simple (const $ MaybeCont.nothing) (return ())
+
+{- |
+Appending many signals is inefficient,
+since in cascadingly appended signals the parts are counted in an unary way.
+Concatenating infinitely many signals is impossible.
+If you want to concatenate a lot of signals,
+please render them to lazy storable vectors first.
+-}
+{-
+We might save a little space by using a union
+for the states of the first and the second signal generator.
+If the concatenated generators allocate memory,
+we could also save some memory by calling @startB@
+only after the first generator finished.
+However, for correct deallocation
+we would need to track which of the @start@ blocks
+have been executed so far.
+This in turn might be difficult in connection with the garbage collector.
+-}
+append :: (Phi a, Undefined a) => T a -> T a -> T a
+append
+ (Cons nextA allocaA startA createIOContextA deleteIOContextA)
+ (Cons nextB allocaB startB createIOContextB deleteIOContextB) =
+ Cons
+ (\(parameterA, parameterB) (localA, localB) es0 ->
+ MaybeCont.fromMaybe $ do
+ es1 <-
+ Either.run es0
+ (\sa0 ->
+ MaybeCont.resolve
+ (nextA parameterA localA sa0)
+ (fmap Either.right $ startB parameterB)
+ (\(a1,sa1) -> return (Either.left (a1, sa1))))
+ (return . Either.right)
+
+ Either.run es1
+ (\(a1,s1) -> return (Maybe.just (a1, Either.left s1)))
+ (\sb0 ->
+ MaybeCont.toMaybe $
+ fmap (\(b,sb1) -> (b, Either.right sb1)) $
+ nextB parameterB localB sb0))
+ (liftM2 (,) allocaA allocaB)
+ (\(parameterA, _parameterB) -> Either.left <$> startA parameterA)
+ (combineCreate createIOContextA createIOContextB)
+ (combineDelete deleteIOContextA deleteIOContextB)
+
+instance (Phi a, Undefined a) => Semigroup (T a) where
+ (<>) = append
+
+instance (Phi a, Undefined a) => Monoid (T a) where
+ mempty = empty
+ mappend = append
+
+
+
storableVectorNextChunk ::
(Phi c, MakeValueTuple a, ValueTuple a ~ value,
Memory.C value, Memory.Struct value ~ struct) =>
diff --git a/src/Synthesizer/LLVM/Storable/ChunkIterator.hs b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs
index 35bd6d9..a1f9da2 100644
--- a/src/Synthesizer/LLVM/Storable/ChunkIterator.hs
+++ b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs
@@ -74,4 +74,4 @@ next stable lenPtr =
SVB.withStartPtr x
(\p l ->
poke lenPtr (fromIntegral l) >>
- return (Memory.castStorablePtr p))
+ return (Memory.castTuplePtr p))
diff --git a/src/Synthesizer/LLVM/Storable/Signal.hs b/src/Synthesizer/LLVM/Storable/Signal.hs
index 2f26ec4..456c322 100644
--- a/src/Synthesizer/LLVM/Storable/Signal.hs
+++ b/src/Synthesizer/LLVM/Storable/Signal.hs
@@ -148,7 +148,7 @@ makeReverser ::
-- IO (Word32 -> Ptr struct -> Ptr struct -> IO ())
makeReverser rev =
fmap (\f len srcPtr dstPtr ->
- f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $
+ f len (Memory.castTuplePtr srcPtr) (Memory.castTuplePtr dstPtr)) $
Exec.compileModule $
Exec.createFunction derefMixPtr "reverse" $ \ size ptrA ptrB -> do
ptrAEnd <- getElementPtr ptrA (size, ())
@@ -276,7 +276,7 @@ fillBuffer ::
(MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
value -> IO (Word32 -> Ptr a -> IO ())
fillBuffer x =
- fmap (\f len ptr -> f len (Memory.castStorablePtr ptr)) $
+ fmap (\f len ptr -> f len (Memory.castTuplePtr ptr)) $
Exec.compileModule $
Exec.createFunction derefFillPtr "constantfill" $ \ size ptr -> do
arrayLoop size ptr () $ \ ptri () -> do
@@ -294,7 +294,7 @@ makeMixer ::
IO (Word32 -> Ptr a -> Ptr a -> IO ())
makeMixer add =
fmap (\f len srcPtr dstPtr ->
- f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $
+ f len (Memory.castTuplePtr srcPtr) (Memory.castTuplePtr dstPtr)) $
Exec.compileModule $
Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr -> do
_ <- arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do
diff --git a/src/Synthesizer/LLVM/Storable/Vector.hs b/src/Synthesizer/LLVM/Storable/Vector.hs
index ec09a7c..545099d 100644
--- a/src/Synthesizer/LLVM/Storable/Vector.hs
+++ b/src/Synthesizer/LLVM/Storable/Vector.hs
@@ -21,5 +21,5 @@ unsafeToPointers ::
unsafeToPointers v =
let (fp,s,l) = SVB.toForeignPtr v
in (fp,
- Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s,
+ Memory.castTuplePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s,
l)
diff --git a/src/Synthesizer/LLVM/Wave.hs b/src/Synthesizer/LLVM/Wave.hs
index bae222c..e2c5436 100644
--- a/src/Synthesizer/LLVM/Wave.hs
+++ b/src/Synthesizer/LLVM/Wave.hs
@@ -5,10 +5,10 @@ module Synthesizer.LLVM.Wave where
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified LLVM.Extra.Arithmetic as A
-import qualified LLVM.Extra.Monad as M
import LLVM.Core (CodeGenFunction, )
+import qualified Control.Monad.HT as M
import Control.Monad.HT ((<=<), )
import NumericPrelude.Numeric
@@ -120,7 +120,7 @@ rationalApproxCosine1 k t = do
A.square =<<
A.mul t =<<
A.sub (A.fromInteger' 1) t
- M.liftR2 A.fdiv
+ M.liftJoin2 A.fdiv
(A.sub num2 den2)
(A.add num2 den2)
@@ -132,9 +132,9 @@ rationalApproxSine1 k t = do
den <-
A.mul t =<<
A.sub (A.fromInteger' 1) t
- M.liftR2 A.fdiv
+ M.liftJoin2 A.fdiv
(A.mul (A.fromInteger' (-2)) =<< A.mul num den)
- (M.liftR2 A.add (A.square num) (A.square den))
+ (M.liftJoin2 A.add (A.square num) (A.square den))
trapezoidSkew ::
diff --git a/synthesizer-llvm.cabal b/synthesizer-llvm.cabal
index 926f82f..d2ee7e5 100644
--- a/synthesizer-llvm.cabal
+++ b/synthesizer-llvm.cabal
@@ -1,5 +1,5 @@
Name: synthesizer-llvm
-Version: 0.8.1.2
+Version: 0.8.2
License: GPL
License-File: LICENSE
Author: Henning Thielemann <haskell@henning-thielemann.de>
@@ -39,7 +39,7 @@ Description:
should be especially useful for an introduction.
Stability: Experimental
Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1
-Cabal-Version: >=1.14
+Cabal-Version: 1.14
Build-Type: Simple
Extra-Source-Files:
Changes.md
@@ -57,7 +57,7 @@ Flag jack
default: False
Source-Repository this
- Tag: 0.8.1.2
+ Tag: 0.8.2
Type: darcs
Location: http://code.haskell.org/synthesizer/llvm/
@@ -68,9 +68,7 @@ Source-Repository head
Library
Build-Depends:
- llvm-extra >=0.7 && <0.8,
- -- llvm must be imported with restrictive version bounds,
- -- because we import implicitly and unqualified
+ llvm-extra >=0.8 && <0.9,
llvm-tf >=3.1 && <3.2,
tfp >=1.0 && <1.1,
vault >=0.3 && <0.4,
@@ -88,9 +86,10 @@ Library
event-list >=0.1 && <0.2,
pathtype >=0.8 && <0.9,
random >=1.0 && <1.2,
- containers >=0.1 && <0.6,
+ containers >=0.1 && <0.7,
transformers >=0.2 && <0.6,
- utility-ht >=0.0.12 && <0.1
+ semigroups >=0.1 && <1.0,
+ utility-ht >=0.0.14 && <0.1
Build-Depends:
-- base-4 needed for Control.Category
@@ -166,6 +165,7 @@ Library
Synthesizer.LLVM.Server.SampledSound
Synthesizer.LLVM.Server.Common
Synthesizer.LLVM.Server.CommonPacked
+ Synthesizer.LLVM.Server.Parameter
Other-Modules:
Synthesizer.LLVM.ConstantPiece
@@ -210,7 +210,7 @@ Executable synthi-llvm-example
non-negative >=0.1 && <0.2,
event-list >=0.1 && <0.2,
random,
- containers >=0.1 && <0.6,
+ containers >=0.1 && <0.7,
transformers,
non-empty,
utility-ht,
@@ -220,7 +220,8 @@ Executable synthi-llvm-example
Buildable: False
Default-Language: Haskell98
GHC-Options: -Wall
- GHC-Prof-Options: -auto-all
+ GHC-Options: -pgmlg++
+ GHC-Prof-Options: -fprof-auto-exported
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -254,7 +255,7 @@ Executable synthi-llvm-lndw
non-negative >=0.1 && <0.2,
event-list >=0.1 && <0.2,
random,
- containers >=0.1 && <0.6,
+ containers >=0.1 && <0.7,
transformers,
non-empty,
utility-ht,
@@ -267,7 +268,8 @@ Executable synthi-llvm-lndw
Buildable: False
Default-Language: Haskell98
GHC-Options: -Wall
- GHC-Prof-Options: -auto-all
+ GHC-Options: -pgmlg++
+ GHC-Prof-Options: -fprof-auto-exported
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -298,9 +300,10 @@ Executable synthi-llvm-alsa
numeric-prelude >=0.3 && <0.5,
non-negative >=0.1 && <0.2,
event-list >=0.1 && <0.2,
+ shell-utility >=0.0 && <0.1,
pathtype >=0.8 && <0.9,
- optparse-applicative >=0.11 && <0.13,
- containers >=0.1 && <0.6,
+ optparse-applicative >=0.11 && <0.15,
+ containers >=0.1 && <0.7,
transformers,
utility-ht,
@@ -314,8 +317,9 @@ Executable synthi-llvm-alsa
Default-Language: Haskell98
-- -threaded -debug
GHC-Options: -Wall
+ GHC-Options: -pgmlg++
GHC-Options: -rtsopts
- GHC-Prof-Options: -auto-all
+ GHC-Prof-Options: -fprof-auto-exported
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -360,9 +364,10 @@ Executable synthi-llvm-jack
random,
explicit-exception >=0.1.7 && <0.2,
event-list >=0.1 && <0.2,
+ shell-utility >=0.0 && <0.1,
pathtype >=0.8 && <0.9,
- optparse-applicative >=0.11 && <0.13,
- containers >=0.1 && <0.6,
+ optparse-applicative >=0.11 && <0.15,
+ containers >=0.1 && <0.7,
transformers,
utility-ht,
@@ -373,8 +378,9 @@ Executable synthi-llvm-jack
Default-Language: Haskell98
-- -threaded -debug
GHC-Options: -Wall
+ GHC-Options: -pgmlg++
GHC-Options: -rtsopts
- GHC-Prof-Options: -auto-all
+ GHC-Prof-Options: -fprof-auto-exported
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -406,9 +412,10 @@ Executable synthi-llvm-render
non-negative >=0.1 && <0.2,
explicit-exception >=0.1.7 && <0.2,
event-list >=0.1 && <0.2,
+ shell-utility >=0.0 && <0.1,
pathtype >=0.8 && <0.9,
- optparse-applicative >=0.11 && <0.13,
- containers >=0.1 && <0.6,
+ optparse-applicative >=0.11 && <0.15,
+ containers >=0.1 && <0.7,
transformers,
utility-ht,
@@ -419,8 +426,9 @@ Executable synthi-llvm-render
Default-Language: Haskell98
-- -threaded -debug
GHC-Options: -Wall
+ GHC-Options: -pgmlg++
GHC-Options: -rtsopts
- GHC-Prof-Options: -auto-all
+ GHC-Prof-Options: -fprof-auto-exported
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -448,7 +456,8 @@ Executable synthi-llvm-sample
Else
Buildable: False
Default-Language: Haskell98
- GHC-Options: -Wall
+ GHC-Options: -Wall
+ GHC-Options: -pgmlg++
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -475,7 +484,8 @@ Executable synthi-llvm-speech
Else
Buildable: False
Default-Language: Haskell98
- GHC-Options: -Wall
+ GHC-Options: -Wall
+ GHC-Options: -pgmlg++
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -503,7 +513,8 @@ Test-Suite synthi-llvm-test
QuickCheck >=1 && <3,
base >=4 && <5
Default-Language: Haskell98
- GHC-Options: -Wall
+ GHC-Options: -Wall
+ GHC-Options: -pgmlg++
If impl(ghc>=7.0)
GHC-Options: -fwarn-unused-do-bind
CPP-Options: -DNoImplicitPrelude=RebindableSyntax
@@ -520,3 +531,4 @@ Test-Suite synthi-llvm-test
Test.Synthesizer.LLVM.Filter
Test.Synthesizer.LLVM.Packed
Test.Synthesizer.LLVM.Utility
+ Test.Synthesizer.LLVM.Generator
diff --git a/testsuite/Test/Synthesizer/LLVM/Filter.hs b/testsuite/Test/Synthesizer/LLVM/Filter.hs
index c41910f..e871219 100644
--- a/testsuite/Test/Synthesizer/LLVM/Filter.hs
+++ b/testsuite/Test/Synthesizer/LLVM/Filter.hs
@@ -43,16 +43,19 @@ import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Basic.Phase as Phase
import qualified Data.StorableVector.Lazy as SVL
-import qualified Data.StorableVector as SV
-import Data.StorableVector.Lazy (ChunkSize, )
+import qualified Test.Synthesizer.LLVM.Generator as Gen
+import Test.Synthesizer.LLVM.Generator
+ (checkWithParam, arg, pair, withGenArgs, )
import Test.Synthesizer.LLVM.Utility
- (checkSimilarity, checkSimilarityState, rangeFromInt,
- CheckSimilarity, CheckSimilarityState, )
+ (checkSimilarity, checkSimilarityState,
+ CheckSimilarity, CheckSimilarityState,
+ randomStorableVector, checkSimilarityPacked, )
import qualified Control.Category as Cat
import Control.Category ((<<<), )
-import Control.Arrow (arr, (&&&), (***), (^<<), (<<^), )
+import Control.Arrow ((&&&), (^<<), (<<^), )
+import Control.Applicative (liftA2, (<$>), )
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Memory as Memory
@@ -70,7 +73,7 @@ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified System.Random as Rnd
import Data.Word (Word32, )
-import Test.QuickCheck (quickCheck, )
+import qualified Test.QuickCheck as QC
import NumericPrelude.Numeric
import NumericPrelude.Base
@@ -128,12 +131,26 @@ allpassPhaserPipeline reduct xs =
$< allpassControl order reduct
$* xs)
-allpassPipeline :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)
+
+genOsci :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)
+genOsci = pair (Gen.choose (0.001, 0.01)) (Gen.choose (0, 0.99))
+
+genOsciReduct ::
+ Gen.T
+ (Param.T p) ((Float, Float), Float)
+ ((Param.T p Float, Param.T p Float), Param.T p Float)
+genOsciReduct = pair genOsci (Gen.choose (10, 100))
+
+genOsciReductPacked ::
+ Gen.T
+ (Param.T p) ((Float, Float), Float)
+ ((Param.T p Float, Param.T p Float), Param.T p Float)
+genOsciReductPacked = pair genOsci (arg $ (4*) <$> QC.choose (1, 25))
+
+allpassPipeline :: Gen.Test ((Float,Float), Float) SimFloat
allpassPipeline =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
in checkSimilarity 1e-2 limitFloat
(allpassPhaserCausal reduct tone)
(allpassPhaserPipeline reduct tone)
@@ -165,16 +182,14 @@ allpassPhaserPacked reduct =
applyPacked Allpass.phaserPacked
(allpassControl TypeNum.d16 reduct)
-allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)
+allpassPacked :: Gen.Test ((Float,Float), Float) SimFloat
allpassPacked =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneP = SigPS.osciSimple Wave.triangle phase freq
- in checkSimilarity 1e-2 limitFloat
+ in checkSimilarityPacked 1e-2 limitFloat
(allpassPhaserCausal reduct tone)
- (SigPS.unpack $ allpassPhaserPacked reduct toneP)
+ (allpassPhaserPacked reduct toneP)
interpolateConstant :: Float -> SigS.T a -> SigS.T a
@@ -209,12 +224,10 @@ allpassPhaserCore reduct =
&&&
Cat.id)
-allpassCore :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)
+allpassCore :: Gen.Test ((Float,Float), Float) SimStateFloat
allpassCore =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneS p =
OsciS.static WaveCore.triangle
(Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
@@ -238,10 +251,10 @@ firstOrderConstant cutOff xs =
$< SigP.constant (FirstOrderCore.parameter ^<< cutOff)
$* xs
-firstOrderExponential :: IO (ChunkSize -> (Int,Int) -> SimFloat)
+firstOrderExponential :: Gen.Test Float SimFloat
firstOrderExponential =
- let cutOff = rangeFromInt (0.001, 0.01) <<^ fst
- gain = exp(-2*pi*cutOff)
+ withGenArgs (Gen.choose (0.001, 0.01)) $ \cutOff ->
+ let gain = exp(-2*pi*cutOff)
in checkSimilarity 1e-2 limitFloat
(SigP.amplify (recip (1 - gain)) $
firstOrderConstant cutOff diracImpulse)
@@ -266,12 +279,10 @@ firstOrderCore reduct =
CausalS.applyFst FirstOrderCore.lowpassCausal $
lfoSineCore FirstOrderCore.parameter reduct
-firstOrder :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)
+firstOrder :: Gen.Test ((Float,Float), Float) SimStateFloat
firstOrder =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneS p =
OsciS.static WaveCore.triangle
(Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
@@ -288,16 +299,14 @@ firstOrderCausalPacked reduct =
FirstOrder.lowpassCausalPacked
(lfoSine FirstOrder.parameter reduct)
-firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)
+firstOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat
firstOrderPacked =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneP = SigPS.osciSimple Wave.triangle phase freq
- in checkSimilarity 1e-2 limitFloat
+ in checkSimilarityPacked 1e-2 limitFloat
(firstOrderCausal reduct tone)
- (SigPS.unpack $ firstOrderCausalPacked reduct toneP)
+ (firstOrderCausalPacked reduct toneP)
secondOrderCausal ::
@@ -317,16 +326,14 @@ secondOrderCausalPacked reduct =
applyPacked SecondOrder.causalPacked
(lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct)
-secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)
+secondOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat
secondOrderPacked =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneP = SigPS.osciSimple Wave.triangle phase freq
- in checkSimilarity 1e-2 limitFloat
+ in checkSimilarityPacked 1e-2 limitFloat
(secondOrderCausal reduct tone)
- (SigPS.unpack $ secondOrderCausalPacked reduct toneP)
+ (secondOrderCausalPacked reduct toneP)
secondOrderCausalPacked2 ::
Param.T p Float ->
@@ -337,12 +344,10 @@ secondOrderCausalPacked2 reduct xs =
$< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct
$* xs
-secondOrderPacked2 :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)
+secondOrderPacked2 :: Gen.Test ((Float,Float), Float) SimFloat
secondOrderPacked2 =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
in checkSimilarity 1e-2 limitFloat
(secondOrderCausal reduct tone)
(secondOrderCausalPacked2 reduct tone)
@@ -374,12 +379,10 @@ universalCore reduct =
CausalS.applyFst UniFilterCore.causal $
lfoSineCore (UniFilterCore.parameter . Pole 10) reduct
-universal :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)
+universal :: Gen.Test ((Float,Float), Float) SimStateFloat
universal =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneS p =
OsciS.static WaveCore.triangle
(Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
@@ -418,12 +421,10 @@ moogCore order reduct =
CausalS.applyFst (MoogCore.lowpassCausal order) $
lfoSineCore (MoogCore.parameter order . Pole 10) reduct
-moog :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)
+moog :: Gen.Test ((Float,Float), Float) SimStateFloat
moog =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- order = TypeNum.d6
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let order = TypeNum.d6
tone = SigP.osciSimple Wave.triangle phase freq
toneS p =
OsciS.static WaveCore.triangle
@@ -453,12 +454,10 @@ complexCausalPacked reduct =
$< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct)
<<^ (\x -> Stereo.cons x A.zero)
-complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)
+complexPacked :: Gen.Test ((Float,Float), Float) SimFloat
complexPacked =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
in checkSimilarity 1e-2 limitFloat
(fmap Stereo.left $
complexCausal reduct tone)
@@ -476,12 +475,10 @@ complexCore reduct =
CausalS.applyFst ComplexFilterCore.causal
(lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct)
-complex :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)
+complex :: Gen.Test ((Float,Float), Float) SimStateFloat
complex =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst
- phase = rangeFromInt (0, 0.99) <<^ snd . fst
- reduct = rangeFromInt (10, 100) <<^ snd
- tone = SigP.osciSimple Wave.triangle phase freq
+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
+ let tone = SigP.osciSimple Wave.triangle phase freq
toneS p =
OsciS.static WaveCore.triangle
(Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
@@ -498,34 +495,35 @@ complex =
-}
-convolvePacked :: IO (ChunkSize -> ((Int,Int), Word32) -> SimFloat)
+convolvePacked :: Gen.Test ((Int,Rnd.StdGen), Word32) SimFloat
convolvePacked =
- let mask =
- (\(len, seed) ->
- fst $ SV.packN len $ Rnd.randomRs (-1,1::Float) seed)
- ^<< rangeFromInt (1,20) *** arr Rnd.mkStdGen <<^ fst
- noise = SigP.noise (arr snd) 1
- noiseP = SigPS.noise (arr snd) 1
- unpack :: SigP.T p VectorValue -> SigP.T p (Value Float)
- unpack = SigPS.unpack
- in checkSimilarity 1e-3 limitFloat
+ withGenArgs
+ (pair
+ (arg $ liftA2 (,) (QC.choose (1,20)) (Rnd.mkStdGen <$> QC.arbitrary))
+ Gen.arbitrary)
+ $
+ \(rnd, seed) ->
+ let mask = randomStorableVector (-1,1::Float) <$> rnd
+ noise = SigP.noise seed 1
+ noiseP = SigPS.noise seed 1
+ in checkSimilarityPacked 1e-3 limitFloat
(FiltNR.convolve mask $* noise)
- (unpack $ (FiltNR.convolvePacked mask $* noiseP))
+ (FiltNR.convolvePacked mask $* noiseP)
tests :: [(String, IO ())]
tests =
- ("secondOrderPacked", quickCheck =<< secondOrderPacked) :
- ("secondOrderPacked2", quickCheck =<< secondOrderPacked2) :
- ("firstOrderExponential", quickCheck =<< firstOrderExponential) :
- ("firstOrder", quickCheck =<< firstOrder) :
- ("firstOrderPacked", quickCheck =<< firstOrderPacked) :
- ("universal", quickCheck =<< universal) :
- ("allpassPacked", quickCheck =<< allpassPacked) :
- ("allpassPipeline", quickCheck =<< allpassPipeline) :
- ("allpassCore", quickCheck =<< allpassCore) :
- ("moog", quickCheck =<< moog) :
- ("complexPacked", quickCheck =<< complexPacked) :
- ("complex", quickCheck =<< complex) :
- ("convolvePacked", quickCheck =<< convolvePacked) :
+ ("secondOrderPacked", checkWithParam secondOrderPacked) :
+ ("secondOrderPacked2", checkWithParam secondOrderPacked2) :
+ ("firstOrderExponential", checkWithParam firstOrderExponential) :
+ ("firstOrder", checkWithParam firstOrder) :
+ ("firstOrderPacked", checkWithParam firstOrderPacked) :
+ ("universal", checkWithParam universal) :
+ ("allpassPacked", checkWithParam allpassPacked) :
+ ("allpassPipeline", checkWithParam allpassPipeline) :
+ ("allpassCore", checkWithParam allpassCore) :
+ ("moog", checkWithParam moog) :
+ ("complexPacked", checkWithParam complexPacked) :
+ ("complex", checkWithParam complex) :
+ ("convolvePacked", checkWithParam convolvePacked) :
[]
diff --git a/testsuite/Test/Synthesizer/LLVM/Generator.hs b/testsuite/Test/Synthesizer/LLVM/Generator.hs
new file mode 100644
index 0000000..6352b8d
--- /dev/null
+++ b/testsuite/Test/Synthesizer/LLVM/Generator.hs
@@ -0,0 +1,64 @@
+module Test.Synthesizer.LLVM.Generator where
+
+import qualified Synthesizer.LLVM.Parameter as Param
+import qualified Synthesizer.LLVM.CausalParameterized.Functional as F
+
+import Data.StorableVector.Lazy (ChunkSize, )
+
+import System.Random (Random, )
+
+import Control.Category (id, )
+import Control.Applicative (liftA2, liftA3, )
+
+import qualified Test.QuickCheck as QC
+
+import Prelude hiding (id, )
+
+
+data T f p a = Cons (QC.Gen p) (F.PrepareArguments f p a)
+
+arg :: QC.Gen a -> T f a (f a)
+arg gen = Cons gen F.atomArg
+
+arbitrary :: (QC.Arbitrary a) => T f a (f a)
+arbitrary = arg QC.arbitrary
+
+choose :: (Random a) => (a,a) -> T f a (f a)
+choose rng = arg $ QC.choose rng
+
+
+pair ::
+ (Functor f) =>
+ T f a0 b0 ->
+ T f a1 b1 ->
+ T f (a0,a1) (b0,b1)
+pair (Cons g0 p0) (Cons g1 p1) =
+ Cons (liftA2 (,) g0 g1) (F.pairArgs p0 p1)
+
+triple ::
+ (Functor f) =>
+ T f a0 b0 ->
+ T f a1 b1 ->
+ T f a2 b2 ->
+ T f (a0,a1,a2) (b0,b1,b2)
+triple (Cons g0 p0) (Cons g1 p1) (Cons g2 p2) =
+ Cons (liftA3 (,,) g0 g1 g2) (F.tripleArgs p0 p1 p2)
+
+withGenArgs ::
+ T (Param.T p) p a ->
+ (a -> IO (ChunkSize -> p -> test)) -> Test p test
+withGenArgs (Cons gen prepArgs) f =
+ (gen, withPreparedArgs prepArgs f)
+
+
+withPreparedArgs ::
+ F.PrepareArguments (Param.T p) p a -> (a -> test) -> test
+withPreparedArgs (F.PrepareArguments prepare) f = f $ prepare id
+
+
+type Test p test = (QC.Gen p, IO (ChunkSize -> p -> test))
+
+checkWithParam :: (Show p, QC.Testable test) => Test p test -> IO ()
+checkWithParam (gen, test) = do
+ f <- test
+ QC.quickCheck (QC.forAll gen $ flip f)
diff --git a/testsuite/Test/Synthesizer/LLVM/Helix.hs b/testsuite/Test/Synthesizer/LLVM/Helix.hs
index 48219e3..e7e74c1 100644
--- a/testsuite/Test/Synthesizer/LLVM/Helix.hs
+++ b/testsuite/Test/Synthesizer/LLVM/Helix.hs
@@ -18,12 +18,13 @@ import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import Data.StorableVector.Lazy (ChunkSize, )
+import Test.Synthesizer.LLVM.Generator (withPreparedArgs, checkWithParam, )
import Test.Synthesizer.LLVM.Utility
- (CheckSimilarity, checkSimilarity, rangeFromInt, )
+ (CheckSimilarity, checkSimilarity,
+ genRandomVectorParam, randomSignal, )
-import Control.Category ((<<<), )
-import Control.Arrow (arr, (***), (^<<), (<<^), )
-import Control.Applicative (pure, )
+import Control.Arrow (arr, )
+import Control.Applicative (pure, liftA2, )
import LLVM.Core (Value, )
@@ -33,7 +34,7 @@ import qualified System.Random as Rnd
import Data.Word (Word32, )
-- import qualified Graphics.Gnuplot.Simple as Gnuplot
-import Test.QuickCheck (quickCheck, )
+import qualified Test.QuickCheck as QC
import NumericPrelude.Numeric
import NumericPrelude.Base
@@ -49,32 +50,29 @@ limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a
limitFloat = SVL.take signalLength
-randomSpeed :: Param.T p (Int, Int) -> SigP.T p (Value Float)
-randomSpeed p =
- SigP.fromStorableVectorLazy
- ((\(len, seed) ->
- SVL.cycle $
- SVL.fromChunks
- [fst $ SV.packN len $ Rnd.randomRs (0,10::Float) seed])
- ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)
-
-randomPhase :: Param.T p (Int, Int) -> SigP.T p (Value Float)
-randomPhase p =
- SigP.fromStorableVectorLazy
- ((\(len, seed) ->
- SVL.cycle $
- SVL.fromChunks
- [fst $ SV.packN len $ Rnd.randomRs (0,1::Float) seed])
- ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)
+randomSpeed :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Float)
+randomSpeed = randomSignal (0,10::Float)
+
+randomPhase :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Float)
+randomPhase = randomSignal (0,1::Float)
+
+genStaticDynamic ::
+ QC.Gen (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32))
+genStaticDynamic =
+ liftA2 (,)
+ (liftA2 (,) genRandomVectorParam genRandomVectorParam)
+ (liftA2 (,) (QC.choose (1,32)) QC.arbitrary)
staticDynamic ::
- IO (ChunkSize -> (((Int, Int), (Int, Int)), (Int, Word32)) -> SimFloat)
+ IO (ChunkSize ->
+ (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32)) -> SimFloat)
staticDynamic =
+ withPreparedArgs
+ (Func.pairArgs
+ (Func.pairArgs Func.atomArg Func.atomArg)
+ (Func.pairArgs Func.atomArg Func.atomArg)) $
+ \((speedParam, phaseParam), (period, noiseParam)) ->
let len = 1000
- speedParam = arr $ fst.fst
- phaseParam = arr $ snd.fst
- noiseParam = arr $ snd.snd
- period = rangeFromInt (1,32::Float) <<^ fst.snd
noise :: Param.T p Word32 -> SigP.T p (Value Float)
noise seed = CausalP.take (pure len) $* SigP.noise seed 1
@@ -104,7 +102,8 @@ staticDynamic =
plot :: IO ()
plot = do
render <- staticDynamic
- case render (SVL.chunkSize 1) (((111,0),(0,23)),(107,11)) of
+ case render (SVL.chunkSize 1)
+ (((76, Rnd.mkStdGen 0),(84, Rnd.mkStdGen 23)),(8.901705,11)) of
CheckSimilarity _tol xs ys ->
Gnuplot.plotLists [] [SVL.unpack xs, SVL.unpack ys]
>>
@@ -114,5 +113,5 @@ plot = do
tests :: [(String, IO ())]
tests =
- ("staticDynamic", quickCheck =<< staticDynamic) :
+ ("staticDynamic", checkWithParam (genStaticDynamic, staticDynamic)) :
[]
diff --git a/testsuite/Test/Synthesizer/LLVM/Packed.hs b/testsuite/Test/Synthesizer/LLVM/Packed.hs
index aeedf90..5f46c43 100644
--- a/testsuite/Test/Synthesizer/LLVM/Packed.hs
+++ b/testsuite/Test/Synthesizer/LLVM/Packed.hs
@@ -1,9 +1,12 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Test.Synthesizer.LLVM.Packed (tests) where
+import qualified Test.Synthesizer.LLVM.Generator as Gen
+import Test.Synthesizer.LLVM.Generator
+ (Test, checkWithParam, arg, pair, withGenArgs, )
import Test.Synthesizer.LLVM.Utility
- (checkSimilarity, checkEquality, rangeFromInt,
- CheckSimilarity, CheckEquality, )
+ (checkSimilarity, checkEquality,
+ CheckSimilarity, CheckEquality, checkSimilarityPacked, )
import qualified Synthesizer.LLVM.Wave as Wave
import qualified Synthesizer.LLVM.Parameter as Param
@@ -22,10 +25,12 @@ import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Data.StorableVector.Lazy as SVL
import Data.StorableVector.Lazy (ChunkSize, )
-import Control.Arrow (arr, (^<<), (<<^), (<<<), )
+import Control.Arrow (arr, (<<<), )
+import Control.Applicative ((<$>), )
import Data.Word (Word32, )
+import qualified Test.QuickCheck as QC
import Test.QuickCheck (quickCheck, )
import NumericPrelude.Numeric
@@ -43,9 +48,11 @@ limitFloat :: SVL.Vector Float -> SVL.Vector Float
limitFloat = SVL.take signalLength
-durFromInt :: Param.T Int Float
-durFromInt =
- fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)
+withDur ::
+ (Param.T Float Float -> IO (ChunkSize -> Float -> test)) ->
+ Test Float test
+withDur =
+ withGenArgs (arg (fromIntegral <$> QC.choose (signalLength, 2*signalLength)))
{-
limitPackedFloat ::
@@ -53,109 +60,106 @@ limitPackedFloat ::
limitPackedFloat = SVL.take (div signalLength 4)
-}
-constant :: IO (ChunkSize -> Int -> SimFloat)
+constant :: Test Float SimFloat
constant =
- let y = rangeFromInt (-1, 1)
- in checkSimilarity 1e-3 limitFloat
- (SigP.constant y)
- (SigPS.unpack (SigPS.constant y :: SigP.T Int VectorValue))
+ withGenArgs (Gen.choose (-1, 1)) $ \y ->
+ checkSimilarityPacked 1e-3 limitFloat
+ (SigP.constant y) (SigPS.constant y)
-ramp :: IO (ChunkSize -> Int -> SimFloat)
+ramp :: Test Float SimFloat
ramp =
- let dur = durFromInt
- in checkSimilarity 1e-3 limitFloat
- (SigP.rampInf dur)
- (SigPS.unpack (SigPS.rampInf dur :: SigP.T Int VectorValue))
+ withDur $ \dur ->
+ checkSimilarityPacked 1e-3 limitFloat
+ (SigP.rampInf dur) (SigPS.rampInf dur)
-parabolaFadeIn :: IO (ChunkSize -> Int -> SimFloat)
+parabolaFadeIn :: Test Float SimFloat
parabolaFadeIn =
- let dur = durFromInt
- in checkSimilarity 1e-3 limitFloat
- (SigP.parabolaFadeInInf dur)
- (SigPS.unpack (SigPS.parabolaFadeInInf dur ::
- SigP.T Int VectorValue))
+ withDur $ \dur ->
+ checkSimilarityPacked 1e-3 limitFloat
+ (SigP.parabolaFadeInInf dur)
+ (SigPS.parabolaFadeInInf dur)
-parabolaFadeOut :: IO (ChunkSize -> Int -> SimFloat)
+parabolaFadeOut :: Test Float SimFloat
parabolaFadeOut =
- let dur = durFromInt
- in checkSimilarity 1e-3 limitFloat
- (SigP.parabolaFadeOutInf dur)
- (SigPS.unpack (SigPS.parabolaFadeOutInf dur ::
- SigP.T Int VectorValue))
+ withDur $ \dur ->
+ checkSimilarityPacked 1e-3 limitFloat
+ (SigP.parabolaFadeOutInf dur)
+ (SigPS.parabolaFadeOutInf dur)
-parabolaFadeInMap :: IO (ChunkSize -> Int -> SimFloat)
+parabolaFadeInMap :: Test Float SimFloat
parabolaFadeInMap =
- let dur = durFromInt
- in checkSimilarity 1e-3 limitFloat
+ withDur $ \dur ->
+ checkSimilarity 1e-3 limitFloat
(SigP.parabolaFadeIn dur)
(SigP.parabolaFadeInMap dur)
-parabolaFadeOutMap :: IO (ChunkSize -> Int -> SimFloat)
+parabolaFadeOutMap :: Test Float SimFloat
parabolaFadeOutMap =
- let dur = durFromInt
- in checkSimilarity 1e-3 limitFloat
+ withDur $ \dur ->
+ checkSimilarity 1e-3 limitFloat
(SigP.parabolaFadeOut dur)
(SigP.parabolaFadeOutMap dur)
-exponential2 :: IO (ChunkSize -> (Int,Int) -> SimFloat)
+
+genExp :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)
+genExp = pair (Gen.choose (1000,10000)) (Gen.choose (-1,1))
+
+exponential2 :: Test (Float,Float) SimFloat
exponential2 =
- let halfLife = rangeFromInt (1000,10000) <<^ fst
- start = rangeFromInt ( -1, 1) <<^ snd
- in checkSimilarity 1e-3 limitFloat
- (SigP.exponential2 halfLife start)
- (SigPS.unpack (SigPS.exponential2 halfLife start ::
- SigP.T (Int,Int) VectorValue))
+ withGenArgs genExp $ \(halfLife,start) ->
+ checkSimilarityPacked 1e-3 limitFloat
+ (SigP.exponential2 halfLife start)
+ (SigPS.exponential2 halfLife start)
-exponential2Static :: IO (ChunkSize -> (Int,Int) -> SimFloat)
+exponential2Static :: Test (Float,Float) SimFloat
exponential2Static =
- let halfLife = rangeFromInt (1000,10000) <<^ fst
- start = rangeFromInt ( -1, 1) <<^ snd
- in checkSimilarity 1e-3 limitFloat
+ withGenArgs genExp $ \(halfLife,start) ->
+ checkSimilarity 1e-3 limitFloat
(SigP.exponential2 halfLife start)
(Exp.causalP start <<<
CausalP.mapSimple Exp.parameter $*
SigP.constant halfLife)
-exponential2PackedStatic :: IO (ChunkSize -> (Int,Int) -> SimFloat)
+exponential2PackedStatic :: Test (Float,Float) SimFloat
exponential2PackedStatic =
- let halfLife = rangeFromInt (1000,10000) <<^ fst
- start = rangeFromInt ( -1, 1) <<^ snd
- in checkSimilarity 1e-3 (limitFloat . SigStL.unpack)
+ withGenArgs genExp $ \(halfLife,start) ->
+ checkSimilarity 1e-3 (limitFloat . SigStL.unpack)
(SigPS.exponential2 halfLife start ::
- SigP.T (Int,Int) VectorValue)
+ SigP.T (Float,Float) VectorValue)
(Exp.causalPackedP start <<<
CausalP.mapSimple Exp.parameterPacked $*
SigP.constant halfLife)
-exponential2Controlled :: IO (ChunkSize -> ((Int,Int), (Int,Int)) -> SimFloat)
+exponential2Controlled :: Test ((Float,Float), (Float,Float)) SimFloat
exponential2Controlled =
- let halfLife = rangeFromInt (1000,10000) <<^ (fst.fst)
- start = rangeFromInt ( -1, 1) <<^ (snd.fst)
- -- this is the LFO frequency measured at vector-rate
- freq = rangeFromInt (0.0001, 0.001) <<^ (fst.snd)
- phase = rangeFromInt (0, 0.99 :: Float) <<^ (snd.snd)
- lfo =
+ withGenArgs
+ (pair genExp
+ (pair (Gen.choose (0.0001, 0.001)) (Gen.choose (0, 0.99 :: Float)))) $
+
+ -- 'freq' is the LFO frequency measured at vector-rate
+ \((halfLife,start), (freq,phase)) ->
+ let lfo =
CausalP.mapExponential 2 halfLife $*
SigP.osciSimple Wave.approxSine2 phase freq
- in checkSimilarity 1e-3 limitFloat
+ in checkSimilarityPacked 1e-3 limitFloat
(Exp.causalP start <<<
CausalP.mapSimple Exp.parameter $*
SigP.interpolateConstant
(TypeNum.integralFromProxy TypeNum.d4 :: Param.T p Float)
lfo)
- (SigPS.unpack
- (Exp.causalPackedP start <<<
- CausalP.mapSimple Exp.parameterPacked $*
- lfo :: SigP.T ((Int,Int),(Int,Int)) VectorValue))
+ (Exp.causalPackedP start <<<
+ CausalP.mapSimple Exp.parameterPacked $* lfo)
-osci :: IO (ChunkSize -> (Int,Int) -> SimFloat)
+osci :: Test (Float,Float) SimFloat
osci =
- let freq = rangeFromInt (0.001, 0.01) <<^ fst
- phase = rangeFromInt (0, 0.99) <<^ snd
- in checkSimilarity 1e-2 limitFloat
- (SigP.osciSimple Wave.approxSine2 phase freq)
- (SigPS.unpack (SigPS.osciSimple Wave.approxSine2 phase freq ::
- SigP.T (Int,Int) VectorValue))
+ withGenArgs
+ (pair
+ (Gen.choose (0.001, 0.01))
+ (Gen.choose (0, 0.99))) $
+ \(freq,phase) ->
+ checkSimilarityPacked 1e-2 limitFloat
+ (SigP.osciSimple Wave.approxSine2 phase freq)
+ (SigPS.osciSimple Wave.approxSine2 phase freq)
@@ -188,17 +192,17 @@ noiseScalarVector =
tests :: [(String, IO ())]
tests =
- ("constant", quickCheck =<< constant) :
- ("ramp", quickCheck =<< ramp) :
- ("parabolaFadeIn", quickCheck =<< parabolaFadeIn) :
- ("parabolaFadeOut", quickCheck =<< parabolaFadeOut) :
- ("parabolaFadeInMap", quickCheck =<< parabolaFadeInMap) :
- ("parabolaFadeOutMap", quickCheck =<< parabolaFadeOutMap) :
- ("exponential2", quickCheck =<< exponential2) :
- ("exponential2Static", quickCheck =<< exponential2Static) :
- ("exponential2PackedStatic", quickCheck =<< exponential2PackedStatic) :
- ("exponential2Controlled", quickCheck =<< exponential2Controlled) :
- ("osci", quickCheck =<< osci) :
+ ("constant", checkWithParam constant) :
+ ("ramp", checkWithParam ramp) :
+ ("parabolaFadeIn", checkWithParam parabolaFadeIn) :
+ ("parabolaFadeOut", checkWithParam parabolaFadeOut) :
+ ("parabolaFadeInMap", checkWithParam parabolaFadeInMap) :
+ ("parabolaFadeOutMap", checkWithParam parabolaFadeOutMap) :
+ ("exponential2", checkWithParam exponential2) :
+ ("exponential2Static", checkWithParam exponential2Static) :
+ ("exponential2PackedStatic", checkWithParam exponential2PackedStatic) :
+ ("exponential2Controlled", checkWithParam exponential2Controlled) :
+ ("osci", checkWithParam osci) :
("noise", quickCheck =<< noise) :
("noiseVector", quickCheck =<< noiseVector) :
("noiseScalarVector", quickCheck =<< noiseScalarVector) :
diff --git a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs
index bdb018d..23413b2 100644
--- a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs
+++ b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs
@@ -9,16 +9,14 @@ import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import Synthesizer.LLVM.CausalParameterized.Process (($*), )
import qualified Data.StorableVector.Lazy as SVL
-import qualified Data.StorableVector as SV
-import Data.StorableVector.Lazy (ChunkSize, )
+import qualified Test.Synthesizer.LLVM.Generator as Gen
+import Test.Synthesizer.LLVM.Generator
+ (Test, checkWithParam, arg, pair, triple, withGenArgs, )
import Test.Synthesizer.LLVM.Utility
- (CheckEquality, checkEquality, rangeFromInt, )
+ (CheckEquality, checkEquality, genRandomVectorParam, randomSignal, )
-import Control.Category ((<<<), )
-import Control.Arrow (arr, (***), (^<<), (<<^), )
import Control.Applicative (pure, )
-import Data.Tuple.HT (fst3, snd3, thd3, )
import qualified LLVM.Extra.Arithmetic as A
@@ -30,8 +28,6 @@ import Foreign.Storable (Storable, )
import qualified System.Random as Rnd
import Data.Word (Word32, )
-import Test.QuickCheck (quickCheck, )
-
import NumericPrelude.Numeric
import NumericPrelude.Base
@@ -46,76 +42,85 @@ limitFloat :: (Storable a) => SVL.Vector a -> SVL.Vector a
limitFloat = SVL.take signalLength
-trackId :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
+trackId :: Test (Int, Word32) EquFloat
trackId =
- let bufferSize = rangeFromInt (1,1000) <<^ fst
- noise = SigP.noise (arr snd) 1
- in checkEquality limitFloat
+ withGenArgs (pair (Gen.choose (1,1000)) Gen.arbitrary) $
+ \(bufferSize, seed) ->
+ let noise = SigP.noise seed 1
+ in checkEquality limitFloat
noise
(CausalP.mapSimple (RingBuffer.index A.zero) $*
RingBuffer.track bufferSize noise)
-trackTail :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
+trackTail :: Test (Int, Word32) EquFloat
trackTail =
- let bufferSize = rangeFromInt (2,1000) <<^ fst
- noise = SigP.noise (arr snd) 1
- in checkEquality limitFloat
+ withGenArgs (pair (Gen.choose (2,1000)) Gen.arbitrary) $
+ \(bufferSize, seed) ->
+ let noise = SigP.noise seed 1
+ in checkEquality limitFloat
(SigP.tail noise)
(CausalP.mapSimple (RingBuffer.index A.one) $*
RingBuffer.track bufferSize noise)
-trackDrop :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
+trackDrop :: Test (Int, Word32) EquFloat
trackDrop =
- let n = rangeFromInt (0,1000) <<^ fst
- noise = SigP.noise (arr snd) 1
- in checkEquality limitFloat
+ withGenArgs (pair (Gen.choose (0,1000)) Gen.arbitrary) $
+ \(n, seed) ->
+ let noise = SigP.noise seed 1
+ in checkEquality limitFloat
(SigP.drop n noise)
(CausalP.map RingBuffer.index (fmap (fromIntegral :: Int -> Word32) n) $*
RingBuffer.track (fmap succ n) noise)
-randomSkips :: Param.T p (Int, Int) -> SigP.T p (Value Word32)
-randomSkips p =
- SigP.fromStorableVectorLazy
- ((\(len, seed) ->
- SVL.cycle $
- SVL.fromChunks
- [fst $ SV.packN len $ Rnd.randomRs (0,10::Word32) seed])
- ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)
+randomSkips :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Word32)
+randomSkips = randomSignal (0,10::Word32)
-trackSkip :: IO (ChunkSize -> ((Int,Int), Word32) -> EquFloat)
+trackSkip :: Test ((Int, Rnd.StdGen), Word32) EquFloat
trackSkip =
- let skips = randomSkips (arr fst)
- noise = SigP.noise (arr snd) 1
+ withGenArgs (pair (arg genRandomVectorParam) Gen.arbitrary) $
+ \(sk, seed) ->
+ let skips = randomSkips sk
+ noise = SigP.noise seed 1
in checkEquality limitFloat
(CausalP.skip noise $* skips)
(CausalP.mapSimple (RingBuffer.index A.one) $*
(RingBuffer.trackSkip 1 noise $* skips))
-trackSkip1 :: IO (ChunkSize -> (Int, Word32) -> EquFloat)
+trackSkip1 :: Test (Word32, Word32) EquFloat
trackSkip1 =
- let bufferSize = 1000
- k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ fst
- noise = SigP.noise (arr snd) 1
- in checkEquality limitFloat
- (CausalP.map RingBuffer.index k $*
- (RingBuffer.track (pure bufferSize) noise))
- (CausalP.map RingBuffer.index k $*
- (RingBuffer.trackSkip (pure bufferSize) noise $* 1))
+ let bufferSize :: Int
+ bufferSize = 1000
+ in withGenArgs
+ (pair
+ (Gen.choose (0, fromIntegral bufferSize - 1))
+ Gen.arbitrary) $
+ \(k, seed) ->
+ let noise = SigP.noise seed 1
+ in checkEquality limitFloat
+ (CausalP.map RingBuffer.index k $*
+ (RingBuffer.track (pure bufferSize) noise))
+ (CausalP.map RingBuffer.index k $*
+ (RingBuffer.trackSkip (pure bufferSize) noise $* 1))
trackSkipHold ::
- IO (ChunkSize -> ((Int,Int), Int, Word32) -> CheckEquality (Bool, Float))
+ Test ((Int, Rnd.StdGen), Word32, Word32) (CheckEquality (Bool, Float))
trackSkipHold =
let bufferSize = 1000
- skips = randomSkips (arr fst3)
- k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ snd3
- noise = SigP.noise (arr thd3) 1
- in checkEquality limitFloat
- (fmap ((,) (LLVM.valueOf True)) $
- (CausalP.map RingBuffer.index k $*
- (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))
- (CausalP.map
- (\ki ((b,_s),buf) -> fmap ((,) b) $ RingBuffer.index ki buf) k $*
- (RingBuffer.trackSkipHold (pure bufferSize) noise $* skips))
+ in withGenArgs
+ (triple
+ (arg genRandomVectorParam)
+ (Gen.choose (0, fromIntegral bufferSize - 1))
+ Gen.arbitrary) $
+ \(sk, k, seed) ->
+ let skips = randomSkips sk
+ noise = SigP.noise seed 1
+ in checkEquality limitFloat
+ (fmap ((,) (LLVM.valueOf True)) $
+ (CausalP.map RingBuffer.index k $*
+ (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))
+ (CausalP.map
+ (\ki ((b,_s),buf) -> fmap ((,) b) $ RingBuffer.index ki buf) k $*
+ (RingBuffer.trackSkipHold (pure bufferSize) noise $* skips))
{-
To do:
@@ -126,10 +131,10 @@ test that trackSkipHold returns False forever after it has returned False once.
tests :: [(String, IO ())]
tests =
- ("trackId", quickCheck =<< trackId) :
- ("trackTail", quickCheck =<< trackTail) :
- ("trackDrop", quickCheck =<< trackDrop) :
- ("trackSkip", quickCheck =<< trackSkip) :
- ("trackSkip1", quickCheck =<< trackSkip1) :
- ("trackSkipHold", quickCheck =<< trackSkipHold) :
+ ("trackId", checkWithParam trackId) :
+ ("trackTail", checkWithParam trackTail) :
+ ("trackDrop", checkWithParam trackDrop) :
+ ("trackSkip", checkWithParam trackSkip) :
+ ("trackSkip1", checkWithParam trackSkip1) :
+ ("trackSkipHold", checkWithParam trackSkipHold) :
[]
diff --git a/testsuite/Test/Synthesizer/LLVM/Utility.hs b/testsuite/Test/Synthesizer/LLVM/Utility.hs
index c2011aa..dd2ce6b 100644
--- a/testsuite/Test/Synthesizer/LLVM/Utility.hs
+++ b/testsuite/Test/Synthesizer/LLVM/Utility.hs
@@ -2,22 +2,28 @@
{-# LANGUAGE TypeFamilies #-}
module Test.Synthesizer.LLVM.Utility where
+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param
+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.State.Signal as SigS
-import Control.Arrow (arr, )
import Control.Monad (liftM, liftM2, )
+import Control.Applicative ((<$>), )
import qualified Data.StorableVector.Lazy as SVL
+import qualified Data.StorableVector as SV
import Data.StorableVector.Lazy (ChunkSize, )
import Foreign.Storable (Storable, )
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class
+import qualified LLVM.Core as LLVM
-import System.Random (Random, randomR, mkStdGen, )
+import qualified Type.Data.Num.Decimal as TypeNum
+
+import System.Random (Random, randomRs, StdGen, mkStdGen, )
import qualified Test.QuickCheck as QC
@@ -28,9 +34,28 @@ import NumericPrelude.Numeric
import NumericPrelude.Base
-rangeFromInt :: Random a => (a,a) -> Param.T Int a
-rangeFromInt rng =
- arr $ fst . randomR rng . mkStdGen
+genRandomVectorParam :: QC.Gen (Int, StdGen)
+genRandomVectorParam =
+ liftM2 (,) (QC.choose (1,100)) (mkStdGen <$> QC.arbitrary)
+
+randomStorableVector ::
+ (Storable a, Random a) =>
+ (a, a) -> (Int, StdGen) -> SV.Vector a
+randomStorableVector range (len, seed) =
+ fst $ SV.packN len $ randomRs range seed
+
+randomStorableVectorLoop ::
+ (Storable a, Random a) =>
+ (a, a) -> (Int, StdGen) -> SVL.Vector a
+randomStorableVectorLoop range param =
+ SVL.cycle $ SVL.fromChunks [randomStorableVector range param]
+
+randomSignal ::
+ (Class.MakeValueTuple a, Class.ValueTuple a ~ tuple, Memory.C tuple,
+ Storable a, Random a) =>
+ (a, a) -> Param.T p (Int, StdGen) -> SigP.T p (Class.ValueTuple a)
+randomSignal range p =
+ SigP.fromStorableVectorLazy (randomStorableVectorLoop range <$> p)
render ::
@@ -101,6 +126,15 @@ checkSimilarity tol limit gen0 gen1 =
(render limit gen0)
(render limit gen1)
+checkSimilarityPacked ::
+ Float ->
+ (SVL.Vector Float -> SVL.Vector Float) ->
+ SigP.T p (LLVM.Value Float) ->
+ SigP.T p (Serial.Value TypeNum.D4 Float) ->
+ IO (ChunkSize -> p -> CheckSimilarity Float)
+checkSimilarityPacked tol limit scalar vector =
+ checkSimilarity tol limit scalar (SigPS.unpack vector)
+
{- |
Instead of testing on equality immediately