packages feed

synthesizer-llvm 0.9 → 1.0

raw patch · 111 files changed

+13877/−16474 lines, 111 filesdep +doctest-exitcode-stdiodep ~llvm-dsldep ~llvm-extradep ~llvm-tf

Dependencies added: doctest-exitcode-stdio

Dependency ranges changed: llvm-dsl, llvm-extra, llvm-tf, optparse-applicative, random, tfp, transformers, unsafe

Files

Changes.md view
@@ -1,5 +1,11 @@ # Change log for the `synthesizer-llvm` package +## 1.0++* Move from `llvm-dsl` `Parameter` to `Exp` for parameters.+  Remove clumsy distinction between simple and parameterized+  `Signal`s and `Process`es.+ ## 0.9  * Clean separation between Haskell's `Storable` memory format
alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs view
@@ -20,10 +20,12 @@ import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa import qualified Synthesizer.CausalIO.Process as PIO -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Storable.Signal as SigStL  import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo  import qualified Data.StorableVector as SV @@ -34,8 +36,7 @@ import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg -import Control.Arrow ((<<<), (^<<), arr)-import Control.Category (id)+import Control.Arrow (arr, (<<<), (^<<), (<<^))  import qualified Number.DimensionTerm as DN @@ -75,7 +76,7 @@    opt <- Option.get    proc <-       Arrange.keyboardFM-         (CausalP.mapSimple StereoInt.interleave)+         (Causal.map StereoInt.interleave)          (Option.channel opt)    playFromEvents opt $ \ sampleRate ->       SigStL.unpackStereoStrict ^<< proc sampleRate@@ -87,7 +88,7 @@        PIO.T (MIO.Events Event.T) (SV.Vector StereoVector)) keyboardDetuneFMCore opt =    Arrange.keyboardDetuneFMCore-      (CausalP.mapSimple StereoInt.interleave)+      (Causal.map StereoInt.interleave)       (Option.sampleDirectory opt)  keyboardDetuneFM :: IO ()@@ -111,7 +112,7 @@    opt <- Option.get    proc <-       Arrange.voderBand-         (CausalP.mapSimple StereoInt.interleave)+         (Causal.map StereoInt.interleave)          (Option.sampleDirectory opt)     playFromEvents opt $ \ sampleRate ->@@ -124,7 +125,7 @@    opt <- Option.get    proc <-       Arrange.voderMask-         (CausalP.mapSimple StereoInt.interleave)+         (Causal.map StereoInt.interleave)          (Option.sampleDirectory opt)     playFromEvents opt $ \ sampleRate ->@@ -137,7 +138,7 @@    opt <- Option.get    proc <-       Arrange.voderMaskEnv-         (CausalP.mapSimple StereoInt.interleave)+         (Causal.map StereoInt.interleave)          (Option.sampleDirectory opt)     playFromEvents opt $ \ sampleRate ->@@ -150,7 +151,7 @@    opt <- Option.get    proc <-       Arrange.voderMaskSeparated-         (CausalP.mapSimple StereoInt.interleave)+         (const $ Causal.map StereoInt.interleave)          (Option.sampleDirectory opt)     playFromEvents opt $ \ sampleRate ->@@ -158,7 +159,7 @@       <<<       proc          (Option.channel opt) (Option.extraChannel opt)-         (VoiceMsg.toProgram 4) sampleRate+         (VoiceMsg.toProgram 4) sampleRate ()  voderMaskMulti :: IO () voderMaskMulti = do@@ -171,21 +172,21 @@ formant = do    opt <- Option.get    proc <--      Arrange.keyboardDetuneFMCore id+      Arrange.keyboardDetuneFMCore (arr Stereo.multiValue)          (Option.sampleDirectory opt)    form <- Speech.filterFormant-   mix <- CausalP.processIO CausalP.mix+   mix <- CausalRender.run Causal.mix    interleave <--      CausalP.processIO-         (CausalP.mapSimple StereoInt.interleave)+      CausalRender.run+         (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue)     playFromEvents opt $ \ sampleRate ->       arr SigStL.unpackStereoStrict       <<<-      interleave ()+      interleave       <<<       foldl1-         (\x y -> mix () <<< Zip.arrowFanout x y)+         (\x y -> mix <<< Zip.arrowFanout x y)          (zipWith              (\n (freq, amp, reson) ->                 form sampleRate
alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs view
@@ -6,12 +6,11 @@ import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.LLVM.Server.Option as Option import qualified Synthesizer.LLVM.Server.Default as Default+import Synthesizer.LLVM.Server.CausalPacked.Common (chopEvents) import Synthesizer.LLVM.Server.CausalPacked.Arrange           ((&+&), shortTime, controllerExponentialDim)-import Synthesizer.LLVM.Server.CommonPacked-          (Vector)-import Synthesizer.LLVM.Server.Common hiding-          (Instrument)+import Synthesizer.LLVM.Server.CommonPacked (Vector)+import Synthesizer.LLVM.Server.Common hiding (Instrument)  import qualified Sound.ALSA.Sequencer.Event as Event -- import qualified Sound.ALSA.Sequencer.Connect as Connect@@ -38,15 +37,17 @@ import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.CausalIO.Process as PIO -import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP+import qualified Synthesizer.LLVM.Causal.Functional as F+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Storable.Process as CausalSt import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.Wave as Wave-import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<))+import Synthesizer.LLVM.Causal.Process (($*), ($<))  import qualified Synthesizer.Generic.Cut          as CutG import qualified Synthesizer.Storable.Cut         as CutSt@@ -58,11 +59,13 @@ import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.BodyTime  as EventListBT +import qualified LLVM.DSL.Expression as Expr+ import System.Path ((</>)) -import Control.Arrow ((<<<), (<<^), (^<<), arr, first)+import Control.Arrow (arr, (***), (<<<), (<<^), (^<<)) import Control.Category (id)-import Control.Applicative (pure, liftA2)+import Control.Applicative (liftA2) import Control.Monad (when) import Control.Monad.Trans.State (evalState) @@ -75,8 +78,9 @@ import Data.Word (Word8, Word32) import Data.Int (Int32) -import Foreign.Storable (Storable)+import qualified System.Unsafe as Unsafe import qualified System.IO as IO+import Foreign.Storable (Storable) import Control.Exception (bracket)  import Prelude hiding (Real, id)@@ -229,10 +233,10 @@    opt <- Option.get    arrange <- CausalSt.makeArranger    amp <--      CausalP.processIO-         (CausalP.mapSimple StereoInt.interleave <<<-          CausalP.envelopeStereo <<<-          first (CausalP.mapSimple Serial.upsample))+      CausalRender.run+         (Causal.map StereoInt.interleave <<<+          Causal.envelopeStereo <<<+          Causal.map Serial.upsample *** arr Stereo.unMultiValue)     ping <- Instr.pingStereoReleaseFM @@ -269,7 +273,7 @@    let proc =           arr SigStL.unpackStereoStrict           <<<-          amp ()+          amp           <<<           (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float)            <<^ Zip.second)@@ -321,8 +325,8 @@    opt <- Option.get     amp <--      CausalP.processIO-         (CausalP.mapSimple StereoInt.interleave)+      CausalRender.run+         (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue)     tomatoSmps <- makeSampledSounds opt @@ -337,7 +341,7 @@    writeTest       (arr SigStL.unpackStereoStrict        <<<-       amp ()+       amp        <<<        tomato (last tomatoSmps) 0 440) $       map@@ -393,8 +397,8 @@    opt <- Option.get     amp <--      CausalP.processIO-         (CausalP.mapSimple StereoInt.interleave)+      CausalRender.run+         (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue)     tomatoSmps <- makeSampledSounds opt @@ -409,7 +413,7 @@    writeTest       (arr SigStL.unpackStereoStrict        <<<-       amp ()+       amp        <<<        tomato (head tomatoSmps) 0 440) $       map@@ -424,9 +428,9 @@  lfo :: SVL.Vector Real lfo =-   SigP.renderChunky (SVL.chunkSize 512)-      (1 + 0.1 * SigP.osciSimple Wave.approxSine2 (pure (0::Float)) 0.0001)-      ()+   Unsafe.performIO $+   fmap ($ SVL.chunkSize 512) $+   Render.run (1 + 0.1 * Sig.osci Wave.approxSine2 Expr.zero 0.0001)  asMono :: vector Real -> vector Real asMono = id@@ -438,10 +442,8 @@     SVL.writeFile "/tmp/test.f32" .       asMono .-      (\f -> f smp lfo) =<<-      CausalP.runStorableChunky-         (CausalP.frequencyModulationLinear $-          SigP.fromStorableVectorLazy id)+      (\f -> pioApply (f smp) lfo) =<<+      CausalRender.run Causal.frequencyModulationLinear   frequencyModulationIO :: IO ()@@ -449,10 +451,7 @@    opt <- Option.get    smp <- loadTomato opt -   proc <--      CausalP.processIO-         (CausalP.frequencyModulationLinear $-          SigP.fromStorableVectorLazy id)+   proc <- CausalRender.run Causal.frequencyModulationLinear     writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $       SVL.chunks lfo@@ -462,10 +461,7 @@    opt <- Option.get    smp <- loadTomato opt -   proc <--      CausalP.processIO-         (CausalP.frequencyModulationLinear $-          SigP.fromStorableVector id)+   proc <- CausalRender.run Causal.frequencyModulationLinear     writeTest       (proc (SV.concat $ SVL.chunks smp) ::@@ -475,9 +471,9 @@ frequencyModulationSawIO :: IO () frequencyModulationSawIO = do    proc <--      CausalP.processIO-         (CausalP.frequencyModulationLinear-             (CausalP.take 50000 $* SigP.osciSaw 0 id))+      CausalRender.run $ \freq ->+         Causal.frequencyModulationLinear+             (Causal.take 50000 $* Sig.osci Wave.saw 0 freq)     writeTest (proc (0.01::Real) :: PIO.T (SV.Vector Real) (SV.Vector Real)) $       SVL.chunks lfo@@ -487,9 +483,7 @@    opt <- Option.get    smp <- loadTomato opt -   proc <--      CausalP.processIO-         (CausalP.envelope $< SigP.fromStorableVectorLazy id)+   proc <- CausalRender.run $ \env -> Causal.envelope $< env     writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $       SVL.chunks lfo@@ -498,14 +492,15 @@ functional :: IO () functional = do    phaser <--      CausalP.processIO $ F.withArgs $ \ratio ->-         let freq = frequency id-             noise = F.fromSignal $ SigP.noise 12 (recip freq)+      CausalRender.run $+      wrapped $ \(NoiseReference noiseRef) (SampleRate _sr) ->+      F.withArgs $ \ratio ->+         let noise = F.fromSignal $ Sig.noise 12 noiseRef          in  (1-ratio) * noise +-             ratio * (CausalP.delayZero 100 F.$& noise)+             ratio * (Causal.delayZero 100 F.$& noise)     writeTest-      (phaser (sampleRate, 200000) ::+      (phaser sampleRate (200000 :: Real) ::          PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $       map (\y -> EventListBT.singleton y 10000)           [0, 0.25, 0.5, 0.75, 1.00]@@ -514,12 +509,15 @@ functionalPlug :: IO () functionalPlug = do    phaser <--      FP.withArgs $ \ratio0 ->-         let freq = frequency id-             ratio = FP.plug ratio0-             noise = FP.fromSignal $ SigP.noise 12 (recip freq)+      FP.withArgs $ \ratio0 pl ->+      (\f ->+         case Expr.unzip pl of+            (sr,noiseRef) -> f (expSampleRate sr) noiseRef) $+      wrapped $ \(NoiseReference noiseRef) (SampleRate _sr) ->+         let ratio = FP.plug ratio0+             noise = FP.fromSignal $ Sig.noise 12 noiseRef          in  (1-ratio) * noise +-             ratio * (CausalP.delayZero 100 FP.$& noise)+             ratio * (Causal.delayZero 100 FP.$& noise)     writeTest       (phaser () (sampleRate, 200000) ::@@ -531,9 +529,9 @@ makeUnpackStereoStrict ::    IO (PIO.T (SV.Vector (Stereo.T Vector)) (SV.Vector (Stereo.T Real))) makeUnpackStereoStrict =-   fmap (\proc -> SigStL.unpackStereoStrict ^<< proc ()) $-   CausalP.processIO-      (CausalP.mapSimple StereoInt.interleave)+   fmap (SigStL.unpackStereoStrict ^<<) $+   CausalRender.run+      (Causal.map StereoInt.interleave <<^ Stereo.unMultiValue) {- makeUnpackStereoStrict ::    IO (SV.Vector (Stereo.T Vector) -> SV.Vector (Stereo.T Real))
alsa/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -20,14 +20,17 @@ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo  import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*))-import Synthesizer.LLVM.Parameter (($#))+import Synthesizer.LLVM.Causal.Process (($<), ($*)) +import LLVM.DSL.Expression (Exp)+ import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL @@ -45,7 +48,7 @@ import qualified System.Path as Path  import qualified Control.Applicative.HT as App-import Control.Arrow ((<<<), (^<<), arr)+import Control.Arrow (arr, (<<<), (^<<), (<<^)) import Control.Applicative (pure, liftA2, liftA3, (<*>)) import Control.Monad.Trans.State (evalState) @@ -108,13 +111,13 @@ frequencyModulation = do    opt <- Option.get    osc <--      SigP.runChunky-         ((CausalPS.osciSimple WaveL.triangle $< zero)-           $* Instr.frequencyFromBendModulation-                 (frequencyConst 10)-                 (Instr.modulation (\fm -> (fm,880))))+      Render.run $+      wrapped $ \(Instr.Modulation fm) ->+      constant frequency 10 $ \speed _sr ->+         ((CausalPS.osci WaveL.triangle $< zero)+           $* Instr.frequencyFromBendModulation speed fm)    withMIDIEventsMono opt play $ \vectorChunkSize sampleRate ->-      osc vectorChunkSize . (,) sampleRate .+      osc vectorChunkSize sampleRate . flip (,) (880::Real) .       evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real))  @@ -123,10 +126,10 @@ keyboard = do    opt <- Option.get    sound <- Instr.pingRelease $/ 0.4 $/ 0.1-   amp <- CausalP.runStorableChunky (CausalPS.amplify (arr id))+   amp <- CausalRender.run CausalPS.amplify    arrange <- SigStL.makeArranger    withMIDIEventsMono opt play $ \vectorChunkSize sampleRate ->-      (amp :: Real -> SigSt.T Vector -> SigSt.T Vector) 0.2 .+      pioApply (amp (0.2::Real)) .       arrange vectorChunkSize .       evalState          (Gen.sequence (Option.channel opt) $@@ -137,12 +140,12 @@    opt <- Option.get    sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1    amp <--      CausalP.runStorableChunky-         (CausalP.mapSimple StereoInt.interleave <<<-          CausalPS.amplifyStereo (arr id))+      CausalRender.run $ \vol ->+         Causal.map StereoInt.interleave <<<+         CausalPS.amplifyStereo vol <<^ Stereo.unMultiValue    arrange <- SigStL.makeArranger    withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->-      (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 .+      pioApply (amp (0.2 :: Real)) .       arrange vectorChunkSize .       evalState          (Gen.sequence (Option.channel opt) $@@ -153,12 +156,12 @@    opt <- Option.get    str <- Instr.softStringFM    amp <--      CausalP.runStorableChunky-         (CausalP.mapSimple StereoInt.interleave <<<-          CausalPS.amplifyStereo (arr id))+      CausalRender.run $ \vol ->+         Causal.map StereoInt.interleave <<<+         CausalPS.amplifyStereo vol <<^ Stereo.unMultiValue    arrange <- SigStL.makeArranger    withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->-      (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 .+      pioApply (amp (0.2 :: Real)) .       arrange vectorChunkSize .       evalState          (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03@@ -171,12 +174,12 @@    str <- Instr.softStringFM    tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1    amp <--      CausalP.runStorableChunky-         (CausalP.mapSimple StereoInt.interleave <<<-          CausalPS.amplifyStereo (arr id))+      CausalRender.run $ \vol ->+         Causal.map StereoInt.interleave <<<+         CausalPS.amplifyStereo vol <<^ Stereo.unMultiValue    arrange <- SigStL.makeArranger    withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->-      (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 .+      pioApply (amp (0.2 :: Real)) .       arrange vectorChunkSize .       evalState          (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03@@ -240,10 +243,10 @@     arrange <- SigStL.makeArranger    amp <--      CausalP.runStorableChunky-         (CausalP.mapSimple StereoInt.interleave <<<-          CausalP.envelopeStereo $<-            Instr.piecewiseConstantVector (arr id))+      CausalRender.run $ \ctrl ->+         (Causal.map StereoInt.interleave <<<+          Causal.envelopeStereo $< Instr.piecewiseConstantVector ctrl)+            <<^ Stereo.unMultiValue    return $ \chan pgm vcsize sr -> do       let        evHead =@@ -421,7 +424,7 @@        ctrls <- PCS.fromChannel chan -      fmap (amp volume . arrange vcsize) $+      fmap (pioApply (amp volume) . arrange vcsize) $          Gen.sequenceModulatedMultiProgram             ctrls chan pgm             (map (\sound fm -> sound fm $ sr) $@@ -436,35 +439,38 @@    opt <- Option.get    proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)    withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->-      evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) vectorChunkSize sampleRate)+      evalState+         (proc (Option.channel opt) (VoiceMsg.toProgram 0)+            vectorChunkSize sampleRate)  keyboardFilter :: IO () keyboardFilter = do    opt <- Option.get    proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)-   mix <- CausalP.runStorableChunky $+   mix <- CausalRender.run $ \xs ->       arr id       +-      (CausalP.mapSimple (StereoInt.amplify 0.5)+      (Causal.map (StereoInt.amplify 0.5)        <<<-       CausalP.fromSignal (SigP.fromStorableVectorLazy (arr id)))+       Causal.fromSignal xs)     lowpass0 <--      CausalP.runStorableChunky $-      CausalP.mapSimple StereoInt.interleave+      CausalRender.run $ \cutoff ->+      Causal.map StereoInt.interleave       <<< --      CausalPS.amplifyStereo 0.1 <<<       CausalPS.pack-         (CausalP.stereoFromMonoControlled-             (UniFilter.lowpass ^<< UniFilterL.causal) $<-          (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real))-             (piecewiseConstant (arr id)))+         (Causal.stereoFromMonoControlled+             (UniFilter.lowpass ^<< UniFilterL.causalExp) $<+          Sig.interpolateConstant (fromIntegral vectorSize :: Exp Int)+             (UniFilterL.unMultiValueParameter <$> piecewiseConstant cutoff))       <<<-      CausalP.mapSimple StereoInt.deinterleave+      Causal.map StereoInt.deinterleave    let lowpass ::           Option.SampleRate Real -> PC.T Real -> PC.T Real ->           SigSt.T StereoVector -> SigSt.T StereoVector        lowpass (Option.SampleRate sr) resons freqs =+          pioApply $           lowpass0 $ fmap UniFilter.parameter $           PC.zipWith FiltR.Pole resons $ fmap (/ sr) freqs @@ -490,5 +496,5 @@                 proc (Option.channel opt) (VoiceMsg.toProgram 0)                    vectorChunkSize sampleRate              return-                (pureMusic `mix`+                (pioApply (mix pureMusic) $                  lowpass sampleRate resonance freq filterMusic))
alsa/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -3,29 +3,29 @@ import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr import qualified Synthesizer.LLVM.Server.Default as Default import qualified Synthesizer.LLVM.Server.SampledSound as Sample+import Synthesizer.LLVM.Server.Packed.Instrument (InputArg(Modulation)) import Synthesizer.LLVM.Server.ALSA (makeNote)-import Synthesizer.LLVM.Server.CommonPacked-          (Vector, vectorSize)-import Synthesizer.LLVM.Server.Common hiding-          (Instrument)+import Synthesizer.LLVM.Server.CommonPacked (Vector, vectorSize)+import Synthesizer.LLVM.Server.Common hiding (Instrument)  import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.Generic as Gen  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Plain as Serial  import qualified Synthesizer.ALSA.Storable.Play as Play import Synthesizer.MIDI.Storable (Instrument, chunkSizesFromLazyTime)  import qualified Synthesizer.LLVM.MIDI.BendModulation as BM-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Render as Render import qualified Synthesizer.LLVM.Storable.Signal as SigStL-import Synthesizer.LLVM.CausalParameterized.Process (($*))+import Synthesizer.LLVM.Causal.Process (($*))  import qualified Synthesizer.Storable.Cut         as CutSt import qualified Synthesizer.Storable.Signal      as SigSt@@ -36,7 +36,7 @@ import qualified Data.EventList.Relative.BodyTime  as EventListBT  import Control.Arrow ((<<<), arr)-import Control.Applicative (pure, liftA, liftA2)+import Control.Applicative (pure, liftA, liftA2, (<$>)) import Control.Monad.Trans.State (evalState)  import qualified Numeric.NonNegative.Wrapper as NonNegW@@ -212,11 +212,8 @@    liftA       (\osc smp _fm _vel _freq _dur ->          osc chunkSize (Sample.body smp))-      (SigP.runChunky-         (let smp = arr id-          in  fmap (\x -> Stereo.cons x x) $-              SigPS.pack $-              SigP.fromStorableVectorLazy smp))+      (Render.run $ \smp ->+         fmap (\x -> Stereo.consMultiValue x x) $ SigPS.pack smp)  sampledSoundTest1 ::    IO (Sample.T ->@@ -226,15 +223,13 @@    liftA       (\osc smp _fm _vel _freq _dur ->          osc chunkSize (Sample.body smp))-      (SigP.runChunky-         (let smp = arr id-          in  CausalP.stereoFromMono-                 (CausalPS.pack-                    (CausalP.frequencyModulationLinear-                       (SigP.fromStorableVectorLazy smp)))+      (Render.run $ \smp ->+         Stereo.multiValue <$>+         Causal.stereoFromMono+                  (CausalPS.pack (Causal.frequencyModulationLinear smp))                $* liftA2 Stereo.cons                      (SigPS.constant 0.999)-                     (SigPS.constant 1.001)))+                     (SigPS.constant 1.001)) --               $* (SigPS.constant $# Stereo.cons 0.999 1.001)))  sampledSoundTest2 ::@@ -250,20 +245,18 @@                 SigSt.drop (Sample.start pos) $                 Sample.body smp          in  SVP.take (chunkSizesFromLazyTime dur) $-             osc chunkSize-                (sampleRate, (body, (fm, freq * Sample.period pos))))-      (SigP.runChunky-         (let smp = signal fst-              fm = Instr.modulation snd-          in  (CausalP.stereoFromMono-                  (CausalPS.pack-                     (CausalP.frequencyModulationLinear-                        (SigP.fromStorableVectorLazy smp)))+             osc chunkSize sampleRate body (fm, freq * Sample.period pos))+      (Render.run $+       wrapped $ \(Signal smp) (Modulation fm) ->+       constant frequency 3 $ \speed _sr ->+         Stereo.multiValue <$>+         ((Causal.stereoFromMono+                  (CausalPS.pack (Causal.frequencyModulationLinear smp))                <<<                liftA2 Stereo.cons                   (CausalPS.amplify 0.999)                   (CausalPS.amplify 1.001))-                 $* Instr.frequencyFromBendModulation (frequencyConst 3) fm))+                 $* Instr.frequencyFromBendModulation speed fm))  sampledSoundTest3SpaceLeak ::    IO (Sample.T ->@@ -278,30 +271,28 @@          Without (periodic) frequency modulation          we could just split the piecewise constant control curve @fm@.          -}-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize+                SigSt.repeat chunkSize                    (Serial.replicate (freq*Sample.period pos/sampleRatePlain))-                      :: SigSt.T Vector)              pos = Sample.positions smp              amp = 2 * amplitudeFromVelocity vel              (attack, sustain, release) = Sample.parts smp-         in  osc-                (amp,-                 attack `SigSt.append`-                 SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))-                sustainFM-             `SigSt.append`-             osc (amp,release) releaseFM)-      (CausalP.runStorableChunky-         (let smp = arr snd-              amp = arr fst-          in  CausalPS.amplifyStereo amp+         in pioApply+              (osc amp+                (attack `SigSt.append`+                 SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))+              sustainFM+            `SigSt.append`+            pioApply (osc amp release) releaseFM)+      (CausalRender.run $ \amp smp ->+         Stereo.multiValue <$>+         (CausalPS.amplifyStereo amp               <<<-              CausalP.stereoFromMono+              Causal.stereoFromMono                  (CausalPS.pack-                    (CausalP.frequencyModulationLinear-                       (SigP.fromStorableVectorLazy smp)))+                    (Causal.frequencyModulationLinear smp))               <<<               liftA2 Stereo.cons                  (CausalPS.amplify 0.999)@@ -320,18 +311,20 @@          Without (periodic) frequency modulation          we could just split the piecewise constant control curve @fm@.          -}-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (freqMod-                   (chunkSizesFromLazyTime (PC.duration fm))-                   (sampleRate, (fm, freq*Sample.period pos)) :: SigSt.T Vector)+                pioApplyToLazyTime+                   (freqMod sampleRate (fm, freq*Sample.period pos))+                   (PC.duration fm)              pos = Sample.positions smp          in  SigSt.map                 (\x -> Stereo.cons x x)                 (sustainFM `SigSt.append` releaseFM))-      (SigP.runChunkyPattern-         (Instr.frequencyFromBendModulation-            (frequencyConst 3) (Instr.modulation id)))+      (CausalRender.run $+       wrapped $ \(Modulation fm) ->+       constant frequency 3 $ \speed _sr ->+       Causal.fromSignal $ Instr.frequencyFromBendModulation speed fm)  sampledSoundTest5LargeSpaceLeak ::    IO (Sample.T ->@@ -346,26 +339,27 @@          Without (periodic) frequency modulation          we could just split the piecewise constant control curve @fm@.          -}-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (freqMod-                   (chunkSizesFromLazyTime (PC.duration fm))-                   (sampleRate, (fm, freq*Sample.period pos)) :: SigSt.T Vector)+                pioApplyToLazyTime+                   (freqMod sampleRate (fm, freq*Sample.period pos))+                   (PC.duration fm)              pos = Sample.positions smp              amp = 2 * amplitudeFromVelocity vel              (attack, sustain, release) = Sample.parts smp-         in  osc-                (amp,-                 attack `SigSt.append`-                 SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))-                sustainFM-             `SigSt.append`-             osc (amp,release) releaseFM)-      (CausalP.runStorableChunky-         (arr (\x -> Stereo.cons x x)))-      (SigP.runChunkyPattern-         (Instr.frequencyFromBendModulation-            (frequencyConst 3) (Instr.modulation id)))+         in pioApply+              (osc amp+                 (attack `SigSt.append`+                  SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))+              sustainFM+            `SigSt.append`+            pioApply (osc amp release) releaseFM)+      (CausalRender.run $ \ _amp _smp -> arr (\x -> Stereo.consMultiValue x x))+      (CausalRender.run $+       wrapped $ \(Modulation fm) ->+       constant frequency 3 $ \speed _sr ->+       Causal.fromSignal $ Instr.frequencyFromBendModulation speed fm)   sampledSoundSmallSpaceLeak4 ::@@ -375,17 +369,16 @@ sampledSoundSmallSpaceLeak4 =    liftA       (\osc smp _fm _vel freq dur ->-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize+                SigSt.repeat chunkSize                    (Serial.replicate (freq*Sample.period pos/sampleRatePlain))-                      :: SigSt.T Vector)              pos = Sample.positions smp-         in  osc () sustainFM+         in  pioApply osc sustainFM              `SigSt.append`              SigSt.map (\x -> Stereo.cons x x) releaseFM)-      (CausalP.runStorableChunky-         (arr (\x -> Stereo.cons x x)))+      (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x))  sampledSoundSmallSpaceLeak4a ::    IO (Sample.T ->@@ -395,15 +388,13 @@    liftA       (\osc smp _fm _vel freq dur ->          case SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize-                   (Serial.replicate (freq*Sample.period (Sample.positions smp) / sampleRatePlain))-                      :: SigSt.T Vector) of+                SigSt.repeat chunkSize+                   (Serial.replicate (freq*Sample.period (Sample.positions smp) / sampleRatePlain)) of             (sustainFM, releaseFM) ->-               osc () sustainFM+               pioApply osc (sustainFM :: SigSt.T Vector)                `SigSt.append`                SigSt.map (\x -> Stereo.cons x x) releaseFM)-      (CausalP.runStorableChunky-         (arr (\x -> Stereo.cons x x)))+      (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x))  sampledSoundNoSmallSpaceLeak3 ::    IO (Sample.T ->@@ -412,11 +403,11 @@ sampledSoundNoSmallSpaceLeak3 =    pure       (\smp _fm _vel freq dur ->-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize+                SigSt.repeat chunkSize                    (Serial.replicate (freq*Sample.period pos/sampleRatePlain))-                      :: SigSt.T Vector)              pos = Sample.positions smp          in  SigSt.map (\x -> Stereo.cons x x) sustainFM              `SigSt.append`@@ -433,18 +424,17 @@ sampledSoundNoSmallSpaceLeak2 =    liftA       (\osc smp _fm _vel freq dur ->-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize+                SigSt.repeat chunkSize                    (Serial.replicate (freq*Sample.period pos/sampleRatePlain))-                      :: SigSt.T Vector)              pos = Sample.positions smp-         in  osc ()+         in  pioApply osc                 (amplifySVL sustainFM                  `SigSt.append`                  amplifySVL releaseFM))-      (CausalP.runStorableChunky-         (arr (\x -> Stereo.cons x x)))+      (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x))  sampledSoundSmallSpaceLeak1 ::    IO (Sample.T ->@@ -453,17 +443,16 @@ sampledSoundSmallSpaceLeak1 =    liftA       (\osc smp _fm _vel freq dur ->-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize+                SigSt.repeat chunkSize                    (Serial.replicate (freq*Sample.period pos/sampleRatePlain))-                      :: SigSt.T Vector)              pos = Sample.positions smp-         in  osc () sustainFM+         in  pioApply osc sustainFM              `SigSt.append`-             osc () releaseFM)-      (CausalP.runStorableChunky-         (arr (\x -> Stereo.cons x x)))+             pioApply osc releaseFM)+      (CausalRender.run $ arr (\x -> Stereo.consMultiValue x x))  sampledSoundSmallSpaceLeak0 ::    IO (Sample.T ->@@ -478,23 +467,22 @@          Without (periodic) frequency modulation          we could just split the piecewise constant control curve @fm@.          -}-         let (sustainFM, releaseFM) =+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =                 SVP.splitAt (chunkSizesFromLazyTime dur) $-                (SigSt.repeat chunkSize+                SigSt.repeat chunkSize                    (Serial.replicate (freq*Sample.period pos/sampleRatePlain))-                      :: SigSt.T Vector)              pos = Sample.positions smp              amp = 2 * amplitudeFromVelocity vel              (attack, sustain, release) = Sample.parts smp-         in  osc-                (amp,-                 attack `SigSt.append`-                 SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))+         in  pioApply+                (osc amp+                   (attack `SigSt.append`+                    SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))                 sustainFM              `SigSt.append`-             osc (amp,release) releaseFM)-      (CausalP.runStorableChunky-         (arr (\x -> Stereo.cons x x)))+             pioApply (osc amp release) releaseFM)+      (CausalRender.run $ \ _amp _smp -> arr (\x -> Stereo.consMultiValue x x))  makeSample :: Int -> Sample.T makeSample size =@@ -571,10 +559,10 @@    let stereoPlain = SigSt.map (\x -> Stereo.cons x x)    SVL.writeFile "test.f32" $       let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10+          sustainFM, releaseFM :: SigSt.T Vector           !(sustainFM, releaseFM) =              SVP.splitAt dur $-             (SigSt.repeat chunkSize (Serial.replicate 1)-                 :: SigSt.T Vector)+             SigSt.repeat chunkSize (Serial.replicate 1)       in  case 3::Int of              -- no leak              0 -> stereoLLVM  $ sustainFM `SigSt.append` releaseFM@@ -633,8 +621,7 @@    SVL.writeFile "test.f32" $       arrange vectorChunkSize $       evalState-         (let evs =-                 EventListBT.cons (BM.Cons 0.01 0.001) 10 evs+         (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs           in  Gen.sequenceCore                  Default.channel Gen.errorNoProgram                  (Gen.Modulator () return@@ -646,8 +633,7 @@ sequenceFM1 = do    arrange <- SigStL.makeArranger    sound <- Instr.softStringFM $/-      let evs =-             EventListBT.cons (BM.Cons 0.01 0.001) 10 evs+      let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs       in  evs --   sound <- Instr.softStringReleaseEnvelope    SVL.writeFile "test.f32" $
alsa/Synthesizer/LLVM/Server/Scalar/Run.hs view
@@ -3,20 +3,23 @@ import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr import qualified Synthesizer.LLVM.Server.Option as Option import Synthesizer.LLVM.Server.ALSA (Output, play, startMessage)-import Synthesizer.LLVM.Server.Common+import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation)+import Synthesizer.LLVM.Server.Common hiding (transposeModulation)  import qualified Sound.ALSA.Sequencer.Event as Event import qualified Data.EventList.Relative.TimeBody  as EventList -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.MIDI as MIDIL-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.Causal.Process (($<#), ($*))+import Synthesizer.LLVM.Causal.Process (($<), ($*)) -import qualified Synthesizer.Storable.Signal      as SigSt+import qualified Synthesizer.Storable.Signal as SigSt  import qualified Synthesizer.ALSA.EventList as Ev @@ -25,8 +28,9 @@  import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import Control.Arrow ((<<<), arr)+import Control.Arrow ((^<<), (<<^)) import Control.Monad.Trans.State (evalState)+import Control.Applicative ((<$>))  import Control.Exception (bracket) @@ -57,35 +61,31 @@   -freq :: Option.SampleRate Real -> Real -> Real-freq (Option.SampleRate sampleRate) f =-   f / sampleRate-- pitchBend :: IO () pitchBend = do    opt <- Option.get    osc <--      SigP.runChunky-         ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))-             $* piecewiseConstant (arr id))+      Render.run $ \fm ->+         Causal.osci WaveL.triangle $< zero $* piecewiseConstant fm    withMIDIEvents opt play $ \chunkSize sampleRate ->       (id :: SigSt.T Real -> SigSt.T Real) .       osc chunkSize .-      evalState (PC.pitchBend (Option.channel opt) 2 (freq sampleRate 880))+      evalState (PC.pitchBend (Option.channel opt) 2 (frequency sampleRate 880))   frequencyModulation :: IO () frequencyModulation = do    opt <- Option.get    osc <--      SigP.runChunky-         (((CausalP.osciSimple WaveL.triangle $<# (zero::Real))-              <<< (MIDIL.frequencyFromBendModulation (frequencyConst (10::Real))))-           $* piecewiseConstant (arr (\(sr,ctrl) -> transposeModulation sr 880 ctrl)))+      Render.run $+      constant frequency 10 $ \speed _sr fm ->+         Causal.osci WaveL.triangle+            $< zero+            $* (MIDIL.frequencyFromBendModulation speed+                  $* piecewiseConstant (fmap BM.unMultiValue <$> fm))    withMIDIEvents opt play $ \chunkSize sampleRate ->       (id :: SigSt.T Real -> SigSt.T Real) .-      osc chunkSize . (,) sampleRate .+      osc chunkSize sampleRate . transposeModulation sampleRate 880 .       evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real))  @@ -100,10 +100,10 @@       (Instr.pingReleaseEnvelope $/ 0.4 $/ 0.1) -}    sound <- Instr.pingRelease $/ 0.4 $/ 0.1-   amp <- CausalP.runStorableChunky (CausalP.amplify (arr id))+   amp <- CausalRender.run Causal.amplify    arrange <- SigStL.makeArranger    withMIDIEvents opt play $ \chunkSize sampleRate ->-      (amp :: Real -> SigSt.T Real -> SigSt.T Real) 0.2 .+      pioApply (amp (0.2 :: Real)) .       arrange chunkSize .       evalState          (Gen.sequence@@ -114,10 +114,12 @@ keyboardStereo = do    opt <- Option.get    sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1-   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo (arr id))+   amp <-+      CausalRender.run $ \vol ->+         Stereo.multiValue ^<< Causal.amplifyStereo vol <<^ Stereo.unMultiValue    arrange <- SigStL.makeArranger    withMIDIEvents opt play $ \chunkSize sampleRate ->-      (amp :: Real -> SigSt.T (Stereo.T Real) -> SigSt.T (Stereo.T Real)) 0.2 .+      pioApply (amp (0.2 :: Real)) .       arrange chunkSize .       evalState          (Gen.sequence
alsa/Synthesizer/LLVM/Server/Scalar/Test.hs view
@@ -13,10 +13,10 @@ import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.Generic as Gen -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.Causal.Process (($<#), ($*))+import Synthesizer.LLVM.Causal.Process (($<), ($*))  import qualified Synthesizer.Storable.Cut         as CutSt import qualified Synthesizer.Storable.Signal      as SigSt@@ -24,7 +24,6 @@  import qualified Data.EventList.Relative.TimeBody  as EventList -import Control.Arrow (arr) import Control.Monad.Trans.State (evalState)  import NumericPrelude.Numeric (zero)@@ -34,9 +33,6 @@ chunkSize :: SVL.ChunkSize chunkSize = Play.defaultChunkSize -sampleRatePlain :: Real-sampleRatePlain = case Default.sampleRate of SampleRate r -> r- sampleRate :: SampleRate Real sampleRate = Default.sampleRate @@ -44,13 +40,12 @@ pitchBend0 :: IO () pitchBend0 = do    osc <--      SigP.runChunky-         ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))-             $* piecewiseConstant (arr id))+      Render.run $ \fm ->+         Causal.osci WaveL.triangle $< zero $* piecewiseConstant fm    SVL.writeFile "test.f32" $       (id :: SigSt.T Real -> SigSt.T Real) .       osc chunkSize .-      evalState (PC.pitchBend Default.channel 2 (880/sampleRatePlain)) $+      evalState (PC.pitchBend Default.channel 2 (frequency sampleRate 880)) $       let evs = EventList.cons 100 [] evs       in  EventList.cons 0 ([]::[Event.T]) evs @@ -58,13 +53,12 @@ pitchBend1 = do    opt <- Option.get    osc <--      SigP.runChunky-         ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))-             $* piecewiseConstant (arr id))+      Render.run $ \fm ->+         Causal.osci WaveL.triangle $< zero $* piecewiseConstant fm    withMIDIEvents opt (record "test.f32") $ \ _size _rate ->       (id :: SigSt.T Real -> SigSt.T Real) .       osc chunkSize .-      evalState (PC.pitchBend Default.channel 2 (880/sampleRatePlain))+      evalState (PC.pitchBend Default.channel 2 (frequency sampleRate 880))  pitchBend2 :: IO () pitchBend2 = do
+ example/Synthesizer/LLVM/ExampleUtility.hs view
@@ -0,0 +1,29 @@+module Synthesizer.LLVM.ExampleUtility where++import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import Type.Data.Num.Decimal (D4, D16)++import Data.Word (Word32)+++type Id a = a -> a++asMono :: Id (vector Float)+asMono = id++asStereo :: Id (vector (Stereo.T Float))+asStereo = id++asMonoPacked :: Id (vector (Serial.T D4 Float))+asMonoPacked = id++asMonoPacked16 :: Id (vector (Serial.T D16 Float))+asMonoPacked16 = id++asWord32 :: Id (vector Word32)+asWord32 = id++asWord32Packed :: Id (vector (Serial.T D4 Word32))+asWord32Packed = id
example/Synthesizer/LLVM/LAC2011.hs view
@@ -2,6 +2,8 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Synthesizer.LLVM.LAC2011 where +import Synthesizer.LLVM.ExampleUtility+ import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth@@ -11,34 +13,32 @@ import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P import qualified Synthesizer.LLVM.Filter.Moog as Moog import qualified Synthesizer.LLVM.Filter.Universal as UniFilter-import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV+import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.Signal as Gen+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.SignalPacked as GenP+import qualified Synthesizer.LLVM.Generator.Signal as Gen import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Parameter as Param +import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)+ import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Tuple as Tuple-import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf)-import LLVM.Util.Arithmetic () -- Floating instance for TValue+ import qualified LLVM.Core as LLVM-import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8)+ import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8) -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS-import qualified Synthesizer.LLVM.Parameterized.Signal as GenP import Synthesizer.LLVM.Causal.Process (($<), ($*), ($*#))-import Synthesizer.LLVM.Parameter (($#))  import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core@@ -70,7 +70,6 @@ -- import qualified Sound.ALSA.PCM as ALSA -- import qualified Synthesizer.ALSA.Storable.Play as Play -import Data.Word (Word32) import Data.List (genericLength) import System.Random (randomRs, mkStdGen) @@ -85,52 +84,23 @@ import qualified NumericPrelude.Base as P  -asMono :: vector Float -> vector Float-asMono = id--asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)-asStereo = id--asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float)-asMonoPacked = id--asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float)-asMonoPacked16 = id--asWord32 :: vector Word32 -> vector Word32-asWord32 = id--asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32)-asWord32Packed = id---playStereo :: Gen.T (Stereo.T (Value Float)) -> IO ()-playStereo =-   playStereoStream .-   Gen.renderChunky (SVL.chunkSize 100000)+playStereo :: Gen.T (Stereo.T (MultiValue.T Float)) -> IO ()+playStereo sig =+   playStereoStream . ($ SVL.chunkSize 100000) =<<+   Render.run (fmap Stereo.multiValue sig)  playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () playStereoStream = playStreamSox -playMono :: Gen.T (Value Float) -> IO ()-playMono =-   playMonoStream .-   Gen.renderChunky (SVL.chunkSize 100000)--playMonoParam :: GenP.T () (Value Float) -> IO ()-playMonoParam =-   playMonoStream .-   ($ ()) .-   ($ SVL.chunkSize 100000) <=<-   GenP.runChunky+playMono :: Gen.MV Float -> IO ()+playMono sig  =  playMonoStream . ($ SVL.chunkSize 100000) =<< Render.run sig -playMonoPacked :: GenP.T () (Serial.Value D4 Float) -> IO ()+playMonoPacked :: Gen.T (MultiValue.T (Serial.T D4 Float)) -> IO () playMonoPacked =    playMonoStream .    SigStL.unpack .-   ($ ()) .    ($ SVL.chunkSize 100000) <=<-   GenP.runChunky+   Render.run  playMonoStream :: SVL.Vector Float -> IO () playMonoStream = playStreamSox@@ -139,7 +109,7 @@ {- play ::    (C.MakeValueTuple y, Tuple.ValueOf y ~ a, Memory.C a struct) =>-   Gen.T a -> IO ()+   Gen.MV a -> IO () play =    playStreamSox .    Gen.renderChunky (SVL.chunkSize 100000)@@ -167,26 +137,12 @@ intSecond :: Ring.C a => Float -> a intSecond t = fromInteger $ round $ t * sampleRate -secondP :: Param.T p Float -> Param.T p Float-secondP t = t * sampleRate--hertzP :: Param.T p Float -> Param.T p Float-hertzP f = f / sampleRate- second :: Field.C a => a -> a second t = t * sampleRate  hertz :: Field.C a => a -> a hertz f = f / sampleRate -{--second :: Float -> Param.T p Float-second t = return (t * sampleRate)--hertz :: Float -> Param.T p Float-hertz f = return (f / sampleRate)--}- sine :: IO () sine =    playMono (0.99 * Gen.osci Wave.sine 0 (hertz 440))@@ -209,18 +165,11 @@    playStereo (traverse (Gen.osci Wave.triangle 0 . hertz) (Stereo.cons 439 441))  -fst :: Arrow arrow => arrow (a,b) a-fst = arr P.fst--snd :: Arrow arrow => arrow (a,b) b-snd = arr P.snd-- pingParam :: IO (Float -> SVL.Vector Float) pingParam =    fmap ($ SVL.chunkSize 1024) $-   GenP.runChunky $-   GenP.exponential2 (second 0.3) 1 * GenP.osciSimple Wave.triangle 0 id+   Render.run $ \freq ->+   Gen.exponential2 (second 0.3) 1 * Gen.osci Wave.triangle 0 freq  playPingParam :: IO () playPingParam = do@@ -240,8 +189,8 @@ pingParam2 :: IO ((Float, Float) -> SVL.Vector Float) pingParam2 =    fmap ($ SVL.chunkSize 1024) $-   GenP.runChunky $-   GenP.exponential2 (second 0.3) fst * GenP.osciSimple Wave.triangle 0 snd+   Render.run $ \(amp,freq) ->+   Gen.exponential2 (second 0.3) amp * Gen.osci Wave.triangle 0 freq  playMelody2 :: IO () playMelody2 = do@@ -249,86 +198,57 @@    playMonoStream $ SVL.concat $ map (SVL.take (intSecond 0.2) . png) $ zip (map sin $ [0,0.1..]) (cycle $ map hertz [440, 550, 660, 880])  -retard :: GenP.T p (Value Float) -> GenP.T p (Value Float)+retard :: Gen.MV Float -> Gen.MV Float retard xs =-   CausalP.frequencyModulationLinear xs .-   CausalV.map Field.recip $*-   GenP.rampCore (1 / secondP 10) 1+   Causal.frequencyModulationLinear xs .+   Causal.map Field.recip $*+   (1 + Gen.rampInf (second 10))  playRetarded :: IO () playRetarded = do    mel <- melody-   playMonoParam $ retard $ GenP.fromStorableVectorLazy $ pure $ mel+   ret <- Render.run retard+   playMonoStream $ ret (SVL.chunkSize 10000) mel   -pingGen :: GenP.T p (Value Float)+pingGen :: Gen.MV Float pingGen =-   GenP.exponential2 (second 0.5) 0.7 *-   GenP.osciSimple Wave.triangle 0 (hertzP 440)--delayp :: Param.T p Int -> CausalP.T p (Value Float) (Value Float)-delayp = CausalP.delayZero+   Gen.exponential2 (second 0.5) 0.7 *+   Gen.osci Wave.triangle 0 (hertz 440)  delay :: IO () delay =-   playMonoParam $-      pingGen + 0.7 * (delayp (intSecond 0.5) $* pingGen)+   playMono $+      pingGen + 0.7 * (Causal.delay 0 (intSecond 0.5) $* pingGen)  delayArrow :: IO () delayArrow =-   playMonoParam-      ((id + 0.7 * delayp (intSecond 0.5)) $* pingGen)+   playMono+      ((id + 0.7 * Causal.delay 0 (intSecond 0.5)) $* pingGen)  comb :: IO () comb =-   playMonoParam $-      (CausalP.loopZero-          (id  &&&  0.7 * delayp (intSecond 0.5)-             <<< CausalP.mix) $*+   playMono $+      (Causal.loopZero+          (id  &&&  0.7 * Causal.delay 0 (intSecond 0.5)+             <<< Causal.mix) $*        pingGen)  -lfoSine ::-   Param.T p Float ->-   GenP.T p (Moog.Parameter D8 (Value Float))+lfoSine :: Exp Float -> Gen.T (Moog.Parameter D8 (MultiValue.T Float)) lfoSine reduct =-   Causal.map (Moog.parameter d8 (valueOf (30::Float))) .-   CausalP.mapExponential 2 (hertz 700) $*-   GenP.osciSimple Wave.sine 0 (reduct * hertz 0.1)+   Causal.map (Moog.parameter d8 30 . (hertz 700 *) . (2**))+   $*+   Gen.osci Wave.sine 0 (reduct * hertz 0.1)  filterSweep :: IO () filterSweep =-   playMonoParam $-      (0.2 * CtrlP.processCtrlRate 128 lfoSine-       $* GenP.noise 0 0.3)+   playMono $+      (Ctrl.processCtrlRate 128 lfoSine $* Gen.noise 0 (recip $ hertz 3.5e6))   pingPacked :: IO () pingPacked =-   playMonoPacked (GenPS.exponential2 (second 1) 1 * GenPS.osciSimple Wave.triangle 0 (hertz 440))----{--Module can be loaded into GHCi only when synthesizer-llvm was installed with-$ cabal install --enable-shared--In contrast to that, you have to install with-$ cabal install -fbuildTests -fbuildExamples --enable-shared --disable-library-profiling --ghc-option=-dynamic-for build the executables.-But then GHCi complains:--$ ghci-GHCi, version 6.12.3: http://www.haskell.org/ghc/  :? for help-Loading package ghc-prim ... linking ... done.-Loading package integer-gmp ... linking ... done.-Loading package base ... linking ... done.-Loading package ffi-1.0 ... linking ... done.-[1 of 1] Compiling Main             ( src/Synthesizer/LLVM/Test.hs, interpreted )--src/Synthesizer/LLVM/Test.hs:4:0:-    Bad interface file: /home/thielema/.cabal/lib/synthesizer-llvm-0.3/ghc-6.12.3/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hi-        mismatched interface file ways (wanted "", got "dyn")-Failed, modules loaded: none.--}+   playMonoPacked $+      GenP.exponential2 (second 1) 1 * GenP.osci Wave.triangle 0 (hertz 440)
example/Synthesizer/LLVM/LNdW2011.hs view
@@ -1,17 +1,27 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Synthesizer.LLVM.LNdW2011 where +import Synthesizer.LLVM.ExampleUtility++import qualified Synthesizer.LLVM.Causal.Render as Render+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as SigRender+import qualified Synthesizer.LLVM.Generator.SignalPacked as GenP+import qualified Synthesizer.LLVM.Generator.Signal as Gen+ import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS import qualified Synthesizer.MIDI.EventList as Ev import qualified Synthesizer.MIDI.CausalIO.ControllerSelection as MCS import qualified Synthesizer.MIDI.CausalIO.Process as PMIDI+import qualified Synthesizer.MIDI.Value as MV import qualified Synthesizer.ALSA.CausalIO.Process as PALSA import qualified Synthesizer.CausalIO.Process as PIO-import qualified Synthesizer.MIDI.Value as MV import qualified Synthesizer.Zip as Zip import Synthesizer.ALSA.EventList (ClientName(ClientName)) @@ -28,34 +38,28 @@ import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P import qualified Synthesizer.LLVM.Filter.Moog as Moog import qualified Synthesizer.LLVM.Filter.Universal as UniFilter-import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.Signal as Gen-import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Parameter as Param +import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Core as LLVM import LLVM.Core (Value, value, valueOf, constVector, constOf) import LLVM.Util.Arithmetic () -- Floating instance for TValue-import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8) -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS-import qualified Synthesizer.LLVM.Parameterized.Signal as GenP-import Synthesizer.LLVM.Causal.Process (($<), ($*), ($*#), ($<#))-import Synthesizer.LLVM.Parameter (($#))+import qualified Synthesizer.Causal.Class as CausalClass+import Synthesizer.Causal.Class (($<), ($*))  import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core@@ -65,17 +69,17 @@  import qualified Control.Monad.Trans.State as State import qualified Control.Arrow as Arr-import Control.Arrow (Arrow, arr, (&&&), (^<<), (^>>))+import Control.Arrow (Arrow, arr, (&&&), (***), (^<<), (^>>), (>>^)) import Control.Category ((<<<), (.), id, (>>>)) import Control.Monad (liftM2, (<=<))-import Control.Applicative (liftA2, pure)+import Control.Applicative (liftA2, pure, (<$>)) import Control.Functor.HT (void) import Data.Tuple.HT (mapPair) import Data.Traversable (traverse) -import Foreign.Storable (Storable) import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)  import qualified Data.EventList.Relative.TimeBody  as EventList import qualified Data.EventList.Relative.BodyTime  as EventListBT@@ -95,13 +99,13 @@ import qualified Sound.ALSA.PCM as ALSA import qualified Synthesizer.ALSA.Storable.Play as Play -import Data.Word (Word32) import Data.List (genericLength) import System.Random (randomRs, mkStdGen)  import qualified System.IO as IO  import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.Algebraic as Algebraic import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive@@ -112,52 +116,24 @@ import qualified NumericPrelude.Base as P  -asMono :: vector Float -> vector Float-asMono = id--asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)-asStereo = id--asMonoPacked :: vector Vector -> vector Vector-asMonoPacked = id--asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float)-asMonoPacked16 = id--asWord32 :: vector Word32 -> vector Word32-asWord32 = id--asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32)-asWord32Packed = id---playStereo :: Gen.T (Stereo.T (Value Float)) -> IO ()-playStereo =-   playStereoStream .-   Gen.renderChunky (SVL.chunkSize 100000)+playStereo :: Gen.T (Stereo.T (MultiValue.T Float)) -> IO ()+playStereo sig =+   playStereoStream . ($ SVL.chunkSize 100000) =<<+   SigRender.run (fmap Stereo.multiValue sig)  playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () playStereoStream = playStreamSox -playMono :: Gen.T (Value Float) -> IO ()-playMono =-   playMonoStream .-   Gen.renderChunky (SVL.chunkSize 100000)--playMonoParam :: GenP.T () (Value Float) -> IO ()-playMonoParam =-   playMonoStream .-   ($ ()) .-   ($ SVL.chunkSize 100000) <=<-   GenP.runChunky+playMono :: Gen.MV Float -> IO ()+playMono sig =+   playMonoStream . ($ SVL.chunkSize 100000) =<< SigRender.run sig -playMonoPacked :: GenP.T () VectorValue -> IO ()+playMonoPacked :: Gen.T VectorValue -> IO () playMonoPacked =    playMonoStream .    SigStL.unpack .-   ($ ()) .    ($ SVL.chunkSize 100000) <=<-   GenP.runChunky+   SigRender.run  playMonoStream :: SVL.Vector Float -> IO () playMonoStream = playStreamSox@@ -180,9 +156,9 @@ sampleRate :: Ring.C a => a sampleRate = 44100 -type Vector = Serial.Plain VectorSize Float+type Vector = Serial.T VectorSize Float type VectorSize = TypeNum.D4-type VectorValue = Serial.Value VectorSize Float+type VectorValue = MultiValue.T Vector  vectorSize :: Int vectorSize =@@ -226,11 +202,9 @@  modulation :: IO () modulation = do-   proc <--      CausalP.processIO-         (0.95 * (CausalP.osciSimple Wave.approxSine4 $< 0))+   proc <- Render.run (0.95 * (Causal.osci Wave.approxSine4 $< 0))    playFromEvents 0.01 (0.015::Double)-      ((proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float))+      ((proc :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float))        .        PMIDI.controllerExponential          (ChannelMsg.toChannel 0)@@ -241,32 +215,31 @@ vectorBlockSize :: Double vectorBlockSize = fromIntegral $ 150*vectorSize -subsample :: (Integral.C t) => t -> t -> State.State t t-subsample step t =-   State.state $ \r -> divMod (r+t) step-{--   do modify (t+)-      (q,r) <- gets (flip divMod step)-      put r-      return q--}+subsample, _subsample :: (Integral.C t) => t -> t -> State.State t t+subsample step t  =  State.state $ \r -> divMod (r+t) step+_subsample step t = do+   State.modify (t+)+   (q,r) <- State.gets (flip divMod step)+   State.put r+   return q  subsampleBT :: EventListBT.T NonNegW.Int a -> EventListBT.T NonNegW.Int a subsampleBT =    flip State.evalState NonNeg.zero .-   EventListBT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" vectorSize))+   EventListBT.mapTimeM+      (subsample (NonNegW.fromNumberMsg "vectorSize" vectorSize))  modulationPacked :: IO () modulationPacked = do    proc <--      CausalP.processIO-         (0.95 * (CausalPS.osciSimple Wave.approxSine4 $< 0)+      Render.run+         (0.95 * (CausalP.osci Wave.approxSine4 $< 0)           .           Causal.map Serial.upsample)    playFromEvents 0.01 (vectorBlockSize/sampleRate)       (arr SigStL.unpackStrict        .-       (proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector))+       (proc :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector))        .        arr subsampleBT        .@@ -279,14 +252,14 @@ bubbles :: IO () bubbles = do    proc <--      CausalP.processIO-         (0.95 * (CausalP.osciSimple Wave.sine $< 0)+      Render.run+         (0.95 * (Causal.osci Wave.sine $< 0)           .           (fst.fst * (1 + snd.fst * snd))           .-          Arr.second (CausalP.osciSimple Wave.saw $< 0))+          Arr.second (Causal.osci Wave.saw $< 0))    playFromEvents 0.01 (0.015::Double)-      ((proc () ::+      ((proc ::            PIO.T               (Zip.T                  (Zip.T@@ -327,23 +300,23 @@ bubblesSet :: IO () bubblesSet = do    proc <--      CausalP.processIOCore+      Render.runPlugged          (PIn.controllerSet d6)-         (CausalP.arrayElement d0 *-          (CausalP.osciSimple Wave.sine $< 0)+         (Causal.arrayElement d0 *+          (Causal.osci Wave.sine $< 0)           .-          (CausalP.arrayElement d1+          (Causal.arrayElement d1            *-           (1 - CausalP.arrayElement d2 *-              (CausalP.osciSimple Wave.saw $< 0) .-              CausalP.arrayElement d3)+           (1 - Causal.arrayElement d2 *+              (Causal.osci Wave.saw $< 0) .+              Causal.arrayElement d3)            *-           (1 - CausalP.arrayElement d4 *-              (CausalP.osciSimple Wave.saw $< 0) .-              CausalP.arrayElement d5)))+           (1 - Causal.arrayElement d4 *+              (Causal.osci Wave.saw $< 0) .+              Causal.arrayElement d5)))          POut.storableVector    playFromEvents 0.01 (0.015::Double)-      ((proc () :: PIO.T (PCS.T Int Float) (SV.Vector Float))+      ((proc :: PIO.T (PCS.T Int Float) (SV.Vector Float))        .        bubbleControl) @@ -357,25 +330,25 @@ bubblesPacked :: IO () bubblesPacked = do    proc <--      CausalP.processIOCore+      Render.runPlugged          (PIn.controllerSet d6)-         (CausalPS.arrayElement d0 *-          (CausalPS.osciSimple Wave.approxSine4 $< 0)+         (CausalP.arrayElement d0 *+          (CausalP.osci Wave.approxSine4 $< 0)           .-          (CausalPS.arrayElement d1+          (CausalP.arrayElement d1            *-           (1 - CausalPS.arrayElement d2 *-              (CausalPS.osciSimple Wave.saw $< 0) .-              CausalPS.arrayElement d3)+           (1 - CausalP.arrayElement d2 *+              (CausalP.osci Wave.saw $< 0) .+              CausalP.arrayElement d3)            *-           (1 - CausalPS.arrayElement d4 *-              (CausalPS.osciSimple Wave.saw $< 0) .-              CausalPS.arrayElement d5)))+           (1 - CausalP.arrayElement d4 *+              (CausalP.osci Wave.saw $< 0) .+              CausalP.arrayElement d5)))          POut.storableVector    playFromEvents 0.01 (vectorBlockSize/sampleRate)       (arr SigStL.unpackStrict        .-       (proc () :: PIO.T (PCS.T Int Float) (SV.Vector Vector))+       (proc :: PIO.T (PCS.T Int Float) (SV.Vector Vector))        .        arr subsamplePCS        .@@ -389,88 +362,79 @@ that cannot be satisfied with @LLVM.Vector@s. -} moveAround2dLifted ::-   (A.Transcendental v, v ~ A.Scalar v, A.PseudoModule v,-    A.Real v, A.RationalConstant v) =>-   Value.T v -> Value.T v -> (Value.T v, Value.T v) ->-   CausalP.T p (v, v) (v, v)+   (Expr.Aggregate ve vl, Algebraic.C ve, NormedEuc.Sqr ve ve) =>+   ve -> ve -> (ve, ve) -> Causal.T (vl, vl) (vl, vl) moveAround2dLifted att sonicDelay ear =-   Causal.map-      (uncurry $ Value.unlift2 $ curry $ Spatial.moveAround att sonicDelay ear)+   Causal.map (Spatial.moveAround att sonicDelay ear)  moveAround2d ::-   (A.Algebraic v, A.RationalConstant v) =>-   Value.T v -> Value.T v -> (Value.T v, Value.T v) ->-   CausalP.T p (v, v) (v, v)+   (ve ~ Exp v, vl ~ MultiValue.T v,+    MultiValue.Algebraic v, MultiValue.RationalConstant v) =>+   ve -> ve -> (ve, ve) -> Causal.T (vl, vl) (vl, vl) moveAround2d att sonicDelay ear =-   Causal.map $ Value.flattenFunction $+   Causal.map $       (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) .       euclideanNorm2d . subtract ear  euclideanNorm2d ::-   (A.Algebraic a) =>-   (Value.T a, Value.T a) -> Value.T a-euclideanNorm2d (x,y) =-   Value.sqrt $ Value.square x + Value.square y--mapFunc ::-   (Value.Flatten a, Value.Flatten b) =>-   (a -> b) ->-   CausalP.T p (Value.Registers a) (Value.Registers b)-mapFunc f =-   Causal.map (Value.flattenFunction f)+   (MultiValue.Algebraic a) =>+   (Exp a, Exp a) -> Exp a+euclideanNorm2d (x,y) = Expr.sqrt $ Expr.sqr x + Expr.sqr y  flyChannel ::-   (Value.T (Value Float), Value.T (Value Float)) ->-   CausalP.T p (Value Float, (Value Float, Value Float)) (Value Float)+   (ae ~ Exp Float, al ~ MultiValue.T Float) =>+   (ae, ae) -> Causal.T (al, (al, al)) al flyChannel ear =    ((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id))     &&&     (Arr.second-        (2 * ((CausalP.differentiate $# (0::Float, 0::Float))-              >>>-              mapFunc euclideanNorm2d))+         (2 * (Causal.differentiate (0,0) >>> Causal.map euclideanNorm2d))      >>>-     CausalP.mix))+     Causal.mix))    >>>    arr (\((phase,volume), speed) -> (volume, (phase,speed)))    >>>-   Arr.second (CausalP.osciSimple Wave.saw)+   Arr.second (Causal.osci Wave.saw)    >>>-   (CausalP.envelope * 10)+   (Causal.envelope * 10)  fly :: IO () fly = do-   let slow, fast :: CausalP.T p (Value Float) (Value Float)+   let slow, fast :: Causal.T (MultiValue.T Float) (MultiValue.T Float)        slow =-          Filt1.lowpassCausal $<#-          Filt1Core.parameter (1/sampleRate::Float)+          Filt1.lowpassCausal $<+          Gen.constant (Filt1Core.parameter (1/sampleRate :: Exp Float))        fast =-          Filt1.lowpassCausal $<#-          Filt1Core.parameter (30/sampleRate::Float)+          Filt1.lowpassCausal $<+          Gen.constant (Filt1Core.parameter (30/sampleRate :: Exp Float))    proc <--      CausalP.processIOCore+      Render.runPlugged          (PIn.controllerSet d5)-         ((CausalP.arrayElement d0 &&&+         ((Causal.arrayElement d0 &&&            (liftA2 (,)-               (CausalP.arrayElement d2)+               (Causal.arrayElement d2)                (liftA2 (,)-                   ((CausalP.arrayElement d3 >>> slow)+                   ((Causal.arrayElement d3 >>> slow)                     +-                    CausalP.arrayElement d1 *-                    (CausalP.fromSignal (GenP.noise 366210 0.3) >>> fast >>> fast))-                   ((CausalP.arrayElement d4 >>> slow)+                    Causal.arrayElement d1 *+                    (CausalClass.fromSignal (Gen.noise 366210 0.3)+                        >>> fast >>> fast))+                   ((Causal.arrayElement d4 >>> slow)                     +-                    CausalP.arrayElement d1 *-                    (CausalP.fromSignal (GenP.noise 234298 0.3) >>> fast >>> fast)))+                    Causal.arrayElement d1 *+                    (CausalClass.fromSignal (Gen.noise 234298 0.3)+                        >>> fast >>> fast)))             >>>             liftA2 Stereo.cons                (flyChannel (-1,0))                (flyChannel ( 1,0))))           >>>-          CausalP.envelopeStereo)+          Causal.envelopeStereo+          >>^+          Stereo.multiValue)          POut.storableVector    playFromEvents 0.01 (0.015::Double)-      ((proc () :: PIO.T (PCS.T Int Float) (SV.Vector (Stereo.T Float)))+      ((proc :: PIO.T (PCS.T Int Float) (SV.Vector (Stereo.T Float)))        .        MCS.filter [           MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2,@@ -483,64 +447,66 @@   flyChannelPacked ::-   (Value.T VectorValue, Value.T VectorValue) ->-   CausalP.T p (VectorValue, (VectorValue, VectorValue)) VectorValue+   (ae ~ Exp Vector, al ~ VectorValue) =>+   (ae, ae) -> Causal.T (al, (al, al)) al flyChannelPacked ear =    ((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id))     &&&     (Arr.second-        (2 * ((CausalPS.differentiate $# (0::Float, 0::Float))-              >>>-              mapFunc euclideanNorm2d))+         (2 * (CausalP.differentiate 0 *** CausalP.differentiate 0+               >>>+               Causal.map euclideanNorm2d))      >>>-     CausalP.mix))+     Causal.mix))    >>>    arr (\((phase,volume), speed) -> (volume, (phase,speed)))    >>>-   Arr.second (CausalPS.osciSimple Wave.saw)+   Arr.second (CausalP.osci Wave.saw)    >>>-   CausalP.envelope+   Causal.envelope    >>>-   CausalPS.amplify 10+   CausalP.amplify 10   flyPacked :: IO () flyPacked = do-   let slow, fast :: CausalP.T p VectorValue VectorValue+   let slow, fast :: Causal.T VectorValue VectorValue        slow =-          Filt1.lowpassCausalPacked $<#-          Filt1Core.parameter (1/sampleRate::Float)+          Filt1.lowpassCausalPacked $<+          Gen.constant (Filt1Core.parameter (1/sampleRate :: Exp Float))        fast =-          Filt1.lowpassCausalPacked $<#-          Filt1Core.parameter (30/sampleRate::Float)+          Filt1.lowpassCausalPacked $<+          Gen.constant (Filt1Core.parameter (30/sampleRate :: Exp Float))    proc <--      CausalP.processIOCore+      Render.runPlugged          (PIn.controllerSet d5)-         ((CausalPS.arrayElement d0 &&&+         ((CausalP.arrayElement d0 &&&            (liftA2 (,)-               (CausalPS.arrayElement d2)+               (CausalP.arrayElement d2)                (liftA2 (,)-                  ((CausalPS.arrayElement d3 >>> slow)+                  ((CausalP.arrayElement d3 >>> slow)                    +-                   CausalPS.arrayElement d1 *-                   (CausalP.fromSignal (GenPS.noise 366210 0.3) >>> fast >>> fast))-                  ((CausalPS.arrayElement d4 >>> slow)+                   CausalP.arrayElement d1 *+                   (CausalClass.fromSignal (GenP.noise 366210 0.3)+                        >>> fast >>> fast))+                  ((CausalP.arrayElement d4 >>> slow)                    +-                   CausalPS.arrayElement d1 *-                   (CausalP.fromSignal (GenPS.noise 234298 0.3) >>> fast >>> fast)))+                   CausalP.arrayElement d1 *+                   (CausalClass.fromSignal (GenP.noise 234298 0.3)+                        >>> fast >>> fast)))             >>>             liftA2 Stereo.cons                (flyChannelPacked (-1,0))                (flyChannelPacked ( 1,0))))           >>>-          CausalP.envelopeStereo-          >>>-          Causal.map StereoInt.interleave)+          Causal.envelopeStereo+          >>^+          Stereo.multiValueSerial)          POut.storableVector    playFromEvents 0.01 (vectorBlockSize/sampleRate)-      (arr SigStL.unpackStereoStrict+      (arr SigStL.unpackStrict        .-       (proc () :: PIO.T (PCS.T Int Float) (SV.Vector (StereoInt.T VectorSize Float)))+       (proc :: PIO.T (PCS.T Int Float) (SV.Vector (Serial.T VectorSize (Stereo.T Float))))        .        arr subsamplePCS        .
example/Synthesizer/LLVM/Test.hs view
@@ -1,2005 +1,1926 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module Main where--import Synthesizer.LLVM.LAC2011 ()--import qualified Synthesizer.LLVM.Server.Default as Default-import qualified Synthesizer.LLVM.Server.SampledSound as Sample--import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass-import qualified Synthesizer.LLVM.Filter.Allpass as Allpass-import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth-import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev-import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1-import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2-import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P-import qualified Synthesizer.LLVM.Filter.Moog as Moog-import qualified Synthesizer.LLVM.Filter.Universal as UniFilter-import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR-import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func-import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix-import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Interpolation as Interpolation-import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified Synthesizer.LLVM.Simple.Value as Value-import qualified Synthesizer.LLVM.Storable.Signal as SigStL-import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Parameter as Param-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&))-import Synthesizer.LLVM.Causal.Process (($<), ($>), ($*), ($*#))-import Synthesizer.LLVM.Simple.Value ((%>), (%&&))-import Synthesizer.LLVM.Parameter (($#))--import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Frame as Frame--import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Maybe as Maybe--import qualified LLVM.Core as LLVM-import LLVM.Core (Value, valueOf, Vector)-import LLVM.Util.Arithmetic () -- Floating instance for TValue--import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (D4, D8, D16)-import Type.Base.Proxy (Proxy)--import qualified Synthesizer.CausalIO.Process as PIO-import qualified Synthesizer.Causal.Class as CausalClass-import qualified Synthesizer.Zip as Zip-import qualified Synthesizer.State.Control as CtrlS-import qualified Synthesizer.State.Signal as SigS--import qualified Synthesizer.Plain.Filter.Recursive as FiltR-import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core-import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core--import Control.Arrow (Arrow, arr, (&&&), (^<<), (<<^), (***))-import Control.Category ((<<<), (.), id)-import Control.Applicative (pure, liftA2)-import Control.Functor.HT (void)-import Control.Monad (when)--import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import Foreign.Storable (Storable)--import qualified Data.EventList.Relative.TimeBody  as EventList-import qualified Data.EventList.Relative.BodyTime  as EventListBT-import qualified Data.EventList.Relative.MixedTime as EventListMT-import qualified Data.EventList.Relative.TimeMixed as EventListTM-import qualified Numeric.NonNegative.Wrapper as NonNeg--import qualified Sound.Sox.Option.Format as SoxOption-import qualified Sound.Sox.Play as SoxPlay--- import qualified Synthesizer.ALSA.Storable.Play as Play--import qualified Data.NonEmpty.Class as NonEmptyC-import qualified Data.NonEmpty as NonEmpty-import Data.NonEmpty ((!:))-import Data.Traversable (sequenceA)-import Data.Word (Word32)-import Data.List (genericLength)-import System.Path ((</>))-import System.Random (randomRs, mkStdGen)--import qualified System.IO as IO-import Control.Exception (bracket)--import Prelude hiding (fst, snd, id, (.))-import qualified NumericPrelude.Numeric as NP-import qualified Prelude as P---asMono :: vector Float -> vector Float-asMono = id--asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)-asStereo = id--asMonoPacked :: vector (Serial.Plain D4 Float) -> vector (Serial.Plain D4 Float)-asMonoPacked = id--asMonoPacked16 :: vector (Serial.Plain D16 Float) -> vector (Serial.Plain D16 Float)-asMonoPacked16 = id--asStereoInterleaved :: vector (StereoInt.T D4 Float) -> vector (StereoInt.T D4 Float)-asStereoInterleaved = id--asWord32 :: vector Word32 -> vector Word32-asWord32 = id--asWord32Packed :: vector (Serial.Plain D4 Word32) -> vector (Serial.Plain D4 Word32)-asWord32Packed = id---{- |-> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01)--Unfortunately: If you call :reload,-then the next attempt to play something will be answered by:--ghci: JITEmitter.cpp:110: <unnamed>::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed.--}-playStereo :: Sig.T (Stereo.T (Value Float)) -> IO ()-playStereo =-   playStereoVector .-   Sig.renderChunky (SVL.chunkSize 100000)--playStereoVector :: SVL.Vector (Stereo.T Float) -> IO ()-playStereoVector =-   void . SoxPlay.simple SVL.hPut SoxOption.none 44100--playMono :: Sig.T (Value Float) -> IO ()-playMono =-   playMonoVector .-   Sig.renderChunky (SVL.chunkSize 100000)--playMonoVector :: SVL.Vector Float -> IO ()-playMonoVector =-   void . SoxPlay.simple SVL.hPut SoxOption.none 44100---playFileMono :: FilePath -> IO ()-playFileMono fileName = do-   IO.withFile fileName IO.ReadMode $ \h ->-      playStereo .-      Sig.fromStorableVectorLazy .-      asStereo . snd-       =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h-   return ()---frequency :: Float -> Param.T p Float-frequency = return--{- |-Assist GHC-7.10.3 with determining the type of causal processes.-GHC-7.8.4 and GHC-8.0.1 do not need it.--}-causalP :: CausalP.T p a b -> CausalP.T p a b-causalP = id---constant :: Float -> IO ()-constant y =-   SV.writeFile "speedtest.f32" $ asMono $ flip Sig.render 1000 $ Sig.constant y--saw :: IO ()-saw =-   SV.writeFile "speedtest.f32" $-   asMono $-   flip Sig.render 10000000 $-   Sig.osciSaw 0 0.01--exponential :: IO ()-exponential =-   SV.writeFile "speedtest.f32" $-   asMono $-   flip Sig.render 10000000 $-   Sig.exponential2 50000 1--triangle :: IO ()-triangle =-   SV.writeFile "speedtest.f32" $-   asMono $-   flip Sig.render 10000000 $-   Sig.osci Wave.triangle 0.25 0.01--trianglePack :: IO ()-trianglePack =-   SV.writeFile "speedtest.f32" $-   asMonoPacked $-   (\xs -> SigP.render xs (div 10000000 4) ()) $-   Sig.map Wave.triangle $-   SigPS.packSmall $-   SigP.osciCore 0.25 (frequency 4.015803e-4)--trianglePacked :: IO ()-trianglePacked =-   SV.writeFile "speedtest.f32" $-   asMonoPacked $-   (\xs -> SigP.render xs (div 10000000 4) ()) $-   (causalP (CausalPS.osciSimple Wave.triangle)-     $< SigPS.constant 0.25-     $* SigPS.constant 0.01)--triangleReplicate :: IO ()-triangleReplicate =-   SV.writeFile "speedtest.f32" $-   asMonoPacked $-   (\xs -> SigP.render xs (div 10000000 4) ()) $-   (causalP-     (CausalPS.shapeModOsci-       (\k p -> do-           x <- Wave.triangle =<< Wave.replicate k p-           y <- Wave.approxSine4 =<< Wave.halfEnvelope p-           A.mul x y))-     $< SigPS.rampInf 1000000-     $< SigPS.constant 0-     $* SigPS.constant 0.01)--rationalSine :: IO ()-rationalSine =-   SV.writeFile "speedtest.f32" $-   asMonoPacked $-   (\xs -> SigP.render xs (div 10000000 4) ()) $-   (causalP (CausalPS.shapeModOsci Wave.rationalApproxSine1)-     $< (0.001 + SigPS.rampInf 10000000)-     $< SigPS.constant 0-     $* SigPS.constant 0.01)--rationalSineStereo :: IO ()-rationalSineStereo =-   SV.writeFile "speedtest.f32" $-   SigStL.unpackStereoStrict $-   asStereoInterleaved $-   (\xs -> SigP.render xs (div 10000000 4) ()) $-   Sig.map StereoInt.interleave $-   liftA2 Stereo.cons-      (causalP (CausalPS.shapeModOsci Wave.rationalApproxSine1)-        $< (0.001 + SigPS.rampInf 10000000)-        $< SigPS.constant (-0.25)-        $* SigPS.constant 0.00999)-      (causalP (CausalPS.shapeModOsci Wave.rationalApproxSine1)-        $< (0.001 + SigPS.rampInf 10000000)-        $< SigPS.constant 0.25-        $* SigPS.constant 0.01001)---pingSig :: Float -> Sig.T (Value Float)-pingSig freq =-   Sig.envelope-      (Sig.exponential2 50000 1)-      (Sig.osciSaw 0.5 freq)--pingSigP :: Param.T p Float -> SigP.T p (Value Float)-pingSigP freq =-   SigP.envelope-      (SigP.exponential2 50000 1)-      (SigP.osciSaw 0.5 freq)--ping :: IO ()-ping =-   SV.writeFile "speedtest.f32" $-   asMono $-   flip Sig.render 10000000 $-   pingSig 0.01--pingSigPacked :: SigP.T Float (Serial.Value D4 Float)-pingSigPacked =-   let freq = id-   in  SigP.envelope-          (SigPS.exponential2 50000 1)-          (SigPS.osciSimple Wave.saw 0 freq)--pingPacked :: IO ()-pingPacked =-   SV.writeFile "speedtest.f32" $-   asMonoPacked $-   (\xs -> SigP.render xs (div 10000000 4) 0.01) $-   pingSigPacked--pingUnpack :: IO ()-pingUnpack =-   SV.writeFile "speedtest.f32" $-   asMono $-   (\xs -> SigP.render xs 10000000 0.01) $-   SigPS.unpack $-   pingSigPacked--pingSmooth :: IO ()-pingSmooth =-   SV.writeFile "speedtest-scalar.f32" $-   asMono $-   (\xs -> SigP.render xs 10000000 ()) $-   (causalP Filt1.lowpassCausal-     $< (fmap Filt1Core.Parameter $-         1 - (Sig.exponential2 50000 1))-     $* SigP.osciSimple Wave.triangle 0 (frequency 0.01))--pingSmoothPacked :: IO ()-pingSmoothPacked =-   SV.writeFile "speedtest-vector.f32" $-   asMonoPacked $-   (\xs -> SigP.render xs (div 10000000 4) ()) $-   (causalP Filt1.lowpassCausalPacked-     $< (fmap Filt1Core.Parameter $-         1 - (Sig.exponential2 (50000/4) 1))-     $* SigPS.osciSimple Wave.triangle 0 (frequency 0.01))--stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float))-stereoOsciSaw freq =-   liftA2 Stereo.cons-      (Sig.osciSaw 0.0 (freq*1.001) `Sig.mix`-       Sig.osciSaw 0.2 (freq*1.003) `Sig.mix`-       Sig.osciSaw 0.1 (freq*0.995))-      (Sig.osciSaw 0.1 (freq*1.005) `Sig.mix`-       Sig.osciSaw 0.7 (freq*0.997) `Sig.mix`-       Sig.osciSaw 0.5 (freq*0.999))--stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float))-stereoOsciSawPacked freq =-   let mix4 =-          Frame.mixVector .-          flip asTypeOf (undefined :: Value (Vector D4 Float))-   in  liftA2 Stereo.cons-          (Sig.map mix4 $-           Sig.osciPlain Wave.saw-              (valueOf $ LLVM.consVector 0.0 0.2 0.1 0.4)-              (valueOf $ fmap (freq*) $-               LLVM.consVector 1.001 1.003 0.995 0.996))-          (Sig.map mix4 $-           Sig.osciPlain Wave.saw-              (valueOf $ LLVM.consVector 0.1 0.7 0.5 0.7)-              (valueOf $ fmap (freq*) $-               LLVM.consVector 1.005 0.997 0.999 1.001))--stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float))-stereoOsciSawPacked2 freq =-   Sig.map (Frame.mixVectorToStereo .-            flip asTypeOf (undefined :: Value (Vector D8 Float))) $-   Sig.osciPlain (Wave.trapezoidSkew (A.fromRational' 0.2))-      (valueOf $ LLVM.consVector 0.0 0.2 0.1 0.4 0.1 0.7 0.5 0.7)-      (valueOf $ fmap (freq*) $-       LLVM.consVector 1.001 1.003 0.995 0.996 1.005 0.997 0.999 1.001)--stereo :: IO ()-stereo =-   SV.writeFile "speedtest.f32" $-   asStereo $-   flip Sig.render 10000000 $-   Sig.amplifyStereo 0.25 $-   stereoOsciSawPacked2 0.01--lazy :: IO ()-lazy =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asMono $-   Sig.renderChunky (SVL.chunkSize 100000)-      {- SVL.defaultChunkSize - too slow -} $-   Sig.envelope-      (Sig.exponential2 50000 1)-      (Sig.osci Wave.sine 0.5 0.01 :: Sig.T (Value Float))--lazyStereo :: IO ()-lazyStereo =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asStereo $-   Sig.renderChunky (SVL.chunkSize 100000) $-   Sig.amplifyStereo 0.25 $-   stereoOsciSawPacked 0.01--packTake :: IO ()-packTake =-   SVL.writeFile "speedtest.f32" $-   asMonoPacked $-   flip (SigP.renderChunky (SVL.chunkSize 1000)) () $-   SigPS.packRotate $-   (CausalP.take 5 $*-    SigP.osciSimple Wave.saw 0 (frequency 0.01))--chord :: Float -> Sig.T (Stereo.T (Value Float))-chord base =-   {--   This exceeds available vector registers-   and thus needs more stack accesses.-   Thus it needs twice as much time as the simple mixing.-   However doing all 32 oscillators in parallel-   and mix them in one go might be still faster.--   foldl1 (Sig.zipWith Frame.mixStereoV) $-   -}-   NonEmpty.foldBalanced Sig.mix $-   fmap (\f -> stereoOsciSawPacked2 (base*f)) $-   0.25 !: 1.00 : 1.25 : 1.50 : []--lazyChord :: IO ()-lazyChord =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asStereo $-   Sig.renderChunky (SVL.chunkSize 100000) $-   Sig.amplifyStereo 0.1 $-   chord 0.005--filterSweepComplex :: IO ()-filterSweepComplex =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asStereo $-   Sig.renderChunky (SVL.chunkSize 100000) $-   Sig.amplifyStereo 0.3 $-   Causal.apply BandPass.causal $-   Sig.zip-      (Sig.map (BandPass.parameter (valueOf 100)) $-       Sig.map (\x -> 0.01 * exp (2 * return x)) $-       Sig.osci Wave.sine 0 (0.1/44100)) $-   chord 0.005--lfoSineCausal ::-   CausalP.T p (Value Float) a -> Param.T p Float -> SigP.T p a-lfoSineCausal f reduct =-   CausalP.apply f $-   Sig.map (\x -> 0.01 * exp (2 * return x)) $-   SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100)--lfoSine ::-   (Memory.C a) =>-   (forall r. Value Float -> LLVM.CodeGenFunction r a) ->-   Param.T p Float ->-   SigP.T p a-lfoSine f = lfoSineCausal (Causal.map f)--filterSweep :: IO ()-filterSweep =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asMono $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (0.2 *-      CtrlP.processCtrlRate 128-         (lfoSine (Filt2.bandpassParameter (valueOf 100)))-      $* SigP.osciSimple Wave.saw 0 (frequency 0.01))--filterSweepPacked :: IO ()-filterSweepPacked =-   SVL.writeFile "speedtest.f32" $-   SVL.take (div 10000000 4) $-   asMonoPacked $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (0.2 *-    CtrlPS.processCtrlRate 128-       (lfoSine (Filt2.bandpassParameter (valueOf 100)))-      $* SigPS.osciSimple Wave.saw 0 0.01)--exponentialFilter2Packed :: IO ()-exponentialFilter2Packed =-   SVL.writeFile "speedtest.f32" $-   SVL.take (div 10000000 16) $-   asMonoPacked16 $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (causalP Filt2.causalPacked-      $< (SigP.constant $#-             Filt2Core.Parameter (1::Float) 0 0   0 0.99)-      $* (---          (CausalP.delay1 $# Serial.fromFixedList (0.1 !: 0.01 !: 0.001 !: 0.0001 !: Empty.Cons))---          (CausalP.delay1 $# Serial.replicate (1::Float))-          (CausalP.delay1 $# Serial.fromFixedList ((1::Float) !: NonEmptyC.repeat 0))-           $* 0))--filterSweepPacked2 :: IO ()-filterSweepPacked2 =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asMono $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (0.2 *-    CtrlP.processCtrlRate 128-       (lfoSine (Filt2P.bandpassParameter (valueOf 100)))-      $* SigP.osciSimple Wave.saw 0 (frequency 0.01))--butterworthNoisePacked :: IO ()-butterworthNoisePacked =-   SVL.writeFile "speedtest.f32" $-   SVL.take (div 10000000 4) $-   asMonoPacked $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (CausalPS.amplify 0.2 .-    CtrlPS.processCtrlRate 128-      (lfoSineCausal-         (CausalClass.applyConstFst-            (Butterworth.parameterCausal TypeNum.d3 FiltR.Lowpass)-            (valueOf 0.5)))-      $* SigPS.noise 0 0.3)--chebyshevNoisePacked :: IO ()-chebyshevNoisePacked =-   SVL.writeFile "speedtest.f32" $-   SVL.take (div 10000000 4) $-   asMonoPacked $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (CausalPS.amplify 0.2 .-    CtrlPS.processCtrlRate 128-      (lfoSineCausal-         (CausalClass.applyConstFst-            (Chebyshev.parameterCausalA TypeNum.d5 FiltR.Lowpass)-            (valueOf 0.5)))-      $* SigPS.noise 0 0.3)--{--Provoke non-aligned vector accesses by calling alloca for a record of 5 floats-in LLVM-2.6.-However, the vector accesses are those of noise.-Using scalar Noise there is no problem.--}-noiseAllocaBug :: IO ()-noiseAllocaBug =-   SVL.writeFile "speedtest.f32" $-   SVL.take (div 10000000 4) $-   asMonoPacked $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (CausalPS.amplify 0.2 . Filt2.causalPacked-      $< (Sig.map (const $ Memory.load =<< LLVM.alloca) $-            (Sig.constant (0::Float)))-      $* SigPS.noise 0 0.3)--noiseAllocaScalar :: IO ()-noiseAllocaScalar =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asMono $-   flip (SigP.renderChunky (SVL.chunkSize 10000)) () $-   (0.2 * causalP Filt2.causal-      $< (Sig.map (const $-             (Memory.load =<< LLVM.alloca ::-                 LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $-           (Sig.constant (0::Float)))-      $* SigP.noise 0 0.3)---upsample :: IO ()-upsample =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asMono $-   Sig.renderChunky (SVL.chunkSize 100000) $-      (let reduct = 128 :: Float-       in  flip Causal.applyConst reduct $ Causal.interpolateConstant $-           Sig.osci Wave.sine 0 (reduct*0.1/44100))---filterSweepControlRateCausal ::-   Causal.T-      (Stereo.T (Value Float))-      (Stereo.T (Value Float))-filterSweepControlRateCausal =-   Causal.amplifyStereo 0.3 <<<-   BandPass.causal <<<-   Causal.feedFst-      (let reduct = 128-       in  flip Causal.applyConst reduct $ Causal.interpolateConstant $-           Sig.map (BandPass.parameter (valueOf 100)) $-           Sig.map (\x -> 0.01 * exp (2 * return x)) $-           Sig.osci Wave.sine 0 (reduct*0.1/44100))--filterSweepControlRateProc ::-   Sig.T (Stereo.T (Value Float)) ->-   Sig.T (Stereo.T (Value Float))-filterSweepControlRateProc =-   Causal.apply filterSweepControlRateCausal--{- |-Trigonometric functions are very slow in LLVM-because they are translated to calls to C's math library.-Thus it is advantageous to compute filter parameters-at a lower rate and interpolate constantly.--}-filterSweepControlRate :: IO ()-filterSweepControlRate =-   SVL.writeFile "speedtest.f32" $-   asStereo $-   SVL.take 10000000 $-   Sig.renderChunky (SVL.chunkSize 100000) $-   filterSweepControlRateProc $-   chord 0.005---filterSweepMusic :: IO ()-filterSweepMusic = do-   music <- SV.readFile "lichter.f32"-   SVL.writeFile "speedtest.f32" $-      asStereo $-      Sig.renderChunky (SVL.chunkSize 100000) $-      Sig.amplifyStereo 20 $-      filterSweepControlRateProc $-      Sig.fromStorableVector $-      (music :: SV.Vector (Stereo.T Float))---playFilterSweepMusicLazy :: IO ()-playFilterSweepMusicLazy = do-   IO.withFile "lichter.f32" IO.ReadMode $ \h ->-      playStereo .---      Sig.amplifyStereo 1.125 .-      Sig.amplifyStereo 20 .-      filterSweepControlRateProc .-      Sig.fromStorableVectorLazy .-      asStereo . snd-       =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h-   return ()--playFilterSweepMusicCausal :: IO ()-playFilterSweepMusicCausal = do-   music <- SV.readFile "lichter.f32"-   _ <- SoxPlay.simple SV.hPut SoxOption.none 44100 $-      asStereo $-      Causal.applyStorable-         (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $-      (music :: SV.Vector (Stereo.T Float))-   return ()--playFilterSweepMusicCausalLazy :: IO ()-playFilterSweepMusicCausalLazy = do-   IO.withFile "lichter.f32" IO.ReadMode $ \h ->-      playStereoVector .-      Causal.applyStorableChunky-         (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) .-      asStereo . snd-       =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h-   return ()--deinterleaveProc ::-   IO (Float ->-       PIO.T-         (SV.Vector (StereoInt.T D4 Float))-         (Zip.T-            (SV.Vector (StereoInt.T D4 Float))-            (SV.Vector (StereoInt.T D4 Float))))-deinterleaveProc =-   CausalP.processIO deinterleaveCausal--deinterleaveCausal ::-   CausalP.T Float-      (StereoInt.Value D4 Float)-      (StereoInt.Value D4 Float, StereoInt.Value D4 Float)-deinterleaveCausal =-   Func.withArgs $ \input ->-      let env =-             Func.fromSignal $-                0.5 * (1 + SigPS.osciSimple (Wave.triangleSquarePower 4) 0 id)-      in  (Causal.zipWith StereoInt.envelope $& env &|& input)-          &|&-          (Causal.zipWith StereoInt.envelope $& (1-env) &|& input)--deinterleave :: IO ()-deinterleave = do-   proc <- deinterleaveProc-   runSplitProcess (proc (2/44100))---disturbProc, disturbFMProc ::-   IO (PIO.T-         (SV.Vector (StereoInt.T D4 Float))-         (Zip.T-            (SV.Vector (StereoInt.T D4 Float))-            (SV.Vector (StereoInt.T D4 Float))))-disturbProc =-   fmap ($()) $ CausalP.processIO $ crossMix disturbCausal--disturbCausal, disturbFMCausal ::-   CausalP.T p (StereoInt.Value D4 Float) (StereoInt.Value D4 Float)-disturbCausal =-   Func.withArgs $ \inputInt ->-      let tone =-             Func.fromSignal $-                SigPS.osciSimple Wave.triangle 0 (440/44100)-          getEnvelope x =-             Filt1.lowpassCausalPacked $&-                (Func.fromSignal $-                 (SigP.constant $# Filt1Core.parameter (1/44100::Float)))-                &|&-                (CausalV.map abs $& x)-          envelopedTone x = getEnvelope x * tone-      in  Causal.map StereoInt.interleave $&-          CausalPS.amplifyStereo 5 $&-          Stereo.liftApplicative envelopedTone-             (Causal.map StereoInt.deinterleave $& inputInt)--disturbFMProc =-   fmap ($()) $ CausalP.processIO $ crossMix disturbFMCausal--disturbFMCausal =-   Func.withArgs $ \inputInt ->-      let getEnvelope x =-             Filt1.lowpassCausalPacked $&-                (Func.fromSignal $-                 (SigP.constant $# Filt1Core.parameter (1/44100::Float)))-                &|&-                (CausalV.map abs $& x)-          modulatedTone x =-             getEnvelope x *-             (CausalPS.osciSimple Wave.triangle $&-                NP.zero-                &|&-                10 *-                getEnvelope-                   ((CausalPS.differentiate $# (0 :: Float)) $& x))-      in  Causal.map StereoInt.interleave $&-          CausalPS.amplifyStereo 5 $&-          Stereo.liftApplicative modulatedTone-             (Causal.map StereoInt.deinterleave $& inputInt)--disturb :: IO ()-disturb =-   runSplitProcess =<< disturbFMProc---wowFlutterProc ::-   IO (PIO.T-         (SV.Vector (StereoInt.T D4 Float))-         (Zip.T-            (SV.Vector (StereoInt.T D4 Float))-            (SV.Vector (StereoInt.T D4 Float))))-wowFlutterProc =-   fmap ($()) $ CausalP.processIO $ crossMix wowFlutterCausal--wowFlutterCausal ::-   CausalP.T p (StereoInt.Value D4 Float) (StereoInt.Value D4 Float)-wowFlutterCausal =-   Func.withArgs $ \inputInt ->-      let freq =-             Func.fromSignal $ (44100*) $-                0.01 * (1 + SigPS.osciSimple Wave.triangle 0 (1/44100 :: Param.T p Float)) +-                0.01 * (1 + SigPS.osciSimple Wave.approxSine2 0 (1.23/44100 :: Param.T p Float))-          modulatedTone x =-             CausalPS.pack-                (CausalP.delayControlledInterpolated Interpolation.linear-                    (0 :: Param.T p Float) (441*2*2+10))-             $&-             freq &|& x-      in  Causal.map StereoInt.interleave $&-          Stereo.liftApplicative modulatedTone-             (Causal.map StereoInt.deinterleave $& inputInt)--crossMix ::-   CausalP.T p (StereoInt.Value D4 Float) (StereoInt.Value D4 Float) ->-   CausalP.T p-      (StereoInt.Value D4 Float)-      (StereoInt.Value D4 Float, StereoInt.Value D4 Float)-crossMix proc =-   ((fst NP.+ snd)  &&&  (fst NP.- snd))-   .-   (id &&& proc)-   .-   Causal.map (StereoInt.amplify 0.5)---wowFlutter :: IO ()-wowFlutter =-   runSplitProcess =<< wowFlutterProc----scrambleProc0, scrambleProc1 ::-   IO (Float ->-       PIO.T-         (SV.Vector (StereoInt.T D4 Float))-         (Zip.T-            (SV.Vector (StereoInt.T D4 Float))-            (SV.Vector (StereoInt.T D4 Float))))-scrambleProc0 =-   CausalP.processIO $-      deinterleaveCausal NP.+-      (id &&& NP.negate id) .-         Causal.map (StereoInt.amplify 0.5) . wowFlutterCausal--scrambleProc1 =-   CausalP.processIO $-      deinterleaveCausal NP.+-      (id &&& NP.negate id) .-         Causal.map (StereoInt.amplify 0.3) .-         (wowFlutterCausal NP.+ disturbFMCausal)--scramble :: IO ()-scramble = do-   proc <- scrambleProc1-   runSplitProcess (proc (2/44100))---runSplitProcess ::-   (Storable a) =>-   PIO.T (SV.Vector a) (Zip.T (SV.Vector a) (SV.Vector a)) ->-   IO ()-runSplitProcess proc = do-   void $-      IO.withFile "/tmp/test.f32" IO.ReadMode $ \h ->-      IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 ->-      IO.withFile "/tmp/odd.f32"  IO.WriteMode $ \h1 ->--      case proc of-         PIO.Cons next create delete ->-            {--            Is the use of 'bracket' correct?-            I think 'delete' must be called with the final state,-            not with the initial one.-            -}-            bracket create delete $-               let chunkSize = 543210-                   loop s0 = do-                      chunk <- SV.hGet h chunkSize-                      (Zip.Cons y0 y1, s1) <- next chunk s0-                      SV.hPut h0 y0-                      SV.hPut h1 y1-                      when-                         (SV.length y0 >= SV.length chunk &&-                          SV.length y1 >= SV.length chunk &&-                          SV.length chunk >= chunkSize)-                         (loop s1)-               in  loop---antimixProc ::-   IO (SVL.Vector (StereoInt.T D4 Float) ->-       PIO.T-         (SV.Vector (StereoInt.T D4 Float))-         (Zip.T-            (SV.Vector (StereoInt.T D4 Float))-            (SV.Vector (StereoInt.T D4 Float))))-antimixProc =-   CausalP.processIO $ crossMix $-      Causal.map (StereoInt.amplify 0.5) .-      (CausalP.fromSignal $ SigP.fromStorableVectorLazy id)--antimix :: IO ()-antimix = do-   proc <- antimixProc-   void $-      IO.withFile "/tmp/test.f32" IO.ReadMode $ \h ->-      IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 ->-      IO.withFile "/tmp/odd.f32"  IO.WriteMode $ \h1 -> do-         let chunkSize = SVL.chunkSize 543210-         input <- fmap snd $ SVL.hGetContentsAsync chunkSize h-         let vectorSize = 4-             additive = SVL.drop (div 44100 vectorSize) input-{--             additive =-                case SVL.splitAt (div 44100 vectorSize) input of-                   (prefix, suffix) ->-                      SVL.append suffix $-                      SVL.replicate chunkSize (SVL.length prefix) StereoInt.zero--}-{--             additive =-                case SVL.splitAt (div 44100 vectorSize) input of-                   (prefix, suffix) -> SVL.append suffix prefix--}--         case proc additive of-            PIO.Cons next create delete ->-               {--               Is the use of 'bracket' correct?-               I think 'delete' must be called with the final state,-               not with the initial one.-               -}-               bracket create delete $ \state ->-                  let loop cs0 s0 =-                         case cs0 of-                            [] -> return ()-                            c : cs -> do-                               (Zip.Cons y0 y1, s1) <- next c s0-                               SV.hPut h0 y0-                               SV.hPut h1 y1-                               when-                                  (SV.length y0 >= SV.length c &&-                                   SV.length y1 >= SV.length c)-                                  (loop cs s1)-                  in  loop (SVL.chunks input) state---arrangeLazy :: IO ()-arrangeLazy = do-   IO.hSetBuffering IO.stdout IO.NoBuffering-   arrange <- SigStL.makeArranger-   print $-      arrange (SVL.chunkSize 2) $-      EventList.fromPairList $-         (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) :-         (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) :-         (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) :- --        repeat (2, SVL.empty)---         (2, SVL.empty) :---         (2, SVL.empty) :---         (2::NonNeg.Int, error "undefined sound") :-         error "end of list"- --        []---{- |-This is inefficient because pingSig is compiled by LLVM-for every occurence of the sound!--randomTones :: IO ()-randomTones = do-   playMonoVector $-      SigStL.arrange (SVL.chunkSize 12345) $-      EventList.fromPairList $ zip-         (cycle $ map (flip div 16 . (44100*)) [1,2,3])-         (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) .-                       pingSig . (0.01*))-          [1,1.25,1.5,2])-   return ()--}--{- |-So far we have not managed to compile signals-that depend on parameters.-Thus in order to avoid much recompilation,-we compile and render a few sounds in advance.--}-pingTones :: [SVL.Vector Float]-pingTones =-   map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) .-        pingSig . (0.01*))-   [1,1.25,1.5,2]--pingTonesIO :: IO [SVL.Vector Float]-pingTonesIO =-   fmap-      (\pingVec ->-         map-            (SVL.take 44100 .-             pingVec (SVL.chunkSize 4321) .-             (0.01*))-            [1,1.25,1.5,2])-      (SigP.runChunky $ pingSigP id)--{--Arrange itself does not seem to have a space leak with temporary data.-However it may leak sound data.-This is not very likely because this would result in a large memory leak.--Generate random tones in order to see whether generated sounds leak.-How does 'arrange' compare with 'concat'?--}--cycleTones :: IO ()-cycleTones = do---   playMono $-   pings <- pingTonesIO-   SVL.writeFile "test.f32" $---   Play.auto (0.01::Double) 44100 $-      asMono $-{--after 13min runtime memory consumption increased from 2.5 to 3.9-and we get lot of buffer underruns with this implementation of amplification-(renderChunky . amplify . fromStorableVector)--}-      Sig.renderChunky (SVL.chunkSize 432109) $-      Sig.amplify 0.1 $-      Sig.fromStorableVectorLazy $-{--after 20min memory consumption increased from 2.5 to 3.4-and we get lot of buffer underruns with applyStorableChunky--}-{--applyStorableChunky applied to concatenated zero vectors-starts with memory consumption 1.0 and after an hour, it's still 1.1-without buffer underruns.--}-{--      CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $-      asMono $--}-{--with chunksize 12345678-after 50min runtime the memory consumption increased from 12.0 to 26.2--with chunksize 123-after 25min runtime the memory consumption is constant 7.4-however at start time there 5 buffer underruns, but no more-probably due to initial LLVM compilation--with chunksize 1234567 and SVL.replicate instead of pingTones-we get memory consumption from 1.3 to 3.2 in 15min,-while producing lots of buffer underruns.-After 45min in total, it is still 3.2 of memory consumption.-Is this a memory leak, or isn't it?--with chunksize 12345678 and SVL.replicate-we get from 5.6 to 10.2 in 3min-to 14.9 after total 13min.--}-{--      SigStL.arrange (SVL.chunkSize 12345678) $-      EventList.fromPairList $ zip-         (repeat (div 44100 8))---         (cycle $ map (flip div 4 . (44100*)) [1,2,3])--}-{--With plain concatenation of those zero vectors-we stay constantly at 0.4 memory consumption and no buffer underruns over 30min.--}-      SVL.concat-         (cycle pings)---         (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0)-   return ()---tonesChunkSize :: SVL.ChunkSize-numTones :: Int--{--For one-time-compiled fill functions,-larger chunks have no relevant effect on the processing speed.--}-(tonesChunkSize, numTones) =-   (SVL.chunkSize 441, 200)---   (SVL.chunkSize 44100, 200)--fst :: Arrow arrow => arrow (a,b) a-fst = arr P.fst--snd :: Arrow arrow => arrow (a,b) b-snd = arr P.snd---{-# NOINLINE makePing #-}-makePing :: IO ((Float,Float) -> SVL.Vector Float)-makePing =-   fmap ($tonesChunkSize) $-   SigP.runChunky $-   Param.withTuple1 $ \(halfLife, freq) ->-      SigP.envelope-         (SigP.exponential2 halfLife 1)-         (SigP.osciSaw 0.5 freq)--tonesDown :: IO ()-tonesDown = do-   let dist = div 44100 10-   pingp <- makePing-   arrange <- SigStL.makeArranger-   playMonoVector $-      CausalP.applyStorableChunky (CausalP.amplify id) (0.03::Float) $-      arrange tonesChunkSize $-      EventList.fromPairList $ zip-         (repeat (NonNeg.fromNumber dist))-         (map (SVL.take (numTones * dist) . curry pingp 50000) $-          iterate (0.999*) 0.01)-   return ()---vibes :: SigP.T (Float,Float) (Value Float)-vibes =-   let freq = snd-       modDepth = fst-       halfLife = 5000-       -- sine = Wave.sine-       sine = Wave.approxSine4-   in  causalP CausalP.envelope-         $< SigP.exponential2 halfLife 1-         $* (((CausalP.osciSimple sine-                $< (causalP CausalP.envelope-                       $< SigP.exponential2 halfLife modDepth-                       $* (CausalP.osciSimple sine-                              $* SigP.constant (return (0::Float) &&& (2*freq)))))-               <<<-               CausalP.mapLinear (0.01*freq) freq-               <<<-               CausalP.osciSimple sine)-             $* SigP.constant (return (0::Float, 0.0001::Float)))--makeVibes :: IO ((Float,Float) -> SVL.Vector Float)-makeVibes =-   fmap ($tonesChunkSize) $-   SigP.runChunky vibes--vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> IO (SVL.Vector Float)-vibesCycleVector pingp =-   (\evs -> fmap (\arrange -> arrange tonesChunkSize evs) SigStL.makeArranger) $-   EventList.fromPairList $ zip-      (repeat 5000)-      (map (SVL.take 50000 . pingp) $-       zip-          (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0)-          (cycle $ map (0.01*) [1, 1.25, 1.5, 2]))--vibesCycle :: IO ()-vibesCycle = do-   sig <- vibesCycleVector =<< makeVibes-   playMonoVector $-      CausalP.applyStorableChunky (CausalP.amplify id) (0.2::Float) sig-   return ()--vibesEcho :: IO ()-vibesEcho = do-   sig <- vibesCycleVector =<< makeVibes-   playMonoVector $-      CausalP.applyStorableChunky-         (CausalP.amplify id <<<-          CausalP.comb (0.5 :: Param.T p Float) 7000)-         (0.2::Float) sig-   return ()--vibesReverb :: IO ()-vibesReverb = do-   sig <- vibesCycleVector =<< makeVibes-   playMonoVector $-      CausalP.applyStorableChunky-         (CausalP.amplify id <<<-          CausalP.reverbSimple (mkStdGen 142) 16 (0.9,0.97) (400,1000))-         (0.3::Float) sig-   return ()--vibesReverbEfficient :: IO ()-vibesReverbEfficient = do-   sig <- vibesCycleVector =<< makeVibes-   playMonoVector $-      CausalP.applyStorableChunky-         (CausalP.amplify id <<<-          (CausalP.reverb $# mkStdGen 142 $# 16 $# (0.9,0.97) $# (400,1000)))-         (0.3::Float) sig-   return ()--vibesReverbStereo :: IO ()-vibesReverbStereo = do-   sig <- vibesCycleVector =<< makeVibes-   void $ playStereoVector $-      CausalP.applyStorableChunky-         (CausalP.stereoFromMonoParameterized-             (\amp seed ->-                CausalP.amplify amp-                <<<-                CausalP.reverb (fmap mkStdGen seed)-                   16 (pure (0.9,0.97)) (pure (400,1000)))-             (pure $ Stereo.cons 142 857)-          <<^-          (\x -> Stereo.cons x x))-         (0.3::Float) sig----stair :: IO ()-stair =-   SVL.writeFile "speedtest.f32" $-   SVL.take 10000000 $-   asMono $-   flip (SigP.renderChunky tonesChunkSize) () $-   SigP.piecewiseConstant $-   return $-   EventListBT.fromPairList $-   zip-      (iterate (/2) (1::Float))-      (iterate (2*) (1::NonNeg.Int))---filterBass :: IO ()-filterBass =-   void $-   playStereoVector $-      asStereo $-      flip (SigP.renderChunky tonesChunkSize) () $-      CausalP.apply-         (BandPass.causal-          <<<-          CausalP.feedSnd-             (liftA2 Stereo.cons-                 (SigP.osciSimple Wave.saw 0 (frequency 0.001499))-                 (SigP.osciSimple Wave.saw 0 (frequency 0.001501)))-          <<<-          Causal.map (BandPass.parameter (valueOf (100::Float)))) $-      SigP.piecewiseConstant $-      return $ EventListBT.fromPairList $-      zip-         (map (((0.01::Float)*) . (2**) . (/12) . fromInteger) $-          randomRs (0,24) (mkStdGen 998))-         (repeat (6300::NonNeg.Int))---{- |-This function is not very efficient,-since it compiles an LLVM mixing routine-for every pair of mixer inputs.--}-mixVectorRecompile ::-   SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float-mixVectorRecompile xs ys =-   Sig.renderChunky tonesChunkSize $-   Sig.mix-      (Sig.fromStorableVectorLazy xs)-      (Sig.fromStorableVectorLazy ys)--mixVectorParamIO ::-   IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float)-mixVectorParamIO =-   fmap curry $-   fmap ($tonesChunkSize) $-   SigP.runChunky-      (SigP.mix-         (SigP.fromStorableVectorLazy fst)-         (SigP.fromStorableVectorLazy snd))--mixVectorCausalIO ::-   IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float)-mixVectorCausalIO =-   CausalP.runStorableChunky-      (CausalP.mix $<-       SigP.fromStorableVectorLazy id)--mixVectorCausal ::-   SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float-mixVectorCausal =-   CausalP.applyStorableChunky-      (CausalP.mix $<-       SigP.fromStorableVectorLazy id)--mixVectorStereo ::-   SVL.Vector (Stereo.T Float) ->-   SVL.Vector (Stereo.T Float) ->-   SVL.Vector (Stereo.T Float)-mixVectorStereo =-   CausalP.applyStorableChunky-      (CausalP.mix $< SigP.fromStorableVectorLazy id)--mixVectorStereoIO ::-   IO (SVL.Vector (Stereo.T Float) ->-       SVL.Vector (Stereo.T Float) ->-       SVL.Vector (Stereo.T Float))-mixVectorStereoIO =-   CausalP.runStorableChunky-      (CausalP.mix $< SigP.fromStorableVectorLazy id)--{--slightly slower than mixVectorParam--}-mixVectorHaskell ::-   SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float-mixVectorHaskell = SVL.zipWith (+)--toneMix :: IO ()-toneMix = do-   pingp <- makePing-   mix <- mixVectorCausalIO-   playMonoVector $-      Causal.applyStorableChunky (Causal.amplify 0.1) $-      foldl1 mix $-      map (curry pingp 1000000) $-      take numTones $-      iterate (*(2/3)) 0.01-   return ()--fadeEnvelope :: SigP.T (Int, Int) (Value Float)-fadeEnvelope =-   let dur :: Param.T (Int, Int) Float-       dur = fmap fromIntegral fst-   in  SigP.parabolaFadeIn dur-       `SigP.append`-       (CausalP.take snd $* Sig.constant 1)-       `SigP.append`-       SigP.parabolaFadeOut dur--fadeEnvelopeWrite :: IO ()-fadeEnvelopeWrite =-   SVL.writeFile "speedtest.f32" $-   asMono $-   SigP.renderChunky (SVL.chunkSize 1234)-   fadeEnvelope (100000, 200000)----- | normalize a list of numbers, such that they have a specific average--- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs-normalizeLevel :: Fractional a => a -> [a] -> [a]-normalizeLevel newAvrg xs =-   let avrg = sum xs / genericLength xs-   in  map ((newAvrg-avrg)+) xs--stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float))-stereoOsciSawP =-   let n = 5-       volume :: Float-       volume = recip $ sqrt $ fromIntegral n-       detunes :: [Float]-       detunes =-          normalizeLevel 1 $ take (2*n) $-             randomRs (0,0.03) $ mkStdGen 912-       phases :: [Float]-       phases = randomRs (0,1) $ mkStdGen 54-   in  stereoFromMonoParameterizedSignal-          (\_ params ->-              (SigP.amplify $# volume) $-              multiMixSignal-                 (\_ phaseFreq ->-                     SigP.osciSaw-                        (fmap fst phaseFreq)-                        (fmap snd phaseFreq))-                 params)-          (arr-              (\freq ->-                 uncurry Stereo.cons $ splitAt n $-                 zipWith-                    (\phase detune -> (phase, detune*freq))-                    phases detunes))--stereoFromMonoParameterizedSignal ::-   (forall q. Param.T q p -> Param.T q x -> SigP.T q (Value Float)) ->-   Param.T p (Stereo.T x) -> SigP.T p (Stereo.T (Value Float))-stereoFromMonoParameterizedSignal f ps =-   CausalP.toSignal $-      CausalP.stereoFromMonoParameterized (\p -> CausalP.fromSignal . f p) ps-      <<^-      (\() -> Stereo.cons () ())--multiMixSignal ::-   (forall q. Param.T q p -> Param.T q x -> SigP.T q (Value Float)) ->-   Param.T p [x] -> SigP.T p (Value Float)-multiMixSignal f =-   CausalP.toSignal . multiMix (\p x -> CausalP.fromSignal $ f p x)--multiMix ::-   (forall q. Param.T q p -> Param.T q x -> CausalP.T q a (Value Float)) ->-   Param.T p [x] -> CausalP.T p a (Value Float)-multiMix f ps =-   CausalP.replicateControlledParam-      (\p x -> CausalP.mix <<< CausalP.first (f p x)) ps-   <<^-   (\a -> (a, A.zero))--stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float)-stereoOsciSawVector =-   SigP.renderChunky tonesChunkSize stereoOsciSawP--stereoOsciSawChord :: NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)-stereoOsciSawChord =-   NonEmpty.foldBalanced mixVectorStereo . fmap stereoOsciSawVector--stereoOsciSawPad :: Int -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)-stereoOsciSawPad dur pitches =-   let attack = 20000-   in  CausalP.applyStorableChunky-          (CausalP.envelopeStereo $< fadeEnvelope)-          (attack, dur-attack)-          (stereoOsciSawChord pitches)--a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1,- a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2,- a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3,- a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float-a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 :- a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 :- a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 :- a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ =-  iterate ((2 ** recip 12) *) (55/44100)---chordSequence :: [(Int, NonEmpty.T [] Float)]-chordSequence =-   (2, f1  !: f2  : a2 : c3 : []) :-   (1, g1  !: g2  : b2 : d3 : []) :-   (2, c2  !: g2  : c3 : e3 : []) :-   (1, f1  !: a2  : c3 : f3 : []) :-   (2, g1  !: g2  : b2 : d3 : []) :-   (1, gs1 !: gs2 : b2 : e3 : []) :-   (2, a1  !: e2  : a2 : c3 : []) :-   (1, g1  !: g2  : b2 : d3 : []) :-   (3, c2  !: g2  : c3 : e3 : []) :--   (2, f1  !: f2  : a2 : c3 : []) :-   (1, g1  !: g2  : b2 : d3 : []) :-   (2, c2  !: g2  : c3 : e3 : []) :-   (1, f1  !: a2  : c3 : f3 : []) :-   (2, g1  !: g2  : b2 : d3 : []) :-   (1, gs1 !: gs2 : b2 : e3 : []) :-   (2, a1  !: e2  : a2 : c3 : []) :-   (1, g1  !: g2  : b2 : e3 : []) :-   (3, c2  !: e2  : g2 : c3 : []) :-   []---withDur :: (Int -> a -> v) -> Int -> a -> (v, NonNeg.Int)-withDur f d ps =-   let dur = d*30000-   in  (f dur ps, NonNeg.fromNumber dur)---padMusic :: IO ()-padMusic = do-   arrange <- SigStL.makeArranger-   playStereoVector $-      CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.1::Float) $-      arrange tonesChunkSize $-      EventListTM.switchTimeR const $-      EventListMT.consTime 0 $-      EventListBT.fromPairList $-      map (\(d,ps) -> withDur stereoOsciSawPad d ps)-      chordSequence-   return ()---lowpassSweepControlRateCausal ::-   CausalP.T p-      (Stereo.T (Value Float))-      (Stereo.T (Value Float))-lowpassSweepControlRateCausal =---   CausalP.stereoFromVector $-   CausalP.stereoFromMono $-      UniFilter.lowpass ^<<-      CtrlP.processCtrlRate 128-         (lfoSine (UniFilter.parameter (valueOf (10::Float))))---moogSweepControlRateCausal ::-   CausalP.T p-      (Stereo.T (Value Float))-      (Stereo.T (Value Float))-moogSweepControlRateCausal =---   CausalP.stereoFromVector $-   CausalP.stereoFromMono $-      CtrlP.processCtrlRate 128-         (lfoSine (Moog.parameter TypeNum.d8 (valueOf (10::Float))))---filterMusic :: IO ()-filterMusic = do-   arrange <- SigStL.makeArranger-   pad <- stereoOsciSawPadIO-   void $ playStereoVector $-      CausalP.applyStorableChunky-         (CausalP.amplifyStereo id <<<-          moogSweepControlRateCausal) (0.05::Float) $-      arrange tonesChunkSize $-      EventListTM.switchTimeR const $-      EventListMT.consTime 0 $-      EventListBT.fromPairList $-      map (\(d,ps) -> withDur pad d ps)-      chordSequence----stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float))-stereoOsciSawVectorIO =-   fmap ($tonesChunkSize) $-   SigP.runChunky $-   stereoOsciSawP--applyFadeEnvelopeIO ::-   IO (Int -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float))-applyFadeEnvelopeIO =-   fmap-      (\envelope dur sig ->-         let attack = 20000-         in  envelope (attack, dur-attack) sig)-      (CausalP.runStorableChunky-         (CausalP.envelopeStereo $< fadeEnvelope))--stereoOsciSawChordIO :: IO (NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float))-stereoOsciSawChordIO = do-   sawv <- stereoOsciSawVectorIO-   mix <- mixVectorStereoIO-   return (NonEmpty.foldBalanced mix . fmap sawv)--stereoOsciSawPadIO ::-   IO (Int -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float))-stereoOsciSawPadIO = do-   chrd <- stereoOsciSawChordIO-   envelope <- applyFadeEnvelopeIO-   return $-      \ dur pitches -> envelope dur (chrd pitches)--padMusicIO :: IO ()-padMusicIO = do-   arrange <- SigStL.makeArranger-   pad <- stereoOsciSawPadIO-   playStereoVector $-      CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.08::Float) $-      arrange tonesChunkSize $-      EventListTM.switchTimeR const $-      EventListMT.consTime 0 $-      EventListBT.fromPairList $-      map (uncurry (withDur pad)) $-      chordSequence-   return ()--{--Apply the envelope separately to each tone of the chord-and mix all tones by 'arrange'.--}-padMusicSeparate :: IO ()-padMusicSeparate = do-   arrange <- SigStL.makeArranger-   osci <- stereoOsciSawVectorIO-   env <- applyFadeEnvelopeIO-   playStereoVector $-      CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.08::Float) $-      arrange tonesChunkSize $-      EventList.flatten $-      EventListTM.switchTimeR const $-      EventListMT.consTime 0 $-      EventListBT.fromPairList $-      map (uncurry (withDur (\d ps ->-         map (\p -> env d (osci p)) $ NonEmpty.flatten ps))) $-      chordSequence-   return ()---delay :: IO ()-delay =-   SVL.writeFile "speedtest.f32" $-   asMono $-   flip (SigP.renderChunky tonesChunkSize) (0, 10000) $-   (CausalP.delayZero fst . CausalP.take snd-    $*-    SigP.osciSaw 0 (frequency 0.01))--delayStereo :: IO ()-delayStereo =-   SVL.writeFile "speedtest.f32" $-   asStereo $-   flip (SigP.renderChunky tonesChunkSize) (7, 10000) $-   (CausalP.take snd . liftA2 Stereo.cons id (CausalP.delayZero fst)-    $*-    SigP.osciSaw 0 (frequency 0.01))--delayPhaser :: IO ()-delayPhaser =-   SVL.writeFile "speedtest.f32" $-   asStereo $-   flip (SigP.renderChunky tonesChunkSize) 40000 $-   Func.compileSignal $-      let osci = Func.fromSignal $ SigP.osciSaw 0 (frequency 0.01)-          ctrl =-             Func.fromSignal $-             SigP.osciSimple Wave.triangle 0 $ frequency (1/20000)-      in  CausalP.take id $&-          liftA2 Stereo.cons-             osci-             (CausalP.delayControlledInterpolated Interpolation.cubic-                 (0 :: Param.T p Float) 100-              $&-              (50+50*ctrl) &|& osci)----allpassControl ::-   (TypeNum.Natural n) =>-   Proxy n ->-   SigP.T Float (Allpass.CascadeParameter n (Value Float))-allpassControl order =-   let reduct = id-   in  SigP.interpolateConstant reduct $-       lfoSine (Allpass.flangerParameter order) reduct--allpassPhaserCausal, allpassPhaserPipeline ::-   SigP.T Float (Value Float) ->-   SigP.T Float (Value Float)-allpassPhaserCausal =-   let order = TypeNum.d16-   in  CausalP.apply-          (0.5 * Allpass.phaser $< allpassControl order)--allpassPhaserPipeline =-   let order = TypeNum.d16-   in  -- (F.nest (TypeNum.integralFromProxy order) SigP.tail .) $-       SigP.drop (return $ TypeNum.integralFromProxy order) .-       CausalP.apply-          (0.5 * Allpass.phaserPipeline $< allpassControl order)--allpassPhaser :: IO ()-allpassPhaser =-   SVL.writeFile "speedtest.f32" $-   asMono $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) 128 $-   allpassPhaserPipeline $-   SigP.osciSaw 0 (frequency 0.01)--noise :: IO ()-noise =-   SVL.writeFile "speedtest.f32" $-   asMono $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   SigP.noise 0 0.3--noisePacked :: IO ()-noisePacked =-   SVL.writeFile "speedtest.f32" $-   asMonoPacked $-   SVL.take (div 10000000 4) $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   SigPS.noise 0 0.3---   SigPS.pack (SigP.noise 0 0.3)---   SigPS.packSmall (SigP.noise 0 0.3)--frequencyModulationStorable :: IO ()-frequencyModulationStorable = do-   smp <- SigP.runChunky (SigP.osciSaw 0 (frequency 0.01))-   SVL.writeFile "speedtest.f32" $-      asMono $-      flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-      (CausalP.frequencyModulationLinear-          (SigP.fromStorableVectorLazy $#-           (SVL.take 1000000 $ asMono $-            smp (SVL.chunkSize 1000) ()))-       $*# (0.3::Float))--frequencyModulation :: IO ()-frequencyModulation =-   SVL.writeFile "speedtest.f32" $-   asMono $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   (CausalP.frequencyModulationLinear-       (SigP.osciSaw 0 (frequency 0.01))-    $* Sig.exponential2 500000 1)--frequencyModulationStereo :: IO ()-frequencyModulationStereo = do-   smp <- SigP.runChunky (SigP.osciSaw 0 (frequency 0.01))-   SVL.writeFile "speedtest.f32" $-      asStereo $-      flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-      (CausalP.stereoFromMono-         (CausalP.frequencyModulationLinear-            (SigP.fromStorableVectorLazy $#-             (SVL.take 1000000 $ asMono $-              smp (SVL.chunkSize 1000) ())))-       $*# Stereo.cons (0.2999::Float) 0.3001)--frequencyModulationProcess :: IO ()-frequencyModulationProcess =-   SVL.writeFile "speedtest.f32" .-   asMono .-   (\f ->-      f () $ asMono $-      SigP.renderChunky (SVL.chunkSize 512)-         (1 + 0.1 * SigP.osciSimple Wave.approxSine2 (pure (0::Float)) 0.0001)-         ()) =<<-   CausalP.runStorableChunky-      (CausalP.frequencyModulationLinear-          (CausalP.take 50000 $*-           SigP.osciSaw 0 (frequency 0.01)))----quantize :: IO ()-quantize =-{--   SV.writeFile "speedtest.f32" $-   asMono $-   (\xs -> SigP.render xs 10000000 ()) $--}-   SVL.writeFile "speedtest.f32" $-   asMono $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   ((CausalP.quantizeLift $# (5.5::Float)) id $*-    SigP.osciSaw 0 (frequency 0.01))--quantizedFilterControl :: IO ()-quantizedFilterControl =-   SVL.writeFile "speedtest.f32" $-   asMono $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   CausalP.apply (0.3 * (UniFilter.lowpass ^<< CtrlP.process)) $-   SigP.zip-      ((CausalP.quantizeLift $# (128::Float))-         (Causal.map (UniFilter.parameter (valueOf 100)) <<<---         (Causal.map (Moog.parameter TypeNum.d8 (valueOf 100)) <<<-          CausalV.map (\x -> 0.01 * exp (2 * x)))-         $* SigP.osciSimple Wave.approxSine2 0 (frequency (0.1/44100))) $-   SigP.osciSaw 0 (frequency 0.01)---arrowNonShared :: IO ()-arrowNonShared =-   SVL.writeFile "speedtest.f32" $-   asStereo $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   (let osci = CausalP.osciSimple Wave.approxSine2-    in  liftA2 Stereo.cons osci osci $*-        SigP.constant (return (0::Float, 0.01::Float)))--arrowShared :: IO ()-arrowShared =-   SVL.writeFile "speedtest.f32" $-   asStereo $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   (let osci = Func.lift (CausalP.osciSimple Wave.approxSine2)-    in  Func.compile (liftA2 Stereo.cons osci osci) $*-        SigP.constant (return (0::Float, 0.01::Float)))--arrowIndependent :: IO ()-arrowIndependent =-   SVL.writeFile "speedtest.f32" $-   asStereo $-   SVL.take 10000000 $-   flip (SigP.renderChunky (SVL.chunkSize 100000)) () $-   (let osci = CausalP.osciSimple Wave.approxSine2-    in  Func.compile-          (fmap (uncurry Stereo.cons)  $-           osci *** osci  $&-           Func.lift id) $*-        SigP.constant (return ((0::Float, 0.01::Float), (0.25::Float, 0.01001::Float))))---rampDown :: Int -> SV.Vector Float-rampDown n =-   SigS.toStrictStorableSignal n $-   CtrlS.line n (1, 0)--impulses :: Int -> Float -> SVL.Vector Float-impulses n x =-   SVL.fromChunks $-   concatMap (\k -> [SV.singleton x, SV.replicate k 0]) $-   take n $ iterate (2*) 1--convolution :: IO ()-convolution =-   SVL.writeFile "speedtest.f32" $-   asMono $-   CausalP.applyStorableChunky-      (FiltNR.convolve id)-      (rampDown 1000)-      (impulses 18 0.1)--convolutionPacked :: IO ()-convolutionPacked =-   SVL.writeFile "speedtest.f32" $-   asMonoPacked $-   CausalP.applyStorableChunky-      (FiltNR.convolvePacked id)-      (rampDown 1000)-      (asMonoPacked $-       (\xs -> SigP.renderChunky SVL.defaultChunkSize xs ()) $-       SigPS.pack $-       SigP.fromStorableVectorLazy $-       pure $ impulses 18 0.1)----helixSaw :: IO ()-helixSaw = do-   let srcFreq = 0.01-       srcLength :: Float-       srcLength = 40000-   osci <- SigP.run $ SigP.osciSaw 0 (pure srcFreq) * (1-SigP.ramp id)-   let perc = asMono $ osci (round srcLength) srcLength-   SV.writeFile "osci-saw.f32" perc-   stretched <--      SigP.runChunky $-      Func.compileSignal $-      (Helix.static Interpolation.cubic Interpolation.cubic-          100 (pure $ recip srcFreq) snd-       $&-       (Func.fromSignal $ Sig.amplify srcLength $ SigP.ramp fst)-       &|&-       (CausalP.osciCore $& 0 &|& 0.01))-   SVL.writeFile "osci-stretched.f32" $ asMono $-      stretched SVL.defaultChunkSize (80000 :: Float, perc)---loadTomato :: IO (Float, SVL.Vector Float)-loadTomato = do-   let Sample.Info name _sampleRate positions = Sample.tomatensalat-   word <- Sample.load (Default.sampleDirectory </> name)-   return (Sample.period $ head positions, word)--helixOsci :: Param.T p Float -> Func.T p a (Value Float)-helixOsci period =-   CausalP.osciCore $&-      0 &|& Func.fromSignal (SigP.constant (recip period))--helixSpeechStaticSig ::-   Func.T p () (Value Float) ->-   Param.T p (SVL.Vector Float) ->-   Param.T p Float ->-   SigP.T p (Value Float)-helixSpeechStaticSig shape word period =-   Func.compileSignal-      (Helix.static Interpolation.linear Interpolation.linear-          (fmap round period) period-          (fmap (SV.concat . SVL.chunks) word)-       $&-       shape-       &|&-       helixOsci period)--helixSpeechStaticSpeed ::-   Param.T p Float ->-   Param.T p (SVL.Vector Float) ->-   Param.T p Float ->-   SigP.T p (Value Float)-helixSpeechStaticSpeed speed word =-   helixSpeechStaticSig-      (Func.fromSignal-         (CausalPV.takeWhile (%>)-             (fmap ((fromIntegral :: Int -> Float) . SVL.length) word) $*-          SigP.rampSlope speed))-      word--helixSpeechStatic :: IO ()-helixSpeechStatic = do-   smp <- loadTomato-   stretched <--      SigP.runChunky $-      Param.withTuple1 $ \(speed, (period, word)) ->-      helixSpeechStaticSpeed speed word period-   SVL.writeFile "speech-stretched.f32" $ asMono $-      stretched SVL.defaultChunkSize (0.5, smp)--helixSpeechDynamicSig ::-   Func.T p () (Value Float) ->-   Param.T p (SVL.Vector Float) ->-   Param.T p Float ->-   SigP.T p (Value Float)-helixSpeechDynamicSig shape word period =-   Func.compileSignal-      (Helix.dynamicLimited Interpolation.linear Interpolation.linear-          (fmap round period) period (SigP.fromStorableVectorLazy word)-       $&-       shape-       &|&-       helixOsci period)--helixSpeechDynamicSpeed ::-   Param.T p Float ->-   Param.T p (SVL.Vector Float) ->-   Param.T p Float ->-   SigP.T p (Value Float)-helixSpeechDynamicSpeed speed =-   helixSpeechDynamicSig (Func.fromSignal $ SigP.constant speed)--helixSpeechDynamic :: IO ()-helixSpeechDynamic = do-   smp <- loadTomato-   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-   smp <- loadTomato-   stretched <--      SigP.runChunky $-      Param.withTuple1 $ \(speed, (period, word)) ->-      sequenceA $-      Stereo.cons-         (helixSpeechStaticSpeed speed word period)-         (helixSpeechDynamicSpeed speed word period)-   SVL.writeFile "speech-stretched.f32" $ asStereo $-      stretched SVL.defaultChunkSize (0.5, smp)--helixSpeechVariCompare :: IO ()-helixSpeechVariCompare = do-   smp <- loadTomato-   stretched <--      SigP.runChunky $-      Param.withTuple1 $ \(period, word) ->-      sequenceA $-      let speed =-             Func.fromSignal $ SigP.cycle $-             SigP.fromStorableVector $ pure $-             SV.pack [0.2, 0.5, 1, 1.5, 1.8 :: Float]-      in  Stereo.cons-             (helixSpeechStaticSig-                 ((CausalP.integrate $# (0::Float)) $& speed) word period)-             (helixSpeechDynamicSig speed word period)-   SVL.writeFile "speech-stretched.f32" $ asStereo $-      stretched SVL.defaultChunkSize smp---helixLimited :: IO ()-helixLimited = do-   let period = 100-       srcLength = 500-       dstLength = 5000-       speed :: Param.T p Float-       speed = 0.5-       osci =-          0.5-          *-          SigP.ramp (pure (fromIntegral srcLength :: Float))-          *-          SigP.osciSimple Wave.approxSine2 0 (recip period)-   renderOsci <- SigP.run osci-   let osciVec = renderOsci srcLength ()-   SV.writeFile "helix-orig.f32" $ asMono osciVec--   let stretchedStatic =-          Helix.static Interpolation.linear Interpolation.linear-             (fmap round period) period (pure osciVec)-          $&-          Func.fromSignal (SigP.rampSlope speed)-          &|&-          helixOsci period-       stretchedDynamic =-          Helix.dynamic Interpolation.linear Interpolation.linear-             (fmap round period) period osci-          $&-          Func.fromSignal (SigP.constant speed)-          &|&-          helixOsci period-       stretched = liftA2 Stereo.cons stretchedStatic stretchedDynamic-   renderHelix <- SigP.run $ Func.compileSignal stretched-   SV.writeFile "helix-stretched.f32" $ asStereo $ renderHelix dstLength ()---cycleRamp :: IO ()-cycleRamp =-   SVL.writeFile "speedtest.f32" . asMono .-         (\f -> f SVL.defaultChunkSize (10000::Float)) =<<-      SigP.runChunky-         (CausalP.take 100000 $*-          (SigP.cycle $ SigP.append (SigP.ramp id) (1 - SigP.ramp id)))--zigZag :: IO ()-zigZag =-   SVL.writeFile "speedtest.f32" . asMono .-         (\f -> f SVL.defaultChunkSize (-3::Float)) =<<-      SigP.runChunky-         (CausalP.take 100000 $* (Helix.zigZag id $* 0.0001))--zigZagPacked :: IO ()-zigZagPacked =-   SVL.writeFile "speedtest.f32" . asMonoPacked .-         (\f -> f SVL.defaultChunkSize (-3::Float)) =<<-      SigP.runChunky-         (let vectorSize = 4-          in  CausalP.take (pure $ div 100000 vectorSize) $*-              (Helix.zigZagPacked id $* 0.0001))---trigger :: IO ()-trigger =-   SVL.writeFile "speedtest.f32" . asMono .-         (\f -> f SVL.defaultChunkSize (0.01 :: Float)) =<<-      SigP.runChunky-         (let pause len =-                 CausalClass.applyConst (CausalP.take len) Maybe.nothing-              pulse :: Float -> Param.T p Int -> SigP.T p (Maybe.T (Value Float))-              pulse freq len =-                 CausalP.take len .-                 arr (flip Maybe.fromBool (valueOf freq)) .-                 CausalP.delay1 (pure True) $*# False-          in  Sig.zipWith (flip Maybe.select) (SigP.noise 0 0.01) $-              (CausalP.trigger-                  (\_ freq -> CausalP.take 150000 $* pingSigP freq) $*-               pause 50000 `SigP.append`-               pulse 0.004 100000 `SigP.append`-               pulse 0.005 200000 `SigP.append`-               pulse 0.006 400000))---triggerLFO :: SigP.T p (Value Float)-triggerLFO =-   SigP.osciSimple Wave.approxSine2 0 (pure (0.00015 :: Float))-   +-   SigP.osciSimple Wave.approxSine2 0 (pure (0.000037 :: Float))--trackZeros :: CausalP.T p (Value Float) (Value Bool)-trackZeros =-   CausalV.zipWith (\x y -> x %&& Value.not y) .-   (id &&& CausalP.delay1 (pure False)) .-   CausalV.map (%> 0)--fmPingSig :: Param.T p Float -> Param.T p Float -> SigP.T p (Value Float)-fmPingSig freq depth =-   SigP.envelope-      (Sig.exponential2 5000 1)-      ((CausalP.osciSimple Wave.approxSine2 $> SigP.constant freq)-       $*-       (SigP.constant depth * SigP.osciSimple Wave.approxSine2 0 (2*freq)))--sweepTrigger :: IO ()-sweepTrigger =-   SVL.writeFile "speedtest.f32" . asMono .-         (\f -> f SVL.defaultChunkSize (0.01 :: Float)) =<<-      SigP.runChunky-         (Sig.zipWith (flip Maybe.select) (SigP.noise 0 0.01) $-            (CausalP.trigger (const $ fmPingSig (pure (0.005 :: Float))) $*-               liftA2 Maybe.fromBool-                  (CausalP.take 10000000 . trackZeros $* triggerLFO)-                  (5 * SigP.osciSimple Wave.approxSine2 0 (pure (0.00001 :: Float)))))+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Main where++import Synthesizer.LLVM.LAC2011 ()+import Synthesizer.LLVM.ExampleUtility++import qualified Synthesizer.LLVM.Server.Default as Default+import qualified Synthesizer.LLVM.Server.SampledSound as Sample++import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass+import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth+import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P+import qualified Synthesizer.LLVM.Filter.Moog as Moog+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter+import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR+import qualified Synthesizer.LLVM.Causal.Helix as Helix+import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Causal.Functional as Func+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Core as SigCore+import qualified Synthesizer.LLVM.Generator.Source as Source+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Interpolation as Interpolation+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.ConstantPiece as Const+import qualified Synthesizer.LLVM.Wave as Wave+import Synthesizer.LLVM.Causal.Functional (($&), (&|&))+import Synthesizer.LLVM.Causal.Process (($<), ($>), ($*), ($<#), ($*#))++import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial++import qualified LLVM.DSL.Expression.Maybe as ExprMaybe+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp, (>*), (&&*))++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Vector.Instance as MultiVectorI+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Maybe as Maybe++import qualified LLVM.Core as LLVM+import LLVM.Util.Arithmetic () -- Floating instance for TValue++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D2, D4, (:*:))+import Type.Base.Proxy (Proxy)++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.Zip as Zip+import qualified Synthesizer.State.Control as CtrlS+import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Plain.Filter.Recursive as FiltR+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core++import Control.Arrow (Arrow, arr, first, (&&&), (^<<), (<<^), (***))+import Control.Category ((<<<), (.), id)+import Control.Applicative (liftA2)+import Control.Functor.HT (void)+import Control.Monad (when, join)++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Numeric.NonNegative.Wrapper as NonNeg++import qualified Sound.Sox.Option.Format as SoxOption+import qualified Sound.Sox.Play as SoxPlay+-- import qualified Synthesizer.ALSA.Storable.Play as Play++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Foldable as Fold+import Data.Function.HT (nest)+import Data.NonEmpty ((!:))+import Data.Semigroup ((<>))+import Data.Traversable (sequenceA)+import Data.Tuple.HT (mapSnd)+import System.Path ((</>))+import System.Random (randomRs, mkStdGen)++import qualified System.Unsafe as Unsafe+import qualified System.IO as IO+import Control.Exception (bracket)++import qualified Algebra.Field as Field++import qualified NumericPrelude.Numeric as NP+import qualified Prelude as P+import NumericPrelude.Numeric (fromIntegral, sum, (+), (-), (/), (*))+import Prelude hiding (fst, snd, id, (.), fromIntegral, sum, (+), (-), (/), (*))+++asStereoPacked :: Id (vector (Serial.T D4 (Stereo.T Float)))+asStereoPacked = id++asStereoInterleaved :: Id (vector (StereoInt.T D4 Float))+asStereoInterleaved = id+++{- |+> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01)+-}+playStereo :: Sig.T (Stereo.T (MultiValue.T Float)) -> IO ()+playStereo sig =+   playStereoVector . ($ SVL.chunkSize 100000) =<<+   Render.run (Stereo.multiValue <$> sig)++playStereoVector :: SVL.Vector (Stereo.T Float) -> IO ()+playStereoVector =+   void . SoxPlay.simple SVL.hPut SoxOption.none 44100++playMono :: Sig.MV Float -> IO ()+playMono sig  =  playMonoVector . ($ SVL.chunkSize 100000) =<< Render.run sig++playMonoVector :: SVL.Vector Float -> IO ()+playMonoVector =+   void . SoxPlay.simple SVL.hPut SoxOption.none 44100+++playFileMono :: FilePath -> IO ()+playFileMono fileName = do+   f <- Render.run id+   IO.withFile fileName IO.ReadMode $ \h ->+      playStereoVector . f (SVL.chunkSize 100000) .+      asStereo . snd+       =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h+++frequency :: Float -> Exp Float+frequency = Expr.cons++{- |+Assist GHC-7.10.3 with determining the type of causal processes.+GHC-7.8.4 and GHC-8.0.1 do not need it.+-}+causalP :: Causal.T a b -> Causal.T a b+causalP = id+++constant :: Float -> IO ()+constant y =+   (SV.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ 1000) $ Render.run $+   Sig.constant (Expr.cons y)++saw :: IO ()+saw =+   (SV.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ 10000000) $ Render.run $+   Sig.osci Wave.saw 0 0.01++exponential :: IO ()+exponential =+   (SV.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ 10000000) $ Render.run $+   Sig.exponential2 50000 1++triangle :: IO ()+triangle =+   (SV.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ 10000000) $ Render.run $+   Sig.osci Wave.triangle 0.25 0.01++trianglePack :: IO ()+trianglePack =+   (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap ($ div 10000000 4) $ Render.run $+   (Causal.map (Expr.liftM Wave.triangle) $*) $+   SigPS.packSmall $+   SigCore.osci 0.25 (4.015803e-4)++trianglePacked :: IO ()+trianglePacked =+   (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap ($ div 10000000 4) $ Render.run $+   (CausalPS.osci Wave.triangle+     $< SigPS.constant 0.25+     $* SigPS.constant 0.01)++triangleReplicate :: IO ()+triangleReplicate =+   (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap ($ div 10000000 4) $ Render.run $+   (CausalPS.shapeModOsci+       (\k p -> do+           x <- Wave.triangle =<< Wave.replicate k p+           y <- Wave.approxSine4 =<< Wave.halfEnvelope p+           A.mul x y)+     $< SigPS.rampInf 1000000+     $< SigPS.constant 0+     $* SigPS.constant 0.01)++rationalSine :: IO ()+rationalSine =+   (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap ($ div 10000000 4) $ Render.run $+   (CausalPS.shapeModOsci Wave.rationalApproxSine1+     $< (0.001 + SigPS.rampInf 10000000)+     $< SigPS.constant 0+     $* SigPS.constant 0.01)++rationalSineStereo :: IO ()+rationalSineStereo =+   (SV.writeFile "speedtest.f32" . asStereoPacked =<<) $+   fmap ($ div 10000000 4) $ Render.run $+   fmap Stereo.multiValueSerial $+   liftA2 Stereo.cons+      (CausalPS.shapeModOsci Wave.rationalApproxSine1+        $< (0.001 + SigPS.rampInf 10000000)+        $< SigPS.constant (-0.25)+        $* SigPS.constant 0.00999)+      (CausalPS.shapeModOsci Wave.rationalApproxSine1+        $< (0.001 + SigPS.rampInf 10000000)+        $< SigPS.constant 0.25+        $* SigPS.constant 0.01001)+++pingSig :: Float -> Sig.MV Float+pingSig freq =+   Sig.exponential2 50000 1+   *+   Sig.osci Wave.saw 0.5 (Expr.cons freq)++pingSigP :: Exp Float -> Sig.MV Float+pingSigP freq =+   Sig.exponential2 50000 1+   *+   Sig.osci Wave.saw 0.5 freq++ping :: IO ()+ping =+   (SV.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ 10000000) $ Render.run $+   pingSig 0.01++pingSigPacked :: Exp Float -> Sig.T (CausalPS.Serial D4 Float)+pingSigPacked freq =+   SigPS.exponential2 50000 1+   *+   SigPS.osci Wave.saw 0 freq++pingPacked :: IO ()+pingPacked =+   (SV.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap (\f -> f (div 10000000 4) (0.01::Float)) $ Render.run $+   pingSigPacked++pingUnpack :: IO ()+pingUnpack =+   (SV.writeFile "speedtest.f32" . asMono =<<) $+   fmap (\f -> f 10000000 (0.01::Float)) $ Render.run $+   SigPS.unpack . pingSigPacked++pingSmooth :: IO ()+pingSmooth =+   SV.writeFile "speedtest-scalar.f32" . asMono . ($ 10000000) =<<+   Render.run+      (Filt1.lowpassCausal+         $< fmap Filt1Core.Parameter (1 - Sig.exponential2 50000 1)+         $* Sig.osci Wave.triangle 0 0.01)++pingSmoothPacked :: IO ()+pingSmoothPacked =+   SV.writeFile "speedtest-vector.f32" . asMonoPacked . ($ div 10000000 4) =<<+   Render.run+      (Filt1.lowpassCausalPacked+         $< fmap Filt1Core.Parameter (1 - Sig.exponential2 (50000/4) 1)+         $* SigPS.osci Wave.triangle 0 0.01)++stereoOsciSaw :: Exp Float -> Sig.T (Stereo.T (MultiValue.T Float))+stereoOsciSaw freq =+   liftA2 Stereo.cons+      (Sig.osci Wave.saw 0.0 (freq*1.001) ++       Sig.osci Wave.saw 0.2 (freq*1.003) ++       Sig.osci Wave.saw 0.1 (freq*0.995))+      (Sig.osci Wave.saw 0.1 (freq*1.005) ++       Sig.osci Wave.saw 0.7 (freq*0.997) ++       Sig.osci Wave.saw 0.5 (freq*0.999))++stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (MultiValue.T Float))+stereoOsciSawPacked freq =+   let mix4 = Expr.liftM $ MultiVector.sum . MultiVectorI.fromMultiValue+   in  liftA2 Stereo.cons+          ((Causal.map mix4 $*) $+           Sig.osci Wave.saw+              (Expr.cons $ LLVM.consVector 0.0 0.2 0.1 0.4)+              (Expr.cons $ fmap (freq*) $+               LLVM.consVector 1.001 1.003 0.995 0.996))+          ((Causal.map mix4 $*) $+           Sig.osci Wave.saw+              (Expr.cons $ LLVM.consVector 0.1 0.7 0.5 0.7)+              (Expr.cons $ fmap (freq*) $+               LLVM.consVector 1.005 0.997 0.999 1.001))++stereoDeinterleave :: NonEmpty.T [] a -> NonEmpty.T [] (Stereo.T a)+stereoDeinterleave xt =+   case xt of+      NonEmpty.Cons _ [] -> error "stereoDeinterleave: singleton"+      NonEmpty.Cons x0 (x1:xs) ->+         Stereo.cons x0 x1 !:+            let go (y0:y1:ys) = Stereo.cons y0 y1 : go ys+                go [] = []+                go [_] = error "stereoDeinterleave: odd length"+            in go xs++mixVectorToStereo ::+   (TypeNum.Positive n, MultiVector.Additive a) =>+   MultiVector.T n a -> LLVM.CodeGenFunction r (Stereo.T (MultiValue.T a))+mixVectorToStereo =+   NonEmpty.foldBalanced (\x y -> join $ liftA2 A.add x y) .+   fmap sequenceA . stereoDeinterleave . MultiVector.dissectList1++mixVec ::+   (TypeNum.Positive n, MultiVector.Additive a) =>+   Exp (LLVM.Vector n a) -> Stereo.T (Exp a)+mixVec =+   Stereo.unExpression .+   Expr.liftM+      (fmap Stereo.multiValue . mixVectorToStereo . MultiVectorI.fromMultiValue)++stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (MultiValue.T Float))+stereoOsciSawPacked2 freq =+   (Causal.map mixVec $*) $+   Sig.osci (Wave.trapezoidSlope (A.fromRational' 5))+      (Expr.cons $ LLVM.consVector 0.0 0.2 0.1 0.4 0.1 0.7 0.5 0.7)+      (Expr.cons $ fmap (freq*) $+       LLVM.consVector 1.001 1.003 0.995 0.996 1.005 0.997 0.999 1.001)++stereo :: IO ()+stereo =+   SV.writeFile "speedtest.f32" . asStereo .  ($ 10000000) =<<+   Render.run+      (Stereo.multiValue <$> Causal.amplifyStereo 0.25+         $* stereoOsciSawPacked2 0.01)++lazy :: IO ()+lazy =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run {- SVL.defaultChunkSize - too slow -}+      (Causal.envelope+         $< Sig.exponential2 50000 1+         $* Sig.osci Wave.sine 0.5 0.01)++lazyStereo :: IO ()+lazyStereo =+   (SVL.writeFile "speedtest.f32" . asStereo . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (Stereo.multiValue <$> Causal.amplifyStereo 0.25+         $* stereoOsciSawPacked 0.01)++packTake :: IO ()+packTake =+   (SVL.writeFile "speedtest.f32" . asMonoPacked . ($ SVL.chunkSize 1000) =<<) $+   (Render.run . SigPS.packRotate)+      (Causal.take 5 $* Sig.osci Wave.saw 0 (frequency 0.01))++chord :: Float -> Sig.T (Stereo.T (MultiValue.T Float))+chord base =+   {-+   This exceeds available vector registers+   and thus needs more stack accesses.+   Thus it needs twice as much time as the simple mixing.+   However doing all 32 oscillators in parallel+   and mix them in one go might be still faster.++   foldl1 (Sig.zipWith Frame.mixStereoV) $+   -}+   NonEmpty.foldBalanced (+) $+   fmap (\f -> stereoOsciSawPacked2 (base*f)) $+   0.25 !: 1.00 : 1.25 : 1.50 : []++lazyChord :: IO ()+lazyChord =+   (SVL.writeFile "speedtest.f32" . asStereo . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run (Stereo.multiValue <$> Causal.amplifyStereo 0.1 $* chord 0.005)++filterSweepComplex :: IO ()+filterSweepComplex =+   playStereo $+      (Causal.amplifyStereo 0.3 . BandPass.causal+         $< (Causal.map (\x -> BandPass.parameter 100 (0.01 * exp (2*x))) $*+             Sig.osci Wave.sine 0 (0.1/44100))+         $* chord 0.005)++lfoSineCausal ::+   Causal.T (MultiValue.T Float) a -> Exp Float -> Sig.T a+lfoSineCausal f reduct =+   f . Causal.map (\x -> 0.01 * exp (2*x)) $*+   Sig.osci Wave.sine 0 (reduct * 0.1/44100)++lfoSine ::+   (Expr.Aggregate ae a) =>+   (Exp Float -> ae) ->+   Exp Float -> Sig.T a+lfoSine f = lfoSineCausal (Causal.map f)++filterSweep :: IO ()+filterSweep =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 10000) $+   Render.run $+      (0.2 * Ctrl.processCtrlRate 128 (lfoSine (Filt2.bandpassParameter 100))+         $* Sig.osci Wave.saw 0 (frequency 0.01))++filterSweepPacked :: IO ()+filterSweepPacked =+   (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap (SVL.take (div 10000000 4)) $+   fmap ($ SVL.chunkSize 10000) $+   Render.run+      (0.2 *+       CtrlPS.processCtrlRate 128 (lfoSine (Filt2.bandpassParameter 100))+            $* SigPS.osci Wave.saw 0 (frequency 0.01))++exponentialFilter2Packed :: IO ()+exponentialFilter2Packed =+   (SVL.writeFile "speedtest.f32" . asMonoPacked16 =<<) $+   fmap (SVL.take (div 10000000 16)) $+   fmap ($ SVL.chunkSize 10000) $+   Render.run+      (Filt2.causalPacked+         $< Sig.constant (Filt2.Parameter 1 0 0   0 0.99)+         $* (+--             (Causal.delay1 $ Serial.fromFixedList (0.1 !: 0.01 !: 0.001 !: 0.0001 !: Empty.Cons))+--             (Causal.delay1 $ Serial.replicate 1)+             (Causal.delay1 $ Serial.fromFixedList (1 !: NonEmptyC.repeat 0))+               $* 0))++filterSweepPacked2 :: IO ()+filterSweepPacked2 =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 10000) $+   Render.run+      (0.2 *+       Ctrl.processCtrlRate 128 (lfoSine (Filt2P.bandpassParameter 100))+         $* Sig.osci Wave.saw 0 (frequency 0.01))++butterworthNoisePacked :: IO ()+butterworthNoisePacked =+   (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap (SVL.take (div 10000000 4)) $+   fmap ($ SVL.chunkSize 10000) $+   Render.run+      (CausalPS.amplify 0.2 .+       CtrlPS.processCtrlRate 128+         (lfoSineCausal+            (Butterworth.parameterCausal TypeNum.d3 FiltR.Lowpass $<# 0.5))+         $* SigPS.noise 0 0.3)++chebyshevNoisePacked :: IO ()+chebyshevNoisePacked =+   (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $+   fmap (SVL.take (div 10000000 4)) $+   fmap ($ SVL.chunkSize 10000) $+   Render.run+      (CausalPS.amplify 0.2 .+       CtrlPS.processCtrlRate 128+         (lfoSineCausal+            (Chebyshev.parameterCausalA TypeNum.d5 FiltR.Lowpass $<# 0.5))+         $* SigPS.noise 0 0.3)+++upsample :: IO ()+upsample =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (let reduct = 128 :: Exp Float+       in Sig.interpolateConstant reduct+            (Sig.osci Wave.sine 0 (reduct*0.1/44100)))+++filterSweepControlRateCausal ::+   Causal.T+      (Stereo.T (MultiValue.T Float))+      (Stereo.T (MultiValue.T Float))+filterSweepControlRateCausal =+   Causal.amplifyStereo 0.3 <<< BandPass.causal+   $< (let reduct = 128 :: Exp Float+       in Sig.interpolateConstant reduct+            (Causal.map (BandPass.parameter 100) .+             Causal.map (\x -> 0.01 * exp (2*x))+               $* Sig.osci Wave.sine 0 (reduct*0.1/44100)))++{- |+Trigonometric functions are very slow in LLVM+because they are translated to calls to C's math library.+Thus it is advantageous to compute filter parameters+at a lower rate and interpolate constantly.+-}+filterSweepControlRate :: IO ()+filterSweepControlRate =+   (SVL.writeFile "speedtest.f32" . asStereo . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (Stereo.multiValue <$> filterSweepControlRateCausal $* chord 0.005)+++filterSweepMusic :: IO ()+filterSweepMusic = do+   proc <-+      Render.run $ \music ->+         Stereo.multiValue ^<< Causal.amplifyStereo 20 .+            filterSweepControlRateCausal <<^ Stereo.unMultiValue $* music+   music <- SV.readFile "lichter.f32"+   SVL.writeFile "speedtest.f32" . asStereo+      =<< proc (SVL.chunkSize 100000) music+++playFilterSweepMusicLazy :: IO ()+playFilterSweepMusicLazy = do+   proc <-+      Render.run $ \vol music ->+         Stereo.multiValue ^<< Causal.amplifyStereo vol .+            filterSweepControlRateCausal <<^ Stereo.unMultiValue $* music+   IO.withFile "lichter.f32" IO.ReadMode $ \h ->+      playStereoVector . proc (SVL.chunkSize 100000) (20::Float) {-1.125-} . snd+         =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h++playFilterSweepMusicCausal :: IO ()+playFilterSweepMusicCausal = do+   proc <-+      CausalRender.run $+         Stereo.multiValue ^<< Causal.amplifyStereo 20 .+            filterSweepControlRateCausal <<^ Stereo.unMultiValue+   music <- SV.readFile "lichter.f32"+   void $ SoxPlay.simple SV.hPut SoxOption.none 44100 =<<+      pioApplyStrict proc music++playFilterSweepMusicCausalLazy :: IO ()+playFilterSweepMusicCausalLazy = do+   proc <-+      CausalRender.run $+         Stereo.multiValue ^<< Causal.amplifyStereo 20 .+            filterSweepControlRateCausal <<^ Stereo.unMultiValue+   IO.withFile "lichter.f32" IO.ReadMode $ \h ->+      playStereoVector =<< pioApply proc . snd+       =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h+++deinterleaveProc ::+   IO (Float ->+       PIO.T+         (SV.Vector (StereoInt.T D4 Float))+         (Zip.T+            (SV.Vector (StereoInt.T D4 Float))+            (SV.Vector (StereoInt.T D4 Float))))+deinterleaveProc =+   CausalRender.run deinterleaveCausal++deinterleaveCausal ::+   Exp Float ->+   Causal.T+      (StereoInt.Value D4 Float)+      (StereoInt.Value D4 Float, StereoInt.Value D4 Float)+deinterleaveCausal freq =+   Func.withArgs $ \input ->+      let env =+             Func.fromSignal $+                0.5 * (1 + SigPS.osci (Wave.triangleSquarePower 4) 0 freq)+      in  (Causal.zipWith StereoInt.envelope $& env &|& input)+          &|&+          (Causal.zipWith StereoInt.envelope $& (1-env) &|& input)++deinterleave :: IO ()+deinterleave = do+   proc <- deinterleaveProc+   runSplitProcess (proc (2/44100))+++disturbProc, disturbFMProc ::+   IO (PIO.T+         (SV.Vector (StereoInt.T D4 Float))+         (Zip.T+            (SV.Vector (StereoInt.T D4 Float))+            (SV.Vector (StereoInt.T D4 Float))))+disturbProc =+   CausalRender.run $ crossMix disturbCausal++disturbCausal, disturbFMCausal ::+   Causal.T (StereoInt.Value D4 Float) (StereoInt.Value D4 Float)+disturbCausal =+   Func.withArgs $ \inputInt ->+      let tone = Func.fromSignal $ SigPS.osci Wave.triangle 0 (440/44100)+          getEnvelope x =+             Filt1.lowpassCausalPacked $&+                (Func.fromSignal $+                 Sig.constant $ Filt1Core.parameter (1/44100))+                &|&+                (Causal.map abs $& x)+          envelopedTone x = getEnvelope x * tone+      in  Causal.map StereoInt.interleave $&+          CausalPS.amplifyStereo 5 $&+          Stereo.liftApplicative envelopedTone+             (Causal.map StereoInt.deinterleave $& inputInt)++disturbFMProc =+   CausalRender.run $ crossMix disturbFMCausal++disturbFMCausal =+   Func.withArgs $ \inputInt ->+      let getEnvelope x =+             Filt1.lowpassCausalPacked $&+                (Func.fromSignal $+                 Sig.constant $ Filt1Core.parameter (1/44100))+                &|&+                (Causal.map abs $& x)+          modulatedTone x =+             getEnvelope x *+             (CausalPS.osci Wave.triangle $&+                NP.zero+                &|&+                10 * getEnvelope (CausalPS.differentiate 0 $& x))+      in  Causal.map StereoInt.interleave $&+          CausalPS.amplifyStereo 5 $&+          Stereo.liftApplicative modulatedTone+             (Causal.map StereoInt.deinterleave $& inputInt)++disturb :: IO ()+disturb =+   runSplitProcess =<< disturbFMProc+++wowFlutterProc ::+   IO (PIO.T+         (SV.Vector (StereoInt.T D4 Float))+         (Zip.T+            (SV.Vector (StereoInt.T D4 Float))+            (SV.Vector (StereoInt.T D4 Float))))+wowFlutterProc =+   CausalRender.run $ crossMix wowFlutterCausal++wowFlutterCausal ::+   Causal.T (StereoInt.Value D4 Float) (StereoInt.Value D4 Float)+wowFlutterCausal =+   Func.withArgs $ \inputInt ->+      let freq =+             Func.fromSignal $ (44100*) $+                0.01 * (1 + SigPS.osci Wave.triangle 0 (1/44100 :: Exp Float)) ++                0.01 * (1 + SigPS.osci Wave.approxSine2+                                                  0 (1.23/44100 :: Exp Float))+          modulatedTone x =+             CausalPS.pack+                (Causal.delayControlledInterpolated Interpolation.linear+                    (0 :: Exp Float) (441*2*2+10))+             $&+             freq &|& x+      in  Causal.map StereoInt.interleave $&+          Stereo.liftApplicative modulatedTone+             (Causal.map StereoInt.deinterleave $& inputInt)++crossMix ::+   Causal.T (StereoInt.Value D4 Float) (StereoInt.Value D4 Float) ->+   Causal.T+      (StereoInt.Value D4 Float)+      (StereoInt.Value D4 Float, StereoInt.Value D4 Float)+crossMix proc =+   ((fst NP.+ snd)  &&&  (fst NP.- snd))+   .+   (id &&& proc)+   .+   Causal.map (StereoInt.amplify 0.5)+++wowFlutter :: IO ()+wowFlutter =+   runSplitProcess =<< wowFlutterProc++++scrambleProc0, scrambleProc1 ::+   IO (Float ->+       PIO.T+         (SV.Vector (StereoInt.T D4 Float))+         (Zip.T+            (SV.Vector (StereoInt.T D4 Float))+            (SV.Vector (StereoInt.T D4 Float))))+scrambleProc0 =+   CausalRender.run $ \freq ->+      deinterleaveCausal freq NP.++      (id &&& NP.negate id) .+         Causal.map (StereoInt.amplify 0.5) . wowFlutterCausal++scrambleProc1 =+   CausalRender.run $ \freq ->+      deinterleaveCausal freq NP.++      (id &&& NP.negate id) .+         Causal.map (StereoInt.amplify 0.3) .+         (wowFlutterCausal NP.+ disturbFMCausal)++scramble :: IO ()+scramble = do+   proc <- scrambleProc1+   runSplitProcess (proc (2/44100))+++runSplitProcess ::+   (Storable a) =>+   PIO.T (SV.Vector a) (Zip.T (SV.Vector a) (SV.Vector a)) ->+   IO ()+runSplitProcess proc = do+   void $+      IO.withFile "/tmp/test.f32" IO.ReadMode $ \h ->+      IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 ->+      IO.withFile "/tmp/odd.f32"  IO.WriteMode $ \h1 ->++      case proc of+         PIO.Cons next create delete ->+            {-+            Is the use of 'bracket' correct?+            I think 'delete' must be called with the final state,+            not with the initial one.+            -}+            bracket create delete $+               let chunkSize = 543210+                   loop s0 = do+                      chunk <- SV.hGet h chunkSize+                      (Zip.Cons y0 y1, s1) <- next chunk s0+                      SV.hPut h0 y0+                      SV.hPut h1 y1+                      when+                         (SV.length y0 >= SV.length chunk &&+                          SV.length y1 >= SV.length chunk &&+                          SV.length chunk >= chunkSize)+                         (loop s1)+               in  loop+++antimixProc ::+   IO (SVL.Vector (StereoInt.T D4 Float) ->+       PIO.T+         (SV.Vector (StereoInt.T D4 Float))+         (Zip.T+            (SV.Vector (StereoInt.T D4 Float))+            (SV.Vector (StereoInt.T D4 Float))))+antimixProc =+   CausalRender.run $ \xs -> crossMix $+      Causal.map (StereoInt.amplify 0.5) . Causal.fromSignal xs++antimix :: IO ()+antimix = do+   proc <- antimixProc+   void $+      IO.withFile "/tmp/test.f32" IO.ReadMode $ \h ->+      IO.withFile "/tmp/even.f32" IO.WriteMode $ \h0 ->+      IO.withFile "/tmp/odd.f32"  IO.WriteMode $ \h1 -> do+         let chunkSize = SVL.chunkSize 543210+         input <- fmap snd $ SVL.hGetContentsAsync chunkSize h+         let vectorSize = 4+             additive = SVL.drop (div 44100 vectorSize) input+{-+             additive =+                case SVL.splitAt (div 44100 vectorSize) input of+                   (prefix, suffix) ->+                      SVL.append suffix $+                      SVL.replicate chunkSize (SVL.length prefix) StereoInt.zero+-}+{-+             additive =+                case SVL.splitAt (div 44100 vectorSize) input of+                   (prefix, suffix) -> SVL.append suffix prefix+-}++         case proc additive of+            PIO.Cons next create delete ->+               {-+               Is the use of 'bracket' correct?+               I think 'delete' must be called with the final state,+               not with the initial one.+               -}+               bracket create delete $ \state ->+                  let loop cs0 s0 =+                         case cs0 of+                            [] -> return ()+                            c : cs -> do+                               (Zip.Cons y0 y1, s1) <- next c s0+                               SV.hPut h0 y0+                               SV.hPut h1 y1+                               when+                                  (SV.length y0 >= SV.length c &&+                                   SV.length y1 >= SV.length c)+                                  (loop cs s1)+                  in  loop (SVL.chunks input) state+++arrangeLazy :: IO ()+arrangeLazy = do+   IO.hSetBuffering IO.stdout IO.NoBuffering+   arrange <- SigStL.makeArranger+   print $+      arrange (SVL.chunkSize 2) $+      EventList.fromPairList $+         (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) :+         (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) :+         (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) :+ --        repeat (2, SVL.empty)+--         (2, SVL.empty) :+--         (2, SVL.empty) :+--         (2::NonNeg.Int, error "undefined sound") :+         error "end of list"+ --        []+++{- |+This is inefficient because pingSig is compiled by LLVM+for every occurence of the sound!++randomTones :: IO ()+randomTones = do+   playMonoVector $+      SigStL.arrange (SVL.chunkSize 12345) $+      EventList.fromPairList $ zip+         (cycle $ map (flip div 16 . (44100*)) [1,2,3])+         (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) .+                       pingSig . (0.01*))+          [1,1.25,1.5,2])+-}++{-+{- |+So far we have not managed to compile signals+that depend on parameters.+Thus in order to avoid much recompilation,+we compile and render a few sounds in advance.+-}+pingTones :: [SVL.Vector Float]+pingTones =+   map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) .+        pingSig . (0.01*))+   [1,1.25,1.5,2]+-}++pingTonesIO :: IO [SVL.Vector Float]+pingTonesIO =+   fmap+      (\pingVec ->+         map+            (SVL.take 44100 .+             pingVec (SVL.chunkSize 4321) .+             (0.01*))+            [1,1.25,1.5,2::Float])+      (Render.run pingSigP)++{-+Arrange itself does not seem to have a space leak with temporary data.+However it may leak sound data.+This is not very likely because this would result in a large memory leak.++Generate random tones in order to see whether generated sounds leak.+How does 'arrange' compare with 'concat'?+-}++{-+cycleTones :: IO ()+cycleTones = do+--   playMono $+   pings <- pingTonesIO+   SVL.writeFile "test.f32" $+--   Play.auto (0.01::Double) 44100 $+      asMono $+{-+after 13min runtime memory consumption increased from 2.5 to 3.9+and we get lot of buffer underruns with this implementation of amplification+(renderChunky . amplify . fromStorableVector)+-}+      Sig.renderChunky (SVL.chunkSize 432109) $+      Sig.amplify 0.1 $+      Sig.fromStorableVectorLazy $+{-+after 20min memory consumption increased from 2.5 to 3.4+and we get lot of buffer underruns with applyStorableChunky+-}+{-+applyStorableChunky applied to concatenated zero vectors+starts with memory consumption 1.0 and after an hour, it's still 1.1+without buffer underruns.+-}+{-+      CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $+      asMono $+-}+{-+with chunksize 12345678+after 50min runtime the memory consumption increased from 12.0 to 26.2++with chunksize 123+after 25min runtime the memory consumption is constant 7.4+however at start time there 5 buffer underruns, but no more+probably due to initial LLVM compilation++with chunksize 1234567 and SVL.replicate instead of pingTones+we get memory consumption from 1.3 to 3.2 in 15min,+while producing lots of buffer underruns.+After 45min in total, it is still 3.2 of memory consumption.+Is this a memory leak, or isn't it?++with chunksize 12345678 and SVL.replicate+we get from 5.6 to 10.2 in 3min+to 14.9 after total 13min.+-}+{-+      SigStL.arrange (SVL.chunkSize 12345678) $+      EventList.fromPairList $ zip+         (repeat (div 44100 8))+--         (cycle $ map (flip div 4 . (44100*)) [1,2,3])+-}+{-+With plain concatenation of those zero vectors+we stay constantly at 0.4 memory consumption and no buffer underruns over 30min.+-}+      SVL.concat+         (cycle pings)+--         (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0)+   return ()+-}+++tonesChunkSize :: SVL.ChunkSize+numTones :: Int++{-+For one-time-compiled fill functions,+larger chunks have no relevant effect on the processing speed.+-}+(tonesChunkSize, numTones) =+   (SVL.chunkSize 441, 200)+--   (SVL.chunkSize 44100, 200)++fst :: Arrow arrow => arrow (a,b) a+fst = arr P.fst++snd :: Arrow arrow => arrow (a,b) b+snd = arr P.snd+++{-# NOINLINE makePing #-}+makePing :: IO (Float -> Float -> SVL.Vector Float)+makePing =+   fmap ($ tonesChunkSize) $+   Render.run $ \halfLife freq ->+      Causal.envelope+         $< Sig.exponential2 halfLife 1+         $* Sig.osci Wave.saw 0.5 freq++tonesDown :: IO ()+tonesDown = do+   let dist = div 44100 10+   pingp <- makePing+   arrange <- SigStL.makeArranger+   amplify <- CausalRender.run Causal.amplify+   playMonoVector =<<+      (pioApply (amplify (0.03::Float)) $+       arrange tonesChunkSize $+       EventList.fromPairList $+       zip+         (repeat (NonNeg.fromNumber dist))+         (map (SVL.take (numTones * dist) . pingp 50000) $+          iterate (0.999*) 0.01))+++vibes :: (Exp Float, Exp Float) -> Sig.MV Float+vibes (modDepth, freq) =+   let halfLife = 5000+       -- sine = Wave.sine+       sine = Wave.approxSine4+   in Causal.envelope+         $< Sig.exponential2 halfLife 1+         $* (((Causal.osci sine+                $< (Causal.envelope+                       $< Sig.exponential2 halfLife modDepth+                       $* (Causal.osci sine $* Sig.constant (0, 2*freq))))+               <<<+               Causal.amplify freq+               <<<+               (Causal.osci sine * 0.01 + 1))+             $* Sig.constant (0, 0.0001))++makeVibes :: IO ((Float,Float) -> SVL.Vector Float)+makeVibes = fmap ($ tonesChunkSize) $ Render.run vibes++vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> IO (SVL.Vector Float)+vibesCycleVector pingp =+   (\evs -> fmap (\arrange -> arrange tonesChunkSize evs) SigStL.makeArranger) $+   EventList.fromPairList $ zip+      (repeat 5000)+      (map (SVL.take 50000 . pingp) $+       zip+          (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0)+          (cycle $ map (0.01*) [1, 1.25, 1.5, 2]))++pioApply ::+   (Storable a, Storable b) =>+   PIO.T (SV.Vector a) (SV.Vector b) -> SVL.Vector a -> IO (SVL.Vector b)+pioApply proc sig = do+   act <- PIO.runStorableChunkyCont proc+   return $ act (const SVL.empty) sig++pioApplyStrict ::+   (Storable a, Storable b) =>+   PIO.T (SV.Vector a) (SV.Vector b) -> SV.Vector a -> IO (SV.Vector b)+pioApplyStrict proc sig = do+   act <- PIO.runCont proc+   return $+      case act (const []) [sig] of+         chunk : _ -> chunk+         [] -> SV.empty++vibesCycle :: IO ()+vibesCycle = do+   sig <- vibesCycleVector =<< makeVibes+   proc <- CausalRender.run Causal.amplify+   playMonoVector =<< pioApply (proc (0.2::Float)) sig++vibesEcho :: IO ()+vibesEcho = do+   sig <- vibesCycleVector =<< makeVibes+   proc <-+      CausalRender.run (\vol -> Causal.amplify vol <<< Causal.comb 0.5 7000)+   playMonoVector =<< pioApply (proc (0.2::Float)) sig++vibesReverb :: IO ()+vibesReverb = do+   sig <- vibesCycleVector =<< makeVibes+   proc <-+      CausalRender.run+         (\params -> Causal.amplify 0.3 <<< Causal.reverbExplicit params)+   playMonoVector =<<+      pioApply+         (proc (Causal.reverbParams (mkStdGen 142)+                  TypeNum.d16 (0.9,0.97) (400,1000)))+         sig++vibesReverbStereo :: IO ()+vibesReverbStereo = do+   sig <- vibesCycleVector =<< makeVibes+   proc <-+      CausalRender.run+         (\params ->+            Stereo.multiValue+            ^<<+            Causal.amplifyStereo 0.3+            <<<+            Causal.stereoFromMonoParameterized Causal.reverbExplicit params+            <<^+            (\x -> Stereo.cons x x))+   playStereoVector =<<+      pioApply+         (proc+            (fmap+                (\seed ->+                   Causal.reverbParams (mkStdGen seed)+                      TypeNum.d16 (0.9,0.97) (400,1000))+                (Stereo.cons 142 857)))+         sig+++stair :: IO ()+stair =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap+      (\f ->+         f tonesChunkSize $+         EventListBT.fromPairList $+         zip (iterate (/2) 1) (iterate (2*) (1::NonNeg.Integer))) $+   Render.run Const.flatten+++filterBass :: IO ()+filterBass = do+   proc <-+      Render.run $ \xs ->+         (fmap Stereo.multiValue BandPass.causal+          <<<+          CausalClass.feedSnd+            (liftA2 Stereo.cons+               (Sig.osci Wave.saw 0 (frequency 0.001499))+               (Sig.osci Wave.saw 0 (frequency 0.001501)))+          <<<+          Causal.map (BandPass.parameter 100))+         $*+         Const.flatten xs++   playStereoVector $ proc tonesChunkSize $+      EventListBT.fromPairList $+      zip+         (map (((0.01::Float)*) . (2**) . (/12) . fromInteger) $+          randomRs (0,24) (mkStdGen 998))+         (repeat (6300::NonNeg.Int))+++mixVectorStereo ::+   SVL.Vector (Stereo.T Float) ->+   SVL.Vector (Stereo.T Float) ->+   SVL.Vector (Stereo.T Float)+mixVectorStereo = Unsafe.performIO mixVectorStereoIO++mixVectorStereoIO ::+   IO (SVL.Vector (Stereo.T Float) ->+       SVL.Vector (Stereo.T Float) ->+       SVL.Vector (Stereo.T Float))+mixVectorStereoIO =+   (\proc xs ys -> Unsafe.performIO $ pioApply (proc xs) ys)+   <$>+   CausalRender.run (\xs -> Causal.mix $< xs)++{-+slightly slower than mixVectorParam+-}+mixVectorHaskell :: SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float+mixVectorHaskell = SVL.zipWith (+)++toneMix :: IO ()+toneMix = do+   pingp <- makePing+   mix <- CausalRender.run $ \x -> Causal.mix $< x+   amplify <- CausalRender.run (Causal.amplify 0.1)+   playMonoVector+      =<< pioApply amplify+      =<< ((\(x:xs) -> Fold.foldlM (pioApply . mix) x xs) $ take numTones $+           map (pingp 1000000) $ iterate (*(2/3)) 0.01)++fadeEnvelope :: Exp Word -> Exp Word -> Sig.MV Float+fadeEnvelope intro len =+   Sig.parabolaFadeIn intro+   <>+   (Causal.take len $* 1)+   <>+   Sig.parabolaFadeOut intro++fadeEnvelopeWrite :: IO ()+fadeEnvelopeWrite =+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ SVL.chunkSize 1234) $+   Render.run $ fadeEnvelope 100000 200000+++-- | normalize a list of numbers, such that they have a specific average+-- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs+normalizeLevel :: (Field.C a) => a -> [a] -> [a]+normalizeLevel newAvrg xs =+   let avrg = sum xs / fromIntegral (length xs)+   in  map ((newAvrg-avrg)+) xs++stereoOsciParams ::+   (TypeNum.Integer n) =>+   Proxy n -> Float -> (Float, Stereo.T (MultiValue.Array n (Float,Float)))+stereoOsciParams np freq =+   let n = TypeNum.integralFromProxy np+       volume :: Float+       volume = recip $ sqrt $ TypeNum.integralFromProxy np+       detunes :: [Float]+       detunes =+          normalizeLevel 1 $ take (2*n) $+             randomRs (0,0.03) $ mkStdGen 912+       phases :: [Float]+       phases = randomRs (0,1) $ mkStdGen 54+   in (,) volume $+      fmap MultiValue.Array $+      uncurry Stereo.cons $ splitAt n $+      zipWith+         (\phase detune -> (phase, detune*freq))+         phases detunes++stereoOsciSawP ::+   (TypeNum.Natural n) =>+   (TypeNum.Natural arrSize, arrSize ~ (n :*: LLVM.UnknownSize)) =>+   (TypeNum.Natural stereoSize, stereoSize ~ (D2 :*: arrSize)) =>+   Exp Float -> Stereo.T (Exp (MultiValue.Array n (Float,Float))) ->+   Sig.MV (Stereo.T Float)+stereoOsciSawP volume =+   fmap Stereo.multiValue+   .+   stereoFromMonoParameterizedSignal+      (\params ->+         Causal.amplify volume+         $* multiMixSignal+               (\phaseFreq ->+                   Sig.osci Wave.saw+                      (Expr.fst phaseFreq)+                      (Expr.snd phaseFreq))+               params)++stereoFromMonoParameterizedSignal ::+   (Marshal.C x) =>+   (D2 :*: LLVM.SizeOf (Marshal.Struct x) ~ arrSize,+    TypeNum.Natural arrSize) =>+   (Exp x -> Sig.MV Float) ->+   Stereo.T (Exp x) -> Sig.T (Stereo.T (MultiValue.T Float))+stereoFromMonoParameterizedSignal f ps =+   Causal.toSignal $+      Causal.stereoFromMonoParameterized (Causal.fromSignal . f) ps+      <<^+      (\() -> Stereo.cons () ())++multiMixSignal ::+   (TypeNum.Natural n, Marshal.C x,+    n :*: LLVM.SizeOf (Marshal.Struct x) ~ arraySize,+    TypeNum.Natural arraySize,+    Tuple.Undefined a, Tuple.Phi a, A.Additive a) =>+   (Exp x -> Sig.T a) ->+   Exp (MultiValue.Array n x) -> Sig.T a+multiMixSignal f =+   Causal.toSignal . multiMix (Causal.fromSignal . f)++multiMix ::+   (TypeNum.Natural n, Marshal.C x,+    n :*: LLVM.SizeOf (Marshal.Struct x) ~ arraySize,+    TypeNum.Natural arraySize,+    Tuple.Undefined b, Tuple.Phi b, A.Additive b) =>+   (Exp x -> Causal.T a b) ->+   Exp (MultiValue.Array n x) -> Causal.T a b+multiMix f ps =+   Causal.replicateControlledParam (\x -> Causal.mix <<< first (f x)) ps+   <<^+   (\a -> (a, A.zero))++stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float)+stereoOsciSawVector freq =+   Unsafe.performIO $+   (\f -> uncurry (f tonesChunkSize) (stereoOsciParams TypeNum.d5 freq))+   <$>+   Render.run stereoOsciSawP++stereoOsciSawChord :: NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)+stereoOsciSawChord =+   NonEmpty.foldBalanced mixVectorStereo . fmap stereoOsciSawVector++stereoOsciSawPad :: Word -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float)+stereoOsciSawPad dur pitches =+   let attack = 20000+   in Unsafe.performIO $+      fmap+         (\f ->+            Unsafe.performIO $+            pioApply (f attack (dur-attack)) (stereoOsciSawChord pitches)) $+      CausalRender.run+         (\intro len ->+            Stereo.multiValue <$>+               (Causal.envelopeStereo $< fadeEnvelope intro len)+                  <<^ Stereo.unMultiValue)++a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1,+ a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2,+ a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3,+ a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float+a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 :+ a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 :+ a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 :+ a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ =+  iterate ((2 ** recip 12) *) (55/44100)+++chordSequence :: [(Word, NonEmpty.T [] Float)]+chordSequence =+   (2, f1  !: f2  : a2 : c3 : []) :+   (1, g1  !: g2  : b2 : d3 : []) :+   (2, c2  !: g2  : c3 : e3 : []) :+   (1, f1  !: a2  : c3 : f3 : []) :+   (2, g1  !: g2  : b2 : d3 : []) :+   (1, gs1 !: gs2 : b2 : e3 : []) :+   (2, a1  !: e2  : a2 : c3 : []) :+   (1, g1  !: g2  : b2 : d3 : []) :+   (3, c2  !: g2  : c3 : e3 : []) :++   (2, f1  !: f2  : a2 : c3 : []) :+   (1, g1  !: g2  : b2 : d3 : []) :+   (2, c2  !: g2  : c3 : e3 : []) :+   (1, f1  !: a2  : c3 : f3 : []) :+   (2, g1  !: g2  : b2 : d3 : []) :+   (1, gs1 !: gs2 : b2 : e3 : []) :+   (2, a1  !: e2  : a2 : c3 : []) :+   (1, g1  !: g2  : b2 : e3 : []) :+   (3, c2  !: e2  : g2 : c3 : []) :+   []+++withDur :: (Word -> a -> v) -> Word -> a -> (v, NonNeg.Int)+withDur f d ps =+   let dur = d*30000+   in  (f dur ps, NonNeg.fromNumber $ fromIntegral dur)+++padMusic :: IO ()+padMusic = do+   arrange <- SigStL.makeArranger+   amplify <-+      CausalRender.run $ \volume ->+         Stereo.multiValue ^<<+         Causal.amplifyStereo volume <<^+         Stereo.unMultiValue+   (playStereoVector =<<) $+      pioApply (amplify (0.1::Float)) $+      arrange tonesChunkSize $+      EventListTM.switchTimeR const $+      EventListMT.consTime 0 $+      EventListBT.fromPairList $+      map (\(d,ps) -> withDur stereoOsciSawPad d ps)+      chordSequence+++lowpassSweepControlRateCausal ::+   Causal.T+      (Stereo.T (MultiValue.T Float))+      (Stereo.T (MultiValue.T Float))+lowpassSweepControlRateCausal =+--   Causal.stereoFromVector $+   Causal.stereoFromMono $+      UniFilter.lowpass ^<<+      Ctrl.processCtrlRate 128+         (lfoSine (UniFilter.parameter (10::Exp Float)))+++moogSweepControlRateCausal ::+   Causal.T+      (Stereo.T (MultiValue.T Float))+      (Stereo.T (MultiValue.T Float))+moogSweepControlRateCausal =+--   Causal.stereoFromVector $+   Causal.stereoFromMono $+      Ctrl.processCtrlRate 128+         (lfoSine (Moog.parameter TypeNum.d8 (10::Exp Float)))+++filterMusic :: IO ()+filterMusic = do+   arrange <- SigStL.makeArranger+   pad <- stereoOsciSawPadIO+   proc <-+      CausalRender.run $ \volume ->+         Stereo.multiValue ^<<+         Causal.amplifyStereo volume <<<+         moogSweepControlRateCausal <<^+         Stereo.unMultiValue+   (playStereoVector =<<) $+      pioApply (proc (0.05::Float)) $+      arrange tonesChunkSize $+      EventListTM.switchTimeR const $+      EventListMT.consTime 0 $+      EventListBT.fromPairList $+      map (\(d,ps) -> withDur pad d ps)+      chordSequence++++stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float))+stereoOsciSawVectorIO =+   (\f freq -> uncurry (f tonesChunkSize) (stereoOsciParams TypeNum.d5 freq))+   <$>+   Render.run stereoOsciSawP++applyFadeEnvelopeIO ::+   IO (Word -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float))+applyFadeEnvelopeIO =+   let attack = 20000 in+   fmap+      (\f dur sig ->+         Unsafe.performIO $ pioApply (f attack (dur-attack)) sig) $+   CausalRender.run+      (\intro len ->+         Stereo.multiValue <$>+            (Causal.envelopeStereo $< fadeEnvelope intro len)+               <<^ Stereo.unMultiValue)++stereoOsciSawChordIO :: IO (NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float))+stereoOsciSawChordIO = do+   sawv <- stereoOsciSawVectorIO+   mix <- mixVectorStereoIO+   return (NonEmpty.foldBalanced mix . fmap sawv)++stereoOsciSawPadIO ::+   IO (Word -> NonEmpty.T [] Float -> SVL.Vector (Stereo.T Float))+stereoOsciSawPadIO = do+   chrd <- stereoOsciSawChordIO+   envelope <- applyFadeEnvelopeIO+   return $+      \ dur pitches -> envelope dur (chrd pitches)++padMusicIO :: IO ()+padMusicIO = do+   arrange <- SigStL.makeArranger+   pad <- stereoOsciSawPadIO+   amplify <-+      CausalRender.run $ \volume ->+         Stereo.multiValue ^<<+         Causal.amplifyStereo volume <<^+         Stereo.unMultiValue+   (playStereoVector =<<) $+      pioApply (amplify (0.08::Float)) $+      arrange tonesChunkSize $+      EventListTM.switchTimeR const $+      EventListMT.consTime 0 $+      EventListBT.fromPairList $+      map (uncurry (withDur pad)) $+      chordSequence++{-+Apply the envelope separately to each tone of the chord+and mix all tones by 'arrange'.+-}+padMusicSeparate :: IO ()+padMusicSeparate = do+   arrange <- SigStL.makeArranger+   osci <- stereoOsciSawVectorIO+   env <- applyFadeEnvelopeIO+   amplify <-+      CausalRender.run $ \volume ->+         Stereo.multiValue ^<<+         Causal.amplifyStereo volume <<^+         Stereo.unMultiValue+   (playStereoVector =<<) $+      pioApply (amplify (0.08::Float)) $+      arrange tonesChunkSize $+      EventList.flatten $+      EventListTM.switchTimeR const $+      EventListMT.consTime 0 $+      EventListBT.fromPairList $+      map (uncurry (withDur (\d ps ->+         map (\p -> env d (osci p)) $ NonEmpty.flatten ps))) $+      chordSequence+++delay :: IO ()+delay =+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   fmap (\f -> f tonesChunkSize (0::Word) (10000::Word)) $+   Render.run $ \del dur ->+      Causal.delayZero del . Causal.take dur+      $*+      Sig.osci Wave.saw 0 (frequency 0.01)++delayStereo :: IO ()+delayStereo =+   (SVL.writeFile "speedtest.f32" . asStereo =<<) $+   fmap (\f -> f tonesChunkSize (7::Word) (10000::Word)) $+   Render.run $ \del dur ->+      Causal.take dur . liftA2 Stereo.consMultiValue id (Causal.delayZero del)+      $*+      Sig.osci Wave.saw 0 (frequency 0.01)++delayPhaser :: IO ()+delayPhaser =+   (SVL.writeFile "speedtest.f32" . asStereo =<<) $+   fmap (\f -> f tonesChunkSize (40000::Word)) $+   Render.run $ \dur ->+   Func.compileSignal $+      let osci = Func.fromSignal $ Sig.osci Wave.saw 0 (frequency 0.01)+          ctrl =+             Func.fromSignal $+             Sig.osci Wave.triangle 0 $ frequency (1/20000)+      in  Causal.take dur $&+          liftA2 Stereo.consMultiValue+             osci+             (Causal.delayControlledInterpolated Interpolation.cubic 0 100+              $&+              (50+50*ctrl) &|& osci)++++allpassControl ::+   (TypeNum.Natural n) =>+   Proxy n -> Exp Float ->+   Sig.T (Allpass.CascadeParameter n (MultiValue.T Float))+allpassControl order reduct =+   Sig.interpolateConstant reduct $+   lfoSine (Allpass.flangerParameter order) reduct++allpassPhaserCausal, allpassPhaserPipeline ::+   Exp Float ->+   Sig.MV Float ->+   Sig.MV Float+allpassPhaserCausal reduct xs =+   let order = TypeNum.d16+   in 0.5 * Allpass.phaser $< allpassControl order reduct $* xs++allpassPhaserPipeline reduct xs =+   let order = TypeNum.d16+   in (nest (TypeNum.integralFromProxy order) Sig.tail) $+      -- Sig.drop+      --    (TypeNum.integralFromProxy order)+         (0.5 * Allpass.phaserPipeline $< allpassControl order reduct $* xs)++allpassPhaser :: IO ()+allpassPhaser =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap (\f -> f (SVL.chunkSize 100000) (128::Float)) $+   Render.run $+   \reduct ->+--      allpassPhaserCausal reduct $+      allpassPhaserPipeline reduct $+      Sig.osci Wave.saw 0 (frequency 0.01)++noise :: IO ()+noise =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run $+   Sig.noise 0 0.3++noisePacked :: IO ()+noisePacked =+   (SVL.writeFile "speedtest.f32" . asMonoPacked+      . SVL.take (div 10000000 4) =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run $+   SigPS.noise 0 0.3+--   SigPS.pack (SigP.noise 0 0.3)+--   SigPS.packSmall (SigP.noise 0 0.3)++frequencyModulationStorable :: IO ()+frequencyModulationStorable = do+   sample <- Render.run $ Sig.osci Wave.saw 0 (frequency 0.01)+   f <-+      Render.run $ \smp ->+         Causal.frequencyModulationLinear smp $* 0.3+   SVL.writeFile "speedtest.f32" . asMono $+      f (SVL.chunkSize 100000) $ SVL.take 1000000 $ sample (SVL.chunkSize 1000)+++frequencyModulation :: IO ()+frequencyModulation =+   (SVL.writeFile "speedtest.f32" . asMono . SVL.take 10000000 =<<) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (Causal.frequencyModulationLinear (Sig.osci Wave.saw 0 (frequency 0.01))+       $* Sig.exponential2 500000 1)++frequencyModulationStereo :: IO ()+frequencyModulationStereo = do+   sample <- Render.run $ Sig.osci Wave.saw 0 (frequency 0.01)+   f <-+      Render.run $ \smp ->+         Stereo.multiValue ^<<+         Causal.stereoFromMono (Causal.frequencyModulationLinear smp)+            $* Sig.constant (Stereo.cons 0.2999 0.3001)+   SVL.writeFile "speedtest.f32" . asStereo $+      f (SVL.chunkSize 100000) $ SVL.take 1000000 $ sample (SVL.chunkSize 1000)++frequencyModulationProcess :: IO ()+frequencyModulationProcess = do+   proc <-+      CausalRender.run+         (Causal.frequencyModulationLinear+            (Causal.take 50000 $* Sig.osci Wave.saw 0 (frequency 0.01)))+   sample <- Render.run (1 + 0.1 * Sig.osci Wave.approxSine2 0 0.0001)+   SVL.writeFile "speedtest.f32" . asMono =<<+      pioApply proc (sample (SVL.chunkSize 512))++++quantize :: IO ()+quantize =+{-+   SV.writeFile "speedtest.f32" $+   asMono $+   (\xs -> SigP.render xs 10000000 ()) $+-}+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   fmap (SVL.take 10000000) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run $+      (Causal.quantizeLift id+         $<# (5.5::Float)+         $* Sig.osci Wave.saw 0 (frequency 0.01))++quantizedFilterControl :: IO ()+quantizedFilterControl =+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   fmap (SVL.take 10000000) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (0.3 * (UniFilter.lowpass ^<< Ctrl.process)+       $< (Causal.quantizeLift+            (Causal.map (UniFilter.parameter 100) <<<+   --         (Causal.map (Moog.parameter TypeNum.d8 100) <<<+             Causal.map (\x -> 0.01 * exp (2 * x)))+            $<# (128::Float)+            $* Sig.osci Wave.approxSine2 0 (frequency (0.1/44100)))+       $* Sig.osci Wave.saw 0 (frequency 0.01))+++arrowNonShared :: IO ()+arrowNonShared =+   (SVL.writeFile "speedtest.f32" . asStereo =<<) $+   fmap (SVL.take 10000000) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (let osci = Causal.osci Wave.approxSine2+       in liftA2 Stereo.consMultiValue osci osci $* Sig.constant (0, 0.01))++arrowShared :: IO ()+arrowShared =+   (SVL.writeFile "speedtest.f32" . asStereo =<<) $+   fmap (SVL.take 10000000) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (let osci = Func.lift $ Causal.osci Wave.approxSine2+       in Func.compile (liftA2 Stereo.consMultiValue osci osci) $*+          Sig.constant (0, 0.01))++arrowIndependent :: IO ()+arrowIndependent =+   (SVL.writeFile "speedtest.f32" . asStereo =<<) $+   fmap (SVL.take 10000000) $+   fmap ($ SVL.chunkSize 100000) $+   Render.run+      (let osci = Causal.osci Wave.approxSine2+       in Func.compile+               (uncurry Stereo.consMultiValue  <$>+                  (osci *** osci  $&  Func.lift id)) $*+            Sig.constant ((0, 0.01), (0.25, 0.01001)))+++rampDown :: Int -> SV.Vector Float+rampDown n =+   SigS.toStrictStorableSignal n $+   CtrlS.line n (1, 0)++impulses :: Int -> Float -> SVL.Vector Float+impulses n x =+   SVL.fromChunks $+   concatMap (\k -> [SV.singleton x, SV.replicate k 0]) $+   take n $ iterate (2*) 1++convolution :: IO ()+convolution =+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   ((\f ->+      pioApply (f $ Render.buffer $ rampDown 1000) (impulses 18 0.1)) =<<) $+   CausalRender.run FiltNR.convolve++convolutionPacked :: IO ()+convolutionPacked = do+   pack <- Render.run SigPS.pack+   impulsesPacked <- pack SVL.defaultChunkSize $ impulses 18 0.1+   (SVL.writeFile "speedtest.f32" . asMonoPacked =<<) $+      ((\f ->+         pioApply (f $ Render.buffer $ rampDown 1000) impulsesPacked) =<<) $+      CausalRender.run FiltNR.convolvePacked+++helixSaw :: IO ()+helixSaw = do+   let srcFreq = 0.01+       srcLength :: Word+       srcLength = 40000+   osci <- Render.run $ \dur -> Sig.osci Wave.saw 0 srcFreq * (1-Sig.ramp dur)+   let perc =+         asMono $ osci (fromIntegral srcLength) srcLength+   SV.writeFile "osci-saw.f32" perc+   stretched <-+      Render.run $ \dur sig ->+      Func.compileSignal $+      (Helix.static Interpolation.cubic Interpolation.cubic+            100 (recip srcFreq) sig+         $&+         (Func.fromSignal $ Sig.amplify (fromIntegral srcLength) $ Sig.ramp dur)+         &|&+         (Causal.osciCore $& 0 &|& 0.01))+   SVL.writeFile "osci-stretched.f32" . asMono =<<+      stretched SVL.defaultChunkSize (80000::Word) (Render.buffer perc)+++loadTomato :: IO (Float, SVL.Vector Float)+loadTomato = do+   let Sample.Info name _sampleRate positions = Sample.tomatensalat+   word <- Sample.load (Default.sampleDirectory </> name)+   return (Sample.period $ head positions, word)++helixOsci :: Exp Float -> Func.T a (MultiValue.T Float)+helixOsci period =+   Causal.osciCore  $&  0 &|& Func.fromSignal (Sig.constant (recip period))++helixSpeechStaticSig ::+   Func.T () (MultiValue.T Float) ->+   Exp (Source.StorableVector Float) ->+   Exp Float ->+   Sig.MV Float+helixSpeechStaticSig shape word period =+   Func.compileSignal+      (Helix.static Interpolation.linear Interpolation.linear+          (Expr.roundToIntFast period) period word+       $&+       shape+       &|&+       helixOsci period)++helixSpeechStaticSpeed ::+   Exp Float ->+   Exp (Source.StorableVector Float) ->+   Exp Float ->+   Sig.MV Float+helixSpeechStaticSpeed speed word =+   helixSpeechStaticSig+      (Func.fromSignal+         (Causal.takeWhile+            (Expr.fromIntegral (Source.storableVectorLength word) >*)+          $*+          Sig.rampSlope speed))+      word++helixSpeechStatic :: IO ()+helixSpeechStatic = do+   smp <- loadTomato+   stretched <-+      Render.run $ \speed (period, word) ->+         helixSpeechStaticSpeed speed word period+   (SVL.writeFile "speech-stretched.f32" . asMono =<<) $+      stretched SVL.defaultChunkSize (0.5::Float) $+      mapSnd (Render.buffer . SV.concat . SVL.chunks) smp++helixSpeechDynamicSig ::+   Func.T () (MultiValue.T Float) ->+   Sig.MV Float ->+   Exp Float ->+   Sig.MV Float+helixSpeechDynamicSig shape word period =+   Func.compileSignal+      (Helix.dynamicLimited Interpolation.linear Interpolation.linear+          (Expr.roundToIntFast period) period word+       $&+       shape+       &|&+       helixOsci period)++helixSpeechDynamicSpeed ::+   Exp Float ->+   Sig.MV Float ->+   Exp Float ->+   Sig.MV Float+helixSpeechDynamicSpeed speed =+   helixSpeechDynamicSig (Func.fromSignal $ Sig.constant speed)++helixSpeechDynamic :: IO ()+helixSpeechDynamic = do+   smp <- loadTomato+   stretched <-+      Render.run $ \speed (period, word) ->+      helixSpeechDynamicSpeed speed word period+   SVL.writeFile "speech-stretched.f32" $ asMono $+      stretched SVL.defaultChunkSize (0.5::Float) smp++helixSpeechCompare :: IO ()+helixSpeechCompare = do+   (per,smp) <- loadTomato+   stretched <-+      Render.run $ \speed period word wordBuffer ->+      fmap Stereo.multiValue $+      sequenceA $+      Stereo.cons+         (helixSpeechStaticSpeed speed wordBuffer period)+         (helixSpeechDynamicSpeed speed word period)+   SVL.writeFile "speech-stretched.f32" $ asStereo $+      stretched SVL.defaultChunkSize (0.5::Float)+         per smp (Render.buffer . SV.concat . SVL.chunks $ smp)++helixSpeechVariCompare :: IO ()+helixSpeechVariCompare = do+   (per,smp) <- loadTomato+   stretched <-+      Render.run $ \period word wordBuffer ->+      fmap Stereo.multiValue $+      sequenceA $+      let speed =+             Func.fromSignal $ Sig.cycle $+             Sig.fromArray $ Expr.cons $+             (MultiValue.Array [0.2, 0.5, 1, 1.5, 1.8]+                :: MultiValue.Array TypeNum.D5 Float)+      in  Stereo.cons+             (helixSpeechStaticSig+                 (Causal.integrateZero $& speed)+                 wordBuffer period)+             (helixSpeechDynamicSig speed word period)+   SVL.writeFile "speech-stretched.f32" $ asStereo $+      stretched SVL.defaultChunkSize+         per smp (Render.buffer . SV.concat . SVL.chunks $ smp)++helixLimited :: IO ()+helixLimited = do+   let period = 100+       srcLength :: Int+       srcLength = 500+       dstLength = 5000+       speed :: Exp Float+       speed = 0.5+       osci =+          0.5+          *+          Sig.ramp (fromIntegral srcLength)+          *+          Sig.osci Wave.approxSine2 0 (recip period)+   renderOsci <- Render.run osci+   let osciVec = renderOsci srcLength+   SV.writeFile "helix-orig.f32" $ asMono osciVec++   let stretchedStatic osciBuffer =+          Helix.static Interpolation.linear Interpolation.linear+             (Expr.roundToIntFast period) period osciBuffer+          $&+          Func.fromSignal (Sig.rampSlope speed)+          &|&+          helixOsci period+       stretchedDynamic =+          Helix.dynamic Interpolation.linear Interpolation.linear+             (Expr.roundToIntFast period) period osci+          $&+          Func.fromSignal (Sig.constant speed)+          &|&+          helixOsci period+       stretched osciBuffer =+          liftA2 Stereo.consMultiValue+             (stretchedStatic osciBuffer) stretchedDynamic+   renderHelix <- Render.run $ Func.compileSignal . stretched+   SV.writeFile "helix-stretched.f32" $ asStereo $+      renderHelix dstLength (Render.buffer osciVec)++cycleRamp :: IO ()+cycleRamp =+   SVL.writeFile "speedtest.f32" . asMono .+         (\f -> f SVL.defaultChunkSize (10000::Word)) =<<+      Render.run+         (\dur ->+            Causal.take 100000 $*+            Sig.cycle (Sig.append (Sig.ramp dur) (1 - Sig.ramp dur)))++zigZag :: IO ()+zigZag =+   SVL.writeFile "speedtest.f32" . asMono .+         (\f -> f SVL.defaultChunkSize (-3::Float)) =<<+      Render.run+         (\start -> Causal.take 100000 $* (Helix.zigZag start $* 0.0001))++zigZagPacked :: IO ()+zigZagPacked =+   SVL.writeFile "speedtest.f32" . asMonoPacked .+         (\f -> f SVL.defaultChunkSize (-3::Float)) =<<+      Render.run+         (\start ->+            let vectorSize = 4+            in Causal.take (fromInteger $ div 100000 vectorSize) $*+                  (Helix.zigZagPacked start $* 0.0001))+++trigger :: IO ()+trigger =+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ SVL.defaultChunkSize) $+      Render.run+         (let pause len =+                 CausalClass.applyConst (Causal.take len) Maybe.nothing+              pulse :: Float -> Exp Word -> Sig.T (Maybe.T (MultiValue.T Float))+              pulse freq len =+                 Causal.take len .+                 arr (flip Maybe.fromBool (MultiValue.cons freq) . unbool) .+                 Causal.delay1 Expr.true $*# False+          in  (Causal.zipWith ExprMaybe.select+                  $> Sig.noise 0 (0.01 :: Exp Float)) $*+              (Causal.trigger (\freq -> Causal.take 150000 $* pingSigP freq) $*+               pause 50000 <>+               pulse 0.004 100000 <>+               pulse 0.005 200000 <>+               pulse 0.006 400000))++-- FixMe: duplicate of CausalExp.ProcessPrivate+unbool :: MultiValue.T Bool -> LLVM.Value Bool+unbool (MultiValue.Cons b) = b+++triggerLFO :: Sig.MV Float+triggerLFO =+   Sig.osci Wave.approxSine2 0 0.00015+   ++   Sig.osci Wave.approxSine2 0 0.000037++trackZeros :: Causal.MV Float Bool+trackZeros =+   Causal.zipWith (\x y -> x &&* Expr.not y) .+   (id &&& Causal.delay1 Expr.false) .+   Causal.map (>* 0)++fmPingSig :: Exp Float -> Exp Float -> Sig.MV Float+fmPingSig freq depth =+   Sig.exponential2 5000 1+   *+   ((Causal.osci Wave.approxSine2 $> Sig.constant freq)+    $*+    (Sig.constant depth * Sig.osci Wave.approxSine2 0 (2*freq)))++sweepTrigger :: IO ()+sweepTrigger =+   (SVL.writeFile "speedtest.f32" . asMono =<<) $+   fmap ($ SVL.defaultChunkSize) $+      Render.run+         ((Causal.zipWith ExprMaybe.select $> Sig.noise 0 0.01) $*+            (Causal.trigger (fmPingSig 0.005) $*+               liftA2 (Maybe.fromBool . unbool)+                  (Causal.take 10000000 . trackZeros $* triggerLFO)+                  (5 * Sig.osci Wave.approxSine2 0 0.00001)))   main :: IO ()
example/Synthesizer/LLVM/TestALSA.hs view
@@ -2,6 +2,11 @@  import qualified Synthesizer.LLVM.LNdW2011 as LNdW +import Control.Monad (when) + main :: IO ()-main = LNdW.flyPacked+main = do+   when True LNdW.flyPacked+   when False LNdW.modulation+   when False LNdW.bubblesPacked
jack/Synthesizer/LLVM/Server/JACK.hs view
@@ -13,13 +13,16 @@ import qualified Synthesizer.MIDI.CausalIO.Process as MIO import qualified Synthesizer.CausalIO.Process as PIO -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Storable.Signal as SigStL  import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Type.Data.Num.Decimal as TypeNum+ import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB import Foreign.Marshal.Array (copyArray)@@ -47,9 +50,8 @@ import qualified System.Path.PartClass as PathClass import qualified System.Path as Path -import Control.Arrow ((<<<), (^<<), arr)+import Control.Arrow (arr, (<<<), (^<<)) import Control.Category (id)-import Control.Applicative (pure)  import qualified System.Random as Random import qualified Numeric.NonNegative.Wrapper as NonNegW@@ -205,11 +207,11 @@ keyboardMultiChannel = do    opt <- Option.get    proc <- keyboardDetuneFMCore (Option.sampleDirectory opt)-   mix <- CausalP.processIO CausalP.mix+   mix <- CausalRender.run Causal.mix     playStereoFromEvents opt $ \ sampleRate ->       foldl1-         (\x y -> mix () <<< Zip.arrowFanout x y)+         (\x y -> mix <<< Zip.arrowFanout x y)          (map              (\chan ->                 proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)@@ -232,24 +234,29 @@ voderMaskSeparated :: IO () voderMaskSeparated = do    opt <- Option.get-   let postProcessing =+   let postProcessing params =           if True             then-               let reverb seed =-                      CausalP.reverb-                         (pure $ Random.mkStdGen seed) 16 (pure (0.92,0.98))-                         (fmap (\(SampleRate rate) -> (round (rate/200), round (rate/40))) id)-               in  CausalPS.pack (Stereo.arrowFromChannels (reverb 42) (reverb 23))+               CausalPS.pack+                  (Stereo.arrowFromChannels+                     (Causal.reverbExplicit $ Stereo.left params)+                     (Causal.reverbExplicit $ Stereo.right params))             else id    proc <-       Arrange.voderMaskSeparated-         (arr unconsStereo <<< postProcessing)+         (\reverbParams -> unconsStereo ^<< postProcessing reverbParams)          (Option.sampleDirectory opt) -   playStereoFromEvents opt $ \ sampleRate ->+   playStereoFromEvents opt $ \ sampleRate@(SampleRate rate) ->       proc          (Option.channel opt) (Option.extraChannel opt)          (VoiceMsg.toProgram 4) sampleRate+         (fmap+            (\seed ->+               Causal.reverbParams+                  (Random.mkStdGen seed) TypeNum.d16 (0.92,0.98)+                  (round (rate/200), round (rate/40)))+            (Stereo.cons 42 23))   main :: IO ()
render/Synthesizer/LLVM/Server/Render.hs view
@@ -7,6 +7,7 @@  import qualified Synthesizer.LLVM.Server.Option as Option import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import Synthesizer.LLVM.Server.CausalPacked.Common (chopEvents) import Synthesizer.LLVM.Server.Common  import qualified Synthesizer.CausalIO.Process as PIO@@ -59,7 +60,7 @@ render :: Option.T -> IO (MidiFile.T -> SVL.Vector (Stereo.T Real)) render opt = do    proc <--      case 0::Int of+      case fromInteger 0 :: Int of          0 -> Arrange.keyboardMultiChannel $ Option.sampleDirectory opt          _ -> Arrange.voderMaskMulti $ Option.sampleDirectory opt    run <- PIO.runCont $ proc $ fmap fromIntegral $ Option.sampleRate opt
server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs view
@@ -1,6 +1,7 @@ module Synthesizer.LLVM.Server.CausalPacked.Arrange where -import Synthesizer.LLVM.Server.CommonPacked (VectorSize, Vector, VectorValue, stair)+import Synthesizer.LLVM.Server.CommonPacked+         (VectorSize, Vector, VectorValue, stair)  import qualified Sound.MIDI.Controller as Ctrl @@ -18,8 +19,10 @@ import qualified Synthesizer.PiecewiseConstant.Signal as PC  import qualified Synthesizer.LLVM.Plug.Output as POut-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render import qualified Synthesizer.LLVM.Storable.Process as CausalSt import qualified Synthesizer.LLVM.Storable.Signal as SigStL @@ -42,14 +45,13 @@ import qualified System.Path.PartClass as PathClass import qualified System.Path as Path -import Control.Arrow (Arrow, arr, first, (<<<), (^<<))+import Control.Arrow (Arrow, arr, (***), (<<<), (^<<), (<<^)) import Control.Category (id) import Control.Applicative ((<*>))  import qualified Data.List.HT as ListHT-import Data.Maybe.HT (toMaybe)- import qualified Data.Map as Map+import Data.Maybe.HT (toMaybe)  import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim@@ -72,12 +74,12 @@        PIO.T (MIO.Events msg) (SV.Vector Vector)) keyboard = do    arrange <- CausalSt.makeArranger-   amp <- CausalP.processIO (CausalPS.amplify 0.2)+   amp <- CausalRender.run (CausalPS.amplify 0.2)     ping <- Instr.pingRelease     return $ \ chan sampleRate ->-      amp ()+      amp       <<<       arrange       <<<@@ -117,19 +119,19 @@  keyboardFM ::    (Check.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    ChannelMsg.Channel ->    IO (SampleRate Real -> PIO.T (MIO.Events msg) b) keyboardFM emitStereo chan = do    arrange <- CausalSt.makeArranger    amp <--      CausalP.processIO-         (emitStereo <<< CausalPS.amplifyStereo 0.2)+      CausalRender.run+         (emitStereo <<< CausalPS.amplifyStereo 0.2 <<^ Stereo.unMultiValue)     ping <- Instr.pingStereoReleaseFM     return $ \ sampleRate ->-      amp ()+      amp       <<<       arrange       <<<@@ -201,19 +203,19 @@  keyboardDetuneFMCore ::    (PathClass.AbsRel ar, Check.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->        SampleRate Real -> PIO.T (MIO.Events msg) b) keyboardDetuneFMCore emitStereo smpDir = do    arrange <- keyboardDetuneFMConstVolume smpDir    amp <--      CausalP.processIO+      CausalRender.run          (emitStereo <<<-          CausalP.envelopeStereo <<<-          first (CausalP.mapSimple Serial.upsample))+          Causal.envelopeStereo <<<+          Causal.map Serial.upsample *** arr Stereo.unMultiValue)    return $ \chan initPgm rate ->-      amp ()+      amp       <<<       MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)       &+&@@ -433,15 +435,15 @@ keyboardMultiChannel smpDir = do    proc <-       keyboardDetuneFMCore-         (CausalP.mapSimple StereoInt.interleave)+         (Causal.map StereoInt.interleave)          smpDir-   mix <- CausalP.processIO CausalP.mix+   mix <- CausalRender.run Causal.mix     return $ \ sampleRate ->       arr SigStL.unpackStereoStrict       <<<       foldl1-         (\x y -> mix () <<< Zip.arrowFanout x y)+         (\x y -> mix <<< Zip.arrowFanout x y)          (map              (\chan ->                 proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)@@ -485,18 +487,18 @@  voder ::    (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    Speech.VowelSynth ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->        SampleRate Real -> PIO.T (MIO.Events msg) b) voder emitStereo voice smpDir = do-   carrier <- keyboardDetuneFMCore id smpDir+   carrier <- keyboardDetuneFMCore (arr Stereo.multiValue) smpDir    arrange <- CausalSt.makeArranger-   interleave <- CausalP.processIO emitStereo+   interleave <- CausalRender.run (emitStereo <<^ Stereo.unMultiValue)     return $ \chan initPgm sampleRate ->-      interleave ()+      interleave       <<<       arrange       <<<@@ -512,7 +514,7 @@  voderBand ::    (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->        SampleRate Real -> PIO.T (MIO.Events msg) b)@@ -522,7 +524,7 @@  voderMask ::    (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->        SampleRate Real -> PIO.T (MIO.Events msg) b)@@ -538,7 +540,7 @@  voderEnv ::    (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    Speech.VowelSynthEnv ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->@@ -547,13 +549,13 @@    carrier <- keyboardDetuneFMConstVolume smpDir    arrange <- CausalSt.makeArranger    amp <--      CausalP.processIO+      CausalRender.run          (emitStereo <<<-          CausalP.envelopeStereo <<<-          first (CausalP.mapSimple Serial.upsample))+          Causal.envelopeStereo <<<+          Causal.map Serial.upsample *** arr Stereo.unMultiValue)     return $ \chan initPgm sampleRate ->-      amp ()+      amp       <<<       MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)       &+&@@ -574,7 +576,7 @@  voderMaskEnv ::    (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+   Causal.T (Stereo.T VectorValue) (POut.Element b) ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> VoiceMsg.Program ->        SampleRate Real -> PIO.T (MIO.Events msg) b)@@ -584,23 +586,24 @@   voderSeparated ::-   (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->+   (PathClass.AbsRel ar, Render.RunArg p,+    Check.C msg, Construct.C msg, POut.Default b) =>+   (Render.DSLArg p -> Causal.T (Stereo.T VectorValue) (POut.Element b)) ->    Speech.VowelSynthEnv ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->-       SampleRate Real -> PIO.T (MIO.Events msg) b)+       SampleRate Real -> p -> PIO.T (MIO.Events msg) b) voderSeparated emitStereo voice smpDir = do-   carrier <- keyboardDetuneFMCore id smpDir+   carrier <- keyboardDetuneFMCore (arr Stereo.multiValue) smpDir    arrange <- CausalSt.makeArranger    amp <--      CausalP.processIO-         (emitStereo <<<-          CausalP.envelopeStereo <<<-          first (CausalP.mapSimple Serial.upsample))+      CausalRender.run $ \p ->+         (emitStereo p <<<+          Causal.envelopeStereo <<<+          Causal.map Serial.upsample *** arr Stereo.unMultiValue) -   return $ \carrierChan phonemeChan initPgm sampleRate ->-      amp sampleRate+   return $ \carrierChan phonemeChan initPgm sampleRate p ->+      amp p       <<<       MIO.controllerExponential phonemeChan controllerVolume (0.001, 1) (0.2::Float)       &+&@@ -618,11 +621,12 @@              (carrier carrierChan initPgm sampleRate)))  voderMaskSeparated ::-   (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>-   CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->+   (PathClass.AbsRel ar, Render.RunArg p,+    Check.C msg, Construct.C msg, POut.Default b) =>+   (Render.DSLArg p -> Causal.T (Stereo.T VectorValue) (POut.Element b)) ->    Path.Dir ar ->    IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->-       SampleRate Real -> PIO.T (MIO.Events msg) b)+       SampleRate Real -> p -> PIO.T (MIO.Events msg) b) voderMaskSeparated emitStereo smpDir = do    voice <- Speech.phonemeMask <*> Speech.loadMasksGrouped    voderSeparated emitStereo voice smpDir@@ -633,22 +637,22 @@    IO (SampleRate Real ->        PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real))) voderMaskMulti smpDir = do-   mix <- CausalP.processIO CausalP.mix+   mix <- CausalRender.run Causal.mix    proc <-       voderMaskSeparated-         (CausalP.mapSimple StereoInt.interleave)+         (const $ Causal.map StereoInt.interleave)          smpDir     return $ \ sampleRate ->       arr SigStL.unpackStereoStrict       <<<       foldl1-         (\x y -> mix () <<< Zip.arrowFanout x y)+         (\x y -> mix <<< Zip.arrowFanout x y)          (map              (\chan ->                 proc                    (ChannelMsg.toChannel chan)                    (ChannelMsg.toChannel $ succ chan)                    (VoiceMsg.toProgram 4)-                   sampleRate)+                   sampleRate ())              [0, 2, 4, 6])
src/Synthesizer/LLVM/Causal/Controlled.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {- | This module provides a type class that automatically selects a filter@@ -10,9 +11,13 @@ because there may be different ways to specify the filter parameters but there is only one implementation of the filter itself. -}-module Synthesizer.LLVM.Causal.Controlled (C(..)) where+module Synthesizer.LLVM.Causal.Controlled (+   C(..),+   processCtrlRate,+   ) where -import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFiltPack+import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked+                                                           as ComplexFiltPack import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilt import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1@@ -22,30 +27,48 @@ import qualified Synthesizer.LLVM.Filter.Moog as Moog import qualified Synthesizer.LLVM.Filter.Universal as UniFilter -import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import Synthesizer.Causal.Class (($<))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM-import LLVM.Core (Value, IsConst)  import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal.Number ((:*:)) +import qualified Algebra.Module as Module +++processCtrlRate ::+   (C parameter a b, Memory.C parameter) =>+   (Marshal.C r, MultiValue.IntegerConstant r,+    MultiValue.Additive r, MultiValue.Comparison r) =>+   Exp r -> (Exp r -> Sig.T parameter) -> Causal.T a b+processCtrlRate reduct ctrlGen =+   process $< Sig.interpolateConstant reduct (ctrlGen reduct)++ {- | A filter parameter type uniquely selects a filter function. However it does not uniquely determine the input and output type, since the same filter can run on mono and stereo signals. -} class (a ~ Input parameter b, b ~ Output parameter a) => C parameter a b where-   type Input  parameter b :: *-   type Output parameter a :: *-   process :: (Causal.C process) => process (parameter, a) b+   type Input  parameter b+   type Output parameter a+   process :: Causal.T (parameter, a) b   {-@@ -54,7 +77,7 @@ -}  instance-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a,+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v,     Memory.C a, Memory.C v) =>       C (Filt1.Parameter a) v (Filt1.Result v) where    type Input  (Filt1.Parameter a) (Filt1.Result v) = v@@ -70,27 +93,25 @@    process = Filt2.causal  instance-   (Vector.Arithmetic a, SoV.RationalConstant a,-    Memory.C (Value (Filt2P.State a))) =>-      C (Filt2P.Parameter a)-        (Value a) (Value a) where-   type Input  (Filt2P.Parameter a) (Value a) = Value a-   type Output (Filt2P.Parameter a) (Value a) = Value a+   (Marshal.C a, Marshal.Vector TypeNum.D4 a, MultiVector.PseudoRing a) =>+      C (Filt2P.Parameter a) (MultiValue.T a) (MultiValue.T a) where+   type Input  (Filt2P.Parameter a) (MultiValue.T a) = MultiValue.T a+   type Output (Filt2P.Parameter a) (MultiValue.T a) = MultiValue.T a    process = Filt2P.causal  instance-   (LLVM.IsSized v, SoV.PseudoModule v, SoV.Scalar v ~ a,-    LLVM.IsSized a, SoV.IntegerConstant a,-    TypeNum.Natural n,-    TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-      C (Cascade.ParameterValue n a) (Value v) (Value v) where-   type Input  (Cascade.ParameterValue n a) (Value v) = Value v-   type Output (Cascade.ParameterValue n a) (Value v) = Value v+   (a ~ MultiValue.Scalar v, MultiValue.PseudoModule v,+    Marshal.C a, MultiValue.IntegerConstant a, Marshal.C v,+    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize),+    inp ~ MultiValue.T v, out ~ MultiValue.T v) =>+      C (Cascade.ParameterValue n a) inp out where+   type Input  (Cascade.ParameterValue n a) out = out+   type Output (Cascade.ParameterValue n a) inp = inp    process = Cascade.causal   instance-   (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v,     Memory.C a, Memory.C v) =>       C (Allpass.Parameter a) v v where    type Input  (Allpass.Parameter a) v = v@@ -98,9 +119,8 @@    process = Allpass.causal  instance-   (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,-    Memory.C a, Memory.C v,-    TypeNum.Natural n) =>+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v,+    Memory.C a, Memory.C v, TypeNum.Natural n) =>       C (Allpass.CascadeParameter n a) v v where    type Input  (Allpass.CascadeParameter n a) v = v    type Output (Allpass.CascadeParameter n a) v = v@@ -108,7 +128,7 @@   instance-   (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v,     Memory.C v, TypeNum.Natural n) =>       C (Moog.Parameter n a) v v where    type Input  (Moog.Parameter n a) v = v@@ -117,7 +137,7 @@   instance-   (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,+   (A.PseudoModule v, A.Scalar v ~ a, A.RationalConstant a,     Memory.C a, Memory.C v) =>       C (UniFilter.Parameter a) v (UniFilter.Result v) where    type Input  (UniFilter.Parameter a) (UniFilter.Result v) = v@@ -132,10 +152,9 @@    process = ComplexFilt.causal  instance-   (Vector.Arithmetic a, IsConst a,-    Memory.C (Value (Filt2P.State a))) =>-      C (ComplexFiltPack.Parameter a)-        (Stereo.T (Value a)) (Stereo.T (Value a)) where-   type Input  (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a)-   type Output (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a)+   (Marshal.Vector n a, n ~ TypeNum.D3, MultiVector.PseudoRing a,+    inp ~ MultiValue.T a, out ~ MultiValue.T a) =>+      C (ComplexFiltPack.ParameterMV a) (Stereo.T inp) (Stereo.T out) where+   type Input  (ComplexFiltPack.ParameterMV a) (Stereo.T out) = Stereo.T out+   type Output (ComplexFiltPack.ParameterMV a) (Stereo.T inp) = Stereo.T inp    process = ComplexFiltPack.causal
src/Synthesizer/LLVM/Causal/ControlledPacked.hs view
@@ -2,47 +2,73 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {- |-This is like "Synthesizer.LLVM.Causal.Controlled"+This is like "Synthesizer.LLVM.CausalExp.Controlled" but for vectorised signals. -}-module Synthesizer.LLVM.Causal.ControlledPacked (C(..)) where+module Synthesizer.LLVM.Causal.ControlledPacked (+   C(..),+   processCtrlRate,+   ) where +import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2-import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade import qualified Synthesizer.LLVM.Filter.Moog as Moog import qualified Synthesizer.LLVM.Filter.Universal as UniFilter -import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalS+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import Synthesizer.Causal.Class (($<))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM-import LLVM.Core (IsSized)  import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal.Number ((:*:)) +import qualified Algebra.Module as Module+import qualified NumericPrelude.Numeric as NP+ import Control.Arrow ((<<<), arr, first)  ++processCtrlRate ::+   (C parameter av bv, Memory.C parameter,+    Serial.Read  av, n ~ Serial.Size av,+    Serial.Write bv, n ~ Serial.Size bv) =>+   (Marshal.C r, MultiValue.RationalConstant r,+    MultiValue.Field r, MultiValue.Comparison r) =>+   Exp r -> (Exp r -> Sig.T parameter) -> Causal.T av bv+processCtrlRate reduct ctrlGen = Serial.withSize $ \n ->+   process $<+      Sig.interpolateConstant (reduct / NP.fromIntegral n) (ctrlGen reduct)++ {- | A filter parameter type uniquely selects a filter function. However it does not uniquely determine the input and output type, since the same filter can run on mono and stereo signals. -}-class (a ~ Input parameter b, b ~ Output parameter a) => C parameter a b where-   type Input  parameter b :: *-   type Output parameter a :: *-   process :: (Causal.C process) => process (parameter, a) b+class (Output parameter a ~ b, Input parameter b ~ a) => C parameter a b where+   type Output parameter a+   type Input  parameter b+   process :: Causal.T (parameter, a) b   {-@@ -51,29 +77,29 @@ -}  instance-   (Serial.C v, Serial.Element v ~ a,-    A.PseudoRing a, A.IntegerConstant a, Memory.C a,-    A.PseudoRing v) =>+   (Serial.Write v, Serial.Element v ~ a,+    A.PseudoRing v, A.IntegerConstant v,+    A.PseudoRing a, A.IntegerConstant a, Expr.Aggregate ae a,+    Tuple.Phi a, Tuple.Undefined a, Memory.C a) =>       C (Filt1.Parameter a) v (Filt1.Result v) where    type Input  (Filt1.Parameter a) (Filt1.Result v) = v    type Output (Filt1.Parameter a) v = Filt1.Result v    process = Filt1.causalPacked  instance-   (Serial.C v, Serial.Element v ~ a,-    A.PseudoRing a, A.IntegerConstant a, Memory.C a,-    A.PseudoRing v, A.IntegerConstant v, Memory.C v) =>+   (Serial.Write v, Serial.Element v ~ a,+    A.PseudoRing v, A.IntegerConstant v,+    A.PseudoRing a, A.IntegerConstant a, Expr.Aggregate ae a,+    Tuple.Phi a, Tuple.Undefined a, Memory.C a, Memory.C v) =>       C (Filt2.Parameter a) v v where    type Input  (Filt2.Parameter a) v = v    type Output (Filt2.Parameter a) v = v    process = Filt2.causalPacked  instance-   (LLVM.Value a ~ A.Scalar v, A.PseudoModule v,-    Serial.C v, Serial.Element v ~ LLVM.Value a,-    SoV.IntegerConstant a,-    A.PseudoRing v, A.IntegerConstant v, Memory.C v,-    LLVM.IsPrimitive a, IsSized a,+   (Serial.Write v, Serial.Element v ~ MultiValue.T a,+    Memory.C v, A.PseudoRing v, A.IntegerConstant v,+    Marshal.C a, MultiValue.PseudoRing a, MultiValue.IntegerConstant a,     TypeNum.Positive (n :*: LLVM.UnknownSize),     TypeNum.Natural n) =>       C (Cascade.ParameterValue n a) v v where@@ -81,11 +107,10 @@    type Output (Cascade.ParameterValue n a) v = v    process = Cascade.causalPacked - instance-   (Serial.C v, Serial.Element v ~ a,-    Memory.C a, A.IntegerConstant a,-    A.PseudoRing v, A.PseudoRing a) =>+   (Serial.Write v, Serial.Element v ~ a,+    A.PseudoRing a, A.IntegerConstant a, Memory.C a,+    A.PseudoRing v, A.IntegerConstant v) =>       C (Allpass.Parameter a) v v where    type Input  (Allpass.Parameter a) v = v    type Output (Allpass.Parameter a) v = v@@ -93,7 +118,7 @@  instance    (TypeNum.Natural n,-    Serial.C v, Serial.Element v ~ a,+    Serial.Write v, Serial.Element v ~ a,     A.PseudoRing a, A.IntegerConstant a, Memory.C a,     A.PseudoRing v, A.RationalConstant v) =>       C (Allpass.CascadeParameter n a) v v where@@ -103,23 +128,22 @@   instance-   (Serial.C v, Serial.Element v ~ b, Tuple.Phi a, Tuple.Undefined a,-    a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b,-    TypeNum.Natural n) =>+   (TypeNum.Natural n,+    Serial.Write v, Serial.Element v ~ b, Memory.C b,+    Tuple.Phi a, Tuple.Undefined a,+    Expr.Aggregate ae a, Expr.Aggregate be b, Module.C ae be) =>       C (Moog.Parameter n a) v v where    type Input  (Moog.Parameter n a) v = v    type Output (Moog.Parameter n a) v = v-   process =-      CausalS.pack Moog.causal <<<-      first (arr Serial.constant)+   process = CausalP.pack Moog.causal <<< first (arr Serial.constant)   instance-   (Serial.C v, Serial.Element v ~ b, Tuple.Phi a, Tuple.Undefined a,-    a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b) =>+   (Serial.Write v, Serial.Element v ~ b, Memory.C b,+    Tuple.Phi a, Tuple.Undefined a,+    Expr.Aggregate ae a, Expr.Aggregate be b, Module.C ae be) =>       C (UniFilter.Parameter a) v (UniFilter.Result v) where    type Input  (UniFilter.Parameter a) (UniFilter.Result v) = v    type Output (UniFilter.Parameter a) v = UniFilter.Result v    process =-      CausalS.pack UniFilter.causal <<<-      first (arr Serial.constant)+      CausalP.pack UniFilter.causalExp <<< first (arr Serial.constant)
+ src/Synthesizer/LLVM/Causal/Exponential2.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{- |+Exponential curve with controllable delay.+-}+module Synthesizer.LLVM.Causal.Exponential2 (+   Parameter,+   parameter,+   parameterPlain,+   multiValueParameter,+   unMultiValueParameter,+   causal,++   ParameterPacked,+   parameterPacked,+   parameterPackedExp,+   parameterPackedPlain,+   multiValueParameterPacked,+   unMultiValueParameterPacked,+   causalPacked,+   ) where++import qualified Synthesizer.LLVM.Causal.Private as CausalPriv+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Causal.Functional as F+import qualified Synthesizer.LLVM.Frame.SerialVector.Plain as SerialPlain+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialOld+import qualified Synthesizer.LLVM.Value as Value++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value, IsFloating)++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign.Storable.Traversable as Store+import qualified Foreign.Storable+import Foreign.Storable (Storable)++import qualified Control.Applicative as App+import Control.Applicative (liftA2, pure, (<*>))+import Control.Arrow (arr, (&&&))++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+import Data.Traversable (traverse)++import qualified Algebra.Transcendental as Trans++import NumericPrelude.Numeric+import NumericPrelude.Base+++newtype Parameter a = Parameter a+   deriving (Show, Storable)+++instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f (Parameter k) = Parameter (f k)++instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x+   {-# INLINE (<*>) #-}+   Parameter f <*> Parameter k = Parameter (f k)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA (Parameter k) = fmap Parameter k+++instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where+   phi = Tuple.phiTraversable+   addPhi = Tuple.addPhiFoldable++instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where+   undef = Tuple.undefPointed++instance Tuple.Zero a => Tuple.Zero (Parameter a) where+   zero = Tuple.zeroPointed++instance (Memory.C a) => Memory.C (Parameter a) where+   type Struct (Parameter a) = Memory.Struct a+   load = Memory.loadNewtype Parameter+   store = Memory.storeNewtype (\(Parameter k) -> k)+   decompose = Memory.decomposeNewtype Parameter+   compose = Memory.composeNewtype (\(Parameter k) -> k)++instance (Marshal.C a) => Marshal.C (Parameter a) where+   pack (Parameter k) = Marshal.pack k+   unpack = Parameter . Marshal.unpack++instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where+   pack (Parameter k) = MarshalMV.pack k+   unpack = Parameter . MarshalMV.unpack++instance (Storable.C a) => Storable.C (Parameter a) where+   load = Storable.loadNewtype Parameter Parameter+   store = Storable.storeNewtype Parameter (\(Parameter k) -> k)++instance (Tuple.Value a) => Tuple.Value (Parameter a) where+   type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a)+   valueOf = Tuple.valueOfFunctor++instance (MultiValue.C a) => MultiValue.C (Parameter a) where+   type Repr (Parameter a) = Parameter (MultiValue.Repr a)+   cons = multiValueParameter . fmap MultiValue.cons+   undef = multiValueParameter $ pure MultiValue.undef+   zero = multiValueParameter $ pure MultiValue.zero+   phi bb =+      fmap multiValueParameter .+      traverse (MultiValue.phi bb) . unMultiValueParameter+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb)+         (unMultiValueParameter a) (unMultiValueParameter b)++multiValueParameter ::+   Parameter (MultiValue.T a) -> MultiValue.T (Parameter a)+multiValueParameter = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++unMultiValueParameter ::+   MultiValue.T (Parameter a) -> Parameter (MultiValue.T a)+unMultiValueParameter (MultiValue.Cons x) = fmap MultiValue.Cons x+++instance (Value.Flatten a) => Value.Flatten (Parameter a) where+   type Registers (Parameter a) = Parameter (Value.Registers a)+   flattenCode = Value.flattenCodeTraversable+   unfoldCode = Value.unfoldCodeTraversable+++instance (Vector.Simple v) => Vector.Simple (Parameter v) where+   type Element (Parameter v) = Parameter (Vector.Element v)+   type Size (Parameter v) = Vector.Size v+   shuffleMatch = Vector.shuffleMatchTraversable+   extract = Vector.extractTraversable++instance (Vector.C v) => Vector.C (Parameter v) where+   insert  = Vector.insertTraversable+++instance+   (Expr.Aggregate exp mv) =>+      Expr.Aggregate (Parameter exp) (Parameter mv) where+   type MultiValuesOf (Parameter exp) = Parameter (Expr.MultiValuesOf exp)+   type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)+   bundle (Parameter p) = fmap Parameter $ Expr.bundle p+   dissect (Parameter p) = Parameter $ Expr.dissect p+++parameter ::+   (Trans.C a, SoV.TranscendentalConstant a, IsFloating a) =>+   Value a ->+   CodeGenFunction r (Parameter (Value a))+parameter = Value.unlift1 parameterPlain++parameterPlain ::+   (Trans.C a) =>+   a -> Parameter a+parameterPlain halfLife =+   Parameter $ 0.5 ^? recip halfLife+++causal ::+   (MarshalMV.C a, MultiValue.T a ~ am, MultiValue.PseudoRing a) =>+   Exp a -> Causal.T (Parameter am) am+causal initial =+   Causal.loop initial+      (arr snd &&& CausalPriv.zipWith (\(Parameter a) -> A.mul a))+++data ParameterPacked a =+   ParameterPacked {ppFeedback, ppCurrent :: a}+++instance Functor ParameterPacked where+   {-# INLINE fmap #-}+   fmap f p = ParameterPacked+      (f $ ppFeedback p) (f $ ppCurrent p)++instance App.Applicative ParameterPacked where+   {-# INLINE pure #-}+   pure x = ParameterPacked x x+   {-# INLINE (<*>) #-}+   f <*> p = ParameterPacked+      (ppFeedback f $ ppFeedback p)+      (ppCurrent f $ ppCurrent p)++instance Fold.Foldable ParameterPacked where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable ParameterPacked where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA2 ParameterPacked+         (ppFeedback p) (ppCurrent p)+++instance (Tuple.Phi a) => Tuple.Phi (ParameterPacked a) where+   phi = Tuple.phiTraversable+   addPhi = Tuple.addPhiFoldable++instance Tuple.Undefined a => Tuple.Undefined (ParameterPacked a) where+   undef = Tuple.undefPointed++instance Tuple.Zero a => Tuple.Zero (ParameterPacked a) where+   zero = Tuple.zeroPointed+++{-+storeParameter ::+   Storable a => Store.Dictionary (ParameterPacked a)+storeParameter =+   Store.run $+   liftA2 ParameterPacked+      (Store.element ppFeedback)+      (Store.element ppCurrent)++instance Storable a => Storable (ParameterPacked a) where+   sizeOf    = Store.sizeOf storeParameter+   alignment = Store.alignment storeParameter+   peek      = Store.peek storeParameter+   poke      = Store.poke storeParameter+-}++instance Storable a => Storable (ParameterPacked a) where+   sizeOf    = Store.sizeOf+   alignment = Store.alignment+   peek      = Store.peekApplicative+   poke      = Store.poke+++type ParameterPackedStruct a = LLVM.Struct (a, (a, ()))++memory ::+   (Memory.C a) =>+   Memory.Record r (ParameterPackedStruct (Memory.Struct a)) (ParameterPacked a)+memory =+   liftA2 ParameterPacked+      (Memory.element ppFeedback TypeNum.d0)+      (Memory.element ppCurrent  TypeNum.d1)++instance (Memory.C a) => Memory.C (ParameterPacked a) where+   type Struct (ParameterPacked a) = ParameterPackedStruct (Memory.Struct a)+   load = Memory.loadRecord memory+   store = Memory.storeRecord memory+   decompose = Memory.decomposeRecord memory+   compose = Memory.composeRecord memory++instance (Marshal.C a) => Marshal.C (ParameterPacked a) where+   pack (ParameterPacked bend depth) = Marshal.pack (bend, depth)+   unpack = uncurry ParameterPacked . Marshal.unpack++instance (MarshalMV.C a) => MarshalMV.C (ParameterPacked a) where+   pack (ParameterPacked bend depth) = MarshalMV.pack (bend, depth)+   unpack = uncurry ParameterPacked . MarshalMV.unpack++instance (Storable.C a) => Storable.C (ParameterPacked a) where+   load = Storable.loadApplicative+   store = Storable.storeFoldable+++instance (Tuple.Value a) => Tuple.Value (ParameterPacked a) where+   type ValueOf (ParameterPacked a) = ParameterPacked (Tuple.ValueOf a)+   valueOf = Tuple.valueOfFunctor++instance (MultiValue.C a) => MultiValue.C (ParameterPacked a) where+   type Repr (ParameterPacked a) = ParameterPacked (MultiValue.Repr a)+   cons = multiValueParameterPacked . fmap MultiValue.cons+   undef = multiValueParameterPacked $ pure MultiValue.undef+   zero = multiValueParameterPacked $ pure MultiValue.zero+   phi bb =+      fmap multiValueParameterPacked .+      traverse (MultiValue.phi bb) . unMultiValueParameterPacked+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb)+         (unMultiValueParameterPacked a) (unMultiValueParameterPacked b)++multiValueParameterPacked ::+   ParameterPacked (MultiValue.T a) -> MultiValue.T (ParameterPacked a)+multiValueParameterPacked = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++unMultiValueParameterPacked ::+   MultiValue.T (ParameterPacked a) -> ParameterPacked (MultiValue.T a)+unMultiValueParameterPacked (MultiValue.Cons x) = fmap MultiValue.Cons x+++instance (Value.Flatten a) => Value.Flatten (ParameterPacked a) where+   type Registers (ParameterPacked a) = ParameterPacked (Value.Registers a)+   flattenCode = Value.flattenCodeTraversable+   unfoldCode = Value.unfoldCodeTraversable++instance+   (Expr.Aggregate exp mv) =>+      Expr.Aggregate (ParameterPacked exp) (ParameterPacked mv) where+   type MultiValuesOf (ParameterPacked exp) =+            ParameterPacked (Expr.MultiValuesOf exp)+   type ExpressionsOf (ParameterPacked mv) =+            ParameterPacked (Expr.ExpressionsOf mv)+   bundle p =+      liftA2 ParameterPacked+         (Expr.bundle $ ppFeedback p) (Expr.bundle $ ppCurrent p)+   dissect p =+      ParameterPacked+         (Expr.dissect $ ppFeedback p) (Expr.dissect $ ppCurrent p)+++type instance F.Arguments f (ParameterPacked a) = f (ParameterPacked a)+instance F.MakeArguments (ParameterPacked a) where+   makeArgs = id++++withSize ::+   (TypeNum.Natural n) =>+   (SerialOld.Write v, SerialOld.Size v ~ n, TypeNum.Positive n) =>+   (TypeNum.Singleton n -> m (param v)) ->+   m (param v)+withSize f = f TypeNum.singleton++parameterPacked ::+   (SerialOld.Write v, SerialOld.Element v ~ a,+    A.PseudoRing v, A.RationalConstant v,+    A.Transcendental a, A.RationalConstant a) =>+   a -> CodeGenFunction r (ParameterPacked v)+parameterPacked halfLife = withSize $ \n -> do+   feedback <-+      SerialOld.upsample =<<+      A.pow (A.fromRational' 0.5) =<<+      A.fdiv (A.fromInteger' $ TypeNum.integralFromSingleton n) halfLife+   k <-+      A.pow (A.fromRational' 0.5) =<<+      A.fdiv (A.fromInteger' 1) halfLife+   current <-+      SerialOld.iterate (A.mul k) (A.fromInteger' 1)+   return $ ParameterPacked feedback current+{-+   Value.unlift1 parameterPackedPlain+-}++withSizePlain ::+   (TypeNum.Positive n) =>+   (TypeNum.Singleton n -> param (Serial.T n a)) ->+   param (Serial.T n a)+withSizePlain f = f TypeNum.singleton++parameterPackedPlain ::+   (TypeNum.Positive n, Trans.C a) =>+   a -> ParameterPacked (Serial.T n a)+parameterPackedPlain halfLife =+   withSizePlain $ \n ->+   ParameterPacked+      (SerialPlain.replicate+         (0.5 ^? (fromInteger (TypeNum.integerFromSingleton n) / halfLife)))+      (SerialPlain.iterate (0.5 ^? recip halfLife *) one)++withSizeExp ::+   (TypeNum.Positive n) =>+   (TypeNum.Singleton n -> param (exp (Serial.T n a))) ->+   param (exp (Serial.T n a))+withSizeExp f = f TypeNum.singleton++parameterPackedExp ::+   (TypeNum.Positive n) =>+   (MultiValue.Transcendental a, MultiValue.RationalConstant a) =>+   (MultiVector.C a) =>+   Exp a -> ParameterPacked (Exp (Serial.T n a))+parameterPackedExp halfLife =+   withSizeExp $ \n ->+   ParameterPacked+      (Serial.upsample+         (0.5 ^? (fromInteger (TypeNum.integerFromSingleton n) / halfLife)))+      (Serial.iterate (0.5 ^? recip halfLife *) one)+++causalPacked ::+   (MultiVector.PseudoRing a, MultiValue.IntegerConstant a,+    TypeNum.Positive n, MarshalMV.Vector n a, MarshalMV.C a) =>+   Exp a ->+   Causal.T (ParameterPacked (SerialCode.Value n a)) (SerialCode.Value n a)+causalPacked initial =+   Causal.loop+      (Serial.upsample initial)+      (CausalPriv.map $+       \(p, s0) -> liftA2 (,)+          (A.mul (ppCurrent p) s0)+          (A.mul (ppFeedback p) s0))
+ src/Synthesizer/LLVM/Causal/Functional.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Causal.Functional (+   T,+   lift, fromSignal,+   ($&), (&|&),+   compile,+   compileSignal,+   withArgs, MakeArguments, Arguments, makeArgs,+   AnyArg(..),++   Ground(Ground),+   withGroundArgs, MakeGroundArguments, GroundArguments,+   makeGroundArgs,++   Atom(..), atom,+   withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments,+   makeGuidedArgs,++   PrepareArguments(PrepareArguments), withPreparedArgs, withPreparedArgs2,+   atomArg, stereoArgs, pairArgs, tripleArgs,+   ) where++import qualified Synthesizer.LLVM.Causal.Private as CausalCore+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Signal as Signal+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.Causal.Class as CausalClass+import Synthesizer.LLVM.Private (getPairPtrs, noLocalPtr)++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A++import LLVM.Core (CodeGenFunction)+import qualified LLVM.Core as LLVM++import qualified Number.Ratio as Ratio+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Class as MT+import Control.Monad.Trans.State (StateT)++import qualified Data.Vault.Lazy as Vault+import Data.Vault.Lazy (Vault)+import qualified Control.Category as Cat+import Control.Arrow (Arrow, (>>^), (&&&), arr, first)+import Control.Category (Category, (.))+import Control.Applicative (Applicative, (<*>), pure, liftA2)++import Data.Tuple.Strict (zipPair)+import Data.Tuple.HT (fst3, snd3, thd3)++import qualified System.Unsafe as Unsafe++import Prelude hiding ((.))+++newtype T inp out = Cons (Code inp out)+++-- | similar to @Causal.T a b@+data Code a b =+   forall global local state.+      (Memory.C global, LLVM.IsSized local, Memory.C state) =>+      Code (forall r c.+            (Tuple.Phi c) =>+            global -> LLVM.Value (LLVM.Ptr local) -> a -> state ->+            StateT Vault (MaybeCont.T r c) (b, state))+               -- compute next value+           (forall r. CodeGenFunction r (global, state))+               -- initial state+           (forall r. global -> CodeGenFunction r ())+               -- cleanup+++instance Category Code where+   id = arr id+   Code nextB startB stopB . Code nextA startA stopA = Code+      (\(globalA, globalB) local a (sa0,sb0) -> do+         (localA,localB) <- MT.lift $ getPairPtrs local+         (b,sa1) <- nextA globalA localA a sa0+         (c,sb1) <- nextB globalB localB b sb0+         return (c, (sa1,sb1)))+      (liftA2 zipPair startA startB)+      (\(globalA, globalB) -> stopA globalA >> stopB globalB)+++instance Arrow Code where+   arr f = Code+      (\() -> noLocalPtr $ \a () -> return (f a, ()))+      (return ((),()))+      (\() -> return ())+   first (Code next start stop) = Code (CausalCore.firstNext next) start stop+++{-+We must not define Category and Arrow instances+because in osci***osci the result of osci would be shared,+although it depends on the particular input.++instance Category T where+   id = tagUnique Cat.id+   Cons a . Cons b = tagUnique (a . b)++instance Arrow T where+   arr f = tagUnique $ arr f+   first (Cons a) = tagUnique $ first a+-}++instance Functor (T inp) where+   fmap f (Cons x) =+      tagUnique $ x >>^ f++instance Applicative (T inp) where+   pure a = tagUnique $ arr (const a)+   f <*> x = fmap (uncurry ($))  $  f &|& x+++lift0 :: (forall r. CodeGenFunction r out) -> T inp out+lift0 f = lift (CausalCore.map (const f))++lift1 :: (forall r. a -> CodeGenFunction r out) -> T inp a -> T inp out+lift1 f x = CausalCore.map f $& x++lift2 ::+   (forall r. a -> b -> CodeGenFunction r out) ->+   T inp a -> T inp b -> T inp out+lift2 f x y = CausalCore.zipWith f $& x&|&y+++instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T a b) where+   fromInteger n = pure (A.fromInteger' n)+   (+) = lift2 A.add+   (-) = lift2 A.sub+   (*) = lift2 A.mul+   abs = lift1 A.abs+   signum = lift1 A.signum++instance (A.Field b, A.Real b, A.RationalConstant b) => Fractional (T a b) where+   fromRational x = pure (A.fromRational' x)+   (/) = lift2 A.fdiv+++instance (A.Additive b) => Additive.C (T a b) where+   zero = pure A.zero+   (+) = lift2 A.add+   (-) = lift2 A.sub+   negate = lift1 A.neg++instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   (*) = lift2 A.mul++instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   (/) = lift2 A.fdiv++instance (A.Transcendental b, A.RationalConstant b) => Algebraic.C (T a b) where+   sqrt = lift1 A.sqrt+   root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n)+   x^/r = lift2 A.pow x (Field.fromRational' r)++instance (A.Transcendental b, A.RationalConstant b) => Trans.C (T a b) where+   pi = lift0 A.pi+   sin = lift1 A.sin+   cos = lift1 A.cos+   (**) = lift2 A.pow+   exp = lift1 A.exp+   log = lift1 A.log++   asin _ = error "LLVM missing intrinsic: asin"+   acos _ = error "LLVM missing intrinsic: acos"+   atan _ = error "LLVM missing intrinsic: atan"+++infixr 0 $&++($&) :: Causal.T b c -> T a b -> T a c+f $& (Cons b) =+   tagUnique $  liftCode f . b+++infixr 3 &|&++(&|&) :: T a b -> T a c -> T a (b,c)+Cons b &|& Cons c =+   tagUnique $  b &&& c+++liftCode :: Causal.T inp out -> Code inp out+liftCode (CausalCore.Cons next start stop) =+   Code+      (\p l a state -> MT.lift (next p l a state))+      start stop++lift :: Causal.T inp out -> T inp out+lift = tagUnique . liftCode++fromSignal :: Signal.T out -> T inp out+fromSignal = lift . CausalClass.fromSignal++tag :: Vault.Key out -> Code inp out -> T inp out+tag key (Code next start stop) =+   Cons $+   Code+      (\p l a s0 -> do+         mb <- State.gets (Vault.lookup key)+         case mb of+            Just b -> return (b,s0)+            Nothing -> do+               bs@(b,_) <- next p l a s0+               State.modify (Vault.insert key b)+               return bs)+      start stop++-- dummy for debugging+_tag :: Vault.Key out -> Code inp out -> T inp out+_tag _ = Cons++tagUnique :: Code inp out -> T inp out+tagUnique code =+   Unsafe.performIO $+   fmap (flip tag code) Vault.newKey++initialize :: Code inp out -> Causal.T inp out+initialize (Code next start stop) =+   CausalCore.Cons+      (\p l a state -> State.evalStateT (next p l a state) Vault.empty)+      start stop++compile :: T inp out -> Causal.T inp out+compile (Cons code) = initialize code++compileSignal :: T () out -> Signal.T out+compileSignal f = CausalClass.toSignal $ compile f+++{- |+Using 'withArgs' you can simplify++> let x = F.lift (arr fst)+>     y = F.lift (arr (fst.snd))+>     z = F.lift (arr (snd.snd))+> in  F.compile (f x y z)++to++> withArgs $ \(x,(y,z)) -> f x y z+-}+withArgs ::+   (MakeArguments inp) =>+   (Arguments (T inp) inp -> T inp out) -> Causal.T inp out+withArgs f = withId $ f . makeArgs++withId :: (T inp inp -> T inp out) -> Causal.T inp out+withId f = compile $ f $ lift Cat.id+++type family Arguments (f :: * -> *) arg++class MakeArguments arg where+   makeArgs :: Functor f => f arg -> Arguments f arg+++{-+I have thought about an Arg type, that marks where to stop descending.+This way we can throw away all of these FlexibleContext instances+and the user can freely choose the granularity of arguments.+However this does not work so easily,+because we would need a functional depedency from, say,+@(Arg a, Arg b)@ to @(a,b)@.+This is the opposite direction to the dependency we use currently.+The 'AnyArg' type provides a solution in this spirit.+-}+type instance Arguments f (LLVM.Value a) = f (LLVM.Value a)+instance MakeArguments (LLVM.Value a) where+   makeArgs = id++type instance Arguments f (MultiValue.T a) = f (MultiValue.T a)+instance MakeArguments (MultiValue.T a) where+   makeArgs = id++{- |+Consistent with pair instance.+You may use 'AnyArg' or 'withGuidedArgs'+to stop descending into the stereo channels.+-}+type instance Arguments f (Stereo.T a) = Stereo.T (Arguments f a)+instance (MakeArguments a) => MakeArguments (Stereo.T a) where+   makeArgs = fmap makeArgs . Stereo.sequence++type instance Arguments f (Serial.Constant n a) = f (Serial.Constant n a)+instance MakeArguments (Serial.Constant n a) where+   makeArgs = id++type instance Arguments f () = f ()+instance MakeArguments () where+   makeArgs = id++type instance Arguments f (a,b) = (Arguments f a, Arguments f b)+instance (MakeArguments a, MakeArguments b) =>+      MakeArguments (a,b) where+   makeArgs f = (makeArgs $ fmap fst f, makeArgs $ fmap snd f)++type instance Arguments f (a,b,c) =+                  (Arguments f a, Arguments f b, Arguments f c)+instance (MakeArguments a, MakeArguments b, MakeArguments c) =>+      MakeArguments (a,b,c) where+   makeArgs f =+      (makeArgs $ fmap fst3 f, makeArgs $ fmap snd3 f, makeArgs $ fmap thd3 f)+++{- |+You can use this to explicitly stop breaking of composed data types.+It might be more comfortable to do this using 'withGuidedArgs'.+-}+newtype AnyArg a = AnyArg {getAnyArg :: a}++type instance Arguments f (AnyArg a) = f a+instance MakeArguments (AnyArg a) where+   makeArgs = fmap getAnyArg++++{- |+This is similar to 'withArgs'+but it requires to specify the decomposition depth+using constructors in the arguments.+-}+withGroundArgs ::+   (MakeGroundArguments (T inp) args,+    GroundArguments args ~ inp) =>+   (args -> T inp out) -> Causal.T inp out+withGroundArgs f = withId $ f . makeGroundArgs+++newtype 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'+but it allows to specify the decomposition depth using a pattern.+-}+withGuidedArgs ::+   (MakeGuidedArguments pat, PatternArguments pat ~ inp) =>+   pat ->+   (GuidedArguments (T inp) pat -> T inp out) -> Causal.T inp out+withGuidedArgs p f = withId $ f . makeGuidedArgs p+++data Atom a = Atom++atom :: Atom a+atom = Atom+++type family GuidedArguments (f :: * -> *) pat+type family PatternArguments pat++class MakeGuidedArguments pat where+   makeGuidedArgs ::+      Functor f =>+      pat -> f (PatternArguments pat) -> GuidedArguments f pat+++type instance GuidedArguments f (Atom a) = f a+type instance PatternArguments (Atom a) = a+instance MakeGuidedArguments (Atom a) where+   makeGuidedArgs Atom = id++type instance GuidedArguments f (Stereo.T a) = Stereo.T (GuidedArguments f a)+type instance PatternArguments (Stereo.T a) = Stereo.T (PatternArguments a)+instance MakeGuidedArguments a => MakeGuidedArguments (Stereo.T a) where+   makeGuidedArgs pat f =+      Stereo.cons+         (makeGuidedArgs (Stereo.left  pat) $ fmap Stereo.left f)+         (makeGuidedArgs (Stereo.right pat) $ fmap Stereo.right f)++type instance GuidedArguments f () = f ()+type instance PatternArguments () = ()+instance MakeGuidedArguments () where+   makeGuidedArgs () = id++type instance+   GuidedArguments f (a,b) =+      (GuidedArguments f a, GuidedArguments f b)+type instance+   PatternArguments (a,b) =+      (PatternArguments a, PatternArguments b)+instance (MakeGuidedArguments a, MakeGuidedArguments b) =>+      MakeGuidedArguments (a,b) where+   makeGuidedArgs (pa,pb) f =+      (makeGuidedArgs pa $ fmap fst f,+       makeGuidedArgs pb $ fmap snd f)++type instance+   GuidedArguments f (a,b,c) =+      (GuidedArguments f a, GuidedArguments f b, GuidedArguments f c)+type instance+   PatternArguments (a,b,c) =+      (PatternArguments a, PatternArguments b, PatternArguments c)+instance+   (MakeGuidedArguments a, MakeGuidedArguments b, MakeGuidedArguments c) =>+      MakeGuidedArguments (a,b,c) where+   makeGuidedArgs (pa,pb,pc) f =+      (makeGuidedArgs pa $ fmap fst3 f,+       makeGuidedArgs pb $ fmap snd3 f,+       makeGuidedArgs pc $ fmap thd3 f)++++{- |+Alternative to withGuidedArgs.+This way of pattern construction is even Haskell 98.+-}+withPreparedArgs ::+   PrepareArguments (T inp) inp a ->+   (a -> T inp out) -> Causal.T inp out+withPreparedArgs (PrepareArguments prepare) f = withId $ f . prepare++withPreparedArgs2 ::+   PrepareArguments (T (inp0, inp1)) inp0 a ->+   PrepareArguments (T (inp0, inp1)) inp1 b ->+   (a -> b -> T (inp0, inp1) out) ->+   Causal.T (inp0, inp1) out+withPreparedArgs2 prepareA prepareB f =+   withPreparedArgs (pairArgs prepareA prepareB) (uncurry f)++newtype PrepareArguments f merged separated =+   PrepareArguments (f merged -> separated)++atomArg :: PrepareArguments f a (f a)+atomArg = PrepareArguments id++stereoArgs ::+   (Functor f) =>+   PrepareArguments f a b ->+   PrepareArguments f (Stereo.T a) (Stereo.T b)+stereoArgs (PrepareArguments p) =+   PrepareArguments $ fmap p . Stereo.sequence++pairArgs ::+   (Functor f) =>+   PrepareArguments f a0 b0 ->+   PrepareArguments f a1 b1 ->+   PrepareArguments f (a0,a1) (b0,b1)+pairArgs (PrepareArguments p0) (PrepareArguments p1) =+   PrepareArguments $ \f -> (p0 $ fmap fst f, p1 $ fmap snd f)++tripleArgs ::+   (Functor f) =>+   PrepareArguments f a0 b0 ->+   PrepareArguments f a1 b1 ->+   PrepareArguments f a2 b2 ->+   PrepareArguments f (a0,a1,a2) (b0,b1,b2)+tripleArgs (PrepareArguments p0) (PrepareArguments p1) (PrepareArguments p2) =+   PrepareArguments $ \f ->+      (p0 $ fmap fst3 f, p1 $ fmap snd3 f, p2 $ fmap thd3 f)
+ src/Synthesizer/LLVM/Causal/FunctionalPlug.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.LLVM.Causal.FunctionalPlug (+   T,+   ($&), (&|&),+   run, runPlugOut,+   fromSignal, plug, askParameter, Input,+   withArgs, withArgsPlugOut,+   MakeArguments, Arguments, makeArgs,+   ) where++import qualified Synthesizer.LLVM.Plug.Input as PIn+import qualified Synthesizer.LLVM.Plug.Output as POut++import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Private as CausalPriv+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Signal as Sig++import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Zip as Zip++import qualified Data.EventList.Relative.BodyTime as EventListBT+import qualified Data.StorableVector as SV++import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Arithmetic as A+import LLVM.Core (CodeGenFunction)++import Data.IORef (newIORef, readIORef)++import qualified Number.Ratio as Ratio+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Control.Monad.Trans.Reader as MR+import qualified Control.Monad.Trans.State as MS+import Control.Monad.IO.Class (liftIO)++import qualified Data.Set as Set+import qualified Data.Vault.Lazy as Vault+import Data.Vault.Lazy (Vault)+import Data.Unique (Unique, newUnique)+import Data.Maybe (fromMaybe)++import Control.Arrow ((^<<), (<<^), arr, first, second)+import Control.Category (id, (.))+import Control.Applicative (Applicative, (<*>), pure, liftA2, liftA3)++import qualified System.Unsafe as Unsafe++import Prelude hiding (id, (.))+++{- |+This data type detects sharing.+-}+{-+There are two levels of the use of keys.+At the top level, in T's State monad,+we store an object id in order to check,+whether we have already seen a certain object.+If we encounter a known object+then we use the Simple constructor+and fetch the stored CausalP output+within the causal process enclosed in Simple.+This and the causal process in the Plugged constructor+are the second level.+These arrows handle a Vault like a state monad+and insert all values they produce into the Vault.+-}+newtype T pp inp out =+   Cons (MS.State (Set.Set Unique) (Core pp inp out))++{-+We need to hide the x and y types+since these types grow when combining Cores,+and then we could not define numeric instances.+-}+data Core pp inp out =+   forall x y. CutG.Read x =>+   Plugged+      (pp -> inp -> x)+      (PIn.T x y)+      (Causal.T (y, Vault) (out, Vault))+   |+   {-+   The Simple constructor is needed for reusing shared CausalP processes+   and for input without external representation. (a Plug.Input)+   -}+   Simple (Causal.T Vault (out, Vault))+++applyCore ::+   Causal.T (a, Vault) (b, Vault) ->+   Core pp inp a ->+   Core pp inp b+applyCore f core =+   case core of+      Plugged prep plg process -> Plugged prep plg (f . process)+      Simple process -> Simple (f . process)++combineCore ::+   Core pp inp a ->+   Core pp inp b ->+   Core pp inp (a,b)+combineCore (Plugged prepA plugA processA) (Plugged prepB plugB processB) =+   Plugged+      (\p -> Zip.arrowFanout (prepA p) (prepB p))+      (PIn.split plugA plugB)+      ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB+       . arr (\((a,v),b) -> (a,(b,v))) .+       first processA <<^ (\((a,b),v) -> ((a,v),b)))+combineCore (Simple processA) (Plugged prepB plugB processB) =+   Plugged prepB plugB+      ((\(b,(a,v)) -> ((a,b), v)) ^<< second processA . processB)+combineCore (Plugged prepA plugA processA) (Simple processB) =+   Plugged prepA plugA+      ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA)+combineCore (Simple processA) (Simple processB) =+   Simple ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA)+++reuseCore :: Vault.Key out -> Core pp inp out+reuseCore key =+   Simple $ arr $ \vault ->+      (fromMaybe (error "key must have been lost") $ Vault.lookup key vault,+       vault)+++tag ::+   Unique -> Vault.Key out ->+   MS.State (Set.Set Unique) (Core pp inp out) ->+   T pp inp out+tag unique key stateCore = Cons $ do+   alreadySeen <- MS.gets (Set.member unique)+   if alreadySeen+      then return $ reuseCore key+      else do+         MS.modify (Set.insert unique)+         fmap (applyCore (arr $ \(a,v) -> (a, Vault.insert key a v))) stateCore++tagUnique ::+   MS.State (Set.Set Unique) (Core pp inp out) ->+   T pp inp out+tagUnique core =+   Unsafe.performIO $+   liftA3 tag newUnique Vault.newKey (pure core)+++infixr 0 $&++($&) ::+   Causal.T a b ->+   T pp inp a ->+   T pp inp b+f  $&  Cons core =+   tagUnique $ fmap (applyCore $ first f) core+++infixr 3 &|&++(&|&) ::+   T pp inp a ->+   T pp inp b ->+   T pp inp (a,b)+Cons coreA  &|&  Cons coreB =+   tagUnique $ liftA2 combineCore coreA coreB+++instance Functor (Core pp inp) where+   fmap f (Simple process) = Simple (fmap (first f) process)+   fmap f (Plugged prep plg process) = Plugged prep plg (fmap (first f) process)++instance Applicative (Core pp inp) where+   pure a = lift0Core $ pure a+   f <*> x = fmap (uncurry ($))  $  combineCore f x++lift0Core :: (forall r. CodeGenFunction r out) -> Core pp inp out+lift0Core f = Simple (CausalPriv.map (\v -> fmap (flip (,) v) f))+++instance Functor (T pp inp) where+   fmap f (Cons x) = tagUnique $ fmap (fmap f) x++instance Applicative (T pp inp) where+   pure a = tagUnique $ pure $ pure a+   f <*> x = fmap (uncurry ($))  $  f &|& x+++lift0 :: (forall r. CodeGenFunction r out) -> T pp inp out+lift0 f = tagUnique $ pure $ lift0Core f++lift1 ::+   (forall r. a -> CodeGenFunction r out) ->+   T pp inp a -> T pp inp out+lift1 f x = CausalPriv.map f $& x++lift2 ::+   (forall r. a -> b -> CodeGenFunction r out) ->+   T pp inp a -> T pp inp b -> T pp inp out+lift2 f x y = CausalPriv.zipWith f $& x&|&y+++instance+   (A.PseudoRing b, A.Real b, A.IntegerConstant b) =>+      Num (T pp a b) where+   fromInteger n = pure (A.fromInteger' n)+   (+) = lift2 A.add+   (-) = lift2 A.sub+   (*) = lift2 A.mul+   abs = lift1 A.abs+   signum = lift1 A.signum++instance+   (A.Field b, A.Real b, A.RationalConstant b) =>+      Fractional (T pp a b) where+   fromRational x = pure (A.fromRational' x)+   (/) = lift2 A.fdiv+++instance (A.Additive b) => Additive.C (T pp a b) where+   zero = pure A.zero+   (+) = lift2 A.add+   (-) = lift2 A.sub+   negate = lift1 A.neg++instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T pp a b) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   (*) = lift2 A.mul++instance (A.Field b, A.RationalConstant b) => Field.C (T pp a b) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   (/) = lift2 A.fdiv++instance+   (A.Transcendental b, A.RationalConstant b) =>+      Algebraic.C (T pp a b) where+   sqrt = lift1 A.sqrt+   root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n)+   x^/r = lift2 A.pow x (Field.fromRational' r)++instance+   (A.Transcendental b, A.RationalConstant b) =>+      Trans.C (T pp a b) where+   pi = lift0 A.pi+   sin = lift1 A.sin+   cos = lift1 A.cos+   (**) = lift2 A.pow+   exp = lift1 A.exp+   log = lift1 A.log++   asin _ = error "LLVM missing intrinsic: asin"+   acos _ = error "LLVM missing intrinsic: acos"+   atan _ = error "LLVM missing intrinsic: atan"++++fromSignal :: Sig.T a -> T pp inp a+fromSignal sig =+   tagUnique $ pure $ Simple (CausalClass.feedFst sig)++++type Input pp a = MR.Reader (pp, a)++plug ::+   (CutG.Read b, PIn.Default b) =>+   Input pp a b ->+   T pp a (PIn.Element b)+plug accessor =+   tagUnique $ pure $+   Plugged+      (curry $ MR.runReader accessor)+      PIn.deflt+      id++askParameter :: Input pp a pp+askParameter = MR.asks fst+++runPlugOut ::+   (Marshal.C pl) =>+   (Exp pl -> T pp a x) -> POut.T x b ->+   IO (pp -> pl -> PIO.T a b)+runPlugOut func pout = do+   let name = "FunctionalPlug.runPlugOut"+   ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"+   case func (Exp (liftIO (readIORef ref))) of+      Cons core ->+         case MS.evalState core Set.empty of+            Simple _ -> error $ name ++ ": no substantial input available"+               -- Simple process ->+               --    CausalRender.processIOCore pin process pout+            Plugged prep pin process ->+               fmap (\f pp pl -> f (return (pl, return ())) <<^ prep pp) $+               case fst ^<< process <<^ flip (,) Vault.empty of+                  CausalPriv.Cons next start stop ->+                     (\paramd ->+                        CausalRender.processIOParameterized pin paramd pout) $+                     Parameterized.Cons+                        (\p global local a state ->+                           MaybeCont.lift (Parameterized.loadParam ref p) >>+                           next global local a state)+                        (\p ->+                           Parameterized.loadParam ref p >> start)+                        (\p global ->+                           Parameterized.loadParam ref p >> stop global)++run ::+   (Marshal.C pl) =>+   (POut.Default b) =>+   (Exp pl -> T pp a (POut.Element b)) ->+   IO (pp -> pl -> PIO.T a b)+run f = runPlugOut f POut.deflt+++{- |+Cf. 'F.withArgs'.+-}+withArgs ::+   (Marshal.C pl) =>+   (MakeArguments a, POut.Default b) =>+   (Arguments (Input pp a) a -> Exp pl -> T pp a (POut.Element b)) ->+   IO (pp -> pl -> PIO.T a b)+withArgs f = withArgsPlugOut f POut.deflt++withArgsPlugOut ::+   (Marshal.C pl) =>+   (MakeArguments a) =>+   (Arguments (Input pp a) a -> Exp pl -> T pp a x) ->+   POut.T x b ->+   IO (pp -> pl -> PIO.T a b)+withArgsPlugOut = withArgsPlugOutStart (MR.asks snd)++withArgsPlugOutStart ::+   (Marshal.C pl) =>+   (MakeArguments a) =>+   Input pp a a ->+   (Arguments (Input pp a) a -> Exp pl -> T pp a x) ->+   POut.T x b ->+   IO (pp -> pl -> PIO.T a b)+withArgsPlugOutStart fid f = runPlugOut (f (makeArgs fid))++++type family Arguments (f :: * -> *) arg++class MakeArguments arg where+   makeArgs :: Functor f => f arg -> Arguments f arg+++type instance Arguments f (EventListBT.T i a) = f (EventListBT.T i a)+instance MakeArguments (EventListBT.T i a) where+   makeArgs = id++type instance Arguments f (SV.Vector a) = f (SV.Vector a)+instance MakeArguments (SV.Vector a) where+   makeArgs = id++type instance Arguments f (Zip.T a b) = (Arguments f a, Arguments f b)+instance (MakeArguments a, MakeArguments b) =>+      MakeArguments (Zip.T a b) where+   makeArgs f = (makeArgs $ fmap Zip.first f, makeArgs $ fmap Zip.second f)
+ src/Synthesizer/LLVM/Causal/Helix.hs view
@@ -0,0 +1,622 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RebindableSyntax #-}+{- |+<http://arxiv.org/abs/0911.5171>+-}+module Synthesizer.LLVM.Causal.Helix (+   -- * time and phase control based on the helix model+   static,+   staticPacked,+   dynamic,+   dynamicLimited,++   -- * useful control curves+   zigZag,+   zigZagPacked,+   zigZagLong,+   zigZagLongPacked,+   ) where++import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Private as CausalPriv+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Causal.Functional as Func+import qualified Synthesizer.LLVM.Generator.Source as Source+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Private as SigPriv+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Causal.RingBufferForward as RingBuffer+import qualified Synthesizer.LLVM.Frame.SerialVector as SerialExp+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialClass+import qualified Synthesizer.LLVM.Interpolation as Ip+import Synthesizer.LLVM.Causal.Functional (($&), (&|&))+import Synthesizer.LLVM.Private (noLocalPtr)++import Synthesizer.Causal.Class (($*), ($<))++import qualified LLVM.DSL.Expression.Vector as ExprVec+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp, (<*), (>=*))++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Memory as Memory++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Word (Word)++import Control.Arrow (first, (<<<))+import Control.Category (id)+import Control.Functor.HT (unzip)+import Data.Traversable (mapM)+import Data.Tuple.HT (mapPair, mapFst)++import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric hiding (splitFraction)+import NumericPrelude.Base hiding (unzip, zip, mapM, id)++import Prelude ()+++{- |+Inputs are @(shape, phase)@.++The shape parameter is limited at the beginning and at the end+such that only available data is used for interpolation.+Actually, we allow almost one step less than possible,+since the right boundary of the interval of admissible @shape@ values is open.+-}+static ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Storable.C vh, MultiValue.T vh ~ v) =>+   (Marshal.C a, MultiValue.Field a, MultiValue.RationalConstant a) =>+   (MultiValue.Fraction a, MultiValue.NativeFloating a ar) =>+   (MultiValueVec.NativeFloating a ar, MultiValue.T a ~ am) =>+   (forall r. Ip.T r nodesLeap am v) ->+   (forall r. Ip.T r nodesStep am v) ->+   Exp Int ->+   Exp a ->+   Exp (Source.StorableVector vh) ->+   Causal.T (am, am) v+static ipLeap ipStep periodInt period vec =+   let periodWord = wordFromInt periodInt+       cellMargin = combineMarginParams ipLeap ipStep periodInt+   in  interpolateCell ipLeap ipStep+       <<<+       first (peekCell cellMargin periodWord vec)+       <<<+       flattenShapePhaseProc periodWord period+       <<<+       first+          (limitShape cellMargin periodInt+              (intFromWord $ Source.storableVectorLength vec))++intFromWord :: Exp Word -> Exp Int+intFromWord = Expr.liftReprM LLVM.bitcast++wordFromInt :: Exp Int -> Exp Word+wordFromInt = Expr.liftReprM LLVM.bitcast++staticPacked ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Storable.C vh, MultiValue.T vh ~ ve, SerialClass.Element v ~ ve) =>+   (SerialClass.Size (nodesLeap (nodesStep v)) ~ n,+    SerialClass.Write (nodesLeap (nodesStep v)),+    SerialClass.Element (nodesLeap (nodesStep v)) ~+       nodesLeap (nodesStep (SerialClass.Element v))) =>+   (TypeNum.Positive n) =>+   (Marshal.C a, MultiVector.Field a, MultiVector.Real a,+    MultiVector.Fraction a, MultiVector.RationalConstant a,+    MultiVector.NativeFloating n a ar) =>+   (forall r. Ip.T r nodesLeap (Serial.Value n a) v) ->+   (forall r. Ip.T r nodesStep (Serial.Value n a) v) ->+   Exp Int ->+   Exp a ->+   Exp (Source.StorableVector vh) ->+   Causal.T (Serial.Value n a, Serial.Value n a) v+staticPacked ipLeap ipStep periodInt period vec =+   let periodWord = wordFromInt periodInt+       cellMargin = combineMarginParams ipLeap ipStep periodInt+   in  interpolateCell ipLeap ipStep+       <<<+       first (CausalPS.pack+          (peekCell (elementMargin cellMargin) periodWord vec))+       <<<+       flattenShapePhaseProcPacked periodWord period+       <<<+       first+          (limitShapePacked cellMargin periodInt+              (intFromWord $ Source.storableVectorLength vec))+++{- |+In contrast to 'dynamic' this one ends+when the end of the manipulated signal is reached.+-}+dynamicLimited ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Marshal.C a, MultiValue.Field a, MultiValue.Fraction a,+    MultiValue.Select a, MultiValue.Comparison a,+    MultiValue.NativeFloating a ar,+    MultiValue.RationalConstant a,+    MultiValueVec.NativeFloating a ar) =>+   (MultiValue.T a ~ am) =>+   (Memory.C v) =>+   (forall r. Ip.T r nodesLeap am v) ->+   (forall r. Ip.T r nodesStep am v) ->+   Exp Int ->+   Exp a ->+   Sig.T v ->+   Causal.T (am, am) v+dynamicLimited ipLeap ipStep periodInt period sig =+   dynamicGen+      (\cellMargin (skips, fracs) ->+         let windows =+               (RingBuffer.trackSkip+                     (wordFromInt $ Ip.marginNumberExp cellMargin) sig)+                  $& skips+         in  (windows,+              Causal.delay1 zero $& skips,+              Causal.delay1 zero $& fracs))+      ipLeap ipStep periodInt period++{- |+If the time control exceeds the end of the input signal,+then the last waveform is locked.+This is analogous to 'static'.+-}+dynamic ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Marshal.C a, MultiValue.Field a, MultiValue.Fraction a,+    MultiValue.Select a, MultiValue.Comparison a,+    MultiValue.NativeFloating a ar,+    MultiValue.RationalConstant a,+    MultiValueVec.NativeFloating a ar) =>+   (MultiValue.T a ~ am) =>+   (Memory.C v) =>+   (forall r. Ip.T r nodesLeap am v) ->+   (forall r. Ip.T r nodesStep am v) ->+   Exp Int ->+   Exp a ->+   Sig.T v ->+   Causal.T (am, am) v+dynamic ipLeap ipStep periodInt period sig =+   dynamicGen+      (\cellMargin (skips, fracs) ->+         let {-+             For conformance with 'static'+             we stop one step before the definite end.+             We achieve this by using a buffer+             that is one step longer than necessary.+             -}+             ((running, actualSkips), windows) =+                mapFst unzip $ unzip $+                (RingBuffer.trackSkipHold+                   (wordFromInt (Ip.marginNumberExp cellMargin) + 1) sig)+                   $& skips+             holdFracs =+                Causal.zipWith (\r fr -> Expr.select r fr 1)+                $&+                running &|& (Causal.delay1 zero $& fracs)+         in  (windows, actualSkips, holdFracs))+      ipLeap ipStep periodInt period++dynamicGen ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Marshal.C a, MultiValue.Field a, MultiValue.Fraction a,+    MultiValue.Select a, MultiValue.Comparison a,+    MultiValue.NativeFloating a ar,+    MultiValue.RationalConstant a,+    MultiValueVec.NativeFloating a ar) =>+   (MultiValue.T a ~ am) =>+   (Memory.C v) =>+   (Exp (Ip.Margin (nodesLeap (nodesStep v))) ->+    (Func.T (am, am) (MultiValue.T Word),+     Func.T (am, am) am) ->+    (Func.T (am, am) (RingBuffer.T v),+     Func.T (am, am) (MultiValue.T Word),+     Func.T (am, am) am)) ->+   (forall r. Ip.T r nodesLeap am v) ->+   (forall r. Ip.T r nodesStep am v) ->+   Exp Int ->+   Exp a ->+   Causal.T (am, am) v+dynamicGen limitMaxShape ipLeap ipStep periodInt period =+   let periodWord = wordFromInt periodInt+       cellMargin = combineMarginParams ipLeap ipStep periodInt+       minShape = wordFromInt $ fst $ shapeMargin cellMargin periodInt++   in  Func.withArgs $ \(shape, phase) ->+          let (windows, skips, fracs) =+                 limitMaxShape cellMargin $+                 unzip (integrateFrac $& (limitMinShape minShape $& shape))+              (offsets, shapePhases) =+                 unzip+                    (flattenShapePhaseProc periodWord period $&+                       (constantFromWord minShape + fracs)+                       &|&+                       (Causal.osciCoreSync $&+                          phase+                          &|&+                          negate+                             (Causal.map ((/period)) $&+                                (Causal.map Expr.fromIntegral $& skips))))+          in interpolateCell ipLeap ipStep $&+                 (CausalPriv.map+                    (\(buffer, offset) -> do+                       p <- Expr.unExp periodWord+                       cellFromBuffer p buffer offset)+                  $&+                  windows+                  &|&+                  offsets)+                 &|&+                 shapePhases++constantFromWord ::+   (MultiValue.NativeFloating a ar) =>+   Exp Word -> Func.T inp (MultiValue.T a)+constantFromWord x =+   Func.fromSignal (Causal.map Expr.fromIntegral $* Sig.constant x)++limitMinShape ::+   (Marshal.C a, MultiValue.Select a, MultiValue.Comparison a,+    MultiValue.NativeFloating a ar) =>+   Exp Word ->+   Causal.T (MultiValue.T a) (MultiValue.T a)+limitMinShape xLim =+   Causal.mapAccum+      (\x lim ->+         Expr.unzip $+         Expr.select (x>=*lim) (Expr.zip (x-lim) zero) (Expr.zip zero (lim-x)))+      (Expr.fromIntegral xLim)++integrateFrac ::+   (Marshal.C a, MultiValue.Additive a,+    MultiValueVec.NativeFloating a ar, LLVM.IsPrimitive ar) =>+   Causal.T (MultiValue.T a) (MultiValue.T Word, MultiValue.T a)+integrateFrac =+   Causal.mapAccum+      (\a frac ->+         let s = ExprVec.splitFractionToInt (a+frac)+         in (s, snd s))+      zero+++interpolateCell ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (forall r. Ip.T r nodesLeap a v) ->+   (forall r. Ip.T r nodesStep a v) ->+   Causal.T (nodesLeap (nodesStep v), (a, a)) v+interpolateCell ipLeap ipStep =+   CausalPriv.map+      (\(nodes, (leap,step)) ->+         ipLeap leap =<< mapM (ipStep step) nodes)++cellFromBuffer ::+   (Memory.C a, Ip.C nodesLeap, Ip.C nodesStep) =>+   MultiValue.T Word ->+   RingBuffer.T a ->+   MultiValue.T Word ->+   LLVM.CodeGenFunction r (nodesLeap (nodesStep a))+cellFromBuffer periodInt buffer offset =+   Ip.indexNodesExp+      (Ip.indexNodesExp (flip RingBuffer.index buffer) A.one)+      periodInt offset++elementMargin ::+   Exp (Ip.Margin (nodesLeap (nodesStep v))) ->+   Exp (Ip.Margin (nodesLeap (nodesStep (SerialClass.Element v))))+elementMargin = Expr.liftReprM return++peekCell ::+   (Storable.C a, MultiValue.T a ~ value, Ip.C nodesLeap, Ip.C nodesStep) =>+   Exp (Ip.Margin (nodesLeap (nodesStep value))) ->+   Exp Word ->+   Exp (Source.StorableVector a) ->+   Causal.T (MultiValue.T Word) (nodesLeap (nodesStep value))+peekCell margin periodWord vec =+   CausalPriv.map+      (\n -> do+         ~(MultiValue.Cons (ptr,_l)) <- Expr.unExp vec+         ~(MultiValue.Cons offset) <-+            Expr.unExp $ intFromWord (Expr.lift0 n) - Ip.marginOffsetExp margin+         perInt <- Expr.unExp $ intFromWord periodWord+         Ip.loadNodesExp (Ip.loadNodesExp Storable.load A.one) perInt+            =<< Storable.advancePtr offset ptr)+++flattenShapePhaseProc ::+   (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) =>+   (MultiValue.NativeFloating a ar, MultiValueVec.NativeFloating a ar) =>+   Exp Word ->+   Exp a ->+   Causal.T+      (MultiValue.T a, MultiValue.T a)+      (MultiValue.T Word, (MultiValue.T a, MultiValue.T a))+flattenShapePhaseProc periodInt period =+   Causal.map+      (\(shape, phase) -> flattenShapePhase periodInt period shape phase)++_flattenShapePhaseProc ::+   (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) =>+   (MultiValue.NativeFloating a ar) =>+   Exp Word ->+   Exp a ->+   Causal.T+      (MultiValue.T a, MultiValue.T a)+      (MultiValue.T Word, (MultiValue.T a, MultiValue.T a))+_flattenShapePhaseProc period32 period =+   CausalPriv.map+      (\(shape, phase) -> do+         perInt <- Expr.unExp period32+         per <- Expr.unExp period+         _flattenShapePhase perInt per shape phase)++flattenShapePhaseProcPacked ::+   (TypeNum.Positive n, MultiVector.Field a, MultiVector.RationalConstant a) =>+   (MultiVector.Fraction a, MultiVector.NativeFloating n a ar) =>+   Exp Word ->+   Exp a ->+   Causal.T+      (Serial.Value n a, Serial.Value n a)+      (Serial.Value n Word, (Serial.Value n a, Serial.Value n a))+flattenShapePhaseProcPacked periodInt period =+   Causal.zipWith+      (flattenShapePhase+         (SerialExp.upsample periodInt) (SerialExp.upsample period))++flattenShapePhase ::+   (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) =>+   (MultiValueVec.NativeFloating a ar, MultiValueVec.NativeInteger i ir) =>+   (LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   Exp i -> Exp a ->+   Exp a -> Exp a ->+   (Exp i, (Exp a, Exp a))+flattenShapePhase periodInt period shape phase =+   let qLeap = Expr.fraction $ shape/period - phase+       (n,qStep) =+          ExprVec.splitFractionToInt $+          {-+          If 'shape' is correctly limited,+          the value is always non-negative algebraically,+          but maybe not numerically.+          -}+          Expr.max zero $+          shape - qLeap * ExprVec.fromIntegral periodInt+   in (n,(qLeap,qStep))++_flattenShapePhase ::+   (MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.Fraction a) =>+   (MultiValue.NativeFloating a ar, MultiValue.NativeInteger i ir) =>+   MultiValue.T i ->+   MultiValue.T a ->+   MultiValue.T a -> MultiValue.T a ->+   LLVM.CodeGenFunction r (MultiValue.T i, (MultiValue.T a, MultiValue.T a))+_flattenShapePhase = Expr.unliftM4 $ \periodInt period shape phase ->+   let qLeap = Expr.fraction $ shape/period - phase+       (n,qStep) =+          Expr.splitFractionToInt $+          {-+          If 'shape' is correctly limited,+          the value is always non-negative algebraically,+          but maybe not numerically.+          -}+          Expr.max zero $+          shape - qLeap * Expr.fromIntegral periodInt+   in  (n,(qLeap,qStep))+++limitShape ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Marshal.C t, MultiValue.Real t, MultiValue.NativeFloating t tr) =>+   (i ~ Int) =>+   Exp (Ip.Margin (nodesLeap (nodesStep value))) ->+   Exp i -> Exp i -> Causal.MV t t+limitShape margin periodInt len =+   Causal.zipWith Expr.limit+   $<+   limitShapeSignal margin periodInt len++limitShapePacked ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Marshal.C t, MultiValue.NativeFloating t tr) =>+   (TypeNum.Positive n, MultiVector.Real t) =>+   (i ~ Int) =>+   Exp (Ip.Margin (nodesLeap (nodesStep value))) ->+   Exp i ->+   Exp i ->+   Causal.T (Serial.Value n t) (Serial.Value n t)+limitShapePacked margin periodInt len =+   Causal.zipWith+      (\(minShape,maxShape) shape ->+         SerialExp.limit+            (SerialExp.upsample minShape,+             SerialExp.upsample maxShape)+            shape)+   $<+   limitShapeSignal margin periodInt len++limitShapeSignal ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (Marshal.C t, MultiValue.NativeFloating t tr) =>+   (i ~ Int) =>+   Exp (Ip.Margin (nodesLeap (nodesStep value))) ->+   Exp i ->+   Exp i ->+   Sig.T (MultiValue.T t, MultiValue.T t)+limitShapeSignal margin periodInt len =+   SigPriv.Cons+      (\minMax -> noLocalPtr $ \() -> return (minMax, ()))+      (do+         limits <-+            Expr.bundle+               (mapPair (Expr.fromIntegral, Expr.fromIntegral) $+                shapeLimits margin periodInt len)+         return (limits, ()))+      (const $ return ())+++shapeLimits ::+   (Ip.C nodesLeap, Ip.C nodesStep, Exp Int ~ t) =>+   Exp (Ip.Margin (nodesLeap (nodesStep value))) ->+   t -> t -> (t, t)+shapeLimits margin periodInt len =+   case shapeMargin margin periodInt of+      (leftMargin, rightMargin) -> (leftMargin, len - rightMargin)++shapeMargin ::+   (Ip.C nodesLeap, Ip.C nodesStep, Exp Int ~ i) =>+   Exp (Ip.Margin (nodesLeap (nodesStep value))) ->+   i -> (i, i)+shapeMargin margin periodInt =+   let (marginNumber, marginOffset) =+         Expr.unzip $+         Expr.lift1 (uncurry MultiValue.zip . Ip.unzipMargin) margin+       leftMargin = marginOffset + periodInt+       rightMargin = marginNumber - leftMargin+   in  (leftMargin, rightMargin)++_shapeLimits ::+   (Ip.C nodesLeap, Ip.C nodesStep) =>+   (MultiValue.NativeFloating t tr) =>+   (MultiValue.Additive t) =>+   Ip.Margin (nodesLeap (nodesStep value)) ->+   Exp Word -> Exp t -> (Exp t, Exp t)+_shapeLimits margin periodInt len =+   let (leftMargin, rightMargin) = _shapeMargin margin periodInt+   in  (Expr.fromIntegral leftMargin, len - Expr.fromIntegral rightMargin)++_shapeMargin ::+   (Ip.C nodesLeap, Ip.C nodesStep, Ring.C i) =>+   Ip.Margin (nodesLeap (nodesStep value)) ->+   i -> (i, i)+_shapeMargin margin periodInt =+   let leftMargin = fromIntegral (Ip.marginOffset margin) + periodInt+       rightMargin = fromIntegral (Ip.marginNumber margin) - leftMargin+   in  (leftMargin, rightMargin)++combineMarginParams ::+   (Ip.C nodesStep, Ip.C nodesLeap) =>+   (forall r. Ip.T r nodesLeap a v) ->+   (forall r. Ip.T r nodesStep a v) ->+   Exp Int ->+   Exp (Ip.Margin (nodesLeap (nodesStep v)))+combineMarginParams ipLeap ipStep periodInt =+   let marginLeap = Ip.toMargin ipLeap in+   let marginStep = Ip.toMargin ipStep in+   Expr.lift2 Ip.zipMargin+      (fromIntegral (Ip.marginNumber marginStep) ++       fromIntegral (Ip.marginNumber marginLeap) * periodInt)+      (fromIntegral (Ip.marginOffset marginStep) ++       fromIntegral (Ip.marginOffset marginLeap) * periodInt)++_combineMargins ::+   Ip.Margin (nodesLeap value) ->+   Ip.Margin (nodesStep value) ->+   Int ->+   Ip.Margin (nodesLeap (nodesStep value))+_combineMargins marginLeap marginStep periodInt =+   Ip.Margin {+      Ip.marginNumber =+         Ip.marginNumber marginStep ++         Ip.marginNumber marginLeap * periodInt,+      Ip.marginOffset =+         Ip.marginOffset marginStep ++         Ip.marginOffset marginLeap * 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 ::+   (Marshal.C a) =>+   (MultiValue.Select a, MultiValue.Comparison a, MultiValue.Fraction a) =>+   (MultiValue.Field a, MultiValue.RationalConstant a) =>+   Exp a -> Exp a -> Causal.MV a a+zigZagLong =+   zigZagLongGen (Causal.fromSignal . Sig.constant) zigZag++zigZagLongPacked ::+   (Marshal.Vector n a) =>+   (MultiVector.Field a, MultiVector.Fraction a) =>+   (MultiVector.RationalConstant a) =>+   (MultiVector.Select a, MultiVector.Comparison a) =>+   Exp a -> Exp a -> Causal.T (Serial.Value n a) (Serial.Value n a)+zigZagLongPacked =+   zigZagLongGen (Causal.fromSignal . SigPS.constant) zigZagPacked++zigZagLongGen ::+   (MultiValue.RationalConstant a, MultiValue.Field a) =>+   (A.RationalConstant al, A.Field al) =>+   (Exp a -> Causal.T al al) ->+   (Exp a -> Causal.T al al) ->+   Exp a -> Exp a -> Causal.T al al+zigZagLongGen constant zz prefix loop =+   zz (negate $ prefix/loop) * constant loop + constant prefix+   <<<+   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 ::+   (Marshal.C a) =>+   (MultiValue.Select a, MultiValue.Comparison a, MultiValue.Fraction a) =>+   (MultiValue.Field a, MultiValue.RationalConstant a) =>+   Exp a -> Causal.MV a a+zigZag start =+   Causal.map (\x -> 1 - abs (1-x))+   <<<+   Causal.mapAccum+      (\d t0 -> let t1 = t0+d in (t0, wrap Expr.select (0<*) t1))+      start++zigZagPacked ::+   (TypeNum.Positive n) =>+   (Marshal.C a) =>+   (MultiVector.Field a, MultiVector.Fraction a) =>+   (MultiVector.RationalConstant a) =>+   (MultiVector.Select a, MultiVector.Comparison a) =>+   Exp a -> Causal.T (Serial.Value n a) (Serial.Value n a)+zigZagPacked start =+   Causal.map (\x -> 1 - abs (1-x))+   <<<+   Causal.mapAccum+      (\d t0 ->+         let (t1,cum) = SerialExp.cumulate t0 d+         in (wrap SerialExp.select (SerialExp.cmp LLVM.CmpLT zero) cum, t1))+      start++wrap ::+   (MultiValue.Field a, MultiValue.Fraction a, MultiValue.RationalConstant a) =>+   (Exp b -> Exp a -> Exp a -> Exp a) ->+   (Exp a -> Exp b) ->+   Exp a -> Exp a+wrap select positive a = select (positive a) (2 * Expr.fraction (a/2)) a
+ src/Synthesizer/LLVM/Causal/Parameterized.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Causal.Parameterized where++import qualified Synthesizer.LLVM.Causal.Private as Causal++import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import Control.Monad.IO.Class (liftIO)++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+++data T p a b =+   forall global local state.+      (Memory.C global, LLVM.IsSized local, Memory.C state) =>+      Cons (forall r c.+            (Tuple.Phi c) =>+            p -> global -> LLVM.Value (LLVM.Ptr local) ->+            a -> state -> MaybeCont.T r c (b, state))+           (forall r. p -> LLVM.CodeGenFunction r (global, state))+           (forall r. p -> global -> LLVM.CodeGenFunction r ())+++fromProcess :: String -> (Exp p -> Causal.T a b) -> IO (T (MultiValue.T p) a b)+fromProcess name f = do+   ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"+   return $+      case f (Exp (liftIO (readIORef ref))) of+         Causal.Cons next start stop ->+            Cons+               (\p global local a state ->+                  liftIO (writeIORef ref p) >> next global local a state)+               (\p -> liftIO (writeIORef ref p) >> start)+               (\p global -> liftIO (writeIORef ref p) >> stop global)+++fromProcessPtr ::+   (Marshal.C p) =>+   String -> (Exp p -> Causal.T a b) ->+   IO (T (LLVM.Value (LLVM.Ptr (Marshal.Struct p))) a b)+fromProcessPtr name f = do+   ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"+   return $+      case f (Exp (liftIO (readIORef ref))) of+         Causal.Cons next start stop ->+            Cons+               (\p global local a state ->+                  MaybeCont.lift (loadParam ref p) >> next global local a state)+               (\p -> loadParam ref p >> start)+               (\p global -> loadParam ref p >> stop global)++loadParam ::+   (Marshal.C param) =>+   IORef (MultiValue.T param) ->+   LLVM.Value (LLVM.Ptr (Marshal.Struct param)) ->+   LLVM.CodeGenFunction r ()+loadParam ref ptr = liftIO . writeIORef ref =<< Memory.load ptr
+ src/Synthesizer/LLVM/Causal/Private.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Causal.Private where++import qualified Synthesizer.LLVM.Generator.Private as Sig+import Synthesizer.LLVM.Private (getPairPtrs, noLocalPtr, unbool)++import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.Causal.Utility as ArrowUtil+import Synthesizer.Causal.Class (($>))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction)++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Category as Cat+import Control.Arrow (Arrow, arr, first, (&&&), (<<<))+import Control.Category (Category)+import Control.Applicative (Applicative, pure, liftA2, (<*>), (<$>))++import Data.Tuple.Strict (mapFst, zipPair)+import Data.Word (Word)++import qualified Number.Ratio as Ratio+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import NumericPrelude.Base hiding (map, zip, zipWith, init)++import qualified Prelude as P+++data T a b =+   forall global local state.+      (Memory.C global, LLVM.IsSized local, Memory.C state) =>+      Cons (forall r c.+            (Tuple.Phi c) =>+            global -> LLVM.Value (LLVM.Ptr local) ->+            a -> state -> MaybeCont.T r c (b, state))+               -- compute next value+           (forall r. CodeGenFunction r (global, state))+               -- initial state+           (forall r. global -> CodeGenFunction r ())+               -- cleanup+++type instance CausalClass.ProcessOf Sig.T = T++instance CausalClass.C T where+   type SignalOf T = Sig.T+   toSignal (Cons next start stop) = Sig.Cons+      (\global local -> next global local ())+      start+      stop+   fromSignal (Sig.Cons next start stop) = Cons+      (\global local _ -> next global local)+      start+      stop+++noGlobal ::+   (LLVM.IsSized local, Memory.C state) =>+   (forall r c.+    (Tuple.Phi c) =>+    LLVM.Value (LLVM.Ptr local) -> a -> state -> MaybeCont.T r c (b, state)) ->+   (forall r. CodeGenFunction r state) ->+   T a b+noGlobal next start =+   Cons (const next) (fmap ((,) ()) start) return++simple ::+   (Memory.C state) =>+   (forall r c. (Tuple.Phi c) => a -> state -> MaybeCont.T r c (b, state)) ->+   (forall r. CodeGenFunction r state) ->+   T a b+simple next start = noGlobal (noLocalPtr next) start++mapAccum ::+   (Memory.C state) =>+   (forall r. a -> state -> CodeGenFunction r (b, state)) ->+   (forall r. CodeGenFunction r state) ->+   T a b+mapAccum next =+   simple (\a s -> MaybeCont.lift $ next a s)++map ::+   (forall r. a -> CodeGenFunction r b) ->+   T a b+map f =+   mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ())++zipWith ::+   (forall r. a -> b -> CodeGenFunction r c) ->+   T (a,b) c+zipWith f = map (uncurry f)+++instance Category T where+   id = map return+   Cons nextB startB stopB . Cons nextA startA stopA = Cons+      (\(globalA, globalB) local a (sa0,sb0) -> do+         (localA,localB) <- getPairPtrs local+         (b,sa1) <- nextA globalA localA a sa0+         (c,sb1) <- nextB globalB localB b sb0+         return (c, (sa1,sb1)))+      (liftA2 zipPair startA startB)+      (\(globalA, globalB) -> stopA globalA >> stopB globalB)++instance Arrow T where+   arr f = map (return . f)+   first (Cons next start stop) = Cons (firstNext next) start stop++firstNext ::+   (Functor m) =>+   (global -> local -> a -> s -> m (b, s)) ->+   global -> local ->  (a, c) -> s -> m ((b, c), s)+firstNext next global local (b,d) s0 =+   fmap+      (\(c,s1) -> ((c,d), s1))+      (next global local b s0)+++instance Functor (T a) where+   fmap = flip (>>^)++instance Applicative (T a) where+   pure = ArrowUtil.pure+   (<*>) = ArrowUtil.apply+++infixr 1 >>^, ^>>++(>>^) :: T a b -> (b -> c) -> T a c+Cons next start stop >>^ f =+   Cons+      (\global local a state -> mapFst f <$> next global local a state)+      start stop++(^>>) :: (a -> b) -> T b c -> T a c+f ^>> Cons next start stop =+   Cons+      (\global local -> next global local . f)+      start stop+++mapProc ::+   (forall r. b -> CodeGenFunction r c) ->+   T a b -> T a c+mapProc f x = map f <<< x++zipProcWith ::+   (forall r. b -> c -> CodeGenFunction r d) ->+   T a b -> T a c -> T a d+zipProcWith f x y = zipWith f <<< x&&&y+++instance (A.Additive b) => Additive.C (T a b) where+   zero = pure A.zero+   negate = mapProc A.neg+   (+) = zipProcWith A.add+   (-) = zipProcWith A.sub++instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   (*) = zipProcWith A.mul++instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   (/) = zipProcWith A.fdiv+++instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T a b) where+   fromInteger n = pure (A.fromInteger' n)+   negate = mapProc A.neg+   (+) = zipProcWith A.add+   (-) = zipProcWith A.sub+   (*) = zipProcWith A.mul+   abs = mapProc A.abs+   signum = mapProc A.signum++instance+      (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T a b) where+   fromRational x = pure (A.fromRational' x)+   (/) = zipProcWith A.fdiv+++{- |+Not quite the loop of ArrowLoop+because we need a delay of one time step+and thus an initialization value.++For a real ArrowLoop.loop, that is a zero-delay loop,+we would formally need a MonadFix instance of CodeGenFunction.+But this will not become reality, since LLVM is not able to re-order code+in a way that allows to access a result before creating the input.+-}+loop ::+   (Memory.C c) =>+   (forall r. CodeGenFunction r c) -> T (a,c) (b,c) -> T a b+loop initial (Cons next start stop) = Cons+   (\global local a0 (c0,s0) -> do+      ((b1,c1), s1) <- next global local (a0,c0) s0+      return (b1,(c1,s1)))+   (liftA2 (\ini (global,s) -> (global,(ini,s))) initial start)+   stop+++replicateSerial ::+   (Tuple.Undefined a, Tuple.Phi a) =>+   Exp Word -> T a a -> T a a+replicateSerial n proc =+   (\a -> ((),a)) ^>> replicateControlled n (snd^>>proc)++replicateControlled ::+   (Tuple.Undefined a, Tuple.Phi a) =>+   Exp Word -> T (c,a) a -> T (c,a) a+replicateControlled n (Cons next start stop) = Cons+   (\(len,globalStates) local (c,a) () ->+      MaybeCont.fromMaybe $ fmap (\(_,ms) -> flip (,) () <$> ms) $+         MaybeCont.arrayLoop len globalStates a $+               \globalStatePtr a0 -> do+            (global, s0) <- MaybeCont.lift $ Memory.load globalStatePtr+            (a1,s1) <- next global local (c,a0) s0+            MaybeCont.lift $+               Memory.store s1 =<<+               LLVM.getElementPtr0 globalStatePtr (TypeNum.d1, ())+            return a1)+   (do+      MultiValue.Cons len <- Expr.unExp n+      globalStates <- LLVM.arrayMalloc len+      C.arrayLoop len globalStates () $ \globalStatePtr () ->+         flip Memory.store globalStatePtr =<< start+      return ((len,globalStates), ()))+   (\(len,globalStates) -> do+      C.arrayLoop len globalStates () $ \globalStatePtr () ->+         stop =<< Memory.load+            =<< LLVM.getElementPtr0 globalStatePtr (TypeNum.d0, ())+      LLVM.free globalStates)++{-+We can implement 'replicateControlled' in terms of 'replicateSerial'+but this adds constraints @(Tuple.Undefined c, Tuple.Phi c)@.+-}+replicateControlledAlt ::+   (Tuple.Undefined a, Tuple.Phi a) =>+   (Tuple.Undefined c, Tuple.Phi c) =>+   Exp Word -> T (c,a) a -> T (c,a) a+replicateControlledAlt n proc =+   replicateSerial n (arr fst &&& proc) >>^ snd++replicateParallel ::+   (Tuple.Undefined b, Tuple.Phi b) =>+   Exp Word -> Sig.T b -> T (b,b) b -> T a b -> T a b+replicateParallel n z cum p =+   replicateControlled n (cum <<< first p) $> z+++quantizeLift ::+   (Memory.C b, Marshal.C c, MultiValue.IntegerConstant c,+    MultiValue.Additive c, MultiValue.Comparison c) =>+   T a b -> T (MultiValue.T c, a) b+quantizeLift (Cons next start stop) = Cons+   (\global local (k, a0) yState0 -> do+      (yState1, frac1) <-+         MaybeCont.fromBool $+         C.whileLoop+            (LLVM.valueOf True, yState0)+            (\(cont1, (_, frac0)) ->+               LLVM.and cont1 . unbool+                  =<< MultiValue.cmp LLVM.CmpLE frac0 A.zero)+            (\(_,((_,state01), frac0)) ->+               MaybeCont.toBool $ liftA2 (,)+                  (next global local a0 state01)+                  (MaybeCont.lift $ A.add frac0 k))++      frac2 <- MaybeCont.lift $ A.sub frac1 A.one+      return (fst yState1, (yState1, frac2)))+{- using this initialization code we would not need undefined values+   (do (global,s) <- start+       (a,_) <- next s+       return (global, ((a,s), A.zero))+-}+   (do+      (global,s) <- start+      return (global, ((Tuple.undef, s), A.zero)))+   stop
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -1,756 +1,787 @@ {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Causal.Process (-   C(simple, replicateControlled),-   T,-   amplify,-   amplifyStereo,-   apply,-   applyFst,-   applySnd,-   applyConst,-   applyConstFst,-   applyConstSnd,-   (CausalClass.$<), (CausalClass.$>), (CausalClass.$*),-   ($<#), ($>#), ($*#),-   feedFst,-   feedSnd,-   feedConstFst,-   feedConstSnd,-   first,-   envelope,-   envelopeStereo,-   fromModifier,-   fromSignal,-   toSignal,-   loopConst,-   loopZero,-   delay1Zero,-   feedbackControlledZero,-   map,-   mapAccum,-   zipWith,-   mapProc,-   zipProcWith,-   mix,-   takeWhile,-   pipeline,-   stereoFromVector,-   vectorize,-   replaceChannel,-   arrayElement,-   element,-   osciCoreSync,-   osciCore,-   osci,-   shapeModOsci,-   skip,-   foldChunks,-   foldChunksPartial,-   frequencyModulation,-   interpolateConstant,-   quantizeLift,-   applyStorable,-   applyStorableChunky,-   runStorableChunky,-   ) where--import Synthesizer.LLVM.Causal.ProcessPrivate--import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig-import qualified Synthesizer.LLVM.Simple.Value as Value-import qualified Synthesizer.LLVM.Fold as Fold-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame as Frame-import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr--import qualified Synthesizer.Plain.Modifier as Modifier-import qualified Synthesizer.Causal.Class as CausalClass--import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import qualified Data.StorableVector.Base as SVB--import qualified LLVM.DSL.Execution as Exec--import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Tuple as Tuple-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.Maybe as Maybe-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory--import qualified LLVM.Core as LLVM-import LLVM.Core-          (CodeGenFunction, ret, Value, valueOf,-           IsConst, IsFirstClass, IsArithmetic, IsPrimitive)--import qualified Type.Data.Num.Decimal as TypeNum-import Type.Base.Proxy (Proxy)-import Type.Data.Num.Decimal (D2, (:<:))--import qualified Control.Arrow    as Arr-import Control.Monad.Trans.State (runState)-import Control.Arrow (arr, (<<<), (>>>), (&&&))-import Control.Monad (liftM2)-import Control.Applicative (liftA3, (<$>))--import qualified Data.List as List-import Data.Tuple.HT (swap)-import Data.Word (Word)--import Foreign.Ptr (Ptr)-import Control.Exception (bracket)-import qualified System.Unsafe as Unsafe--import Prelude hiding (and, map, zip, zipWith, init, takeWhile)----fromModifier ::-   (C process) =>-   (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) =>-   Modifier.Simple sh ch ah bh -> process (cl,al) bl-fromModifier (Modifier.Simple initial step) =-   mapAccum-      (\(c,a) s ->-         Value.flatten $-         runState-            (step (Value.unfold c) (Value.unfold a))-            (Value.unfold s))-      (Value.flatten initial)---apply :: T a b -> Sig.T a -> Sig.T b-apply = CausalClass.apply--feedFst :: Sig.T a -> T b (a,b)-feedFst = CausalClass.feedFst--feedSnd :: Sig.T a -> T b (b,a)-feedSnd = CausalClass.feedSnd--feedConstFst :: (Tuple.Value a, Tuple.ValueOf a ~ al) => a -> T b (al,b)-feedConstFst = CausalClass.feedConstFst . Tuple.valueOf--feedConstSnd :: (Tuple.Value a, Tuple.ValueOf a ~ al) => a -> T b (b,al)-feedConstSnd = CausalClass.feedConstSnd . Tuple.valueOf---applyFst :: T (a,b) c -> Sig.T a -> T b c-applyFst = CausalClass.applyFst--applySnd :: T (a,b) c -> Sig.T b -> T a c-applySnd = CausalClass.applySnd--applyConst ::-   (Tuple.Value a, Tuple.ValueOf a ~ al) =>-   T al b -> a -> Sig.T b-applyConst proc =-   CausalClass.applyConst proc . Tuple.valueOf--applyConstFst ::-   (Tuple.Value a, Tuple.ValueOf a ~ al) =>-   T (al,b) c -> a -> T b c-applyConstFst proc =-   CausalClass.applyConstFst proc . Tuple.valueOf--applyConstSnd ::-   (Tuple.Value b, Tuple.ValueOf b ~ bl) =>-   T (a,bl) c -> b -> T a c-applyConstSnd proc =-   CausalClass.applyConstSnd proc . Tuple.valueOf---infixl 0 $<#, $>#, $*#--{- |-provide constant input in a comfortable way--}-($*#) ::-   (C process, CausalClass.SignalOf process ~ signal,-    Tuple.Value ah, Tuple.ValueOf ah ~ a) =>-   process a b -> ah -> signal b-proc $*# x = CausalClass.applyConst proc $ Tuple.valueOf x--($<#) ::-   (C process, Tuple.Value ah, Tuple.ValueOf ah ~ a) =>-   process (a,b) c -> ah -> process b c-proc $<# x = CausalClass.applyConstFst proc $ Tuple.valueOf x--($>#) ::-   (C process, Tuple.Value bh, Tuple.ValueOf bh ~ b) =>-   process (a,b) c -> bh -> process a c-proc $># x = CausalClass.applyConstSnd proc $ Tuple.valueOf x----{- |-You may also use '(+)'.--}-mix ::-   (C process, A.Additive a) =>-   process (a, a) a-mix = zipWith Frame.mix---{- |-You may also use '(*)'.--}-envelope ::-   (C process, A.PseudoRing a) =>-   process (a, a) a-envelope = zipWith Frame.amplifyMono--envelopeStereo ::-   (C process, A.PseudoRing a) =>-   process (a, Stereo.T a) (Stereo.T a)-envelopeStereo = zipWith Frame.amplifyStereo--amplify ::-   (C process, IsArithmetic a, IsConst a) =>-   a -> process (Value a) (Value a)-amplify x =-   map (Frame.amplifyMono (valueOf x))--amplifyStereo ::-   (C process, IsArithmetic a, IsConst a) =>-   a -> process (Stereo.T (Value a)) (Stereo.T (Value a))-amplifyStereo x =-   map (Frame.amplifyStereo (valueOf x))----loopConst ::-   (C process, Memory.C c) =>-   c -> process (a,c) (b,c) -> process a b-loopConst init =-   alter-      (\(Core next start stop) ->-          Core-             (loopNext next)-             (fmap ((,) init) . start)-             (stop . snd))--{- |-Like 'Synthesizer.LLVM.CausalParameterized.loop'-but uses zero as initial value-and it does not need a zero as Haskell value.--}-loopZero ::-   (C process, A.Additive c, Memory.C c) =>-   process (a,c) (b,c) -> process a b-loopZero = loopConst A.zero--delay1Zero ::-   (C process, A.Additive a, Memory.C a) =>-   process a a-delay1Zero = loopZero (arr swap)---{- |-This allows to compute a chain of equal processes efficiently,-if all of these processes can be bundled in one vectorial process.-Applications are an allpass cascade or an FM operator cascade.--The function expects that the vectorial input process-works like parallel scalar processes.-The different pipeline stages may be controlled by different parameters,-but the structure of all pipeline stages must be equal.-Our function feeds the input of the pipelined process-to the zeroth element of the Vector.-The result of processing the i-th element (the i-th channel, so to speak)-is fed to the (i+1)-th element.-The (n-1)-th element of the vectorial process is emitted-as output of the pipelined process.--The pipeline necessarily introduces a delay of (n-1) values.-For simplification we extend this to n values delay.-If you need to combine the resulting signal from the pipeline-with another signal in a 'zip'-like way,-you may delay that signal with @pipeline id@.-The first input values in later stages of the pipeline-are initialized with zero.-If this is not appropriate for your application,-then we may add a more sensible initialization.--}-pipeline ::-   (C process,-    TypeNum.Positive n, MultiVector.C x,-    v ~ MultiVector.T n x,-    a ~ MultiValue.T x,-    Tuple.Zero v, Memory.C v) =>-   process v v -> process a a-pipeline vectorProcess =-   loopConst MultiVector.zero $-      map (uncurry MultiVector.shiftUp)-      >>>-      Arr.second vectorProcess---feedbackControlledZero ::-   (C process, A.Additive c, Memory.C c) =>-   process ((ctrl,a),c) b -> process (ctrl,b) c -> process (ctrl,a) b-feedbackControlledZero forth back =-   loopZero (feedbackControlledAux forth back)---{--In order to let this work we have to give the disable-mmx option somewhere,-but where?--}-stereoFromVector ::-   (C process, IsPrimitive a, IsPrimitive b) =>-   process (Value (LLVM.Vector D2 a)) (Value (LLVM.Vector D2 b)) ->-   process (Stereo.T (Value a)) (Stereo.T (Value b))-stereoFromVector proc =-   map Frame.stereoFromVector <<<-   proc <<<-   map Frame.vectorFromStereo---{--insert and extract instructions will be in opposite order,-no matter whether we use foldr or foldl-and independent from the order of proc and channel in replaceChannel.-However, LLVM neglects the order anyway.--}-vectorize ::-   (C process,-    TypeNum.Positive n,-    MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va,-    MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) =>-   process a b -> process va vb-vectorize proc =-   withSize $ \n ->-      foldl-         (\acc i -> replaceChannel i proc acc)-         (arr (const $ Tuple.undef)) $-      List.take (TypeNum.integralFromSingleton n) [0 ..]--withSize ::-   (TypeNum.Positive n, MultiVector.T n a ~ v) =>-   (TypeNum.Singleton n -> f v) ->-   f v-withSize f = f TypeNum.singleton--{- |-Given a vector process, replace the i-th output by output-that is generated by a scalar process from the i-th input.--}-replaceChannel ::-   (C process,-    TypeNum.Positive n,-    MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va,-    MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) =>-   Int -> process a b -> process va vb -> process va vb-replaceChannel i channel proc =-   let li = valueOf $ fromIntegral i-   in  zipWith (MultiVector.insert li) <<<-          (channel <<< map (MultiVector.extract li)) &&&-          proc--{- |-Read the i-th element from each array.--}-arrayElement ::-   (C process, IsFirstClass a,-    TypeNum.Natural index, TypeNum.Natural dim,-    index :<: dim) =>-   Proxy index -> process (Value (LLVM.Array dim a)) (Value a)-arrayElement i =-   map (\array -> LLVM.extractvalue array i)--{- |-Read the i-th element from an aggregate type.--}-element ::-   (C process, IsFirstClass a, LLVM.GetValue agg index,-    LLVM.ValueType agg index ~ a) =>-   index -> process (Value agg) (Value a)-element i =-   map (\array -> LLVM.extractvalue array i)----{- |-Compute the phases from phase distortions and frequencies.--It's like integrate but with wrap-around performed by @fraction@.-For FM synthesis we need also negative phase distortions,-thus we use 'A.addToPhase' which supports that.--}-osciCore, _osciCore, osciCoreSync ::-   (C process, Memory.C t, A.Fraction t) =>-   process (t, t) (t)-_osciCore =-   zipWith A.addToPhase <<<-   Arr.second-      (mapAccum-         (\a s -> do-            b <- A.incPhase a s-            return (s,b))-         (return A.zero))--{--This could be implemented using a generalized frequencyModulation,-however, osciCoreSync allows for negative phase differences.--}-osciCoreSync =-   zipWith A.addToPhase <<<-   Arr.second-      (mapAccum-         (\a s -> do-            b <- A.incPhase a s-            return (b,b))-         (return A.zero))--osciCore =-   zipWith A.addToPhase <<<-   Arr.second (loopZero (arr snd &&& zipWith A.incPhase))--osci ::-   (C process, Memory.C t, A.Fraction t) =>-   (forall r. t -> CodeGenFunction r y) ->-   process (t, t) y-osci wave =-   map wave <<< osciCore--shapeModOsci ::-   (C process, Memory.C t, A.Fraction t) =>-   (forall r. c -> t -> CodeGenFunction r y) ->-   process (c, (t, t)) y-shapeModOsci wave =-   zipWith wave <<< Arr.second osciCore---{- |-Feeds a signal into a causal process while holding or skipping signal elements-according to the process input.-The skip happens after a value is passed from the fed signal.--@skip x $* 0@ repeats the first signal value in the output.-@skip x $* 1@ feeds the signal to the output as is.-@skip x $* 2@ feeds the signal to the output with double speed.--}-skip ::-   (C process, CausalClass.SignalOf process ~ signal,-    Tuple.Undefined a, Tuple.Phi a, Memory.C a) =>-   signal a -> process (Value Word) a-skip =-   alterSignal-      (\(Sig.Core next start stop) -> Core-         (\context n1 (yState0,n0) -> do-            yState1@(y,_) <--               MaybeCont.fromMaybe $ fmap snd $-               MaybeCont.fixedLengthLoop n0 yState0 $-               next context . snd-            return (y, (yState1,n1)))-         (fmap (\s -> ((Tuple.undef, s), A.one)) . start)-         (\((_y,state),_k) -> stop state))--{- |-The input of the process is a sequence of chunk sizes.-The signal is chopped into chunks of these sizes-and each chunk is folded using-the given initial value and the accumulation function.-A trailing incomplete chunk will be ignored.--}-foldChunks ::-   (C process, CausalClass.SignalOf process ~ signal, Tuple.Undefined b, Tuple.Phi b) =>-   Fold.T a b -> signal a -> process (Value Word) b-foldChunks (Fold.Cons accum initial) =-   alterSignal-      (\(Sig.Core next start stop) -> Core-         (\context n state ->-            MaybeCont.fromMaybe $ fmap snd $-            MaybeCont.fixedLengthLoop n (initial,state) $ \(b0,state0) -> do-               (a,state1) <- next context state0-               b1 <- MaybeCont.lift $ accum b0 a-               return (b1,state1))-         start-         stop)--{- |-Like 'foldChunks' but an incomplete chunk at the end-is treated like a complete one.--}-foldChunksPartial ::-   (C process, CausalClass.SignalOf process ~ signal,-    Tuple.Undefined a, Tuple.Phi a, Tuple.Undefined b, Tuple.Phi b) =>-   Fold.T a b -> signal a -> process (Value Word) b-foldChunksPartial (Fold.Cons accum initial) =-   alterSignal-      (\(Sig.Core next start stop) -> Core-         (\context n runState0 -> do-            ((i,b), runState1) <--               MaybeCont.lift $-               C.whileLoopShared ((n, initial), runState0) $-                     \((i0,b0), (run,s0)) ->-                  (A.and run =<< A.cmp LLVM.CmpGT i0 A.zero,-                   do mas1 <- MaybeCont.toMaybe $ next context s0-                      Maybe.run mas1-                        (return ((i0,b0), (valueOf False, s0)))-                        (\(a,s1) -> do-                           b1 <- accum b0 a-                           i1 <- A.dec i0-                           return ((i1,b1), (valueOf True, s1))))-            MaybeCont.guard =<< MaybeCont.lift (A.cmp LLVM.CmpLT i n)-            return (b, runState1))-         (fmap ((,) (valueOf True)) . start)-         (stop . snd))--{--It is quite similar to quantizeLift but the control is the reciprocal.-This is especially a problem since we need the fractional part for interpolation.--}-frequencyModulation ::-   (C process, CausalClass.SignalOf process ~ signal,-    SoV.IntegerConstant a, LLVM.IsFloating a,-    LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, LLVM.IsSized a,-    Tuple.Undefined nodes, Tuple.Phi nodes, Memory.C nodes) =>-   (forall r. Value a -> nodes -> CodeGenFunction r v) ->-   signal nodes -> process (Value a) v-frequencyModulation ip =-   alterSignal (\(Sig.Core next start stop) -> Core-      (\context k yState0 -> do-         ((nodes2,state2), ss2) <--            MaybeCont.fromBool $-            C.whileLoop-               (valueOf True, yState0)-               (\(cont0, (_, ss0)) ->-                  LLVM.and cont0 =<< A.fcmp LLVM.FPOGE ss0 A.one)-               (\(_,((_,state0), ss0)) ->-                  MaybeCont.toBool $ liftM2 (,)-                     (next context state0)-                     (MaybeCont.lift $ A.sub ss0 A.one))--         MaybeCont.lift $ do-            y <- ip ss2 nodes2-            ss3 <- A.add ss2 k-            return (y, ((nodes2, state2), ss3)))-      (fmap (\sa -> ((Tuple.undef, sa), A.one)) . start)-      (\((_y01,state),_ss) -> stop state))---{- |-Stretch signal in time by a time-varying factor.--}-interpolateConstant ::-   (C process, CausalClass.SignalOf process ~ signal,-    Memory.C a, LLVM.IsSized b, SoV.IntegerConstant b,-    LLVM.IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool) =>-   signal a -> process (Value b) a-interpolateConstant xs =-   quantizeLift (CausalClass.fromSignal xs) $># ()---quantizeLift ::-   (C process, Memory.C b,-    SoV.IntegerConstant c, LLVM.IsFloating c,-    LLVM.CmpRet c, LLVM.CmpResult c ~ Bool, LLVM.IsSized c) =>-   process a b ->-   process (Value c, a) b-quantizeLift = alter (\(Core next start stop) -> Core-   (\context (k, a0) yState0 -> do-      (yState1, frac1) <--         MaybeCont.fromBool $-         C.whileLoop-            (LLVM.valueOf True, yState0)-            (\(cont1, (_, frac0)) ->-               LLVM.and cont1 =<< A.fcmp LLVM.FPOLE frac0 A.zero)-            (\(_,((_,state01), frac0)) ->-               MaybeCont.toBool $ liftM2 (,)-                  (next context a0 state01)-                  (MaybeCont.lift $ A.add frac0 k))--      frac2 <- MaybeCont.lift $ A.sub frac1 A.one-      return (fst yState1, (yState1, frac2)))-{- using this initialization code we would not need undefined values-   (do sa <- start-       (a,_) <- next sa-       return (sa, a, A.zero))--}-   (\p -> do-      s <- start p-      return ((Tuple.undef, s), A.zero))-   (\((_, s), _) -> stop s))----foreign import ccall safe "dynamic" derefFillPtr ::-   Exec.Importer-      (LLVM.Ptr paramStruct -> Word -> Ptr a -> Ptr b -> IO Word)---compile ::-   (Storable.C a, Tuple.ValueOf a ~ aValue,-    Storable.C b, Tuple.ValueOf b ~ bValue,-    Memory.C param, Memory.Struct param ~ paramStruct,-    Tuple.Phi state, Tuple.Undefined state) =>-   (forall r z. (Tuple.Phi z) =>-    param -> local -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r. param -> CodeGenFunction r state) ->-   IO (LLVM.Ptr paramStruct -> Word -> Ptr a -> Ptr b -> IO Word)-compile next alloca start =-   Exec.compile "causal" $-      Exec.createFunction derefFillPtr "fillprocessblock" $-         \ paramPtr size alPtr blPtr -> do-            param <- Memory.load paramPtr-            s <- start param-            local <- alloca-            (pos,_) <--               Storable.arrayLoopMaybeCont2 size alPtr blPtr s $-                  \ aPtri bPtri s0 -> do-               a <- MaybeCont.lift $ Storable.load aPtri-               (b,s1) <- next param local a s0-               MaybeCont.lift $ Storable.store b bPtri-               return s1-            ret pos---applyStorable ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T valueA valueB -> SV.Vector a -> SV.Vector b-applyStorable proc = Unsafe.performIO $ runStorable proc--runStorable ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T valueA valueB -> IO (SV.Vector a -> SV.Vector b)-runStorable proc = (Unsafe.performIO .) <$> runStorableIO proc--runStorableIO ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T valueA valueB -> IO (SV.Vector a -> IO (SV.Vector b))-runStorableIO-      (Cons next alloca start createIOContext deleteIOContext) = do--   fill <- compile next alloca start-   return $ \as ->-      bracket createIOContext (deleteIOContext . fst) $ \ (_ioContext, params) ->-         SVB.withStartPtr as $ \ aPtr len ->-         SVB.createAndTrim len $ \ bPtr ->-         Marshal.with params $ \paramPtr ->-            fmap (fromIntegral :: Word -> Int) $-            fill paramPtr (fromIntegral len) aPtr bPtr---foreign import ccall safe "dynamic" derefStartPtr ::-   Exec.Importer (LLVM.Ptr b -> IO (LLVM.Ptr a))--foreign import ccall safe "dynamic" derefStopPtr ::-   Exec.Importer (LLVM.Ptr a -> IO ())--foreign import ccall safe "dynamic" derefChunkPtr ::-   Exec.Importer-      (LLVM.Ptr paramStruct -> LLVM.Ptr stateStruct -> Word ->-       Ptr a -> Ptr b -> IO Word)---compileChunky ::-   (Storable.C a, Tuple.ValueOf a ~ aValue,-    Storable.C b, Tuple.ValueOf b ~ bValue,-    Memory.C param, Memory.Struct param ~ paramStruct,-    Memory.C state, Memory.Struct state ~ stateStruct) =>-   (forall r z. (Tuple.Phi z) =>-    param -> local -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r.-    param -> CodeGenFunction r state) ->-   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr stateStruct),-       Exec.Finalizer stateStruct,-       LLVM.Ptr paramStruct -> LLVM.Ptr stateStruct ->-       Word -> Ptr a -> Ptr b -> IO Word)-compileChunky next alloca start =-   Exec.compile "causal-chunky" $-      liftA3 (,,)-         (Exec.createFunction derefStartPtr "startprocess" $-          \paramPtr -> do-             pptr <- LLVM.malloc-             param <- Memory.load paramPtr-             flip Memory.store pptr =<< start param-             ret pptr)-         (Exec.createFinalizer derefStopPtr "stopprocess" $-          \ pptr -> LLVM.free pptr >> ret ())-         (Exec.createFunction derefChunkPtr "fillprocess" $-          \paramPtr sptr loopLen aPtr bPtr -> do-             sInit <- Memory.load sptr-             param <- Memory.load paramPtr-             local <- alloca-             (pos,sExit) <--                Storable.arrayLoopMaybeCont2 loopLen aPtr bPtr sInit $-                   \ aPtri bPtri s0 -> do-                a <- MaybeCont.lift $ Storable.load aPtri-                (b,s1) <- next param local a s0-                MaybeCont.lift $ Storable.store b bPtri-                return s1-             Memory.store (Maybe.fromJust sExit) sptr-             ret pos)---traverseChunks ::-   (Storable.C a, Storable.C b) =>-   (LLVM.Ptr paramStruct -> LLVM.Ptr stateStruct ->-    Word -> Ptr a -> Ptr b -> IO Word) ->-   ForeignPtr.MemoryPtr paramStruct ->-   ForeignPtr.MemoryPtr stateStruct ->-   SVL.Vector a -> IO [SVB.Vector b]-traverseChunks fill paramFPtr statePtr =-   let go xt =-          Unsafe.interleaveIO $-          case xt of-             [] -> return []-             x:xs -> SVB.withStartPtr x $ \aPtr size -> do-                v <--                   ForeignPtr.with paramFPtr $ \paramPtr ->-                   ForeignPtr.with statePtr $ \sptr ->-                   SVB.createAndTrim size $-                      fmap (fromIntegral :: Word -> Int) .-                      fill paramPtr sptr (fromIntegral size) aPtr-                (if SV.length v > 0-                   then fmap (v:)-                   else id) $-                   (if SV.length v < size-                      then return []-                      else go xs)-   in  go . SVL.chunks---runStorableChunky ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b)-runStorableChunky-      (Cons next alloca start createIOContext deleteIOContext) = do--   (startFunc, stopFunc, fill) <- compileChunky next alloca start-   return $ \sig -> SVL.fromChunks $ Unsafe.performIO $ do-      (ioContext, params) <- createIOContext-      paramPtr <- ForeignPtr.new (deleteIOContext ioContext) params-      statePtr <--         ForeignPtr.newInit stopFunc $ ForeignPtr.with paramPtr startFunc-      traverseChunks fill paramPtr statePtr sig---applyStorableChunky ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T valueA valueB -> SVL.Vector a -> SVL.Vector b-applyStorableChunky = Unsafe.performIO . runStorableChunky+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Causal.Process (+   Causal.T, MV,+   CausalClass.fromSignal,+   CausalClass.toSignal,+   (CausalClass.$<), (CausalClass.$>), (CausalClass.$*),+   ($<#), ($>#), ($*#),+   map,+   zipWith,+   takeWhile,+   take,+   mix,+   raise,+   envelope,+   envelopeStereo,+   amplify,+   amplifyStereo,+   mapLinear,+   mapExponential,+   loop,+   loopZero,+   integrate,+   integrateZero,+   delay1,+   delayControlled,+   delayControlledInterpolated,+   differentiate,+   feedbackControlled,+   feedbackControlledZero,+   mapAccum,+   fromModifier,+   osciCoreSync,+   osciCore,+   osci,+   shapeModOsci,+   skip,+   frequencyModulation,+   frequencyModulationLinear,+   Causal.quantizeLift,+   track,+   delay,+   delayZero,+   Causal.replicateControlled,+   replicateControlledParam,+   stereoFromMono,+   stereoFromMonoControlled,+   stereoFromMonoParameterized,+   comb,+   combStereo,+   reverbExplicit,+   reverbParams,+   trigger,+   arrayElement,+   vectorize,+   pipeline,+   ) where++import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Private as SigPriv+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.RingBuffer as RingBuffer+import qualified Synthesizer.LLVM.Interpolation as Interpolation+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame as Frame+import Synthesizer.LLVM.Generator.Private (arraySize)+import Synthesizer.LLVM.Private (noLocalPtr, unbool)++import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Class as CausalClass+import Synthesizer.Causal.Class (($*), ($<))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:<:))+import Type.Base.Proxy (Proxy(Proxy))++import qualified Data.List as List+import Data.Traversable (sequenceA)+import Data.Tuple.HT (mapSnd, swap)+import Data.Word (Word)++import qualified Control.Arrow as Arrow+import qualified Control.Category as Cat+import qualified Control.Monad.Trans.State as MS+import qualified Control.Functor.HT as FuncHT+import qualified Control.Applicative.HT as App+import Control.Arrow (Arrow, arr, (<<<), (^<<), (<<^), (>>>), (***), (&&&))+import Control.Applicative (pure, liftA2, liftA3, (<$>))++import qualified System.Unsafe as Unsafe+import System.Random (Random, RandomGen, randomR)++import qualified Algebra.Additive as Additive+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (map, zipWith, takeWhile, take)+import Prelude ()+++type MV a b = Causal.T (MultiValue.T a) (MultiValue.T b)+++infixl 0 $<#, $>#, $*#++{- |+provide constant input in a comfortable way+-}+($*#) ::+   (CausalClass.C process, CausalClass.SignalOf process ~ signal,+    MultiValue.C a) =>+   process (MultiValue.T a) b -> a -> signal b+proc $*# x = CausalClass.applyConst proc $ MultiValue.cons x++($<#) ::+   (CausalClass.C process, MultiValue.C a) =>+   process (MultiValue.T a, b) c -> a -> process b c+proc $<# x = CausalClass.applyConstFst proc $ MultiValue.cons x++($>#) ::+   (CausalClass.C process, MultiValue.C b) =>+   process (a, MultiValue.T b) c -> b -> process a c+proc $># x = CausalClass.applyConstSnd proc $ MultiValue.cons x++++map ::+   (Expr.Aggregate ae a, Expr.Aggregate be b) =>+   (ae -> be) -> Causal.T a b+map f = Causal.map (\a -> Expr.bundle (f (Expr.dissect a)))++zipWith ::+   (Expr.Aggregate ae a, Expr.Aggregate be b, Expr.Aggregate ce c) =>+   (ae -> be -> ce) -> Causal.T (a,b) c+zipWith f = map (uncurry f)++takeWhile :: (Expr.Aggregate ae a) => (ae -> Exp Bool) -> Causal.T a a+takeWhile p = Causal.simple+   (\a () -> do+      MaybeCont.guard . unbool =<< MaybeCont.lift (Expr.unliftM1 p a)+      return (a,()))+   (return ())++take :: Exp Word -> Causal.T a a+take len =+   arr snd $< (takeWhile (0 Expr.<*) $* Sig.iterate (subtract 1) len)+++{- |+You may also use '(+)'.+-}+mix :: (A.Additive a) => Causal.T (a,a) a+mix = Causal.zipWith Frame.mix++{- |+You may also use '(+)' and a 'Sig.constant' signal or a number literal.+-}+raise :: (Marshal.C a, MultiValue.Additive a) => Exp a -> MV a a+raise x = mix $< Sig.constant x+++{- |+You may also use '(*)'.+-}+envelope :: (A.PseudoRing a) => Causal.T (a, a) a+envelope = Causal.zipWith Frame.amplifyMono++envelopeStereo :: (A.PseudoRing a) => Causal.T (a, Stereo.T a) (Stereo.T a)+envelopeStereo = Causal.zipWith Frame.amplifyStereo++{- |+You may also use '(*)' and a 'Sig.constant' signal or a number literal.+-}+amplify ::+   (Expr.Aggregate ea a, Memory.C a, A.PseudoRing a) =>+   ea -> Causal.T a a+amplify x = envelope $< Sig.constant x++amplifyStereo ::+   (Marshal.C a, MultiValue.PseudoRing a, Stereo.T (MultiValue.T a) ~ stereo) =>+   Exp a -> Causal.T stereo stereo+amplifyStereo x = envelopeStereo $< Sig.constant x+++mapLinear ::+   (Marshal.C a, MultiValue.T a ~ am,+    MultiValue.PseudoRing a, MultiValue.IntegerConstant a) =>+   Exp a -> Exp a -> Causal.T am am+mapLinear depth center = map (\x -> center + depth*x)++-- ToDo: use base 2+mapExponential ::+   (Marshal.C a, MultiValue.T a ~ am,+    MultiValue.Transcendental a, MultiValue.RationalConstant a) =>+   Exp a -> Exp a -> Causal.T am am+mapExponential depth center =+   let logDepth = log depth+   in map (\x -> center * exp (logDepth * x))+++loop ::+   (Expr.Aggregate ce c, Memory.C c) =>+   ce -> Causal.T (a,c) (b,c) -> Causal.T a b+loop initial = Causal.loop (Expr.bundle initial)++loopZero ::+   (A.Additive c, Memory.C c) =>+   Causal.T (a,c) (b,c) -> Causal.T a b+loopZero = Causal.loop (return A.zero)++loopConst ::+   (Memory.C c) =>+   c -> Causal.T (a,c) (b,c) -> Causal.T a b+loopConst c = Causal.loop (return c)+++integrate ::+   (Expr.Aggregate ae a, A.Additive a, Memory.C a) => ae -> Causal.T a a+integrate initial = loop initial (arr snd &&& Causal.zipWith A.add)++integrateZero :: (A.Additive a, Memory.C a) => Causal.T a a+integrateZero = loopZero (arr snd &&& Causal.zipWith A.add)+++feedbackControlledAux ::+   (Arrow arrow) =>+   arrow ((ctrl,a),c) b ->+   arrow (ctrl,b) c ->+   arrow ((ctrl,a),c) (b,c)+feedbackControlledAux forth back =+   arr snd &&& back  <<<  arr (fst.fst) &&& forth++feedbackControlled ::+   (Expr.Aggregate ce c, Memory.C c) =>+   ce -> Causal.T ((ctrl,a),c) b -> Causal.T (ctrl,b) c -> Causal.T (ctrl,a) b+feedbackControlled initial forth back =+   loop initial (feedbackControlledAux forth back)++feedbackControlledZero ::+   (A.Additive c, Memory.C c) =>+   Causal.T ((ctrl,a),c) b -> Causal.T (ctrl,b) c -> Causal.T (ctrl,a) b+feedbackControlledZero forth back =+   loopZero (feedbackControlledAux forth back)+++arrayPtr ::+   (TypeNum.Natural n, LLVM.IsSized a) =>+   LLVM.Value (LLVM.Ptr a) ->+   LLVM.CodeGenFunction r (LLVM.Value (LLVM.Ptr (LLVM.Array n a)))+arrayPtr = LLVM.bitcast++replicateControlledParam ::+   (TypeNum.Natural n) =>+   (Tuple.Undefined a, Tuple.Phi a) =>+   (Marshal.C b, (n TypeNum.:*: LLVM.SizeOf (Marshal.Struct b)) ~ bSize,+    TypeNum.Natural bSize) =>+   (Exp b -> Causal.T (c,a) a) ->+   Exp (MultiValue.Array n b) -> Causal.T (c,a) a+replicateControlledParam f ps = Unsafe.performIO $ do+   let n :: Word+       n = TypeNum.integralFromProxy $ arraySize ps+   paramd <- Parameterized.fromProcessPtr "Causal.replicateControlledParam" f+   return $+      case paramd of+         Parameterized.Cons next start stop ->+            Causal.Cons+               (\(bPtr,globalPtr) localPtr (c,a0) statePtr -> do+                  a1 <-+                     MaybeCont.fromBool $+                     Iter.mapWhileState_+                        (\(biPtr,globalIPtr,localIPtr,stateIPtr)+                              (_cont,ai0) -> do+                           global <- Memory.load globalIPtr+                           local <- Memory.load localIPtr+                           state0 <- Memory.load stateIPtr+                           (conti,(ai1,state1)) <-+                              MaybeCont.toBool $+                              next biPtr global local (c,ai0) state0+                           flip LLVM.store stateIPtr =<< Memory.compose state1+                           return (conti,(conti,ai1)))+                        (Iter.take (LLVM.valueOf n) $+                         App.lift4 (,,,)+                           (Iter.arrayPtrs bPtr)+                           (Iter.arrayPtrs globalPtr)+                           (Iter.arrayPtrs localPtr)+                           (Iter.arrayPtrs statePtr))+                        (LLVM.valueOf True, a0)+                  return (a1, statePtr))+               (do+                  bArr <- Expr.unExp ps+                  bPtr <- LLVM.arrayMalloc n+                  Memory.store bArr =<< arrayPtr bPtr+                  {-+                  ToDo:+                  Instead of a pointer to a malloced with dynamic length+                  we could use LLVM.Array.+                  However, we would have to establish the constraint+                  Natural (n :*: LLVM.SizeOf (Marshal.Struct a))+                  This is pretty cumbersome+                  with current decimal number representation.+                  It would be feasible with type-level natural numbers, though.+                  -}+                  globalPtr <- LLVM.arrayMalloc n+                  statePtr <- LLVM.arrayMalloc n+                  Iter.mapM_+                     (\(biPtr,globalIPtr,stateIPtr) -> do+                        (global,state) <- start biPtr+                        flip LLVM.store globalIPtr =<< Memory.compose global+                        flip LLVM.store stateIPtr =<< Memory.compose state)+                     (Iter.take (LLVM.valueOf n) $+                      liftA3 (,,)+                        (Iter.arrayPtrs bPtr)+                        (Iter.arrayPtrs globalPtr)+                        (Iter.arrayPtrs statePtr))+                  return ((bPtr,globalPtr), statePtr))+               (\(bPtr,globalPtr) ->+                  Iter.mapM_+                     (\(biPtr,globalIPtr) -> do+                        stop biPtr =<< Memory.load globalIPtr)+                     (Iter.take (LLVM.valueOf n) $+                      liftA2 (,)+                        (Iter.arrayPtrs bPtr)+                        (Iter.arrayPtrs globalPtr)))+++{- |+Run a causal process independently on each stereo channel.+-}+stereoFromMono ::+   (Tuple.Phi a, Tuple.Undefined a, Tuple.Phi b, Tuple.Undefined b) =>+   Causal.T a b -> Causal.T (Stereo.T a) (Stereo.T b)+stereoFromMono proc =+   snd+   ^<<+   Causal.replicateSerial 2+      ((\((x,a),b) -> (Stereo.swap a, Stereo.cons (Stereo.right b) x))+       ^<<+       Arrow.first ((proc <<^ Stereo.left) &&& Cat.id))+   <<^+   (\a -> (a, Tuple.undef))++stereoFromMonoControlled ::+   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c,+    Tuple.Undefined a, Tuple.Undefined b, Tuple.Undefined c) =>+   Causal.T (c,a) b -> Causal.T (c, Stereo.T a) (Stereo.T b)+stereoFromMonoControlled proc =+   stereoFromMono proc <<^ (\(c,sa) -> (,) c <$> sa)++arrayFromStereo ::+   (Marshal.C a) =>+   Stereo.T (MultiValue.T a) ->+   LLVM.CodeGenFunction r (MultiValue.T (MultiValue.Array TypeNum.D2 a))+arrayFromStereo a =+   MultiValue.insertArrayValue TypeNum.d0 (Stereo.left a) =<<+   MultiValue.insertArrayValue TypeNum.d1 (Stereo.right a) MultiValue.undef++stereoFromMonoParameterized ::+   (Marshal.C x,+    Tuple.Phi a, Tuple.Undefined a, Tuple.Phi b, Tuple.Undefined b) =>+   ((TypeNum.D2 TypeNum.:*: LLVM.SizeOf (Marshal.Struct x)) ~ xSize,+    TypeNum.Natural xSize) =>+   (Exp x -> Causal.T a b) ->+   Stereo.T (Exp x) -> Causal.T (Stereo.T a) (Stereo.T b)+stereoFromMonoParameterized f sx =+   snd+   ^<<+   replicateControlledParam+      (\x ->+         (\((y,a),b) -> (Stereo.swap a, Stereo.cons (Stereo.right b) y))+         ^<<+         Arrow.first ((f x <<^ Stereo.left) &&& Cat.id)+         <<^+         snd)+      (Expr.liftM arrayFromStereo sx)+   <<^+   (\a -> ((),(a,Tuple.undef)))+++mapAccum ::+   (Expr.Aggregate state statel, Memory.C statel,+    Expr.Aggregate a al, Expr.Aggregate b bl) =>+   (a -> state -> (b, state)) -> state -> Causal.T al bl+mapAccum next start =+   Causal.mapAccum+      (\a s -> Expr.bundle $ next (Expr.dissect a) (Expr.dissect s))+      (Expr.bundle start)++fromModifier ::+   (Expr.Aggregate ae al,+    Expr.Aggregate be bl,+    Expr.Aggregate ce cl,+    Expr.Aggregate se sl, Memory.C sl) =>+   Modifier.Simple se ce ae be -> Causal.T (cl,al) bl+fromModifier (Modifier.Simple initial step) =+   mapAccum (\(c,a) -> MS.runState (step c a)) initial+++delay1 :: (Expr.Aggregate ae a, Memory.C a) => ae -> Causal.T a a+delay1 initial  =  loop initial (arr swap)++differentiate ::+   (A.Additive a, Expr.Aggregate ae a, Memory.C a) => ae -> Causal.T a a+differentiate initial  =  Cat.id - delay1 initial+++{- |+Compute the phases from phase distortions and frequencies.++It's like integrate but with wrap-around performed by @fraction@.+For FM synthesis we need also negative phase distortions,+thus we use 'A.addToPhase' which supports that.+-}+osciCore, _osciCore, osciCoreSync ::+   (Memory.C t, A.Fraction t) => Causal.T (t, t) t+_osciCore =+   Causal.zipWith A.addToPhase <<<+   Arrow.second+      (Causal.mapAccum+         (\a s -> do+            b <- A.incPhase a s+            return (s,b))+         (return A.zero))++{-+This could be implemented using a generalized frequencyModulation,+however, osciCoreSync allows for negative phase differences.+-}+osciCoreSync =+   Causal.zipWith A.addToPhase <<<+   Arrow.second+      (Causal.mapAccum+         (\a s -> do+            b <- A.incPhase a s+            return (b,b))+         (return A.zero))++osciCore =+   Causal.zipWith A.addToPhase <<<+   Arrow.second (loopZero (arr snd &&& Causal.zipWith A.incPhase))++osci ::+   (Memory.C t, A.Fraction t) =>+   (forall r. t -> LLVM.CodeGenFunction r y) ->+   Causal.T (t, t) y+osci wave  =  Causal.map wave <<< osciCore++shapeModOsci ::+   (Memory.C t, A.Fraction t) =>+   (forall r. c -> t -> LLVM.CodeGenFunction r y) ->+   Causal.T (c, (t, t)) y+shapeModOsci wave  =  Causal.zipWith wave <<< Arrow.second osciCore+++{- |+Feeds a signal into a causal process while holding or skipping signal elements+according to the process input.+The skip happens after a value is passed from the fed signal.++@skip x $* 0@ repeats the first signal value in the output.+@skip x $* 1@ feeds the signal to the output as is.+@skip x $* 2@ feeds the signal to the output with double speed.+-}+skip ::+   (Tuple.Undefined a, Tuple.Phi a, Memory.C a) =>+   Sig.T a -> Causal.T (MultiValue.T Word) a+skip (SigPriv.Cons next start stop) = Causal.Cons+   (\global local n1 (yState0, MultiValue.Cons n0) -> do+      yState1@(y,_) <-+         MaybeCont.fromMaybe $ fmap snd $+         MaybeCont.fixedLengthLoop n0 yState0 $+         next global local . snd+      return (y, (yState1,n1)))+   (mapSnd (\s -> ((Tuple.undef, s), A.one)) <$> start)+   stop++frequencyModulation ::+   (Marshal.C a,+    MultiValue.IntegerConstant a,+    MultiValue.Additive a,+    MultiValue.Comparison a,+    Tuple.Undefined nodes, Tuple.Phi nodes, Memory.C nodes) =>+   (forall r. MultiValue.T a -> nodes -> LLVM.CodeGenFunction r v) ->+   SigPriv.T nodes -> Causal.T (MultiValue.T a) v+frequencyModulation ip (SigPriv.Cons next start stop) = Causal.Cons+   (\global local k yState0 -> do+      ((nodes2,state2), ss2) <-+         MaybeCont.fromBool $+         C.whileLoop+            (LLVM.valueOf True, yState0)+            (\(cont0, (_, ss0)) ->+               LLVM.and cont0 . unbool =<< MultiValue.cmp LLVM.CmpGE ss0 A.one)+            (\(_,((_,state0), ss0)) ->+               MaybeCont.toBool $ liftA2 (,)+                  (next global local state0)+                  (MaybeCont.lift $ A.sub ss0 A.one))++      MaybeCont.lift $ do+         y <- ip ss2 nodes2+         ss3 <- A.add ss2 k+         return (y, ((nodes2, state2), ss3)))+   (fmap (\(global,sa) -> (global, ((Tuple.undef, sa), A.one))) start)+   stop++frequencyModulationLinear ::+   (MultiValue.PseudoRing a, MultiValue.IntegerConstant a,+    MultiValue.Comparison a, Marshal.C a) =>+   Sig.MV a -> MV a a+frequencyModulationLinear sig =+   frequencyModulation Interpolation.linear (Sig.adjacentNodes02 sig)+++track ::+   (Expr.Aggregate ae al, Memory.C al) =>+   ae -> Exp Word -> Causal.T al (RingBuffer.T al)+track initial time = Causal.Cons+   (\(size0,ptr) -> noLocalPtr $ \a remain0 -> MaybeCont.lift $ do+      Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())+      cont <- A.cmp LLVM.CmpGT remain0 A.zero+      remain1 <- C.ifThenSelect cont size0 (A.dec remain0)+      size1 <- A.inc size0+      return (RingBuffer.Cons ptr size1 remain0 remain1, remain1))+   (do+      MultiValue.Cons size0 <- Expr.unExp time+      size1 <- A.inc size0+      ptr <- LLVM.arrayMalloc size1+      a <- Expr.bundle initial+      -- cf. LLVM.Storable.Signal.fill+      C.arrayLoop size1 ptr () $ \ ptri () -> Memory.store a ptri+      return ((size0,ptr), size0))+   (LLVM.free . snd)++{- |+Delay time must be non-negative.+-}+delay ::+   (Expr.Aggregate ae al, Memory.C al) =>+   ae -> Exp Word -> Causal.T al al+delay initial time = Causal.map RingBuffer.oldest <<< track initial time++delayZero ::+   (Expr.Aggregate ae al, Additive.C ae, Memory.C al) =>+   Exp Word -> Causal.T al al+delayZero = delay zero++{- |+Delay time must be greater than zero!+-}+comb ::+   (Marshal.C a, MultiValue.PseudoRing a) =>+   Exp a -> Exp Word -> MV a a+comb gain time =+   loopZero (mix >>> (Cat.id &&& (delayZero (time-1) >>> amplify gain)))++combStereo ::+   (Marshal.C a, MultiValue.PseudoRing a, Stereo.T (MultiValue.T a) ~ stereo) =>+   Exp a -> Exp Word -> Causal.T stereo stereo+combStereo gain time =+   loopZero (mix >>> (Cat.id &&& (delayZero (time-1) >>> amplifyStereo gain)))++reverbExplicit ::+   (TypeNum.Natural n, (n TypeNum.:*: LLVM.UnknownSize) ~ paramSize,+    TypeNum.Natural paramSize) =>+   (Marshal.C a,+    MultiValue.Field a, MultiValue.Real a, MultiValue.IntegerConstant a) =>+   Exp (MultiValue.Array n (a,Word)) -> MV a a+reverbExplicit params =+   amplify (Expr.recip $ TypeNum.integralFromProxy $ arraySize params)+   <<<+   replicateControlledParam+      (\p -> Arrow.first (comb (Expr.fst p) (Expr.snd p)) >>> mix)+      params+   <<^+   (\a -> (a,a))++reverbParams ::+   (RandomGen g, TypeNum.Integer n, Random a) =>+   g -> Proxy n -> (a,a) -> (Word, Word) -> MultiValue.Array n (a, Word)+reverbParams rnd Proxy gainRange timeRange =+   flip MS.evalState rnd $+   sequenceA $ pure $+   liftA2 (,)+      (MS.state (randomR gainRange))+      (MS.state (randomR timeRange))+++{- |+Delay by a variable amount of samples.+The momentum delay must be between @0@ and @maxTime@, inclusively.+How about automated clipping?+-}+delayControlled ::+   (Expr.Aggregate ae al, Memory.C al) =>+   ae -> Exp Word -> Causal.T (MultiValue.T Word, al) al+delayControlled initial maxTime =+   Causal.zipWith RingBuffer.index+   <<<+   arr (\(MultiValue.Cons i) -> i) *** track initial maxTime++{- |+Delay by a variable fractional amount of samples.+Non-integer delays are achieved by interpolation.+The momentum delay must be between @0@ and @maxTime@, inclusively.+-}+delayControlledInterpolated ::+   (Interpolation.C nodes) =>+   (MultiValue.T a ~ am) =>+   (MultiValue.NativeFloating a ar, MultiValue.Additive a) =>+   (Expr.Aggregate ve v, Memory.C v) =>+   (forall r. Interpolation.T r nodes am v) ->+   ve -> Exp Word -> Causal.T (am, v) v+delayControlledInterpolated ip initial maxTime =+   let margin = Interpolation.toMargin ip+   in Causal.zipWith+         (\del buf -> do+            let offset =+                  A.fromInteger' $ fromIntegral $+                  Interpolation.marginOffset margin+            n <- A.max offset =<< MultiValue.truncateToInt del+            k <- A.sub del =<< MultiValue.fromIntegral n+            ~(MultiValue.Cons m) <- A.sub n (offset :: MultiValue.T Word)+            ip k =<<+               Interpolation.indexNodes (flip RingBuffer.index buf) A.one m)+      <<<+      Arrow.second+         (track initial+             (fromIntegral (Interpolation.marginNumber margin) + maxTime))+++{- |+This allows to compute a chain of equal processes efficiently,+if all of these processes can be bundled in one vectorial process.+Applications are an allpass cascade or an FM operator cascade.++The function expects that the vectorial input process+works like parallel scalar processes.+The different pipeline stages may be controlled by different parameters,+but the structure of all pipeline stages must be equal.+Our function feeds the input of the pipelined process+to the zeroth element of the Vector.+The result of processing the i-th element (the i-th channel, so to speak)+is fed to the (i+1)-th element.+The (n-1)-th element of the vectorial process is emitted+as output of the pipelined process.++The pipeline necessarily introduces a delay of (n-1) values.+For simplification we extend this to n values delay.+If you need to combine the resulting signal from the pipeline+with another signal in a 'zip'-like way,+you may delay that signal with @pipeline id@.+The first input values in later stages of the pipeline+are initialized with zero.+If this is not appropriate for your application,+then we may add a more sensible initialization.+-}+pipeline ::+   (TypeNum.Positive n, MultiVector.C x,+    v ~ MultiVector.T n x,+    a ~ MultiValue.T x,+    Tuple.Zero v, Memory.C v) =>+   Causal.T v v -> Causal.T a a+pipeline vectorProcess =+   loopConst MultiVector.zero $+      Causal.map (uncurry MultiVector.shiftUp)+      >>>+      Arrow.second vectorProcess+++{-+insert and extract instructions will be in opposite order,+no matter whether we use foldr or foldl+and independent from the order of proc and channel in replaceChannel.+However, LLVM neglects the order anyway.+-}+vectorize ::+   (TypeNum.Positive n,+    MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va,+    MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) =>+   Causal.T a b -> Causal.T va vb+vectorize proc =+   withSize $ \n ->+      foldl+         (\acc i -> replaceChannel i proc acc)+         (arr (const Tuple.undef)) $+      List.take (TypeNum.integralFromSingleton n) [0 ..]++withSize ::+   (TypeNum.Positive n, MultiVector.T n a ~ v) =>+   (TypeNum.Singleton n -> f v) ->+   f v+withSize f = f TypeNum.singleton++{- |+Given a vector process, replace the i-th output by output+that is generated by a scalar process from the i-th input.+-}+replaceChannel ::+   (TypeNum.Positive n,+    MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va,+    MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) =>+   Int -> Causal.T a b -> Causal.T va vb -> Causal.T va vb+replaceChannel i channel proc =+   let li = LLVM.valueOf $ fromIntegral i+   in Causal.zipWith (MultiVector.insert li) <<<+         (channel <<< Causal.map (MultiVector.extract li)) &&&+         proc+++{- |+Read the i-th element from each array.+-}+arrayElement ::+   (Marshal.C a, Marshal.Struct a ~ aStruct, LLVM.IsFirstClass aStruct,+    TypeNum.Natural i, TypeNum.Natural n, i :<: n) =>+   Proxy i -> Causal.T (MultiValue.T (MultiValue.Array n a)) (MultiValue.T a)+arrayElement i = Causal.map (MultiValue.extractArrayValue i)+++{- |+@trigger fill signal@ sends @signal@ to the output+and restarts it whenever the process input is 'Just'.+Before the Arrow.first occurrence of 'Just'+and between instances of the signal the output is filled with 'Maybe.nothing'.+-}+trigger ::+   (Marshal.C a, Tuple.Undefined b, Tuple.Phi b) =>+   (Exp a -> Sig.T b) ->+   Causal.T (Maybe.T (MultiValue.T a)) (Maybe.T b)+trigger f = Unsafe.performIO $ do+   paramd <-+      Parameterized.fromProcess "Causal.trigger" (CausalClass.fromSignal . f)+   return $+      case paramd of+         Parameterized.Cons next start stop -> Causal.Cons+            (\globalPtr local ma ms0 -> MaybeCont.lift $ do+               ms1 <-+                  Maybe.run ma+                     (return ms0)+                     (\a -> do+                        stopAndFree stop globalPtr+                        (global2,state2) <- start a+                        Memory.store (Maybe.just (a,global2)) globalPtr+                        return $ Maybe.just state2)+               mc1 <- Memory.load globalPtr+               mcs1 <- Maybe.lift2 (,) mc1 ms1+               as2 <-+                  Maybe.run mcs1 (return Maybe.nothing) $ \((p1,c1),s1) ->+                     MaybeCont.toMaybe $ next p1 c1 local () s1+               return $ FuncHT.unzip as2)+            (do+               globalPtr <- LLVM.malloc+               Memory.store (nothingFromFunc f stop) globalPtr+               return (globalPtr, Maybe.nothing))+            (\globalPtr -> do+               stopAndFree stop globalPtr+               LLVM.free globalPtr)++stopAndFree ::+   (Memory.C global, Memory.C am) =>+   (am -> global -> LLVM.CodeGenFunction r ()) ->+   LLVM.Value (LLVM.Ptr (Memory.Struct (Maybe.T (am, global)))) ->+   LLVM.CodeGenFunction r ()+stopAndFree stop globalPtr = do+   maybeGlobal <- Memory.load globalPtr+   Maybe.for maybeGlobal $ \(a,global) -> stop a global++nothingFromFunc ::+   (MultiValue.C a, Tuple.Undefined global) =>+   (Exp a -> Sig.T b) ->+   (ap -> global -> code) ->+   Maybe.T (MultiValue.T a, global)+nothingFromFunc _ _ = Maybe.nothing
src/Synthesizer/LLVM/Causal/ProcessPacked.hs view
@@ -1,76 +1,83 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Causal.ProcessPacked where +import qualified Synthesizer.LLVM.Causal.Private as CausalPriv import qualified Synthesizer.LLVM.Causal.Process as Causal-import Synthesizer.LLVM.Causal.ProcessPrivate (Core(Core), alter)- import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialClass+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame as Frame -import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Control as C--import qualified LLVM.Core as LLVM-import LLVM.Core-          (CodeGenFunction, Value, valueOf,-           IsSized, IsFirstClass)+import qualified LLVM.Extra.Arithmetic as A  import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal ((:<:)) import Type.Base.Proxy (Proxy) +import qualified LLVM.Core as LLVM++import qualified Control.Arrow as Arrow+import qualified Control.Category as Cat import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS-import qualified Control.Arrow as Arr import Control.Arrow ((<<<)) +import Data.Tuple.HT (swap) import Data.Word (Word)  import NumericPrelude.Numeric-import NumericPrelude.Base+import NumericPrelude.Base hiding (map, zipWith, takeWhile)+import Prelude ()  +type Serial n a = MultiValue.T (Serial.T n a)++ {- | Run a scalar process on packed data. If the signal length is not divisible by the chunk size, then the last chunk is dropped. -} pack ::-   (Causal.C process,-    Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va,-    Serial.C    vb, n ~ Serial.Size vb, b ~ Serial.Element vb) =>-   process a b -> process va vb-pack = alter (\(Core next start stop) -> Core-   (\param a s -> do-      r <- Maybe.lift $ Serial.readStart a+   (SerialClass.Read  va, n ~ SerialClass.Size va, a ~ SerialClass.Element va,+    SerialClass.Write vb, n ~ SerialClass.Size vb, b ~ SerialClass.Element vb)+   =>+   Causal.T a b -> Causal.T va vb+pack (CausalPriv.Cons next start stop) = CausalPriv.Cons+   (\global local a s -> do+      r <- Maybe.lift $ SerialClass.readStart a       ((_,w2),(_,s2)) <-          Maybe.fromBool $          C.whileLoop-            (valueOf True,+            (LLVM.valueOf True,              let w = Tuple.undef-             in  ((r,w),-                  (valueOf (fromIntegral $ Serial.sizeOfIterator w :: Word), s)))+             in ((r,w),+                 (LLVM.valueOf (SerialClass.sizeOfIterator w :: Word), s)))             (\(cont,(_rw0,(i0,_s0))) ->-               A.and cont =<<-                  A.cmp LLVM.CmpGT i0 A.zero)+               A.and cont =<< A.cmp LLVM.CmpGT i0 A.zero)             (\(_,((r0,w0),(i0,s0))) -> Maybe.toBool $ do-               (ai,r1) <- Maybe.lift $ Serial.readNext r0-               (bi,s1) <- next param ai s0+               (ai,r1) <- Maybe.lift $ SerialClass.readNext r0+               (bi,s1) <- next global local ai s0                Maybe.lift $ do-                  w1 <- Serial.writeNext bi w0+                  w1 <- SerialClass.writeNext bi w0                   i1 <- A.dec i0                   return ((r1,w1),(i1,s1)))-      b <- Maybe.lift $ Serial.writeStop w2+      b <- Maybe.lift $ SerialClass.writeStop w2       return (b, s2))    start-   stop)+   stop  {- | Like 'pack' but duplicates the code for the scalar process.@@ -79,100 +86,95 @@ This is efficient only for simple input processes. -} packSmall ::-   (Causal.C process,-    Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va,-    Serial.C    vb, n ~ Serial.Size vb, b ~ Serial.Element vb) =>-   process a b -> process va vb-packSmall = alter (\(Core next start stop) -> Core-   (\param a ->+   (SerialClass.Read  va, n ~ SerialClass.Size va, a ~ SerialClass.Element va,+    SerialClass.Write vb, n ~ SerialClass.Size vb, b ~ SerialClass.Element vb)+   =>+   Causal.T a b -> Causal.T va vb+packSmall (CausalPriv.Cons next start stop) = CausalPriv.Cons+   (\global local a ->       MS.runStateT $-         (MT.lift . Maybe.lift . Serial.assemble)+         MT.lift . Maybe.lift . SerialClass.assemble          =<<-         mapM (MS.StateT . next param)+         mapM (MS.StateT . next global local)          =<<-         (MT.lift $ Maybe.lift $ Serial.extractAll a))+         (MT.lift $ Maybe.lift $ SerialClass.dissect a))    start-   stop)+   stop  -{- |-Run a packed process on scalar data.-If the signal length is not divisible by the chunk size,-then the last chunk is dropped.-In order to stay causal, we have to delay the output by @n@ samples.--}-unpack ::-   (Causal.C process,-    Serial.Zero va, n ~ Serial.Size va, a ~ Serial.Element va,-    Serial.Read vb, n ~ Serial.Size vb, b ~ Serial.Element vb,-    Memory.C va, Memory.C ita, ita ~ Serial.WriteIt va,-    Memory.C vb, Memory.C itb, itb ~ Serial.ReadIt vb) =>-   process va vb -> process a b-unpack = alter (\(Core next start stop) -> Core-   (\param ai ((w0,r0),(i0,s0)) -> do-      endOfVector <- Maybe.lift $ A.cmp LLVM.CmpEQ i0 A.zero-      ((w2,r2),(i2,s2)) <--         Maybe.fromBool $-         C.ifThen endOfVector (valueOf True, ((w0,r0),(i0,s0))) $ do-            a0 <- Serial.writeStop w0-            (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0-            r1 <- Serial.readStart b1-            w1 <- Serial.writeStart-            return (cont1,-                      ((w1, r1),-                       (valueOf $ fromIntegral $ Serial.size a0, s1)))-      Maybe.lift $ do-         w3 <- Serial.writeNext ai w2-         (bi,r3) <- Serial.readNext r2-         i3 <- A.dec i2-         return (bi, ((w3,r3),(i3,s2))))-   (\s -> do-      s1 <- start s-      w <- Serial.writeZero-      return ((w, Tuple.undef), (valueOf (0::Word), s1)))-   (\(_wr,(_i,state)) -> stop state))+raise ::+   (TypeNum.Positive n, MultiVector.Additive a) =>+   Exp a -> Causal.T (Serial n a) (Serial n a)+raise x =+   CausalPriv.map+      (\y -> Expr.unExp (Serial.upsample x) >>= flip Frame.mix y) +amplify ::+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   Exp a -> Causal.T (Serial n a) (Serial n a)+amplify x =+   CausalPriv.map+      (\y -> Expr.unExp (Serial.upsample x) >>= flip Frame.amplifyMono y) +amplifyStereo ::+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   Exp a -> Causal.T (Stereo.T (Serial n a)) (Stereo.T (Serial n a))+amplifyStereo x =+   CausalPriv.map+      (\y -> Expr.unExp (Serial.upsample x) >>= flip Frame.amplifyStereo y)+++delay1 ::+   (LLVM.Positive n, Marshal.C a,+    MultiVector.C a, SerialCode.Value n a ~ v) =>+   Exp a -> Causal.T v v+delay1 initial =+   Causal.loop initial $+   Causal.map (swap . uncurry Serial.shiftUp . swap)++differentiate ::+   (LLVM.Positive n, Marshal.C a,+    MultiVector.Additive a, SerialCode.Value n a ~ v) =>+   Exp a -> Causal.T v v+differentiate initial = Cat.id - delay1 initial++integrate ::+   (LLVM.Positive n, Marshal.C a,+    MultiVector.Additive a, SerialCode.Value n a ~ v) =>+   Exp a -> Causal.T v v+integrate =+   Causal.mapAccum (\a acc0 -> swap $ Serial.cumulate acc0 a)++ osciCore ::-   (Causal.C process,-    IsSized t, Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,-    TypeNum.Positive n) =>-   process (Serial.Value n t, Serial.Value n t) (Serial.Value n t)+   (TypeNum.Positive n, Marshal.C t, MultiVector.Fraction t) =>+   Causal.T (Serial n t, Serial n t) (Serial n t) osciCore =-   Causal.zipWith A.addToPhase <<<-   Arr.second+   CausalPriv.zipWith A.addToPhase <<<+   Arrow.second       (Causal.mapAccum-         (\a phase0 -> do-            (phase1,b1) <- Serial.cumulate phase0 a-            phase2 <- A.signedFraction phase1-            return (b1,phase2))-         (return A.zero))+         (\a phase0 ->+            let (phase1,b1) = Serial.cumulate phase0 a+            in (b1, Expr.liftM A.signedFraction phase1))+         Expr.zero)  osci ::-   (Causal.C process,-    IsSized t, Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,-    TypeNum.Positive n) =>-   (forall r. Serial.Value n t -> CodeGenFunction r y) ->-   process (Serial.Value n t, Serial.Value n t) y-osci wave =-   Causal.map wave <<< osciCore+   (TypeNum.Positive n, Marshal.C t, MultiVector.Fraction t) =>+   (forall r. Serial n t -> LLVM.CodeGenFunction r y) ->+   Causal.T (Serial n t, Serial n t) y+osci wave = CausalPriv.map wave <<< osciCore  shapeModOsci ::-   (Causal.C process,-    IsSized t, Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,-    TypeNum.Positive n) =>-   (forall r. c -> Serial.Value n t -> CodeGenFunction r y) ->-   process (c, (Serial.Value n t, Serial.Value n t)) y-shapeModOsci wave =-   Causal.zipWith wave <<< Arr.second osciCore-+   (TypeNum.Positive n, Marshal.C t, MultiVector.Fraction t) =>+   (forall r. c -> Serial n t -> LLVM.CodeGenFunction r y) ->+   Causal.T (c, (Serial n t, Serial n t)) y+shapeModOsci wave = CausalPriv.zipWith wave <<< Arrow.second osciCore   arrayElement ::-   (Causal.C process,-    IsFirstClass a, LLVM.Value a ~ Serial.Element v, Serial.C v,-    TypeNum.Natural index, TypeNum.Natural dim,-    index :<: dim) =>-   Proxy index -> process (Value (LLVM.Array dim a)) v-arrayElement i =-   Causal.map Serial.upsample <<< Causal.arrayElement i+   (TypeNum.Positive n,+    MultiVector.C a, Marshal.C a,+    Marshal.Struct a ~ aStruct, LLVM.IsFirstClass aStruct,+    TypeNum.Natural i, TypeNum.Natural d, i :<: d) =>+   Proxy i -> Causal.T (MultiValue.T (MultiValue.Array d a)) (Serial n a)+arrayElement i = Causal.map Serial.upsample <<< Causal.arrayElement i
− src/Synthesizer/LLVM/Causal/ProcessPrivate.hs 
@@ -1,306 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Causal.ProcessPrivate where--import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig-import qualified Synthesizer.Causal.Class as CausalClass-import qualified Synthesizer.Causal.Utility as ArrowUtil--import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory--import LLVM.Core (CodeGenFunction, Value)--import System.Random (Random, RandomGen, randomR)--import qualified Control.Arrow    as Arr-import qualified Control.Category as Cat-import qualified Control.Monad.Trans.State as MS-import Control.Arrow (Arrow, arr, (<<<), (>>>), (&&&))-import Control.Monad (liftM2, replicateM)-import Control.Applicative (Applicative, pure, (<*>))--import qualified Number.Ratio as Ratio-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, map, zip, zipWith, init)--import qualified Prelude as P---data Core context initState exitState a b =-   forall state.-      (Memory.C state) =>-      Core (forall r c.-            (Tuple.Phi c) =>-            context ->-            a -> state -> MaybeCont.T r c (b, state))-               -- compute next value-           (forall r.-            initState ->-            CodeGenFunction r state)-               -- initial state-           (state -> exitState)-               -- extract final state for cleanup---class-   (CausalClass.C process, Sig.C (CausalClass.SignalOf process)) =>-      C process where-   simple ::-      (Memory.C state) =>-      (forall r c.-       (Tuple.Phi c) =>-       a -> state -> MaybeCont.T r c (b, state)) ->-      (forall r. CodeGenFunction r state) ->-      process a b--   alter ::-      (forall contextLocal initState exitState.-          Core contextLocal initState exitState a0 b0 ->-          Core contextLocal initState exitState a1 b1) ->-      process a0 b0 -> process a1 b1--   replicateControlled ::-      (Tuple.Undefined x, Tuple.Phi x) =>-      Int -> process (c,x) x -> process (c,x) x---alterSignal ::-   (C process, CausalClass.SignalOf process ~ signal) =>-   (forall contextLocal initState exitState.-       Sig.Core contextLocal initState exitState a0 ->-       Core contextLocal initState exitState a1 b1) ->-   signal a0 -> process a1 b1-alterSignal f =-   alter (\(Core next start stop) -> f (Sig.Core (\c -> next c ()) start stop))-   .-   CausalClass.fromSignal----data T a b =-   forall state local ioContext parameters.-      (Marshal.C parameters, Memory.C state) =>-      Cons (forall r c.-            (Tuple.Phi c) =>-            Tuple.ValueOf parameters -> local ->-            a -> state -> MaybeCont.T r c (b, state))-               -- compute next value-           (forall r.-            CodeGenFunction r local)-               -- allocate temporary variables before a loop-           (forall r.-            Tuple.ValueOf parameters ->-            CodeGenFunction r state)-               -- initial state-           (IO (ioContext, parameters))-               -- initialization from IO monad-           (ioContext -> IO ())-               -- finalization from IO monad---type instance CausalClass.ProcessOf Sig.T = T--instance CausalClass.C T where-   type SignalOf T = Sig.T-   toSignal = toSignal-   fromSignal = fromSignal--instance C T where-   simple next start =-      Cons-         (const $ \ () -> next)-         (return ())-         (const start)-         (return ((),()))-         (const $ return ())--   alter f (Cons next0 alloca start0 create delete) =-      case f (Core (uncurry next0) start0 id) of-         Core next1 start1 _ ->-            Cons (curry next1) alloca start1 create delete--   {--   Could be implemented with a machine code loop like in CausalParameterized.-   But to this end we would need a 'stop' function.-   -}-   replicateControlled = CausalClass.replicateControlled---toSignal :: T () a -> Sig.T a-toSignal (Cons next alloca start createIOContext deleteIOContext) = Sig.Cons-   (\ioContext local -> next ioContext local ())-   alloca-   start-   createIOContext deleteIOContext--fromSignal :: Sig.T b -> T a b-fromSignal (Sig.Cons next alloca start createIOContext deleteIOContext) = Cons-   (\ioContext local _ -> next ioContext local)-   alloca-   start-   createIOContext deleteIOContext---map ::-   (C process) =>-   (forall r. a -> CodeGenFunction r b) ->-   process a b-map f =-   mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ())--mapAccum ::-   (C process, Memory.C state) =>-   (forall r.-    a -> state -> CodeGenFunction r (b, state)) ->-   (forall r. CodeGenFunction r state) ->-   process a b-mapAccum next =-   simple (\a s -> MaybeCont.lift $ next a s)--zipWith ::-   (C process) =>-   (forall r. a -> b -> CodeGenFunction r c) ->-   process (a,b) c-zipWith f = map (uncurry f)---mapProc ::-   (C process) =>-   (forall r. b -> CodeGenFunction r c) ->-   process a b ->-   process a c-mapProc f x = map f <<< x--zipProcWith ::-   (C process) =>-   (forall r. b -> c -> CodeGenFunction r d) ->-   process a b ->-   process a c ->-   process a d-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)-      (Cons nextB allocaB startB createIOContextB deleteIOContextB) = Cons-   (\(paramA, paramB) (localA, localB) a (sa0,sb0) -> do-      (b,sa1) <- nextA paramA localA a sa0-      (c,sb1) <- nextB paramB localB b sb0-      return (c, (sa1,sb1)))-   (liftM2 (,) allocaA allocaB)-   (Sig.combineStart startA startB)-   (Sig.combineCreate createIOContextA createIOContextB)-   (Sig.combineDelete deleteIOContextA deleteIOContextB)---first :: (C process) => process b c -> process (b, d) (c, d)-first = alter (\(Core next start stop) -> Core (firstNext next) start stop)---instance Cat.Category T where-   id = map return-   (.) = flip compose--instance Arr.Arrow T where-   arr f = map (return . f)-   first = first----instance Functor (T a) where-   fmap = ArrowUtil.map--instance Applicative (T a) where-   pure = ArrowUtil.pure-   (<*>) = ArrowUtil.apply---instance (A.Additive b) => Additive.C (T a b) where-   zero = pure A.zero-   negate = mapProc A.neg-   (+) = zipProcWith A.add-   (-) = zipProcWith A.sub--instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where-   one = pure A.one-   fromInteger n = pure (A.fromInteger' n)-   (*) = zipProcWith A.mul--instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where-   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)-   (/) = zipProcWith A.fdiv---instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T a b) where-   fromInteger n = pure (A.fromInteger' n)-   negate = mapProc A.neg-   (+) = zipProcWith A.add-   (-) = zipProcWith A.sub-   (*) = zipProcWith A.mul-   abs = mapProc A.abs-   signum = mapProc A.signum--instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T a b) where-   fromRational x = pure (A.fromRational' x)-   (/) = zipProcWith A.fdiv----firstNext ::-   (Functor m) =>-   (context -> a -> s -> m (b, s)) ->-   context -> (a, c) -> s -> m ((b, c), s)-firstNext next context (b,d) s0 =-   fmap-      (\(c,s1) -> ((c,d), s1))-      (next context b s0)--loopNext ::-   (Monad m) =>-   (context -> (a,c) -> state -> m ((b,c), state)) ->-   context -> a -> (c, state) -> m (b, (c, state))-loopNext next ctx a0 (c0,s0) = do-   ((b1,c1), s1) <- next ctx (a0,c0) s0-   return (b1,(c1,s1))--feedbackControlledAux ::-   Arrow arrow =>-   arrow ((ctrl,a),c) b ->-   arrow (ctrl,b) c ->-   arrow ((ctrl,a),c) (b,c)-feedbackControlledAux forth back =-   arr (fst.fst) &&& forth  >>>  arr snd &&& back---reverbParams ::-   (RandomGen g, Random a) =>-   g -> Int -> (a, a) -> (Int, Int) -> [(a, Int)]-reverbParams rnd num gainRange timeRange =-   flip MS.evalState rnd $-   replicateM num $-   liftM2 (,)-      (MS.state (randomR gainRange))-      (MS.state (randomR timeRange))
src/Synthesizer/LLVM/Causal/ProcessValue.hs view
@@ -1,50 +1,46 @@-{- |-This module provides functions similar to-"Synthesizer.LLVM.Causal.Process"-but expects functions that operate on 'Value.T'.-This way you can use common arithmetic operators-instead of LLVM assembly functions.--}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Causal.ProcessValue (-   map, zipWith, mapAccum, takeWhile,+   Causal.T,+   mapAccum,+   fromModifier,    ) where -import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Private as Causal +import qualified Synthesizer.LLVM.Value as Value++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Memory as Memory+ import qualified LLVM.Core as LLVM -import Prelude (Bool)+import Control.Monad.Trans.State (runState)  -map ::-   (Causal.C process) =>-   (Value.T a -> Value.T b) ->-   process a b-map f =-   Causal.map (Value.unlift1 f) -zipWith ::-   (Causal.C process) =>-   (Value.T a -> Value.T b -> Value.T c) ->-   process (a,b) c-zipWith f =-   Causal.zipWith (Value.unlift2 f)- mapAccum ::-   (Causal.C process, Memory.C s) =>-   (Value.T a -> Value.T s -> (Value.T b, Value.T s)) ->-   Value.T s ->-   process a b-mapAccum next start =-   Causal.mapAccum-      (Value.unlift2 next)-      (Value.unlift0 start)+   (Memory.C state) =>+   (forall r. a -> state -> LLVM.CodeGenFunction r (b, state)) ->+   (forall r. LLVM.CodeGenFunction r state) ->+   Causal.T a b+mapAccum next = Causal.simple (\a s -> MaybeCont.lift $ next a s) -takeWhile ::-   (Causal.C process) =>-   (Value.T a -> Value.T (LLVM.Value Bool)) ->-   process a a-takeWhile p =-   Causal.takeWhile (Value.unlift1 p)+fromModifier ::+   (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) =>+   Modifier.Simple sh ch ah bh -> Causal.T (cl,al) bl+fromModifier (Modifier.Simple initial step) =+   mapAccum+      (\(c,a) s ->+         Value.flatten $+         runState+            (step (Value.unfold c) (Value.unfold a))+            (Value.unfold s))+      (Value.flatten initial)
+ src/Synthesizer/LLVM/Causal/Render.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Causal.Render where++import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+import Synthesizer.LLVM.Causal.Private (T(Cons))+import Synthesizer.LLVM.Generator.Render+         (Triple, tripleStruct,+          derefStartPtr, derefStopPtr,+          RunArg, DSLArg, BuildArg(BuildArg), buildArg)++import qualified Synthesizer.LLVM.Plug.Input as PIn+import qualified Synthesizer.LLVM.Plug.Output as POut++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Generic.Cut as Cut++import qualified LLVM.DSL.Execution as Exec+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Data.StorableVector.Base as SVB+import qualified Data.StorableVector as SV++import Control.Monad (when, join)+import Control.Applicative (liftA3)++import Foreign.Ptr (Ptr)++import Data.Tuple.HT (snd3)+import Data.Word (Word)++++foreign import ccall safe "dynamic" derefFillPtr ::+   Exec.Importer (LLVM.Ptr global -> Word -> Ptr a -> Ptr b -> IO Word)+++compile ::+   (Storable.C a, MultiValue.T a ~ al,+    Storable.C b, MultiValue.T b ~ bl,+    Marshal.C param, Marshal.Struct param ~ paramStruct) =>+   (Exp param -> T al bl) ->+   IO (LLVM.Ptr paramStruct -> Word -> Ptr a -> Ptr b -> IO Word)+compile proc =+   Exec.compile "process" $+   Exec.createFunction derefFillPtr "fill" $ \paramPtr size aPtr bPtr ->+   case proc (Exp (Memory.load paramPtr)) of+      Cons next start stop -> do+         (global,s) <- start+         local <- LLVM.alloca+         (pos,_) <- Storable.arrayLoopMaybeCont2 size aPtr bPtr s $+               \aPtri bPtri s0 -> do+            a <- MaybeCont.lift $ Storable.load aPtri+            (b,s1) <- next global local a s0+            MaybeCont.lift $ Storable.store b bPtri+            return s1+         stop global+         return pos++runAux ::+   (Marshal.C p,+    Storable.C a, MultiValue.T a ~ al,+    Storable.C b, MultiValue.T b ~ bl) =>+   (Exp p -> T al bl) ->+   IO (IO () -> p -> SV.Vector a -> IO (SV.Vector b))+runAux proc = do+   fill <- compile proc+   return $ \final param as ->+      Marshal.with param $ \paramPtr ->+      SVB.withStartPtr as $ \ aPtr len ->+      SVB.createAndTrim len $ \bPtr -> do+         n <- fill paramPtr (fromIntegral len) aPtr bPtr+         final+         return $ fromIntegral n++run_ ::+   (Marshal.C p,+    Storable.C a, MultiValue.T a ~ al,+    Storable.C b, MultiValue.T b ~ bl) =>+   (Exp p -> T al bl) -> IO (p -> SV.Vector a -> IO (SV.Vector b))+run_ = fmap ($ return ()) . runAux++++foreign import ccall safe "dynamic" derefChunkPtr ::+   Exec.Importer (LLVM.Ptr globalState -> Word -> Ptr a -> Ptr b -> IO Word)++compileChunky ::+   (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr,+    Memory.C state, Memory.Struct state ~ stateStruct,+    Memory.C global, Memory.Struct global ~ globalStruct,+    Triple paramStruct globalStruct stateStruct ~ triple,+    LLVM.IsSized local,+    Storable.C a, MultiValue.T a ~ valueA,+    Storable.C b, MultiValue.T b ~ valueB) =>+   (forall r z. (Tuple.Phi z) =>+    pPtr ->+    global -> LLVM.Value (LLVM.Ptr local) ->+    valueA -> state -> MaybeCont.T r z (valueB, state)) ->+   (forall r. pPtr -> LLVM.CodeGenFunction r (global, state)) ->+   (forall r. pPtr -> global -> LLVM.CodeGenFunction r ()) ->+   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple),+       Exec.Finalizer triple,+       LLVM.Ptr triple -> Word -> Ptr a -> Ptr b -> IO Word)+compileChunky next start stop =+   Exec.compile "process-chunky" $+   liftA3 (,,)+      (Exec.createFunction derefStartPtr "startprocess" $+         \paramPtr -> do+            paramGlobalStatePtr <- LLVM.malloc+            (global,state) <- start paramPtr+            flip LLVM.store paramGlobalStatePtr =<<+               join+                  (liftA3 tripleStruct+                     (LLVM.load paramPtr)+                     (Memory.compose global)+                     (Memory.compose state))+            return paramGlobalStatePtr)+      (Exec.createFinalizer derefStopPtr "stopprocess" $+         \paramGlobalStatePtr -> do+            paramPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ())+            stop paramPtr =<<+               Memory.load =<<+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+            LLVM.free paramGlobalStatePtr)+      (Exec.createFunction derefChunkPtr "fillprocess" $+         \paramGlobalStatePtr loopLen aPtr bPtr -> do+            paramPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ())+            globalPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+            statePtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ())+            global <- Memory.load globalPtr+            sInit <- Memory.load statePtr+            local <- LLVM.alloca+            (pos,sExit) <-+               Storable.arrayLoopMaybeCont2 loopLen aPtr bPtr sInit $+                  \ aPtri bPtri s0 -> do+               a <- MaybeCont.lift $ Storable.load aPtri+               (b,s1) <- next paramPtr global local a s0+               MaybeCont.lift $ Storable.store b bPtri+               return s1+            Memory.store (Maybe.fromJust sExit) statePtr+            return pos)+++foreign import ccall safe "dynamic" derefChunkPluggedPtr ::+   Exec.Importer+      (LLVM.Ptr globalStateStruct -> Word ->+       LLVM.Ptr inp -> LLVM.Ptr out -> IO Word)++compilePlugged ::+   (Tuple.Undefined stateIn, Tuple.Phi stateIn) =>+   (Tuple.Undefined stateOut, Tuple.Phi stateOut) =>+   (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr,+    Memory.C state, Memory.Struct state ~ stateStruct,+    Memory.C global, Memory.Struct global ~ globalStruct,+    Triple paramStruct globalStruct stateStruct ~ triple) =>+   (LLVM.IsSized local) =>+   (Memory.C paramIn, Memory.Struct paramIn ~ inStruct) =>+   (Memory.C paramOut, Memory.Struct paramOut ~ outStruct) =>+   (forall r.+    paramIn -> stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) ->+   (forall r.+    paramIn -> LLVM.CodeGenFunction r stateIn) ->+   (forall r z. (Tuple.Phi z) =>+    pPtr -> global -> LLVM.Value (LLVM.Ptr local) ->+    valueA -> state -> MaybeCont.T r z (valueB, state)) ->+   (forall r. pPtr -> LLVM.CodeGenFunction r (global, state)) ->+   (forall r. pPtr -> global -> LLVM.CodeGenFunction r ()) ->+   (forall r.+    paramOut -> valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) ->+   (forall r.+    paramOut -> LLVM.CodeGenFunction r stateOut) ->+   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple),+       LLVM.Ptr triple -> IO (),+       LLVM.Ptr triple ->+         Word -> LLVM.Ptr inStruct -> LLVM.Ptr outStruct -> IO Word)+compilePlugged nextIn startIn next start stop nextOut startOut =+   Exec.compile "process-plugged" $+   liftA3 (,,)+      (Exec.createFunction derefStartPtr "startprocess" $+         \paramPtr -> do+            paramGlobalStatePtr <- LLVM.malloc+            (global,state) <- start paramPtr+            flip LLVM.store paramGlobalStatePtr =<<+               join+                  (liftA3 tripleStruct+                     (LLVM.load paramPtr)+                     (Memory.compose global)+                     (Memory.compose state))+            return paramGlobalStatePtr)+      (Exec.createFunction derefStopPtr "stopprocess" $+         \paramGlobalStatePtr -> do+            paramPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ())+            stop paramPtr =<<+               Memory.load =<<+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+            LLVM.free paramGlobalStatePtr)+      (Exec.createFunction derefChunkPluggedPtr "fillprocess" $+         \paramGlobalStatePtr loopLen inPtr outPtr -> do+            paramPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ())+            globalPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+            statePtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ())+            global <- Memory.load globalPtr+            sInit <- Memory.load statePtr+            inParam  <- Memory.load inPtr+            outParam <- Memory.load outPtr+            inInit  <- startIn  inParam+            outInit <- startOut outParam+            local <- LLVM.alloca+            (pos,sExit) <-+               MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $+                  \ (in0,s0,out0) -> do+               (a,in1) <- MaybeCont.lift $ nextIn inParam in0+               (b,s1) <- next paramPtr global local a s0+               out1 <- MaybeCont.lift $ nextOut outParam b out0+               return (in1, s1, out1)+            Memory.store (snd3 $ Maybe.fromJust sExit) statePtr+            return pos)+++{-+I liked to write something with signature++> import qualified Synthesizer.Causal.Process as Causal+>+> liftStorableChunk ::+>    (Exp param -> T valueA valueB) ->+>    IO (param -> Causal.T (SV.Vector a) (SV.Vector b))++but it does not quite work this way.+@Causal.T@ from @synthesizer-core@ uses an immutable state internally,+whereas @T@ uses mutable states.+In principle the immutable state of @Causal.T@+could be used for breaking the processing of a stream+and continue it on two different streams in parallel.+I have no function that makes use of this feature,+and thus an @ST@ monad might be a way out.++With this function we can convert an LLVM causal process to a causal IO arrow.+We also need the plugs in order+to read and write LLVM values from and to Haskell data chunks.++In a second step we could convert this to a processor of lazy lists,+and thus to a processor of chunky storable vectors.+-}+processIOParameterized ::+   (Marshal.C p, Cut.Read a, x ~ LLVM.Value (LLVM.Ptr (Marshal.Struct p))) =>+   PIn.T a b -> Parameterized.T x b c -> POut.T c d ->+   IO (IO (p, IO ()) -> PIO.T a d)+processIOParameterized+      (PIn.Cons nextIn startIn createIn deleteIn)+      paramd+      (POut.Cons nextOut startOut createOut deleteOut) = do+   case paramd of+      Parameterized.Cons next start stop -> do+         (startFunc, stopFunc, fill) <-+            compilePlugged+               nextIn startIn+               next start stop+               nextOut startOut+         return $ \createContext -> PIO.Cons+            (\a s@(_,statePtr) -> do+               let maximumSize = Cut.length a+               (contextIn, paramIn)  <- createIn a+               (contextOut,paramOut) <- createOut maximumSize+               actualSize <-+                  Marshal.with paramIn $ \inptr ->+                  Marshal.with paramOut $ \outptr ->+                  fill statePtr (fromIntegral maximumSize) inptr outptr+               -- print actualSize+               when (fromIntegral actualSize > maximumSize) $+                  error $ "CausalParametrized.Process: " +++                          "output size " ++ show actualSize +++                          " > input size " ++ show maximumSize+               deleteIn contextIn+               b <- deleteOut (fromIntegral actualSize) contextOut+               return (b, s))+            (do+               (p, deleteContext) <- createContext+               ptr <- Marshal.with p startFunc+               return (deleteContext, ptr))+            (\(deleteContext, ptr) -> stopFunc ptr >> deleteContext)++processIOCore ::+   (Marshal.C p, Cut.Read a) =>+   PIn.T a b -> (Exp p -> T b c) -> POut.T c d ->+   IO (IO (p, IO ()) -> PIO.T a d)+processIOCore pin proc pout = do+   paramd <- Parameterized.fromProcessPtr "Causal.process" proc+   processIOParameterized pin paramd pout++processIO ::+   (Marshal.C p, Cut.Read a, PIn.Default a, POut.Default d) =>+   (Exp p -> T (PIn.Element a) (POut.Element d)) ->+   IO (p -> PIO.T a d)+processIO proc =+   fmap (\f p -> f (return (p, return ()))) $+   processIOCore PIn.deflt proc POut.deflt+++class Run f where+   type DSL f a b+   type In f+   type Out f+   build ::+      (Marshal.C p) =>+      PIn.T (In f) a -> (Exp p -> DSL f a b) -> POut.T b (Out f) ->+      IO (IO (p, IO ()) -> f)++instance (Cut.Read a) => Run (PIO.T a b) where+   type DSL (PIO.T a b) al bl = T al bl+   type In (PIO.T a b) = a+   type Out (PIO.T a b) = b+   build = processIOCore++instance (RunArg a, Run f) => Run (a -> f) where+   type DSL (a -> f) al bl = DSLArg a -> DSL f al bl+   type In (a -> f) = In f+   type Out (a -> f) = Out f+   build pin sig pout =+      case buildArg of+         BuildArg pass createA -> do+            f <- build pin (Expr.uncurry $ \p -> sig p . pass) pout+            return $ \createP av ->+               f (do (p,finalP) <- createP+                     (pa,finalA) <- createA av+                     return ((p,pa), finalA >> finalP))+++runPlugged :: (Run f) => PIn.T (In f) a -> DSL f a b -> POut.T b (Out f) -> IO f+runPlugged pin sig pout = do+   act <- build pin (const sig) pout+   return $ act (return ((), return ()))++run ::+   (Run f) =>+   (In f ~ a, PIn.Default a, PIn.Element a ~ al) =>+   (Out f ~ b, POut.Default b, POut.Element b ~ bl) =>+   DSL f al bl -> IO f+run sig = runPlugged PIn.deflt sig POut.deflt
+ src/Synthesizer/LLVM/Causal/RingBufferForward.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Causal.RingBufferForward (+   T, track, trackSkip, trackSkipHold,+   index, mapIndex,+   ) where++import qualified Synthesizer.LLVM.Causal.Private as CausalPriv+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Private as Sig+import Synthesizer.LLVM.RingBuffer (MemoryPtr)++import Synthesizer.LLVM.Causal.Process (($*#))+import Synthesizer.Causal.Class (($<), ($*))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value)++import qualified Control.Arrow as Arrow+import Control.Arrow ((<<<), (<<^))+import Data.Tuple.HT (mapSnd, mapPair)++import Data.Word (Word)++import Prelude hiding (length)++++{- |+This type is very similar to 'Synthesizer.LLVM.RingBuffer.T'+but differs in several details:++* It stores values in time order,+  whereas 'Synthesizer.LLVM.RingBuffer.T' stores in opposite order.++* Since it stores future values it is not causal+  and can only track signal generators.++* There is no need for an initial value.++* It stores one value less than 'Synthesizer.LLVM.RingBuffer.T'+  since it is meant to provide infixes of the signal+  rather than providing the basis for a delay line.++Those differences in detail would not justify a new type,+you could achieve the same by a combination of+'Synthesizer.LLVM.RingBuffer.track'+and+'Synthesizer.LLVM.CausalParameterized.Process.skip'.+The fundamental problem of this combination is+that it requires to keep the ring buffer alive+longer than the providing signal exists.+This is not possible with the current design.+That's why we provide the combination of @track@ and @skip@+in a way that does not suffer from that problem.+This functionality is critical for+'Synthesizer.LLVM.CausalParameterized.Helix.dynamic'.+-}+data T a =+   Cons {+      buffer :: Value (MemoryPtr a),+      length :: Value Word,+      current :: Value Word+   }++{- |+This function does not check for range violations.+If the ring buffer was generated by @track time@,+then the minimum index is zero and the maximum index is @time-1@.+Index zero refers to the current sample+and index @time-1@ refers to the one that is farthermost in the future.+-}+index :: (Memory.C a) => MultiValue.T Word -> T a -> CodeGenFunction r a+index (MultiValue.Cons i) rb = do+   k <- flip A.irem (length rb) =<< A.add (current rb) i+   Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())++mapIndex :: (Memory.C a) => Exp Word -> Causal.T (T a) a+mapIndex k = CausalPriv.map (\buf -> flip index buf =<< Expr.unExp k)+++{- |+@track time signal@ bundles @time@ successive values of @signal@.+The values can be accessed using 'index' with indices+ranging from 0 to @time-1@.++The @time@ parameter must be non-negative.+-}+track :: (Memory.C a) => Exp Word -> Sig.T a -> Sig.T (T a)+track time input = trackSkip time input $* 1++{- |+@trackSkip time input $* skips@+is like+@Process.skip (track time input) $* skips@+but this composition would require a @Memory@ constraint for 'T'+which we cannot provide.+-}+trackSkip ::+   (Memory.C a) =>+   Exp Word -> Sig.T a -> Causal.T (MultiValue.T Word) (T a)+trackSkip time (Sig.Cons next start stop) =+   CausalPriv.Cons+      (trackNext next)+      (trackStart start time)+      (trackStop stop)+   <<^+   (\(MultiValue.Cons skip) -> skip)++{- |+Like @trackSkip@ but repeats the last buffer content+when the end of the input signal is reached.+The returned 'Bool' flag is 'True' if a skip could be performed completely+and it is 'False' if the skip exceeds the end of the input.+That is, once a 'False' is returned all following values are tagged with 'False'.+The returned 'Word' value is the number of actually skipped values.+This lags one step behind the input of skip values.+The number of an actual number of skips+is at most the number of requested skips.+If the flag is 'False', then the number of actual skips is zero.+The converse does not apply.++If the input signal is too short, the output is undefined.+(Before the available data the buffer will be filled with arbitrary values.)+We could fill the buffer with zeros,+but this would require an Arithmetic constraint+and the generated signal would not be very meaningful.+We could also return an empty signal if the input is too short.+However this would require a permanent check.+-}+trackSkipHold ::+   (Memory.C a) =>+   Exp Word -> Sig.T a ->+   Causal.T (MultiValue.T Word) ((MultiValue.T Bool, MultiValue.T Word), T a)+trackSkipHold time xs =+   Arrow.first+      (Arrow.second clearFirst <<^ mapPair (MultiValue.Cons, MultiValue.Cons))+   <<<+   trackSkipHold_ time xs+   <<^+   (\(MultiValue.Cons skip) -> skip)++clearFirst ::+   (MultiValue.PseudoRing a, MultiValue.Real a,+    MultiValue.IntegerConstant a, MultiValue.Select a) =>+   Causal.MV a a+clearFirst =+   Causal.zipWith (\b x -> Expr.select b x 0)+      $< (Causal.delay1 Expr.false $*# True)++trackSkipHold_ ::+   (Memory.C a) =>+   Exp Word -> Sig.T a ->+   Causal.T (Value Word) ((Value Bool, Value Word), T a)+trackSkipHold_ time (Sig.Cons next start stop) =+   CausalPriv.Cons+      (trackNextHold next)+      (trackStartHold start time)+      (trackStopHold stop)+++trackNext ::+   (Memory.C al, Tuple.Phi z,+    Tuple.Phi state, Tuple.Undefined state) =>+   (forall z0. (Tuple.Phi z0) =>+    context -> local -> state -> MaybeCont.T r z0 (al, state)) ->+   (context, (Value Word, Value (MemoryPtr al))) -> local ->+   Value Word ->+   (Value Word, (state, Value Word)) ->+   MaybeCont.T r z (T al, (Value Word, (state, Value Word)))+trackNext next (context, (size0,ptr)) local n1 (n0, statePos) = do+   (state3, pos3) <-+      MaybeCont.fromMaybe $ fmap snd $+      MaybeCont.fixedLengthLoop n0 statePos $ \(state0, pos0) -> do+         (a, state1) <- next context local state0+         MaybeCont.lift $+            fmap ((,) state1) $ storeNext (size0,ptr) a pos0+   return (Cons ptr size0 pos3, (n1, (state3, pos3)))++trackStart ::+   (LLVM.IsSized am, Tuple.Phi state, Tuple.Undefined state) =>+   CodeGenFunction r (context, state) ->+   Exp Word ->+   CodeGenFunction r+      ((context, (Value Word, Value (LLVM.Ptr am))),+       (Value Word, (state, Value Word)))+trackStart start size = do+   (context, state) <- start+   ~(MultiValue.Cons size0) <- Expr.unExp size+   ptr <- LLVM.arrayMalloc size0+   return ((context, (size0,ptr)), (size0, (state, A.zero)))++trackStop ::+   (LLVM.IsType am) =>+   (context -> CodeGenFunction r ()) ->+   (context, (tl, Value (LLVM.Ptr am))) ->+   CodeGenFunction r ()+trackStop stop (context, (_size,ptr)) = do+   LLVM.free ptr+   stop context+++trackNextHold ::+   (Memory.C al, Tuple.Phi z,+    Tuple.Phi state, Tuple.Undefined state) =>+   (forall z0. (Tuple.Phi z0) =>+    context -> local -> state -> MaybeCont.T r z0 (al, state)) ->+   (context, (Value Word, Value (MemoryPtr al))) -> local ->+   Value Word ->+   (Value Word, (Maybe.T state, Value Word)) ->+   MaybeCont.T r z+      (((Value Bool, Value Word), T al),+       (Value Word, (Maybe.T state, Value Word)))+trackNextHold next (context, (size0,ptr)) local nNext (n0, (mstate0, pos0)) =+      MaybeCont.lift $ do+   (n3, (pos3, state3)) <-+      Maybe.run mstate0+         (return (n0, (pos0, mstate0)))+         (\state0 ->+            Maybe.loopWithExit (n0, (state0, pos0))+               (\(n1, (state1, pos1)) -> do+                  cont <- A.cmp LLVM.CmpGT n1 A.zero+                  fmap (mapSnd ((,) n1 . (,) pos1)) $+                     C.ifThen cont+                        (Maybe.nothing, Maybe.just state1)+                        (do aState <-+                              MaybeCont.toMaybe $ next context local state1+                            return (aState, fmap snd aState)))+               (\((a,state), (n1, (pos1, _mstate))) -> do+                  pos2 <- storeNext (size0,ptr) a pos1+                  n2 <- A.dec n1+                  return (n2, (state, pos2))))+   skipped <- A.sub n0 n3+   return (((Maybe.isJust state3, skipped), Cons ptr size0 pos3),+           (nNext, (state3, pos3)))++storeNext ::+   (Memory.C al) =>+   (Value Word, Value (MemoryPtr al)) ->+   al -> Value Word -> CodeGenFunction r (Value Word)+storeNext (size0,ptr) a pos0 = do+   Memory.store a =<< LLVM.getElementPtr ptr (pos0, ())+   pos1 <- A.inc pos0+   cont <- A.cmp LLVM.CmpLT pos1 size0+   C.select cont pos1 A.zero+++trackStartHold ::+   (LLVM.IsSized am,+    Tuple.Phi state, Tuple.Undefined state) =>+   CodeGenFunction r (context, state) ->+   Exp Word ->+   CodeGenFunction r+      ((context, (Value Word, Value (LLVM.Ptr am))),+       (Value Word, (Maybe.T state, Value Word)))+trackStartHold start size = do+   (context, state) <- start+   ~(MultiValue.Cons size0) <- Expr.unExp size+   ptr <- LLVM.arrayMalloc size0+   return ((context, (size0,ptr)), (size0, (Maybe.just state, A.zero)))++trackStopHold ::+   (LLVM.IsType am) =>+   (context -> CodeGenFunction r ()) ->+   (context, (Value Word, Value (LLVM.Ptr am))) ->+   CodeGenFunction r ()+trackStopHold stop (context, (_size,ptr)) = do+   LLVM.free ptr+   stop context
− src/Synthesizer/LLVM/CausalParameterized/Controlled.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{- |-This module provides a type class that automatically selects a filter-for a given parameter type.-We choose the dependency this way-because there may be different ways to specify the filter parameters-but there is only one implementation of the filter itself.--}-module Synthesizer.LLVM.CausalParameterized.Controlled (-   Ctrl.process,-   processCtrlRate,-   ) where--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV--import qualified LLVM.Core as LLVM-import LLVM.Core (Value, IsFloating)---processCtrlRate ::-   (Ctrl.C parameter a b,-    Memory.C parameter,-    Marshal.C r, Tuple.ValueOf r ~ Value r,-    IsFloating r, SoV.IntegerConstant r,-    LLVM.CmpRet r, LLVM.IsPrimitive r) =>-   Param.T p r ->-   (Param.T p r -> SigP.T p parameter) ->-   CausalP.T p a b-processCtrlRate reduct ctrlGen =-   CausalP.applyFst Ctrl.process-      (SigP.interpolateConstant reduct (ctrlGen reduct))
− src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs 
@@ -1,48 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{- |-This is like "Synthesizer.LLVM.CausalParameterized.Controlled"-but for vectorised signals.--}-module Synthesizer.LLVM.CausalParameterized.ControlledPacked (-   CtrlS.process,-   processCtrlRate,-   ) where--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV--import qualified LLVM.Core as LLVM-import LLVM.Core (Value, IsFloating)--import qualified Algebra.Field as Field--import NumericPrelude.Numeric-import NumericPrelude.Base-import Prelude ()---processCtrlRate ::-   (CtrlS.C parameter av bv,-    Serial.Read av, n ~ Serial.Size av,-    Serial.C    bv, n ~ Serial.Size bv,-    Memory.C parameter,-    Marshal.C r, Field.C r, IsFloating r, SoV.IntegerConstant r,-    Tuple.ValueOf r ~ Value r, LLVM.CmpRet r, LLVM.IsPrimitive r) =>-   Param.T p r ->-   (Param.T p r -> SigP.T p parameter) ->-   CausalP.T p av bv-processCtrlRate reduct ctrlGen = Serial.withSize $ \n ->-   CausalP.applyFst CtrlS.process-      (SigP.interpolateConstant-         (fmap (/ fromIntegral n) reduct)-         (ctrlGen reduct))
− src/Synthesizer/LLVM/CausalParameterized/Functional.hs 
@@ -1,531 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.CausalParameterized.Functional (-   T,-   lift, fromSignal,-   ($&), (&|&),-   compile,-   compileSignal,-   withArgs, MakeArguments, Arguments, makeArgs,-   AnyArg(..),--   Ground(Ground),-   withGroundArgs, MakeGroundArguments, GroundArguments,-   makeGroundArgs,--   Atom(..), atom,-   withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments,-   makeGuidedArgs,--   PrepareArguments(PrepareArguments), withPreparedArgs, withPreparedArgs2,-   atomArg, stereoArgs, pairArgs, tripleArgs,-   ) where--import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal-import qualified Synthesizer.LLVM.Parameterized.Signal as Signal-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A--import LLVM.Core (CodeGenFunction)-import qualified LLVM.Core as LLVM--import qualified Number.Ratio as Ratio-import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive--import qualified Control.Monad.Trans.State as State-import qualified Control.Monad.Trans.Class as Trans-import Control.Monad.Trans.State (StateT)--import qualified Data.Vault.Lazy as Vault-import Data.Vault.Lazy (Vault)-import qualified Control.Category as Cat-import Control.Arrow (Arrow, (>>^), (&&&), arr, first)-import Control.Category (Category, (.))-import Control.Applicative (Applicative, (<*>), pure, liftA2)--import Data.Tuple.HT (fst3, snd3, thd3)--import qualified System.Unsafe as Unsafe--import Prelude hiding ((.))---newtype T p inp out = Cons (Code p inp out)----- | similar to @CausalP.T p a b@-data Code p a b =-   forall context local state ioContext parameters.-      (Marshal.C parameters,-       Memory.C context,-       Memory.C state) =>-   Code-      (forall r c.-       (Tuple.Phi c) =>-       context -> local -> a -> state ->-       StateT Vault (Maybe.T r c) (b, state))-          -- compute next value-      (forall r.-       CodeGenFunction r local)-          -- allocate temporary variables before a loop-      (forall r.-       Tuple.ValueOf parameters ->-       CodeGenFunction r (context, state))-          -- initial state-      (forall r.-       context -> state ->-       CodeGenFunction r ())-          -- cleanup-      (p -> IO (ioContext, parameters))-          {- initialization from IO monad-          This will be run within Unsafe.performIO,-          so no observable In/Out actions please!-          -}-      (ioContext -> IO ())-          -- finalization from IO monad, also run within Unsafe.performIO----instance Category (Code p) where-   id = arr id-   Code nextB allocaB startB stopB createIOContextB deleteIOContextB .-      Code nextA allocaA startA stopA createIOContextA deleteIOContextA = Code-         (CausalP.composeNext-             (State.mapStateT . Maybe.onFail)-             stopA stopB nextA nextB)-         (liftA2 (,) allocaA allocaB)-         (CausalP.composeStart startA startB)-         (CausalP.composeStop stopA stopB)-         (CausalP.composeCreate createIOContextA createIOContextB)-         (CausalP.composeDelete deleteIOContextA deleteIOContextB)---instance Arrow (Code p) where-   arr f = Code-      (\ _p () a () -> return (f a, ()))-      (return ())-      (\() -> return ((),()))-      (\() () -> return ())-      (const $ return ((),()))-      (const $ return ())-   first (Code next alloca start stop create delete) = Code-      (curry $ Causal.firstNext $ uncurry next) alloca start stop-      create delete---{--We must not define Category and Arrow instances-because in osci***osci the result of osci would be shared,-although it depends on the particular input.--instance Category (T p) where-   id = tagUnique Cat.id-   Cons a . Cons b = tagUnique (a . b)--instance Arrow (T p) where-   arr f = tagUnique $ arr f-   first (Cons a) = tagUnique $ first a--}--instance Functor (T p inp) where-   fmap f (Cons x) =-      tagUnique $ x >>^ f--instance Applicative (T p inp) where-   pure a = tagUnique $ arr (const a)-   f <*> x = fmap (uncurry ($))  $  f &|& x---lift0 :: (forall r. CodeGenFunction r out) -> T p inp out-lift0 f = lift (CausalP.mapSimple (const f))--lift1 :: (forall r. a -> CodeGenFunction r out) -> T p inp a -> T p inp out-lift1 f x = CausalP.mapSimple f $& x--lift2 :: (forall r. a -> b -> CodeGenFunction r out) -> T p inp a -> T p inp b -> T p inp out-lift2 f x y = CausalP.zipWithSimple f $& x&|&y---instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T p a b) where-   fromInteger n = pure (A.fromInteger' n)-   (+) = lift2 A.add-   (-) = lift2 A.sub-   (*) = lift2 A.mul-   abs = lift1 A.abs-   signum = lift1 A.signum--instance (A.Field b, A.Real b, A.RationalConstant b) => Fractional (T p a b) where-   fromRational x = pure (A.fromRational' x)-   (/) = lift2 A.fdiv---instance (A.Additive b) => Additive.C (T p a b) where-   zero = pure A.zero-   (+) = lift2 A.add-   (-) = lift2 A.sub-   negate = lift1 A.neg--instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T p a b) where-   one = pure A.one-   fromInteger n = pure (A.fromInteger' n)-   (*) = lift2 A.mul--instance (A.Field b, A.RationalConstant b) => Field.C (T p a b) where-   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)-   (/) = lift2 A.fdiv--instance (A.Transcendental b, A.RationalConstant b) => Algebraic.C (T p a b) where-   sqrt = lift1 A.sqrt-   root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n)-   x^/r = lift2 A.pow x (Field.fromRational' r)--instance (A.Transcendental b, A.RationalConstant b) => Trans.C (T p a b) where-   pi = lift0 A.pi-   sin = lift1 A.sin-   cos = lift1 A.cos-   (**) = lift2 A.pow-   exp = lift1 A.exp-   log = lift1 A.log--   asin _ = error "LLVM missing intrinsic: asin"-   acos _ = error "LLVM missing intrinsic: acos"-   atan _ = error "LLVM missing intrinsic: atan"---infixr 0 $&--($&) :: CausalP.T p b c -> T p a b -> T p a c-f $& (Cons b) =-   tagUnique $  liftCode f . b---infixr 3 &|&--(&|&) :: T p a b -> T p a c -> T p a (b,c)-Cons b &|& Cons c =-   tagUnique $  b &&& c---liftCode :: CausalP.T p inp out -> Code p inp out-liftCode (CausalP.Cons next alloca start stop create delete) =-   Code-      (\p l a state -> Trans.lift (next p l a state))-      alloca start stop create delete--lift :: CausalP.T p inp out -> T p inp out-lift = tagUnique . liftCode--fromSignal :: Signal.T p out -> T p inp out-fromSignal = lift . CausalP.fromSignal--tag :: Vault.Key out -> Code p inp out -> T p inp out-tag key (Code next alloca start stop create delete) =-   Cons $-   Code-      (\p l a s0 -> do-         mb <- State.gets (Vault.lookup key)-         case mb of-            Just b -> return (b,s0)-            Nothing -> do-               bs@(b,_) <- next p l a s0-               State.modify (Vault.insert key b)-               return bs)-      alloca start stop create delete---- dummy for debugging-_tag :: Vault.Key out -> Code p inp out -> T p inp out-_tag _ = Cons--tagUnique :: Code p inp out -> T p inp out-tagUnique code =-   Unsafe.performIO $-   fmap (flip tag code) Vault.newKey--initialize :: Code p inp out -> CausalP.T p inp out-initialize (Code next alloca start stop create delete) =-   CausalP.Cons-      (\p l a state -> State.evalStateT (next p l a state) Vault.empty)-      alloca start stop create delete--compile :: T p inp out -> CausalP.T p inp out-compile (Cons code) = initialize code--compileSignal :: T p () out -> Signal.T p out-compileSignal f = CausalP.toSignal $ compile f---{- |-Using 'withArgs' you can simplify--> let x = F.lift (arr fst)->     y = F.lift (arr (fst.snd))->     z = F.lift (arr (snd.snd))-> in  F.compile (f x y z)--to--> withArgs $ \(x,(y,z)) -> f x y z--}-withArgs ::-   (MakeArguments inp) =>-   (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out-withArgs f = withId $ f . makeArgs--withId :: (T p inp inp -> T p inp out) -> CausalP.T p inp out-withId f = compile $ f $ lift Cat.id---type family Arguments (f :: * -> *) (arg :: *)--class MakeArguments arg where-   makeArgs :: Functor f => f arg -> Arguments f arg---{--I have thought about an Arg type, that marks where to stop descending.-This way we can throw away all of these FlexibleContext instances-and the user can freely choose the granularity of arguments.-However this does not work so easily,-because we would need a functional depedency from, say,-@(Arg a, Arg b)@ to @(a,b)@.-This is the opposite direction to the dependency we use currently.-The 'AnyArg' type provides a solution in this spirit.--}-type instance Arguments f (LLVM.Value a) = f (LLVM.Value a)-instance MakeArguments (LLVM.Value a) where-   makeArgs = id--{- |-Consistent with pair instance.-You may use 'AnyArg' or 'withGuidedArgs'-to stop descending into the stereo channels.--}-type instance Arguments f (Stereo.T a) = Stereo.T (Arguments f a)-instance (MakeArguments a) => MakeArguments (Stereo.T a) where-   makeArgs = fmap makeArgs . Stereo.sequence--type instance Arguments f (Serial.T v) = f (Serial.T v)-instance MakeArguments (Serial.T v) where-   makeArgs = id--type instance Arguments f () = f ()-instance MakeArguments () where-   makeArgs = id--type instance Arguments f (a,b) = (Arguments f a, Arguments f b)-instance (MakeArguments a, MakeArguments b) =>-      MakeArguments (a,b) where-   makeArgs f = (makeArgs $ fmap fst f, makeArgs $ fmap snd f)--type instance Arguments f (a,b,c) = (Arguments f a, Arguments f b, Arguments f c)-instance (MakeArguments a, MakeArguments b, MakeArguments c) =>-      MakeArguments (a,b,c) where-   makeArgs f = (makeArgs $ fmap fst3 f, makeArgs $ fmap snd3 f, makeArgs $ fmap thd3 f)---{- |-You can use this to explicitly stop breaking of composed data types.-It might be more comfortable to do this using 'withGuidedArgs'.--}-newtype AnyArg a = AnyArg {getAnyArg :: a}--type instance Arguments f (AnyArg a) = f a-instance MakeArguments (AnyArg a) where-   makeArgs = fmap getAnyArg----{- |-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---newtype 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'-but it allows to specify the decomposition depth using a pattern.--}-withGuidedArgs ::-   (MakeGuidedArguments pat, PatternArguments pat ~ inp) =>-   pat ->-   (GuidedArguments (T p inp) pat -> T p inp out) -> CausalP.T p inp out-withGuidedArgs p f = withId $ f . makeGuidedArgs p---data Atom a = Atom--atom :: Atom a-atom = Atom---type family GuidedArguments (f :: * -> *) pat-type family PatternArguments pat--class MakeGuidedArguments pat where-   makeGuidedArgs ::-      Functor f =>-      pat -> f (PatternArguments pat) -> GuidedArguments f pat---type instance GuidedArguments f (Atom a) = f a-type instance PatternArguments (Atom a) = a-instance MakeGuidedArguments (Atom a) where-   makeGuidedArgs Atom = id--type instance GuidedArguments f (Stereo.T a) = Stereo.T (GuidedArguments f a)-type instance PatternArguments (Stereo.T a) = Stereo.T (PatternArguments a)-instance MakeGuidedArguments a => MakeGuidedArguments (Stereo.T a) where-   makeGuidedArgs pat f =-      Stereo.cons-         (makeGuidedArgs (Stereo.left  pat) $ fmap Stereo.left f)-         (makeGuidedArgs (Stereo.right pat) $ fmap Stereo.right f)--type instance GuidedArguments f () = f ()-type instance PatternArguments () = ()-instance MakeGuidedArguments () where-   makeGuidedArgs () = id--type instance-   GuidedArguments f (a,b) =-      (GuidedArguments f a, GuidedArguments f b)-type instance-   PatternArguments (a,b) =-      (PatternArguments a, PatternArguments b)-instance (MakeGuidedArguments a, MakeGuidedArguments b) =>-      MakeGuidedArguments (a,b) where-   makeGuidedArgs (pa,pb) f =-      (makeGuidedArgs pa $ fmap fst f,-       makeGuidedArgs pb $ fmap snd f)--type instance-   GuidedArguments f (a,b,c) =-      (GuidedArguments f a, GuidedArguments f b, GuidedArguments f c)-type instance-   PatternArguments (a,b,c) =-      (PatternArguments a, PatternArguments b, PatternArguments c)-instance-   (MakeGuidedArguments a, MakeGuidedArguments b, MakeGuidedArguments c) =>-      MakeGuidedArguments (a,b,c) where-   makeGuidedArgs (pa,pb,pc) f =-      (makeGuidedArgs pa $ fmap fst3 f,-       makeGuidedArgs pb $ fmap snd3 f,-       makeGuidedArgs pc $ fmap thd3 f)----{- |-Alternative to withGuidedArgs.-This way of pattern construction is even Haskell 98.--}-withPreparedArgs ::-   PrepareArguments (T p inp) inp a ->-   (a -> T p inp out) -> CausalP.T p inp out-withPreparedArgs (PrepareArguments prepare) f = withId $ f . prepare--withPreparedArgs2 ::-   PrepareArguments (T p (inp0, inp1)) inp0 a ->-   PrepareArguments (T p (inp0, inp1)) inp1 b ->-   (a -> b -> T p (inp0, inp1) out) ->-   CausalP.T p (inp0, inp1) out-withPreparedArgs2 prepareA prepareB f =-   withPreparedArgs (pairArgs prepareA prepareB) (uncurry f)--newtype PrepareArguments f merged separated =-   PrepareArguments (f merged -> separated)--atomArg :: PrepareArguments f a (f a)-atomArg = PrepareArguments id--stereoArgs ::-   (Functor f) =>-   PrepareArguments f a b ->-   PrepareArguments f (Stereo.T a) (Stereo.T b)-stereoArgs (PrepareArguments p) =-   PrepareArguments $ fmap p . Stereo.sequence--pairArgs ::-   (Functor f) =>-   PrepareArguments f a0 b0 ->-   PrepareArguments f a1 b1 ->-   PrepareArguments f (a0,a1) (b0,b1)-pairArgs (PrepareArguments p0) (PrepareArguments p1) =-   PrepareArguments $ \f -> (p0 $ fmap fst f, p1 $ fmap snd f)--tripleArgs ::-   (Functor f) =>-   PrepareArguments f a0 b0 ->-   PrepareArguments f a1 b1 ->-   PrepareArguments f a2 b2 ->-   PrepareArguments f (a0,a1,a2) (b0,b1,b2)-tripleArgs (PrepareArguments p0) (PrepareArguments p1) (PrepareArguments p2) =-   PrepareArguments $ \f ->-      (p0 $ fmap fst3 f, p1 $ fmap snd3 f, p2 $ fmap thd3 f)
− src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs 
@@ -1,339 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}-module Synthesizer.LLVM.CausalParameterized.FunctionalPlug (-   T,-   ($&), (&|&),-   run, runPlugOut,-   fromSignal, plug, askParameter, Input,-   withArgs, withArgsPlugOut,-   MakeArguments, Arguments, makeArgs,-   ) where--import qualified Synthesizer.LLVM.Plug.Input as PIn-import qualified Synthesizer.LLVM.Plug.Output as POut--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as Sig--import qualified Synthesizer.CausalIO.Process as PIO-import qualified Synthesizer.Generic.Cut as CutG-import qualified Synthesizer.Zip as Zip--import qualified Data.EventList.Relative.BodyTime as EventListBT-import qualified Data.StorableVector as SV--import qualified LLVM.Extra.Arithmetic as A-import LLVM.Core (CodeGenFunction)--import qualified Number.Ratio as Ratio-import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive--import qualified Control.Monad.Trans.Reader as MR-import qualified Control.Monad.Trans.State as MS--import qualified Data.Set as Set-import qualified Data.Vault.Lazy as Vault-import Data.Vault.Lazy (Vault)-import Data.Unique (Unique, newUnique)-import Data.Maybe (fromMaybe)--import Control.Arrow ((^<<), (<<^), arr, first, second)-import Control.Category (id, (.))-import Control.Applicative (Applicative, (<*>), pure, liftA2, liftA3)--import qualified System.Unsafe as Unsafe--import Prelude hiding (id, (.))---{- |-This data type detects sharing.--}-{--There are two levels of the use of keys.-At the top level, in T's State monad,-we store an object id in order to check,-whether we have already seen a certain object.-If we encounter a known object-then we use the Simple constructor-and fetch the stored CausalP output-within the causal process enclosed in Simple.-This and the causal process in the Plugged constructor-are the second level.-These arrows handle a Vault like a state monad-and insert all values they produce into the Vault.--}-newtype T pp pl inp out =-   Cons (MS.State (Set.Set Unique) (Core pp pl inp out))--{--We need to hide the x and y types-since these types grow when combining Cores,-and then we could not define numeric instances.--}-data Core pp pl inp out =-   forall x y. CutG.Read x =>-   Plugged-      (pp -> inp -> x)-      (PIn.T x y)-      (CausalP.T pl (y, Vault) (out, Vault))-   |-   {--   The Simple constructor is needed for reusing shared CausalP processes-   and for input without external representation. (a Plug.Input)-   -}-   Simple (CausalP.T pl Vault (out, Vault))---applyCore ::-   CausalP.T pl (a, Vault) (b, Vault) ->-   Core pp pl inp a ->-   Core pp pl inp b-applyCore f core =-   case core of-      Plugged prep plg process -> Plugged prep plg (f . process)-      Simple process -> Simple (f . process)--combineCore ::-   Core pp pl inp a ->-   Core pp pl inp b ->-   Core pp pl inp (a,b)-combineCore (Plugged prepA plugA processA) (Plugged prepB plugB processB) =-   Plugged-      (\p -> Zip.arrowFanout (prepA p) (prepB p))-      (PIn.split plugA plugB)-      ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB-       . arr (\((a,v),b) -> (a,(b,v))) .-       first processA <<^ (\((a,b),v) -> ((a,v),b)))-combineCore (Simple processA) (Plugged prepB plugB processB) =-   Plugged prepB plugB-      ((\(b,(a,v)) -> ((a,b), v)) ^<< second processA . processB)-combineCore (Plugged prepA plugA processA) (Simple processB) =-   Plugged prepA plugA-      ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA)-combineCore (Simple processA) (Simple processB) =-   Simple ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA)---reuseCore :: Vault.Key out -> Core pp pl inp out-reuseCore key =-   Simple $ arr $ \vault ->-      (fromMaybe (error "key must have been lost") $ Vault.lookup key vault,-       vault)---tag ::-   Unique -> Vault.Key out ->-   MS.State (Set.Set Unique) (Core pp pl inp out) ->-   T pp pl inp out-tag unique key stateCore = Cons $ do-   alreadySeen <- MS.gets (Set.member unique)-   if alreadySeen-      then return $ reuseCore key-      else do-         MS.modify (Set.insert unique)-         fmap (applyCore (arr $ \(a,v) -> (a, Vault.insert key a v))) stateCore--tagUnique ::-   MS.State (Set.Set Unique) (Core pp pl inp out) ->-   T pp pl inp out-tagUnique core =-   Unsafe.performIO $-   liftA3 tag newUnique Vault.newKey (pure core)---infixr 0 $&--($&) ::-   CausalP.T pl a b ->-   T pp pl inp a ->-   T pp pl inp b-f  $&  Cons core =-   tagUnique $ fmap (applyCore $ first f) core---infixr 3 &|&--(&|&) ::-   T pp pl inp a ->-   T pp pl inp b ->-   T pp pl inp (a,b)-Cons coreA  &|&  Cons coreB =-   tagUnique $ liftA2 combineCore coreA coreB---instance Functor (Core pp pl inp) where-   fmap f (Simple process) = Simple (fmap (first f) process)-   fmap f (Plugged prep plg process) = Plugged prep plg (fmap (first f) process)--instance Applicative (Core pp pl inp) where-   pure a = lift0Core $ pure a-   f <*> x = fmap (uncurry ($))  $  combineCore f x--lift0Core :: (forall r. CodeGenFunction r out) -> Core pp pl inp out-lift0Core f = Simple (CausalP.mapSimple (\v -> fmap (flip (,) v) f))---instance Functor (T pp pl inp) where-   fmap f (Cons x) = tagUnique $ fmap (fmap f) x--instance Applicative (T pp pl inp) where-   pure a = tagUnique $ pure $ pure a-   f <*> x = fmap (uncurry ($))  $  f &|& x---lift0 :: (forall r. CodeGenFunction r out) -> T pp pl inp out-lift0 f = tagUnique $ pure $ lift0Core f--lift1 :: (forall r. a -> CodeGenFunction r out) -> T pp pl inp a -> T pp pl inp out-lift1 f x = CausalP.mapSimple f $& x--lift2 :: (forall r. a -> b -> CodeGenFunction r out) -> T pp pl inp a -> T pp pl inp b -> T pp pl inp out-lift2 f x y = CausalP.zipWithSimple f $& x&|&y---instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T pp pl a b) where-   fromInteger n = pure (A.fromInteger' n)-   (+) = lift2 A.add-   (-) = lift2 A.sub-   (*) = lift2 A.mul-   abs = lift1 A.abs-   signum = lift1 A.signum--instance (A.Field b, A.Real b, A.RationalConstant b) => Fractional (T pp pl a b) where-   fromRational x = pure (A.fromRational' x)-   (/) = lift2 A.fdiv---instance (A.Additive b) => Additive.C (T pp pl a b) where-   zero = pure A.zero-   (+) = lift2 A.add-   (-) = lift2 A.sub-   negate = lift1 A.neg--instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T pp pl a b) where-   one = pure A.one-   fromInteger n = pure (A.fromInteger' n)-   (*) = lift2 A.mul--instance (A.Field b, A.RationalConstant b) => Field.C (T pp pl a b) where-   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)-   (/) = lift2 A.fdiv--instance (A.Transcendental b, A.RationalConstant b) => Algebraic.C (T pp pl a b) where-   sqrt = lift1 A.sqrt-   root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n)-   x^/r = lift2 A.pow x (Field.fromRational' r)--instance (A.Transcendental b, A.RationalConstant b) => Trans.C (T pp pl a b) where-   pi = lift0 A.pi-   sin = lift1 A.sin-   cos = lift1 A.cos-   (**) = lift2 A.pow-   exp = lift1 A.exp-   log = lift1 A.log--   asin _ = error "LLVM missing intrinsic: asin"-   acos _ = error "LLVM missing intrinsic: acos"-   atan _ = error "LLVM missing intrinsic: atan"----fromSignal ::-   Sig.T pl a ->-   T pp pl inp a-fromSignal sig =-   tagUnique $ pure $ Simple (CausalP.feedFst sig)----type Input pp a = MR.Reader (pp, a)--plug ::-   (CutG.Read b, PIn.Default b) =>-   Input pp a b ->-   T pp pl a (PIn.Element b)-plug accessor =-   tagUnique $ pure $-   Plugged-      (curry $ MR.runReader accessor)-      PIn.deflt-      id--askParameter :: Input pp a pp-askParameter = MR.asks fst---runPlugOut ::-   T pp pl a x -> POut.T x b ->-   IO (pp -> pl -> PIO.T a b)-runPlugOut (Cons core) pout =-   case MS.evalState core Set.empty of-      Plugged prep pin process ->-         fmap (\f pp pl -> f pl <<^ prep pp) $-         CausalP.processIOCore-            pin-            (fst ^<< process <<^ flip (,) Vault.empty)-            pout-      Simple _ ->-         error "FunctionalPlug.runPlugOut: no substantial input available"-         -- Simple process ->-         --    CausalP.processIOCore pin process pout--run ::-   (POut.Default b) =>-   T pp pl a (POut.Element b) ->-   IO (pp -> pl -> PIO.T a b)-run f = runPlugOut f POut.deflt---{- |-Cf. 'F.withArgs'.--}-withArgs ::-   (MakeArguments a, POut.Default b) =>-   (Arguments (Input pp a) a -> T pp pl a (POut.Element b)) ->-   IO (pp -> pl -> PIO.T a b)-withArgs f = withArgsPlugOut f POut.deflt--withArgsPlugOut ::-   (MakeArguments a) =>-   (Arguments (Input pp a) a -> T pp pl a x) ->-   POut.T x b ->-   IO (pp -> pl -> PIO.T a b)-withArgsPlugOut = withArgsPlugOutStart (MR.asks snd)--withArgsPlugOutStart ::-   (MakeArguments a) =>-   Input pp a a ->-   (Arguments (Input pp a) a -> T pp pl a x) ->-   POut.T x b ->-   IO (pp -> pl -> PIO.T a b)-withArgsPlugOutStart fid f = runPlugOut (f (makeArgs fid))----type family Arguments (f :: * -> *) (arg :: *)--class MakeArguments arg where-   makeArgs :: Functor f => f arg -> Arguments f arg---type instance Arguments f (EventListBT.T i a) = f (EventListBT.T i a)-instance MakeArguments (EventListBT.T i a) where-   makeArgs = id--type instance Arguments f (SV.Vector a) = f (SV.Vector a)-instance MakeArguments (SV.Vector a) where-   makeArgs = id--type instance Arguments f (Zip.T a b) = (Arguments f a, Arguments f b)-instance (MakeArguments a, MakeArguments b) =>-      MakeArguments (Zip.T a b) where-   makeArgs f = (makeArgs $ fmap Zip.first f, makeArgs $ fmap Zip.second f)
− src/Synthesizer/LLVM/CausalParameterized/Helix.hs 
@@ -1,636 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Rank2Types #-}-{- |-<http://arxiv.org/abs/0911.5171>--}-module Synthesizer.LLVM.CausalParameterized.Helix (-   -- * time and phase control based on the helix model-   static,-   staticPacked,-   dynamic,-   dynamicLimited,--   -- * useful control curves-   zigZag,-   zigZagPacked,-   zigZagLong,-   zigZagLongPacked,-   ) where--import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate-                                                              as CausalPrivP-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP-import qualified Synthesizer.LLVM.CausalParameterized.RingBufferForward as RingBuffer-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Simple.Value as Value-import qualified Synthesizer.LLVM.Interpolation as Ip-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&))-import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<))-import Synthesizer.LLVM.Simple.Value ((%>), (%>=), (?), (??))--import qualified Synthesizer.LLVM.Storable.Vector as SVU-import qualified Data.StorableVector as SV--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.MaybeContinuation as MaybeCont--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, IsSized, IsFloating)--import qualified Type.Data.Num.Decimal as TypeNum--import Data.Word (Word)--import Foreign.ForeignPtr (touchForeignPtr)--import Control.Arrow (first, (<<<), (^<<), (<<^))-import Control.Category (id)-import Control.Applicative (liftA2)-import Control.Functor.HT (unzip)-import Data.Traversable (mapM)-import Data.Tuple.HT (mapFst)--import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring--import NumericPrelude.Numeric hiding (splitFraction)-import NumericPrelude.Base hiding (unzip, zip, mapM, id)--import Prelude ()---{- |-Inputs are @(shape, phase)@.--The shape parameter is limited at the beginning and at the end-such that only available data is used for interpolation.-Actually, we allow almost one step less than possible,-since the right boundary of the interval of admissible @shape@ values is open.--}-static ::-   (Storable.C vh, Tuple.ValueOf vh ~ v,-    Ip.C nodesStep, Ip.C nodesLeap,-    SoV.RationalConstant a, SoV.Fraction a,-    Marshal.C a, Tuple.ValueOf a ~ Value a, LLVM.IsPrimitive a) =>-   (forall r. Ip.T r nodesLeap (Value a) v) ->-   (forall r. Ip.T r nodesStep (Value a) v) ->-   Param.T p Int ->-   Param.T p a ->-   Param.T p (SV.Vector vh) ->-   CausalP.T p (Value a, Value a) v-static ipLeap ipStep periodInt period vec =-   let period32 = Param.wordInt periodInt-       cellMargin = combineMarginParams ipLeap ipStep periodInt-   in  interpolateCell ipLeap ipStep-       <<<-       first (peekCell cellMargin period32 vec)-       <<<-       flattenShapePhaseProc period32 period-       <<<-       first-          (limitShape cellMargin period32-              (Param.wordInt $ fmap SV.length vec))---staticPacked ::-   (Storable.C vh, Tuple.ValueOf vh ~ ve, Serial.Element v ~ ve,-    Ip.C nodesStep, Ip.C nodesLeap,-    Serial.Size (nodesLeap (nodesStep v)) ~ n,-    Serial.C (nodesLeap (nodesStep v)),-    Serial.Element (nodesLeap (nodesStep v)) ~-       nodesLeap (nodesStep (Serial.Element v)),-    TypeNum.Positive n,-    SoV.RationalConstant a, SoV.Fraction a, Vector.Real a,-    Marshal.C a, Tuple.ValueOf a ~ Value a, LLVM.IsPrimitive a) =>-   (forall r. Ip.T r nodesLeap (Serial.Value n a) v) ->-   (forall r. Ip.T r nodesStep (Serial.Value n a) v) ->-   Param.T p Int ->-   Param.T p a ->-   Param.T p (SV.Vector vh) ->-   CausalP.T p (Serial.Value n a, Serial.Value n a) v-staticPacked ipLeap ipStep periodInt period vec =-   let period32 = Param.wordInt periodInt-       cellMargin = combineMarginParams ipLeap ipStep periodInt-   in  interpolateCell ipLeap ipStep-       <<<-       first (CausalPS.pack-          (peekCell (fmap elementMargin cellMargin) period32 vec))-       <<<-       flattenShapePhaseProcPacked period32 period-       <<<-       first-          (limitShapePacked cellMargin period32-              (Param.wordInt $ fmap SV.length vec))---{- |-In contrast to 'dynamic' this one ends-when the end of the manipulated signal is reached.--}-dynamicLimited ::-   (Ip.C nodesStep, Ip.C nodesLeap,-    A.Additive v, Memory.C v,-    SoV.RationalConstant a, SoV.Fraction a,-    Marshal.C a, Tuple.ValueOf a ~ Value a, LLVM.IsPrimitive a, LLVM.CmpRet a) =>-   (forall r. Ip.T r nodesLeap (Value a) v) ->-   (forall r. Ip.T r nodesStep (Value a) v) ->-   Param.T p Int ->-   Param.T p a ->-   SigP.T p v ->-   CausalP.T p (Value a, Value a) v-dynamicLimited ipLeap ipStep periodInt period sig =-   dynamicGen-      (\cellMargin (skips, fracs) ->-         let windows =-                RingBuffer.trackSkip (fmap Ip.marginNumber cellMargin) sig $& skips-         in  (windows,-              CausalP.delay1Zero $& skips,-              CausalP.delay1Zero $& fracs))-      ipLeap ipStep periodInt period--{- |-If the time control exceeds the end of the input signal,-then the last waveform is locked.-This is analogous to 'static'.--}-dynamic ::-   (Ip.C nodesStep, Ip.C nodesLeap,-    A.Additive v, Memory.C v,-    SoV.RationalConstant a, SoV.Fraction a,-    Marshal.C a, Tuple.ValueOf a ~ Value a, LLVM.IsPrimitive a, LLVM.CmpRet a) =>-   (forall r. Ip.T r nodesLeap (Value a) v) ->-   (forall r. Ip.T r nodesStep (Value a) v) ->-   Param.T p Int ->-   Param.T p a ->-   SigP.T p v ->-   CausalP.T p (Value a, Value a) v-dynamic ipLeap ipStep periodInt period sig =-   dynamicGen-      (\cellMargin (skips, fracs) ->-         let {--             For conformance with 'static'-             we stop one step before the definite end.-             We achieve this by using a buffer-             that is one step longer than necessary.-             -}-             ((running, actualSkips), windows) =-                mapFst unzip $ unzip $-                RingBuffer.trackSkipHold-                   (fmap (succ . Ip.marginNumber) cellMargin) sig $& skips-             holdFracs =-                CausalPV.zipWithSimple (\r fr -> r ? (fr, 1))-                $&-                running &|& (CausalP.delay1Zero $& fracs)-         in  (windows, actualSkips, holdFracs))-      ipLeap ipStep periodInt period--dynamicGen ::-   (Ip.C nodesStep, Ip.C nodesLeap,-    A.Additive v, Memory.C v,-    SoV.RationalConstant a, SoV.Fraction a,-    Marshal.C a, Tuple.ValueOf a ~ Value a, LLVM.IsPrimitive a, LLVM.CmpRet a) =>-   (Param.T p (Ip.Margin (nodesLeap (nodesStep v))) ->-    (Func.T p (Value a, Value a) (Value Word),-     Func.T p (Value a, Value a) (Value a)) ->-    (Func.T p (Value a, Value a) (RingBuffer.T v),-     Func.T p (Value a, Value a) (Value Word),-     Func.T p (Value a, Value a) (Value a))) ->-   (forall r. Ip.T r nodesLeap (Value a) v) ->-   (forall r. Ip.T r nodesStep (Value a) v) ->-   Param.T p Int ->-   Param.T p a ->-   CausalP.T p (Value a, Value a) v-dynamicGen limitMaxShape ipLeap ipStep periodInt period =-   let period32 = Param.wordInt periodInt-       cellMargin = combineMarginParams ipLeap ipStep periodInt-       minShape =-          Param.wordInt $ fmap fst $-          liftA2 shapeMargin cellMargin periodInt--   in  Func.withArgs $ \(shape, phase) ->-          let (windows, skips, fracs) =-                 limitMaxShape cellMargin $-                 unzip (integrateFrac $& (limitMinShape minShape $& shape))-              (offsets, shapePhases) =-                 unzip-                    (flattenShapePhaseProc period32 period $&-                       (constantFromWord32 minShape + fracs)-                       &|&-                       (CausalP.osciCoreSync $&-                          phase-                          &|&-                          negate-                             (CausalPV.map (flip (/)) period $&-                                (CausalP.mapSimple LLVM.inttofp $& skips))))-          in  interpolateCell ipLeap ipStep $&-                 (CausalP.map (uncurry . cellFromBuffer) period32-                  $&-                  windows-                  &|&-                  offsets)-                 &|&-                 shapePhases--constantFromWord32 ::-   (IsFloating a, LLVM.IsPrimitive a) =>-   Param.T p Word -> Func.T p inp (Value a)-constantFromWord32 x =-   Func.fromSignal-      (CausalP.mapSimple LLVM.inttofp $* SigP.constant x)--limitMinShape ::-   (IsFloating a, IsSized a, LLVM.IsPrimitive a, LLVM.CmpRet a) =>-   Param.T p Word ->-   CausalP.T p (Value a) (Value a)-limitMinShape xLim =-   CausalPV.mapAccum-      (\_ x lim -> (x%>=lim) ? ((x-lim,zero), (zero,lim-x)))-      (Value.lift1 LLVM.inttofp) (return ()) xLim--integrateFrac ::-   (IsFloating a, IsSized a, LLVM.IsPrimitive a) =>-   CausalP.T p (Value a) (Value Word, Value a)-integrateFrac =-   CausalP.mapAccumSimple-      (\a (_n,frac) -> do-         s <- splitFraction =<< A.add a frac-         return (s, s))-      (return (A.zero, A.zero))---interpolateCell ::-   (Ip.C nodesStep, Ip.C nodesLeap) =>-   (forall r. Ip.T r nodesLeap a v) ->-   (forall r. Ip.T r nodesStep a v) ->-   CausalP.T p (nodesLeap (nodesStep v), (a, a)) v-interpolateCell ipLeap ipStep =-   CausalP.mapSimple-      (\(nodes, (leap,step)) ->-         ipLeap leap =<< mapM (ipStep step) nodes)--cellFromBuffer ::-   (Memory.C a, Ip.C nodesLeap, Ip.C nodesStep) =>-   Value Word ->-   RingBuffer.T a ->-   Value Word ->-   CodeGenFunction r (nodesLeap (nodesStep a))-cellFromBuffer periodInt buffer offset =-   Ip.indexNodes-      (Ip.indexNodes (flip RingBuffer.index buffer) A.one)-      periodInt offset--elementMargin ::-   Ip.Margin (nodesLeap (nodesStep v)) ->-   Ip.Margin (nodesLeap (nodesStep (Serial.Element v)))-elementMargin (Ip.Margin x y) = Ip.Margin x y--peekCell ::-   (Storable.C a, Tuple.ValueOf a ~ value, Ip.C nodesLeap, Ip.C nodesStep) =>-   Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->-   Param.T p Word ->-   Param.T p (SV.Vector a) ->-   CausalP.T p (Value Word) (nodesLeap (nodesStep value))-peekCell margin period32 vec =-   Param.withValue (Param.wordInt $ fmap Ip.marginOffset margin) $ \getOffset valueOffset ->-   Param.withValue period32 $ \getPeriod valuePeriod -> CausalPrivP.Cons-      (\(p,off,per) () n () -> MaybeCont.lift $ do-         offset <- LLVM.bitcast =<< A.sub n (valueOffset off)-         perInt <- LLVM.bitcast $ valuePeriod per-         nodes <--            Ip.loadNodes (Ip.loadNodes Storable.load A.one) perInt-               =<< Storable.advancePtr offset p-         return (nodes, ()))-      (return ())-      (return . flip (,) ())-      (const $ const $ return ())-      (\p ->-         let (fp,ptr,_l) = SVU.unsafeToPointers $ Param.get vec p-         in  return (fp, (ptr, getOffset p, getPeriod p)))-      touchForeignPtr---flattenShapePhaseProc ::-   (IsFloating a, SoV.Fraction a, SoV.RationalConstant a,-    Marshal.C ah, Tuple.ValueOf ah ~ Value a, LLVM.IsPrimitive a) =>-   Param.T p Word ->-   Param.T p ah ->-   CausalP.T p-      (Value a, Value a)-      (Value Word, (Value a, Value a))-flattenShapePhaseProc period32 period =-   CausalP.map-      (\(perInt, per) (shape, phase) ->-         flattenShapePhase perInt per shape phase)-      (liftA2 (,) period32 period)--flattenShapePhaseProcPacked ::-   (IsFloating a, Vector.Real a, SoV.RationalConstant a,-    Marshal.C ah, Tuple.ValueOf ah ~ Value a, LLVM.IsPrimitive a,-    TypeNum.Positive n) =>-   Param.T p Word ->-   Param.T p ah ->-   CausalP.T p-      (Serial.Value n a, Serial.Value n a)-      (Serial.Value n Word,-       (Serial.Value n a, Serial.Value n a))-flattenShapePhaseProcPacked period32 period =-   CausalP.map-      (\(perInt, per) (Serial.Cons shape, Serial.Cons phase) -> do-         perIntVec <- SoV.replicate perInt-         perVec <- SoV.replicate per-         (i, (leap, step)) <--            flattenShapePhase perIntVec perVec shape phase-         return (Serial.Cons i, (Serial.Cons leap, Serial.Cons step)))-      (liftA2 (,) period32 period)--flattenShapePhase ::-   (IsFloating a, SoV.Fraction a, SoV.RationalConstant a,-    LLVM.ShapeOf a ~ LLVM.ShapeOf i, LLVM.IsInteger i) =>-   Value i ->-   Value a ->-   Value a -> Value a ->-   CodeGenFunction r (Value i, (Value a, Value a))-flattenShapePhase = Value.unlift4 $ \periodInt period shape phase ->-   let qLeap = Value.lift1 A.fraction $ shape/period - phase-       (n,qStep) =-          unzip $ Value.lift1 splitFraction $-          {--          If 'shape' is correctly limited,-          the value is always non-negative algebraically,-          but maybe not numerically.-          -}-          Value.max zero $-          shape - qLeap * Value.lift1 LLVM.inttofp periodInt-   in  (n,(qLeap,qStep))--{- |-You must make sure, that the argument is non-negative.--}-splitFraction ::-   (IsFloating a, LLVM.IsInteger i, LLVM.ShapeOf a ~ LLVM.ShapeOf i) =>-   Value a -> CodeGenFunction r (Value i, Value a)-splitFraction x = do-   n <- LLVM.fptoint x-   frac <- A.sub x =<< LLVM.inttofp n-   return (n, frac)---limitShape ::-   (IsSized t, IsFloating t, SoV.Real t,-    LLVM.ShapeOf t ~ LLVM.ShapeOf i,-    Marshal.C i, Tuple.ValueOf i ~ Value i,-    Ring.C i, LLVM.IsInteger i, SoV.IntegerConstant i,-    Ip.C nodesStep, Ip.C nodesLeap) =>-   Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->-   Param.T p i ->-   Param.T p i ->-   CausalP.T p (Value t) (Value t)-limitShape margin periodInt len =-   CausalPV.zipWithSimple (Value.limit . unzip)-   $<-   limitShapeSignal margin periodInt len--limitShapePacked ::-   (IsSized t, IsFloating t, LLVM.IsPrimitive t, Vector.Real t,-    TypeNum.Positive n,-    Ip.C nodesStep, Ip.C nodesLeap) =>-   Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->-   Param.T p Word ->-   Param.T p Word ->-   CausalP.T p (Serial.Value n t) (Serial.Value n t)-limitShapePacked margin periodInt len =-   CausalPV.zipWithSimple-      (\minmax shape ->-         let (minShape,maxShape) = unzip minmax-         in  Value.limit-                (Value.lift1 Serial.upsample minShape,-                 Value.lift1 Serial.upsample maxShape)-                shape)-   $<-   limitShapeSignal margin periodInt len--limitShapeSignal ::-   (IsSized t, IsFloating t,-    LLVM.ShapeOf t ~ LLVM.ShapeOf i,-    Marshal.C i, Tuple.ValueOf i ~ Value i,-    Ring.C i, LLVM.IsInteger i, SoV.IntegerConstant i,-    Ip.C nodesStep, Ip.C nodesLeap) =>-   Param.T p (Ip.Margin (nodesLeap (nodesStep value))) ->-   Param.T p i ->-   Param.T p i ->-   SigP.T p (Value t, Value t)-limitShapeSignal margin periodInt len =-   SigP.Cons-      (\minMax () () -> return (minMax, ()))-      (return ())-      (\(minShapeInt, maxShapeInt) -> do-         minShape <- LLVM.inttofp minShapeInt-         maxShape <- LLVM.inttofp maxShapeInt-         return ((minShape, maxShape), ()))-      (const $ const $ return ())-      (\p -> return ((),-         shapeLimits-            (Param.get margin p)-            (Param.get periodInt p)-            (Param.get len p)))-      (const $ return ())---_limitShape ::-   (Ring.C th, Marshal.C th, Tuple.ValueOf th ~ t, A.Real t,-    Ip.C nodesStep, Ip.C nodesLeap) =>-   Ip.Margin (nodesLeap (nodesStep value)) ->-   Param.T p th ->-   Param.T p th ->-   CausalP.T p t t-_limitShape margin periodInt len =-   CausalPrivP.Cons-      (\(minShape,maxShape) () shape () -> MaybeCont.lift $ do-         limited <- A.min maxShape =<< A.max minShape shape-         return (limited, ()))-      (return ())-      (\minmax -> return (minmax, ()))-      (const $ const $ return ())-      (\p ->-         return-            ((),-             shapeLimits margin-                (Param.get periodInt p)-                (Param.get len p)))-      (const $ return ())--shapeLimits ::-   (Ip.C nodesLeap, Ip.C nodesStep, Ring.C t) =>-   Ip.Margin (nodesLeap (nodesStep value)) ->-   t ->-   t ->-   (t, t)-shapeLimits margin periodInt len =-   case shapeMargin margin periodInt of-      (leftMargin, rightMargin) ->-         (leftMargin, len - rightMargin)--_shapeLimits ::-   (Ip.C nodesLeap, Ip.C nodesStep,-    IsFloating t, LLVM.ShapeOf t ~ LLVM.ScalarShape) =>-   Ip.Margin (nodesLeap (nodesStep value)) ->-   Value.T (Value Word) ->-   Value.T (Value t) ->-   (Value.T (Value t), Value.T (Value t))-_shapeLimits margin periodInt len =-   let (leftMargin, rightMargin) = shapeMargin margin periodInt-   in  (Value.lift1 LLVM.inttofp leftMargin,-        len - Value.lift1 LLVM.inttofp rightMargin)--shapeMargin ::-   (Ip.C nodesLeap, Ip.C nodesStep, Ring.C i) =>-   Ip.Margin (nodesLeap (nodesStep value)) ->-   i -> (i, i)-shapeMargin margin periodInt =-   let leftMargin = fromIntegral (Ip.marginOffset margin) + periodInt-       rightMargin = fromIntegral (Ip.marginNumber margin) - leftMargin-   in  (leftMargin, rightMargin)--combineMarginParams ::-   (Ip.C nodesStep, Ip.C nodesLeap) =>-   (forall r. Ip.T r nodesLeap a v) ->-   (forall r. Ip.T r nodesStep a v) ->-   Param.T p Int ->-   Param.T p (Ip.Margin (nodesLeap (nodesStep v)))-combineMarginParams ipLeap ipStep periodInt =-   fmap-      (combineMargins (Ip.toMargin ipLeap) (Ip.toMargin ipStep))-      periodInt--combineMargins ::-   Ip.Margin (nodesLeap value) ->-   Ip.Margin (nodesStep value) ->-   Int ->-   Ip.Margin (nodesLeap (nodesStep value))-combineMargins marginLeap marginStep periodInt =-   Ip.Margin {-      Ip.marginNumber =-         Ip.marginNumber marginStep +-         Ip.marginNumber marginLeap * periodInt,-      Ip.marginOffset =-         Ip.marginOffset marginStep +-         Ip.marginOffset marginLeap * 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 ::-   (Marshal.C a, Tuple.ValueOf a ~ Value a,-    SoV.Fraction a, IsFloating a, SoV.RationalConstant a, LLVM.CmpRet a,-    Field.C a) =>-   Param.T p a ->-   Param.T p a ->-   CausalP.T p (Value a) (Value a)-zigZagLong =-   zigZagLongGen (CausalP.fromSignal . SigP.constant) zigZag--zigZagLongPacked ::-   (Marshal.C a, Tuple.ValueOf a ~ Value a,-    Marshal.Vector n a, Tuple.VectorValueOf n a ~ Value (LLVM.Vector n a),-    SoV.Fraction a, SoV.RationalConstant a, Vector.Real a,-    LLVM.IsPrimitive a, Field.C a,-    (n TypeNum.:*: LLVM.SizeOf a) ~ asize,-    TypeNum.Positive asize,-    TypeNum.Positive n) =>-   Param.T p a ->-   Param.T p a ->-   CausalP.T p (Serial.Value n a) (Serial.Value n a)-zigZagLongPacked =-   zigZagLongGen (CausalP.fromSignal . SigPS.constant) zigZagPacked--zigZagLongGen ::-   (A.RationalConstant al, A.Field al, Field.C a) =>-   (Param.T p a -> CausalP.T p al al) ->-   (Param.T p a -> CausalP.T p al al) ->-   Param.T p a ->-   Param.T p a ->-   CausalP.T p al al-zigZagLongGen constant zz prefix loop =-   zz (negate $ prefix/loop) * constant loop + constant prefix-   <<<-   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 ::-   (Marshal.C a, Tuple.ValueOf a ~ Value a,-    SoV.Fraction a, IsFloating a, SoV.RationalConstant a, LLVM.CmpRet a) =>-   Param.T p a ->-   CausalP.T p (Value a) (Value a)-zigZag start =-   CausalPV.mapSimple (\x -> 1-abs (1-x))-   <<<-   CausalPV.mapAccum-      (\_ d t0 ->-         let t1 = t0+d-         in  (t0, wrap (curry . (??)) t1))-      id (return ()) start--zigZagPacked ::-   (Marshal.C a, Tuple.ValueOf a ~ Value a,-    SoV.Fraction a, IsFloating a, Vector.Real a, SoV.RationalConstant a,-    LLVM.CmpRet a,-    TypeNum.Positive n) =>-   Param.T p a ->-   CausalP.T p (Serial.Value n a) (Serial.Value n a)-zigZagPacked start =-   Serial.Cons-   ^<<-   CausalPV.mapSimple (\x -> 1 - abs (1-x))-   <<<-   CausalPV.mapAccum-      (\_ d t0 ->-         let (t1, cum) = unzip $ Value.lift2 Vector.cumulate t0 d-         {--         LLVM.select can be replaced by (??)-         once vector select is implemented by LLVM.-         -}-         in  (wrap (Value.lift3 LLVM.select) cum, t1))-      id (return ()) start-   <<^-   (\(Serial.Cons v) -> v)--wrap ::-   (SoV.RationalConstant a, IsFloating a, SoV.Fraction a, LLVM.CmpRet a) =>-   (Value.T (Value (LLVM.CmpResult a)) ->-    Value.T (Value a) ->-    Value.T (Value a) ->-    Value.T (Value a)) ->-   Value.T (Value a) -> Value.T (Value a)-wrap select a = select (a%>0) (2 * Value.fraction (a/2)) a
− src/Synthesizer/LLVM/CausalParameterized/Process.hs 
@@ -1,1044 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.CausalParameterized.Process (-   T, simple,-   fromSignal, toSignal,-   mapAccum, map, mapSimple, zipWith, zipWithSimple,-   apply, compose, first,-   feedFst, feedSnd,-   loop, loopZero, take, takeWhile, integrate,--   ($<), ($>), ($*),-   applyFst, applySnd,--   reparameterize,--   mapAccumSimple,--   replicateControlled,-   replicateParallel,-   replicateControlledParam,-   feedbackControlled,-   Causal.feedbackControlledZero,-   Causal.fromModifier,-   fromInitializedModifier,-   stereoFromMono,-   stereoFromMonoControlled,-   stereoFromMonoParameterized,-   Causal.stereoFromVector,-   Causal.vectorize,-   Causal.replaceChannel,-   Causal.arrayElement,-   Causal.element,-   Causal.mix,-   raise,-   Causal.envelope,-   Causal.envelopeStereo,-   amplify,-   amplifyStereo,-   mapLinear,-   mapExponential,-   quantizeLift,-   osciSimple,-   Causal.osciCore,-   Causal.osciCoreSync,-   Causal.shapeModOsci,-   delay,-   delayZero,-   delay1,-   Causal.delay1Zero,-   delayControlled,-   delayControlledInterpolated,-   differentiate,-   comb,-   combStereo,-   reverbSimple,-   reverb,-   Causal.pipeline,-   Causal.skip,-   Causal.frequencyModulation,-   frequencyModulationLinear,-   trigger,--   runStorable,-   applyStorable,-   runStorableChunky,-   runStorableChunkyCont,-   applyStorableChunky,--   processIO,-   processIOCore,-   ) where--import Synthesizer.LLVM.CausalParameterized.ProcessPrivate-import Synthesizer.LLVM.Causal.ProcessPrivate-         (feedbackControlledAux, reverbParams)-import Synthesizer.LLVM.Causal.Process (loopZero, mix)-import qualified Synthesizer.LLVM.Causal.ProcessPrivate as CausalPriv-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Plug.Input as PIn-import qualified Synthesizer.LLVM.Plug.Output as POut-import qualified Synthesizer.CausalIO.Process as PIO--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-import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr--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-import qualified Data.StorableVector.Base as SVB--import qualified LLVM.DSL.Execution as Exec-import qualified LLVM.DSL.Parameter as Param-import LLVM.DSL.Parameter (($#))--import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Maybe as Maybe-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM-import LLVM.Core-          (CodeGenFunction, ret, Value, valueOf,-           IsSized, IsConst, IsArithmetic, IsFloating)--import qualified Type.Data.Num.Decimal as TypeNum--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, (<*>))-import Control.Functor.HT (void, unzip)-import Control.Exception (bracket)--import qualified Data.List as List-import Data.Traversable (traverse)-import Data.Foldable (sequence_)-import Data.Tuple.HT (swap, mapFst, mapSnd, uncurry3, snd3)-import Data.Word (Word)-import Data.Int (Int8)--import System.Random (Random, RandomGen)--import Foreign.StablePtr-          (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr)-import Foreign.ForeignPtr (touchForeignPtr)-import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr)--import qualified System.Unsafe as Unsafe--import qualified LLVM.DSL.Debug.Marshal as DebugSt-import qualified LLVM.DSL.Debug.Counter as DebugCnt--import qualified Algebra.Transcendental as Trans--import NumericPrelude.Numeric-import NumericPrelude.Base hiding-          (and, iterate, map, unzip, zip, zipWith, take, takeWhile, sequence_)---infixl 0 $<, $>, $*--- infixr 0 $:*   -- can be used together with $--applyFst, ($<) :: T p (a,b) c -> SigP.T p a -> T p b c-applyFst = CausalClass.applyFst--applySnd, ($>) :: T p (a,b) c -> SigP.T p b -> T p a c-applySnd = CausalClass.applySnd--{--These infix operators may become methods of a type class-that can also have synthesizer-core:Causal.Process as instance.--}-($*) :: T p a b -> SigP.T p a -> SigP.T p b-($*) = apply-($<) = applyFst-($>) = applySnd---reparameterize :: Param.T q p -> T p a b -> T q a b-reparameterize p (Cons start alloca stop next create delete) =-   Cons start alloca stop next (create . Param.get p) delete---mapAccumSimple ::-   (Memory.C s) =>-   (forall r. a -> s -> CodeGenFunction r (b,s)) ->-   (forall r. CodeGenFunction r s) ->-   T p a b-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,-    Marshal.C i, Tuple.ValueOf 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 ::-   (Tuple.Undefined b, Tuple.Phi b) =>-   Param.T p Int -> SigP.T p b -> T p (b,b) b -> T p a b -> T p a b-replicateParallel n z cum p =-   replicateControlled n (first p >>> cum) $> z--{--There are several problems:-- * We have to call f on every parameter in the list,-   but we have to assume that the generated code is always the same.-- * createIOContext may return different types for every element in the list.-   If types are different, the LLVM code cannot be the same, though.--}-replicateControlledParam ::-   (Tuple.Undefined x, Tuple.Phi x) =>-   (forall q. Param.T q p -> Param.T q a -> T q (c,x) x) ->-   Param.T p [a] -> T p (c,x) x-replicateControlledParam f ps =-   case f (arr fst) (arr snd) of-      Cons next alloca start stop createIOContext deleteIOContext -> Cons-         (replicateControlledNext next stop)---         (_replicateControlledNext next)-         alloca-         (replicateControlledStart start)-         (replicateControlledStop stop)-         (\p ->-            replicateControlledCreate $-               mapM-                  (\a -> createIOContext (p,a))-                  (Param.get ps p))-         (replicateControlledDelete deleteIOContext)----- cf. synthesizer-core:Causal.Process-feedbackControlled ::-   (Marshal.C ch, Tuple.ValueOf ch ~ c) =>-   Param.T p ch ->-   T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b-feedbackControlled initial forth back =-   loop initial (feedbackControlledAux forth back)---{- |-Run a causal process independently on each stereo channel.--}-stereoFromMono ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>-   T p a b -> T p (Stereo.T a) (Stereo.T b)-stereoFromMono-      (Cons next alloca start stop createIOContext deleteIOContext) = Cons-   (stereoNext stop next)-   alloca-   (stereoStart start)-   (stereoStop stop)-   (stereoCreate createIOContext createIOContext)-   (composeDelete deleteIOContext deleteIOContext)--stereoFromMonoControlled ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, Tuple.Undefined b) =>-   T p (c,a) b -> T p (c, Stereo.T a) (Stereo.T b)-stereoFromMonoControlled proc =-   stereoFromMono proc <<^ (\(c,sa) -> fmap ((,) c) sa)--stereoFromMonoParameterized ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>-   (forall q. Param.T q p -> Param.T q x -> T q a b) ->-   Param.T p (Stereo.T x) -> T p (Stereo.T a) (Stereo.T b)-stereoFromMonoParameterized f ps =-   case f (arr fst) (arr snd) of-      Cons next alloca start stop createIOContext deleteIOContext -> Cons-         (stereoNext stop next)-         alloca-         (stereoStart start)-         (stereoStop stop)-         (stereoCreate-            (\p -> createIOContext (p, Stereo.left  $ Param.get ps p))-            (\p -> createIOContext (p, Stereo.right $ Param.get ps p)))-         (composeDelete deleteIOContext deleteIOContext)--stereoCreate ::-   Monad m =>-   (p -> m (ioContextA, context)) ->-   (p -> m (ioContextB, context)) ->-   p -> m ((ioContextA, ioContextB), Stereo.T context)-stereoCreate l r =-   liftM (mapSnd $ uncurry Stereo.cons) . composeCreate l r---stereoNext ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, Tuple.Phi s, Tuple.Phi context,-    Tuple.Undefined b, Tuple.Undefined s) =>-   (context -> s -> CodeGenFunction r ()) ->-   (forall z. (Tuple.Phi z) => context -> local -> a -> s -> MaybeCont.T r z (b, s)) ->-   Stereo.T context ->-   local ->-   Stereo.T a ->-   Stereo.T s ->-   MaybeCont.T r c (Stereo.T b, Stereo.T s)-stereoNext stop next context local a s0 = MaybeCont.fromMaybe $ do-   mbs1 <--      twiceStereo-         (MaybeCont.toMaybe . uncurry3 (flip next local))-         (liftA3 (,,) context a s0)--   mbs2 <--      if True-        then Maybe.lift2 Stereo.cons (Stereo.left mbs1) (Stereo.right mbs1)-        else MaybeCont.toMaybe $ traverse (MaybeCont.fromMaybe . return) mbs1--   end <- Maybe.getIsNothing mbs2-   C.ifThen end () $-      sequence_ $-      liftA2-         (\mbsi c -> Maybe.for mbsi (stop c . snd))-         mbs1 context--   return $ fmap unzip mbs2--stereoStart ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, Tuple.Undefined b, Tuple.Undefined c) =>-   (a -> CodeGenFunction r (c, b)) ->-   Stereo.T a -> CodeGenFunction r (Stereo.T c, Stereo.T b)-stereoStart code a =-   fmap unzip $ twiceStereo code a--stereoStop ::-   (Tuple.Phi context, Tuple.Phi state) =>-   (context -> state -> CodeGenFunction r ()) ->-   Stereo.T context -> Stereo.T state -> CodeGenFunction r ()-stereoStop code c s = void $ twiceStereo (uncurry code) (liftA2 (,) c s)--twiceStereo ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>-   (a -> CodeGenFunction r b) ->-   Stereo.T a -> CodeGenFunction r (Stereo.T b)-twiceStereo code a =-   fmap (uncurry Stereo.cons) $-   twice code (Stereo.left a, Stereo.right a)--twice ::-   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>-   (a -> CodeGenFunction r b) ->-   (a,a) -> CodeGenFunction r (b,b)-twice code a =-   fmap snd $-   C.fixedLengthLoop (valueOf (2::Int8)) (a, Tuple.undef) $-      \((a0,a1), (_,b1)) -> do-         b0 <- code a0-         return ((a1,a0), (b1,b0))---{- |-You may also use '(+)' and a 'SigP.constant' signal or a number literal.--}-raise ::-   (A.Additive al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p al al-raise =-   map Frame.mix---{- |-You may also use '(*)' and a 'SigP.constant' signal or a number literal.--}-amplify ::-   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p al al-amplify =-   map Frame.amplifyMono--amplifyStereo ::-   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p (Stereo.T al) (Stereo.T al)-amplifyStereo =-   map Frame.amplifyStereo----mapLinear ::-   (IsArithmetic a, Marshal.C a, Tuple.ValueOf a ~ Value a) =>-   Param.T p a -> Param.T p a -> T p (Value a) (Value a)-mapLinear depth center =-   map-      (\(d,c) x -> A.add c =<< A.mul d x)-      (depth&&&center)--mapExponential ::-   (Trans.C a, Marshal.C a, IsFloating a, IsConst a,-    SoV.TranscendentalConstant a, Tuple.ValueOf a ~ Value a) =>-   Param.T p a -> Param.T p a -> T p (Value a) (Value a)-mapExponential depth center =-   map-      (\(d,c) x ->-         A.mul c =<< A.exp =<< A.mul d x)-      (log depth &&& center)---{- |-@quantizeLift k f@ applies the process @f@ to every @k@th sample-and repeats the result @k@ times.--Like 'SigP.interpolateConstant' this function can be used-for computation of filter parameters at a lower rate.-This can be useful, if you have a frequency control signal at sample rate-that shall be used both for an oscillator and a frequency filter.--}-quantizeLift ::-   (Memory.C b,-    Marshal.C c, Tuple.ValueOf c ~ Value cl,-    SoV.IntegerConstant cl, IsFloating cl,-    LLVM.CmpRet cl, LLVM.CmpResult cl ~ Bool) =>-   Param.T p c ->-   T p a b ->-   T p a b-quantizeLift k causal =-   Causal.quantizeLift causal $< SigP.constant k----- for backwards compatibility-osciSimple ::-   (SoV.Fraction t, IsSized t) =>-   (forall r. Value t -> CodeGenFunction r y) ->-   T p (Value t, Value t) y-osciSimple = Causal.osci---{- |-Delay time must be non-negative.--The initial value is needed in order to determine the ring buffer element type.--}-delay ::-   (Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> Param.T p Int -> T p al al-delay initial time =-   mapSimple RingBuffer.oldest-   <<<-   RingBuffer.track initial time--delayZero ::-   (Memory.C a, A.Additive a) =>-   Param.T p Int -> T p a a-delayZero time =-   mapSimple RingBuffer.oldest-   <<<-   RingBuffer.trackConst A.zero time---{- |-Delay by one sample.-For very small delay times (say up to 8)-it may be more efficient to apply 'delay1' several times-or to use a pipeline,-e.g. @pipeline (id :: T (Vector D4 Float) (Vector D4 Float))@-delays by 4 samples in an efficient way.-In principle it would be also possible to use-@unpack (delay1 (pure $ consVector 0 0 0 0))@-but 'unpack' causes an additional delay.-Thus @unpack (id :: T (Vector D4 Float) (Vector D4 Float))@ may do,-what you want.--}-delay1 ::-   (Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p al al-delay1 initial = loop initial (arr swap)---{- |-Delay by a variable amount of samples.-The momentum delay must be between @0@ and @maxTime@, inclusively.--}-delayControlled ::-   (Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> Param.T p Int -> T p (Value Word, al) al-delayControlled initial maxTime =-   zipWithSimple RingBuffer.index-   <<<-   second (RingBuffer.track initial maxTime)--{- |-Delay by a variable fractional amount of samples.-Non-integer delays are achieved by linear interpolation.-The momentum delay must be between @0@ and @maxTime@, inclusively.--}-delayControlledInterpolated ::-   (Interpolation.C nodes,-    Marshal.C vh, Tuple.ValueOf vh ~ v,-    IsFloating a, LLVM.ShapeOf a ~ LLVM.ScalarShape) =>-   (forall r. Interpolation.T r nodes (Value a) v) ->-   Param.T p vh -> Param.T p Int -> T p (Value a, v) v-delayControlledInterpolated ip initial maxTime =-   let margin = Interpolation.toMargin ip-   in  zipWithSimple-          (\del buf -> do-             let offset =-                    A.fromInteger' $ fromIntegral $-                    Interpolation.marginOffset margin-             n <- A.max offset =<< LLVM.fptoint del-             k <- A.sub del =<< LLVM.inttofp n-             m <- A.sub n offset-             ip k =<<-                Interpolation.indexNodes (flip RingBuffer.index buf) A.one m)-       <<<-       second-          (RingBuffer.track initial-              (fmap (Interpolation.marginNumber margin +) maxTime))---differentiate ::-   (A.Additive al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p al al-differentiate initial =-   Cat.id - delay1 initial--{- |-Delay time must be greater than zero!--}-comb ::-   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> Param.T p Int ->-   T p al al-comb gain time =-   loopZero (mix >>> (Cat.id &&&-      (delayZero (time-1) >>> amplify gain)))--combStereo ::-   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> Param.T p Int ->-   T p (Stereo.T al) (Stereo.T al)-combStereo gain time =-   loopZero (mix >>> (Cat.id &&&-      (delayZero (time-1) >>> amplifyStereo gain)))--{- |-Example: apply a stereo reverb to a mono sound.--> traverse->    (\seed -> reverbSimple (Random.mkStdGen seed) 16 (0.92,0.98) (200,1000))->    (Stereo.cons 42 23)--There is a serious problem:-The parameters are not of type 'Param.T',-thus they cannot depend e.g. on a dynamic sample rate as required by JACK.--}-reverbSimple ::-   (Random a, IsArithmetic a, SoV.RationalConstant a,-    Marshal.C a, Tuple.ValueOf a ~ Value a,-    RandomGen g) =>-   g -> Int -> (a,a) -> (Int,Int) ->-   T p (Value a) (Value a)-reverbSimple rnd num gainRange timeRange =-   mapSimple (A.mul (A.fromRational' $ recip $ fromIntegral num)) <<<-   (foldl (+) zero $-    List.map (\(g,t) -> comb $# g $# t) $-    reverbParams rnd num gainRange timeRange)--reverb ::-   (Random a, Marshal.C a, Tuple.ValueOf a ~ Value a,-    SoV.PseudoModule a, SoV.Scalar a ~ s,-    IsFloating s, SoV.IntegerConstant s, LLVM.IsPrimitive s,-    RandomGen g) =>-   Param.T p g -> Param.T p Int -> Param.T p (a,a) -> Param.T p (Int,Int) ->-   T p (Value a) (Value a)-reverb rnd num gainRange timeRange =-   map-      (\n x -> flip A.scale x =<< A.fdiv A.one =<< LLVM.inttofp n)-      (Param.wordInt num)-   <<<-   replicateControlledParam-      (\_p p -> first (comb (fmap fst p) (fmap snd p)) >>> mix)-      (pure reverbParams <*> rnd <*> num <*> gainRange <*> timeRange)-   <<^-   (\a -> (a,a))---{- |-Like 'skip' but does not require @Memory@ constraint on the result type.-This way it can be used on a stream of ring buffer states.-The downside is that the result is recomputed (from the previous state)-at every step.--Warning:-This process is actually unsafe.-It fails on signal generators that use mutable variables,-like Signal.storableVectorLazy.--}-_skipVolatile ::-   (Causal.C process, CausalClass.SignalOf process ~ signal) =>-   signal v -> process (Value Word) v-_skipVolatile =-   CausalPriv.alterSignal-      (\(SigPriv.Core next start stop) -> CausalPriv.Core-         (\context n state0 -> do-            y <- fmap fst $ next context state0-            state1 <--               MaybeCont.fromMaybe $ fmap snd $-               MaybeCont.fixedLengthLoop n state0 $-               fmap snd . next context-            return (y, state1))-         start-         stop)---{- |-> frequencyModulationLinear signal--is a causal process mapping from a shrinking factor-to the modulated input @signal@.-Similar to 'Sig.interpolateConstant'-but the factor is reciprocal and controllable-and we use linear interpolation.-The shrinking factor must be non-negative.--}-frequencyModulationLinear ::-   (SoV.IntegerConstant a, IsFloating a,-    LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, IsSized a) =>-   SigP.T p (Value a) -> T p (Value a) (Value a)-frequencyModulationLinear =-   Causal.frequencyModulation Interpolation.linear . SigP.adjacentNodes02---type Exporter f = f -> IO (FunPtr f)--foreign import ccall safe "wrapper" callbackCreate ::-   Exporter (LLVM.Ptr lparam -> LLVM.Ptr init -> IO (StablePtr ioContext))--foreign import ccall safe "wrapper" callbackDelete ::-   Exporter (StablePtr ioContext -> IO ())--stopAndDelete ::-   LLVM.Function (StablePtr ioContext -> IO ()) ->-   (context -> state -> CodeGenFunction r ()) ->-   Maybe.T ((context, state), Value (StablePtr ioContext)) ->-   CodeGenFunction r ()-stopAndDelete eraser stop mcsio =-   Maybe.for mcsio $ \(cs, io) -> do-      uncurry stop cs-      void $ LLVM.call eraser io---{- |-@trigger fill signal@ send @signal@ to the output-and restart it whenever the Boolean process input is 'True'.-Before the first occurrence of 'True'-and between instances of the signal the output is filled with 'Maybe.nothing'.--Every restart of the signal needs a call into Haskell code.-Thus it is certainly a good idea, not to trigger the signal too frequently.--}-{--Are exceptions handled correctly?--}-trigger ::-   (Marshal.C a, Tuple.ValueOf a ~ al, Tuple.Undefined b, Tuple.Phi b) =>-   (forall q. Param.T q p -> Param.T q a -> SigP.T q b) ->-   T p (Maybe.T al) (Maybe.T b)-trigger sig =-   triggerAux (sig (arr fst) (arr snd))--triggerAux ::-   (Marshal.C a, Tuple.ValueOf a ~ al, Tuple.Undefined b, Tuple.Phi b) =>-   SigP.T (p,a) b ->-   T p (Maybe.T al) (Maybe.T b)-triggerAux-   (SigPPriv.Cons next alloca start stop createIOContext deleteIOContext) = Cons-   (\(creator, eraser) (local, (param, xPtr)) mx mcsio0 -> MaybeCont.lift $ do-      mcsio1 <--         Maybe.run mx-            (return mcsio0)-            (\x ->-               stopAndDelete eraser stop mcsio0-               >>-               do-                  Memory.store x xPtr-                  io <- LLVM.call creator param xPtr-                  cs <- start =<< Memory.load param-                  return $ Maybe.just (cs, io))-      mcasio2 <--         Maybe.run mcsio1 (return Maybe.nothing) $ \((c1,s1), io1) ->-            MaybeCont.toMaybe $ fmap (flip (,) io1 . (,) c1) $ next c1 local s1-      return (fmap (fst.snd.fst) mcasio2, fmap (mapFst (mapSnd snd)) mcasio2))-   (liftA2 (,) alloca $ liftA2 (,) LLVM.alloca LLVM.alloca)-   (\ce -> return (ce, Maybe.nothing))-   (\(_creator, eraser) mcsio -> stopAndDelete eraser stop mcsio)-   (\p -> do-      creator <- callbackCreate $ \paramPtr xPtr -> do-         x <- Marshal.peek xPtr-         (context, param) <- createIOContext (p,x)-         Marshal.poke paramPtr param-         newStablePtr context-      eraser <- callbackDelete $ \contextPtr -> do-         deleteIOContext =<< deRefStablePtr contextPtr-         freeStablePtr contextPtr-      let ce = (creator, eraser)-      return (ce, ce))-   (\(creator, eraser) ->-      freeHaskellFunPtr creator >>-      freeHaskellFunPtr eraser)---{- |-On each restart the parameters of type @b@ are passed to the signal.--triggerParam ::-   (Tuple.Value a, Tuple.ValueOf a ~ al,-    Tuple.Value b, Tuple.ValueOf b ~ bl) =>-   Param.T p a ->-   (Param.T p b -> SigP.T p a) ->-   T p (Value Bool, bl) al-triggerParam fill sig =--}----foreign import ccall safe "dynamic" derefFillPtr ::-   Exec.Importer (LLVM.Ptr param -> Word -> Ptr a -> Ptr b -> IO Word)--runStorable ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T p valueA valueB ->-   IO (p -> SV.Vector a -> SV.Vector b)-runStorable (Cons next alloca start stop createIOContext deleteIOContext) = do-   fill <--      Exec.compile "process" $-      Exec.createFunction derefFillPtr "fillprocessblock" $-      \paramPtr size alPtr blPtr -> do-         param <- Memory.load paramPtr-         (c,s) <- start param-         local <- alloca-         (pos,msExit) <--            Storable.arrayLoopMaybeCont2 size alPtr blPtr s $-               \ aPtri bPtri s0 -> do-            a <- MaybeCont.lift $ Storable.load aPtri-            (b,s1) <- next c local a s0-            MaybeCont.lift $ Storable.store b bPtri-            return s1-         Maybe.for msExit $ stop c-         ret pos--   return $ \p as ->-      Unsafe.performIO $-      bracket (createIOContext p) (deleteIOContext . fst) $-      \ (_,params) ->-         SVB.withStartPtr as $ \ aPtr len ->-         SVB.createAndTrim len $ \ bPtr ->-         Marshal.with params $ \paramPtr ->-         fmap fromIntegral $-            fill paramPtr (fromIntegral len) aPtr bPtr--applyStorable ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T p valueA valueB ->-   p -> SV.Vector a -> SV.Vector b-applyStorable gen = Unsafe.performIO $ runStorable gen----foreign import ccall safe "dynamic" derefChunkPtr ::-   Exec.Importer-      (LLVM.Ptr contextStateStruct -> Word -> Ptr a -> Ptr b -> IO Word)---compileChunky ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB,-    Memory.C parameters, Memory.Struct parameters ~ paramStruct,-    Memory.C context, Memory.C state,-    Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>-   (forall r z.-    (Tuple.Phi z) =>-    context -> local ->-    valueA -> state ->-    MaybeCont.T r z (valueB, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r.-    parameters ->-    CodeGenFunction r (context, state)) ->-   (forall r.-    context -> state ->-    CodeGenFunction r ()) ->-   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct),-       Exec.Finalizer contextStateStruct,-       LLVM.Ptr contextStateStruct -> Word -> Ptr a -> Ptr b -> IO Word)-compileChunky next alloca start stop =-   Exec.compile "process-chunky" $-      liftA3 (,,)-         (Exec.createFunction derefStartPtr "startprocess" $-          \paramPtr -> do-             pptr <- LLVM.malloc-             flip Memory.store pptr . mapSnd Maybe.just-                =<< start =<< Memory.load paramPtr-             ret pptr)-         (Exec.createFinalizer derefStopPtr "stopprocess" $-          \ contextStatePtr -> do-             (c,ms) <- Memory.load contextStatePtr-             Maybe.for ms $ stop c-             LLVM.free contextStatePtr-             ret ())-         (Exec.createFunction derefChunkPtr "fillprocess" $-          \ contextStatePtr loopLen aPtr bPtr -> do-             (param, msInit) <- Memory.load contextStatePtr-             local <- alloca-             (pos,msExit) <--                Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->-                   Storable.arrayLoopMaybeCont2 loopLen aPtr bPtr sInit $-                   \ aPtri bPtri s0 -> do-                a <- MaybeCont.lift $ Storable.load aPtri-                (b,s1) <- next param local a s0-                MaybeCont.lift $ Storable.store b bPtri-                return s1-             sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())-             Memory.store msExit sptr-             ret pos)---foreign import ccall safe "dynamic" derefStartPtr ::-   Exec.Importer (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct))--foreign import ccall safe "dynamic" derefStopPtr ::-   Exec.Importer (LLVM.Ptr contextStateStruct -> IO ())--foreign import ccall safe "dynamic" derefChunkPluggedPtr ::-   Exec.Importer-      (LLVM.Ptr contextStateStruct -> Word ->-       LLVM.Ptr inp -> LLVM.Ptr out -> IO Word)--compilePlugged ::-   (Memory.C parameters, Memory.Struct parameters ~ paramStruct,-    Memory.C context, Memory.C state,-    Memory.Struct (context, Maybe.T state) ~ contextStateStruct,-    Tuple.Undefined stateIn,  Tuple.Phi stateIn,-    Tuple.Undefined stateOut, Tuple.Phi stateOut,-    Memory.C paramValueIn,  Memory.Struct paramValueIn  ~ paramStructIn,-    Memory.C paramValueOut, Memory.Struct paramValueOut ~ paramStructOut) =>-   (forall r.-    paramValueIn ->-    stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) ->-   (forall r.-    paramValueIn ->-    LLVM.CodeGenFunction r stateIn) ->-   (forall r z.-    (Tuple.Phi z) =>-    context -> local ->-    valueA -> state ->-    MaybeCont.T r z (valueB, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r.-    parameters ->-    CodeGenFunction r (context, state)) ->-   (forall r.-    context -> state ->-    CodeGenFunction r ()) ->-   (forall r.-    paramValueOut ->-    valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) ->-   (forall r.-    paramValueOut ->-    LLVM.CodeGenFunction r stateOut) ->-   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct),-       LLVM.Ptr contextStateStruct -> IO (),-       LLVM.Ptr contextStateStruct -> Word ->-         LLVM.Ptr paramStructIn -> LLVM.Ptr paramStructOut -> IO Word)-compilePlugged nextIn startIn next alloca start stop nextOut startOut =-   Exec.compile "process-plugged" $-      liftA3 (,,)-         (Exec.createFunction derefStartPtr "startprocess" $-          \paramPtr -> do-             pptr <- LLVM.malloc-             flip Memory.store pptr . mapSnd Maybe.just-                =<< start =<< Memory.load paramPtr-             ret pptr)-         (Exec.createFunction derefStopPtr "stopprocess" $-          \ contextStatePtr -> do-             (c,ms) <- Memory.load contextStatePtr-             Maybe.for ms $ stop c-             LLVM.free contextStatePtr-             ret ())-         (Exec.createFunction derefChunkPluggedPtr "fillprocess" $-          \ contextStatePtr loopLen inPtr outPtr -> do-             (param, msInit) <- Memory.load contextStatePtr-             inParam  <- Memory.load inPtr-             outParam <- Memory.load outPtr-             inInit  <- startIn  inParam-             outInit <- startOut outParam-             local <- alloca-             (pos,msExit) <--                Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->-                   MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $-                      \ (in0,s0,out0) -> do-                (a,in1) <- MaybeCont.lift $ nextIn inParam in0-                (b,s1) <- next param local a s0-                out1 <- MaybeCont.lift $ nextOut outParam b out0-                return (in1, s1, out1)-             sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())-             Memory.store (fmap snd3 msExit) sptr-             ret pos)---runStorableChunky ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T p valueA valueB ->-   IO (p -> SVL.Vector a -> SVL.Vector b)-runStorableChunky proc =-   fmap ($ const SVL.empty) $-   runStorableChunkyCont proc--{- |-This function should be used-instead of @StorableVector.Lazy.Pattern.splitAt@ and subsequent @append@,-because it does not have the risk of a memory leak.--}-runStorableChunkyCont ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T p valueA valueB ->-   IO ((SVL.Vector a -> SVL.Vector b) ->-       p -> SVL.Vector a -> SVL.Vector b)-runStorableChunkyCont-      (Cons next alloca start stop createIOContext deleteIOContext) = do-   (startFunc, stopFunc, fill) <- compileChunky next alloca start stop-   return $-      \ procRest p sig ->-      SVL.fromChunks $ Unsafe.performIO $ do-         (ioContext, param) <- createIOContext p--         when False $-            DebugCnt.next DebugSt.dumpCounter >>=-            DebugSt.dump "param" param--         statePtr <- ForeignPtr.newParam stopFunc startFunc param-         ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)--         let go xt =-               Unsafe.interleaveIO $-               case xt of-                  [] -> return []-                  x:xs -> SVB.withStartPtr x $ \aPtr size -> do-                     v <--                        ForeignPtr.with statePtr $ \sptr ->-                        SVB.createAndTrim size $-                        fmap fromIntegral .-                        fill sptr (fromIntegral size) aPtr-                     touchForeignPtr ioContextPtr-                     (if SV.length v > 0-                        then fmap (v:)-                        else id) $-                        (if SV.length v < size-                           then return $ SVL.chunks $-                                procRest $ SVL.fromChunks $-                                SV.drop (SV.length v) x : xs-                           else go xs)-         go (SVL.chunks sig)--applyStorableChunky ::-   (Storable.C a, Tuple.ValueOf a ~ valueA,-    Storable.C b, Tuple.ValueOf b ~ valueB) =>-   T p valueA valueB ->-   p -> SVL.Vector a -> SVL.Vector b-applyStorableChunky gen =-   Unsafe.performIO (runStorableChunky gen)---{--I liked to write something with signature--> import qualified Synthesizer.Causal.Process as Causal->-> liftStorableChunk ::->    T p valueA valueB ->->    IO (p -> Causal.T (SV.Vector a) (SV.Vector b))--but it does not quite work this way.-@Causal.T@ from @synthesizer-core@ uses an immutable state internally,-whereas @T@ uses mutable states.-In principle the immutable state of @Causal.T@-could be used for breaking the processing of a stream-and continue it on two different streams in parallel.-I have no function that makes use of this feature,-and thus an @ST@ monad might be a way out.--With this function we can convert an LLVM causal process to an causal IO arrow.-We also need the plugs in order-to read and write LLVM values from and to Haskell data chunks.--In a second step we could convert this to a processor of lazy lists,-and thus to a processor of chunky storable vectors.--}-processIOCore ::-   (Cut.Read a) =>-   PIn.T a b ->-   T p b c ->-   POut.T c d ->-   IO (p -> PIO.T a d)-processIOCore-      (PIn.Cons nextIn startIn createIn deleteIn)-      (Cons next alloca start stop createIOContext deleteIOContext)-      (POut.Cons nextOut startOut createOut deleteOut) = do-   (startFunc, stopFunc, fill) <--      compilePlugged nextIn startIn next alloca start stop nextOut startOut-   return $ \p -> PIO.Cons-      (\a s@(_, paramPtr) -> do-         let maximumSize = Cut.length a-         (contextIn, paramIn)  <- createIn a-         (contextOut,paramOut) <- createOut maximumSize-         actualSize <--            Marshal.with paramIn $ \inptr ->-            Marshal.with paramOut $ \outptr ->-            fill paramPtr (fromIntegral maximumSize) inptr outptr-         deleteIn contextIn-         b <- deleteOut (fromIntegral actualSize) contextOut-         return (b, s))-      (do-         (ioContext, param) <- createIOContext p--         when False $-            DebugCnt.next DebugSt.dumpCounter >>=-            DebugSt.dump "param" param-         contextStatePtr <- Marshal.with param startFunc--         return (ioContext, contextStatePtr))-      (\(ioContext, contextStatePtr) -> do-         stopFunc contextStatePtr-         deleteIOContext ioContext)--processIO ::-   (Cut.Read a, PIn.Default a, POut.Default d) =>-   T p (PIn.Element a) (POut.Element d) ->-   IO (p -> PIO.T a d)-processIO proc =-   processIOCore PIn.deflt proc POut.deflt
− src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.CausalParameterized.ProcessPacked (-   CausalS.pack,-   CausalS.packSmall,-   CausalS.unpack,-   raise,-   amplify,-   amplifyStereo,-   CausalS.osciCore,-   osciSimple,-   CausalS.shapeModOsci,-   delay1,-   differentiate,-   integrate,-   CausalS.arrayElement,-   ) where--import Synthesizer.LLVM.CausalParameterized.ProcessPrivate (T)-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalS-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Frame as Frame-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, IsSized, IsArithmetic, IsPrimitive)--import qualified Type.Data.Num.Decimal as TypeNum--import qualified Control.Category as Cat--import Data.Tuple.HT (swap)--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith)---raise ::-   (IsArithmetic a, Marshal.C a, Tuple.ValueOf a ~ Value a, IsPrimitive a,-    TypeNum.Positive n) =>-   Param.T p a ->-   T p (Serial.Value n a) (Serial.Value n a)-raise =-   CausalP.map-      (\x y -> Serial.upsample x >>= flip Frame.mix y)--amplify ::-   (IsArithmetic a, Marshal.C a, Tuple.ValueOf a ~ Value a, IsPrimitive a,-    TypeNum.Positive n) =>-   Param.T p a ->-   T p (Serial.Value n a) (Serial.Value n a)-amplify =-   CausalP.map-      (\x y -> Serial.upsample x >>= flip Frame.amplifyMono y)--amplifyStereo ::-   (IsArithmetic a, Marshal.C a, Tuple.ValueOf a ~ Value a, IsPrimitive a,-    TypeNum.Positive n) =>-   Param.T p a ->-   T p (Stereo.T (Serial.Value n a)) (Stereo.T (Serial.Value n a))-amplifyStereo =-   CausalP.map-      (\x y -> Serial.upsample x >>= flip Frame.amplifyStereo y)----- for backwards compatibility-osciSimple ::-   (Causal.C process,-    Vector.Real t, SoV.Fraction t, LLVM.IsFloating t, IsSized t,-    TypeNum.Positive n) =>-   (forall r. Serial.Value n t -> CodeGenFunction r y) ->-   process (Serial.Value n t, Serial.Value n t) y-osciSimple = CausalS.osci---delay1 ::-   (Serial.C va, n ~ Serial.Size va, al ~ Serial.Element va,-    Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p va va-delay1 initial =-   CausalP.loop initial $-   Causal.map (fmap swap . uncurry Serial.shiftUp . swap)--differentiate ::-   (Serial.C va, n ~ Serial.Size va, al ~ Serial.Element va,-    A.Additive va,-    Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p va va-differentiate initial =-   Cat.id - delay1 initial--integrate ::-   (Vector.Arithmetic a, Marshal.C a, Tuple.ValueOf a ~ Value a, IsPrimitive a,-    TypeNum.Positive n) =>-   Param.T p a ->-   T p (Serial.Value n a) (Serial.Value n a)-integrate =-   CausalP.mapAccum-      (\() a acc0 -> do-         (acc1,b) <- Serial.cumulate acc0 a-         return (b,acc1))-      return-      (return ())
− src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs 
@@ -1,518 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.CausalParameterized.ProcessPrivate where--import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as Sig-import qualified Synthesizer.LLVM.Causal.ProcessPrivate as CausalPriv-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr-import Synthesizer.LLVM.Causal.ProcessPrivate (loopNext)-import Synthesizer.LLVM.Causal.Process (mapProc, zipProcWith)-import Synthesizer.LLVM.Simple.SignalPrivate (proxyFromElement2)--import qualified Synthesizer.Causal.Class as CausalClass-import qualified Synthesizer.Causal.Utility as ArrowUtil--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory--import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, valueOf)--import Type.Data.Num.Decimal (d1)--import qualified Control.Monad.HT as M-import qualified Control.Arrow    as Arr-import qualified Control.Category as Cat-import Control.Arrow (arr, (^<<), (<<<), (&&&))-import Control.Applicative (Applicative, pure, (<*>), (<$>))-import Data.Tuple.HT (mapSnd)--import Data.Word (Word)--import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr, mallocForeignPtrBytes)--import qualified System.Unsafe as Unsafe--import qualified Number.Ratio as Ratio-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, init)--import qualified Prelude as P---data T p a b =-   forall context state local ioContext parameters.-      (Marshal.C parameters, Memory.C context, Memory.C state) =>-   Cons-      (forall r c.-       (Tuple.Phi c) =>-       context -> local ->-       a -> state -> MaybeCont.T r c (b, state))-          -- compute next value-      (forall r.-       CodeGenFunction r local)-          -- allocate temporary variables before a loop-      (forall r.-       Tuple.ValueOf parameters ->-       CodeGenFunction r (context, state))-          -- initial state-      (forall r.-       context -> state ->-       CodeGenFunction r ())-          -- cleanup-      (p -> IO (ioContext, parameters))-          {- initialization from IO monad-          This will be run within Unsafe.performIO,-          so no observable In/Out actions please!-          -}-      (ioContext -> IO ())-          -- finalization from IO monad, also run within Unsafe.performIO---type instance CausalClass.ProcessOf (Sig.T p) = T p--instance CausalClass.C (T p) where-   type SignalOf (T p) = Sig.T p-   toSignal = toSignal-   fromSignal = fromSignal--instance Causal.C (T p) where-   simple next start =-      simple (\() -> next) (\() -> fmap ((,) ()) start) (pure ())--   alter f (Cons next0 alloca start0 stop0 create delete) =-      case f (CausalPriv.Core (uncurry next0) return id) of-         CausalPriv.Core next1 start1 stop1 ->-            Cons-               (curry next1) alloca-               (Sig.withStart start0 start1)-               (\c -> stop0 c . stop1)-               create delete--   replicateControlled n = replicateControlled $ pure n---simple ::-   (Marshal.C parameters, Memory.C context, Memory.C state) =>-   (forall r c.-    (Tuple.Phi c) =>-    context -> a -> state -> MaybeCont.T r c (b, state)) ->-   (forall r.-    Tuple.ValueOf parameters ->-    CodeGenFunction r (context, state)) ->-   Param.T p parameters -> T p a b-simple f start param =-   Param.withValue param $ \get value ->-   Cons-      (\context () -> f context)-      (return ())-      (start . value)-      (const $ const $ return ())-      (return . (,) () . get)-      (const $ return ())---toSignal :: T p () a -> Sig.T p a-toSignal-      (Cons next alloca start stop createIOContext deleteIOContext) = Sig.Cons-   (\p l -> next p l ())-   alloca-   start stop-   createIOContext deleteIOContext--fromSignal :: Sig.T p b -> T p a b-fromSignal-      (Sig.Cons next alloca start stop createIOContext deleteIOContext) = Cons-   (\p l _ -> next p l)-   alloca-   start stop-   createIOContext deleteIOContext---mapAccum ::-   (Marshal.C pnh, Tuple.ValueOf pnh ~ pnl,-    Marshal.C psh, Tuple.ValueOf psh ~ psl,-    Memory.C s) =>-   (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->-   (forall r. psl -> CodeGenFunction r s) ->-   Param.T p pnh ->-   Param.T p psh ->-   T p a b-mapAccum next start selectParamN selectParamS =-   simple-      (\p a s -> MaybeCont.lift $ next p a s)-      (\(n,s) -> fmap ((,) n) $ start s)-      (selectParamN &&& selectParamS)---map ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (forall r. pl -> a -> CodeGenFunction r b) ->-   Param.T p ph ->-   T p a b-map f selectParamF =-   mapAccum-      (\p a s -> fmap (flip (,) s) $ f p a)-      (const $ return ())-      selectParamF-      (return ())--mapSimple ::-   (forall r. a -> CodeGenFunction r b) ->-   T p a b-mapSimple f =-   map (const f) (return ())--zipWith ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (forall r. pl -> a -> b -> CodeGenFunction r c) ->-   Param.T p ph ->-   T p (a,b) c-zipWith f =-   map (uncurry . f)--zipWithSimple ::-   (forall r. a -> b -> CodeGenFunction r c) ->-   T p (a,b) c-zipWithSimple f =-   mapSimple (uncurry f)---apply :: T p a b -> Sig.T p a -> Sig.T p b-apply = CausalClass.apply--feedFst :: Sig.T p a -> T p b (a,b)-feedFst = CausalClass.feedFst--feedSnd :: Sig.T p a -> T p b (b,a)-feedSnd = CausalClass.feedSnd---{--Very similar to 'apply',-since 'apply' can be considered being of type-@T p a b -> T p () a -> T p () b@.--}-compose :: T p a b -> T p b c -> T p a c-compose-      (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)-      (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =-   Cons-      (composeNext MaybeCont.onFail stopA stopB nextA nextB)-      (M.lift2 (,) allocaA allocaB)-      (composeStart startA startB)-      (composeStop stopA stopB)-      (composeCreate createIOContextA createIOContextB)-      (composeDelete deleteIOContextA deleteIOContextB)--composeNext ::-   (Monad maybe) =>-   (forall x. code () -> maybe x -> maybe x) ->-   (contextA -> stateA -> code ()) ->-   (contextB -> stateB -> code ()) ->-   (contextA -> localA -> a -> stateA -> maybe (b, stateA)) ->-   (contextB -> localB -> b -> stateB -> maybe (c, stateB)) ->-   (contextA, contextB) ->-   (localA, localB) ->-   a ->-   (stateA, stateB) ->-   maybe (c, (stateA, stateB))-composeNext onFail stopA stopB nextA nextB-      (paramA, paramB) (localA, localB) a (sa0,sb0) = do-   (b,sa1) <- onFail (stopB paramB sb0) $ nextA paramA localA a sa0-   (c,sb1) <- onFail (stopA paramA sa1) $ nextB paramB localB b sb0-   return (c, (sa1,sb1))--composeStart ::-   Monad m =>-   (paramA -> m (contextA, stateA)) ->-   (paramB -> m (contextB, stateB)) ->-   (paramA, paramB) -> m ((contextA, contextB), (stateA, stateB))-composeStart = Sig.combineStart--composeStop ::-   Monad m =>-   (contextA -> stateA -> m ()) ->-   (contextB -> stateB -> m ()) ->-   (contextA, contextB) -> (stateA, stateB) -> m ()-composeStop = Sig.combineStop--composeCreate ::-   Monad m =>-   (p -> m (ioContextA, contextA)) ->-   (p -> m (ioContextB, contextB)) ->-   p -> m ((ioContextA, ioContextB), (contextA, contextB))-composeCreate = Sig.combineCreate--composeDelete ::-   (Monad m) =>-   (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m ()-composeDelete = Sig.combineDelete---{- |-serial replication--But you may also use it for a parallel replication, see 'replicateParallel'.--}-replicateControlled ::-   (Tuple.Undefined x, Tuple.Phi x) =>-   Param.T p Int -> T p (c,x) x -> T p (c,x) x-replicateControlled-      n (Cons next alloca start stop createIOContext deleteIOContext) =-   case Param.wordInt n of-      n32 -> Cons-         (\(len, cs) ->-            replicateControlledNext next stop (Param.valueTuple n32 len, cs))-         (-- we re-use the temporary variable for all stages)-          alloca)-         (\(len, param) ->-            replicateControlledStart start (Param.valueTuple n32 len, param))-         (\(len, cs) ->-            replicateControlledStop stop (Param.valueTuple n32 len, cs))-         (\p ->-            replicateControlledCreate $-               M.replicate (Param.get n p) (createIOContext p))-         (replicateControlledDelete deleteIOContext)--replicateControlledNext ::-   (Memory.C context, Memory.C state,-    contextState ~-       LLVM.Struct (Memory.Struct context, (Memory.Struct state, ())),-    Tuple.Phi z, Tuple.Phi a, Tuple.Undefined a) =>-   (forall z0. (Tuple.Phi z0) =>-    context -> local -> (ctrl, a) -> state ->-    MaybeCont.T r z0 (a, state)) ->-   (context -> state -> CodeGenFunction r ()) ->-   (Value Word, Value (LLVM.Ptr contextState)) ->-   local ->-   (ctrl, a) ->-   () ->-   MaybeCont.T r z (a, ())-replicateControlledNext next stop (len, contextStates) local (c,a) () =-   MaybeCont.fromMaybe $ fmap (\(_,ms) -> flip (,) () <$> ms) $-      MaybeCont.arrayLoop len contextStates a $-            \contextStatePtr a0 -> do-         (context, s0) <- MaybeCont.lift $ Memory.load contextStatePtr-         (a1,s1) <--            MaybeCont.onFail-               (replicateControlledStopExcept-                  stop len contextStates contextStatePtr) $-            next context local (c,a0) s0-         MaybeCont.lift $-            Memory.store s1 =<< LLVM.getElementPtr0 contextStatePtr (d1, ())-         return a1--replicateControlledStopExcept ::-   (Memory.C a, Memory.C b,-    ab ~ LLVM.Struct (Memory.Struct a, (Memory.Struct b, ()))) =>-   (a -> b -> CodeGenFunction r ()) ->-   Value Word ->-   Value (LLVM.Ptr ab) ->-   Value (LLVM.Ptr ab) ->-   CodeGenFunction r ()-replicateControlledStopExcept stop len contextStates contextStatePtr =-   C.arrayLoop len contextStates () $ \ptr () -> do-      b <- A.cmp LLVM.CmpNE ptr contextStatePtr-      C.ifThen b () $ uncurry stop =<< Memory.load ptr--_replicateControlledNext ::-   (Memory.C context, Memory.C state,-    contextState ~-       LLVM.Struct (Memory.Struct context, (Memory.Struct state, ())),-    Tuple.Phi z, Tuple.Phi a, Tuple.Undefined a) =>-   (forall z0. (Tuple.Phi z0) =>-    context -> (ctrl, a) -> state ->-    MaybeCont.T r z0 (a, state)) ->-   (Value Word, Value (LLVM.Ptr contextState)) ->-   (ctrl, a) ->-   () ->-   MaybeCont.T r z (a, ())-_replicateControlledNext next (len, contextStates) (c,a) () =-   fmap (flip (,) ()) $ MaybeCont.fromBool $ fmap snd $-   C.arrayLoopWithExit len contextStates (valueOf True, a) $-         \contextStatePtr (_,a0) -> do-      (context, s0) <- Memory.load contextStatePtr-      (cont, (a1,s1)) <- MaybeCont.toBool $ next context (c,a0) s0-      Memory.store s1 =<< LLVM.getElementPtr0 contextStatePtr (d1, ())-      return (cont, (cont,a1))--replicateControlledStart ::-   (Memory.C a, Memory.C b) =>-   (a -> CodeGenFunction r b) ->-   (Value Word, Value (LLVM.Ptr (Memory.Struct a))) ->-   CodeGenFunction r ((Value Word, Value (LLVM.Ptr (Memory.Struct b))), ())-replicateControlledStart start (len, params) = do-   contextStates <- LLVM.arrayMalloc len-   C.arrayLoop2 len params contextStates () $ \paramPtr statePtr () ->-      flip Memory.store statePtr =<< start =<< Memory.load paramPtr-   return ((len, contextStates), ())--replicateControlledStop ::-   (Memory.C a, Memory.C b,-    ab ~ LLVM.Struct (Memory.Struct a, (Memory.Struct b, ()))) =>-   (a -> b -> CodeGenFunction r ()) ->-   (Value Word, Value (LLVM.Ptr ab)) ->-   () ->-   CodeGenFunction r ()-replicateControlledStop stop (len, contextStates) () = do-   C.arrayLoop len contextStates () $ \contextStatePtr () ->-      uncurry stop =<< Memory.load contextStatePtr-   LLVM.free contextStates---replicateControlledCreate ::-   (Monad m, Marshal.C b, Marshal.Struct b ~ struct) =>-   m [(a, b)] ->-   m (([a], ForeignPtr.MemoryPtr struct), (Word, LLVM.Ptr struct))-replicateControlledCreate createIOContexts = do-   (ioContexts, params) <- M.lift unzip createIOContexts-   let len = length params-   let fptr = Unsafe.performIO $ do-         fptr0 <--            mallocForeignPtrBytes $ EE.sizeOfArray (proxyFromElement2 fptr) len-         ForeignPtr.with fptr0 $ flip EE.pokeList (fmap Marshal.pack params)-         return fptr0-   return ((ioContexts, fptr),-           (fromIntegral len,-            EE.castFromStoredPtr $ Unsafe.foreignPtrToPtr fptr))--replicateControlledDelete ::-   (a -> IO ()) ->-   ([a], ForeignPtr b) -> IO ()-replicateControlledDelete deleteIOContext (ioContexts, fptr) = do-   mapM_ deleteIOContext ioContexts-   touchForeignPtr fptr---instance Cat.Category (T p) where-   id = mapSimple return-   (.) = flip compose--instance Arr.Arrow (T p) where-   arr f = mapSimple (return . f)-   first = Causal.first---instance Functor (T p a) where-   fmap = ArrowUtil.map--instance Applicative (T p a) where-   pure = ArrowUtil.pure-   (<*>) = ArrowUtil.apply---instance (A.Additive b) => Additive.C (T p a b) where-   zero = pure A.zero-   negate = mapProc A.neg-   (+) = zipProcWith A.add-   (-) = zipProcWith A.sub--instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T p a b) where-   one = pure A.one-   fromInteger n = pure (A.fromInteger' n)-   (*) = zipProcWith A.mul--instance (A.Field b, A.RationalConstant b) => Field.C (T p a b) where-   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)-   (/) = zipProcWith A.fdiv---instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T p a b) where-   fromInteger n = pure (A.fromInteger' n)-   negate = mapProc A.neg-   (+) = zipProcWith A.add-   (-) = zipProcWith A.sub-   (*) = zipProcWith A.mul-   abs = mapProc A.abs-   signum = mapProc A.signum--instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T p a b) where-   fromRational x = pure (A.fromRational' x)-   (/) = zipProcWith A.fdiv---{- |-Not quite the loop of ArrowLoop-because we need a delay of one time step-and thus an initialization value.--For a real ArrowLoop.loop, that is a zero-delay loop,-we would formally need a MonadFix instance of CodeGenFunction.-But this will not become reality, since LLVM is not able to re-order code-in a way that allows to access a result before creating the input.--}-loop ::-   (Marshal.C c, Tuple.ValueOf c ~ cl) =>-   Param.T p c -> T p (a,cl) (b,cl) -> T p a b-loop initial (Cons next alloca start stop createIOContext deleteIOContext) =-   Param.withValue initial $ \getInitial valueInitial -> Cons-      (curry $ loopNext $ uncurry next)-      alloca-      (\(i,p) -> fmap (mapSnd ((,) (valueInitial i))) $ start p)-      (loopStop stop)-      (\p -> do-         (ctx, param) <- createIOContext p-         return (ctx, (getInitial p, param)))-      deleteIOContext--loopStop :: (context -> state -> m) -> context -> (c, state) -> m-loopStop stop ctx (_c,s) = stop ctx s---takeWhile ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (forall r. pl -> a -> CodeGenFunction r (Value Bool)) ->-   Param.T p ph ->-   T p a a-takeWhile check selectParam = simple-   (\p a () -> do-      MaybeCont.guard =<< MaybeCont.lift (check p a)-      return (a, ()))-   (\p -> return (p, ()))-   selectParam---take ::-   Param.T p Int ->-   T p a a-take len =-   snd ^<<-   Causal.takeWhile (A.cmp LLVM.CmpLT A.zero . fst) <<<-   feedFst-      (Sig.iterate (const A.dec) (return ())-         (Param.wordInt $ max 0 ^<< len))---{- |-The first output value is the initial value.-Thus 'integrate' delays by one sample compared with 'integrateSync'.--}-integrate ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.Additive al) =>-   Param.T p a ->-   T p al al-integrate =-   flip loop (arr snd &&& zipWithSimple A.add)--integrateSync ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.Additive al) =>-   Param.T p a ->-   T p al al-integrateSync =-   flip loop ((\a -> (a,a)) ^<< zipWithSimple A.add)
− src/Synthesizer/LLVM/CausalParameterized/ProcessValue.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{- |-This module provides functions similar to-"Synthesizer.LLVM.CausalParameterized.Process"-but expects functions that operate on 'Value.T'.-This way you can use common arithmetic operators-instead of LLVM assembly functions.--}-module Synthesizer.LLVM.CausalParameterized.ProcessValue (---   simple,-   mapAccum, map, mapSimple, zipWith, zipWithSimple,-   takeWhile,-   ) where--import Synthesizer.LLVM.CausalParameterized.ProcessPrivate (T)-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV-import qualified Synthesizer.LLVM.Simple.Value as Value--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory--import qualified LLVM.Core as LLVM--import Prelude hiding (map, zipWith, takeWhile)---{--simple ::-   (Storable startParamTuple,-    Storable nextParamTuple,-    Tuple.Value startParamTuple, Tuple.ValueOf startParamTuple ~ startParamValue,-    Tuple.Value nextParamTuple, Tuple.ValueOf nextParamTuple ~ nextParamValue,-    Memory.C startParamValue,-    Memory.C nextParamValue,-    Memory.C state) =>-   (Value.T nextParamValue ->-    Value.T a -> Value.T state -> Value.Maybe (Value.T b, Value.T state)) ->-   (Value.T startParamValue -> Value.T state) ->-   Param.T p nextParamTuple ->-   Param.T p startParamTuple -> T p a b-simple f start =-   CausalP.simple-      (\p a s ->-         Value.flattenMaybe $-         next-            (Value.constantValue p)-            (Value.constantValue a)-            (Value.constantValue s))-      (Value.unlift1 start)--}--map ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (Value.T pl -> Value.T a -> Value.T b) ->-   Param.T p ph ->-   T p a b-map f = CausalP.map (Value.unlift2 f)--mapSimple ::-   (Value.T a -> Value.T b) ->-   T p a b-mapSimple = CausalV.map--zipWith ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (Value.T pl -> Value.T a -> Value.T b -> Value.T c) ->-   Param.T p ph -> T p (a,b) c-zipWith f =-   CausalP.zipWith (Value.unlift3 f)--zipWithSimple ::-   (Value.T a -> Value.T b -> Value.T c) ->-   T p (a,b) c-zipWithSimple = CausalV.zipWith--mapAccum ::-   (Marshal.C pnh, Tuple.ValueOf pnh ~ pnl,-    Marshal.C psh, Tuple.ValueOf psh ~ psl,-    Memory.C s) =>-   (Value.T pnl -> Value.T a -> Value.T s -> (Value.T b, Value.T s)) ->-   (Value.T psl -> Value.T s) ->-   Param.T p pnh ->-   Param.T p psh ->-   T p a b-mapAccum next start =-   CausalP.mapAccum-      (Value.unlift3 next)-      (Value.unlift1 start)--takeWhile ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (Value.T pl -> Value.T a -> Value.T (LLVM.Value Bool)) ->-   Param.T p ph ->-   T p a a-takeWhile check =-   CausalP.takeWhile (Value.unlift2 check)
− src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-module Synthesizer.LLVM.CausalParameterized.RingBuffer (-   T, track, trackConst,-   index, oldest,-   ) where--import Synthesizer.LLVM.RingBuffer--import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Tuple as Tuple---{- |-@track initial time@ tracks the last @time@ sample values-including the current one.-The values before the actual input data are filled with @initial@.-The values can be accessed using 'index' with indices-ranging from 0 to @time@.--The @time@ parameter must be non-negative.--The initial value is also needed for determining the ring buffer element type.--}-track ::-   (Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> Param.T p Int -> CausalP.T p al (T al)-track initial time =-   Param.withValue initial $ \getInitial valueInitial ->-   Param.withValue (Param.wordInt time) $ \getTime valueTime ->-      CausalP.Cons-         (trackNext valueTime)-         (return ())-         (\(x, size) -> trackStart valueTime (valueInitial x, size))-         trackStop-         (trackCreate getInitial getTime)-         trackDelete--{- |-Initialize with zero without the need of a Haskell zero value.--We cannot get rid of the type 'a' so easily,-because we need its Storable instance-for allocating the buffer on the Haskell side.--}-trackConst :: (Memory.C al) => al -> Param.T p Int -> CausalP.T p al (T al)-trackConst initial time =-   Param.withValue (Param.wordInt time) $ \getTime valueTime ->-      CausalP.Cons-         (trackNext valueTime)-         (return ())-         (\size -> trackStart valueTime (initial, size))-         trackStop-         (trackConstCreate getTime)-         trackDelete
− src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs 
@@ -1,295 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.CausalParameterized.RingBufferForward (-   T, track, trackSkip, trackSkipHold,-   index,-   ) where--import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate-                                                              as CausalPrivP-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*))-import Synthesizer.LLVM.RingBuffer (MemoryPtr)--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Maybe as Maybe-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple--import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value)--import Control.Arrow ((<<<))-import Control.Applicative (pure)-import Data.Tuple.HT (mapSnd)--import Data.Word (Word)--import Prelude hiding (length)---{- |-This type is very similar to 'Synthesizer.LLVM.RingBuffer.T'-but differs in several details:--* It stores values in time order,-  whereas 'Synthesizer.LLVM.RingBuffer.T' stores in opposite order.--* Since it stores future values it is not causal-  and can only track signal generators.--* There is no need for an initial value.--* It stores one value less than 'Synthesizer.LLVM.RingBuffer.T'-  since it is meant to provide infixes of the signal-  rather than providing the basis for a delay line.--Those differences in detail would not justify a new type,-you could achieve the same by a combination of-'Synthesizer.LLVM.RingBuffer.track'-and-'Synthesizer.LLVM.CausalParameterized.Process.skip'.-The fundamental problem of this combination is-that it requires to keep the ring buffer alive-longer than the providing signal exists.-This is not possible with the current design.-That's why we provide the combination of @track@ and @skip@-in a way that does not suffer from that problem.-This functionality is critical for-'Synthesizer.LLVM.CausalParameterized.Helix.dynamic'.--}-data T a =-   Cons {-      buffer :: Value (MemoryPtr a),-      length :: Value Word,-      current :: Value Word-   }--{- |-This function does not check for range violations.-If the ring buffer was generated by @track time@,-then the minimum index is zero and the maximum index is @time-1@.-Index zero refers to the current sample-and index @time-1@ refers to the one that is farthermost in the future.--}-index :: (Memory.C a) => Value Word -> T a -> CodeGenFunction r a-index i rb = do-   k <- flip A.irem (length rb) =<< A.add (current rb) i-   Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())---{- |-@track time signal@ bundles @time@ successive values of @signal@.-The values can be accessed using 'index' with indices-ranging from 0 to @time-1@.--The @time@ parameter must be non-negative.--}-track :: (Memory.C a) => Param.T p Int -> SigP.T p a -> SigP.T p (T a)-track time input = trackSkip time input $* 1--{- |-@trackSkip time input $* skips@-is like-@Process.skip (track time input) $* skips@-but this composition would require a @Memory@ constraint for 'T'-which we cannot provide.--}-trackSkip ::-   (Memory.C a) =>-   Param.T p Int -> SigP.T p a -> CausalP.T p (Value Word) (T a)-trackSkip time (SigP.Cons next alloca start stop create delete) =-   Param.withValue (Param.wordInt time) $ \getTime valueTime ->-      CausalPrivP.Cons-         (trackNext next valueTime)-         alloca-         (trackStart start valueTime)-         (trackStop stop)-         (trackCreate create getTime)-         (trackDelete delete)--{- |-Like @trackSkip@ but repeats the last buffer content-when the end of the input signal is reached.-The returned 'Bool' flag is 'True' if a skip could be performed completely-and it is 'False' if the skip exceeds the end of the input.-That is, once a 'False' is returned all following values are tagged with 'False'.-The returned 'Word' value is the number of actually skipped values.-This lags one step behind the input of skip values.-The number of an actual number of skips-is at most the number of requested skips.-If the flag is 'False', then the number of actual skips is zero.-The converse does not apply.--If the input signal is too short, the output is undefined.-(Before the available data the buffer will be filled with arbitrary values.)-We could fill the buffer with zeros,-but this would require an Arithmetic constraint-and the generated signal would not be very meaningful.-We could also return an empty signal if the input is too short.-However this would require a permanent check.--}-trackSkipHold, trackSkipHold_ ::-   (Memory.C a) =>-   Param.T p Int -> SigP.T p a ->-   CausalP.T p (Value Word) ((Value Bool, Value Word), T a)-trackSkipHold time xs =-   (CausalP.zipWithSimple-       (\b ((c,x), buf) -> do-          y <- C.select b x A.zero-          return ((c, y), buf))-      $< (CausalP.delay1 (pure False) $* SigP.constant (pure True)))-{--   (CausalPV.zipWithSimple (\b ((c,x), buf) -> ((c, b ?? (x,0)), buf))-      $< (CausalP.delay1 (pure False) $* SigP.constant (pure True)))--}-   <<<-   trackSkipHold_ time xs--trackSkipHold_ time (SigP.Cons next alloca start stop create delete) =-   (Param.withValue (Param.wordInt time) $ \getTime valueTime ->-      CausalPrivP.Cons-         (trackNextHold next valueTime)-         alloca-         (trackStartHold start valueTime)-         (trackStopHold stop)-         (trackCreate create getTime)-         (trackDelete delete))---trackNext ::-   (Memory.C al, Tuple.Phi z,-    Tuple.Phi state, Tuple.Undefined state) =>-   (forall z0. (Tuple.Phi z0) =>-    context -> local -> state -> MaybeCont.T r z0 (al, state)) ->-   (tl -> Value Word) ->-   (context, (tl, Value (MemoryPtr al))) -> local ->-   Value Word ->-   (Value Word, (state, Value Word)) ->-   MaybeCont.T r z (T al, (Value Word, (state, Value Word)))-trackNext next valueTime (context, (size,ptr)) local n1 (n0, statePos) = do-   let size0 = valueTime size-   (state3, pos3) <--      MaybeCont.fromMaybe $ fmap snd $-      MaybeCont.fixedLengthLoop n0 statePos $ \(state0, pos0) -> do-         (a, state1) <- next context local state0-         MaybeCont.lift $-            fmap ((,) state1) $ storeNext (size0,ptr) a pos0-   return (Cons ptr size0 pos3, (n1, (state3, pos3)))--trackStart ::-   (LLVM.IsSized am, Tuple.Phi state, Tuple.Undefined state) =>-   (param -> CodeGenFunction r (context, state)) ->-   (tl -> Value Word) ->-   (param, tl) ->-   CodeGenFunction r-      ((context, (tl, Value (LLVM.Ptr am))),-       (Value Word, (state, Value Word)))-trackStart start valueTime (param, size) = do-   (context, state) <- start param-   let size0 = valueTime size-   ptr <- LLVM.arrayMalloc size0-   return ((context, (size,ptr)), (size0, (state, A.zero)))--trackStop ::-   (LLVM.IsType am) =>-   (context -> state -> CodeGenFunction r ()) ->-   (context, (tl, Value (LLVM.Ptr am))) ->-   (Value Word, (state, Value Word)) ->-   CodeGenFunction r ()-trackStop stop (context, (_size,ptr)) (_n, (state, _remain)) = do-   LLVM.free ptr-   stop context state---trackNextHold ::-   (Memory.C al, Tuple.Phi z,-    Tuple.Phi state, Tuple.Undefined state) =>-   (forall z0. (Tuple.Phi z0) =>-    context -> local -> state -> MaybeCont.T r z0 (al, state)) ->-   (tl -> Value Word) ->-   (context, (tl, Value (MemoryPtr al))) -> local ->-   Value Word ->-   (Value Word, (Maybe.T state, Value Word)) ->-   MaybeCont.T r z-      (((Value Bool, Value Word), T al),-       (Value Word, (Maybe.T state, Value Word)))-trackNextHold-   next valueTime (context, (size,ptr)) local nNext (n0, (mstate0, pos0)) =-      MaybeCont.lift $ do-   let size0 = valueTime size-   (n3, (pos3, state3)) <--      Maybe.run mstate0-         (return (n0, (pos0, mstate0)))-         (\state0 ->-            Maybe.loopWithExit (n0, (state0, pos0))-               (\(n1, (state1, pos1)) -> do-                  cont <- A.cmp LLVM.CmpGT n1 A.zero-                  fmap (mapSnd ((,) n1 . (,) pos1)) $-                     C.ifThen cont-                        (Maybe.nothing, Maybe.just state1)-                        (do aState <--                              MaybeCont.toMaybe $ next context local state1-                            return (aState, fmap snd aState)))-               (\((a,state), (n1, (pos1, _mstate))) -> do-                  pos2 <- storeNext (size0,ptr) a pos1-                  n2 <- A.dec n1-                  return (n2, (state, pos2))))-   skipped <- A.sub n0 n3-   return (((Maybe.isJust state3, skipped), Cons ptr size0 pos3),-           (nNext, (state3, pos3)))--storeNext ::-   (Memory.C al) =>-   (Value Word, Value (MemoryPtr al)) ->-   al -> Value Word -> CodeGenFunction r (Value Word)-storeNext (size0,ptr) a pos0 = do-   Memory.store a =<< LLVM.getElementPtr ptr (pos0, ())-   pos1 <- A.inc pos0-   cont <- A.cmp LLVM.CmpLT pos1 size0-   C.select cont pos1 A.zero---trackStartHold ::-   (LLVM.IsSized am,-    Tuple.Phi state, Tuple.Undefined state) =>-   (param -> CodeGenFunction r (context, state)) ->-   (tl -> Value Word) ->-   (param, tl) ->-   CodeGenFunction r-      ((context, (tl, Value (LLVM.Ptr am))),-       (Value Word, (Maybe.T state, Value Word)))-trackStartHold start valueTime (param, size) = do-   (context, state) <- start param-   let size0 = valueTime size-   ptr <- LLVM.arrayMalloc size0-   return ((context, (size,ptr)), (size0, (Maybe.just state, A.zero)))--trackStopHold ::-   (LLVM.IsType am) =>-   (context -> state -> CodeGenFunction r ()) ->-   (context, (tl, Value (LLVM.Ptr am))) ->-   (Value Word, (Maybe.T state, Value Word)) ->-   CodeGenFunction r ()-trackStopHold stop (context, (_size,ptr)) (_n, (state, _remain)) = do-   LLVM.free ptr-   Maybe.for state $ stop context---trackCreate ::-   (p -> IO (ioContext, param)) ->-   (p -> t) ->-   p ->-   IO (ioContext, (param, t))-trackCreate create getTime p = do-   (context, param) <- create p-   return (context, (param, getTime p))--trackDelete :: (ioContext -> IO ()) -> ioContext -> IO ()-trackDelete = id
src/Synthesizer/LLVM/Complex.hs view
@@ -3,25 +3,28 @@ module Synthesizer.LLVM.Complex (    Complex.T(Complex.real, Complex.imag),    Struct,-   (Complex.+:),+   (+:),    Complex.cis,    Complex.scale,    constOf, unfold,    ) where -import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Value as Value +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM import LLVM.Core (Value, ConstValue, IsConst) -import qualified Type.Data.Num.Decimal      as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum  import Control.Applicative (liftA2)  import qualified Number.Complex as Complex+import Number.Complex ((+:))   type Struct a = LLVM.Struct (a, (a, ()))@@ -38,16 +41,16 @@    Value (Struct a) -> Complex.T (Value.T (Value a)) unfold x =    Value.lift0 (LLVM.extractvalue x TypeNum.d0)-   Complex.+:+   +:    Value.lift0 (LLVM.extractvalue x TypeNum.d1)   instance (Tuple.Undefined a) => Tuple.Undefined (Complex.T a) where-   undef = (Complex.+:) Tuple.undef Tuple.undef+   undef = Tuple.undef +: Tuple.undef  instance (Tuple.Phi a) => Tuple.Phi (Complex.T a) where    phi bb v =-      liftA2 (Complex.+:)+      liftA2 (+:)          (Tuple.phi bb (Complex.real v))          (Tuple.phi bb (Complex.imag v))    addPhi bb x y = do@@ -59,7 +62,7 @@    (Memory.C l) =>    Memory.Record r (Struct (Memory.Struct l)) (Complex.T l) memory =-   liftA2 (Complex.+:)+   liftA2 (+:)       (Memory.element Complex.real TypeNum.d0)       (Memory.element Complex.imag TypeNum.d1) @@ -69,3 +72,36 @@    store = Memory.storeRecord memory    decompose = Memory.decomposeRecord memory    compose = Memory.composeRecord memory++++instance (MultiValue.C a) => MultiValue.C (Complex.T a) where+   type Repr (Complex.T a) = Complex.T (MultiValue.Repr a)+   cons x =+      consMV+         (MultiValue.cons $ Complex.real x)+         (MultiValue.cons $ Complex.imag x)+   undef = consMV MultiValue.undef MultiValue.undef+   zero = consMV MultiValue.zero MultiValue.zero+   phi bb a =+      case deconsMV a of+         (a0,a1) -> liftA2 consMV (MultiValue.phi bb a0) (MultiValue.phi bb a1)+   addPhi bb a b =+      case (deconsMV a, deconsMV b) of+         ((a0,a1), (b0,b1)) ->+            MultiValue.addPhi bb a0 b0 >> MultiValue.addPhi bb a1 b1++consMV :: MultiValue.T a -> MultiValue.T a -> MultiValue.T (Complex.T a)+consMV (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a+:b)++deconsMV :: MultiValue.T (Complex.T a) -> (MultiValue.T a, MultiValue.T a)+deconsMV (MultiValue.Cons x) =+   (MultiValue.Cons $ Complex.real x, MultiValue.Cons $ Complex.imag x)+++instance (Marshal.C a) => Marshal.C (Complex.T a) where+   pack x =+      LLVM.consStruct+         (Marshal.pack $ Complex.real x)+         (Marshal.pack $ Complex.imag x)+   unpack = LLVM.uncurryStruct $ \a b -> Marshal.unpack a +: Marshal.unpack b
src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -10,24 +10,15 @@    Struct,    parameterMemory,    flatten,-   piecewiseConstant,-   lazySize,+   causalMap,    ) where -import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP-import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig--import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt-import qualified Data.StorableVector.Lazy.Pattern as SVP--import qualified Synthesizer.LLVM.EventIterator as EventIt-import qualified Data.EventList.Relative.BodyTime as EventList-import qualified Numeric.NonNegative.Wrapper as NonNeg+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Private as Sig -import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Expression as Expr  import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A@@ -38,9 +29,10 @@  import Type.Data.Num.Decimal (d0, d1) +import Data.Tuple.HT (mapSnd) import Data.Word (Word) -import Control.Applicative (liftA2)+import Control.Applicative (liftA2, (<$>))  import NumericPrelude.Numeric () import NumericPrelude.Base@@ -48,6 +40,9 @@  data T a = Cons (Value Word) a +instance Functor T where+   fmap f (Cons len y) = Cons len (f y)+ instance (Tuple.Phi a) => Tuple.Phi (T a) where    phi bb (Cons len y) =       liftA2 Cons (Tuple.phi bb len) (Tuple.phi bb y)@@ -78,69 +73,24 @@    compose = Memory.composeRecord parameterMemory  -flatten ::-   (Sig.C signal, Memory.C value) =>-   signal (T value) ->-   signal value-flatten = Sig.alter (\(Sig.Core next start stop) ->-   Sig.Core-      (\context state0 -> do+causalMap ::+   (Expr.Aggregate a am, Expr.Aggregate b bm) =>+   (a -> b) -> Causal.T (T am) (T bm)+causalMap f = Causal.map (\(Cons len y) -> Cons len <$> Expr.unliftM1 f y)+++flatten :: (Memory.C a) => Sig.T (T a) -> Sig.T a+flatten (Sig.Cons next start stop) =+   Sig.Cons+      (\global local state0 -> do          ~(Cons length1 y1, s1) <-             Maybe.fromBool $             whileLoop (valueOf True, state0)                (\(cont, (Cons len _y, _s)) ->                   LLVM.and cont =<< A.cmp LLVM.CmpEQ len A.zero)                (\(_cont, (Cons _len _y, s)) ->-                  Maybe.toBool $ next context s)+                  Maybe.toBool $ next global local s)          length2 <- Maybe.lift (A.dec length1)          return (y1, (Cons length2 y1, s1)))-      (fmap ((,) (Cons A.zero Tuple.undef)) . start)-      (stop . snd))---piecewiseConstant ::-   (Marshal.C a, Tuple.ValueOf a ~ value, Marshal.Struct a ~ struct) =>-   Param.T p (EventList.T NonNeg.Int a) ->-   SigP.T p (T value)-piecewiseConstant evs = SigP.Cons-   (\stable yPtr () -> do-      len <- Maybe.lift $ do-         nextFn <--            LLVM.staticNamedFunction-               "ConstantPiece.piecewiseConstant.nextChunk"-               EventIt.nextCallBack-         LLVM.call nextFn stable yPtr-      Maybe.guard =<<-         Maybe.lift (A.cmp LLVM.CmpNE len A.zero)-      y <- Maybe.lift $ Memory.load yPtr-      return (Cons len y, ()))-   LLVM.alloca-   return-   (const $ const $ return ())-   (\p -> do-      stable <- EventIt.new (Param.get evs p)-      return (stable, (stable, ())))-   EventIt.dispose---lazySize ::-   Param.T p SVP.LazySize ->-   SigP.T p (T ())-lazySize size = SigP.Cons-   (\stable () () -> do-      len <- Maybe.lift $ do-         nextFn <--            LLVM.staticNamedFunction-               "ConstantPiece.lazySize.nextChunk"-               SizeIt.nextCallBack-         LLVM.call nextFn stable-      Maybe.guard =<<-         Maybe.lift (A.cmp LLVM.CmpNE len A.zero)-      return (Cons len (), ()))-   (return ())-   return-   (const $ const $ return ())-   (\p -> do-      stable <- SizeIt.new (Param.get size p)-      return (stable, (stable, ())))-   SizeIt.dispose+      (mapSnd ((,) (Cons A.zero Tuple.undef)) <$> start)+      stop
src/Synthesizer/LLVM/EventIterator.hs view
@@ -6,7 +6,7 @@ import qualified Data.EventList.Relative.BodyTime as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg -import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal import qualified LLVM.Core as LLVM  import Foreign.StablePtr@@ -28,10 +28,10 @@ type MarshalPtr a = LLVM.Ptr (Marshal.Struct a)  -foreign import ccall "&nextConstant"+foreign import ccall "&nextConstantExp"    nextCallBack :: FunPtr (StablePtr (T a) -> MarshalPtr a -> IO Word) -foreign export ccall "nextConstant"+foreign export ccall "nextConstantExp"    next :: StablePtr (T a) -> MarshalPtr a -> IO Word
src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -8,30 +8,28 @@ {-# LANGUAGE DeriveTraversable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Allpass (-   Parameter, parameter,-   CascadeParameter, flangerParameter, flangerParameterPlain,+   Parameter, Allpass.parameter,+   CascadeParameter(CascadeParameter), flangerParameter,+   cascadeParameterMultiValue, cascadeParameterUnMultiValue,    causal, cascade, phaser,    cascadePipeline, phaserPipeline,    causalPacked, cascadePacked, phaserPacked,--   causalP, cascadeP, phaserP,-   causalPackedP, cascadePackedP, phaserPackedP,    ) where  import Synthesizer.Plain.Filter.Recursive.Allpass (Parameter(Parameter)) import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 -import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F-import qualified Synthesizer.LLVM.Causal.ProcessValue as CausalV+import qualified Synthesizer.LLVM.Causal.Private as CausalPriv import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Functional as F+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial +import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Vector as Vector@@ -41,8 +39,6 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction)  import qualified Type.Data.Num.Decimal as TypeNum import Type.Base.Proxy (Proxy(Proxy))@@ -55,9 +51,10 @@  import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold-import Data.Tuple.HT (mapPair)+import Data.Tuple.HT (mapFst)  import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module as Module  import NumericPrelude.Numeric import NumericPrelude.Base@@ -73,6 +70,14 @@ instance Tuple.Zero a => Tuple.Zero (Parameter a) where    zero = Tuple.zeroPointed +instance+   (Expr.Aggregate e mv) =>+      Expr.Aggregate (Parameter e) (Parameter mv) where+   type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e)+   type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)+   bundle = Trav.traverse Expr.bundle+   dissect = fmap Expr.dissect+ instance (Memory.C a) => Memory.C (Parameter a) where    type Struct (Parameter a) = Memory.Struct a    load = Memory.loadNewtype Parameter@@ -84,19 +89,15 @@    pack (Parameter k) = Marshal.pack k    unpack = Parameter . Marshal.unpack +instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where+   pack (Parameter k) = MarshalMV.pack k+   unpack = Parameter . MarshalMV.unpack+ instance (Storable.C a) => Storable.C (Parameter a) where    load = Storable.loadNewtype Parameter Parameter    store = Storable.storeNewtype Parameter (\(Parameter k) -> k)  -{--instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)--instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where-   tupleDesc = Class.tupleDescFoldable--}- instance (Tuple.Value a) => Tuple.Value (Parameter a) where    type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a)    valueOf = Tuple.valueOfFunctor@@ -106,6 +107,7 @@    vectorValueOf = fmap Tuple.vectorValueOf . Trav.sequenceA  instance (MultiValue.C a) => MultiValue.C (Allpass.Parameter a) where+   type Repr (Parameter a) = Parameter (MultiValue.Repr a)    cons = paramFromPlainValue . MultiValue.cons . Allpass.getParameter     undef = paramFromPlainValue MultiValue.undef@@ -121,6 +123,7 @@          (plainFromParamValue b)  instance (MultiVector.C a) => MultiVector.C (Allpass.Parameter a) where+   type Repr n (Parameter a) = Parameter (MultiVector.Repr n a)    cons = paramFromPlainVector . MultiVector.cons . fmap Allpass.getParameter    undef = paramFromPlainVector MultiVector.undef    zero = paramFromPlainVector MultiVector.zero@@ -171,12 +174,6 @@    MultiValue.lift1 Allpass.getParameter  -instance (Value.Flatten a) => Value.Flatten (Parameter a) where-   type Registers (Parameter a) = Parameter (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable-- instance (Vector.Simple v) => Vector.Simple (Parameter v) where    type Element (Parameter v) = Parameter (Vector.Element v)    type Size (Parameter v) = Vector.Size v@@ -191,12 +188,6 @@    makeArgs = id  -parameter ::-   (A.Transcendental a, A.RationalConstant a) =>-   a -> a -> CodeGenFunction r (Parameter a)-parameter = Value.unlift2 Allpass.parameter-- newtype CascadeParameter n a =    CascadeParameter (Allpass.Parameter a)       deriving@@ -219,19 +210,15 @@    pack (CascadeParameter k) = Marshal.pack k    unpack = CascadeParameter . Marshal.unpack +instance (MarshalMV.C a) => MarshalMV.C (CascadeParameter n a) where+   pack (CascadeParameter k) = MarshalMV.pack k+   unpack = CascadeParameter . MarshalMV.unpack+ instance (Storable.C a) => Storable.C (CascadeParameter n a) where    load = Storable.loadNewtype CascadeParameter id    store = Storable.storeNewtype CascadeParameter id  -{--instance LLVM.ValueTuple a => LLVM.ValueTuple (CascadeParameter n a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)--instance LLVM.IsTuple a => LLVM.IsTuple (CascadeParameter n a) where-   tupleDesc = Class.tupleDescFoldable--}- instance (Tuple.Value a) => Tuple.Value (CascadeParameter n a) where    type ValueOf (CascadeParameter n a) = Parameter (Tuple.ValueOf a)    valueOf (CascadeParameter a) = Tuple.valueOf a@@ -245,6 +232,7 @@       fmap Tuple.vectorValueOf . Trav.traverse (\(CascadeParameter k) -> k)  instance (MultiValue.C a) => MultiValue.C (CascadeParameter n a) where+   type Repr (CascadeParameter n a) = Parameter (MultiValue.Repr a)    cons (CascadeParameter a) = cascadeFromParamValue $ MultiValue.cons a     undef = cascadeFromParamValue MultiValue.undef@@ -259,7 +247,8 @@          (paramFromCascadeValue a)          (paramFromCascadeValue b) -instance (MultiVector.C a) => MultiVector.C (CascadeParameter n a) where+instance (MultiVector.C a) => MultiVector.C (CascadeParameter m a) where+   type Repr n (CascadeParameter m a) = Parameter (MultiVector.Repr n a)    cons =       cascadeFromParamVector . MultiVector.cons .       fmap (\(CascadeParameter a) -> a)@@ -308,12 +297,7 @@    MultiValue.T (Allpass.Parameter a) paramFromCascadeValue = MultiValue.lift1 id -instance (Value.Flatten a) => Value.Flatten (CascadeParameter n a) where-   type Registers (CascadeParameter n a) = CascadeParameter n (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable - instance (Vector.Simple v) => Vector.Simple (CascadeParameter n v) where    type Element (CascadeParameter n v) = CascadeParameter n (Vector.Element v)    type Size (CascadeParameter n v) = Vector.Size v@@ -328,76 +312,64 @@    makeArgs = id  -flangerParameter ::-   (A.Transcendental a, A.RationalConstant a, TypeNum.Natural n) =>-   Proxy n -> a ->-   CodeGenFunction r (CascadeParameter n a)-flangerParameter order =-   Value.unlift1 (flangerParameterPlain order)+instance+   (Expr.Aggregate e mv, n ~ m) =>+      Expr.Aggregate (CascadeParameter n e) (CascadeParameter m mv) where+   type MultiValuesOf (CascadeParameter n e) =+            CascadeParameter n (Expr.MultiValuesOf e)+   type ExpressionsOf (CascadeParameter m mv) =+            CascadeParameter m (Expr.ExpressionsOf mv)+   bundle = Trav.traverse Expr.bundle+   dissect = fmap Expr.dissect -flangerParameterPlain ::++flangerParameter ::    (Trans.C a, TypeNum.Natural n) =>    Proxy n -> a -> CascadeParameter n a-flangerParameterPlain order freq =+flangerParameter order freq =    CascadeParameter $    Allpass.flangerParameter (TypeNum.integralFromProxy order) freq  -modifier ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>-   Modifier.Simple-      -- (Allpass.State (Value.T v))-      (Value.T v, Value.T v)-      (Parameter (Value.T a))-      (Value.T v) (Value.T v)-modifier =-   Allpass.firstOrderModifier--{--For Allpass cascade you may use the 'Causal.pipeline' function.--} causal ::-   (Causal.C process,-    A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>-   process (Parameter a, v) v-causal =-   Causal.fromModifier modifier+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) =>+   Causal.T (Parameter a, v) v+causal = Causal.fromModifier Allpass.firstOrderModifier   replicateStage ::-   (Causal.C process,-    TypeNum.Natural n, Tuple.Phi b, Tuple.Undefined b) =>+   (TypeNum.Natural n) =>+   (Tuple.Phi a, Tuple.Undefined a) =>+   (Tuple.Phi b, Tuple.Undefined b) =>    Proxy n ->-   process (Parameter a, b) b ->-   process (CascadeParameter n a, b) b+   Causal.T (Parameter a, b) b ->+   Causal.T (CascadeParameter n a, b) b replicateStage order stg =    Causal.replicateControlled       (TypeNum.integralFromProxy order)       (stg <<< first (arr (\(CascadeParameter p) -> p)))  cascade ::-   (Causal.C process,-    A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,-    TypeNum.Natural n) =>-   process (CascadeParameter n a, v) v-cascade =-   replicateStage Proxy causal+   (TypeNum.Natural n) =>+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) =>+   (Tuple.Phi a, Tuple.Undefined a) =>+   (Tuple.Phi v, Tuple.Undefined v) =>+   Causal.T (CascadeParameter n a, v) v+cascade = replicateStage Proxy causal  halfVector ::-   (Causal.C process, A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) =>-   process v v-halfVector = CausalV.map (Value.fromRational' 0.5 *>)+   (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) =>+   Causal.T v v+halfVector = CausalPriv.map (A.scale $ A.fromRational' 0.5)  phaser ::-   (Causal.C process,-    A.RationalConstant a, A.RationalConstant v,-    a ~ A.Scalar v, A.PseudoModule v, Memory.C v,-    TypeNum.Natural n) =>-   process (CascadeParameter n a, v) v-phaser =-   Causal.mix <<<-   cascade &&& arr snd <<<-   second halfVector+   (TypeNum.Natural n) =>+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) =>+   (Tuple.Phi a, Tuple.Undefined a) =>+   (Tuple.Phi v, Tuple.Undefined v) =>+   (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) =>+   Causal.T (CascadeParameter n a, v) v+phaser = (cascade + arr snd) <<< second halfVector   paramFromCascadeParam ::@@ -411,12 +383,11 @@ but LLVM-2.6 does not yet do it. -} stage ::-   (Causal.C process,-    TypeNum.Positive n, MultiVector.C a,+   (TypeNum.Positive n, MultiVector.C a,     MultiVector.T n (CascadeParameter n a, a) ~ v,     MultiValue.PseudoRing a, MultiValue.IntegerConstant a,-    Marshal.C a) =>-   Proxy n -> process v v+    MarshalMV.C a) =>+   Proxy n -> Causal.T v v stage _ =    Causal.vectorize $       uncurry MultiValue.zip@@ -432,8 +403,8 @@       MultiValue.unzip  withSize ::-   (Proxy n -> process (MultiValue.T (CascadeParameter n a), b) c) ->-   process (MultiValue.T (CascadeParameter n a), b) c+   (Proxy n -> Causal.T (mv (CascadeParameter n a), b) c) ->+   Causal.T (mv (CascadeParameter n a), b) c withSize f = f Proxy  {- |@@ -443,12 +414,11 @@ and we get a delay by the number of pipeline stages. -} cascadePipeline ::-   (Causal.C process,-    TypeNum.Positive n, MultiVector.C a,+   (TypeNum.Positive n, MultiVector.C a,     Tuple.ValueOf a ~ ar,     MultiValue.PseudoRing a, MultiValue.IntegerConstant a,-    Marshal.C a, Marshal.Vector n a) =>-   process+    MarshalMV.C a, MarshalMV.Vector n a) =>+   Causal.T       (MultiValue.T (CascadeParameter n a), MultiValue.T a)       (MultiValue.T a) cascadePipeline = withSize $ \order ->@@ -459,148 +429,82 @@    uncurry MultiValue.zip  vectorId ::-   (Causal.C process) =>-   Proxy n -> process (MultiVector.T n a) (MultiVector.T n a)+   Proxy n -> Causal.T (MultiVector.T n a) (MultiVector.T n a) vectorId _ = Cat.id  half ::-   (Causal.C process, A.RationalConstant a, A.PseudoRing a) =>-   process a a-half = CausalV.map (Value.fromRational' 0.5 *)---multiValue ::-   (Tuple.ValueOf a ~ LLVM.Value a) =>-   LLVM.Value a -> MultiValue.T a-multiValue = MultiValue.Cons--unmultiValue ::-   (Tuple.ValueOf a ~ LLVM.Value a) =>-   MultiValue.T a -> LLVM.Value a-unmultiValue (MultiValue.Cons a) = a--multiCascadeParam ::-   (Tuple.ValueOf a ~ LLVM.Value a) =>-   CascadeParameter n (LLVM.Value a) ->-   MultiValue.T (CascadeParameter n a)-multiCascadeParam (CascadeParameter a) =-   MultiValue.Cons a--phaserPipeline ::-   (Causal.C process,-    TypeNum.Positive n,-    MultiValue.PseudoRing a, MultiValue.RationalConstant a,-    Marshal.C a, Marshal.Vector n a, MultiVector.C a,-    Tuple.ValueOf a ~ LLVM.Value a) =>-   process-      (CascadeParameter n (LLVM.Value a), LLVM.Value a)-      (LLVM.Value a)-phaserPipeline =-   unmultiValue-   ^<<-   phaserPipelineMulti-   <<^-   mapPair (multiCascadeParam, multiValue)---phaserPipelineMulti ::-   (Causal.C process,-    TypeNum.Positive n,-    MultiValue.PseudoRing a, MultiValue.RationalConstant a,-    Marshal.C a, Marshal.Vector n a, MultiVector.C a) =>-   process-      (MultiValue.T (CascadeParameter n a), MultiValue.T a)-      (MultiValue.T a)-phaserPipelineMulti = withSize $ \order ->-   Causal.mix <<<-   cascadePipeline &&&-   (Causal.pipeline (vectorId order) <<^ snd) <<<---   (Causal.delay (const zero) (const $ TypeNum.integralFromProxy order) <<^ snd) <<<-   second half+   (A.RationalConstant a, A.PseudoRing a) =>+   Causal.T a a+half = CausalPriv.map (A.mul (A.fromRational' 0.5))   causalPacked,   causalNonRecursivePacked ::-   (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) v+   (Serial.Write v, Serial.Element v ~ a,+    A.PseudoRing a, A.IntegerConstant a, Memory.C a,+    A.PseudoRing v, A.IntegerConstant v) =>+   Causal.T (Parameter a, v) v  causalPacked =    Filt1L.causalRecursivePacked <<<-   (Causal.map-       (\(Parameter k, _) ->-           fmap Filt1.Parameter $ A.neg k) &&&+   (CausalPriv.map (\(Parameter k, _) -> fmap Filt1.Parameter $ A.neg k) &&&     causalNonRecursivePacked)  causalNonRecursivePacked =-   Causal.mapAccum+   CausalPriv.mapAccum       (\(Parameter k, v0) x1 -> do          (_,v1) <- Serial.shiftUp x1 v0          y <- A.add v1 =<< A.mul v0 =<< Serial.upsample k-         let size = fromIntegral $ Serial.size v0-         u0 <- Serial.extract (LLVM.valueOf $ size - 1) v0+         u0 <- Serial.last v0          return (y, u0))       (return A.zero)  cascadePacked, phaserPacked ::-   (Causal.C process,-    TypeNum.Natural n,-    Serial.C v, Serial.Element v ~ a,+   (TypeNum.Natural n,+    Serial.Write v, Serial.Element v ~ a,     A.PseudoRing a, A.IntegerConstant a, Memory.C a,     A.PseudoRing v, A.RationalConstant v) =>-   process (CascadeParameter n a, v) v-cascadePacked =-   replicateStage Proxy causalPacked+   Causal.T (CascadeParameter n a, v) v+cascadePacked = replicateStage Proxy causalPacked  phaserPacked =-   Causal.mix <<<-   cascadePacked &&& arr snd <<<-   second (Causal.map (A.mul (A.fromRational' 0.5)))---+   (cascadePacked + arr snd) <<<+   second (CausalPriv.map (A.mul (A.fromRational' 0.5)))  -causalP ::-   (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>-   CausalP.T p (Parameter a, v) v-causalP = causal--cascadeP ::-   (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,-    TypeNum.Natural n) =>-   CausalP.T p (CascadeParameter n a, v) v-cascadeP = cascade+-- ToDo: consistent naming with Exponential2+cascadeParameterMultiValue ::+   CascadeParameter n (MultiValue.T a) ->+   MultiValue.T (CascadeParameter n a)+cascadeParameterMultiValue (CascadeParameter k) =+   MultiValue.Cons $ fmap (\(MultiValue.Cons a) -> a) k -phaserP ::-   (A.RationalConstant a, A.RationalConstant v,-    a ~ A.Scalar v, A.PseudoModule v, Memory.C v,-    TypeNum.Natural n) =>-   CausalP.T p (CascadeParameter n a, v) v-phaserP = phaser+cascadeParameterUnMultiValue ::+   MultiValue.T (CascadeParameter n a) ->+   CascadeParameter n (MultiValue.T a)+cascadeParameterUnMultiValue (MultiValue.Cons k) =+   CascadeParameter $ fmap MultiValue.Cons k  -causalPackedP ::-   (Serial.C v, Serial.Element v ~ a,-    Memory.C a, A.IntegerConstant a,-    A.PseudoRing v, A.PseudoRing a) =>-   CausalP.T p (Parameter a, v) v-causalPackedP = causalPacked--cascadePackedP, phaserPackedP ::-   (TypeNum.Natural n,-    Serial.C v, Serial.Element v ~ a,-    A.PseudoRing a, A.IntegerConstant a, Memory.C a,-    A.PseudoRing v, A.RationalConstant v) =>-   CausalP.T p (CascadeParameter n a, v) v-cascadePackedP = cascadePacked-phaserPackedP = phaserPacked+phaserPipelineMV ::+   (TypeNum.Positive n,+    MultiValue.PseudoRing a, MultiValue.RationalConstant a,+    Marshal.C a, MarshalMV.Vector n a) =>+   Causal.T+      (MultiValue.T (CascadeParameter n a), MultiValue.T a)+      (MultiValue.T a)+phaserPipelineMV = withSize $ \order ->+   Causal.mix <<<+   cascadePipeline &&&+   (Causal.pipeline (vectorId order) <<^ snd) <<<+--   (Causal.delay (const zero) (const $ TypeNum.integralFromProxy order) <<^ snd) <<<+   second half -{-# DEPRECATED causalP          "use 'causal' instead" #-}-{-# DEPRECATED cascadeP         "use 'cascade' instead" #-}-{-# DEPRECATED phaserP          "use 'phaser' instead" #-}-{-# DEPRECATED causalPackedP    "use 'causalPacked' instead" #-}-{-# DEPRECATED cascadePackedP   "use 'cascadePacked' instead" #-}-{-# DEPRECATED phaserPackedP    "use 'phaserPacked' instead" #-}+phaserPipeline ::+   (TypeNum.Positive n,+    MultiValue.PseudoRing a, MultiValue.RationalConstant a,+    Marshal.C a, MarshalMV.Vector n a) =>+   Causal.T+      (CascadeParameter n (MultiValue.T a), MultiValue.T a)+      (MultiValue.T a)+phaserPipeline = phaserPipelineMV <<^ mapFst cascadeParameterMultiValue
src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -4,29 +4,28 @@ {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Butterworth (    parameter, parameterCausal, Cascade.ParameterValue,-   Cascade.causal,  Cascade.causalPacked,-   Cascade.causalP, Cascade.causalPackedP,+   Cascade.causal, Cascade.causalPacked,    Cascade.fixSize,    ) where  import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2-import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal-import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Private as Sig  import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth import Synthesizer.Plain.Filter.Recursive (Passband) import Synthesizer.Causal.Class (($<)) -import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Control as U+import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as U  import qualified LLVM.Core as LLVM-import LLVM.Core-   (CodeGenFunction, Value, valueOf, constOf,-    IsFloating, IsSized, SizeOf)  import Data.Word (Word) @@ -43,13 +42,12 @@   parameterCausal ::-   (Causal.C process,-    Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,-    TypeNum.Natural n,-    TypeNum.Positive (n :*: SizeOf a),-    IsSized (Cascade.ParameterStruct n a)) =>+   (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)),+    TypeNum.Natural (n :*: LLVM.UnknownSize),+    TypeNum.Natural n, Trans.C a,+    Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) =>    Proxy n -> Passband ->-   process (Value a, Value a) (Cascade.ParameterValue n a)+   Causal.T (MultiValue.T a, MultiValue.T a) (Cascade.ParameterValue n a) parameterCausal n kind =    Causal.map       (\((psine, ps), (ratio, freq)) ->@@ -58,12 +56,12 @@    Sig.zipWith (curry return) Sig.alloca Sig.alloca  parameter ::-   (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,-    TypeNum.Natural n,-    TypeNum.Positive (n :*: SizeOf a),-    IsSized (Cascade.ParameterStruct n a)) =>-   Proxy n -> Passband -> Value a -> Value a ->-   CodeGenFunction r (Cascade.ParameterValue n a)+   (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)),+    TypeNum.Natural (n :*: LLVM.UnknownSize),+    TypeNum.Natural n, Trans.C a,+    Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) =>+   Proxy n -> Passband -> MultiValue.T a -> MultiValue.T a ->+   LLVM.CodeGenFunction r (Cascade.ParameterValue n a) parameter n kind ratio freq = do    psine <- LLVM.malloc    ps <- LLVM.malloc@@ -73,29 +71,30 @@    return pv  parameterCore ::-   (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,-    TypeNum.Natural n,-    TypeNum.Positive (n :*: SizeOf a),-    IsSized (Cascade.ParameterStruct n a)) =>+   (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)),+    TypeNum.Natural (n :*: LLVM.UnknownSize),+    TypeNum.Natural n, Trans.C a,+    Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) =>    Proxy n -> Passband ->-   Value (LLVM.Ptr (LLVM.Array n a)) ->-   Value (LLVM.Ptr (Cascade.ParameterStruct n a)) ->-   Value a -> Value a ->-   CodeGenFunction r (Cascade.ParameterValue n a)+   LLVM.Value (LLVM.Ptr (Marshal.Struct (MultiValue.Array n a))) ->+   LLVM.Value (LLVM.Ptr (Cascade.ParameterStruct n a)) ->+   MultiValue.T a -> MultiValue.T a ->+   LLVM.CodeGenFunction r (Cascade.ParameterValue n a) parameterCore n kind psine ps ratio freq = do    let order = 2 * TypeNum.integralFromProxy n-   partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio-   let sines =-          Cascade.constArray n $-          map constOf $ Butterworth.makeSines order-   LLVM.store sines psine-   s <- LLVM.getElementPtr0 psine (valueOf (0::Word), ())-   p <- LLVM.getElementPtr0 ps (valueOf (0::Word), ())-   let len = valueOf $ (TypeNum.integralFromProxy n :: Word)+   partialRatio <- Expr.unliftM1 (Butterworth.partialRatio order) ratio+   let evalSines :: (Trans.C a) => mv a -> Int -> [a]+       evalSines _ = Butterworth.makeSines+   let sines = Cascade.constArray n $ evalSines freq order+   Memory.store sines psine+   s <- LLVM.getElementPtr0 psine (LLVM.valueOf (0::Word), ())+   p <- LLVM.getElementPtr0 ps (LLVM.valueOf (0::Word), ())+   let len = LLVM.valueOf (TypeNum.integralFromProxy n :: Word)    _ <- U.arrayLoop len p s $ \ptri si -> do-      sinw <- LLVM.load si-      flip LLVM.store ptri =<<-         Filt2.composeParameter =<<-         Value.unlift3 (Butterworth.partialParameter kind) partialRatio sinw freq+      sinw <- Memory.load si+      flip Memory.store ptri =<<+         Filt2.composeParameterMV =<<+         Expr.unliftM3 (Butterworth.partialParameter kind)+            partialRatio sinw freq       A.advanceArrayElementPtr si-   fmap Cascade.ParameterValue $ LLVM.load ps+   fmap Cascade.ParameterValue $ Memory.load ps
src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -6,38 +6,37 @@    parameterCausalA, parameterCausalB,    parameterA, parameterB, Cascade.ParameterValue,    Cascade.causal,  Cascade.causalPacked,-   Cascade.causalP, Cascade.causalPackedP,    Cascade.fixSize,    ) where  import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2-import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal-import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Private as Sig  import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Chebyshev import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core import Synthesizer.Plain.Filter.Recursive (Passband) import Synthesizer.Causal.Class (($<)) -import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Control as U+import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as U  import qualified LLVM.Core as LLVM-import LLVM.Core-   (Value, valueOf, IsSized, SizeOf, IsFloating, CodeGenFunction) import Data.Word (Word) - import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal.Number ((:*:)) import Type.Base.Proxy (Proxy) -import qualified Synthesizer.LLVM.Complex as ComplexL+import qualified Synthesizer.LLVM.Complex as Complex -import qualified Number.Complex as Complex+import Control.Applicative (liftA2)  import qualified Algebra.Transcendental as Trans @@ -53,14 +52,12 @@ because they use stack-based @alloca@ instead of @malloc@. -} parameterCausalA, parameterCausalB ::-   (Causal.C process,-    Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,-    TypeNum.Positive n, TypeNum.Natural n,-    TypeNum.Positive (n :*: SizeOf a),-    IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,-    (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>+   (TypeNum.Natural n, Trans.C a,+    Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) =>+   (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)),+    TypeNum.Positive (n :*: LLVM.UnknownSize)) =>    Proxy n -> Passband ->-   process (Value a, Value a) (Cascade.ParameterValue n a)+   Causal.T (MultiValue.T a, MultiValue.T a) (Cascade.ParameterValue n a) parameterCausalA n kind =    Causal.map       (\((psine, ps), (ratio, freq)) ->@@ -79,18 +76,17 @@    allocaArrays  allocaArrays ::-   (Sig.C signal, IsSized a, IsSized b) =>-   signal (Value (LLVM.Ptr a), Value (LLVM.Ptr b))-allocaArrays = Sig.zipWith (curry return) Sig.alloca Sig.alloca+   (LLVM.IsSized a, LLVM.IsSized b) =>+   Sig.T (LLVM.Value (LLVM.Ptr a), LLVM.Value (LLVM.Ptr b))+allocaArrays = liftA2 (,) Sig.alloca Sig.alloca  parameterA, parameterB ::-   (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,-    TypeNum.Positive n, TypeNum.Natural n,-    TypeNum.Positive (n :*: SizeOf a),-    IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,-    (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>-   Proxy n -> Passband -> Value a -> Value a ->-   CodeGenFunction r (Cascade.ParameterValue n a)+   (TypeNum.Natural n, Trans.C a,+    Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a) =>+   (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)),+    TypeNum.Positive (n :*: LLVM.UnknownSize)) =>+   Proxy n -> Passband -> MultiValue.T a -> MultiValue.T a ->+   LLVM.CodeGenFunction r (Cascade.ParameterValue n a) parameterA n kind ratio freq =    withArrays $ \psine ps ->       fmap Cascade.ParameterValue $@@ -104,8 +100,9 @@  withArrays ::    (LLVM.IsSized a, LLVM.IsSized b) =>-   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> CodeGenFunction r c) ->-   CodeGenFunction r c+   (LLVM.Value (LLVM.Ptr a) -> LLVM.Value (LLVM.Ptr b) ->+    LLVM.CodeGenFunction r c) ->+   LLVM.CodeGenFunction r c withArrays act = do    psine <- LLVM.malloc    ps <- LLVM.malloc@@ -117,52 +114,43 @@  -- | adjust amplification of the first filter adjustAmplitude ::-   (LLVM.IsArithmetic a, IsSized a, SoV.IntegerConstant a,-    Filt2.ParameterStruct a ~ filt2, TypeNum.Natural n) =>-   Value a -> Value (LLVM.Array n filt2) ->-   CodeGenFunction r (Value (LLVM.Array n filt2))-adjustAmplitude ratio pv = do-   filt0 <--      Filt2.decomposeParameter =<<-      LLVM.extractvalue pv (0::Word)-   flip (LLVM.insertvalue pv) (0::Word) =<<-      Filt2.composeParameter =<<-      Value.flatten-         (Filt2Core.amplify (Value.constantValue ratio) (Value.unfold filt0))-+   (TypeNum.Natural n, Filt2.Parameter a ~ filt2,+    Marshal.C a, MultiValue.IntegerConstant a, MultiValue.PseudoRing a) =>+   MultiValue.T a -> MultiValue.T (MultiValue.Array n filt2) ->+   LLVM.CodeGenFunction r (MultiValue.T (MultiValue.Array n filt2))+adjustAmplitude ratio (MultiValue.Cons pv) = do+   filt0 <- Filt2.decomposeParameterMV =<< LLVM.extractvalue pv (0::Word)+   fmap MultiValue.Cons $+      flip (LLVM.insertvalue pv) (0::Word) =<<+      Filt2.composeParameterMV =<<+      Expr.unliftM2 Filt2Core.amplify ratio filt0  parameter ::-   (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a,-    Value.T (Value a) ~ av,-    TypeNum.Positive n, TypeNum.Natural n,-    TypeNum.Positive (n :*: SizeOf a),-    IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,-    (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>-   (Passband -> Int -> av -> Complex.T av -> av -> Filt2Core.Parameter av) ->+   (TypeNum.Positive (n :*: LLVM.SizeOf (Marshal.Struct a)),+    TypeNum.Positive (n :*: LLVM.UnknownSize),+    TypeNum.Natural n, Trans.C a,+    Marshal.C a, MultiValue.RationalConstant a, MultiValue.Transcendental a,+    Expr.Exp a ~ ae) =>+   (Passband -> Int -> ae -> Complex.T ae -> ae -> Filt2Core.Parameter ae) ->    Proxy n -> Passband ->-   Value (LLVM.Ptr (LLVM.Array n (ComplexL.Struct a))) ->-   Value (LLVM.Ptr (Cascade.ParameterStruct n a)) ->-   Value a -> Value a ->-   CodeGenFunction r (Value (Cascade.ParameterStruct n a))+   LLVM.Value (LLVM.Ptr (Marshal.Struct (MultiValue.Array n (Complex.T a)))) ->+   LLVM.Value (LLVM.Ptr (Cascade.ParameterStruct n a)) ->+   MultiValue.T a -> MultiValue.T a ->+   LLVM.CodeGenFunction r (MultiValue.T (Cascade.Parameter n a)) parameter partialParameter n kind psine ps ratio freq = do    let order = TypeNum.integralFromProxy n-   let sines =-          Cascade.constArray n $-          map ComplexL.constOf $-          Chebyshev.makeCirclePoints order-   LLVM.store sines psine-   s <- LLVM.getElementPtr0 psine (valueOf (0::Word), ())-   p <- LLVM.getElementPtr0 ps (valueOf (0::Word), ())-   let len = valueOf $ (TypeNum.integralFromProxy n :: Word)+   let evalSines :: (Trans.C a) => mv a -> Int -> [Complex.T a]+       evalSines _ = Chebyshev.makeCirclePoints+   let sines = Cascade.constArray n $ evalSines freq order+   Memory.store sines psine+   s <- LLVM.getElementPtr0 psine (LLVM.valueOf (0::Word), ())+   p <- LLVM.getElementPtr0 ps (LLVM.valueOf (0::Word), ())+   let len = LLVM.valueOf (TypeNum.integralFromProxy n :: Word)    _ <- U.arrayLoop len p s $ \ptri si -> do-      c <- LLVM.load si-      flip LLVM.store ptri =<<-         Filt2.composeParameter =<<-         Value.flatten-            (partialParameter kind order-               (Value.constantValue ratio)-               (ComplexL.unfold c)-               (Value.constantValue freq))+      c <- Memory.load si+      flip Memory.store ptri =<<+         Filt2.composeParameterMV =<<+         Expr.unliftM3 (partialParameter kind order) ratio c freq       A.advanceArrayElementPtr si -   LLVM.load ps+   Memory.load ps
src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -1,17 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Synthesizer.LLVM.Filter.ComplexFirstOrder (-   Parameter, parameter,-   causal, causalP,+   Parameter(Parameter), parameter, causal,+   parameterCode, causalExp,    ) where -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Process as CausalExp+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Value as Value  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Complex as Complex +import qualified LLVM.DSL.Expression as Expr+ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple@@ -27,6 +30,9 @@ import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold +import qualified Algebra.Transcendental as Trans+import qualified Algebra.Ring as Ring+ import NumericPrelude.Numeric import NumericPrelude.Base @@ -91,25 +97,39 @@    flattenCode = Value.flattenCodeTraversable    unfoldCode = Value.unfoldCodeTraversable +instance+   (Expr.Aggregate e mv) =>+      Expr.Aggregate (Parameter e) (Parameter mv) where+   type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e)+   type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)+   bundle = Trav.traverse Expr.bundle+   dissect = fmap Expr.dissect -parameter, _parameter ::++parameterCode, _parameterCode ::    (A.Transcendental a, A.RationalConstant a) =>    a -> a -> CodeGenFunction r (Parameter a)-parameter reson freq =+parameterCode reson freq =    let amp = recip $ Value.unfold reson    in  Value.flatten $ Parameter amp $        Complex.scale (1-amp) $ Complex.cis $-       Value.unfold freq * Value.twoPi+       Value.unfold freq * Value.tau -_parameter reson freq = do+_parameterCode reson freq = do    amp <- A.fdiv A.one reson    k   <- A.sub  A.one amp-   w  <- A.mul freq =<< Value.decons Value.twoPi+   w  <- A.mul freq =<< Value.decons Value.tau    kr <- A.mul k =<< A.cos w    ki <- A.mul k =<< A.sin w    return (Parameter amp (kr Complex.+: ki)) +parameter :: (Trans.C a) => a -> a -> Parameter a+parameter reson freq =+   let amp = recip reson+   in Parameter amp $+      Complex.scale (1-amp) $ Complex.cis $ freq * 2*pi + {- Synthesizer.Plain.Filter.Recursive.FirstOrderComplex.step cannot be used directly, because Filt1C has complex amplitude@@ -120,15 +140,12 @@    Complex.T a ->    CodeGenFunction r (Stereo.T a, Complex.T a) next inp state =-   let stereoFromComplex ::-          Complex.T a -> Complex.T (Value.T a) ->-          Stereo.T (Value.T a)-       stereoFromComplex _ c =-          Stereo.cons (Complex.real c) (Complex.imag c)+   let stereoFromComplexVal :: Complex.T (Value.T a) -> Stereo.T (Value.T a)+       stereoFromComplexVal = stereoFromComplex        (Parameter amp k, x) = Value.unfold inp        xc = Stereo.left x  Complex.+:  Stereo.right x        y = Complex.scale amp xc + k * Value.unfold state-   in  Value.flatten (stereoFromComplex state y, y)+   in  Value.flatten (stereoFromComplexVal y, y)  _next (Parameter amp k, x) s = do    let kr = Complex.real k@@ -151,18 +168,27 @@    return (A.zero Complex.+: A.zero)  causal ::-   (Causal.C process, A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>-   process+   (A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+   Causal.T       (Parameter a, Stereo.T a)       (Stereo.T a) causal =    Causal.mapAccum next start -{-# DEPRECATED causalP "use causal instead" #-}-causalP ::-   (A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>-   CausalP.T p-      (Parameter a, Stereo.T a)-      (Stereo.T a)-causalP =-   CausalP.mapAccumSimple next start++stereoFromComplex :: Complex.T a -> Stereo.T a+stereoFromComplex c = Stereo.cons (Complex.real c) (Complex.imag c)++nextPlain ::+   (Ring.C a) =>+   (Parameter a, Stereo.T a) -> Complex.T a -> (Stereo.T a, Complex.T a)+nextPlain (Parameter amp k, x) state =+   let xc = Stereo.left x  Complex.+:  Stereo.right x+       y = Complex.scale amp xc + k * state+   in (stereoFromComplex y, y)++causalExp ::+   (Ring.C ae, Expr.Aggregate ae a, Memory.C a) =>+   CausalExp.T (Parameter a, Stereo.T a) (Stereo.T a)+causalExp =+   CausalExp.mapAccum nextPlain zero
src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs view
@@ -2,150 +2,136 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked (-   Parameter, parameter,-   causal, causalP,+   Parameter(Parameter), parameterPlain, parameter, causal,+   ParameterMV,    ) where -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter +import qualified Synthesizer.LLVM.Causal.Private as Causal+ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM-import LLVM.Core-   (Value, valueOf, Struct,-    IsPrimitive, IsFloating, IsSized,-    Vector, insertelement,-    CodeGenFunction) -import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (D4, d0, d1, (:*:))+import Type.Data.Num.Decimal (D3, d0, d1)  import Control.Applicative (liftA2) +import qualified Algebra.Transcendental as Trans++import qualified Number.Complex as Complex+ import NumericPrelude.Numeric import NumericPrelude.Base  --- the pair should also be replaced by a Vector-data Parameter a =-   Parameter (Value (Vector D4 a)) (Value (Vector D4 a))+data Parameter a = Parameter (LLVM.Vector D3 a) (LLVM.Vector D3 a) -instance IsPrimitive a => Tuple.Phi (Parameter a) where-   phi bb (Parameter r i) = do+data ParameterMV a = ParameterMV (MultiVector.T D3 a) (MultiVector.T D3 a)++instance (MultiVector.C a) => Tuple.Phi (ParameterMV a) where+   phi bb (ParameterMV r i) = do       r' <- Tuple.phi bb r       i' <- Tuple.phi bb i-      return (Parameter r' i')+      return (ParameterMV r' i')    addPhi bb-        (Parameter r i)-        (Parameter r' i') = do+        (ParameterMV r i)+        (ParameterMV r' i') = do       Tuple.addPhi bb r r'       Tuple.addPhi bb i i' -instance IsPrimitive a => Tuple.Undefined (Parameter a) where-   undef = Parameter Tuple.undef Tuple.undef+instance (MultiVector.C a) => Tuple.Undefined (ParameterMV a) where+   undef = ParameterMV Tuple.undef Tuple.undef  -type ParameterStruct a = Struct (Vector D4 a, (Vector D4 a, ()))+type ParameterStruct a = Marshal.Struct (LLVM.Vector D3 a, LLVM.Vector D3 a)  parameterMemory ::-   (IsPrimitive a, IsSized a,-    TypeNum.Positive (TypeNum.D4 :*: LLVM.SizeOf a)) =>-   Memory.Record r (ParameterStruct a) (Parameter a)+   (Marshal.Vector D3 a) =>+   Memory.Record r (ParameterStruct a) (ParameterMV a) parameterMemory =-   liftA2 Parameter-      (Memory.element (\(Parameter kr _) -> kr) d0)-      (Memory.element (\(Parameter _ ki) -> ki) d1)--{--The complicated Add constraints are caused by the IsType superclass of Memory.--instance (IsPrimitive l, IsSized (Vector D4 l) ss) =>-      Memory.C (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where+   liftA2 ParameterMV+      (Memory.element (\(ParameterMV kr _) -> kr) d0)+      (Memory.element (\(ParameterMV _ ki) -> ki) d1) -Mul constraint seems to be not enough, GHC urges to give constraints in terms of Add-instance (IsPrimitive l, IsSized l s, Mul D4 s ss, Sets.Pos ss) =>-      Memory.C (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where--}-instance-   (IsPrimitive a, IsSized a,-    TypeNum.Positive (TypeNum.D4 :*: LLVM.SizeOf a)) =>-      Memory.C (Parameter a) where-   type Struct (Parameter a) = ParameterStruct a+instance (Marshal.Vector D3 a) => Memory.C (ParameterMV a) where+   type Struct (ParameterMV a) = ParameterStruct a    load = Memory.loadRecord parameterMemory    store = Memory.storeRecord parameterMemory    decompose = Memory.decomposeRecord parameterMemory    compose = Memory.composeRecord parameterMemory -parameter ::-   (SoV.TranscendentalConstant a, IsFloating a, IsPrimitive a) =>-   Value a -> Value a -> CodeGenFunction r (Parameter a)-parameter reson freq = do-   amp <- A.fdiv A.one reson-   k   <- A.sub  A.one amp-   w  <- A.mul freq =<< Value.decons Value.twoPi-   kr <- A.mul k =<< A.cos w-   ki <- A.mul k =<< A.sin w -   kin <- A.neg ki-   kvr <- Vector.assemble [kr,kin,amp, A.zero]-   kvi <- Vector.assemble [ki,kr, amp, A.zero]-   return (Parameter kvr kvi)+data ParameterExp a =+   ParameterExp (forall r. LLVM.CodeGenFunction r (ParameterMV a)) +instance Expr.Aggregate (ParameterExp a) (ParameterMV a) where+   type MultiValuesOf (ParameterExp a) = ParameterMV a+   type ExpressionsOf (ParameterMV a) = ParameterExp a+   dissect x = ParameterExp (return x)+   bundle (ParameterExp code) = code -type State a = Vector D4 a -{--The handling of Vector D2 Float in LLVM-2.5 and LLVM-2.6 is at least unexpected.-Because of compatibility reasons, LLVM chooses MMX registers-which requires to call EMMS occasionally.-Thus I choose Vector D4 for Float computations.-Actually, I have now rearranged the data-such that we can make use of SSE4's dot product operation.-This would even require a vector of size 3.--}+parameterPlain :: (Trans.C a) => a -> a -> Parameter a+parameterPlain reson freq =+   let (ComplexFilter.Parameter amp k) = ComplexFilter.parameter reson freq+       kr = Complex.real k+       ki = Complex.imag k+   in Parameter+         (LLVM.consVector kr (-ki) amp)+         (LLVM.consVector ki   kr  amp)++parameter ::+   (MultiVector.Transcendental a, MultiVector.RationalConstant a) =>+   Exp a -> Exp a -> ParameterExp a+parameter (Exp reson) (Exp freq) =+   ParameterExp (do+      r <- reson+      f <- freq+      ~(ComplexFilter.Parameter amp k) <- ComplexFilter.parameterCode r f+      let kr = Complex.real k+      let ki = Complex.imag k+      kin <- A.neg ki+      liftA2 ParameterMV+         (MultiVector.assembleFromVector $ LLVM.consVector kr kin amp)+         (MultiVector.assembleFromVector $ LLVM.consVector ki kr  amp))+++type State a = MultiVector.T D3 a+ next ::-   (Vector.Arithmetic a) =>-   (Parameter a, Stereo.T (Value a)) ->-   Value (State a) ->-   CodeGenFunction r (Stereo.T (Value a), (Value (State a)))-next (Parameter kr ki, x) s = do-   sr <- insertelement s (Stereo.left  x) (valueOf 2)-   yr <- Vector.dotProduct kr sr+   (MultiVector.PseudoRing a) =>+   (ParameterMV a, Stereo.T (MultiValue.T a)) ->+   State a -> LLVM.CodeGenFunction r (Stereo.T (MultiValue.T a), State a)+next (ParameterMV kr ki, x) s = do+   let two = LLVM.valueOf 2+   sr <- MultiVector.insert two (Stereo.left  x) s+   yr <- MultiVector.dotProduct kr sr -   si <- insertelement s (Stereo.right x) (valueOf 2)-   yi <- Vector.dotProduct ki si+   si <- MultiVector.insert two (Stereo.right x) s+   yi <- MultiVector.dotProduct ki si -   sv <- Vector.assemble [yr,yi]+   sv <- MultiVector.assembleFromVector $ LLVM.consVector yr yi Tuple.undef    return (Stereo.cons yr yi, sv) -start ::-   (Vector.Arithmetic a) =>-   CodeGenFunction r (Value (State a))-start = return A.zero- causal ::-   (Causal.C process, Vector.Arithmetic a, Memory.C (Value (State a))) =>-   process-      (Parameter a, Stereo.T (Value a))-      (Stereo.T (Value a))-causal =-   Causal.mapAccum next start--{-# DEPRECATED causalP "use causal instead" #-}-causalP ::-   (Vector.Arithmetic a, Memory.C (Value (State a))) =>-   CausalP.T p-      (Parameter a, Stereo.T (Value a))-      (Stereo.T (Value a))-causalP =-   CausalP.mapAccumSimple next start+   (Marshal.Vector n a, n ~ D3, MultiVector.PseudoRing a) =>+   Causal.T+      (ParameterMV a, Stereo.T (MultiValue.T a))+      (Stereo.T (MultiValue.T a))+causal = Causal.mapAccum next (return A.zero)
src/Synthesizer/LLVM/Filter/FirstOrder.hs view
@@ -1,45 +1,40 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.FirstOrder (-   Result(Result,lowpass_,highpass_), Parameter, parameter,+   Result(Result,lowpass_,highpass_), Parameter, FirstOrder.parameter,    causal, lowpassCausal, highpassCausal,    causalInit, lowpassCausalInit, highpassCausalInit,-   causalInitPacked, lowpassCausalInitPacked, highpassCausalInitPacked,    causalPacked, lowpassCausalPacked, highpassCausalPacked,+   causalInitPacked, lowpassCausalInitPacked, highpassCausalInitPacked,    causalRecursivePacked, -- for Allpass--   causalP, lowpassCausalP, highpassCausalP,-   causalInitP, lowpassCausalInitP, highpassCausalInitP,-   causalPackedP, lowpassCausalPackedP, highpassCausalPackedP,-   causalInitPackedP, lowpassCausalInitPackedP, highpassCausalInitPackedP,-   causalRecursivePackedP, -- for Allpass    ) where  import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder+import qualified Synthesizer.Plain.Modifier as Modifier import Synthesizer.Plain.Filter.Recursive.FirstOrder           (Parameter(Parameter), Result(Result,lowpass_,highpass_)) -import qualified Synthesizer.Plain.Modifier as Modifier--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Private as CausalPriv import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialCode -import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Expression as Expr -import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM  import Control.Arrow (arr, (&&&), (<<<))-import Control.Monad (liftM2, foldM)+import Control.Monad (foldM)+import Control.Applicative (liftA2) +import qualified Algebra.Module as Module+ import NumericPrelude.Numeric import NumericPrelude.Base @@ -58,143 +53,70 @@    decompose = Memory.decomposeNewtype Parameter    compose = Memory.composeNewtype (\(Parameter k) -> k) -instance (Marshal.C a) => Marshal.C (Parameter a) where-   pack (Parameter k) = Marshal.pack k-   unpack = Parameter . Marshal.unpack -instance (Storable.C a) => Storable.C (Parameter a) where-   load = Storable.loadNewtype Parameter Parameter-   store = Storable.storeNewtype Parameter (\(Parameter k) -> k)--instance (Value.Flatten a) => Value.Flatten (Parameter a) where-   type Registers (Parameter a) = Parameter (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable--instance (Value.Flatten a) => Value.Flatten (Result a) where-   type Registers (Result a) = Result (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable--{--instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)--instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where-   tupleDesc = Class.tupleDescFoldable--}--instance (Tuple.Value a) => Tuple.Value (Parameter a) where-   type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a)-   valueOf = Tuple.valueOfFunctor---parameter ::-   (A.Transcendental a, A.RationalConstant a) =>-   a -> LLVM.CodeGenFunction r (Parameter a)-parameter = Value.unlift1 FirstOrder.parameter+instance+   (Expr.Aggregate e mv) =>+      Expr.Aggregate (Parameter e) (Parameter mv) where+   type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e)+   type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)+   bundle (Parameter p) = fmap Parameter $ Expr.bundle p+   dissect (Parameter p) = Parameter $ Expr.dissect p  -modifier ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>-   Modifier.Simple-      (Value.T v)-      (Parameter (Value.T a))-      (Value.T v) (Result (Value.T v))-modifier = FirstOrder.modifier--lowpassModifier, highpassModifier ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>-   Modifier.Simple---      (FirstOrder.State (Value.T v))-      (Value.T v)-      (Parameter (Value.T a))-      (Value.T v) (Value.T v)-lowpassModifier  = FirstOrder.lowpassModifier-highpassModifier = FirstOrder.highpassModifier+instance (Expr.Aggregate e mv) => Expr.Aggregate (Result e) (Result mv) where+   type MultiValuesOf (Result e) = Result (Expr.MultiValuesOf e)+   type ExpressionsOf (Result mv) = Result (Expr.ExpressionsOf mv)+   bundle (Result f k) = liftA2 Result (Expr.bundle f) (Expr.bundle k)+   dissect (Result f k) = Result (Expr.dissect f) (Expr.dissect k)  causal ::-   (Causal.C process,-    A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>-   process (Parameter a, v) (Result v)-causal = Causal.fromModifier modifier+   (Expr.Aggregate ae a, Module.C ae ve,+    Expr.Aggregate ve v, Memory.C v) =>+   Causal.T (Parameter a, v) (Result v)+causal = Causal.fromModifier FirstOrder.modifier  lowpassCausal, highpassCausal ::-   (Causal.C process,-    A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>-   process (Parameter a, v) v-lowpassCausal  = CausalP.fromModifier lowpassModifier-highpassCausal = CausalP.fromModifier highpassModifier+   (Expr.Aggregate ae a, Module.C ae ve,+    Expr.Aggregate ve v, Memory.C v) =>+   Causal.T (Parameter a, v) v+lowpassCausal  = Causal.fromModifier FirstOrder.lowpassModifier+highpassCausal = Causal.fromModifier FirstOrder.highpassModifier  -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)+   (Expr.Aggregate ae a, Memory.C a, Module.C ae ve,+    Expr.Aggregate ve v, Memory.C v) =>+   ve -> Causal.T (Parameter a, v) (Result v) causalInit =-   Causal.fromModifier . Modifier.initialize modifierInit . Value.unfold+   Causal.fromModifier . Modifier.initialize FirstOrder.modifierInit  lowpassCausalInit, highpassCausalInit ::-   (Causal.C process,-    A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>-   v -> process (Parameter a, v) v+   (Expr.Aggregate ae a, Memory.C a, Module.C ae ve,+    Expr.Aggregate ve v, Memory.C v) =>+   ve -> Causal.T (Parameter a, v) v lowpassCausalInit =-   CausalP.fromModifier .-   Modifier.initialize lowpassModifierInit . Value.unfold+   Causal.fromModifier . Modifier.initialize FirstOrder.lowpassModifierInit highpassCausalInit =-   CausalP.fromModifier .-   Modifier.initialize highpassModifierInit . Value.unfold+   Causal.fromModifier . Modifier.initialize FirstOrder.highpassModifierInit   lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked,       preampPacked ::-   (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) v+   (SerialCode.Write v, SerialCode.Element v ~ a,+    A.PseudoRing v, A.IntegerConstant v,+    A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+   Causal.T (Parameter a, v) v highpassCausalPacked =-   Causal.zipWith A.sub <<< arr snd &&& lowpassCausalPacked+   CausalPriv.zipWith A.sub <<< arr snd &&& lowpassCausalPacked lowpassCausalPacked =-   causalRecursivePacked <<< (arr fst &&& preampPacked)+   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)+   CausalPriv.mapAccum causalRecursivePackedStep (return A.zero)  preampPacked =-   Causal.map-      (\(Parameter k, x) ->-         A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k)+   CausalPriv.map+      (\(Parameter k, x) -> A.mul x =<< SerialCode.upsample =<< A.sub A.one k)   @@ -213,41 +135,24 @@ f2x = f1x + k^2 * f1x->2 -} causalRecursivePackedStep ::-   (A.PseudoRing v, Serial.C v, Serial.Element v ~ a, A.PseudoRing a) =>+   (SerialCode.Write v, SerialCode.Element v ~ a,+    A.PseudoRing v, A.IntegerConstant v, 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-         kv <- Serial.upsample k-         xk2 <--            fmap fst $-            foldM-               (\(y,k0) d ->-                  liftM2 (,)-                     (A.add y =<<-                      Serial.shiftUpMultiZero d =<<-                      A.mul y k0)-                     (A.mul k0 k0))-               (xk1,kv)-               (takeWhile (< size) $ iterate (2*) 1)-{- do replicate in the loop-         xk2 <--            fmap fst $-            foldM-               (\(y,k0) d ->-                  liftM2 (,)-                     (A.add y =<<-                      Serial.shiftUpMultiZero d =<<-                      A.mul y =<<-                      Serial.upsample k0)-                     (A.mul k0 k0))-               (xk1,k)-               (takeWhile (< size) $ iterate (2*) 1)--}-         y0 <- Serial.extract (LLVM.valueOf $ fromIntegral $ size - 1) xk2-         return (xk2, y0)+causalRecursivePackedStep (Parameter k, xk0) y1 = do+   y1k <- A.mul k y1+   xk1 <- SerialCode.modify A.zero (A.add y1k) xk0+   kv <- SerialCode.upsample k+   xk2 <-+      fmap fst $+      foldM+         (\(y,k0) d ->+            liftA2 (,)+               (A.add y =<< SerialCode.shiftUpMultiZero d =<< A.mul y k0)+               (A.mul k0 k0))+         (xk1,kv)+         (takeWhile (< SerialCode.size xk0) $ iterate (2*) 1)+   y0 <- SerialCode.last xk2+   return (xk2, y0)  {- We can also optimize filtering with time-varying filter parameter.@@ -288,105 +193,41 @@ -}  - addHighpass ::-   (Causal.C process, A.Additive v) =>-   process (param, v) v -> process (param, v) (Result v)+   (A.Additive v) =>+   Causal.T (param,v) v -> Causal.T (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{lowpass_ = l, highpass_ = h}))-    <<< (lowpass &&& arr snd)+   CausalPriv.map+      (\(l,x) -> do+         h <- A.sub x l+         return (Result{lowpass_ = l, 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)+   (SerialCode.Write v, SerialCode.Element v ~ a,+    A.PseudoRing v, A.IntegerConstant v,+    A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+   Causal.T (Parameter a, v) (Result v) 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)-causalP = addHighpass lowpassCausalP--lowpassCausalP, highpassCausalP ::-   (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>-   CausalP.T p (Parameter a, v) v-lowpassCausalP  = lowpassCausal-highpassCausalP = highpassCausal--causalInitP ::-   (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v,-    Marshal.C vh, Tuple.ValueOf 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,-    Marshal.C vh, Tuple.ValueOf 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,-    A.PseudoRing v, A.PseudoRing a) =>-   CausalP.T p (Parameter a, v) v-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,-    Marshal.C ah, Tuple.ValueOf 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,-    A.PseudoRing v, A.PseudoRing a) =>-   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,-    Marshal.C ah, Tuple.ValueOf ah ~ a) =>-   Param.T p ah -> CausalP.T p (Parameter a, v) (Result v)-causalInitPackedP a = addHighpass (lowpassCausalInitPackedP a)+lowpassCausalInitPacked, highpassCausalInitPacked,+      causalRecursiveInitPacked ::+   (A.PseudoRing v, A.IntegerConstant v,+    SerialCode.Write v, SerialCode.Element v ~ a,+    Expr.Aggregate ae a, A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+   ae -> Causal.T (Parameter a, v) v+causalRecursiveInitPacked a =+   CausalPriv.mapAccum causalRecursivePackedStep (Expr.bundle a) +highpassCausalInitPacked a = arr snd - lowpassCausalInitPacked a+lowpassCausalInitPacked a =+   causalRecursiveInitPacked a <<< arr fst &&& preampPacked -{-# DEPRECATED causalP                "use 'causal' instead" #-}-{-# DEPRECATED lowpassCausalP         "use 'lowpassCausal' instead" #-}-{-# DEPRECATED highpassCausalP        "use 'highpassCausal' instead" #-}-{-# DEPRECATED causalPackedP          "use 'causalPacked' instead" #-}-{-# DEPRECATED lowpassCausalPackedP   "use 'lowpassCausalPacked' instead" #-}-{-# DEPRECATED highpassCausalPackedP  "use 'highpassCausalPacked' instead" #-}-{-# DEPRECATED causalRecursivePackedP "use 'causalRecursivePacked' instead" #-}+causalInitPacked ::+   (A.PseudoRing v, A.IntegerConstant v,+    SerialCode.Write v, SerialCode.Element v ~ a,+    Expr.Aggregate ae a, A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+   ae -> Causal.T (Parameter a, v) (Result v)+causalInitPacked a = addHighpass (lowpassCausalInitPacked a)
src/Synthesizer/LLVM/Filter/Moog.hs view
@@ -1,33 +1,29 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveTraversable #-}-module Synthesizer.LLVM.Filter.Moog-   (Parameter, parameter,-    causal, causalInit,-    causalP, causalInitP,+module Synthesizer.LLVM.Filter.Moog (+   Parameter, parameter,+   causal, causalInit,    ) where -import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 ()  import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog import Synthesizer.Plain.Filter.Recursive (Pole(..)) -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.Value as Value -import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Expression as Expr  import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction)  import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal (d0, d1)@@ -40,6 +36,8 @@ import Control.Arrow (arr, (>>>), (&&&)) import Control.Applicative (liftA2) +import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module as Module import NumericPrelude.Numeric import NumericPrelude.Base @@ -62,33 +60,30 @@    zero = Tuple.zeroPointed  -type ParameterStruct a = LLVM.Struct (a, (a, ()))+type ParameterStruct a =+   LLVM.Struct (Memory.Struct a, (Memory.Struct (FirstOrder.Parameter a), ()))  parameterMemory ::    (Memory.C a, TypeNum.Natural n) =>-   Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter n a)+   Memory.Record r (ParameterStruct a) (Parameter n a) parameterMemory =    liftA2 (\f k -> Parameter (Moog.Parameter f k))       (Memory.element (Moog.feedback     . getParam) d0)       (Memory.element (Moog.lowpassParam . getParam) d1)  instance-      (Memory.C a, TypeNum.Natural n) =>+   (Memory.C a, TypeNum.Natural n) =>       Memory.C (Parameter n a) where-   type Struct (Parameter n a) = ParameterStruct (Memory.Struct a)+   type Struct (Parameter n a) = ParameterStruct a    load = Memory.loadRecord parameterMemory    store = Memory.storeRecord parameterMemory    decompose = Memory.decomposeRecord parameterMemory    compose = Memory.composeRecord parameterMemory  -instance (Value.Flatten a, TypeNum.Natural n) => Value.Flatten (Parameter n a) where-   type Registers (Parameter n a) = Parameter n (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable---instance (Vector.Simple v, TypeNum.Natural n) => Vector.Simple (Parameter n v) where+instance+   (Vector.Simple v, TypeNum.Natural n) =>+      Vector.Simple (Parameter n v) where    type Element (Parameter n v) = Parameter n (Vector.Element v)    type Size (Parameter n v) = Vector.Size v    shuffleMatch = Vector.shuffleMatchTraversable@@ -99,81 +94,64 @@   parameter ::-   (A.Transcendental a, A.RationalConstant a, TypeNum.Natural n) =>-   Proxy n -> a -> a ->-   CodeGenFunction r (Parameter n a)-parameter order =-   Value.unlift2 $ \reson freq ->-   Parameter $ Moog.parameter (TypeNum.integralFromProxy order) (Pole reson freq)+   (TypeNum.Natural n, Trans.C a) =>+   Proxy n -> a -> a -> Parameter n a+parameter order reson freq =+   Parameter $+   Moog.parameter (TypeNum.integralFromProxy order) (Pole reson freq) +instance+   (n ~ m, Expr.Aggregate e mv) =>+      Expr.Aggregate (Parameter n e) (Parameter m mv) where+   type MultiValuesOf (Parameter n e) = Parameter n (Expr.MultiValuesOf e)+   type ExpressionsOf (Parameter m mv) = Parameter m (Expr.ExpressionsOf mv)+   bundle (Parameter (Moog.Parameter f k)) =+      fmap Parameter $ liftA2 Moog.Parameter (Expr.bundle f) (Expr.bundle k)+   dissect (Parameter (Moog.Parameter f k)) =+      Parameter (Moog.Parameter (Expr.dissect f) (Expr.dissect k)) + merge ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>-   (Parameter n a, v) -> v ->-   CodeGenFunction r (FirstOrder.Parameter a, v)-merge (Parameter (Moog.Parameter f k), x) y0 =-   let c :: a -> Value.T a-       c = Value.constantValue-   in  Value.flatten (fmap c k, c x - c f *> c y0)+   (Module.C a v) => (Parameter n a, v) -> v -> (FirstOrder.Parameter a, v)+merge (Parameter (Moog.Parameter f k), x) y0 = (k, x - f *> y0) -amplify ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>-   Parameter n a ->-   v ->-   CodeGenFunction r v-amplify =-   Value.unlift2 $ \p y1 ->-      case fmap (Moog.feedback . getParam) p of-         f -> (1 + f) *> y1+amplify :: (Module.C a v) => Parameter n a -> v -> v+amplify p y1 = (1 + Moog.feedback (getParam p)) *> y1  causal ::-   (Causal.C process,-    Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,-    TypeNum.Natural n) =>-   process (Parameter n a, v) v+   (TypeNum.Natural n, Memory.C v,+    Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v) =>+   Causal.T (Parameter n a, v) v causal =    causalSize-      (flip Causal.feedbackControlledZero (arr snd))+      (flip (Causal.feedbackControlled zero) (arr snd))       Proxy -causalP ::-   (Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,-    TypeNum.Natural n) =>-   CausalP.T p (Parameter n a, v) v-causalP = causal --causalInit, causalInitP ::-   (Marshal.C vh, Tuple.ValueOf vh ~ v,-    A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,-    TypeNum.Natural n) =>-   Param.T p vh -> CausalP.T p (Parameter n a, v) v-causalInit = causalInitP-causalInitP initial =-   let selectOutput :: Param.T p vh -> (b, Tuple.ValueOf vh) -> Tuple.ValueOf vh-       selectOutput _ = snd-   in  causalSize-          (flip-             (CausalP.feedbackControlled initial)-             (arr $ selectOutput initial))-          Proxy+causalInit ::+   (TypeNum.Natural n, Memory.C v,+    Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v) =>+   ve -> Causal.T (Parameter n a, v) v+causalInit initial =+   causalSize+      (flip+         (Causal.feedbackControlled initial)+         (arr snd))+      Proxy   causalSize ::-   (Causal.C process,-    Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,-    TypeNum.Natural n) =>-   (process ((Parameter n a, v), v) v ->-    process (Parameter n a, v) v) ->+   (TypeNum.Natural n, Memory.C v,+    Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v) =>+   (Causal.T ((Parameter n a, v), v) v ->+    Causal.T (Parameter n a, v) v) ->    Proxy n ->-   process (Parameter n a, v) v+   Causal.T (Parameter n a, v) v causalSize feedback n =    let order = TypeNum.integralFromProxy n    in  Arrow.arr fst &&&        feedback           (Causal.zipWith merge >>>-           Causal.replicateControlled order Filt1.lowpassCausal)+           Causal.replicateControlled order+             (Causal.fromModifier FirstOrder.lowpassModifier))         >>> Causal.zipWith amplify--{-# DEPRECATED causalP     "use 'causal' instead" #-}-{-# DEPRECATED causalInitP "use 'causalInit' instead" #-}
src/Synthesizer/LLVM/Filter/NonRecursive.hs view
@@ -1,45 +1,44 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.NonRecursive (    convolve,    convolvePacked,    ) where -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.RingBuffer as RingBuffer-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Causal.Private as CausalPriv+import qualified Synthesizer.LLVM.Generator.Source as Source+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.RingBuffer as RingBuffer+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial -import qualified Synthesizer.LLVM.Storable.Vector as SVU-import qualified Data.StorableVector as SV+import qualified Synthesizer.Causal.Class as CausalClass+import Synthesizer.Causal.Class (($<)) -import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp) -import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM-import LLVM.Core (Value, valueOf, CodeGenFunction, IsSized, SizeOf)  import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal.Number ((:*:)) -import Foreign.ForeignPtr (touchForeignPtr) import Foreign.Ptr (Ptr) import Data.Word (Word)  import Control.Arrow ((<<<), (&&&)) import Control.Monad (liftM2) -import qualified Algebra.IntegralDomain as Integral- import NumericPrelude.Numeric import NumericPrelude.Base-+import Prelude ()   {-@@ -47,86 +46,75 @@ No Karatsuba, No Toom-Cook, No Fourier. -} convolve ::-   (Storable.C a, Tuple.ValueOf a ~ al, Memory.C al, A.PseudoRing al) =>-   Param.T p (SV.Vector a) -> CausalP.T p al al+   (Storable.C a, Marshal.C a, MultiValue.PseudoRing a, MultiValue.T a ~ am) =>+   Exp (Source.StorableVector a) -> Causal.T am am convolve mask =-   let len = fmap SV.length mask-   in  CausalP.zipWith scalarProduct-         (fmap (fromIntegral :: Int -> Word) len)-       <<<-       RingBuffer.trackConst A.zero len &&& provideMask mask+   let len = Source.storableVectorLength mask+   in (CausalPriv.zipWith (\(MultiValue.Cons l) -> scalarProduct l)+         $< Sig.constant len)+      <<<+      Causal.track Expr.zero len &&& provideMask mask  convolvePacked ::-   (TypeNum.Positive n, TypeNum.Positive (n :*: asize),-    Storable.C a, Tuple.ValueOf a ~ Value al,-    LLVM.IsArithmetic al, LLVM.IsPrimitive al, IsSized al, SizeOf al ~ asize) =>-   Param.T p (SV.Vector a) ->-   CausalP.T p (Serial.Value n al) (Serial.Value n al)-convolvePacked mask =-   Serial.withSize $ \vectorSize ->-      let len = fmap SV.length mask-      in  CausalP.zipWith scalarProductPacked-             (fmap (fromIntegral :: Int -> Word) len)-          <<<-          RingBuffer.trackConst A.zero-             (fmap (flip Integral.divUp vectorSize) len)-          &&&-          provideMask mask+   (Marshal.Vector n a, MultiVector.PseudoRing a) =>+   (Storable.C a, MultiValue.PseudoRing a, Serial.Value n a ~ v) =>+   Exp (Source.StorableVector a) -> Causal.T v v+convolvePacked = convolvePackedAux TypeNum.singleton +convolvePackedAux ::+   (Marshal.Vector n a, MultiVector.PseudoRing a) =>+   (Storable.C a, MultiValue.PseudoRing a, Serial.Value n a ~ v) =>+   TypeNum.Singleton n -> Exp (Source.StorableVector a) -> Causal.T v v+convolvePackedAux vectorSize mask =+   let len = Source.storableVectorLength mask+   in (CausalPriv.zipWith (\(MultiValue.Cons l) -> scalarProductPacked l)+         $< Sig.constant len)+      <<<+      Causal.track Expr.zero+         (divUp (TypeNum.integralFromSingleton vectorSize) len)+      &&&+      provideMask mask++divUp :: Exp Word -> Exp Word -> Exp Word+divUp k n = Expr.idiv (n+(k-1)) k+ provideMask ::-   (Storable.C a) => Param.T p (SV.Vector a) -> CausalP.T p x (Value (Ptr a))+   (Storable.C a) =>+   Exp (Source.StorableVector a) -> Causal.T x (LLVM.Value (Ptr a)) provideMask mask =-   CausalP.Cons-      (\p () _x () -> return (p,()))-      (return ())-      return-      (const $ const $ return ())-      (\p ->-         let (fp,ptr,_l) = SVU.unsafeToPointers $ Param.get mask p-         in  return (fp, (ptr, ())))-      -- keep the foreign ptr alive-      touchForeignPtr+   CausalClass.fromSignal $+   fmap (\(MultiValue.Cons (ptr,_l)) -> ptr) $+   Sig.constant mask   scalarProduct ::-   (Storable.C a, Tuple.ValueOf a ~ al, Memory.C al, A.PseudoRing al) =>-   Value Word ->-   RingBuffer.T al -> Value (Ptr a) ->-   CodeGenFunction r al-scalarProduct n rb mask =+   (Storable.C a, Marshal.C a, MultiValue.T a ~ am, MultiValue.PseudoRing a) =>+   LLVM.Value Word ->+   (RingBuffer.T am, LLVM.Value (Ptr a)) ->+   LLVM.CodeGenFunction r am+scalarProduct n (rb,mask) =    fmap snd $    Storable.arrayLoop n mask (A.zero, A.zero) $ \ptr (k, s) -> do       a <- RingBuffer.index k rb       b <- Storable.load ptr       liftM2 (,) (A.inc k) (A.add s =<< A.mul a b) -_scalarProduct ::-   (Storable.C a, IsSized a,-    Tuple.ValueOf a ~ Value a, LLVM.IsArithmetic a) =>-   Value Word ->-   RingBuffer.T (Value a) -> Value (Ptr a) ->-   CodeGenFunction r (Value a)-_scalarProduct = scalarProduct - scalarProductPacked ::-   (Storable.C a,-    Tuple.ValueOf a ~ Value al, LLVM.IsArithmetic al,-    LLVM.IsPrimitive al, IsSized al, SizeOf al ~ asize,-    TypeNum.Positive n, TypeNum.Positive (n :*: asize)) =>-   Value Word ->-   RingBuffer.T (Serial.Value n al) -> Value (Ptr a) ->-   CodeGenFunction r (Serial.Value n al)-scalarProductPacked n0 rb mask0 = do+   (Storable.C a, Marshal.Vector n a, MultiVector.PseudoRing a) =>+   LLVM.Value Word ->+   (RingBuffer.T (Serial.Value n a), LLVM.Value (Ptr a)) ->+   LLVM.CodeGenFunction r (Serial.Value n a)+scalarProductPacked n0 (rb,mask0) = do    (ax, rx) <- readSerialStart rb    bx <- Storable.load mask0-   sx <- A.scale bx ax+   sx <- Serial.scale bx ax    n1 <- A.dec n0    mask1 <- Storable.incrementPtr mask0    fmap snd $ Storable.arrayLoop n1 mask1 (rx, sx) $ \ptr (r1, s1) -> do       (a,r2) <- readSerialNext rb r1       b <- Storable.load ptr-      fmap ((,) r2) (A.add s1 =<< A.scale b a)+      fmap ((,) r2) (A.add s1 =<< Serial.scale b a)   type@@ -138,31 +126,29 @@         that is, from high to low indices.         -}         Serial.Value n a,-        Value Word),-       Value Word)+        LLVM.Value Word),+       LLVM.Value Word)  readSerialStart ::-   (LLVM.IsPrimitive a, IsSized a, SizeOf a ~ asize,-    TypeNum.Positive n, TypeNum.Positive (n :*: asize)) =>+   (TypeNum.Positive n, Marshal.Vector n a) =>    RingBuffer.T (Serial.Value n a) ->-   CodeGenFunction r (Serial.Value n a, Iterator n a)+   LLVM.CodeGenFunction r (Serial.Value n a, Iterator n a) readSerialStart rb = do    a <- RingBuffer.index A.zero rb    return (a, ((a, Tuple.undef, A.zero), A.zero))  readSerialNext ::-   (LLVM.IsPrimitive a, IsSized a, SizeOf a ~ asize,-    TypeNum.Positive n, TypeNum.Positive (n :*: asize)) =>+   (MultiValue.C a, Marshal.Vector n a) =>    RingBuffer.T (Serial.Value n a) ->    Iterator n a ->-   CodeGenFunction r (Serial.Value n a, Iterator n a)+   LLVM.CodeGenFunction r (Serial.Value n a, Iterator n a) readSerialNext rb ((a0,r0,j0), k0) = do    vectorEnd <- A.cmp LLVM.CmpEQ j0 A.zero    ((r1,j1), k1) <-       C.ifThen vectorEnd ((r0,j0), k0) $ do          k <- A.inc k0          r <- RingBuffer.index k rb-         return ((r, valueOf (fromIntegral $ Serial.size r :: Word)), k)+         return ((r, LLVM.valueOf (Serial.size r :: Word)), k)    j2 <- A.dec j1    (ai,r2) <- Serial.shiftUp Tuple.undef r1    (_, a1) <- Serial.shiftUp ai a0
src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -1,15 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.SecondOrder (    Parameter(Parameter),    Filt2.c0, Filt2.c1, Filt2.c2, Filt2.d1, Filt2.d2,    bandpassParameter,+   bandpassParameterCode,    ParameterStruct, composeParameter, decomposeParameter, -- for cascade+   composeParameterMV, decomposeParameterMV,+   causalExp,    causal, causalPacked,-   causalP, causalPackedP,    ) where  import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2@@ -17,11 +20,15 @@  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.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Process as CausalExp+import qualified Synthesizer.LLVM.Causal.ProcessValue as Causal+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial+import qualified Synthesizer.LLVM.Value as Value +import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory@@ -38,8 +45,14 @@ import qualified Control.Applicative.HT as App import Control.Arrow (arr, (<<<), (&&&)) import Control.Monad (liftM2, foldM)-import Control.Applicative (pure, (<$>), (<*>))+import Control.Applicative (pure, liftA2, (<$>), (<*>)) +import qualified Data.Foldable as Fold+import Data.Traversable (traverse)++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module as Module+ import NumericPrelude.Numeric import NumericPrelude.Base @@ -51,14 +64,6 @@ instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where    undef = Tuple.undefPointed -{--instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)--instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where-   tupleDesc = Class.tupleDescFoldable--}- instance (Tuple.Value a) => Tuple.Value (Parameter a) where    type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a)    valueOf = Tuple.valueOfFunctor@@ -88,6 +93,18 @@       <*> LLVM.extractvalue param TypeNum.d3       <*> LLVM.extractvalue param TypeNum.d4 +decomposeParameterMV ::+   (MarshalMV.C a) =>+   LLVM.Value (MarshalMV.Struct (Parameter a)) ->+   CodeGenFunction r (Filt2.Parameter (MultiValue.T a))+decomposeParameterMV param =+   pure Filt2.Parameter+      <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d0)+      <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d1)+      <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d2)+      <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d3)+      <*> (Memory.decompose =<< LLVM.extractvalue param TypeNum.d4)+ composeParameter ::    (LLVM.IsSized a) =>    Filt2.Parameter (LLVM.Value a) ->@@ -100,6 +117,20 @@    (\param -> LLVM.insertvalue param d2_ TypeNum.d4) =<<    return (LLVM.value LLVM.undef) +composeParameterMV ::+   (MarshalMV.C a) =>+   Filt2.Parameter (MultiValue.T a) ->+   CodeGenFunction r (LLVM.Value (MarshalMV.Struct (Parameter a)))+composeParameterMV (Filt2.Parameter c0_ c1_ c2_ d1_ d2_) =+   let insert field ix param =+         Memory.compose field >>= flip (LLVM.insertvalue param) ix in+   insert c0_ TypeNum.d0 =<<+   insert c1_ TypeNum.d1 =<<+   insert c2_ TypeNum.d2 =<<+   insert d1_ TypeNum.d3 =<<+   insert d2_ TypeNum.d4 =<<+   return (LLVM.value LLVM.undef)+ instance (Memory.C a) => Memory.C (Parameter a) where    type Struct (Parameter a) = ParameterStruct (Memory.Struct a)    load = Memory.loadRecord parameterMemory@@ -124,8 +155,47 @@    flattenCode = Value.flattenCodeTraversable    unfoldCode = Value.unfoldCodeTraversable +instance (MultiValue.C a) => MultiValue.C (Parameter a) where+   type Repr (Parameter a) = Parameter (MultiValue.Repr a)+   cons = parameterMultiValue . fmap MultiValue.cons+   undef = parameterMultiValue $ pure MultiValue.undef+   zero = parameterMultiValue $ pure MultiValue.zero+   phi bb =+      fmap parameterMultiValue .+      traverse (MultiValue.phi bb) .+      parameterUnMultiValue+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb)+         (parameterUnMultiValue a) (parameterUnMultiValue b) +instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where+   pack p =+      case MarshalMV.pack <$> p of+         Filt2.Parameter c0_ c1_ c2_ d1_ d2_ ->+            LLVM.consStruct c0_ c1_ c2_ d1_ d2_+   unpack = fmap MarshalMV.unpack . LLVM.uncurryStruct Filt2.Parameter +parameterMultiValue ::+   Parameter (MultiValue.T a) -> MultiValue.T (Parameter a)+parameterMultiValue =+   MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++parameterUnMultiValue ::+   MultiValue.T (Parameter a) -> Parameter (MultiValue.T a)+parameterUnMultiValue (MultiValue.Cons x) =+   fmap MultiValue.Cons x++instance+   (Expr.Aggregate e mv) =>+      Expr.Aggregate (Parameter e) (Parameter mv) where+   type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e)+   type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)+   bundle = traverse Expr.bundle+   dissect = fmap Expr.dissect+++ instance (Tuple.Phi a) => Tuple.Phi (Filt2.State a) where    phi = Tuple.phiTraversable    addPhi = Tuple.addPhiFoldable@@ -159,25 +229,37 @@    flattenCode = Value.flattenCodeTraversable    unfoldCode = Value.unfoldCodeTraversable +instance+   (Expr.Aggregate e mv) =>+      Expr.Aggregate (Filt2.State e) (Filt2.State mv) where+   type MultiValuesOf (Filt2.State e) = Filt2.State (Expr.MultiValuesOf e)+   type ExpressionsOf (Filt2.State mv) = Filt2.State (Expr.ExpressionsOf mv)+   bundle = traverse Expr.bundle+   dissect = fmap Expr.dissect + {-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-}-bandpassParameter ::+bandpassParameterCode ::    (A.Transcendental a, A.RationalConstant a) =>    a -> a ->    CodeGenFunction r (Parameter a)-bandpassParameter reson cutoff = do+bandpassParameterCode reson cutoff = do    rreson <- A.fdiv A.one reson    k <- A.sub A.one rreson    k2 <- A.neg =<< A.mul k k    kcos <-       A.mul (A.fromInteger' 2) =<< A.mul k =<<       A.cos =<< A.mul cutoff =<<-      Value.decons Value.twoPi-   return $-      Filt2.Parameter-         rreson A.zero A.zero-         kcos k2+      Value.decons Value.tau+   return $ Filt2.Parameter  rreson A.zero A.zero  kcos k2 +-- ToDo: move to synthesizer-core:Filter.SecondOrder (it is not the universal filter)+bandpassParameter :: (Trans.C a) => a -> a -> Parameter a+bandpassParameter reson cutoff =+   let rreson = recip reson+       k = one - rreson+   in Filt2.Parameter  rreson zero zero  (2*k*cos(2*pi*cutoff)) (-k*k)+ modifier ::    (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>    Modifier.Simple@@ -188,49 +270,38 @@    Filt2.modifier  causal ::-   (Causal.C process,-    a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>-   process (Parameter a, v) v+   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>+   Causal.T (Parameter a, v) v causal =    Causal.fromModifier modifier -{-# DEPRECATED causalP "use causal instead" #-}-causalP ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>-   CausalP.T p (Parameter a, v) v-causalP =-   CausalP.fromModifier modifier+causalExp ::+   (Expr.Aggregate ae a, Memory.C a, Module.C ae ve,+    Expr.Aggregate ve v, Memory.C v) =>+   CausalExp.T (Parameter a, v) v+causalExp =+   CausalExp.fromModifier Filt2.modifier  -{-# DEPRECATED causalPackedP "use causalPacked instead" #-}-causalPackedP ::-   (Serial.C v, Serial.Element v ~ a,-    Memory.C v, Memory.C a, A.IntegerConstant v, A.IntegerConstant a,-    A.PseudoRing v, A.PseudoRing a) =>-   CausalP.T p (Parameter a, v) v-causalPackedP = causalPacked- {- | Vector size must be at least D2. -} causalPacked,   causalRecursivePacked ::-   (Causal.C process,-    Serial.C v, Serial.Element v ~ a,+   (Serial.Write v, Serial.Element v ~ a,     Memory.C v, Memory.C a, A.IntegerConstant v, A.IntegerConstant a,     A.PseudoRing v, A.PseudoRing a) =>-   process (Parameter a, v) v+   Causal.T (Parameter a, v) v causalPacked =    causalRecursivePacked <<<    (arr fst &&& causalNonRecursivePacked)  _causalRecursivePackedAlt,   causalNonRecursivePacked ::-   (Causal.C process,-    Serial.C v, Serial.Element v ~ a,+   (Serial.Write v, Serial.Element v ~ a,     Memory.C a, A.IntegerConstant v, A.IntegerConstant a,     A.PseudoRing v, A.PseudoRing a) =>-   process (Parameter a, v) v+   Causal.T (Parameter a, v) v causalNonRecursivePacked =    Causal.mapAccum       (\(p, v0) (x1,x2) -> do@@ -283,7 +354,7 @@          d2v  <- Serial.upsample (Filt2.d2 p)          d2vn <- A.neg d2v -         y1  <- Serial.extract (valueOf $ fromIntegral size - 1) y1v+         y1  <- Serial.last y1v          xk1 <-             Serial.modify (valueOf 0)                (\u0 -> A.add u0 =<< A.mul (Filt2.d1 p) y1) =<<
src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -1,35 +1,33 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Filter.SecondOrderCascade (-   causal,  causalPacked,-   causalP, causalPackedP,+   causal, causalPacked,+   Parameter,    ParameterValue(..),    ParameterStruct,    fixSize, constArray,    ) where  import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2-import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core -import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&))+import qualified Synthesizer.LLVM.Causal.Functional as Func+import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Private as Sig -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial import Synthesizer.Causal.Class (($<)) +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM-import LLVM.Core (Value, IsArithmetic, IsSized, CodeGenFunction)  import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal.Number ((:*:))@@ -37,19 +35,16 @@  import Data.Word (Word) -import qualified Control.Arrow as Arrow-import Control.Arrow ((>>>), (<<<), (^<<), (&&&), arr)-import Control.Applicative (liftA2)-+import Control.Arrow ((<<<), (^<<), (&&&), arr) -import NumericPrelude.Numeric import NumericPrelude.Base  -type ParameterStruct n a = LLVM.Array n (Filt2.ParameterStruct a)+type Parameter n a = MultiValue.Array n (Filt2.Parameter a)+type ParameterStruct n a = Marshal.Struct (Parameter n a)  newtype ParameterValue n a =-   ParameterValue {parameterValue :: Value (ParameterStruct n a)}+   ParameterValue {parameterValue :: MultiValue.T (Parameter n a)} {- Automatic deriving is not allowed even with GeneralizedNewtypeDeriving because of IsSized constraint@@ -59,24 +54,20 @@           Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -} -instance (TypeNum.Natural n, IsSized a) =>+instance (TypeNum.Natural n, Marshal.C a) =>       Tuple.Phi (ParameterValue n a) where-   phi bb (ParameterValue r) =-      fmap ParameterValue $ Tuple.phi bb r-   addPhi bb-        (ParameterValue r)-        (ParameterValue r') =-      Tuple.addPhi bb r r'+   phi bb (ParameterValue r) = fmap ParameterValue $ MultiValue.phi bb r+   addPhi bb (ParameterValue r) (ParameterValue r') = MultiValue.addPhi bb r r' -instance (TypeNum.Natural n, IsSized a) =>+instance (TypeNum.Natural n, Marshal.C a) =>       Tuple.Undefined (ParameterValue n a) where-   undef = ParameterValue Tuple.undef+   undef = ParameterValue MultiValue.undef -instance (TypeNum.Natural n, IsSized a) =>+instance (TypeNum.Natural n, Marshal.C a) =>       Tuple.Zero (ParameterValue n a) where-   zero = ParameterValue Tuple.zero+   zero = ParameterValue MultiValue.zero -instance (TypeNum.Natural n, IsSized a,+instance (TypeNum.Natural n, Marshal.C a,           TypeNum.Positive (n :*: LLVM.UnknownSize)) =>       Memory.C (ParameterValue n a) where    type Struct (ParameterValue n a) = ParameterStruct n a@@ -103,54 +94,31 @@ fixSize _n = id  constArray ::-   (TypeNum.Natural n, IsSized a) =>-   Proxy n -> [LLVM.ConstValue a] ->-   LLVM.Value (LLVM.Array n a)-constArray _n = LLVM.value . LLVM.constArray---causalP ::-   (Memory.C v, A.PseudoModule v, A.Scalar v ~ LLVM.Value a,-    IsSized a, IsArithmetic a, SoV.IntegerConstant a, TypeNum.Natural n,-    TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   CausalP.T p (ParameterValue n a, v) v-causalP = causal--causalPackedP ::-   (Memory.C v, A.PseudoRing v, A.IntegerConstant v, A.PseudoModule v,-    Serial.C v, Serial.Element v ~ LLVM.Value a,-    A.Scalar v ~ LLVM.Value a,-    SoV.IntegerConstant a, LLVM.IsPrimitive a, IsSized a,-    TypeNum.Positive (n :*: LLVM.UnknownSize),-    TypeNum.Natural n) =>-   CausalP.T p (ParameterValue n a, v) v-causalPackedP = causalPacked+   (TypeNum.Natural n, Marshal.C a) =>+   Proxy n -> [a] -> MultiValue.T (MultiValue.Array n a)+constArray _n = MultiValue.cons . MultiValue.Array   causal ::-   (Causal.C process,-    Memory.C v, A.PseudoModule v, A.Scalar v ~ LLVM.Value a,-    IsSized a, IsArithmetic a, SoV.IntegerConstant a, TypeNum.Natural n,-    TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   process (ParameterValue n a, v) v+   (A.PseudoModule v, Memory.C v, A.Scalar v ~ MultiValue.T a,+    Marshal.C a, MultiValue.IntegerConstant a,+    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>+   Causal.T (ParameterValue n a, v) v causal = causalGen Filt2.causal  causalPacked ::-   (Causal.C process,-    A.PseudoRing v, A.IntegerConstant v,-    Memory.C v, A.PseudoModule v, A.Scalar v ~ LLVM.Value a,-    Serial.C v, Serial.Element v ~ LLVM.Value a,-    SoV.IntegerConstant a, LLVM.IsPrimitive a, IsSized a,-    TypeNum.Positive (n :*: LLVM.UnknownSize),-    TypeNum.Natural n) =>-   process (ParameterValue n a, v) v+   (Marshal.C a, MultiValue.PseudoRing a, MultiValue.IntegerConstant a,+    Serial.Write v, Serial.Element v ~ MultiValue.T a,+    Memory.C v, A.PseudoRing v, A.IntegerConstant v,+    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>+   Causal.T (ParameterValue n a, v) v causalPacked = causalGen Filt2.causalPacked  causalGen ::-   (Causal.C process, IsSized a, Tuple.Phi v, Tuple.Undefined v,+   (Marshal.C a, Tuple.Phi v, Tuple.Undefined v,     TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   process (Filt2Core.Parameter (Value a), v) v ->-   process (ParameterValue n a, v) v+   Causal.T (Filt2.Parameter (MultiValue.T a), v) v ->+   Causal.T (ParameterValue n a, v) v causalGen stage =    withSize $ \n ->       snd@@ -161,17 +129,17 @@       <<<       Causal.map          (\(ptr, (p,v)) -> do-            LLVM.store (parameterValue p) ptr+            Memory.store (parameterValue p) ptr             return (ptr, (A.zero, v)))       $<       Sig.alloca  paramStage ::-   (Causal.C process, IsSized a,-    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   process (Filt2Core.Parameter (Value a), v) v ->-   process-      (Value (LLVM.Ptr (ParameterStruct n a)), (Value Word, v)) (Value Word, v)+   (TypeNum.Natural n, Marshal.C a) =>+   Causal.T (Filt2.Parameter (MultiValue.T a), v) v ->+   Causal.T+      (LLVM.Value (LLVM.Ptr (ParameterStruct n a)), (LLVM.Value Word, v))+      (LLVM.Value Word, v) paramStage stage =    let p = arr fst        i = arr (fst.snd)@@ -183,59 +151,12 @@            &&&            v) -_paramStage ::-   (IsSized a,-    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   CausalP.T p (Filt2Core.Parameter (Value a), v) v ->-   CausalP.T p-      (Value (LLVM.Ptr (ParameterStruct n a)), (Value Word, v)) (Value Word, v)-_paramStage stage =-   Func.withGuidedArgs (Func.atom, (Func.atom, Func.atom)) $ \(p,(i,v)) ->-      liftA2 (,) (i+1)-         (stage $&-             (Causal.zipWith getStageParameterGEP $& p &|& i)-             &|&-             v)--_causalGenP ::-   (Causal.C process, IsSized a,-    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   process (Filt2Core.Parameter (Value a), v) v ->-   process (ParameterValue n a, v) v-_causalGenP stage =-   withSize $ \n ->-   foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $-   map-      (\k ->-         stage <<<-         Arrow.first (Causal.map (flip getStageParameter k)))-      (take (TypeNum.integralFromSingleton n) [0..])---getStageParameter ::-   (IsSized a,-    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   ParameterValue n a ->-   Word ->-   CodeGenFunction r (Filt2Core.Parameter (Value a))-getStageParameter ps k =-   Filt2.decomposeParameter =<< LLVM.extractvalue (parameterValue ps) k-{--   Memory.decompose =<<-   flip LLVM.extractvalue k =<<-   Memory.compose ps--}- getStageParameterGEP ::-   (IsSized a,-    TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   Value (LLVM.Ptr (ParameterStruct n a)) ->-   Value Word -> CodeGenFunction r (Filt2Core.Parameter (Value a))+   (TypeNum.Natural n,  Marshal.C a) =>+   LLVM.Value (LLVM.Ptr (ParameterStruct n a)) ->+   LLVM.Value Word ->+   LLVM.CodeGenFunction r (Filt2.Parameter (MultiValue.T a)) getStageParameterGEP ptr k =-   Filt2.decomposeParameter+   Filt2.decomposeParameterMV     =<< LLVM.load     =<< LLVM.getElementPtr0 ptr (k, ())---{-# DEPRECATED causalP          "use 'causal' instead" #-}-{-# DEPRECATED causalPackedP    "use 'causalPacked' instead" #-}
src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -1,37 +1,34 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Filter.SecondOrderPacked (-   Parameter, bandpassParameter, State, causal, causalP,+   Parameter, ParameterExp, bandpassParameter, State, causal,    ) where  import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2L import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector+import qualified Synthesizer.LLVM.Causal.Private as Causal++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM-import LLVM.Core-   (Value, valueOf, Struct,-    IsFirstClass, IsFloating,-    Vector, IsPrimitive, IsSized,-    CodeGenFunction) -import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (D4, d0, d1, (:*:))+import Type.Data.Num.Decimal (D4, d0, d1)  import Control.Applicative (liftA2) -import qualified Algebra.Transcendental as Trans- import NumericPrelude.Numeric import NumericPrelude.Base @@ -41,10 +38,9 @@  > c0 [c1 d1 c2 d2] -}-data Parameter a =-   Parameter (Value a) (Value (Vector D4 a))+data Parameter a = Parameter (MultiValue.T a) (MultiVector.T D4 a) -instance (IsFirstClass a, IsPrimitive a) => Tuple.Phi (Parameter a) where+instance (MultiVector.C a) => Tuple.Phi (Parameter a) where    phi bb (Parameter r i) = do       r' <- Tuple.phi bb r       i' <- Tuple.phi bb i@@ -53,23 +49,21 @@       Tuple.addPhi bb r r'       Tuple.addPhi bb i i' -instance (IsFirstClass a, IsPrimitive a) => Tuple.Undefined (Parameter a) where+instance (MultiVector.C a) => Tuple.Undefined (Parameter a) where    undef = Parameter Tuple.undef Tuple.undef  -type ParameterStruct a = Struct (a, (Vector D4 a, ()))+type ParameterStruct a = Memory.Struct (MultiValue.T a, MultiVector.T D4 a)  parameterMemory ::-   (IsPrimitive a, IsSized a, TypeNum.Positive (D4 :*: LLVM.SizeOf a)) =>+   (Marshal.C a, Marshal.Vector D4 a) =>    Memory.Record r (ParameterStruct a) (Parameter a) parameterMemory =    liftA2 Parameter       (Memory.element (\(Parameter c0 _) -> c0) d0)       (Memory.element (\(Parameter _ cd) -> cd) d1) -instance-   (IsPrimitive a, IsSized a, TypeNum.Positive (D4 :*: LLVM.SizeOf a)) =>-      Memory.C (Parameter a) where+instance (Marshal.C a, Marshal.Vector D4 a) => Memory.C (Parameter a) where    type Struct (Parameter a) = ParameterStruct a    load = Memory.loadRecord parameterMemory    store = Memory.storeRecord parameterMemory@@ -77,44 +71,60 @@    compose = Memory.composeRecord parameterMemory  -type State = Vector D4+data ParameterExp a =+   ParameterExp (forall r. LLVM.CodeGenFunction r (Parameter a)) +instance Expr.Aggregate (ParameterExp a) (Parameter a) where+   type MultiValuesOf (ParameterExp a) = Parameter a+   type ExpressionsOf (Parameter a) = ParameterExp a+   dissect x = ParameterExp (return x)+   bundle (ParameterExp code) = code ++type State = MultiVector.T D4++ {-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} bandpassParameter ::-   (Trans.C a, IsFloating a, SoV.TranscendentalConstant a, IsPrimitive a) =>-   Value a ->-   Value a ->-   CodeGenFunction r (Parameter a)-bandpassParameter reson cutoff = do-   p <- Filt2L.bandpassParameter reson cutoff-   v <- Vector.assemble [Filt2.c1 p, Filt2.d1 p, Filt2.c2 p, Filt2.d2 p]+   (MultiVector.C a, MultiValue.Transcendental a,+    MultiValue.RationalConstant a) =>+   Exp a -> Exp a -> ParameterExp a+bandpassParameter (Exp reson) (Exp cutoff) =+   ParameterExp (do+      r <- reson+      c <- cutoff+      bandpassParameterCode r c)++bandpassParameterCode ::+   (MultiVector.C a, MultiValue.Transcendental a,+    MultiValue.RationalConstant a) =>+   MultiValue.T a ->+   MultiValue.T a ->+   LLVM.CodeGenFunction r (Parameter a)+bandpassParameterCode reson cutoff = do+   p <- Filt2L.bandpassParameterCode reson cutoff+   v <-+      MultiVector.assembleFromVector $ fmap ($ p) $+      LLVM.consVector Filt2.c1 Filt2.d1 Filt2.c2 Filt2.d2    return $ Parameter (Filt2.c0 p) v   next ::-   (Vector.Arithmetic a) =>-   (Parameter a, Value a) ->-   Value (State a) ->-   CodeGenFunction r (Value a, Value (State a))+   (MultiVector.PseudoRing a) =>+   (Parameter a, MultiValue.T a) ->+   State a ->+   LLVM.CodeGenFunction r (MultiValue.T a, State a) next (Parameter c0 k1, x0) y1 = do    s0 <- A.mul c0 x0-   s1 <- Vector.dotProduct k1 y1+   s1 <- MultiVector.dotProduct k1 y1    y0 <- A.add s0 s1-   x1new <- Vector.extract (valueOf 0) y1-   y1new <- Vector.extract (valueOf 1) y1-   yv <- Vector.assemble [x0, y0, x1new, y1new]+   x1new <- MultiVector.extract (LLVM.valueOf 0) y1+   y1new <- MultiVector.extract (LLVM.valueOf 1) y1+   yv <- MultiVector.assembleFromVector $ LLVM.consVector x0 y0 x1new y1new    return (y0, yv)  causal ::-   (Causal.C process,-    Vector.Arithmetic a, Value (State a) ~ value, Memory.C value) =>-   process (Parameter a, Value a) (Value a)-causal =-   Causal.mapAccum next (return A.zero)--{-# DEPRECATED causalP "use causal instead" #-}-causalP ::-   (Vector.Arithmetic a, Value (State a) ~ value, Memory.C value) =>-   CausalP.T p (Parameter a, Value a) (Value a)-causalP = causal+   (MultiVector.PseudoRing a) =>+   (Marshal.Vector D4 a) =>+   Causal.T (Parameter a, MultiValue.T a) (MultiValue.T a)+causal = Causal.mapAccum next (return A.zero)
src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -1,22 +1,31 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Universal (    Result(Result, lowpass, highpass, bandpass, bandlimit),-   Parameter, parameter, causal, causalP,+   Parameter, parameter, causal,+   parameterCode, causalExp,+   multiValueResult, unMultiValueResult,+   multiValueParameter, unMultiValueParameter,    ) where  import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal import Synthesizer.Plain.Filter.Recursive.Universal-          (Parameter(Parameter), Result)+          (Parameter(Parameter), Result(..)) import Synthesizer.Plain.Filter.Recursive (Pole(..))  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.Simple.Value as Value+import qualified Synthesizer.LLVM.Causal.Process as CausalExp+import qualified Synthesizer.LLVM.Causal.ProcessValue as Causal+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial+import qualified Synthesizer.LLVM.Value as Value +import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory@@ -30,9 +39,15 @@ import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, d5)  import qualified Control.Applicative.HT as App-import Control.Applicative ((<$>))+import Control.Applicative (liftA2, (<$>)) +import qualified Data.Foldable as Fold+import Data.Traversable (traverse) +import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module as Module++ instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where    phi = Tuple.phiTraversable    addPhi = Tuple.addPhiFoldable@@ -74,14 +89,28 @@    load = Storable.loadApplicative    store = Storable.storeFoldable -{--instance LLVM.ValueTuple a => LLVM.ValueTuple (Result a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) -instance LLVM.IsTuple a => LLVM.IsTuple (Result a) where-   tupleDesc = Class.tupleDescFoldable--} +type ResultStruct a = LLVM.Struct (a, (a, (a, (a, ()))))++resultMemory ::+   (Memory.C a) =>+   Memory.Record r (ResultStruct (Memory.Struct a)) (Result a)+resultMemory =+   App.lift4 Result+      (Memory.element Universal.highpass  d0)+      (Memory.element Universal.bandpass  d1)+      (Memory.element Universal.lowpass   d2)+      (Memory.element Universal.bandlimit d3)+++instance (Memory.C a) => Memory.C (Result a) where+   type Struct (Result a) = ResultStruct (Memory.Struct a)+   load = Memory.loadRecord resultMemory+   store = Memory.storeRecord resultMemory+   decompose = Memory.decomposeRecord resultMemory+   compose = Memory.composeRecord resultMemory+ instance (Tuple.Value a) => Tuple.Value (Result a) where    type ValueOf (Result a) = Result (Tuple.ValueOf a)    valueOf = Tuple.valueOfFunctor@@ -91,15 +120,40 @@    flattenCode = Value.flattenCodeTraversable    unfoldCode = Value.unfoldCodeTraversable +instance (MultiValue.C a) => MultiValue.C (Result a) where+   type Repr (Result a) = Result (MultiValue.Repr a)+   cons = multiValueResult . fmap MultiValue.cons+   undef = multiValueResult $ pure MultiValue.undef+   zero = multiValueResult $ pure MultiValue.zero+   phi bb =+      fmap multiValueResult .+      traverse (MultiValue.phi bb) . unMultiValueResult+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb)+         (unMultiValueResult a) (unMultiValueResult b) -{--instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)+multiValueResult ::+   Result (MultiValue.T a) -> MultiValue.T (Result a)+multiValueResult = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a) -instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where-   tupleDesc = Class.tupleDescFoldable--}+unMultiValueResult ::+   MultiValue.T (Result a) -> Result (MultiValue.T a)+unMultiValueResult (MultiValue.Cons x) = fmap MultiValue.Cons x +instance (MarshalMV.C a) => MarshalMV.C (Result a) where+   pack p =+      case MarshalMV.pack <$> p of+         Result hp bp lp bl -> LLVM.consStruct hp bp lp bl+   unpack = fmap MarshalMV.unpack . LLVM.uncurryStruct Result++instance (Expr.Aggregate e mv) => Expr.Aggregate (Result e) (Result mv) where+   type MultiValuesOf (Result e) = Result (Expr.MultiValuesOf e)+   type ExpressionsOf (Result mv) = Result (Expr.ExpressionsOf mv)+   bundle = traverse Expr.bundle+   dissect = fmap Expr.dissect++ instance (Tuple.Value a) => Tuple.Value (Parameter a) where    type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a)    valueOf = Tuple.valueOfFunctor@@ -109,7 +163,43 @@    flattenCode = Value.flattenCodeTraversable    unfoldCode = Value.unfoldCodeTraversable +instance (MultiValue.C a) => MultiValue.C (Parameter a) where+   type Repr (Parameter a) = Parameter (MultiValue.Repr a)+   cons = multiValueParameter . fmap MultiValue.cons+   undef = multiValueParameter $ pure MultiValue.undef+   zero = multiValueParameter $ pure MultiValue.zero+   phi bb =+      fmap multiValueParameter .+      traverse (MultiValue.phi bb) . unMultiValueParameter+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb)+         (unMultiValueParameter a) (unMultiValueParameter b) +multiValueParameter ::+   Parameter (MultiValue.T a) -> MultiValue.T (Parameter a)+multiValueParameter = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++unMultiValueParameter ::+   MultiValue.T (Parameter a) -> Parameter (MultiValue.T a)+unMultiValueParameter (MultiValue.Cons x) = fmap MultiValue.Cons x++instance (MarshalMV.C a) => MarshalMV.C (Parameter a) where+   pack p =+      case MarshalMV.pack <$> p of+         Parameter k1 k2 ampIn ampI1 ampI2 ampLimit ->+            LLVM.consStruct k1 k2 ampIn ampI1 ampI2 ampLimit+   unpack = fmap MarshalMV.unpack . LLVM.uncurryStruct Parameter++instance+   (Expr.Aggregate e mv) =>+      Expr.Aggregate (Parameter e) (Parameter mv) where+   type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e)+   type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)+   bundle = traverse Expr.bundle+   dissect = fmap Expr.dissect++ instance (Vector.Simple v) => Vector.Simple (Parameter v) where    type Element (Parameter v) = Parameter (Vector.Element v)    type Size (Parameter v) = Vector.Size v@@ -146,7 +236,7 @@    readStart = Serial.readStartTraversable    readNext = Serial.readNextTraversable -instance (Serial.C v) => Serial.C (Result v) where+instance (Serial.Write v) => Serial.Write (Result v) where    type WriteIt (Result v) = Result (Serial.WriteIt v)    insert  = Serial.insertTraversable    writeStart = Serial.writeStartTraversable@@ -154,14 +244,17 @@    writeStop = Serial.writeStopTraversable  -parameter ::+parameterCode ::    (A.Transcendental a, A.RationalConstant a) =>    a -> a -> CodeGenFunction r (Parameter a)-parameter =+parameterCode =    Value.unlift2 $ \reson freq ->    Universal.parameter (Pole reson freq) +parameter :: (Trans.C a) => a -> a -> Parameter a+parameter reson freq = Universal.parameter (Pole reson freq) + modifier ::    (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>    Modifier.Simple@@ -172,16 +265,14 @@    Universal.modifier  causal ::-   (Causal.C process,-    a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>-   process (Parameter a, v) (Result v)+   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>+   Causal.T (Parameter a, v) (Result v) causal = Causal.fromModifier modifier -{-# DEPRECATED causalP "use causal instead" #-}-causalP ::-   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a, Memory.C v) =>-   CausalP.T p (Parameter a, v) (Result v)-causalP = causal+causalExp ::+   (Module.C ae ve, Expr.Aggregate ae a, Expr.Aggregate ve v, Memory.C v) =>+   CausalExp.T (Parameter a, v) (Result v)+causalExp = CausalExp.fromModifier Universal.modifier  {- The state variable filter could be vectorised
src/Synthesizer/LLVM/ForeignPtr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {- | Adding the finalizer to a ForeignPtr seems to be the only way that warrants execution of the finalizer (not too early and not never).@@ -12,6 +13,7 @@ module Synthesizer.LLVM.ForeignPtr where  import qualified LLVM.DSL.Execution as Exec+import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Core as LLVM@@ -47,6 +49,14 @@    b -> IO (MemoryPtr a) newParam stop start b =    newInit stop (Marshal.with b start)++newParamMV ::+   (MarshalMV.C b) =>+   Exec.Finalizer a ->+   (LLVM.Ptr (MarshalMV.Struct b) -> IO (LLVM.Ptr a)) ->+   b -> IO (MemoryPtr a)+newParamMV stop start b =+   newInit stop (MarshalMV.with b start)  new ::    (Marshal.C a, Marshal.Struct a ~ struct) =>
src/Synthesizer/LLVM/Frame/Binary.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Synthesizer.LLVM.Frame.Binary (    toCanonical,    ) where
src/Synthesizer/LLVM/Frame/SerialVector.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-} {- | A special vector type that represents a time-sequence of samples. This way we can distinguish safely between LLVM vectors@@ -14,648 +11,99 @@ -} module Synthesizer.LLVM.Frame.SerialVector (    T(Cons),-   Plain, Value,-   plain, value, constant,--   Read, Element, ReadIt, extract, readStart, readNext,-   C, WriteIt, insert, writeStart, writeNext, writeStop,-   Zero, writeZero,-   Iterator(Iterator), ReadIterator, WriteIterator, ReadMode, WriteMode,--   Sized, Size, size, sizeOfIterator, withSize,--   insertTraversable, extractTraversable,-   readStartTraversable, readNextTraversable,-   writeStartTraversable, writeNextTraversable, writeStopTraversable,-   writeZeroTraversable,--   extractAll, assemble, modify,+   fromFixedList,    upsample, subsample,-   cumulate, iterate, iteratePlain, reverse,-   shiftUp, shiftUpMultiZero, shiftDownMultiZero,-   replicate, replicate_, replicateOf, fromList, fromFixedList,-   mapPlain, mapV, zipV,+   shiftUp,+   reverse, iterate, cumulate,+   limit,+   select, cmp,    ) where -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Code+import Synthesizer.LLVM.Frame.SerialVector.Code+         (T, fromMultiVector, toMultiVector) -import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.DSL.Expression.Vector as ExprVec+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum -import qualified Foreign.Storable as St import Data.Word (Word32) -import Control.Monad (liftM2, liftM3, foldM, replicateM, (<=<))-import Control.Applicative (liftA2)-import qualified Control.Monad.Trans.State as MS-import qualified Control.Applicative as App-import qualified Data.Traversable as Trav--import qualified Data.NonEmpty.Class as NonEmptyC-import qualified Data.NonEmpty as NonEmpty-import qualified Data.List.HT as ListHT-import qualified Data.List as List-import Data.Tuple.HT (mapSnd, fst3, snd3, thd3)--import Prelude hiding (Read, replicate, reverse, iterate)---{--This datatype can be used for both Haskell vector and LLVM.Value Vector.-It should not contain tuples of vectors,-since the interpretation is:-"Everything inside Cons will be virtually concatenated."--We tried to use distinct types (T n a) and (Value n a)-for Haskell and LLVM objects, respectively,-but then GHC-6.12.3 to GHC-7.4.1 could not perform the GeneralizedNewtypeDeriving,-because it was not able to add a (IsPositive n ~ True) constraint-to the instances.--The disadvantage of this approach is,-that we cannot have a type that contains both parallel and serial data.--}-newtype T v = Cons v-   deriving (-      Eq, St.Storable,-      Tuple.Zero, Tuple.Undefined,-      A.IntegerConstant, A.RationalConstant, Num)---      SoV.IntegerConstant, SoV.RationalConstant, SoV.TranscendentalConstant)--instance (Tuple.Phi v) => Tuple.Phi (T v) where-   phi bb (Cons v) = fmap Cons $ Tuple.phi bb v-   addPhi bb (Cons x) (Cons y) = Tuple.addPhi bb x y--instance (A.Additive v) => A.Additive (T v) where-   add = lift2 A.add-   sub = lift2 A.sub-   neg = lift1 A.neg-   zero = Cons A.zero--instance (A.PseudoRing v) => A.PseudoRing (T v) where-   mul = lift2 A.mul--instance (A.Real v) => A.Real (T v) where-   min = lift2 A.min-   max = lift2 A.max-   abs = lift1 A.abs-   signum = lift1 A.signum--instance (A.Fraction v) => A.Fraction (T v) where-   truncate = lift1 A.truncate-   fraction = lift1 A.fraction--instance (A.Field v) => A.Field (T v) where-   fdiv = lift2 A.fdiv--instance (A.Algebraic v) => A.Algebraic (T v) where-   sqrt = lift1 A.sqrt--instance (A.Transcendental v) => A.Transcendental (T v) where-   pi  = fmap Cons A.pi-   sin = lift1 A.sin-   log = lift1 A.log-   exp = lift1 A.exp-   cos = lift1 A.cos-   pow = lift2 A.pow---lift1 :: Functor f => (a -> f b) -> T a -> f (T b)-lift1 f (Cons x) = fmap Cons $ f x--lift2 :: Functor f => (a -> b -> f c) -> T a -> T b -> f (T c)-lift2 f (Cons x) (Cons y) = fmap Cons $ f x y---type instance A.Scalar (T v) = A.Scalar v-instance (A.PseudoModule v) => A.PseudoModule (T v) where-   scale a (Cons v) = fmap Cons $ A.scale a v---type Plain n a = T (LLVM.Vector n a)-type Value n a = T (LLVM.Value (LLVM.Vector n a))---plain :: LLVM.Vector n a -> Plain n a-plain = Cons--value :: LLVM.Value (LLVM.Vector n a) -> Value n a-value = Cons+import Prelude hiding (replicate, reverse, iterate)  -replicate :: (TypeNum.Positive n) => a -> Plain n a-replicate x = Cons $ App.pure x--replicate_ :: (TypeNum.Positive n) => TypeNum.Singleton n -> a -> Plain n a-replicate_ _ = replicate--replicateOf :: (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsConst a) => a -> Value n a-replicateOf x = Cons $ LLVM.valueOf $ App.pure x--fromList :: (TypeNum.Positive n) => NonEmpty.T [] a -> Plain n a-fromList = Cons . LLVM.cyclicVector- fromFixedList ::-   (TypeNum.Positive n) =>-   LLVM.FixedList (TypeNum.ToUnary n) a -> Plain n a-fromFixedList = Cons . LLVM.vector+   (TypeNum.Positive n, MultiVector.C a) =>+   LLVM.FixedList (TypeNum.ToUnary n) a -> Exp (T n a)+fromFixedList = fromOrdinary . Expr.cons . LLVM.vector -constant :: (TypeNum.Positive n) => a -> T (Vector.Constant n a)-constant = Cons . Vector.constant  -newtype Iterator mode it v = Iterator {unIterator :: it}-   deriving (Tuple.Undefined)--instance Tuple.Phi it => Tuple.Phi (Iterator mode it v) where-   phi bb (Iterator x) = fmap Iterator $ Tuple.phi bb x-   addPhi bb (Iterator x) (Iterator y) = Tuple.addPhi bb x y---type ReadIterator = Iterator ReadMode-type WriteIterator = Iterator WriteMode--data ReadMode-data WriteMode---instance (Memory.C it) => Memory.C (Iterator mode it v) where-   type Struct (Iterator mode it v) = Memory.Struct it-   load = Memory.loadNewtype Iterator-   store = Memory.storeNewtype (\(Iterator v) -> v)-   decompose = Memory.decomposeNewtype Iterator-   compose = Memory.composeNewtype (\(Iterator v) -> v)---fmapIt ::-   (ita -> itb) -> (va -> vb) ->-   Iterator mode ita va -> Iterator mode itb vb-fmapIt f _ (Iterator a) = Iterator (f a)---combineIt2 :: Iterator mode xa va -> Iterator mode xb vb -> Iterator mode (xa,xb) (va,vb)-combineIt2 (Iterator va) (Iterator vb) = Iterator (va,vb)--combineIt3 :: Iterator mode xa va -> Iterator mode xb vb -> Iterator mode xc vc -> Iterator mode (xa,xb,xc) (va,vb,vc)-combineIt3 (Iterator va) (Iterator vb) (Iterator vc) = Iterator (va,vb,vc)--combineItFunctor ::-   (Functor f) =>-   f (Iterator mode x v) -> Iterator mode (f x) (f v)-combineItFunctor =-   Iterator . fmap unIterator--sequenceItFunctor ::-   (Functor f) =>-   Iterator mode (f it) (f v) ->-   f (Iterator mode it v)-sequenceItFunctor =-   fmap Iterator . unIterator---class-   (TypeNum.Positive (Size v), Sized v,-    Tuple.Phi (ReadIt v), Tuple.Undefined (ReadIt v),-    Tuple.Phi v, Tuple.Undefined v) =>-      Read v where--   type Element v :: *-   type ReadIt v :: *--   extract :: LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r (Element v)--   extractAll :: v -> LLVM.CodeGenFunction r [Element v]-   extractAll x =-      mapM-         (flip extract x . LLVM.valueOf)-         (take (size x) [0..])--   readStart :: v -> LLVM.CodeGenFunction r (ReadIterator (ReadIt v) v)-   readNext ::-      ReadIterator (ReadIt v) v ->-      LLVM.CodeGenFunction r (Element v, ReadIterator (ReadIt v) v)--class (Read v, Tuple.Phi (WriteIt v), Tuple.Undefined (WriteIt v)) => C v where-   type WriteIt v :: *--   insert :: LLVM.Value Word32 -> Element v -> v -> LLVM.CodeGenFunction r v--   assemble :: [Element v] -> LLVM.CodeGenFunction r v-   assemble =-      foldM (\v (k,x) -> insert (LLVM.valueOf k) x v) Tuple.undef .-      zip [0..]--   writeStart :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v)-   writeNext ::-      Element v -> WriteIterator (WriteIt v) v ->-      LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v)-   writeStop :: WriteIterator (WriteIt v) v -> LLVM.CodeGenFunction r v--class (C v, Tuple.Phi (WriteIt v), Tuple.Zero (WriteIt v)) => Zero v where-   -- initializes the target with zeros-   -- you may only call 'writeStop' on the result of 'writeZero'-   writeZero :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v)--instance (Vector.Simple v) => Sized (T v) where-   type Size (T v) = Vector.Size v--{- |-This instance also allows to wrap tuples of vectors,-but you cannot reasonably use them,-because it would mean to serialize vectors with different element types.--}-instance (Vector.Simple v) => Read (T v) where--   type Element (T v) = Vector.Element v-   type ReadIt (T v) = v--   extract k (Cons v) = Vector.extract k v--   readStart (Cons v) = return $ Iterator v-   readNext (Iterator v0) = do-      x <- Vector.extract (LLVM.valueOf 0) v0-      v1 <- Vector.rotateDown v0-      return (x, Iterator v1)---instance (Vector.C v) => C (T v) where-   type WriteIt (T v) = v--   insert k a (Cons v) = fmap Cons $ Vector.insert k a v--   writeStart = return (Iterator Tuple.undef)-   writeNext x (Iterator v0) = do-      v1 <- fmap snd $ Vector.shiftDown x v0-      return (Iterator v1)-   writeStop (Iterator v0) = return (Cons v0)--instance (Vector.C v, Tuple.Zero v) => Zero (T v) where-   writeZero = return (Iterator Tuple.zero)---instance-   (Read va, Read vb, Size va ~ Size vb) =>-      Read (va, vb) where--   type Element (va, vb) = (Element va, Element vb)-   type ReadIt (va, vb) = (ReadIt va, ReadIt vb)--   extract k (va,vb) =-      liftM2 (,)-         (extract k va)-         (extract k vb)--   readStart (va,vb) =-      liftM2 combineIt2 (readStart va) (readStart vb)-   readNext it = do-      (a, ita) <- readNext $ fmapIt fst fst it-      (b, itb) <- readNext $ fmapIt snd snd it-      return ((a,b), combineIt2 ita itb)--instance-   (C va, C vb, Size va ~ Size vb) =>-      C (va, vb) where--   type WriteIt (va, vb) = (WriteIt va, WriteIt vb)--   insert k (a,b) (va,vb) =-      liftM2 (,)-         (insert k a va)-         (insert k b vb)--   writeStart =-      liftM2 combineIt2 writeStart writeStart-   writeNext (a,b) it =-      liftM2 combineIt2-         (writeNext a $ fmapIt fst fst it)-         (writeNext b $ fmapIt snd snd it)-   writeStop it =-      liftM2 (,)-         (writeStop (fmapIt fst fst it))-         (writeStop (fmapIt snd snd it))--instance-   (Zero va, Zero vb, Size va ~ Size vb) =>-      Zero (va, vb) where--   writeZero =-      liftM2 combineIt2 writeZero writeZero---instance-   (Read va, Read vb, Read vc,-    Size va ~ Size vb,-    Size vb ~ Size vc) =>-      Read (va, vb, vc) where--   type Element (va, vb, vc) = (Element va, Element vb, Element vc)-   type ReadIt (va, vb, vc) = (ReadIt va, ReadIt vb, ReadIt vc)--   extract k (va,vb,vc) =-      liftM3 (,,)-         (extract k va)-         (extract k vb)-         (extract k vc)--   readStart (va,vb,vc) =-      liftM3 combineIt3 (readStart va) (readStart vb) (readStart vc)-   readNext it = do-      (a, ita) <- readNext $ fmapIt fst3 fst3 it-      (b, itb) <- readNext $ fmapIt snd3 snd3 it-      (c, itc) <- readNext $ fmapIt thd3 thd3 it-      return ((a,b,c), combineIt3 ita itb itc)---instance-   (C va, C vb, C vc,-    Size va ~ Size vb,-    Size vb ~ Size vc) =>-      C (va, vb, vc) where--   type WriteIt (va, vb, vc) = (WriteIt va, WriteIt vb, WriteIt vc)--   insert k (a,b,c) (va,vb,vc) =-      liftM3 (,,)-         (insert k a va)-         (insert k b vb)-         (insert k c vc)--   writeStart =-      liftM3 combineIt3 writeStart writeStart writeStart-   writeNext (a,b,c) it =-      liftM3 combineIt3-         (writeNext a $ fmapIt fst3 fst3 it)-         (writeNext b $ fmapIt snd3 snd3 it)-         (writeNext c $ fmapIt thd3 thd3 it)-   writeStop it =-      liftM3 (,,)-         (writeStop (fmapIt fst3 fst3 it))-         (writeStop (fmapIt snd3 snd3 it))-         (writeStop (fmapIt thd3 thd3 it))--instance-   (Zero va, Zero vb, Zero vc,-    Size va ~ Size vb,-    Size vb ~ Size vc) =>-      Zero (va, vb, vc) where--   writeZero =-      liftM3 combineIt3 writeZero writeZero writeZero---instance (Read v) => Read (Stereo.T v) where--   type Element (Stereo.T v) = Stereo.T (Element v)-   type ReadIt (Stereo.T v) = Stereo.T (ReadIt v)--   extract = extractTraversable--   readStart = readStartTraversable-   readNext = readNextTraversable--instance (C v) => C (Stereo.T v) where--   type WriteIt (Stereo.T v) = Stereo.T (WriteIt v)--   insert = insertTraversable--   writeStart = writeStartTraversable-   writeNext = writeNextTraversable-   writeStop = writeStopTraversable--instance (Zero v) => Zero (Stereo.T v) where--   writeZero = writeZeroTraversable---modify ::-   (C v) =>-   LLVM.Value Word32 ->-   (Element v -> LLVM.CodeGenFunction r (Element v)) ->-   v -> LLVM.CodeGenFunction r v-modify k f v = do-   flip (insert k) v =<< f =<< extract k v---subsample ::-   (Read v) =>-   v -> LLVM.CodeGenFunction r (Element v)-subsample v =-   extract (A.zero :: LLVM.Value Word32) v+subsample :: (TypeNum.Positive n, MultiVector.C a) => Exp (T n a) -> Exp a+subsample =+   Expr.liftM (MultiValueVec.extract (A.zero :: LLVM.Value Word32)) . toOrdinary --- this will be translated to an efficient pshufd-upsample ::-   (C v) =>-   Element v -> LLVM.CodeGenFunction r v-upsample x =-   withSize $ \n -> assemble $ List.replicate n x+upsample :: (TypeNum.Positive n, MultiVector.C a) => Exp a -> Exp (T n a)+upsample = fromOrdinary . ExprVec.replicate  -cumulate ::-   (Vector.Arithmetic a, TypeNum.Positive n) =>-   LLVM.Value a -> Value n a ->-   LLVM.CodeGenFunction r (LLVM.Value a, Value n a)-cumulate x (Cons v) =-   fmap (mapSnd Cons) $ Vector.cumulate x v+shiftUp ::+   (TypeNum.Positive n, MultiVector.C x, Exp x ~ a, Exp (T n x) ~ v) =>+   a -> v -> (a, v)+shiftUp a v =+   (Expr.liftM2 ((fmap fst .) . Code.shiftUp) a v,+    Expr.liftM2 ((fmap snd .) . Code.shiftUp) a v)  -mapPlain ::-   (TypeNum.Positive n) => (a -> b) -> Plain n a -> Plain n b-mapPlain f (Cons v) = Cons $ fmap f v--iteratePlain ::-   (TypeNum.Positive n) => (a -> a) -> a -> Plain n a-iteratePlain f x = fromList $ NonEmptyC.iterate f x- iterate ::-   (C v) =>-   (Element v -> LLVM.CodeGenFunction r (Element v)) ->-   Element v -> LLVM.CodeGenFunction r v-iterate f x =-   withSize $ \n ->-      assemble =<<-      (flip MS.evalStateT x $-       replicateM n $-       MS.StateT $ \x0 -> do x1 <- f x0; return (x0,x1))+   (TypeNum.Positive n, MultiVector.C a) =>+   (Exp a -> Exp a) -> Exp a -> Exp (T n a)+iterate f = fromOrdinary . ExprVec.iterate f  reverse ::-   (C v) =>-   v -> LLVM.CodeGenFunction r v+   (TypeNum.Positive n, MultiVector.C a) =>+   Exp (T n a) -> Exp (T n a) reverse =-   assemble . List.reverse <=< extractAll--shiftUp ::-   (C v) =>-   Element v -> v -> LLVM.CodeGenFunction r (Element v, v)-shiftUp x v =-   ListHT.switchR-      (return (x,v))-      (\ys0 y -> fmap ((,) y) $ assemble (x:ys0))-   =<<-   extractAll v---shiftUpMultiZero ::-   (C v, A.Additive (Element v)) =>-   Int -> v -> LLVM.CodeGenFunction r v-shiftUpMultiZero n v =-   assemble . take (size v) . (List.replicate n A.zero ++) =<< extractAll v--shiftDownMultiZero ::-   (C v, A.Additive (Element v)) =>-   Int -> v -> LLVM.CodeGenFunction r v-shiftDownMultiZero n v =-   assemble . take (size v) . (++ List.repeat A.zero) . List.drop n-      =<< extractAll v---insertTraversable ::-   (C v, Trav.Traversable f, App.Applicative f) =>-   LLVM.Value Word32 -> f (Element v) -> f v -> LLVM.CodeGenFunction r (f v)-insertTraversable n a v =-   Trav.sequence (liftA2 (insert n) a v)--extractTraversable ::-   (Read v, Trav.Traversable f) =>-   LLVM.Value Word32 -> f v -> LLVM.CodeGenFunction r (f (Element v))-extractTraversable n v =-   Trav.mapM (extract n) v---readStartTraversable ::-   (Trav.Traversable f, App.Applicative f, Read v) =>-   f v -> LLVM.CodeGenFunction r (ReadIterator (f (ReadIt v)) (f v))-readNextTraversable ::-   (Trav.Traversable f, App.Applicative f, Read v) =>-   ReadIterator (f (ReadIt v)) (f v) ->-   LLVM.CodeGenFunction r (f (Element v), ReadIterator (f (ReadIt v)) (f v))--readStartTraversable v =-   fmap combineItFunctor $ Trav.mapM readStart v--readNextTraversable it = do-   st <- Trav.mapM readNext $ sequenceItFunctor it-   return (fmap fst st, combineItFunctor $ fmap snd st)---writeStartTraversable ::-   (Trav.Traversable f, App.Applicative f, C v) =>-   LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v))-writeNextTraversable ::-   (Trav.Traversable f, App.Applicative f, C v) =>-   f (Element v) -> WriteIterator (f (WriteIt v)) (f v) ->-   LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v))-writeStopTraversable ::-   (Trav.Traversable f, App.Applicative f, C v) =>-   WriteIterator (f (WriteIt v)) (f v) -> LLVM.CodeGenFunction r (f v)-writeZeroTraversable ::-   (Trav.Traversable f, App.Applicative f, Zero v) =>-   LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v))--writeStartTraversable =-   fmap combineItFunctor $ Trav.sequence $ App.pure writeStart--writeNextTraversable x it =-   fmap combineItFunctor $ Trav.sequence $-   liftA2 writeNext x $ sequenceItFunctor it--writeStopTraversable = Trav.mapM writeStop . sequenceItFunctor--writeZeroTraversable =-   fmap combineItFunctor $ Trav.sequence $ App.pure writeZero---instance (Tuple.Value v) => Tuple.Value (T v) where-   type ValueOf (T v) = T (Tuple.ValueOf v)-   valueOf (Cons v) = Cons (Tuple.valueOf v)--instance (Memory.C v) => Memory.C (T v) where-   type Struct (T v) = Memory.Struct v-   load = Memory.loadNewtype Cons-   store = Memory.storeNewtype (\(Cons v) -> v)-   decompose = Memory.decomposeNewtype Cons-   compose = Memory.composeNewtype (\(Cons v) -> v)--instance (Marshal.C v) => Marshal.C (T v) where-   pack (Cons v) = Marshal.pack v-   unpack v = Cons $ Marshal.unpack v--instance (Storable.C v) => Storable.C (T v) where-   load = Storable.loadNewtype Cons Cons-   store = Storable.storeNewtype Cons (\(Cons v) -> v)+   Expr.liftM (fmap fromMultiVector . MultiVector.reverse . toMultiVector)  -mapV :: (Functor m) =>-   (LLVM.Value (LLVM.Vector n a) -> m (LLVM.Value (LLVM.Vector n b))) ->-   Value n a -> m (Value n b)-mapV f (Cons x) = fmap Cons (f x)--zipV :: (Functor m) =>-   (c -> d) ->-   (LLVM.Value (LLVM.Vector n a) ->-    LLVM.Value (LLVM.Vector n b) ->-    m c) ->-   Value n a ->-   Value n b ->-   m d-zipV g f (Cons x) (Cons y) =-   fmap g (f x y)+cumulate ::+   (TypeNum.Positive n, MultiVector.Additive a) =>+   Exp a -> Exp (T n a) -> (Exp a, Exp (T n a))+cumulate a v =+   (Expr.liftM2 ((fmap fst .) . Code.cumulate) a v,+    Expr.liftM2 ((fmap snd .) . Code.cumulate) a v) +limit ::+   (TypeNum.Positive n, MultiVector.Real a) =>+   (Exp (T n a), Exp (T n a)) -> Exp (T n a) -> Exp (T n a)+limit (l,u) =+   fromOrdinary . ExprVec.limit (toOrdinary l, toOrdinary u) . toOrdinary  -withSize :: Sized v => (Int -> m v) -> m v-withSize =-   let sz :: (Sized v) => TypeNum.Singleton (Size v) -> (Int -> m v) -> m v-       sz n f = f (TypeNum.integralFromSingleton n)-   in  sz TypeNum.singleton--size :: Sized v => v -> Int-size =-   let sz :: (Sized v) => TypeNum.Singleton (Size v) -> v -> Int-       sz n _ = TypeNum.integralFromSingleton n-   in  sz TypeNum.singleton+cmp ::+   (TypeNum.Positive n, MultiVector.Comparison a) =>+   LLVM.CmpPredicate -> Exp (T n a) -> Exp (T n a) -> Exp (T n Bool)+cmp ord a b = fromOrdinary $ ExprVec.cmp ord (toOrdinary a) (toOrdinary b) -sizeOfIterator :: Sized v => Iterator mode it v -> Int-sizeOfIterator =-   let sz :: Sized v => TypeNum.Singleton (Size v) -> Iterator mode it v -> Int-       sz n _ = TypeNum.integralFromSingleton n-   in  sz TypeNum.singleton+select ::+   (TypeNum.Positive n, MultiVector.Select a) =>+   Exp (T n Bool) -> Exp (T n a) -> Exp (T n a) -> Exp (T n a)+select c a b =+   fromOrdinary $ ExprVec.select (toOrdinary c) (toOrdinary a) (toOrdinary b)  -{- |-The type parameter @value@ shall be a virtual LLVM register-or a wrapper around one or more virtual LLVM registers.--}-class (TypeNum.Positive (Size valueTuple)) => Sized valueTuple where-   type Size valueTuple :: *--{- |-Basic LLVM types are all counted as scalar values, even LLVM Vectors.-This means that an LLVM Vector can be used for parallel handling of data.--}-instance Sized (LLVM.Value a) where-   type Size (LLVM.Value a) = TypeNum.D1--instance (Sized value) => Sized (Stereo.T value) where-   type Size (Stereo.T value) = Size value--instance-   (Sized value0, Sized value1,-    Size value0 ~ Size value1) =>-      Sized (value0, value1) where-   type Size (value0, value1) = Size value0+fromOrdinary :: Exp (LLVM.Vector n a) -> Exp (T n a)+fromOrdinary = Expr.lift1 MultiValue.cast -instance-   (Sized value0, Sized value1, Sized value2,-    Size value0 ~ Size value1,-    Size value1 ~ Size value2) =>-      Sized (value0, value1, value2) where-   type Size (value0, value1, value2) = Size value0+toOrdinary :: Exp (T n a) -> Exp (LLVM.Vector n a)+toOrdinary = Expr.lift1 MultiValue.cast
+ src/Synthesizer/LLVM/Frame/SerialVector/Class.hs view
@@ -0,0 +1,523 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{- |+A special vector type that represents a time-sequence of samples.+This way we can distinguish safely between LLVM vectors+used for parallel signals and pipelines and+those used for chunky processing of scalar signals.+For the chunky processing this data type allows us+to derive the factor from the type+that time constants have to be multiplied with.+-}+module Synthesizer.LLVM.Frame.SerialVector.Class (+   Constant(Constant), constant,++   Read, Element, ReadIt, extract, readStart, readNext,+   Write, WriteIt, insert, writeStart, writeNext, writeStop,+   Zero, writeZero,+   Iterator(Iterator), ReadIterator, WriteIterator, ReadMode, WriteMode,++   Sized, Size, size, sizeOfIterator, withSize,++   insertTraversable, extractTraversable,+   readStartTraversable, readNextTraversable,+   writeStartTraversable, writeNextTraversable, writeStopTraversable,+   writeZeroTraversable,++   dissect, assemble, modify,+   upsample, subsample, last,+   iterate, reverse,+   shiftUp, shiftUpMultiZero, shiftDownMultiZero,+   ) where++import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Word (Word32)++import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative as App+import Control.Monad (foldM, replicateM, (<=<))+import Control.Applicative (liftA2, liftA3, (<$>))++import qualified Data.Traversable as Trav+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Tuple.HT (mapSnd, fst3, snd3, thd3)++import Prelude hiding (Read, replicate, reverse, iterate, last)++++newtype Constant n a = Constant a++constant :: (TypeNum.Positive n) => a -> Constant n a+constant = Constant++instance Functor (Constant n) where+   fmap f (Constant a) = Constant (f a)++instance App.Applicative (Constant n) where+   pure = Constant+   Constant f <*> Constant a = Constant (f a)++instance (Tuple.Phi a) => Tuple.Phi (Constant n a) where+   phi bb (Constant a) = Constant <$> Tuple.phi bb a+   addPhi bb (Constant a) (Constant b) = Tuple.addPhi bb a b++instance (Tuple.Undefined a) => Tuple.Undefined (Constant n a) where+   undef = Tuple.undefPointed++++instance (TypeNum.Positive n) => Sized (Constant n a) where+   type Size (Constant n a) = n++instance+   (TypeNum.Positive n, Tuple.Phi a, Tuple.Undefined a) =>+      Read (Constant n a) where++   type Element (Constant n a) = a+   type ReadIt (Constant n a) = a++   extract _k (Constant a) = return a++   readStart (Constant a) = return $ Iterator a+   readNext it@(Iterator a) = return (a, it)++++newtype Iterator mode it v = Iterator {unIterator :: it}+   deriving (Tuple.Undefined)++instance Tuple.Phi it => Tuple.Phi (Iterator mode it v) where+   phi bb (Iterator x) = fmap Iterator $ Tuple.phi bb x+   addPhi bb (Iterator x) (Iterator y) = Tuple.addPhi bb x y+++type ReadIterator = Iterator ReadMode+type WriteIterator = Iterator WriteMode++data ReadMode+data WriteMode+++instance (Memory.C it) => Memory.C (Iterator mode it v) where+   type Struct (Iterator mode it v) = Memory.Struct it+   load = Memory.loadNewtype Iterator+   store = Memory.storeNewtype (\(Iterator v) -> v)+   decompose = Memory.decomposeNewtype Iterator+   compose = Memory.composeNewtype (\(Iterator v) -> v)+++fmapIt ::+   (ita -> itb) -> (va -> vb) ->+   Iterator mode ita va -> Iterator mode itb vb+fmapIt f _ (Iterator a) = Iterator (f a)+++combineIt2 ::+   Iterator mode xa va -> Iterator mode xb vb ->+   Iterator mode (xa,xb) (va,vb)+combineIt2 (Iterator va) (Iterator vb) = Iterator (va,vb)++combineIt3 ::+   Iterator mode xa va -> Iterator mode xb vb -> Iterator mode xc vc ->+   Iterator mode (xa,xb,xc) (va,vb,vc)+combineIt3 (Iterator va) (Iterator vb) (Iterator vc) = Iterator (va,vb,vc)++combineItFunctor ::+   (Functor f) => f (Iterator mode x v) -> Iterator mode (f x) (f v)+combineItFunctor = Iterator . fmap unIterator++sequenceItFunctor ::+   (Functor f) => Iterator mode (f it) (f v) -> f (Iterator mode it v)+sequenceItFunctor = fmap Iterator . unIterator+++withSize :: Sized v => (Int -> m v) -> m v+withSize =+   let sz :: (Sized v) => TypeNum.Singleton (Size v) -> (Int -> m v) -> m v+       sz n f = f (TypeNum.integralFromSingleton n)+   in  sz TypeNum.singleton++size :: (Sized v, Integral i) => v -> i+size =+   let sz :: (Sized v, Integral i) => TypeNum.Singleton (Size v) -> v -> i+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton++sizeOfIterator :: (Sized v, Integral i) => Iterator mode it v -> i+sizeOfIterator =+   let sz :: (Sized v, Integral i) =>+               TypeNum.Singleton (Size v) -> Iterator mode it v -> i+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton+++{- |+The type parameter @v@ shall be a @MultiVector@ or @MultiValue Serial@+or a wrapper around one or more such things sharing the same size.+-}+class (TypeNum.Positive (Size v)) => Sized v where+   type Size v++class+   (Sized v,+    Tuple.Phi (ReadIt v), Tuple.Undefined (ReadIt v),+    Tuple.Phi v, Tuple.Undefined v) =>+      Read v where++   type Element v+   type ReadIt v++   extract :: LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r (Element v)++   dissect :: v -> LLVM.CodeGenFunction r [Element v]+   dissect x = mapM (flip extract x . LLVM.valueOf) (take (size x) [0..])++   readStart :: v -> LLVM.CodeGenFunction r (ReadIterator (ReadIt v) v)+   readNext ::+      ReadIterator (ReadIt v) v ->+      LLVM.CodeGenFunction r (Element v, ReadIterator (ReadIt v) v)++class+   (Read v, Tuple.Phi (WriteIt v), Tuple.Undefined (WriteIt v)) =>+      Write v where+   type WriteIt v++   insert :: LLVM.Value Word32 -> Element v -> v -> LLVM.CodeGenFunction r v++   assemble :: [Element v] -> LLVM.CodeGenFunction r v+   assemble =+      foldM (\v (k,x) -> insert (LLVM.valueOf k) x v) Tuple.undef . zip [0..]++   writeStart :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v)+   writeNext ::+      Element v -> WriteIterator (WriteIt v) v ->+      LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v)+   writeStop :: WriteIterator (WriteIt v) v -> LLVM.CodeGenFunction r v++class (Write v, Tuple.Phi (WriteIt v), Tuple.Zero (WriteIt v)) => Zero v where+   -- initializes the target with zeros+   -- you may only call 'writeStop' on the result of 'writeZero'+   writeZero :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v)++++instance (TypeNum.Positive n) => Sized (MultiVector.T n a) where+   type Size (MultiVector.T n a) = n++instance (TypeNum.Positive n, MultiVector.C a) => Read (MultiVector.T n a) where++   type Element (MultiVector.T n a) = MultiValue.T a+   type ReadIt (MultiVector.T n a) = MultiVector.T n a++   extract = MultiVector.extract++   readStart v = return $ Iterator v+   readNext (Iterator v) =+      mapSnd Iterator <$> MultiVector.shiftDown MultiValue.undef v++instance+      (TypeNum.Positive n, MultiVector.C a) => Write (MultiVector.T n a) where++   type WriteIt (MultiVector.T n a) = MultiVector.T n a++   insert = MultiVector.insert++   writeStart = return (Iterator MultiVector.undef)+   writeNext x (Iterator v) = Iterator . snd <$> MultiVector.shiftDown x v+   writeStop (Iterator v) = return v++instance (TypeNum.Positive n, MultiVector.C a) => Zero (MultiVector.T n a) where+   writeZero = return (Iterator Tuple.zero)++++type Serial n a = SerialCode.Value n a++instance (TypeNum.Positive n) => Sized (Serial n a) where+   type Size (Serial n a) = n++instance (TypeNum.Positive n, MultiVector.C a) => Read (Serial n a) where++   type Element (Serial n a) = MultiValue.T a+   type ReadIt (Serial n a) = Serial n a++   extract = SerialCode.extract++   readStart v = return $ Iterator v+   readNext (Iterator v) =+      mapSnd Iterator <$> SerialCode.shiftDown MultiValue.undef v++instance (TypeNum.Positive n, MultiVector.C a) => Write (Serial n a) where++   type WriteIt (Serial n a) = Serial n a++   insert = SerialCode.insert++   writeStart = return (Iterator Tuple.undef)+   writeNext x (Iterator v) = Iterator . snd <$> SerialCode.shiftDown x v+   writeStop (Iterator v) = return v++instance (TypeNum.Positive n, MultiVector.C a) => Zero (Serial n a) where+   writeZero = return (Iterator Tuple.zero)++++instance (Sized va, Sized vb, Size va ~ Size vb) => Sized (va, vb) where+   type Size (va, vb) = Size va++instance (Read va, Read vb, Size va ~ Size vb) => Read (va, vb) where++   type Element (va, vb) = (Element va, Element vb)+   type ReadIt (va, vb) = (ReadIt va, ReadIt vb)++   extract k (va,vb) = liftA2 (,) (extract k va) (extract k vb)++   readStart (va,vb) = liftA2 combineIt2 (readStart va) (readStart vb)+   readNext it = do+      (a, ita) <- readNext $ fmapIt fst fst it+      (b, itb) <- readNext $ fmapIt snd snd it+      return ((a,b), combineIt2 ita itb)++instance (Write va, Write vb, Size va ~ Size vb) => Write (va, vb) where++   type WriteIt (va, vb) = (WriteIt va, WriteIt vb)++   insert k (a,b) (va,vb) =+      liftA2 (,)+         (insert k a va)+         (insert k b vb)++   writeStart = liftA2 combineIt2 writeStart writeStart+   writeNext (a,b) it =+      liftA2 combineIt2+         (writeNext a $ fmapIt fst fst it)+         (writeNext b $ fmapIt snd snd it)+   writeStop it =+      liftA2 (,)+         (writeStop (fmapIt fst fst it))+         (writeStop (fmapIt snd snd it))++instance (Zero va, Zero vb, Size va ~ Size vb) => Zero (va, vb) where+   writeZero = liftA2 combineIt2 writeZero writeZero+++instance+   (Sized va, Sized vb, Sized vc, Size va ~ Size vb, Size vb ~ Size vc) =>+      Sized (va, vb, vc) where+   type Size (va, vb, vc) = Size va++instance+   (Read va, Read vb, Read vc, Size va ~ Size vb, Size vb ~ Size vc) =>+      Read (va, vb, vc) where++   type Element (va, vb, vc) = (Element va, Element vb, Element vc)+   type ReadIt (va, vb, vc) = (ReadIt va, ReadIt vb, ReadIt vc)++   extract k (va,vb,vc) =+      liftA3 (,,)+         (extract k va)+         (extract k vb)+         (extract k vc)++   readStart (va,vb,vc) =+      liftA3 combineIt3 (readStart va) (readStart vb) (readStart vc)+   readNext it = do+      (a, ita) <- readNext $ fmapIt fst3 fst3 it+      (b, itb) <- readNext $ fmapIt snd3 snd3 it+      (c, itc) <- readNext $ fmapIt thd3 thd3 it+      return ((a,b,c), combineIt3 ita itb itc)+++instance+   (Write va, Write vb, Write vc, Size va ~ Size vb, Size vb ~ Size vc) =>+      Write (va, vb, vc) where++   type WriteIt (va, vb, vc) = (WriteIt va, WriteIt vb, WriteIt vc)++   insert k (a,b,c) (va,vb,vc) =+      liftA3 (,,)+         (insert k a va)+         (insert k b vb)+         (insert k c vc)++   writeStart = liftA3 combineIt3 writeStart writeStart writeStart+   writeNext (a,b,c) it =+      liftA3 combineIt3+         (writeNext a $ fmapIt fst3 fst3 it)+         (writeNext b $ fmapIt snd3 snd3 it)+         (writeNext c $ fmapIt thd3 thd3 it)+   writeStop it =+      liftA3 (,,)+         (writeStop (fmapIt fst3 fst3 it))+         (writeStop (fmapIt snd3 snd3 it))+         (writeStop (fmapIt thd3 thd3 it))++instance+   (Zero va, Zero vb, Zero vc, Size va ~ Size vb, Size vb ~ Size vc) =>+      Zero (va, vb, vc) where++   writeZero = liftA3 combineIt3 writeZero writeZero writeZero+++instance (Sized value) => Sized (Stereo.T value) where+   type Size (Stereo.T value) = Size value++instance (Read v) => Read (Stereo.T v) where++   type Element (Stereo.T v) = Stereo.T (Element v)+   type ReadIt (Stereo.T v) = Stereo.T (ReadIt v)++   extract = extractTraversable++   readStart = readStartTraversable+   readNext = readNextTraversable++instance (Write v) => Write (Stereo.T v) where++   type WriteIt (Stereo.T v) = Stereo.T (WriteIt v)++   insert = insertTraversable++   writeStart = writeStartTraversable+   writeNext = writeNextTraversable+   writeStop = writeStopTraversable++instance (Zero v) => Zero (Stereo.T v) where++   writeZero = writeZeroTraversable+++insertTraversable ::+   (Write v, Trav.Traversable f, App.Applicative f) =>+   LLVM.Value Word32 -> f (Element v) -> f v -> LLVM.CodeGenFunction r (f v)+insertTraversable n a v =+   Trav.sequence (liftA2 (insert n) a v)++extractTraversable ::+   (Read v, Trav.Traversable f) =>+   LLVM.Value Word32 -> f v -> LLVM.CodeGenFunction r (f (Element v))+extractTraversable n v =+   Trav.mapM (extract n) v+++readStartTraversable ::+   (Trav.Traversable f, App.Applicative f, Read v) =>+   f v -> LLVM.CodeGenFunction r (ReadIterator (f (ReadIt v)) (f v))+readNextTraversable ::+   (Trav.Traversable f, App.Applicative f, Read v) =>+   ReadIterator (f (ReadIt v)) (f v) ->+   LLVM.CodeGenFunction r (f (Element v), ReadIterator (f (ReadIt v)) (f v))++readStartTraversable v =+   fmap combineItFunctor $ Trav.mapM readStart v++readNextTraversable it = do+   st <- Trav.mapM readNext $ sequenceItFunctor it+   return (fmap fst st, combineItFunctor $ fmap snd st)+++writeStartTraversable ::+   (Trav.Traversable f, App.Applicative f, Write v) =>+   LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v))+writeNextTraversable ::+   (Trav.Traversable f, App.Applicative f, Write v) =>+   f (Element v) -> WriteIterator (f (WriteIt v)) (f v) ->+   LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v))+writeStopTraversable ::+   (Trav.Traversable f, App.Applicative f, Write v) =>+   WriteIterator (f (WriteIt v)) (f v) -> LLVM.CodeGenFunction r (f v)+writeZeroTraversable ::+   (Trav.Traversable f, App.Applicative f, Zero v) =>+   LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v))++writeStartTraversable =+   fmap combineItFunctor $ Trav.sequence $ App.pure writeStart++writeNextTraversable x it =+   fmap combineItFunctor $ Trav.sequence $+   liftA2 writeNext x $ sequenceItFunctor it++writeStopTraversable = Trav.mapM writeStop . sequenceItFunctor++writeZeroTraversable =+   fmap combineItFunctor $ Trav.sequence $ App.pure writeZero+++modify ::+   (Write v, Element v ~ a) =>+   LLVM.Value Word32 ->+   (a -> LLVM.CodeGenFunction r a) ->+   v -> LLVM.CodeGenFunction r v+modify k f v = flip (insert k) v =<< f =<< extract k v+++last :: (Read v) => v -> LLVM.CodeGenFunction r (Element v)+last v = extract (LLVM.valueOf (size v - 1 :: Word32)) v++subsample :: (Read v) => v -> LLVM.CodeGenFunction r (Element v)+subsample v = extract (A.zero :: LLVM.Value Word32) v++-- this will be translated to an efficient pshufd+upsample :: (Write v) => Element v -> LLVM.CodeGenFunction r v+upsample x = withSize $ \n -> assemble $ List.replicate n x+++iterate ::+   (Write v) =>+   (Element v -> LLVM.CodeGenFunction r (Element v)) ->+   Element v -> LLVM.CodeGenFunction r v+iterate f x =+   withSize $ \n ->+      assemble =<<+      (flip MS.evalStateT x $+       replicateM n $+       MS.StateT $ \x0 -> do x1 <- f x0; return (x0,x1))++reverse ::+   (Write v) =>+   v -> LLVM.CodeGenFunction r v+reverse =+   assemble . List.reverse <=< dissect++shiftUp ::+   (Write v) =>+   Element v -> v -> LLVM.CodeGenFunction r (Element v, v)+shiftUp x v =+   ListHT.switchR+      (return (x,v))+      (\ys0 y -> fmap ((,) y) $ assemble (x:ys0))+   =<<+   dissect v+++shiftUpMultiZero ::+   (Write v, A.Additive (Element v)) =>+   Int -> v -> LLVM.CodeGenFunction r v+shiftUpMultiZero n v =+   assemble . take (size v) . (List.replicate n A.zero ++) =<< dissect v++shiftDownMultiZero ::+   (Write v, A.Additive (Element v)) =>+   Int -> v -> LLVM.CodeGenFunction r v+shiftDownMultiZero n v =+   assemble . take (size v) . (++ List.repeat A.zero) . List.drop n+      =<< dissect v
+ src/Synthesizer/LLVM/Frame/SerialVector/Code.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Synthesizer.LLVM.Frame.SerialVector.Code (+   T(Cons), Value, size,+   fromOrdinary, toOrdinary,+   fromMultiVector, toMultiVector,+   extract, insert, modify,+   assemble, dissect,+   assemble1, dissect1,+   upsample, subsample, last,+   reverse, shiftUp, shiftUpMultiZero, shiftDown,+   cumulate, iterate,+   scale,+   ) where++import qualified LLVM.Extra.Multi.Vector.Instance as MultiVectorInst+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign.Storable as Store+import Foreign.Storable (Storable)+import Foreign.Ptr (castPtr)++import Control.Applicative ((<$>))++import qualified Data.NonEmpty as NonEmpty+import Data.Word (Word32)+import Data.Tuple.HT (mapSnd)++import Prelude as P hiding (last, reverse, iterate)+++newtype T n a = Cons (LLVM.Vector n a)+   deriving (Eq, Num)++type Value n a = MultiValue.T (T n a)++instance (TypeNum.Positive n, MultiVector.C a) => MultiValue.C (T n a) where+   type Repr (T n a) = MultiVector.Repr n a+   cons (Cons v) = fromOrdinary $ MultiValue.cons v+   undef = fromOrdinary MultiValue.undef+   zero = fromOrdinary MultiValue.zero+   phi bb = fmap fromOrdinary . MultiValue.phi bb . toOrdinary+   addPhi bb a b = MultiValue.addPhi bb (toOrdinary a) (toOrdinary b)++instance (Marshal.Vector n a) => Marshal.C (T n a) where+   pack (Cons v) = Marshal.pack v+   unpack = Cons . Marshal.unpack++instance (TypeNum.Positive n, Storable a) => Storable (T n a) where+   sizeOf (Cons v) = Store.sizeOf v+   alignment (Cons v) = Store.alignment v+   poke ptr (Cons v) = Store.poke (castPtr ptr) v+   peek ptr = Cons <$> Store.peek (castPtr ptr)++instance+   (TypeNum.Positive n, Storable.Vector a, MultiVector.C a) =>+      Storable.C (T n a) where+   load ptr = fmap fromOrdinary $ Storable.load =<< LLVM.bitcast ptr+   store v ptr = Storable.store (toOrdinary v) =<< LLVM.bitcast ptr++instance+   (TypeNum.Positive n, MultiVector.IntegerConstant a) =>+      MultiValue.IntegerConstant (T n a) where+   fromInteger' = fromMultiVector . MultiVector.fromInteger'++instance+   (TypeNum.Positive n, MultiVector.RationalConstant a) =>+      MultiValue.RationalConstant (T n a) where+   fromRational' = fromMultiVector . MultiVector.fromRational'++instance+   (TypeNum.Positive n, MultiVector.Additive a) =>+      MultiValue.Additive (T n a) where+   add = lift2 MultiVector.add+   sub = lift2 MultiVector.sub+   neg = lift1 MultiVector.neg++instance+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+      MultiValue.PseudoRing (T n a) where+   mul = lift2 MultiVector.mul++scale ::+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   MultiValue.T a -> Value n a -> LLVM.CodeGenFunction r (Value n a)+scale = lift1 . MultiVector.scale++instance+   (TypeNum.Positive n, MultiVector.Real a) =>+      MultiValue.Real (T n a) where+   min = lift2 MultiVector.min+   max = lift2 MultiVector.max+   abs = lift1 MultiVector.abs+   signum = lift1 MultiVector.signum++instance+   (TypeNum.Positive n, MultiVector.Fraction a) =>+      MultiValue.Fraction (T n a) where+   truncate = lift1 MultiVector.truncate+   fraction = lift1 MultiVector.fraction++instance+   (TypeNum.Positive n, MultiVector.Field a) =>+      MultiValue.Field (T n a) where+   fdiv = lift2 MultiVector.fdiv++instance+   (TypeNum.Positive n, MultiVector.Algebraic a) =>+      MultiValue.Algebraic (T n a) where+   sqrt = lift1 MultiVector.sqrt++instance+   (TypeNum.Positive n, MultiVector.Transcendental a) =>+      MultiValue.Transcendental (T n a) where+   pi  = fmap fromMultiVector MultiVector.pi+   sin = lift1 MultiVector.sin+   log = lift1 MultiVector.log+   exp = lift1 MultiVector.exp+   cos = lift1 MultiVector.cos+   pow = lift2 MultiVector.pow++instance+   (TypeNum.Positive n, n ~ m,+    MultiVector.NativeInteger n a ar,+    MultiValue.NativeInteger a ar) =>+      MultiValueVec.NativeInteger (T n a) (LLVM.Vector m ar) where++instance+   (TypeNum.Positive n, n ~ m,+    MultiVector.NativeFloating n a ar,+    MultiValue.NativeFloating a ar) =>+      MultiValueVec.NativeFloating (T n a) (LLVM.Vector m ar) where++lift1 ::+   (Functor f) =>+   (MultiVector.T n a -> f (MultiVector.T m b)) ->+   (Value n a -> f (Value m b))+lift1 f a = fromMultiVector <$> f (toMultiVector a)++lift2 ::+   (Functor f) =>+   (MultiVector.T n a -> MultiVector.T m b -> f (MultiVector.T k c)) ->+   (Value n a -> Value m b -> f (Value k c))+lift2 f a b = fromMultiVector <$> f (toMultiVector a) (toMultiVector b)+++extract ::+   (TypeNum.Positive n,+    MultiVector.C x, MultiValue.T x ~ a, Value n x ~ v) =>+   LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r a+extract i v = MultiVector.extract i (toMultiVector v)++insert ::+   (TypeNum.Positive n,+    MultiVector.C x, MultiValue.T x ~ a, Value n x ~ v) =>+   LLVM.Value Word32 -> a -> v -> LLVM.CodeGenFunction r v+insert i a v =+    fromMultiVector <$> MultiVector.insert i a (toMultiVector v)++modify ::+   (TypeNum.Positive n,+    MultiVector.C x, MultiValue.T x ~ a, Value n x ~ v) =>+   LLVM.Value Word32 ->+   (a -> LLVM.CodeGenFunction r a) ->+   v -> LLVM.CodeGenFunction r v+modify k f v = flip (insert k) v =<< f =<< extract k v+++assemble ::+   (TypeNum.Positive n, MultiVector.C a) =>+   [MultiValue.T a] ->+   LLVM.CodeGenFunction r (Value n a)+assemble = fmap fromMultiVector . MultiVector.assemble++dissect ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a ->+   LLVM.CodeGenFunction r [MultiValue.T a]+dissect = MultiVector.dissect . toMultiVector++assemble1 ::+   (TypeNum.Positive n, MultiVector.C a) =>+   NonEmpty.T [] (MultiValue.T a) ->+   LLVM.CodeGenFunction r (Value n a)+assemble1 = fmap fromMultiVector . MultiVector.assemble1++dissect1 ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a ->+   LLVM.CodeGenFunction r (NonEmpty.T [] (MultiValue.T a))+dissect1 = MultiVector.dissect1 . toMultiVector+++sizeS :: TypeNum.Positive n => Value n a -> TypeNum.Singleton n+sizeS _ = TypeNum.singleton++size :: (TypeNum.Positive n, P.Integral i) => Value n a -> i+size = TypeNum.integralFromSingleton . sizeS+++last ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a -> LLVM.CodeGenFunction r (MultiValue.T a)+last v = extract (LLVM.valueOf (size v - 1 :: Word32)) v++subsample ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a -> LLVM.CodeGenFunction r (MultiValue.T a)+subsample = extract (A.zero :: LLVM.Value Word32)++upsample ::+   (TypeNum.Positive n, MultiVector.C a) =>+   MultiValue.T a -> LLVM.CodeGenFunction r (Value n a)+upsample = fmap fromOrdinary . MultiValueVec.replicate+++reverse ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a -> LLVM.CodeGenFunction r (Value n a)+reverse =+   fmap fromMultiVector . MultiVector.reverse . toMultiVector++shiftUp ::+   (TypeNum.Positive n, MultiVector.C x,+    MultiValue.T x ~ a, Value n x ~ v) =>+   a -> v -> LLVM.CodeGenFunction r (a, v)+shiftUp a v =+   mapSnd fromMultiVector <$> MultiVector.shiftUp a (toMultiVector v)++shiftUpMultiZero ::+   (TypeNum.Positive n, MultiVector.C x, Value n x ~ v) =>+   Int -> v -> LLVM.CodeGenFunction r v+shiftUpMultiZero k v =+   fromMultiVector <$> MultiVector.shiftUpMultiZero k (toMultiVector v)++shiftDown ::+   (TypeNum.Positive n, MultiVector.C x,+    MultiValue.T x ~ a, Value n x ~ v) =>+   a -> v -> LLVM.CodeGenFunction r (a, v)+shiftDown a v =+   mapSnd fromMultiVector <$> MultiVector.shiftDown a (toMultiVector v)+++iterate ::+   (TypeNum.Positive n, MultiVector.C a) =>+   (MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T a)) ->+   MultiValue.T a -> LLVM.CodeGenFunction r (Value n a)+iterate f = fmap fromOrdinary . MultiValueVec.iterate f++cumulate ::+   (TypeNum.Positive n, MultiVector.Additive a) =>+   MultiValue.T a -> Value n a ->+   LLVM.CodeGenFunction r (MultiValue.T a, Value n a)+cumulate a =+   fmap (mapSnd fromMultiVector) . MultiVector.cumulate a . toMultiVector+++fromOrdinary :: MultiValue.T (LLVM.Vector n a) -> Value n a+fromOrdinary = MultiValue.cast++toOrdinary :: Value n a -> MultiValue.T (LLVM.Vector n a)+toOrdinary = MultiValue.cast++fromMultiVector :: MultiVector.T n a -> Value n a+fromMultiVector = fromOrdinary . MultiVectorInst.toMultiValue++toMultiVector :: Value n a -> MultiVector.T n a+toMultiVector = MultiVectorInst.fromMultiValue . toOrdinary
+ src/Synthesizer/LLVM/Frame/SerialVector/Plain.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TypeFamilies #-}+{- |+A special vector type that represents a time-sequence of samples.+This way we can distinguish safely between LLVM vectors+used for parallel signals and pipelines and+those used for chunky processing of scalar signals.+For the chunky processing this data type allows us+to derive the factor from the type+that time constants have to be multiplied with.+-}+module Synthesizer.LLVM.Frame.SerialVector.Plain (+   T(Cons),+   fromList,+   replicate,+   iterate,+   ) where++import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Code+import Synthesizer.LLVM.Frame.SerialVector.Code (T)++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty++import Prelude as P hiding (zip, unzip, last, reverse, iterate, replicate)+++fromList :: (TypeNum.Positive n) => NonEmpty.T [] a -> T n a+fromList = Code.Cons . LLVM.cyclicVector++replicate :: (TypeNum.Positive n) => a -> T n a+replicate = Code.Cons . pure++iterate :: (TypeNum.Positive n) => (a -> a) -> a -> T n a+iterate f x = fromList $ NonEmptyC.iterate f x
src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Re-export functions from "Sound.Frame.Stereo"@@ -9,7 +10,11 @@ -} module Synthesizer.LLVM.Frame.Stereo (    Stereo.T, Stereo.cons, Stereo.left, Stereo.right,-   Stereo.Channel(Left, Right), Stereo.select,+   Stereo.Channel(Stereo.Left, Stereo.Right), Stereo.select,+   Stereo.swap,+   multiValue, unMultiValue, consMultiValue, unExpression,+   multiVector, unMultiVector,+   multiValueSerial, unMultiValueSerial,    Stereo.arrowFromMono,    Stereo.arrowFromMonoControlled,    Stereo.arrowFromChannels,@@ -18,22 +23,31 @@    Stereo.liftApplicative,    ) where +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.Frame.Stereo as Stereo -import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.DSL.Expression as Expr+import qualified LLVM.DSL.Value as Value++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Storable as StorableMV+import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Core as LLVM  import Type.Data.Num.Decimal (d0, d1) -import Control.Monad (liftM2)-import Control.Applicative (liftA2)+import Control.Applicative (liftA2, pure, (<$>))+ import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold  import Prelude hiding (Either(Left, Right), sequence) @@ -47,38 +61,104 @@ instance (C.Select a) => C.Select (Stereo.T a) where    select = C.selectTraversable -{--instance LLVM.CmpRet a, LLVM.CmpResult a ~ b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where--}- instance (Tuple.Value h) => Tuple.Value (Stereo.T h) where    type ValueOf (Stereo.T h) = Stereo.T (Tuple.ValueOf h)-   valueOf s =-      Stereo.cons-         (Tuple.valueOf $ Stereo.left s)-         (Tuple.valueOf $ Stereo.right s)--{--instance Tuple.Value a => Tuple.Value (Stereo.T a) where-   buildTuple f =-      liftM2 Stereo.cons (buildTuple f) (buildTuple f)--instance IsTuple a => IsTuple (Stereo.T a) where-   tupleDesc s =-      tupleDesc (Stereo.left s) ++-      tupleDesc (Stereo.right s)--}+   valueOf = fmap Tuple.valueOf  instance (Tuple.Phi a) => Tuple.Phi (Stereo.T a) where    phi bb v =-      liftM2 Stereo.cons+      liftA2 Stereo.cons          (Tuple.phi bb (Stereo.left v))          (Tuple.phi bb (Stereo.right v))    addPhi bb x y = do       Tuple.addPhi bb (Stereo.left  x) (Stereo.left  y)       Tuple.addPhi bb (Stereo.right x) (Stereo.right y) +instance (MultiValue.C a) => MultiValue.C (Stereo.T a) where+   type Repr (Stereo.T a) = Stereo.T (MultiValue.Repr a)+   cons = multiValue . fmap MultiValue.cons+   undef = multiValue $ pure MultiValue.undef+   zero = multiValue $ pure MultiValue.zero+   phi bb = fmap multiValue . Trav.traverse (MultiValue.phi bb) . unMultiValue+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb) (unMultiValue a) (unMultiValue b) +instance (MultiValue.Compose a) => MultiValue.Compose (Stereo.T a) where+   type Composed (Stereo.T a) = Stereo.T (MultiValue.Composed a)+   compose = multiValue . fmap MultiValue.compose++instance (MultiValue.Decompose p) => MultiValue.Decompose (Stereo.T p) where+   decompose p = liftA2 MultiValue.decompose p . unMultiValue++type instance MultiValue.Decomposed f (Stereo.T pa) =+                  Stereo.T (MultiValue.Decomposed f pa)+type instance MultiValue.PatternTuple (Stereo.T pa) =+                  Stereo.T (MultiValue.PatternTuple pa)++multiValue :: Stereo.T (MultiValue.T a) -> MultiValue.T (Stereo.T a)+multiValue = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++unMultiValue :: MultiValue.T (Stereo.T a) -> Stereo.T (MultiValue.T a)+unMultiValue (MultiValue.Cons x) = fmap MultiValue.Cons x++consMultiValue :: MultiValue.T a -> MultiValue.T a -> MultiValue.T (Stereo.T a)+consMultiValue l r = multiValue $ Stereo.cons l r+++unExpression :: Expr.Exp (Stereo.T a) -> Stereo.T (Expr.Exp a)+unExpression x =+   Stereo.cons+      (Expr.lift1 (MultiValue.lift1 Stereo.left) x)+      (Expr.lift1 (MultiValue.lift1 Stereo.right) x)+++instance (MultiVector.C a) => MultiVector.C (Stereo.T a) where+   type Repr n (Stereo.T a) = Stereo.T (MultiVector.Repr n a)+   cons = multiVector . fmap MultiVector.cons . Stereo.sequence+   undef = multiVector $ pure MultiVector.undef+   zero = multiVector $ pure MultiVector.zero+   phi bb =+      fmap multiVector . Trav.traverse (MultiVector.phi bb) . unMultiVector+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiVector.addPhi bb) (unMultiVector a) (unMultiVector b)++   shuffle is u v =+      multiVector <$>+      traverse2 (MultiVector.shuffle is) (unMultiVector u) (unMultiVector v)+   extract k =+      fmap multiValue . Trav.traverse (MultiVector.extract k) . unMultiVector+   insert k a v =+      multiVector <$>+      traverse2 (MultiVector.insert k) (unMultiValue a) (unMultiVector v)++multiVector :: Stereo.T (MultiVector.T n a) -> MultiVector.T n (Stereo.T a)+multiVector = MultiVector.Cons . fmap (\(MultiVector.Cons a) -> a)++unMultiVector :: MultiVector.T n (Stereo.T a) -> Stereo.T (MultiVector.T n a)+unMultiVector (MultiVector.Cons x) = fmap MultiVector.Cons x+++multiValueSerial ::+   Stereo.T (MultiValue.T (Serial.T n a)) ->+   MultiValue.T (Serial.T n (Stereo.T a))+multiValueSerial = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++unMultiValueSerial ::+   MultiValue.T (Serial.T n (Stereo.T a)) ->+   Stereo.T (MultiValue.T (Serial.T n a))+unMultiValueSerial (MultiValue.Cons x) = fmap MultiValue.Cons x+++instance+      (Expr.Aggregate e mv) => Expr.Aggregate (Stereo.T e) (Stereo.T mv) where+   type MultiValuesOf (Stereo.T e) = Stereo.T (Expr.MultiValuesOf e)+   type ExpressionsOf (Stereo.T mv) = Stereo.T (Expr.ExpressionsOf mv)+   bundle = Trav.traverse Expr.bundle+   dissect = fmap Expr.dissect++ instance (Vector.Simple v) => Vector.Simple (Stereo.T v) where    type Element (Stereo.T v) = Stereo.T (Vector.Element v)    type Size (Stereo.T v) = Vector.Size v@@ -114,13 +194,31 @@    load = Storable.loadApplicative    store = Storable.storeFoldable +instance (MarshalMV.C l) => MarshalMV.C (Stereo.T l) where+   pack x = MarshalMV.pack (Stereo.left x, Stereo.right x)+   unpack = uncurry Stereo.cons . MarshalMV.unpack +instance (StorableMV.C l) => StorableMV.C (Stereo.T l) where+   load = StorableMV.loadApplicative+   store = StorableMV.storeFoldable++instance+   (StorableMV.Vector l, MultiVector.C l) =>+      StorableMV.Vector (Stereo.T l) where+   assembleVector p =+      Trav.traverse (StorableMV.assembleVector (Stereo.left<$>p)) .+      Stereo.sequence+   disassembleVector p =+      fmap (\x -> liftA2 Stereo.cons (Stereo.left x) (Stereo.right x)) .+      Trav.traverse (StorableMV.disassembleVector (Stereo.left<$>p))++ {- instance       (Memory l s) =>       Memory (Stereo.T l) (LLVM.Struct (s, (s, ()))) where    load ptr =-      liftM2 Stereo.cons+      liftA2 Stereo.cons          (load =<< getElementPtr0 ptr (d0, ()))          (load =<< getElementPtr0 ptr (d1, ()))    store y ptr = do@@ -130,11 +228,33 @@  instance (A.Additive a) => A.Additive (Stereo.T a) where    zero = Stereo.cons A.zero A.zero-   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+   add x y = traverse2 A.add x y+   sub x y = traverse2 A.sub x y+   neg x   = Trav.traverse 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)+   scale a = Trav.traverse (A.scale a)++++instance (MultiValue.Additive a) => MultiValue.Additive (Stereo.T a) where+   add x y =+      multiValue <$> traverse2 MultiValue.add (unMultiValue x) (unMultiValue y)+   sub x y =+      multiValue <$> traverse2 MultiValue.sub (unMultiValue x) (unMultiValue y)+   neg x = multiValue <$> Trav.traverse MultiValue.neg (unMultiValue x)+++traverse2 ::+   (Monad m, Applicative t, Traversable t) =>+   (a -> b -> m c) -> t a -> t b -> m (t c)+traverse2 f x y = Trav.sequence $ liftA2 f x y++++instance Value.Flatten a => Value.Flatten (Stereo.T a) where+   type Registers (Stereo.T a) = Stereo.T (Value.Registers a)+   flattenCode = Value.flattenCodeTraversable+   unfoldCode = Value.unfoldCodeTraversable
src/Synthesizer/LLVM/Frame/StereoInterleaved.hs view
@@ -1,332 +1,45 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{- |-Represent a vector of Stereo values in two vectors-that store the values in an interleaved way.-That is:--> vector0[0] = left[0]-> vector0[1] = right[0]-> vector0[2] = left[1]-> vector0[3] = right[1]-> vector1[0] = left[2]-> vector1[1] = right[2]-> vector1[2] = left[3]-> vector1[3] = right[3]--This representation is not very useful for computation,-but necessary as intermediate representation for interfacing with memory.-SSE/SSE2 have the instructions UNPACK(L|H)P(S|D) that interleave efficiently.--} module Synthesizer.LLVM.Frame.StereoInterleaved (    T,-   Value(Value),+   Value,    interleave,    deinterleave,-   fromMono,-   assemble, extractAll,-   zero,    amplify,    envelope,    ) where -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F--import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Core as LLVM-import LLVM.Core (Vector, IsSized, SizeOf)--import qualified Type.Data.Num.Decimal as TypeNum--import qualified Foreign.Storable as St-import Foreign.Ptr (Ptr, castPtr)--import qualified Data.Foldable as Fold-import Control.Monad (liftM2)-import Control.Applicative (liftA2, pure)--import Data.Tuple.HT (mapPair)--import qualified Algebra.Additive as Additive---data T n a = Cons (Vector n a) (Vector n a)--data Value n a = Value (LLVM.Value (Vector n a)) (LLVM.Value (Vector n a))+import qualified Synthesizer.LLVM.Frame.StereoInterleavedCode as StereoInt+import Synthesizer.LLVM.Frame.StereoInterleavedCode (T, Value) +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial -type instance F.Arguments f (Value n a) = f (Value n a)-instance F.MakeArguments (Value n a) where-   makeArgs = id+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp) +import qualified LLVM.Extra.Multi.Vector as MultiVector -withSize :: (TypeNum.Natural n) => (Int -> m (Value n a)) -> m (Value n a)-withSize =-   let sz ::-          (TypeNum.Natural n) =>-          TypeNum.Singleton n -> (Int -> m (Value n a)) -> m (Value n a)-       sz n f = f (TypeNum.integralFromSingleton n)-   in  sz TypeNum.singleton+import qualified Type.Data.Num.Decimal as TypeNum   interleave ::-   (LLVM.IsPrimitive a, TypeNum.Positive n) =>-   Stereo.T (Serial.Value n a) ->-   LLVM.CodeGenFunction r (Value n a)-interleave x =-   assemble =<< Serial.extractAll x+   (TypeNum.Positive n, MultiVector.C a) =>+   Stereo.T (Exp (Serial.T n a)) -> Exp (T n a)+interleave = Expr.liftM StereoInt.interleave  deinterleave ::-   (LLVM.IsPrimitive a, TypeNum.Positive n) =>-   Value n a ->-   LLVM.CodeGenFunction r (Stereo.T (Serial.Value n a))-deinterleave v =-   Serial.assemble =<< extractAll v--fromMono ::-   (LLVM.IsPrimitive a, TypeNum.Positive n) =>-   Serial.Value n a ->-   LLVM.CodeGenFunction r (Value n a)-fromMono x =-   assemble . map pure =<< Serial.extractAll x--assemble ::-   (LLVM.IsPrimitive a, TypeNum.Positive n) =>-   [Stereo.T (LLVM.Value a)] -> LLVM.CodeGenFunction r (Value n a)-assemble x =-   withSize $ \n ->-      uncurry (liftM2 Value) .-      mapPair (Vector.assemble, Vector.assemble) .-      splitAt n .-      concatMap Fold.toList $ x--extractAll ::-   (LLVM.IsPrimitive a, TypeNum.Positive n) =>-   Value n a -> LLVM.CodeGenFunction r [Stereo.T (LLVM.Value a)]-extractAll (Value v0 v1) =-   fmap-      (let aux (l:r:xs) = Stereo.cons l r : aux xs-           aux [] = []-           aux _ = error "odd number of stereo elements"-       in  aux) $-   liftM2 (++)-      (Vector.extractAll v0)-      (Vector.extractAll v1)---instance-   (TypeNum.Positive n, LLVM.IsPrimitive a, St.Storable a) =>-      St.Storable (T n a) where-   sizeOf ~(Cons v0 v1) = St.sizeOf v0 + St.sizeOf v1-   alignment ~(Cons v _) = St.alignment v-   peek ptr =-      let p = castPtr ptr-      in  liftM2 Cons-             (St.peekElemOff p 0)-             (St.peekElemOff p 1)-   poke ptr (Cons v0 v1) =-      let p = castPtr ptr-      in  St.pokeElemOff p 0 v0 >>-          St.pokeElemOff p 1 v1--instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Tuple.Zero (Value n a) where-   zero = Value Tuple.zero Tuple.zero--instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Tuple.Undefined (Value n a) where-   undef = Value (LLVM.value LLVM.undef) (LLVM.value LLVM.undef)--{--Can only be implemented by ifThenElse-since the atomic 'select' command wants a bool vector.--instance (TypeNum.Positive n, LLVM.IsPrimitive a, Tuple.Phi a) => C.Select (Value n a) where-   select b (Value x0 x1) (Value y0 y1) =-      liftM2 Value-         (C.select b x0 y0)-         (C.select b x1 y1)--instance LLVM.CmpRet a, LLVM.CmpResult a ~ b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where--}--instance (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsConst a) =>-      Tuple.Value (T n a) where-   type ValueOf (T n a) = Value n a-   valueOf (Cons v0 v1) =-      Value-         (LLVM.valueOf v0)-         (LLVM.valueOf v1)--instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Tuple.Phi (Value n a) where-   phi bb = mapV (Tuple.phi bb)-   addPhi bb = zipV (\_ _ -> ()) (Tuple.addPhi bb)---instance (TypeNum.Positive n) => Serial.Sized (Value n a) where-   type Size (Value n a) = n--{- |-The implementation of 'extract' may need to perform-arithmetics at run-time and is thus a bit inefficient.--}-instance (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.Read (Value n a) where-   type Element (Value n a) = Stereo.T (LLVM.Value a)-   type ReadIt (Value n a) = Value n a--   extract k (Value v0 v1) =-      let size = LLVM.valueOf $ fromIntegral $ Vector.sizeInTuple v0-          ext j = do-             b <- A.cmp LLVM.CmpLT j size-             C.ifThenElse b-                (Vector.extract j v0)-                (do j1 <- A.sub j size-                    Vector.extract j1 v1)-      in  do-             k20 <- A.add k k-             k21 <- A.inc k20-             liftM2 Stereo.cons (ext k20) (ext k21)--   extractAll = extractAll--   readStart = return . Serial.Iterator-   readNext (Serial.Iterator v) = do-      xt <- extractAll v-      case xt of-         x:xs -> fmap ((,) x . Serial.Iterator) $ assemble xs-         [] -> error "StereoInterleaved.readNext: size zero"---{- |-The implementation of 'insert' may need to perform-arithmetics at run-time and is thus a bit inefficient.--}-instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Serial.C (Value n a) where-   type WriteIt (Value n a) = Value n a--   insert k x v =-      let size = LLVM.valueOf $ fromIntegral $ Serial.size v-          ins j c (Value v0 v1) = do-             b <- A.cmp LLVM.CmpLT j size-             C.ifThenElse b-                (do w0 <- Vector.insert j c v0-                    return $ Value w0 v1)-                (do j1 <- A.sub j size-                    w1 <- Vector.insert j1 c v1-                    return $ Value v0 w1)-      in  do-             k20 <- A.add k k-             k21 <- A.inc k20-             ins k21 (Stereo.right x) =<< ins k20 (Stereo.left x) v--   assemble = assemble--   writeStart = return (Serial.Iterator Tuple.undef)-   writeNext x (Serial.Iterator v) = do-      xs <- extractAll v-      fmap Serial.Iterator $ assemble $ tail xs ++ [x]-   writeStop (Serial.Iterator v) = return v---type Struct n a = LLVM.Struct (Vector n a, (Vector n a, ()))--memory ::-   (TypeNum.Positive n, LLVM.IsPrimitive a, IsSized a,-    TypeNum.Positive (n TypeNum.:*: SizeOf a)) =>-   Memory.Record r (Struct n a) (Value n a)-memory =-   liftA2 Value-      (Memory.element (\(Value v _) -> v) TypeNum.d0)-      (Memory.element (\(Value _ v) -> v) TypeNum.d1)--instance-      (TypeNum.Positive n,-       LLVM.IsPrimitive a, IsSized a,-       TypeNum.Positive (n TypeNum.:*: SizeOf a)) =>-      Memory.C (Value n a) where-   type Struct (Value n a) = Struct n a-   load = Memory.loadRecord memory-   store = Memory.storeRecord memory-   decompose = Memory.decomposeRecord memory-   compose = Memory.composeRecord memory--instance-   (TypeNum.Positive n, Tuple.VectorValue n a,-    Tuple.VectorValueOf n a ~ LLVM.Value (Vector n a),-    LLVM.IsPrimitive a, LLVM.IsConst a, Storable.Vector a) =>-      Storable.C (T n a) where-   load ptrV = do-      ptr <- castHalfPtr ptrV-      liftM2 Value-         (Storable.load ptr)-         (Storable.load =<< Storable.incrementPtr ptr)-   store (Value v0 v1) ptrV = do-      ptr <- castHalfPtr ptrV-      Storable.storeNext v0 ptr >>= Storable.store v1--castHalfPtr ::-   LLVM.Value (Ptr (T n a)) ->-   LLVM.CodeGenFunction r (LLVM.Value (Ptr (Vector n a)))-castHalfPtr = LLVM.bitcast---{- |-This instance allows to run @arrange@ on interleaved stereo vectors.--}-instance-   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>-      A.Additive (Value n a) where-   zero = Value A.zero A.zero-   add = zipV Value A.add-   sub = zipV Value A.sub-   neg = mapV A.neg---zero :: (TypeNum.Positive n, Additive.C a) => (T n a)-zero = Cons (pure Additive.zero) (pure Additive.zero)---scale ::-   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>-   LLVM.Value a -> Value n a -> LLVM.CodeGenFunction r (Value n a)-scale a v = do-   av <- SoV.replicate a-   mapV (A.mul av) v+   (TypeNum.Positive n, MultiVector.C a) =>+   Exp (T n a) -> Stereo.T (Exp (Serial.T n a))+deinterleave x =+   Stereo.cons+      (Expr.liftM (fmap Stereo.left  . StereoInt.deinterleave) x)+      (Expr.liftM (fmap Stereo.right . StereoInt.deinterleave) x)  amplify ::-   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) =>-   a -> Value n a -> LLVM.CodeGenFunction r (Value n a)-amplify a = scale (LLVM.valueOf a)+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   Exp a -> Exp (T n a) -> Exp (T n a)+amplify = Expr.liftM2 StereoInt.scale  envelope ::-   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) =>-   Serial.Value n a -> Value n a -> LLVM.CodeGenFunction r (Value n a)-envelope e a =-   zipV Value (flip A.mul) a =<< fromMono e---mapV :: (Monad m) =>-   (LLVM.Value (Vector n a) -> m (LLVM.Value (Vector n a))) ->-   Value n a -> m (Value n a)-mapV f (Value x0 x1) =-   liftM2 Value (f x0) (f x1)--zipV :: (Monad m) =>-   (c -> c -> d) ->-   (LLVM.Value (Vector n a) ->-    LLVM.Value (Vector n b) ->-    m c) ->-   Value n a ->-   Value n b ->-   m d-zipV g f (Value x0 x1) (Value y0 y1) =-   liftM2 g (f x0 y0) (f x1 y1)+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   Exp (Serial.T n a) -> Exp (T n a) -> Exp (T n a)+envelope = Expr.liftM2 StereoInt.envelope
+ src/Synthesizer/LLVM/Frame/StereoInterleavedCode.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{- |+Represent a vector of Stereo values in two vectors+that store the values in an interleaved way.+That is:++> vector0[0] = left[0]+> vector0[1] = right[0]+> vector0[2] = left[1]+> vector0[3] = right[1]+> vector1[0] = left[2]+> vector1[1] = right[2]+> vector1[2] = left[3]+> vector1[3] = right[3]++This representation is not very useful for computation,+but necessary as intermediate representation for interfacing with memory.+SSE/SSE2 have the instructions UNPACK(L|H)P(S|D) that interleave efficiently.+-}+module Synthesizer.LLVM.Frame.StereoInterleavedCode (+   T,+   Value,+   interleave,+   deinterleave,+   fromMono,+   assemble, dissect,+   zero,+   scale,+   amplify,+   envelope,+   ) where++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import LLVM.Core (Vector)++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign.Storable as St+import Foreign.Ptr (Ptr, castPtr)++import qualified Control.Applicative.HT as AppHT+import Control.Applicative (liftA2, pure)++import qualified Data.Foldable as Fold+import Data.Tuple.HT (mapPair)++import qualified Algebra.Additive as Additive+++data T n a = Cons (Vector n a) (Vector n a)++type Value n a = MultiValue.T (T n a)+++withSize :: (TypeNum.Natural n) => (Int -> m (Value n a)) -> m (Value n a)+withSize =+   let sz ::+          (TypeNum.Natural n) =>+          TypeNum.Singleton n -> (Int -> m (Value n a)) -> m (Value n a)+       sz n f = f (TypeNum.integralFromSingleton n)+   in  sz TypeNum.singleton+++interleave ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Stereo.T (Serial.Value n a) ->+   LLVM.CodeGenFunction r (Value n a)+interleave x =+   assemble . map Stereo.unMultiValue+      =<< Serial.dissect (Stereo.multiValueSerial x)++deinterleave ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a ->+   LLVM.CodeGenFunction r (Stereo.T (Serial.Value n a))+deinterleave v =+   Stereo.unMultiValueSerial <$>+      (Serial.assemble . map Stereo.multiValue =<< dissect v)++fromMono ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Serial.Value n a ->+   LLVM.CodeGenFunction r (Value n a)+fromMono x =+   assemble . map pure =<< Serial.dissect x++assemble ::+   (TypeNum.Positive n, MultiVector.C a) =>+   [Stereo.T (MultiValue.T a)] -> LLVM.CodeGenFunction r (Value n a)+assemble x =+   withSize $ \n ->+      uncurry (liftA2 merge) .+      mapPair (MultiVector.assemble, MultiVector.assemble) .+      splitAt n .+      concatMap Fold.toList $ x++dissect ::+   (TypeNum.Positive n, MultiVector.C a) =>+   Value n a -> LLVM.CodeGenFunction r [Stereo.T (MultiValue.T a)]+dissect v =+   let (v0,v1) = split v in+   fmap+      (let aux (l:r:xs) = Stereo.cons l r : aux xs+           aux [] = []+           aux _ = error "odd number of stereo elements"+       in  aux) $+   liftA2 (++)+      (MultiVector.dissect v0)+      (MultiVector.dissect v1)+++merge :: MultiVector.T n a -> MultiVector.T n a -> MultiValue.T (T n a)+merge (MultiVector.Cons a) (MultiVector.Cons b) = MultiValue.Cons (a,b)++split :: MultiValue.T (T n a) -> (MultiVector.T n a, MultiVector.T n a)+split (MultiValue.Cons (a,b)) = (MultiVector.Cons a, MultiVector.Cons b)++merge_ ::+   MultiValue.T (Vector n a) -> MultiValue.T (Vector n a) ->+   MultiValue.T (T n a)+merge_ (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a,b)++split_ ::+   MultiValue.T (T n a) ->+   (MultiValue.T (Vector n a), MultiValue.T (Vector n a))+split_ (MultiValue.Cons (a,b)) = (MultiValue.Cons a, MultiValue.Cons b)++instance (TypeNum.Positive n, MultiVector.C a) => MultiValue.C (T n a) where+   type Repr (T n a) = (MultiVector.Repr n a, MultiVector.Repr n a)+   cons (Cons v0 v1) = merge (MultiVector.cons v0) (MultiVector.cons v1)+   undef = merge MultiVector.undef MultiVector.undef+   zero = merge MultiVector.zero MultiVector.zero+   phi bb =+      fmap (uncurry merge) .+      AppHT.mapPair (MultiVector.phi bb, MultiVector.phi bb) . split+   addPhi bb a b =+      case (split a, split b) of+         ((a0,a1), (b0,b1)) -> do+            MultiVector.addPhi bb a0 b0+            MultiVector.addPhi bb a1 b1++instance (Marshal.Vector n a) => Marshal.C (T n a) where+   pack (Cons v0 v1) = Marshal.pack (v0,v1)+   unpack = uncurry Cons . Marshal.unpack++instance+   (TypeNum.Positive n, MultiVector.C a, St.Storable a) =>+      St.Storable (T n a) where+   sizeOf ~(Cons v0 v1) = St.sizeOf v0 + St.sizeOf v1+   alignment ~(Cons v _) = St.alignment v+   peek ptr =+      let p = castPtr ptr+      in  liftA2 Cons+             (St.peekElemOff p 0)+             (St.peekElemOff p 1)+   poke ptr (Cons v0 v1) =+      let p = castPtr ptr+      in  St.pokeElemOff p 0 v0 >>+          St.pokeElemOff p 1 v1++instance (TypeNum.Positive n, Storable.Vector a) => Storable.C (T n a) where+   load ptrV = do+      ptr <- castHalfPtr ptrV+      liftA2 merge_+         (Storable.load ptr)+         (Storable.load =<< Storable.incrementPtr ptr)+   store v ptrV = do+      let (v0,v1) = split_ v+      ptr <- castHalfPtr ptrV+      Storable.storeNext v0 ptr >>= Storable.store v1++castHalfPtr ::+   LLVM.Value (Ptr (T n a)) ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr (Vector n a)))+castHalfPtr = LLVM.bitcast+++{- |+This instance allows to run @arrange@ on interleaved stereo vectors.+-}+instance+   (TypeNum.Positive n, MultiVector.Additive a) =>+      MultiValue.Additive (T n a) where+   add = zipV merge A.add+   sub = zipV merge A.sub+   neg = mapV A.neg+++zero :: (TypeNum.Positive n, Additive.C a) => T n a+zero = Cons (pure Additive.zero) (pure Additive.zero)+++scale ::+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   MultiValue.T a -> Value n a -> LLVM.CodeGenFunction r (Value n a)+scale a v = do+   av <- MultiVector.replicate a+   mapV (A.mul av) v++amplify ::+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   a -> Value n a -> LLVM.CodeGenFunction r (Value n a)+amplify a = scale (MultiValue.cons a)++envelope ::+   (TypeNum.Positive n, MultiVector.PseudoRing a) =>+   Serial.Value n a -> Value n a -> LLVM.CodeGenFunction r (Value n a)+envelope e a =+   zipV merge (flip A.mul) a =<< fromMono e+++mapV :: (Applicative m) =>+   (MultiVector.T n a -> m (MultiVector.T n a)) ->+   Value n a -> m (Value n a)+mapV f x =+   case split x of+      (x0,x1) -> uncurry merge <$> liftA2 (,) (f x0) (f x1)++zipV :: (Applicative m) =>+   (c -> c -> d) ->+   (MultiVector.T n a ->+    MultiVector.T n b ->+    m c) ->+   Value n a ->+   Value n b ->+   m d+zipV g f x y =+   case (split x, split y) of+      ((x0,x1), (y0,y1)) -> liftA2 g (f x0 y0) (f x1 y1)
+ src/Synthesizer/LLVM/Generator/Core.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Synthesizer.LLVM.Generator.Core where++import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Private as Sig+import qualified Synthesizer.LLVM.Random as Rnd++import Synthesizer.Causal.Class (($*))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Arithmetic as A++import Control.Applicative ((<$>))++import Data.Word (Word32)++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (map, iterate, takeWhile, tail)++++type MV a = Sig.T (MultiValue.T a)++iterate :: (Marshal.C a) => (Exp a -> Exp a) -> Exp a -> MV a+iterate f a = Sig.iterate (Expr.unliftM1 f) (Expr.unExp a)++-- ToDo: replace by constantSharing and scanl+iterateParam ::+   (Marshal.C a, Marshal.C b) =>+   (Exp b -> Exp a -> Exp a) -> Exp b -> Exp a -> MV a+iterateParam f b a =+   MultiValue.snd <$>+   iterate (Expr.uncurry $ \bi ai -> Expr.zip bi $ f bi ai) (Expr.zip b a)+++ramp ::+   (Marshal.C a, MultiValue.Additive a) =>+   Exp a -> Exp a -> MV a+ramp = iterateParam Expr.add++parabola ::+   (Marshal.C a, MultiValue.Additive a) =>+   Exp a -> Exp a -> Exp a -> MV a+parabola d2 d1 start = integrate start $* ramp d2 d1++integrate ::+   (Marshal.C a, MultiValue.Additive a, MultiValue.T a ~ al) =>+   Exp a -> Causal.T al al+integrate start =+   Causal.mapAccum (\a s -> (,) s <$> A.add s a) (Expr.unExp start)+++osci ::+   (MultiValue.Fraction t, Marshal.C t) =>+   Exp t -> Exp t -> MV t+osci phase freq  =  iterate (Expr.liftM2 A.incPhase freq) phase++exponential ::+   (Marshal.C a, MultiValue.PseudoRing a) =>+   Exp a -> Exp a -> MV a+exponential  =  iterateParam Expr.mul++exponentialBounded ::+   (Marshal.C a, MultiValue.PseudoRing a,+    MultiValue.Real a, MultiValue.IntegerConstant a) =>+   Exp a -> Exp a -> Exp a -> MV a+exponentialBounded bound decay =+   iterateParam+      (\bk y -> case Expr.unzip bk of (b,k) -> Expr.max b $ k*y)+      (Expr.zip bound decay)+++noise, noiseAlt :: Exp Word32 -> MV Word32+noise seed =+   iterate (Expr.liftReprM Rnd.nextCG)+      (Expr.irem seed (Expr.cons Rnd.modulus-1) + 1)++noiseAlt seed =+   iterate (Expr.liftReprM Rnd.nextCG32)+      (Expr.irem seed (Expr.cons Rnd.modulus-1) + 1)
− src/Synthesizer/LLVM/Generator/Exponential2.hs 
@@ -1,332 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{- |-Exponential curve with controllable delay.--}-module Synthesizer.LLVM.Generator.Exponential2 (-   Parameter,-   parameter,-   parameterPlain,-   causalP,--   ParameterPacked,-   parameterPacked,-   parameterPackedPlain,-   causalPackedP,-   ) where--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Simple.Value as Value-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM-import LLVM.Core-         (CodeGenFunction, Value, IsArithmetic, IsPrimitive, IsFloating, SizeOf)--import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal.Number ((:*:))--import Foreign.Storable (Storable)-import qualified Foreign.Storable--- import qualified Foreign.Storable.Record as Store-import qualified Foreign.Storable.Traversable as Store--import qualified Control.Applicative as App-import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav-import Control.Applicative (liftA2, (<*>))-import Control.Arrow (arr, (^<<), (&&&))-import Control.Monad (liftM2)--import qualified Algebra.Transcendental as Trans--import NumericPrelude.Numeric-import NumericPrelude.Base---newtype Parameter a = Parameter a-   deriving (Show, Storable)---instance Functor Parameter where-   {-# INLINE fmap #-}-   fmap f (Parameter k) = Parameter (f k)--instance App.Applicative Parameter where-   {-# INLINE pure #-}-   pure x = Parameter x-   {-# INLINE (<*>) #-}-   Parameter f <*> Parameter k =-      Parameter (f k)--instance Fold.Foldable Parameter where-   {-# INLINE foldMap #-}-   foldMap = Trav.foldMapDefault--instance Trav.Traversable Parameter where-   {-# INLINE sequenceA #-}-   sequenceA (Parameter k) =-      fmap Parameter k---instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where-   phi = Tuple.phiTraversable-   addPhi = Tuple.addPhiFoldable--instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where-   undef = Tuple.undefPointed--instance Tuple.Zero a => Tuple.Zero (Parameter a) where-   zero = Tuple.zeroPointed--instance (Memory.C a) => Memory.C (Parameter a) where-   type Struct (Parameter a) = Memory.Struct a-   load = Memory.loadNewtype Parameter-   store = Memory.storeNewtype (\(Parameter k) -> k)-   decompose = Memory.decomposeNewtype Parameter-   compose = Memory.composeNewtype (\(Parameter k) -> k)--instance (Storable.C a) => Storable.C (Parameter a) where-   load = Storable.loadNewtype Parameter Parameter-   store = Storable.storeNewtype Parameter (\(Parameter k) -> k)--{--instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)--instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where-   tupleDesc = Class.tupleDescFoldable--}--instance (Tuple.Value a) => Tuple.Value (Parameter a) where-   type ValueOf (Parameter a) = Parameter (Tuple.ValueOf a)-   valueOf = Tuple.valueOfFunctor---instance (Value.Flatten a) => Value.Flatten (Parameter a) where-   type Registers (Parameter a) = Parameter (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable---instance (Vector.Simple v) => Vector.Simple (Parameter v) where-   type Element (Parameter v) = Parameter (Vector.Element v)-   type Size (Parameter v) = Vector.Size v-   shuffleMatch = Vector.shuffleMatchTraversable-   extract = Vector.extractTraversable--instance (Vector.C v) => Vector.C (Parameter v) where-   insert  = Vector.insertTraversable---parameter ::-   (Trans.C a, SoV.TranscendentalConstant a, IsFloating a) =>-   Value a ->-   CodeGenFunction r (Parameter (Value a))-parameter = Value.unlift1 parameterPlain--parameterPlain ::-   (Trans.C a) =>-   a -> Parameter a-parameterPlain halfLife =-   Parameter $ 0.5 ** recip halfLife---causalP ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.PseudoRing al) =>-   Param.T p a ->-   CausalP.T p (Parameter al) al-causalP initial =-   CausalP.loop initial-      (arr snd &&& CausalP.zipWithSimple (\(Parameter a) -> A.mul a))---data ParameterPacked a =-   ParameterPacked {ppFeedback, ppCurrent :: a}---instance Functor ParameterPacked where-   {-# INLINE fmap #-}-   fmap f p = ParameterPacked-      (f $ ppFeedback p) (f $ ppCurrent p)--instance App.Applicative ParameterPacked where-   {-# INLINE pure #-}-   pure x = ParameterPacked x x-   {-# INLINE (<*>) #-}-   f <*> p = ParameterPacked-      (ppFeedback f $ ppFeedback p)-      (ppCurrent f $ ppCurrent p)--instance Fold.Foldable ParameterPacked where-   {-# INLINE foldMap #-}-   foldMap = Trav.foldMapDefault--instance Trav.Traversable ParameterPacked where-   {-# INLINE sequenceA #-}-   sequenceA p =-      liftA2 ParameterPacked-         (ppFeedback p) (ppCurrent p)---instance (Tuple.Phi a) => Tuple.Phi (ParameterPacked a) where-   phi = Tuple.phiTraversable-   addPhi = Tuple.addPhiFoldable--instance Tuple.Undefined a => Tuple.Undefined (ParameterPacked a) where-   undef = Tuple.undefPointed--instance Tuple.Zero a => Tuple.Zero (ParameterPacked a) where-   zero = Tuple.zeroPointed---{--storeParameter ::-   Storable a => Store.Dictionary (ParameterPacked a)-storeParameter =-   Store.run $-   liftA2 ParameterPacked-      (Store.element ppFeedback)-      (Store.element ppCurrent)--instance Storable a => Storable (ParameterPacked a) where-   sizeOf    = Store.sizeOf storeParameter-   alignment = Store.alignment storeParameter-   peek      = Store.peek storeParameter-   poke      = Store.poke storeParameter--}--instance Storable a => Storable (ParameterPacked a) where-   sizeOf    = Store.sizeOf-   alignment = Store.alignment-   peek      = Store.peekApplicative-   poke      = Store.poke---type ParameterPackedStruct a = LLVM.Struct (a, (a, ()))--memory ::-   (Memory.C a) =>-   Memory.Record r (ParameterPackedStruct (Memory.Struct a)) (ParameterPacked a)-memory =-   liftA2 ParameterPacked-      (Memory.element ppFeedback TypeNum.d0)-      (Memory.element ppCurrent  TypeNum.d1)--instance (Memory.C a) => Memory.C (ParameterPacked a) where-   type Struct (ParameterPacked a) = ParameterPackedStruct (Memory.Struct a)-   load = Memory.loadRecord memory-   store = Memory.storeRecord memory-   decompose = Memory.decomposeRecord memory-   compose = Memory.composeRecord memory--instance (Storable.C a) => Storable.C (ParameterPacked a) where-   load = Storable.loadApplicative-   store = Storable.storeFoldable---{--instance LLVM.ValueTuple a => LLVM.ValueTuple (ParameterPacked a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)--instance LLVM.IsTuple a => LLVM.IsTuple (ParameterPacked a) where-   tupleDesc = Class.tupleDescFoldable--}--instance (Tuple.Value a) => Tuple.Value (ParameterPacked a) where-   type ValueOf (ParameterPacked a) = ParameterPacked (Tuple.ValueOf a)-   valueOf = Tuple.valueOfFunctor---instance (Value.Flatten a) => Value.Flatten (ParameterPacked a) where-   type Registers (ParameterPacked a) = ParameterPacked (Value.Registers a)-   flattenCode = Value.flattenCodeTraversable-   unfoldCode = Value.unfoldCodeTraversable--type instance F.Arguments f (ParameterPacked a) = f (ParameterPacked a)-instance F.MakeArguments (ParameterPacked a) where-   makeArgs = id----withSize ::-   (TypeNum.Natural n) =>-   (Serial.C v, Serial.Size v ~ n, TypeNum.Positive n) =>-   (TypeNum.Singleton n -> m (param v)) ->-   m (param v)-withSize f = f TypeNum.singleton--parameterPacked ::-   (Serial.C v, Serial.Element v ~ a,-    A.PseudoRing v, A.RationalConstant v,-    A.Transcendental a, A.RationalConstant a) =>-   a -> CodeGenFunction r (ParameterPacked v)-parameterPacked halfLife = withSize $ \n -> do-   feedback <--      Serial.upsample =<<-      A.pow (A.fromRational' 0.5) =<<-      A.fdiv (A.fromInteger' $ TypeNum.integralFromSingleton n) halfLife-   k <--      A.pow (A.fromRational' 0.5) =<<-      A.fdiv (A.fromInteger' 1) halfLife-   current <--      Serial.iterate (A.mul k) (A.fromInteger' 1)-   return $ ParameterPacked feedback current-{--   Value.unlift1 parameterPackedPlain--}--withSizePlain ::-   (TypeNum.Natural n) =>-   (TypeNum.Singleton n -> param (Serial.Plain n a)) ->-   param (Serial.Plain n a)-withSizePlain f = f TypeNum.singleton--parameterPackedPlain ::-   (Trans.C a,-    TypeNum.Positive n) =>-   a -> ParameterPacked (Serial.Plain n a)-parameterPackedPlain halfLife =-   withSizePlain $ \n ->-   ParameterPacked-      (Serial.replicate_ n (0.5 ** (fromInteger (TypeNum.integerFromSingleton n) / halfLife)))-      (Serial.iteratePlain (0.5 ** recip halfLife *) one)---withSizeValue ::-   (TypeNum.Natural n) =>-   (TypeNum.Singleton n -> f (Serial.Value n a)) ->-   f (Serial.Value n a)-withSizeValue f = f TypeNum.singleton--causalPackedP ::-   (IsArithmetic a, SoV.IntegerConstant a,-    Marshal.C a, Tuple.ValueOf a ~ Value a,-    Marshal.Vector n a, Tuple.VectorValueOf n a ~ Value (LLVM.Vector n a),-    IsPrimitive a,-    TypeNum.Positive (n :*: SizeOf a),-    TypeNum.Positive n) =>-   Param.T p a ->-   CausalP.T p (ParameterPacked (Serial.Value n a)) (Serial.Value n a)-causalPackedP initial =-   withSizeValue $ \n ->-   CausalP.loop-      (Serial.replicate_ n ^<< initial)-      (CausalP.mapSimple $-       \(p, s0) -> liftM2 (,)-          (A.mul (ppCurrent p) s0)-          (A.mul (ppFeedback p) s0))
+ src/Synthesizer/LLVM/Generator/Extra.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Generator.Extra where++import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import Synthesizer.Causal.Class (($*))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue++import Data.Word (Word)++import NumericPrelude.Numeric++++ramp,+ parabolaFadeIn, parabolaFadeOut,+ parabolaFadeInMap, parabolaFadeOutMap ::+   (Marshal.C a, MultiValue.Field a, MultiValue.IntegerConstant a,+    MultiValue.NativeFloating a ar) =>+   Exp Word -> Sig.MV a++ramp dur =+   Causal.take dur $* Sig.rampInf (Expr.fromIntegral dur)++parabolaFadeIn dur =+   Causal.take dur $* Sig.parabolaFadeInInf (Expr.fromIntegral dur)++parabolaFadeOut dur =+   Causal.take dur $* Sig.parabolaFadeOutInf (Expr.fromIntegral dur)++parabolaFadeInMap dur = Causal.map (\t -> t*(2-t)) $* ramp dur+parabolaFadeOutMap dur = Causal.map (\t -> 1-t*t) $* ramp dur
+ src/Synthesizer/LLVM/Generator/Private.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Generator.Private where++import Synthesizer.LLVM.Private (getPairPtrs, noLocalPtr)++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction)++import Type.Base.Proxy (Proxy(Proxy))++import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>))++import Data.Semigroup (Semigroup, (<>))+import Data.Tuple.Strict (mapFst, zipPair)++import qualified Number.Ratio as Ratio+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Prelude as P+import Prelude hiding (iterate, takeWhile, map, zipWith)+++data T a =+   forall global local state.+      (Memory.C global, LLVM.IsSized local, Memory.C state) =>+      Cons (forall r c.+            (Tuple.Phi c) =>+            global ->+            -- pointer to loop local storage+            LLVM.Value (LLVM.Ptr local) ->+            state -> MaybeCont.T r c (a, state))+               -- compute next value+           (forall r. CodeGenFunction r (global, state))+               -- initial state+           (forall r. global -> CodeGenFunction r ())+               -- cleanup+++noGlobal ::+   (LLVM.IsSized local, Memory.C state) =>+   (forall r c.+    (Tuple.Phi c) =>+    LLVM.Value (LLVM.Ptr local) -> state -> MaybeCont.T r c (a, state)) ->+   (forall r. CodeGenFunction r state) ->+   T a+noGlobal next start = Cons (const next) (fmap ((,) ()) start) return++alloca :: (LLVM.IsSized a) => T (LLVM.Value (LLVM.Ptr a))+alloca =+   noGlobal+      (\ptr () -> return (ptr, ()))+      (return ())+++iterate ::+   (Memory.C a) =>+   (forall r. a -> CodeGenFunction r a) ->+   (forall r. CodeGenFunction r a) -> T a+iterate f a =+   noGlobal+      (noLocalPtr $ \s -> fmap ((,) s) $ MaybeCont.lift $ f s)+      a++iterateParam ::+   (Memory.C b, Memory.C a) =>+   (forall r. b -> a -> CodeGenFunction r a) ->+   (forall r. CodeGenFunction r b) ->+   (forall r. CodeGenFunction r a) -> T a+iterateParam f b a =+   fmap snd $ iterate (\(bi,ai) -> (,) bi <$> f bi ai) (liftA2 (,) b a)++takeWhile ::+   (forall r. a -> CodeGenFunction r (LLVM.Value Bool)) -> T a -> T a+takeWhile p (Cons next start stop) = Cons+   (\global local s0 -> do+      (a,s1) <- next global local s0+      MaybeCont.guard =<< MaybeCont.lift (p a)+      return (a,s1))+   start+   stop+++empty :: T a+empty = noGlobal (noLocalPtr $ \ _state -> 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 :: (Tuple.Phi a, Tuple.Undefined a) => T a -> T a -> T a+append (Cons nextA startA stopA) (Cons nextB startB stopB) = Cons+   (\(globalA, globalB) local (sa0,sb0,phaseB) -> do+      (localA,localB) <- getPairPtrs local+      MaybeCont.alternative+         (do+            MaybeCont.guard =<< MaybeCont.lift (LLVM.inv phaseB)+            (a,sa1) <- nextA globalA localA sa0+            return (a, (sa1, sb0, LLVM.valueOf False)))+         (do+            (b,sb1) <- nextB globalB localB sb0+            return (b, (sa0, sb1, LLVM.valueOf True))))+   (do+      (globalA,stateA) <- startA+      (globalB,stateB) <- startB+      return ((globalA,globalB), (stateA, stateB, LLVM.valueOf False)))+   (\(globalA,globalB) -> stopB globalB >> stopA globalA)++instance (Tuple.Phi a, Tuple.Undefined a) => Semigroup (T a) where+   (<>) = append++instance (Tuple.Phi a, Tuple.Undefined a) => Monoid (T a) where+   mempty = empty+   mappend = (<>)++++instance Functor T where+   fmap f (Cons next start stop) = Cons+      (\global local s -> mapFst f <$> next global local s)+      start stop++instance Applicative T where+   pure a = noGlobal (noLocalPtr $ \() -> return (a, ())) (return ())+   Cons nextF startF stopF <*> Cons nextA startA stopA = Cons+      (\(globalF, globalA) local (sf0,sa0) -> do+         (localF,localA) <- getPairPtrs local+         (f,sf1) <- nextF globalF localF sf0+         (a,sa1) <- nextA globalA localA sa0+         return (f a, (sf1,sa1)))+      (liftA2 zipPair startF startA)+      (\(globalF, globalA) -> stopA globalA >> stopF globalF)+++map :: (forall r. a -> CodeGenFunction r b) -> T a -> T b+map f (Cons next start stop) =+   Cons+      (\global local sa0 -> do+         (a,sa1) <- next global local sa0+         b <- MaybeCont.lift $ f a+         return (b, sa1))+      start stop++zipWith :: (forall r. a -> b -> CodeGenFunction r c) -> T a -> T b -> T c+zipWith f as bs = map (uncurry f) $ liftA2 (,) as bs++instance (A.Additive a) => Additive.C (T a) where+   zero = pure A.zero+   negate = map A.neg+   (+) = zipWith A.add+   (-) = zipWith A.sub++instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where+   one = pure A.one+   fromInteger n = pure (A.fromInteger' n)+   (*) = zipWith A.mul++instance (A.Field a, A.RationalConstant a) => Field.C (T a) where+   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)+   (/) = zipWith A.fdiv+++instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T a) where+   fromInteger n = pure (A.fromInteger' n)+   negate = map A.neg+   (+) = zipWith A.add+   (-) = zipWith A.sub+   (*) = zipWith A.mul+   abs = map A.abs+   signum = map A.signum++instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where+   fromRational x = pure (A.fromRational' x)+   (/) = zipWith A.fdiv++++arraySize :: value (array n a) -> Proxy n+arraySize _ = Proxy
+ src/Synthesizer/LLVM/Generator/Render.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Generator.Render where++import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+import qualified Synthesizer.LLVM.Generator.Source as Source+import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt+import qualified Synthesizer.LLVM.EventIterator as EventIt+import Synthesizer.LLVM.Generator.Private (T(Cons))++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Storable.Vector as SVU+import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr+import qualified Synthesizer.LLVM.ConstantPiece as Const++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.Causal.Class as CausalClass++import qualified LLVM.DSL.Execution as Exec+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector.Base as SVB+import qualified Data.StorableVector as SV++import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Wrapper as NonNeg+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import Control.Monad (join)+import Control.Applicative (liftA3)++import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.Ptr (Ptr)++import Data.Foldable (traverse_)+import Data.Tuple.Strict (mapPair, mapTriple)+import Data.Word (Word, Word8, Word32)++import qualified System.Unsafe as Unsafe+++foreign import ccall safe "dynamic" derefFillPtr ::+   Exec.Importer (LLVM.Ptr param -> Word -> Ptr struct -> IO Word)+++compile ::+   (Storable.C a, MultiValue.T a ~ value,+    Marshal.C param, Marshal.Struct param ~ paramStruct) =>+   (Exp param -> T value) ->+   IO (LLVM.Ptr paramStruct -> Word -> Ptr a -> IO Word)+compile sig =+   Exec.compile "signal" $+   Exec.createFunction derefFillPtr "fill" $ \paramPtr size bPtr ->+   case sig (Exp (Memory.load paramPtr)) of+      Cons next start stop -> do+         (global,s) <- start+         local <- LLVM.alloca+         (pos,_) <- Storable.arrayLoopMaybeCont size bPtr s $ \ ptri s0 -> do+            (y,s1) <- next global local s0+            MaybeCont.lift $ Storable.store y ptri+            return s1+         stop global+         return pos++runAux ::+   (Marshal.C p, Storable.C a, MultiValue.T a ~ value) =>+   (Exp p -> T value) -> IO (IO () -> Int -> p -> IO (SV.Vector a))+runAux sig = do+   fill <- compile sig+   return $ \final len param ->+      Marshal.with param $ \paramPtr ->+      SVB.createAndTrim len $ \ptr -> do+         n <- fill paramPtr (fromIntegral len) ptr+         final+         return $ fromIntegral n++run_ ::+   (Marshal.C p, Storable.C a, MultiValue.T a ~ value) =>+   (Exp p -> T value) -> IO (Int -> p -> IO (SV.Vector a))+run_ = fmap ($ return ()) . runAux+++foreign import ccall safe "dynamic" derefStartPtr ::+   Exec.Importer (LLVM.Ptr param -> IO (LLVM.Ptr globalState))++foreign import ccall safe "dynamic" derefStopPtr ::+   Exec.Importer (LLVM.Ptr globalState -> IO ())++foreign import ccall safe "dynamic" derefChunkPtr ::+   Exec.Importer (LLVM.Ptr globalState -> Word -> Ptr a -> IO Word)+++type MemoryPtr a = LLVM.Ptr (Memory.Struct a)++type WithGlobalState param = LLVM.Struct (param, ())++type Pair a b = LLVM.Struct (a,(b,()))+type Triple a b c = LLVM.Struct (a,(b,(c,())))++tripleStruct ::+   (LLVM.IsSized a, LLVM.IsSized b, LLVM.IsSized c) =>+   LLVM.Value a -> LLVM.Value b -> LLVM.Value c ->+   LLVM.CodeGenFunction r (LLVM.Value (Triple a b c))+tripleStruct a b c = do+   s0 <- LLVM.insertvalue Tuple.undef a TypeNum.d0+   s1 <- LLVM.insertvalue s0 b TypeNum.d1+   LLVM.insertvalue s1 c TypeNum.d2++{- |+This is a pretty ugly hack, but its seems to be the least ugly one.+We need to solve the following problem:+We have a function of type @Exp param -> T value@.+This means that all methods in @T value@ depend on @Exp param@.+We need to choose one piece of LLVM code in @Exp param@+that generates appropriate code for all methods in @T value@.+If we access a function parameter via @Memory.load paramPtr@+this means that all methods must end up in the same LLVM function+in order to access this parameter.+Thus I have to put all functionality in one LLVM function+and then the three functions in 'compileChunky'+jump into the handler function with a 'Word8' code+specifying the actual sub-routine.+We need to squeeze all possible inputs and outputs+through one function interface.++However, since the handler is marked as internal+the optimizer inlines it in the three functions from 'compileChunky'+and eliminates dead code.+This way, we end up with the code that we would have written otherwise.++The alternative would be to construct @T value@ multiple times.+Due to existential quantification we cannot prove+that the pointer types of different methods match,+so we need to cast pointers.+However, with the current approach we also have to do that.+-}+compileHandler ::+   (Marshal.C param, Marshal.Struct param ~ paramStruct,+    Storable.C a, MultiValue.T a ~ value) =>+   (Exp param -> T value) ->+   LLVM.CodeGenModule+      (LLVM.Function+         (Word8 -> LLVM.Ptr paramStruct -> Word -> Ptr a ->+          IO (Pair (LLVM.Ptr (WithGlobalState paramStruct)) Word)))+compileHandler sig =+   LLVM.createNamedFunction LLVM.InternalLinkage "handlesignal" $+   \phase paramPtr loopLen bufferPtr ->+   case sig $ Exp (Memory.load paramPtr) of+      Cons next start stop -> do+         paramGlobalStatePtr <- LLVM.bitcast paramPtr++         let create = do+               newParamGlobalStatePtr <- LLVM.malloc+               (global,state) <- start+               flip LLVM.store newParamGlobalStatePtr =<<+                  join+                     (liftA3 tripleStruct+                        (LLVM.load paramPtr)+                        (Memory.compose global)+                        (Memory.compose state))+               newOpaqueParamGlobalStatePtr <-+                  LLVM.bitcast+                     (newParamGlobalStatePtr `asTypeOf` paramGlobalStatePtr)+               LLVM.insertvalue Tuple.undef+                  newOpaqueParamGlobalStatePtr TypeNum.d0++         let delete = do+               globalPtr <-+                  LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+               stop =<< Memory.load globalPtr+               LLVM.free paramGlobalStatePtr+               return Tuple.undef++         let fill = do+               globalPtr <-+                  LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+               statePtr <-+                  LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ())+               global <- Memory.load globalPtr+               sInit <- Memory.load statePtr+               local <- LLVM.alloca+               (pos,sExit) <-+                  Storable.arrayLoopMaybeCont loopLen bufferPtr sInit $+                     \ ptr s0 -> do+                  (y,s1) <- next global local s0+                  MaybeCont.lift $ Storable.store y ptr+                  return s1+               Memory.store (Maybe.fromJust sExit) statePtr+               LLVM.insertvalue Tuple.undef pos TypeNum.d1++         doCreate <- A.cmp LLVM.CmpEQ (LLVM.valueOf 0) phase+         doDelete <- A.cmp LLVM.CmpEQ (LLVM.valueOf 1) phase+         C.ret =<<+            (C.ifThenElse doCreate create $+             C.ifThenElse doDelete delete fill)++compileChunky ::+   (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr,+    Memory.C state, Memory.Struct state ~ stateStruct,+    Memory.C global, Memory.Struct global ~ globalStruct,+    Triple paramStruct globalStruct stateStruct ~ triple,+    LLVM.IsSized local,+    Storable.C a, MultiValue.T a ~ value) =>+   (forall r z. (Tuple.Phi z) =>+    pPtr -> global -> LLVM.Value (LLVM.Ptr local) ->+    () -> state -> MaybeCont.T r z (value, state)) ->+   (forall r. pPtr -> LLVM.CodeGenFunction r (global, state)) ->+   (forall r. pPtr -> global -> LLVM.CodeGenFunction r ()) ->+   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple),+       Exec.Finalizer triple,+       LLVM.Ptr triple -> Word -> Ptr a -> IO Word)+compileChunky next start stop =+   Exec.compile "signal-chunky" $+   liftA3 (,,)+      (Exec.createFunction derefStartPtr "startsignal" $+         \paramPtr -> do+            paramGlobalStatePtr <- LLVM.malloc+            (global,state) <- start paramPtr+            flip LLVM.store paramGlobalStatePtr =<<+               join+                  (liftA3 tripleStruct+                     (LLVM.load paramPtr)+                     (Memory.compose global)+                     (Memory.compose state))+            return paramGlobalStatePtr)+      (Exec.createFinalizer derefStopPtr "stopsignal" $+         \paramGlobalStatePtr -> do+            paramPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ())+            stop paramPtr =<<+               Memory.load =<<+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+            LLVM.free paramGlobalStatePtr)+      (Exec.createFunction derefChunkPtr "fillsignal" $+         \paramGlobalStatePtr loopLen ptr -> do+            paramPtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d0, ())+            global <-+               Memory.load =<<+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+            statePtr <-+               LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ())+            sInit <- Memory.load statePtr+            local <- LLVM.alloca+            (pos,sExit) <-+               Storable.arrayLoopMaybeCont loopLen ptr sInit $+                  \ ptri s0 -> do+               (y,s1) <- next paramPtr global local () s0+               MaybeCont.lift $ Storable.store y ptri+               return s1+            Memory.store (Maybe.fromJust sExit) statePtr+            return pos)+++runChunkyAux ::+   (Storable.C a, MultiValue.T a ~ value, Marshal.C p) =>+   (Exp p -> T value) -> IO (IO () -> SVL.ChunkSize -> p -> IO (SVL.Vector a))+runChunkyAux sig = do+   paramd <-+      Parameterized.fromProcessPtr "Signal.run" (CausalClass.fromSignal . sig)+   case paramd of+      Parameterized.Cons next start stop -> do+         (startFunc,stopFunc,fill) <- compileChunky next start stop+         return $ \final (SVL.ChunkSize size) p -> do+            statePtr <- ForeignPtr.newParamMV stopFunc startFunc p++            let go =+                  Unsafe.interleaveIO $ do+                     v <-+                        ForeignPtr.with statePtr $ \sptr ->+                        SVB.createAndTrim size $+                        fmap (fromIntegral :: Word -> Int) .+                        fill sptr (fromIntegral size)+                     (if SV.length v > 0+                        then fmap (v:)+                        else id) $+                        (if SV.length v < size+                           then final >> return []+                           else go)+            fmap SVL.fromChunks go++runChunky ::+   (Storable.C a, MultiValue.T a ~ value, Marshal.C p) =>+   (Exp p -> T value) -> IO (SVL.ChunkSize -> p -> IO (SVL.Vector a))+runChunky = fmap ($ return ()) . runChunkyAux+++runChunkyOnVector ::+   (Storable.C a, MultiValue.T a ~ al) =>+   (Storable.C b, MultiValue.T b ~ bl) =>+   (T al -> T bl) ->+   IO (SVL.ChunkSize -> SV.Vector a -> IO (SVL.Vector b))+runChunkyOnVector sig = do+   f <- runChunkyAux (sig . Source.storableVector)+   return $ \chunkSize av -> do+      let (fp,ptr,l) = SVU.unsafeToPointers av+      f (touchForeignPtr fp) chunkSize (Source.consStorableVector ptr l)+++class Run f where+   type DSL f+   type Shape f+   build ::+      (Marshal.C p) =>+      (Exp p -> DSL f) -> IO (IO (p, IO ()) -> Shape f -> f)++instance (Storable.C a) => Run (SVL.Vector a) where+   type DSL (SVL.Vector a) = T (MultiValue.T a)+   type Shape (SVL.Vector a) = SVL.ChunkSize+   build =+      fmap (\f create shape -> Unsafe.performIO $ buildIOGen f create shape) .+      runChunkyAux++instance (Storable.C a) => Run (SV.Vector a) where+   type DSL (SV.Vector a) = T (MultiValue.T a)+   type Shape (SV.Vector a) = Int+   build =+      fmap (\f create shape -> Unsafe.performIO $ buildIOGen f create shape) .+      runAux++instance (RunIO a) => Run (IO a) where+   type DSL (IO a) = T (DSL_IO a)+   type Shape (IO a) = ShapeIO a+   build = buildIO++instance (RunArg a, Run f) => Run (a -> f) where+   type DSL (a -> f) = DSLArg a -> DSL f+   type Shape (a -> f) = Shape f+   build sig =+      case buildArg of+         BuildArg pass createA -> do+            f <- build (Expr.uncurry $ \p -> sig p . pass)+            return $ \createP shape av ->+               f (do (p,finalP) <- createP+                     (pa,finalA) <- createA av+                     return ((p,pa), finalA >> finalP))+                  shape+++class RunIO a where+   type DSL_IO a+   type ShapeIO a+   buildIO ::+      (Marshal.C p) =>+      (Exp p -> T (DSL_IO a)) -> IO (IO (p, IO ()) -> ShapeIO a -> IO a)++instance (Storable.C a) => RunIO (SVL.Vector a) where+   type DSL_IO (SVL.Vector a) = MultiValue.T a+   type ShapeIO (SVL.Vector a) = SVL.ChunkSize+   buildIO = fmap buildIOGen . runChunkyAux++instance (Storable.C a) => RunIO (SV.Vector a) where+   type DSL_IO (SV.Vector a) = MultiValue.T a+   type ShapeIO (SV.Vector a) = Int+   buildIO = fmap buildIOGen . runAux++buildIOGen ::+   (Monad m) => (final -> shape -> p -> m a) -> m (p, final) -> shape -> m a+buildIOGen f create shape = do (p,final) <- create; f final shape p+++data BuildArg a =+   forall al. Marshal.C al =>+   BuildArg (Exp al -> DSLArg a) (a -> IO (al, IO ()))++class RunArg a where+   type DSLArg a+   buildArg :: BuildArg a++instance RunArg () where+   type DSLArg () = ()+   buildArg = BuildArg (\ _unit -> ()) (\() -> return ((), return ()))++instance (RunArg a, RunArg b) => RunArg (a,b) where+   type DSLArg (a,b) = (DSLArg a, DSLArg b)+   buildArg =+      case (buildArg,buildArg) of+         (BuildArg passA createA, BuildArg passB createB) ->+            BuildArg+               (mapPair (passA,passB) . Expr.unzip)+               (\(a,b) -> do+                  (pa,finalA) <- createA a+                  (pb,finalB) <- createB b+                  return ((pa,pb), finalB>>finalA))++instance (RunArg a, RunArg b, RunArg c) => RunArg (a,b,c) where+   type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c)+   buildArg =+      case (buildArg,buildArg,buildArg) of+         (BuildArg passA createA, BuildArg passB createB,+          BuildArg passC createC) ->+            BuildArg+               (mapTriple (passA,passB,passC) . Expr.unzip3)+               (\(a,b,c) -> do+                  (pa,finalA) <- createA a+                  (pb,finalB) <- createB b+                  (pc,finalC) <- createC c+                  return ((pa,pb,pc), finalC>>finalB>>finalA))++primitiveArg :: (Marshal.C a, DSLArg a ~ Exp a) => BuildArg a+primitiveArg = BuildArg id (\a -> return (a, return ()))++instance RunArg Float where+   type DSLArg Float = Exp Float+   buildArg = primitiveArg++instance RunArg Int where+   type DSLArg Int = Exp Int+   buildArg = primitiveArg++instance RunArg Word where+   type DSLArg Word = Exp Word+   buildArg = primitiveArg++instance RunArg Word32 where+   type DSLArg Word32 = Exp Word32+   buildArg = primitiveArg++instance (RunArg a) => RunArg (Stereo.T a) where+   type DSLArg (Stereo.T a) = Stereo.T (DSLArg a)+   buildArg =+      case buildArg of+         BuildArg pass create ->+            BuildArg+               (fmap pass . Stereo.unExpression)+               (\s -> do+                  pf <- traverse create s+                  return (fst<$>pf, traverse_ snd pf))++instance+   (TypeNum.Natural n, Marshal.C a, LLVM.IsSized (Marshal.Struct a),+    TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf (Marshal.Struct a))) =>+      RunArg (MultiValue.Array n a) where+   type DSLArg (MultiValue.Array n a) = Exp (MultiValue.Array n a)+   buildArg = primitiveArg++instance (Storable.C a) => RunArg (SV.Vector a) where+   type DSLArg (SV.Vector a) = T (MultiValue.T a)+   buildArg =+      BuildArg+         Source.storableVector+         (\av -> do+            let (fp,ptr,l) = SVU.unsafeToPointers av+            return (Source.consStorableVector ptr l, touchForeignPtr fp))++newtype Buffer a = Buffer (SV.Vector a)++buffer :: SV.Vector a -> Buffer a+buffer = Buffer++instance (Storable.C a) => RunArg (Buffer a) where+   type DSLArg (Buffer a) = Exp (Source.StorableVector a)+   buildArg =+      BuildArg id+         (\(Buffer av) -> do+            let (fp,ptr,l) = SVU.unsafeToPointers av+            return (Source.consStorableVector ptr l, touchForeignPtr fp))++newDisposeArg ::+   (Marshal.C handle) =>+   (a -> IO handle) -> (handle -> IO ()) ->+   (Exp handle -> DSLArg a) -> BuildArg a+newDisposeArg new dispose fetch =+   BuildArg fetch+      (\x -> do+         it <- new x+         return (it, dispose it))++instance (Storable.C a) => RunArg (SVL.Vector a) where+   type DSLArg (SVL.Vector a) = T (MultiValue.T a)+   buildArg =+      newDisposeArg ChunkIt.new ChunkIt.dispose Source.storableVectorLazy++class TimeInteger int where+   subdivideLong :: EventList.T (NonNeg.T int) a -> EventList.T NonNeg.Int a++instance TimeInteger Int where+   subdivideLong = id++instance TimeInteger Integer where+   subdivideLong = PC.subdivideLongStrict++instance+   (time ~ NonNeg.T int, TimeInteger int, Marshal.C a) =>+      RunArg (EventList.T time a) where+   type DSLArg (EventList.T time a) = T (Const.T (MultiValue.T a))+   buildArg =+      newDisposeArg+         (EventIt.new . subdivideLong) EventIt.dispose Source.eventList++instance (a ~ SVL.ChunkSize) => RunArg (NonNegChunky.T a) where+   type DSLArg (NonNegChunky.T a) = T (Const.T ())+   buildArg =+      newDisposeArg SizeIt.new SizeIt.dispose Source.lazySize++{-+do f <- run (\n -> takeWhile (<*n) (iterate (1+) 0) <> takeWhile (<*n) (iterate (2+) 0)); f SVL.defaultChunkSize (12::Float) :: IO (SVL.Vector Float)+do f <- Sig.run (\n -> Sig.takeWhile (Expr.<*n) (Sig.iterate (1+) 0) <> Sig.takeWhile (Expr.<*n) (Sig.iterate (2+) 0)); f SVL.defaultChunkSize (12::Float) :: IO (SVL.Vector Float)+-}+run :: (Run f) => DSL f -> IO (Shape f -> f)+run sig = do+   act <- build (const sig)+   return $ act (return ((), return ()))
+ src/Synthesizer/LLVM/Generator/Signal.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Generator.Signal (+   Sig.T,+   MV,++   constant,+   fromArray,+   Core.iterate,+   takeWhile,+   take,+   tail,+   drop,+   Sig.append,+   cycle,++   amplify,++   osci,+   exponential2,+   exponentialBounded2,+   noise,++   adjacentNodes02,+   adjacentNodes13,+   interpolateConstant,++   rampSlope,+   rampInf,+   ramp,+   parabolaFadeInInf,+   parabolaFadeOutInf,+   parabolaFadeIn,+   parabolaFadeOut,+   parabolaFadeInMap,+   parabolaFadeOutMap,+   ) where++import qualified Synthesizer.LLVM.Causal.Private as Causal+import qualified Synthesizer.LLVM.Generator.Core as Core+import qualified Synthesizer.LLVM.Generator.Private as Sig+import qualified Synthesizer.LLVM.Interpolation as Interpolation+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.Random as Rnd+import Synthesizer.LLVM.Generator.Private (arraySize)+import Synthesizer.LLVM.Private (noLocalPtr)++import qualified Synthesizer.Causal.Class as CausalC+import Synthesizer.Causal.Class (apply, ($*), ($<))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction)++import qualified Type.Data.Num.Decimal.Number as TypeNum+import Type.Data.Num.Decimal.Number ((:*:))++import Control.Monad.HT ((<=<))+import Control.Applicative (liftA2)++import Data.Word (Word32, Word)+import Data.Int (Int32)++import NumericPrelude.Numeric+import NumericPrelude.Base hiding+         (map, iterate, takeWhile, take, tail, drop, cycle)++++type MV a = Sig.T (MultiValue.T a)++constant :: (Expr.Aggregate ae al, Memory.C al) => ae -> Sig.T al+constant a = Sig.iterate return (Expr.bundle a)+++fromArray ::+   (TypeNum.Natural n, Marshal.C a) =>+   ((n :*: LLVM.SizeOf (Marshal.Struct a)) ~ arrSize,+    TypeNum.Natural arrSize) =>+   Exp (MultiValue.Array n a) -> MV a+fromArray arrExp = Sig.Cons+   (\arrPtr -> noLocalPtr $ \i -> do+      inRange <- MaybeCont.lift $+         LLVM.cmp LLVM.CmpLT i $ LLVM.valueOf $+            TypeNum.integralFromProxy $ arraySize arrExp+      MaybeCont.guard inRange+      MaybeCont.lift $ do+         ptr <- LLVM.getElementPtr0 arrPtr (i, ())+         liftA2 (,) (Memory.load ptr) (A.inc i))+   (do+      arrPtr <- LLVM.malloc+      flip Memory.store arrPtr =<< Expr.unExp arrExp+      return (arrPtr, A.zero :: LLVM.Value Word))+   LLVM.free+++takeWhile :: (Expr.Aggregate ae a) => (ae -> Exp Bool) -> Sig.T a -> Sig.T a+takeWhile p =+   Sig.takeWhile (fmap (\(MultiValue.Cons cont) -> cont) . Expr.unliftM1 p)++take :: Exp Word -> Sig.T a -> Sig.T a+take len =+   liftA2 (flip const) $ takeWhile (0 Expr.<*) (Core.iterate (subtract 1) len)++{- |+@tail empty@ generates the empty signal.+-}+tail :: Sig.T a -> Sig.T a+tail (Sig.Cons next start stop) = Sig.Cons+   next+   (do+      local <- LLVM.alloca+      (global,s0) <- start+      MaybeCont.resolve (next global local s0)+         (return (global,s0))+         (\(_a,s1) -> return (global,s1)))+   stop++drop :: Exp Word -> Sig.T a -> Sig.T a+drop n (Sig.Cons next start stop) = Sig.Cons+   next+   (do+      local <- LLVM.alloca+      (global,state0) <- start+      ~(MultiValue.Cons nv) <- Expr.unExp n+      state1 <-+         Iter.mapWhileState_+            (\_ s0 ->+               MaybeCont.resolve (next global local s0)+                  (return (LLVM.valueOf False, s0))+                  (\(_a,s1) -> return (LLVM.valueOf True, s1)))+            (Iter.countDown nv) state0+      return (global,state1))+   stop+++{- |+> cycle empty == empty+-}+cycle :: (Tuple.Phi a, Tuple.Undefined a) => Sig.T a -> Sig.T a+cycle (Sig.Cons next start stop) =+   Sig.Cons+      (\globalPtr local s0 ->+         MaybeCont.alternative+            (do+               c0 <- MaybeCont.lift $ Memory.load globalPtr+               next c0 local s0)+            (do+               (c1,s1) <- MaybeCont.lift $ do+                  stop =<< Memory.load globalPtr+                  cs1 <- start+                  Memory.store (fst cs1) globalPtr+                  return cs1+               next c1 local s1))+      (do+         globalPtr <- LLVM.malloc+         (global,state) <- start+         Memory.store global globalPtr+         return (globalPtr, state))+      (\globalPtr -> do+         stop =<< Memory.load globalPtr+         LLVM.free globalPtr)+++amplify ::+   (Expr.Aggregate ea a, Memory.C a, A.PseudoRing a) =>+   ea -> Sig.T a -> Sig.T a+amplify x = apply (Causal.zipWith Frame.amplifyMono $< constant x)+++rampInf, rampSlope,+ parabolaFadeInInf, parabolaFadeOutInf ::+   (Marshal.C a, MultiValue.Field a, MultiValue.IntegerConstant a) =>+   Exp a -> MV a+rampSlope slope  =  Core.ramp slope Expr.zero+rampInf dur  =  rampSlope (Expr.recip dur)++{-+t*(2-t) = 1 - (t-1)^2++(t+d)*(2-t-d) - t*(2-t)+   = d*(2-t) - d*t - d^2+   = 2*d*(1-t) - d^2+   = d*(2*(1-t) - d)++2*d*(1-t-d) + d^2  -  (2*d*(1-t) + d^2)+   = -2*d^2+-}+parabolaFadeInInf dur =+   Core.parabola+      ((\d -> -2*d*d)  $ Expr.recip dur)+      ((\d -> d*(2-d)) $ Expr.recip dur)+      Expr.zero++{-+1-t^2+-}+parabolaFadeOutInf dur =+   Core.parabola+      ((\d -> -2*d*d) $ Expr.recip dur)+      ((\d ->   -d*d) $ Expr.recip dur)+      Expr.one++ramp,+ parabolaFadeIn, parabolaFadeOut,+ parabolaFadeInMap, parabolaFadeOutMap ::+   (Marshal.C a, MultiValue.Field a, MultiValue.IntegerConstant a,+    MultiValue.NativeFloating a ar) =>+   Exp Word -> MV a++ramp dur =+   take dur $ rampInf (Expr.fromIntegral dur)++parabolaFadeIn dur =+   take dur $ parabolaFadeInInf (Expr.fromIntegral dur)++parabolaFadeOut dur =+   take dur $ parabolaFadeOutInf (Expr.fromIntegral dur)++parabolaFadeInMap dur =+   Causal.map (Expr.unliftM1 (\t -> t*(2-t))) $* ramp dur++parabolaFadeOutMap dur =+   Causal.map (Expr.unliftM1 (\t -> 1-t*t)) $* ramp dur+++osci ::+   (MultiValue.Fraction t, Marshal.C t) =>+   (forall r. MultiValue.T t -> CodeGenFunction r y) ->+   Exp t -> Exp t -> Sig.T y+osci wave phase freq  =  Causal.map wave $* Core.osci phase freq+++exponential2 ::+   (Marshal.C a) =>+   (MultiValue.Real a) =>+   (MultiValue.RationalConstant a) =>+   (MultiValue.Transcendental a) =>+   Exp a -> Exp a -> MV a+exponential2 halfLife  =  Core.exponential (1 / 2 ** recip halfLife)++exponentialBounded2 ::+   (Marshal.C a) =>+   (MultiValue.Real a) =>+   (MultiValue.RationalConstant a) =>+   (MultiValue.Transcendental a) =>+   Exp a -> Exp a -> Exp a -> MV a+exponentialBounded2 bound halfLife =+   Core.exponentialBounded bound (1 / 2 ** recip halfLife)+++{- |+@noise seed rate@++The @rate@ parameter is for adjusting the amplitude+such that it is uniform across different sample rates+and after frequency filters.+The @rate@ is the ratio of the current sample rate to the default sample rate,+where the variance of the samples would be one.+If you want that at sample rate 22050 the variance is 1,+then in order to get a consistent volume at sample rate 44100+you have to set @rate = 2@.++I use the variance as quantity and not the amplitude,+because the amplitude makes only sense for uniformly distributed samples.+However, frequency filters transform the probabilistic density of the samples+towards the normal distribution according to the central limit theorem.+-}+noise ::+   (Marshal.C a, MultiValue.Transcendental a, MultiValue.RationalConstant a,+    MultiValue.NativeFloating a ar) =>+   Exp Word32 -> Exp a -> MV a+noise seed rate =+   let m2 = Expr.fromInteger' $ div Rnd.modulus 2+       r = sqrt (3 * rate) / m2+   in  Causal.map (Expr.unliftM1 (\y -> r * (int31tofp y - (m2+1)))) $*+       Core.noise seed++{-+sitofp is a single instruction on x86+and thus we use it, since the arguments are below 2^31.+-}+int31tofp ::+   (MultiValue.NativeFloating a ar) =>+   Exp Word32 -> Exp a+int31tofp =+   Expr.liftM+      (MultiValue.fromIntegral <=<+       (MultiValue.liftM LLVM.bitcast ::+         MultiValue.T Word32 -> CodeGenFunction r (MultiValue.T Int32)))+++adjacentNodes02 ::+   (Memory.C a) =>+   Sig.T a -> Sig.T (Interpolation.Nodes02 a)+adjacentNodes02 =+   tail+   .+   apply+      (Causal.mapAccum+         (\new old -> return (Interpolation.Nodes02 old new, new))+         (return Tuple.undef))++adjacentNodes13 ::+   (Marshal.C a, MultiValue.T a ~ al) =>+   Exp a -> Sig.T al -> Sig.T (Interpolation.Nodes13 al)+adjacentNodes13 yp0 =+   tail .+   tail .+   apply+      (Causal.mapAccum+         (\new (x0, x1, x2) ->+            return (Interpolation.Nodes13 x0 x1 x2 new, (x1, x2, new)))+         (do+            y0 <- Expr.unExp yp0+            return (MultiValue.undef, MultiValue.undef, y0)))+++{- |+Stretch signal in time by a certain factor.++This can be used for doing expensive computations+of filter parameters at a lower rate.+Alternatively, we could provide an adaptive @map@+that recomputes output values only if the input value changes,+or if the input value differs from the last processed one by a certain amount.+-}+interpolateConstant ::+   (Memory.C a, Marshal.C b, MultiValue.IntegerConstant b,+    MultiValue.Additive b, MultiValue.Comparison b) =>+   Exp b -> Sig.T a -> Sig.T a+interpolateConstant k sig =+   CausalC.toSignal (Causal.quantizeLift (CausalC.fromSignal sig) $< constant k)
+ src/Synthesizer/LLVM/Generator/SignalPacked.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Signal generators that generate the signal in chunks+that can be processed natively by the processor.+Some of the functions for plain signals can be re-used without modification.+E.g. rendering a signal and reading from and to signals work+because the vector type as element type warrents correct alignment.+We can convert between atomic and chunked signals.++The article+<http://perilsofparallel.blogspot.com/2008/09/larrabee-vs-nvidia-mimd-vs-simd.html>+explains the difference between Vector and SIMD computing.+According to that the SSE extensions in Intel processors+must be called Vector computing.+But since we use the term Vector already in the mathematical sense,+I like to use the term "packed" that is used in Intel mnemonics like mulps.+-}+module Synthesizer.LLVM.Generator.SignalPacked (+   pack, packRotate,+   packSmall,+   unpack, unpackRotate,+   constant,+   exponential2,+   exponentialBounded2,+   osciCore,+   osci,+   parabolaFadeInInf, parabolaFadeOutInf,+   rampInf, rampSlope,+   noise,+   noiseCore, noiseCoreAlt,+   ) where++import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Private as Priv+import qualified Synthesizer.LLVM.Generator.Core as Core+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as SerialClass+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Random as Rnd++import Synthesizer.Causal.Class (($*))++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Control as U+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:*:))++import qualified LLVM.Core as LLVM++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import Control.Monad.HT ((<=<))+import Control.Monad (replicateM)+import Control.Applicative ((<$>))++import qualified Algebra.Ring as Ring++import Data.Tuple.HT (mapSnd)+import Data.Word (Word32, Word)+import Data.Int (Int32)++import NumericPrelude.Numeric+import NumericPrelude.Base++++{- |+Convert a signal of scalar values into one using processor vectors.+If the signal length is not divisible by the chunk size,+then the last chunk is dropped.+-}+pack, packRotate ::+   (SerialClass.Write v, a ~ SerialClass.Element v) =>+   Sig.T a -> Sig.T v+pack = packRotate++packRotate (Priv.Cons next start stop) = Priv.Cons+   (\global local s -> do+      wInit <- Maybe.lift $ SerialClass.writeStart+      (w2,_,s2) <-+         Maybe.fromBool $+         U.whileLoop+            (LLVM.valueOf True,+             (wInit,+              LLVM.valueOf $ (SerialClass.sizeOfIterator wInit :: Word),+              s))+            (\(cont,(_w0,i0,_s0)) ->+               A.and cont =<<+                  A.cmp LLVM.CmpGT i0 A.zero)+            (\(_,(w0,i0,s0)) -> Maybe.toBool $ do+               (a,s1) <- next global local s0+               Maybe.lift $ do+                  w1 <- SerialClass.writeNext a w0+                  i1 <- A.dec i0+                  return (w1,i1,s1))+      v <- Maybe.lift $ SerialClass.writeStop w2+      return (v, s2))+   start+   stop++{-+We could reformulate it in terms of WriteIterator+that accesses elements using LLVM.extract.+We might move the loop counter into the Iterator,+but we have to assert that the counter is not duplicated.++packIndex ::+   (SerialClass.Write v, a ~ SerialClass.Element v) =>+   Sig.T a -> Sig.T v+packIndex = alter (\(Core next start stop) -> Core+   (\param s -> do+      (v2,_,s2) <-+         Maybe.fromBool $+         U.whileLoop+            (LLVM.valueOf True, (Tuple.undef, A.zero, s))+            (\(cont,(v0,i0,_s0)) ->+               A.and cont =<<+                  A.cmp LLVM.CmpLT i0 (LLVM.valueOf $ SerialClass.size v0))+            (\(_,(v0,i0,s0)) -> Maybe.toBool $ do+               (a,s1) <- next param s0+               Maybe.lift $ do+                  v1 <- Vector.insert i0 a v0+                  i1 <- A.inc i0+                  return (v1,i1,s1))+      return (v2, s2))+   start+   stop)+-}+++{- |+Like 'pack' but duplicates the code for creating elements.+That is, for vectors of size n, the code of the input signal+will be emitted n times.+This is efficient only for simple input generators.+-}+packSmall ::+   (SerialClass.Write v, a ~ SerialClass.Element v) =>+   Sig.T a -> Sig.T v+packSmall (Priv.Cons next start stop) = Priv.Cons+   (\global local ->+      MS.runStateT $+      SerialClass.withSize $ \n ->+         MT.lift . Maybe.lift . SerialClass.assemble+         =<<+         replicateM n (MS.StateT $ next global local))+   start+   stop+++unpack, unpackRotate ::+   (SerialClass.Read v, a ~ SerialClass.Element v,+    SerialClass.ReadIt v ~ itv, Memory.C itv) =>+   Sig.T v -> Sig.T a+unpack = unpackRotate++unpackRotate (Priv.Cons next start stop) = Priv.Cons+   (\global local (i0,r0,s0) -> do+      endOfVector <-+         Maybe.lift $ A.cmp LLVM.CmpEQ i0 (LLVM.valueOf (0::Word))+      (i2,r2,s2) <-+         Maybe.fromBool $+         U.ifThen endOfVector (LLVM.valueOf True, (i0,r0,s0)) $ do+            (cont1, (v1,s1)) <- Maybe.toBool $ next global local s0+            r1 <- SerialClass.readStart v1+            return (cont1, (LLVM.valueOf $ SerialClass.size v1, r1, s1))+      Maybe.lift $ do+         (a,r3) <- SerialClass.readNext r2+         i3 <- A.dec i2+         return (a, (i3,r3,s2)))+   (mapSnd (\s -> (A.zero, Tuple.undef, s)) <$> start)+   stop+++{-+We could reformulate it in terms of ReadIterator+that accesses elements using LLVM.extract.+We might move the loop counter into the Iterator,+but we have to assert that the counter is not duplicated.++unpackIndex ::+   (SerialClass.Write v, a ~ SerialClass.Element v, Memory.C v) =>+   Sig.T v -> Sig.T a+unpackIndex = alter (\(Core next start stop) -> Core+   (\param (i0,v0,s0) -> do+      endOfVector <-+         Maybe.lift $ A.cmp LLVM.CmpGE i0 (LLVM.valueOf $ SerialClass.size v0)+      (i2,v2,s2) <-+         Maybe.fromBool $+         U.ifThen endOfVector (LLVM.valueOf True, (i0,v0,s0)) $ do+            (cont1, (v1,s1)) <- Maybe.toBool $ next param s0+            return (cont1, (A.zero, v1, s1))+      Maybe.lift $ do+         a <- Vector.extract i2 v2+         i3 <- A.inc i2+         return (a, (i3,v2,s2)))+   (\p -> do+      s <- start p+      let v = Tuple.undef+      return (LLVM.valueOf $ SerialClass.size v, v, s))+   stop)+-}++++type Serial n a = SerialCode.Value n a++withSize ::+   (TypeNum.Positive n) =>+   (TypeNum.Singleton n -> Sig.T (Serial n a)) ->+   Sig.T (Serial n a)+withSize f = f TypeNum.singleton++withSizeRing ::+   (Ring.C b, TypeNum.Positive n) =>+   (b -> Sig.T (Serial n a)) ->+   Sig.T (Serial n a)+withSizeRing f =+   withSize $ f . fromInteger . TypeNum.integerFromSingleton+++constant ::+   (Marshal.Vector n a) =>+   Exp a -> Sig.T (Serial n a)+constant = Sig.constant . Serial.upsample+++exponential2 ::+   (Marshal.Vector n a, MultiVector.Transcendental a,+    MultiValue.RationalConstant a) =>+   Exp a -> Exp a -> Sig.T (Serial n a)+exponential2 halfLife start = withSizeRing $ \n ->+   Core.exponential+      (Serial.upsample (0.5 ** (n / halfLife)))+      (Serial.iterate (0.5 ** recip halfLife *) start)++exponentialBounded2 ::+   (Marshal.Vector n a, MultiVector.Transcendental a,+    MultiValue.RationalConstant a,+    MultiVector.IntegerConstant a, MultiVector.Real a) =>+   Exp a -> Exp a -> Exp a -> Sig.T (Serial n a)+exponentialBounded2 bound halfLife start = withSizeRing $ \n ->+   Core.exponentialBounded+      (Serial.upsample bound)+      (Serial.upsample (0.5 ** (n / halfLife)))+      (Serial.iterate (0.5 ** recip halfLife *) start)++osciCore ::+   (Marshal.Vector n t, MultiVector.PseudoRing t, MultiVector.Fraction t,+    MultiValue.IntegerConstant t) =>+   Exp t -> Exp t -> Sig.T (Serial n t)+osciCore phase freq = withSizeRing $ \n ->+   Core.osci+      (Serial.iterate (Expr.fraction . (freq +)) phase)+      (Serial.upsample (Expr.fraction (n * freq)))++osci ::+   (Marshal.Vector n t, MultiVector.PseudoRing t, MultiVector.Fraction t,+    MultiValue.IntegerConstant t) =>+   (forall r. Serial n t -> LLVM.CodeGenFunction r y) ->+   Exp t -> Exp t -> Sig.T y+osci wave phase freq = Priv.map wave $ osciCore phase freq+++rampInf, rampSlope, parabolaFadeInInf, parabolaFadeOutInf ::+   (Marshal.Vector n a, MultiVector.Field a, MultiVector.IntegerConstant a,+    MultiValue.RationalConstant a) =>+   Exp a -> Sig.T (Serial n a)+rampSlope slope = withSizeRing $ \n ->+   Core.ramp+      (Serial.upsample (n * slope))+      (Serial.iterate (slope +) 0)+rampInf dur = rampSlope (Expr.recip dur)++parabolaFadeInInf dur = withSizeRing $ \n ->+   let d = n/dur+   in Core.parabola+         (Serial.upsample (-2*d*d))+         (Serial.iterate (subtract $ 2 / dur ^ 2) (d*(2-d)))+         ((\t -> t*(2-t)) $ Serial.iterate (recip dur +) 0)++parabolaFadeOutInf dur = withSizeRing $ \n ->+   let d = n/dur+   in Core.parabola+         (Serial.upsample (-2*d*d))+         (Serial.iterate (subtract $ 2 / dur ^ 2) (-d*d))+         ((\t -> 1-t*t) $ Serial.iterate (recip dur +) 0)+++{- |+For the mysterious rate parameter see 'Sig.noise'.+-}+noise ::+   (MultiVector.NativeFloating n a ar) =>+   (MultiVector.PseudoRing a, MultiVector.IntegerConstant a) =>+   (MultiValue.Algebraic a, MultiValue.RationalConstant a) =>+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>+   Exp Word32 -> Exp a -> Sig.T (Serial n a)+noise seed rate =+   let m2 = div Rnd.modulus 2+       r = Serial.upsample $ Expr.sqrt (3*rate) / Expr.fromInteger' m2+   in Causal.map+         (\y -> r * (Expr.liftM int31tofp y - Expr.fromInteger' (m2+1))) $*+      noiseCoreAlt seed++{-+sitofp is a single instruction on x86+and thus we use it, since the arguments are below 2^31.++It would be better to use LLVM's range annotation, instead.+-}+int31tofp ::+   (MultiVector.NativeFloating n a ar,+    TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>+   Serial n Word32 -> LLVM.CodeGenFunction r (Serial n a)+int31tofp =+   fmap SerialCode.fromOrdinary . MultiValueVec.fromIntegral .+   SerialCode.toOrdinary . forceInt32+      <=< MultiValue.liftM LLVM.bitcast++type Id a = a -> a++forceInt32 :: Id (Serial n Int32)+forceInt32 = id++noiseCore, noiseCoreAlt ::+   (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>+   Exp Word32 -> Sig.T (Serial n Word32)+noiseCore    = Sig.iterate (Expr.liftReprM Rnd.nextVector)   . vectorSeed+noiseCoreAlt = Sig.iterate (Expr.liftReprM Rnd.nextVector64) . vectorSeed++vectorSeed :: (TypeNum.Positive n) => Exp Word32 -> Exp (Serial.T n Word32)+vectorSeed seed =+   Serial.iterate (Expr.liftReprM Rnd.nextCG) $+   Expr.irem seed (fromInteger Rnd.modulus - 1) + 1
+ src/Synthesizer/LLVM/Generator/Source.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.LLVM.Generator.Source where++import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt+import qualified Synthesizer.LLVM.Generator.Private as Sig+import qualified Synthesizer.LLVM.ConstantPiece as Const+import qualified Synthesizer.LLVM.EventIterator as EventIt+import Synthesizer.LLVM.Private (noLocalPtr)++import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C++import qualified LLVM.Core as LLVM++import Foreign.Storable (Storable)+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (Ptr, nullPtr)++import Control.Applicative (liftA2, (<$>))++import Data.Tuple.HT (mapSnd)+import Data.Word (Word)+++type T a = Sig.T (MultiValue.T a)+++data StorableVector a = StorableVector (Ptr a) Word++storableVectorLength :: Exp (StorableVector a) -> Exp Word+storableVectorLength = Expr.lift1 (MultiValue.lift1 (\(_ptr,l) -> l))++consStorableVector :: Ptr a -> Int -> StorableVector a+consStorableVector p = StorableVector p . fromIntegral++instance (Storable a) => MultiValue.C (StorableVector a) where+   type Repr (StorableVector a) = (LLVM.Value (Ptr a), LLVM.Value Word)+   cons (StorableVector p l) = MultiValue.Cons (LLVM.valueOf p, LLVM.valueOf l)+   undef = MultiValue.undefTuple+   zero = MultiValue.zeroTuple+   phi = MultiValue.phiTuple+   addPhi = MultiValue.addPhiTuple++instance (Storable a) => Marshal.C (StorableVector a) where+   pack (StorableVector p l) = LLVM.consStruct p l+   unpack = LLVM.uncurryStruct StorableVector++storableVector :: (Storable.C a) => Exp (StorableVector a) -> T a+storableVector vec =+   Sig.noGlobal+      (noLocalPtr $ \(p0,l0) -> do+         cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero+         MaybeCont.withBool cont $ do+            y1 <- Storable.load p0+            p1 <- Storable.incrementPtr p0+            l1 <- A.dec l0+            return (y1,(p1,l1)))+      (fmap (\(MultiValue.Cons (p,l)) -> (p,l)) (Expr.unExp vec))+++{-+This function calls back into the Haskell function 'ChunkIt.next'+that returns a pointer to the data of the next chunk+and advances to the next chunk in the sequence.+-}+storableVectorLazy ::+   (Storable.C a) => Exp (StablePtr (ChunkIt.T a)) -> T a+storableVectorLazy = flattenChunks . storableVectorChunks++type Chunk a = (LLVM.Value (Ptr a), LLVM.Value Word)++storableVectorChunks ::+   (Storable.C a) => Exp (StablePtr (ChunkIt.T a)) -> Sig.T (Chunk a)+storableVectorChunks sig =+   Sig.Cons+      (\stable lenPtr () -> MaybeCont.fromBool $ do+         nextChunkFn <-+            LLVM.staticNamedFunction+               "SignalExp.fromStorableVectorLazy.nextChunk"+               ChunkIt.nextCallBack+         (buffer,len) <-+            liftA2 (,)+               (LLVM.call nextChunkFn stable lenPtr)+               (LLVM.load lenPtr)+         valid <- A.cmp LLVM.CmpNE buffer (LLVM.valueOf nullPtr)+         return (valid, ((buffer,len), ())))+      (fmap (\(MultiValue.Cons it) -> (it, ())) $ Expr.unExp sig)+      (\ _it -> return ())++flattenChunks :: (Storable.C a) => Sig.T (Chunk a) -> T a+flattenChunks (Sig.Cons next start stop) =+   Sig.Cons+      (\global local ((buffer0,length0), state0) -> do+         ((buffer1,length1), state1) <- MaybeCont.fromBool $ do+            needNext <- A.cmp LLVM.CmpEQ length0 A.zero+            C.ifThen needNext+               (LLVM.valueOf True, ((buffer0,length0), state0))+               (MaybeCont.toBool $ next global local state0)+         MaybeCont.lift $ do+            x <- Storable.load buffer1+            buffer2 <- Storable.incrementPtr buffer1+            length2 <- A.dec length1+            return (x, ((buffer2,length2), state1)))+      (mapSnd ((,) (LLVM.valueOf nullPtr, A.zero)) <$> start)+      stop+++eventList ::+   (Marshal.C a) =>+   Exp (StablePtr (EventIt.T a)) -> Sig.T (Const.T (MultiValue.T a))+eventList sig =+   Sig.Cons+      -- FixMe: duplicate of ConstantPiece.piecewiseConstant+      (\stable yPtr () -> do+         len <- MaybeCont.lift $ do+            nextFn <-+               LLVM.staticNamedFunction+                  "ConstantPiece.piecewiseConstant.nextChunk"+                  EventIt.nextCallBack+            LLVM.call nextFn stable yPtr+         MaybeCont.guard =<< MaybeCont.lift (A.cmp LLVM.CmpNE len A.zero)+         y <- MaybeCont.lift $ Memory.load yPtr+         return (Const.Cons len y, ()))+      (fmap (\(MultiValue.Cons it) -> (it, ())) $ Expr.unExp sig)+      (\ _it -> return ())++lazySize :: Exp (StablePtr SizeIt.T) -> Sig.T (Const.T ())+lazySize size = Sig.Cons+   (\stable -> noLocalPtr $ \() -> do+      len <- MaybeCont.lift $ do+         nextFn <-+            LLVM.staticNamedFunction+               "ConstantPiece.lazySize.next"+               SizeIt.nextCallBack+         LLVM.call nextFn stable+      MaybeCont.guard =<< MaybeCont.lift (A.cmp LLVM.CmpNE len A.zero)+      return (Const.Cons len (), ()))+   (fmap (\(MultiValue.Cons it) -> (it, ())) $ Expr.unExp size)+   (\ _it -> return ())
src/Synthesizer/LLVM/Interpolation.hs view
@@ -1,12 +1,19 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Synthesizer.LLVM.Interpolation (    C(margin),    loadNodes,    indexNodes,+   loadNodesExp,+   indexNodesExp,     Margin(..),+   zipMargin,+   unzipMargin,    toMargin,+   marginNumberExp,+   marginOffsetExp,     T, @@ -19,11 +26,14 @@    cubicVector,    ) where -import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Value as Value -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Class as Serial import qualified Synthesizer.Interpolation.Core as Interpolation +import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Scalar as Scalar import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple@@ -33,6 +43,7 @@  import LLVM.Core (CodeGenFunction, Value) +import Foreign.Storable (Storable) import Foreign.Ptr (Ptr) import Data.Word (Word) @@ -44,13 +55,47 @@ import Data.Foldable (Foldable, foldMap)  -class (Applicative nodes, Traversable nodes) => C nodes where-   margin :: Margin (nodes a)- data Margin nodes = Margin { marginNumber, marginOffset :: Int }    deriving (Show, Eq) +singletonMargin :: MultiValue.T Int -> MultiValue.T (Margin nodes)+singletonMargin n = zipMargin n n +unzipMargin ::+   MultiValue.T (Margin nodes) -> (MultiValue.T Int, MultiValue.T Int)+unzipMargin (MultiValue.Cons (from, to)) =+   (MultiValue.Cons from, MultiValue.Cons to)++zipMargin :: MultiValue.T Int -> MultiValue.T Int -> MultiValue.T (Margin nodes)+zipMargin (MultiValue.Cons from) (MultiValue.Cons to) =+   MultiValue.Cons (from, to)++marginNumberExp :: (Expr.Value val) => val (Margin nodes) -> val Int+marginNumberExp = Expr.lift1 (fst . unzipMargin)++marginOffsetExp :: (Expr.Value val) => val (Margin nodes) -> val Int+marginOffsetExp = Expr.lift1 (snd . unzipMargin)++instance MultiValue.C (Margin nodes) where+   type Repr (Margin nodes) = (LLVM.Value Int, LLVM.Value Int)+   cons (Margin start len) =+      zipMargin (MultiValue.cons start) (MultiValue.cons len)+   undef = singletonMargin MultiValue.undef+   zero = singletonMargin MultiValue.zero+   phi bb a =+      case unzipMargin a of+         (a0,a1) ->+            liftA2 zipMargin (MultiValue.phi bb a0) (MultiValue.phi bb a1)+   addPhi bb a b =+      case (unzipMargin a, unzipMargin b) of+         ((a0,a1), (b0,b1)) -> do+            MultiValue.addPhi bb a0 b0+            MultiValue.addPhi bb a1 b1+++class (Applicative nodes, Traversable nodes) => C nodes where+   margin :: Margin (nodes a)+ type T r nodes a v = a -> nodes v -> CodeGenFunction r v  @@ -96,7 +141,7 @@    readStart = Serial.readStartTraversable    readNext = Serial.readNextTraversable -instance (Serial.C v) => Serial.C (Nodes02 v) where+instance (Serial.Write v) => Serial.Write (Nodes02 v) where    type WriteIt (Nodes02 v) = Nodes02 (Serial.WriteIt v)     insert = Serial.insertTraversable@@ -183,7 +228,7 @@    readStart = Serial.readStartTraversable    readNext = Serial.readNextTraversable -instance (Serial.C v) => Serial.C (Nodes13 v) where+instance (Serial.Write v) => Serial.Write (Nodes13 v) where    type WriteIt (Nodes13 v) = Nodes13 (Serial.WriteIt v)     insert = Serial.insertTraversable@@ -234,8 +279,16 @@    Value.unlift5 Interpolation.cubic a b c d r  +loadNodesExp ::+   (C nodes, Storable am) =>+   (Value (Ptr am) -> CodeGenFunction r a) ->+   MultiValue.T Int ->+   Value (Ptr am) -> CodeGenFunction r (nodes a)+loadNodesExp loadNode (MultiValue.Cons step) =+   MS.evalStateT $ sequenceA $ pure $ loadNext loadNode step+ loadNodes ::-   (C nodes, Storable.C am) =>+   (C nodes, Storable am) =>    (Value (Ptr am) -> CodeGenFunction r a) ->    Value Int ->    Value (Ptr am) -> CodeGenFunction r (nodes a)@@ -243,7 +296,7 @@    MS.evalStateT $ sequenceA $ pure $ loadNext loadNode step  loadNext ::-   (Storable.C am) =>+   (Storable am) =>    (Value (Ptr am) -> CodeGenFunction r a) ->    Value Int ->    MS.StateT (Value (Ptr am)) (CodeGenFunction r) a@@ -251,6 +304,14 @@    MS.StateT $ \ptr -> liftA2 (,) (loadNode ptr) (Storable.advancePtr step ptr)  ++indexNodesExp ::+   (C nodes) =>+   (MultiValue.T Word -> CodeGenFunction r v) ->+   MultiValue.T Word ->+   MultiValue.T Word -> CodeGenFunction r (nodes v)+indexNodesExp indexNode (MultiValue.Cons step) (MultiValue.Cons offset) =+   indexNodes (indexNode . MultiValue.Cons) step offset  indexNodes ::    (C nodes) =>
src/Synthesizer/LLVM/MIDI.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Rank2Types #-} {- | Convert MIDI events of a MIDI controller to a control signal. -}@@ -14,169 +13,62 @@  import qualified Synthesizer.MIDI.Generic as Gen import qualified Synthesizer.LLVM.MIDI.BendModulation as BM-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector as SerialExp+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial -import Synthesizer.LLVM.CausalParameterized.Process (($>))-import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.Functional as Func+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Wave as Wave+import Synthesizer.LLVM.Causal.Process (($>)) -import qualified LLVM.DSL.Parameter as Param+import LLVM.DSL.Expression (Exp) -import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Core as LLVM-import LLVM.Core (SizeOf) -import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal.Number ((:*:))--import qualified Algebra.RealField      as RealField-import qualified Algebra.Additive       as Additive- import Control.Arrow (second, (<<<), (<<^))-import Control.Monad ({- liftM, -} liftM2)  import NumericPrelude.Numeric import Prelude (($))  -{--{-# INLINE piecewiseConstantInit #-}-piecewiseConstantInit ::-   (Storable y, Tuple.Value y, Tuple.ValueOf y ~ yl,-    Memory.C yl ym, LLVM.IsSized ym ys) =>-   y -> EventListTT.T LazyTime y -> SigP.T p yl-piecewiseConstantInit initial evs =-   SigP.piecewiseConstant $#-   (PC.subdivideInt $-    EventListMT.consBody initial evs)---{-# INLINE controllerLinear #-}-controllerLinear ::-   (Field.C y, Storable y, Tuple.Value y, Tuple.ValueOf y ~ yl,-    Memory.C yl ym, LLVM.IsSized ym ys) =>-   Channel -> Controller ->-   (y,y) -> y ->-   Filter (SigP.T p yl)-controllerLinear chan ctrl bnd initial =-   liftM (piecewiseConstantInit initial .-          EventListTT.mapBody (MV.controllerLinear bnd)) $-   getControllerEvents chan ctrl---{-# INLINE controllerExponential #-}-controllerExponential ::-   (Trans.C y, Storable y, Tuple.Value y, Tuple.ValueOf y ~ yl,-    Memory.C yl ym, LLVM.IsSized ym ys) =>-   Channel -> Controller ->-   (y,y) -> y ->-   Filter (SigP.T p yl)-controllerExponential chan ctrl bnd initial =-   liftM (piecewiseConstantInit initial .-          EventListTT.mapBody (MV.controllerExponential bnd)) $-   getControllerEvents chan ctrl---{- |-@pitchBend channel range center@:-emits frequencies on an exponential scale from-@center/range@ to @center*range@.--}-{-# INLINE pitchBend #-}-pitchBend ::-   (Trans.C y, Storable y, Tuple.Value y, Tuple.ValueOf y ~ yl,-    Memory.C yl ym, LLVM.IsSized ym ys) =>-   Channel ->-   y -> y ->-   Filter (SigP.T p yl)-pitchBend chan range center =-   liftM (piecewiseConstantInit center .-          EventListTT.mapBody (MV.pitchBend range center)) $-   getSlice (maybePitchBend chan)---   getPitchBendEvents chan--{-# INLINE channelPressure #-}-channelPressure ::-   (Trans.C y, Storable y, Tuple.Value y, Tuple.ValueOf y ~ yl,-    Memory.C yl ym, LLVM.IsSized ym ys) =>-   Channel ->-   y -> y ->-   Filter (SigP.T p yl)-channelPressure chan maxVal initVal =-   liftM (piecewiseConstantInit initVal .-          EventListTT.mapBody (MV.controllerLinear (0,maxVal))) $-   getSlice (maybeChannelPressure chan)---{-# INLINE bendWheelPressure #-}-bendWheelPressure ::-   (Ring.C a, LLVM.IsConst a,-    RealField.C y, Trans.C y,-    LLVM.IsConst y, SoV.Fraction y, a ~ SoV.Scalar y, SoV.Replicate y,-    Storable y, Tuple.Value y (LLVM.Value y), LLVM.IsSized y ys) =>-   Channel ->-   Int -> y -> y -> y ->-   Filter (SigP.T p (LLVM.Value y))-bendWheelPressure chan-     pitchRange speed wheelDepth pressDepth =-   do bend  <- pitchBend chan-                  (2^?(fromIntegral pitchRange/12) `asTypeOf` speed) 1-      fm    <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0-      press <- channelPressure chan pressDepth 0-      return $-         SigP.envelope bend $-         SigP.mapSimple (A.add A.one) $-         SigP.envelope-            (SigP.mix fm press)-            (SigP.osciSimple Wave.approxSine2 zero $# speed)--}-- frequencyFromBendModulation ::-   (Marshal.C y, Additive.C y, Tuple.ValueOf y ~ yl,-    A.PseudoRing yl, A.Fraction yl, A.IntegerConstant yl) =>-   Param.T p y ->-   CausalP.T p (BM.T yl) yl+   (Marshal.C y, MultiValue.T y ~ ym,+    MultiValue.PseudoRing y, MultiValue.IntegerConstant y,+    MultiValue.Fraction y) =>+   Exp y -> Causal.T (BM.T ym) ym frequencyFromBendModulation speed =-   frequencyFromPair SigP.osciSimple speed+   frequencyFromPair Sig.osci speed    <<^    (\(BM.Cons b m) -> (b,m))   frequencyFromBendModulationPacked ::-   (Marshal.C a, Tuple.ValueOf a ~ LLVM.Value a,-    Marshal.Vector n a, Tuple.VectorValueOf n a ~ LLVM.Value (LLVM.Vector n a),-    LLVM.IsPrimitive a, LLVM.IsConst a, LLVM.IsFloating a,-    RealField.C a, Vector.Real a, SoV.IntegerConstant a,-    TypeNum.Positive n,-    TypeNum.Positive (n :*: SizeOf a)) =>-   Param.T p a ->-   CausalP.T p (BM.T (LLVM.Value a)) (Serial.Value n a)+   (Marshal.Vector n a) =>+   (MultiVector.PseudoRing a, MultiVector.IntegerConstant a) =>+   (MultiVector.Fraction a) =>+   Exp a -> Causal.T (BM.T (MultiValue.T a)) (Serial.Value n a) frequencyFromBendModulationPacked speed =-   frequencyFromPair SigPS.osciSimple speed+   frequencyFromPair SigPS.osci speed    <<<-   CausalP.mapSimple-      (\(BM.Cons b m) ->-         liftM2 (,) (Serial.upsample b) (Serial.upsample m))+   Causal.map (\(BM.Cons b m) -> (SerialExp.upsample b, SerialExp.upsample m))  frequencyFromPair, _frequencyFromPair ::-   (Additive.C y, A.PseudoRing yl, A.IntegerConstant yl, A.Fraction yl) =>-   ((forall r. yl -> LLVM.CodeGenFunction r yl) ->-    Param.T p y -> Param.T p y -> SigP.T p yl) ->-   Param.T p y ->-   CausalP.T p (yl,yl) yl+   (MultiValue.Additive y,+    A.PseudoRing ym, A.IntegerConstant ym, A.Fraction ym) =>+   ((forall r. ym -> LLVM.CodeGenFunction r ym) ->+    Exp y -> Exp y -> Sig.T ym) ->+   Exp y -> Causal.T (ym,ym) ym frequencyFromPair osci speed =    Func.withGuidedArgs (Func.atom, Func.atom) $ \(b, m) ->       b * (1 + m * Func.fromSignal (osci Wave.approxSine2 zero speed))  _frequencyFromPair osci speed =-   CausalP.envelope+   Causal.envelope    <<<-   second (1 + (CausalP.envelope $> osci Wave.approxSine2 zero speed))+   second (1 + (Causal.envelope $> osci Wave.approxSine2 zero speed))
src/Synthesizer/LLVM/MIDI/BendModulation.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Various LLVM related instances of the BM.T type.@@ -9,11 +10,18 @@    BM.T(..),    BM.deflt,    BM.shift,+   multiValue,+   unMultiValue,    ) where  import qualified Synthesizer.MIDI.Value.BendModulation as BM-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F+import qualified Synthesizer.LLVM.Causal.Functional as F +import qualified LLVM.DSL.Expression as Expr++import qualified LLVM.Extra.Multi.Value.Storable as StorableMV+import qualified LLVM.Extra.Multi.Value.Marshal as MarshalMV+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Storable as Storable@@ -22,20 +30,16 @@ import qualified LLVM.Extra.Control as C import qualified LLVM.Core as LLVM -import Control.Applicative (liftA2) import qualified Type.Data.Num.Decimal as TypeNum +import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold -instance (Tuple.Zero a) => Tuple.Zero (BM.T a) where-   zero = Tuple.zeroPointed+import Control.Applicative (liftA2) -{--instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BM.T a) where-   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) -instance LLVM.IsTuple a => LLVM.IsTuple (BM.T a) where-   tupleDesc = Class.tupleDescFoldable--}+instance (Tuple.Zero a) => Tuple.Zero (BM.T a) where+   zero = Tuple.zeroPointed  instance (Tuple.Undefined a) => Tuple.Undefined (BM.T a) where    undef = Tuple.undefPointed@@ -43,14 +47,40 @@ instance (C.Select a) => C.Select (BM.T a) where    select = C.selectTraversable -{--instance LLVM.CmpRet a, LLVM.CmpResult a ~ b =>-      LLVM.CmpRet (BM.T a) (BM.T b) where--}- instance Tuple.Value h => Tuple.Value (BM.T h) where    type ValueOf (BM.T h) = BM.T (Tuple.ValueOf h)    valueOf = Tuple.valueOfFunctor+++instance (Expr.Aggregate e mv) => Expr.Aggregate (BM.T e) (BM.T mv) where+   type MultiValuesOf (BM.T e) = BM.T (Expr.MultiValuesOf e)+   type ExpressionsOf (BM.T mv) = BM.T (Expr.ExpressionsOf mv)+   bundle = Trav.traverse Expr.bundle+   dissect = fmap Expr.dissect++instance (MultiValue.C a) => MultiValue.C (BM.T a) where+   type Repr (BM.T a) = BM.T (MultiValue.Repr a)+   cons = multiValue . fmap MultiValue.cons+   undef = multiValue $ pure MultiValue.undef+   zero = multiValue $ pure MultiValue.zero+   phi bb = fmap multiValue . Trav.traverse (MultiValue.phi bb) . unMultiValue+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb) (unMultiValue a) (unMultiValue b)++instance (MarshalMV.C l) => MarshalMV.C (BM.T l) where+   pack (BM.Cons bend depth) = MarshalMV.pack (bend, depth)+   unpack = uncurry BM.Cons . MarshalMV.unpack++instance (StorableMV.C l) => StorableMV.C (BM.T l) where+   load = StorableMV.loadApplicative+   store = StorableMV.storeFoldable++multiValue :: BM.T (MultiValue.T a) -> MultiValue.T (BM.T a)+multiValue = MultiValue.Cons . fmap (\(MultiValue.Cons a) -> a)++unMultiValue :: MultiValue.T (BM.T a) -> BM.T (MultiValue.T a)+unMultiValue (MultiValue.Cons x) = fmap MultiValue.Cons x   type Struct a = LLVM.Struct (a, (a, ()))
− src/Synthesizer/LLVM/Parameter.hs 
@@ -1,12 +0,0 @@-module Synthesizer.LLVM.Parameter (-   Param.T,-   Param.get,-   (Param.$#),--   Param.Tuple(..),-   Param.withTuple,-   Param.withTuple1,-   Param.withTuple2,-   ) where--import qualified LLVM.DSL.Parameter as Param
− src/Synthesizer/LLVM/Parameterized/Signal.hs 
@@ -1,1000 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Parameterized.Signal (-   T,-   adjacentNodes02,-   adjacentNodes13,-   amplify,-   amplifyStereo,-   Sig.empty,-   append,-   cycle,-   drop,-   exponential2,-   exponentialCore,-   exponentialBounded2,-   exponentialBoundedCore,-   interpolateConstant,-   iterate,-   lazySize,-   map,-   mapSimple,-   mapAccum,-   Sig.mix,-   Sig.mixExt,-   noise,-   noiseCore,-   osci,-   osciCore,-   osciSaw,-   osciSimple,-   parabolaCore,-   parabolaFadeIn,-   parabolaFadeInInf,-   parabolaFadeInMap,-   parabolaFadeOut,-   parabolaFadeOutInf,-   parabolaFadeOutMap,-   piecewiseConstant,-   ramp,-   rampCore,-   rampInf,-   rampSlope,-   reparameterize,-   tail,-   constant,-   Sig.envelope,-   Sig.envelopeStereo,-   simple,-   zip,-   zipWith,-   zipWithSimple,--   fromStorableVector,-   fromStorableVectorLazy,--   render,-   renderChunky,-   run,-   runChunky,-   runChunkyPattern,-   runChunkyPlugged,--   -- for testing-   noiseCoreAlt,-   ) where--import Synthesizer.LLVM.Parameterized.SignalPrivate-import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv-import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.Causal.Process as Causal-import qualified Synthesizer.LLVM.Plug.Output as POut-import qualified Synthesizer.LLVM.Interpolation as Interpolation-import qualified Synthesizer.LLVM.ConstantPiece as Const-import Synthesizer.Causal.Class (($*), ($<))--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame as Frame-import qualified Synthesizer.LLVM.Random as Rnd-import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr--import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt-import qualified Synthesizer.LLVM.Storable.Vector as SVU-import qualified Data.StorableVector.Lazy.Pattern as SVP-import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import qualified Data.StorableVector.Base as SVB--import qualified Data.EventList.Relative.BodyTime as EventList-import qualified Numeric.NonNegative.Chunky as Chunky-import qualified Numeric.NonNegative.Wrapper as NonNeg--import qualified LLVM.DSL.Execution as Exec-import qualified LLVM.DSL.Parameter as Param--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.Maybe as Maybe-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Tuple as Tuple-import LLVM.Extra.Control (whileLoop)--import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Core as LLVM-import LLVM.Core-          (CodeGenFunction, ret, Value, value, valueOf,-           IsSized, IsConst, IsArithmetic, IsFloating,-           CodeGenModule, Function)--import qualified Type.Data.Num.Decimal as TypeNum--import Control.Monad.HT ((<=<))-import Control.Monad (when)-import Control.Arrow ((^<<))-import Control.Applicative (Applicative, liftA2, liftA3, pure, (<$>))-import Control.Functor.HT (void)--import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealField as RealField-import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.Field as Field-import qualified Algebra.Additive as Additive--import Data.Functor.Compose (Compose(Compose))-import Data.Tuple.HT (mapSnd)-import Data.Word (Word8, Word32, Word)-import Data.Int (Int32)--import Foreign.ForeignPtr (touchForeignPtr)-import Foreign.Ptr (Ptr, nullPtr)-import Control.Exception (bracket)-import qualified System.Unsafe as Unsafe--import qualified LLVM.DSL.Debug.Marshal as DebugSt-import qualified LLVM.DSL.Debug.Counter as Counter--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, tail, iterate, map, zip, zipWith, cycle, drop)---reparameterize :: Param.T q p -> T p a -> T q a-reparameterize p (Cons start alloca stop next create delete) =-   Cons start alloca stop next (create . Param.get p) delete----- * timeline edit--{- |-@tail empty@ generates the empty signal.--}-tail :: T p a -> T p a-tail (Cons next alloca start stop createIOContext deleteIOContext) = Cons-   next-   alloca-   (\parameter -> do-      local <- alloca-      (c,s0) <- start parameter-      MaybeCont.resolve (next c local s0)-         (return (c,s0))-         (\(_a,s1) -> return (c,s1)))-   stop-   createIOContext-   deleteIOContext--drop :: Param.T p Int -> T p a -> T p a-drop n (Cons next alloca start stop createIOContext deleteIOContext) =-   Param.withValue (Param.wordInt n) $ \getN valueN -> Cons-   next-   alloca-   (\(parameter, i0) -> do-      local <- alloca-      (c,s0) <- start parameter-      (_, _, s3) <--         whileLoop (valueOf True, valueN i0, s0)-            (\(cont,i1,_s1) ->-               A.and cont =<<-                  A.cmp LLVM.CmpGT i1 A.zero)-            (\(_cont,i1,s1) -> do-               (cont, s2) <--                  MaybeCont.resolve (next c local s1)-                     (return (valueOf False, s1))-                     (\(_a,s) -> return (valueOf True, s))-               i2 <- A.dec i1-               return (cont, i2, s2))-      return (c, s3))-   stop-   (\p -> do-      (ioContext, param) <- createIOContext p-      return (ioContext, (param, getN p)))-   deleteIOContext---cycle ::-   (Tuple.Phi a, Tuple.Undefined a) =>-   T p a -> T p a-cycle (Cons next alloca start stop createIOContext deleteIOContext) =-   Cons-      (\parameter local (c0,s0) ->-          MaybeCont.alternative-             (fmap (mapSnd ((,) c0)) $ next c0 local s0)-             (do (c1,s1) <- MaybeCont.lift $ start parameter-                 (b0,s2) <- next c1 local s1-                 return (b0,(c1,s2))))-      alloca-      (\parameter -> do-         contextState <- start parameter-         return (parameter, contextState))-      (\_parameter contextState -> uncurry stop contextState)-      createIOContext-      deleteIOContext----- * signal modifiers--{- |-Stretch signal in time by a certain factor.--This can be used for doing expensive computations-of filter parameters at a lower rate.-Alternatively, we could provide an adaptive @map@-that recomputes output values only if the input value changes,-or if the input value differs from the last processed one by a certain amount.--}-interpolateConstant ::-   (Memory.C a,-    IsFloating b, SoV.IntegerConstant b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool,-    Marshal.C b, Tuple.ValueOf b ~ Value b) =>-   Param.T p b -> T p a -> T p a-interpolateConstant k sig =-   CausalP.toSignal-      (Causal.quantizeLift (CausalP.fromSignal sig) $< constant k)---amplify ::-   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p al -> T p al-amplify =-   map Frame.amplifyMono--amplifyStereo ::-   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p a -> T p (Stereo.T al) -> T p (Stereo.T al)-amplifyStereo =-   map Frame.amplifyStereo---mapAccum ::-   (Marshal.C pnh, Tuple.ValueOf pnh ~ pnl,-    Marshal.C psh, Tuple.ValueOf psh ~ psl, Memory.C s) =>-   (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->-   (forall r. psl -> CodeGenFunction r s) ->-   Param.T p pnh ->-   Param.T p psh ->-   T p a -> T p b-mapAccum next start n s xs =-   CausalP.mapAccum next start n s $* xs--adjacentNodes02 ::-   (Memory.C a, Tuple.Undefined a) =>-   T p a -> T p (Interpolation.Nodes02 a)-adjacentNodes02 =-   tail-   .-   Sig.mapAccum-      (\new old -> return (Interpolation.Nodes02 old new, new))-      (return Tuple.undef)--adjacentNodes13 ::-   (Marshal.C ah, Tuple.ValueOf ah ~ a, Tuple.Undefined a) =>-   Param.T p ah -> T p a -> T p (Interpolation.Nodes13 a)-adjacentNodes13 yp0 =-   tail .-   tail .-   mapAccum-      (\() new (x0, x1, x2) ->-         return (Interpolation.Nodes13 x0 x1 x2 new, (x1, x2, new)))-      (\y0 -> return (Tuple.undef, Tuple.undef, Param.valueTuple yp0 y0))-      (pure ()) yp0------ * signal generators---exponentialCore ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.PseudoRing al) =>-   Param.T p a -> Param.T p a -> T p al-exponentialCore =-   iterate A.mul--exponential2 ::-   (Trans.C a, Marshal.C a, Tuple.ValueOf a ~ Value a,-    IsArithmetic a, IsConst a) =>-   Param.T p a -> Param.T p a -> T p (Value a)-exponential2 halfLife =-   exponentialCore (0.5 ** recip halfLife)---exponentialBoundedCore ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.PseudoRing al, A.Real al) =>-   Param.T p a -> Param.T p a -> Param.T p a ->-   T p al-exponentialBoundedCore bound decay =-   iterate-      (\(b,k) y -> A.max b =<< A.mul k y)-      (liftA2 (,) bound decay)--{- |-Exponential curve that remains at the bound value-if it would fall below otherwise.-This way you can avoid extremal values, e.g. denormalized ones.-The initial value and the bound value must be positive.--}-exponentialBounded2 ::-   (Trans.C a, Marshal.C a, Tuple.ValueOf a ~ Value a, SoV.Real a, IsConst a) =>-   Param.T p a -> Param.T p a -> Param.T p a ->-   T p (Value a)-exponentialBounded2 bound halfLife =-   exponentialBoundedCore bound (0.5 ** recip halfLife)---osciCore ::-   (Marshal.C t, Tuple.ValueOf t ~ tl, A.Fraction tl) =>-   Param.T p t -> Param.T p t -> T p tl-osciCore phase freq =-   iterate A.incPhase freq phase--osci ::-   (Marshal.C t, Tuple.ValueOf t ~ tl, A.Fraction tl, A.IntegerConstant tl,-    Marshal.C c, Tuple.ValueOf c ~ cl) =>-   (forall r. cl -> tl -> CodeGenFunction r y) ->-   Param.T p c ->-   Param.T p t -> Param.T p t -> T p y-osci wave waveParam phase freq =-   map wave waveParam $ osciCore phase freq--osciSimple ::-   (Marshal.C t, Tuple.ValueOf t ~ tl, A.Fraction tl, A.IntegerConstant tl) =>-   (forall r. tl -> CodeGenFunction r y) ->-   Param.T p t -> Param.T p t -> T p y-osciSimple wave phase freq =-   Sig.map wave $ osciCore phase freq--osciSaw ::-   (Marshal.C a, Tuple.ValueOf a ~ al,-    A.PseudoRing al, A.Fraction al, A.IntegerConstant al) =>-   Param.T p a -> Param.T p a -> T p al-osciSaw =-   osciSimple Wave.saw----rampCore ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.Additive al, A.IntegerConstant al) =>-   Param.T p a -> Param.T p a -> T p al-rampCore = iterate A.add--parabolaCore ::-   (Marshal.C a, Tuple.ValueOf a ~ al, A.Additive al, A.IntegerConstant al) =>-   Param.T p a -> Param.T p a -> Param.T p a -> T p al-parabolaCore d2 d1 start =-   CausalP.apply (CausalP.integrate start) $-   rampCore d2 d1----rampInf, rampSlope,- parabolaFadeInInf, parabolaFadeOutInf ::-   (Field.C a,-    Marshal.C a, Tuple.ValueOf a ~ al, A.Additive al, A.IntegerConstant al) =>-   Param.T p a -> T p al-rampSlope slope  =  rampCore slope Additive.zero-rampInf dur  =  rampSlope (recip dur)--{--t*(2-t) = 1 - (t-1)^2--(t+d)*(2-t-d) - t*(2-t)-   = d*(2-t) - d*t - d^2-   = 2*d*(1-t) - d^2-   = d*(2*(1-t) - d)--2*d*(1-t-d) + d^2  -  (2*d*(1-t) + d^2)-   = -2*d^2--}-parabolaFadeInInf dur =-   parabolaCore-      (fmap (\d -> -2*d*d)  $ recip dur)-      (fmap (\d -> d*(2-d)) $ recip dur)-      Additive.zero--{--1-t^2--}-parabolaFadeOutInf dur =-   parabolaCore-      (fmap (\d -> -2*d*d) $ recip dur)-      (fmap (\d ->   -d*d) $ recip dur)-      one--ramp,- parabolaFadeIn, parabolaFadeOut,- parabolaFadeInMap, parabolaFadeOutMap ::-   (RealField.C a, Marshal.C a, Tuple.ValueOf a ~ al,-    A.PseudoRing al, A.IntegerConstant al) =>-   Param.T p a -> T p al--ramp dur =-   CausalP.apply (CausalP.take (fmap round dur)) $-   rampInf dur--parabolaFadeIn dur =-   CausalP.apply (CausalP.take (fmap round dur)) $-   parabolaFadeInInf dur--parabolaFadeOut dur =-   CausalP.apply (CausalP.take (fmap round dur)) $-   parabolaFadeOutInf dur--parabolaFadeInMap dur =-   -- t*(2-t)-   CausalP.apply (CausalP.mapSimple (\t -> A.mul t =<< A.sub (A.fromInteger' 2) t)) $-   ramp dur--parabolaFadeOutMap dur =-   -- 1-t^2-   CausalP.apply (CausalP.mapSimple (\t -> A.sub (A.fromInteger' 1) =<< A.mul t t)) $-   ramp dur---{- |-@noise seed rate@--The @rate@ parameter is for adjusting the amplitude-such that it is uniform across different sample rates-and after frequency filters.-The @rate@ is the ratio of the current sample rate to the default sample rate,-where the variance of the samples would be one.-If you want that at sample rate 22050 the variance is 1,-then in order to get a consistent volume at sample rate 44100-you have to set @rate = 2@.--I use the variance as quantity and not the amplitude,-because the amplitude makes only sense for uniformly distributed samples.-However, frequency filters transform the probabilistic density of the samples-towards the normal distribution according to the central limit theorem.--}-noise ::-   (Algebraic.C a, IsFloating a, IsConst a, Marshal.C a,-    Tuple.ValueOf a ~ Value a, LLVM.IsPrimitive a) =>-   Param.T p Word32 ->-   Param.T p a ->-   T p (Value a)-noise seed rate =-   let m2 = fromInteger $ div Rnd.modulus 2-   in  map (\r y ->-          A.mul r-           =<< flip A.sub (valueOf $ m2+1)-           =<< int31tofp y)-          (sqrt (3 * rate) / return m2) $-       noiseCore seed--{--sitofp is a single instruction on x86-and thus we use it, since the arguments are below 2^31.--}-int31tofp ::-   (IsFloating a, LLVM.ShapeOf a ~ LLVM.ScalarShape) =>-   Value Word32 -> CodeGenFunction r (Value a)-int31tofp =-   LLVM.inttofp <=<-   (LLVM.bitcast ::-       Value Word32 -> CodeGenFunction r (Value Int32))--noiseCore, noiseCoreAlt ::-   Param.T p Word32 ->-   T p (Value Word32)-noiseCore seed =-   iterate (const Rnd.nextCG)-      (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed)--noiseCoreAlt seed =-   iterate (const Rnd.nextCG32)-      (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed)----- * conversion from and to storable vectors--fromStorableVector ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   Param.T p (SV.Vector a) ->-   T p value-fromStorableVector selectVec =-   Cons-      (\() () (p0,l0) -> do-         cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero-         MaybeCont.withBool cont $ do-            y1 <- Storable.load p0-            p1 <- Storable.incrementPtr p0-            l1 <- A.dec l0-            return (y1,(p1,l1)))-      (return ())-      (return . (,) ())-      (\() _ -> return ())-      (\p ->-         let (fp,ptr,l) = SVU.unsafeToPointers $ Param.get selectVec p-         in  return (fp, (ptr, fromIntegral l :: Word)))-      -- keep the foreign ptr alive-      touchForeignPtr--{--This function calls back into the Haskell function 'ChunkIt.next'-that returns a pointer to the data of the next chunk-and advances to the next chunk in the sequence.--}-fromStorableVectorLazy ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   Param.T p (SVL.Vector a) -> T p value-fromStorableVectorLazy = SigPriv.flattenChunks . storableVectorChunks--storableVectorChunks ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   Param.T p (SVL.Vector a) ->-   T p (Value (Ptr a), Value Word)-storableVectorChunks sig =-   Cons-      (SigPriv.storableVectorNextChunk-         "Parameterized.Signal.fromStorableVectorLazy.nextChunk")-      LLVM.alloca-      (\s -> return (s, ()))-      (\ _s _ -> return ())-      (\p -> do-          s <- ChunkIt.new (Param.get sig p)-          return (s, s))-      ChunkIt.dispose----piecewiseConstant ::-   (Marshal.C a, Tuple.ValueOf a ~ value) =>-   Param.T p (EventList.T NonNeg.Int a) ->-   T p value-piecewiseConstant =-   Const.flatten . Const.piecewiseConstant----{- |-Turns a lazy chunky size into a signal generator with unit element type.-The signal length is the only information that the generator provides.-Using 'zipWith' you can use this signal as a lazy 'take'.--}-lazySize ::-   Param.T p SVP.LazySize ->-   T p ()-lazySize =-   Const.flatten . Const.lazySize----createFunction ::-   (Functor genMod, EE.ExecutionFunction fun) =>-   Exec.Importer fun -> genMod (Function fun) ->-   Compose genMod EE.EngineAccess fun-createFunction importer modul =-   Compose $ EE.getExecutionFunction importer <$> modul--createFinalizer ::-   (Applicative genMod, EE.ExecutionFunction fun) =>-   Exec.Importer fun -> genMod (Function fun) ->-   Compose genMod EE.EngineAccess (EE.ExecutionEngine, fun)-createFinalizer importer modul =-   liftA2 (,)-      (Compose $ pure EE.getEngine)-      (createFunction importer modul)---foreign import ccall safe "dynamic" derefFillPtr ::-   Exec.Importer (LLVM.Ptr param -> Word -> Ptr a -> IO Word)---moduleFill ::-   (Storable.C a, Tuple.ValueOf a ~ value,-    Memory.C parameters, Memory.Struct parameters ~ paramStruct,-    Tuple.Phi state, Tuple.Undefined state) =>-   (forall r z.-    (Tuple.Phi z) =>-    context -> local -> state -> MaybeCont.T r z (value, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r.-    parameters -> CodeGenFunction r (context, state)) ->-   (forall r.-    context -> state -> CodeGenFunction r ()) ->-   CodeGenModule-      (Function (LLVM.Ptr paramStruct -> Word -> Ptr a -> IO Word))-moduleFill next alloca start stop =-   Exec.createLLVMFunction "fillsignalblock" $-   \paramPtr size bPtr -> do-      param <- Memory.load paramPtr-      (c,s) <- start param-      local <- alloca-      (pos,se) <- Storable.arrayLoopMaybeCont size bPtr s $ \ ptri s0 -> do-         (y,s1) <- next c local s0-         MaybeCont.lift $ Storable.store y ptri-         return s1-      Maybe.for se $ stop c-      ret pos---declareMallocBytes :: LLVM.TFunction (Ptr Word8 -> IO (Ptr a))-declareMallocBytes = LLVM.newNamedFunction LLVM.ExternalLinkage "malloc"--debugMain ::-   forall parameters a paramStruct.-   (Marshal.C parameters,-    Storable.C a,-    LLVM.IsType paramStruct, IsSized paramStruct) =>-   CodeGenModule-      (Function (LLVM.Ptr paramStruct -> Word -> Ptr a -> IO Word)) ->-   parameters ->-   IO (Function (Word -> Ptr (Ptr Word8) -> IO Word))-debugMain sigModule params = do-   paramArray <--      DebugSt.withConstArray params (\arr -> do-         ptr <- LLVM.alloca-         LLVM.store (value arr) =<< LLVM.bitcast ptr-         return ptr)--   m <- LLVM.newModule--   mainFunc <- LLVM.defineModule m (do-      LLVM.setTarget LLVM.hostTriple-      mallocBytes <- declareMallocBytes-      fill <- sigModule-      Exec.createLLVMFunction "main" $ \ _argc _argv -> do-         paramPtr <- paramArray-         let chunkSize = 100000-             basePtr = LLVM.valueOf nullPtr-         buffer <--            LLVM.call mallocBytes =<<-            LLVM.bitcast =<<-            Storable.advancePtr-               (LLVM.valueOf chunkSize) (basePtr :: LLVM.Value (Ptr a))-         _done <--            LLVM.call fill paramPtr-               (LLVM.valueOf $ fromIntegral chunkSize)-               (asTypeOf buffer basePtr)-         ret (A.zero :: LLVM.Value Word))--   Exec.dumper "main" >>= \writeBitcodeToFile -> writeBitcodeToFile "" m--   return mainFunc---run ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   T p value ->-   IO (Int -> p -> SV.Vector a)-run (Cons next alloca start stop createIOContext deleteIOContext) =-   do -- this compiles once and is much faster than simpleFunction-      let modul = moduleFill next alloca start stop-      fill <- Exec.compile "signal" $ createFunction derefFillPtr modul--      return $ \len p ->-         Unsafe.performIO $-         bracket (createIOContext p) (deleteIOContext . fst) $-         \ (_,params) -> do-            when False $ void $ debugMain modul params--            SVB.createAndTrim len $ \ ptr ->-               Marshal.with params $ \paramPtr ->-               fmap fromIntegral $ fill paramPtr (fromIntegral len) ptr--{- |-This is not really a function, see 'renderChunky'.--}-render ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   T p value -> Int -> p -> SV.Vector a-render gen = Unsafe.performIO $ run gen---foreign import ccall safe "dynamic" derefStartPtr ::-   Exec.Importer (LLVM.Ptr b -> IO (LLVM.Ptr a))--foreign import ccall safe "dynamic" derefStopPtr ::-   Exec.Importer (LLVM.Ptr a -> IO ())--foreign import ccall safe "dynamic" derefChunkPtr ::-   Exec.Importer (LLVM.Ptr contextStateStruct -> Word -> Ptr a -> IO Word)--foreign import ccall safe "dynamic" derefChunkPluggedPtr ::-   Exec.Importer-      (LLVM.Ptr contextStateStruct -> Word -> LLVM.Ptr struct -> IO Word)---moduleStart ::-   (Memory.C parameters, Memory.Struct parameters ~ paramStruct,-    Memory.C context, Memory.C state,-    Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>-   (forall r. parameters -> CodeGenFunction r (context, state)) ->-   CodeGenModule (Function-      (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct)))-moduleStart start =-   Exec.createLLVMFunction "startsignal" $-   \paramPtr -> do-      pptr <- LLVM.malloc-      flip Memory.store pptr . mapSnd Maybe.just-         =<< start =<< Memory.load paramPtr-      ret pptr--moduleStop ::-   (Memory.C context, Memory.C state,-    Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>-   (forall r. context -> state -> CodeGenFunction r ()) ->-   CodeGenModule (Function (LLVM.Ptr contextStateStruct -> IO ()))-moduleStop stop =-   Exec.createLLVMFunction "stopsignal" $-   \contextStatePtr -> do-      (c,ms) <- Memory.load contextStatePtr-      Maybe.for ms $ stop c-      LLVM.free contextStatePtr-      ret ()--moduleNext ::-   (Storable.C a, Tuple.ValueOf a ~ value,-    Memory.C context, Memory.C state,-    Memory.Struct (context, Maybe.T state) ~ contextStateStruct,-    Tuple.Phi state, Tuple.Undefined state) =>-   (forall r z.-    (Tuple.Phi z) =>-    context -> local -> state -> MaybeCont.T r z (value, state)) ->-   (forall r. CodeGenFunction r local) ->-   CodeGenModule-      (Function (LLVM.Ptr contextStateStruct -> Word -> Ptr a -> IO Word))-moduleNext next alloca =-   Exec.createLLVMFunction "fillsignal" $-   \contextStatePtr loopLen ptr -> do-      (context, msInit) <- Memory.load contextStatePtr-      local <- alloca-      (pos,msExit) <--         Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->-            Storable.arrayLoopMaybeCont loopLen ptr sInit $ \ptri s0 -> do-         (y,s1) <- next context local s0-         MaybeCont.lift $ Storable.store y ptri-         return s1-      sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())-      Memory.store msExit sptr-      ret pos--moduleNextPlugged ::-   (Memory.C context, Memory.C state,-    Memory.Struct (context, Maybe.T state) ~ contextStateStruct,-    Tuple.Undefined stateOut, Tuple.Phi stateOut,-    Memory.C paramValueOut, Memory.Struct paramValueOut ~ paramStructOut) =>-   (forall r z.-    (Tuple.Phi z) =>-    context -> local -> state -> MaybeCont.T r z (value, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r.-    paramValueOut ->-    value -> stateOut -> LLVM.CodeGenFunction r stateOut) ->-   (forall r.-    paramValueOut ->-    LLVM.CodeGenFunction r stateOut) ->-   CodeGenModule-      (Function-         (LLVM.Ptr contextStateStruct -> Word ->-          LLVM.Ptr paramStructOut -> IO Word))-moduleNextPlugged next alloca nextOut startOut =-   Exec.createLLVMFunction "fillsignal" $-   \contextStatePtr loopLen outPtr -> do-      (context, msInit) <- Memory.load contextStatePtr-      outParam <- Memory.load outPtr-      outInit <- startOut outParam-      local <- alloca-      (pos,msExit) <--         Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->-            MaybeCont.fixedLengthLoop loopLen (sInit, outInit) $-               \ (s0,out0) -> do-         (y,s1) <- next context local s0-         out1 <- MaybeCont.lift $ nextOut outParam y out0-         return (s1, out1)-      sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())-      Memory.store (fmap fst msExit) sptr-      ret pos--debugChunkyMain ::-   forall parameters a paramStruct contextStateStruct.-   (Marshal.C parameters,-    Storable.C a,-    LLVM.IsType contextStateStruct,-    LLVM.IsType paramStruct, IsSized paramStruct) =>-   CodeGenModule-      (Function (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct)),-       Function (LLVM.Ptr contextStateStruct -> IO ()),-       Function (LLVM.Ptr contextStateStruct ->-                 Word -> Ptr a -> IO Word)) ->-   parameters ->-   IO (Function (Word -> Ptr (Ptr Word8) -> IO Word))-debugChunkyMain sigModule params = do-{--This does not work, since we cannot add (Mul n D32 s) constraint-to the function argument in reifyIntegral.-   nextArray <--      DebugSt.withConstArray nextParam (\arr -> do-         ptr <- LLVM.alloca-         LLVM.store (value arr) ptr-         LLVM.bitcast ptr)--}-   paramArray <--      DebugSt.withConstArray params (\arr -> do-         ptr <- LLVM.alloca-         LLVM.store (value arr) =<< LLVM.bitcast ptr-         return ptr)--   m <- LLVM.newModule--   mainFunc <- LLVM.defineModule m (do-      LLVM.setTarget LLVM.hostTriple-      mallocBytes <- declareMallocBytes-      (start, stop, fill) <- sigModule-      Exec.createLLVMFunction "main" $ \ _argc _argv -> do-         contextState <- LLVM.call start =<< paramArray-         let chunkSize = 100000-             basePtr = LLVM.valueOf nullPtr-         buffer <--            LLVM.call mallocBytes =<<-            LLVM.bitcast =<<-            Storable.advancePtr-               (LLVM.valueOf chunkSize) (basePtr :: LLVM.Value (Ptr a))-         _done <--            LLVM.call fill contextState-               (LLVM.valueOf $ fromIntegral chunkSize)-               (asTypeOf buffer basePtr)-         _ <- LLVM.call stop contextState-         ret (A.zero :: LLVM.Value Word))--   Exec.dumper "main-chunky" >>= \writeBitcodeToFile -> writeBitcodeToFile "" m--   return mainFunc----{- |-Renders a signal generator to a chunky storable vector with given pattern.-If the pattern is shorter than the generated signal-this means that the signal is shortened.--}-runChunkyPattern, _runChunkyPattern ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   T p value ->-   IO (SVP.LazySize -> p -> SVL.Vector a)-_runChunkyPattern =-   fmap (\f size -> SVL.fromChunks . f size) .-   flip runChunkyPatternPlugged POut.deflt--runChunkyPattern-      (Cons next alloca start stop createIOContext deleteIOContext) = do--   let startF = moduleStart start-   let stopF = moduleStop stop-   let nextF = moduleNext next alloca--   (startFunc, stopFunc, fill) <--      Exec.compile "signal-pattern" $-      liftA3 (,,)-         (createFunction derefStartPtr startF)-         (createFinalizer derefStopPtr stopF)-         (createFunction derefChunkPtr nextF)--   return $-      \ lazysize p -> SVL.fromChunks $ Unsafe.performIO $ do-         (ioContext, param) <- createIOContext p--{--         putStr "nextParam: "-         DebugSt.format nextParam >>= putStrLn--}-         when False $-            Counter.next DebugSt.dumpCounter >>=-            DebugSt.dump "param" param--         when False $ void $-            debugChunkyMain (liftA3 (,,) startF stopF nextF) param--         statePtr <- ForeignPtr.newParam stopFunc startFunc param-         ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)--         let go cs =-                Unsafe.interleaveIO $-                case cs of-                   [] -> return []-                   SVL.ChunkSize size : rest -> do-                      v <--                         ForeignPtr.with statePtr $ \sptr ->-                         SVB.createAndTrim size $-                         fmap fromIntegral .-                         fill sptr (fromIntegral size)-                      touchForeignPtr ioContextPtr-                      (if SV.length v > 0-                         then fmap (v:)-                         else id) $-                         (if SV.length v < size-                            then return []-                            else go rest)-         go (Chunky.toChunks lazysize)--runChunkyPatternPlugged ::-   T p value ->-   POut.T value chunk ->-   IO (SVP.LazySize -> p -> [chunk])-runChunkyPatternPlugged-      (Cons next alloca start stop createIOContext deleteIOContext)-      (POut.Cons nextOut startOut createOut deleteOut) = do--   (startFunc, stopFunc, fill) <--      Exec.compile "signal-plugged" $-      liftA3 (,,)-         (createFunction derefStartPtr $ moduleStart start)-         (createFinalizer derefStopPtr $ moduleStop stop)-         (createFunction derefChunkPluggedPtr $-          moduleNextPlugged next alloca nextOut startOut)--   return $-      \ lazysize p -> Unsafe.performIO $ do-         (ioContext, param) <- createIOContext p--         statePtr <- ForeignPtr.newParam stopFunc startFunc param-         ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)--         let go cs =-                Unsafe.interleaveIO $-                case cs of-                   [] -> return []-                   SVL.ChunkSize maximumSize : rest -> do-                      (contextOut,paramOut) <- createOut maximumSize-                      actualSize <--                         fmap fromIntegral $-                         Marshal.with paramOut $ \outptr ->-                         ForeignPtr.with statePtr $ \sptr ->-                         fill sptr (fromIntegral maximumSize) outptr-                      when (fromIntegral actualSize > maximumSize) $-                         error $ "Parametrized.Signal: " ++-                                 "output size " ++ show actualSize ++-                                 " > input size " ++ show maximumSize-                      v <- deleteOut actualSize contextOut-                      touchForeignPtr ioContextPtr-                      (if actualSize > 0-                         then fmap (v:)-                         else id) $-                         (if actualSize < maximumSize-                            then return []-                            else go rest)-         go (Chunky.toChunks lazysize)--runChunky, _runChunky ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   T p value ->-   IO (SVL.ChunkSize -> p -> SVL.Vector a)-runChunky sig =-   flip fmap (runChunkyPattern sig) $ \f size p ->-      f (Chunky.fromChunks (repeat size)) p--_runChunky =-   fmap (\f size -> SVL.fromChunks . f size) .-   flip runChunkyPlugged POut.deflt--runChunkyPlugged ::-   T p value ->-   POut.T value chunk ->-   IO (SVL.ChunkSize -> p -> [chunk])-runChunkyPlugged sig plug =-   flip fmap (runChunkyPatternPlugged sig plug) $ \f size p ->-      f (Chunky.fromChunks (repeat size)) p--{- |-This looks like a function,-but it is not a function since it depends on LLVM being initialized-with LLVM.initializeNativeTarget before.-It is also problematic since you cannot control when and how often-the underlying LLVM code is compiled.-The compilation cannot be observed, thus it is referential transparent.-But this influences performance considerably-and I assume that you use this package exclusively for performance reasons.--}-renderChunky ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   SVL.ChunkSize -> T p value ->-   p -> SVL.Vector a-renderChunky size gen =-   Unsafe.performIO (runChunky gen) size
− src/Synthesizer/LLVM/Parameterized/SignalPacked.hs 
@@ -1,287 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}-{- |-Signal generators that generate the signal in chunks-that can be processed natively by the processor.-Some of the functions for plain signals can be re-used without modification.-E.g. rendering a signal and reading from and to signals work-because the vector type as element type warrents correct alignment.-We can convert between atomic and chunked signals.--The article-<http://perilsofparallel.blogspot.com/2008/09/larrabee-vs-nvidia-mimd-vs-simd.html>-explains the difference between Vector and SIMD computing.-According to that the SSE extensions in Intel processors-must be called Vector computing.-But since we use the term Vector already in the mathematical sense,-I like to use the term "packed" that is used in Intel mnemonics like mulps.--}-module Synthesizer.LLVM.Parameterized.SignalPacked (-   SigS.pack, SigS.packRotate,-   SigS.packSmall,-   SigS.unpack, SigS.unpackRotate,-   constant,-   exponential2,-   exponentialBounded2,-   osciCore,-   osci,-   osciSimple,-   parabolaFadeInInf, parabolaFadeOutInf,-   rampInf, rampSlope,-   noise,-   noiseCore, noiseCoreAlt,-   ) where--import Synthesizer.LLVM.Parameterized.Signal (T)-import qualified Synthesizer.LLVM.Simple.SignalPacked as SigS-import qualified Synthesizer.LLVM.Parameterized.Signal as Sig-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Random as Rnd--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple--import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal ((:*:))--import qualified LLVM.Core as LLVM-import LLVM.Core-         (CodeGenFunction, Value,-          IsConst, IsArithmetic, IsFloating, IsPrimitive, Vector, SizeOf)--import Control.Monad.HT ((<=<))--- we can also use <$> for parameters-import Control.Arrow ((^<<))-import Control.Applicative (liftA2)--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.RealField as RealField-import qualified Algebra.Ring as Ring--import Data.Word (Word32)-import Data.Int (Int32)--import NumericPrelude.Numeric as NP-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith)----withSize ::-   (TypeNum.Positive n) =>-   (TypeNum.Singleton n -> T p (Serial.Value n a)) ->-   T p (Serial.Value n a)-withSize f = f TypeNum.singleton--withSizeRing ::-   (Ring.C b, TypeNum.Positive n) =>-   (TypeNum.Singleton n -> b -> T p (Serial.Value n a)) ->-   T p (Serial.Value n a)-withSizeRing f =-   withSize $ \n -> f n $ fromInteger $ TypeNum.integerFromSingleton n---constant ::-   (Marshal.Vector n a, Tuple.ValueOf a ~ Value a, IsConst a,-    Tuple.VectorValueOf n a ~ Value (Vector n a),-    IsPrimitive a, SizeOf a ~ asize,-    TypeNum.Positive (n :*: asize),-    TypeNum.Positive n) =>-   Param.T p a -> T p (Serial.Value n a)-constant x =-   withSize $ \n -> Sig.constant (Serial.replicate_ n ^<< x)---exponential2 ::-   (Trans.C a, Marshal.Vector n a, Tuple.ValueOf a ~ Value a,-    Tuple.VectorValueOf n a ~ Value (Vector n a),-    IsArithmetic a, IsConst a,-    IsPrimitive a, SizeOf a ~ asize,-    TypeNum.Positive (n :*: asize),-    TypeNum.Positive n) =>-   Param.T p a -> Param.T p a -> T p (Serial.Value n a)-exponential2 halfLife start = withSizeRing $ \sn n ->-   Sig.exponentialCore-      (Serial.replicate_ sn ^<< 0.5 ** (n / halfLife))-      (liftA2-         (\h -> Serial.iteratePlain (0.5 ** recip h *))-         halfLife start)--exponentialBounded2 ::-   (Trans.C a, Marshal.Vector n a, Tuple.ValueOf a ~ Value a,-    Tuple.VectorValueOf n a ~ Value (Vector n a),-    Vector.Real a, IsConst a,-    IsPrimitive a, SizeOf a ~ as,-    TypeNum.Positive (n :*: as),-    TypeNum.Positive n) =>-   Param.T p a -> Param.T p a -> Param.T p a ->-   T p (Serial.Value n a)-exponentialBounded2 bound halfLife start = withSizeRing $ \sn n ->-   Sig.exponentialBoundedCore-      (fmap (Serial.replicate_ sn) bound)-      (Serial.replicate_ sn ^<< 0.5 ** (n / halfLife))-      (liftA2-         (\h -> Serial.iteratePlain (0.5 ** recip h *))-         halfLife start)---osciCore ::-   (Marshal.Vector n t, Tuple.ValueOf t ~ Value t,-    Tuple.VectorValueOf n t ~ Value (Vector n t),-    IsPrimitive t, SizeOf t ~ tsize,-    TypeNum.Positive (n :*: tsize),-    Vector.Real t, IsFloating t, RealField.C t, IsConst t,-    TypeNum.Positive n) =>-   Param.T p t -> Param.T p t -> T p (Serial.Value n t)-osciCore phase freq = withSizeRing $ \sn n ->-   Sig.osciCore-      (liftA2-         (\f -> Serial.iteratePlain (fraction . (f +)))-         freq phase)-      (fmap-         (\f -> Serial.replicate_ sn (fraction (n * f)))-         freq)--osci ::-   (Marshal.Vector n t, Tuple.ValueOf t ~ Value t,-    Marshal.C c, Tuple.ValueOf c ~ cl,-    Tuple.VectorValueOf n t ~ Value (Vector n t),-    IsPrimitive t, SizeOf t ~ tsize,-    TypeNum.Positive (n :*: tsize),-    Memory.C cl,-    Vector.Real t, IsFloating t, RealField.C t, IsConst t,-    TypeNum.Positive n) =>-   (forall r. cl -> Serial.Value n t -> CodeGenFunction r y) ->-   Param.T p c ->-   Param.T p t -> Param.T p t -> T p y-osci wave waveParam phase freq =-   Sig.map wave waveParam $-   osciCore phase freq--osciSimple ::-   (Marshal.Vector n t, Tuple.ValueOf t ~ Value t,-    Tuple.VectorValueOf n t ~ Value (Vector n t),-    IsPrimitive t, SizeOf t ~ tsize,-    TypeNum.Positive (n :*: tsize),-    Vector.Real t, IsFloating t, RealField.C t, IsConst t,-    TypeNum.Positive n) =>-   (forall r. Serial.Value n t -> CodeGenFunction r y) ->-   Param.T p t -> Param.T p t -> T p y-osciSimple wave =-   osci (const wave) (return ())---rampInf, rampSlope,- parabolaFadeInInf, parabolaFadeOutInf ::-   (RealField.C a, Marshal.Vector n a, Tuple.ValueOf a ~ Value a,-    Tuple.VectorValueOf n a ~ Value (Vector n a),-    IsPrimitive a, SizeOf a ~ as,-    TypeNum.Positive (n :*: as),-    IsArithmetic a, SoV.IntegerConstant a,-    TypeNum.Positive n) =>-   Param.T p a -> T p (Serial.Value n a)-rampSlope slope = withSizeRing $ \sn n ->-   Sig.rampCore-      (fmap (\s -> Serial.replicate_ sn (n * s)) slope)-      (fmap (\s -> Serial.iteratePlain (s +) 0) slope)-rampInf dur = rampSlope (recip dur)--parabolaFadeInInf dur = withSizeRing $ \sn n ->-   Sig.parabolaCore-      (fmap-         (\dr ->-            let d = n / dr-            in  Serial.replicate_ sn (-2*d*d)) dur)-      (fmap-         (\dr ->-            let d = n / dr-            in  Serial.iteratePlain (subtract $ 2 / dr ^ 2) (d*(2-d)))-         dur)-      (fmap-         (\dr ->-            Serial.mapPlain (\t -> t*(2-t)) $ Serial.iteratePlain (recip dr +) 0)-         dur)--parabolaFadeOutInf dur = withSizeRing $ \sn n ->-   Sig.parabolaCore-      (fmap-         (\dr ->-            let d = n / dr-            in  Serial.replicate_ sn (-2*d*d)) dur)-      (fmap-         (\dr ->-            let d = n / dr-            in  Serial.iteratePlain (subtract $ 2 / dr ^ 2) (-d*d))-         dur)-      (fmap-         (\dr ->-            Serial.mapPlain (\t -> 1-t*t) $ Serial.iteratePlain (recip dr +) 0)-         dur)---{- |-For the mysterious rate parameter see 'Sig.noise'.--}-noise ::-   (Algebraic.C a, IsFloating a, SoV.IntegerConstant a,-    TypeNum.Positive n,-    TypeNum.Positive (n :*: TypeNum.D32),-    IsPrimitive a, SizeOf a ~ as,-    TypeNum.Positive (n :*: as),-    Marshal.Vector n a, Tuple.VectorValueOf n a ~ Value (Vector n a),-    Tuple.ValueOf a ~ Value a) =>-   Param.T p Word32 ->-   Param.T p a ->-   T p (Serial.Value n a)-noise seed rate =-   withSize $ \n ->-   let m2 = div Rnd.modulus 2-   in  Sig.map-          (\r y ->-             A.mul r-              =<< flip A.sub (A.fromInteger' $ m2+1)-              =<< int31tofp y)-          (Serial.replicate_ n ^<< sqrt (3 * rate) / return (fromInteger m2)) $-       noiseCore seed--{--sitofp is a single instruction on x86-and thus we use it, since the arguments are below 2^31.--}-int31tofp ::-   (IsFloating a, IsPrimitive a,-    TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>-   Serial.Value n Word32 -> CodeGenFunction r (Serial.Value n a)-int31tofp =-   Serial.mapV $-   LLVM.inttofp <=<-   (LLVM.bitcast ::-       (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) =>-       Value (Vector n Word32) ->-       CodeGenFunction r (Value (Vector n Int32)))--noiseCore, noiseCoreAlt ::-   (TypeNum.Positive n,-    TypeNum.Positive (n :*: TypeNum.D32)) =>-   Param.T p Word32 ->-   T p (Serial.Value n Word32)-noiseCore seed =-   fmap Serial.value $-   Sig.iterate (const Rnd.nextVector)-      (return ())-      (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed)--noiseCoreAlt seed =-   fmap Serial.value $-   Sig.iterate (const Rnd.nextVector64)-      (return ())-      (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed)
− src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs 
@@ -1,346 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Parameterized.SignalPrivate where--import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig-import qualified LLVM.Extra.Tuple as Tuple-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.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.DSL.Parameter as Param-import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction)--import Control.Arrow ((&&&))-import Control.Monad (liftM, liftM2)-import Control.Applicative (Applicative, pure, (<*>))--import Data.Tuple.Strict (zipPair)-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-import qualified Algebra.Additive as Additive--import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith)--import qualified Prelude as P---{--In this attempt we use a Haskell value as parameter supply.-This is okay, since the Haskell value will be converted to internal parameters-and then to LLVM values only once.-We can even have a storable vector as parameter.-However, this way we cannot easily implement-the Vanilla signal using Parameterized.Value as element type.--This separation is nice for maximum efficiency,-but it cannot be utilized by Generic.Signal methods.-Consider an expression like @iterate ((0.5 ** recip halfLife) *) 1@.-How shall we know, that the sub-expression @(0.5 ** recip halfLife)@-needs to be computated only once?-I do not try to do such optimization, instead I let LLVM do it.-However, this means that parameter initialization-will be performed (unnecessarily) at the beginning of every chunk.-For Generic.Signal method instances-we will always set the @(p -> paramTuple)@ to 'id'.--Could we drop parameterized signals at all-and rely entirely on Causal processes?-Unfortunately 'interpolateConstant' does not fit into the Causal process scheme.-(... although it would be causal for stretching factor being at least one.-It would have to maintain the waiting signal as state,-i.e. the state would grow linearly with time.)-Consider a signal algorithm, where the LFO frequency is a parameter.--}-data T p a =-   forall context state local ioContext parameters.-      (Marshal.C parameters, Memory.C context, Memory.C state) =>-   Cons-      (forall r c.-       (Tuple.Phi c) =>-       context -> local -> state -> MaybeCont.T r c (a, state))-          -- compute next value-      (forall r.-       CodeGenFunction r local)-          -- allocate temporary variables before a loop-      (forall r.-       Tuple.ValueOf parameters ->-       CodeGenFunction r (context, state))-          -- allocate initial state-      (forall r.-       context -> state ->-       CodeGenFunction r ())-          {- cleanup-          You must make sure to call this-          whenever you allocated context and state with the 'start' function.-          You must call it with the latest state returned from the 'next' function.-          -}-      (p -> IO (ioContext, parameters))-          {- initialization from IO monad-          This will be run within Unsafe.performIO,-          so no observable In/Out actions please!-          -}-      (ioContext -> IO ())-          -- finalization from IO monad, also run within Unsafe.performIO---instance Sig.C (T p) where-   simpleAlloca next alloca0 start =-      Cons-         (\() local -> next local)-         alloca0-         (const $ fmap ((,) ()) start)-         (const $ const $ return ())-         (const $ return ((), ()))-         (const $ return ())--   alter f (Cons next0 alloca0 start0 stop0 create delete) =-      case f (Sig.Core (uncurry next0) return id) of-         Sig.Core next1 start1 stop1 ->-            Cons-               (curry next1)-               alloca0-               (withStart start0 start1)-               (\c -> stop0 c . stop1)-               create delete---withStart ::-   Monad m =>-   (startParam -> m (context, state0)) ->-   (state0 -> m state1) ->-   startParam -> m (context, state1)-withStart start act p = do-   (c,s) <- start p-   liftM ((,) c) $ act s--combineStart ::-   Monad m =>-   (paramA -> m (contextA, stateA)) ->-   (paramB -> m (contextB, stateB)) ->-   (paramA, paramB) -> m ((contextA, contextB), (stateA, stateB))-combineStart startA startB (paramA, paramB) =-   liftM2 zipPair (startA paramA) (startB paramB)--combineStop ::-   Monad m =>-   (contextA -> stateA -> m ()) ->-   (contextB -> stateB -> m ()) ->-   (contextA, contextB) -> (stateA, stateB) -> m ()-combineStop stopA stopB (ca, cb) (sa, sb) =-   stopA ca sa >> stopB cb sb--combineCreate ::-   Monad m =>-   (p -> m (ioContextA, contextA)) ->-   (p -> m (ioContextB, contextB)) ->-   p -> m ((ioContextA, ioContextB), (contextA, contextB))-combineCreate createIOContextA createIOContextB p =-   liftM2 zipPair (createIOContextA p) (createIOContextB p)--combineDelete ::-   (Monad m) =>-   (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m ()-combineDelete deleteIOContextA deleteIOContextB (ca,cb) =-   deleteIOContextA ca >> deleteIOContextB cb----simple ::-   (Marshal.C parameters, Tuple.ValueOf parameters ~ paramTuple,-    Memory.C context, Memory.C state) =>-   (forall r c.-    (Tuple.Phi c) =>-    context -> state -> MaybeCont.T r c (al, state)) ->-   (forall r.-    paramTuple ->-    CodeGenFunction r (context, state)) ->-   Param.T p parameters -> T p al-simple f start param =-   Param.withValue param $ \getParam valueParam ->-   Cons-      (\context () state -> f context state)-      (return ())-      (start . valueParam)-      (const $ const $ return ())-      (return . (,) () . getParam)-      (const $ return ())---constant :: (Marshal.C a, Tuple.ValueOf a ~ al) => Param.T p a -> T p al-constant =-   simple-      (\pl () -> return (pl, ()))-      (return . flip (,) ())---map ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (forall r. pl -> a -> CodeGenFunction r b) ->-   Param.T p ph ->-   T p a -> T p b-map f param =-   Sig.map (uncurry f) . zip (constant param)---- for backwards compatibility-mapSimple ::-   (forall r. a -> CodeGenFunction r b) ->-   T p a -> T p b-mapSimple = Sig.map---zipWith ::-   (Marshal.C ph, Tuple.ValueOf ph ~ pl) =>-   (forall r. pl -> a -> b -> CodeGenFunction r c) ->-   Param.T p ph ->-   T p a -> T p b -> T p c-zipWith f param as bs =-   map (uncurry . f) param $ zip as bs--zip :: T p a -> T p b -> T p (a,b)-zip (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)-    (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =-   Cons-      (\(parameterA, parameterB) (localA, localB) (sa0,sb0) -> do-         (a,sa1) <--            MaybeCont.onFail (stopB parameterB sb0) $-            nextA parameterA localA sa0-         (b,sb1) <--            MaybeCont.onFail (stopA parameterA sa1) $-            nextB parameterB localB sb0-         return ((a,b), (sa1,sb1)))-      (liftM2 (,) allocaA allocaB)-      (combineStart startA startB)-      (combineStop stopA stopB)-      (combineCreate createIOContextA createIOContextB)-      (combineDelete deleteIOContextA deleteIOContextB)--{--maintained for backwards compatibility-It is a specialisation of Sig.zipWith.-However, we cannot define zipWithSimple = Sig.zipWith,-since Sig.zipWith depends on Applicative.liftA2,-which depends on zipWithSimple.--}-zipWithSimple ::-   (forall r. a -> b -> CodeGenFunction r c) ->-   T p a -> T p b -> T p c-zipWithSimple f as bs =-   mapSimple (uncurry f) $ zip as bs---instance Functor (T p) where-   fmap f = mapSimple (return . f)--{- |-ZipList semantics--}-instance Applicative (T p) where-   pure x =-      simple-         (\() () -> return (x, ()))-         (\() -> return ((),()))-         (return ())-   (<*>) = zipWithSimple (\f a -> return (f a))---instance (A.Additive a) => Additive.C (T p a) where-   zero = pure A.zero-   negate = mapSimple A.neg-   (+) = zipWithSimple A.add-   (-) = zipWithSimple A.sub--instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T p a) where-   one = pure A.one-   fromInteger n = pure (A.fromInteger' n)-   (*) = zipWithSimple A.mul--instance (A.Field a, A.RationalConstant a) => Field.C (T p a) where-   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)-   (/) = zipWithSimple A.fdiv---instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T p a) where-   fromInteger n = pure (A.fromInteger' n)-   negate = mapSimple A.neg-   (+) = zipWithSimple A.add-   (-) = zipWithSimple A.sub-   (*) = zipWithSimple A.mul-   abs = mapSimple A.abs-   signum = mapSimple A.signum--instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T p a) where-   fromRational x = pure (A.fromRational' x)-   (/) = zipWithSimple A.fdiv---{- |-For restrictions see 'Sig.append'.--}-append :: (Tuple.Phi a, Tuple.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 (Tuple.Phi a, Tuple.Undefined a) => Semigroup (T p a) where-   (<>) = append--instance (Tuple.Phi a, Tuple.Undefined a) => Monoid (T p a) where-   mempty = Sig.empty-   mappend = append---iterate ::-   (Marshal.C c, Tuple.ValueOf c ~ cl,-    Marshal.C a, Tuple.ValueOf a ~ al) =>-   (forall r. cl -> al -> CodeGenFunction r al) ->-   Param.T p c -> Param.T p a -> T p al-iterate f param initial = simple-   (\pl al0 -> MaybeCont.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))-   return-   (param &&& initial)--malloc :: (LLVM.IsSized a) => T p (LLVM.Value (LLVM.Ptr a))-malloc =-   Cons-      (\ptr () () -> return (ptr, ()))-      (return ())-      (const $ fmap (flip (,) ()) $ LLVM.malloc)-      (\ptr () -> LLVM.free ptr)-      (const $ return ((), ()))-      (const $ return ())
src/Synthesizer/LLVM/Plug/Input.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Plug.Input (    T(..),    Default(..),@@ -21,16 +19,19 @@  import qualified Synthesizer.LLVM.ConstantPiece as Const -import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Control as C +import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:*:)) import Type.Base.Proxy (Proxy)  import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS@@ -49,14 +50,17 @@ import qualified Foreign.ForeignPtr as FPtr import Foreign.Storable (pokeElemOff) -import Control.Applicative (liftA2)+import qualified Control.Functor.HT as FuncHT+import Control.Applicative (liftA2, (<$>))  import qualified Data.Map as Map--import Data.Tuple.Strict (mapFst, mapPair, swap, zipPair)+import qualified Data.List as List+import Data.Tuple.Strict (mapFst, zipPair) import Data.Word (Word) +import Prelude hiding (map) + {- This datatype does not provide an early exit option, e.g. by Maybe.T, since we warrant that the driver function will always@@ -69,104 +73,90 @@       (Marshal.C parameters, Memory.C state) =>    Cons       (forall r.-       Tuple.ValueOf parameters ->+       MultiValue.T parameters ->        state -> LLVM.CodeGenFunction r (b, state))-          -- compute next value+         -- compute next value       (forall r.-       Tuple.ValueOf parameters ->+       MultiValue.T parameters ->        LLVM.CodeGenFunction r state)-          -- initial state+         -- initial state       (a -> IO (ioContext, parameters))-          {- initialization from IO monad-          This is called once input chunk.-          This will be run within Unsafe.performIO,-          so no observable In/Out actions please!-          -}+         {- initialization from IO monad+         This is called once input chunk.+         This will be run within Unsafe.performIO,+         so no observable In/Out actions please!+         -}       (ioContext -> IO ())-          {--          finalization from IO monad, also run within Unsafe.performIO-          -}+         {-+         finalization from IO monad, also run within Unsafe.performIO+         -}   instance Functor (T a) where    fmap f (Cons next start create delete) =       Cons (\p s -> fmap (mapFst f) $ next p s) start create delete +map :: (forall r. a -> LLVM.CodeGenFunction r b) -> T inp a -> T inp b+map f (Cons next start create delete) =+   Cons (\p s -> FuncHT.mapFst f =<< next p s) start create delete -class Default a where-   type Element a :: *-   deflt :: T a (Element a) -instance (Default a, Default b) => Default (Zip.T a b) where-   type Element (Zip.T a b) = (Element a, Element b)-   deflt = split deflt deflt -instance Default SigG.LazySize where-   type Element SigG.LazySize = ()-   deflt = lazySize--instance (Storable.C a) => Default (SV.Vector a) where-   type Element (SV.Vector a) = Tuple.ValueOf a-   deflt = storableVector---{--This is intentionally restricted to NonNegW.Int aka StrictTimeShort,-since chunks must fit into memory.-If you have good reasons to allow other types,-see the versioning history for an according hack.--}-instance-   (Storable.C a, Memory.C (Tuple.ValueOf a)) =>-      Default (EventListBT.T NonNegW.Int a) where-   type Element (EventListBT.T NonNegW.Int a) = Tuple.ValueOf a-   deflt = piecewiseConstant-+class Default a where+   type Element a+   deflt :: T a (Element a)   rmap :: (a -> b) -> T b c -> T a c rmap f (Cons next start create delete) =    Cons next start (create . f) delete +fanout :: T a b -> T a c -> T a (b,c)+fanout f g = rmap (\a -> Zip.Cons a a) $ split f g ++instance (Default a, Default b) => Default (Zip.T a b) where+   type Element (Zip.T a b) = (Element a, Element b)+   deflt = split deflt deflt+ split :: T a c -> T b d -> T (Zip.T a b) (c,d) split (Cons nextA startA createA deleteA)       (Cons nextB startB createB deleteB) = Cons-   (\(parameterA, parameterB) (sa,sb) ->-      liftA2 zipPair-         (nextA parameterA sa)-         (nextB parameterB sb))-   (\(parameterA, parameterB) ->-      liftA2 (,)-         (startA parameterA)-         (startB parameterB))+   (MultiValue.uncurry $ \parameterA parameterB (sa,sb) ->+      liftA2 zipPair (nextA parameterA sa) (nextB parameterB sb))+   (MultiValue.uncurry $ \parameterA parameterB ->+      liftA2 (,) (startA parameterA) (startB parameterB))    (\(Zip.Cons a b) ->-      liftA2 zipPair-         (createA a)-         (createB b))-   (\(ca,cb) ->-      deleteA ca >>-      deleteB cb)+      liftA2 zipPair (createA a) (createB b))+   (\(ca,cb) -> deleteA ca >> deleteB cb) -fanout :: T a b -> T a c -> T a (b,c)-fanout f g = rmap (\a -> Zip.Cons a a) $ split f g +instance Default SigG.LazySize where+   type Element SigG.LazySize = ()+   deflt = lazySize+ lazySize :: T SigG.LazySize () lazySize = ignore  ignore :: T a () ignore =    Cons-      (\ _ _ -> return ((), ()))+      (\ _ unit -> return ((), unit))       return       (\ _a -> return ((), ()))       (const $ return ()) -storableVector ::-   (Storable.C a, Tuple.ValueOf a ~ value) => T (SV.Vector a) value+instance (Storable.C a) => Default (SV.Vector a) where+   type Element (SV.Vector a) = MultiValue.T a+   deflt = storableVector++storableVector :: (Storable.C a) => T (SV.Vector a) (MultiValue.T a) storableVector =    Cons-      (\ _ p -> liftA2 (,) (Storable.load p) (Storable.incrementPtr p))+      (\ _ (MultiValue.Cons p) ->+         liftA2 (,)+            (Storable.load p)+            (MultiValue.Cons <$> Storable.incrementPtr p))       return       (\vec ->          let (fp,ptr,_l) = SVU.unsafeToPointers vec@@ -174,24 +164,40 @@       -- keep the foreign ptr alive       FPtr.touchForeignPtr + {-+This is intentionally restricted to NonNegW.Int aka StrictTimeShort,+since chunks must fit into memory.+If you have good reasons to allow other types,+see the versioning history for an according hack.+-}+instance+   (Marshal.C a, time ~ NonNegW.Int) =>+      Default (EventListBT.T time a) where+   type Element (EventListBT.T time a) = MultiValue.T a+   deflt = piecewiseConstant++{- I would like to re-use code from ConstantPiece here. Unfortunately, it is based on the LLVM-Maybe-Monad, but here we do not accept early exit. -} piecewiseConstant ::-   (Storable.C a, Tuple.ValueOf a ~ value, Memory.C value) =>-   T (EventListBT.T NonNegW.Int a) value+   (Marshal.C a) => T (EventListBT.T NonNegW.Int a) (MultiValue.T a) piecewiseConstant =    expandConstantPieces $-   rmap (uncurry Zip.Cons .-         mapPair-            (SV.pack .-               map ((fromIntegral :: Int -> Word) . NonNegW.toNumber),-             SV.pack) .-         swap . unzip . EventListBT.toPairList) $-   fmap (uncurry Const.Cons) $-   split storableVector storableVector+   rmap+      (SV.pack .+       List.map+         (\(a,t) -> EE.Stored $ LLVM.Struct+            (fromIntegral $ NonNegW.toNumber t :: Word, (Marshal.pack a, ()))) .+       EventListBT.toPairList) $+   map+      (\(MultiValue.Cons s) -> do+         t <- LLVM.extractvalue s TypeNum.d0+         a <- LLVM.extractvalue s TypeNum.d1+         Const.Cons t . MultiValue.Cons <$> Memory.decompose a) $+   storableVector  expandConstantPieces ::    (Memory.C value) => T events (Const.T value) -> T events value@@ -204,9 +210,7 @@                 next param s))       length2 <- A.dec length1       return (y1, (Const.Cons length2 y1, s1)))-   (\param ->-      fmap ((,) (Const.Cons Tuple.zero Tuple.undef)) $-      start param)+   (\param -> (,) (Const.Cons Tuple.zero Tuple.undef) <$> start param)    create delete  @@ -215,33 +219,41 @@ in order to forbid writing to the array. -} controllerSet ::-   (TypeNum.Natural n, Storable.C a,-    LLVM.Storable a, Tuple.ValueOf a ~ LLVM.Value a, LLVM.IsSized a) =>-   Proxy n -> T (PCS.T Int a) (LLVM.Value (LLVM.Array n a))+   (Marshal.C a, Marshal.Struct a ~ aStruct, LLVM.IsSized aStruct,+    TypeNum.Natural n,+    (n:*:LLVM.SizeOf aStruct) ~ arrSize, TypeNum.Natural arrSize) =>+   Proxy n -> T (PCS.T Int a) (MultiValue.T (MultiValue.Array n a)) controllerSet pn =    controllerSetFromSV pn $-   split storableVector $ split storableVector storableVector+   map+      (\(MultiValue.Cons s) -> do+         len <- LLVM.extractvalue s TypeNum.d0+         i   <- LLVM.extractvalue s TypeNum.d1+         a   <- Memory.decompose =<< LLVM.extractvalue s TypeNum.d2+         return (len,(i,a))) $+   storableVector  controllerSetFromSV ::-   (TypeNum.Natural n,-    LLVM.Storable a, Tuple.ValueOf a ~ LLVM.Value a, LLVM.IsSized a) =>+   (Marshal.C a, Marshal.Struct a ~ aStruct, LLVM.IsSized aStruct,+    TypeNum.Natural n,+    (n:*:LLVM.SizeOf aStruct) ~ arrSize, TypeNum.Natural arrSize) =>    Proxy n ->-   T (Zip.T (SV.Vector Word) (Zip.T (SV.Vector Word) (SV.Vector a)))-     (LLVM.Value Word, (LLVM.Value Word, LLVM.Value a)) ->-   T (PCS.T Int a) (LLVM.Value (LLVM.Array n a))+   T (SV.Vector (EE.Stored (Marshal.Struct (Word,Word,a))))+     (LLVM.Value Word, (LLVM.Value Word, MultiValue.T a)) ->+   T (PCS.T Int a) (MultiValue.T (MultiValue.Array n a)) controllerSetFromSV pn (Cons next start create delete) = Cons-   (\((arrPtr, _), param) state0 -> do+   (MultiValue.uncurry $ \(MultiValue.Cons (arrPtr, _)) param state0 -> do       (length2, s2) <-          C.whileLoopShared state0             (\(len0, s0) ->                (A.cmp LLVM.CmpEQ len0 Tuple.zero,                 do ((len1, (i,a)), s1) <- next param s0-                   LLVM.store a =<< LLVM.getElementPtr arrPtr (i, ())+                   Memory.store a =<< LLVM.getElementPtr arrPtr (i, ())                    return (len1, s1)))       length3 <- A.dec length2-      arr <- LLVM.load =<< LLVM.bitcast arrPtr+      arr <- Memory.load =<< LLVM.bitcast arrPtr       return (arr, (length3, s2)))-   (\((_, initialTime), param) -> do+   (MultiValue.uncurry $ \(MultiValue.Cons (_, initialTime)) param -> do       state <- start param       return (initialTime, state)) @@ -250,14 +262,14 @@          (\initialTime bt -> do             (context, param) <-                create-                  (uncurry Zip.Cons .-                   mapPair-                     (SV.pack,-                      uncurry Zip.Cons . mapPair (SV.pack, SV.pack). unzip) .-                   unzip .-                   map (\((i,a),len) ->-                      (fromIntegral len :: Word,-                       (fromIntegral i :: Word, a))) .+                  (SV.pack .+                   List.map+                     (\((i,a),len) ->+                        EE.Stored $+                        Marshal.pack+                           (fromIntegral len :: Word,+                            fromIntegral i :: Word,+                            a)) .                    EventListBT.toPairList $                    bt) @@ -267,11 +279,12 @@             flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) ->                if i >= n                  then error "Plug.Input.controllerSet: array too small"-                 else pokeElemOff arr i a+                 else pokeElemOff arr i $ EE.Stored $ Marshal.pack a              return                ((arr, context),-                ((LLVM.fromPtr arr, fromIntegral initialTime :: Word), param)))+                ((EE.castFromStoredPtr arr, fromIntegral initialTime :: Word),+                  param)))             {-             It would be more elegant,             if we could pass Arrays around just like Vectors.
src/Synthesizer/LLVM/Plug/Output.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Plug.Output (    T(..),    Default(..),@@ -13,14 +10,14 @@  import qualified Synthesizer.Zip as Zip -import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Tuple as Tuple  import qualified LLVM.Core as LLVM -import Control.Monad (liftM2)+import Control.Applicative (liftA2)  import qualified Synthesizer.LLVM.Storable.Vector as SVU import qualified Data.StorableVector as SV@@ -30,76 +27,59 @@  import Data.Tuple.Strict (zipPair) -import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile) - data T a b =    forall state ioContext parameters.       (Marshal.C parameters, Memory.C state) =>    Cons       (forall r.-       Tuple.ValueOf parameters ->-       a -> state -> LLVM.CodeGenFunction r state)-          -- compute next value-      (forall r.-       Tuple.ValueOf parameters ->-       LLVM.CodeGenFunction r state)-          -- initial state+       MultiValue.T parameters -> a -> state -> LLVM.CodeGenFunction r state)+         -- compute next value+      (forall r. MultiValue.T parameters -> LLVM.CodeGenFunction r state)+         -- initial state       (Int -> IO (ioContext, parameters))-          {- initialization from IO monad-          This is called once per output chunk-          with the number of input samples.-          This number is also the maximum possible number of output samples.-          This will be run within Unsafe.performIO,-          so no observable In/Out actions please!-          -}+         {- initialization from IO monad+         This is called once per output chunk+         with the number of input samples.+         This number is also the maximum possible number of output samples.+         This will be run within Unsafe.performIO,+         so no observable In/Out actions please!+         -}       (Int -> ioContext -> IO b)-          {--          finalization from IO monad, also run within Unsafe.performIO-          The integer argument is the actually produced size of data.-          We must clip the allocated output vectors accordingly.-          -}+         {-+         finalization from IO monad, also run within Unsafe.performIO+         The integer argument is the actually produced size of data.+         We must clip the allocated output vectors accordingly.+         -}   class Default b where-   type Element b :: *+   type Element b    deflt :: T (Element b) b + instance (Default c, Default d) => Default (Zip.T c d) where    type Element (Zip.T c d) = (Element c, Element d)    deflt = split deflt deflt -instance (Storable.C a) => Default (SV.Vector a) where-   type Element (SV.Vector a) = Tuple.ValueOf a-   deflt = storableVector-- split :: T a c -> T b d -> T (a,b) (Zip.T c d) split (Cons nextA startA createA deleteA)       (Cons nextB startB createB deleteB) = Cons-   (\(parameterA, parameterB) (a,b) (sa,sb) ->-      liftM2 (,)-         (nextA parameterA a sa)-         (nextB parameterB b sb))-   (\(parameterA, parameterB) ->-      liftM2 (,)-         (startA parameterA)-         (startB parameterB))-   (\len ->-      liftM2 zipPair-         (createA len)-         (createB len))-   (\len (ca,cb) ->-      liftM2 Zip.Cons-         (deleteA len ca)-         (deleteB len cb))+   (MultiValue.uncurry $ \parameterA parameterB (a,b) (sa,sb) ->+      liftA2 (,) (nextA parameterA a sa) (nextB parameterB b sb))+   (MultiValue.uncurry $ \parameterA parameterB ->+      liftA2 (,) (startA parameterA) (startB parameterB))+   (\len -> liftA2 zipPair (createA len) (createB len))+   (\len (ca,cb) -> liftA2 Zip.Cons (deleteA len ca) (deleteB len cb))  -storableVector ::-   (Storable.C a, Tuple.ValueOf a ~ value) => T value (SV.Vector a)+instance (Storable.C a) => Default (SV.Vector a) where+   type Element (SV.Vector a) = MultiValue.T a+   deflt = storableVector++storableVector :: (Storable.C a) => T (MultiValue.T a) (SV.Vector a) storableVector = Cons-   (const Storable.storeNext)+   (\ _param -> MultiValue.liftM . Storable.storeNext)    return    (\len -> do       vec <- SVB.create len (const $ return ())
+ src/Synthesizer/LLVM/Private.hs view
@@ -0,0 +1,26 @@+module Synthesizer.LLVM.Private where++import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Multi.Value as MultiValue++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Control.Applicative (liftA2)+++unbool :: MultiValue.T Bool -> LLVM.Value Bool+unbool (MultiValue.Cons b) = b++noLocalPtr :: f -> (LLVM.Value (LLVM.Ptr (LLVM.Struct ())) -> f)+noLocalPtr = const++getPairPtrs ::+   LLVM.Value (LLVM.Ptr (LLVM.Struct (a, (b, ())))) ->+   MaybeCont.T r c (LLVM.Value (LLVM.Ptr a), LLVM.Value (LLVM.Ptr b))+getPairPtrs ptr =+   MaybeCont.lift $+   liftA2 (,)+      (LLVM.getElementPtr0 ptr (TypeNum.d0, ()))+      (LLVM.getElementPtr0 ptr (TypeNum.d1, ()))
+ src/Synthesizer/LLVM/Server/CausalPacked/Common.hs view
@@ -0,0 +1,37 @@+module Synthesizer.LLVM.Server.CausalPacked.Common where++import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), Real)++import qualified Synthesizer.LLVM.MIDI.BendModulation as BM++import qualified Data.EventList.Relative.TimeTime as EventListTT++import qualified Numeric.NonNegative.Class as NonNeg++import Prelude hiding (Real)+++-- ToDo: might be moved to event-list package+chopEvents ::+   (NonNeg.C time, Num time) =>+   time ->+   EventListTT.T time body ->+   [EventListTT.T time body]+chopEvents chunkSize =+   let go evs =+          -- splitBeforeTime?+          let (chunk,rest) = EventListTT.splitAtTime chunkSize evs+          in  if EventListTT.duration chunk == 0+                then []+                else chunk : go rest+   in  go+++transposeModulation ::+   (Functor stream) =>+   SampleRate Real ->+   Real ->+   stream (BM.T Real) ->+   stream (BM.T Real)+transposeModulation (SampleRate sampleRate) freq =+   fmap (BM.shift (freq/sampleRate))
src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -32,12 +32,12 @@    frequencyControl, zipEnvelope,    ) where -import qualified Synthesizer.LLVM.Server.Parameter as ParamS import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise)+import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation) import Synthesizer.LLVM.Server.CommonPacked-import Synthesizer.LLVM.Server.Common hiding (Instrument)-import Synthesizer.LLVM.Server.Parameter-         (Number(Number), VectorTime(VectorTime), Signal(Signal))+import Synthesizer.LLVM.Server.Common hiding+         (Instrument, Frequency, Time, Control, transposeModulation)+import Synthesizer.LLVM.Server.Common (Arg(Frequency, Time))  import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.LLVM.Storable.Process as PSt@@ -45,31 +45,31 @@ import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.CausalParameterized.Process (($<))-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&)) import qualified Synthesizer.LLVM.Filter.Universal as UniFilter import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.Moog as Moog-import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp+import qualified Synthesizer.LLVM.Causal.Exponential2 as Exp import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.Helix as Helix+import qualified Synthesizer.LLVM.Causal.Functional as F+import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Wave as WaveL-import qualified Synthesizer.LLVM.Simple.Value as Value-import Synthesizer.LLVM.Simple.Value ((%>), (%<=))+import Synthesizer.LLVM.Causal.Functional (($&), (&|&))+import Synthesizer.LLVM.Causal.Process (($<), ($>), ($<#))  import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.MIDI as MIDIL import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.Causal.Class as CausalClass import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Zip as Zip import qualified Data.EventList.Relative.BodyTime as EventListBT@@ -78,24 +78,31 @@ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV -import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp, (<=*), (>*))++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum +import qualified Control.Applicative.HT as App 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 Control.Applicative (liftA2, liftA3, (<$>))+import Control.Functor.HT (unzip)  import qualified Data.Traversable as Trav+import Data.Semigroup ((<>)) import Data.Monoid (mappend)+import Data.Tuple.HT (mapPair)  import qualified Number.DimensionTerm as DN  import NumericPrelude.Numeric-import NumericPrelude.Base hiding (id, (.))+import NumericPrelude.Base hiding (id, unzip, (.))   type Instrument a sig = SampleRate a -> MIO.Instrument a sig@@ -113,16 +120,24 @@ type PIOId a = PIO.T a a  ++frequencyFromBendModulationPacked ::+   Exp Real ->+   F.T inp (MultiValue.T (BM.T Real)) ->+   F.T inp VectorValue+frequencyFromBendModulationPacked speed fm =+   MIDIL.frequencyFromBendModulationPacked speed $& (BM.unMultiValue <$> fm)+ stereoFrequenciesFromDetuneBendModulation ::-   Param p Real ->-   (FuncP p inp (LLVM.Value Real),-    FuncP p inp (BM.T (LLVM.Value Real))) ->-   FuncP p inp (Stereo.T VectorValue)+   Exp Real ->+   (F.T inp (MultiValue.T Real),+    F.T inp (MultiValue.T (BM.T Real))) ->+   F.T inp (Stereo.T VectorValue) stereoFrequenciesFromDetuneBendModulation speed (detune, freq) =-   CausalP.envelopeStereo $&-      (MIDIL.frequencyFromBendModulationPacked speed $& freq)+   Causal.envelopeStereo $&+      frequencyFromBendModulationPacked speed freq       &|&-      (CausalP.mapSimple (Trav.mapM Serial.upsample) $&+      (Causal.map (fmap Serial.upsample) $&        liftA2 Stereo.cons (one + detune) (one - detune))  @@ -146,12 +161,9 @@ frequencyControl sr =    fmap (flip DN.divToScalar $ frequencyFromSampleRate sr) -takeThreshold ::-   Param.T p Real ->-   CausalP.T p VectorValue VectorValue-takeThreshold =-   CausalPV.takeWhile-      (\threshold y -> threshold %<= Value.lift1 Serial.subsample y)+takeThreshold :: Exp Real -> Causal.T VectorValue VectorValue+takeThreshold threshold =+   Causal.takeWhile (\y -> threshold <=* Serial.subsample y)   type EnvelopeControl =@@ -188,16 +200,16 @@ ping :: IO (Instrument Real Chunk) ping =    fmap (\proc sampleRate vel freq ->-      proc (sampleRate, (vel,freq))+      proc sampleRate vel freq       .       Gate.toStorableVector) $-   CausalP.processIO $-      let vel = number fst-          freq = frequency snd-      in  CausalP.fromSignal $-          SigP.envelope-             (SigPS.exponential2 (timeConst 0.2) (fmap amplitudeFromVelocity vel)) $-          SigPS.osciSimple WaveL.saw zero freq+   CausalRender.run $+   wrapped $ \(Number vel) (Frequency freq) ->+   constant time 0.2 $ \halfLife _sr ->+      Causal.fromSignal $+         SigPS.exponential2 halfLife (amplitudeFromVelocity vel)+         *+         SigPS.osci WaveL.saw zero freq   pingReleaseEnvelope ::@@ -205,38 +217,40 @@        SampleRate Real -> Real ->        PIO.T MIO.GateChunk Chunk) pingReleaseEnvelope =-   liftM2+   liftA2       (\sustain release dec rel sr vel ->          PSt.continuePacked-            (sustain (sr,(dec,vel))+            (sustain sr dec vel              .              Gate.toChunkySize)             (\y ->-               release (sr,(rel,y))+               release sr rel y                .                Gate.allToChunkySize))-      (CausalP.processIO $-       ParamS.withTuple2 $ \(VectorTime decay, Number vel) ->-         CausalP.fromSignal $-         SigPS.exponential2 decay (fmap amplitudeFromVelocity vel))-      (CausalP.processIO $-       ParamS.withTuple2 $ \(ParamS.Time release, Number level) ->-         CausalP.take (fmap round (vectorTime (const 1)))+      (CausalRender.run $+       wrapped $ \(Time decay) (Number vel) (SampleRate _sr) ->+         Causal.fromSignal $+         SigPS.exponential2+            -- FixMe: is division vectorSize correct?+            (decay / fromIntegral vectorSize) (amplitudeFromVelocity vel))+      (CausalRender.run $+       wrapped $ \(Time releaseHL) (Number level) ->+       constant time 1 $ \releaseTime _sr ->+         Causal.take+            (Expr.roundToIntFast $ releaseTime / fromIntegral vectorSize)          .-         CausalP.fromSignal (SigPS.exponential2 release level))+         Causal.fromSignal (SigPS.exponential2 releaseHL level))  pingRelease :: IO (Real -> Real -> Instrument Real Chunk) pingRelease =-   liftM2+   liftA2       (\osci envelope dec rel sr vel freq ->-         osci (sr, freq)+         osci sr freq          .          envelope dec rel sr vel)-      (CausalP.processIO $-         let freq = frequency id-         in  CausalP.envelope-             .-             CausalP.feedFst (SigPS.osciSimple WaveL.saw zero freq))+      (CausalRender.run $+       wrapped $ \(Frequency freq) (SampleRate _sr) ->+         Causal.envelope $> SigPS.osci WaveL.saw zero freq)       pingReleaseEnvelope  @@ -245,27 +259,27 @@    IO (SampleRate Real -> Real ->        PIO.T EnvelopeControl Chunk) pingControlledEnvelope threshold =-   liftM2+   liftA2       (\sustain release sr vel ->          PSt.continuePacked-            (sustain (sr,vel)+            (sustain sr vel              .              Gate.shorten              .              Zip.arrowSecond (arr (halfLifeControl sr . Zip.first)))             (\y ->-             release (sr,y)+             release sr y              <<^              halfLifeControl sr . Zip.second . Zip.second))-      (CausalP.processIO $-         let vel = number id-         in  Exp.causalPackedP-                (fmap amplitudeFromVelocity vel))-      (CausalP.processIO $-         let level = number id-             expo = Exp.causalPackedP level+      (CausalRender.run $+       wrapped $ \(Number vel) (SampleRate _sr) ->+         Exp.causalPacked (amplitudeFromVelocity vel)+            <<^ Exp.unMultiValueParameterPacked)+      (CausalRender.run $+       wrapped $ \(Number level) (SampleRate _sr) ->+         let expo = Exp.causalPacked level <<^ Exp.unMultiValueParameterPacked          in  case threshold of-                Just y -> takeThreshold (pure y) . expo+                Just y -> takeThreshold (Expr.cons y) . expo                 Nothing -> expo)  @@ -282,7 +296,7 @@ pingStereoReleaseFM =    liftA2       (\osc env sr vel freq ->-         osc (sr, ())+         osc sr          .          Zip.arrowSecond             (Zip.arrowSplit@@ -294,28 +308,33 @@                    arr $ halfLifeControl sr)))          .          zipEnvelope (env sr vel))-      (CausalP.processIO-         (CausalP.envelopeStereo+      (CausalRender.run $+       constant frequency 10 $ \speed _sr ->+         (arr Stereo.multiValue           .+          Causal.envelopeStereo+          .           second              (F.withArgs $ \((shape0,shapeDecay),((phase,phaseDecay),fm)) ->-              let shape = CausalP.mapSimple Serial.upsample $& shape0+              let shape = Causal.map Serial.upsample $& shape0                   shapeCtrl =                      1/pi + (shape-1/pi) *-                        (Exp.causalPackedP (1::Param.T p Real) $& shapeDecay)-                  freqs =-                     stereoFrequenciesFromDetuneBendModulation-                        (frequencyConst 10) fm+                        (Exp.causalPacked 1+                              <<^ Exp.unMultiValueParameterPacked+                           $& shapeDecay)+                  freqs = stereoFrequenciesFromDetuneBendModulation speed fm                   expo =-                     (CausalP.mapSimple Serial.upsample $& phase) *-                     (Exp.causalPackedP (1::Param.T p Real) $& phaseDecay)+                     (Causal.map Serial.upsample $& phase) *+                     (Exp.causalPacked 1 <<^ Exp.unMultiValueParameterPacked+                        $& phaseDecay)                   osci ::-                     CausalP.T p+                     Causal.T                         (VectorValue, (VectorValue, VectorValue)) VectorValue                   osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1               in  liftA2 Stereo.cons                      (osci $&  shapeCtrl &|& (expo &|& fmap Stereo.left freqs))-                     (osci $&  shapeCtrl &|& (negate expo &|& fmap Stereo.right freqs)))))+                     (osci $&  shapeCtrl &|&+                                 (negate expo &|& fmap Stereo.right freqs)))))       (pingControlledEnvelope (Just 0.01))  @@ -331,7 +350,7 @@ filterSawStereoFM =    liftA2       (\osc env sr vel freq ->-         osc (sr, ())+         osc sr          .          Zip.arrowSecond             (Zip.arrowSplit@@ -342,33 +361,37 @@                   arr $ transposeModulation sr freq))          .          zipEnvelope (env sr vel))-      (CausalP.processIO-         (CausalP.envelopeStereo+      (CausalRender.run $+       constant frequency 10 $ \speed ->+       constant frequency 100 $ \lowerFreq _sr ->+         (arr Stereo.multiValue           .+          Causal.envelopeStereo+          .           second              (F.withArgs $ \((cutoff,cutoffDecay),fm) ->-              let freqs =-                     stereoFrequenciesFromDetuneBendModulation-                        (frequencyConst 10) fm+              let freqs = stereoFrequenciesFromDetuneBendModulation speed fm                   {- bound control in order to avoid too low resonant frequency,                      which makes the filter instable -}                   expo =-                     takeThreshold (frequencyConst 100) $&-                     (CausalP.mapSimple Serial.upsample $& cutoff) *-                     (Exp.causalPackedP (1::Param.T p Real) $& cutoffDecay)-              in  CausalP.stereoFromMonoControlled+                     takeThreshold lowerFreq $&+                     (Causal.map Serial.upsample $& cutoff) *+                     (Exp.causalPacked 1 <<^ Exp.unMultiValueParameterPacked+                        $& cutoffDecay)+              in  Causal.stereoFromMonoControlled                      (UniFilter.lowpass ^<< CtrlPS.process)                   $&-                  (CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real)-                      (CausalP.mapSimple-                          (UniFilter.parameter (LLVM.valueOf 10)-                           <=<+                  ((Causal.quantizeLift+                     (Causal.map+                          (UniFilter.parameter 10+                           .                            Serial.subsample))+                     $<# (100 / fromIntegral vectorSize :: Real))                    $&                    expo)                   &|&-                  (CausalP.stereoFromMono-                     (CausalPS.osciSimple WaveL.saw $< zero) $&+                  (Causal.stereoFromMono+                     (CausalPS.osci WaveL.saw $< zero) $&                      freqs))))       (pingControlledEnvelope (Just 0.01)) @@ -383,38 +406,94 @@ tineStereoFM =    liftA2       (\osc env sr vel freq ->-         osc (sr, vel)+         osc sr vel          .          (Zip.arrowSecond $ Zip.arrowSecond $           Zip.arrowSecond $             arr $ transposeModulation sr freq)          .          zipEnvelope (env sr vel))-      (CausalP.processIO-         (CausalP.envelopeStereo+      (CausalRender.run $+       wrapped $ \(Number vel) ->+       constant frequency 5 $ \speed ->+       constant time 1 $ \halfLife _sr ->+         (arr Stereo.multiValue           .+          Causal.envelopeStereo+          .           second              (F.withArgs $ \((index0,depth0), fm) ->-              let vel = number id-                  freqs =-                     stereoFrequenciesFromDetuneBendModulation-                        (frequencyConst 5) fm-                  index = CausalP.mapSimple Serial.upsample $& index0-                  depth = CausalP.mapSimple Serial.upsample $& depth0-                  expo =-                     F.fromSignal $-                     SigPS.exponential2 (timeConst 1) (1 + vel)-                  osci freq =-                     CausalPS.osciSimple WaveL.approxSine2 $&-                        expo * depth *-                           (CausalPS.osciSimple WaveL.approxSine2-                            $& zero &|& index*freq)-                        &|&-                        freq-              in  Stereo.liftApplicative osci freqs)))+              let freqs = stereoFrequenciesFromDetuneBendModulation speed fm+                  index = Causal.map Serial.upsample $& index0+                  depth = Causal.map Serial.upsample $& depth0+                  expo = F.fromSignal $ SigPS.exponential2 halfLife (1 + vel)+                  osci indexDepth freq =+                     case unzip indexDepth of+                        (index1,depth1) ->+                           CausalPS.osci WaveL.approxSine2 $&+                              expo * depth1 *+                                 (CausalPS.osci WaveL.approxSine2+                                  $& zero &|& index1*freq)+                              &|&+                              freq+              in  stereoFromMonoControlled osci (index&|&depth) freqs)))       (pingControlledEnvelope (Just 0.01)) +{- |+'Stereo.liftApplicative' specialised to 'T'. +Should be moved to Functional utility module.+(Functional module itself would cause cyclic dependency.)+-}+stereoFromMonoControlled,+      _stereoFromMonoControlledArgs,+      _stereoFromMonoControlledGrounded,+      _stereoFromMonoControlledGuided,+      _stereoFromMonoControlledPrepared,+      _stereoFromMonoControlledPrepared2 ::+   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c) =>+   (Tuple.Undefined a, Tuple.Undefined b, Tuple.Undefined c) =>+   (forall inp0. F.T inp0 c -> F.T inp0 a -> F.T inp0 b) ->+   F.T inp c -> F.T inp (Stereo.T a) -> F.T inp (Stereo.T b)+stereoFromMonoControlled proc ctrl stereo =+   Causal.stereoFromMonoControlled+      (F.compile $ uncurry proc $ unzip $ F.lift id)+   $&+   ctrl &|& stereo++_stereoFromMonoControlledArgs proc ctrl stereo =+   Causal.stereoFromMonoControlled+      (F.withArgs (uncurry proc) <<^ mapPair (F.AnyArg, F.AnyArg))+   $&+   ctrl &|& stereo++_stereoFromMonoControlledGrounded proc ctrl stereo =+   Causal.stereoFromMonoControlled+      (F.withGroundArgs $ \(F.Ground c, F.Ground s) -> proc c s)+   $&+   ctrl &|& stereo++_stereoFromMonoControlledGuided proc ctrl stereo =+   Causal.stereoFromMonoControlled+      (F.withGuidedArgs (F.atom, F.atom) (uncurry proc))+   $&+   ctrl &|& stereo++_stereoFromMonoControlledPrepared proc ctrl stereo =+   Causal.stereoFromMonoControlled+      (F.withPreparedArgs (F.pairArgs F.atomArg F.atomArg) (uncurry proc))+   $&+   ctrl &|& stereo++_stereoFromMonoControlledPrepared2 proc ctrl stereo =+   Causal.stereoFromMonoControlled+      (F.withPreparedArgs2 F.atomArg F.atomArg proc)+   $&+   ctrl &|& stereo+++type RealValue = MultiValue.T Real+ bellNoiseStereoFM ::    IO (SampleRate Real -> Real -> Real ->        PIO.T@@ -426,7 +505,7 @@ bellNoiseStereoFM =    liftA3       (\osc env envInf sr vel freq ->-         osc (sr, ())+         osc sr          .          (Zip.arrowSecond $ Zip.arrowSecond $           Zip.arrowSecond $@@ -450,36 +529,40 @@                       (envInf sr (vel*4)                        .                        Zip.arrowSecond (shortenTimes 7)))))-      (CausalP.processIO+      (CausalRender.run $+       constant noiseReference 20000 $ \noiseRef ->+       constant frequency 5 $ \speed _sr ->          (F.withArgs $ \((env1,(env4,env7)),((noiseAmp0,noiseReson),fm)) ->-          let noiseAmp = CausalP.mapSimple Serial.upsample $& noiseAmp0+          let noiseAmp = Causal.map Serial.upsample $& noiseAmp0+              noiseParam ::+                  Causal.T+                     (RealValue, RealValue)+                     (Moog.Parameter TypeNum.D8 RealValue)               noiseParam =-                 CausalP.quantizeLift-                    (100 / fromIntegral vectorSize :: Param.T p Real)-                    (CausalP.zipWithSimple (Moog.parameter TypeNum.d8))-              noise =-                 F.fromSignal (SigPS.noise 12 (noiseReference 20000))-              freqs =-                 stereoFrequenciesFromDetuneBendModulation-                    (frequencyConst 5) fm+                 Causal.quantizeLift+                       (Causal.zipWith (Moog.parameter TypeNum.d8))+                    $<# (100 / fromIntegral vectorSize :: Real)+              noise = F.fromSignal (SigPS.noise 12 noiseRef)+              freqs = stereoFrequenciesFromDetuneBendModulation speed fm               osci amp env n =                  CausalPS.amplifyStereo amp $&-                 CausalP.envelopeStereo $&+                 Causal.envelopeStereo $&                  env &|&-                 (CausalP.stereoFromMono-                    (CausalPS.osciSimple WaveL.approxSine4 $< zero)+                 (Causal.stereoFromMono+                    (CausalPS.osci WaveL.approxSine4 $< zero)                   $&                   CausalPS.amplifyStereo n                   $&                   freqs)-          in  (CausalP.envelopeStereo $&+          in Stereo.multiValue <$>+              (Causal.envelopeStereo $&                  (noiseAmp * env1)                  &|&                  Stereo.liftApplicative                     (\freq ->                        CtrlPS.process $&                           (noiseParam $& noiseReson &|&-                           (CausalP.mapSimple Serial.subsample $& freq))+                           (Causal.map Serial.subsample $& freq))                           &|&                           noise)                     freqs)@@ -495,55 +578,54 @@    IO (SampleRate Real -> Real ->        PIO.T EnvelopeControl Chunk) stringControlledEnvelope =-   liftM3+   liftA3       (\attack sustain release sr vel ->          let amp = amplitudeFromVelocity vel          in  PSt.continuePacked-                (mappend-                    (attack (sr,amp))-                    {- we could also feed the sustain process-                       with a signal with sample type () -}-                    (sustain (sr,amp))+                ((attack sr amp <>+                  {- we could also feed the sustain process+                     with a signal with sample type () -}+                  sustain sr amp)                  .                  Gate.shorten                  .                  Zip.arrowSecond (arr (halfLifeControl sr . Zip.first)))                 (\y ->-                 release (sr,y)+                 release sr y                  <<^                  halfLifeControl sr . Zip.second . Zip.second))-      (CausalP.processIO $-         let amp = number id-         in  CausalP.fromSignal (SigPS.constant amp)+      (CausalRender.run $+       wrapped $ \(Number amp) (SampleRate _sr) ->+             Causal.fromSignal (SigPS.constant amp)              --             takeThreshold (1e-4 :: Param.T p Real)+             takeThreshold 1e-4              .-             Exp.causalPackedP amp)-      (CausalP.processIO $-         let amp = number id-         in  CausalP.fromSignal (SigPS.constant amp))-      (CausalP.processIO $-         let level = number id-         in  takeThreshold (0.01 :: Param.T p Real)+             Exp.causalPacked amp <<^ Exp.unMultiValueParameterPacked)+      (CausalRender.run $+       wrapped $ \(Number amp) (SampleRate _sr) ->+             Causal.fromSignal (SigPS.constant amp))+      (CausalRender.run $+       wrapped $ \(Number level) (SampleRate _sr) ->+             takeThreshold 0.01              .-             Exp.causalPackedP level)+             Exp.causalPacked level <<^ Exp.unMultiValueParameterPacked)   windCore ::-   F.T (SampleRate Real, p) a (LLVM.Value Real) ->-   F.T (SampleRate Real, p) a (BM.T (LLVM.Value Real)) ->-   F.T (SampleRate Real, p) a (Stereo.T VectorValue)+   F.T a (MultiValue.T Real) ->+   F.T a (MultiValue.T (BM.T Real)) ->+   SampleRate (Exp Real) ->+   F.T a (Stereo.T VectorValue) windCore reson fm =+   constant frequency 0.2 $ \speed sr ->    let modu =-          CausalP.mapSimple Serial.subsample $&+          Causal.map Serial.subsample $&           (fmap (`asTypeOf` (undefined :: VectorValue)) $-           (MIDIL.frequencyFromBendModulationPacked-              (frequencyConst 0.2) $& fm))-   in  CausalP.stereoFromMonoControlled CtrlPS.process $&-          (CausalP.zipWithSimple (Moog.parameter TypeNum.d8) $&-             reson &|& modu)+           frequencyFromBendModulationPacked speed fm)+   in  Causal.stereoFromMonoControlled CtrlPS.process $&+          (Causal.zipWith (Moog.parameter TypeNum.d8) $&  reson &|& modu)           &|&-          F.fromSignal stereoNoise+          F.fromSignal (stereoNoise sr)  wind ::    IO (SampleRate Real -> Real -> Real ->@@ -553,17 +635,16 @@ wind =    liftA2       (\osc env sr vel freq ->-         osc (sr, ())+         osc sr          .          (Zip.arrowSecond $ Zip.arrowSecond $             arr $ transposeModulation sr freq)          .          zipEnvelope (env sr vel))-      (CausalP.processIO-         (F.withArgs $ \(env,(reson,fm)) ->-              CausalP.envelopeStereo $&-                 env &|&-                 windCore reson fm))+      (CausalRender.run $ \sr ->+         F.withArgs $ \(env,(reson,fm)) ->+            Stereo.multiValue <$>+            Causal.envelopeStereo $& env &|& windCore reson fm sr)       stringControlledEnvelope  @@ -577,35 +658,37 @@ windPhaser =    liftA2       (\osc env sr vel freq ->-         osc (sr, ())+         osc sr          .          (Zip.arrowSecond $ Zip.arrowSecond $           Zip.arrowSplit-             (arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) .+             (arr $ fmap (Allpass.flangerParameter TypeNum.d8) .                     frequencyControl sr)              (Zip.arrowSecond $               arr $ transposeModulation sr freq))          .          zipEnvelope (env sr vel))-      (CausalP.processIO+      (CausalRender.run $ \sr ->          (F.withArgs $ \(env,(phaserMix0,(phaserFreq,(reson,fm)))) ->-          let phaserMix = CausalP.mapSimple Serial.upsample $& phaserMix0-              noise = windCore reson fm+          let phaserMix = Causal.map Serial.upsample $& phaserMix0+              noise = windCore reson fm sr -          in  CausalP.envelopeStereo $&+          in Stereo.multiValue <$>+              Causal.envelopeStereo $&                  env &|&-                 ((CausalP.envelopeStereo $& (1 - phaserMix) &|& noise)+                 ((Causal.envelopeStereo $& (1 - phaserMix) &|& noise)                   +-                  (CausalP.envelopeStereo $&+                  (Causal.envelopeStereo $&                      phaserMix &|&                      (Stereo.arrowFromMonoControlled CtrlPS.process $&-                        phaserFreq &|& noise)))))+                        (Allpass.cascadeParameterUnMultiValue <$> phaserFreq)+                        &|& noise)))))       stringControlledEnvelope   phaserOsci ::-   (Param.T p Real -> Param.T p Real -> CausalP.T p a VectorValue) ->-   CausalP.T p a (Stereo.T VectorValue)+   (Exp Real -> Exp Real -> Causal.T a VectorValue) ->+   Causal.T a (Stereo.T VectorValue) phaserOsci osci =    CausalPS.amplifyStereo 0.25    .@@ -632,27 +715,28 @@ softStringShapeCore wave =    liftA2       (\osc env sr vel freq ->-         osc (sr, ())+         osc sr          .          (Zip.arrowSecond $ Zip.arrowSecond $           Zip.arrowSecond $             arr $ transposeModulation sr freq)          .          zipEnvelope (env sr vel))-      (CausalP.processIO-         (CausalP.envelopeStereo+      (CausalRender.run $+       constant frequency 5 $ \speed _sr ->+         (arr Stereo.multiValue           .+          Causal.envelopeStereo+          .           second              (F.withArgs $ \(shape0,(det0,fm)) ->-              let det = CausalP.mapSimple Serial.upsample $& det0-                  shape = CausalP.mapSimple Serial.upsample $& shape0-                  modu =-                     MIDIL.frequencyFromBendModulationPacked-                        (frequencyConst 5) $& fm+              let det = Causal.map Serial.upsample $& det0+                  shape = Causal.map Serial.upsample $& shape0+                  modu = frequencyFromBendModulationPacked speed fm                   osci ::-                     Param.T (mod,fm) Real ->-                     Param.T (mod,fm) Real ->-                     CausalP.T (mod,fm)+                     Exp Real ->+                     Exp Real ->+                     Causal.T                         (VectorValue,                               {- wave shape parameter -}                          (VectorValue, VectorValue)@@ -662,9 +746,9 @@                      CausalPS.shapeModOsci wave                      .                      second-                        (CausalP.feedFst (SigPS.constant p)+                        (CausalClass.feedFst (SigPS.constant p)                          .-                         CausalP.envelope+                         Causal.envelope                          .                          first (one + CausalPS.amplify d)) @@ -709,51 +793,51 @@ fmStringStereoFM =    liftA2       (\osc env sr vel freq ->-         osc (sr, ())+         osc sr          .          (Zip.arrowSecond $ Zip.arrowSecond $           Zip.arrowSecond $             arr $ transposeModulation sr freq)          .          zipEnvelope (env sr vel))-      (CausalP.processIO+      (CausalRender.run $+       constant frequency 5 $ \speed _sr ->          (F.withArgs $ \(env,((depth0,shape0),(det0,fm))) ->-          let det = CausalP.mapSimple Serial.upsample $& det0-              shape = CausalP.mapSimple Serial.upsample $& shape0+          let det = Causal.map Serial.upsample $& det0+              shape = Causal.map Serial.upsample $& shape0               depth =-                 CausalP.envelope $&+                 Causal.envelope $&                     env &|&-                    (CausalP.mapSimple Serial.upsample $& depth0)-              modu =-                 MIDIL.frequencyFromBendModulationPacked-                    (frequencyConst 5) $& fm+                    (Causal.map Serial.upsample $& depth0)+              modu = frequencyFromBendModulationPacked speed fm                osci ::-                 Param.T (mod,fm) Real ->-                 Param.T (mod,fm) Real ->-                 CausalP.T (mod,fm)+                 Exp Real ->+                 Exp Real ->+                 Causal.T                     ((VectorValue, VectorValue)                           {- phase modulation depth, modulator distortion -},                      (VectorValue, VectorValue)                           {- detune, frequency modulation -})                     VectorValue               osci p d =-                 CausalPS.osciSimple WaveL.approxSine2+                 CausalPS.osci WaveL.approxSine2                  .-                 ((CausalP.envelope+                 ((Causal.envelope                   .                   second                      (CausalPS.shapeModOsci WaveL.rationalApproxSine1-                        . second (CausalP.feedFst (SigPS.constant p)))+                        . second (CausalClass.feedFst (SigPS.constant p)))                   <<^                   (\((dp, ds), f) -> (dp, (ds, f))))                   &&& arr snd)                  .                  second-                    (CausalP.envelope .+                    (Causal.envelope .                      first (one + CausalPS.amplify d)) -          in  CausalP.envelopeStereo $&+          in  Stereo.multiValue <$>+              Causal.envelopeStereo $&                  env &|&                  (phaserOsci osci $&  (depth &|& shape) &|& (det &|& modu))))       stringControlledEnvelope@@ -775,13 +859,20 @@              Zip.arrowSecond                 ((id :: PIOId StereoChunk)                  .-                 freqMod (sr, ())+                 freqMod sr                  .                  (Zip.arrowSecond $ arr $                     transposeModulation sr (freq * Sample.period pos))))-      (CausalP.processIO (CausalP.stereoFromMono resamplingProc))-      (CausalP.processIO-         (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))+      (CausalRender.run $ \sr (amp, smp) ->+         Stereo.multiValue+         ^<<+         Causal.stereoFromMono (resamplingProc sr (amp, smp))+         <<^+         Stereo.unMultiValue)+      (CausalRender.run $+       constant frequency 3 $ \speed _sr ->+         fmap Stereo.multiValue $+         F.withArgs $ stereoFrequenciesFromDetuneBendModulation speed)   {- |@@ -800,12 +891,13 @@              Zip.arrowSecond                 ((id :: PIOId Chunk)                  .-                 freqMod (sr, ())+                 freqMod sr                  .                  (arr $ transposeModulation sr (freq * Sample.period pos))))-      (CausalP.processIO resamplingProc)-      (CausalP.processIO-         (MIDIL.frequencyFromBendModulationPacked (frequencyConst 3)))+      (CausalRender.run resamplingProc)+      (CausalRender.run $+       constant frequency 3 $ \speed _sr ->+         F.withArgs $ frequencyFromBendModulationPacked speed)  {- We split the frequency modulation signal@@ -815,14 +907,14 @@ -} assembleParts ::    (CutG.Transform a, CutG.Transform b) =>-   ((SampleRate Real, (Real, SVL.Vector Real)) -> PIO.T a b) ->+   (SampleRate Real -> (Real, SVL.Vector Real) -> PIO.T a b) ->    Sample.T -> SampleRate Real -> Real ->    PIO.T (Zip.T (Gate.Chunk gate) a) b assembleParts osc smp sr vel =    let pos = Sample.positions smp        amp = 2 * amplitudeFromVelocity vel        (attack, sustain, release) = Sample.parts smp-       osci smpBody = osc (sr, (amp, smpBody))+       osci smpBody = osc sr (amp, smpBody)    in  mappend           (osci              (attack `SigSt.append`@@ -832,22 +924,20 @@           (osci release <<^ Zip.second)  resamplingProc ::-   CausalP.T-      (SampleRate Real, (Real, SigSt.T Real))-      VectorValue VectorValue-resamplingProc =-   let amp = number fst-       smp = signal snd-   in  CausalPS.amplify amp+   SampleRate (Exp Real) ->+   (Exp Real, Sig.T (MultiValue.T Real)) ->+   Causal.T VectorValue VectorValue+resamplingProc _sr (amp, smp) =+       CausalPS.amplify amp        .        CausalPS.pack-          (CausalP.frequencyModulationLinear+          (Causal.frequencyModulationLinear              {--             (SigP.fromStorableVector $+             (Sig.fromStorableVector $                 fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp)              -}-             (SigP.fromStorableVectorLazy smp)-             {- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -})+             smp+             {- (Sig.osci WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -})  helixSound ::    IO (Sample.T ->@@ -857,7 +947,7 @@               (Zip.T (Control Real) DetuneBendModControl))           StereoChunk) helixSound =-   liftM4+   App.lift4       (\helix zigZag integrate freqMod smp sr vel freq ->          let pos = Sample.positions smp              amp = 2 * amplitudeFromVelocity vel@@ -875,16 +965,17 @@                 (fromIntegral $ Sample.start pos,                  fromIntegral $ Sample.loopStart pos,                  fromIntegral $ Sample.loopLength pos)-         in  helix (sr, ((amp, Sample.period pos), Sample.body smp))+         in  helix sr amp (Sample.period pos)+                (Render.buffer $ SV.concat $ SVL.chunks $ Sample.body smp)              .              Zip.arrowFirstShorten                 (mappend-                    (zigZag (sr, poss) . Gate.shorten)-                    (integrate (sr, (releaseStart, releaseStop))+                    (zigZag sr poss . Gate.shorten)+                    (integrate sr (releaseStart, releaseStop)                         <<^ Zip.second))              .              Zip.arrowSecond-                (freqMod (sr, ())+                (freqMod sr                  .                  (Zip.arrowSecond $ arr $ transposeModulation sr freq))              .@@ -893,52 +984,56 @@       makeHelix       makeZigZag       makeIntegrate-      (CausalP.processIO-         (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))+      (CausalRender.run $+       constant frequency 3 $ \speed _sr ->+         fmap Stereo.multiValue $+         F.withArgs $ stereoFrequenciesFromDetuneBendModulation speed)  makeHelix ::-   IO ((SampleRate Real, ((Real, Real), SigSt.T Real)) ->+   IO (SampleRate Real -> Real -> Real -> Render.Buffer Real ->        PIO.T (Zip.T Chunk StereoChunk) StereoChunk) makeHelix =-   CausalP.processIO $-   ParamS.withTuple2 $-      \((Number amp, Number per), Signal smp) ->+   CausalRender.run $+   wrapped $+      \(Number amp) (Number per) (SampleRate _sr) smp ->+           arr Stereo.multiValue+           .            CausalPS.amplifyStereo amp            .-           CausalP.stereoFromMono+           Causal.stereoFromMono               (Helix.staticPacked                   Interpolation.linear                   Interpolation.linear-                  (fmap round per) per-                  (fmap (SV.concat . SVL.chunks) smp)+                  (Expr.roundToIntFast per) per+                  smp                .                second (CausalPS.osciCore $< 0))            .-           arr (\(shape, freq) -> fmap ((,) shape) freq)+           arr (\(shape, freq) -> (,) shape <$> Stereo.unMultiValue freq)  makeZigZag ::-   IO ((SampleRate Real, (Real, Real, Real)) ->+   IO (SampleRate Real -> (Real, Real, Real) ->        PIO.T (Control Real) Chunk) makeZigZag =-   CausalP.processIO $-   ParamS.withTuple2 $-      \(Number start, Number loopStart, Number loopLength) ->+   CausalRender.run $+   wrapped $+      \(Number start, Number loopStart, Number loopLength) (SampleRate _sr) ->          CausalPS.raise start          .          -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)          Helix.zigZagLongPacked (loopStart-start) loopLength          .-         CausalP.mapSimple Serial.upsample+         Causal.map Serial.upsample  makeIntegrate ::-   IO ((SampleRate Real, (Real, Real)) ->+   IO (SampleRate Real -> (Real, Real) ->        PIO.T (Control Real) Chunk) makeIntegrate =-   CausalP.processIO $-   ParamS.withTuple2 $-      \(Number start, Number stop) ->-         CausalPV.takeWhile (\s v ->  s %> Value.lift1 Serial.subsample v) stop+   CausalRender.run $+   wrapped $+      \(Number start, Number stop) (SampleRate _sr) ->+         Causal.takeWhile (\v -> stop >* Serial.subsample v)          .          CausalPS.integrate start          .-         CausalP.mapSimple Serial.upsample+         Causal.map Serial.upsample
src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs view
@@ -4,7 +4,7 @@ The Instruments in this module have the same causal arrow interface as the ones in "Synthesizer.LLVM.Server.CausalPacked.Instrument", but here we use the higher level interface-of the "Synthesizer.LLVM.CausalParameterized.FunctionalPlug" module.+of the "Synthesizer.LLVM.Causal.FunctionalPlug" module. -} module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug (    tineStereoFM,@@ -17,55 +17,54 @@           pingControlledEnvelope,           stringControlledEnvelope,           reorderEnvelopeControl)-import Synthesizer.LLVM.Server.CommonPacked (-          Param, VectorValue)+import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation)+import Synthesizer.LLVM.Server.CommonPacked (VectorValue) import Synthesizer.LLVM.Server.Common (-          SampleRate, Real,-          frequencyConst, timeConst,-          number, transposeModulation)+          SampleRate, expSampleRate, Real,+          Arg(Number), wrapped,+          constant, frequency, time)  import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&)) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix-import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.Helix as Helix+import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Wave as WaveL+import Synthesizer.LLVM.Causal.FunctionalPlug (($&), (&|&))  import qualified Synthesizer.LLVM.MIDI.BendModulation as BM import qualified Synthesizer.LLVM.MIDI as MIDIL import qualified Synthesizer.Zip as Zip -import qualified LLVM.DSL.Parameter as Param-import qualified LLVM.Core as LLVM+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp) -import qualified Data.Traversable as Trav-import Control.Category (id, (.))-import Control.Applicative (liftA2)+import qualified LLVM.Extra.Multi.Value as MultiValue +import Control.Category ((.))+import Control.Applicative (liftA2, (<$>))+ import NumericPrelude.Numeric import NumericPrelude.Base hiding (id, (.))  -type FuncP pp pl = FP.T pp (SampleRate Real, pl)-- stereoFrequenciesFromDetuneBendModulation ::-   Param pl Real ->-   (FuncP pp pl inp (LLVM.Value Real),-    FuncP pp pl inp (BM.T (LLVM.Value Real))) ->-   FuncP pp pl inp (Stereo.T VectorValue)+   Exp Real ->+   (FP.T p inp (MultiValue.T Real),+    FP.T p inp (MultiValue.T (BM.T Real))) ->+   FP.T p inp (Stereo.T VectorValue) stereoFrequenciesFromDetuneBendModulation speed (detune, freq) =-   CausalP.envelopeStereo $&-      (MIDIL.frequencyFromBendModulationPacked speed $& freq)+   Causal.envelopeStereo $&+      (MIDIL.frequencyFromBendModulationPacked speed $&+         (BM.unMultiValue <$> freq))       &|&-      (CausalP.mapSimple (Trav.mapM Serial.upsample) $&+      (Causal.map (fmap Serial.upsample) $&        liftA2 Stereo.cons (one + detune) (one - detune))  tineStereoFM ::@@ -84,27 +83,30 @@          Zip.arrowFirstShorten (env sr vel)          .          reorderEnvelopeControl)-      (FP.withArgs $ \(env, ((index0,depth0), (detune,fm))) ->-         let vel = number id-             freqs =+      (FP.withArgs $ \(env, ((index0,depth0), (detune,fm))) pl ->+       (\f -> case Expr.unzip pl of (sr,vel) -> f (expSampleRate sr) vel) $+       wrapped $ \(Number vel) ->+       constant time 1 $ \halfLife ->+       constant frequency 5 $ \speed _sr ->+         let freqs =                 stereoFrequenciesFromDetuneBendModulation-                   (frequencyConst 5)+                   speed                    (FP.plug detune,-                    FP.plug $ liftA2 (uncurry transposeModulation) FP.askParameter fm)-             index = CausalP.mapSimple Serial.upsample $& FP.plug index0-             depth = CausalP.mapSimple Serial.upsample $& FP.plug depth0-             expo =-                FP.fromSignal $-                SigPS.exponential2 (timeConst 1) (1 + vel)+                    FP.plug $+                      liftA2 (uncurry transposeModulation) FP.askParameter fm)+             index = Causal.map Serial.upsample $& FP.plug index0+             depth = Causal.map Serial.upsample $& FP.plug depth0+             expo = FP.fromSignal $ SigPS.exponential2 halfLife (1 + vel)              osci freq =-                CausalPS.osciSimple WaveL.approxSine2 $&+                CausalPS.osci WaveL.approxSine2 $&                    expo * depth *-                      (CausalPS.osciSimple WaveL.approxSine2+                      (CausalPS.osci WaveL.approxSine2                        $& zero &|& index*freq)                    &|&                    freq-         in  CausalP.envelopeStereo $&-                FP.plug env &|& Stereo.liftApplicative osci freqs)+         in fmap Stereo.multiValue $+            Causal.envelopeStereo $&+               FP.plug env &|& Stereo.liftApplicative osci freqs)       (pingControlledEnvelope (Just 0.01))  @@ -117,30 +119,34 @@ helixNoise =    liftA2       (\osc env sr vel freq ->-         osc (sr, freq) (sr, vel)+         osc (sr, freq) sr          .          Zip.arrowFirstShorten (env sr vel)          .          reorderEnvelopeControl)-      (FP.withArgs $ \(env, (speed0, (detune,fm))) ->+      (FP.withArgs $ \(env, (speed0, (detune,fm))) sr ->+       (\f -> f (expSampleRate sr)) $+       constant frequency 5 $ \modSpeed _sr ->          let freqs =                 stereoFrequenciesFromDetuneBendModulation-                   (frequencyConst 5)+                   modSpeed                    (FP.plug detune,-                    FP.plug $ liftA2 (uncurry transposeModulation) FP.askParameter fm)-             speed = CausalP.mapSimple Serial.upsample $& FP.plug speed0-         in  CausalP.envelopeStereo $&-                FP.plug env &|& Stereo.liftApplicative (helixOsci speed) freqs)+                    FP.plug $+                      liftA2 (uncurry transposeModulation) FP.askParameter fm)+             speed = Causal.map Serial.upsample $& FP.plug speed0+         in fmap Stereo.multiValue $+            Causal.envelopeStereo $&+               FP.plug env &|& Stereo.liftApplicative (helixOsci speed) freqs)       stringControlledEnvelope  helixOsci ::-   FP.T pp pl inp VectorValue ->-   FP.T pp pl inp VectorValue ->-   FP.T pp pl inp VectorValue+   FP.T pp inp VectorValue ->+   FP.T pp inp VectorValue ->+   FP.T pp inp VectorValue helixOsci speed freq =    CausalPS.pack       (Helix.dynamicLimited Interpolation.cubic Interpolation.cubic-          64 (64 :: Param.T p Real) (SigP.noise 66 0.2))+          64 (64 :: Exp Real) (Sig.noise 66 0.2))    $&    speed &|&    (CausalPS.osciCore $& 0 &|& freq)
src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs view
@@ -22,25 +22,29 @@           (StereoChunk, Control, Frequency, frequencyControl,            WithEnvelopeControl, zipEnvelope,            stringControlledEnvelope, pingControlledEnvelope)-import Synthesizer.LLVM.Server.CommonPacked (VectorValue)+import Synthesizer.LLVM.Server.CommonPacked (Vector) import Synthesizer.LLVM.Server.Common-          (SampleRate(SampleRate), Real, parameter, noiseReference, frequency)+          (SampleRate(SampleRate), Real, wrapped,+           Arg(Frequency), constant, noiseReference) import qualified Synthesizer.LLVM.Server.SampledSound as Sample  import qualified Synthesizer.MIDI.CausalIO.Process as MIO import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*))-import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&)) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR-import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP+import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import Synthesizer.LLVM.Causal.FunctionalPlug (($&), (&|&))+import Synthesizer.LLVM.Causal.Process (($*), ($<), ($>))  import qualified Synthesizer.Zip as Zip import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg@@ -57,12 +61,12 @@ import qualified Data.StorableVector as SV import qualified Data.Map as Map ; import Data.Map (Map) -import qualified LLVM.Core as LLVM+import qualified LLVM.Extra.Multi.Value as MultiValue  import qualified System.Path as Path import System.Path ((</>), (<.>)) -import Control.Arrow (arr, second, (^<<), (***))+import Control.Arrow (arr, second, (^<<), (<<^), (***)) import Control.Category ((.)) import Control.Applicative (pure, liftA, liftA3, (<$>), (<*>)) @@ -111,19 +115,23 @@          case formants p of             Nothing -> arr $ const SV.empty             Just fs ->-               filt (sr, fs)+               filt sr fs                .                Gate.shorten)-      (CausalP.processIO-         (CausalP.stereoFromMono+      (CausalRender.run $+       wrapped $ \(Frequency low, Frequency high) (SampleRate _sr) ->+         Stereo.multiValue+         ^<<+         Causal.stereoFromMono              (let lowpass q f =                      UniFilter.bandpass                      ^<<                      CtrlPS.process                      $<-                     SigP.constant-                        (UniFilter.parameter . Pole q ^<< frequency f)-              in  lowpass 100 fst + lowpass 20 snd)))+                     Sig.constant (UniFilter.parameter $ Pole q f)+              in  lowpass 100 low + lowpass 20 high)+         <<^+         Stereo.unMultiValue)  formants :: VoiceMsg.Pitch -> Maybe (Real, Real) formants p =@@ -146,15 +154,16 @@    IO (Map VoiceMsg.Pitch (SV.Vector Real) -> VowelSynth) vowelMask =    liftA-      (\filt dict sr p ->+      (\filt dict _sr p ->          case Map.lookup p dict of             Nothing -> arr $ const SV.empty-            Just mask ->-               filt (sr, mask)-               .-               Gate.shorten)-      (CausalP.processIO-         (CausalP.stereoFromMono (FiltNR.convolvePacked (parameter id))))+            Just mask -> filt (Render.buffer mask) . Gate.shorten)+      (CausalRender.run $ \mask ->+         Stereo.multiValue+         ^<<+         Causal.stereoFromMono (FiltNR.convolvePacked mask)+         <<^+         Stereo.unMultiValue)   type@@ -183,53 +192,57 @@          case Map.lookup p dict of             Nothing -> arr $ const SV.empty             Just (typ, mask) ->+               let maskBuf = Render.buffer mask in                case typ of                   Filtered env carrier ->                      (case carrier of-                        Voiced -> filt (sr, mask)-                        Unvoiced -> filtNoise (sr, mask) . arr Zip.first+                        Voiced -> filt maskBuf+                        Unvoiced -> filtNoise sr maskBuf . arr Zip.first                         Rasp ->-                           filtRasp (sr, (mask,+                           filtRasp maskBuf $                               case sr of                                  SampleRate r ->                                     SVL.cycle $ SVL.take (round $ r/20) $                                     CtrlG.exponential SigG.defaultLazySize-                                       (r/40) 1)))+                                       (r/40) 1)                      .                      zipEnvelope                         (case env of                            Continuous -> contEnv sr vel                            Percussive -> percEnv sr vel)                   Sampled ->-                     smp (sr, SVL.fromChunks $ repeat mask)+                     smp (SVL.fromChunks $ repeat mask)                      .                      arr Zip.first                      .                      zipEnvelope (contEnv sr vel))-   <*> CausalP.processIO-         (CausalP.envelopeStereo+   <*> (CausalRender.run $ \mask ->+         Stereo.multiValue <$>+          Causal.envelopeStereo           .           second-             (CausalP.stereoFromMono (FiltNR.convolvePacked (parameter id))))-   <*> CausalP.processIO-         (CausalP.envelopeStereo+             (Causal.stereoFromMono (FiltNR.convolvePacked mask)+                  <<^ Stereo.unMultiValue))+   <*> (CausalRender.run $ \mask env ->+         Stereo.multiValue <$>+          Causal.envelopeStereo           .-          ((CausalP.envelope-              $< SigPS.pack (SigP.fromStorableVectorLazy (parameter snd)))+          ((Causal.envelope $< SigPS.pack env)            ***-           CausalP.stereoFromMono (FiltNR.convolvePacked (parameter fst))))-   <*> CausalP.processIO-         (CausalP.envelopeStereo $>+           (Causal.stereoFromMono (FiltNR.convolvePacked mask)+               <<^ Stereo.unMultiValue)))+   <*> (CausalRender.run $+        constant noiseReference 1e7 $ \noiseRef _sr mask ->+         Stereo.multiValue <$>+         Causal.envelopeStereo $>              traverse                 (\seed ->-                   FiltNR.convolvePacked (parameter id) $*-                   (SigPS.noise seed $ noiseReference 1e7))+                   FiltNR.convolvePacked mask $* SigPS.noise seed noiseRef)                 (Stereo.cons 42 23))-   <*> CausalP.processIO-         (let smp = parameter id-          in  pure ^<<-              (CausalP.envelope $>-                 (SigPS.pack $ SigP.fromStorableVectorLazy smp)))+   <*> (CausalRender.run $ \smp ->+         (\x -> Stereo.consMultiValue x x)+         ^<<+         (Causal.envelope $> SigPS.pack smp))    <*> stringControlledEnvelope    <*> pingControlledEnvelope (Just 0.01) @@ -422,8 +435,9 @@ plugUniFilterParameter ::    Input a (Control Real) ->    Input a (Control Frequency) ->-   FP.T (SampleRate Real) pl a (UniFilter.Parameter (LLVM.Value Real))+   FP.T (SampleRate Real) a (UniFilter.Parameter (MultiValue.T Real)) plugUniFilterParameter reson freq =+   fmap UniFilterL.unMultiValueParameter $    FP.plug $    liftA3       (\resonChunk freqChunk sr ->@@ -441,16 +455,17 @@    (Input inp (Control Real),       (Input inp (Control Real), Input inp (Control Frequency))) ->    Input inp StereoChunk ->-   FP.T (SampleRate Real) pl inp (Stereo.T VectorValue)+   FP.T (SampleRate Real) inp (MultiValue.T (Stereo.T Vector)) singleFormant (amp, (reson, freq)) x =-   CausalP.envelopeStereo $&-      (CausalP.mapSimple Serial.upsample $& FP.plug amp)+   Stereo.multiValue <$>+   Causal.envelopeStereo $&+      (Causal.map Serial.upsample $& FP.plug amp)       &|&-      (CausalP.stereoFromMonoControlled+      (Causal.stereoFromMonoControlled            (UniFilter.bandpass ^<< CtrlPS.process) $&          plugUniFilterParameter reson freq          &|&-         FP.plug x)+         (Stereo.unMultiValue <$> FP.plug x))  filterFormant ::    IO (SampleRate Real ->@@ -459,8 +474,8 @@           StereoChunk) filterFormant =    liftA-      (\filt sr -> filt sr (sr, ()))-      (FP.withArgs $ \(fmt, x) -> singleFormant fmt x)+      (\filt sr -> filt sr ())+      (FP.withArgs $ \(fmt, x) _unit -> singleFormant fmt x)  filterFormants ::    IO (SampleRate Real ->@@ -473,6 +488,6 @@              StereoChunk) filterFormants =    liftA-      (\filt sr -> filt sr (sr, ()))-      (FP.withArgs $ \((fmt0, (fmt1, (fmt2, (fmt3, fmt4)))), x) ->+      (\filt sr -> filt sr ())+      (FP.withArgs $ \((fmt0, (fmt1, (fmt2, (fmt3, fmt4)))), x) _unit ->          foldl1 (+) $ map (flip singleFormant x) [fmt0, fmt1, fmt2, fmt3, fmt4])
src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Main where -import Synthesizer.LLVM.Server.Common (Real)+import Synthesizer.LLVM.Server.Common (Real, pioApply)  import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Sound.Sox.Write as SoxWrite@@ -11,13 +11,18 @@ import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D -import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Causal.Controlled as Ctrl+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR-import Synthesizer.LLVM.Causal.Process (($*), ($<), ($<#))+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import Synthesizer.LLVM.Causal.Process (($*), ($<)) +import qualified LLVM.DSL.Expression as Expr+ import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder import Synthesizer.Plain.Filter.Recursive (Pole(Pole))@@ -35,8 +40,8 @@ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV -import Control.Arrow (arr, (<<<), (^<<))-import Control.Category ((.), id)+import Control.Arrow ((<<<), (^<<))+import Control.Category ((.)) import Control.Applicative ((<$>))  import Control.Functor.HT (void)@@ -48,7 +53,9 @@ import Data.Maybe (catMaybes) import Data.Tuple.HT (mapSnd) import Data.Ord.HT (comparing)-import Data.Monoid (mempty, mappend)+import Data.Semigroup ((<>))+import Data.Monoid (mempty)+import Data.Word (Word)  import qualified System.Path.PartClass as PathClass import qualified System.Path as Path@@ -144,20 +151,20 @@    (UniFilter.lowpass, Pole 2 3000, 0.6) :    [] -synthesis :: IO (SVL.ChunkSize -> () -> SVL.Vector Real)+synthesis :: IO (SVL.ChunkSize -> SVL.Vector Real) synthesis =-   SigP.runChunky $+   Render.run $       (sum (map (\(typ, Pole q f, amp) ->-                   CausalP.amplify (return amp)+                   Causal.amplify (Expr.cons amp)                    <<<                    typ                    ^<<-                   CtrlP.process+                   Ctrl.process                    $<-                   (SigP.constant $ return $-                    UniFilter.parameter $ Pole q $ f / sampleRate))+                   (fmap UniFilterL.unMultiValueParameter $ Sig.constant $+                    Expr.cons $ UniFilter.parameter $ Pole q $ f / sampleRate))                 formants_sch)-        $* SigP.noise 174373 0.02)+        $* Sig.noise 174373 0.02)  compareSpec ::IO () compareSpec = do@@ -165,39 +172,45 @@    synthesized <- synthesis    void $ Plot.plot WXT.cons $       spectrumPlot sampled-      `mappend`+      <>       spectrumPlot          (SVL.take (SVL.length sampled) $-          synthesized (SVL.chunkSize 4096) ())+          synthesized (SVL.chunkSize 4096))  render ::IO () render = do    synthesized <- synthesis    saveSound (Path.relFile "sch-synth.wav") $       SVL.take sampleRateInt $-      synthesized (SVL.chunkSize 4096) ()+      synthesized (SVL.chunkSize 4096)   -- * purification of sampled periods  -- ** using a comb filter -type Comb = (Real, Int) -> SVL.Vector Real -> SVL.Vector Real+type Comb = Real -> Word -> SVL.Vector Real -> SVL.Vector Real  makeComb :: IO Comb makeComb =-   CausalP.runStorableChunky $ CausalP.comb (arr fst) (arr snd)+   (\proc gain time -> pioApply (proc gain time))+   <$>+   CausalRender.run Causal.comb  makeHighComb :: IO Comb makeHighComb =-   CausalP.runStorableChunky $-      CausalP.comb (arr fst) (arr snd)+   fmap (\proc gain time -> pioApply (proc gain time))+   $+   CausalRender.run $ \gain time ->+      Causal.comb gain time       .-      (Filt1.highpassCausal $<# FirstOrder.parameter (1000/sampleRate))+      (Filt1.highpassCausal $<+         Sig.constant (FirstOrder.parameter (1000 / Expr.cons sampleRate))) -scorePeriod :: Comb -> Real -> Int -> SVL.Vector Real -> (Real, SVL.Vector Real)+scorePeriod ::+   Comb -> Real -> Word -> SVL.Vector Real -> (Real, SVL.Vector Real) scorePeriod comb gain period sig =-   let end = SVL.takeEnd (3*period) $ comb (gain, period) sig+   let end = SVL.takeEnd (3 * fromIntegral period) $ comb gain period sig    in  (Analysis.volumeEuclideanSqr end, end)  vowelNames :: [String]@@ -258,7 +271,7 @@ findPeriod :: Comb -> SVL.Vector Real -> SVL.Vector Real findPeriod comb sampled =    normalize $-   uncurry bestRotation $+   uncurry (bestRotation . fromIntegral) $    mapSnd snd $    List.maximumBy (comparing (fst . snd)) $    flip map [350 .. 400] $ \period ->@@ -275,7 +288,9 @@  makeFilter :: IO (SV.Vector Real -> SVL.Vector Real -> SVL.Vector Real) makeFilter =-   CausalP.runStorableChunky $ FiltNR.convolve id+   (\proc mask -> pioApply (proc (Render.buffer mask)))+   <$>+   CausalRender.run FiltNR.convolve  normalizeMax :: SVL.Vector Real -> SVL.Vector Real normalizeMax = FiltNRG.normalize Analysis.volumeMaximum
src/Synthesizer/LLVM/Server/Common.hs view
@@ -1,135 +1,332 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE EmptyDataDecls #-} module Synthesizer.LLVM.Server.Common (-   Real, Param,-   SampleRate(SampleRate),+   Real,+   SampleRate(SampleRate), expSampleRate,    Instrument,-   frequency, time, noiseReference, number, control, signal, parameter,-   frequencyConst, timeConst,+   ($+),+   constant, ($++),+   frequency, time, noiseReference, number,+   Quantity(..), Arg(..), Frequency, Time, Number,+   Input(..), InputArg(..), Parameter, Control, Signal,+   ArgTuple(..),+   Wrapped(..),+   amplitudeFromVelocity,    ($/), -   chopEvents,    piecewiseConstant,    transposeModulation,-   amplitudeFromVelocity, +   pioApply,+   pioApplyCont,+   pioApplyToLazyTime,+    controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,    controllerFilterCutoff, controllerFilterResonance,    controllerVolume,    ) where -import qualified Sound.MIDI.Controller as Ctrl-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import Synthesizer.LLVM.Causal.Process (($*)) +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM+import qualified Synthesizer.LLVM.ConstantPiece as Const import qualified Synthesizer.MIDI.Storable as MidiSt+import qualified Synthesizer.MIDI.EventList as Ev import qualified Synthesizer.PiecewiseConstant.Signal as PC-import qualified Synthesizer.LLVM.MIDI.BendModulation as BM+import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Generic.Signal as SigG -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified LLVM.DSL.Parameter as Param+import qualified Sound.MIDI.Controller as Ctrl+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp) -import qualified Synthesizer.Storable.Signal as SigSt+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory -import qualified Data.EventList.Relative.TimeTime as EventListTT+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable) -import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Chunky as NonNegChunky+import qualified Numeric.NonNegative.Wrapper as NonNegW -import Control.Arrow (arr, (^<<))+import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>)) -import Prelude hiding (Real)+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold +import qualified System.Unsafe as Unsafe +import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring +import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++type Real = Float++type Instrument a sig = SampleRate a -> MidiSt.Instrument a sig++ newtype SampleRate a = SampleRate a    deriving (Show)  instance Functor SampleRate where    fmap f (SampleRate sr) = SampleRate (f sr) +instance Fold.Foldable SampleRate where+   foldMap f (SampleRate sr) = f sr -type Real = Float+instance Trav.Traversable SampleRate where+   traverse f (SampleRate sr) = SampleRate <$> f sr -type Param p = Param.T (SampleRate Real, p)+instance Applicative SampleRate where+   pure = SampleRate+   SampleRate f <*> SampleRate sr = SampleRate $ f sr -type Instrument a sig = SampleRate a -> MidiSt.Instrument a sig +instance (Render.RunArg a) => Render.RunArg (SampleRate a) where+   type DSLArg (SampleRate a) = SampleRate (Render.DSLArg a)+   buildArg =+      case Render.buildArg of+         Render.BuildArg pass create ->+            Render.BuildArg+               (SampleRate . pass)+               (\(SampleRate sr) -> create sr) -frequency :: (p -> Real) -> Param p Real-frequency param =-   arr (\(SampleRate sampleRate, p) -> param p / sampleRate)+instance (MultiValue.C a) => MultiValue.C (SampleRate a) where+   type Repr (SampleRate a) = MultiValue.Repr a+   cons = multiValueSampleRate . fmap MultiValue.cons+   undef = multiValueSampleRate $ pure MultiValue.undef+   zero = multiValueSampleRate $ pure MultiValue.zero+   phi bb =+      fmap multiValueSampleRate .+      Trav.traverse (MultiValue.phi bb) . unMultiValueSampleRate+   addPhi bb a b =+      Fold.sequence_ $+      liftA2 (MultiValue.addPhi bb)+         (unMultiValueSampleRate a) (unMultiValueSampleRate b) -time :: (p -> Real) -> Param p Real-time param =-   arr (\(SampleRate sampleRate, p) -> param p * sampleRate)+instance (Marshal.C a) => Marshal.C (SampleRate a) where+   pack (SampleRate a) = Marshal.pack a+   unpack = SampleRate . Marshal.unpack -noiseReference :: Real -> Param p Real-noiseReference freq =-   arr (\(SampleRate sampleRate, _p) -> sampleRate/freq)+multiValueSampleRate ::+   SampleRate (MultiValue.T a) -> MultiValue.T (SampleRate a)+multiValueSampleRate (SampleRate (MultiValue.Cons a)) = MultiValue.Cons a -number :: (p -> Real) -> Param p Real-number param = arr (param . snd)+unMultiValueSampleRate ::+   MultiValue.T (SampleRate a) -> SampleRate (MultiValue.T a)+unMultiValueSampleRate (MultiValue.Cons a) = SampleRate (MultiValue.Cons a) -control :: (p -> PC.T Real) -> Param p (PC.T Real)-control param = arr (param . snd) -signal :: (p -> SigSt.T a) -> Param p (SigSt.T a)-signal param = arr (param . snd)+expSampleRate :: Exp (SampleRate a) -> SampleRate (Exp a)+expSampleRate = SampleRate . Expr.lift1 MultiValue.cast -parameter :: (p -> a) -> Param p a-parameter param = arr (param . snd)  -frequencyConst :: Real -> Param p Real-frequencyConst param =-   arr (\(SampleRate sampleRate, _p) -> param / sampleRate)+($/) :: (Functor f) => f (a -> b) -> a -> f b+f $/ x = fmap ($ x) f -timeConst :: Real -> Param p Real-timeConst param =-   arr (\(SampleRate sampleRate, _p) -> param * sampleRate) +infixr 0 $+, $++ +($+) ::+   (SampleRate a -> b -> c) ->+   (c -> SampleRate a -> d) ->+   SampleRate a -> b -> d+(p$+f) sampleRate param = f (p sampleRate param) sampleRate -($/) :: (Functor f) => f (a -> b) -> a -> f b-f $/ x = fmap ($x) f+($++) ::+   (SampleRate a -> b -> c, b) ->+   (c -> SampleRate a -> d) ->+   SampleRate a -> d+((p,param)$++f) sampleRate = f (p sampleRate param) sampleRate +constant ::+   (SampleRate a -> b -> c) -> b ->+   (c -> SampleRate a -> d) ->+   SampleRate a -> d+constant p param f sampleRate = f (p sampleRate param) sampleRate --- might be moved to event-list package-chopEvents ::-   (NonNeg.C time, Num time) =>-   time ->-   EventListTT.T time body ->-   [EventListTT.T time body]-chopEvents chunkSize =-   let go evs =-          let (chunk,rest) = EventListTT.splitAtTime chunkSize evs-          in  if EventListTT.duration chunk == 0-                then []-                else chunk : go rest-   in  go +frequency :: (Field.C a) => SampleRate a -> a -> a+frequency (SampleRate sr) param = param / sr -piecewiseConstant ::-   (Marshal.C a, Tuple.ValueOf a ~ al) =>-   Param.T p (PC.T a) -> SigP.T p al-piecewiseConstant pc =-   SigP.piecewiseConstant-      (PC.subdivideLongStrict ^<< pc)+time :: (Ring.C a) => SampleRate a -> a -> a+time (SampleRate sr) param = param * sr -transposeModulation ::-   (Functor stream) =>-   SampleRate Real ->-   Real ->-   stream (BM.T Real) ->-   stream (BM.T Real)-transposeModulation (SampleRate sampleRate) freq =-   fmap (BM.shift (freq/sampleRate))+noiseReference :: (Field.C a) => SampleRate a -> a -> a+noiseReference (SampleRate sr) freq = sr/freq +number :: SampleRate a -> a -> a+number = flip const ++data Number+data Frequency+data Time+data NoiseReference++class Quantity quantity a where+   data Arg quantity a+   eval :: SampleRate a -> a -> Arg quantity a++instance Quantity Number a where+   data Arg Number a = Number a+   eval sampleRate a = Number $ number sampleRate a++instance (Field.C a) => Quantity Frequency a where+   data Arg Frequency a = Frequency a+   eval sampleRate a = Frequency $ frequency sampleRate a++instance (Ring.C a) => Quantity Time a where+   data Arg Time a = Time a+   eval sampleRate a = Time $ time sampleRate a++instance (Field.C a) => Quantity NoiseReference a where+   data Arg NoiseReference a = NoiseReference a+   eval sampleRate a = NoiseReference $ noiseReference sampleRate a+++class Input signal a where+   data InputArg signal a+   type InputSource signal a+   evalInput :: SampleRate a -> InputSource signal a -> InputArg signal a++data Parameter b++instance Input (Parameter b) a where+   data InputArg (Parameter b) a = Parameter b+   type InputSource (Parameter b) a = b+   evalInput _sr = Parameter++data Control b++instance Input (Control b) a where+   data InputArg (Control b) a = Control (Sig.T b)+   type InputSource (Control b) a = Sig.T b+   evalInput _sr = Control++data Signal b++instance Input (Signal b) a where+   data InputArg (Signal b) a = Signal (Sig.T b)+   type InputSource (Signal b) a = Sig.T b+   evalInput _sr = Signal+++class ArgTuple a tuple where+   type ArgPlain tuple+   evalTuple :: SampleRate a -> ArgPlain tuple -> tuple++instance (Quantity quantity b, a ~ b) => ArgTuple a (Arg quantity b) where+   type ArgPlain (Arg quantity b) = b+   evalTuple = eval++instance (Input signal b, a ~ b) => ArgTuple a (InputArg signal b) where+   type ArgPlain (InputArg signal b) = InputSource signal b+   evalTuple = evalInput++instance (ArgTuple a b, ArgTuple a c) => ArgTuple a (b,c) where+   type ArgPlain (b,c) = (ArgPlain b, ArgPlain c)+   evalTuple sampleRate (b,c) = (evalTuple sampleRate b, evalTuple sampleRate c)++instance (ArgTuple a b, ArgTuple a c, ArgTuple a d) => ArgTuple a (b,c,d) where+   type ArgPlain (b,c,d) = (ArgPlain b, ArgPlain c, ArgPlain d)+   evalTuple sampleRate (b,c,d) =+      (evalTuple sampleRate b, evalTuple sampleRate c, evalTuple sampleRate d)++++class Wrapped a f where+   type Unwrapped f+   wrapped :: f -> SampleRate a -> Unwrapped f++instance (a ~ b) => Wrapped a (SampleRate b -> f) where+   type Unwrapped (SampleRate b -> f) = f+   wrapped f = f++instance+   (a ~ b, Quantity quantity b, Wrapped a f) =>+      Wrapped a (Arg quantity b -> f) where+   type Unwrapped (Arg quantity b -> f) = b -> Unwrapped f+   wrapped f sampleRate arg =+      wrapped (f (eval sampleRate arg)) sampleRate++instance+   (a ~ b, Input signal b, Wrapped a f) =>+      Wrapped a (InputArg signal b -> f) where+   type Unwrapped (InputArg signal b -> f) =+         InputSource signal b -> Unwrapped f+   wrapped f sampleRate arg =+      wrapped (f (evalInput sampleRate arg)) sampleRate++instance+   (ArgTuple a b, ArgTuple a c, Wrapped a f) =>+      Wrapped a ((b,c) -> f) where+   type Unwrapped ((b,c) -> f) = (ArgPlain b, ArgPlain c) -> Unwrapped f+   wrapped f sampleRate arg =+      wrapped (f (evalTuple sampleRate arg)) sampleRate++instance+   (ArgTuple a b, ArgTuple a c, ArgTuple a d, Wrapped a f) =>+      Wrapped a ((b,c,d) -> f) where+   type Unwrapped ((b,c,d) -> f) =+         (ArgPlain b, ArgPlain c, ArgPlain d) -> Unwrapped f+   wrapped f sampleRate arg =+      wrapped (f (evalTuple sampleRate arg)) sampleRate++ {-# INLINE amplitudeFromVelocity #-}-amplitudeFromVelocity :: Real -> Real-amplitudeFromVelocity vel = 4**vel+amplitudeFromVelocity :: (Trans.C a) => a -> a+amplitudeFromVelocity vel = fromInteger 4 ^? vel+++piecewiseConstant :: (Memory.C a) => Sig.T (Const.T a) -> Sig.T a+piecewiseConstant = Const.flatten++transposeModulation :: (Field.C a, Expr.Aggregate a am) =>+   SampleRate a -> a -> Sig.T (Const.T (BM.T am)) -> Sig.T (Const.T (BM.T am))+transposeModulation (SampleRate sampleRate) freq xs =+   Const.causalMap (BM.shift (freq/sampleRate)) $* xs++++pioApply ::+   (Storable a, Storable b) =>+   PIO.T (SV.Vector a) (SV.Vector b) -> SVL.Vector a -> SVL.Vector b+pioApply = pioApplyCont (const SVL.empty)++pioApplyCont ::+   (Storable a, Storable b) =>+   (SVL.Vector a -> SVL.Vector b) ->+   PIO.T (SV.Vector a) (SV.Vector b) -> SVL.Vector a -> SVL.Vector b+pioApplyCont cont proc sig = Unsafe.performIO $ do+   act <- PIO.runStorableChunkyCont proc+   return $ act cont sig++pioApplyToLazyTime ::+   (Storable b) =>+   PIO.T SigG.LazySize (SV.Vector b) -> Ev.LazyTime -> SVL.Vector b+pioApplyToLazyTime proc sig = Unsafe.performIO $ do+   act <- PIO.runCont proc+   return $ SVL.fromChunks $ act (const []) $+      map (SigG.LazySize . NonNegW.toNumber) $+      concatMap PC.chopLongTime $ NonNegChunky.toChunks sig+   controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,
src/Synthesizer/LLVM/Server/CommonPacked.hs view
@@ -1,26 +1,19 @@-module Synthesizer.LLVM.Server.CommonPacked (-   module Synthesizer.LLVM.Server.CommonPacked,-   Param,-   ) where+module Synthesizer.LLVM.Server.CommonPacked where  import Synthesizer.LLVM.Server.Common -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial  import qualified Data.NonEmpty as NonEmpty -import qualified Algebra.Additive as Additive- import qualified Type.Data.Num.Decimal as TypeNum -import Control.Arrow (arr)+import qualified Algebra.Field as Field+import qualified Algebra.Additive as Additive -import NumericPrelude.Numeric ((+), (-), (*))-import Prelude hiding (Real, (+), (-), (*))+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()   sumNested :: (Additive.C a) => [a] -> a@@ -36,27 +29,19 @@    in  n + 0.01*r  -type SigP p = SigP.T (SampleRate Real, p)-type CausalP p = CausalP.T (SampleRate Real, p)-type FuncP p = F.T (SampleRate Real, p)---type Vector = Serial.Plain VectorSize Real+type Vector = Serial.T VectorSize Real type VectorValue = Serial.Value VectorSize Real type VectorSize = TypeNum.D4  +-- ToDo: generalize to Integral class vectorSize :: Int vectorSize =    TypeNum.integralFromSingleton       (TypeNum.singleton :: TypeNum.Singleton VectorSize) -vectorRate :: Fractional a => SampleRate a -> a-vectorRate (SampleRate sampleRate) =-   sampleRate / fromIntegral vectorSize-+vectorRate :: (Field.C a) => SampleRate a -> a+vectorRate (SampleRate sr) = sr / fromIntegral vectorSize -vectorTime :: (p -> Real) -> Param p Real-vectorTime param =-   arr (\(SampleRate sampleRate, p) ->-          param p * sampleRate / fromIntegral vectorSize)+vectorTime :: (Field.C a) => SampleRate a -> a -> a+vectorTime (SampleRate sr) param = param * sr / fromIntegral vectorSize
src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -13,1489 +13,1494 @@   instruments:-   use a greymap picture as source of waveforms-   mix of detuned noisy-waverforms, try different and uniform waveforms-   mix of sawtooth, where every sawtooth is modulated with red noise-   mix of sine with harmonics where every harmonic is modulated differently-   Flute: sine + filtered noise-   Drum with various parameters-   derive percussive instruments from fmString and arcString (for bass synths)-   an FM sound with a slowly changing timbre-      by using a very slightly detuned frequency for the modulator-   making a tone out of noise using time stretch with helix algorithm-      a chorus effect could be applied by two successive helix stretches-      or by mixture of two stretches signals-      additionally a resonant filter could be applied-   a kind of Karplus-Strong algorithm with a non-linear function of past values-      e.g. y(t) = f(y(t-d), y(t-2*d))-      where d is the tone period and f is non-linear, maybe chaotic function.-      In order to limit the appearance of chaotic waveforms,-      we could combine this with a lowpass filter.-   let attack and release depend on On and Off velocity-   tineStereoFM:-      continuous control of the modulation index-      by linear interpolation of waves between modulations with integral indices.-      E.g. modulation index 2.3 means-      0.7*modulation with index 2 and 0.3*modulation with index 3.--effects:-   reverb and controllable delay-   phaser or Chebyshev filter--continuous sounds:-   fly-   water/bubbles-      when I accidentally did not scale filter frequency with sample rate,-      the filter sound much like water bubbles.-      I think a control curve consisting of some ramps will do the same.-   hail, Geiger counter, pitch applied by comb filter-      at a very high impulse rate the impulses itself-      can generate an almost periodic signal---Speech sounds improvements (tomatensalat)-   use PSOLA for transposition-   To this end divide signal into tonal part and residue (noise)-   by a comb filter.-   Maybe a non-linear comb filter may help,-   that selects the center value from the filter window,-   if the side values are similar-   and returns zero, if the the side values differ too much.-   Process the tonal part by PSOLA and-   simply mix it with the non-tonal part on replay.--Harmonizer-like:-   We like to input an audio signal of speech-   and a set of keys, and the speech is extended to chords-   according to the pressed keys.-   The lowest key is interpreted as base frequency of the input audio speech.-   A PSOLA method transposes the audio input.--Resonant filter controlled by keys-   applied to an audio input signal-   or an ordinary audio signal generated by other keys.-   The splitting of keys however could be performed-   by a MIDI event stream editor.--}--{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Server.Packed.Instrument (-   pingRelease,-   pingStereoRelease,-   pingStereoReleaseFM,-   squareStereoReleaseFM,-   bellStereoFM,-   bellNoiseStereoFM,-   tine,-   tineStereo,-   softString,-   softStringFM,-   tineStereoFM,-   tineControlledFM,-   fenderFM,-   tineModulatorBankFM,-   tineBankFM,-   resonantFMSynth,-   softStringDetuneFM,-   softStringShapeFM, cosineStringStereoFM,-   arcSineStringStereoFM, arcTriangleStringStereoFM,-   arcSquareStringStereoFM, arcSawStringStereoFM,-   fmStringStereoFM,-   wind,-   windPhaser,-   filterSawStereoFM,-   brass,-   sampledSound,--   -- * helper functions-   stereoNoise,-   frequencyFromBendModulation,-   modulation,-   piecewiseConstantVector,--   -- * for testing-   pingReleaseEnvelope,-   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-import qualified Synthesizer.MIDI.PiecewiseConstant as PC-import qualified Synthesizer.MIDI.EventList as Ev--import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime)--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL-import qualified Synthesizer.LLVM.Filter.Allpass as Allpass-import qualified Synthesizer.LLVM.Filter.Moog as MoogL-import qualified Synthesizer.LLVM.MIDI as MIDIL-import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified Synthesizer.LLVM.Storable.Signal as SigStL-import qualified Synthesizer.LLVM.Frame as Frame-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*))-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&))--import qualified LLVM.DSL.Parameter as Param-import LLVM.DSL.Parameter (($#))--import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Core as LLVM-import qualified Type.Data.Num.Decimal as TypeNum--import qualified Synthesizer.Generic.Cut         as CutG-import qualified Synthesizer.Storable.Signal      as SigSt-import qualified Data.StorableVector.Lazy.Pattern as SVP-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)-import Data.Traversable (traverse)-import qualified Data.Traversable as Trav--import Data.Tuple.HT (fst3, snd3, thd3)--import qualified Numeric.NonNegative.Chunky as NonNegChunky--import qualified Algebra.Additive as Additive--import NumericPrelude.Numeric (zero, one, round, (^?), (+), (-), (*))-import Prelude hiding (Real, round, break, id, (+), (-), (*))----frequencyControl :: (p -> PC.T Real) -> Param p (PC.T Real)-frequencyControl param =-   arr (\(SampleRate sampleRate, p) -> fmap (/sampleRate) $ param p)--modulation ::-   (p -> (PC.T (BM.T Real), Real)) -> Param p (PC.T (BM.T Real))-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))-detuneModulation param =-   arr $ \(sr, p) ->-      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 ::-{--   (Storable a,-    Tuple.Value a, ValueTuple a ~ (Value a)) =>--}-   Param p Real ->-   Param p (PC.T (BM.T Real)) ->-   SigP p VectorValue-frequencyFromBendModulation speed fmFreq =-   MIDIL.frequencyFromBendModulationPacked speed-      $* piecewiseConstant fmFreq--stereoFrequenciesFromDetuneBendModulation ::-   Param p Real ->-   Param p (PC.T Real, PC.T (BM.T Real)) ->-   SigP p (Stereo.T VectorValue)-stereoFrequenciesFromDetuneBendModulation speed detFmFreq =-   (CausalP.envelopeStereo-      $< frequencyFromBendModulation speed-           (fmap (\(_det,fm) -> (fm)) detFmFreq))-   <<<-   liftA2 Stereo.cons (one + id) (one - id)-   $* piecewiseConstantVector-         (fmap (\(det,_fm) -> det) detFmFreq)--piecewiseConstantVector ::-   Param.T p (PC.T Real) -> SigP.T p VectorValue-{--   (Storable a,-    Tuple.Value a, Tuple.ValueOf a ~ al,-    Memory.C al am,-    LLVM.IsSized am as) =>-   Param.T p (PC.T a) -> SigP.T p (Serial.Value n al)--}-piecewiseConstantVector =-   piecewiseConstant . fmap (fmap (Serial.replicate))---pingReleaseEnvelope ::-   IO (Real -> Real ->-       SigSt.ChunkSize ->-       SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)-pingReleaseEnvelope =-   liftA2-      (\pressed release decay rel vcsize sr vel dur ->-         SigStL.continuePacked-            (pressed (chunkSizesFromLazyTime dur) (sr, (decay,vel)))-            (\x -> release vcsize (sr, (rel,x))))-      (SigP.runChunkyPattern $-       let decay = time fst-           velocity = number snd-       in  SigPS.exponential2 decay-              (amplitudeFromVelocity ^<< velocity))-      (SigP.runChunky $-       let releaseTime = vectorTime fst * 5-           releaseHL = time fst-           amplitude = number snd-       in  CausalP.take (round ^<< releaseTime) $*-           SigPS.exponential2 releaseHL amplitude)--pingRelease ::-   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)-pingRelease =-   liftA2-      (\osc env dec rel vcsize sr vel freq dur ->-         osc (sr,freq) (env dec rel vcsize sr vel dur))-      (CausalP.runStorableChunky-         (let freq = frequency id-          in  CausalP.envelope $>-              SigPS.osciSimple WaveL.saw zero freq))-      pingReleaseEnvelope--pingStereoRelease ::-   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))-pingStereoRelease =-   liftA2-      (\osc env dec rel vcsize sr vel freq dur ->-         osc (sr,freq) (env dec rel vcsize sr vel dur))-      (CausalP.runStorableChunky-         (let freq = frequency id-          in  CausalP.envelopeStereo $>-              liftA2 Stereo.cons-                 (SigPS.osciSimple WaveL.saw zero (0.999*freq))-                 (SigPS.osciSimple WaveL.saw zero (1.001*freq))))-      pingReleaseEnvelope--pingStereoReleaseFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real ->-       Real -> Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-pingStereoReleaseFM =-   liftA2-      (\osc env dec rel detune shape phase phaseDecay vcsize fm sr vel freq dur ->-         osc-            (sr, ((phase, phaseDecay), shape, (detune,fm,freq)))-            (env dec rel vcsize sr vel dur))-      (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))-      pingReleaseEnvelope--{- |-Square like wave constructed as difference-of two phase shifted sawtooth like oscillations.--}-squareStereoReleaseFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-squareStereoReleaseFM =-   liftA2-      (\osc env dec rel detune shape phase vcsize fm sr vel freq dur ->-         osc-            (sr, ((phase, shape), (detune,fm,freq)))-            (env dec rel vcsize sr vel dur))-      (CausalP.runStorableChunky $-       ParamS.withTuple2 $ \((Control phs, Control shp), DetuneModulation fm) ->-         (let chanOsci ::-                 CausalP p-                    ((VectorValue, VectorValue), VectorValue)-                    VectorValue-              chanOsci =-                 ((CausalPS.shapeModOsci WaveL.rationalApproxSine1-                   <<<-                   second (first (Additive.negate id)))-                  --                   CausalPS.shapeModOsci WaveL.rationalApproxSine1)-                 <<^-                 (\((p,s),f) -> (s,(p,f)))-          in  CausalP.envelopeStereo $>-              ((CausalP.stereoFromMonoControlled chanOsci-                   $< SigP.zip-                         (piecewiseConstantVector phs)-                         (piecewiseConstantVector shp))-                $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)))-      pingReleaseEnvelope---type Triple a = (a, a, a)--bellStereoFM ::-   IO (Real -> Real ->-       PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-bellStereoFM =-   liftA2-      (\osc env dec rel detune vcsize fm sr vel freq dur ->-         osc (sr, ((detune, fm, freq), vel,-                   (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 $-       ParamS.withTuple2 $-       \(DetuneModulation fm, Number vel, (Signal env4, Signal env7)) ->-         (let osci ::-                 (Triple VectorValue -> VectorValue) ->-                 Param.T p Real ->-                 Param.T p Real ->-                 CausalP.T p-                    (Triple VectorValue, Stereo.T VectorValue)-                    (Stereo.T VectorValue)-              osci sel v d =-                 CausalP.envelopeStereo-                 <<<-                 (arr sel ***-                    (CausalPS.amplifyStereo v-                     <<<-                     CausalP.stereoFromMono-                        (CausalPS.osciSimple WaveL.approxSine4 $< zero)-                     <<<-                     CausalPS.amplifyStereo d))-          in  sumNested-                 [osci fst3  0.6              1,-                  osci snd3 (0.02 *  50^?vel) 4,-                  osci thd3 (0.02 * 100^?vel) 7]-              <<<-              CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)-              <<<-              arr (\(e1,(e4,e7)) -> (e1,e4,e7))-               $> {--                  Be careful, those storable vectors shorten the whole sound-                  if they have shorter release than the main envelope.-                  -}-                  SigP.zip-                     (SigP.fromStorableVectorLazy env4)-                     (SigP.fromStorableVectorLazy env7)))-      pingReleaseEnvelope--bellNoiseStereoFM ::-   IO (Real -> Real ->-       PC.T Real -> PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-bellNoiseStereoFM =-   liftA2-      (\osc env dec rel noiseAmp noiseReson vcsize fm sr vel freq dur ->-         osc (sr,-              ((fm, freq),-               (noiseAmp,noiseReson),-               (vel,-                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 $-       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 ->-                 CausalP.T p-                    (Triple VectorValue, VectorValue)-                    VectorValue-              osci sel v d =-                 CausalP.envelope-                 <<<-                 (arr sel ***-                    (CausalPS.amplify v-                     <<<-                     (CausalPS.osciSimple WaveL.approxSine4 $< zero)-                     <<<-                     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 p Real ->-                 CausalP p (Triple VectorValue, VectorValue) VectorValue-              noise sel d =-                 (CausalP.envelope $< piecewiseConstantVector noiseAmp)-                 <<<-                 CausalP.envelope-                 <<<-                 (arr sel ***-                    ({- UniFilter.lowpass-                        ^<< -}-                     (CtrlPS.process-                        $> SigPS.noise 12 (noiseReference 20000))-                     <<<-{--                     (CausalP.quantizeLift-                        $# (128 / fromIntegral vectorSize :: Real))-                           (CausalP.zipWithSimple UniFilterL.parameter)--}-                     (CausalP.quantizeLift-                        $# (128 / fromIntegral vectorSize :: Real))-                           (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8))-                     <<<-                     CausalP.feedFst (piecewiseConstant noiseReson)-                     <<<-                     CausalP.mapSimple Serial.subsample-                     <<<-                     CausalPS.amplify d))-          in  liftA2 Stereo.cons-                 (sumNested-                    [osci fst3  0.6              (1*0.999),-                     osci snd3 (0.02 *  50^?vel) (4*0.999),-                     osci thd3 (0.02 * 100^?vel) (7*0.999),-                     noise fst3 0.999])-                 (sumNested-                    [osci fst3  0.6              (1*1.001),-                     osci snd3 (0.02 *  50^?vel) (4*1.001),-                     osci thd3 (0.02 * 100^?vel) (7*1.001),-                     noise fst3 1.001])-              <<<-              CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) fm)-              <<<-              arr (\(e1,(e4,e7)) -> (e1,e4,e7))-               $> {--                  Be careful, those storable vectors shorten the whole sound-                  if they have shorter release than the main envelope.-                  -}-                  SigP.zip-                     (SigP.fromStorableVectorLazy env4)-                     (SigP.fromStorableVectorLazy env7)))-      pingReleaseEnvelope---tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)-tine =-   liftA2-      (\osc env dec rel vcsize sr vel freq dur ->-         osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur))-      (CausalP.runStorableChunky-         (let freq = frequency snd-              vel  = number fst-          in  CausalP.envelope $>-                 (CausalPS.osciSimple WaveL.approxSine2-                    $> SigPS.constant freq-                    $* (CausalP.envelope-                          $< SigPS.exponential2 (timeConst 1) (vel+1)-                          $* SigPS.osciSimple WaveL.approxSine2 zero-                                (2*freq)))))-      pingReleaseEnvelope--tineStereo ::-   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))-tineStereo =-   liftA2-      (\osc env dec rel vcsize sr vel freq dur ->-         osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur))-      (CausalP.runStorableChunky-         (let freq = frequency snd-              vel  = number fst-              chanOsci d =-                 CausalPS.osciSimple WaveL.approxSine2-                    $> SigPS.constant (freq*d)-          in  CausalP.envelopeStereo $>-                 (liftA2 Stereo.cons-                    (chanOsci 0.995) (chanOsci 1.005)-                  $* SigP.envelope-                        (SigPS.exponential2 (timeConst 1) (vel+1))-                        (SigPS.osciSimple WaveL.approxSine2 zero-                           (2*freq)))))-      pingReleaseEnvelope---softStringReleaseEnvelope ::-   IO (Real -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)-softStringReleaseEnvelope =-   liftA2-      (\rev env attackTime sr vel dur ->-         let attackTimeVector =-                round (attackTime * vectorRate sr)-             {--             release <- take attackTime beginning-             would yield a space leak, thus we first split 'beginning'-             and then concatenate it again-             -}-             {--             We can not easily generate attack and sustain separately,-             because we want to use the chunk structure implied by 'dur'.-             -}-             (attack, sustain) =-                SigSt.splitAt attackTimeVector $-                env (chunkSizesFromLazyTime dur)-                    (sr, (amplitudeFromVelocity vel, attackTimeVector))-             release = rev attack-         in  attack `SigSt.append` sustain `SigSt.append` release)-      SigStL.makeReversePacked-      (let amp = number fst-           attackTimeVector = parameter snd-       in  SigP.runChunkyPattern $-           flip SigP.append (SigPS.constant amp) $-           (CausalPS.amplify amp <<<-            CausalP.take attackTimeVector-            $* SigPS.parabolaFadeInInf-                  (fmap (fromIntegral . (vectorSize*)) attackTimeVector)))--softString :: IO (Instrument Real (Stereo.T Vector))-softString =-   liftA2-      (\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)-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (liftA2 Stereo.cons-                 (osci 1.005 + osci 0.998)-                 (osci 1.002 + osci 0.995))))-      softStringReleaseEnvelope---softStringFM :: IO (PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector))-softStringFM =-   liftA2-      (\osc env fm sr vel freq dur ->-         osc (sr, (fm,freq)) (env 1 sr vel dur))-      (let fm = modulation id-           osci ::-              Param.T fm Real ->-              CausalP.T fm VectorValue VectorValue-           osci d =-              (CausalPS.osciSimple WaveL.saw $< zero) <<<-              CausalPS.amplify d-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (liftA2 Stereo.cons-                  (osci 1.005 + osci 0.998)-                  (osci 1.002 + osci 0.995)-               $* frequencyFromBendModulation (frequencyConst 5) fm)))-      softStringReleaseEnvelope---tineStereoFM ::-   IO (Real -> Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-tineStereoFM =-   liftA2-      (\osc env dec rel vcsize fm sr vel freq dur ->-         osc (sr, (vel,(fm,freq))) (env dec rel vcsize sr 0 dur))-      (CausalP.runStorableChunky-         (let vel  = number fst-              fm   = modulation snd-              chanOsci d =-                 CausalPS.osciSimple WaveL.approxSine2-                    <<< second (CausalPS.amplify d)-          in  CausalP.envelopeStereo $>-                 (liftA2 Stereo.cons-                     (chanOsci 0.995) (chanOsci 1.005)-                  <<<-                  (((CausalP.envelope-                       $< SigPS.exponential2 (timeConst 1) (vel+1))-                     <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero)-                     <<< CausalPS.amplify 2)-                   &&& id)-                  $* frequencyFromBendModulation (frequencyConst 5) fm)))-      pingReleaseEnvelope---_tineControlledProc, tineControlledFnProc ::-   Param p (PC.T Real) ->-   Param p (PC.T Real) ->-   Param p Real ->-   CausalP p-      (Stereo.T VectorValue)-      (Stereo.T VectorValue)-_tineControlledProc index depth vel =-   CausalP.stereoFromMono-      (CausalPS.osciSimple WaveL.approxSine2)-   <<<-   Stereo.interleave-   ^<<-   ((CausalP.envelopeStereo-       $< SigP.envelope-             (piecewiseConstantVector depth)-             (SigPS.exponential2 (timeConst 1) (vel+1)))-    <<<-    CausalP.stereoFromMono-       (CausalPS.osciSimple WaveL.approxSine2 $< zero)-    <<<-    (CausalP.envelopeStereo-       $< piecewiseConstantVector index))-            &&& id--tineControlledFnProc index depth vel =-   F.withGuidedArgs F.atom $ \freq ->-      CausalP.stereoFromMono-         (CausalPS.osciSimple WaveL.approxSine2)-      $&-      liftA2 (liftA2 (,))-         ((CausalP.envelopeStereo-             $< SigP.envelope-                   (piecewiseConstantVector depth)-                   (SigPS.exponential2 (timeConst 1) (vel+1)))-          <<<-          CausalP.stereoFromMono-             (CausalPS.osciSimple WaveL.approxSine2 $< zero)-          <<<-          (CausalP.envelopeStereo-             $< piecewiseConstantVector index)-          $&-          freq)-         freq--tineControlledFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-tineControlledFM =-   liftA2-      (\osc env dec rel detune index depth vcsize fm sr vel freq dur ->-         osc-            (sr, ((index, depth), vel, (detune,fm,freq)))-            (env dec rel vcsize sr 0 dur))-      (CausalP.runStorableChunky $-       ParamS.withTuple2 $-       \((Control index, Control depth), Number vel, DetuneModulation fm) ->-         CausalP.envelopeStereo $>-            (tineControlledFnProc index depth vel $*-             stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))-      pingReleaseEnvelope---fenderProc ::-   Param p (PC.T Real) ->-   Param p (PC.T Real) ->-   Param p (PC.T Real) ->-   Param p Real ->-   CausalP p-      (Stereo.T VectorValue)-      (Stereo.T VectorValue)-fenderProc fade index depth vel =-   F.withGuidedArgs F.atom $ \stereoFreq ->-       let {--           channel_n_1 ::-              FuncP p VectorValue VectorValue ->-              FuncP p VectorValue VectorValue-           -}-           channel_n_1 freq =-              CausalPS.osciSimple WaveL.approxSine2-              $&-              ((CausalP.envelope-                  $< SigP.envelope-                        (piecewiseConstantVector depth)-                        (SigPS.exponential2 (timeConst 1) (vel+1)))-               <<<-               (CausalPS.osciSimple WaveL.approxSine2 $< zero)-               <<<-               (CausalP.envelope-                  $< piecewiseConstantVector index)-               $&-               freq)-              &|&-              freq-           {--           channel_1_2 ::-              FuncP p VectorValue VectorValue ->-              FuncP p VectorValue VectorValue-           -}-           channel_1_2 freq =-              CausalPS.osciSimple WaveL.approxSine2-              $&-              ((CausalP.envelope-                  $< SigP.envelope-                        (piecewiseConstantVector depth)-                        (SigPS.exponential2 (timeConst 1) (vel+1)))-               <<<-               (CausalPS.osciSimple WaveL.approxSine2 $< zero)-               $&-               freq)-              &|&-              (CausalPS.amplify 2 $& freq)-       in  (CausalP.stereoFromMonoControlled-              (fadeProcess-                 (F.compile $ channel_n_1 $ F.lift id)-                 (F.compile $ channel_1_2 $ F.lift id))-              $< piecewiseConstantVector fade)-           $&-           stereoFreq--fenderFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-fenderFM =-   liftA2-      (\osc env dec rel detune index depth fade vcsize fm sr vel freq dur ->-         osc-            (sr, (((index, depth), fade), vel, (detune,fm,freq)))-            (env dec rel vcsize sr 0 dur))-      (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---fmModulator ::-   Param p Real ->-   Param p Real ->-   Param p (PC.T Real) ->-   CausalP p-      (Stereo.T VectorValue)-      (Stereo.T VectorValue)-fmModulator vel n depth =-   (CausalP.envelopeStereo-      $< SigP.envelope-            (piecewiseConstantVector depth)-            (SigPS.exponential2 (timeConst 1) (vel+1)))-   <<<-   CausalP.stereoFromMono-      (CausalPS.osciSimple WaveL.approxSine2 $< zero)-   <<<-   CausalPS.amplifyStereo n--tineModulatorBankFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-tineModulatorBankFM =-   liftA2-      (\osc env-            dec rel detune-            depth1 depth2 depth3 depth4-            vcsize fm sr vel freq dur ->-         osc-            (sr, ((depth1,(depth2,(depth3,(depth4)))), vel, (detune,fm,freq)))-            (env dec rel vcsize sr 0 dur))-      (CausalP.runStorableChunky $-       ParamS.withTuple2 $-       \((Control depth1, (Control depth2, (Control depth3, Control depth4))),-            Number vel, DetuneModulation fm) ->-              (CausalP.envelopeStereo $>-                 (CausalP.stereoFromMono-                     (CausalPS.osciSimple WaveL.approxSine2)-                  <<<-                  Stereo.interleave-                  ^<<-                  sumNested-                     [fmModulator vel 1 depth1,-                      fmModulator vel 2 depth2,-                      fmModulator vel 3 depth3,-                      fmModulator vel 4 depth4]-                    &&& id-                  $*-                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))-      pingReleaseEnvelope--tineBankFM ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-tineBankFM =-   liftA2-      (\osc env-            dec rel detune-            depth1 depth2 depth3 depth4-            partial1 partial2 partial3 partial4-            vcsize fm sr vel freq dur ->-         osc-            (sr,-             ((depth1,(depth2,(depth3,(depth4)))),-              (partial1,(partial2,(partial3,(partial4)))),-              (vel, (detune,fm,freq))))-            (env dec rel vcsize sr 0 dur))-      (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 =-                 A.mul amp =<<-                 WaveL.partial WaveL.approxSine2 n t-          in  CausalP.envelopeStereo $>-                 (CausalP.stereoFromMono-                     (CausalPS.shapeModOsci-                         (\(p1,(p2,(p3,p4))) t -> do-                             y1 <- A.mul p1 =<< WaveL.approxSine2 t-                             y2 <- partial p2 2 t-                             y3 <- partial p3 3 t-                             y4 <- partial p4 4 t-                             A.add y1 =<< A.add y2 =<< A.add y3 y4)-                        $<-                           (SigP.zip (piecewiseConstantVector partial1) $-                            SigP.zip (piecewiseConstantVector partial2) $-                            SigP.zip (piecewiseConstantVector partial3)-                                     (piecewiseConstantVector partial4)))-                  <<<-                  Stereo.interleave-                  ^<<-                  sumNested-                     [fmModulator vel 1 depth1,-                      fmModulator vel 2 depth2,-                      fmModulator vel 3 depth3,-                      fmModulator vel 4 depth4]-                    &&& id-                  $*-                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))-      pingReleaseEnvelope---{- |-FM synthesis where the modulator is a resonantly filtered sawtooth.-This way we get a sinus-like modulator where the sine frequency-(that is, something like the modulation index) can be controlled continously.--}-resonantFMSynthProc ::-   Param p (PC.T Real) ->-   Param p (PC.T Real) ->-   Param p (PC.T Real) ->-   Param p Real ->-   CausalP p-      (Stereo.T VectorValue)-      (Stereo.T VectorValue)-resonantFMSynthProc reson index depth vel =-   F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq ->-       let -- chan :: FuncP p inp VectorValue -> FuncP p inp VectorValue-           chan freq =-              CausalPS.osciSimple WaveL.approxSine2-              $&-              ((CausalP.envelope-                  $< SigP.envelope-                        (piecewiseConstantVector depth)-                        (SigPS.exponential2 (timeConst 1) (vel+1)))-               <<<-               UniFilter.lowpass-               ^<<-               CtrlPS.process-               $&-               (CausalP.zipWithSimple UniFilterL.parameter-                   <<<-                   CausalP.feedFst (piecewiseConstant reson)-                   <<<-                   (CausalP.envelope $< piecewiseConstant index)-                   <<<-                   CausalP.mapSimple Serial.subsample-                   $&-                   freq)-               &|&-               ((CausalPS.osciSimple WaveL.saw $< zero)-                $&-                freq))-              &|&-              freq-       in  Trav.traverse chan stereoFreq--resonantFMSynth ::-   IO (Real -> Real ->-       PC.T Real ->-       PC.T Real -> PC.T Real -> PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-resonantFMSynth =-   liftA2-      (\osc env dec rel detune reson index depth vcsize fm sr vel freq dur ->-         osc-            (sr, ((reson, index, depth), vel, (detune,fm,freq)))-            (env dec rel vcsize sr 0 dur))-      (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---phaserOsci ::-   (Param.T p Real -> CausalP.T p a VectorValue) ->-   CausalP.T p a (Stereo.T VectorValue)-phaserOsci osci =-   CausalPS.amplifyStereo 0.25-   <<<-   liftA2 Stereo.cons-      (sumNested $ map osci [1.0, -0.4, 0.5, -0.7])-      (sumNested $ map osci [0.4, -1.0, 0.7, -0.5])---softStringDetuneFM ::-   IO (Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-softStringDetuneFM =-   liftA2-      (\osc env att det fm sr vel freq dur ->-         osc (sr, (det, (fm,freq))) (env att sr vel dur))-      (let det = control fst-           fm  = modulation snd-           osci ::-              Param.T (det,fm) Real ->-              CausalP.T (det,fm)-                 (VectorValue, VectorValue)-                 VectorValue-           osci d =-              (CausalPS.osciSimple WaveL.saw $< zero)-              <<<-              CausalP.envelope-              <<<-              first (one + CausalPS.amplify d)-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (phaserOsci osci-               <<<-               CausalP.feedFst (piecewiseConstantVector det)-               $* frequencyFromBendModulation (frequencyConst 5) fm)))-      softStringReleaseEnvelope--{--We might decouple the frequency of the enveloped tone-from the frequency of the envelope,-in order to get something like formants.--}-softStringShapeFM, cosineStringStereoFM,-  arcSineStringStereoFM, arcTriangleStringStereoFM,-  arcSquareStringStereoFM, arcSawStringStereoFM ::-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-softStringShapeFM =-   softStringShapeCore WaveL.rationalApproxSine1-cosineStringStereoFM =-   softStringShapeCore-      (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p)-arcSawStringStereoFM = arcStringStereoFM WaveL.saw-arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2-arcSquareStringStereoFM = arcStringStereoFM WaveL.square-arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle--arcStringStereoFM ::-   (forall r.-    VectorValue ->-    LLVM.CodeGenFunction r VectorValue) ->-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-arcStringStereoFM wave =-   softStringShapeCore-      (\k p ->-         M.liftJoin2 Frame.amplifyMono-            (WaveL.approxSine4 =<< WaveL.halfEnvelope p)-            (wave =<< WaveL.replicate k p))--softStringShapeCore ::-   (forall r.-    VectorValue ->-    VectorValue ->-    LLVM.CodeGenFunction r VectorValue) ->-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-softStringShapeCore wave =-   liftA2-      (\osc env att det dist fm sr vel freq dur ->-         osc (sr, ((det, dist), (fm,freq))) (env att sr vel dur))-      (let det  = control (fst.fst)-           dist = control (snd.fst)-           fm   = modulation snd-           osci ::-              Param.T (mod,fm) Real ->-              CausalP.T (mod,fm)-                 (VectorValue,-                       {- wave shape parameter -}-                  (VectorValue, VectorValue)-                       {- detune, frequency modulation -})-                 VectorValue-           osci d =-              CausalPS.shapeModOsci wave-              <<<-              second-                 (CausalP.feedFst zero-                  <<<-                  CausalP.envelope-                  <<<-                  first (one + CausalPS.amplify d))-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (phaserOsci osci-               $< piecewiseConstantVector dist-               $< piecewiseConstantVector det-               $* frequencyFromBendModulation (frequencyConst 5) fm)))-      softStringReleaseEnvelope--fmStringStereoFM ::-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-fmStringStereoFM =-   liftA2-      (\osc env att det depth dist fm sr vel freq dur ->-         osc (sr, ((det, depth, dist), (fm, freq))) (env att sr vel dur))-      (let det   = control (fst3.fst)-           depth = control (snd3.fst)-           dist  = control (thd3.fst)-           fm  = modulation snd-           osci ::-              Param.T (mod,fm) Real ->-              CausalP.T (mod,fm)-                 ((VectorValue, VectorValue)-                       {- phase modulation depth, modulator distortion -},-                  (VectorValue, VectorValue)-                       {- detune, frequency modulation -})-                 VectorValue-           osci d =-              CausalPS.osciSimple WaveL.approxSine2-              <<<-              (CausalP.envelope-               <<<-               second-                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1-                     <<< second (CausalP.feedFst zero))-               <<^-               (\((dp, ds), f) -> (dp, (ds, f))))-               &&& arr snd-              <<<-              second-                 (CausalP.envelope <<<-                  first (one + CausalPS.amplify d))-       in  CausalP.runStorableChunky-              (CausalP.envelopeStereo <<<-                 (id &&&-                  (phaserOsci osci-                   <<<-                   CausalP.feedSnd-                      (SigP.zip-                         (piecewiseConstantVector det)-                         (frequencyFromBendModulation (frequencyConst 5) fm))-                   <<<-                   CausalP.feedSnd (piecewiseConstantVector dist)-                   <<<-                   (CausalP.envelope-                       $< piecewiseConstantVector depth)))))-      softStringReleaseEnvelope---stereoNoise :: SigP p (Stereo.T VectorValue)-stereoNoise =-   traverse-      (\uid -> SigPS.noise uid (noiseReference 20000))-      (Stereo.cons 13 14)--windCore ::-   Param p (PC.T Real) ->-   Param p (PC.T (BM.T Real)) ->-   SigP p (Stereo.T VectorValue)-windCore reson fm =-   CausalP.stereoFromMonoControlled CtrlPS.process-    $< Sig.zipWith-          (MoogL.parameter TypeNum.d8)-          (piecewiseConstant reson)-          (Sig.map Serial.subsample-             (frequencyFromBendModulation (frequencyConst 0.2) fm))-    $* stereoNoise--wind ::-   IO (Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-wind =-   liftA2-      (\osc env att reson fm sr vel freq dur ->-         osc (sr, (reson, (fm,freq))) (env att sr vel dur))-      (let reson = control fst-           fm = modulation snd-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $> windCore reson fm))-      softStringReleaseEnvelope---fadeProcess ::-   (A.PseudoRing v, A.IntegerConstant v) =>-   CausalP.T p a v ->-   CausalP.T p a v ->-   CausalP.T p (v, a) v-fadeProcess proc0 proc1 =-   let k = arr fst-       a0 = proc0 <<^ snd-       a1 = proc1 <<^ snd-   in  (one-k)*a0 + k*a1---windPhaser ::-   IO (Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T Real ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-windPhaser =-   liftA2-      (\osc env att phaserMix phaserFreq reson fm sr vel freq dur ->-         osc (sr, ((phaserMix,phaserFreq), reson, (fm,freq))) (env att sr vel dur))-      (let phaserMix = control (fst.fst3)-           phaserFreq = frequencyControl (snd.fst3)-           reson = control snd3-           fm = modulation thd3-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              ((CausalP.stereoFromMonoControlled-                   (fadeProcess (arr snd) CtrlPS.process-                    <<<-                    first (CausalP.mapSimple Serial.upsample)-                    <<^-                    (\((k,p),x) -> (k,(p,x))))-                  $< SigP.zip-                        (piecewiseConstant phaserMix)-                        (piecewiseConstant-                           (fmap (Allpass.flangerParameterPlain TypeNum.d8)-                               ^<< phaserFreq)))-               $*-               windCore reson fm)))-      softStringReleaseEnvelope---filterSawStereoFM ::-   IO (Real -> Real ->-       PC.T Real ->-       Real -> Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-filterSawStereoFM =-   liftA2-      (\osc env dec rel detune bright brightDecay vcsize fm sr vel freq dur ->-         osc-            (sr, ((bright, brightDecay), (detune,fm,freq)))-            (env dec rel vcsize sr vel dur))-      (CausalP.runStorableChunky-         (let bright    = frequency (fst.fst)-              brightDec = time (snd.fst)-              fm = detuneModulation snd-          in  CausalP.envelopeStereo $>-              (CausalP.stereoFromMono-                  (UniFilter.lowpass-                   ^<<-                   (CtrlPS.processCtrlRate $# (100::Real))-                      (\k -> Sig.map-                          (UniFilterL.parameter (LLVM.valueOf 10))-                          {- bound control in order to avoid too low resonant frequency,-                             which makes the filter instable -}-                          (SigP.exponentialBounded2-                              (frequencyConst 100)-                              (brightDec/k)-                              (bright)))-                   <<<-                   CausalPS.osciSimple WaveL.saw $< zero)-               $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)))-      pingReleaseEnvelope---{- |-The ADSR curve is composed from three parts:-Attack, Decay(+Sustain), Release.-Attack starts when the key is pressed-and lasts attackTime seconds-where it reaches height attackPeak*amplitudeOfVelocity.-It should be attackPeak>1 because in the following phase-we want to approach 1 from above.-Say the curve would approach the limit value L-if it would continue after the end of the attack phase,-the slope is determined by the halfLife with respect to this upper bound.-That is, attackHalfLife is the time in seconds where the attack curve-reaches or would reach L/2.-After Attack the Decay part starts at the same level-and decays to amplitudeOfVelocity.-The slope is again a halfLife,-that is, decayHalfLife is the time where the curve-drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity.-This phase lasts as long as the key is pressed.-If the key is released the curve decays with half life releaseHalfLife.--}-{--1 - 2^(-attackTime/attackHalfLife) = peak--}-adsr ::-   IO (Real -> Real -> Real ->-       Real -> Real ->-       SigSt.ChunkSize ->-       SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)-adsr =-   liftA3-      (\attack decay release-           attackTime attackPeak attackHalfLife-           decayHalfLife releaseHalfLife vcsize sr vel dur ->-         let amp = amplitudeFromVelocity vel-             (attackDur, decayDur) =-                CutG.splitAt (round (attackTime * vectorRate sr)) dur-         in  SigStL.continuePacked-                (attack (chunkSizesFromLazyTime attackDur)-                    (sr,-                     (attackHalfLife,-                      attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))))-                 `SigSt.append`-                 decay (chunkSizesFromLazyTime decayDur)-                    (sr,-                     (decayHalfLife,-                      ((attackPeak-1)*amp, amp))))-                (\x -> release vcsize (sr,(releaseHalfLife,x))))-      (SigP.runChunkyPattern $-       let halfLife  = time fst-           amplitude = number snd-       in  SigPS.constant amplitude --           SigPS.exponential2 halfLife amplitude)-      (SigP.runChunkyPattern $-       let halfLife   = time fst-           amplitude  = number (fst.snd)-           saturation = number (snd.snd)-       in  SigPS.constant saturation +-           SigPS.exponential2 halfLife amplitude)-      (SigP.runChunky $-       let releaseTime = vectorTime fst * 5-           releaseHL   = time fst-           amplitude   = number snd-       in  CausalP.take (round ^<< releaseTime) $*-           SigPS.exponential2 releaseHL amplitude)--brass ::-   IO (Real -> Real ->-       Real -> Real -> Real -> Real ->-       PC.T Real ->-       PC.T Real ->-       SigSt.ChunkSize ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-brass =-   liftA2-      (\osc env attTime attPeak attHL dec rel emph det dist vcsize fm sr vel freq dur ->-         osc-            (sr,-             ((det, dist), (fm,freq),-              env attTime emph attHL dec rel vcsize sr vel dur))-            (env attTime attPeak attHL dec rel vcsize sr vel dur))-      (let det  = control (fst.fst3)-           dist = control (snd.fst3)-           fm   = modulation snd3-           emph = signal thd3-           osci ::-              Param.T p Real ->-              CausalP.T p-                 (VectorValue,-                       {- wave shrink/replication factor -}-                  (VectorValue, VectorValue)-                       {- detune, frequency modulation -})-                 VectorValue-           osci d =-              CausalPS.shapeModOsci WaveL.rationalApproxSine1-              <<<-              second-                 (CausalP.feedFst zero-                  <<<-                  CausalP.envelope-                  <<<-                  first (one + CausalPS.amplify d))-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (phaserOsci osci-               <<<-               CausalP.feedFst (piecewiseConstantVector dist)-               <<<-               CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) fm)-               <<<-               (CausalP.envelope $< piecewiseConstantVector det)-               $*-               SigP.fromStorableVectorLazy emph)))-      adsr---sampledSound ::-   IO (Sample.T ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-sampledSound =-   liftA2-      (\osc freqMod smp fm sr vel freq dur ->-         {--         We split the frequency modulation signal-         in order to get a smooth frequency modulation curve.-         Without (periodic) frequency modulation-         we could just split the piecewise constant control curve @fm@.-         -}-         let fmSig =-                freqMod-                   (chunkSizesFromLazyTime (PC.duration fm))-                   (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector-             pos = Sample.positions smp-             amp = 2 * amplitudeFromVelocity vel-             (attack, sustain, release) = Sample.parts smp-         in  (\cont -> osc cont-                (sr,-                 (amp,-                  attack `SigSt.append`-                  SVL.cycle (SigSt.take (Sample.loopLength pos) sustain),-                  chunkSizesFromLazyTime dur))-                fmSig)-             (osc (const SigSt.empty)-                (sr, (amp, release, NonNegChunky.fromChunks (repeat 1000)))))-      (CausalP.runStorableChunkyCont-         (let amp = number fst3-              smp = signal snd3-              dur = parameter thd3-          in  CausalPS.amplifyStereo amp-              <<<-              CausalP.stereoFromMono-                 (CausalPS.pack-                    (CausalP.frequencyModulationLinear-                       (SigP.fromStorableVectorLazy smp)))-              <<<-              liftA2 Stereo.cons-                 (CausalPS.amplify 0.999)-                 (CausalPS.amplify 1.001)-              <<<-              arr fst-              <<<-              CausalP.feedSnd (SigP.lazySize dur)))-      (SigP.runChunkyPattern-         (frequencyFromBendModulation (frequencyConst 3) (modulation id)))---_sampledSoundLeaky ::-   IO (Sample.T ->-       PC.T (BM.T Real) ->-       Instrument Real (Stereo.T Vector))-_sampledSoundLeaky =-   liftA2-      (\osc freqMod smp fm sr vel freq dur ->-         {--         We split the frequency modulation signal-         in order to get a smooth frequency modulation curve.-         Without (periodic) frequency modulation-         we could just split the piecewise constant control curve @fm@.-         -}-         let (sustainFM, releaseFM) =-                SVP.splitAt (chunkSizesFromLazyTime dur) $-                (freqMod-                   (chunkSizesFromLazyTime (PC.duration fm))-                   (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector)-             pos = Sample.positions smp-             amp = 2 * amplitudeFromVelocity vel-             (attack, sustain, release) = Sample.parts smp-         in  osc-                (sr,-                 (amp,-                  attack `SigSt.append`-                  SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))-                sustainFM-             `SigSt.append`-             osc (sr, (amp,release)) releaseFM)-      (CausalP.runStorableChunky-         (let smp = signal snd-              amp = number fst-          in  CausalPS.amplifyStereo amp-              <<<-              CausalP.stereoFromMono-                 (CausalPS.pack-                    (CausalP.frequencyModulationLinear-                       (SigP.fromStorableVectorLazy smp)))-              <<<-              liftA2 Stereo.cons-                 (CausalPS.amplify 0.999)-                 (CausalPS.amplify 1.001)))-      (SigP.runChunkyPattern-         (frequencyFromBendModulation (frequencyConst 3) (modulation id)))+   tonal noise can be produced by modulating pink noise+      experimental: multiply with waveforms other than sine+   use bits of an ASCII code as waveform+   use a greymap picture as source of waveforms+   mix of detuned noisy-waverforms, try different and uniform waveforms+   mix of sawtooth, where every sawtooth is modulated with red noise+   mix of sine with harmonics where every harmonic is modulated differently+   Flute: sine + filtered noise+   Drum with various parameters+   derive percussive instruments from fmString and arcString (for bass synths)+   an FM sound with a slowly changing timbre+      by using a very slightly detuned frequency for the modulator+   making a tone out of noise using time stretch with helix algorithm+      a chorus effect could be applied by two successive helix stretches+      or by mixture of two stretches signals+      additionally a resonant filter could be applied+   a kind of Karplus-Strong algorithm with a non-linear function of past values+      e.g. y(t) = f(y(t-d), y(t-2*d))+      where d is the tone period and f is non-linear, maybe chaotic function.+      In order to limit the appearance of chaotic waveforms,+      we could combine this with a lowpass filter.+   let attack and release depend on On and Off velocity+   tineStereoFM:+      continuous control of the modulation index+      by linear interpolation of waves between modulations with integral indices.+      E.g. modulation index 2.3 means+      0.7*modulation with index 2 and 0.3*modulation with index 3.++effects:+   reverb and controllable delay+   phaser or Chebyshev filter+   reverb where many single combs are mixed+      every comb has ever-increasing frequency, but is faded in and out.+      Should give an endless effect where the reverb becomes higher and higher.++continuous sounds:+   fly+   water/bubbles+      when I accidentally did not scale filter frequency with sample rate,+      the filter sound much like water bubbles.+      I think a control curve consisting of some ramps will do the same.+   hail, Geiger counter, pitch applied by comb filter+      at a very high impulse rate the impulses itself+      can generate an almost periodic signal+++Speech sounds improvements (tomatensalat)+   use PSOLA for transposition+   To this end divide signal into tonal part and residue (noise)+   by a comb filter.+   Maybe a non-linear comb filter may help,+   that selects the center value from the filter window,+   if the side values are similar+   and returns zero, if the the side values differ too much.+   Process the tonal part by PSOLA and+   simply mix it with the non-tonal part on replay.++Harmonizer-like:+   We like to input an audio signal of speech+   and a set of keys, and the speech is extended to chords+   according to the pressed keys.+   The lowest key is interpreted as base frequency of the input audio speech.+   A PSOLA method transposes the audio input.++Resonant filter controlled by keys+   applied to an audio input signal+   or an ordinary audio signal generated by other keys.+   The splitting of keys however could be performed+   by a MIDI event stream editor.+-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE EmptyDataDecls #-}+module Synthesizer.LLVM.Server.Packed.Instrument (+   InputArg(..),+   FrequencyControl,+   Modulation,+   DetuneModulation,++   pingRelease,+   pingStereoRelease,+   pingStereoReleaseFM,+   squareStereoReleaseFM,+   bellStereoFM,+   bellNoiseStereoFM,+   tine,+   tineStereo,+   softString,+   softStringFM,+   tineStereoFM,+   tineControlledFM,+   fenderFM,+   tineModulatorBankFM,+   tineBankFM,+   resonantFMSynth,+   softStringDetuneFM,+   softStringShapeFM, cosineStringStereoFM,+   arcSineStringStereoFM, arcTriangleStringStereoFM,+   arcSquareStringStereoFM, arcSawStringStereoFM,+   fmStringStereoFM,+   wind,+   windPhaser,+   filterSawStereoFM,+   brass,+   sampledSound,++   -- * helper functions+   stereoNoise,+   frequencyFromBendModulation,+   piecewiseConstantVector,++   -- * for testing+   pingReleaseEnvelope,+   adsr,+   ) where++import Synthesizer.LLVM.Server.CommonPacked+import Synthesizer.LLVM.Server.Common++import qualified Synthesizer.LLVM.Server.SampledSound as Sample+import qualified Synthesizer.LLVM.MIDI.BendModulation as BM+import qualified Synthesizer.LLVM.ConstantPiece as Const+import qualified Synthesizer.MIDI.PiecewiseConstant as PC+import qualified Synthesizer.MIDI.EventList as Ev++import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime)++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL+import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.Moog as MoogL+import qualified Synthesizer.LLVM.MIDI as MIDIL+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Causal.Functional as F+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame as Frame+import qualified Synthesizer.LLVM.Wave as WaveL+import Synthesizer.LLVM.Causal.Process (($<#), ($*), ($<), ($>))+import Synthesizer.LLVM.Causal.Functional (($&), (&|&))++import qualified LLVM.DSL.Expression as Expr+import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import qualified Type.Data.Num.Decimal as TypeNum++import qualified Synthesizer.Causal.Class         as CausalClass+import qualified Synthesizer.Generic.Cut          as CutG+import qualified Synthesizer.Storable.Signal      as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SVP+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)++import qualified Data.Traversable as Trav+import Data.Traversable (traverse)+import Data.Semigroup ((<>))++import Data.Tuple.HT (fst3, snd3, thd3)++import qualified Numeric.NonNegative.Chunky as NonNegChunky++import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, one, round, (^?), (+), (-), (*))+import Prelude hiding (Real, round, break, id, (+), (-), (*))++++frequencyControl ::+   (MultiValue.Field a, MultiValue.RationalConstant a) =>+   SampleRate (Exp a) ->+   Sig.T (Const.T (MultiValue.T a)) ->+   Sig.T (Const.T (MultiValue.T a))+frequencyControl sr xs = Const.causalMap (frequency sr) $* xs++data FrequencyControl a++instance+   (a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) =>+      Input (FrequencyControl b) a where+   data InputArg (FrequencyControl b) a =+         FrequencyControl (Sig.T (Const.T (MultiValue.T b)))+   type InputSource (FrequencyControl b) a =+         Sig.T (Const.T (MultiValue.T b))+   evalInput sampleRate =+      FrequencyControl . frequencyControl sampleRate+++modulation ::+   (MultiValue.Field a, MultiValue.RationalConstant a) =>+   SampleRate (Exp a) ->+   (Sig.T (Const.T (MultiValue.T (BM.T a))), Exp a) ->+   Sig.T (Const.T (BM.T (MultiValue.T a)))+modulation sr (fm,freq) =+   transposeModulation sr freq (fmap BM.unMultiValue <$> fm)++data Modulation a++instance+   (a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) =>+      Input (Modulation b) a where+   data InputArg (Modulation b) a =+         Modulation (Sig.T (Const.T (BM.T (MultiValue.T b))))+   type InputSource (Modulation b) a =+         (Sig.T (Const.T (MultiValue.T (BM.T b))), Exp b)+   evalInput sampleRate (fm,freq) =+      Modulation $ modulation sampleRate (fm,freq)+++detuneModulation ::+   (MultiValue.Field a, MultiValue.RationalConstant a) =>+   SampleRate (Exp a) ->+   (b, Sig.T (Const.T (MultiValue.T (BM.T a))), Exp a) ->+   (b, Sig.T (Const.T (BM.T (MultiValue.T a))))+detuneModulation sr (det,fm,freq) =+   (det, transposeModulation sr freq (fmap BM.unMultiValue <$> fm))++data DetuneModulation a++instance+   (a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) =>+      Input (DetuneModulation b) a where+   data InputArg (DetuneModulation b) a =+         DetuneModulation+            (Sig.T (Const.T (MultiValue.T b)),+             Sig.T (Const.T (BM.T (MultiValue.T b))))+   type InputSource (DetuneModulation b) a =+         (Sig.T (Const.T (MultiValue.T b)),+          Sig.T (Const.T (MultiValue.T (BM.T b))),+          Exp b)+   evalInput sampleRate (det,fm,freq) =+      DetuneModulation $ detuneModulation sampleRate (det,fm,freq)+++type RealValue = MultiValue.T Real++frequencyFromBendModulation ::+   Exp Real ->+   Sig.T (Const.T (BM.T RealValue)) ->+   Sig.T VectorValue+frequencyFromBendModulation speed fmFreq =+   MIDIL.frequencyFromBendModulationPacked speed $* piecewiseConstant fmFreq++stereoFrequenciesFromDetuneBendModulation ::+   Exp Real ->+   (Sig.T (Const.T RealValue), Sig.T (Const.T (BM.T RealValue))) ->+   Sig.T (Stereo.T VectorValue)+stereoFrequenciesFromDetuneBendModulation speed (det,fm) =+   (Causal.envelopeStereo $< frequencyFromBendModulation speed fm)+   <<<+   liftA2 Stereo.cons (one + id) (one - id)+   $* piecewiseConstantVector det++piecewiseConstantVector :: Sig.T (Const.T RealValue) -> Sig.T VectorValue+piecewiseConstantVector xs =+   piecewiseConstant (Const.causalMap Serial.upsample $* xs)++pingReleaseEnvelope ::+   IO (Real -> Real ->+       SigSt.ChunkSize ->+       SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)+pingReleaseEnvelope =+   liftA2+      (\pressed release decay rel vcsize sr vel dur ->+         SigStL.continuePacked+            (pioApplyToLazyTime (pressed sr decay vel) dur)+            (\x -> release vcsize sr rel x))+      (CausalRender.run $+       wrapped $ \(Time decay) (Number velocity) (SampleRate _sr) ->+       Causal.fromSignal+         (SigPS.exponential2 decay (amplitudeFromVelocity velocity)))+      (Render.run $+       wrapped $ \(Time releaseHL) (Number amplitude) (SampleRate _sr) ->+       let releaseTime = releaseHL * 5 / fromIntegral vectorSize+       in Causal.take (Expr.roundToIntFast releaseTime) $*+          SigPS.exponential2 releaseHL amplitude)++pingRelease ::+   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)+pingRelease =+   liftA2+      (\osc env dec rel vcsize sr vel freq dur ->+         pioApply (osc sr freq) (env dec rel vcsize sr vel dur))+      (CausalRender.run $ wrapped $ \(Frequency freq) (SampleRate _sr) ->+         Causal.envelope $> SigPS.osci WaveL.saw zero freq)+      pingReleaseEnvelope++pingStereoRelease ::+   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))+pingStereoRelease =+   liftA2+      (\osc env dec rel vcsize sr vel freq dur ->+         pioApply (osc sr freq) (env dec rel vcsize sr vel dur))+      (CausalRender.run $ wrapped $ \(Frequency freq) (SampleRate _sr) ->+         Stereo.multiValue <$>+         Causal.envelopeStereo $>+         liftA2 Stereo.cons+            (SigPS.osci WaveL.saw zero (0.999*freq))+            (SigPS.osci WaveL.saw zero (1.001*freq)))+      pingReleaseEnvelope++pingStereoReleaseFM ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real ->+       Real -> Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+pingStereoReleaseFM =+   liftA2+      (\osc env dec rel detune shape phase phaseDecay vcsize fm+            sr vel freq dur ->+         pioApply+            (osc sr (phase, phaseDecay) shape (detune, fm, freq))+            (env dec rel vcsize sr vel dur))+      (CausalRender.run $+       wrapped $+         \(Number phase, Time decay) (Control shape) (DetuneModulation fm) ->+       constant frequency 10 $ \speed _sr ->+         Stereo.multiValue <$>+         Causal.envelopeStereo $>+         ((Causal.stereoFromMonoControlled+             (CausalPS.shapeModOsci WaveL.rationalApproxSine1)+               $< piecewiseConstantVector shape)+             <<^ Stereo.interleave+           $< (liftA2 Stereo.cons id (Additive.negate id)+                $* SigPS.exponential2 decay phase)+           $* stereoFrequenciesFromDetuneBendModulation speed fm))+      pingReleaseEnvelope++{- |+Square like wave constructed as difference+of two phase shifted sawtooth like oscillations.+-}+squareStereoReleaseFM ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+squareStereoReleaseFM =+   liftA2+      (\osc env dec rel detune shape phase vcsize fm sr vel freq dur ->+         pioApply+            (osc sr (phase, shape) (detune, fm, freq))+            (env dec rel vcsize sr vel dur))+      (CausalRender.run $+       wrapped $ \(Control phs, Control shp) (DetuneModulation fm) ->+       constant frequency 10 $ \speed _sr ->+         (let chanOsci ::+                 Causal.T+                    ((VectorValue, VectorValue), VectorValue)+                    VectorValue+              chanOsci =+                 ((CausalPS.shapeModOsci WaveL.rationalApproxSine1+                   <<<+                   second (first (Additive.negate id)))+                  -+                   CausalPS.shapeModOsci WaveL.rationalApproxSine1)+                 <<^+                 (\((p,s),f) -> (s,(p,f)))+          in Stereo.multiValue <$>+             Causal.envelopeStereo $>+              ((Causal.stereoFromMonoControlled chanOsci+                   $< liftA2 (,)+                         (piecewiseConstantVector phs)+                         (piecewiseConstantVector shp))+                $* stereoFrequenciesFromDetuneBendModulation speed fm)))+      pingReleaseEnvelope+++type Triple a = (a, a, a)++bellStereoFM ::+   IO (Real -> Real ->+       PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+bellStereoFM =+   liftA2+      (\osc env dec rel detune vcsize fm sr vel freq dur ->+         pioApply+             (osc sr (detune, fm, freq) vel+                  (env (dec/4) rel vcsize sr vel dur)+                  (env (dec/7) rel vcsize sr vel dur))+             (env dec rel vcsize sr vel dur))+      (CausalRender.run $+       wrapped $+       \(DetuneModulation fm) (Number vel) (Signal env4) (Signal env7) ->+       constant frequency 5 $ \speed _sr ->+         (let osci ::+                 (Triple VectorValue -> VectorValue) ->+                 Exp Real ->+                 Exp Real ->+                 Causal.T+                    (Triple VectorValue, Stereo.T VectorValue)+                    (Stereo.T VectorValue)+              osci sel v d =+                 Causal.envelopeStereo+                 <<<+                 (arr sel ***+                    (CausalPS.amplifyStereo v+                     <<<+                     Causal.stereoFromMono+                        (CausalPS.osci WaveL.approxSine4 $< zero)+                     <<<+                     CausalPS.amplifyStereo d))+          in  Stereo.multiValue <$>+              sumNested+                 [osci fst3  0.6              1,+                  osci snd3 (0.02 *  50^?vel) 4,+                  osci thd3 (0.02 * 100^?vel) 7]+              <<<+              CausalClass.feedSnd+                 (stereoFrequenciesFromDetuneBendModulation speed fm)+              <<<+              arr (\(e1,(e4,e7)) -> (e1,e4,e7))+               $> {-+                  Be careful, those storable vectors shorten the whole sound+                  if they have shorter release than the main envelope.+                  -}+                  liftA2 (,) env4 env7))+      pingReleaseEnvelope++bellNoiseStereoFM ::+   IO (Real -> Real ->+       PC.T Real -> PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+bellNoiseStereoFM =+   liftA2+      (\osc env dec rel noiseAmp noiseReson vcsize fm sr vel freq dur ->+         pioApply+            (osc sr (fm, freq) (noiseAmp, noiseReson) vel+               (env (dec/4) rel vcsize sr vel dur)+               (env (dec/7) rel vcsize sr vel dur))+            (env dec rel vcsize sr vel dur))+      (CausalRender.run $+       wrapped $+       \(Modulation fm) (Control noiseAmp, Control noiseReson)+         (Number vel) (Signal env4) (Signal env7) ->+       constant noiseReference 20000 $ \noiseRef ->+       constant frequency 5 $ \speed _sr ->+         (let osci ::+                 (Triple VectorValue -> VectorValue) ->+                 Exp Real ->+                 Exp Real ->+                 Causal.T (Triple VectorValue, VectorValue) VectorValue+              osci sel v d =+                 Causal.envelope+                 <<<+                 (arr sel ***+                    (CausalPS.amplify v+                     <<<+                     (CausalPS.osci WaveL.approxSine4 $< zero)+                     <<<+                     CausalPS.amplify d))++              noise ::+                 (Triple VectorValue -> VectorValue) ->+                 Exp Real ->+                 Causal.T (Triple VectorValue, VectorValue) VectorValue+              noise sel d =+                 (Causal.envelope $< piecewiseConstantVector noiseAmp)+                 <<<+                 Causal.envelope+                 <<<+                 (arr sel ***+                    ({- UniFilter.lowpass+                        ^<< -}+                     (CtrlPS.process $> SigPS.noise 12 noiseRef)+                     <<<+{-+                     (Causal.quantizeLift+                        (Causal.zipWith UniFilterL.parameter)+                        $<# (128 / fromIntegral vectorSize :: Real))+-}+                     (Causal.quantizeLift+                        (Causal.zipWith (MoogL.parameter TypeNum.d8))+                        $<# (128 / fromIntegral vectorSize :: Real))+                     <<<+                     CausalClass.feedFst (piecewiseConstant noiseReson)+                     <<<+                     Causal.map Serial.subsample+                     <<<+                     CausalPS.amplify d))+          in  liftA2 Stereo.consMultiValue+                 (sumNested+                    [osci fst3  0.6              (1*0.999),+                     osci snd3 (0.02 *  50^?vel) (4*0.999),+                     osci thd3 (0.02 * 100^?vel) (7*0.999),+                     noise fst3 0.999])+                 (sumNested+                    [osci fst3  0.6              (1*1.001),+                     osci snd3 (0.02 *  50^?vel) (4*1.001),+                     osci thd3 (0.02 * 100^?vel) (7*1.001),+                     noise fst3 1.001])+              <<<+              CausalClass.feedSnd (frequencyFromBendModulation speed fm)+              <<<+              arr (\(e1,(e4,e7)) -> (e1,e4,e7))+               $> {-+                  Be careful, those storable vectors shorten the whole sound+                  if they have shorter release than the main envelope.+                  -}+                  liftA2 (,) env4 env7))+      pingReleaseEnvelope+++tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)+tine =+   liftA2+      (\osc env dec rel vcsize sr vel freq dur ->+         pioApply (osc sr vel freq) (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Number vel) (Frequency freq) ->+       constant time 1 $ \halfLife _sr ->+         (Causal.envelope $>+            (CausalPS.osci WaveL.approxSine2+               $> SigPS.constant freq+               $* (Causal.envelope+                     $< SigPS.exponential2 halfLife (vel+1)+                     $* SigPS.osci WaveL.approxSine2 zero (2*freq)))))+      pingReleaseEnvelope++tineStereo ::+   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))+tineStereo =+   liftA2+      (\osc env dec rel vcsize sr vel freq dur ->+         pioApply (osc sr vel freq) (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Number vel) (Frequency freq) ->+       constant time 1 $ \halfLife _sr ->+         (let chanOsci d =+                 CausalPS.osci WaveL.approxSine2 $> SigPS.constant (freq*d)+          in Stereo.multiValue <$>+             Causal.envelopeStereo $>+               (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005)+                  $* (SigPS.exponential2 halfLife (vel+1) *+                      SigPS.osci WaveL.approxSine2 zero (2*freq)))))+      pingReleaseEnvelope+++softStringReleaseEnvelope ::+   IO (Real -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)+softStringReleaseEnvelope =+   liftA2+      (\rev env attackTime sr vel dur ->+         let attackTimeVector :: Word+             attackTimeVector = round (attackTime * vectorRate sr)+             {-+             release <- take attackTime beginning+             would yield a space leak, thus we first split 'beginning'+             and then concatenate it again+             -}+             {-+             We can not easily generate attack and sustain separately,+             because we want to use the chunk structure implied by 'dur'.+             -}+             (attack, sustain) =+                SigSt.splitAt (fromIntegral attackTimeVector) $+                pioApplyToLazyTime+                  (env sr (amplitudeFromVelocity vel) attackTimeVector)+                  dur+             release = rev attack+         in  attack <> sustain <> release)+      SigStL.makeReversePacked+      (CausalRender.run $+       wrapped $ \(Number amp) (Parameter attackTimeVector) (SampleRate _sr) ->+       Causal.fromSignal $+           (<> SigPS.constant amp) $+           (CausalPS.amplify amp <<<+            Causal.take attackTimeVector+            $* SigPS.parabolaFadeInInf+                  (fromIntegral vectorSize *+                   Expr.fromIntegral attackTimeVector)))++softString :: IO (Instrument Real (Stereo.T Vector))+softString =+   liftA2+      (\osc env sr vel freq dur ->+         pioApply (osc sr freq) (env 1 sr vel dur))+      (CausalRender.run $+       wrapped $ \(Frequency freq) (SampleRate _sr) ->+       let osci d = SigPS.osci WaveL.saw zero (d * freq)+       in Stereo.multiValue <$>+           Causal.envelopeStereo $>+              (liftA2 Stereo.cons+                 (osci 1.005 + osci 0.998)+                 (osci 1.002 + osci 0.995)))+      softStringReleaseEnvelope+++softStringFM :: IO (PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector))+softStringFM =+   liftA2+      (\osc env fm sr vel freq dur ->+         pioApply (osc sr (fm, freq)) (env 1 sr vel dur))+      (CausalRender.run $+       wrapped $ \(Modulation fm) ->+       constant frequency 5 $ \speed _sr ->+       let osci d = (CausalPS.osci WaveL.saw $< zero) <<< CausalPS.amplify d+       in Stereo.multiValue <$>+           (Causal.envelopeStereo $>+              (liftA2 Stereo.cons+                  (osci 1.005 + osci 0.998)+                  (osci 1.002 + osci 0.995)+               $* frequencyFromBendModulation speed fm)))+      softStringReleaseEnvelope+++tineStereoFM ::+   IO (Real -> Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+tineStereoFM =+   liftA2+      (\osc env dec rel vcsize fm sr vel freq dur ->+         pioApply (osc sr vel (fm, freq)) (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Number vel) (Modulation fm) ->+       constant time 1 $ \halfLife ->+       constant frequency 5 $ \speed _sr ->+         (let chanOsci d =+                 CausalPS.osci WaveL.approxSine2+                    <<< second (CausalPS.amplify d)+          in Stereo.multiValue <$>+              Causal.envelopeStereo $>+                 (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005)+                  <<<+                  (((Causal.envelope+                       $< SigPS.exponential2 halfLife (vel+1))+                     <<< (CausalPS.osci WaveL.approxSine2 $< zero)+                     <<< CausalPS.amplify 2)+                   &&& id)+                  $* frequencyFromBendModulation speed fm)))+      pingReleaseEnvelope+++_tineControlledProc, tineControlledFnProc ::+   Sig.T (Const.T RealValue) ->+   Sig.T (Const.T RealValue) ->+   Exp Real ->+   SampleRate (Exp Real) ->+   Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)+_tineControlledProc index depth vel = constant time 1 $ \halfLife _sr ->+   Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2)+   <<<+   Stereo.interleave+   ^<<+   ((Causal.envelopeStereo+       $< (piecewiseConstantVector depth+           *+           SigPS.exponential2 halfLife (vel+1)))+    <<<+    Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero)+    <<<+    (Causal.envelopeStereo $< piecewiseConstantVector index))+            &&& id++tineControlledFnProc index depth vel = constant time 1 $ \halfLife _sr ->+   F.withGuidedArgs F.atom $ \freq ->+      Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2)+      $&+      liftA2 (liftA2 (,))+         ((Causal.envelopeStereo+             $< (piecewiseConstantVector depth+                 *+                 SigPS.exponential2 halfLife (vel+1)))+          <<<+          Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero)+          <<<+          (Causal.envelopeStereo $< piecewiseConstantVector index)+          $&+          freq)+         freq++tineControlledFM ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real -> PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+tineControlledFM =+   liftA2+      (\osc env dec rel detune index depth vcsize fm sr vel freq dur ->+         pioApply+            (osc sr (index, depth) vel (detune, fm, freq))+            (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Control index, Control depth)+          (Number vel) (DetuneModulation fm) ->+       constant frequency 5 $ \speed sr ->+         Stereo.multiValue <$>+         Causal.envelopeStereo $>+            (tineControlledFnProc index depth vel sr $*+             stereoFrequenciesFromDetuneBendModulation speed fm))+      pingReleaseEnvelope+++fenderProc ::+   Sig.T (Const.T RealValue) ->+   Sig.T (Const.T RealValue) ->+   Sig.T (Const.T RealValue) ->+   Exp Real ->+   SampleRate (Exp Real) ->+   Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)+fenderProc fade index depth vel = constant time 1 $ \halfLife _sr ->+   F.withGuidedArgs F.atom $ \stereoFreq ->+       let channel_n_1 ::+              F.T VectorValue VectorValue ->+              F.T VectorValue VectorValue+           channel_n_1 freq =+              CausalPS.osci WaveL.approxSine2+              $&+              ((Causal.envelope+                  $< (piecewiseConstantVector depth+                      *+                      SigPS.exponential2 halfLife (vel+1)))+               <<<+               (CausalPS.osci WaveL.approxSine2 $< zero)+               <<<+               (Causal.envelope $< piecewiseConstantVector index)+               $&+               freq)+              &|&+              freq+           channel_1_2 ::+              F.T VectorValue VectorValue ->+              F.T VectorValue VectorValue+           channel_1_2 freq =+              CausalPS.osci WaveL.approxSine2+              $&+              ((Causal.envelope+                  $< (piecewiseConstantVector depth+                      *+                      SigPS.exponential2 halfLife (vel+1)))+               <<<+               (CausalPS.osci WaveL.approxSine2 $< zero)+               $&+               freq)+              &|&+              (CausalPS.amplify 2 $& freq)+       in  (Causal.stereoFromMonoControlled+              (fadeProcess+                 (F.compile $ channel_n_1 $ F.lift id)+                 (F.compile $ channel_1_2 $ F.lift id))+              $< piecewiseConstantVector fade)+           $&+           stereoFreq++fenderFM ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real -> PC.T Real -> PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+fenderFM =+   liftA2+      (\osc env dec rel detune index depth fade vcsize fm sr vel freq dur ->+         pioApply+            (osc sr (index, depth) fade vel (detune, fm, freq))+            (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Control index, Control depth) (Control fade)+            (Number vel) (DetuneModulation fm) ->+       constant frequency 5 $ \speed sr ->+         Stereo.multiValue <$>+         Causal.envelopeStereo $>+            (fenderProc fade index depth vel sr $*+             stereoFrequenciesFromDetuneBendModulation speed fm))+      pingReleaseEnvelope+++fmModulator ::+   Exp Real ->+   Exp Real ->+   Sig.T (Const.T RealValue) ->+   SampleRate (Exp Real) ->+   Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)+fmModulator vel n depth = constant time 1 $ \halfLife _sr ->+   (Causal.envelopeStereo+      $< (piecewiseConstantVector depth+          *+          SigPS.exponential2 halfLife (vel+1)))+   <<<+   Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero)+   <<<+   CausalPS.amplifyStereo n++tineModulatorBankFM ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+tineModulatorBankFM =+   liftA2+      (\osc env+            dec rel detune+            depth1 depth2 depth3 depth4+            vcsize fm sr vel freq dur ->+         pioApply+            (osc sr depth1 depth2 depth3 depth4 vel (detune, fm, freq))+            (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $+       \(Control depth1) (Control depth2) (Control depth3) (Control depth4)+           (Number vel) (DetuneModulation fm) ->+       constant frequency 5 $ \speed sr ->+           Stereo.multiValue <$>+              (Causal.envelopeStereo $>+                 (Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2)+                  <<<+                  Stereo.interleave+                  ^<<+                  sumNested+                     [fmModulator vel 1 depth1 sr,+                      fmModulator vel 2 depth2 sr,+                      fmModulator vel 3 depth3 sr,+                      fmModulator vel 4 depth4 sr]+                    &&& id+                  $*+                  stereoFrequenciesFromDetuneBendModulation speed fm)))+      pingReleaseEnvelope++tineBankFM ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->+       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+tineBankFM =+   liftA2+      (\osc env+            dec rel detune+            depth1 depth2 depth3 depth4+            partial1 partial2 partial3 partial4+            vcsize fm sr vel freq dur ->+         pioApply+            (osc sr depth1 depth2 depth3 depth4+               partial1 partial2 partial3 partial4+               vel (detune, fm, freq))+            (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $+         \(Control depth1) (Control depth2) (Control depth3) (Control depth4)+            (Control partial1) (Control  partial2)+               (Control partial3) (Control partial4)+            (Number vel) (DetuneModulation fm) ->+       constant frequency 5 $ \speed sr ->++         (let partial ::+                 VectorValue -> Int -> VectorValue ->+                 LLVM.CodeGenFunction r VectorValue+              partial amp n t =+                 A.mul amp =<<+                 WaveL.partial WaveL.approxSine2 n t+          in  Stereo.multiValue <$>+              Causal.envelopeStereo $>+                 (Causal.stereoFromMono+                     (CausalPS.shapeModOsci+                         (\(p1,(p2,(p3,p4))) t -> do+                             y1 <- A.mul p1 =<< WaveL.approxSine2 t+                             y2 <- partial p2 2 t+                             y3 <- partial p3 3 t+                             y4 <- partial p4 4 t+                             A.add y1 =<< A.add y2 =<< A.add y3 y4)+                        $<+                           (liftA2 (,) (piecewiseConstantVector partial1) $+                            liftA2 (,) (piecewiseConstantVector partial2) $+                            liftA2 (,) (piecewiseConstantVector partial3)+                                       (piecewiseConstantVector partial4)))+                  <<<+                  Stereo.interleave+                  ^<<+                  sumNested+                     [fmModulator vel 1 depth1 sr,+                      fmModulator vel 2 depth2 sr,+                      fmModulator vel 3 depth3 sr,+                      fmModulator vel 4 depth4 sr]+                    &&& id+                  $*+                  stereoFrequenciesFromDetuneBendModulation speed fm)))+      pingReleaseEnvelope+++{- |+FM synthesis where the modulator is a resonantly filtered sawtooth.+This way we get a sinus-like modulator where the sine frequency+(that is, something like the modulation index) can be controlled continously.+-}+resonantFMSynthProc ::+   Sig.T (Const.T RealValue) ->+   Sig.T (Const.T RealValue) ->+   Sig.T (Const.T RealValue) ->+   Exp Real ->+   SampleRate (Exp Real) ->+   Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)+resonantFMSynthProc reson index depth vel =+   constant time 1 $ \halfLife _sr ->+   F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq ->+       let chan :: F.T inp VectorValue -> F.T inp VectorValue+           chan freq =+              CausalPS.osci WaveL.approxSine2+              $&+              ((Causal.envelope+                  $< (piecewiseConstantVector depth+                      *+                      SigPS.exponential2 halfLife (vel+1)))+               <<<+               UniFilter.lowpass+               ^<<+               CtrlPS.process+               $&+               (Causal.zipWith UniFilterL.parameter+                   <<<+                   CausalClass.feedFst (piecewiseConstant reson)+                   <<<+                   (Causal.envelope $< piecewiseConstant index)+                   <<<+                   Causal.map Serial.subsample+                   $&+                   freq)+               &|&+               ((CausalPS.osci WaveL.saw $< zero)+                $&+                freq))+              &|&+              freq+       in  Trav.traverse chan stereoFreq++resonantFMSynth ::+   IO (Real -> Real ->+       PC.T Real ->+       PC.T Real -> PC.T Real -> PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+resonantFMSynth =+   liftA2+      (\osc env dec rel detune reson index depth vcsize fm sr vel freq dur ->+         pioApply+            (osc sr (reson, index, depth) vel (detune, fm, freq))+            (env dec rel vcsize sr 0 dur))+      (CausalRender.run $+       wrapped $+       \(Control reson, Control index, Control depth)+         (Number vel) (DetuneModulation fm) ->+       constant frequency 5 $ \speed sr ->+            Stereo.multiValue <$>+            Causal.envelopeStereo $>+               (resonantFMSynthProc reson index depth vel sr $*+                stereoFrequenciesFromDetuneBendModulation speed fm))+      pingReleaseEnvelope+++phaserOsci ::+   (Exp Real -> Causal.T a VectorValue) ->+   Causal.T a (Stereo.T VectorValue)+phaserOsci osci =+   CausalPS.amplifyStereo 0.25+   <<<+   liftA2 Stereo.cons+      (sumNested $ map osci [1.0, -0.4, 0.5, -0.7])+      (sumNested $ map osci [0.4, -1.0, 0.7, -0.5])+++softStringDetuneFM ::+   IO (Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+softStringDetuneFM =+   liftA2+      (\osc env att det fm sr vel freq dur ->+         pioApply (osc sr det (fm, freq)) (env att sr vel dur))+      (let osci :: Exp Real -> Causal.T (VectorValue, VectorValue) VectorValue+           osci d =+              (CausalPS.osci WaveL.saw $< zero)+              <<<+              Causal.envelope+              <<<+              first (one + CausalPS.amplify d)+       in  CausalRender.run $+           wrapped $ \(Control det) (Modulation fm) ->+           constant frequency 5 $ \speed _sr ->+           Stereo.multiValue <$>+           (Causal.envelopeStereo $>+              (phaserOsci osci+               $< piecewiseConstantVector det+               $* frequencyFromBendModulation speed fm)))+      softStringReleaseEnvelope++{-+We might decouple the frequency of the enveloped tone+from the frequency of the envelope,+in order to get something like formants.+-}+softStringShapeFM, cosineStringStereoFM,+  arcSineStringStereoFM, arcTriangleStringStereoFM,+  arcSquareStringStereoFM, arcSawStringStereoFM ::+   IO (Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+softStringShapeFM =+   softStringShapeCore WaveL.rationalApproxSine1+cosineStringStereoFM =+   softStringShapeCore+      (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p)+arcSawStringStereoFM = arcStringStereoFM WaveL.saw+arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2+arcSquareStringStereoFM = arcStringStereoFM WaveL.square+arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle++arcStringStereoFM ::+   (forall r.+    VectorValue ->+    LLVM.CodeGenFunction r VectorValue) ->+   IO (Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+arcStringStereoFM wave =+   softStringShapeCore+      (\k p ->+         M.liftJoin2 Frame.amplifyMono+            (WaveL.approxSine4 =<< WaveL.halfEnvelope p)+            (wave =<< WaveL.replicate k p))++softStringShapeCore ::+   (forall r.+    VectorValue ->+    VectorValue ->+    LLVM.CodeGenFunction r VectorValue) ->+   IO (Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+softStringShapeCore wave =+   liftA2+      (\osc env att det dist fm sr vel freq dur ->+         pioApply (osc sr det dist (fm, freq)) (env att sr vel dur))+      (let osci ::+              Exp Real ->+              Causal.T+                 (VectorValue,+                       {- wave shape parameter -}+                  (VectorValue, VectorValue)+                       {- detune, frequency modulation -})+                 VectorValue+           osci d =+              CausalPS.shapeModOsci wave+              <<<+              second+                 (CausalClass.feedFst zero+                  <<<+                  Causal.envelope+                  <<<+                  first (one + CausalPS.amplify d))+       in  CausalRender.run $+           wrapped $ \(Control det) (Control dist) (Modulation fm) ->+           constant frequency 5 $ \speed _sr ->+           Stereo.multiValue <$>+           (Causal.envelopeStereo $>+              (phaserOsci osci+               $< piecewiseConstantVector dist+               $< piecewiseConstantVector det+               $* frequencyFromBendModulation speed fm)))+      softStringReleaseEnvelope++fmStringStereoFM ::+   IO (Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+fmStringStereoFM =+   liftA2+      (\osc env att det depth dist fm sr vel freq dur ->+         pioApply (osc sr det depth dist (fm, freq)) (env att sr vel dur))+      (let osci ::+              Exp Real ->+              Causal.T+                 ((VectorValue, VectorValue)+                       {- phase modulation depth, modulator distortion -},+                  (VectorValue, VectorValue)+                       {- detune, frequency modulation -})+                 VectorValue+           osci d =+              CausalPS.osci WaveL.approxSine2+              <<<+              (Causal.envelope+               <<<+               second+                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1+                     <<< second (CausalClass.feedFst zero))+               <<^+               (\((dp, ds), f) -> (dp, (ds, f))))+               &&& arr snd+              <<<+              second (Causal.envelope <<< first (one + CausalPS.amplify d))+       in  CausalRender.run $+           wrapped $+              \(Control det) (Control depth) (Control dist) (Modulation fm) ->+           constant frequency 5 $ \speed _sr ->+              Stereo.multiValue <$>+              (Causal.envelopeStereo <<<+                 (id &&&+                  (phaserOsci osci+                   <<<+                   CausalClass.feedSnd+                      (liftA2 (,)+                         (piecewiseConstantVector det)+                         (frequencyFromBendModulation speed fm))+                   <<<+                   CausalClass.feedSnd (piecewiseConstantVector dist)+                   <<<+                   (Causal.envelope $< piecewiseConstantVector depth)))))+      softStringReleaseEnvelope+++stereoNoise :: SampleRate (Exp Real) -> Sig.T (Stereo.T VectorValue)+stereoNoise =+   constant noiseReference 20000 $ \noiseRef _sr ->+   traverse+      (\uid -> SigPS.noise uid noiseRef)+      (Stereo.cons 13 14)++windCore ::+   Sig.T (Const.T RealValue) ->+   Sig.T (Const.T (BM.T RealValue)) ->+   SampleRate (Exp Real) ->+   Sig.T (Stereo.T VectorValue)+windCore reson fm =+   constant frequency 0.2 $ \speed sr ->+   Causal.stereoFromMonoControlled CtrlPS.process+    $< (Causal.zipWith (MoogL.parameter TypeNum.d8)+          $< piecewiseConstant reson+          $* (Causal.map Serial.subsample $*+                frequencyFromBendModulation speed fm))+    $* stereoNoise sr++wind ::+   IO (Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+wind =+   liftA2+      (\osc env att reson fm sr vel freq dur ->+         pioApply (osc sr reson (fm, freq)) (env att sr vel dur))+      (CausalRender.run $+         wrapped $ \(Control reson) (Modulation fm) sr ->+            Stereo.multiValue <$>+            Causal.envelopeStereo $> windCore reson fm sr)+      softStringReleaseEnvelope+++fadeProcess ::+   (A.PseudoRing v, A.IntegerConstant v) =>+   Causal.T a v ->+   Causal.T a v ->+   Causal.T (v, a) v+fadeProcess proc0 proc1 =+   let k = arr fst+       a0 = proc0 <<^ snd+       a1 = proc1 <<^ snd+   in  (one-k)*a0 + k*a1+++windPhaser ::+   IO (Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T Real ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+windPhaser =+   liftA2+      (\osc env att phaserMix phaserFreq reson fm sr vel freq dur ->+         pioApply+            (osc sr phaserMix phaserFreq reson (fm, freq))+            (env att sr vel dur))+      (CausalRender.run $+         wrapped $+           \(Control phaserMix) (FrequencyControl phaserFreq)+              (Control reson) (Modulation fm) sr ->+           Stereo.multiValue <$>+           (Causal.envelopeStereo $>+              ((Causal.stereoFromMonoControlled+                   (fadeProcess (arr snd) CtrlPS.process+                    <<<+                    first (Causal.map Serial.upsample)+                    <<^+                    (\((k,p),x) -> (k,(p,x))))+                  $< liftA2 (,)+                        (piecewiseConstant phaserMix)+                        (piecewiseConstant+                           (Const.causalMap+                              (Allpass.flangerParameter TypeNum.d8)+                                 $* phaserFreq)))+               $*+               windCore reson fm sr)))+      softStringReleaseEnvelope+++filterSawStereoFM ::+   IO (Real -> Real ->+       PC.T Real ->+       Real -> Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+filterSawStereoFM =+   liftA2+      (\osc env dec rel detune bright brightDecay vcsize fm sr vel freq dur ->+         pioApply+            (osc sr bright brightDecay (detune, fm, freq))+            (env dec rel vcsize sr vel dur))+      (CausalRender.run $+       wrapped $ \(Frequency bright) (Time brightDec) (DetuneModulation fm) ->+       constant frequency 10 $ \speed ->+       constant frequency 100 $ \cutoff _sr ->+         (Stereo.multiValue <$>+              Causal.envelopeStereo $>+              (Causal.stereoFromMono+                  (UniFilter.lowpass+                   ^<<+                   CtrlPS.processCtrlRate 100+                      (\k ->+                        Causal.map (UniFilterL.parameter 10) $*+                           {- bound control in order to avoid too low resonant frequency,+                              which makes the filter instable -}+                           Sig.exponentialBounded2+                              cutoff (brightDec/k) bright)+                   <<<+                   CausalPS.osci WaveL.saw $< zero)+               $* stereoFrequenciesFromDetuneBendModulation speed fm)))+      pingReleaseEnvelope+++{- |+The ADSR curve is composed from three parts:+Attack, Decay(+Sustain), Release.+Attack starts when the key is pressed+and lasts attackTime seconds+where it reaches height attackPeak*amplitudeOfVelocity.+It should be attackPeak>1 because in the following phase+we want to approach 1 from above.+Say the curve would approach the limit value L+if it would continue after the end of the attack phase,+the slope is determined by the halfLife with respect to this upper bound.+That is, attackHalfLife is the time in seconds where the attack curve+reaches or would reach L/2.+After Attack the Decay part starts at the same level+and decays to amplitudeOfVelocity.+The slope is again a halfLife,+that is, decayHalfLife is the time where the curve+drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity.+This phase lasts as long as the key is pressed.+If the key is released the curve decays with half life releaseHalfLife.+-}+{-+1 - 2^(-attackTime/attackHalfLife) = peak+-}+adsr ::+   IO (Real -> Real -> Real ->+       Real -> Real ->+       SigSt.ChunkSize ->+       SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)+adsr =+   liftA3+      (\attack decay release+           attackTime attackPeak attackHalfLife+           decayHalfLife releaseHalfLife vcsize sr vel dur ->+         let amp = amplitudeFromVelocity vel+             (attackDur, decayDur) =+                CutG.splitAt (round (attackTime * vectorRate sr)) dur+         in SigStL.continuePacked+               (pioApplyToLazyTime+                  (attack sr+                     attackHalfLife+                     (attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))))+                  attackDur+                <>+                pioApplyToLazyTime+                  (decay sr+                     decayHalfLife+                     ((attackPeak-1)*amp)+                     amp)+                  decayDur)+               (\x -> release vcsize sr releaseHalfLife x))+      (CausalRender.run $+       wrapped $ \(Time halfLife) (Number amplitude) (SampleRate _sr) ->+         Causal.fromSignal $+         SigPS.constant amplitude - SigPS.exponential2 halfLife amplitude)+      (CausalRender.run $ wrapped $+         \(Time halfLife) (Number amplitude) (Number saturation)+            (SampleRate _sr) ->+         Causal.fromSignal $+         SigPS.constant saturation + SigPS.exponential2 halfLife amplitude)+      (Render.run $+       wrapped $ \(Time releaseHL) (Number amplitude) (SampleRate _sr) ->+       let releaseTime = releaseHL * 5 / fromIntegral vectorSize+       in Causal.take (Expr.roundToIntFast releaseTime) $*+          SigPS.exponential2 releaseHL amplitude)++brass ::+   IO (Real -> Real ->+       Real -> Real -> Real -> Real ->+       PC.T Real ->+       PC.T Real ->+       SigSt.ChunkSize ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+brass =+   liftA2+      (\osc env attTime attPeak attHL+            dec rel emph det dist vcsize fm sr vel freq dur ->+         pioApply+            (osc sr det dist (fm, freq)+               (env attTime emph attHL dec rel vcsize sr vel dur))+            (env attTime attPeak attHL dec rel vcsize sr vel dur))+      (let osci ::+              Exp Real ->+              Causal.T+                 (VectorValue,+                       {- wave shrink/replication factor -}+                  (VectorValue, VectorValue)+                       {- detune, frequency modulation -})+                 VectorValue+           osci d =+              CausalPS.shapeModOsci WaveL.rationalApproxSine1+              <<<+              second+                 (CausalClass.feedFst zero+                  <<<+                  Causal.envelope+                  <<<+                  first (one + CausalPS.amplify d))+       in CausalRender.run $+          wrapped $+             \(Control det) (Control dist) (Modulation fm) (Signal emph) ->+          constant frequency 5 $ \speed _sr ->+            Stereo.multiValue <$>+            Causal.envelopeStereo $>+              (phaserOsci osci+               <<<+               CausalClass.feedFst (piecewiseConstantVector dist)+               <<<+               CausalClass.feedSnd (frequencyFromBendModulation speed fm)+               <<<+               (Causal.envelope $< piecewiseConstantVector det)+               $*+               emph))+      adsr+++sampledSound ::+   IO (Sample.T ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+sampledSound =+   liftA2+      (\osc freqMod smp fm sr vel freq dur ->+         {-+         We split the frequency modulation signal+         in order to get a smooth frequency modulation curve.+         Without (periodic) frequency modulation+         we could just split the piecewise constant control curve @fm@.+         -}+         let fmSig :: SigSt.T Vector+             fmSig =+               pioApplyToLazyTime+                  (freqMod sr (fm, freq * Sample.period pos))+                  (PC.duration fm)+             pos = Sample.positions smp+             amp = 2 * amplitudeFromVelocity vel+             (attack, sustain, release) = Sample.parts smp+         in (\cont ->+               pioApplyCont cont+                  (osc sr amp+                     (attack <>+                      SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))+                     (chunkSizesFromLazyTime dur))+                  fmSig)+            (pioApplyCont (const SigSt.empty)+               (osc sr amp release (NonNegChunky.fromChunks (repeat 1000)))))+      (CausalRender.run $+       wrapped $ \(Number amp) (Signal smp) (Signal dur) (SampleRate _sr) ->+         Stereo.multiValue <$>+         CausalPS.amplifyStereo amp+              <<<+              Causal.stereoFromMono+                 (CausalPS.pack (Causal.frequencyModulationLinear smp))+              <<<+              liftA2 Stereo.cons+                 (CausalPS.amplify 0.999)+                 (CausalPS.amplify 1.001)+              <<<+              arr fst+              <<<+              CausalClass.feedSnd (Const.flatten dur))+      (CausalRender.run $+       wrapped $ \(Modulation fm) ->+       constant frequency 3 $ \speed _sr ->+         Causal.fromSignal $ frequencyFromBendModulation speed fm)+++_sampledSoundLeaky ::+   IO (Sample.T ->+       PC.T (BM.T Real) ->+       Instrument Real (Stereo.T Vector))+_sampledSoundLeaky =+   liftA2+      (\osc freqMod smp fm sr vel freq dur ->+         {-+         We split the frequency modulation signal+         in order to get a smooth frequency modulation curve.+         Without (periodic) frequency modulation+         we could just split the piecewise constant control curve @fm@.+         -}+         let sustainFM, releaseFM :: SigSt.T Vector+             (sustainFM, releaseFM) =+               SVP.splitAt (chunkSizesFromLazyTime dur) $+               pioApplyToLazyTime+                  (freqMod sr (fm, freq * Sample.period pos))+                  (PC.duration fm)+             pos = Sample.positions smp+             amp = 2 * amplitudeFromVelocity vel+             (attack, sustain, release) = Sample.parts smp+         in pioApply+               (osc sr amp+                  (attack <>+                   SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))+               sustainFM+            <>+            pioApply (osc sr amp release) releaseFM)+      (CausalRender.run $+       wrapped $ \(Number amp) (Signal smp) (SampleRate _sr) ->+         Stereo.multiValue <$>+              CausalPS.amplifyStereo amp+              <<<+              Causal.stereoFromMono+                 (CausalPS.pack (Causal.frequencyModulationLinear smp))+              <<<+              liftA2 Stereo.cons+                 (CausalPS.amplify 0.999)+                 (CausalPS.amplify 1.001))+      (CausalRender.run $+       wrapped $ \(Modulation fm) ->+       constant frequency 3 $ \speed _sr ->+         Causal.fromSignal $ frequencyFromBendModulation speed fm)
− src/Synthesizer/LLVM/Server/Parameter.hs 
@@ -1,106 +0,0 @@-{-# 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.Storable.Signal as SigSt--import qualified LLVM.DSL.Parameter as Param--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
src/Synthesizer/LLVM/Server/Scalar/Instrument.hs view
@@ -14,13 +14,17 @@  import Synthesizer.LLVM.Server.Common import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*))+import Synthesizer.Causal.Class (($<), ($>), ($*)) -import qualified LLVM.Core as LLVM+import qualified LLVM.DSL.Expression as Expr+import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.DSL.Expression (Exp)  import qualified Synthesizer.MIDI.EventList as Ev import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime)@@ -28,33 +32,29 @@ import qualified Synthesizer.Storable.Signal      as SigSt import qualified Data.StorableVector.Lazy.Pattern as SigStV -import Control.Arrow ((^<<), arr) import Control.Applicative (liftA, liftA2)+import Data.Semigroup ((<>))  import NumericPrelude.Numeric (zero, round, (+)) import Prelude hiding (Real, round, break, (+))  -pingSig :: SigP.T (SampleRate Real, (Real, Real)) (LLVM.Value Real)+pingSig ::+   SampleRate (Exp Real) -> Exp Real -> Exp Real -> Sig.T (MultiValue.T Real) pingSig =-   let vel = number fst-       freq = frequency snd-   in  CausalP.envelope-          $< SigP.exponential2 (timeConst 0.2)-                (fmap amplitudeFromVelocity vel)-          $* SigP.osciSimple WaveL.saw zero freq+   wrapped $ \(Number vel) (Frequency freq) ->+   constant time 0.2 $ \halfLife _sr ->+      Causal.envelope+         $< Sig.exponential2 halfLife (amplitudeFromVelocity vel)+         $* Sig.osci WaveL.saw zero freq  ping :: IO (SigSt.ChunkSize -> SampleRate Real -> Real -> Real -> SigSt.T Real)-ping =-   fmap (\f chunkSize sr vel freq -> f chunkSize (sr, (vel,freq))) $-   SigP.runChunky pingSig+ping = Render.run pingSig  pingDur :: IO (Instrument Real Real) pingDur =-   fmap-      (\sound sr vel freq dur ->-         sound (chunkSizesFromLazyTime dur) (sr, (vel, freq))) $-   SigP.runChunkyPattern pingSig+   fmap (\sound sr vel freq -> pioApplyToLazyTime $ sound sr vel freq) $+   CausalRender.run (\sr vel freq -> Causal.fromSignal $ pingSig sr vel freq)  pingDurTake :: IO (SigSt.ChunkSize -> Instrument Real Real) pingDurTake =@@ -77,41 +77,38 @@    liftA2       (\pressed release decay rel chunkSize sr vel dur ->          SigStL.continue-            (pressed (chunkSizesFromLazyTime dur) (sr, (decay,vel)))-            (\x -> release chunkSize (sr, (rel,x))))-      (SigP.runChunkyPattern $-       let decay = time fst-           velocity = number snd-       in  SigP.exponential2 decay-              (amplitudeFromVelocity ^<< velocity))-      (SigP.runChunky $-       let release = time fst-           amplitude = number snd-       in  (CausalP.take (round ^<< (release*3)) $*-            SigP.exponential2 release amplitude))+            (pioApplyToLazyTime (pressed sr decay vel) dur)+            (\x -> release chunkSize sr rel x))+      (CausalRender.run $+       wrapped $ \(Time halfLife) (Number velocity) (SampleRate _sr) ->+       Causal.fromSignal+         (Sig.exponential2 halfLife (amplitudeFromVelocity velocity)))+      (Render.run $+       wrapped $ \(Time release) (Number amplitude) (SampleRate _sr) ->+         Causal.take (Expr.roundToIntFast (release*3)) $*+         Sig.exponential2 release amplitude)  pingRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Real) pingRelease =    liftA2       (\osc env dec rel chunkSize sr vel freq dur ->-         osc (sr, freq) (env dec rel chunkSize sr vel dur))-      (CausalP.runStorableChunky-         (let freq = frequency id-          in  CausalP.envelope $>-              SigP.osciSimple WaveL.saw zero freq))+         pioApply (osc sr freq) (env dec rel chunkSize sr vel dur))+      (CausalRender.run $ frequency $+ \freq _sr ->+         Causal.envelope $> Sig.osci WaveL.saw zero freq)       pingReleaseEnvelope -pingStereoRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real))+pingStereoRelease ::+   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real)) pingStereoRelease =    liftA2       (\osc env dec rel chunkSize sr vel freq dur ->-         osc (sr, freq) (env dec rel chunkSize sr vel dur))-      (CausalP.runStorableChunky-         (let freq = frequency id-          in  CausalP.envelopeStereo $>-              liftA2 Stereo.cons-                 (SigP.osciSimple WaveL.saw zero (0.999*freq))-                 (SigP.osciSimple WaveL.saw zero (1.001*freq))))+         pioApply (osc sr freq) (env dec rel chunkSize sr vel dur))+      (CausalRender.run $ frequency $+ \freq _sr ->+         Stereo.multiValue <$>+         Causal.envelopeStereo $>+            liftA2 Stereo.cons+               (Sig.osci WaveL.saw zero (0.999*freq))+               (Sig.osci WaveL.saw zero (1.001*freq)))       pingReleaseEnvelope  @@ -120,35 +117,35 @@ tine =    liftA2       (\osc env dec rel chunkSize sr vel freq dur ->-         osc (sr, (vel,freq)) (env dec rel chunkSize sr 0 dur))-      (CausalP.runStorableChunky-         (let freq = frequency snd-              vel  = number fst-          in  CausalP.envelope $>-                 (CausalP.osciSimple WaveL.approxSine2-                    $> (SigP.constant freq)-                    $* (CausalP.envelope-                          $< SigP.exponential2 (timeConst 1) (vel+1)-                          $* SigP.osciSimple WaveL.approxSine2 zero (2*freq)))))+         pioApply (osc sr vel freq) (env dec rel chunkSize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Number vel) (Frequency freq) ->+       constant time 1 $ \halfLife _sr ->+         Causal.envelope $>+         (Causal.osci WaveL.approxSine2+            $> Sig.constant freq+            $* (Causal.envelope+                  $< Sig.exponential2 halfLife (vel+1)+                  $* Sig.osci WaveL.approxSine2 zero (2*freq))))       pingReleaseEnvelope -tineStereo :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real))+tineStereo ::+   IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Real)) tineStereo =    liftA2       (\osc env dec rel chunkSize sr vel freq dur ->-         osc (sr, (vel,freq)) (env dec rel chunkSize sr 0 dur))-      (CausalP.runStorableChunky-         (let freq = frequency snd-              vel  = number fst-              chanOsci d =-                 CausalP.osciSimple WaveL.approxSine2-                    $> SigP.constant (freq*d)-          in  CausalP.envelopeStereo $>-                 (liftA2 Stereo.cons-                     (chanOsci 0.995) (chanOsci 1.005)-                  $* SigP.envelope-                        (SigP.exponential2 (timeConst 1) (vel+1))-                        (SigP.osciSimple WaveL.approxSine2 zero (2*freq)))))+         pioApply (osc sr vel freq) (env dec rel chunkSize sr 0 dur))+      (CausalRender.run $+       wrapped $ \(Number vel) (Frequency freq) ->+       constant time 1 $ \halfLife _sr ->+         let chanOsci d =+               Causal.osci WaveL.approxSine2 $> Sig.constant (freq*d)+         in Stereo.multiValue <$>+            Causal.envelopeStereo $>+               (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005) $*+                  (Causal.envelope+                     $< Sig.exponential2 halfLife (vel+1)+                     $* Sig.osci WaveL.approxSine2 zero (2*freq))))       pingReleaseEnvelope  @@ -158,8 +155,7 @@ softStringReleaseEnvelope =    liftA       (\env attackTime (SampleRate sampleRate) vel dur ->-         let attackTimeInt =-                round (attackTime * sampleRate)+         let attackTimeInt = round (attackTime * sampleRate)              {-              release <- take attackTime beginning              would yield a space leak, thus we first split 'beginning'@@ -171,29 +167,25 @@              -}              (attack, sustain) =                 SigSt.splitAt attackTimeInt $-                env (chunkSizesFromLazyTime dur)-                    (fromIntegral attackTimeInt :: Real,-                     amplitudeFromVelocity vel)+                pioApplyToLazyTime+                   (env+                      (fromIntegral attackTimeInt :: Word)+                      (amplitudeFromVelocity vel))+                   dur              release = SigSt.reverse attack-         in  attack `SigSt.append` sustain `SigSt.append` release)-      (let amp = arr snd-           attackTime = arr fst-       in  SigP.runChunkyPattern $-           flip SigP.append (SigP.constant amp) $-           SigP.amplify amp $-           (SigP.parabolaFadeIn attackTime))+         in attack <> sustain <> release)+      (CausalRender.run $ \attackTime amp -> Causal.fromSignal $+       Sig.amplify amp (Sig.parabolaFadeIn attackTime) <> Sig.constant amp)  softString :: IO (Instrument Real (Stereo.T Real)) softString =    liftA2-      (\osc env sr vel freq dur ->-         osc (sr, freq) (env 1 sr vel dur))-      (let freq = frequency id-           osci d =-              SigP.osciSimple WaveL.saw zero (d * freq)-       in  CausalP.runStorableChunky $-           (CausalP.envelopeStereo $>-              (liftA2 Stereo.cons-                 (osci 1.005 + osci 0.998)-                 (osci 1.002 + osci 0.995))))+      (\osc env sr vel freq dur -> pioApply (osc sr freq) (env 1 sr vel dur))+      (CausalRender.run $ frequency $+ \freq _sr ->+       let osci d = Sig.osci WaveL.saw zero (d * freq)+       in Stereo.multiValue <$>+          Causal.envelopeStereo $>+            liftA2 Stereo.cons+               (osci 1.005 + osci 0.998)+               (osci 1.002 + osci 0.995))       softStringReleaseEnvelope
− src/Synthesizer/LLVM/Simple/Signal.hs 
@@ -1,384 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Simple.Signal (-   C(simple),-   T,-   amplify,-   amplifyStereo,-   constant,-   envelope,-   envelopeStereo,-   exponential2,-   iterate,-   map,-   mapAccum,-   mix,-   mixExt,-   takeWhile,-   empty,-   append,-   osci,-   osciPlain,-   osciSaw,-   zip,-   zipWith,--   fromStorableVector,-   fromStorableVectorLazy,--   render,-   renderChunky,-   runChunky,-   ) where--import Synthesizer.LLVM.Simple.SignalPrivate hiding (alloca)--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.Frame as Frame-import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr--import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt-import qualified Synthesizer.LLVM.Storable.Vector as SVU-import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import qualified Data.StorableVector.Base as SVB--import qualified LLVM.DSL.Execution as Exec--import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Maybe as Maybe-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple--import qualified LLVM.Core as LLVM-import LLVM.Core-          (CodeGenFunction, ret, Value, valueOf,-           IsFirstClass, IsSized, IsConst, IsArithmetic)--import Control.Monad (liftM2)-import Control.Applicative (pure, liftA2, liftA3, (<$>))--import Data.Monoid (Monoid, mappend)--import qualified Algebra.Transcendental as Trans--import qualified System.Unsafe as Unsafe-import Foreign.ForeignPtr (touchForeignPtr)-import Foreign.Ptr (Ptr)-import Data.Word (Word)-import Control.Exception (bracket)--import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, takeWhile)---constant :: (C signal, IsConst a) => a -> signal (Value a)-constant x = pure (valueOf x)--mapAccum ::-   (C signal, Memory.C s) =>-   (forall r. a -> s -> CodeGenFunction r (b,s)) ->-   (forall r. CodeGenFunction r s) ->-   signal a -> signal b-mapAccum f startS = alter (\(Core next start stop) ->-   Core-      (\ioContext (sa0,ss0) -> do-         (a,sa1) <- next ioContext sa0-         (b,ss1) <- MaybeCont.lift $ f a ss0-         return (b, (sa1,ss1)))-      (\ioContext ->-         liftM2 (,) (start ioContext) startS)-      (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, Tuple.Phi a, Tuple.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) =>-   signal a -> signal a -> signal a-envelope = zipWith Frame.amplifyMono--envelopeStereo ::-   (C signal, A.PseudoRing a) =>-   signal a -> signal (Stereo.T a) -> signal (Stereo.T a)-envelopeStereo = zipWith Frame.amplifyStereo--amplify ::-   (C signal, IsArithmetic a, IsConst a) =>-   a -> signal (Value a) -> signal (Value a)-amplify x =-   map (Frame.amplifyMono (valueOf x))--amplifyStereo ::-   (C signal, IsArithmetic a, IsConst a) =>-   a -> signal (Stereo.T (Value a)) -> signal (Stereo.T (Value a))-amplifyStereo x =-   map (Frame.amplifyStereo (valueOf x))----iterate ::-   (C signal, IsFirstClass a, IsSized a, IsConst a) =>-   (forall r. Value a -> CodeGenFunction r (Value a)) ->-   Value a -> signal (Value a)-iterate f initial =-   simple-      (\y -> MaybeCont.lift $ fmap (\y1 -> (y,y1)) (f y))-      (return initial)--exponential2 ::-   (C signal, Trans.C a, IsArithmetic a, IsSized a, IsConst a) =>-   a -> a -> signal (Value a)-exponential2 halfLife =-   iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf---osciPlain ::-   (C signal, SoV.Fraction t, IsSized t, IsConst t) =>-   (forall r. Value t -> CodeGenFunction r y) ->-   Value t -> Value t -> signal y-osciPlain wave phase freq =-   map wave $-   iterate (SoV.incPhase freq) $-   phase--osci ::-   (C signal, SoV.Fraction t, IsSized t, IsConst t) =>-   (forall r. Value t -> CodeGenFunction r y) ->-   t -> t -> signal y-osci wave phase freq =-   osciPlain wave (valueOf phase) (valueOf freq)--osciSaw ::-   (C signal, SoV.IntegerConstant a, SoV.Fraction a, IsSized a, IsConst a) =>-   a -> a -> signal (Value a)-osciSaw = osci Wave.saw----fromStorableVector ::-   (Storable.C a, Tuple.ValueOf a ~ value) => SV.Vector a -> T value-fromStorableVector xs =-   let (fp,ptr,l) = SVU.unsafeToPointers xs-   in  Cons-          (\_ () (p0,l0) -> do-             cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero-             MaybeCont.withBool cont $ do-                y1 <- Storable.load p0-                p1 <- Storable.incrementPtr p0-                l1 <- A.dec l0-                return (y1,(p1,l1)))-          (return ())-          (const $ return-             (valueOf ptr,-              valueOf (fromIntegral l :: Word)))-          -- keep the foreign ptr alive-          (return (fp, ()))-          touchForeignPtr--{--This function calls back into the Haskell function 'nextChunk'-that returns a pointer to the data of the next chunk-and advances to the next chunk in the sequence.--}-fromStorableVectorLazy ::-   (Storable.C a, Tuple.ValueOf a ~ value) => SVL.Vector a -> T value-fromStorableVectorLazy = flattenChunks . storableVectorChunks--storableVectorChunks ::-   (Storable.C a) => SVL.Vector a -> T (Value (Ptr a), Value Word)-storableVectorChunks sig =-   Cons-      (storableVectorNextChunk "Simple.Signal.fromStorableVectorLazy.nextChunk")-      LLVM.alloca-      (const $ return ())-      ((\stable -> (stable,stable)) <$> ChunkIt.new sig)-      ChunkIt.dispose---foreign import ccall safe "dynamic" derefFillPtr ::-   Exec.Importer (Word -> Ptr struct -> IO Word)---compile ::-   (Storable.C a, Tuple.ValueOf a ~ value, Memory.C state) =>-   (forall r z.-    (Tuple.Phi z) => local -> state -> MaybeCont.T r z (value, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r. CodeGenFunction r state) ->-   IO (Word -> Ptr a -> IO Word)-compile next alloca start =-   Exec.compile "signal" $-      Exec.createFunction derefFillPtr "fillsignalblock" $ \ size bPtr -> do-         s <- start-         local <- alloca-         (pos,_) <--               Storable.arrayLoopMaybeCont size bPtr s $ \ ptri s0 -> do-            (y,s1) <- next local s0-            MaybeCont.lift $ Storable.store y ptri-            return s1-         ret pos--{--This parameter order would allows us to compile the code once-and apply it to different signal lengths.-However, we do not make use of this and instead bake-parts of the IO context into the code to allow constant folding.-The parameter order is consistent with that of @Parameterized.Signal.render@.--}-render ::-   (Storable.C a, Tuple.ValueOf a ~ value, Memory.C value) =>-   T value -> Int -> SV.Vector a-render (Cons next alloca start createIOContext deleteIOContext) len =-   Unsafe.performIO $-   bracket createIOContext (deleteIOContext . fst) $ \ (_ioContext, params) ->-   SVB.createAndTrim len $ \ ptr ->-      do fill <--            compile-               (next $ Tuple.valueOf params) alloca (start $ Tuple.valueOf params)-         fmap (fromIntegral :: Word -> Int) $ fill (fromIntegral len) ptr---foreign import ccall safe "dynamic" derefStartPtr ::-   Exec.Importer (IO (LLVM.Ptr a))--foreign import ccall safe "dynamic" derefStopPtr ::-   Exec.Importer (LLVM.Ptr a -> IO ())--foreign import ccall safe "dynamic" derefChunkPtr ::-   Exec.Importer (LLVM.Ptr stateStruct -> Word -> Ptr struct -> IO Word)---compileChunky ::-   (Storable.C a, Tuple.ValueOf a ~ value,-    Memory.C state, Memory.Struct state ~ stateStruct) =>-   (forall r z.-    (Tuple.Phi z) =>-    local -> state -> MaybeCont.T r z (value, state)) ->-   (forall r. CodeGenFunction r local) ->-   (forall r. CodeGenFunction r state) ->-   IO (IO (LLVM.Ptr stateStruct),-       Exec.Finalizer stateStruct,-       LLVM.Ptr stateStruct -> Word -> Ptr a -> IO Word)-compileChunky next alloca start =-   Exec.compile "signal-chunky" $-      liftA3 (,,)-         (Exec.createFunction derefStartPtr "startsignal" $-          do-             pptr <- LLVM.malloc-             flip Memory.store pptr =<< start-             ret pptr)-{- for debugging: allocation with initialization makes type inference difficult-         (Exec.createFunPtr "startsignal" $-          do-             pptr <- malloc-             let retn :: CodeGenFunction r state -> Value (Ptr state) -> CodeGenFunction (Ptr state) ()-                 retn _ ptr = ret ptr-             retn undefined pptr)--}-         (Exec.createFinalizer derefStopPtr "stopsignal" $-          \ pptr -> LLVM.free pptr >> ret ())-         (Exec.createFunction derefChunkPtr "fillsignal" $-          \ sptr loopLen ptr -> do-             sInit <- Memory.load sptr-             local <- alloca-             (pos,sExit) <--                Storable.arrayLoopMaybeCont loopLen ptr sInit $-                   \ ptri s0 -> do-                (y,s1) <- next local s0-                MaybeCont.lift $ Storable.store y ptri-                return s1-             Memory.store (Maybe.fromJust sExit) sptr-             ret pos)---runChunky ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   T value -> SVL.ChunkSize -> IO (SVL.Vector a)-runChunky (Cons next alloca start createIOContext deleteIOContext)-      (SVL.ChunkSize size) = do-   (ioContext, params) <- createIOContext-   (startFunc, stopFunc, fill) <--      compileChunky-         (next $ Tuple.valueOf params) alloca (start $ Tuple.valueOf params)--   statePtr <- ForeignPtr.newInit stopFunc startFunc-   ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)--   let go =-         Unsafe.interleaveIO $ do-            v <--               ForeignPtr.with statePtr $ \sptr ->-               SVB.createAndTrim size $-               fmap (fromIntegral :: Word -> Int) .-               fill sptr (fromIntegral size)-            touchForeignPtr ioContextPtr-            (if SV.length v > 0-               then fmap (v:)-               else id) $-               (if SV.length v < size-                  then return []-                  else go)-   fmap SVL.fromChunks go--renderChunky ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>-   SVL.ChunkSize -> T value -> SVL.Vector a-renderChunky size sig =-   Unsafe.performIO (runChunky sig size)
− src/Synthesizer/LLVM/Simple/SignalPacked.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-module Synthesizer.LLVM.Simple.SignalPacked where--import Synthesizer.LLVM.Simple.SignalPrivate (Core(Core), alter)-import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial--import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Control as U-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple--import qualified LLVM.Core as LLVM-import LLVM.Core (valueOf)--import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Trans.State as MS-import Control.Monad (replicateM)--import Data.Word (Word)--import NumericPrelude.Numeric as NP-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith)----{- |-Convert a signal of scalar values into one using processor vectors.-If the signal length is not divisible by the chunk size,-then the last chunk is dropped.--}-pack, packRotate ::-   (Sig.C signal, Serial.C v, a ~ Serial.Element v) =>-   signal a -> signal v-pack = packRotate--packRotate = alter (\(Core next start stop) -> Core-   (\param s -> do-      wInit <- Maybe.lift $ Serial.writeStart-      (w2,_,s2) <--         Maybe.fromBool $-         U.whileLoop-            (valueOf True,-             (wInit,-              valueOf $ (fromIntegral $ Serial.sizeOfIterator wInit :: Word),-              s))-            (\(cont,(_w0,i0,_s0)) ->-               A.and cont =<<-                  A.cmp LLVM.CmpGT i0 A.zero)-            (\(_,(w0,i0,s0)) -> Maybe.toBool $ do-               (a,s1) <- next param s0-               Maybe.lift $ do-                  w1 <- Serial.writeNext a w0-                  i1 <- A.dec i0-                  return (w1,i1,s1))-      v <- Maybe.lift $ Serial.writeStop w2-      return (v, s2))-   start-   stop)--{--We could reformulate it in terms of WriteIterator-that accesses elements using LLVM.extract.-We might move the loop counter into the Iterator,-but we have to assert that the counter is not duplicated.--packIndex ::-   (Sig.C signal, Serial.C v, a ~ Serial.Element v) =>-   signal a -> signal v-packIndex = alter (\(Core next start stop) -> Core-   (\param s -> do-      (v2,_,s2) <--         Maybe.fromBool $-         U.whileLoop-            (valueOf True, (Tuple.undef, A.zero, s))-            (\(cont,(v0,i0,_s0)) ->-               A.and cont =<<-                  A.cmp LLVM.CmpLT i0-                     (valueOf $ fromIntegral $ Serial.size v0))-            (\(_,(v0,i0,s0)) -> Maybe.toBool $ do-               (a,s1) <- next param s0-               Maybe.lift $ do-                  v1 <- Vector.insert i0 a v0-                  i1 <- A.inc i0-                  return (v1,i1,s1))-      return (v2, s2))-   start-   stop)--}---{- |-Like 'pack' but duplicates the code for creating elements.-That is, for vectors of size n, the code of the input signal-will be emitted n times.-This is efficient only for simple input generators.--}-packSmall ::-   (Sig.C signal, Serial.C v, a ~ Serial.Element v) =>-   signal a -> signal v-packSmall = alter (\(Core next start stop) -> Core-   (\param ->-      MS.runStateT $-      Serial.withSize $ \n ->-         MT.lift . Maybe.lift . Serial.assemble-         =<<-         replicateM n (MS.StateT $ next param))-   start-   stop)---unpack, unpackRotate ::-   (Sig.C signal,-    Serial.Read v, a ~ Serial.Element v, Serial.ReadIt v ~ itv, Memory.C itv) =>-   signal v -> signal a-unpack = unpackRotate--unpackRotate = alter (\(Core next start stop) -> Core-   (\context (i0,r0,s0) -> do-      endOfVector <--         Maybe.lift $ A.cmp LLVM.CmpEQ i0 (valueOf (0::Word))-      (i2,r2,s2) <--         Maybe.fromBool $-         U.ifThen endOfVector (valueOf True, (i0,r0,s0)) $ do-            (cont1, (v1,s1)) <- Maybe.toBool $ next context s0-            r1 <- Serial.readStart v1-            return (cont1, (valueOf $ fromIntegral $ Serial.size v1, r1, s1))-      Maybe.lift $ do-         (a,r3) <- Serial.readNext r2-         i3 <- A.dec i2-         return (a, (i3,r3,s2)))-   (fmap (\s -> (A.zero, Tuple.undef, s)) . start)-   (\(_,_,state) -> stop state))---{--We could reformulate it in terms of ReadIterator-that accesses elements using LLVM.extract.-We might move the loop counter into the Iterator,-but we have to assert that the counter is not duplicated.--unpackIndex ::-   (Serial.C v, a ~ Serial.Element v, Memory.C v) =>-   signal v -> signal a-unpackIndex = alter (\(Core next start stop) -> Core-   (\param (i0,v0,s0) -> do-      endOfVector <--         Maybe.lift $ A.cmp LLVM.CmpGE i0-            (valueOf $ fromIntegral $ Serial.size v0)-      (i2,v2,s2) <--         Maybe.fromBool $-         U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do-            (cont1, (v1,s1)) <- Maybe.toBool $ next param s0-            return (cont1, (A.zero, v1, s1))-      Maybe.lift $ do-         a <- Vector.extract i2 v2-         i3 <- A.inc i2-         return (a, (i3,v2,s2)))-   (\p -> do-      s <- start p-      let v = Tuple.undef-      return (valueOf $ fromIntegral $ Serial.size v, v, s))-   stop)--}
− src/Synthesizer/LLVM/Simple/SignalPrivate.hs 
@@ -1,340 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Simple.SignalPrivate where--import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt--import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-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 qualified LLVM.Extra.Tuple as Tuple-import LLVM.Extra.Control (ifThen)--import qualified LLVM.Util.Proxy as LP-import qualified LLVM.Core as LLVM-import LLVM.Core (CodeGenFunction, Value, valueOf)--import Control.Monad (liftM2)-import Control.Applicative (Applicative, pure, liftA2, (<*>), (<$>))--import Foreign.StablePtr (StablePtr)-import Foreign.Ptr (Ptr, nullPtr)--import Data.Tuple.Strict (zipPair)-import Data.Monoid (Monoid, mempty, mappend)-import Data.Semigroup (Semigroup, (<>))-import Data.Word (Word)--import qualified Number.Ratio as Ratio-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive--import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith)--import qualified Prelude as P---{--We need the forall quantification for 'CodeGenFunction's @r@ parameter.-This type parameter will be unified with the result type of the final function.-Since one piece of code can be used in multiple functions-we cannot yet fix the type @r@ here.---We might avoid code duplication with Causal.Process by defining--> newtype T a = Cons (Causal.T () a)---In earlier versions the createIOContext method created only an ioContext-that was directly used to construct code for 'start' and 'next'.-This had the advantage that we did not need to pass-something via the Memory.C interface to the function.-However, creating both an ioContext and a low-level parameter has those advantages:-We can design Causal.Process such that a process-can be applied to multiple signals without recompilation.-We can lift simple signals and processes to their parameterized counterparts.--}-data T a =-   forall state local ioContext parameters.-      (Marshal.C parameters, Memory.C state) =>-      Cons (forall r c.-            (Tuple.Phi c) =>-            Tuple.ValueOf parameters -> local ->-            state -> MaybeCont.T r c (a, state))-               -- compute next value-           (forall r.-            CodeGenFunction r local)-               -- allocate temporary variables before a loop-           (forall r.-            Tuple.ValueOf parameters ->-            CodeGenFunction r state)-               -- initial state-           (IO (ioContext, parameters))-               {- initialization from IO monad-               This will be run within Unsafe.performIO,-               so no observable In/Out actions please!-               -}-           (ioContext -> IO ())-               -- finalization from IO monad, also run within Unsafe.performIO---data Core context initState exitState a =-   forall state.-      (Memory.C state) =>-      Core (forall r c.-            (Tuple.Phi c) =>-            context ->-            state -> MaybeCont.T r c (a, state))-               -- compute next value-           (forall r.-            initState ->-            CodeGenFunction r state)-               -- initial state-           (state -> exitState)-               -- extract final state for cleanup---class Applicative signal => C signal where-   simple ::-      (Memory.C state) =>-      (forall r c. state -> MaybeCont.T r c (a, state)) ->-      (forall r. CodeGenFunction r state) ->-      signal a-   simple next start =-      simpleAlloca (\() state -> next state) (return ()) start--   simpleAlloca ::-      (Memory.C state) =>-      (forall r c. local -> state -> MaybeCont.T r c (a, state)) ->-      (forall r. CodeGenFunction r local) ->-      (forall r. CodeGenFunction r state) ->-      signal a--   alter ::-      (forall contextLocal initState exitState.-          Core contextLocal initState exitState a0 ->-          Core contextLocal initState exitState a1) ->-      signal a0 -> signal a1--instance C T where-   simpleAlloca next alloca0 start =-      Cons-         (\() local -> next local)-         alloca0-         (const start)-         (return ((),()))-         (const $ return ())--   alter f (Cons next0 alloca0 start0 create delete) =-      case f (Core (uncurry next0) start0 id) of-         Core next1 start1 _ ->-            Cons (curry next1) alloca0 start1 create delete---map ::-   (C signal) =>-   (forall r. a -> CodeGenFunction r b) -> signal a -> signal b-map f = alter (\(Core next start stop) ->-   Core-      (\ioContext sa0 -> do-         (a,sa1) <- next ioContext sa0-         b <- MaybeCont.lift $ f a-         return (b, sa1))-      start-      stop)--zipWith ::-   (C signal) =>-   (forall r. a -> b -> CodeGenFunction r c) ->-   signal a -> signal b -> signal c-zipWith f a b  =  map (uncurry f) $ liftA2 (,) a b---zip :: T a -> T b -> T (a,b)-zip (Cons nextA allocaA startA createIOContextA deleteIOContextA)-    (Cons nextB allocaB startB createIOContextB deleteIOContextB) =-   Cons-      (\(paramA, paramB) (localA, localB) (sa0,sb0) ->-         liftM2 zipPair-            (nextA paramA localA sa0)-            (nextB paramB localB sb0))-      (liftM2 (,) allocaA allocaB)-      (combineStart startA startB)-      (combineCreate createIOContextA createIOContextB)-      (combineDelete deleteIOContextA deleteIOContextB)--combineStart ::-   Monad m =>-   (paramA -> m stateA) ->-   (paramB -> m stateB) ->-   (paramA, paramB) -> m (stateA, stateB)-combineStart startA startB (paramA, paramB) =-   liftM2 (,) (startA paramA) (startB paramB)--combineCreate ::-   Monad m =>-   m (ioContextA, contextA) ->-   m (ioContextB, contextB) ->-   m ((ioContextA, ioContextB), (contextA, contextB))-combineCreate createIOContextA createIOContextB =-   liftM2 zipPair createIOContextA createIOContextB--combineDelete :: (Monad m) => (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m ()-combineDelete deleteIOContextA deleteIOContextB (ca,cb) =-   deleteIOContextA ca >> deleteIOContextB cb---instance Functor T where-   fmap f = map (return . f)--{- |-ZipList semantics--}-instance Applicative T where-   pure x = simple (\() -> return (x, ())) (return ())-   f <*> a = fmap (uncurry ($)) $ zip f a--instance (A.Additive a) => Additive.C (T a) where-   zero = pure A.zero-   negate = map A.neg-   (+) = zipWith A.add-   (-) = zipWith A.sub--instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where-   one = pure A.one-   fromInteger n = pure (A.fromInteger' n)-   (*) = zipWith A.mul--instance (A.Field a, A.RationalConstant a) => Field.C (T a) where-   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)-   (/) = zipWith A.fdiv---instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T a) where-   fromInteger n = pure (A.fromInteger' n)-   negate = map A.neg-   (+) = zipWith A.add-   (-) = zipWith A.sub-   (*) = zipWith A.mul-   abs = map A.abs-   signum = map A.signum--instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where-   fromRational x = pure (A.fromRational' x)-   (/) = zipWith A.fdiv----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 :: (Tuple.Phi a, Tuple.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 (Tuple.Phi a, Tuple.Undefined a) => Semigroup (T a) where-   (<>) = append--instance (Tuple.Phi a, Tuple.Undefined a) => Monoid (T a) where-   mempty = empty-   mappend = append----storableVectorNextChunk ::-   (Tuple.Phi c, Storable.C a) =>-   String ->-   Value (StablePtr (ChunkIt.T a)) -> Value (LLVM.Ptr Word) -> () ->-   MaybeCont.T r c ((Value (Ptr a), Value Word), ())-storableVectorNextChunk callbackName stable lenPtr () =-   MaybeCont.fromBool $ do-      nextChunkFn <- LLVM.staticNamedFunction callbackName ChunkIt.nextCallBack-      (buffer,len) <--         liftM2 (,)-            (LLVM.call nextChunkFn stable lenPtr)-            (LLVM.load lenPtr)-      valid <- A.cmp LLVM.CmpNE buffer (valueOf nullPtr)-      return (valid, ((buffer,len), ()))--flattenChunks ::-   (C signal, Storable.C a, Tuple.ValueOf a ~ value) =>-   signal (Value (Ptr a), Value Word) -> signal value-flattenChunks = alter $ \(Core next start stop) ->-   Core-      (\context ((buffer0,length0), state0) -> do-         ((buffer1,length1), state1) <- MaybeCont.fromBool $ do-            needNext <- A.cmp LLVM.CmpEQ length0 A.zero-            ifThen needNext-               (valueOf True, ((buffer0,length0), state0))-               (MaybeCont.toBool $ next context state0)-         MaybeCont.lift $ do-            x <- Storable.load buffer1-            buffer2 <- Storable.incrementPtr buffer1-            length2 <- A.dec length1-            return (x, ((buffer2,length2), state1)))-      (\p -> (,) (valueOf nullPtr, A.zero) <$> start p)-      (stop . snd)--alloca :: (C signal, LLVM.IsSized a) => signal (LLVM.Value (LLVM.Ptr a))-alloca =-   simpleAlloca-      (\ptr () -> return (ptr, ()))-      LLVM.alloca-      (return ())---proxyFromElement :: f a -> LP.Proxy a-proxyFromElement _ = LP.Proxy--proxyFromElement2 :: f (g a) -> LP.Proxy a-proxyFromElement2 _ = LP.Proxy
− src/Synthesizer/LLVM/Simple/Value.hs 
@@ -1,569 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-module Synthesizer.LLVM.Simple.Value (-   T, decons,-   twoPi, square, sqrt,-   max, min, limit, fraction,--   (%==), (%/=), (%<), (%<=), (%>), (%>=), not,-   (%&&), (%||),-   (?), (??),--   lift0, lift1, lift2, lift3,-   unlift0, unlift1, unlift2, unlift3, unlift4, unlift5,-   constantValue, constant,-   fromInteger', fromRational',--   Flatten(flattenCode, unfoldCode), Registers,-   flatten, unfold,-   flattenCodeTraversable, unfoldCodeTraversable,-   flattenFunction,-   ) where--import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple--import LLVM.Core (CodeGenFunction)-import qualified LLVM.Core as LLVM--import qualified Synthesizer.Basic.Phase as Phase--import qualified Data.Vault.Lazy as Vault-import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Trans.State as MS-import Control.Monad (liftM2, liftM3)-import Control.Applicative (Applicative, pure, (<*>))-import Control.Functor.HT (unzip, unzip3)--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo---- import qualified Algebra.NormedSpace.Maximum   as NormedMax-import qualified Algebra.NormedSpace.Euclidean as NormedEuc-import qualified Algebra.NormedSpace.Sum       as NormedSum--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.RealRing as RealRing-import qualified Algebra.Absolute as Absolute-import qualified Algebra.Module as Module-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive--import qualified Number.Complex as Complex--import qualified Data.Traversable as Trav-import qualified Data.Foldable as Fold--import qualified System.Unsafe as Unsafe--import qualified Prelude as P-import NumericPrelude.Numeric hiding (pi, sqrt, fromRational', fraction)-import NumericPrelude.Base hiding (min, max, unzip, unzip3, not)---{--The @r@ type parameter must be hidden and forall-quantified-because otherwise we would need an impossible type-where we have to quantify for @r@ and @t@ in different scopes-while having a class constraint that involves both of them.--> osci ::->    (RealRing.C (Value.T r t),->     IsFirstClass t, IsFloating t,->     IsPrimitive t, IsConst t) =>->    (forall r. Wave.T (Value.T r t) (Value.T r y)) ->->    t -> t -> T (Value y)---}-newtype T a = Cons {code :: forall r. Compute r a}--decons :: T a -> (forall r. LLVM.CodeGenFunction r a)-decons value =-   MS.evalStateT (code value) Vault.empty--instance Functor T where-   fmap f x = consUnique (fmap f (code x))--instance Applicative T where-   pure = constantValue-   f <*> x = consUnique (code f <*> code x)---type Compute r a =-   MS.StateT Vault.Vault (LLVM.CodeGenFunction r) a--consUnique :: (forall r. Compute r a) -> T a-consUnique code0 =-   Unsafe.performIO $-   fmap (consKey code0) Vault.newKey--consKey :: (forall r. Compute r a) -> Vault.Key a -> T a-consKey code0 key =-   Cons (do-      ma <- MS.gets (Vault.lookup key)-      case ma of-         Just a -> return a-         Nothing -> do-            a <- code0-            MS.modify (Vault.insert key a)-            return a)--{- |-We do not require a numeric prelude superclass,-thus also LLVM only types like vectors are instances.--}-instance (A.Additive a) => Additive.C (T a) where-   zero = constantValue A.zero-   (+) = lift2 A.add-   (-) = lift2 A.sub-   negate = lift1 A.neg--instance (A.PseudoRing a, A.IntegerConstant a) =>-      Ring.C (T a) where-   one = constantValue A.one-   (*) = lift2 A.mul-   fromInteger = fromInteger'--{--This instance is enough for Module here.-The difference to Module instances on Haskell tuples is,-that LLVM vectors cannot be nested.--}-instance (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>-      Module.C (T a) (T v) where-   (*>) = lift2 A.scale--instance (A.Additive a, A.IntegerConstant a) => Enum (T a) where-   succ x = x + constantValue A.one-   pred x = x - constantValue A.one-   fromEnum _ = error "CodeGenFunction Value: fromEnum"-   toEnum = constantValue . A.fromInteger' . fromIntegral--{--instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T a) where-   toRational _ = error "CodeGenFunction Value: toRational"--instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T a) where-   quot = lift2 idiv-   rem  = lift2 irem-   quotRem x y = (quot x y, rem x y)-   toInteger _ = error "CodeGenFunction Value: toInteger"--}--instance (A.Field a, A.RationalConstant a) => Field.C (T a) where-   (/) = lift2 A.fdiv-   fromRational' = fromRational' . Field.fromRational'--{--instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T a) where-   properFraction _ = error "CodeGenFunction Value: properFraction"--}--instance (A.Transcendental a, A.RationalConstant a) => Algebraic.C (T a) where-   sqrt = lift1 A.sqrt-   root n x = lift2 A.pow x (1 / fromInteger n)-   x^/r = lift2 A.pow x (Field.fromRational' r)--instance (A.Transcendental a, A.RationalConstant a) => Trans.C (T a) where-   pi = lift0 A.pi-   sin = lift1 A.sin-   cos = lift1 A.cos-   (**) = lift2 A.pow-   exp = lift1 A.exp-   log = lift1 A.log--   asin _ = error "LLVM missing intrinsic: asin"-   acos _ = error "LLVM missing intrinsic: acos"-   atan _ = error "LLVM missing intrinsic: atan"---instance-   (A.PseudoRing a, A.Real a, A.IntegerConstant a) =>-      P.Num (T a) where-   fromInteger = fromInteger'-   (+) = lift2 A.add-   (-) = lift2 A.sub-   (*) = lift2 A.mul-   negate = lift1 A.neg-   abs = lift1 A.abs-   signum = lift1 A.signum--instance-   (A.Field a, A.Real a, A.RationalConstant a) =>-      P.Fractional (T a) where-   fromRational = fromRational'-   (/) = lift2 A.fdiv--instance-   (A.Transcendental a, A.Real a, A.RationalConstant a) =>-      P.Floating (T a) where-   pi = lift0 A.pi-   sin = lift1 A.sin-   cos = lift1 A.cos-   (**) = lift2 A.pow-   exp = lift1 A.exp-   log = lift1 A.log--   asin _ = error "LLVM missing intrinsic: asin"-   acos _ = error "LLVM missing intrinsic: acos"-   atan _ = error "LLVM missing intrinsic: atan"--   sinh x  = (exp x - exp (-x)) / 2-   cosh x  = (exp x + exp (-x)) / 2-   asinh x = log (x + sqrt (x*x + 1))-   acosh x = log (x + sqrt (x*x - 1))-   atanh x = (log (1 + x) - log (1 - x)) / 2---twoPi ::-   (A.Transcendental a, A.RationalConstant a) =>-   T a-twoPi = 2 * Trans.pi--square ::-   (A.PseudoRing a) =>-   T a -> T a-square = lift1 A.square--{- |-The same as 'Algebraic.sqrt',-but needs only Algebraic constraint, not Transcendental.--}-sqrt ::-   (A.Algebraic a) =>-   T a -> T a-sqrt = lift1 A.sqrt---min, max :: (A.Real a) => T a -> T a -> T a-min = lift2 A.min-max = lift2 A.max--limit :: (A.Real a) => (T a, T a) -> T a -> T a-limit (l,u) = max l . min u--fraction :: (A.Fraction a) => T a -> T a-fraction = lift1 A.fraction---instance (A.Real a, A.PseudoRing a, A.IntegerConstant a) =>-      Absolute.C (T a) where-   abs = lift1 A.abs-   signum = lift1 A.signum--{--For useful instances with different scalar and vector type,-we would need a more flexible superclass.--}-instance (A.Real a, A.IntegerConstant a, a ~ A.Scalar a, A.PseudoModule a) =>-      NormedSum.C (T a) (T a) where-   norm = lift1 A.abs--instance (A.Real a, A.IntegerConstant a, a ~ A.Scalar a, A.PseudoModule a) =>-      NormedEuc.Sqr (T a) (T a) where-   normSqr = lift1 A.square--instance-   (NormedEuc.Sqr (T a) (T v),-    A.RationalConstant a, A.Algebraic a) =>-      NormedEuc.C (T a) (T v) where-   norm = lift1 A.sqrt . NormedEuc.normSqr--{--instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) =>-      NormedMax.C (T a) (T a) where-   norm = lift1 A.abs--}---infix  4  %==, %/=, %<, %<=, %>=, %>--(%==), (%/=), (%<), (%<=), (%>), (%>=) ::-   (LLVM.CmpRet a) =>-   T (LLVM.Value a) -> T (LLVM.Value a) -> T (LLVM.Value (LLVM.CmpResult a))-(%==) = lift2 $ LLVM.cmp LLVM.CmpEQ-(%/=) = lift2 $ LLVM.cmp LLVM.CmpNE-(%>)  = lift2 $ LLVM.cmp LLVM.CmpGT-(%>=) = lift2 $ LLVM.cmp LLVM.CmpGE-(%<)  = lift2 $ LLVM.cmp LLVM.CmpLT-(%<=) = lift2 $ LLVM.cmp LLVM.CmpLE--infixr 3  %&&-infixr 2  %||---- | Lazy AND-(%&&) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool)-a %&& b = a ? (b, constant False)---- | Lazy OR-(%||) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool)-a %|| b = a ? (constant True, b)--not :: T (LLVM.Value Bool) -> T (LLVM.Value Bool)-not = lift1 LLVM.inv---infix  0 ?-{- |-@true ? (t,f)@ evaluates @t@,-@false ? (t,f)@ evaluates @f@.-@t@ and @f@ can reuse interim results,-but they cannot contribute shared results,-since only one of them will be run.-Cf. '(??)'--}-(?) ::-   (Flatten value, Registers value ~ a, Tuple.Phi a) =>-   T (LLVM.Value Bool) -> (value, value) -> value-c ? (t, f) =-   unfoldCode $ consUnique $ do-      b <- code c-      shared <- MS.get-      MT.lift $-         C.ifThenElse b-            (MS.evalStateT (flattenCode t) shared)-            (MS.evalStateT (flattenCode f) shared)--infix 0 ??-{- |-The expression @c ?? (t,f)@ evaluates both @t@ and @f@-and selects components from @t@ and @f@ according to @c@.-It is useful for vector values and-for sharing @t@ or @f@ with other branches of an expression.--}-(??) ::-   (LLVM.IsFirstClass a, LLVM.CmpRet a) =>-   T (LLVM.Value (LLVM.CmpResult a)) ->-   (T (LLVM.Value a), T (LLVM.Value a)) ->-   T (LLVM.Value a)-c ?? (t, f) = lift3 LLVM.select c t f----lift0 ::-   (forall r. CodeGenFunction r a) ->-   T a-lift0 f =-   consUnique $ MT.lift $ f--lift1 ::-   (forall r. a -> CodeGenFunction r b) ->-   T a -> T b-lift1 f x =-   consUnique $ MT.lift . f =<< code x--lift2 ::-   (forall r. a -> b -> CodeGenFunction r c) ->-   T a -> T b -> T c-lift2 f x y =-   consUnique $ do-      xv <- code x-      yv <- code y-      MT.lift $ f xv yv--lift3 ::-   (forall r. a -> b -> c -> CodeGenFunction r d) ->-   T a -> T b -> T c -> T d-lift3 f x y z =-   consUnique $ do-      xv <- code x-      yv <- code y-      zv <- code z-      MT.lift $ f xv yv zv---_unlift0 ::-   T a ->-   (forall r. CodeGenFunction r a)-_unlift0 = decons--unlift0 ::-   (Flatten value) =>-   value ->-   (forall r. CodeGenFunction r (Registers value))-unlift0 = flatten--_unlift1 ::-   (T a -> T b) ->-   (forall r. a -> CodeGenFunction r b)-_unlift1 = unlift1--{--Better type inference than flattenFunction.--}-unlift1 ::-   (Flatten value) =>-   (T a -> value) ->-   (forall r. a -> CodeGenFunction r (Registers value))-unlift1 f a =-   flatten (f (constantValue a))--_unlift2 ::-   (T a -> T b -> T c) ->-   (forall r. a -> b -> CodeGenFunction r c)-_unlift2 = unlift2--unlift2 ::-   (Flatten value) =>-   (T a -> T b -> value) ->-   (forall r. a -> b -> CodeGenFunction r (Registers value))-unlift2 f a b =-   flatten (f (constantValue a) (constantValue b))--unlift3 ::-   (Flatten value) =>-   (T a -> T b -> T c -> value) ->-   (forall r. a -> b -> c -> CodeGenFunction r (Registers value))-unlift3 f a b c =-   flatten (f (constantValue a) (constantValue b) (constantValue c))--unlift4 ::-   (Flatten value) =>-   (T a -> T b -> T c -> T d -> value) ->-   (forall r. a -> b -> c -> d -> CodeGenFunction r (Registers value))-unlift4 f a b c d =-   flatten $-   f (constantValue a) (constantValue b) (constantValue c) (constantValue d)--unlift5 ::-   (Flatten value) =>-   (T a -> T b -> T c -> T d -> T e -> value) ->-   (forall r. a -> b -> c -> d -> e -> CodeGenFunction r (Registers value))-unlift5 f a b c d e =-   flatten $-   f (constantValue a) (constantValue b) (constantValue c)-      (constantValue d) (constantValue e)---constantValue :: a -> T a-constantValue x =-   consUnique (return x)--constant :: (LLVM.IsConst a) => a -> T (LLVM.Value a)-constant = constantValue . LLVM.valueOf--fromInteger' :: (A.IntegerConstant a) => Integer -> T a-fromInteger' = constantValue . A.fromInteger'--fromRational' :: (A.RationalConstant a) => P.Rational -> T a-fromRational' = constantValue . A.fromRational'---class Flatten value where-   type Registers value :: *-   flattenCode :: value -> Compute r (Registers value)-   unfoldCode :: T (Registers value) -> value--flatten ::-   (Flatten value) =>-   value -> CodeGenFunction r (Registers value)-flatten x = MS.evalStateT (flattenCode x) Vault.empty--unfold ::-   (Flatten value) =>-   (Registers value) -> value-unfold x = unfoldCode $ pure x--flattenCodeTraversable ::-   (Flatten value, Trav.Traversable f) =>-   f value -> Compute r (f (Registers value))-flattenCodeTraversable =-   Trav.mapM flattenCode--unfoldCodeTraversable ::-   (Flatten value, Trav.Traversable f, Applicative f) =>-   T (f (Registers value)) -> f value-unfoldCodeTraversable =-   unfoldFromGetters getters--unfoldFromGetters ::-   (Functor f, Flatten b) =>-   f (a -> Registers b) -> T a -> f b-unfoldFromGetters g x =-   fmap (unfoldCode . flip fmap x) g--getters ::-   (Trav.Traversable f, Applicative f) =>-   f (f a -> a)-getters =-   fmap (\n x -> Fold.toList x !! n) $-   MS.evalState (Trav.sequenceA (pure (MS.state $ \n -> (n, succ n)))) 0---flattenFunction ::-   (Flatten a, Flatten b) =>-   (a -> b) -> (Registers a -> CodeGenFunction r (Registers b))-flattenFunction f =-   flatten . f . unfold--{--This function is hardly useful,-since most functions are not of type-@(Registers a -> (forall r. CodeGenFunction r (Registers b)))@-but of type-@(forall r. Registers a -> CodeGenFunction r (Registers b))@.-We would also need a method unfoldF.-See ValueUnfoldF for some implementations.--unfoldFunction ::-   (Flatten a, Flatten b) =>-   (Registers a -> (forall r. CodeGenFunction r (Registers b))) -> (a -> b)-unfoldFunction f x =-   unfoldF (f =<< flatten x)--}---instance (Flatten a, Flatten b) => Flatten (a,b) where-   type Registers (a,b) = (Registers a, Registers b)-   flattenCode (a,b) =-      liftM2 (,) (flattenCode a) (flattenCode b)-   unfoldCode x =-      case unzip x of-         (a,b) -> (unfoldCode a, unfoldCode b)--instance (Flatten a, Flatten b, Flatten c) => Flatten (a,b,c) where-   type Registers (a,b,c) = (Registers a, Registers b, Registers c)-   flattenCode (a,b,c) =-      liftM3 (,,) (flattenCode a) (flattenCode b) (flattenCode c)-   unfoldCode x =-      case unzip3 x of-         (a,b,c) -> (unfoldCode a, unfoldCode b, unfoldCode c)--instance Flatten a => Flatten (Stereo.T a) where-   type Registers (Stereo.T a) = Stereo.T (Registers a)-   flattenCode = flattenCodeTraversable-   unfoldCode = unfoldCodeTraversable--instance Flatten a => Flatten (Complex.T a) where-   type Registers (Complex.T a) = Complex.T (Registers a)-   flattenCode s =-      liftM2 (Complex.+:)-         (flattenCode $ Complex.real s)-         (flattenCode $ Complex.imag s)-   unfoldCode =-      unfoldFromGetters $ Complex.real Complex.+: Complex.imag--instance (RealRing.C a, Flatten a) => Flatten (Phase.T a) where-   type Registers (Phase.T a) = Registers a-   flattenCode s =-      flattenCode $ Phase.toRepresentative s-   unfoldCode s =-      -- could also be unsafeFromRepresentative-      Phase.fromRepresentative $ unfoldCode s---instance Flatten (T a) where-   type Registers (T a) = a-   flattenCode = code-   unfoldCode = id--instance Flatten () where-   type Registers () = ()-   flattenCode = return-   unfoldCode _ = ()
− src/Synthesizer/LLVM/Simple/Vanilla.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}-module Synthesizer.LLVM.Simple.Vanilla where--import qualified Synthesizer.LLVM.Simple.Signal as Sig-import qualified Synthesizer.LLVM.Simple.Value as Value--import qualified Synthesizer.Basic.Phase as Phase-import qualified Synthesizer.Basic.Wave  as Wave--import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Memory as Memory-import LLVM.Core (IsArithmetic, IsConst, IsFirstClass, IsSized, Value)--import qualified Algebra.RealRing as RealRing--import NumericPrelude.Base hiding (and, iterate, map, zipWith)---iterateVal ::-   (Memory.C a) =>-   (Value.T a -> Value.T a) ->-   Value.T a -> Sig.T (Value.T a)-iterateVal f initial =-   Sig.simple-      (\y ->-         Maybe.lift $-         fmap (\y1 -> (Value.constantValue y, y1))-              (Value.unlift1 f y))-      (Value.decons initial)--iterate ::-   (Value.Flatten a, Value.Registers a ~ reg, Memory.C reg) =>-   (a -> a) ->-   (a -> Sig.T a)-iterate f initial =-   Sig.simple-      (\y ->-         Maybe.lift $-         fmap (\y1 -> (Value.unfold y, y1))-              (Value.flattenFunction f y))-      (Value.flatten initial)----map ::-   (a -> b) ->-   Sig.T a -> Sig.T b-map f = Sig.map (return . f)---osciReg ::-   (RealRing.C tv, tv ~ Value.T (Value t),-    SoV.Fraction t, IsConst t, IsSized t,-    IsFirstClass y) =>-   Wave.T (Value.T (Value t)) (Value.T (Value y)) ->-   Value t -> Value t -> Sig.T (Value y)-osciReg wave phase freq =-   Sig.map-      (Value.unlift1 $ Wave.apply wave . Phase.fromRepresentative) $-   Sig.iterate (SoV.incPhase freq) phase--osciVal ::-   (RealRing.C tv, tv ~ Value.T (Value t),-    SoV.Fraction t, IsConst t, IsSized t) =>-   Wave.T (Value.T (Value t)) y ->-   Value.T (Value t) -> Value.T (Value t) -> Sig.T y-osciVal wave phase freq =-   map (Wave.apply wave . Phase.fromRepresentative) $-   iterateVal (incPhaseVal freq) phase--incPhaseVal ::-   (SoV.Fraction a, IsArithmetic a) =>-   Value.T (Value a) -> Value.T (Value a) -> Value.T (Value a)-incPhaseVal = Value.lift2 SoV.incPhase--osci ::-   (RealRing.C t,-    Value.Flatten t, Value.Registers t ~ reg, Memory.C reg,-    SoV.Fraction t, IsConst t) =>-   Wave.T t y ->-   Phase.T t -> t -> Sig.T y-osci wave phase freq =-   map (Wave.apply wave) $-   iterate (Phase.increment freq) phase
src/Synthesizer/LLVM/Storable/ChunkIterator.hs view
@@ -6,11 +6,10 @@ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector.Base as SVB -import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Core as LLVM  import Data.Word (Word)-import Foreign.Storable (poke)+import Foreign.Storable (Storable, poke) import Foreign.Ptr (FunPtr, Ptr, nullPtr)  import Control.Monad (liftM2)@@ -23,7 +22,7 @@ FFI declarations must not have constraints. Thus we put them in the iterator datatype. -}-data T a = (Storable.C a) => Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))+data T a = (Storable a) => Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))   foreign import ccall "&nextChunk"@@ -33,7 +32,7 @@    next :: StablePtr (T a) -> Ptr Word -> IO (Ptr a)  -new :: (Storable.C a) => SVL.Vector a -> IO (StablePtr (T a))+new :: (Storable a) => SVL.Vector a -> IO (StablePtr (T a)) new sig =    newStablePtr =<<    liftM2 Cons
src/Synthesizer/LLVM/Storable/Process.hs view
@@ -8,10 +8,9 @@    continuePacked,    ) where -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.CausalIO.Process as PIO- import qualified Synthesizer.Generic.Cut as CutG  import qualified Data.StorableVector as SV@@ -21,12 +20,10 @@ import qualified Data.EventList.Relative.TimeTime  as EventListTT import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Absolute.TimeBody  as AbsEventList-import qualified Number.NonNegative as NonNeg +import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum @@ -36,6 +33,8 @@  import qualified System.Unsafe as Unsafe +import qualified Number.NonNegative as NonNeg+ import NumericPrelude.Numeric import NumericPrelude.Base @@ -49,7 +48,7 @@ must fit into the length of the event list. -} makeArranger ::-   (Arr.Arrow arrow, Storable.C a, Tuple.ValueOf a ~ value, A.Additive value) =>+   (Arr.Arrow arrow, Storable.C a, MultiValue.Additive a) =>    IO (arrow           (EventListTT.T NonNeg.Int (SV.Vector a))           (SV.Vector a))@@ -79,10 +78,10 @@   continuePacked ::-   (CutG.Transform a, Storable.C b, LLVM.IsPrimitive b, TypeNum.Positive n) =>-   PIO.T a (SV.Vector (Serial.Plain n b)) ->-   (b -> PIO.T a (SV.Vector (Serial.Plain n b))) ->-   PIO.T a (SV.Vector (Serial.Plain n b))+   (CutG.Transform a, Storable.Vector b, TypeNum.Positive n) =>+   PIO.T a (SV.Vector (Serial.T n b)) ->+   (b -> PIO.T a (SV.Vector (Serial.T n b))) ->+   PIO.T a (SV.Vector (Serial.T n b)) continuePacked proc0 proc1 =    PIO.continueChunk proc0       (proc1 Arr.<<^ SV.last . SigStL.unpackStrict)
src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -1,27 +1,22 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} {- |-Functions on lazy storable vectors that are implemented using LLVM.+Functions on storable vectors that are implemented using LLVM. -} module Synthesizer.LLVM.Storable.Signal (    unpackStrict, unpack,    unpackStereoStrict, unpackStereo,-   makeUnpackGenericStrict, makeUnpackGeneric,    makeReversePackedStrict, makeReversePacked,    continue, continuePacked, continuePackedGeneric,-   -- should be moved to a private module-   fillBuffer, makeMixer, addToBuffer,-   makeArranger, arrange,+   fillBuffer, makeMixer,+   makeArranger,    ) where -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoVector+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo  import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV@@ -33,33 +28,22 @@ import qualified Number.NonNegative as NonNeg  import qualified LLVM.DSL.Execution as Exec--import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Tuple as Tuple-+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Core as LLVM-import LLVM.Core (IsPrimitive, ret)  import qualified Type.Data.Num.Decimal as TypeNum -import qualified Control.Category as Cat--import qualified Data.List.HT as ListHT-import Data.Word (Word)+import Control.Monad.HT (void) -import Foreign.Ptr (Ptr)+import Foreign.Marshal.Array (advancePtr) import Foreign.ForeignPtr (castForeignPtr) import Foreign.Storable (Storable)-import Foreign.Marshal.Array (advancePtr)+import Foreign.Ptr (Ptr)  import qualified System.Unsafe as Unsafe -import NumericPrelude.Numeric-import NumericPrelude.Base - {- | This function needs only constant time in contrast to 'Synthesizer.LLVM.Parameterized.SignalPacked.unpack'.@@ -68,27 +52,32 @@ since the array size may not line up. It would also need copying since the source data may not be aligned properly. -}-unpackStrict ::-   (Storable.C a, IsPrimitive a, TypeNum.Positive n) =>-   SV.Vector (Serial.Plain n a) -> SV.Vector a-unpackStrict v =+unpackChunk ::+   (Storable.C a, TypeNum.Positive n) =>+   SV.Vector (Serial.T n a) -> SV.Vector a+unpackChunk v =    let getDim ::           (TypeNum.Positive n) =>-          SV.Vector (Serial.Plain n a) -> TypeNum.Singleton n -> Int+          SV.Vector (Serial.T n a) -> TypeNum.Singleton n -> Int        getDim _ = TypeNum.integralFromSingleton        d = getDim v TypeNum.singleton        (fptr,s,l) = SVB.toForeignPtr v    in  SVB.SV (castForeignPtr fptr) (s*d) (l*d) ++unpackStrict ::+   (TypeNum.Positive n, Storable.Vector a) =>+   SV.Vector (Serial.T n a) -> SV.Vector a+unpackStrict = unpackChunk+ unpack ::-   (Storable.C a, IsPrimitive a, TypeNum.Positive n) =>-   SVL.Vector (Serial.Plain n a) -> SVL.Vector a-unpack =-   SVL.fromChunks . map unpackStrict . SVL.chunks+   (TypeNum.Positive n, Storable.Vector a) =>+   SVL.Vector (Serial.T n a) -> SVL.Vector a+unpack = SVL.fromChunks . map unpackChunk . SVL.chunks   unpackStereoStrict ::-   (Storable.C a, IsPrimitive a, TypeNum.Positive n) =>+   (TypeNum.Positive n, Storable.C a) =>    SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a) unpackStereoStrict v =    let getDim ::@@ -100,67 +89,30 @@    in  SVB.SV (castForeignPtr fptr) (s*d) (l*d)  unpackStereo ::-   (Storable.C a, IsPrimitive a, TypeNum.Positive n) =>+   (TypeNum.Positive n, Storable.C a) =>    SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a) unpackStereo =    SVL.fromChunks . map unpackStereoStrict . SVL.chunks -{- |-This is similar to 'unpackStrict' but performs rearrangement of data.-This is for instance necessary for stereo signals-where the data layout of packed and unpacked data is different,-thus simple casting of the data is not possible.-However, for vectorized Stereo data the StereoInterleaved type-still uses vector operations for interleaving and thus is more efficient.--}-makeUnpackGenericStrict ::-   (Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,-    Memory.C (Serial.ReadIt vv),-    Storable.C a, Tuple.ValueOf a ~ va,-    Storable.C v, Tuple.ValueOf v ~ vv) =>-   IO (SV.Vector v -> SV.Vector a)-makeUnpackGenericStrict =-   let vectorSize ::-          (Serial.C vl, n ~ Serial.Size vl, al ~ Serial.Element vl,-           Storable.C v, Tuple.ValueOf v ~ vl) =>-          SV.Vector v -> TypeNum.Singleton n-       vectorSize _ = TypeNum.singleton-   in  fmap (\f v -> f (TypeNum.integralFromSingleton (vectorSize v) * SV.length v) v) $-       SigP.run (SigPS.unpack $ SigP.fromStorableVector Cat.id) -makeUnpackGeneric ::-   (Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,-    Memory.C (Serial.ReadIt vv),-    Storable.C a, Tuple.ValueOf a ~ va,-    Storable.C v, Tuple.ValueOf v ~ vv) =>-   IO (SVL.Vector v -> SVL.Vector a)-makeUnpackGeneric =-   fmap (\f -> SVL.fromChunks . map f . SVL.chunks) $-   makeUnpackGenericStrict-- makeReverser ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>+   (Storable.C a, MultiValue.T a ~ value) =>    (value -> LLVM.CodeGenFunction () value) ->    IO (Word -> Ptr a -> Ptr a -> IO ())---   (Memory.C a struct, Serial.C a) =>---   IO (Word -> Ptr struct -> Ptr struct -> IO ()) makeReverser rev =    Exec.compile "reverse" $    Exec.createFunction derefMixPtr "reverse" $ \ size ptrA ptrB -> do       sizeInt <- LLVM.bitcast size       ptrAEnd <- Storable.advancePtr sizeInt ptrA-      _ <- Storable.arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do+      void $ Storable.arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do          ptrAj1 <- Storable.decrementPtr ptrAj0          flip Storable.store ptrBi             =<< rev             =<< Storable.load ptrAj1          return ptrAj1-      ret ()  makeReversePackedStrict ::-   (Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,-    Storable.C v, Tuple.ValueOf v ~ vv) =>+   (TypeNum.Positive n, Storable.Vector a, v ~ Serial.T n a) =>    IO (SV.Vector v -> SV.Vector v) makeReversePackedStrict = do    rev <- makeReverser Serial.reverse@@ -171,14 +123,14 @@       rev (fromIntegral len) ptrA ptrB  makeReversePacked ::-   (Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,-    Storable.C v, Tuple.ValueOf v ~ vv) =>+   (TypeNum.Positive n, Storable.Vector a, v ~ Serial.T n a) =>    IO (SVL.Vector v -> SVL.Vector v) makeReversePacked =    fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $    makeReversePackedStrict  +-- ToDo: move to synthesizer-core or storablevector {- | Append two signals where the second signal gets the last value of the first signal as parameter.@@ -195,24 +147,16 @@       (SVL.chunks x)       (SV.switchR [] $ \_ -> SVL.chunks . y) -_continueNeglectLast ::-   (Storable a) =>-   SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a-_continueNeglectLast x y =-   SVL.switchR SVL.empty-      (\body l -> SVL.append body (y l)) x- continuePacked ::-   (TypeNum.Positive n, Storable.C a, IsPrimitive a) =>-   SVL.Vector (Serial.Plain n a) ->-   (a -> SVL.Vector (Serial.Plain n a)) ->-   SVL.Vector (Serial.Plain n a)+   (TypeNum.Positive n, Storable.Vector a) =>+   SVL.Vector (Serial.T n a) ->+   (a -> SVL.Vector (Serial.T n a)) ->+   SVL.Vector (Serial.T n a) continuePacked x y =    SVL.fromChunks $    withLast SV.empty       (SVL.chunks x)-      (SV.switchR [] (\_ -> SVL.chunks . y) .-       unpackStrict)+      (SV.switchR [] (\_ -> SVL.chunks . y) . unpackStrict)  {- This function reduces the last chunk to size one, repacks that@@ -229,10 +173,6 @@ >    return (continuePackedGeneric unpackGeneric x y) -} continuePackedGeneric ::-{--   (Storable v, Serial.C v, n ~ Serial.Size v, a ~ Serial.Element v,-    Tuple.Value v, Tuple.ValueOf v ~ vv, Memory.C vv) =>--}    (Storable v, Storable a) =>    (SV.Vector v -> SV.Vector a) ->    SVL.Vector v -> (a -> SVL.Vector v) -> SVL.Vector v@@ -245,24 +185,14 @@          SV.drop (SV.length lastChunk - 1) $ lastChunk)  --- candidate for utility-ht+-- ToDo: candidate for utility-ht withLast :: a -> [a] -> (a -> [a]) -> [a] withLast deflt x y =    foldr       (\a cont _ -> a : cont a)       y x deflt -{--This version is too strict, since it looks one element ahead.--}-_withLast :: [a] -> (a -> [a]) -> [a]-_withLast x y =-   ListHT.switchR []-      (\body end -> body ++ end : y end)-      x -- foreign import ccall safe "dynamic" derefFillPtr ::    Exec.Importer (Word -> Ptr a -> IO ()) @@ -271,31 +201,28 @@ it also simplifies type inference. -} fillBuffer ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>+   (Storable.C a, MultiValue.T a ~ value) =>    value -> IO (Word -> Ptr a -> IO ()) fillBuffer x =    Exec.compile "constant" $-   Exec.createFunction derefFillPtr "constantfill" $ \ size ptr -> do+   Exec.createFunction derefFillPtr "constantfill" $ \ size ptr ->       Storable.arrayLoop size ptr () $ \ ptri () -> Storable.store x ptri-      ret ()   foreign import ccall safe "dynamic" derefMixPtr ::    Exec.Importer (Word -> Ptr a -> Ptr a -> IO ())  makeMixer ::-   (Storable.C a, Tuple.ValueOf a ~ value) =>+   (Storable.C a, MultiValue.T a ~ value) =>    (value -> value -> LLVM.CodeGenFunction () value) ->    IO (Word -> Ptr a -> Ptr a -> IO ()) makeMixer add =    Exec.compile "mixer" $-   Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr -> do-      _ <--         Storable.arrayLoop2 size srcPtr dstPtr () $+   Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr ->+      void $ Storable.arrayLoop2 size srcPtr dstPtr () $             \srcPtri dstPtri () -> do          y <- Storable.load srcPtri          Storable.modify (add y) dstPtri-      ret ()   addToBuffer ::@@ -316,13 +243,13 @@ Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist -} makeArranger ::-   (Storable.C a, Tuple.ValueOf a ~ value, A.Additive value) =>+   (Storable.C a, MultiValue.Additive a) =>    IO (SVL.ChunkSize ->        EventList.T NonNeg.Int (SVL.Vector a) ->        SVL.Vector a) makeArranger = do-   mixer <- makeMixer A.add-   fill <- fillBuffer A.zero+   mixer <- makeMixer MultiValue.add+   fill <- fillBuffer MultiValue.zero    return $ \ (SVL.ChunkSize sz) ->       let sznn = NonNeg.fromNumberMsg "arrange" sz           go acc evs =@@ -351,20 +278,3 @@                    then []                    else chunk : go newAcc future       in  SVL.fromChunks . go []--{- |-This is unsafe since it relies on the prior initialization of the LLVM JIT.-Better use 'makeArranger'.--}-{-# DEPRECATED arrange "better use makeArranger" #-}-arrange ::-   (Storable.C a, Tuple.ValueOf a ~ value, A.Additive value) =>-      SVL.ChunkSize-   -> EventList.T NonNeg.Int (SVL.Vector a)-         {-^ A list of pairs: (relative start time, signal part),-             The start time is relative to the start time-             of the previous event. -}-   -> SVL.Vector a-         {-^ The mixed signal. -}-arrange =-   Unsafe.performIO makeArranger
src/Synthesizer/LLVM/Storable/Vector.hs view
@@ -1,18 +1,17 @@ {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Storable.Vector where -import qualified LLVM.Extra.Storable as Storable- import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB  import Foreign.Marshal.Array (advancePtr)+import Foreign.Storable (Storable) import Foreign.ForeignPtr (ForeignPtr) import Foreign.Ptr (Ptr) import qualified System.Unsafe as Unsafe  -unsafeToPointers :: (Storable.C a) => SV.Vector a -> (ForeignPtr a, Ptr a, Int)+unsafeToPointers :: (Storable a) => SV.Vector a -> (ForeignPtr a, Ptr a, Int) unsafeToPointers v =    let (fp,s,l) = SVB.toForeignPtr v    in  (fp, Unsafe.foreignPtrToPtr fp `advancePtr` s, l)
+ src/Synthesizer/LLVM/Value.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Synthesizer.LLVM.Value (+   T, decons,+   tau, square, sqrt,+   max, min, limit, fraction,++   (%==), (%/=), (%<), (%<=), (%>), (%>=), not,+   (%&&), (%||),+   (?), (??),++   lift0, lift1, lift2, lift3,+   unlift0, unlift1, unlift2, unlift3, unlift4, unlift5,+   constantValue, constant,+   fromInteger', fromRational',++   Flatten(flattenCode, unfoldCode), Registers,+   flatten, unfold,+   flattenCodeTraversable, unfoldCodeTraversable,+   flattenFunction,+   ) where++import LLVM.DSL.Value++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo ()+import qualified Synthesizer.Basic.Phase as Phase++import qualified Algebra.RealRing as RealRing++import qualified Prelude as P ()+import NumericPrelude.Base hiding (min, max, unzip, unzip3, not)+++instance (RealRing.C a, Flatten a) => Flatten (Phase.T a) where+   type Registers (Phase.T a) = Registers a+   flattenCode s = flattenCode $ Phase.toRepresentative s+   unfoldCode s =+      -- could also be unsafeFromRepresentative+      Phase.fromRepresentative $ unfoldCode s
src/Synthesizer/LLVM/Wave.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Wave where -import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Value as Value  import qualified LLVM.Extra.Arithmetic as A @@ -147,11 +147,24 @@    A.sub (A.fromInteger' 1) <=<    A.mul (A.fromInteger' 2) +{- |+> trapezoidSlope steepness = trapezoidSkew (recip steepness)+-}+trapezoidSlope ::+   (A.PseudoRing a, A.RationalConstant a, A.Real a) =>+   a -> a -> CodeGenFunction r a+trapezoidSlope p =+   A.max (A.fromInteger' (-1)) <=<+   A.min (A.fromInteger' 1) <=<+   A.mul p <=<+   A.sub (A.fromInteger' 1) <=<+   A.mul (A.fromInteger' 2)+ sine ::    (A.Transcendental a, A.RationalConstant a) =>    a -> CodeGenFunction r a sine t =-   A.sin =<< A.mul t =<< Value.decons Value.twoPi+   A.sin =<< A.mul t =<< Value.decons Value.tau
synthesizer-llvm.cabal view
@@ -1,6 +1,6 @@ Cabal-Version:  2.2 Name:           synthesizer-llvm-Version:        0.9+Version:        1.0 License:        GPL-3.0-only License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -58,7 +58,7 @@   default:     False  Source-Repository this-  Tag:         0.9+  Tag:         1.0   Type:        darcs   Location:    http://code.haskell.org/synthesizer/llvm/ @@ -69,9 +69,9 @@  Library   Build-Depends:-    llvm-dsl >=0.0 && <0.1,-    llvm-extra >=0.10 && <0.11,-    llvm-tf >=9.0 && <9.3,+    llvm-dsl >=0.1 && <0.2,+    llvm-extra >=0.11 && <0.12,+    llvm-tf >=9.0 && <13.0,     tfp >=1.0 && <1.1,     vault >=0.3 && <0.4,     synthesizer-core >=0.8 && <0.9,@@ -86,9 +86,9 @@     non-empty >=0.2.1 && <0.4,     event-list >=0.1 && <0.2,     pathtype >=0.8 && <0.9,-    random >=1.0 && <1.2,+    random >=1.0 && <1.3,     containers >=0.1 && <0.7,-    transformers >=0.2 && <0.6,+    transformers >=0.2 && <0.7,     semigroups >=0.1 && <1.0,     utility-ht >=0.0.15 && <0.1 @@ -109,12 +109,11 @@    Hs-source-dirs: src   Exposed-Modules:-    Synthesizer.LLVM.Simple.Signal-    Synthesizer.LLVM.Simple.SignalPacked-    Synthesizer.LLVM.Simple.Value-    Synthesizer.LLVM.Parameterized.Signal-    Synthesizer.LLVM.Parameterized.SignalPacked-    Synthesizer.LLVM.Parameter+    Synthesizer.LLVM.Generator.Signal+    Synthesizer.LLVM.Generator.SignalPacked+    Synthesizer.LLVM.Generator.Core+    Synthesizer.LLVM.Generator.Source+    Synthesizer.LLVM.Generator.Render     Synthesizer.LLVM.Storable.Signal     Synthesizer.LLVM.Storable.Process     Synthesizer.LLVM.Causal.Process@@ -122,16 +121,12 @@     Synthesizer.LLVM.Causal.ProcessPacked     Synthesizer.LLVM.Causal.Controlled     Synthesizer.LLVM.Causal.ControlledPacked-    Synthesizer.LLVM.CausalParameterized.Process-    Synthesizer.LLVM.CausalParameterized.ProcessValue-    Synthesizer.LLVM.CausalParameterized.ProcessPacked-    Synthesizer.LLVM.CausalParameterized.Controlled-    Synthesizer.LLVM.CausalParameterized.ControlledPacked-    Synthesizer.LLVM.CausalParameterized.Functional-    Synthesizer.LLVM.CausalParameterized.FunctionalPlug-    Synthesizer.LLVM.CausalParameterized.RingBuffer-    Synthesizer.LLVM.CausalParameterized.RingBufferForward-    Synthesizer.LLVM.CausalParameterized.Helix+    Synthesizer.LLVM.Causal.Exponential2+    Synthesizer.LLVM.Causal.FunctionalPlug+    Synthesizer.LLVM.Causal.Functional+    Synthesizer.LLVM.Causal.RingBufferForward+    Synthesizer.LLVM.Causal.Helix+    Synthesizer.LLVM.Causal.Render     Synthesizer.LLVM.Fold     Synthesizer.LLVM.Plug.Input     Synthesizer.LLVM.Plug.Output@@ -147,13 +142,15 @@     Synthesizer.LLVM.Filter.Moog     Synthesizer.LLVM.Filter.Universal     Synthesizer.LLVM.Filter.NonRecursive-    Synthesizer.LLVM.Generator.Exponential2     Synthesizer.LLVM.Interpolation     Synthesizer.LLVM.Frame.SerialVector-    Synthesizer.LLVM.Frame-    Synthesizer.LLVM.Frame.Stereo+    Synthesizer.LLVM.Frame.SerialVector.Class+    Synthesizer.LLVM.Frame.SerialVector.Code+    Synthesizer.LLVM.Frame.SerialVector.Plain     Synthesizer.LLVM.Frame.StereoInterleaved+    Synthesizer.LLVM.Frame.Stereo     Synthesizer.LLVM.Frame.Binary+    Synthesizer.LLVM.Frame     Synthesizer.LLVM.Complex     Synthesizer.LLVM.Wave     Synthesizer.LLVM.MIDI@@ -163,13 +160,14 @@     Synthesizer.LLVM.Server.CausalPacked.Instrument     Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug     Synthesizer.LLVM.Server.CausalPacked.Speech+    Synthesizer.LLVM.Server.CausalPacked.Common     Synthesizer.LLVM.Server.SampledSound     Synthesizer.LLVM.Server.Common     Synthesizer.LLVM.Server.CommonPacked-    Synthesizer.LLVM.Server.Parameter+    Synthesizer.LLVM.ConstantPiece+    Synthesizer.LLVM.Value    Other-Modules:-    Synthesizer.LLVM.ConstantPiece     Synthesizer.LLVM.ForeignPtr     Synthesizer.LLVM.Random     Synthesizer.LLVM.EventIterator@@ -177,13 +175,12 @@     Synthesizer.LLVM.Storable.ChunkIterator     Synthesizer.LLVM.Storable.LazySizeIterator     Synthesizer.LLVM.RingBuffer-    Synthesizer.LLVM.Simple.SignalPrivate-    Synthesizer.LLVM.Parameterized.SignalPrivate-    Synthesizer.LLVM.Causal.ProcessPrivate-    Synthesizer.LLVM.CausalParameterized.ProcessPrivate-    -- experimental-    Synthesizer.LLVM.Simple.Vanilla-    -- Synthesizer.LLVM.Parameterized.Value+    Synthesizer.LLVM.Causal.Parameterized+    Synthesizer.LLVM.Causal.Private+    Synthesizer.LLVM.Frame.StereoInterleavedCode+    Synthesizer.LLVM.Generator.Extra+    Synthesizer.LLVM.Generator.Private+    Synthesizer.LLVM.Private  Library server   If flag(buildExamples)@@ -199,7 +196,7 @@       event-list,       shell-utility >=0.0 && <0.2,       pathtype,-      optparse-applicative >=0.11 && <0.16,+      optparse-applicative >=0.11 && <0.19,       containers,       utility-ht,       base@@ -225,6 +222,7 @@       server,       synthesizer-llvm, +      llvm-dsl,       llvm-extra,       llvm-tf,       tfp,@@ -238,6 +236,7 @@       non-empty,       utility-ht,       pathtype,+      unsafe,       base   Else     Buildable: False@@ -256,12 +255,14 @@   Main-Is:     Synthesizer/LLVM/Test.hs   Other-Modules:     Synthesizer.LLVM.LAC2011+    Synthesizer.LLVM.ExampleUtility  Executable synthi-llvm-lndw   If flag(buildExamples) && flag(alsa)     Build-Depends:       synthesizer-llvm, +      llvm-dsl,       llvm-extra,       llvm-tf,       tfp,@@ -300,6 +301,7 @@   Main-Is:     Synthesizer/LLVM/TestALSA.hs   Other-Modules:     Synthesizer.LLVM.LNdW2011+    Synthesizer.LLVM.ExampleUtility  Executable synthi-llvm-alsa   If flag(buildExamples) && flag(alsa)@@ -307,6 +309,8 @@       server,       synthesizer-llvm, +      unsafe,+      llvm-dsl,       llvm-tf,       synthesizer-core,       synthesizer-midi,@@ -358,6 +362,7 @@     Build-Depends:       server,       synthesizer-llvm,+      tfp,        jack >=0.7 && <0.8, @@ -367,7 +372,7 @@       storablevector,       non-negative,       random,-      explicit-exception >=0.1.7 && <0.2,+      explicit-exception >=0.1.7 && <0.3,       event-list,       pathtype,       optparse-applicative,@@ -458,6 +463,7 @@       gnuplot >=0.5 && <0.6,       pathtype,       sox,+      llvm-dsl,       synthesizer-llvm,       synthesizer-core,       numeric-prelude,@@ -481,8 +487,10 @@ Test-Suite synthi-llvm-test   Type: exitcode-stdio-1.0   Build-Depends:+    doctest-exitcode-stdio >=0.0 && <0.1,     synthesizer-llvm, +    llvm-dsl,     llvm-extra,     llvm-tf,     tfp,@@ -493,6 +501,7 @@     utility-ht,      QuickCheck >=1 && <3,+    unsafe,     base   Default-Language: Haskell98   GHC-Options:      -Wall
testsuite/Test/Main.hs view
@@ -7,20 +7,26 @@  import qualified LLVM.Core as LLVM +import Control.Monad.IO.Class (liftIO)+ import Data.Tuple.HT (mapFst) +import qualified Test.DocTest.Driver as DocTest -prefix :: String -> [(String, IO ())] -> [(String, IO ())]++prefix :: String -> [(String, prop)] -> [(String, prop)] prefix msg =    map (mapFst (\str -> msg ++ "." ++ str))  main :: IO () main = do    LLVM.initializeNativeTarget-   mapM_ (\(name,test) -> putStr (name ++ ": ") >> test) $-      concat $-      prefix "Helix" Helix.tests :-      prefix "RingBufferForward" RingBufferForward.tests :-      prefix "Filter" Filter.tests :-      prefix "Packed" Packed.tests :+   DocTest.run $ mapM_+      (\(name,prop) -> do+         DocTest.printPrefix (name++": ")+         DocTest.property =<< liftIO prop) $+      prefix "Helix" Helix.tests +++      prefix "RingBufferForward" RingBufferForward.tests +++      prefix "Filter" Filter.tests +++      prefix "Packed" Packed.tests ++       []
testsuite/Test/Synthesizer/LLVM/Filter.hs view
@@ -1,33 +1,33 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-} module Test.Synthesizer.LLVM.Filter (tests) where +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked+                                                            as ComplexFilterP+import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP-import qualified Synthesizer.LLVM.Filter.Universal as UniFilter import qualified Synthesizer.LLVM.Filter.Moog as Moog-import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter-import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR  import qualified Synthesizer.Plain.Filter.Recursive.Allpass    as AllpassCore import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore import qualified Synthesizer.Plain.Filter.Recursive.Universal  as UniFilterCore import qualified Synthesizer.Plain.Filter.Recursive.Moog       as MoogCore-import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex+                                                            as ComplexFilterCore -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Simple.Signal as Sig-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*))-import Synthesizer.LLVM.Parameter (($#))+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Core as Core+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import Synthesizer.LLVM.Causal.Process (($<), ($*))  import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) import qualified Synthesizer.Interpolation.Module as Ip@@ -52,16 +52,17 @@     randomStorableVector, checkSimilarityPacked)  import qualified Control.Category as Cat-import Control.Category ((<<<))-import Control.Arrow ((&&&), (^<<), (<<^))+import Control.Category ((.), (<<<))+import Control.Arrow ((&&&), (^<<)) import Control.Applicative (liftA2, (<$>)) +import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Core as LLVM-import LLVM.Core (Value)- import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal (D4) import Type.Base.Proxy (Proxy)@@ -75,7 +76,7 @@ import qualified Test.QuickCheck as QC  import NumericPrelude.Numeric-import NumericPrelude.Base+import NumericPrelude.Base hiding ((.))   type SimFloat = CheckSimilarity Float@@ -96,63 +97,58 @@   lfoSine ::-   (Memory.C a) =>-   (forall r. Value Float -> LLVM.CodeGenFunction r a) ->-   Param.T p Float ->-   SigP.T p a+   (Memory.C a, Expr.Aggregate ae a) =>+   (Exp Float -> ae) ->+   Exp Float ->+   Sig.T a lfoSine f reduct =-   SigP.interpolateConstant reduct $-   Sig.map f $-   CausalP.apply (CausalP.mapExponential 2 0.01) $-   SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct)+   Sig.interpolateConstant reduct $+   (Causal.map f . Causal.mapExponential 2 0.01 $*+      Sig.osci Wave.sine 0 (reduct * (0.1/44100)))  allpassControl ::    (TypeNum.Natural n) =>    Proxy n ->-   Param.T p Float ->-   SigP.T p (Allpass.CascadeParameter n (Value Float))+   Exp Float ->+   Sig.T (Allpass.CascadeParameter n (MultiValue.T Float)) allpassControl order =    lfoSine (Allpass.flangerParameter order)  allpassPhaserCausal, allpassPhaserPipeline ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Value Float)-allpassPhaserCausal reduct =-   CausalP.apply-      (Allpass.phaser-       $< allpassControl TypeNum.d16 reduct)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (MultiValue.T Float)+allpassPhaserCausal reduct xs =+   Allpass.phaser+      $< allpassControl TypeNum.d16 reduct+      $* xs  allpassPhaserPipeline reduct xs =    let order = TypeNum.d16-   in  (SigP.drop $# TypeNum.integralFromProxy order) $+   in  (Sig.drop (TypeNum.integralFromProxy order)) $        (Allpass.phaserPipeline          $< allpassControl order reduct          $* xs)  -genOsci :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)+genOsci :: QC.Gen (Float, 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 :: QC.Gen ((Float, Float), 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 :: QC.Gen ((Float, Float), Float) genOsciReductPacked = pair genOsci (arg $ (4*) <$> QC.choose (1, 25))  allpassPipeline :: Gen.Test ((Float,Float), Float) SimFloat allpassPipeline =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple Wave.triangle phase freq-   in  checkSimilarity 1e-2 limitFloat-          (allpassPhaserCausal reduct tone)-          (allpassPhaserPipeline reduct tone)+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci Wave.triangle phase freq+   in checkSimilarity 1e-2 limitFloat+         (\(freqPhase, reduct) ->+            allpassPhaserCausal reduct $ tone freqPhase)+         (\(freqPhase, reduct) ->+            allpassPhaserPipeline reduct $ tone freqPhase)   @@ -162,33 +158,33 @@ -} applyPacked ::    (Memory.C c) =>-   CausalP.T p (c, VectorValue) VectorValue ->-   SigP.T p c ->-   SigP.T p VectorValue ->-   SigP.T p VectorValue+   Causal.T (c, VectorValue) VectorValue ->+   Sig.T c ->+   Sig.T VectorValue ->+   Sig.T VectorValue applyPacked proc cs xs =    proc-      $< ((SigP.interpolateConstant $#-            (recip $ TypeNum.integralFromProxy TypeNum.d4 :: Float)) cs)+      $< Sig.interpolateConstant+            (recip $ TypeNum.integralFromProxy TypeNum.d4 :: Exp Float) cs       $* xs   allpassPhaserPacked ::-   Param.T p Float ->-   SigP.T p VectorValue ->-   SigP.T p VectorValue+   Exp Float ->+   Sig.T VectorValue ->+   Sig.T VectorValue allpassPhaserPacked reduct =    applyPacked Allpass.phaserPacked       (allpassControl TypeNum.d16 reduct)  allpassPacked :: Gen.Test ((Float,Float), Float) SimFloat allpassPacked =-   withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->-   let tone  = SigP.osciSimple  Wave.triangle phase freq-       toneP = SigPS.osciSimple Wave.triangle phase freq+   withGenArgs genOsciReductPacked $+   let tone  (freq,phase) = Sig.osci  Wave.triangle phase freq+       toneP (freq,phase) = SigPS.osci Wave.triangle phase freq    in  checkSimilarityPacked 1e-2 limitFloat-          (allpassPhaserCausal reduct tone)-          (allpassPhaserPacked reduct toneP)+          (\(freqPhase, reduct) -> allpassPhaserCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) -> allpassPhaserPacked reduct $ toneP freqPhase)   interpolateConstant :: Float -> SigS.T a -> SigS.T a@@ -225,44 +221,43 @@  allpassCore :: Gen.Test ((Float,Float), Float) SimStateFloat allpassCore =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple Wave.triangle phase freq-       toneS p =+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci Wave.triangle phase freq+       toneS (freq,phase) =           OsciS.static WaveCore.triangle-             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+             (Phase.fromRepresentative phase) freq    in  checkSimilarityState 1e-2 limitFloat-          (allpassPhaserCausal reduct tone)-          (\p -> allpassPhaserCore (Param.get reduct p) (toneS p))+          (\(freqPhase, reduct) -> allpassPhaserCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) -> allpassPhaserCore reduct $ toneS freqPhase)   -diracImpulse :: SigP.T p (Value Float)-diracImpulse =-   (CausalP.delay1 $# (one::Float)) $*-   (SigP.constant $# (zero::Float))+diracImpulse :: Sig.T (MultiValue.T Float)+diracImpulse = Causal.delay1 one $* Sig.constant zero  firstOrderConstant ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Value Float)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (MultiValue.T Float) firstOrderConstant cutOff xs =    FirstOrder.lowpassCausal-    $< SigP.constant (FirstOrderCore.parameter ^<< cutOff)+    $< Sig.constant (FirstOrderCore.parameter cutOff)     $* xs  firstOrderExponential :: Gen.Test Float SimFloat firstOrderExponential =-   withGenArgs (Gen.choose (0.001, 0.01)) $ \cutOff ->-   let gain = exp(-2*pi*cutOff)+   withGenArgs (Gen.choose (0.001, 0.01)) $+   let gain cutOff = exp(-2*pi*cutOff)    in  checkSimilarity 1e-2 limitFloat-          (SigP.amplify (recip (1 - gain)) $-           firstOrderConstant cutOff diracImpulse)-          (SigP.exponentialCore gain $# (one :: Float))+          (\cutOff ->+             Causal.amplify (recip (1 - gain cutOff)) $*+             firstOrderConstant cutOff diracImpulse)+          (\cutOff -> Core.exponential (gain cutOff) one)  firstOrderCausal ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Value Float)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (MultiValue.T Float) firstOrderCausal reduct xs =    FirstOrder.lowpassCausal     $< lfoSine FirstOrder.parameter reduct@@ -280,19 +275,19 @@  firstOrder :: Gen.Test ((Float,Float), Float) SimStateFloat firstOrder =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple Wave.triangle phase freq-       toneS p =+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci Wave.triangle phase freq+       toneS (freq,phase) =           OsciS.static WaveCore.triangle-             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+             (Phase.fromRepresentative phase) freq    in  checkSimilarityState 1e-2 limitFloat-          (firstOrderCausal reduct tone)-          (\p -> firstOrderCore (Param.get reduct p) (toneS p))+          (\(freqPhase, reduct) -> firstOrderCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) -> firstOrderCore reduct $ toneS freqPhase)  firstOrderCausalPacked ::-   Param.T p Float ->-   SigP.T p VectorValue ->-   SigP.T p VectorValue+   Exp Float ->+   Sig.T VectorValue ->+   Sig.T VectorValue firstOrderCausalPacked reduct =    applyPacked       FirstOrder.lowpassCausalPacked@@ -300,56 +295,62 @@  firstOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat firstOrderPacked =-   withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->-   let tone  = SigP.osciSimple  Wave.triangle phase freq-       toneP = SigPS.osciSimple Wave.triangle phase freq+   withGenArgs genOsciReductPacked $+   let tone  (freq,phase) = Sig.osci  Wave.triangle phase freq+       toneP (freq,phase) = SigPS.osci Wave.triangle phase freq    in  checkSimilarityPacked 1e-2 limitFloat-          (firstOrderCausal reduct tone)-          (firstOrderCausalPacked reduct toneP)+          (\(freqPhase, reduct) ->+             firstOrderCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) ->+             firstOrderCausalPacked reduct $ toneP freqPhase)   secondOrderCausal ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Value Float)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (MultiValue.T Float) secondOrderCausal reduct xs =    SecondOrder.causal-    $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct+    $< lfoSine (SecondOrder.bandpassParameter 10) reduct     $* xs  secondOrderCausalPacked ::-   Param.T p Float ->-   SigP.T p VectorValue ->-   SigP.T p VectorValue+   Exp Float ->+   Sig.T VectorValue ->+   Sig.T VectorValue secondOrderCausalPacked reduct =    applyPacked SecondOrder.causalPacked-      (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct)+      (lfoSine (SecondOrder.bandpassParameter 10) reduct)  secondOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat secondOrderPacked =-   withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->-   let tone  = SigP.osciSimple  Wave.triangle phase freq-       toneP = SigPS.osciSimple Wave.triangle phase freq+   withGenArgs genOsciReductPacked $+   let tone  (freq,phase) = Sig.osci  Wave.triangle phase freq+       toneP (freq,phase) = SigPS.osci Wave.triangle phase freq    in  checkSimilarityPacked 1e-2 limitFloat-          (secondOrderCausal reduct tone)-          (secondOrderCausalPacked reduct toneP)+          (\(freqPhase, reduct) ->+             secondOrderCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) ->+             secondOrderCausalPacked reduct $ toneP freqPhase)  secondOrderCausalPacked2 ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Value Float)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (MultiValue.T Float) secondOrderCausalPacked2 reduct xs =    SecondOrderP.causal-    $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct+    $< lfoSine (SecondOrderP.bandpassParameter 10) reduct     $* xs  secondOrderPacked2 :: Gen.Test ((Float,Float), Float) SimFloat secondOrderPacked2 =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple  Wave.triangle phase freq+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci  Wave.triangle phase freq    in  checkSimilarity 1e-2 limitFloat-          (secondOrderCausal reduct tone)-          (secondOrderCausalPacked2 reduct tone)+          (\(freqPhase, reduct) ->+             secondOrderCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) ->+             secondOrderCausalPacked2 reduct $ tone freqPhase)   {-@@ -360,12 +361,12 @@ -}  universalCausal ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (UniFilter.Result (Value Float))+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (UniFilter.Result (MultiValue.T Float)) universalCausal reduct xs =    UniFilter.causal-    $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct+    $< lfoSine (UniFilter.parameter 10) reduct     $* xs  {-# INLINE universalCore #-}@@ -380,17 +381,18 @@  universal :: Gen.Test ((Float,Float), Float) SimStateFloat universal =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple Wave.triangle phase freq-       toneS p =+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci Wave.triangle phase freq+       toneS (freq,phase) =           OsciS.static WaveCore.triangle-             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+             (Phase.fromRepresentative phase) freq    in  checkSimilarityState 1e-2 limitFloat-          (fmap UniFilter.lowpass $-             universalCausal reduct tone)-          (\p ->+          (\(freqPhase, reduct) ->+             fmap UniFilter.lowpass $+             universalCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) ->              SigS.map UniFilterCore.lowpass $-             universalCore (Param.get reduct p) (toneS p))+             universalCore reduct $ toneS freqPhase) {-        checkSimilarityState 1e-2 limitUniFilter           (universalCausal reduct tone)@@ -401,12 +403,12 @@ moogCausal ::    (TypeNum.Natural n) =>    Proxy n ->-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Value Float)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (MultiValue.T Float) moogCausal order reduct xs =    Moog.causal-    $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct+    $< lfoSine (Moog.parameter order 10) reduct     $* xs  {-# INLINE moogCore #-}@@ -422,46 +424,49 @@  moog :: Gen.Test ((Float,Float), Float) SimStateFloat moog =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+   withGenArgs genOsciReduct $    let order = TypeNum.d6-       tone  = SigP.osciSimple Wave.triangle phase freq-       toneS p =+       tone  (freq,phase) = Sig.osci Wave.triangle phase freq+       toneS (freq,phase) =           OsciS.static WaveCore.triangle-             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+             (Phase.fromRepresentative phase) freq    in  checkSimilarityState 1e-2 limitFloat-          (moogCausal order reduct tone)-          (\p -> moogCore (TypeNum.integralFromProxy order) (Param.get reduct p) (toneS p))+         (\(freqPhase, reduct) ->+            moogCausal order reduct $ tone freqPhase)+         (\(freqPhase, reduct) ->+            moogCore (TypeNum.integralFromProxy order) reduct $+            toneS freqPhase)   complexCausal ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Stereo.T (Value Float))-complexCausal reduct =-   CausalP.apply $-      (ComplexFilter.causal-        $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct)-      <<^ (\x -> Stereo.cons x A.zero)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (Stereo.T (MultiValue.T Float))+complexCausal reduct xs =+   ComplexFilter.causal+      $< lfoSine (ComplexFilter.parameter 10) reduct+      $* ((\x -> Stereo.cons x A.zero) <$> xs)  complexCausalPacked ::-   Param.T p Float ->-   SigP.T p (Value Float) ->-   SigP.T p (Stereo.T (Value Float))-complexCausalPacked reduct =-   CausalP.apply $-      (ComplexFilterP.causal-        $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct)-      <<^ (\x -> Stereo.cons x A.zero)+   Exp Float ->+   Sig.T (MultiValue.T Float) ->+   Sig.T (Stereo.T (MultiValue.T Float))+complexCausalPacked reduct xs =+   ComplexFilterP.causal+      $< lfoSine (ComplexFilterP.parameter 10) reduct+      $* ((\x -> Stereo.cons x A.zero) <$> xs)  complexPacked :: Gen.Test ((Float,Float), Float) SimFloat complexPacked =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple Wave.triangle phase freq+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci Wave.triangle phase freq    in  checkSimilarity 1e-2 limitFloat-          (fmap Stereo.left $-             complexCausal reduct tone)-          (fmap Stereo.left $-             complexCausalPacked reduct tone)+          (\(freqPhase, reduct) ->+             fmap Stereo.left $+             complexCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) ->+             fmap Stereo.left $+             complexCausalPacked reduct $ tone freqPhase)  {-# INLINE complexCore #-} complexCore ::@@ -476,17 +481,18 @@  complex :: Gen.Test ((Float,Float), Float) SimStateFloat complex =-   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->-   let tone = SigP.osciSimple Wave.triangle phase freq-       toneS p =+   withGenArgs genOsciReduct $+   let tone (freq,phase) = Sig.osci Wave.triangle phase freq+       toneS (freq,phase) =           OsciS.static WaveCore.triangle-             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+             (Phase.fromRepresentative phase) freq    in  checkSimilarityState 1e-2 limitFloat-          (fmap Stereo.left $-             complexCausal reduct tone)-          (\p ->+          (\(freqPhase, reduct) ->+             fmap Stereo.left $+             complexCausal reduct $ tone freqPhase)+          (\(freqPhase, reduct) ->              SigS.map ((0.1*) . Stereo.left) $-             complexCore (Param.get reduct p) (toneS p))+             complexCore reduct $ toneS freqPhase) {-    in  checkSimilarityState 1e-2 limitStereoFloat           (complexCausal reduct tone)@@ -501,16 +507,17 @@          (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)-          (FiltNR.convolvePacked mask $* noiseP)+   fmap+      (\f chunkSize (rnd, seed) ->+         f chunkSize+            (Render.buffer $ randomStorableVector (-1,1::Float) rnd, seed))+   $+   checkSimilarityPacked 1e-3 limitFloat+      (\(mask, seed) -> FiltNR.convolve mask $* Sig.noise seed 1)+      (\(mask, seed) -> FiltNR.convolvePacked mask $* SigPS.noise seed 1)  -tests :: [(String, IO ())]+tests :: [(String, IO QC.Property)] tests =    ("secondOrderPacked", checkWithParam secondOrderPacked) :    ("secondOrderPacked2", checkWithParam secondOrderPacked2) :
testsuite/Test/Synthesizer/LLVM/Generator.hs view
@@ -1,7 +1,5 @@ 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) @@ -15,50 +13,33 @@ import Prelude hiding (id)  -data T f p a = Cons (QC.Gen p) (F.PrepareArguments f p a)+type T f p a = QC.Gen p -arg :: QC.Gen a -> T f a (f a)-arg gen = Cons gen F.atomArg+type Param p = (->) p -arbitrary :: (QC.Arbitrary a) => T f a (f a)-arbitrary = arg QC.arbitrary+arg :: QC.Gen a -> QC.Gen a+arg = id -choose :: (Random a) => (a,a) -> T f a (f a)-choose rng = arg $ QC.choose rng+arbitrary :: (QC.Arbitrary a) => QC.Gen a+arbitrary = QC.arbitrary +choose :: (Random a) => (a,a) -> QC.Gen a+choose = QC.choose -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)+pair :: QC.Gen a -> QC.Gen b -> QC.Gen (a,b)+pair = liftA2 (,) +triple :: QC.Gen a -> QC.Gen b -> QC.Gen c -> QC.Gen (a,b,c)+triple = liftA3 (,,) -withPreparedArgs ::-   F.PrepareArguments (Param.T p) p a -> (a -> test) -> test-withPreparedArgs (F.PrepareArguments prepare) f = f $ prepare id+withGenArgs :: QC.Gen p -> (IO (ChunkSize -> p -> test)) -> Test p test+withGenArgs = (,)   type Test p test = (QC.Gen p, IO (ChunkSize -> p -> test)) -checkWithParam :: (Show p, QC.Testable test) => Test p test -> IO ()+checkWithParam :: (Show p, QC.Testable test) => Test p test -> IO QC.Property checkWithParam (gen, test) = do    f <- test-   QC.quickCheck (QC.forAll gen $ flip f)+   return $ QC.property (QC.forAll gen $ flip f)
testsuite/Test/Synthesizer/LLVM/Helix.hs view
@@ -1,41 +1,42 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-} module Test.Synthesizer.LLVM.Helix (tests) where -import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix-import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Causal.Helix as Helix+import qualified Synthesizer.LLVM.Causal.Functional as Func+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.Source as Source+import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Interpolation as Interpolation-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&))-import Synthesizer.LLVM.CausalParameterized.Process (($*))-import Synthesizer.LLVM.Parameter (($#))+import Synthesizer.LLVM.Causal.Functional (($&), (&|&))+import Synthesizer.LLVM.Causal.Process (($*))  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.Generator (checkWithParam) import Test.Synthesizer.LLVM.Utility           (CheckSimilarity, checkSimilarity,-           genRandomVectorParam, randomSignal)+           genRandomVectorParam, randomStorableVectorLoop) -import Control.Arrow (arr)-import Control.Applicative (pure, liftA2)+import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Expression (Exp) -import LLVM.Core (Value)+import qualified LLVM.Extra.Multi.Value as MultiValue  import Foreign.Storable (Storable)  import qualified System.Random as Rnd import Data.Word (Word32) +import Control.Applicative (liftA2)+ -- import qualified Graphics.Gnuplot.Simple as Gnuplot import qualified Test.QuickCheck as QC +import qualified Algebra.Ring as Ring import NumericPrelude.Numeric import NumericPrelude.Base @@ -50,11 +51,11 @@ limitFloat = SVL.take signalLength  -randomSpeed :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Float)-randomSpeed = randomSignal (0,10::Float)+randomSpeed :: (Int, Rnd.StdGen) -> SVL.Vector Float+randomSpeed = randomStorableVectorLoop (0,10) -randomPhase :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Float)-randomPhase = randomSignal (0,1::Float)+randomPhase :: (Int, Rnd.StdGen) -> SVL.Vector Float+randomPhase = randomStorableVectorLoop (0,1)  genStaticDynamic ::    QC.Gen (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32))@@ -67,36 +68,44 @@    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-       noise :: Param.T p Word32 -> SigP.T p (Value Float)-       noise seed = CausalP.take (pure len) $* SigP.noise seed 1+   let len :: (Ring.C a) => a+       len = 1000+       noise :: Exp Word32 -> Sig.T (MultiValue.T Float)+       noise seed = Sig.noise seed 1 -       static =+       static, dynamic ::+          ((Sig.T (MultiValue.T Float), Sig.T (MultiValue.T Float)),+           Exp Float,+           (Exp Word32, Exp (Source.StorableVector Float))) ->+          Func.T inp (MultiValue.T Float)+       static ((speedSig, phaseSig), period, (_, noiseSig)) =           Helix.static Interpolation.linear Interpolation.linear-             (fmap round period) period-             (fmap (\seed -> SigP.render (noise (arr id)) len seed :: SV.Vector Float) noiseParam)+             (Expr.roundToIntFast period) period noiseSig           $&-          Func.fromSignal-             ((CausalP.integrate $# (0::Float)) $* randomSpeed speedParam)+          Func.fromSignal (Causal.integrate zero $* speedSig)           &|&-          Func.fromSignal (randomPhase phaseParam)+          Func.fromSignal phaseSig -       dynamic =+       dynamic ((speedSig, phaseSig), period, (noiseParam, _)) =           Helix.dynamic Interpolation.linear Interpolation.linear-             (fmap round period) period (noise noiseParam)+             (Expr.roundToIntFast period) period+             (Causal.take len $* noise noiseParam)           $&-          Func.fromSignal (randomSpeed speedParam)+          Func.fromSignal speedSig           &|&-          Func.fromSignal (randomPhase phaseParam)+          Func.fromSignal phaseSig -   in  checkSimilarity 5e-3 limitFloat-          (Func.compileSignal static)-          (Func.compileSignal dynamic)+   in liftA2+         (\noiseSig f chunkSize+               ((speedParam, phaseParam), (period, noiseParam)) ->+            f chunkSize+               ((randomSpeed speedParam, randomPhase phaseParam),+                period,+                (noiseParam, Render.buffer (noiseSig len noiseParam))))+         (Render.run noise)+         (checkSimilarity 5e-3 limitFloat+            (Func.compileSignal . static)+            (Func.compileSignal . dynamic))  {- plot :: IO ()@@ -111,7 +120,7 @@ -}  -tests :: [(String, IO ())]+tests :: [(String, IO QC.Property)] tests =    ("staticDynamic", checkWithParam (genStaticDynamic, staticDynamic)) :    []
testsuite/Test/Synthesizer/LLVM/Packed.hs view
@@ -9,36 +9,39 @@     CheckSimilarity, CheckEquality, checkSimilarityPacked)  import qualified Synthesizer.LLVM.Wave as Wave-import qualified Synthesizer.LLVM.Parameter as Param+import LLVM.DSL.Expression (Exp)  import Type.Data.Num.Decimal (D4) import qualified Type.Data.Num.Decimal as TypeNum -import qualified Synthesizer.LLVM.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp-import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import Synthesizer.LLVM.CausalParameterized.Process (($*))+import qualified Synthesizer.LLVM.Frame.SerialVector.Plain as SerialPlain+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Core as SigCore+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Causal.Exponential2 as Exp+import qualified Synthesizer.LLVM.Causal.Process as Causal+import Synthesizer.LLVM.Causal.Process (($*))  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 ((<<<)) import Control.Applicative ((<$>)) -import Data.Word (Word32)+import Data.Word (Word, Word32)  import qualified Test.QuickCheck as QC-import Test.QuickCheck (quickCheck) +import qualified Algebra.Ring as Ring+ import NumericPrelude.Numeric import NumericPrelude.Base   type SimFloat = CheckSimilarity Float-type VectorValue = Serial.Value D4 Float+type VectorValue = SerialCode.Value D4 Float  signalLength :: Int signalLength = 10000@@ -48,87 +51,87 @@ limitFloat = SVL.take signalLength  -withDur ::-   (Param.T Float Float -> IO (ChunkSize -> Float -> test)) ->-   Test Float test+withDur :: (Ring.C a) => IO (ChunkSize -> a -> b) -> Test a b withDur =    withGenArgs (arg (fromIntegral <$> QC.choose (signalLength, 2*signalLength)))  {- limitPackedFloat ::-   SVL.Vector (Serial.Plain D4 Float) -> SVL.Vector (Serial.Plain D4 Float)+   SVL.Vector (SerialPlain.T D4 Float) -> SVL.Vector (SerialPlain.T D4 Float) limitPackedFloat = SVL.take (div signalLength 4) -}  constant :: Test Float SimFloat constant =-   withGenArgs (Gen.choose (-1, 1)) $ \y ->+   withGenArgs (Gen.choose (-1, 1)) $       checkSimilarityPacked 1e-3 limitFloat-         (SigP.constant y) (SigPS.constant y)+         (\y -> Sig.constant y) (\y -> SigPS.constant y)  ramp :: Test Float SimFloat ramp =-   withDur $ \dur ->+   withDur $       checkSimilarityPacked 1e-3 limitFloat-         (SigP.rampInf dur) (SigPS.rampInf dur)+         (\dur -> Sig.rampInf dur) (\dur -> SigPS.rampInf dur)  parabolaFadeIn :: Test Float SimFloat parabolaFadeIn =-   withDur $ \dur ->+   withDur $       checkSimilarityPacked 1e-3 limitFloat-         (SigP.parabolaFadeInInf dur)-         (SigPS.parabolaFadeInInf dur)+         (\dur -> Sig.parabolaFadeInInf dur)+         (\dur -> SigPS.parabolaFadeInInf dur)  parabolaFadeOut :: Test Float SimFloat parabolaFadeOut =-   withDur $ \dur ->+   withDur $       checkSimilarityPacked 1e-3 limitFloat-         (SigP.parabolaFadeOutInf dur)-         (SigPS.parabolaFadeOutInf dur)+         (\dur -> Sig.parabolaFadeOutInf dur)+         (\dur -> SigPS.parabolaFadeOutInf dur) -parabolaFadeInMap :: Test Float SimFloat+parabolaFadeInMap :: Test Word SimFloat parabolaFadeInMap =-   withDur $ \dur ->+   withDur $       checkSimilarity 1e-3 limitFloat-          (SigP.parabolaFadeIn dur)-          (SigP.parabolaFadeInMap dur)+          (\dur -> Sig.parabolaFadeIn dur)+          (\dur -> Sig.parabolaFadeInMap dur) -parabolaFadeOutMap :: Test Float SimFloat+parabolaFadeOutMap :: Test Word SimFloat parabolaFadeOutMap =-   withDur $ \dur ->+   withDur $       checkSimilarity 1e-3 limitFloat-          (SigP.parabolaFadeOut dur)-          (SigP.parabolaFadeOutMap dur)+          (\dur -> Sig.parabolaFadeOut dur)+          (\dur -> Sig.parabolaFadeOutMap dur)  -genExp :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)+genExp :: QC.Gen (Float, Float) genExp = pair (Gen.choose (1000,10000)) (Gen.choose (-1,1))  exponential2 :: Test (Float,Float) SimFloat exponential2 =-   withGenArgs genExp $ \(halfLife,start) ->+   withGenArgs genExp $       checkSimilarityPacked 1e-3 limitFloat-         (SigP.exponential2 halfLife start)-         (SigPS.exponential2 halfLife start)+         (\(halfLife,start) -> Sig.exponential2 halfLife start)+         (\(halfLife,start) -> SigPS.exponential2 halfLife start)  exponential2Static :: Test (Float,Float) SimFloat exponential2Static =-   withGenArgs genExp $ \(halfLife,start) ->+   withGenArgs genExp $       checkSimilarity 1e-3 limitFloat-          (SigP.exponential2 halfLife start)-          (Exp.causalP start <<<-           CausalP.mapSimple Exp.parameter $*-           SigP.constant halfLife)+          (\(halfLife,start) -> Sig.exponential2 halfLife start)+          (\(halfLife,start) ->+           Exp.causal start <<<+           Causal.map Exp.parameterPlain $*+           Sig.constant halfLife)  exponential2PackedStatic :: Test (Float,Float) SimFloat exponential2PackedStatic =-   withGenArgs genExp $ \(halfLife,start) ->+   withGenArgs genExp $       checkSimilarity 1e-3 (limitFloat . SigStL.unpack)-          (SigPS.exponential2 halfLife start ::-           SigP.T (Float,Float) VectorValue)-          (Exp.causalPackedP start <<<-           CausalP.mapSimple Exp.parameterPacked $*-           SigP.constant halfLife)+         (\(halfLife,start) ->+            SigPS.exponential2 halfLife start :: Sig.T VectorValue)+         (\(halfLife,start) ->+           Exp.causalPacked start <<<+           Causal.map Exp.parameterPackedExp $*+           Sig.constant halfLife)  exponential2Controlled :: Test ((Float,Float), (Float,Float)) SimFloat exponential2Controlled =@@ -136,19 +139,20 @@       (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+   let lfo halfLife freq phase =+          Causal.mapExponential 2 halfLife $*+          Sig.osci Wave.approxSine2 phase freq    in  checkSimilarityPacked 1e-3 limitFloat-          (Exp.causalP start <<<-           CausalP.mapSimple Exp.parameter $*-           SigP.interpolateConstant-              (TypeNum.integralFromProxy TypeNum.d4 :: Param.T p Float)-              lfo)-          (Exp.causalPackedP start <<<-           CausalP.mapSimple Exp.parameterPacked $* lfo)+          (-- 'freq' is the LFO frequency measured at vector-rate+           \((halfLife,start), (freq,phase)) ->+           Exp.causal start <<<+           Causal.map Exp.parameterPlain $*+           Sig.interpolateConstant+              (TypeNum.integralFromProxy TypeNum.d4 :: Exp Float)+              (lfo halfLife freq phase))+          (\((halfLife,start), (freq,phase)) ->+           Exp.causalPacked start <<<+           Causal.map Exp.parameterPackedExp $* lfo halfLife freq phase)  osci :: Test (Float,Float) SimFloat osci =@@ -156,10 +160,9 @@       (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)+   checkSimilarityPacked 1e-2 limitFloat+      (\(freq,phase) -> Sig.osci Wave.approxSine2 phase freq)+      (\(freq,phase) -> SigPS.osci Wave.approxSine2 phase freq)   @@ -167,30 +170,28 @@ limitWord32 = SVL.take signalLength  limitPackedWord32 ::-   SVL.Vector (Serial.Plain D4 Word32) -> SVL.Vector (Serial.Plain D4 Word32)+   SVL.Vector (SerialPlain.T D4 Word32) -> SVL.Vector (SerialPlain.T D4 Word32) limitPackedWord32 = SVL.take (div signalLength 4)   noise :: IO (ChunkSize -> Word32 -> CheckEquality Word32) noise =-   checkEquality limitWord32-      (SigP.noiseCore (arr id))-      (SigP.noiseCoreAlt (arr id))+   checkEquality limitWord32 SigCore.noise SigCore.noiseAlt -noiseVector :: IO (ChunkSize -> Word32 -> CheckEquality (Serial.Plain D4 Word32))+noiseVector ::+   IO (ChunkSize -> Word32 -> CheckEquality (SerialPlain.T D4 Word32)) noiseVector =-   checkEquality limitPackedWord32-      (SigPS.noiseCore (arr id))-      (SigPS.noiseCoreAlt (arr id))+   checkEquality limitPackedWord32 SigPS.noiseCore SigPS.noiseCoreAlt -noiseScalarVector :: IO (ChunkSize -> Word32 -> CheckEquality (Serial.Plain D4 Word32))+noiseScalarVector ::+   IO (ChunkSize -> Word32 -> CheckEquality (SerialPlain.T D4 Word32)) noiseScalarVector =    checkEquality limitPackedWord32-      (SigPS.noiseCore (arr id))-      (SigPS.packSmall (SigP.noiseCore (arr id)))+      SigPS.noiseCore+      (SigPS.packSmall . SigCore.noise)  -tests :: [(String, IO ())]+tests :: [(String, IO QC.Property)] tests =    ("constant", checkWithParam constant) :    ("ramp", checkWithParam ramp) :@@ -203,7 +204,7 @@    ("exponential2PackedStatic", checkWithParam exponential2PackedStatic) :    ("exponential2Controlled", checkWithParam exponential2Controlled) :    ("osci", checkWithParam osci) :-   ("noise", quickCheck =<< noise) :-   ("noiseVector", quickCheck =<< noiseVector) :-   ("noiseScalarVector", quickCheck =<< noiseScalarVector) :+   ("noise", QC.property <$> noise) :+   ("noiseVector", QC.property <$> noiseVector) :+   ("noiseScalarVector", QC.property <$> noiseScalarVector) :    []
testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-} module Test.Synthesizer.LLVM.RingBufferForward (tests) where -import qualified Synthesizer.LLVM.Parameter as Param-import qualified Synthesizer.LLVM.CausalParameterized.RingBufferForward as RingBuffer-import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import Synthesizer.LLVM.CausalParameterized.Process (($*))+import qualified Synthesizer.LLVM.Causal.RingBufferForward as RingBuffer+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import Synthesizer.LLVM.Causal.Process (($*))  import qualified Data.StorableVector.Lazy as SVL @@ -15,20 +13,23 @@          (Test, checkWithParam, arg, pair, triple, withGenArgs) import Test.Synthesizer.LLVM.Utility          (CheckEquality, CheckEquality2, checkEquality, checkEquality2,-          genRandomVectorParam, randomSignal)+          genRandomVectorParam, randomStorableVectorLoop) -import Control.Applicative (pure)+import qualified Control.Arrow as Arrow+import Control.Arrow ((<<^))+import Control.Applicative ((<$>)) -import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.DSL.Expression as Expr -import qualified LLVM.Core as LLVM-import LLVM.Core (Value)+import qualified LLVM.Extra.Multi.Value as MultiValue  import Foreign.Storable (Storable)  import qualified System.Random as Rnd import Data.Word (Word, Word32) +import qualified Test.QuickCheck as QC+ import NumericPrelude.Numeric import NumericPrelude.Base @@ -43,65 +44,67 @@ limitFloat = SVL.take signalLength  -trackId :: Test (Int, Word32) EquFloat+trackId :: Test (Word, Word32) EquFloat trackId =    withGenArgs (pair (Gen.choose (1,1000)) Gen.arbitrary) $-         \(bufferSize, seed) ->-     let noise = SigP.noise seed 1+     let noise seed = Sig.noise seed 1      in checkEquality limitFloat-          noise-          (CausalP.mapSimple (RingBuffer.index A.zero) $*-           RingBuffer.track bufferSize noise)+            (\(_bufferSize, seed) -> noise seed)+            (\(bufferSize, seed) ->+               RingBuffer.mapIndex zero+                  $* RingBuffer.track bufferSize (noise seed)) -trackTail :: Test (Int, Word32) EquFloat+trackTail :: Test (Word, Word32) EquFloat trackTail =    withGenArgs (pair (Gen.choose (2,1000)) Gen.arbitrary) $-         \(bufferSize, seed) ->-     let noise = SigP.noise seed 1+     let noise seed = Sig.noise seed 1      in checkEquality limitFloat-          (SigP.tail noise)-          (CausalP.mapSimple (RingBuffer.index A.one) $*-           RingBuffer.track bufferSize noise)+            (\(_bufferSize, seed) -> Sig.tail $ noise seed)+            (\(bufferSize, seed) ->+               RingBuffer.mapIndex one+                  $* RingBuffer.track bufferSize (noise seed)) -trackDrop :: Test (Int, Word32) EquFloat+trackDrop :: Test (Word, Word32) EquFloat trackDrop =    withGenArgs (pair (Gen.choose (0,1000)) Gen.arbitrary) $-         \(n, seed) ->-     let noise = SigP.noise seed 1+     let noise seed = Sig.noise seed 1      in checkEquality limitFloat-          (SigP.drop n noise)-          (CausalP.map RingBuffer.index (fmap (fromIntegral :: Int -> Word) n) $*-           RingBuffer.track (fmap succ n) noise)+          (\(n, seed) -> Sig.drop n $ noise seed)+          (\(n, seed) ->+             RingBuffer.mapIndex n $* RingBuffer.track (n+1) (noise seed)) -randomSkips :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Word)-randomSkips = randomSignal (0,10::Word)+randomSkips :: (Int, Rnd.StdGen) -> SVL.Vector Word+randomSkips = randomStorableVectorLoop (0,10)  trackSkip :: Test ((Int, Rnd.StdGen), Word32) EquFloat trackSkip =    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))+   let noise seed = Sig.noise seed 1+   in (\f chunkSize (sk, seed) -> f chunkSize (randomSkips sk, seed))+      <$>+      checkEquality limitFloat+         (\(skips, seed) -> Causal.skip (noise seed) $* skips)+         (\(skips, seed) ->+            RingBuffer.mapIndex one+               $* (RingBuffer.trackSkip 1 (noise seed) $* skips))  trackSkip1 :: Test (Word, Word32) EquFloat trackSkip1 =-   let bufferSize :: Int-       bufferSize = 1000+   let bufferSize = 1000    in  withGenArgs          (pair             (Gen.choose (0, fromIntegral bufferSize - 1))             Gen.arbitrary) $-         \(k, seed) ->-            let noise = SigP.noise seed 1++            let noise seed = Sig.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))+                  (\(k, seed) ->+                     RingBuffer.mapIndex k $*+                     RingBuffer.track (Expr.cons bufferSize) (noise seed))+                  (\(k, seed) ->+                     RingBuffer.mapIndex k $*+                     (RingBuffer.trackSkip (Expr.cons bufferSize) (noise seed)+                        $* 1))  trackSkipHold ::    Test ((Int, Rnd.StdGen), Word, Word32) (CheckEquality2 Bool Float)@@ -112,17 +115,24 @@             (arg genRandomVectorParam)             (Gen.choose (0, fromIntegral bufferSize - 1))             Gen.arbitrary) $-         \(sk, k, seed) ->-            let skips = randomSkips sk-                noise = SigP.noise seed 1-            in  checkEquality2 limitFloat 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)) +            let noise seed = Sig.noise seed 1+            in (\f chunkSize (sk, k, seed) ->+                  f chunkSize (randomSkips sk, k, seed))+               <$>+               checkEquality2 limitFloat limitFloat+                  (\(skips, k, seed) ->+                   (,) (MultiValue.cons True) <$>+                   (RingBuffer.mapIndex k $*+                    (RingBuffer.trackSkip (Expr.cons bufferSize) (noise seed)+                        $* skips)))+                  (\(skips, k, seed) ->+                   (Arrow.second (RingBuffer.mapIndex k)+                        <<^ (\((b,_s),buf) -> (b,buf)))+                   $*+                   (RingBuffer.trackSkipHold (Expr.cons bufferSize) (noise seed)+                        $* skips))+ {- To do: @@ -130,7 +140,7 @@ -}  -tests :: [(String, IO ())]+tests :: [(String, IO QC.Property)] tests =    ("trackId", checkWithParam trackId) :    ("trackTail", checkWithParam trackTail) :
testsuite/Test/Synthesizer/LLVM/Utility.hs view
@@ -1,13 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} 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.Plug.Output as POut-import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Generator.Render as Render+import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Frame.SerialVector.Code as SerialCode+import Synthesizer.LLVM.Causal.Process () +import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.State.Signal as SigS import qualified Synthesizer.Zip as Zip @@ -19,9 +24,8 @@ import Data.StorableVector.Lazy (ChunkSize) import Foreign.Storable (Storable) -import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Core as LLVM+import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value as MultiValue  import qualified Type.Data.Num.Decimal as TypeNum @@ -31,6 +35,8 @@  import qualified Test.QuickCheck as QC +import qualified System.Unsafe as Unsafe+ import qualified Algebra.RealRing as RealRing import qualified Algebra.Absolute as Absolute @@ -54,30 +60,28 @@ randomStorableVectorLoop range param =    SVL.cycle $ SVL.fromChunks [randomStorableVector range param] -randomSignal ::-   (Storable.C a, Tuple.ValueOf a ~ al, Random a) =>-   (a, a) -> Param.T p (Int, StdGen) -> SigP.T p al-randomSignal range p =-   SigP.fromStorableVectorLazy (randomStorableVectorLoop range <$> p) - render ::-   (Storable.C a, Tuple.ValueOf a ~ al) =>+   (Render.RunArg p) =>+   (Storable.C a, MultiValue.T a ~ al) =>    (SVL.Vector a -> sig) ->-   SigP.T p al -> IO (ChunkSize -> p -> sig)+   (Render.DSLArg p -> Sig.T al) -> IO (ChunkSize -> p -> sig) render limit sig =-   fmap (\func chunkSize -> limit . func chunkSize) $ SigP.runChunky sig+   fmap (\func chunkSize -> limit . func chunkSize) $ Render.run sig  render2 ::-   (Storable.C a, Tuple.ValueOf a ~ al) =>-   (Storable.C b, Tuple.ValueOf b ~ bl) =>+   (Render.RunArg p) =>+   (Storable.C a, MultiValue.T a ~ al) =>+   (Storable.C b, MultiValue.T b ~ bl) =>    ((SVL.Vector a, SVL.Vector b) -> sig) ->-   SigP.T p (al, bl) -> IO (ChunkSize -> p -> sig)-render2 limit sig =-   fmap (\func chunkSize ->-            limit . mapPair (SVL.fromChunks, SVL.fromChunks) .-            unzip . map (\(Zip.Cons a b) -> (a,b)) . func chunkSize) $-   SigP.runChunkyPlugged sig POut.deflt+   (Render.DSLArg p -> Sig.T (al, bl)) -> IO (ChunkSize -> p -> sig)+render2 limit sig = do+   proc <- CausalRender.run (CausalClass.fromSignal . sig)+   return $ \(SVL.ChunkSize chunkSize) p ->+      limit . mapPair (SVL.fromChunks, SVL.fromChunks) .+      unzip . map (\(Zip.Cons a b) -> (a,b)) $+      Unsafe.performIO (PIO.runCont (proc p)) (const [])+         (repeat $ SigG.LazySize chunkSize)   data CheckSimilarityState a =@@ -94,10 +98,11 @@  {-# INLINE checkSimilarityState #-} checkSimilarityState ::-   (RealRing.C a, Storable.C a, Tuple.ValueOf a ~ av) =>+   (Render.RunArg p) =>+   (RealRing.C a, Storable.C a, MultiValue.T a ~ av) =>    a ->    (SVL.Vector a -> SVL.Vector a) ->-   SigP.T p av ->+   (Render.DSLArg p -> Sig.T av) ->    (p -> SigS.T a) ->    IO (ChunkSize -> p -> CheckSimilarityState a) checkSimilarityState tol limit gen0 sig1 =@@ -110,7 +115,9 @@ data CheckSimilarity a =    CheckSimilarity a (SVL.Vector a) (SVL.Vector a) -instance (Storable a, Ord a, Absolute.C a) => QC.Testable (CheckSimilarity a) where+instance+   (Storable a, Ord a, Absolute.C a) =>+      QC.Testable (CheckSimilarity a) where    property (CheckSimilarity tol xs ys) =       QC.property $          SigS.foldR (&&) True $@@ -121,11 +128,13 @@  {-# INLINE checkSimilarity #-} checkSimilarity ::+   (Render.RunArg p) =>    (RealRing.C b, Storable.C b,-    Storable.C a, Tuple.ValueOf a ~ av) =>+    Storable.C a, MultiValue.T a ~ av) =>    b ->    (SVL.Vector a -> SVL.Vector b) ->-   SigP.T p av -> SigP.T p av ->+   (Render.DSLArg p -> Sig.T av) ->+   (Render.DSLArg p -> Sig.T av) ->    IO (ChunkSize -> p -> CheckSimilarity b) checkSimilarity tol limit gen0 gen1 =    liftM2@@ -135,13 +144,14 @@       (render limit gen1)  checkSimilarityPacked ::+   (Render.RunArg p) =>    Float ->    (SVL.Vector Float -> SVL.Vector Float) ->-   SigP.T p (LLVM.Value Float) ->-   SigP.T p (Serial.Value TypeNum.D4 Float) ->+   (Render.DSLArg p -> Sig.T (MultiValue.T Float)) ->+   (Render.DSLArg p -> Sig.T (SerialCode.Value TypeNum.D4 Float)) ->    IO (ChunkSize -> p -> CheckSimilarity Float) checkSimilarityPacked tol limit scalar vector =-   checkSimilarity tol limit scalar (SigPS.unpack vector)+   checkSimilarity tol limit scalar (SigPS.unpack . vector)   {- |@@ -158,9 +168,11 @@    property (CheckEqualityGen x y) = QC.property (x==y)  checkEquality ::-   (Eq a, Storable.C a, Tuple.ValueOf a ~ av) =>+   (Render.RunArg p) =>+   (Eq a, Storable.C a, MultiValue.T a ~ av) =>    (SVL.Vector a -> SVL.Vector a) ->-   SigP.T p av -> SigP.T p av ->+   (Render.DSLArg p -> Sig.T av) ->+   (Render.DSLArg p -> Sig.T av) ->    IO (ChunkSize -> p -> CheckEquality a) checkEquality limit gen0 gen1 =    liftM2@@ -170,11 +182,13 @@       (render limit gen1)  checkEquality2 ::-   (Eq a, Storable.C a, Tuple.ValueOf a ~ al) =>-   (Eq b, Storable.C b, Tuple.ValueOf b ~ bl) =>+   (Render.RunArg p) =>+   (Eq a, Storable.C a, MultiValue.T a ~ al) =>+   (Eq b, Storable.C b, MultiValue.T b ~ bl) =>    (SVL.Vector a -> SVL.Vector a) ->    (SVL.Vector b -> SVL.Vector b) ->-   SigP.T p (al,bl) -> SigP.T p (al,bl) ->+   (Render.DSLArg p -> Sig.T (al,bl)) ->+   (Render.DSLArg p -> Sig.T (al,bl)) ->    IO (ChunkSize -> p -> CheckEquality2 a b) checkEquality2 limitA limitB gen0 gen1 =    liftM2