diff --git a/Changes.md b/Changes.md new file mode 100644 --- /dev/null +++ b/Changes.md @@ -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. diff --git a/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs b/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs --- a/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs +++ b/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs @@ -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 diff --git a/alsa/Synthesizer/LLVM/Server/Option.hs b/alsa/Synthesizer/LLVM/Server/Option.hs --- a/alsa/Synthesizer/LLVM/Server/Option.hs +++ b/alsa/Synthesizer/LLVM/Server/Option.hs @@ -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 - fmap (\size -> flags{chunkSize = SVL.ChunkSize $ fromInteger size}) $ - parseNumber "blocksize" (\n -> 0 - 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" diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs --- a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs +++ b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs @@ -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)) diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Test.hs b/alsa/Synthesizer/LLVM/Server/Packed/Test.hs --- a/alsa/Synthesizer/LLVM/Server/Packed/Test.hs +++ b/alsa/Synthesizer/LLVM/Server/Packed/Test.hs @@ -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 diff --git a/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs b/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs --- a/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs +++ b/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs @@ -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 #-} diff --git a/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs b/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs --- a/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs +++ b/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs @@ -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] $ diff --git a/example/Synthesizer/LLVM/LAC2011.hs b/example/Synthesizer/LLVM/LAC2011.hs --- a/example/Synthesizer/LLVM/LAC2011.hs +++ b/example/Synthesizer/LLVM/LAC2011.hs @@ -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 diff --git a/example/Synthesizer/LLVM/LNdW2011.hs b/example/Synthesizer/LLVM/LNdW2011.hs --- a/example/Synthesizer/LLVM/LNdW2011.hs +++ b/example/Synthesizer/LLVM/LNdW2011.hs @@ -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 <- diff --git a/example/Synthesizer/LLVM/Test.hs b/example/Synthesizer/LLVM/Test.hs --- a/example/Synthesizer/LLVM/Test.hs +++ b/example/Synthesizer/LLVM/Test.hs @@ -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 diff --git a/example/Synthesizer/LLVM/TestALSA.hs b/example/Synthesizer/LLVM/TestALSA.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/TestALSA.hs @@ -0,0 +1,7 @@ +module Main where + +import qualified Synthesizer.LLVM.LNdW2011 as LNdW + + +main :: IO () +main = LNdW.flyPacked diff --git a/jack/Synthesizer/LLVM/Server/JACK.hs b/jack/Synthesizer/LLVM/Server/JACK.hs --- a/jack/Synthesizer/LLVM/Server/JACK.hs +++ b/jack/Synthesizer/LLVM/Server/JACK.hs @@ -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)) diff --git a/jack/Synthesizer/LLVM/Server/Option.hs b/jack/Synthesizer/LLVM/Server/Option.hs --- a/jack/Synthesizer/LLVM/Server/Option.hs +++ b/jack/Synthesizer/LLVM/Server/Option.hs @@ -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" diff --git a/render/Synthesizer/LLVM/Server/Option.hs b/render/Synthesizer/LLVM/Server/Option.hs --- a/render/Synthesizer/LLVM/Server/Option.hs +++ b/render/Synthesizer/LLVM/Server/Option.hs @@ -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 - fmap (\size -> flags{chunkSize = SVL.ChunkSize $ fromInteger size}) $ - parseNumber "blocksize" (\n -> 0 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" diff --git a/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs new file mode 100644 --- /dev/null +++ b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs @@ -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]) diff --git a/server/Synthesizer/LLVM/Server/Default.hs b/server/Synthesizer/LLVM/Server/Default.hs new file mode 100644 --- /dev/null +++ b/server/Synthesizer/LLVM/Server/Default.hs @@ -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" diff --git a/server/Synthesizer/LLVM/Server/OptionCommon.hs b/server/Synthesizer/LLVM/Server/OptionCommon.hs new file mode 100644 --- /dev/null +++ b/server/Synthesizer/LLVM/Server/OptionCommon.hs @@ -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 + 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 + 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) diff --git a/src/Synthesizer/LLVM/Alloc.hs b/src/Synthesizer/LLVM/Alloc.hs --- a/src/Synthesizer/LLVM/Alloc.hs +++ b/src/Synthesizer/LLVM/Alloc.hs @@ -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 = diff --git a/src/Synthesizer/LLVM/Causal/Controlled.hs b/src/Synthesizer/LLVM/Causal/Controlled.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/Controlled.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Causal/ControlledPacked.hs b/src/Synthesizer/LLVM/Causal/ControlledPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Causal/ControlledPacked.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Causal/Process.hs b/src/Synthesizer/LLVM/Causal/Process.hs --- a/src/Synthesizer/LLVM/Causal/Process.hs +++ b/src/Synthesizer/LLVM/Causal/Process.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Causal/ProcessPacked.hs b/src/Synthesizer/LLVM/Causal/ProcessPacked.hs --- a/src/Synthesizer/LLVM/Causal/ProcessPacked.hs +++ b/src/Synthesizer/LLVM/Causal/ProcessPacked.hs @@ -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)) <- diff --git a/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs b/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs --- a/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs +++ b/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs @@ -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)) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs b/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Controlled.hs @@ -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 diff --git a/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs b/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs --- a/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs @@ -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) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Functional.hs b/src/Synthesizer/LLVM/CausalParameterized/Functional.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Functional.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Functional.hs @@ -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) diff --git a/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs b/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs --- a/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs @@ -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, ) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Helix.hs b/src/Synthesizer/LLVM/CausalParameterized/Helix.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Helix.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Helix.hs @@ -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, ())) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Process.hs b/src/Synthesizer/LLVM/CausalParameterized/Process.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Process.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Process.hs @@ -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 :: diff --git a/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs b/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs --- a/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs @@ -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 diff --git a/src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs b/src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs @@ -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 diff --git a/src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs b/src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs @@ -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 diff --git a/src/Synthesizer/LLVM/ConstantPiece.hs b/src/Synthesizer/LLVM/ConstantPiece.hs --- a/src/Synthesizer/LLVM/ConstantPiece.hs +++ b/src/Synthesizer/LLVM/ConstantPiece.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Execution.hs b/src/Synthesizer/LLVM/Execution.hs --- a/src/Synthesizer/LLVM/Execution.hs +++ b/src/Synthesizer/LLVM/Execution.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Filter/Chebyshev.hs b/src/Synthesizer/LLVM/Filter/Chebyshev.hs --- a/src/Synthesizer/LLVM/Filter/Chebyshev.hs +++ b/src/Synthesizer/LLVM/Filter/Chebyshev.hs @@ -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 $ diff --git a/src/Synthesizer/LLVM/Filter/NonRecursive.hs b/src/Synthesizer/LLVM/Filter/NonRecursive.hs --- a/src/Synthesizer/LLVM/Filter/NonRecursive.hs +++ b/src/Synthesizer/LLVM/Filter/NonRecursive.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Filter/SecondOrder.hs b/src/Synthesizer/LLVM/Filter/SecondOrder.hs --- a/src/Synthesizer/LLVM/Filter/SecondOrder.hs +++ b/src/Synthesizer/LLVM/Filter/SecondOrder.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs b/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs --- a/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs +++ b/src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Filter/Universal.hs b/src/Synthesizer/LLVM/Filter/Universal.hs --- a/src/Synthesizer/LLVM/Filter/Universal.hs +++ b/src/Synthesizer/LLVM/Filter/Universal.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Fold.hs b/src/Synthesizer/LLVM/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Fold.hs @@ -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) diff --git a/src/Synthesizer/LLVM/ForeignPtr.hs b/src/Synthesizer/LLVM/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/ForeignPtr.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Frame/Binary.hs b/src/Synthesizer/LLVM/Frame/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/Binary.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Parameter.hs b/src/Synthesizer/LLVM/Parameter.hs --- a/src/Synthesizer/LLVM/Parameter.hs +++ b/src/Synthesizer/LLVM/Parameter.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Parameterized/Signal.hs b/src/Synthesizer/LLVM/Parameterized/Signal.hs --- a/src/Synthesizer/LLVM/Parameterized/Signal.hs +++ b/src/Synthesizer/LLVM/Parameterized/Signal.hs @@ -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) $ diff --git a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs --- a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +++ b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs @@ -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 ()) diff --git a/src/Synthesizer/LLVM/RingBuffer.hs b/src/Synthesizer/LLVM/RingBuffer.hs --- a/src/Synthesizer/LLVM/RingBuffer.hs +++ b/src/Synthesizer/LLVM/RingBuffer.hs @@ -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) diff --git a/src/Synthesizer/LLVM/RingBufferForward.hs b/src/Synthesizer/LLVM/RingBufferForward.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/RingBufferForward.hs +++ /dev/null @@ -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 diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +++ /dev/null @@ -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]) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs --- a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs @@ -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)) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs b/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs --- a/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs +++ b/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs @@ -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, diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs --- a/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs @@ -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") diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs b/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs --- a/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs +++ b/src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs --- a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs +++ b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs @@ -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 -> {- diff --git a/src/Synthesizer/LLVM/Server/SampledSound.hs b/src/Synthesizer/LLVM/Server/SampledSound.hs --- a/src/Synthesizer/LLVM/Server/SampledSound.hs +++ b/src/Synthesizer/LLVM/Server/SampledSound.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs b/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs --- a/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs +++ b/src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs b/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs --- a/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs +++ b/src/Synthesizer/LLVM/Server/Scalar/Instrument.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Simple/Signal.hs b/src/Synthesizer/LLVM/Simple/Signal.hs --- a/src/Synthesizer/LLVM/Simple/Signal.hs +++ b/src/Synthesizer/LLVM/Simple/Signal.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Simple/SignalPacked.hs b/src/Synthesizer/LLVM/Simple/SignalPacked.hs --- a/src/Synthesizer/LLVM/Simple/SignalPacked.hs +++ b/src/Synthesizer/LLVM/Simple/SignalPacked.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Simple/SignalPrivate.hs b/src/Synthesizer/LLVM/Simple/SignalPrivate.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Simple/SignalPrivate.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Simple/Value.hs b/src/Synthesizer/LLVM/Simple/Value.hs --- a/src/Synthesizer/LLVM/Simple/Value.hs +++ b/src/Synthesizer/LLVM/Simple/Value.hs @@ -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, ) diff --git a/src/Synthesizer/LLVM/Storable/Signal.hs b/src/Synthesizer/LLVM/Storable/Signal.hs --- a/src/Synthesizer/LLVM/Storable/Signal.hs +++ b/src/Synthesizer/LLVM/Storable/Signal.hs @@ -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 diff --git a/synthesizer-llvm.cabal b/synthesizer-llvm.cabal --- a/synthesizer-llvm.cabal +++ b/synthesizer-llvm.cabal @@ -1,5 +1,5 @@ Name: synthesizer-llvm -Version: 0.7.0.1 +Version: 0.8 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -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: diff --git a/testsuite/Test/Synthesizer/LLVM/Helix.hs b/testsuite/Test/Synthesizer/LLVM/Helix.hs --- a/testsuite/Test/Synthesizer/LLVM/Helix.hs +++ b/testsuite/Test/Synthesizer/LLVM/Helix.hs @@ -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 = diff --git a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs --- a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs +++ b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs @@ -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 (($*), )