synthesizer-llvm 0.7.0.1 → 0.8
raw patch · 64 files changed
+3379/−2625 lines, 64 filesdep +optparse-applicativedep +pathtypedep −filepathdep ~llvm-extradep ~llvm-tfdep ~midinew-component:exe:synthi-llvm-lndw
Dependencies added: optparse-applicative, pathtype
Dependencies removed: filepath
Dependency ranges changed: llvm-extra, llvm-tf, midi, non-empty, numeric-prelude, random, sox, storable-record, storablevector, synthesizer-core, tfp, transformers, utility-ht, vault
Files
- Changes.md +18/−0
- alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs +10/−6
- alsa/Synthesizer/LLVM/Server/Option.hs +33/−129
- alsa/Synthesizer/LLVM/Server/Packed/Run.hs +6/−2
- alsa/Synthesizer/LLVM/Server/Packed/Test.hs +43/−40
- alsa/Synthesizer/LLVM/Server/Scalar/Run.hs +3/−2
- alsa/Synthesizer/LLVM/Server/Scalar/Test.hs +19/−11
- example/Synthesizer/LLVM/LAC2011.hs +5/−3
- example/Synthesizer/LLVM/LNdW2011.hs +25/−23
- example/Synthesizer/LLVM/Test.hs +27/−22
- example/Synthesizer/LLVM/TestALSA.hs +7/−0
- jack/Synthesizer/LLVM/Server/JACK.hs +8/−2
- jack/Synthesizer/LLVM/Server/Option.hs +15/−88
- render/Synthesizer/LLVM/Server/Option.hs +36/−117
- server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +658/−0
- server/Synthesizer/LLVM/Server/Default.hs +29/−0
- server/Synthesizer/LLVM/Server/OptionCommon.hs +118/−0
- src/Synthesizer/LLVM/Alloc.hs +18/−10
- src/Synthesizer/LLVM/Causal/Controlled.hs +150/−0
- src/Synthesizer/LLVM/Causal/ControlledPacked.hs +128/−0
- src/Synthesizer/LLVM/Causal/Process.hs +197/−368
- src/Synthesizer/LLVM/Causal/ProcessPacked.hs +5/−3
- src/Synthesizer/LLVM/Causal/ProcessPrivate.hs +262/−1
- src/Synthesizer/LLVM/CausalParameterized/Controlled.hs +8/−138
- src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs +8/−117
- src/Synthesizer/LLVM/CausalParameterized/Functional.hs +63/−23
- src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs +2/−2
- src/Synthesizer/LLVM/CausalParameterized/Helix.hs +6/−4
- src/Synthesizer/LLVM/CausalParameterized/Process.hs +65/−74
- src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs +8/−5
- src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs +60/−0
- src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs +295/−0
- src/Synthesizer/LLVM/ConstantPiece.hs +9/−3
- src/Synthesizer/LLVM/Execution.hs +46/−28
- src/Synthesizer/LLVM/Filter/Chebyshev.hs +1/−1
- src/Synthesizer/LLVM/Filter/NonRecursive.hs +1/−1
- src/Synthesizer/LLVM/Filter/SecondOrder.hs +1/−1
- src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs +7/−5
- src/Synthesizer/LLVM/Filter/Universal.hs +1/−1
- src/Synthesizer/LLVM/Fold.hs +40/−0
- src/Synthesizer/LLVM/ForeignPtr.hs +62/−0
- src/Synthesizer/LLVM/Frame/Binary.hs +28/−0
- src/Synthesizer/LLVM/Parameter.hs +10/−1
- src/Synthesizer/LLVM/Parameterized/Signal.hs +180/−48
- src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +12/−1
- src/Synthesizer/LLVM/RingBuffer.hs +2/−55
- src/Synthesizer/LLVM/RingBufferForward.hs +0/−293
- src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +0/−655
- src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +24/−1
- src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs +4/−1
- src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs +26/−7
- src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs +36/−39
- src/Synthesizer/LLVM/Server/Packed/Instrument.hs +49/−5
- src/Synthesizer/LLVM/Server/SampledSound.hs +15/−8
- src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs +5/−2
- src/Synthesizer/LLVM/Server/Scalar/Instrument.hs +13/−1
- src/Synthesizer/LLVM/Simple/Signal.hs +111/−222
- src/Synthesizer/LLVM/Simple/SignalPacked.hs +6/−6
- src/Synthesizer/LLVM/Simple/SignalPrivate.hs +216/−0
- src/Synthesizer/LLVM/Simple/Value.hs +1/−1
- src/Synthesizer/LLVM/Storable/Signal.hs +4/−9
- synthesizer-llvm.cabal +130/−39
- testsuite/Test/Synthesizer/LLVM/Helix.hs +3/−0
- testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs +1/−1
+ Changes.md view
@@ -0,0 +1,18 @@+# Change log for the `synthesizer-llvm` package++## 8.0++* Compiled code is now freed by the garbage collector if it is no longer needed.++* `reverbSimple`: No longer add the original signal.+ Every partial comb filter maintains it anyway.++* In `CausalParameterized.Process`:+ `reverb` -> `reverbSimple`+ `reverbEfficient` -> `reverb`++* added many export lists++* For GHC-7.10 we had to separate `ProcessOf` type functions+ from `synthesizer-core:CausalClass`.+ We adapt to this change here.
alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs view
@@ -5,6 +5,7 @@ import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr 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.Arrange ((&+&), shortTime, controllerExponentialDim, ) import Synthesizer.LLVM.Server.CommonPacked@@ -27,6 +28,7 @@ import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.Zip as Zip +import qualified Synthesizer.ALSA.Storable.Play as Play import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa import Synthesizer.MIDI.Storable (Instrument, ) @@ -56,6 +58,8 @@ import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.BodyTime as EventListBT +import System.Path ((</>), )+ import Control.Arrow ((<<<), (<<^), (^<<), arr, first, ) import Control.Category (id, ) import Control.Applicative (pure, liftA2, )@@ -81,8 +85,8 @@ import Prelude hiding (Real, round, break, id, ) -sampleRate :: Option.SampleRate Real-sampleRate = Option.SampleRate Option.defaultSampleRate+sampleRate :: SampleRate Real+sampleRate = Default.sampleRate {- | try to reproduce a space leak@@ -91,8 +95,8 @@ sequencePlain = SVL.writeFile "/tmp/test.f32" $ -- print $ last $ SVL.chunks $- CutSt.arrange Option.defaultChunkSize $- evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $+ CutSt.arrange Play.defaultChunkSize $+ evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Real)) $ let evs = EventList.cons 10 ([]::[Event.T]) evs in evs @@ -136,7 +140,7 @@ arr shortTime <<< MIO.sequenceCore- Option.defaultChannel+ Default.channel (\ _pgm -> ping sampleRate) writeTest proc evs@@ -352,7 +356,7 @@ loadTomato opt = case Sample.tomatensalat of Sample.Info name _sampleRate _positions ->- Sample.load (Option.sampleDirectory opt ++ "/" ++ name)+ Sample.load (Option.sampleDirectory opt </> name) sampledSoundMono :: IO () sampledSoundMono = do
alsa/Synthesizer/LLVM/Server/Option.hs view
@@ -1,27 +1,22 @@ module Synthesizer.LLVM.Server.Option ( T(..), get,- defaultChannel,- Play.defaultChunkSize,- defaultSampleRate,- defaultLatency, SampleRate(SampleRate), ) where -import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), )+import qualified Synthesizer.LLVM.Server.OptionCommon as Option+import Synthesizer.LLVM.Server.Common (SampleRate(..), )+ import qualified Synthesizer.ALSA.Storable.Play as Play import qualified Data.StorableVector.Lazy as SVL import Synthesizer.ALSA.EventList (ClientName(ClientName)) import qualified Sound.MIDI.Message.Channel as ChannelMsg -import System.Console.GetOpt- (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )-import System.Environment (getArgs, getProgName, )-import System.Exit (exitSuccess, exitFailure, )-import qualified System.IO as IO--import Control.Monad (when, )+import qualified System.Path as Path+import qualified Options.Applicative as OP+import Control.Applicative (pure, (<$>), (<*>), )+import Data.Monoid ((<>), ) import Prelude hiding (Real, ) @@ -31,7 +26,7 @@ device :: Play.Device, clientName :: ClientName, channel, extraChannel :: ChannelMsg.Channel,- sampleDirectory :: FilePath,+ sampleDirectory :: Path.AbsRelDir, sampleRate :: Maybe (SampleRate Int), chunkSize :: SVL.ChunkSize, latency :: Int@@ -39,31 +34,6 @@ deriving (Show) -deflt :: T-deflt =- Cons {- device = Play.defaultDevice,- clientName = defaultClientName,- channel = defaultChannel,- extraChannel = ChannelMsg.toChannel 1,- sampleDirectory = "speech",- sampleRate = Nothing,- chunkSize = Play.defaultChunkSize,- latency = defaultLatency- }--defaultClientName :: ClientName-defaultClientName =- ClientName "Haskell-LLVM-Synthesizer"--defaultChannel :: ChannelMsg.Channel-defaultChannel = ChannelMsg.toChannel 0--defaultSampleRate :: Num a => a--- defaultSampleRate = 24000--- defaultSampleRate = 48000-defaultSampleRate = 44100- defaultLatency :: Int defaultLatency = -- 0@@ -72,97 +42,31 @@ -exitFailureMsg :: String -> IO a-exitFailureMsg msg =- IO.hPutStrLn IO.stderr msg >> exitFailure--parseChannel :: String -> IO ChannelMsg.Channel-parseChannel str =- case reads str of- [(chan, "")] ->- if 0<=chan && chan<16- then return $ ChannelMsg.toChannel chan- else exitFailureMsg "MIDI channel must a number from 0..15"- _ ->- exitFailureMsg $ "channel must be a number, but is '" ++ str ++ "'"--parseNumber ::- (Read a) =>- String -> (a -> Bool) -> String -> String -> IO a-parseNumber name constraint constraintName str =- case reads str of- [(n, "")] ->- if constraint n- then return n- else exitFailureMsg $ name ++ " must be a " ++ constraintName ++ " number"- _ ->- exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"--maxInt :: Integer-maxInt =- fromIntegral (maxBound :: Int)---{--Guide for common Linux/Unix command-line options:- http://www.faqs.org/docs/artu/ch10s05.html--}-description :: [OptDescr (T -> IO T)]-description =- Option ['h'] ["help"]- (NoArg $ \ _flags -> do- programName <- getProgName- putStrLn- (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description)- exitSuccess)- "show options" :- Option ['d'] ["device"]- (flip ReqArg "NAME" $ \str flags ->- return $ flags{device = str})- "select ALSA output device" :- Option [] ["clientname"]- (flip ReqArg "NAME" $ \str flags ->- return $ flags{clientName = ClientName str})- "name of the ALSA client" :- Option ['r'] ["samplerate"]- (flip ReqArg "RATE" $ \str flags ->- fmap (\rate -> flags{sampleRate = Just $ SampleRate $ fromInteger rate}) $- parseNumber "sample-rate" (\n -> 0<n && n<=maxInt) "positive" str)- "sample-rate in samples per second" :- Option ['b'] ["blocksize"]- (flip ReqArg "SIZE" $ \str flags ->- fmap (\size -> flags{chunkSize = SVL.ChunkSize $ fromInteger size}) $- parseNumber "blocksize" (\n -> 0<n && n<=maxInt) "positive" str)- "block size as number of sample-frames" :- Option [] ["latency"]- (flip ReqArg "SIZE" $ \str flags ->- fmap (\size -> flags{latency = fromInteger size}) $- parseNumber "latency" (\n -> 0<=n && n<=maxInt) "non-negative" str)- "latency as number of sample-frames" :- Option ['c'] ["channel"]- (flip ReqArg "CHANNEL" $ \str flags ->- fmap (\chan -> flags{channel = chan}) $- parseChannel str)- "select MIDI input channel (0-based)" :- Option [] ["extra-channel"]- (flip ReqArg "CHANNEL" $ \str flags ->- fmap (\chan -> flags{extraChannel = chan}) $- parseChannel str)- "select MIDI channel with effects" :- Option ['I'] ["sample-directory"]- (flip ReqArg "DIR" $ \str flags ->- return $ flags{sampleDirectory = str})- "directory for sound samples" :- []+options :: OP.Parser T+options =+ pure Cons+ <*> OP.strOption+ (OP.short 'd' <>+ OP.long "device" <>+ OP.metavar "NAME" <>+ OP.value Play.defaultDevice <>+ OP.help "select ALSA output device")+ <*> fmap+ (\(Option.ClientName name) -> ClientName name)+ (Option.clientName "Name of the ALSA client")+ <*> Option.channel+ <*> Option.extraChannel+ <*> Option.sampleDirectory+ <*> Option.sampleRate+ <*> Option.blockSize Play.defaultChunkSize+ <*> OP.option+ (fromInteger <$>+ Option.parseNumber "latency" (\n -> 0<=n && n<=Option.maxInt) "non-negative")+ (OP.long "latency" <>+ OP.metavar "SIZE" <>+ OP.value defaultLatency <>+ OP.help "latency as number of sample-frames") get :: IO T-get = do- argv <- getArgs- let (opts, files, errors) = getOpt RequireOrder description argv- when (not $ null errors) $- exitFailureMsg (init (concat errors))- when (not $ null files) $- exitFailureMsg $- "Do not know what to do with arguments " ++ show files- foldl (>>=) (return deflt) opts+get = Option.get options "Live software synthesizer using LLVM and ALSA"
alsa/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -41,7 +41,10 @@ import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.MixedTime as EventListMT -import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, )+import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path++import Control.Applicative.HT (liftA4, liftA5, liftA6, ) import Control.Arrow ((<<<), (^<<), arr, ) import Control.Applicative (pure, liftA2, liftA3, (<*>), ) import Control.Monad.Trans.State (evalState, )@@ -203,7 +206,8 @@ controllerFMPartial4 = Ctrl.effect2Depth keyboardDetuneFMCore ::- FilePath ->+ (PathClass.AbsRel ar) =>+ Path.Dir ar -> IO (ChannelMsg.Channel -> VoiceMsg.Program -> SVL.ChunkSize -> SampleRate Real -> MidiEv.Filter Event.T (SigSt.T StereoVector))
alsa/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -1,7 +1,7 @@ module Synthesizer.LLVM.Server.Packed.Test where import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr-import qualified Synthesizer.LLVM.Server.Option as Option+import qualified Synthesizer.LLVM.Server.Default as Default import qualified Synthesizer.LLVM.Server.SampledSound as Sample import Synthesizer.LLVM.Server.ALSA (makeNote, ) import Synthesizer.LLVM.Server.CommonPacked@@ -58,17 +58,20 @@ import Prelude hiding (Real, round, break, ) +chunkSize :: SVL.ChunkSize+chunkSize = Play.defaultChunkSize+ vectorChunkSize :: SVL.ChunkSize vectorChunkSize =- case Play.defaultChunkSize of+ case chunkSize of SVL.ChunkSize size -> SVL.ChunkSize (divUp size vectorSize) sampleRatePlain :: Num a => a-sampleRatePlain = Option.defaultSampleRate+sampleRatePlain = case Default.sampleRate of SampleRate r -> r -sampleRate :: Option.SampleRate Real-sampleRate = Option.SampleRate Option.defaultSampleRate+sampleRate :: SampleRate Real+sampleRate = Default.sampleRate emptyEvents :: time -> EventList.T time [Event.T]@@ -84,8 +87,8 @@ sequencePlain = SVL.writeFile "test.f32" $ -- print $ last $ SVL.chunks $- CutSt.arrange Option.defaultChunkSize $- evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $+ CutSt.arrange chunkSize $+ evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Real)) $ emptyEvents 10 sequenceLLVM :: IO ()@@ -94,7 +97,7 @@ SVL.writeFile "test.f32" $ -- print $ last $ SVL.chunks $ arrange vectorChunkSize $- evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Vector)) $+ evalState (Gen.sequence Default.channel (error "no sound" :: Instrument Real Vector)) $ emptyEvents 10 sequencePitchBendCycle :: IO ()@@ -105,7 +108,7 @@ evalState (let -- fm = error "undefined pitch bend" fm = EventListBT.cons 1 10 fm- in Gen.sequenceModulated fm Option.defaultChannel+ in Gen.sequenceModulated fm Default.channel (error "no sound" :: PC.T Real -> Instrument Real Vector)) $ emptyEvents 10@@ -117,7 +120,7 @@ arrange vectorChunkSize $ evalState (let fm y = EventListBT.cons y 10 (fm (2-y))- in Gen.sequenceModulated (fm 1) Option.defaultChannel+ in Gen.sequenceModulated (fm 1) Default.channel (error "no sound" :: PC.T Real -> Instrument Real Vector)) $ emptyEvents 10@@ -128,8 +131,8 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (do fm <- PC.pitchBend Option.defaultChannel 2 0.01- Gen.sequenceModulated fm Option.defaultChannel+ (do fm <- PC.pitchBend Default.channel 2 0.01+ Gen.sequenceModulated fm Default.channel (error "no sound" :: PC.T Real -> Instrument Real Vector)) $ emptyEvents 10@@ -140,8 +143,8 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03- Gen.sequenceModulated fm Option.defaultChannel+ (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03+ Gen.sequenceModulated fm Default.channel (error "no sound" :: PC.T (BM.T Real) -> Instrument Real Vector)) $@@ -156,7 +159,7 @@ -- sound <- Instr.pingRelease $/ 1 $/ 1 $/ sampleRate -- no space leak SVL.writeFile "test.f32" $ arrange vectorChunkSize $- evalState (Gen.sequence Option.defaultChannel sound) $+ evalState (Gen.sequence Default.channel sound) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ EventList.cons 10 [makeNote Event.NoteOn 64] $@@ -169,8 +172,8 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03- Gen.sequenceModulated fm Option.defaultChannel+ (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03+ Gen.sequenceModulated fm Default.channel (\fmlocal -> sound fmlocal $ sampleRate)) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $@@ -184,8 +187,8 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03- Gen.sequenceModulated fm Option.defaultChannel+ (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03+ Gen.sequenceModulated fm Default.channel (\fmlocal -> sound fmlocal $ sampleRate)) $ let evs t = EventList.cons t [makeNote Event.NoteOn 60] $@@ -202,7 +205,7 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (Gen.sequence Option.defaultChannel (\ _freq -> sound)) $+ (Gen.sequence Default.channel (\ _freq -> sound)) $ let evs t = EventList.cons t [makeNote Event.NoteOn 60] $ EventList.cons t [makeNote Event.NoteOff 60] $@@ -217,7 +220,7 @@ sampledSoundTest0 = liftA (\osc smp _fm _vel _freq _dur ->- osc Option.defaultChunkSize (Sample.body smp))+ osc chunkSize (Sample.body smp)) (SigP.runChunky (let smp = arr id in fmap (\x -> Stereo.cons x x) $@@ -231,7 +234,7 @@ sampledSoundTest1 = liftA (\osc smp _fm _vel _freq _dur ->- osc Option.defaultChunkSize (Sample.body smp))+ osc chunkSize (Sample.body smp)) (SigP.runChunky (let smp = arr id in CausalP.stereoFromMono@@ -256,7 +259,7 @@ SigSt.drop (Sample.start pos) $ Sample.body smp in SVP.take (chunkSizesFromLazyTime dur) $- osc Option.defaultChunkSize+ osc chunkSize (sampleRate, (body, (fm, freq * Sample.period pos)))) (SigP.runChunky (let smp = signal fst@@ -286,7 +289,7 @@ -} let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp@@ -383,7 +386,7 @@ (\osc smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp@@ -401,7 +404,7 @@ liftA (\osc smp _fm _vel freq dur -> case SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period (Sample.positions smp) / sampleRatePlain)) :: SigSt.T Vector) of (sustainFM, releaseFM) ->@@ -420,7 +423,7 @@ (\smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp@@ -441,7 +444,7 @@ (\osc smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp@@ -461,7 +464,7 @@ (\osc smp _fm _vel freq dur -> let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp@@ -486,7 +489,7 @@ -} let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $- (SigSt.repeat Option.defaultChunkSize+ (SigSt.repeat chunkSize (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp@@ -505,7 +508,7 @@ makeSample :: Int -> Sample.T makeSample size = Sample.Cons- (SigSt.replicate Option.defaultChunkSize size 0)+ (SigSt.replicate chunkSize size 0) (DN.frequency 44100) (Sample.Positions 0 100000 50000 50000 100) @@ -517,8 +520,8 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03- Gen.sequenceModulated fm Option.defaultChannel sound) $+ (do fm <- PC.bendWheelPressure Default.channel 2 0.04 0.03+ Gen.sequenceModulated fm Default.channel sound) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ evs 10@@ -528,7 +531,7 @@ sequenceSample1 = do sampler <- Instr.sampledSound let sound =- sampler (SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0)+ sampler (SampledSound (SigSt.replicate chunkSize 100000 0) (SamplePositions 0 100000 50000 50000) 100) SVL.writeFile "test.f32" $@@ -579,7 +582,7 @@ let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 !(sustainFM, releaseFM) = SVP.splitAt dur $- (SigSt.repeat Option.defaultChunkSize (Serial.replicate 1)+ (SigSt.repeat chunkSize (Serial.replicate 1) :: SigSt.T Vector) in case 3::Int of -- no leak@@ -604,9 +607,9 @@ SVL.writeFile "test.f32" $ arrange vectorChunkSize $ evalState- (do bend <- PC.pitchBend Option.defaultChannel 2 0.01+ (do bend <- PC.pitchBend Default.channel 2 0.01 let fm = fmap (\t -> BM.Cons t t) bend- Gen.sequenceModulated fm Option.defaultChannel sound) $+ Gen.sequenceModulated fm Default.channel sound) $ let evs t = EventList.cons t [] (evs (20-t)) in EventList.cons 10 [makeNote Event.NoteOn 60] $ evs 10@@ -626,7 +629,7 @@ evalState (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs- in Gen.sequence Option.defaultChannel (sound evs)) $+ in Gen.sequence Default.channel (sound evs)) $ let evs = EventList.cons 10 [] evs in EventList.cons 10 [makeNote Event.NoteOn 60] evs @@ -642,7 +645,7 @@ (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 10 evs in Gen.sequenceCore- Option.defaultChannel Gen.errorNoProgram+ Default.channel Gen.errorNoProgram (Gen.Modulator () return (return . Gen.renderInstrumentIgnoreProgram (sound evs sampleRate)))) $ let evs = EventList.cons 10 [] evs@@ -660,7 +663,7 @@ arrange vectorChunkSize $ evalState (Gen.sequenceCore- Option.defaultChannel Gen.errorNoProgram+ Default.channel Gen.errorNoProgram (Gen.Modulator () return (return . Gen.renderInstrumentIgnoreProgram (sound sampleRate)))) $ let evs = EventList.cons 10 [] evs
alsa/Synthesizer/LLVM/Server/Scalar/Run.hs view
@@ -30,8 +30,9 @@ import Control.Exception (bracket, ) -import NumericPrelude.Numeric (zero, (*>), )-import Prelude hiding (Real, break, )+import NumericPrelude.Numeric (fromIntegral, zero, (*), (*>), (/), )+import NumericPrelude.Base+import Prelude (Double) {-# INLINE withMIDIEvents #-}
alsa/Synthesizer/LLVM/Server/Scalar/Test.hs view
@@ -2,11 +2,14 @@ import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr import qualified Synthesizer.LLVM.Server.Option as Option+import qualified Synthesizer.LLVM.Server.Default as Default import Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents, ) import Synthesizer.LLVM.Server.ALSA (record, put, makeNote, ) import Synthesizer.LLVM.Server.Common +import qualified Synthesizer.ALSA.Storable.Play as Play import qualified Sound.ALSA.Sequencer.Event as Event+ import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.Generic as Gen @@ -28,11 +31,16 @@ import Prelude hiding (Real, ) -sampleRate :: Real-sampleRate =- Option.defaultSampleRate+chunkSize :: SVL.ChunkSize+chunkSize = Play.defaultChunkSize +sampleRatePlain :: Real+sampleRatePlain = case Default.sampleRate of SampleRate r -> r +sampleRate :: SampleRate Real+sampleRate = Default.sampleRate++ pitchBend0 :: IO () pitchBend0 = do osc <-@@ -41,8 +49,8 @@ $* piecewiseConstant (arr id)) SVL.writeFile "test.f32" $ (id :: SigSt.T Real -> SigSt.T Real) .- osc Option.defaultChunkSize .- evalState (PC.pitchBend Option.defaultChannel 2 (880/sampleRate)) $+ osc chunkSize .+ evalState (PC.pitchBend Default.channel 2 (880/sampleRatePlain)) $ let evs = EventList.cons 100 [] evs in EventList.cons 0 ([]::[Event.T]) evs @@ -55,8 +63,8 @@ $* piecewiseConstant (arr id)) withMIDIEvents opt (record "test.f32") $ \ _size _rate -> (id :: SigSt.T Real -> SigSt.T Real) .- osc Option.defaultChunkSize .- evalState (PC.pitchBend Option.defaultChannel 2 (880/sampleRate))+ osc chunkSize .+ evalState (PC.pitchBend Default.channel 2 (880/sampleRatePlain)) pitchBend2 :: IO () pitchBend2 = do@@ -70,14 +78,14 @@ -- arrange <- SigStL.makeArranger -- sound <- Instr.softString -- sound <- Instr.softStringReleaseEnvelope--- sound <- Instr.pingReleaseEnvelope $/ 1 $/ Option.defaultChunkSize+-- sound <- Instr.pingReleaseEnvelope $/ 1 $/ chunkSize -- sound <- Instr.pingDur -- sound <- Instr.pingDurTake- let sound = Instr.dummy Option.defaultChunkSize (SampleRate sampleRate)+ let sound = Instr.dummy chunkSize Default.sampleRate SVL.writeFile "test.f32" $- CutSt.arrange Option.defaultChunkSize $+ CutSt.arrange chunkSize $ evalState- (do Gen.sequence Option.defaultChannel sound) $+ (do Gen.sequence Default.channel sound) $ let evs t = EventList.cons t [makeNote Event.NoteOn 60] $ EventList.cons t [makeNote Event.NoteOff 60] $
example/Synthesizer/LLVM/LAC2011.hs view
@@ -67,8 +67,8 @@ import qualified Sound.Sox.Frame as SoxFrame import qualified Sound.Sox.Play as SoxPlay -import qualified Sound.ALSA.PCM as ALSA-import qualified Synthesizer.ALSA.Storable.Play as Play+-- import qualified Sound.ALSA.PCM as ALSA+-- import qualified Synthesizer.ALSA.Storable.Play as Play import Data.Word (Word32, ) -- import qualified Data.Function.HT as F@@ -147,18 +147,20 @@ Gen.renderChunky (SVL.chunkSize 100000) -} +{- playStreamALSA :: (Additive.C y, ALSA.SampleFmt y) => SVL.Vector y -> IO () playStreamALSA = Play.auto (Play.makeSink Play.defaultDevice (0.05::Double) sampleRate)+-} -- reacts faster to CTRL-C playStreamSox :: (Storable y, SoxFrame.C y) => SVL.Vector y -> IO () playStreamSox =- void . SoxPlay.simple SVL.hPut SoxOption.none 44100+ void . SoxPlay.simple SVL.hPut SoxOption.none sampleRate sampleRate :: Ring.C a => a
example/Synthesizer/LLVM/LNdW2011.hs view
@@ -6,6 +6,7 @@ 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.ALSA.CausalIO.Process as PALSA@@ -16,6 +17,7 @@ import qualified Sound.MIDI.Controller as Ctrl import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Class.Check as MidiCheck import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass import qualified Synthesizer.LLVM.Filter.Allpass as Allpass@@ -174,7 +176,7 @@ (Storable y, SoxFrame.C y) => SVL.Vector y -> IO () playStreamSox =- void . SoxPlay.simple SVL.hPut SoxOption.none 44100+ void . SoxPlay.simple SVL.hPut SoxOption.none sampleRate sampleRate :: Ring.C a => a@@ -310,6 +312,20 @@ Ctrl.soundVariation (hertz 1, hertz 10) (hertz 1))) +bubbleControl ::+ (MidiCheck.C event) =>+ PIO.T (EventListTT.T Ev.StrictTime [event]) (PCS.T Int Float)+bubbleControl =+ MCS.filter [+ MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.5,+ MCS.controllerExponential Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000),+ MCS.controllerLinear Ctrl.soundVariation (-1, 1) 0.7,+ MCS.controllerExponential Ctrl.timbre (hertz 0.2, hertz 5) (hertz 1),+ MCS.controllerLinear Ctrl.soundController5 (-1, 1) 0.5,+ MCS.controllerExponential Ctrl.soundController7 (hertz 2, hertz 20) (hertz 10)]+ .+ MCS.fromChannel (ChannelMsg.toChannel 0)+ bubblesSet :: IO () bubblesSet = do proc <-@@ -331,15 +347,7 @@ playFromEvents 0.01 (0.015::Double) ((proc () :: PIO.T (PCS.T Int Float) (SV.Vector Float)) .- MCS.filter [- MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.5,- MCS.controllerExponential Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000),- MCS.controllerLinear Ctrl.soundVariation (-1, 1) 0.7,- MCS.controllerExponential Ctrl.timbre (hertz 0.2, hertz 5) (hertz 1),- MCS.controllerLinear Ctrl.soundController5 (-1, 1) 0.5,- MCS.controllerExponential Ctrl.soundController7 (hertz 2, hertz 20) (hertz 10)]- .- MCS.fromChannel (ChannelMsg.toChannel 0))+ bubbleControl) subsamplePCS :: PCS.T key a -> PCS.T key a@@ -373,15 +381,7 @@ . arr subsamplePCS .- MCS.filter [- MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.5,- MCS.controllerExponential Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000),- MCS.controllerLinear Ctrl.soundVariation (-1, 1) 0.7,- MCS.controllerExponential Ctrl.timbre (hertz 0.2, hertz 5) (hertz 1),- MCS.controllerLinear Ctrl.soundController5 (-1, 1) 0.5,- MCS.controllerExponential Ctrl.soundController7 (hertz 2, hertz 20) (hertz 10)]- .- MCS.fromChannel (ChannelMsg.toChannel 0))+ bubbleControl) {-@@ -442,10 +442,11 @@ fly :: IO () fly = do- let slow =+ let slow, fast :: CausalP.T p (Value Float) (Value Float)+ slow = Filt1.lowpassCausal $<# Filt1Core.parameter (1/sampleRate::Float)- let fast =+ fast = Filt1.lowpassCausal $<# Filt1Core.parameter (30/sampleRate::Float) proc <-@@ -507,10 +508,11 @@ flyPacked :: IO () flyPacked = do- let slow =+ let slow, fast :: CausalP.T p VectorValue VectorValue+ slow = Filt1.lowpassCausalPacked $<# Filt1Core.parameter (1/sampleRate::Float)- let fast =+ fast = Filt1.lowpassCausalPacked $<# Filt1Core.parameter (30/sampleRate::Float) proc <-
example/Synthesizer/LLVM/Test.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-} module Main where import Synthesizer.LLVM.LAC2011 ()-import Synthesizer.LLVM.LNdW2011 () +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@@ -36,8 +39,6 @@ import Synthesizer.LLVM.Simple.Value ((%>), (%&&), ) import Synthesizer.LLVM.Parameter (($#), ) -import qualified Synthesizer.LLVM.Server.SampledSound as Sample- import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.SerialVector as Serial@@ -93,7 +94,7 @@ import Data.Word (Word32, ) -- import qualified Data.Function.HT as F import Data.List (genericLength, )-import System.FilePath ((</>), )+import System.Path ((</>), ) import System.Random (randomRs, mkStdGen, ) import qualified System.IO as IO@@ -168,25 +169,29 @@ frequency = return +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 $- Sig.render 10000000 $+ flip Sig.render 10000000 $ Sig.osciSaw 0 0.01 exponential :: IO () exponential = SV.writeFile "speedtest.f32" $ asMono $- Sig.render 10000000 $+ flip Sig.render 10000000 $ Sig.exponential2 50000 1 triangle :: IO () triangle = SV.writeFile "speedtest.f32" $ asMono $- Sig.render 10000000 $+ flip Sig.render 10000000 $ Sig.osci Wave.triangle 0.25 0.01 trianglePack :: IO ()@@ -265,7 +270,7 @@ ping = SV.writeFile "speedtest.f32" $ asMono $- Sig.render 10000000 $+ flip Sig.render 10000000 $ pingSig 0.01 pingSigPacked :: SigP.T Float (Serial.Value D4 Float)@@ -297,7 +302,7 @@ (\xs -> SigP.render xs 10000000 ()) $ (Filt1.lowpassCausal $< (fmap Filt1Core.Parameter $- 1 - (SigP.exponential2 50000 $# (1::Float)))+ 1 - (Sig.exponential2 50000 1)) $* SigP.osciSimple Wave.triangle 0 (frequency 0.01)) pingSmoothPacked :: IO ()@@ -307,7 +312,7 @@ (\xs -> SigP.render xs (div 10000000 4) ()) $ (Filt1.lowpassCausalPacked $< (fmap Filt1Core.Parameter $- 1 - (SigP.exponential2 (50000/4) $# (1::Float)))+ 1 - (Sig.exponential2 (50000/4) 1)) $* SigPS.osciSimple Wave.triangle 0 (frequency 0.01)) stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float))@@ -351,7 +356,7 @@ stereo = SV.writeFile "speedtest.f32" $ asStereo $- Sig.render 10000000 $+ flip Sig.render 10000000 $ Sig.amplifyStereo 0.25 $ stereoOsciSawPacked2 0.01 @@ -516,7 +521,7 @@ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ (CausalPS.amplify 0.2 . Filt2.causalPacked $< (Sig.map (const $ Memory.load =<< LLVM.alloca) $- (SigP.constant $# (0::Float)))+ (Sig.constant (0::Float))) $* SigPS.noise 0 0.3) noiseAllocaScalar :: IO ()@@ -529,7 +534,7 @@ $< (Sig.map (const $ (Memory.load =<< LLVM.alloca :: LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $- (SigP.constant $# (0::Float)))+ (Sig.constant (0::Float))) $* SigP.noise 0 0.3) @@ -1103,7 +1108,7 @@ playMonoVector $ CausalP.applyStorableChunky (CausalP.amplify id <<<- CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000))+ CausalP.reverbSimple (mkStdGen 142) 16 (0.9,0.97) (400,1000)) (0.3::Float) sig return () @@ -1113,7 +1118,7 @@ playMonoVector $ CausalP.applyStorableChunky (CausalP.amplify id <<<- (CausalP.reverbEfficient $# mkStdGen 142 $# 16 $# (0.9,0.97) $# (400,1000)))+ (CausalP.reverb $# mkStdGen 142 $# 16 $# (0.9,0.97) $# (400,1000))) (0.3::Float) sig return () @@ -1126,7 +1131,7 @@ (\amp seed -> CausalP.amplify amp <<<- CausalP.reverbEfficient (fmap mkStdGen seed)+ CausalP.reverb (fmap mkStdGen seed) 16 (pure (0.9,0.97)) (pure (400,1000))) (pure $ Stereo.cons 142 857) <<^@@ -1250,7 +1255,7 @@ dur = fmap fromIntegral fst in SigP.parabolaFadeIn dur `SigP.append`- (CausalP.take snd $* (SigP.constant $# (1::Float)))+ (CausalP.take snd $* Sig.constant 1) `SigP.append` SigP.parabolaFadeOut dur @@ -1606,7 +1611,7 @@ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ (CausalP.frequencyModulationLinear (SigP.osciSaw 0 (frequency 0.01))- $* SigP.exponential2 500000 1)+ $* Sig.exponential2 500000 1) frequencyModulationStereo :: IO () frequencyModulationStereo = do@@ -1750,7 +1755,7 @@ (Helix.static Interpolation.cubic Interpolation.cubic 100 (pure $ recip srcFreq) snd $&- (Func.fromSignal $ SigP.amplify (pure srcLength) $ SigP.ramp fst)+ (Func.fromSignal $ Sig.amplify srcLength $ SigP.ramp fst) &|& (CausalP.osciCore $& 0 &|& 0.01)) SVL.writeFile "osci-stretched.f32" $ asMono $@@ -1760,7 +1765,7 @@ loadTomato :: IO (Float, SVL.Vector Float) loadTomato = do let Sample.Info name _sampleRate positions = Sample.tomatensalat- word <- Sample.load ("speech" </> name)+ word <- Sample.load (Default.sampleDirectory </> name) return (Sample.period $ head positions, word) helixOsci :: Param.T p Float -> Func.T p a (Value Float)@@ -1968,7 +1973,7 @@ fmPingSig :: Param.T p Float -> Param.T p Float -> SigP.T p (Value Float) fmPingSig freq depth = SigP.envelope- (SigP.exponential2 5000 1)+ (Sig.exponential2 5000 1) ((CausalP.osciSimple Wave.approxSine2 $> SigP.constant freq) $* (SigP.constant depth * SigP.osciSimple Wave.approxSine2 0 (2*freq)))@@ -1988,4 +1993,4 @@ main :: IO () main = do LLVM.initializeNativeTarget- convolutionPacked+ filterSweepComplex
+ example/Synthesizer/LLVM/TestALSA.hs view
@@ -0,0 +1,7 @@+module Main where++import qualified Synthesizer.LLVM.LNdW2011 as LNdW+++main :: IO ()+main = LNdW.flyPacked
jack/Synthesizer/LLVM/Server/JACK.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} module Main where -- module Synthesizer.LLVM.Server.JACK where @@ -42,6 +44,9 @@ import qualified Control.Monad.Exception.Synchronous as Exc import qualified Control.Monad.Trans.Class as MT +import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path+ import Control.Arrow ((<<<), (^<<), arr, ) import Control.Category (id, ) import Control.Applicative (pure, )@@ -183,7 +188,8 @@ keyboardDetuneFMCore ::- FilePath ->+ (PathClass.AbsRel ar) =>+ Path.Dir ar -> IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real -> PIO.T@@ -234,7 +240,7 @@ if True then let reverb seed =- CausalP.reverbEfficient+ 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))
jack/Synthesizer/LLVM/Server/Option.hs view
@@ -1,110 +1,37 @@--- the options defined here overlap with the ALSA options module Synthesizer.LLVM.Server.Option ( T(..),- ClientName(ClientName),+ Option.ClientName(ClientName), get,- defaultChannel, ) where +import qualified Synthesizer.LLVM.Server.OptionCommon as Option import qualified Sound.MIDI.Message.Channel as ChannelMsg -import System.Console.GetOpt- (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )-import System.Environment (getArgs, getProgName, )-import System.Exit (exitSuccess, exitFailure, )-import qualified System.IO as IO--import Control.Monad (when, )+import qualified System.Path as Path+import qualified Options.Applicative as OP+import Control.Applicative (pure, (<*>), ) import Prelude hiding (Real, ) data T = Cons {- clientName :: ClientName,+ clientName :: Option.ClientName, channel, extraChannel :: ChannelMsg.Channel,- sampleDirectory :: FilePath+ sampleDirectory :: Path.AbsRelDir } deriving (Show) -deflt :: T-deflt =- Cons {- clientName = defaultClientName,- channel = defaultChannel,- extraChannel = ChannelMsg.toChannel 1,- sampleDirectory = "speech"- } --newtype ClientName = ClientName String- deriving (Show)--defaultClientName :: ClientName-defaultClientName =- ClientName "Haskell-LLVM-Synthesizer"--defaultChannel :: ChannelMsg.Channel-defaultChannel = ChannelMsg.toChannel 0----exitFailureMsg :: String -> IO a-exitFailureMsg msg =- IO.hPutStrLn IO.stderr msg >> exitFailure--parseChannel :: String -> IO ChannelMsg.Channel-parseChannel str =- case reads str of- [(chan, "")] ->- if 0<=chan && chan<16- then return $ ChannelMsg.toChannel chan- else exitFailureMsg "MIDI channel must a number from 0..15"- _ ->- exitFailureMsg $ "channel must be a number, but is '" ++ str ++ "'"--{--Guide for common Linux/Unix command-line options:- http://www.faqs.org/docs/artu/ch10s05.html--}-description :: [OptDescr (T -> IO T)]-description =- Option ['h'] ["help"]- (NoArg $ \ _flags -> do- programName <- getProgName- putStrLn- (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description)- exitSuccess)- "show options" :- Option [] ["clientname"]- (flip ReqArg "NAME" $ \str flags ->- return $ flags{clientName = ClientName str})- "name of the JACK client" :- Option ['c'] ["channel"]- (flip ReqArg "CHANNEL" $ \str flags ->- fmap (\chan -> flags{channel = chan}) $- parseChannel str)- "select MIDI input channel (0-based)" :- Option [] ["extra-channel"]- (flip ReqArg "CHANNEL" $ \str flags ->- fmap (\chan -> flags{extraChannel = chan}) $- parseChannel str)- "select MIDI channel with effects" :- Option ['I'] ["sample-directory"]- (flip ReqArg "DIR" $ \str flags ->- return $ flags{sampleDirectory = str})- "directory for sound samples" :- []+options :: OP.Parser T+options =+ pure Cons+ <*> Option.clientName "Name of the JACK client"+ <*> Option.channel+ <*> Option.extraChannel+ <*> Option.sampleDirectory get :: IO T-get = do- argv <- getArgs- let (opts, files, errors) = getOpt RequireOrder description argv- when (not $ null errors) $- exitFailureMsg (init (concat errors))- when (not $ null files) $- exitFailureMsg $- "Do not know what to do with arguments " ++ show files- foldl (>>=) (return deflt) opts+get = Option.get options "Live software synthesizer using LLVM and JACK"
render/Synthesizer/LLVM/Server/Option.hs view
@@ -1,23 +1,21 @@--- the options defined here overlap with the ALSA options module Synthesizer.LLVM.Server.Option ( T(..), get,- defaultChannel,- defaultSampleRate, ) where -import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), )-import qualified Data.StorableVector.Lazy as SVL+import qualified Synthesizer.LLVM.Server.OptionCommon as Option+import qualified Synthesizer.LLVM.Server.Default as Default+import Synthesizer.LLVM.Server.Common (SampleRate, )+import qualified Data.StorableVector.Lazy as SVL import qualified Sound.MIDI.Message.Channel as ChannelMsg -import System.Console.GetOpt- (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )-import System.Environment (getArgs, getProgName, )-import System.Exit (exitSuccess, exitFailure, )-import qualified System.IO as IO+import qualified System.Path as Path -import Control.Monad (when, )+import qualified Options.Applicative as OP+import Control.Applicative (pure, (<$>), (<*>), )+import Data.Maybe (fromMaybe, )+import Data.Monoid ((<>), ) import Prelude hiding (Real, ) @@ -25,120 +23,41 @@ data T = Cons { channel, extraChannel :: ChannelMsg.Channel,- sampleDirectory :: FilePath,+ sampleDirectory :: Path.AbsRelDir, sampleRate :: SampleRate Int,- chunkSize :: SVL.ChunkSize,- volume :: Float+ chunkSize :: SVL.ChunkSize+-- volume :: Float } deriving (Show) -deflt :: T-deflt =- Cons {- channel = defaultChannel,- extraChannel = ChannelMsg.toChannel 1,- sampleDirectory = "speech",- sampleRate = SampleRate defaultSampleRate,- chunkSize = SVL.chunkSize (128*1024),- volume = 0.2- } --defaultChannel :: ChannelMsg.Channel-defaultChannel = ChannelMsg.toChannel 0--defaultSampleRate :: Num a => a-defaultSampleRate = 44100----exitFailureMsg :: String -> IO a-exitFailureMsg msg =- IO.hPutStrLn IO.stderr msg >> exitFailure--parseChannel :: String -> IO ChannelMsg.Channel-parseChannel str =- case reads str of- [(chan, "")] ->- if 0<=chan && chan<16- then return $ ChannelMsg.toChannel chan- else exitFailureMsg "MIDI channel must a number from 0..15"- _ ->- exitFailureMsg $ "channel must be a number, but is '" ++ str ++ "'"--parseNumber ::- (Read a) =>- String -> (a -> Bool) -> String -> String -> IO a-parseNumber name constraint constraintName str =- case reads str of- [(n, "")] ->- if constraint n- then return n- else exitFailureMsg $ name ++ " must be a " ++ constraintName ++ " number"- _ ->- exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"--maxInt :: Integer-maxInt =- fromIntegral (maxBound :: Int)--{--Guide for common Linux/Unix command-line options:- http://www.faqs.org/docs/artu/ch10s05.html--}-description :: [OptDescr (T -> IO T)]-description =- Option ['h'] ["help"]- (NoArg $ \ _flags -> do- programName <- getProgName- putStrLn- (usageInfo ("Usage: " ++ programName ++ " [OPTIONS] infile.mid [outfile.wav]") description)- exitSuccess)- "show options" :- Option ['r'] ["samplerate"]- (flip ReqArg "RATE" $ \str flags ->- fmap (\rate -> flags{sampleRate = SampleRate $ fromInteger rate}) $- parseNumber "sample-rate" (\n -> 0<n && n<=maxInt) "positive" str)- "sample-rate in samples per second" :- Option ['b'] ["blocksize"]- (flip ReqArg "SIZE" $ \str flags ->- fmap (\size -> flags{chunkSize = SVL.ChunkSize $ fromInteger size}) $- parseNumber "blocksize" (\n -> 0<n && n<=maxInt) "positive" str)- "block size as number of sample-frames" :+options :: OP.Parser T+options =+ pure Cons+ <*> Option.channel+ <*> Option.extraChannel+ <*> Option.sampleDirectory+ <*> fmap (fromMaybe Default.sampleRate) Option.sampleRate+ <*> Option.blockSize (SVL.chunkSize (128*1024)) {-- Option ['v'] ["volume"]- (flip ReqArg "FACTOR" $ \str flags ->- fmap (\x -> flags{volume = x}) $- parseNumber "volume" (const True) "any" str)- "block size as number of sample-frames" :+ <*>+ (OP.option (parseNumber "volume" (const True) "any")+ (OP.short 'v' <>+ OP.long "volume" <>+ OP.metavar "FACTOR" <>+ OP.help "global volume") -}- Option ['c'] ["channel"]- (flip ReqArg "CHANNEL" $ \str flags ->- fmap (\chan -> flags{channel = chan}) $- parseChannel str)- "select MIDI input channel (0-based)" :- Option [] ["extra-channel"]- (flip ReqArg "CHANNEL" $ \str flags ->- fmap (\chan -> flags{extraChannel = chan}) $- parseChannel str)- "select MIDI channel with effects" :- Option ['I'] ["sample-directory"]- (flip ReqArg "DIR" $ \str flags ->- return $ flags{sampleDirectory = str})- "directory for sound samples" :- [] +parser :: OP.Parser (T, String, Maybe String)+parser =+ pure (,,)+ <*> options+ <*> OP.strArgument (OP.metavar "infile.mid")+ <*> OP.argument (Just <$> OP.str)+ (OP.metavar "outfile.wav" <> OP.value Nothing)++ get :: IO (T, String, Maybe String)-get = do- argv <- getArgs- let (opts, files, errors) = getOpt RequireOrder description argv- when (not $ null errors) $- exitFailureMsg (init (concat errors))- opt <- foldl (>>=) (return deflt) opts- case files of- [] -> exitFailureMsg "need MIDI input file"- [midiPath] -> return (opt, midiPath, Nothing)- [midiPath, wavePath] -> return (opt, midiPath, Just wavePath)- _ -> exitFailureMsg "too many file names given"+get = Option.get parser "Render MIDI to audio files using LLVM and SoX"
+ server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs view
@@ -0,0 +1,658 @@+module Synthesizer.LLVM.Server.CausalPacked.Arrange where++import Synthesizer.LLVM.Server.CommonPacked (VectorSize, Vector, VectorValue, stair, )++import qualified Sound.MIDI.Controller as Ctrl++import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech+import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr+import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrPlug+import qualified Synthesizer.LLVM.Server.SampledSound as Sample+import Synthesizer.LLVM.Server.Common++import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS+import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS+import qualified Synthesizer.MIDI.CausalIO.Process as MIO+import qualified Synthesizer.MIDI.Value as MV+import qualified Synthesizer.CausalIO.Process as PIO+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.Storable.Process as CausalSt+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 Synthesizer.LLVM.Frame.SerialVector as Serial++import qualified Data.EventList.Relative.TimeTime as EventListTT++import qualified Data.StorableVector as SV++import qualified Synthesizer.Zip as Zip++import qualified Synthesizer.MIDI.Dimensional.ValuePlain as DMV+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Class.Construct as Construct+import qualified Sound.MIDI.Message.Class.Check as Check++import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path++import Control.Arrow (Arrow, arr, first, (<<<), (^<<), )+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 qualified Number.DimensionTerm as DN+import qualified Algebra.DimensionTerm as Dim++import qualified Algebra.Transcendental as Trans++{-+import qualified Numeric.NonNegative.Chunky as NonNegChunky+import qualified Numeric.NonNegative.Class as NonNeg+-}+import qualified Numeric.NonNegative.Wrapper as NonNegW++import Prelude hiding (Real, id, )++++type StereoVector = StereoInt.T VectorSize Real+++keyboard ::+ (Check.C msg) =>+ IO (ChannelMsg.Channel ->+ SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector Vector))+keyboard = do+ arrange <- CausalSt.makeArranger+ amp <- CausalP.processIO (CausalPS.amplify 0.2)++ ping <- Instr.pingRelease++ return $ \ chan sampleRate ->+ amp ()+ <<<+ arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceCore chan+ (\ _pgm -> ping 0.8 0.1 sampleRate)+++infixr 3 &+&++(&+&) ::+ (Arrow arrow) =>+ arrow a b -> arrow a c -> arrow a (Zip.T b c)+(&+&) = Zip.arrowFanout+++controllerExponentialDirect ::+ (Check.C msg, Trans.C y, Dim.C v) =>+ ChannelMsg.Channel ->+ VoiceMsg.Controller ->+ (DN.T v y, DN.T v y) ->+ DN.T v y ->+ PIO.T (MIO.Events msg) (Instr.Control (DN.T v y))+controllerExponentialDirect chan ctrl bnds initial =+ MIO.slice+ (Check.controller chan ctrl)+ (DMV.controllerExponential bnds)+ initial++shortTime ::+ EventListTT.T PC.StrictTime body ->+ EventListTT.T PC.ShortStrictTime body+shortTime =+ EventListTT.mapTime+ (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)++keyboardFM ::+ (Check.C msg, POut.Default b) =>+ CausalP.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)++ ping <- Instr.pingStereoReleaseFM++ return $ \ sampleRate ->+ amp ()+ <<<+ arrange+ <<<+ arr shortTime+ <<<+ -- ToDo: fetch parameters from controllers+ MIO.sequenceModulated chan+ (\ _pgm -> ping sampleRate)+ <<<+ id &+&+ ((controllerExponentialDirect chan+ Ctrl.attackTime (DN.time 0.25, DN.time 2.5) (DN.time 0.8)+ &+&+ controllerExponentialDirect chan+ Ctrl.releaseTime (DN.time 0.03, DN.time 0.3) (DN.time 0.1))+ &+&+ ((MIO.controllerExponential chan controllerTimbre0 (1/pi,0.01) 0.05+ &+&+ controllerExponentialDirect chan controllerTimbre1+ (DN.time 0.01, DN.time 10)+ (DN.time 5))+ &+&+ ((MIO.controllerLinear chan Ctrl.soundController5 (0,2) 1+ &+&+ controllerExponentialDirect chan Ctrl.soundController7+ (DN.time 0.25, DN.time 2.5)+ (DN.time 0.8))+ &+&+ (MIO.controllerLinear chan controllerDetune (0,0.005) 0.001+ &+&+ MIO.bendWheelPressure chan 2 0.04 0.03))))+++controllerExponentialDim ::+ (Arrow arrow,+ Trans.C y, Dim.C v) =>+ VoiceMsg.Controller ->+ (DN.T v y, DN.T v y) ->+ DN.T v y ->+ MCS.T arrow (DN.T v y)+controllerExponentialDim ctrl bnds initial =+ MCS.slice+ (MCS.Controller ctrl)+ (DMV.controllerExponential bnds)+ initial+++timeControlPercussive, timeControlString ::+ PIO.T+ (PCS.T MCS.Controller Int)+ (Zip.T+ (Instr.Control Instr.Time)+ (Instr.Control Instr.Time))++timeControlPercussive =+ controllerExponentialDim Ctrl.attackTime+ (DN.time 0.1, DN.time 2.5) (DN.time 0.8)+ &+&+ controllerExponentialDim Ctrl.releaseTime+ (DN.time 0.03, DN.time 0.3) (DN.time 0.1)++timeControlString =+ controllerExponentialDim Ctrl.attackTime+ (DN.time 0.005, DN.time 0.1) (DN.time 0.1)+ &+&+ controllerExponentialDim Ctrl.releaseTime+ (DN.time 0.03, DN.time 0.3) (DN.time 0.2)+++keyboardDetuneFMCore ::+ (PathClass.AbsRel ar, Check.C msg, POut.Default b) =>+ CausalP.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+ (emitStereo <<<+ CausalP.envelopeStereo <<<+ first (CausalP.mapSimple Serial.upsample))+ return $ \chan initPgm rate ->+ amp ()+ <<<+ MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)+ &+&+ arrange chan initPgm rate++keyboardDetuneFMConstVolume ::+ (PathClass.AbsRel ar, Check.C msg) =>+ Path.Dir ar ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Vector)))+keyboardDetuneFMConstVolume smpDir = do+ arrange <- CausalSt.makeArranger++ tine <- Instr.tineStereoFM+ ping <- Instr.pingStereoReleaseFM+ filterSaw <- Instr.filterSawStereoFM+ bellNoise <- Instr.bellNoiseStereoFM++ wind <- Instr.wind+ windPhaser <- Instr.windPhaser+ string <- Instr.softStringShapeFM+ fmString <- Instr.fmStringStereoFM+ helixNoise <- InstrPlug.helixNoise+ arcs <- sequence $+ Instr.cosineStringStereoFM :+ Instr.arcSawStringStereoFM :+ Instr.arcSineStringStereoFM :+ Instr.arcSquareStringStereoFM :+ Instr.arcTriangleStringStereoFM :+ []++ helixSound <- Instr.helixSound+ sampledSound <- Instr.sampledSound++ syllables <-+ fmap concat $+ mapM (Sample.loadRanges smpDir) $+ Sample.tomatensalat :+ Sample.hal :+ Sample.graphentheorie :+ []++ let frequencyControlPercussive =+ MCS.controllerLinear controllerDetune (0,0.005) 0.001+ &+&+ MCS.bendWheelPressure 2 0.04 0.03++ frequencyControlString =+ MCS.controllerLinear controllerDetune (0,0.01) 0.005+ &+&+ MCS.bendWheelPressure 2 0.04 0.03++ let tineProc rate vel freq =+ tine rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlPercussive+ &+&+ (((fmap stair ^<<+ MCS.controllerLinear controllerTimbre0 (0.5,6.5) 2)+ &+&+ MCS.controllerLinear controllerTimbre1 (0,1.5) 1)+ &+&+ frequencyControlPercussive))++ pingProc rate vel freq =+ ping rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlPercussive+ &+&+ ((MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05+ &+&+ controllerExponentialDim controllerTimbre1+ (DN.time 0.01, DN.time 10) (DN.time 5))+ &+&+ ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2+ &+&+ controllerExponentialDim Ctrl.soundController7+ (DN.time 0.03, DN.time 1) (DN.time 0.5))+ &+&+ frequencyControlPercussive)))++ filterSawProc rate vel freq =+ filterSaw rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlPercussive+ &+&+ ((controllerExponentialDim controllerTimbre0+ (DN.frequency 100, DN.frequency 10000)+ (DN.frequency 1000)+ &+&+ controllerExponentialDim controllerTimbre1+ (DN.time 0.1, DN.time 1)+ (DN.time 0.6))+ &+&+ frequencyControlPercussive))++ bellNoiseProc rate vel freq =+ bellNoise rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlPercussive+ &+&+ ((MCS.controllerLinear controllerTimbre0 (0,1) 0.3+ &+&+ MCS.controllerExponential controllerTimbre1 (1,1000) 100)+ &+&+ frequencyControlPercussive))++ windProc rate vel freq =+ wind rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ (MCS.controllerExponential controllerTimbre1 (1,1000) 100+ &+&+ MCS.bendWheelPressure 12 0.8 0))++ windPhaserProc rate vel freq =+ windPhaser rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ (MCS.controllerLinear controllerTimbre0 (0,1) 0.5+ &+&+ (controllerExponentialDim controllerDetune+ (DN.frequency 50, DN.frequency 5000) (DN.frequency 500)+ &+&+ (MCS.controllerExponential controllerTimbre1 (1,1000) 100+ &+&+ MCS.bendWheelPressure 12 0.8 0))))++ stringProc rate vel freq =+ string rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ (MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05+ &+&+ frequencyControlString))++ fmStringProc rate vel freq =+ fmString rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ ((MCS.controllerLinear controllerTimbre0 (0,0.5) 0.2+ &+&+ MCS.controllerExponential controllerTimbre1 (1/pi,10) 0.05)+ &+&+ frequencyControlString))++ helixNoiseProc rate vel freq =+ helixNoise rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ (MCS.controllerExponential controllerTimbre0 (1,0.01) 0.1+ &+&+ frequencyControlString))++ makeArc proc rate vel freq =+ proc rate vel freq+ <<<+ Zip.arrowSecond+ (timeControlString+ &+&+ (MCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5+ &+&+ frequencyControlString))++ sampled smp rate vel freq =+ smp rate vel freq+ <<<+ Zip.arrowSecond frequencyControlPercussive++ helixed smp rate vel freq =+ smp rate vel freq+ <<<+ Zip.arrowSecond+ (MCS.controllerExponential Ctrl.attackTime (0.25, 4) 1+ &+&+ frequencyControlPercussive)++ bank =+ Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $+ [tineProc, pingProc, filterSawProc, bellNoiseProc,+ stringProc, fmStringProc] +++ map makeArc arcs ++ windProc : windPhaserProc :+ ([helixed . helixSound, sampled . sampledSound] <*> syllables) +++ helixNoiseProc :+ []++ return $ \chan initPgm rate ->+ arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceModulatedMultiProgram chan initPgm+ (\pgm -> Map.findWithDefault pingProc pgm bank rate)+ <<<+ id &+& MCS.fromChannel chan+++keyboardMultiChannel ::+ (PathClass.AbsRel ar, Check.C msg) =>+ Path.Dir ar ->+ IO (SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))+keyboardMultiChannel smpDir = do+ proc <-+ keyboardDetuneFMCore+ (CausalP.mapSimple StereoInt.interleave)+ smpDir+ mix <- CausalP.processIO CausalP.mix++ return $ \ sampleRate ->+ arr SigStL.unpackStereoStrict+ <<<+ foldl1+ (\x y -> mix () <<< Zip.arrowFanout x y)+ (map+ (\chan ->+ proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)+ sampleRate)+ [0 .. 3])++++data Phoneme = Phoneme Bool VoiceMsg.Velocity VoiceMsg.Pitch++instance Check.C Phoneme where+ note _chan (Phoneme on v p) = Just (v, p, on)+++voderSplit ::+ (Check.C msg, Construct.C msg, Arrow arrow) =>+ ChannelMsg.Channel ->+ arrow+ (MIO.Events msg)+ (Zip.T+ (MIO.Events Phoneme)+ (MIO.Events msg))+voderSplit chan =+ arr $+ uncurry Zip.Cons .+ EventListTT.unzip .+ fmap+ (ListHT.unzipEithers .+ fmap (\ev ->+ case Check.note chan ev of+ Nothing -> Right ev+ Just (v,p,b) ->+ if p >= VoiceMsg.toPitch 36+ then+ let p0 = VoiceMsg.increasePitch (-36) p+ in if p0 <= VoiceMsg.toPitch 29+ then Left $ Phoneme b v p0+ else Right $ Construct.note chan+ (v, VoiceMsg.increasePitch (-12) p, b)+ else Right ev))++voder ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.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+ arrange <- CausalSt.makeArranger+ interleave <- CausalP.processIO emitStereo++ return $ \chan initPgm sampleRate ->+ interleave ()+ <<<+ arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceModulatedMultiProgramVelocityPitch+ chan (VoiceMsg.toProgram 0)+ (\ _pgm _vel -> voice sampleRate)+ <<<+ Zip.arrowSecond (carrier chan initPgm sampleRate)+ <<<+ voderSplit chan++voderBand ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ Path.Dir ar ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderBand emitStereo smpDir = do+ voice <- Speech.vowelBand+ voder emitStereo voice smpDir++voderMask ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ Path.Dir ar ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderMask emitStereo smpDir = do+ voice <-+ Speech.vowelMask <*>+ fmap+ (Map.mapMaybe (\(typ,smp) ->+ toMaybe (typ==Speech.Filtered Speech.Continuous Speech.Voiced) smp))+ Speech.loadMasksKeyboard+ voder emitStereo voice smpDir+++voderEnv ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ Speech.VowelSynthEnv ->+ Path.Dir ar ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderEnv emitStereo voice smpDir = do+ carrier <- keyboardDetuneFMConstVolume smpDir+ arrange <- CausalSt.makeArranger+ amp <-+ CausalP.processIO+ (emitStereo <<<+ CausalP.envelopeStereo <<<+ first (CausalP.mapSimple Serial.upsample))++ return $ \chan initPgm sampleRate ->+ amp ()+ <<<+ MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)+ &+&+ (arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceModulatedMultiProgramVelocityPitch+ chan (VoiceMsg.toProgram 0)+ (\ _pgm vel -> voice sampleRate (MV.velocity vel))+ <<<+ Zip.arrowSecond+ (Zip.arrowFanout+ (timeControlString <<< MCS.fromChannel chan)+ (carrier chan initPgm sampleRate))+ <<<+ voderSplit chan)++voderMaskEnv ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->+ Path.Dir ar ->+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderMaskEnv emitStereo smpDir = do+ voice <- Speech.phonemeMask <*> Speech.loadMasksKeyboard+ voderEnv emitStereo voice smpDir+++voderSeparated ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg, POut.Default b) =>+ CausalP.T (SampleRate Real) (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)+voderSeparated emitStereo voice smpDir = do+ carrier <- keyboardDetuneFMCore id smpDir+ arrange <- CausalSt.makeArranger+ amp <-+ CausalP.processIO+ (emitStereo <<<+ CausalP.envelopeStereo <<<+ first (CausalP.mapSimple Serial.upsample))++ return $ \carrierChan phonemeChan initPgm sampleRate ->+ amp sampleRate+ <<<+ MIO.controllerExponential phonemeChan controllerVolume (0.001, 1) (0.2::Float)+ &+&+ (arrange+ <<<+ arr shortTime+ <<<+ MIO.sequenceModulatedMultiProgramVelocityPitch+ phonemeChan (VoiceMsg.toProgram 0)+ (\ _pgm vel -> voice sampleRate (MV.velocity vel))+ <<<+ Zip.arrowFanout id+ (Zip.arrowFanout+ (timeControlString <<< MCS.fromChannel phonemeChan)+ (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) ->+ Path.Dir ar ->+ IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->+ SampleRate Real -> PIO.T (MIO.Events msg) b)+voderMaskSeparated emitStereo smpDir = do+ voice <- Speech.phonemeMask <*> Speech.loadMasksGrouped+ voderSeparated emitStereo voice smpDir++voderMaskMulti ::+ (PathClass.AbsRel ar, Check.C msg, Construct.C msg) =>+ Path.Dir ar ->+ IO (SampleRate Real ->+ PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))+voderMaskMulti smpDir = do+ mix <- CausalP.processIO CausalP.mix+ proc <-+ voderMaskSeparated+ (CausalP.mapSimple StereoInt.interleave)+ smpDir++ return $ \ sampleRate ->+ arr SigStL.unpackStereoStrict+ <<<+ foldl1+ (\x y -> mix () <<< Zip.arrowFanout x y)+ (map+ (\chan ->+ proc+ (ChannelMsg.toChannel chan)+ (ChannelMsg.toChannel $ succ chan)+ (VoiceMsg.toProgram 4)+ sampleRate)+ [0, 2, 4, 6])
+ server/Synthesizer/LLVM/Server/Default.hs view
@@ -0,0 +1,29 @@+module Synthesizer.LLVM.Server.Default where++import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), )++import qualified Sound.MIDI.Message.Channel as ChannelMsg++import qualified System.Path as Path+++sampleRate :: Num a => SampleRate a+sampleRate =+ SampleRate+ 44100+ -- 24000+ -- 48000+++newtype ClientName = ClientName String+ deriving (Show)++clientName :: ClientName+clientName = ClientName "Haskell-LLVM-Synthesizer"+++channel :: ChannelMsg.Channel+channel = ChannelMsg.toChannel 0++sampleDirectory :: Path.AbsRelDir+sampleDirectory = Path.absRel "speech"
+ server/Synthesizer/LLVM/Server/OptionCommon.hs view
@@ -0,0 +1,118 @@+{-+Guide for common Linux/Unix command-line options:+ http://www.faqs.org/docs/artu/ch10s05.html+-}+module Synthesizer.LLVM.Server.OptionCommon (+ module Synthesizer.LLVM.Server.OptionCommon,+ ClientName(ClientName),+ ) where++import qualified Synthesizer.LLVM.Server.Default as Default+import Synthesizer.LLVM.Server.Default (ClientName(ClientName), )+import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), )++import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Data.StorableVector.Lazy as SVL++import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path++import qualified Options.Applicative as OP+import Control.Applicative ((<$>), (<*>), )+import Data.Monoid ((<>), )++import Prelude hiding (Real, )+++clientName :: String -> OP.Parser ClientName+clientName help =+ OP.option (fmap ClientName OP.str)+ (OP.long "clientname" <>+ OP.metavar "NAME" <>+ OP.help help <>+ OP.value Default.clientName)+++parseChannel :: OP.ReadM ChannelMsg.Channel+parseChannel =+ OP.eitherReader $ \str ->+ case reads str of+ [(chan, "")] ->+ if 0<=chan && chan<16+ then return $ ChannelMsg.toChannel chan+ else Left "MIDI channel must a number from 0..15"+ _ -> Left $ "channel must be a number, but is '" ++ str ++ "'"++channel, extraChannel :: OP.Parser ChannelMsg.Channel+channel =+ OP.option parseChannel+ (OP.short 'c' <>+ OP.long "channel" <>+ OP.metavar "CHANNEL" <>+ OP.help "Select MIDI input channel (0-based)" <>+ OP.value Default.channel)++extraChannel =+ OP.option parseChannel+ (OP.long "extra-channel" <>+ OP.metavar "CHANNEL" <>+ OP.help "Select MIDI channel with effects" <>+ OP.value (ChannelMsg.toChannel 1))++path :: (PathClass.FileDir fd) => OP.ReadM (Path.AbsRel fd)+path = OP.eitherReader Path.parse++sampleDirectory :: OP.Parser Path.AbsRelDir+sampleDirectory =+ OP.option path+ (OP.short 'I' <>+ OP.long "sample-directory" <>+ OP.metavar "DIR" <>+ OP.help "Directory for sound samples" <>+ OP.value Default.sampleDirectory)+++maxInt :: Integer+maxInt = fromIntegral (maxBound :: Int)++parseNumber ::+ (Read a) =>+ String -> (a -> Bool) -> String -> OP.ReadM a+parseNumber name constraint constraintName =+ OP.eitherReader $ \str ->+ case reads str of+ [(n, "")] ->+ if constraint n+ then return n+ else Left $ name ++ " must be a " ++ constraintName ++ " number"+ _ -> Left $ name ++ " must be a number, but is '" ++ str ++ "'"++sampleRate :: OP.Parser (Maybe (SampleRate Int))+sampleRate =+ OP.option+ (Just . SampleRate . fromInteger <$>+ parseNumber "sample-rate" (\n -> 0<n && n<=maxInt) "positive")+ (OP.short 'r' <>+ OP.long "samplerate" <>+ OP.metavar "RATE" <>+ OP.value Nothing <>+ OP.help "Sample-rate in samples per second")++blockSize :: SVL.ChunkSize -> OP.Parser SVL.ChunkSize+blockSize deflt =+ OP.option+ (SVL.ChunkSize . fromInteger <$>+ parseNumber "blocksize" (\n -> 0<n && n<=maxInt) "positive")+ (OP.short 'b' <>+ OP.long "blocksize" <>+ OP.metavar "SIZE" <>+ OP.value deflt <>+ OP.help "Block size as number of sample-frames")+++get :: OP.Parser a -> String -> IO a+get parser descr =+ OP.execParser $+ OP.info+ (OP.helper <*> parser)+ (OP.fullDesc <> OP.progDesc descr)
src/Synthesizer/LLVM/Alloc.hs view
@@ -39,16 +39,14 @@ minusPtr ptr nullPtr {- |-> mallocBytes align size+> mallocAligned align size -}-mallocBytes :: Storable a => a -> Int -> IO (Ptr a)-mallocBytes a size =- Debug.traceMalloc a size =<<- if mod defaultMallocAlign (alignment a) == 0+mallocAligned :: Int -> Int -> IO (Ptr a)+mallocAligned align size =+ if mod defaultMallocAlign align == 0 then F.mallocBytes size else do- let align = alignment a- {- pessimistic but safe -}+ let {- pessimistic but safe -} ptrOffset = size + alignment nullPtr {- This should be optimal and I think it is also correct, but better safe than sorry.@@ -61,15 +59,25 @@ F.poke (seekPointer size alignedPtr) allocPtr return alignedPtr +{- |+> mallocBytes align size+-}+mallocBytes :: Storable a => a -> Int -> IO (Ptr a)+mallocBytes a size =+ Debug.traceMalloc a size =<< mallocAligned (alignment a) size+ peekMock :: Ptr a -> a peekMock _ = error "auxiliary object for free functions" -freeBytes :: Storable a => a -> Int -> Ptr a -> IO ()-freeBytes a size ptr =+freeAligned :: Int -> Int -> Ptr a -> IO ()+freeAligned align size ptr = F.free =<<- if mod defaultMallocAlign (alignment a) == 0+ if mod defaultMallocAlign align == 0 then return ptr else F.peek $ seekPointer size ptr++freeBytes :: Storable a => a -> Int -> Ptr a -> IO ()+freeBytes a size ptr = freeAligned (alignment a) size ptr malloc :: (Storable a) => IO (Ptr a) malloc =
+ src/Synthesizer/LLVM/Causal/Controlled.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+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.Causal.Controlled (C(..)) where++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+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade+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.Causal.Process as Causal+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++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, IsSized, )++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), )+++{- |+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+++{-+Instances for the particular filters shall be defined here+in order to avoid orphan instances.+-}++instance+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a,+ Memory.C a, Memory.C v) =>+ 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.causal++instance+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant 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.causal++instance+ (Vector.Arithmetic a, SoV.RationalConstant a,+ Memory.C (Value (Filt2P.State a)) {-,+ Memory.FirstClass a am, IsSized (Vector TypeNum.D4 a) as,+ IsSized am ams, LLVM.IsPrimitive am -}) =>+ 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+ process = Filt2P.causal++instance+ (a ~ SoV.Scalar v, SoV.PseudoModule v, SoV.IntegerConstant a,+ Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),+ Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v),+ 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+ process = Cascade.causal+++instance+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,+ Memory.C a, Memory.C v) =>+ C (Allpass.Parameter a) v v where+ type Input (Allpass.Parameter a) v = v+ type Output (Allpass.Parameter a) v = v+ process = Allpass.causal++instance+ (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,+ 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+ process = Allpass.cascade+++instance+ (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,+ Memory.C v, TypeNum.Natural n) =>+ 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 = Moog.causal+++instance+ (a ~ A.Scalar v, A.PseudoModule v, 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+ type Output (UniFilter.Parameter a) v = UniFilter.Result v+ process = UniFilter.causal++instance+ (A.PseudoRing a, A.RationalConstant a, Memory.C a) =>+ C (ComplexFilt.Parameter a) (Stereo.T a) (Stereo.T a) where+ type Input (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a+ type Output (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a+ process = ComplexFilt.causal++instance+ (Vector.Arithmetic a, IsConst a,+ Memory.C (Value (Filt2P.State a))) =>+{-+ (Memory.FirstClass a am, Vector.Arithmetic a, LLVM.IsPrimitive am,+ IsSized am ams,+ IsSized (Vector TypeNum.D4 a) as) =>+-}+ 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)+ process = ComplexFiltPack.causal
+ src/Synthesizer/LLVM/Causal/ControlledPacked.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+This is like "Synthesizer.LLVM.Causal.Controlled"+but for vectorised signals.+-}+module Synthesizer.LLVM.Causal.ControlledPacked (C(..)) where++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.Process as Causal+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, )+import LLVM.Core (IsSized, )++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), )++import Control.Arrow ((<<<), arr, first, )+++{- |+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+++{-+Instances for the particular filters shall be defined here+in order to avoid orphan instances.+-}++instance+ (Serial.C v, Serial.Element v ~ a,+ A.PseudoRing a, A.IntegerConstant a, Memory.C a,+ A.PseudoRing v) =>+ 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) =>+ 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,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ LLVM.IsPrimitive a,+ LLVM.IsPrimitive am,+ TypeNum.Positive (n :*: LLVM.UnknownSize),+ TypeNum.Natural n) =>+ C (Cascade.ParameterValue n a) v v where+ type Input (Cascade.ParameterValue n a) v = v+ 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) =>+ C (Allpass.Parameter a) v v where+ type Input (Allpass.Parameter a) v = v+ type Output (Allpass.Parameter a) v = v+ process = Allpass.causalPacked++instance+ (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) =>+ C (Allpass.CascadeParameter n a) v v where+ type Input (Allpass.CascadeParameter n a) v = v+ type Output (Allpass.CascadeParameter n a) v = v+ process = Allpass.cascadePacked+++instance+ (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a,+ a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b,+ TypeNum.Natural n) =>+ 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)+++instance+ (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a,+ a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b) =>+ 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)
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -1,14 +1,12 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Causal.Process (- C(simple, alter, replicateControlled),+ C(simple, replicateControlled), T,- Core(Core),- alterSignal, amplify, amplifyStereo, apply,@@ -50,6 +48,8 @@ osci, shapeModOsci, skip,+ foldChunks,+ foldChunksPartial, frequencyModulation, interpolateConstant, quantizeLift,@@ -58,16 +58,18 @@ runStorableChunky, ) where -import qualified Synthesizer.LLVM.Simple.Signal as Sig+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.Causal.ProcessPrivate as Causal+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.Execution as Exec+import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Causal.Class as CausalClass-import qualified Synthesizer.Causal.Utility as ArrowUtil import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV@@ -81,182 +83,40 @@ 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.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM-import LLVM.ExecutionEngine (simpleFunction, ) import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ret, Value, valueOf,- IsConst, IsFirstClass, IsArithmetic, IsPrimitive,- Linkage(ExternalLinkage), createNamedFunction)+ 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 qualified Control.Category as Cat import Control.Monad.Trans.State (runState, ) import Control.Arrow (arr, (<<<), (>>>), (&&&), )-import Control.Monad (liftM2, liftM3, )-import Control.Applicative (Applicative, pure, (<*>), )+import Control.Monad (liftM2, )+import Control.Applicative (liftA3, (<$>), ) import qualified Data.List as List import Data.Tuple.HT (swap, ) import Data.Word (Word32, ) +import qualified Foreign.Marshal.Utils as AllocUtil import Foreign.Storable (Storable, )-import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, )-import Foreign.Ptr (FunPtr, Ptr, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, )+import Foreign.Ptr (Ptr, ) import Control.Exception (bracket, ) 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 Prelude hiding (and, map, zip, zipWith, init, ) -import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, map, zip, zipWith, init, ) -import qualified Prelude as P --data T a b =- forall state ioContext.- (Memory.C state) =>- Cons (forall r c.- (Phi c) =>- ioContext ->- a -> state -> MaybeCont.T r c (b, state))- -- compute next value- (forall r.- ioContext ->- CodeGenFunction r state)- -- initial state- (IO ioContext)- -- initialization from IO monad- (ioContext -> IO ())- -- finalization from IO monad---data Core context initState exitState a b =- forall state.- (Memory.C state) =>- Core (forall r c.- (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 => C process where- simple ::- (Memory.C state) =>- (forall r c.- (Phi c) =>- a -> state -> MaybeCont.T r c (b, state)) ->- (forall r. CodeGenFunction r state) ->- process a b-- alter ::- (forall context initState exitState.- Core context initState exitState a0 b0 ->- Core context initState exitState a1 b1) ->- process a0 b0 -> process a1 b1-- replicateControlled ::- (Undefined x, Phi x) =>- Int -> process (c,x) x -> process (c,x) x---instance CausalClass.C T where- type SignalOf T = Sig.T- type ProcessOf Sig.T = T- toSignal = toSignal- fromSignal = fromSignal--instance C T where- simple next start =- Cons- (const next)- (const start)- (return ())- (const $ return ())-- alter f (Cons next0 start0 create delete) =- case f (Core next0 start0 id) of- Core next1 start1 _ ->- Cons next1 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 start createIOContext deleteIOContext) = Sig.Cons- (\ioContext -> next ioContext ())- start- createIOContext deleteIOContext--fromSignal :: Sig.T b -> T a b-fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons- (\ioContext _ -> next ioContext)- 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-- fromModifier :: (C process) => (Value.Flatten ah, Value.Registers ah ~ al,@@ -346,81 +206,6 @@ -compose :: T a b -> T b c -> T a c-compose- (Cons nextA startA createIOContextA deleteIOContextA)- (Cons nextB startB createIOContextB deleteIOContextB) = Cons- (\(ioContextA, ioContextB) a (sa0,sb0) -> do- (b,sa1) <- nextA ioContextA a sa0- (c,sb1) <- nextB ioContextB b sb0- return (c, (sa1,sb1)))- (\(ioContextA, ioContextB) ->- liftM2 (,)- (startA ioContextA)- (startB ioContextB))- (liftM2 (,)- createIOContextA- createIOContextB)- (\(ca,cb) ->- deleteIOContextA ca >>- deleteIOContextB cb)---first :: (C process) => process b c -> process (b, d) (c, d)-first =- alter- (\(Core next start stop) ->- Core (Causal.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-- {- | You may also use '(+)'. -}@@ -464,7 +249,7 @@ alter (\(Core next start stop) -> Core- (Causal.loopNext next)+ (loopNext next) (fmap ((,) init) . start) (stop . snd)) @@ -528,7 +313,7 @@ (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 (Causal.feedbackControlledAux forth back)+ loopZero (feedbackControlledAux forth back) {-@@ -660,18 +445,6 @@ zipWith wave <<< Arr.second osciCore --alterSignal ::- (C process, CausalClass.SignalOf process ~ signal) =>- (forall context initState exitState.- Sig.Core context initState exitState a0 ->- Core context 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- {- | Feeds a signal into a causal process while holding or skipping signal elements according to the process input.@@ -683,20 +456,71 @@ -} skip :: (C process, CausalClass.SignalOf process ~ signal,- Undefined v, Phi v, Memory.C v) =>- signal v -> process (Value Word32) v+ Undefined a, Phi a, Memory.C a) =>+ signal a -> process (Value Word32) a skip = alterSignal (\(Sig.Core next start stop) -> Core (\context n1 (yState0,n0) -> do- (y,state1) <-+ yState1@(y,_) <- MaybeCont.fromMaybe $ fmap snd $ MaybeCont.fixedLengthLoop n0 yState0 $ next context . snd- return (y, ((y,state1),n1)))+ return (y, (yState1,n1))) (fmap (\s -> ((Class.undefTuple, 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, Undefined b, Phi b) =>+ Fold.T a b -> signal a -> process (Value Word32) 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,+ Undefined a, Phi a, Undefined b, Phi b) =>+ Fold.T a b -> signal a -> process (Value Word32) 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.@@ -779,164 +603,169 @@ -applyStorable ::- (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,- Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>- T valueA valueB -> SV.Vector a -> SV.Vector b-applyStorable (Cons next start createIOContext deleteIOContext) as =- Unsafe.performIO $- bracket createIOContext deleteIOContext $ \ ioContext ->- SVB.withStartPtr as $ \ aPtr len ->- SVB.createAndTrim len $ \ bPtr -> do- fill <-- simpleFunction $- createNamedFunction ExternalLinkage "fillprocessblock" $ \ size alPtr blPtr -> do- s <- start ioContext+foreign import ccall safe "dynamic" derefFillPtr ::+ Exec.Importer+ (Ptr paramStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)+++compile ::+ (Memory.C aValue, Memory.Struct aValue ~ aStruct,+ Memory.C bValue, Memory.Struct bValue ~ bStruct,+ Memory.C param, Memory.Struct param ~ paramStruct,+ Phi state, Undefined state) =>+ (forall r z.+ (Phi z) => param -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->+ (forall r. param -> CodeGenFunction r state) ->+ IO (Ptr paramStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)+compile next start =+ Exec.compileModule $+ Exec.createFunction derefFillPtr "fillprocessblock" $+ \ paramPtr size alPtr blPtr -> do+ param <- Memory.load paramPtr+ s <- start param (pos,_) <- MaybeCont.arrayLoop2 size alPtr blPtr s $ \ aPtri bPtri s0 -> do a <- MaybeCont.lift $ Memory.load aPtri- (b,s1) <- next ioContext a s0+ (b,s1) <- next param a s0 MaybeCont.lift $ Memory.store b bPtri return s1- ret (pos :: Value Word32)- fmap (fromIntegral :: Word32 -> Int) $- fill (fromIntegral len)- (Memory.castStorablePtr aPtr)- (Memory.castStorablePtr bPtr)+ ret pos +applyStorable ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,+ Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>+ T valueA valueB -> SV.Vector a -> SV.Vector b+applyStorable proc = Unsafe.performIO $ runStorable proc++runStorable ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,+ Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>+ T valueA valueB -> IO (SV.Vector a -> SV.Vector b)+runStorable proc = (Unsafe.performIO .) <$> runStorableIO proc++runStorableIO ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,+ Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>+ T valueA valueB -> IO (SV.Vector a -> IO (SV.Vector b))+runStorableIO (Cons next start createIOContext deleteIOContext) = do+ fill <- compile next start+ return $ \as ->+ bracket createIOContext (deleteIOContext . fst) $ \ (_ioContext, params) ->+ SVB.withStartPtr as $ \ aPtr len ->+ SVB.createAndTrim len $ \ bPtr ->+ AllocUtil.with params $ \paramPtr ->+ fmap (fromIntegral :: Word32 -> Int) $+ fill+ (Memory.castStorablePtr paramPtr)+ (fromIntegral len)+ (Memory.castStorablePtr aPtr)+ (Memory.castStorablePtr bPtr)+++foreign import ccall safe "dynamic" derefStartPtr ::+ Exec.Importer (Ptr b -> IO (Ptr a))++foreign import ccall safe "dynamic" derefStopPtr ::+ Exec.Importer (Ptr a -> IO ())+ foreign import ccall safe "dynamic" derefChunkPtr ::- Exec.Importer (Ptr stateStruct -> Word32 ->- Ptr aStruct -> Ptr bStruct -> IO Word32)+ Exec.Importer+ (Ptr paramStruct -> Ptr stateStruct -> Word32 ->+ Ptr aStruct -> Ptr bStruct -> IO Word32) compileChunky :: (Memory.C aValue, Memory.Struct aValue ~ aStruct, Memory.C bValue, Memory.Struct bValue ~ bStruct,+ Memory.C param, Memory.Struct param ~ paramStruct, Memory.C state, Memory.Struct state ~ stateStruct) => (forall r z. (Phi z) =>- aValue -> state ->- MaybeCont.T r z (bValue, state)) ->+ param -> aValue -> state -> MaybeCont.T r z (bValue, state)) -> (forall r.- CodeGenFunction r state) ->- IO (FunPtr (IO (Ptr stateStruct)),- FunPtr (Ptr stateStruct -> IO ()),- FunPtr (Ptr stateStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32))+ param -> CodeGenFunction r state) ->+ IO (Ptr paramStruct -> IO (Ptr stateStruct),+ Exec.Finalizer stateStruct,+ Ptr paramStruct -> Ptr stateStruct ->+ Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32) compileChunky next start = Exec.compileModule $- liftM3 (,,)- (createNamedFunction ExternalLinkage "startprocess" $- do+ liftA3 (,,)+ (Exec.createFunction derefStartPtr "startprocess" $+ \paramPtr -> do pptr <- LLVM.malloc- flip Memory.store pptr =<< start+ param <- Memory.load paramPtr+ flip Memory.store pptr =<< start param ret pptr)- (createNamedFunction ExternalLinkage "stopprocess" $+ (Exec.createFinalizer derefStopPtr "stopprocess" $ \ pptr -> LLVM.free pptr >> ret ())- (createNamedFunction ExternalLinkage "fillprocess" $- \ sptr loopLen aPtr bPtr -> do+ (Exec.createFunction derefChunkPtr "fillprocess" $+ \paramPtr sptr loopLen aPtr bPtr -> do sInit <- Memory.load sptr+ param <- Memory.load paramPtr (pos,sExit) <- MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $ \ aPtri bPtri s0 -> do a <- MaybeCont.lift $ Memory.load aPtri- (b,s1) <- next a s0+ (b,s1) <- next param a s0 MaybeCont.lift $ Memory.store b bPtri return s1 Memory.store (Maybe.fromJust sExit) sptr- ret (pos :: Value Word32))+ ret pos) -{-# DEPRECATED runStorableChunky "this function will not work when the process itself depends on a lazy storable vector" #-}-{- |-This function will not work as expected,-since feeding a lazy storable vector to the causal process-means that createIOContext creates a StablePtr to an IORef refering to a chunk list.-The IORef will be created once for all uses of the generated function-of type @(SVL.Vector a -> SVL.Vector b)@.-This means that the pointer into the chunks list will conflict.-An alternative would be to create the StablePtr in a foreign function-that calls back to Haskell.-But this way is disallowed for foreign finalizers.--}+traverseChunks ::+ (ValueTuple a ~ aValue, Memory.C aValue, Memory.Struct aValue ~ aStruct,+ ValueTuple b ~ bValue, Memory.C bValue, Memory.Struct bValue ~ bStruct,+ ValueTuple parameters ~ paramValue,+ Memory.C paramValue, Memory.Struct paramValue ~ paramStruct,+ Storable a, MakeValueTuple a,+ Storable b, MakeValueTuple b,+ Storable parameters, MakeValueTuple parameters) =>+ (Ptr paramStruct -> Ptr stateStruct ->+ Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32) ->+ ForeignPtr parameters ->+ ForeignPtr 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 ->+ withForeignPtr statePtr $ \sptr ->+ SVB.createAndTrim size $+ fmap (fromIntegral :: Word32 -> Int) .+ fill paramPtr sptr (fromIntegral size)+ (Memory.castStorablePtr aPtr) .+ Memory.castStorablePtr+ (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 a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b)-runStorableChunky- (Cons next start createIOContext deleteIOContext) = do- ioContext <- createIOContext- (startFunc, stopFunc, fill) <-- compileChunky (next ioContext) (start ioContext)-- {-- This is a dummy pointer, that we need for correct finalization.- Concerning the live time the FunPtr 'fill' also has the live time- that we are after,- but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr.- -}- ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False-+runStorableChunky (Cons next start createIOContext deleteIOContext) = do+ (startFunc, stopFunc, fill) <- compileChunky next start return $ \sig -> SVL.fromChunks $ Unsafe.performIO $ do- statePtr <- ForeignPtr.newInit stopFunc startFunc- let go xt =- Unsafe.interleaveIO $- case xt of- [] -> return []- x:xs -> SVB.withStartPtr x $ \aPtr size -> do- v <-- withForeignPtr statePtr $ \sptr ->- SVB.createAndTrim size $- fmap (fromIntegral :: Word32 -> Int) .- derefChunkPtr fill sptr (fromIntegral size)- (Memory.castStorablePtr aPtr) .- Memory.castStorablePtr- touchForeignPtr ioContextPtr- (if SV.length v > 0- then fmap (v:)- else id) $- (if SV.length v < size- then return []- else go xs)- go (SVL.chunks sig)+ (ioContext, params) <- createIOContext+ paramPtr <- ForeignPtr.new (deleteIOContext ioContext) params+ statePtr <-+ ForeignPtr.newInit stopFunc (ForeignPtr.with paramPtr startFunc)+ traverseChunks fill paramPtr statePtr sig applyStorableChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T valueA valueB -> SVL.Vector a -> SVL.Vector b-applyStorableChunky- (Cons next start createIOContext deleteIOContext) sig =- SVL.fromChunks $ Unsafe.performIO $ do- ioContext <- createIOContext- (startFunc, stopFunc, fill) <-- compileChunky (next ioContext) (start ioContext)-- statePtr <- ForeignPtr.newInit stopFunc startFunc- {-- This is a dummy pointer, that we need for correct finalization.- Concerning the live time the FunPtr 'fill' also has the live time- that we are after,- but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr.- -}- ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False-- let go xt =- Unsafe.interleaveIO $- case xt of- [] -> return []- x:xs -> SVB.withStartPtr x $ \aPtr size -> do- v <-- withForeignPtr statePtr $ \sptr ->- SVB.createAndTrim size $- fmap (fromIntegral :: Word32 -> Int) .- derefChunkPtr fill sptr (fromIntegral size)- (Memory.castStorablePtr aPtr) .- Memory.castStorablePtr- touchForeignPtr ioContextPtr- (if SV.length v > 0- then fmap (v:)- else id) $- (if SV.length v < size- then return []- else go xs)- go (SVL.chunks sig)+applyStorableChunky = Unsafe.performIO . runStorableChunky
src/Synthesizer/LLVM/Causal/ProcessPacked.hs view
@@ -5,6 +5,8 @@ module Synthesizer.LLVM.Causal.ProcessPacked where 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 LLVM.Extra.ScalarOrVector as SoV@@ -45,7 +47,7 @@ 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 = Causal.alter (\(Causal.Core next start stop) -> Causal.Core+pack = alter (\(Core next start stop) -> Core (\param a s -> do r <- Maybe.lift $ Serial.readStart a ((_,w2),(_,s2)) <-@@ -81,7 +83,7 @@ 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 = Causal.alter (\(Causal.Core next start stop) -> Causal.Core+packSmall = alter (\(Core next start stop) -> Core (\param a -> MS.runStateT $ (MT.lift . Maybe.lift . Serial.assemble)@@ -106,7 +108,7 @@ 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 = Causal.alter (\(Causal.Core next start stop) -> Causal.Core+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)) <-
src/Synthesizer/LLVM/Causal/ProcessPrivate.hs view
@@ -1,8 +1,258 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Causal.ProcessPrivate where -import Control.Arrow (Arrow, arr, (>>>), (&&&), )+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.Arithmetic as A+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, ) +import LLVM.Util.Loop (Phi, )+import LLVM.Core (CodeGenFunction, )++import Foreign.Storable (Storable, )++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.+ (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 => C process where+ simple ::+ (Memory.C state) =>+ (forall r c.+ (Phi c) =>+ a -> state -> MaybeCont.T r c (b, state)) ->+ (forall r. CodeGenFunction r state) ->+ process a b++ alter ::+ (forall context initState exitState.+ Core context initState exitState a0 b0 ->+ Core context initState exitState a1 b1) ->+ process a0 b0 -> process a1 b1++ replicateControlled ::+ (Undefined x, Phi x) =>+ Int -> process (c,x) x -> process (c,x) x+++alterSignal ::+ (C process, CausalClass.SignalOf process ~ signal) =>+ (forall context initState exitState.+ Sig.Core context initState exitState a0 ->+ Core context 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 ioContext parameters.+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters),+ Memory.C state) =>+ Cons (forall r c.+ (Phi c) =>+ ValueTuple parameters ->+ a -> state -> MaybeCont.T r c (b, state))+ -- compute next value+ (forall r.+ ValueTuple 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)+ (const start)+ (return ((),()))+ (const $ return ())++ alter f (Cons next0 start0 create delete) =+ case f (Core next0 start0 id) of+ Core next1 start1 _ ->+ Cons next1 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 start createIOContext deleteIOContext) = Sig.Cons+ (\ioContext -> next ioContext ())+ start+ createIOContext deleteIOContext++fromSignal :: Sig.T b -> T a b+fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons+ (\ioContext _ -> next ioContext)+ 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+++compose :: T a b -> T b c -> T a c+compose+ (Cons nextA startA createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) = Cons+ (\(paramA, paramB) a (sa0,sb0) -> do+ (b,sa1) <- nextA paramA a sa0+ (c,sb1) <- nextB paramB b sb0+ return (c, (sa1,sb1)))+ (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)) ->@@ -27,3 +277,14 @@ 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/CausalParameterized/Controlled.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} {- | This module provides a type class that automatically selects a filter for a given parameter type.@@ -11,52 +7,28 @@ 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 where--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-import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2-import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade-import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P-import qualified Synthesizer.LLVM.Filter.Moog as Moog-import qualified Synthesizer.LLVM.Filter.Universal as UniFilter+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 Synthesizer.LLVM.Parameter as Param 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 LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM-import LLVM.Core (Value, IsFloating, IsConst, IsSized, )--import qualified Synthesizer.LLVM.Frame.Stereo as Stereo--import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal.Number ((:*:), )+import LLVM.Core (Value, IsFloating, IsSized, ) import Foreign.Storable (Storable, ) -{- |-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 :: CausalP.T p (parameter, a) b-- processCtrlRate ::- (C parameter a b,+ (Ctrl.C parameter a b, Memory.C parameter, Memory.FirstClass r, IsSized (Memory.Stored r), IsFloating r, Storable r, SoV.IntegerConstant r,@@ -66,107 +38,5 @@ (Param.T p r -> SigP.T p parameter) -> CausalP.T p a b processCtrlRate reduct ctrlGen =- CausalP.applyFst process+ CausalP.applyFst Ctrl.process (SigP.interpolateConstant reduct (ctrlGen reduct))---{--Instances for the particular filters shall are defined here-in order to avoid orphan instances.--}--instance- (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a,- Memory.C a, Memory.C v) =>- 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.causal--instance- (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant 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.causal--instance- (Vector.Arithmetic a, SoV.RationalConstant a,- Memory.C (Value (Filt2P.State a)) {-,- Memory.FirstClass a am, IsSized (Vector TypeNum.D4 a) as,- IsSized am ams, LLVM.IsPrimitive am -}) =>- 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- process = Filt2P.causal--instance- (a ~ SoV.Scalar v, SoV.PseudoModule v, SoV.IntegerConstant a,- Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),- Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v),- 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- process = Cascade.causal---instance- (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,- Memory.C a, Memory.C v) =>- C (Allpass.Parameter a) v v where- type Input (Allpass.Parameter a) v = v- type Output (Allpass.Parameter a) v = v- process = Allpass.causal--instance- (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a,- 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- process = Allpass.cascade---instance- (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,- Memory.C v, TypeNum.Natural n) =>- 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 = Moog.causal---instance- (a ~ A.Scalar v, A.PseudoModule v, 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- type Output (UniFilter.Parameter a) v = UniFilter.Result v- process = UniFilter.causal--instance- (A.PseudoRing a, A.RationalConstant a, Memory.C a) =>- C (ComplexFilt.Parameter a) (Stereo.T a) (Stereo.T a) where- type Input (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a- type Output (ComplexFilt.Parameter a) (Stereo.T a) = Stereo.T a- process = ComplexFilt.causal--instance- (Vector.Arithmetic a, IsConst a,- Memory.C (Value (Filt2P.State a))) =>-{-- (Memory.FirstClass a am, Vector.Arithmetic a, LLVM.IsPrimitive am,- IsSized am ams,- IsSized (Vector TypeNum.D4 a) as) =>--}- 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)- process = ComplexFiltPack.causal
src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs view
@@ -1,65 +1,38 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} {- | This is like "Synthesizer.LLVM.CausalParameterized.Controlled" but for vectorised signals. -} module Synthesizer.LLVM.CausalParameterized.ControlledPacked (- C(process), processCtrlRate,+ CtrlS.process,+ processCtrlRate, ) where -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.Frame.SerialVector as Serial-import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS 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.Parameter as Param+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Class as Class-import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, ) import LLVM.Core (Value, IsFloating, IsSized, ) -import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal.Number ((:*:), )- import Foreign.Storable (Storable, ) -import Control.Arrow ((<<<), arr, first, )- import qualified Algebra.Field as Field import NumericPrelude.Numeric import NumericPrelude.Base+import Prelude () -{- |-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 :: CausalP.T p (parameter, a) b- processCtrlRate ::- (C parameter av bv,+ (CtrlS.C parameter av bv, Serial.Read av, n ~ Serial.Size av, Serial.C bv, n ~ Serial.Size bv, Memory.C parameter,@@ -71,89 +44,7 @@ (Param.T p r -> SigP.T p parameter) -> CausalP.T p av bv processCtrlRate reduct ctrlGen = Serial.withSize $ \n ->- CausalP.applyFst process+ CausalP.applyFst CtrlS.process (SigP.interpolateConstant (fmap (/ fromIntegral n) reduct) (ctrlGen reduct))---{--Instances for the particular filters shall be defined here-in order to avoid orphan instances.--}--instance- (Serial.C v, Serial.Element v ~ a,- A.PseudoRing a, A.IntegerConstant a, Memory.C a,- A.PseudoRing v) =>- 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) =>- 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,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,- LLVM.IsPrimitive a,- LLVM.IsPrimitive am,- TypeNum.Positive (n :*: LLVM.UnknownSize),- TypeNum.Natural n) =>- C (Cascade.ParameterValue n a) v v where- type Input (Cascade.ParameterValue n a) v = v- 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) =>- C (Allpass.Parameter a) v v where- type Input (Allpass.Parameter a) v = v- type Output (Allpass.Parameter a) v = v- process = Allpass.causalPacked--instance- (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) =>- C (Allpass.CascadeParameter n a) v v where- type Input (Allpass.CascadeParameter n a) v = v- type Output (Allpass.CascadeParameter n a) v = v- process = Allpass.cascadePacked---instance- (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a,- a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b,- TypeNum.Natural n) =>- 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 =- CausalPS.pack Moog.causal <<<- first (arr Serial.constant)---instance- (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a,- a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b) =>- 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 =- CausalPS.pack UniFilter.causal <<<- first (arr Serial.constant)
src/Synthesizer/LLVM/CausalParameterized/Functional.hs view
@@ -14,6 +14,9 @@ Atom(..), atom, withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments, makeGuidedArgs,++ PrepareArguments, withPreparedArgs, withPreparedArgs2,+ atomArg, stereoArgs, pairArgs, tripleArgs, ) where import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP@@ -42,8 +45,8 @@ import qualified Control.Monad.Trans.Class as Trans import Control.Monad.Trans.State (StateT, ) -import qualified Data.Vault as Vault-import Data.Vault (Vault, )+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, (.), )@@ -274,13 +277,10 @@ withArgs :: (MakeArguments inp) => (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out-withArgs = withArgsStart (lift Cat.id)+withArgs f = withId $ f . makeArgs -withArgsStart ::- (MakeArguments inp) =>- T p inp inp ->- (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out-withArgsStart fid f = compile (f (makeArgs fid))+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 :: *)@@ -352,14 +352,7 @@ (MakeGuidedArguments pat, PatternArguments pat ~ inp) => pat -> (GuidedArguments (T p inp) pat -> T p inp out) -> CausalP.T p inp out-withGuidedArgs p = withGuidedArgsStart p (lift Cat.id)--withGuidedArgsStart ::- (MakeGuidedArguments pat, PatternArguments pat ~ inp) =>- pat ->- T p inp inp ->- (GuidedArguments (T p inp) pat -> T p inp out) -> CausalP.T p inp out-withGuidedArgsStart p fid f = compile (f (makeGuidedArgs p fid))+withGuidedArgs p f = withId $ f . makeGuidedArgs p data Atom a = Atom@@ -382,12 +375,8 @@ 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)+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@@ -417,9 +406,60 @@ type instance PatternArguments (a,b,c) = (PatternArguments a, PatternArguments b, PatternArguments c)-instance (MakeGuidedArguments a, MakeGuidedArguments b, MakeGuidedArguments 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 view
@@ -38,8 +38,8 @@ import qualified Control.Monad.Trans.State as MS import qualified Data.Set as Set-import qualified Data.Vault as Vault-import Data.Vault (Vault, )+import qualified Data.Vault.Lazy as Vault+import Data.Vault.Lazy (Vault, ) import Data.Unique (Unique, newUnique, ) import Data.Maybe (fromMaybe, )
src/Synthesizer/LLVM/CausalParameterized/Helix.hs view
@@ -20,11 +20,13 @@ 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.Signal as SigP-import qualified Synthesizer.LLVM.RingBufferForward as RingBuffer+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@@ -322,7 +324,7 @@ CausalP.T p (Value Word32) (nodesLeap (nodesStep value)) peekCell margin period32 vec = Param.with (Param.word32 $ fmap Ip.marginOffset margin) $ \getOffset valueOffset ->- Param.with period32 $ \getPeriod valuePeriod -> CausalP.Cons+ Param.with period32 $ \getPeriod valuePeriod -> CausalPrivP.Cons (\(p,off,per) n () -> MaybeCont.lift $ do offset <- A.sub n (valueOffset off) nodes <-@@ -484,7 +486,7 @@ Param.T p th -> CausalP.T p t t _limitShape margin periodInt len =- CausalP.Cons+ CausalPrivP.Cons (\(minShape,maxShape) shape () -> MaybeCont.lift $ do limited <- A.min maxShape =<< A.max minShape shape return (limited, ()))
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.CausalParameterized.Process (- T(Cons), simple,+ T, simple, fromSignal, toSignal, mapAccum, map, mapSimple, zipWith, zipWithSimple, apply, compose, first,@@ -54,8 +54,8 @@ differentiate, comb, combStereo,+ reverbSimple, reverb,- reverbEfficient, Causal.pipeline, Causal.skip, Causal.frequencyModulation,@@ -73,34 +73,37 @@ ) where import Synthesizer.LLVM.CausalParameterized.ProcessPrivate-import Synthesizer.LLVM.Causal.ProcessPrivate (feedbackControlledAux, )+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.LLVM.Parameter as Param import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.Parameter (($#), )-import qualified Synthesizer.LLVM.RingBuffer as RingBuffer+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.Signal as Sig+import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv 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.Execution as Exec+import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr+import Synthesizer.LLVM.Parameter (($#), ) +import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.Generic.Cut as Cut+ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB -import qualified Synthesizer.Generic.Cut as Cut-import qualified Synthesizer.Causal.Class as CausalClass- 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.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A@@ -110,20 +113,17 @@ import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ret, Value, valueOf,- IsSized, IsConst, IsArithmetic, IsFloating,- Linkage(ExternalLinkage), createNamedFunction, )+ IsSized, IsConst, IsArithmetic, IsFloating, ) import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal (D1, ) -import qualified Control.Monad.HT as M import qualified Control.Category as Cat-import qualified Control.Monad.Trans.State as MS-import Control.Monad.Trans.State (evalState, ) import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&), )-import Control.Monad (liftM, liftM2, liftM3, when, )+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, )@@ -132,25 +132,24 @@ import Data.Word (Word32, ) import Data.Int (Int8, ) -import System.Random (Random, RandomGen, randomR, )--import qualified Algebra.Transcendental as Trans+import System.Random (Random, RandomGen, ) import qualified Synthesizer.LLVM.Alloc as Alloc-import qualified System.Unsafe as Unsafe import qualified Foreign.Marshal.Utils as AllocUtil-import qualified Foreign.Concurrent as FC import Foreign.Storable.Tuple () import Foreign.Storable (Storable, poke, peek, ) import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, ) import Foreign.Ptr (FunPtr, Ptr, castPtr, freeHaskellFunPtr, )-import Control.Exception (bracket, ) +import qualified System.Unsafe as Unsafe+ import qualified Synthesizer.LLVM.Debug.Storable as DebugSt import qualified Synthesizer.LLVM.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_, )@@ -535,10 +534,14 @@ Example: apply a stereo reverb to a mono sound. > traverse-> (\seed -> reverb (Random.mkStdGen seed) 16 (0.92,0.98) (200,1000))+> (\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. -}-reverb ::+reverbSimple :: (Random a, IsArithmetic a, SoV.RationalConstant a, MakeValueTuple a, ValueTuple a ~ (Value a),@@ -546,13 +549,13 @@ RandomGen g) => g -> Int -> (a,a) -> (Int,Int) -> T p (Value a) (Value a)-reverb rnd num gainRange timeRange =+reverbSimple rnd num gainRange timeRange = mapSimple (A.mul (A.fromRational' $ recip $ fromIntegral num)) <<<- (foldl (+) Cat.id $+ (foldl (+) zero $ List.map (\(g,t) -> comb $# g $# t) $ reverbParams rnd num gainRange timeRange) -reverbEfficient ::+reverb :: (Random a, SoV.PseudoModule a, SoV.Scalar a ~ s, IsFloating s, SoV.IntegerConstant s, LLVM.NumberOfElements s ~ D1,@@ -561,7 +564,7 @@ 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)-reverbEfficient rnd num gainRange timeRange =+reverb rnd num gainRange timeRange = map (\n x -> flip A.scale x =<< A.fdiv A.one =<< LLVM.inttofp n) (Param.word32 num)@@ -572,18 +575,7 @@ <<^ (\a -> (a,a)) -reverbParams ::- (RandomGen g, Random a) =>- g -> Int -> (a, a) -> (Int, Int) -> [(a, Int)]-reverbParams rnd num gainRange timeRange =- List.take num $- flip evalState rnd $- M.repeat $- liftM2 (,)- (MS.state (randomR gainRange))- (MS.state (randomR timeRange)) - {- | 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.@@ -599,8 +591,8 @@ (Causal.C process, CausalClass.SignalOf process ~ signal) => signal v -> process (Value Word32) v _skipVolatile =- Causal.alterSignal- (\(Sig.Core next start stop) -> Causal.Core+ CausalPriv.alterSignal+ (\(SigPriv.Core next start stop) -> CausalPriv.Core (\context n state0 -> do y <- fmap fst $ next context state0 state1 <-@@ -680,7 +672,8 @@ Undefined b, Phi b) => SigP.T (p,a) b -> T p (Maybe.T al) (Maybe.T b)-triggerAux (SigP.Cons next start stop createIOContext deleteIOContext) = Cons+triggerAux+ (SigPPriv.Cons next start stop createIOContext deleteIOContext) = Cons (\(creator, eraser) mx mcsio0 -> MaybeCont.lift $ do mcsio1 <- Maybe.run mx@@ -742,9 +735,8 @@ IO (p -> SV.Vector a -> SV.Vector b) runStorable (Cons next start stop createIOContext deleteIOContext) = do fill <-- fmap derefFillPtr $ Exec.compileModule $- createNamedFunction ExternalLinkage "fillprocessblock" $+ Exec.createFunction derefFillPtr "fillprocessblock" $ \paramPtr size alPtr blPtr -> do param <- Memory.load paramPtr (c,s) <- start param@@ -755,7 +747,7 @@ MaybeCont.lift $ Memory.store b bPtri return s1 Maybe.for msExit $ stop c- ret (pos :: Value Word32)+ ret pos return $ \p as -> Unsafe.performIO $@@ -780,8 +772,9 @@ foreign import ccall safe "dynamic" derefChunkPtr ::- Exec.Importer (Ptr contextStateStruct -> Word32 ->- Ptr structA -> Ptr structB -> IO Word32)+ Exec.Importer+ (Ptr contextStateStruct -> Word32 ->+ Ptr structA -> Ptr structB -> IO Word32) compileChunky ::@@ -801,25 +794,25 @@ (forall r. context -> state -> CodeGenFunction r ()) ->- IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)),- FunPtr (Ptr contextStateStruct -> IO ()),- FunPtr (Ptr contextStateStruct -> Word32 ->- Ptr structA -> Ptr structB -> IO Word32))+ IO (Ptr paramStruct -> IO (Ptr contextStateStruct),+ Exec.Finalizer contextStateStruct,+ Ptr contextStateStruct -> Word32 ->+ Ptr structA -> Ptr structB -> IO Word32) compileChunky next start stop = Exec.compileModule $- liftM3 (,,)- (createNamedFunction ExternalLinkage "startprocess" $+ liftA3 (,,)+ (Exec.createFunction derefStartPtr "startprocess" $ \paramPtr -> do pptr <- LLVM.malloc flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr)- (createNamedFunction ExternalLinkage "stopprocess" $+ (Exec.createFinalizer derefStopPtr "stopprocess" $ \ contextStatePtr -> do (c,ms) <- Memory.load contextStatePtr Maybe.for ms $ stop c LLVM.free contextStatePtr ret ())- (createNamedFunction ExternalLinkage "fillprocess" $+ (Exec.createFunction derefChunkPtr "fillprocess" $ \ contextStatePtr loopLen aPtr bPtr -> do (param, msInit) <- Memory.load contextStatePtr (pos,msExit) <-@@ -832,10 +825,10 @@ return s1 sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ()) Memory.store msExit sptr- ret (pos :: Value Word32))+ ret pos) -foreign import ccall safe "dynamic" derefStartParamPtr ::+foreign import ccall safe "dynamic" derefStartPtr :: Exec.Importer (Ptr paramStruct -> IO (Ptr contextStateStruct)) foreign import ccall safe "dynamic" derefStopPtr ::@@ -872,25 +865,25 @@ (forall r. paramValueOut -> LLVM.CodeGenFunction r stateOut) ->- IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)),- FunPtr (Ptr contextStateStruct -> IO ()),- FunPtr (Ptr contextStateStruct -> Word32 ->- Ptr paramStructIn -> Ptr paramStructOut -> IO Word32))+ IO (Ptr paramStruct -> IO (Ptr contextStateStruct),+ Ptr contextStateStruct -> IO (),+ Ptr contextStateStruct -> Word32 ->+ Ptr paramStructIn -> Ptr paramStructOut -> IO Word32) compilePlugged nextIn startIn next start stop nextOut startOut = Exec.compileModule $- liftM3 (,,)- (createNamedFunction ExternalLinkage "startprocess" $+ liftA3 (,,)+ (Exec.createFunction derefStartPtr "startprocess" $ \paramPtr -> do pptr <- LLVM.malloc flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr)- (createNamedFunction ExternalLinkage "stopprocess" $+ (Exec.createFunction derefStopPtr "stopprocess" $ \ contextStatePtr -> do (c,ms) <- Memory.load contextStatePtr Maybe.for ms $ stop c LLVM.free contextStatePtr ret ())- (createNamedFunction ExternalLinkage "fillprocess" $+ (Exec.createFunction derefChunkPtr "fillprocess" $ \ contextStatePtr loopLen inPtr outPtr -> do (param, msInit) <- Memory.load contextStatePtr inParam <- Memory.load inPtr@@ -907,7 +900,7 @@ return (in1, s1, out1) sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ()) Memory.store (fmap snd3 msExit) sptr- ret (pos :: Value Word32))+ ret pos) runStorableChunky ::@@ -942,9 +935,7 @@ DebugSt.dump "param" param statePtr <- ForeignPtr.newParam stopFunc startFunc param- concStatePtr <-- withForeignPtr statePtr $- flip FC.newForeignPtr (deleteIOContext ioContext)+ ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext) let go xt = Unsafe.interleaveIO $@@ -955,11 +946,11 @@ withForeignPtr statePtr $ \sptr -> SVB.createAndTrim size $ fmap fromIntegral .- derefChunkPtr fill sptr+ fill sptr (fromIntegral size) (Memory.castStorablePtr aPtr) . Memory.castStorablePtr- touchForeignPtr concStatePtr+ touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:) else id) $@@ -1024,7 +1015,7 @@ actualSize <- AllocUtil.with paramIn $ \inptr -> AllocUtil.with paramOut $ \outptr ->- derefChunkPtr fill paramPtr+ fill paramPtr (fromIntegral maximumSize) (Memory.castStorablePtr inptr) (Memory.castStorablePtr outptr)@@ -1039,11 +1030,11 @@ contextStatePtr <- AllocUtil.with param- (derefStartParamPtr startFunc . Memory.castStorablePtr)+ (startFunc . Memory.castStorablePtr) return (ioContext, contextStatePtr)) (\(ioContext, contextStatePtr) -> do- derefStopPtr stopFunc contextStatePtr+ stopFunc contextStatePtr deleteIOContext ioContext) processIO ::
src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -7,6 +7,7 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as Sig import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Causal.ProcessPrivate as CausalPriv import qualified Synthesizer.LLVM.Causal.Process as Causal import Synthesizer.LLVM.Causal.ProcessPrivate (loopNext, ) import Synthesizer.LLVM.Causal.Process (mapProc, zipProcWith, )@@ -30,7 +31,7 @@ import qualified Control.Arrow as Arr import qualified Control.Category as Cat import Control.Arrow (arr, (^<<), (<<<), (&&&), )-import Control.Applicative (Applicative, pure, (<*>), )+import Control.Applicative (Applicative, pure, (<*>), (<$>), ) import Data.Tuple.HT (mapSnd, ) import qualified Synthesizer.LLVM.Storable.Vector as SVU@@ -82,9 +83,11 @@ (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- type ProcessOf (Sig.T p) = T p toSignal = toSignal fromSignal = fromSignal @@ -93,8 +96,8 @@ simple (\() -> next) (\() -> fmap ((,) ()) start) (pure ()) alter f (Cons next0 start0 stop0 create delete) =- case f (Causal.Core next0 return id) of- Causal.Core next1 start1 stop1 ->+ case f (CausalPriv.Core next0 return id) of+ CausalPriv.Core next1 start1 stop1 -> Cons next1 (Sig.withStart start0 start1)@@ -296,7 +299,7 @@ () -> MaybeCont.T r z (a, ()) replicateControlledNext next stop (len, contextStates) (c,a) () =- MaybeCont.fromMaybe $ fmap (\(_,ms) -> fmap (flip (,) ()) ms) $+ MaybeCont.fromMaybe $ fmap (\(_,ms) -> flip (,) () <$> ms) $ MaybeCont.arrayLoop len contextStates a $ \contextStatePtr a0 -> do (context, s0) <- MaybeCont.lift $ Memory.load contextStatePtr
+ src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs view
@@ -0,0 +1,60 @@+{-# 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 Synthesizer.LLVM.Parameter as Param++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class++import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )+++{- |+@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 ::+ (Storable a, Class.MakeValueTuple a,+ Class.ValueTuple a ~ al, Memory.C al) =>+ Param.T p a -> Param.T p Int -> CausalP.T p al (T al)+track initial time =+ Param.with initial $ \getInitial valueInitial ->+ Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalP.Cons+ (trackNext valueTime)+ (\(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.with (Param.word32 time) $ \getTime valueTime ->+ CausalP.Cons+ (trackNext valueTime)+ (\size -> trackStart valueTime (initial, size))+ trackStop+ (trackConstCreate getTime)+ trackDelete
+ src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs view
@@ -0,0 +1,295 @@+{-# 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 qualified Synthesizer.LLVM.Parameter as Param+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )++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.Class as Class++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, )+import LLVM.Core (CodeGenFunction, Value, )++import Control.Arrow ((<<<), )+import Control.Applicative (pure, )+import Data.Tuple.HT (mapSnd, )++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Ptr (Ptr, )++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 (Ptr (Memory.Struct a)),+ length :: Value Word32,+ current :: Value Word32+ }++{- |+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 Word32 -> 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 Word32) (T a)+trackSkip time (SigP.Cons next start stop create delete) =+ Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalPrivP.Cons+ (trackNext next valueTime)+ (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 'Word32' 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 Word32) ((Value Bool, Value Word32), 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 start stop create delete) =+ (Param.with (Param.word32 time) $ \getTime valueTime ->+ CausalPrivP.Cons+ (trackNextHold next valueTime)+ (trackStartHold start valueTime)+ (trackStopHold stop)+ (trackCreate create getTime)+ (trackDelete delete))+++trackNext ::+ (Memory.C al, Memory.Struct al ~ am, Phi z,+ Phi state, Class.Undefined state) =>+ (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->+ (tl -> Value Word32) ->+ (context, (tl, Value (Ptr am))) ->+ Value Word32 ->+ (Value Word32, (state, Value Word32)) ->+ MaybeCont.T r z (T al, (Value Word32, (state, Value Word32)))+trackNext next valueTime (context, (size,ptr)) 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 state0+ MaybeCont.lift $+ fmap ((,) state1) $ storeNext (size0,ptr) a pos0+ return (Cons ptr size0 pos3, (n1, (state3, pos3)))++trackStart ::+ (LLVM.IsSized am,+ Phi state, Class.Undefined state) =>+ (param -> CodeGenFunction r (context, state)) ->+ (tl -> Value Word32) ->+ (param, tl) ->+ CodeGenFunction r+ ((context, (tl, Value (Ptr am))),+ (Value Word32, (state, Value Word32)))+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 (Ptr am))) ->+ (Value Word32, (state, Value Word32)) ->+ CodeGenFunction r ()+trackStop stop (context, (_size,ptr)) (_n, (state, _remain)) = do+ LLVM.free ptr+ stop context state+++trackNextHold ::+ (Memory.C al, Memory.Struct al ~ am, Phi z,+ Phi state, Class.Undefined state) =>+ (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->+ (tl -> Value Word32) ->+ (context, (tl, Value (Ptr am))) ->+ Value Word32 ->+ (Value Word32, (Maybe.T state, Value Word32)) ->+ MaybeCont.T r z+ (((Value Bool, Value Word32), T al),+ (Value Word32, (Maybe.T state, Value Word32)))+trackNextHold next valueTime (context, (size,ptr)) 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 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, Memory.Struct al ~ am) =>+ (Value Word32, Value (Ptr am)) ->+ al -> Value Word32 -> CodeGenFunction r (Value Word32)+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,+ Phi state, Class.Undefined state) =>+ (param -> CodeGenFunction r (context, state)) ->+ (tl -> Value Word32) ->+ (param, tl) ->+ CodeGenFunction r+ ((context, (tl, Value (Ptr am))),+ (Value Word32, (Maybe.T state, Value Word32)))+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 (Ptr am))) ->+ (Value Word32, (Maybe.T state, Value Word32)) ->+ 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/ConstantPiece.hs view
@@ -8,7 +8,7 @@ module Synthesizer.LLVM.ConstantPiece where import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP-import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt@@ -105,7 +105,10 @@ (\stable () -> do yPtr <- Maybe.lift $ LLVM.alloca len <- Maybe.lift $ do- nextFn <- LLVM.staticFunction EventIt.nextCallBack+ nextFn <-+ LLVM.staticNamedFunction+ "ConstantPiece.piecewiseConstant.nextChunk"+ EventIt.nextCallBack LLVM.call nextFn stable yPtr Maybe.guard =<< Maybe.lift (A.cmp LLVM.CmpNE len A.zero)@@ -125,7 +128,10 @@ lazySize size = SigP.Cons (\stable () -> do len <- Maybe.lift $ do- nextFn <- LLVM.staticFunction SizeIt.nextCallBack+ nextFn <-+ LLVM.staticNamedFunction+ "ConstantPiece.lazySize.nextChunk"+ SizeIt.nextCallBack LLVM.call nextFn stable Maybe.guard =<< Maybe.lift (A.cmp LLVM.CmpNE len A.zero)
src/Synthesizer/LLVM/Execution.hs view
@@ -1,17 +1,19 @@ {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Execution where -import qualified LLVM.Extra.Execution as Exec import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Optimize as Opt import qualified LLVM.Core as LLVM -import Foreign.Ptr (FunPtr, )+import Foreign.Ptr (Ptr, FunPtr, ) import qualified Control.Monad.Trans.Reader as R-import Control.Monad (liftM2, )+import Control.Monad (liftM2, when, void, )+import Control.Applicative (liftA2, pure, (<$>), ) import qualified Data.IORef as IORef+import Data.Functor.Compose (Compose(Compose))+ import qualified System.Unsafe as Unsafe import qualified Synthesizer.LLVM.Debug.Counter as Counter@@ -30,42 +32,58 @@ Unsafe.performIO $ Counter.new +writeBitcodeToFile :: String -> Counter.T ident -> LLVM.Module -> IO ()+writeBitcodeToFile ext cnt =+ when False .+ LLVM.writeBitcodeToFile+ ("generator" ++ Counter.format 3 cnt ++ ext ++ ".bc")+++type Exec = Compose LLVM.CodeGenModule EE.EngineAccess+type Engine = EE.ExecutionEngine+ {- | This function also initializes LLVM. This simplifies usage from GHCi. The @llvm@ packages prevents multiple initialization. -}-assembleModule ::- (llvmFunction -> EE.EngineAccess externFunction) ->- LLVM.CodeGenModule llvmFunction ->- IO externFunction-assembleModule comp bld = do+compileModule :: Exec externFunction -> IO externFunction+compileModule (Compose bld) = do LLVM.initializeNativeTarget m <- LLVM.newModule (funcs, mappings) <-- LLVM.defineModule m (liftM2 (,) bld LLVM.getGlobalMappings)+ LLVM.defineModule m $ do+ LLVM.setTarget LLVM.hostTriple+ liftM2 (,) bld LLVM.getGlobalMappings Counter.with counter $ R.ReaderT $ \cnt -> do- LLVM.writeBitcodeToFile ("generator" ++ Counter.format 3 cnt ++ ".bc") m- _ <- Opt.optimizeModule 3 m- LLVM.writeBitcodeToFile ("generator" ++ Counter.format 3 cnt ++ "-opt.bc") m+ writeBitcodeToFile "" cnt m+ when False $ do+ void $ Opt.optimizeModule 3 m+ writeBitcodeToFile "-opt" cnt m - EE.runEngineAccess $- EE.addModule m >>- EE.addGlobalMappings mappings >>- comp funcs+ EE.runEngineAccessWithModule m $+ EE.addGlobalMappings mappings >> funcs --- this compiles once and is much faster than runFunction-compileModule ::- (Exec.Compile externFunction) =>- LLVM.CodeGenModule (Exec.LLVMFunction externFunction) ->- IO externFunction-compileModule =- assembleModule Exec.compile+createLLVMFunction ::+ (LLVM.FunctionArgs f) =>+ String -> LLVM.FunctionCodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+createLLVMFunction = LLVM.createNamedFunction LLVM.ExternalLinkage -runFunction ::- (EE.Translatable f) =>- LLVM.CodeGenModule (LLVM.Function f) -> IO f-runFunction =- assembleModule EE.generateFunction+createFunction ::+ (EE.ExecutionFunction f, LLVM.FunctionArgs f) =>+ Importer f -> String -> LLVM.FunctionCodeGen f -> Exec f+createFunction importer name f =+ Compose $ EE.getExecutionFunction importer <$> createLLVMFunction name f+++type Finalizer a = (Engine, Ptr a -> IO ())++createFinalizer ::+ (EE.ExecutionFunction f, LLVM.FunctionArgs f) =>+ Importer f -> String -> LLVM.FunctionCodeGen f -> Exec (Engine, f)+createFinalizer importer name f =+ liftA2 (,)+ (Compose $ pure EE.getEngine)+ (createFunction importer name f)
src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -82,7 +82,7 @@ Proxy n -> Passband -> Value a -> Value a -> CodeGenFunction r (Value (Cascade.ParameterStruct n a)) parameter partialParameter n kind ratio freq = do- let order = 2 * TypeNum.integralFromProxy n+ let order = TypeNum.integralFromProxy n let sines = Cascade.constArray n $ map ComplexL.constOf $
src/Synthesizer/LLVM/Filter/NonRecursive.hs view
@@ -10,7 +10,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP import qualified Synthesizer.LLVM.Parameter as Param -import qualified Synthesizer.LLVM.RingBuffer as RingBuffer+import qualified Synthesizer.LLVM.CausalParameterized.RingBuffer as RingBuffer import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Storable.Vector as SVU
src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -38,7 +38,7 @@ import Control.Arrow (arr, (<<<), (&&&), ) import Control.Monad (liftM2, foldM, ) import Control.Applicative (pure, (<*>), )-import Synthesizer.ApplicativeUtility (liftA4, liftA5, )+import Control.Applicative.HT (liftA4, liftA5, ) import NumericPrelude.Numeric import NumericPrelude.Base
src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -188,7 +188,7 @@ in (Causal.map A.inc <<< i) &&& (stage <<<- (Causal.zipWith getStageParameterAlloca <<< p &&& i)+ (Causal.zipWith getStageParameterMalloc <<< p &&& i) &&& v) @@ -201,7 +201,7 @@ Func.withGuidedArgs (Func.atom, (Func.atom, Func.atom)) $ \(p,(i,v)) -> liftA2 (,) (i+1) (stage $&- (Causal.zipWith getStageParameterAlloca $& p &|& i)+ (Causal.zipWith getStageParameterMalloc $& p &|& i) &|& v) @@ -234,7 +234,7 @@ Memory.compose ps -} -_getStageParameterMalloc, getStageParameterAlloca ::+getStageParameterMalloc, _getStageParameterAlloca :: (IsSized a, TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => ParameterValue n a ->@@ -244,7 +244,7 @@ Expensive because we need a heap allocation for every sample. However, we could allocate the memory once in the Causal initialization routine. -}-_getStageParameterMalloc ps k = do+getStageParameterMalloc ps k = do ptr <- LLVM.malloc LLVM.store (parameterValue ps) ptr p <-@@ -258,8 +258,10 @@ With this implementation, LLVM-2.6 generates a stack variable layout that requires non-aligned access to vector values. The result is a crash at runtime.+Even if the layout is right,+alloca will run in a loop and will finally run out of stack space. -}-getStageParameterAlloca ps k = do+_getStageParameterAlloca ps k = do ptr <- LLVM.alloca LLVM.store (parameterValue ps) ptr Filt2.decomposeParameter
src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -29,7 +29,7 @@ import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, d5, ) -import Synthesizer.ApplicativeUtility (liftA6, )+import Control.Applicative.HT (liftA6, ) instance (Phi a) => Phi (Parameter a) where
+ src/Synthesizer/LLVM/Fold.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Fold where++import qualified LLVM.Extra.Arithmetic as A+import LLVM.Core (CodeGenFunction)++import Control.Applicative (liftA2, liftA3)++import Prelude hiding (sum)+++data T a b = Cons (forall r. b -> a -> CodeGenFunction r b) b++premap :: (forall r. a -> CodeGenFunction r b) -> T b c -> T a c+premap f (Cons acc b0) = Cons (\b a -> acc b =<< f a) b0+++maxZero :: (A.Real a) => T a a+maxZero = Cons A.max A.zero++maxAbs :: (A.Real a) => T a a+maxAbs = premap A.abs maxZero++sum :: (A.Additive a) => T a a+sum = Cons A.add A.zero++sumSquare :: (A.PseudoRing a) => T a a+sumSquare = premap A.square sum+++pair :: T a0 b0 -> T a1 b1 -> T (a0,a1) (b0,b1)+pair (Cons acc0 b00) (Cons acc1 b10) =+ Cons (\(a0,a1) (b0,b1) -> liftA2 (,) (acc0 a0 b0) (acc1 a1 b1)) (b00,b10)++triple :: T a0 b0 -> T a1 b1 -> T a2 b2 -> T (a0,a1,a2) (b0,b1,b2)+triple (Cons acc0 b00) (Cons acc1 b10) (Cons acc2 b20) =+ Cons+ (\(a0,a1,a2) (b0,b1,b2) ->+ liftA3 (,,) (acc0 a0 b0) (acc1 a1 b1) (acc2 a2 b2))+ (b00,b10,b20)
+ src/Synthesizer/LLVM/ForeignPtr.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+Adding the finalizer to a ForeignPtr seems to be the only way+that warrants execution of the finalizer (not too early and not never).+However, the normal ForeignPtr finalizers must be independent from Haskell runtime.+In contrast to ForeignPtr finalizers,+addFinalizer adds finalizers to boxes, that are optimized away.+Thus finalizers are run too early or not at all.+Concurrent.ForeignPtr and using threaded execution+is the only way to get finalizers in Haskell IO.+-}+module Synthesizer.LLVM.ForeignPtr where++import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )++import qualified LLVM.ExecutionEngine as EE++import qualified Foreign.Marshal.Utils as Marshal+import qualified Foreign.ForeignPtr as FPtr+import qualified Foreign.Concurrent as FC+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, )+import Foreign.StablePtr (newStablePtr, freeStablePtr)+import Foreign.Storable (Storable, poke, )+import Foreign.Ptr (Ptr, nullPtr, )+++newAux :: IO () -> IO (ForeignPtr ())+newAux = FC.newForeignPtr nullPtr+++makeFinalizer :: (EE.ExecutionEngine, IO ()) -> IO (IO ())+makeFinalizer (ee, finalizer) = do+ stable <- newStablePtr ee+ return $ finalizer >> freeStablePtr stable++newInit ::+ (EE.ExecutionEngine, Ptr a -> IO ()) -> IO (Ptr a) -> IO (ForeignPtr a)+newInit (ee, stop) start = do+ state <- start+ FC.newForeignPtr state =<< makeFinalizer (ee, stop state)++newParam ::+ (Storable b, MakeValueTuple b, Memory.C (ValueTuple b)) =>+ (EE.ExecutionEngine, Ptr a -> IO ()) ->+ (Ptr (Memory.Struct (ValueTuple b)) -> IO (Ptr a)) ->+ b -> IO (ForeignPtr a)+newParam stop start b =+ newInit stop (Marshal.with b (start . Memory.castStorablePtr))++new :: Storable a => IO () -> a -> IO (ForeignPtr a)+new finalizer a = do+ ptr <- FPtr.mallocForeignPtr+ FC.addForeignPtrFinalizer ptr finalizer+ withForeignPtr ptr (flip poke a)+ return ptr++with ::+ (Storable a, MakeValueTuple a, Memory.C (ValueTuple a)) =>+ ForeignPtr a -> (Ptr (Memory.Struct (ValueTuple a)) -> IO b) -> IO b+with fp func =+ withForeignPtr fp (func . Memory.castStorablePtr)
+ src/Synthesizer/LLVM/Frame/Binary.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.LLVM.Frame.Binary (+ toCanonical,+ ) where++import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Core as LLVM++import qualified Algebra.ToInteger as ToInteger+import NumericPrelude.Numeric+import NumericPrelude.Base++import Prelude ()++++toCanonical ::+ (LLVM.NumberOfElements real ~ LLVM.NumberOfElements int,+ LLVM.IsFloating real, SoV.IntegerConstant real,+ LLVM.IsInteger int, Bounded int, ToInteger.C int) =>+ LLVM.Value int -> LLVM.CodeGenFunction r (LLVM.Value real)+toCanonical i = do+ numer <- LLVM.inttofp i+ A.fdiv numer (A.fromInteger' (toInteger (maxBoundOf i)))++maxBoundOf :: (Bounded i) => LLVM.Value i -> i+maxBoundOf _ = maxBound
src/Synthesizer/LLVM/Parameter.hs view
@@ -2,7 +2,16 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-}-module Synthesizer.LLVM.Parameter where+module Synthesizer.LLVM.Parameter (+ T,+ ($#),+ get,+ value,+ with,++ -- * for implementation of new processes+ word32,+ ) where import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Memory as Memory
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -5,10 +5,64 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Parameterized.Signal (- T(Cons), simple, constant, iterate,- map, mapSimple, zip, zipWith, zipWithSimple,- Sig.mix, Sig.envelope, Sig.envelopeStereo,- module Synthesizer.LLVM.Parameterized.Signal+ T,+ adjacentNodes02,+ adjacentNodes13,+ amplify,+ amplifyStereo,+ append,+ cycle,+ drop,+ exponential2,+ exponentialCore,+ exponentialBounded2,+ exponentialBoundedCore,+ interpolateConstant,+ iterate,+ lazySize,+ map,+ mapSimple,+ mapAccum,+ Sig.mix,+ 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,++ -- for testing+ noiseCoreAlt, ) where import Synthesizer.LLVM.Parameterized.SignalPrivate@@ -25,6 +79,7 @@ import qualified Synthesizer.LLVM.Random as Rnd import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.Execution as Exec+import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr import qualified Synthesizer.LLVM.Alloc as Alloc import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt@@ -43,26 +98,25 @@ 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.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (whileLoop, ifThen, ) +import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM import LLVM.Core (CodeGenFunction, ret, Value, value, valueOf, IsSized, IsConst, IsArithmetic, IsFloating,- CodeGenModule, Linkage(ExternalLinkage),- Function, createNamedFunction, )+ CodeGenModule, Function, ) import qualified Type.Data.Num.Decimal as TypeNum import Control.Monad.HT ((<=<), )-import Control.Monad (liftM2, liftM3, when, )+import Control.Monad (liftM2, when, ) import Control.Arrow ((^<<), )-import Control.Applicative (liftA2, pure, )+import Control.Applicative (liftA2, liftA3, pure, (<$>), ) import Control.Functor.HT (void, ) import qualified Algebra.Transcendental as Trans@@ -71,24 +125,24 @@ 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, ) import Data.Int (Int32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )-import Foreign.Ptr (FunPtr, Ptr, nullPtr, )+import Foreign.Ptr (Ptr, nullPtr, ) import Control.Exception (bracket, ) import qualified System.Unsafe as Unsafe-import qualified Foreign.Concurrent as FC import qualified Synthesizer.LLVM.Debug.Storable as DebugSt import qualified Synthesizer.LLVM.Debug.Counter as Counter import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, tail, iterate, map, zip, zipWith, cycle, )+import NumericPrelude.Base hiding (and, tail, iterate, map, zip, zipWith, cycle, drop, ) --- for debugMain+-- for debugChunkyMain import qualified Control.Monad.Trans.Reader as R @@ -538,7 +592,10 @@ Cons (\stable (buffer0,length0) -> do (buffer1,length1) <- MaybeCont.lift $ do- nextChunkFn <- LLVM.staticFunction ChunkIt.nextCallBack+ nextChunkFn <-+ LLVM.staticNamedFunction+ "Parameterized.Signal.fromStorableVectorLazy.nextChunk"+ ChunkIt.nextCallBack needNext <- A.cmp LLVM.CmpEQ length0 A.zero ifThen needNext (buffer0,length0) (do lenPtr <- LLVM.alloca@@ -584,6 +641,74 @@ foreign import ccall safe "dynamic" derefFillPtr :: Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32) ++moduleFill ::+ (Memory.C value, Memory.Struct value ~ struct,+ Memory.C parameters, Memory.Struct parameters ~ paramStruct,+ Loop.Phi state, Undefined state) =>+ (forall r z.+ (Loop.Phi z) =>+ context -> state -> MaybeCont.T r z (value, state)) ->+ (forall r.+ parameters -> CodeGenFunction r (context, state)) ->+ (forall r.+ context -> state -> CodeGenFunction r ()) ->+ CodeGenModule+ (Function (Ptr paramStruct -> Word32 -> Ptr struct -> IO Word32))+moduleFill next start stop =+ Exec.createLLVMFunction "fillsignalblock" $+ \paramPtr size bPtr -> do+ param <- Memory.load paramPtr+ (c,s) <- start param+ (pos,se) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do+ (y,s1) <- next c s0+ MaybeCont.lift $ Memory.store y ptri+ return s1+ Maybe.for se $ stop c+ ret pos++debugMain ::+ forall parameters struct paramStruct.+ (Storable parameters,+ LLVM.IsType struct,+ LLVM.IsType paramStruct,+ IsSized paramStruct) =>+ CodeGenModule+ (Function (Ptr paramStruct -> Word32 -> Ptr struct -> IO Word32)) ->+ parameters ->+ IO (Function (Word32 -> Ptr (Ptr Word8) -> IO Word32))+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 <- LLVM.newNamedFunction LLVM.ExternalLinkage "malloc" ::+ LLVM.TFunction (Ptr Word8 -> IO (Ptr struct))+ fill <- sigModule+ Exec.createLLVMFunction "main" $ \ _argc _argv -> do+ paramPtr <- paramArray+ let chunkSize = LLVM.valueOf 100000+ basePtr = LLVM.valueOf nullPtr+ buffer <-+ LLVM.call mallocBytes =<<+ LLVM.bitcast =<<+ LLVM.getElementPtr basePtr (chunkSize, ())+ _done <-+ LLVM.call fill paramPtr chunkSize (asTypeOf buffer basePtr)+ ret (A.zero :: LLVM.Value Word32))++ Counter.with Exec.counter $ R.ReaderT $ \cnt -> do+ LLVM.writeBitcodeToFile ("main" ++ Counter.format 3 cnt ++ ".bc") m++ return mainFunc++ run :: (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value ->@@ -591,25 +716,20 @@ run (Cons next start stop createIOContext deleteIOContext) = do -- this compiles once and is much faster than simpleFunction fill <-- fmap derefFillPtr .- Exec.compileModule .- createNamedFunction ExternalLinkage "fillsignalblock" $- \paramPtr size bPtr -> do- param <- Memory.load paramPtr- (c,s) <- start param- (pos,se) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do- (y,s1) <- next c s0- MaybeCont.lift $ Memory.store y ptri- return s1- Maybe.for se $ stop c- ret (pos :: Value Word32)+ Exec.compileModule $+ Compose $+ (EE.getExecutionFunction derefFillPtr+ <$> moduleFill next start stop) return $ \len p -> Unsafe.performIO $ bracket (createIOContext p) (deleteIOContext . fst) $- \ (_,params) ->+ \ (_,params) -> do+ when False $ void $+ debugMain (moduleFill next start stop) params+ SVB.createAndTrim len $ \ ptr ->- Alloc.with params $ \paramPtr ->+ Alloc.with params $ \paramPtr -> fmap fromIntegral $ fill (Memory.castStorablePtr paramPtr) (fromIntegral len) (Memory.castStorablePtr ptr)@@ -623,6 +743,12 @@ render gen = Unsafe.performIO $ run gen +foreign import ccall safe "dynamic" derefStartPtr ::+ Exec.Importer (Ptr b -> IO (Ptr a))++foreign import ccall safe "dynamic" derefStopPtr ::+ Exec.Importer (Ptr a -> IO ())+ foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32) @@ -644,19 +770,19 @@ Function (Ptr contextStateStruct -> IO ()), Function (Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32))-moduleChunky next start stop = liftM3 (,,)- (createNamedFunction ExternalLinkage "startsignal" $+moduleChunky next start stop = liftA3 (,,)+ (Exec.createLLVMFunction "startsignal" $ \paramPtr -> do pptr <- LLVM.malloc flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr)- (createNamedFunction ExternalLinkage "stopsignal" $+ (Exec.createLLVMFunction "stopsignal" $ \ contextStatePtr -> do (c,ms) <- Memory.load contextStatePtr Maybe.for ms $ stop c LLVM.free contextStatePtr ret ())- (createNamedFunction ExternalLinkage "fillsignal" $+ (Exec.createLLVMFunction "fillsignal" $ \ contextStatePtr loopLen ptr -> do (context, msInit) <- Memory.load contextStatePtr (pos,msExit) <-@@ -667,7 +793,7 @@ return s1 sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ()) Memory.store msExit sptr- ret (pos :: Value Word32))+ ret pos) compileChunky :: (Memory.C value, Memory.Struct value ~ struct,@@ -681,14 +807,21 @@ parameters -> CodeGenFunction r (context, state)) -> (forall r. context -> state -> CodeGenFunction r ()) ->- IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)),- FunPtr (Ptr contextStateStruct -> IO ()),- FunPtr (Ptr contextStateStruct ->- Word32 -> Ptr struct -> IO Word32))+ IO (Ptr paramStruct -> IO (Ptr contextStateStruct),+ Exec.Finalizer contextStateStruct,+ Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32) compileChunky next start stop =- Exec.compileModule $ moduleChunky next start stop+ Exec.compileModule $+ Compose+ ((\(startF, stopF, nextF) ->+ liftA3 (,,)+ (EE.getExecutionFunction derefStartPtr startF)+ (liftA2 (,) EE.getEngine $+ EE.getExecutionFunction derefStopPtr stopF)+ (EE.getExecutionFunction derefChunkPtr nextF))+ <$> moduleChunky next start stop) -debugMain ::+debugChunkyMain :: forall parameters struct paramStruct contextStateStruct. (Storable parameters, LLVM.IsType struct,@@ -702,7 +835,7 @@ Word32 -> Ptr struct -> IO Word32)) -> parameters -> IO (Function (Word32 -> Ptr (Ptr Word8) -> IO Word32))-debugMain sigModule params = do+debugChunkyMain sigModule params = do {- This does not work, since we cannot add (Mul n D32 s) constraint to the function argument in reifyIntegral.@@ -721,10 +854,11 @@ m <- LLVM.newModule mainFunc <- LLVM.defineModule m (do- mallocBytes <- LLVM.newNamedFunction ExternalLinkage "malloc" ::+ LLVM.setTarget LLVM.hostTriple+ mallocBytes <- LLVM.newNamedFunction LLVM.ExternalLinkage "malloc" :: LLVM.TFunction (Ptr Word8 -> IO (Ptr struct)) (start, stop, fill) <- sigModule- createNamedFunction ExternalLinkage "main" $ \ _argc _argv -> do+ Exec.createLLVMFunction "main" $ \ _argc _argv -> do contextState <- LLVM.call start =<< paramArray let chunkSize = LLVM.valueOf 100000 basePtr = LLVM.valueOf nullPtr@@ -767,12 +901,10 @@ DebugSt.dump "param" param when False $ void $- debugMain (moduleChunky next start stop) param+ debugChunkyMain (moduleChunky next start stop) param statePtr <- ForeignPtr.newParam stopFunc startFunc param- concStatePtr <-- withForeignPtr statePtr $- flip FC.newForeignPtr (deleteIOContext ioContext)+ ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext) let go cs = Unsafe.interleaveIO $@@ -783,9 +915,9 @@ withForeignPtr statePtr $ \sptr -> SVB.createAndTrim size $ fmap fromIntegral .- derefChunkPtr fill sptr (fromIntegral size) .+ fill sptr (fromIntegral size) . Memory.castStorablePtr- touchForeignPtr concStatePtr+ touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:) else id) $
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -5,12 +5,13 @@ {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Parameterized.SignalPrivate where -import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Core as LLVM import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, )@@ -21,6 +22,7 @@ import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )+import Foreign.Ptr (Ptr, ) import qualified Number.Ratio as Ratio import qualified Algebra.Field as Field@@ -299,3 +301,12 @@ Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0)) return (param &&& initial)++malloc :: (LLVM.IsSized a) => T p (LLVM.Value (Ptr a))+malloc =+ Cons+ (\ptr () -> return (ptr, ()))+ (const $ fmap (flip (,) ()) $ LLVM.malloc)+ (\ptr () -> LLVM.free ptr)+ (const $ return ((), ()))+ (const $ return ())
src/Synthesizer/LLVM/RingBuffer.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-module Synthesizer.LLVM.RingBuffer (- T, track, trackConst,- index, oldest,- ) where--import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.Parameter as Param+module Synthesizer.LLVM.RingBuffer where import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Memory as Memory@@ -19,7 +12,6 @@ import Data.Word (Word32, ) import Foreign.Storable.Tuple ()-import Foreign.Storable (Storable, ) import Foreign.Ptr (Ptr, ) import Prelude hiding (length, )@@ -67,54 +59,9 @@ Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ()) -{- |-@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 ::- (Storable a, Class.MakeValueTuple a,- Class.ValueTuple a ~ al, Memory.C al) =>- Param.T p a -> Param.T p Int -> CausalP.T p al (T al)-track initial time =- Param.with initial $ \getInitial valueInitial ->- Param.with (Param.word32 time) $ \getTime valueTime ->- CausalP.Cons- (trackNext valueTime)- (\(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.with (Param.word32 time) $ \getTime valueTime ->- CausalP.Cons- (trackNext valueTime)- (\size -> trackStart valueTime (initial, size))- trackStop- (trackConstCreate getTime)- trackDelete- trackConstCreate :: (p -> t) ->- p ->- IO ((), t)+ p -> IO ((), t) trackConstCreate getTime p = return ((), getTime p)
− src/Synthesizer/LLVM/RingBufferForward.hs
@@ -1,293 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.RingBufferForward (- T, track, trackSkip, trackSkipHold,- index,- ) where--import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import qualified Synthesizer.LLVM.Parameter as Param-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )--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.Class as Class--import qualified LLVM.Core as LLVM-import LLVM.Util.Loop (Phi, )-import LLVM.Core (CodeGenFunction, Value, )--import Control.Arrow ((<<<), )-import Control.Applicative (pure, )-import Data.Tuple.HT (mapSnd, )--import Data.Word (Word32, )-import Foreign.Storable.Tuple ()-import Foreign.Ptr (Ptr, )--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 (Ptr (Memory.Struct a)),- length :: Value Word32,- current :: Value Word32- }--{- |-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 Word32 -> 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 Word32) (T a)-trackSkip time (SigP.Cons next start stop create delete) =- Param.with (Param.word32 time) $ \getTime valueTime ->- CausalP.Cons- (trackNext next valueTime)- (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 'Word32' 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 Word32) ((Value Bool, Value Word32), 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 start stop create delete) =- (Param.with (Param.word32 time) $ \getTime valueTime ->- CausalP.Cons- (trackNextHold next valueTime)- (trackStartHold start valueTime)- (trackStopHold stop)- (trackCreate create getTime)- (trackDelete delete))---trackNext ::- (Memory.C al, Memory.Struct al ~ am, Phi z,- Phi state, Class.Undefined state) =>- (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->- (tl -> Value Word32) ->- (context, (tl, Value (Ptr am))) ->- Value Word32 ->- (Value Word32, (state, Value Word32)) ->- MaybeCont.T r z (T al, (Value Word32, (state, Value Word32)))-trackNext next valueTime (context, (size,ptr)) 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 state0- MaybeCont.lift $- fmap ((,) state1) $ storeNext (size0,ptr) a pos0- return (Cons ptr size0 pos3, (n1, (state3, pos3)))--trackStart ::- (LLVM.IsSized am,- Phi state, Class.Undefined state) =>- (param -> CodeGenFunction r (context, state)) ->- (tl -> Value Word32) ->- (param, tl) ->- CodeGenFunction r- ((context, (tl, Value (Ptr am))),- (Value Word32, (state, Value Word32)))-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 (Ptr am))) ->- (Value Word32, (state, Value Word32)) ->- CodeGenFunction r ()-trackStop stop (context, (_size,ptr)) (_n, (state, _remain)) = do- LLVM.free ptr- stop context state---trackNextHold ::- (Memory.C al, Memory.Struct al ~ am, Phi z,- Phi state, Class.Undefined state) =>- (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->- (tl -> Value Word32) ->- (context, (tl, Value (Ptr am))) ->- Value Word32 ->- (Value Word32, (Maybe.T state, Value Word32)) ->- MaybeCont.T r z- (((Value Bool, Value Word32), T al),- (Value Word32, (Maybe.T state, Value Word32)))-trackNextHold next valueTime (context, (size,ptr)) 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 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, Memory.Struct al ~ am) =>- (Value Word32, Value (Ptr am)) ->- al -> Value Word32 -> CodeGenFunction r (Value Word32)-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,- Phi state, Class.Undefined state) =>- (param -> CodeGenFunction r (context, state)) ->- (tl -> Value Word32) ->- (param, tl) ->- CodeGenFunction r- ((context, (tl, Value (Ptr am))),- (Value Word32, (Maybe.T state, Value Word32)))-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 (Ptr am))) ->- (Value Word32, (Maybe.T state, Value Word32)) ->- 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/Server/CausalPacked/Arrange.hs
@@ -1,655 +0,0 @@-module Synthesizer.LLVM.Server.CausalPacked.Arrange where--import Synthesizer.LLVM.Server.CommonPacked (VectorSize, Vector, VectorValue, stair, )--import qualified Sound.MIDI.Controller as Ctrl--import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech-import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr-import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrPlug-import qualified Synthesizer.LLVM.Server.SampledSound as Sample-import Synthesizer.LLVM.Server.Common--import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS-import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS-import qualified Synthesizer.MIDI.CausalIO.Process as MIO-import qualified Synthesizer.MIDI.Value as MV-import qualified Synthesizer.CausalIO.Process as PIO-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.Storable.Process as CausalSt-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 Synthesizer.LLVM.Frame.SerialVector as Serial--import qualified Data.EventList.Relative.TimeTime as EventListTT--import qualified Data.StorableVector as SV--import qualified Synthesizer.Zip as Zip--import qualified Synthesizer.MIDI.Dimensional.ValuePlain as DMV-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg-import qualified Sound.MIDI.Message.Channel as ChannelMsg-import qualified Sound.MIDI.Message.Class.Construct as Construct-import qualified Sound.MIDI.Message.Class.Check as Check--import Control.Arrow (Arrow, arr, first, (<<<), (^<<), )-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 qualified Number.DimensionTerm as DN-import qualified Algebra.DimensionTerm as Dim--import qualified Algebra.Transcendental as Trans--{--import qualified Numeric.NonNegative.Chunky as NonNegChunky-import qualified Numeric.NonNegative.Class as NonNeg--}-import qualified Numeric.NonNegative.Wrapper as NonNegW--import Prelude hiding (Real, id, )----type StereoVector = StereoInt.T VectorSize Real---keyboard ::- (Check.C msg) =>- IO (ChannelMsg.Channel ->- SampleRate Real ->- PIO.T (MIO.Events msg) (SV.Vector Vector))-keyboard = do- arrange <- CausalSt.makeArranger- amp <- CausalP.processIO (CausalPS.amplify 0.2)-- ping <- Instr.pingRelease-- return $ \ chan sampleRate ->- amp ()- <<<- arrange- <<<- arr shortTime- <<<- MIO.sequenceCore chan- (\ _pgm -> ping 0.8 0.1 sampleRate)---infixr 3 &+&--(&+&) ::- (Arrow arrow) =>- arrow a b -> arrow a c -> arrow a (Zip.T b c)-(&+&) = Zip.arrowFanout---controllerExponentialDirect ::- (Check.C msg, Trans.C y, Dim.C v) =>- ChannelMsg.Channel ->- VoiceMsg.Controller ->- (DN.T v y, DN.T v y) ->- DN.T v y ->- PIO.T (MIO.Events msg) (Instr.Control (DN.T v y))-controllerExponentialDirect chan ctrl bnds initial =- MIO.slice- (Check.controller chan ctrl)- (DMV.controllerExponential bnds)- initial--shortTime ::- EventListTT.T PC.StrictTime body ->- EventListTT.T PC.ShortStrictTime body-shortTime =- EventListTT.mapTime- (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)--keyboardFM ::- (Check.C msg, POut.Default b) =>- CausalP.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)-- ping <- Instr.pingStereoReleaseFM-- return $ \ sampleRate ->- amp ()- <<<- arrange- <<<- arr shortTime- <<<- -- ToDo: fetch parameters from controllers- MIO.sequenceModulated chan- (\ _pgm -> ping sampleRate)- <<<- id &+&- ((controllerExponentialDirect chan- Ctrl.attackTime (DN.time 0.25, DN.time 2.5) (DN.time 0.8)- &+&- controllerExponentialDirect chan- Ctrl.releaseTime (DN.time 0.03, DN.time 0.3) (DN.time 0.1))- &+&- ((MIO.controllerExponential chan controllerTimbre0 (1/pi,0.01) 0.05- &+&- controllerExponentialDirect chan controllerTimbre1- (DN.time 0.01, DN.time 10)- (DN.time 5))- &+&- ((MIO.controllerLinear chan Ctrl.soundController5 (0,2) 1- &+&- controllerExponentialDirect chan Ctrl.soundController7- (DN.time 0.25, DN.time 2.5)- (DN.time 0.8))- &+&- (MIO.controllerLinear chan controllerDetune (0,0.005) 0.001- &+&- MIO.bendWheelPressure chan 2 0.04 0.03))))---controllerExponentialDim ::- (Arrow arrow,- Trans.C y, Dim.C v) =>- VoiceMsg.Controller ->- (DN.T v y, DN.T v y) ->- DN.T v y ->- MCS.T arrow (DN.T v y)-controllerExponentialDim ctrl bnds initial =- MCS.slice- (MCS.Controller ctrl)- (DMV.controllerExponential bnds)- initial---timeControlPercussive, timeControlString ::- PIO.T- (PCS.T MCS.Controller Int)- (Zip.T- (Instr.Control Instr.Time)- (Instr.Control Instr.Time))--timeControlPercussive =- controllerExponentialDim Ctrl.attackTime- (DN.time 0.1, DN.time 2.5) (DN.time 0.8)- &+&- controllerExponentialDim Ctrl.releaseTime- (DN.time 0.03, DN.time 0.3) (DN.time 0.1)--timeControlString =- controllerExponentialDim Ctrl.attackTime- (DN.time 0.005, DN.time 0.1) (DN.time 0.1)- &+&- controllerExponentialDim Ctrl.releaseTime- (DN.time 0.03, DN.time 0.3) (DN.time 0.2)---keyboardDetuneFMCore ::- (Check.C msg, POut.Default b) =>- CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-keyboardDetuneFMCore emitStereo smpDir = do- arrange <- keyboardDetuneFMConstVolume smpDir- amp <-- CausalP.processIO- (emitStereo <<<- CausalP.envelopeStereo <<<- first (CausalP.mapSimple Serial.upsample))- return $ \chan initPgm rate ->- amp ()- <<<- MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)- &+&- arrange chan initPgm rate--keyboardDetuneFMConstVolume ::- (Check.C msg) =>- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real ->- PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Vector)))-keyboardDetuneFMConstVolume smpDir = do- arrange <- CausalSt.makeArranger-- tine <- Instr.tineStereoFM- ping <- Instr.pingStereoReleaseFM- filterSaw <- Instr.filterSawStereoFM- bellNoise <- Instr.bellNoiseStereoFM-- wind <- Instr.wind- windPhaser <- Instr.windPhaser- string <- Instr.softStringShapeFM- fmString <- Instr.fmStringStereoFM- helixNoise <- InstrPlug.helixNoise- arcs <- sequence $- Instr.cosineStringStereoFM :- Instr.arcSawStringStereoFM :- Instr.arcSineStringStereoFM :- Instr.arcSquareStringStereoFM :- Instr.arcTriangleStringStereoFM :- []-- helixSound <- Instr.helixSound- sampledSound <- Instr.sampledSound-- syllables <-- fmap concat $- mapM (Sample.loadRanges smpDir) $- Sample.tomatensalat :- Sample.hal :- Sample.graphentheorie :- []-- let frequencyControlPercussive =- MCS.controllerLinear controllerDetune (0,0.005) 0.001- &+&- MCS.bendWheelPressure 2 0.04 0.03-- frequencyControlString =- MCS.controllerLinear controllerDetune (0,0.01) 0.005- &+&- MCS.bendWheelPressure 2 0.04 0.03-- let tineProc rate vel freq =- tine rate vel freq- <<<- Zip.arrowSecond- (timeControlPercussive- &+&- (((fmap stair ^<<- MCS.controllerLinear controllerTimbre0 (0.5,6.5) 2)- &+&- MCS.controllerLinear controllerTimbre1 (0,1.5) 1)- &+&- frequencyControlPercussive))-- pingProc rate vel freq =- ping rate vel freq- <<<- Zip.arrowSecond- (timeControlPercussive- &+&- ((MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05- &+&- controllerExponentialDim controllerTimbre1- (DN.time 0.01, DN.time 10) (DN.time 5))- &+&- ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2- &+&- controllerExponentialDim Ctrl.soundController7- (DN.time 0.03, DN.time 1) (DN.time 0.5))- &+&- frequencyControlPercussive)))-- filterSawProc rate vel freq =- filterSaw rate vel freq- <<<- Zip.arrowSecond- (timeControlPercussive- &+&- ((controllerExponentialDim controllerTimbre0- (DN.frequency 100, DN.frequency 10000)- (DN.frequency 1000)- &+&- controllerExponentialDim controllerTimbre1- (DN.time 0.1, DN.time 1)- (DN.time 0.6))- &+&- frequencyControlPercussive))-- bellNoiseProc rate vel freq =- bellNoise rate vel freq- <<<- Zip.arrowSecond- (timeControlPercussive- &+&- ((MCS.controllerLinear controllerTimbre0 (0,1) 0.3- &+&- MCS.controllerExponential controllerTimbre1 (1,1000) 100)- &+&- frequencyControlPercussive))-- windProc rate vel freq =- wind rate vel freq- <<<- Zip.arrowSecond- (timeControlString- &+&- (MCS.controllerExponential controllerTimbre1 (1,1000) 100- &+&- MCS.bendWheelPressure 12 0.8 0))-- windPhaserProc rate vel freq =- windPhaser rate vel freq- <<<- Zip.arrowSecond- (timeControlString- &+&- (MCS.controllerLinear controllerTimbre0 (0,1) 0.5- &+&- (controllerExponentialDim controllerDetune- (DN.frequency 50, DN.frequency 5000) (DN.frequency 500)- &+&- (MCS.controllerExponential controllerTimbre1 (1,1000) 100- &+&- MCS.bendWheelPressure 12 0.8 0))))-- stringProc rate vel freq =- string rate vel freq- <<<- Zip.arrowSecond- (timeControlString- &+&- (MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05- &+&- frequencyControlString))-- fmStringProc rate vel freq =- fmString rate vel freq- <<<- Zip.arrowSecond- (timeControlString- &+&- ((MCS.controllerLinear controllerTimbre0 (0,0.5) 0.2- &+&- MCS.controllerExponential controllerTimbre1 (1/pi,10) 0.05)- &+&- frequencyControlString))-- helixNoiseProc rate vel freq =- helixNoise rate vel freq- <<<- Zip.arrowSecond- (timeControlString- &+&- (MCS.controllerExponential controllerTimbre0 (1,0.01) 0.1- &+&- frequencyControlString))-- makeArc proc rate vel freq =- proc rate vel freq- <<<- Zip.arrowSecond- (timeControlString- &+&- (MCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5- &+&- frequencyControlString))-- sampled smp rate vel freq =- smp rate vel freq- <<<- Zip.arrowSecond frequencyControlPercussive-- helixed smp rate vel freq =- smp rate vel freq- <<<- Zip.arrowSecond- (MCS.controllerExponential Ctrl.attackTime (0.25, 4) 1- &+&- frequencyControlPercussive)-- bank =- Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $- [tineProc, pingProc, filterSawProc, bellNoiseProc,- stringProc, fmStringProc] ++- map makeArc arcs ++ windProc : windPhaserProc :- ([helixed . helixSound, sampled . sampledSound] <*> syllables) ++- helixNoiseProc :- []-- return $ \chan initPgm rate ->- arrange- <<<- arr shortTime- <<<- MIO.sequenceModulatedMultiProgram chan initPgm- (\pgm -> Map.findWithDefault pingProc pgm bank rate)- <<<- id &+& MCS.fromChannel chan---keyboardMultiChannel ::- (Check.C msg) =>- FilePath ->- IO (SampleRate Real ->- PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))-keyboardMultiChannel smpDir = do- proc <-- keyboardDetuneFMCore- (CausalP.mapSimple StereoInt.interleave)- smpDir- mix <- CausalP.processIO CausalP.mix-- return $ \ sampleRate ->- arr SigStL.unpackStereoStrict- <<<- foldl1- (\x y -> mix () <<< Zip.arrowFanout x y)- (map- (\chan ->- proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)- sampleRate)- [0 .. 3])----data Phoneme = Phoneme Bool VoiceMsg.Velocity VoiceMsg.Pitch--instance Check.C Phoneme where- note _chan (Phoneme on v p) = Just (v, p, on)---voderSplit ::- (Check.C msg, Construct.C msg, Arrow arrow) =>- ChannelMsg.Channel ->- arrow- (MIO.Events msg)- (Zip.T- (MIO.Events Phoneme)- (MIO.Events msg))-voderSplit chan =- arr $- uncurry Zip.Cons .- EventListTT.unzip .- fmap- (ListHT.unzipEithers .- fmap (\ev ->- case Check.note chan ev of- Nothing -> Right ev- Just (v,p,b) ->- if p >= VoiceMsg.toPitch 36- then- let p0 = VoiceMsg.increasePitch (-36) p- in if p0 <= VoiceMsg.toPitch 29- then Left $ Phoneme b v p0- else Right $ Construct.note chan- (v, VoiceMsg.increasePitch (-12) p, b)- else Right ev))--voder ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->- Speech.VowelSynth ->- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voder emitStereo voice smpDir = do- carrier <- keyboardDetuneFMCore id smpDir- arrange <- CausalSt.makeArranger- interleave <- CausalP.processIO emitStereo-- return $ \chan initPgm sampleRate ->- interleave ()- <<<- arrange- <<<- arr shortTime- <<<- MIO.sequenceModulatedMultiProgramVelocityPitch- chan (VoiceMsg.toProgram 0)- (\ _pgm _vel -> voice sampleRate)- <<<- Zip.arrowSecond (carrier chan initPgm sampleRate)- <<<- voderSplit chan--voderBand ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voderBand emitStereo smpDir = do- voice <- Speech.vowelBand- voder emitStereo voice smpDir--voderMask ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voderMask emitStereo smpDir = do- voice <-- Speech.vowelMask <*>- fmap- (Map.mapMaybe (\(typ,smp) ->- toMaybe (typ==Speech.Filtered Speech.Continuous Speech.Voiced) smp))- Speech.loadMasksKeyboard- voder emitStereo voice smpDir---voderEnv ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->- Speech.VowelSynthEnv ->- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voderEnv emitStereo voice smpDir = do- carrier <- keyboardDetuneFMConstVolume smpDir- arrange <- CausalSt.makeArranger- amp <-- CausalP.processIO- (emitStereo <<<- CausalP.envelopeStereo <<<- first (CausalP.mapSimple Serial.upsample))-- return $ \chan initPgm sampleRate ->- amp ()- <<<- MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)- &+&- (arrange- <<<- arr shortTime- <<<- MIO.sequenceModulatedMultiProgramVelocityPitch- chan (VoiceMsg.toProgram 0)- (\ _pgm vel -> voice sampleRate (MV.velocity vel))- <<<- Zip.arrowSecond- (Zip.arrowFanout- (timeControlString <<< MCS.fromChannel chan)- (carrier chan initPgm sampleRate))- <<<- voderSplit chan)--voderMaskEnv ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->- FilePath ->- IO (ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voderMaskEnv emitStereo smpDir = do- voice <- Speech.phonemeMask <*> Speech.loadMasksKeyboard- voderEnv emitStereo voice smpDir---voderSeparated ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->- Speech.VowelSynthEnv ->- FilePath ->- IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voderSeparated emitStereo voice smpDir = do- carrier <- keyboardDetuneFMCore id smpDir- arrange <- CausalSt.makeArranger- amp <-- CausalP.processIO- (emitStereo <<<- CausalP.envelopeStereo <<<- first (CausalP.mapSimple Serial.upsample))-- return $ \carrierChan phonemeChan initPgm sampleRate ->- amp sampleRate- <<<- MIO.controllerExponential phonemeChan controllerVolume (0.001, 1) (0.2::Float)- &+&- (arrange- <<<- arr shortTime- <<<- MIO.sequenceModulatedMultiProgramVelocityPitch- phonemeChan (VoiceMsg.toProgram 0)- (\ _pgm vel -> voice sampleRate (MV.velocity vel))- <<<- Zip.arrowFanout id- (Zip.arrowFanout- (timeControlString <<< MCS.fromChannel phonemeChan)- (carrier carrierChan initPgm sampleRate)))--voderMaskSeparated ::- (Check.C msg, Construct.C msg, POut.Default b) =>- CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->- FilePath ->- IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->- SampleRate Real -> PIO.T (MIO.Events msg) b)-voderMaskSeparated emitStereo smpDir = do- voice <- Speech.phonemeMask <*> Speech.loadMasksGrouped- voderSeparated emitStereo voice smpDir--voderMaskMulti ::- (Check.C msg, Construct.C msg) =>- FilePath ->- IO (SampleRate Real ->- PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))-voderMaskMulti smpDir = do- mix <- CausalP.processIO CausalP.mix- proc <-- voderMaskSeparated- (CausalP.mapSimple StereoInt.interleave)- smpDir-- return $ \ sampleRate ->- arr SigStL.unpackStereoStrict- <<<- foldl1- (\x y -> mix () <<< Zip.arrowFanout x y)- (map- (\chan ->- proc- (ChannelMsg.toChannel chan)- (ChannelMsg.toChannel $ succ chan)- (VoiceMsg.toProgram 4)- sampleRate)- [0, 2, 4, 6])
src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -10,7 +10,27 @@ However, we preserve this module in order to show how things work internally. -}-module Synthesizer.LLVM.Server.CausalPacked.Instrument where+module Synthesizer.LLVM.Server.CausalPacked.Instrument (+ ping,+ pingRelease,+ helixSound,+ pingStereoReleaseFM,+ filterSawStereoFM,+ tineStereoFM,+ bellNoiseStereoFM,+ wind,+ windPhaser,+ softStringShapeFM, cosineStringStereoFM,+ arcSawStringStereoFM, arcSineStringStereoFM,+ arcSquareStringStereoFM, arcTriangleStringStereoFM,+ fmStringStereoFM,+ sampledSound, sampledSoundMono,+ Control, DetuneBendModControl, WithEnvelopeControl, StereoChunk,+ Frequency, Time,+ pingControlledEnvelope, stringControlledEnvelope,+ reorderEnvelopeControl,+ frequencyControl, zipEnvelope,+ ) where import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise, ) import Synthesizer.LLVM.Server.CommonPacked@@ -291,6 +311,9 @@ expo = (CausalP.mapSimple Serial.upsample $& phase) * (Exp.causalPackedP (1::Param.T p Real) $& phaseDecay)+ osci ::+ CausalP.T p+ (VectorValue, (VectorValue, VectorValue)) VectorValue osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1 in liftA2 Stereo.cons (osci $& shapeCtrl &|& (expo &|& fmap Stereo.left freqs))
src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs view
@@ -6,7 +6,10 @@ but here we use the higher level interface of the "Synthesizer.LLVM.CausalParameterized.FunctionalPlug" module. -}-module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug where+module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug (+ tineStereoFM,+ helixNoise,+ ) where import Synthesizer.LLVM.Server.CausalPacked.Instrument ( Control, DetuneBendModControl,
src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs view
@@ -1,5 +1,22 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.LLVM.Server.CausalPacked.Speech where+module Synthesizer.LLVM.Server.CausalPacked.Speech (+ loadMasks,+ loadMasksGrouped,+ loadMasksKeyboard,+ maskNamesGrouped,+ phonemeMask,+ vowelMask,+ vowelBand,+ filterFormant,+ filterFormants,+ VowelSynth,+ VowelSynthEnv,+ EnvelopeType(..),+ CarrierType(..),+ PhonemeType(..),+ ) where import Synthesizer.LLVM.Server.CausalPacked.Instrument (StereoChunk, Control, Frequency, frequencyControl,@@ -42,11 +59,12 @@ import qualified LLVM.Core as LLVM -import System.FilePath ((</>), (<.>), )+import qualified System.Path as Path+import System.Path ((</>), (<.>), ) import Control.Arrow (arr, second, (^<<), (***), ) import Control.Category ((.), )-import Control.Applicative (pure, liftA, liftA3, (<*>), )+import Control.Applicative (pure, liftA, liftA3, (<$>), (<*>), ) import Data.Traversable (Traversable, traverse, forM, ) @@ -56,7 +74,7 @@ {- stimmhaft-a, e, i, o, u, ä, ö, ü+a, e, i, o, u, ae, oe, ue l, m, n, ng Diphtong@@ -65,7 +83,7 @@ stimmlos/Zischlaute f, h, w, s, sch, th, ch (weich), ch (kochen), r -explosiv+plosiv b, p, g, k, d, t -} @@ -392,9 +410,10 @@ IO (dict (PhonemeType, SV.Vector Real)) loadMasks maskNames = forM maskNames $ \(typ, name) ->- fmap ((,) typ . SV.concat . SVL.chunks) $+ (,) typ . SV.concat . SVL.chunks <$> Sample.load- ((if typ==Sampled then "phoneme" else "mask") </> name <.> "wav")+ (Path.relDir (if typ==Sampled then "phoneme" else "mask")+ </> Path.relFile name <.> "wav")
src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs view
@@ -32,13 +32,12 @@ import qualified Synthesizer.State.Signal as SigS import Synthesizer.Piecewise ((#|-), (-|#), (#|), (|#), ) -import qualified Data.StorableVector.Lazy.Pattern as SVP import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV-import Foreign.Storable (Storable) import Control.Arrow (arr, (<<<), (^<<), ) import Control.Category ((.), id, )+import Control.Applicative ((<$>), ) import Control.Functor.HT (void, ) @@ -51,7 +50,9 @@ import Data.Ord.HT (comparing, ) import Data.Monoid (mempty, mappend, ) -import System.FilePath ((</>), (<.>), )+import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path+import System.Path ((</>), (<.>), ) import qualified Number.Complex as Complex @@ -101,11 +102,25 @@ Plot.plot WXT.cons $ spectrumPlot xs -saveSound :: FilePath -> SVL.Vector Real -> IO ()+saveSound :: (PathClass.AbsRel ar) => Path.File ar -> SVL.Vector Real -> IO () saveSound path xs =- void $ SoxWrite.simple SVL.hPut mempty path sampleRateInt xs+ void $ SoxWrite.simple SVL.hPut mempty (Path.toString path) sampleRateInt xs +tmpWave :: String -> Path.AbsFile+tmpWave name = Path.absDir "/tmp" </> Path.relFile name <.> "wav" +phonemeWave :: String -> Path.RelFile+phonemeWave name = Path.relDir "phoneme" </> Path.relFile name <.> "wav"++maskWave :: String -> Path.RelFile+maskWave name = Path.relDir "mask" </> Path.relFile name <.> "wav"++loadPhoneme :: String -> IO (SVL.Vector Real)+loadPhoneme name = do+ putStrLn name+ Sample.load $ phonemeWave name++ -- * modelling formants using bandpass filters type Formant a = (UniFilter.Result a -> a, Pole Real, Real)@@ -146,7 +161,7 @@ compareSpec ::IO () compareSpec = do- sampled <- Sample.load "phoneme/sch.wav"+ sampled <- Sample.load (phonemeWave "sch") synthesized <- synthesis void $ Plot.plot WXT.cons $ spectrumPlot sampled@@ -158,7 +173,7 @@ render ::IO () render = do synthesized <- synthesis- saveSound "sch-synth.wav" $+ saveSound (Path.relFile "sch-synth.wav") $ SVL.take sampleRateInt $ synthesized (SVL.chunkSize 4096) () @@ -180,16 +195,9 @@ . (Filt1.highpassCausal $<# FirstOrder.parameter (1000/sampleRate)) -{- |-Take n values from the end of the vector in a lazy way.--}-takeEnd :: (Storable a) => Int -> SVL.Vector a -> SVL.Vector a-takeEnd n xs =- SVP.drop (SVP.length (SVL.drop n xs)) xs- scorePeriod :: Comb -> Real -> Int -> SVL.Vector Real -> (Real, SVL.Vector Real) scorePeriod comb gain period sig =- let end = takeEnd (3*period) $ comb (gain, period) sig+ let end = SVL.takeEnd (3*period) $ comb (gain, period) sig in (Analysis.volumeEuclideanSqr end, end) vowelNames :: [String]@@ -208,9 +216,7 @@ scanPeriods = do comb <- makeComb forM_ tonalNames $ \name -> do- let path = "phoneme" </> name <.> "wav"- sampled <- Sample.load path- putStrLn path+ sampled <- loadPhoneme name let scores = flip map [350 .. 400] $ \period -> (period,@@ -261,12 +267,8 @@ extractPeriods ::IO () extractPeriods = do comb <- makeHighComb- forM_ tonalNames $ \name -> do- let readPath = "phoneme" </> name <.> "wav"- sampled <- Sample.load readPath- putStrLn readPath- let writePath = "mask" </> name <.> "wav"- saveSound writePath $ findPeriod comb sampled+ forM_ tonalNames $ \name ->+ saveSound (maskWave name) . findPeriod comb =<< loadPhoneme name -- ** using the frequency spectrum@@ -322,20 +324,19 @@ testTransfer ::IO () testTransfer = do- sampled <- Sample.load "phoneme/o-noise.wav"+ trans <- transfer <$> Sample.load (phonemeWave "o-noise") filt <- makeFilter- let trans = transfer sampled- saveSound "/tmp/spectrum.wav" $+ saveSound (tmpWave "spectrum") $ normalizeMax $ transferSpectrum trans- saveSound "/tmp/shrunkenspectrum.wav" $+ saveSound (tmpWave "shrunkenspectrum") $ normalizeMax $ transferShrunkenSpectrum trans- saveSound "/tmp/envelope.wav" $ transferEnvelope trans- saveSound "/tmp/window.wav" $ transferWindow trans+ saveSound (tmpWave "envelope") $ transferEnvelope trans+ saveSound (tmpWave "window") $ transferWindow trans let window = SV.concat $ SVL.chunks $ transferWindow trans- saveSound "/tmp/filtered.wav" $+ saveSound (tmpWave "filtered") $ filt window $ SVL.concat $ replicate 100 $ SVL.cons 1 $ SVL.replicate SVL.defaultChunkSize 380 0- saveSound "/tmp/chirp.wav" $+ saveSound (tmpWave "chirp") $ filt window $ SVL.concat $ map (\n -> SVL.cons 1 $ SVL.replicate SVL.defaultChunkSize n 0) $ [350..450]@@ -344,13 +345,9 @@ transferMasks = do -- forM_ (map (++"-noise") vowelNames) $ \name -> do forM_ (tonalNames++sibilantNames++stopConsonantNames) $ \name -> do- let readPath = "phoneme" </> name <.> "wav"- sampled <- Sample.load readPath- putStrLn readPath- let writePath = "mask" </> name <.> "wav"- let trans = transfer sampled- saveSound writePath $ normalize $ transferWindow trans- let spectrumPath = "/tmp" </> "spec-" ++ name <.> "wav"+ trans <- transfer <$> loadPhoneme name+ saveSound (maskWave name) $ normalize $ transferWindow trans+ let spectrumPath = tmpWave $ "spec-" ++ name saveSound spectrumPath $ normalizeMax $ transferShrunkenSpectrum trans
src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -13,11 +13,16 @@ instruments:+ 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.@@ -70,9 +75,48 @@ by a MIDI event stream editor. -} +{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Server.Packed.Instrument where+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 Synthesizer.LLVM.Server.CommonPacked import Synthesizer.LLVM.Server.Common @@ -603,14 +647,14 @@ pingReleaseEnvelope -tineControlledProc, tineControlledFnProc ::+_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 =+_tineControlledProc index depth vel = CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<<@@ -1408,11 +1452,11 @@ (frequencyFromBendModulation (frequencyConst 3) (modulation id))) -sampledSoundLeaky ::+_sampledSoundLeaky :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector))-sampledSoundLeaky =+_sampledSoundLeaky = liftA2 (\osc freqMod smp fm sr vel freq dur -> {-
src/Synthesizer/LLVM/Server/SampledSound.hs view
@@ -5,11 +5,14 @@ import qualified Sound.Sox.Read as SoxRead import qualified Sound.Sox.Option.Format as SoxOption import Control.Exception (bracket, )-import System.FilePath ((</>), ) import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL +import qualified System.Path.PartClass as PathClass+import qualified System.Path as Path+import System.Path ((</>), )+ import Data.Tuple.HT (mapPair, ) import qualified Number.DimensionTerm as DN@@ -33,12 +36,13 @@ } -load :: FilePath -> IO (SVL.Vector Real)+-- ToDo: flag failure if files cannot be found, or just remain silent+load :: (PathClass.AbsRel ar) => Path.File ar -> IO (SVL.Vector Real) load path =- bracket (SoxRead.open SoxOption.none path) SoxRead.close $+ bracket (SoxRead.open SoxOption.none (Path.toString path)) SoxRead.close $ SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize) -loadRanges :: FilePath -> Info -> IO [T]+loadRanges :: (PathClass.AbsRel ar) => Path.Dir ar -> Info -> IO [T] loadRanges dir (Info file sr poss) = fmap (\smp -> map (Cons smp (DN.frequency sr)) poss)@@ -48,12 +52,15 @@ data Info = Info {- infoName :: FilePath,+ infoName :: Path.RelFile, infoRate :: Real, infoPositions :: [Positions] } +info :: FilePath -> Real -> [Positions] -> Info+info path = Info (Path.relFile path) + parts :: T -> (SigSt.T Real, SigSt.T Real, SigSt.T Real) parts smp = let pos = positions smp@@ -92,7 +99,7 @@ tomatensalat :: Info tomatensalat =- Info "tomatensalat2.wav" 44100 tomatensalatPositions+ info "tomatensalat2.wav" 44100 tomatensalatPositions halPositions :: [Positions]@@ -107,7 +114,7 @@ hal :: Info hal =- Info "haskell-in-leipzig2.wav" 44100 halPositions+ info "haskell-in-leipzig2.wav" 44100 halPositions graphentheoriePositions :: [Positions]@@ -121,4 +128,4 @@ graphentheorie :: Info graphentheorie =- Info "graphentheorie0.wav" 44100 graphentheoriePositions+ info "graphentheorie0.wav" 44100 graphentheoriePositions
src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs view
@@ -2,6 +2,7 @@ module Main where -- module Synthesizer.LLVM.Server.SampledSoundAnalysis where +import qualified Synthesizer.LLVM.Server.Default as Default import qualified Synthesizer.LLVM.Server.SampledSound as Sample import Synthesizer.LLVM.Server.Common (Real, )@@ -17,6 +18,8 @@ import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL +import qualified System.Path as Path+ import qualified Data.Foldable as Fold import Control.Functor.HT (void, ) import Control.Monad (when, )@@ -120,8 +123,8 @@ main = Fold.forM_ [Sample.tomatensalat, Sample.hal, Sample.graphentheorie] $ \info -> do- putStrLn $ Sample.infoName info- ranges <- Sample.loadRanges "speech" info+ putStrLn $ Path.toString $ Sample.infoName info+ ranges <- Sample.loadRanges Default.sampleDirectory info Fold.forM_ ranges $ \smp -> let ignoreBeginning = 30 body = snd3 $ Sample.parts smp
src/Synthesizer/LLVM/Server/Scalar/Instrument.hs view
@@ -1,4 +1,16 @@-module Synthesizer.LLVM.Server.Scalar.Instrument where+module Synthesizer.LLVM.Server.Scalar.Instrument (+ ping,+ pingDur,+ pingDurTake,+ pingRelease,+ pingStereoRelease,+ tine,+ tineStereo,+ softString,++ -- * for testing+ dummy,+ ) where import Synthesizer.LLVM.Server.Common import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -4,12 +4,40 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Simple.Signal where+module Synthesizer.LLVM.Simple.Signal (+ C(simple),+ T,+ amplify,+ amplifyStereo,+ constant,+ envelope,+ envelopeStereo,+ exponential2,+ iterate,+ map,+ mapAccum,+ mix,+ osci,+ osciPlain,+ osciSaw,+ zip,+ zipWith, + fromStorableVector,+ fromStorableVectorLazy,++ render,+ renderChunky,+ runChunky,+ ) where++import Synthesizer.LLVM.Simple.SignalPrivate+ 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.Execution as Exec+import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt import qualified Synthesizer.LLVM.Storable.Vector as SVU@@ -17,7 +45,6 @@ import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB -import qualified LLVM.Extra.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.MaybeContinuation as MaybeCont@@ -25,123 +52,33 @@ import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (ifThen, )-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, valueTupleOf, ) import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ret, Value, valueOf,- IsSized, IsConst, IsArithmetic,- Linkage(ExternalLinkage), createNamedFunction)+ IsSized, IsConst, IsArithmetic) -import Control.Monad (liftM2, liftM3, )-import Control.Applicative (Applicative, pure, (<*>), liftA2, )+import Control.Monad (liftM2, )+import Control.Applicative (pure, liftA3, (<$>), ) -import qualified Number.Ratio as Ratio import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field as Field-import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive import qualified System.Unsafe as Unsafe import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )-import Foreign.Ptr (FunPtr, Ptr, nullPtr, )+import Foreign.Ptr (Ptr, nullPtr, ) import Data.Word (Word32, ) import Control.Exception (bracket, ) import NumericPrelude.Numeric 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 by defining--> newtype T a = Cons (Causal.T () a)--}-data T a =- forall state ioContext.- (Memory.C state) =>- Cons (forall r c.- (Phi c) =>- ioContext ->- state -> MaybeCont.T r c (a, state))- -- compute next value- (forall r.- ioContext ->- CodeGenFunction r state)- -- initial state- (IO ioContext)- {- 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.- (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-- alter ::- (forall context initState exitState.- Core context initState exitState a0 ->- Core context initState exitState a1) ->- signal a0 -> signal a1--instance C T where- simple next start =- Cons- (const next)- (const start)- (return ())- (const $ return ())-- alter f (Cons next0 start0 create delete) =- case f (Core next0 start0 id) of- Core next1 start1 _ ->- Cons next1 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)+constant :: (C signal, IsConst a) => a -> signal (Value a)+constant x = pure (valueOf x) mapAccum :: (C signal, Memory.C s) =>@@ -159,72 +96,6 @@ (stop . fst)) -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 startA createIOContextA deleteIOContextA)- (Cons nextB startB createIOContextB deleteIOContextB) =- Cons- (\(ioContextA, ioContextB) (sa0,sb0) -> do- (a,sa1) <- nextA ioContextA sa0- (b,sb1) <- nextB ioContextB sb0- return ((a,b), (sa1,sb1)))- (\(ioContextA, ioContextB) ->- liftM2 (,)- (startA ioContextA)- (startB ioContextB))- (liftM2 (,)- createIOContextA- createIOContextB)- (\(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-- mix :: (C signal, A.Additive a) => signal a -> signal a -> signal a@@ -242,59 +113,63 @@ envelopeStereo = zipWith Frame.amplifyStereo amplify ::- (IsArithmetic a, IsConst a) =>- a -> T (Value a) -> T (Value a)+ (C signal, IsArithmetic a, IsConst a) =>+ a -> signal (Value a) -> signal (Value a) amplify x = map (Frame.amplifyMono (valueOf x)) amplifyStereo ::- (IsArithmetic a, IsConst a) =>- a -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))+ (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 ::- (Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) =>+ (C signal,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) => (forall r. Value a -> CodeGenFunction r (Value a)) ->- Value a -> T (Value a)+ Value a -> signal (Value a) iterate f initial = simple (\y -> MaybeCont.lift $ fmap (\y1 -> (y,y1)) (f y)) (return initial) exponential2 ::- (Trans.C a, IsArithmetic a,+ (C signal, Trans.C a, IsArithmetic a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) =>- a -> a -> T (Value a)+ a -> a -> signal (Value a) exponential2 halfLife = iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf osciPlain ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ (C signal,+ Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, SoV.Fraction t, IsConst t) => (forall r. Value t -> CodeGenFunction r y) ->- Value t -> Value t -> T y+ Value t -> Value t -> signal y osciPlain wave phase freq = map wave $ iterate (SoV.incPhase freq) $ phase osci ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ (C signal,+ Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, SoV.Fraction t, IsConst t) => (forall r. Value t -> CodeGenFunction r y) ->- t -> t -> T y+ t -> t -> signal y osci wave phase freq = osciPlain wave (valueOf phase) (valueOf freq) osciSaw ::- (SoV.IntegerConstant a,+ (C signal,+ SoV.IntegerConstant a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, SoV.Fraction a, IsConst a) =>- a -> a -> T (Value a)+ a -> a -> signal (Value a) osciSaw = osci Wave.saw @@ -317,7 +192,7 @@ (valueOf ptr, valueOf (fromIntegral l :: Word32))) -- keep the foreign ptr alive- (return fp)+ (return (fp, ())) touchForeignPtr {-@@ -333,12 +208,15 @@ Cons (\stable (buffer0,length0) -> do (buffer1,length1) <- MaybeCont.lift $ do- nextChunkFn <- LLVM.staticFunction ChunkIt.nextCallBack+ nextChunkFn <-+ LLVM.staticNamedFunction+ "Simple.Signal.fromStorableVectorLazy.nextChunk"+ ChunkIt.nextCallBack needNext <- A.cmp LLVM.CmpEQ length0 A.zero ifThen needNext (buffer0,length0) (do lenPtr <- LLVM.alloca liftM2 (,)- (LLVM.call nextChunkFn (valueOf stable) lenPtr)+ (LLVM.call nextChunkFn stable lenPtr) (LLVM.load lenPtr)) valid <- MaybeCont.lift $ A.cmp LLVM.CmpNE buffer1 (valueOf nullPtr) MaybeCont.withBool valid $ do@@ -347,44 +225,56 @@ length2 <- A.dec length1 return (x, (buffer2,length2))) (const $ return (valueOf nullPtr, A.zero))- (ChunkIt.new sig)+ ((\stable -> (stable,stable)) <$> ChunkIt.new sig) ChunkIt.dispose -{-+foreign import ccall safe "dynamic" derefFillPtr ::+ Exec.Importer (Word32 -> Ptr struct -> IO Word32)++ compile ::- (Memory.C value) =>- T value ->- CodeGenModule (Function (Word32 -> Ptr struct -> IO Word32))--}+ (Memory.C value, Memory.Struct value ~ struct,+ Memory.C state, Memory.Struct state ~ stateStruct) =>+ (forall r z. (Phi z) => state -> MaybeCont.T r z (value, state)) ->+ (forall r. CodeGenFunction r state) ->+ IO (Word32 -> Ptr struct -> IO Word32)+compile next start =+ Exec.compileModule $+ Exec.createFunction derefFillPtr "fillsignalblock" $ \ size bPtr -> do+ s <- start+ (pos,_) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do+ (y,s1) <- next s0+ MaybeCont.lift $ Memory.store y ptri+ return s1+ ret pos {--We could also implement that in terms of getPointerToFunction-as done in Parameterized.Signal.-However, since the 'fill' function will be called only once,-it does not matter whether we use the Just-In-Time compiler-or compile once.+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 a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>- Int -> T value -> SV.Vector a-render len (Cons next start createIOContext deleteIOContext) =+ T value -> Int -> SV.Vector a+render (Cons next start createIOContext deleteIOContext) len = Unsafe.performIO $- bracket createIOContext deleteIOContext $ \ ioContext ->+ bracket createIOContext (deleteIOContext . fst) $ \ (_ioContext, params) -> SVB.createAndTrim len $ \ ptr -> do fill <-- Exec.runFunction $- createNamedFunction ExternalLinkage "fillsignalblock" $ \ size bPtr -> do- s <- start ioContext- (pos,_) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do- (y,s1) <- next ioContext s0- MaybeCont.lift $ Memory.store y ptri- return s1- ret (pos :: Value Word32)+ compile (next $ valueTupleOf params) (start $ valueTupleOf params) fmap (fromIntegral :: Word32 -> Int) $ fill (fromIntegral len) (Memory.castStorablePtr ptr) +foreign import ccall safe "dynamic" derefStartPtr ::+ Exec.Importer (IO (Ptr a))++foreign import ccall safe "dynamic" derefStopPtr ::+ Exec.Importer (Ptr a -> IO ())+ foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32) @@ -397,28 +287,28 @@ state -> MaybeCont.T r z (value, state)) -> (forall r. CodeGenFunction r state) ->- IO (FunPtr (IO (Ptr stateStruct)),- FunPtr (Ptr stateStruct -> IO ()),- FunPtr (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))+ IO (IO (Ptr stateStruct),+ Exec.Finalizer stateStruct,+ Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32) compileChunky next start = Exec.compileModule $- liftM3 (,,)- (createNamedFunction ExternalLinkage "startsignal" $+ 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- (createNamedFunction ExternalLinkage "startsignal" $+ (Exec.createFunPtr "startsignal" $ do pptr <- malloc let retn :: CodeGenFunction r state -> Value (Ptr state) -> CodeGenFunction (Ptr state) () retn _ ptr = ret ptr retn undefined pptr) -}- (createNamedFunction ExternalLinkage "stopsignal" $+ (Exec.createFinalizer derefStopPtr "stopsignal" $ \ pptr -> LLVM.free pptr >> ret ())- (createNamedFunction ExternalLinkage "fillsignal" $+ (Exec.createFunction derefChunkPtr "fillsignal" $ \ sptr loopLen ptr -> do sInit <- Memory.load sptr (pos,sExit) <- MaybeCont.arrayLoop loopLen ptr sInit $@@ -427,21 +317,20 @@ MaybeCont.lift $ Memory.store y ptri return s1 Memory.store (Maybe.fromJust sExit) sptr- ret (pos :: Value Word32))+ ret pos) runChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>- SVL.ChunkSize -> T value -> IO (SVL.Vector a)-runChunky (SVL.ChunkSize size)- (Cons next start createIOContext deleteIOContext) = do- ioContext <- createIOContext+ T value -> SVL.ChunkSize -> IO (SVL.Vector a)+runChunky (Cons next start createIOContext deleteIOContext)+ (SVL.ChunkSize size) = do+ (ioContext, params) <- createIOContext (startFunc, stopFunc, fill) <-- compileChunky (next ioContext) (start ioContext)+ compileChunky (next $ valueTupleOf params) (start $ valueTupleOf params) statePtr <- ForeignPtr.newInit stopFunc startFunc- -- for explanation see Causal.Process- ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False+ ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext) let go = Unsafe.interleaveIO $ do@@ -449,7 +338,7 @@ withForeignPtr statePtr $ \sptr -> SVB.createAndTrim size $ fmap (fromIntegral :: Word32 -> Int) .- derefChunkPtr fill sptr (fromIntegral size) .+ fill sptr (fromIntegral size) . Memory.castStorablePtr touchForeignPtr ioContextPtr (if SV.length v > 0@@ -464,4 +353,4 @@ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => SVL.ChunkSize -> T value -> SVL.Vector a renderChunky size sig =- Unsafe.performIO (runChunky size sig)+ Unsafe.performIO (runChunky sig size)
src/Synthesizer/LLVM/Simple/SignalPacked.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Simple.SignalPacked where -import Synthesizer.LLVM.Simple.Signal (Core(Core), )+import Synthesizer.LLVM.Simple.SignalPrivate (Core(Core), alter, ) import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Frame.SerialVector as Serial @@ -36,7 +36,7 @@ signal a -> signal v pack = packRotate -packRotate = Sig.alter (\(Core next start stop) -> Core+packRotate = alter (\(Core next start stop) -> Core (\param s -> do wInit <- Maybe.lift $ Serial.writeStart (w2,_,s2) <-@@ -69,7 +69,7 @@ packIndex :: (Sig.C signal, Serial.C v, a ~ Serial.Element v) => signal a -> signal v-packIndex = Sig.alter (\(Core next start stop) -> Core+packIndex = alter (\(Core next start stop) -> Core (\param s -> do (v2,_,s2) <- Maybe.fromBool $@@ -100,7 +100,7 @@ packSmall :: (Sig.C signal, Serial.C v, a ~ Serial.Element v) => signal a -> signal v-packSmall = Sig.alter (\(Core next start stop) -> Core+packSmall = alter (\(Core next start stop) -> Core (\param -> MS.runStateT $ Serial.withSize $ \n ->@@ -117,7 +117,7 @@ signal v -> signal a unpack = unpackRotate -unpackRotate = Sig.alter (\(Core next start stop) -> Core+unpackRotate = alter (\(Core next start stop) -> Core (\context (i0,r0,s0) -> do endOfVector <- Maybe.lift $ A.cmp LLVM.CmpEQ i0 (valueOf (0::Word32))@@ -144,7 +144,7 @@ unpackIndex :: (Serial.C v, a ~ Serial.Element v, Memory.C v) => signal v -> signal a-unpackIndex = Sig.alter (\(Core next start stop) -> Core+unpackIndex = alter (\(Core next start stop) -> Core (\param (i0,v0,s0) -> do endOfVector <- Maybe.lift $ A.cmp LLVM.CmpGE i0
+ src/Synthesizer/LLVM/Simple/SignalPrivate.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Simple.SignalPrivate where++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )++import LLVM.Util.Loop (Phi, )+import LLVM.Core (CodeGenFunction, )++import Control.Monad (liftM2, )+import Control.Applicative (Applicative, pure, liftA2, (<*>), )++import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )++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, )++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 ioContext parameters.+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters),+ Memory.C state) =>+ Cons (forall r c.+ (Phi c) =>+ ValueTuple parameters ->+ state -> MaybeCont.T r c (a, state))+ -- compute next value+ (forall r.+ ValueTuple 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.+ (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++ alter ::+ (forall context initState exitState.+ Core context initState exitState a0 ->+ Core context initState exitState a1) ->+ signal a0 -> signal a1++instance C T where+ simple next start =+ Cons+ (const next)+ (const start)+ (return ((),()))+ (const $ return ())++ alter f (Cons next0 start0 create delete) =+ case f (Core next0 start0 id) of+ Core next1 start1 _ ->+ Cons next1 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 startA createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) =+ Cons+ (\(paramA, paramB) (sa0,sb0) -> do+ (a,sa1) <- nextA paramA sa0+ (b,sb1) <- nextB paramB sb0+ return ((a,b), (sa1,sb1)))+ (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 = do+ (ca,paramA) <- createIOContextA+ (cb,paramB) <- createIOContextB+ return ((ca,cb), (paramA,paramB))++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
src/Synthesizer/LLVM/Simple/Value.hs view
@@ -33,7 +33,7 @@ import qualified Synthesizer.Basic.Phase as Phase -import qualified Data.Vault as Vault+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, )
src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -41,9 +41,7 @@ import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM-import LLVM.Core- (Linkage(ExternalLinkage), createNamedFunction, ret,- IsPrimitive, getElementPtr, )+import LLVM.Core (IsPrimitive, ret, getElementPtr, ) import qualified Type.Data.Num.Decimal as TypeNum @@ -151,9 +149,8 @@ makeReverser rev = fmap (\f len srcPtr dstPtr -> f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $- fmap derefMixPtr $ Exec.compileModule $- createNamedFunction ExternalLinkage "reverse" $ \ size ptrA ptrB -> do+ Exec.createFunction derefMixPtr "reverse" $ \ size ptrA ptrB -> do ptrAEnd <- getElementPtr ptrA (size, ()) _ <- arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do ptrAj1 <- getElementPtr ptrAj0 (-1 :: Int32, ())@@ -280,9 +277,8 @@ value -> IO (Word32 -> Ptr a -> IO ()) fillBuffer x = fmap (\f len ptr -> f len (Memory.castStorablePtr ptr)) $- fmap derefFillPtr $ Exec.compileModule $- createNamedFunction ExternalLinkage "constantfill" $ \ size ptr -> do+ Exec.createFunction derefFillPtr "constantfill" $ \ size ptr -> do arrayLoop size ptr () $ \ ptri () -> do Memory.store x ptri return ()@@ -299,9 +295,8 @@ makeMixer add = fmap (\f len srcPtr dstPtr -> f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $- fmap derefMixPtr $ Exec.compileModule $- createNamedFunction ExternalLinkage "mix" $ \ size srcPtr dstPtr -> do+ Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr -> do _ <- arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do y <- Memory.load srcPtri Memory.modify (add y) dstPtri
synthesizer-llvm.cabal view
@@ -1,5 +1,5 @@ Name: synthesizer-llvm-Version: 0.7.0.1+Version: 0.8 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -38,9 +38,11 @@ The module Synthesizer.LLVM.LAC2011 should be especially useful for an introduction. Stability: Experimental-Tested-With: GHC==7.4.1, GHC==7.6.3, GHC==7.8.1+Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1 Cabal-Version: >=1.14 Build-Type: Simple+Extra-Source-Files:+ Changes.md Flag buildExamples description: Build example executables@@ -55,7 +57,7 @@ default: True Source-Repository this- Tag: 0.7.0.1+ Tag: 0.8 Type: darcs Location: http://code.haskell.org/synthesizer/llvm/ @@ -66,13 +68,13 @@ Library Build-Depends:- llvm-extra >=0.6 && <0.7,+ llvm-extra >=0.7 && <0.8, -- llvm must be imported with restrictive version bounds, -- because we import implicitly and unqualified- llvm-tf >=3.0.3 && <3.0.4,+ llvm-tf >=3.1 && <3.1.1, tfp >=1.0 && <1.1,- vault >=0.1 && <0.3,- synthesizer-core >=0.7.1 && <0.8,+ vault >=0.3 && <0.4,+ synthesizer-core >=0.8 && <0.9, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3, storable-record >=0.0.3 && <0.1,@@ -82,13 +84,13 @@ unsafe >=0.0 && <0.1, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,- non-empty >=0.2.1 && <0.3,+ non-empty >=0.2.1 && <0.4, event-list >=0.1 && <0.2,- filepath >=1.1 && <1.4,- random >=1.0 && <1.1,+ pathtype >=0.8 && <0.9,+ random >=1.0 && <1.2, containers >=0.1 && <0.6,- transformers >=0.2 && <0.5,- utility-ht >=0.0.10 && <0.1+ transformers >=0.2 && <0.6,+ utility-ht >=0.0.12 && <0.1 Build-Depends: -- base-4 needed for Control.Category@@ -97,25 +99,29 @@ Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000 Hs-source-dirs: src Exposed-Modules: Synthesizer.LLVM.Simple.Signal Synthesizer.LLVM.Simple.SignalPacked Synthesizer.LLVM.Simple.Value- Synthesizer.LLVM.Simple.Vanilla Synthesizer.LLVM.Parameterized.Signal Synthesizer.LLVM.Parameterized.SignalPacked- -- Synthesizer.LLVM.Parameterized.Value Synthesizer.LLVM.Parameter Synthesizer.LLVM.Storable.Signal Synthesizer.LLVM.Storable.Process Synthesizer.LLVM.Causal.Process Synthesizer.LLVM.Causal.ProcessValue Synthesizer.LLVM.Causal.ProcessPacked+ Synthesizer.LLVM.Causal.Controlled+ Synthesizer.LLVM.Causal.ControlledPacked Synthesizer.LLVM.CausalParameterized.Process Synthesizer.LLVM.CausalParameterized.ProcessValue Synthesizer.LLVM.CausalParameterized.ProcessPacked@@ -123,7 +129,10 @@ 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.Fold Synthesizer.LLVM.Plug.Input Synthesizer.LLVM.Plug.Output Synthesizer.LLVM.Filter.Allpass@@ -139,14 +148,12 @@ Synthesizer.LLVM.Filter.Universal Synthesizer.LLVM.Filter.NonRecursive Synthesizer.LLVM.Generator.Exponential2- Synthesizer.LLVM.RingBuffer- Synthesizer.LLVM.RingBufferForward Synthesizer.LLVM.Interpolation- Synthesizer.LLVM.ConstantPiece Synthesizer.LLVM.Frame.SerialVector Synthesizer.LLVM.Frame Synthesizer.LLVM.Frame.Stereo Synthesizer.LLVM.Frame.StereoInterleaved+ Synthesizer.LLVM.Frame.Binary Synthesizer.LLVM.Complex Synthesizer.LLVM.Wave Synthesizer.LLVM.MIDI@@ -156,19 +163,22 @@ Synthesizer.LLVM.Server.CausalPacked.Instrument Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug Synthesizer.LLVM.Server.CausalPacked.Speech- Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.SampledSound Synthesizer.LLVM.Server.Common Synthesizer.LLVM.Server.CommonPacked Other-Modules:+ Synthesizer.LLVM.ConstantPiece+ Synthesizer.LLVM.ForeignPtr Synthesizer.LLVM.Random Synthesizer.LLVM.EventIterator Synthesizer.LLVM.Storable.Vector Synthesizer.LLVM.Storable.ChunkIterator Synthesizer.LLVM.Storable.LazySizeIterator- Synthesizer.LLVM.Causal.ProcessPrivate+ Synthesizer.LLVM.RingBuffer+ Synthesizer.LLVM.Simple.SignalPrivate Synthesizer.LLVM.Parameterized.SignalPrivate+ Synthesizer.LLVM.Causal.ProcessPrivate Synthesizer.LLVM.CausalParameterized.ProcessPrivate Synthesizer.LLVM.Debug.Counter Synthesizer.LLVM.Debug.StablePtr@@ -177,8 +187,55 @@ Synthesizer.LLVM.Execution -- shall be removed when Foreign.Marshal.Alloc is fixed Synthesizer.LLVM.Alloc+ -- experimental+ Synthesizer.LLVM.Simple.Vanilla+ -- Synthesizer.LLVM.Parameterized.Value Executable synthi-llvm-example+ If flag(buildExamples)+ Build-Depends:+ synthesizer-llvm,++ llvm-extra,+ llvm-tf,+ tfp,+ synthesizer-core,+ synthesizer-midi >=0.6 && <0.7,+ midi >=0.2.1 && <0.3,+ storable-record >=0.0.2 && <0.1,+ storable-tuple >=0.0.2 && <0.1,+ sox >=0.2 && <0.3,+ storablevector >=0.2.6 && <0.3,+ numeric-prelude >=0.3 && <0.5,+ non-negative >=0.1 && <0.2,+ event-list >=0.1 && <0.2,+ random,+ containers >=0.1 && <0.6,+ transformers,+ non-empty,+ utility-ht,+ pathtype,+ base >=4 && <5+ Else+ Buildable: False+ Default-Language: Haskell98+ GHC-Options: -Wall+ GHC-Prof-Options: -auto-all+ If impl(ghc>=7.0)+ GHC-Options: -fwarn-unused-do-bind+ CPP-Options: -DNoImplicitPrelude=RebindableSyntax+ Default-Extensions: CPP+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000+ Hs-Source-Dirs: example, server+ Main-Is: Synthesizer/LLVM/Test.hs+ Other-Modules:+ Synthesizer.LLVM.LAC2011+ Synthesizer.LLVM.Server.Default++Executable synthi-llvm-lndw If flag(buildExamples) && flag(alsa) Build-Depends: synthesizer-llvm,@@ -196,12 +253,12 @@ numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2,- random >=1.0 && <1.1,+ random, containers >=0.1 && <0.6, transformers,- non-empty >=0.2 && <0.3,+ non-empty, utility-ht,- filepath,+ pathtype, synthesizer-alsa >=0.5 && <0.6, alsa-pcm >=0.6 && <0.7,@@ -212,13 +269,16 @@ GHC-Options: -Wall GHC-Prof-Options: -auto-all If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000 Hs-Source-Dirs: example- Main-Is: Synthesizer/LLVM/Test.hs+ Main-Is: Synthesizer/LLVM/TestALSA.hs Other-Modules:- Synthesizer.LLVM.LAC2011 Synthesizer.LLVM.LNdW2011 Executable synthi-llvm-alsa@@ -238,7 +298,8 @@ numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2,- filepath >=1.1 && <1.4,+ pathtype >=0.8 && <0.9,+ optparse-applicative >=0.11 && <0.13, containers >=0.1 && <0.6, transformers, utility-ht,@@ -256,10 +317,14 @@ GHC-Options: -rtsopts GHC-Prof-Options: -auto-all If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP- Hs-Source-Dirs: alsa+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000+ Hs-Source-Dirs: alsa, server Main-Is: Synthesizer/LLVM/Server.hs Other-Modules: Synthesizer.LLVM.Server.Packed.Test@@ -268,8 +333,11 @@ Synthesizer.LLVM.Server.Scalar.Run Synthesizer.LLVM.Server.CausalPacked.Run Synthesizer.LLVM.Server.CausalPacked.Test+ Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.ALSA Synthesizer.LLVM.Server.Option+ Synthesizer.LLVM.Server.OptionCommon+ Synthesizer.LLVM.Server.Default Executable synthi-llvm-jack If flag(buildExamples) && flag(jack)@@ -289,10 +357,11 @@ storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,- random >=1.0 && <1.1,+ random, explicit-exception >=0.1.7 && <0.2, event-list >=0.1 && <0.2,- filepath >=1.1 && <1.4,+ pathtype >=0.8 && <0.9,+ optparse-applicative >=0.11 && <0.13, containers >=0.1 && <0.6, transformers, utility-ht,@@ -310,10 +379,13 @@ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP- Hs-Source-Dirs: jack+ Hs-Source-Dirs: jack, server Main-Is: Synthesizer/LLVM/Server/JACK.hs Other-Modules:+ Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.Option+ Synthesizer.LLVM.Server.OptionCommon+ Synthesizer.LLVM.Server.Default Executable synthi-llvm-render If flag(buildExamples)@@ -334,7 +406,8 @@ non-negative >=0.1 && <0.2, explicit-exception >=0.1.7 && <0.2, event-list >=0.1 && <0.2,- filepath >=1.1 && <1.4,+ pathtype >=0.8 && <0.9,+ optparse-applicative >=0.11 && <0.13, containers >=0.1 && <0.6, transformers, utility-ht,@@ -352,10 +425,13 @@ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP- Hs-Source-Dirs: render+ Hs-Source-Dirs: render, server Main-Is: Synthesizer/LLVM/Server/Render.hs Other-Modules:+ Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.Option+ Synthesizer.LLVM.Server.OptionCommon+ Synthesizer.LLVM.Server.Default Executable synthi-llvm-sample If flag(buildExamples)@@ -363,8 +439,10 @@ gnuplot >=0.5 && <0.6, synthesizer-llvm, synthesizer-core,+ midi, numeric-prelude, storablevector,+ pathtype, utility-ht, base >=4 && <5 Else@@ -372,16 +450,21 @@ Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000+ Hs-Source-Dirs: ., server Main-Is: src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs Executable synthi-llvm-speech If flag(buildExamples) Build-Depends: gnuplot >=0.5 && <0.6,- filepath,+ pathtype, sox, synthesizer-llvm, synthesizer-core,@@ -394,9 +477,13 @@ Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000 Main-Is: src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs Test-Suite synthi-llvm-test@@ -410,7 +497,7 @@ synthesizer-core, storablevector >=0.2.6 && <0.3, numeric-prelude >=0.3 && <0.5,- random >=1.0 && <1.1,+ random, utility-ht, QuickCheck >=1 && <3,@@ -418,9 +505,13 @@ Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0)- GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000+ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP+ If impl(ghc<8.0)+ GHC-Options: -fcontext-stack=1000+ Else+ GHC-Options: -freduction-depth=1000 Hs-Source-Dirs: testsuite Main-Is: Test/Main.hs Other-Modules:
testsuite/Test/Synthesizer/LLVM/Helix.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} module Test.Synthesizer.LLVM.Helix (tests) where @@ -73,6 +75,7 @@ phaseParam = arr $ snd.fst noiseParam = arr $ snd.snd period = rangeFromInt (1,32::Float) <<^ fst.snd+ noise :: Param.T p Word32 -> SigP.T p (Value Float) noise seed = CausalP.take (pure len) $* SigP.noise seed 1 static =
testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs view
@@ -3,7 +3,7 @@ module Test.Synthesizer.LLVM.RingBufferForward (tests) where import qualified Synthesizer.LLVM.Parameter as Param-import qualified Synthesizer.LLVM.RingBufferForward as RingBuffer+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 (($*), )