diff --git a/alsa/Synthesizer/LLVM/Server.hs b/alsa/Synthesizer/LLVM/Server.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server.hs @@ -0,0 +1,82 @@ +module Main where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Test as ServerCausalTest +import qualified Synthesizer.LLVM.Server.CausalPacked.Run as ServerCausal +import qualified Synthesizer.LLVM.Server.Packed.Test as ServerPackedTest +import qualified Synthesizer.LLVM.Server.Packed.Run as ServerPacked +import qualified Synthesizer.LLVM.Server.Scalar.Test as ServerScalarTest +import qualified Synthesizer.LLVM.Server.Scalar.Run as ServerScalar + +import qualified LLVM.Core as LLVM + + +part :: Int +part = 106 + +main :: IO () +main = + LLVM.initializeNativeTarget >> + case part of + 000 -> ServerScalar.pitchBend + 001 -> ServerScalar.frequencyModulation + 002 -> ServerScalar.keyboard + 003 -> ServerScalar.keyboardStereo + 004 -> ServerScalar.keyboardMulti + 005 -> ServerScalar.keyboardStereoMulti + 100 -> ServerPacked.frequencyModulation + 101 -> ServerPacked.keyboard + 102 -> ServerPacked.keyboardStereo + 103 -> ServerPacked.keyboardFM + 104 -> ServerPacked.keyboardFMMulti + 105 -> ServerPacked.keyboardDetuneFM + 106 -> ServerPacked.keyboardFilter -- there is still a leak when playing for a long time with arcStrings + 150 -> ServerCausal.keyboard + 151 -> ServerCausal.keyboardFM + 152 -> ServerCausal.keyboardDetuneFM + 153 -> ServerCausal.keyboardMultiChannel + 154 -> ServerCausal.voder + 155 -> ServerCausal.formant + 200 -> ServerScalarTest.pitchBend0 + 201 -> ServerScalarTest.pitchBend1 + 202 -> ServerScalarTest.pitchBend2 + 203 -> ServerScalarTest.sequencePress + 300 -> ServerPackedTest.adsr + 301 -> ServerPackedTest.sequencePlain + 302 -> ServerPackedTest.sequenceLLVM + 303 -> ServerPackedTest.sequencePitchBendCycle + 304 -> ServerPackedTest.sequencePitchBendSimple + 305 -> ServerPackedTest.sequencePitchBend + 306 -> ServerPackedTest.sequenceModulated + 307 -> ServerPackedTest.sequencePress + 308 -> ServerPackedTest.sequenceModulatedLong + 309 -> ServerPackedTest.sequenceModulatedLongFM + 310 -> ServerPackedTest.sequenceModulatedRepeat + 311 -> ServerPackedTest.sequenceSample + 312 -> ServerPackedTest.sequenceSample1 -- leak +-- 313 -> ServerPackedTest.testSequenceSample1a -- leak + 320 -> ServerPackedTest.sequenceSample2 -- leak + 321 -> ServerPackedTest.sequenceSample3 -- leak + 322 -> ServerPackedTest.sequenceSample4 -- leak + 323 -> ServerPackedTest.sequenceFM1 -- leak + 324 -> ServerPackedTest.bellNoiseStereoTest + 400 -> ServerCausalTest.render + 401 -> ServerCausalTest.sequenceNothing + 402 -> ServerCausalTest.sequenceSingleLong + 403 -> ServerCausalTest.sequenceSingleShort + 404 -> ServerCausalTest.sequenceLoop + 405 -> ServerCausalTest.sequenceStaccato + 406 -> ServerCausalTest.sequenceControlled + 407 -> ServerCausalTest.sequenceControlledModulated + 409 -> ServerCausalTest.functional + 410 -> ServerCausalTest.functionalPlug + 411 -> ServerCausalTest.functionalTine >> + ServerCausalTest.functionalPlugTine + 412 -> ServerCausalTest.sampledSound + 413 -> ServerCausalTest.sampledSoundCrash + 414 -> ServerCausalTest.sampledSoundMono + 415 -> ServerCausalTest.frequencyModulation + 416 -> ServerCausalTest.frequencyModulationIO + 417 -> ServerCausalTest.frequencyModulationStrictIO + 418 -> ServerCausalTest.frequencyModulationSawIO + 419 -> ServerCausalTest.envelopeIO + _ -> error "not implemented server part" diff --git a/alsa/Synthesizer/LLVM/Server/ALSA.hs b/alsa/Synthesizer/LLVM/Server/ALSA.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/ALSA.hs @@ -0,0 +1,165 @@ +module Synthesizer.LLVM.Server.ALSA ( + Output, + play, playChunk, + record, + put, + startMessage, + makeNote, + ) where + +import qualified Synthesizer.LLVM.Server.Option as Option + +import qualified Synthesizer.ALSA.CausalIO.Process as PIO + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Time as Time +import qualified Sound.ALSA.Sequencer.RealTime as RealTime + +import qualified Sound.ALSA.PCM.Node.ALSA as PCM +import qualified Sound.ALSA.PCM.Parameters.Software as SwParam +import qualified Sound.ALSA.PCM.Parameters.Hardware as HwParam + +import qualified Synthesizer.Storable.Signal as SigSt + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.Base as SVB + +import qualified Algebra.Additive as Additive + +import Control.Functor.HT (void, ) + +import qualified System.IO as IO + +-- import NumericPrelude.Numeric (zero, round, ) + +import Prelude hiding (Real, round, ) + + +getOptParams :: Option.T -> h -> ((PCM.Size, PCM.SampleFreq), h) +getOptParams opt h = + ((case Option.chunkSize opt of SVL.ChunkSize size -> size, + case Option.sampleRate opt of + Nothing -> 44100 + Just (Option.SampleRate rate) -> rate), + h) + + +type Output handle signal a = Option.T -> PIO.Output handle signal a + +record :: + (PCM.SampleFmt y) => + FilePath -> Output IO.Handle (SigSt.T y) () +record name opt = + (fmap (getOptParams opt) $ IO.openFile name IO.WriteMode, + IO.hClose, + SVL.hPut) + +put :: (Show signal) => Output () signal () +put opt = + (return $ getOptParams opt (), + return, + \() -> print) + + +playChunk :: + (Additive.C y, PCM.SampleFmt y) => + Output (PCM.Handle HwParam.Interleaved y) (SVB.Vector y) () +playChunk opt = + (openPCM opt, closePCM, write) + + +-- ToDo: do not record the empty chunk that is inserted for latency +{-# INLINE play #-} +play :: + (Additive.C y, PCM.SampleFmt y) => + Output (PCM.Handle HwParam.Interleaved y) (SigSt.T y) () +play opt = + (openPCM opt, closePCM, \h -> mapM_ (write h) . SVL.chunks) +{- + Play.auto (Play.makeSink + (Option.device opts) (Option.periodTime opts) (round rate)) . + SigSt.append (SigSt.replicate (Option.chunkSize opts) (Option.latency opts) zero) +-- FiltG.delayPosLazySize (Option.chunkSize opts) (Option.latency opts) +-- FiltG.delayPos (Option.latency opts) +-} + + +putLog :: String -> IO () +putLog = putStrLn + +openPCM :: + (PCM.Access i, PCM.SampleFmt y) => + Option.T -> + IO ((PCM.Size, PCM.SampleFreq), PCM.Handle i y) +openPCM opt = do + putLog "alsaOpen" + (((bufferSize,periodSize),(bufferTime,periodTime),sampleRate), h) <- + PCM.open (PCM.modes []) PCM.StreamPlayback + (setHwParams (Option.sampleRate opt) (Option.chunkSize opt)) + (\q@(sizes,_,_) -> do + uncurry SwParam.setBufferSize sizes + return q) + (Option.device opt) + PCM.prepare h + putLog $ "bufferTime = " ++ show bufferTime + putLog $ "bufferSize = " ++ show bufferSize + putLog $ "periodTime = " ++ show periodTime + putLog $ "periodSize = " ++ show periodSize + return ((periodSize, sampleRate), h) + +closePCM :: PCM.Handle i y -> IO () +closePCM pcm = do + putLog "alsaClose" + PCM.drain pcm + PCM.close pcm + +setHwParams :: + Maybe (Option.SampleRate Int) -> + SVL.ChunkSize -> + HwParam.T i y ((PCM.Size,PCM.Size),(PCM.Time,PCM.Time),PCM.SampleFreq) + -- ^ ((bufferSize,periodSize),(bufferTime,periodTime),sampleRate) +setHwParams mrate (SVL.ChunkSize periodSize) = do + (actualRate,_) <- + case mrate of + Nothing -> do + HwParam.setRateResample False + HwParam.setRateNear 44100 EQ + Just (Option.SampleRate rate) -> do + HwParam.setRateResample True + HwParam.setRateNear rate EQ + (actualPeriodSize,_) <- + HwParam.setPeriodSizeNear periodSize EQ + actualBufferSize <- + HwParam.setBufferSizeNear + (max periodSize (actualPeriodSize*4)) + + (actualBufferTime,_) <- HwParam.getBufferTime + (actualPeriodTime,_) <- HwParam.getPeriodTime + return ((actualBufferSize, actualPeriodSize), + (actualBufferTime, actualPeriodTime), + actualRate) + +write :: + (PCM.SampleFmt y) => + PCM.Handle PCM.Interleaved y -> SVB.Vector y -> IO () +write h xs = + SVB.withStartPtr xs $ \buf -> + void . PCM.writeiRetry h buf . fromIntegral + + + +startMessage :: String +startMessage = + "run 'aconnect' to connect to the MIDI controller" + + +-- cf. synthesizer-alsa:Synthesizer.ALSA.Storable.Server.Test +makeNote :: Event.NoteEv -> Int -> Event.T +makeNote typ pit = + (Event.simple Addr.subscribers $ Event.NoteEv typ $ + Event.simpleNote (Event.Channel 0) + (Event.Pitch $ fromIntegral pit) Event.normalVelocity) + { Event.time = + Time.consAbs $ Time.Real $ RealTime.fromInteger 0 + } diff --git a/alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs b/alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/CausalPacked/Run.hs @@ -0,0 +1,179 @@ +module Synthesizer.LLVM.Server.CausalPacked.Run where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange +import Synthesizer.LLVM.Server.CausalPacked.Arrange + (StereoVector, controllerExponentialDim, (&+&), ) + +import qualified Sound.MIDI.Controller as Ctrl + +import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.ALSA (playChunk, startMessage, ) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt + +import qualified Data.StorableVector as SV + +import qualified Synthesizer.Zip as Zip + +import qualified Sound.ALSA.PCM as PCM + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import Control.Arrow (Arrow, (<<<), (^<<), arr, ) +import Control.Category (id, ) + +import qualified Number.DimensionTerm as DN + +import qualified Algebra.Additive as Additive + +{- +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky +-} + +import Prelude hiding (Real, id, ) + + + +playFromEvents :: + (PCM.SampleFmt a, Additive.C a) => + Option.T -> + (SampleRate Real -> + PIO.T (MIO.Events Event.T) (SV.Vector a)) -> + IO () +playFromEvents opt process = do + putStrLn startMessage + PAlsa.playFromEventsWithParams (playChunk opt) + (Option.clientName opt) + (\(_size,rate) -> + process (SampleRate $ fromIntegral rate)) + + +keyboard :: IO () +keyboard = do + opt <- Option.get + proc <- Arrange.keyboard + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStrict + <<< + proc (Option.channel opt) sampleRate + + +keyboardFM :: IO () +keyboardFM = do + opt <- Option.get + proc <- + Arrange.keyboardFM + (CausalP.mapSimple StereoInt.interleave) + (Option.channel opt) + playFromEvents opt $ \ sampleRate -> + SigStL.unpackStereoStrict ^<< proc sampleRate + +keyboardDetuneFMCore :: + Option.T -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> + PIO.T (MIO.Events Event.T) (SV.Vector StereoVector)) +keyboardDetuneFMCore opt = + Arrange.keyboardDetuneFMCore + (CausalP.mapSimple StereoInt.interleave) + (Option.sampleDirectory opt) + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + opt <- Option.get + proc <- keyboardDetuneFMCore opt + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc (Option.channel opt) (VoiceMsg.toProgram 0) sampleRate + +keyboardMultiChannel :: IO () +keyboardMultiChannel = do + opt <- Option.get + proc <- keyboardDetuneFMCore opt + mix <- CausalP.processIO CausalP.mix + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + foldl1 + (\x y -> mix () <<< Zip.arrowFanout x y) + (map + (\chan -> + proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0) + sampleRate) + [0 .. 3]) + + +voder :: IO () +voder = do + opt <- Option.get + proc <- + Arrange.voder + (CausalP.mapSimple StereoInt.interleave) + (Option.sampleDirectory opt) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate + + +formant :: IO () +formant = do + opt <- Option.get + proc <- + Arrange.keyboardDetuneFMCore id + (Option.sampleDirectory opt) + form <- Speech.filterFormant + mix <- CausalP.processIO CausalP.mix + interleave <- + CausalP.processIO + (CausalP.mapSimple StereoInt.interleave) + + playFromEvents opt $ \ sampleRate -> + arr SigStL.unpackStereoStrict + <<< + interleave () + <<< + foldl1 + (\x y -> mix () <<< Zip.arrowFanout x y) + (zipWith + (\n (freq, amp, reson) -> + form sampleRate + <<< + Zip.arrowFirst + (MCS.controllerExponential (Ctrl.fromInt $ 16+n) (0.01,1) amp + &+& + (MCS.controllerExponential (Ctrl.fromInt $ 26+n) (1,100) reson + &+& + controllerExponentialDim (Ctrl.fromInt $ 21+n) + (DN.frequency 100, DN.frequency 10000) + (DN.frequency freq)))) + [0..] + [( 650, 1.00, 30), + (1080, 0.25, 30), + (2650, 0.20, 30), + (2900, 0.16, 30), + (3250, 0.01, 30) + ]) + <<< + MCS.fromChannel (Option.channel opt) + &+& + proc (Option.channel opt) (VoiceMsg.toProgram 4) sampleRate diff --git a/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs b/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs @@ -0,0 +1,579 @@ +module Synthesizer.LLVM.Server.CausalPacked.Test where + +import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrFP +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 Synthesizer.LLVM.Server.CausalPacked.Arrange + ((&+&), shortTime, controllerExponentialDim, ) +import Synthesizer.LLVM.Server.CommonPacked + (Vector, ) +import Synthesizer.LLVM.Server.Common hiding + (Instrument, ) + +import qualified Sound.ALSA.Sequencer.Event as Event +-- import qualified Sound.ALSA.Sequencer.Connect as Connect +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Synthesizer.MIDI.Generic as Gen + +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 Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Synthesizer.CausalIO.Gate as Gate +import qualified Synthesizer.Zip as Zip + +import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa +import Synthesizer.MIDI.Storable (Instrument, ) + +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.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Process as CausalSt +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.Wave as Wave +import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<), ) + +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import Control.Arrow ((<<<), (<<^), (^<<), arr, first, ) +import Control.Category (id, ) +import Control.Applicative (pure, ) +import Control.Monad (when, ) +import Control.Monad.Trans.State (evalState, ) + +import qualified Data.Map as Map + +-- import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +-- import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import qualified Number.DimensionTerm as DN + +import Data.Word (Word8, Word32, ) +import Data.Int (Int32, ) + +import Foreign.Storable (Storable, ) +import qualified System.IO as IO +import Control.Exception (bracket, ) + +-- import NumericPrelude.Numeric (zero, round, (^?), ) +import Prelude hiding (Real, round, break, id, ) + + +sampleRate :: Option.SampleRate Real +sampleRate = Option.SampleRate Option.defaultSampleRate + +{- | +try to reproduce a space leak +-} +sequencePlain :: IO () +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)) $ + let evs = EventList.cons 10 ([]::[Event.T]) evs + in evs + + +-- see playFromEvents +writeTest :: + (CutG.Read t, Storable a) => + PIO.T t (SV.Vector a) -> [t] -> IO () +writeTest (PIO.Cons next create delete) evsChunky = + IO.withFile "/tmp/test.f32" IO.WriteMode $ \h -> + bracket create delete $ + let loop evs s0 = + case evs of + [] -> return () + chunk : rest -> do + (pcm, s1) <- next chunk s0 + SV.hPut h pcm + when + (CutG.length pcm >= CutG.length chunk) + (loop rest s1) + in loop evsChunky + +render :: IO () +render = do + ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky +-- ping <- Instr.ping -- not leaky + + writeTest (ping sampleRate 10 440) $ + replicate 10000 $ Gate.chunk 512 Nothing + +sequenceEvents :: [PAlsa.Events] -> IO () +sequenceEvents evs = do + arrange <- CausalSt.makeArranger + + ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky +-- ping <- Instr.ping -- not leaky + + let proc = + arrange + <<< + arr shortTime + <<< + MIO.sequenceCore + Option.defaultChannel + (\ _pgm -> ping sampleRate) + + writeTest proc evs + +sequenceNothing :: IO () +sequenceNothing = + sequenceEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) evs + + +noteEvent :: + Event.NoteEv -> + Word8 -> + Word8 -> + Word8 -> + Event.T +noteEvent mode chan pitch velocity = + -- Event.simple (Connect.toSubscribers Addr.subscribers) $ + Event.simple Addr.subscribers $ Event.NoteEv mode $ + Event.simpleNote + (Event.Channel $ fromIntegral chan) + (Event.Pitch $ fromIntegral pitch) + (Event.Velocity $ fromIntegral velocity) + +ctrlEvent :: + Word8 -> + Word32 -> + Int32 -> + Event.T +ctrlEvent chan cc cval = + -- Event.simple (Connect.toSubscribers Addr.subscribers) $ + Event.simple Addr.subscribers $ + Event.CtrlEv Event.Controller $ + Event.Ctrl + (Event.Channel $ fromIntegral chan) + (Event.Parameter $ fromIntegral cc) + (Event.Value $ fromIntegral cval) + +sequenceSingleLong :: IO () +sequenceSingleLong = do + sequenceEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs + +sequenceSingleShort :: IO () +sequenceSingleShort = do + sequenceEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ + EventList.cons 10 [noteEvent Event.NoteOff 0 60 64] evs + +{- +Although it consumes constant memory, +the memory usage is quite high, +e.g. 40MB for chunk size 100000 and peiod 1100. +This might be caused by the large overlapping in the release phases. +You need only 6MB heap for the same chunksize and period 11000. +-} +sequenceLoop :: IO () +sequenceLoop = do + sequenceEvents $ + let evs = + EventList.cons 11001 + [noteEvent Event.NoteOff 0 60 50, + noteEvent Event.NoteOn 0 60 50] evs + in chopEvents 100000 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs + +sequenceStaccato :: IO () +sequenceStaccato = do + sequenceEvents $ + let evs = + EventList.cons 551 [noteEvent Event.NoteOff 0 60 50] $ + EventList.cons 550 [noteEvent Event.NoteOn 0 60 50] evs + in chopEvents 100000 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs + + + +sequenceControlledEvents :: [PAlsa.Events] -> IO () +sequenceControlledEvents chunkedEvents = do + opt <- Option.get + arrange <- CausalSt.makeArranger + amp <- + CausalP.processIO + (CausalP.mapSimple StereoInt.interleave <<< + CausalP.envelopeStereo <<< + first (CausalP.mapSimple Serial.upsample)) + + ping <- Instr.pingStereoReleaseFM + + let 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) + + frequencyControlPercussive = + MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03 + + pingProc vel freq = + ping sampleRate vel freq + <<< + Zip.arrowSecond + (timeControlPercussive + &+& + ((MCS.controllerExponential controllerTimbre0 (0.3,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))) + + let proc = + arr SigStL.unpackStereoStrict + <<< + amp () + <<< + (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float) + <<^ Zip.second) + &+& + (arrange + <<< + arr shortTime + <<< + MIO.sequenceModulated + (Option.channel opt) (\ _pgm -> pingProc)) + <<< + id &+& MCS.fromChannel (Option.channel opt) + + writeTest proc chunkedEvents + + +sequenceControlled :: IO () +sequenceControlled = + sequenceControlledEvents $ + let evs = EventList.cons 10 [] evs + in chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs + +sequenceControlledModulated :: IO () +sequenceControlledModulated = + sequenceControlledEvents $ + chopEvents 512 $ + EventListTM.takeTime (10^(7::Int)) $ + EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ + EventList.fromPairList $ + map (\ev -> (10,[ev])) $ cycle $ + map (ctrlEvent 0 1) [0..127] + + +sampledSound :: IO () +sampledSound = do + opt <- Option.get + + amp <- + CausalP.processIO + (CausalP.mapSimple StereoInt.interleave) + + tomatoSmps <- + Instr.makeSampledSounds (Option.sampleDirectory opt) Sample.tomatensalat + + let tomato smp vel freq = + smp sampleRate vel freq + <<< + Zip.arrowSecond + (MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03) + + writeTest + (arr SigStL.unpackStereoStrict + <<< + amp () + <<< + tomato (last tomatoSmps) 0 440) $ + map + (\m -> + Zip.consChecked "Test.sampledSound" + (Gate.chunk 512 m) + (PCS.Cons Map.empty (EventListTT.pause 512))) $ + replicate 10 Nothing ++ + Just (100, VoiceMsg.normalVelocity) : + replicate 4 Nothing + +sampledSoundMono :: IO () +sampledSoundMono = do + opt <- Option.get + + case Sample.tomatensalat of + (name, positions, period) -> do + smp <- Sample.load (Option.sampleDirectory opt ++ "/" ++ name) + case Sample.parts (Sample.Cons smp (last positions) period) of + (_attack, _sustain, release) -> + SVL.writeFile "/tmp/release.f32" release + + tomatoSmps <- + Instr.makeSampledSoundsMono (Option.sampleDirectory opt) Sample.tomatensalat + + let tomato smp vel freq = + smp sampleRate vel freq + <<< + Zip.arrowSecond (MCS.bendWheelPressure 2 0.04 0.03) + + writeTest (tomato (last tomatoSmps) 0 220) $ + map + (\m -> + Zip.consChecked "Test.sampledSound" + (Gate.chunk 512 m) + (PCS.Cons Map.empty (EventListTT.pause 512))) $ + replicate 10 Nothing ++ + Just (256, VoiceMsg.normalVelocity) : + replicate 10 Nothing + +{- +This one crashes sometimes in LLVM-3.0 when optimizations are enabled. +-} +sampledSoundCrash :: IO () +sampledSoundCrash = do + opt <- Option.get + + amp <- + CausalP.processIO + (CausalP.mapSimple StereoInt.interleave) + + tomatoSmps <- + Instr.makeSampledSounds (Option.sampleDirectory opt) Sample.tomatensalat + + let tomato smp vel freq = + smp sampleRate vel freq + <<< + Zip.arrowSecond + (MCS.controllerLinear controllerDetune (0,0.005) 0.001 + &+& + MCS.bendWheelPressure 2 0.04 0.03) + + writeTest + (arr SigStL.unpackStereoStrict + <<< + amp () + <<< + tomato (head tomatoSmps) 0 440) $ + map + (\m -> + Zip.consChecked "Test.sampledSound" + (Gate.chunk 512 m) + (PCS.Cons Map.empty (EventListTT.pause 512))) $ + replicate 10 Nothing ++ + Just (100, VoiceMsg.normalVelocity) : + replicate 10 Nothing + + +lfo :: SVL.Vector Real +lfo = + SigP.renderChunky (SVL.chunkSize 512) + (1 + 0.1 * SigP.osciSimple Wave.approxSine2 (pure (0::Float)) 0.0001) + () + +asMono :: vector Real -> vector Real +asMono = id + +frequencyModulation :: IO () +frequencyModulation = do + opt <- Option.get + smp <- + case Sample.tomatensalat of + (name, _positions, _period) -> + Sample.load (Option.sampleDirectory opt ++ "/" ++ name) + + SVL.writeFile "/tmp/test.f32" . + asMono . + (\f -> f smp lfo) =<< + CausalP.runStorableChunky + (CausalP.frequencyModulationLinear $ + SigP.fromStorableVectorLazy id) + + +frequencyModulationIO :: IO () +frequencyModulationIO = do + opt <- Option.get + smp <- + case Sample.tomatensalat of + (name, _positions, _period) -> + Sample.load (Option.sampleDirectory opt ++ "/" ++ name) + + proc <- + CausalP.processIO + (CausalP.frequencyModulationLinear $ + SigP.fromStorableVectorLazy id) + + writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + +frequencyModulationStrictIO :: IO () +frequencyModulationStrictIO = do + opt <- Option.get + smp <- + case Sample.tomatensalat of + (name, _positions, _period) -> + Sample.load (Option.sampleDirectory opt ++ "/" ++ name) + + proc <- + CausalP.processIO + (CausalP.frequencyModulationLinear $ + SigP.fromStorableVector id) + + writeTest + (proc (SV.concat $ SVL.chunks smp) :: + PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + +frequencyModulationSawIO :: IO () +frequencyModulationSawIO = do + proc <- + CausalP.processIO + (CausalP.frequencyModulationLinear + (CausalP.take 50000 $* SigP.osciSaw 0 id)) + + writeTest (proc (0.01::Real) :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + +envelopeIO :: IO () +envelopeIO = do + opt <- Option.get + smp <- + case Sample.tomatensalat of + (name, _positions, _period) -> + Sample.load (Option.sampleDirectory opt ++ "/" ++ name) + + proc <- + CausalP.processIO + (CausalP.envelope $< SigP.fromStorableVectorLazy id) + + writeTest (proc smp :: PIO.T (SV.Vector Real) (SV.Vector Real)) $ + SVL.chunks lfo + + +functional :: IO () +functional = do + phaser <- + CausalP.processIO $ F.withArgs $ \ratio -> + let freq = frequency id + noise = + F.lift $ CausalP.fromSignal $ + SigP.noise 12 (recip freq) + in (1-ratio) * noise + + ratio * (CausalP.delay (pure (0::Float)) 100 F.$& noise) + + writeTest + (phaser (sampleRate, 200000) :: + PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $ + map (\y -> EventListBT.singleton y 10000) + [0, 0.25, 0.5, 0.75, 1.00] + + +functionalPlug :: IO () +functionalPlug = do + phaser <- + FP.withArgs $ \ratio0 -> + let freq = frequency id + ratio = FP.plug ratio0 + noise = FP.fromSignal $ SigP.noise 12 (recip freq) + in (1-ratio) * noise + + ratio * (CausalP.delay (pure (0::Float)) 100 FP.$& noise) + + writeTest + (phaser () (sampleRate, 200000) :: + PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) $ + map (\y -> EventListBT.singleton y 10000) + [0, 0.25, 0.5, 0.75, 1.00] + + +makeUnpackStereoStrict :: + IO (PIO.T (SV.Vector (Stereo.T Vector)) (SV.Vector (Stereo.T Real))) +makeUnpackStereoStrict = + fmap (\proc -> SigStL.unpackStereoStrict ^<< proc ()) $ + CausalP.processIO + (CausalP.mapSimple StereoInt.interleave) +{- +makeUnpackStereoStrict :: + IO (SV.Vector (Stereo.T Vector) -> SV.Vector (Stereo.T Real)) +makeUnpackStereoStrict = + SigStL.makeUnpackGenericStrict +-} + +functionalTine :: IO () +functionalTine = do + ping <- Instr.tineStereoFM + unpack <- makeUnpackStereoStrict + let cs = 512 + writeTest (unpack <<< ping sampleRate 0 440) $ + replicate 100 $ + Zip.Cons + (Gate.chunk 512 Nothing) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton (DN.time 1) cs) + (EventListBT.singleton (DN.time 1) cs)) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton 2 cs) + (EventListBT.singleton 1 cs)) + (Zip.Cons + (EventListBT.singleton 0.001 cs) + (EventListBT.singleton (BM.Cons 1 0.01) cs)))) + +functionalPlugTine :: IO () +functionalPlugTine = do + ping <- InstrFP.tineStereoFM + unpack <- makeUnpackStereoStrict + let cs = 512 + writeTest (unpack <<< ping sampleRate 0 440) $ + replicate 100 $ + Zip.Cons + (Gate.chunk 512 Nothing) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton (DN.time 1) cs) + (EventListBT.singleton (DN.time 1) cs)) + (Zip.Cons + (Zip.Cons + (EventListBT.singleton 2 cs) + (EventListBT.singleton 1 cs)) + (Zip.Cons + (EventListBT.singleton 0.001 cs) + (EventListBT.singleton (BM.Cons 1 0.01) cs)))) diff --git a/alsa/Synthesizer/LLVM/Server/Option.hs b/alsa/Synthesizer/LLVM/Server/Option.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Option.hs @@ -0,0 +1,168 @@ +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.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 Prelude hiding (Real, ) + + +data T = + Cons { + device :: Play.Device, + clientName :: ClientName, + channel, extraChannel :: ChannelMsg.Channel, + sampleDirectory :: FilePath, + sampleRate :: Maybe (SampleRate Int), + chunkSize :: SVL.ChunkSize, + latency :: Int + } + 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 + -- 256 + 1024 + + + +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" : + [] + + +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 diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs @@ -0,0 +1,493 @@ +module Synthesizer.LLVM.Server.Packed.Run where + +import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.ALSA (Output, play, startMessage, ) +import Synthesizer.LLVM.Server.CommonPacked + (Vector, VectorSize, vectorSize, stair, ) +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.ALSA.EventList as Ev +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Synthesizer.MIDI.EventList as MidiEv +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter + +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.MixedTime as EventListMT + +import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, ) +import Control.Arrow ((<<<), (^<<), arr, ) +import Control.Applicative (pure, {- liftA, liftA2, -} liftA3, (<*>), ) +import Control.Monad.Trans.State (evalState, ) + +import Control.Exception (bracket, ) + +{- +import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) + +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky +-} +import Algebra.IntegralDomain (divUp, ) + +import NumericPrelude.Numeric (zero, (^?), (+), ) +import Prelude hiding (Real, break, (+), ) + + + +{-# INLINE withMIDIEventsMono #-} +withMIDIEventsMono :: + Option.T -> + Output handle (SigSt.T Real) a -> + (SigSt.ChunkSize -> SampleRate Real -> + EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO a +withMIDIEventsMono opt output process = do + putStrLn startMessage + case output opt of + (open,close,write) -> + bracket open (close . snd) $ \((chunkSize,rate),h) -> + let rrate = fromIntegral rate :: Double + in Ev.withMIDIEvents + (Option.clientName opt) + (fromIntegral chunkSize / rrate) + (rrate / fromIntegral vectorSize) + (write h . + SigStL.unpack . + process (SigSt.chunkSize $ divUp chunkSize vectorSize) + (Option.SampleRate $ fromIntegral rate)) + +type StereoVector = StereoInt.T VectorSize Real + +{-# INLINE withMIDIEventsStereo #-} +withMIDIEventsStereo :: + Option.T -> + Output handle (SigSt.T (Stereo.T Real)) a -> + (SigSt.ChunkSize -> SampleRate Real -> + EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) -> + IO a +withMIDIEventsStereo opt output process = do + putStrLn startMessage + case output opt of + (open,close,write) -> + bracket open (close . snd) $ \((chunkSize,rate),h) -> + let rrate = fromIntegral rate :: Double + in Ev.withMIDIEvents + (Option.clientName opt) + (fromIntegral chunkSize / rrate) + (rrate / fromIntegral vectorSize) + (write h . + SigStL.unpackStereo . + process (SigSt.chunkSize $ divUp chunkSize vectorSize) + (Option.SampleRate $ fromIntegral rate)) + + +frequencyModulation :: IO () +frequencyModulation = do + opt <- Option.get + osc <- + SigP.runChunky + ((CausalPS.osciSimple WaveL.triangle $< zero) + $* Instr.frequencyFromBendModulation + (frequencyConst 10) + (Instr.modulation (\fm -> (fm,880)))) + withMIDIEventsMono opt play $ \vectorChunkSize sampleRate -> + osc vectorChunkSize . (,) sampleRate . + evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) + + + +keyboard :: IO () +keyboard = do + opt <- Option.get + sound <- Instr.pingRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalPS.amplify (arr id)) + arrange <- SigStL.makeArranger + withMIDIEventsMono opt play $ \vectorChunkSize sampleRate -> + (amp :: Real -> SigSt.T Vector -> SigSt.T Vector) 0.2 . + arrange vectorChunkSize . + evalState + (Gen.sequence (Option.channel opt) $ + sound vectorChunkSize sampleRate) + +keyboardStereo :: IO () +keyboardStereo = do + opt <- Option.get + sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + amp <- + CausalP.runStorableChunky + (CausalP.mapSimple StereoInt.interleave <<< + CausalPS.amplifyStereo (arr id)) + arrange <- SigStL.makeArranger + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 . + arrange vectorChunkSize . + evalState + (Gen.sequence (Option.channel opt) $ + sound vectorChunkSize sampleRate) + +keyboardFM :: IO () +keyboardFM = do + opt <- Option.get + str <- Instr.softStringFM + amp <- + CausalP.runStorableChunky + (CausalP.mapSimple StereoInt.interleave <<< + CausalPS.amplifyStereo (arr id)) + arrange <- SigStL.makeArranger + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 . + arrange vectorChunkSize . + evalState + (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 + Gen.sequenceModulated + fm (Option.channel opt) (flip str sampleRate)) + +keyboardFMMulti :: IO () +keyboardFMMulti = do + opt <- Option.get + str <- Instr.softStringFM + tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 + amp <- + CausalP.runStorableChunky + (CausalP.mapSimple StereoInt.interleave <<< + CausalPS.amplifyStereo (arr id)) + arrange <- SigStL.makeArranger + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 . + arrange vectorChunkSize . + evalState + (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 + Gen.sequenceModulatedMultiProgram + fm (Option.channel opt) + (VoiceMsg.toProgram 1) + (map (\sound fmlocal -> sound fmlocal $ sampleRate) + [str, tin vectorChunkSize])) + +controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, + controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 + :: VoiceMsg.Controller +controllerFMDepth1 = Ctrl.soundController3 +controllerFMDepth2 = Ctrl.soundController5 +controllerFMDepth3 = Ctrl.soundController7 +controllerFMDepth4 = Ctrl.soundController8 +controllerFMPartial1 = Ctrl.generalPurpose1 +controllerFMPartial2 = Ctrl.generalPurpose2 +controllerFMPartial3 = Ctrl.effect1Depth +controllerFMPartial4 = Ctrl.effect2Depth + +keyboardDetuneFMCore :: + FilePath -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SVL.ChunkSize -> SampleRate Real -> + MidiEv.Filter Event.T (SigSt.T StereoVector)) +keyboardDetuneFMCore smpDir = do + str0 <- Instr.softStringDetuneFM + ssh0 <- Instr.softStringShapeFM + css0 <- Instr.cosineStringStereoFM + asw0 <- Instr.arcSawStringStereoFM + asn0 <- Instr.arcSineStringStereoFM + asq0 <- Instr.arcSquareStringStereoFM + atr0 <- Instr.arcTriangleStringStereoFM + wnd0 <- Instr.wind + wnp0 <- Instr.windPhaser + fms0 <- Instr.fmStringStereoFM + tin0 <- Instr.tineStereoFM + tnc0 <- Instr.tineControlledFM + fnd0 <- Instr.fenderFM + tnb0 <- Instr.tineBankFM + rfm0 <- Instr.resonantFMSynth + png0 <- Instr.pingStereoRelease + pngFM0 <- Instr.pingStereoReleaseFM + sqr0 <- Instr.squareStereoReleaseFM + bel0 <- Instr.bellStereoFM + ben0 <- Instr.bellNoiseStereoFM + flt0 <- Instr.filterSawStereoFM + brs0 <- Instr.brass + tmt0 <- Instr.makeSampledSounds smpDir Sample.tomatensalat + hal0 <- Instr.makeSampledSounds smpDir Sample.hal + grp0 <- Instr.makeSampledSounds smpDir Sample.graphentheorie + + + arrange <- SigStL.makeArranger + amp <- + CausalP.runStorableChunky + (CausalP.mapSimple StereoInt.interleave <<< + CausalP.envelopeStereo $< + Instr.piecewiseConstantVector (arr id)) + return $ \chan pgm vcsize sr -> do + let + evHead = + fmap (EventListMT.switchBodyL + (error "empty controller stream") const) + flt = evalState $ + liftA6 (\rel -> flt0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (evHead $ + PCS.controllerExponential controllerTimbre0 (100,10000) 1000) + (evHead $ + PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + png = + (\rel -> png0 (4*rel) rel vcsize) . + evalState + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + pngFM = evalState $ + liftA6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (evHead $ + PCS.controllerLinear controllerTimbre0 (0,1) 1) + (PCS.controllerExponential controllerTimbre1 (1/pi,0.001) 0.05) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + sqr = evalState $ + liftA6 (\rel -> sqr0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) + (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + tin = evalState $ + liftA3 (\rel -> tin0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + tnc = evalState $ + liftA6 (\rel -> tnc0 (4*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (fmap (fmap stair) $ + PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) + (PCS.controllerLinear controllerTimbre1 (0,1.5) 1) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + fnd = evalState $ + pure (\rel -> fnd0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (fmap (fmap stair) $ + PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14) + <*> (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3) + <*> (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25) + <*> (pure vcsize) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + tnb = evalState $ + pure (\rel -> tnb0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0) + <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0) + <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1) + <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0) + <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0) + <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0) + <*> (pure vcsize) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + rfm = evalState $ + pure (\rel -> rfm0 (4*rel) rel) + <*> (evHead $ + PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) + <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + <*> (PCS.controllerExponential controllerTimbre1 (1,100) 30) + <*> (PCS.controllerLinear controllerTimbre0 (1,15) 3) + <*> (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1) + <*> (pure vcsize) + <*> (PCS.bendWheelPressure 2 0.04 0.03) + bel = evalState $ + liftA4 (\rel -> bel0 (2*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) + (PCS.controllerLinear controllerDetune (0,0.005) 0.001) + (pure vcsize) + (PCS.bendWheelPressure 2 0.05 0.02) + ben = evalState $ + liftA5 (\rel -> ben0 (2*rel) rel) + (evHead $ + PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) + (PCS.controllerLinear controllerTimbre0 (0,1) 0.3) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (pure vcsize) + (PCS.bendWheelPressure 2 0.05 0.02) + str = evalState $ + liftA3 str0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.bendWheelPressure 2 0.04 0.03) + ssh = evalState $ + liftA4 ssh0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) + (PCS.bendWheelPressure 2 0.04 0.03) + makeArc gen = evalState $ + liftA4 gen + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5) + (PCS.bendWheelPressure 2 0.04 0.03) + css = makeArc css0 + asw = makeArc asw0 + asn = makeArc asn0 + asq = makeArc asq0 + atr = makeArc atr0 + fms = evalState $ + liftA5 fms0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2) + (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1) + (PCS.bendWheelPressure 2 0.04 0.03) + wnd = evalState $ + liftA3 wnd0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 12 0.8 0) + wnp = evalState $ + liftA5 wnp0 + (evHead $ + PCS.controllerExponential controllerAttack (0.02,2) 0.5) + (PCS.controllerLinear controllerTimbre0 (0,1) 0.5) + (PCS.controllerExponential controllerDetune (50,5000) 500) + (PCS.controllerExponential controllerTimbre1 (1,1000) 100) + (PCS.bendWheelPressure 12 0.8 0) + brs = evalState $ + liftA6 + (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) + (evHead $ + PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) + (PCS.controllerLinear controllerDetune (0,0.01) 0.005) + (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) + (evHead $ + PCS.controllerLinear controllerTimbre1 (1,5) 3) + (pure vcsize) + (PCS.bendWheelPressure 2 0.04 0.03) + freqMod = + evalState + (PCS.bendWheelPressure 2 0.04 0.03) + + + volume <- + PC.controllerExponential chan + controllerVolume + (0.001, 1) 0.2 + + ctrls <- PCS.fromChannel chan + + fmap (amp volume . arrange vcsize) $ + Gen.sequenceModulatedMultiProgram + ctrls chan pgm + (map (\sound fm -> sound fm $ sr) $ + [tnc, fnd, pngFM, flt, bel, ben, sqr, brs, + ssh, fms, css, asn, atr, asq, asw, wnp] ++ + map (.freqMod) tmt0 ++ + map (.freqMod) hal0 ++ + map (.freqMod) grp0 ++ + [str, wnd, png, rfm, tin, tnb]) + + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) vectorChunkSize sampleRate) + +keyboardFilter :: IO () +keyboardFilter = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + mix <- CausalP.runStorableChunky $ + arr id + + + (CausalP.mapSimple (StereoInt.amplify 0.5) + <<< + CausalP.fromSignal (SigP.fromStorableVectorLazy (arr id))) + + lowpass0 <- + CausalP.runStorableChunky $ + CausalP.mapSimple StereoInt.interleave + <<< +-- CausalPS.amplifyStereo 0.1 <<< + CausalPS.pack + (CausalP.stereoFromMonoControlled + (UniFilter.lowpass ^<< UniFilterL.causalP) $< + (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) + (piecewiseConstant (arr id))) + <<< + CausalP.mapSimple StereoInt.deinterleave + let lowpass :: + Option.SampleRate Real -> PC.T Real -> PC.T Real -> + SigSt.T StereoVector -> SigSt.T StereoVector + lowpass (Option.SampleRate sr) resons freqs = + lowpass0 $ fmap UniFilter.parameter $ + PC.zipWith FiltR.Pole resons $ fmap (/ sr) freqs + + withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> + evalState + (do {- + It is important to retrieve the global controllers + before they are filtered out by PCS.fromChannel. + -} + let freqBnd v = 880 * 2^?(v/24) + freq <- + PC.controllerExponential (Option.extraChannel opt) + controllerFilterCutoff + (freqBnd (-64), freqBnd 63) 5000 + resonance <- + PC.controllerExponential (Option.extraChannel opt) + controllerFilterResonance + (1, 100) 1 + filterMusic <- + proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) + vectorChunkSize sampleRate + pureMusic <- + proc (Option.channel opt) (VoiceMsg.toProgram 0) + vectorChunkSize sampleRate + return + (pureMusic `mix` + lowpass sampleRate resonance freq filterMusic)) diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Test.hs b/alsa/Synthesizer/LLVM/Server/Packed/Test.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Packed/Test.hs @@ -0,0 +1,697 @@ +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.SampledSound as Sample +import Synthesizer.LLVM.Server.ALSA (makeNote, ) +import Synthesizer.LLVM.Server.CommonPacked + (Vector, vectorSize, ) +import Synthesizer.LLVM.Server.Common hiding + (Instrument, ) + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import qualified Synthesizer.ALSA.Storable.Play as Play +import Synthesizer.MIDI.Storable (Instrument, chunkSizesFromLazyTime, ) + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import Synthesizer.LLVM.CausalParameterized.Process (($*), ) + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SVP +import qualified Data.StorableVector.Lazy as SVL +-- import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT + +import Control.Arrow ((<<<), arr, ) +import Control.Applicative (pure, liftA, liftA2, ) +import Control.Monad.Trans.State (evalState, ) + +{- +import qualified Numeric.NonNegative.Class as NonNeg +-} +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import Algebra.IntegralDomain (divUp, ) +{- +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Additive as Additive +-} + +-- import NumericPrelude.Numeric (zero, round, (^?), ) +import Prelude hiding (Real, round, break, ) + + +vectorChunkSize :: SVL.ChunkSize +vectorChunkSize = + case Play.defaultChunkSize of + SVL.ChunkSize size -> + SVL.ChunkSize (divUp size vectorSize) + +sampleRatePlain :: Num a => a +sampleRatePlain = Option.defaultSampleRate + +sampleRate :: Option.SampleRate Real +sampleRate = Option.SampleRate Option.defaultSampleRate + + +emptyEvents :: time -> EventList.T time [Event.T] +emptyEvents t = + let evs = EventList.cons t [] evs + in evs + + +{- | +try to reproduce a space leak +-} +sequencePlain :: IO () +sequencePlain = + SVL.writeFile "test.f32" $ +-- print $ last $ SVL.chunks $ + CutSt.arrange Option.defaultChunkSize $ + evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $ + emptyEvents 10 + +sequenceLLVM :: IO () +sequenceLLVM = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ +-- print $ last $ SVL.chunks $ + arrange vectorChunkSize $ + evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Vector)) $ + emptyEvents 10 + +sequencePitchBendCycle :: IO () +sequencePitchBendCycle = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let -- fm = error "undefined pitch bend" + fm = EventListBT.cons 1 10 fm + in Gen.sequenceModulated fm Option.defaultChannel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + emptyEvents 10 + +sequencePitchBendSimple :: IO () +sequencePitchBendSimple = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let fm y = EventListBT.cons y 10 (fm (2-y)) + in Gen.sequenceModulated (fm 1) Option.defaultChannel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + emptyEvents 10 + +sequencePitchBend :: IO () +sequencePitchBend = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.pitchBend Option.defaultChannel 2 0.01 + Gen.sequenceModulated fm Option.defaultChannel + (error "no sound" :: + PC.T Real -> Instrument Real Vector)) $ + emptyEvents 10 + +sequenceModulated :: IO () +sequenceModulated = do + arrange <- SigStL.makeArranger + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 + Gen.sequenceModulated fm Option.defaultChannel + (error "no sound" :: + PC.T (BM.T Real) -> + Instrument Real Vector)) $ + emptyEvents 10 + +sequenceModulatedLong :: IO () +sequenceModulatedLong = do + arrange <- SigStL.makeArranger +-- sound <- Instr.softStringReleaseEnvelope $/ sampleRate + sound <- Instr.softString $/ sampleRate -- space leak +-- sound <- Instr.pingReleaseEnvelope $/ 1 $/ sampleRate -- no space leak +-- sound <- Instr.pingRelease $/ 1 $/ 1 $/ sampleRate -- no space leak + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState (Gen.sequence Option.defaultChannel 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] $ + evs 10 + +sequenceModulatedLongFM :: IO () +sequenceModulatedLongFM = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 + Gen.sequenceModulated fm Option.defaultChannel + (\fmlocal -> sound fmlocal $ sampleRate)) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + EventList.cons 10 [makeNote Event.NoteOn 64] $ + evs 10 + +sequenceModulatedRepeat :: IO () +sequenceModulatedRepeat = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 + Gen.sequenceModulated fm Option.defaultChannel + (\fmlocal -> sound fmlocal $ sampleRate)) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + +sequencePress :: IO () +sequencePress = do + arrange <- SigStL.makeArranger +-- sound <- Instr.softString $/ sampleRate +-- sound <- Instr.softStringReleaseEnvelope $/ sampleRate + sound <- Instr.pingReleaseEnvelope $/ 1 $/ 1 $/ vectorChunkSize $/ sampleRate + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (Gen.sequence Option.defaultChannel (\ _freq -> sound)) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + + +sampledSoundTest0 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest0 = + liftA + (\osc smp _fm _vel _freq _dur -> + osc Option.defaultChunkSize (Sample.body smp)) + (SigP.runChunky + (let smp = arr id + in fmap (\x -> Stereo.cons x x) $ + SigPS.pack $ + SigP.fromStorableVectorLazy smp)) + +sampledSoundTest1 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest1 = + liftA + (\osc smp _fm _vel _freq _dur -> + osc Option.defaultChunkSize (Sample.body smp)) + (SigP.runChunky + (let smp = arr id + in CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + $* liftA2 Stereo.cons + (SigPS.constant 0.999) + (SigPS.constant 1.001))) +-- $* (SigPS.constant $# Stereo.cons 0.999 1.001))) + +sampledSoundTest2 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest2 = + liftA + (\osc smp fm _vel freq dur -> + let pos = Sample.positions smp + body = + SigSt.take (Sample.length pos) $ + SigSt.drop (Sample.start pos) $ + Sample.body smp + in SVP.take (chunkSizesFromLazyTime dur) $ + osc Option.defaultChunkSize + (sampleRate, (body, (fm, freq * Sample.period smp)))) + (SigP.runChunky + (let smp = signal fst + fm = Instr.modulation snd + in (CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + <<< + liftA2 Stereo.cons + (CausalPS.amplify 0.999) + (CausalPS.amplify 1.001)) + $* Instr.frequencyFromBendModulation (frequencyConst 3) fm)) + +sampledSoundTest3SpaceLeak :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest3SpaceLeak = + liftA + (\osc smp _fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (let smp = arr snd + amp = arr fst + in CausalPS.amplifyStereo amp + <<< + CausalP.stereoFromMono + (CausalPS.pack + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy smp))) + <<< + liftA2 Stereo.cons + (CausalPS.amplify 0.999) + (CausalPS.amplify 1.001))) + +sampledSoundTest4NoSpaceLeak :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest4NoSpaceLeak = + liftA + (\freqMod smp fm _vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (freqMod + (chunkSizesFromLazyTime (PC.duration fm)) + (sampleRate, (fm, freq*Sample.period smp)) :: SigSt.T Vector) + in SigSt.map + (\x -> Stereo.cons x x) + (sustainFM `SigSt.append` releaseFM)) + (SigP.runChunkyPattern + (Instr.frequencyFromBendModulation + (frequencyConst 3) (Instr.modulation id))) + +sampledSoundTest5LargeSpaceLeak :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundTest5LargeSpaceLeak = + liftA2 + (\osc freqMod smp fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (freqMod + (chunkSizesFromLazyTime (PC.duration fm)) + (sampleRate, (fm, freq*Sample.period smp)) :: SigSt.T Vector) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + (SigP.runChunkyPattern + (Instr.frequencyFromBendModulation + (frequencyConst 3) (Instr.modulation id))) + + +sampledSoundSmallSpaceLeak4 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak4 = + liftA + (\osc smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) + in osc () sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundSmallSpaceLeak4a :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak4a = + liftA + (\osc smp _fm _vel freq dur -> + case SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) of + (sustainFM, releaseFM) -> + osc () sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundNoSmallSpaceLeak3 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundNoSmallSpaceLeak3 = + pure + (\smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) + in SigSt.map (\x -> Stereo.cons x x) sustainFM + `SigSt.append` + SigSt.map (\x -> Stereo.cons x x) releaseFM) + +{-# NOINLINE amplifySVL #-} +amplifySVL :: SVL.Vector Vector -> SVL.Vector Vector +amplifySVL = SigSt.map (2*) + +sampledSoundNoSmallSpaceLeak2 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundNoSmallSpaceLeak2 = + liftA + (\osc smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) + in osc () + (amplifySVL sustainFM + `SigSt.append` + amplifySVL releaseFM)) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundSmallSpaceLeak1 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak1 = + liftA + (\osc smp _fm _vel freq dur -> + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) + in osc () sustainFM + `SigSt.append` + osc () releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + +sampledSoundSmallSpaceLeak0 :: + IO (Sample.T -> + PC.T (BM.T Real) -> + Instrument Real (Stereo.T Vector)) +sampledSoundSmallSpaceLeak0 = + liftA + (\osc smp _fm vel freq dur -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let (sustainFM, releaseFM) = + SVP.splitAt (chunkSizesFromLazyTime dur) $ + (SigSt.repeat Option.defaultChunkSize + (Serial.fromList [freq*Sample.period smp/sampleRatePlain]) + :: SigSt.T Vector) + pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + in osc + (amp, + attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) + sustainFM + `SigSt.append` + osc (amp,release) releaseFM) + (CausalP.runStorableChunky + (arr (\x -> Stereo.cons x x))) + + + +sequenceSample :: IO () +sequenceSample = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = + sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0) + (Sample.Positions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 + Gen.sequenceModulated fm Option.defaultChannel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + evs 10 + +{- +sequenceSample1 :: IO () +sequenceSample1 = do + sampler <- Instr.sampledSound + let sound = + sampler (SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) + (SamplePositions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + sound +{- + (let evs f = + EventListBT.cons (BM.Cons 0.001 f) 10 (evs (0.02-f)) + in evs 0.01) +-} + (let evs t = + EventListBT.cons (BM.Cons 0.01 0.001) t (evs (20-t)) + in evs 10) +{- + (PCS.Cons + (Map.singleton + (PC.Controller VoiceMsg.modulation) 1) + (let evs t = EventList.cons t [] (evs (20-t)) + in EventListMT.consTime 10 $ evs 10)) +-} + 0.01 1 +-- (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) + (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) +-} + +sequenceSample1 :: IO () +sequenceSample1 = do + sampler <- sampledSoundSmallSpaceLeak4a + let sound = + sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0) + (Sample.Positions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + sound + (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 1 evs + in evs) + 0.01 1 + (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) + +{- +sequenceSample1a :: IO () +sequenceSample1a = do +{- + makeStereoLLVM <- + CausalP.runStorableChunky2 -- NoSpaceLeak + (arr (\x -> Stereo.cons x x)) + let stereoLLVM = makeStereoLLVM () +-} + stereoLLVM <- CausalP.runStorableChunky3 + let stereoPlain = SigSt.map (\x -> Stereo.cons x x) + SVL.writeFile "test.f32" $ + let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 + !(sustainFM, releaseFM) = + SVP.splitAt dur $ + (SigSt.repeat Option.defaultChunkSize (Serial.fromList [1]) + :: SigSt.T Vector) + in case 3::Int of + -- no leak + 0 -> stereoLLVM $ sustainFM `SigSt.append` releaseFM + -- no leak + 1 -> stereoPlain $ sustainFM `SigSt.append` releaseFM + -- no leak + 2 -> stereoPlain sustainFM `SigSt.append` stereoPlain releaseFM + -- leak + 3 -> stereoLLVM sustainFM `SigSt.append` stereoPlain releaseFM + -- no leak + 4 -> stereoPlain sustainFM `SigSt.append` stereoLLVM releaseFM + -- leak + 5 -> stereoLLVM sustainFM `SigSt.append` stereoLLVM releaseFM +-} + +sequenceSample2 :: IO () +sequenceSample2 = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = + sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0) + (Sample.Positions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (do bend <- PC.pitchBend Option.defaultChannel 2 0.01 + let fm = fmap (\t -> BM.Cons t t) bend + Gen.sequenceModulated fm Option.defaultChannel sound) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn 60] $ + evs 10 + +{- +Interestingly, when the program aborts because of heap exhaustion, +then the generated file has size 137MB independent of the heap size +(I tried sizes from 1MB to 64MB). +-} +sequenceSample3 :: IO () +sequenceSample3 = do + arrange <- SigStL.makeArranger + sampler <- sampledSoundTest2 + let sound = + sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0) + (Sample.Positions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let evs = + EventListBT.cons (BM.Cons 0.01 0.001) 10 evs + in Gen.sequence Option.defaultChannel (sound evs)) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs + +sequenceSample4 :: IO () +sequenceSample4 = do + arrange <- SigStL.makeArranger + sampler <- Instr.sampledSound +-- sampler <- sampledSoundTest2 + let sound = + sampler (Sample.Cons (SigSt.replicate Option.defaultChunkSize 100000 0) + (Sample.Positions 0 100000 50000 50000) + 100) + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (let evs = + EventListBT.cons (BM.Cons 0.01 0.001) 10 evs + in Gen.sequenceCore + Option.defaultChannel Gen.errorNoProgram + (Gen.Modulator () return + (return . Gen.renderInstrumentIgnoreProgram (sound evs sampleRate)))) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs + +sequenceFM1 :: IO () +sequenceFM1 = do + arrange <- SigStL.makeArranger + sound <- Instr.softStringFM $/ + let evs = + EventListBT.cons (BM.Cons 0.01 0.001) 10 evs + in evs +-- sound <- Instr.softStringReleaseEnvelope + SVL.writeFile "test.f32" $ + arrange vectorChunkSize $ + evalState + (Gen.sequenceCore + Option.defaultChannel Gen.errorNoProgram + (Gen.Modulator () return + (return . Gen.renderInstrumentIgnoreProgram (sound sampleRate)))) $ + let evs = EventList.cons 10 [] evs + in EventList.cons 10 [makeNote Event.NoteOn 60] evs +{- + sound + 0.01 1 + (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) +-} + + +adsr :: IO () +adsr = do + env <- Instr.adsr + SVL.writeFile "adsr.f32" $ + env 0.2 2 0.15 0.3 0.5 vectorChunkSize sampleRate (-0.5) 88200 + + +constCtrl :: a -> PC.T a +constCtrl x = + let xs = EventListBT.cons x 10000 xs + in xs + +bellNoiseStereoTest :: IO () +bellNoiseStereoTest = do + str <- Instr.bellNoiseStereoFM + SVL.writeFile "bellnoise.f32" $ + str 0.3 0.1 (constCtrl 0.3) (constCtrl 100) + vectorChunkSize + (constCtrl (BM.Cons 1 0.01)) sampleRate 0 440 + 100000 diff --git a/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs b/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Scalar/Run.hs @@ -0,0 +1,154 @@ +module Synthesizer.LLVM.Server.Scalar.Run where + +import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.ALSA (Output, play, startMessage, ) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.MIDI as MIDIL +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), ) + +import qualified Synthesizer.Storable.Signal as SigSt + +import qualified Synthesizer.ALSA.EventList as Ev + +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import Control.Arrow ((<<<), arr, ) +import Control.Monad.Trans.State (evalState, ) + +import Control.Exception (bracket, ) + +import NumericPrelude.Numeric (zero, (*>), ) +import Prelude hiding (Real, break, ) + + +{-# INLINE withMIDIEvents #-} +withMIDIEvents :: + Option.T -> + Output handle signal a -> + (SigSt.ChunkSize -> SampleRate Real -> + EventList.T Ev.StrictTime [Event.T] -> signal) -> IO a +withMIDIEvents opt output process = do + putStrLn startMessage + case output opt of + (open,close,write) -> + bracket open (close . snd) $ \((chunkSize,rate),h) -> + let rrate = fromIntegral rate :: Double + in Ev.withMIDIEvents + (Option.clientName opt) + (fromIntegral chunkSize / rrate) + rrate + (write h . + process (SigSt.chunkSize chunkSize) + (Option.SampleRate $ fromIntegral rate)) + + + +freq :: Option.SampleRate Real -> Real -> Real +freq (Option.SampleRate sampleRate) f = + f / sampleRate + + +pitchBend :: IO () +pitchBend = do + opt <- Option.get + osc <- + SigP.runChunky + ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + $* piecewiseConstant (arr id)) + withMIDIEvents opt play $ \chunkSize sampleRate -> + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . + evalState (PC.pitchBend (Option.channel opt) 2 (freq sampleRate 880)) + + +frequencyModulation :: IO () +frequencyModulation = do + opt <- Option.get + osc <- + SigP.runChunky + (((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + <<< (MIDIL.frequencyFromBendModulation (frequencyConst (10::Real)))) + $* piecewiseConstant (arr (\(sr,ctrl) -> transposeModulation sr 880 ctrl))) + withMIDIEvents opt play $ \chunkSize sampleRate -> + (id :: SigSt.T Real -> SigSt.T Real) . + osc chunkSize . (,) sampleRate . + evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) + + + +keyboard :: IO () +keyboard = do + opt <- Option.get +-- sound <- Instr.pingDur +{- + sound <- + fmap (\s vel _freq dur -> s vel dur) $ + (Instr.pingReleaseEnvelope $/ 0.4 $/ 0.1) +-} + sound <- Instr.pingRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalP.amplify (arr id)) + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> + (amp :: Real -> SigSt.T Real -> SigSt.T Real) 0.2 . + arrange chunkSize . + evalState + (Gen.sequence + (Option.channel opt) + (sound chunkSize sampleRate)) + +keyboardStereo :: IO () +keyboardStereo = do + opt <- Option.get + sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + amp <- CausalP.runStorableChunky (CausalP.amplifyStereo (arr id)) + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> + (amp :: Real -> SigSt.T (Stereo.T Real) -> SigSt.T (Stereo.T Real)) 0.2 . + arrange chunkSize . + evalState + (Gen.sequence + (Option.channel opt) + (sound chunkSize sampleRate)) + +keyboardMulti :: IO () +keyboardMulti = do + opt <- Option.get + png <- Instr.pingDur + pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1 $/ Option.chunkSize opt + tin <- Instr.tine $/ 0.4 $/ 0.1 $/ Option.chunkSize opt + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) . + SigSt.map (0.2*) . + arrange chunkSize . + evalState (Gen.sequenceMultiProgram (Option.channel opt) + (VoiceMsg.toProgram 2) + (map ($ sampleRate) [png, pngRel, tin])) + +keyboardStereoMulti :: IO () +keyboardStereoMulti = do + opt <- Option.get + png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 + tin <- Instr.tineStereo $/ 0.4 $/ 0.1 + str <- Instr.softString + arrange <- SigStL.makeArranger + withMIDIEvents opt play $ \chunkSize sampleRate -> +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) . + SigSt.map ((0.2::Real)*>) . + arrange chunkSize . + evalState (Gen.sequenceMultiProgram (Option.channel opt) + (VoiceMsg.toProgram 1) + (map (\sound -> sound chunkSize sampleRate) [png, tin, const str])) diff --git a/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs b/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs new file mode 100644 --- /dev/null +++ b/alsa/Synthesizer/LLVM/Server/Scalar/Test.hs @@ -0,0 +1,86 @@ +module Synthesizer.LLVM.Server.Scalar.Test where + +import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents, ) +import Synthesizer.LLVM.Server.ALSA (record, put, makeNote, ) +import Synthesizer.LLVM.Server.Common + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.Generic as Gen + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Wave as WaveL +import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), ) + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Data.EventList.Relative.TimeBody as EventList + +import Control.Arrow (arr, ) +import Control.Monad.Trans.State (evalState, ) + +import NumericPrelude.Numeric (zero, ) +import Prelude hiding (Real, ) + + +sampleRate :: Real +sampleRate = + Option.defaultSampleRate + + +pitchBend0 :: IO () +pitchBend0 = do + osc <- + SigP.runChunky + ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + $* 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)) $ + let evs = EventList.cons 100 [] evs + in EventList.cons 0 ([]::[Event.T]) evs + +pitchBend1 :: IO () +pitchBend1 = do + opt <- Option.get + osc <- + SigP.runChunky + ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) + $* 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)) + +pitchBend2 :: IO () +pitchBend2 = do + opt <- Option.get + withMIDIEvents opt put $ \ _size _rate -> id + + + +sequencePress :: IO () +sequencePress = do +-- arrange <- SigStL.makeArranger +-- sound <- Instr.softString +-- sound <- Instr.softStringReleaseEnvelope +-- sound <- Instr.pingReleaseEnvelope $/ 1 $/ Option.defaultChunkSize +-- sound <- Instr.pingDur +-- sound <- Instr.pingDurTake + let sound = Instr.dummy Option.defaultChunkSize (SampleRate sampleRate) + SVL.writeFile "test.f32" $ + CutSt.arrange Option.defaultChunkSize $ + evalState + (do Gen.sequence Option.defaultChannel sound) $ + let evs t = + EventList.cons t [makeNote Event.NoteOn 60] $ + EventList.cons t [makeNote Event.NoteOff 60] $ + evs (20-t) + in evs 10 + diff --git a/example/Synthesizer/LLVM/LAC2011.hs b/example/Synthesizer/LLVM/LAC2011.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/LAC2011.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Synthesizer.LLVM.LAC2011 where + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP +import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Simple.Signal as Gen +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Class as C +import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) +import LLVM.Util.Arithmetic () -- Floating instance for TValue +import qualified LLVM.Core as LLVM +import Types.Data.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, ) +import qualified Types.Data.Num as TypeNum + +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS +import qualified Synthesizer.LLVM.Parameterized.Signal as GenP +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import Control.Arrow (Arrow, arr, (&&&), (^<<), ) +import Control.Category ((<<<), (.), id, ) +import Control.Monad ((<=<), ) +import Control.Applicative (liftA2, pure, ) +import Control.Functor.HT (void, ) +import Data.Traversable (traverse, ) + +import Foreign.Storable (Storable, ) +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Sound.Sox.Option.Format as SoxOption +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 Data.Word (Word32, ) +-- import qualified Data.Function.HT as F +import Data.List (genericLength, ) +import System.Random (randomRs, mkStdGen, ) + +import qualified System.IO as IO +-- import System.Exit (ExitCode, ) + +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 (fst, snd, id, (.), ) +import qualified NumericPrelude.Base as P + + +asMono :: vector Float -> vector Float +asMono = id + +asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) +asStereo = id + +asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float) +asMonoPacked = id + +asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float) +asMonoPacked16 = id + +asWord32 :: vector Word32 -> vector Word32 +asWord32 = id + +asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32) +asWord32Packed = id + + +playStereo :: Gen.T (Stereo.T (Value Float)) -> IO () +playStereo = + playStereoStream . + Gen.renderChunky (SVL.chunkSize 100000) + +playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () +playStereoStream = playStreamSox + +playMono :: Gen.T (Value Float) -> IO () +playMono = + playMonoStream . + Gen.renderChunky (SVL.chunkSize 100000) + +playMonoParam :: GenP.T () (Value Float) -> IO () +playMonoParam = + playMonoStream . + ($ ()) . + ($ SVL.chunkSize 100000) <=< + GenP.runChunky + +playMonoPacked :: GenP.T () (Serial.Value D4 Float) -> IO () +playMonoPacked = + playMonoStream . + SigStL.unpack . + ($ ()) . + ($ SVL.chunkSize 100000) <=< + GenP.runChunky + +playMonoStream :: SVL.Vector Float -> IO () +playMonoStream = playStreamSox + + +{- +play :: + (C.MakeValueTuple y, ValueTuple y ~ a, Memory.C a struct) => + Gen.T a -> IO () +play = + playStreamSox . + 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 + + +sampleRate :: Ring.C a => a +sampleRate = 44100 + +intSecond :: Ring.C a => Float -> a +intSecond t = fromInteger $ round $ t * sampleRate + +secondP :: Param.T p Float -> Param.T p Float +secondP t = t * sampleRate + +hertzP :: Param.T p Float -> Param.T p Float +hertzP f = f / sampleRate + +second :: Field.C a => a -> a +second t = t * sampleRate + +hertz :: Field.C a => a -> a +hertz f = f / sampleRate + +{- +second :: Float -> Param.T p Float +second t = return (t * sampleRate) + +hertz :: Float -> Param.T p Float +hertz f = return (f / sampleRate) +-} + +sine :: IO () +sine = + playMono (0.99 * Gen.osci Wave.sine 0 (hertz 440)) + +ping :: IO () +ping = + playMono (Gen.exponential2 (second 1) 1 * Gen.osci Wave.triangle 0 (hertz 440)) + +tremolo :: IO () +tremolo = + playMono (Gen.osci Wave.sine 0 (hertz 0.3) * Gen.osci Wave.triangle 0 (hertz 440)) + + +stereo :: IO () +stereo = + playStereo (liftA2 Stereo.cons (Gen.osci Wave.triangle 0 (hertz 439)) (Gen.osci Wave.triangle 0 (hertz 441))) + +stereoFancy :: IO () +stereoFancy = + playStereo (traverse (Gen.osci Wave.triangle 0 . hertz) (Stereo.cons 439 441)) + + +fst :: Arrow arrow => arrow (a,b) a +fst = arr P.fst + +snd :: Arrow arrow => arrow (a,b) b +snd = arr P.snd + + +pingParam :: IO (Float -> SVL.Vector Float) +pingParam = + fmap ($ SVL.chunkSize 1024) $ + GenP.runChunky $ + GenP.exponential2 (second 0.3) 1 * GenP.osciSimple Wave.triangle 0 id + +playPingParam :: IO () +playPingParam = do + png <- pingParam + playMonoStream (SVL.take (intSecond 1) $ png (hertz 880)) + +melody :: IO (SVL.Vector Float) +melody = do + png <- pingParam + return $ SVL.concat $ map (SVL.take (intSecond 0.2) . png . hertz) $ cycle [440, 550, 660, 880] + +playMelody :: IO () +playMelody = do + mel <- melody + playMonoStream mel + +pingParam2 :: IO ((Float, Float) -> SVL.Vector Float) +pingParam2 = + fmap ($ SVL.chunkSize 1024) $ + GenP.runChunky $ + GenP.exponential2 (second 0.3) fst * GenP.osciSimple Wave.triangle 0 snd + +playMelody2 :: IO () +playMelody2 = do + png <- pingParam2 + playMonoStream $ SVL.concat $ map (SVL.take (intSecond 0.2) . png) $ zip (map sin $ [0,0.1..]) (cycle $ map hertz [440, 550, 660, 880]) + + +retard :: GenP.T p (Value Float) -> GenP.T p (Value Float) +retard xs = + CausalP.frequencyModulationLinear xs . + CausalP.mapSimple (A.fdiv (LLVM.valueOf 1)) $* + GenP.rampCore (1 / secondP 10) 1 + +playRetarded :: IO () +playRetarded = do + mel <- melody + playMonoParam $ retard $ GenP.fromStorableVectorLazy $ pure $ mel + + + +pingGen :: GenP.T p (Value Float) +pingGen = + GenP.exponential2 (second 0.5) 0.7 * + GenP.osciSimple Wave.triangle 0 (hertzP 440) + +zerop :: Param.T p Float +zerop = pure zero + +delayp :: Param.T p Int -> CausalP.T p (Value Float) (Value Float) +delayp = CausalP.delay zerop + +delay :: IO () +delay = + playMonoParam $ + pingGen + 0.7 * (delayp (intSecond 0.5) $* pingGen) + +delayArrow :: IO () +delayArrow = + playMonoParam + ((id + 0.7 * delayp (intSecond 0.5)) $* pingGen) + +comb :: IO () +comb = + playMonoParam $ + (CausalP.loop zerop + (id &&& 0.7 * delayp (intSecond 0.5) + <<< CausalP.mix) $* + pingGen) + + +lfoSine :: + Param.T p Float -> + GenP.T p (Moog.Parameter D8 (Value Float)) +lfoSine reduct = + CausalP.mapSimple (Moog.parameter d8 (valueOf (30::Float))) . + CausalP.mapExponential 2 (hertz 700) $* + GenP.osciSimple Wave.sine 0 (reduct * hertz 0.1) + +filterSweep :: IO () +filterSweep = + playMonoParam $ + (0.2 * CtrlP.processCtrlRate 128 lfoSine + $* GenP.noise 0 0.3) + + +pingPacked :: IO () +pingPacked = + playMonoPacked (GenPS.exponential2 (second 1) 1 * GenPS.osciSimple Wave.triangle 0 (hertz 440)) + + + +{- +Module can be loaded into GHCi only when synthesizer-llvm was installed with +$ cabal install --enable-shared + +In contrast to that, you have to install with +$ cabal install -fbuildTests -fbuildExamples --enable-shared --disable-library-profiling --ghc-option=-dynamic +for build the executables. +But then GHCi complains: + +$ ghci +GHCi, version 6.12.3: http://www.haskell.org/ghc/ :? for help +Loading package ghc-prim ... linking ... done. +Loading package integer-gmp ... linking ... done. +Loading package base ... linking ... done. +Loading package ffi-1.0 ... linking ... done. +[1 of 1] Compiling Main ( src/Synthesizer/LLVM/Test.hs, interpreted ) + +src/Synthesizer/LLVM/Test.hs:4:0: + Bad interface file: /home/thielema/.cabal/lib/synthesizer-llvm-0.3/ghc-6.12.3/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hi + mismatched interface file ways (wanted "", got "dyn") +Failed, modules loaded: none. +-} diff --git a/example/Synthesizer/LLVM/LNdW2011.hs b/example/Synthesizer/LLVM/LNdW2011.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/LNdW2011.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Synthesizer.LLVM.LNdW2011 where + +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.CausalIO.ControllerSelection as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as PMIDI +import qualified Synthesizer.ALSA.CausalIO.Process as PALSA +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.MIDI.Value as MV +import qualified Synthesizer.Zip as Zip +import Synthesizer.ALSA.EventList (ClientName(ClientName)) + +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP +import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Simple.Signal as Gen +import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Class as C +import LLVM.Core (Value, value, valueOf, constVector, constOf, ) +import LLVM.Util.Arithmetic () -- Floating instance for TValue +import qualified LLVM.Core as LLVM +import Types.Data.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, ) +import qualified Types.Data.Num as TypeNum + +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS +import qualified Synthesizer.LLVM.Parameterized.Signal as GenP +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ($<#), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import qualified Synthesizer.Causal.Spatial as Spatial + +import qualified Control.Monad.Trans.State as State +import qualified Control.Arrow as Arr +import Control.Arrow (Arrow, arr, (&&&), (^<<), (^>>), ) +import Control.Category ((<<<), (.), id, (>>>), ) +import Control.Monad (liftM2, (<=<), ) +import Control.Applicative (liftA2, pure, ) +import Control.Functor.HT (void, ) +import Data.Tuple.HT (mapPair, ) +import Data.Traversable (traverse, ) + +import Foreign.Storable (Storable, ) +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt + +import qualified Sound.Sox.Option.Format as SoxOption +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 Data.Word (Word32, ) +-- import qualified Data.Function.HT as F +import Data.List (genericLength, ) +import System.Random (randomRs, mkStdGen, ) + +import qualified System.IO as IO +-- import System.Exit (ExitCode, ) + +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.IntegralDomain as Integral + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (fst, snd, id, (.), ) +import qualified NumericPrelude.Base as P + + +asMono :: vector Float -> vector Float +asMono = id + +asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) +asStereo = id + +asMonoPacked :: vector Vector -> vector Vector +asMonoPacked = id + +asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float) +asMonoPacked16 = id + +asWord32 :: vector Word32 -> vector Word32 +asWord32 = id + +asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32) +asWord32Packed = id + + +playStereo :: Gen.T (Stereo.T (Value Float)) -> IO () +playStereo = + playStereoStream . + Gen.renderChunky (SVL.chunkSize 100000) + +playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () +playStereoStream = playStreamSox + +playMono :: Gen.T (Value Float) -> IO () +playMono = + playMonoStream . + Gen.renderChunky (SVL.chunkSize 100000) + +playMonoParam :: GenP.T () (Value Float) -> IO () +playMonoParam = + playMonoStream . + ($ ()) . + ($ SVL.chunkSize 100000) <=< + GenP.runChunky + +playMonoPacked :: GenP.T () VectorValue -> IO () +playMonoPacked = + playMonoStream . + SigStL.unpack . + ($ ()) . + ($ SVL.chunkSize 100000) <=< + GenP.runChunky + +playMonoStream :: SVL.Vector Float -> IO () +playMonoStream = playStreamSox + + +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 + + +sampleRate :: Ring.C a => a +sampleRate = 44100 + +type Vector = Serial.Plain VectorSize Float +type VectorSize = TypeNum.D4 +type VectorValue = Serial.Value VectorSize Float + +vectorSize :: Int +vectorSize = TypeNum.fromIntegerT (undefined :: VectorSize) + +vectorRate :: Field.C a => a +vectorRate = sampleRate / fromIntegral vectorSize + + + +intSecond :: Ring.C a => Float -> a +intSecond t = fromInteger $ round $ t * sampleRate + +second :: Field.C a => a -> a +second t = t * sampleRate + +hertz :: Field.C a => a -> a +hertz f = f / sampleRate + + + +fst :: Arrow arrow => arrow (a,b) a +fst = arr P.fst + +snd :: Arrow arrow => arrow (a,b) b +snd = arr P.snd + + +playFromEvents :: + (ALSA.SampleFmt a, Additive.C a) => + Double -> + Double -> + PIO.T PALSA.Events (SV.Vector a) -> + IO () +playFromEvents latency period = + PALSA.playFromEvents + Play.defaultDevice (ClientName "Haskell-LLVM-demo") + latency period sampleRate + + +modulation :: IO () +modulation = do + proc <- + CausalP.processIO + (0.95 * (CausalP.osciSimple Wave.approxSine4 $< 0)) + playFromEvents 0.01 (0.015::Double) + ((proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) + . + PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.modulation + (hertz 500, hertz 2000) (hertz 1000)) + + +vectorBlockSize :: Double +vectorBlockSize = fromIntegral $ 150*vectorSize + +subsample :: (Integral.C t) => t -> t -> State.State t t +subsample step t = + State.state $ \r -> divMod (r+t) step +{- + do modify (t+) + (q,r) <- gets (flip divMod step) + put r + return q +-} + +subsampleBT :: EventListBT.T NonNegW.Int a -> EventListBT.T NonNegW.Int a +subsampleBT = + flip State.evalState NonNeg.zero . + EventListBT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" vectorSize)) + +modulationPacked :: IO () +modulationPacked = do + proc <- + CausalP.processIO + (0.95 * (CausalPS.osciSimple Wave.approxSine4 $< 0) + . + CausalP.mapSimple Serial.upsample) + playFromEvents 0.01 (vectorBlockSize/sampleRate) + (arr SigStL.unpackStrict + . + (proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector)) + . + arr subsampleBT + . + PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.modulation + (hertz 500, hertz 2000) (hertz 1000)) + + +bubbles :: IO () +bubbles = do + proc <- + CausalP.processIO + (0.95 * (CausalP.osciSimple Wave.sine $< 0) + . + (fst.fst * (1 + snd.fst * snd)) + . + Arr.second (CausalP.osciSimple Wave.saw $< 0)) + playFromEvents 0.01 (0.015::Double) + ((proc () :: + PIO.T + (Zip.T + (Zip.T + (EventListBT.T NonNegW.Int Float) + (EventListBT.T NonNegW.Int Float)) + (EventListBT.T NonNegW.Int Float)) + (SV.Vector Float)) + . + PIO.zip + (PIO.zip + (PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.modulation + (hertz 500, hertz 2000) (hertz 1000)) + (PMIDI.controllerLinear + (ChannelMsg.toChannel 0) + Ctrl.timbre + (-1, 1) (-0.1))) + (PMIDI.controllerExponential + (ChannelMsg.toChannel 0) + Ctrl.soundVariation + (hertz 1, hertz 10) (hertz 1))) + +bubblesSet :: IO () +bubblesSet = do + proc <- + CausalP.processIOCore + (PIn.controllerSet d6) + (CausalP.arrayElement d0 * + (CausalP.osciSimple Wave.sine $< 0) + . + (CausalP.arrayElement d1 + * + (1 - CausalP.arrayElement d2 * + (CausalP.osciSimple Wave.saw $< 0) . + CausalP.arrayElement d3) + * + (1 - CausalP.arrayElement d4 * + (CausalP.osciSimple Wave.saw $< 0) . + CausalP.arrayElement d5))) + POut.storableVector + 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)) + + +subsamplePCS :: PCS.T key a -> PCS.T key a +subsamplePCS = + PCS.mapStream $ + flip State.evalState NonNeg.zero . + EventListTT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" $ fromIntegral vectorSize)) + +bubblesPacked :: IO () +bubblesPacked = do + proc <- + CausalP.processIOCore + (PIn.controllerSet d6) + (CausalPS.arrayElement d0 * + (CausalPS.osciSimple Wave.approxSine4 $< 0) + . + (CausalPS.arrayElement d1 + * + (1 - CausalPS.arrayElement d2 * + (CausalPS.osciSimple Wave.saw $< 0) . + CausalPS.arrayElement d3) + * + (1 - CausalPS.arrayElement d4 * + (CausalPS.osciSimple Wave.saw $< 0) . + CausalPS.arrayElement d5))) + POut.storableVector + playFromEvents 0.01 (vectorBlockSize/sampleRate) + (arr SigStL.unpackStrict + . + (proc () :: PIO.T (PCS.T Int Float) (SV.Vector Vector)) + . + 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)) + + +{- +Implementation of 'moveAround' that just lifts the corresponding plain function +in the @Spatial@ module from @synthesizer-core@. +Unfortunately, this way we get a @PseudoModule v v@ constraint +that cannot be satisfied with @LLVM.Vector@s. +-} +moveAround2dLifted :: + (A.Transcendental v, A.PseudoModule v v, + A.Real v, A.RationalConstant v) => + Value.T v -> Value.T v -> (Value.T v, Value.T v) -> + CausalP.T p (v, v) (v, v) +moveAround2dLifted att sonicDelay ear = + CausalP.mapSimple + (uncurry (liftM2 (,)) . + mapPair (Value.decons, Value.decons) . + Spatial.moveAround att sonicDelay ear . + mapPair (Value.constantValue, Value.constantValue)) + +moveAround2d :: + (A.Algebraic v, A.RationalConstant v) => + Value.T v -> Value.T v -> (Value.T v, Value.T v) -> + CausalP.T p (v, v) (v, v) +moveAround2d att sonicDelay ear = + CausalP.mapSimple $ Value.flattenFunction $ + (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . + euclideanNorm2d . subtract ear + +euclideanNorm2d :: + (A.Algebraic a) => + (Value.T a, Value.T a) -> Value.T a +euclideanNorm2d (x,y) = + Value.sqrt $ Value.square x + Value.square y + +mapFunc :: + (Value.Flatten a, Value.Flatten b) => + (a -> b) -> + CausalP.T p (Value.Registers a) (Value.Registers b) +mapFunc f = + CausalP.mapSimple (Value.flattenFunction f) + +flyChannel :: + (Value.T (Value Float), Value.T (Value Float)) -> + CausalP.T p (Value Float, (Value Float, Value Float)) (Value Float) +flyChannel ear = + ((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id)) + &&& + (Arr.second + (2 * ((CausalP.differentiate $# (0::Float, 0::Float)) + >>> + mapFunc euclideanNorm2d)) + >>> + CausalP.mix)) + >>> + arr (\((phase,volume), speed) -> (volume, (phase,speed))) + >>> + Arr.second (CausalP.osciSimple Wave.saw) + >>> + (CausalP.envelope * 10) + +fly :: IO () +fly = do + let slow = + Filt1.lowpassCausalP $<# + Filt1Core.parameter (1/sampleRate::Float) + let fast = + Filt1.lowpassCausalP $<# + Filt1Core.parameter (30/sampleRate::Float) + proc <- + CausalP.processIOCore + (PIn.controllerSet d5) + ((CausalP.arrayElement d0 &&& + (liftA2 (,) + (CausalP.arrayElement d2) + (liftA2 (,) + ((CausalP.arrayElement d3 >>> slow) + + + CausalP.arrayElement d1 * + (CausalP.fromSignal (GenP.noise 366210 0.3) >>> fast >>> fast)) + ((CausalP.arrayElement d4 >>> slow) + + + CausalP.arrayElement d1 * + (CausalP.fromSignal (GenP.noise 234298 0.3) >>> fast >>> fast))) + >>> + liftA2 Stereo.cons + (flyChannel (-1,0)) + (flyChannel ( 1,0)))) + >>> + CausalP.envelopeStereo) + POut.storableVector + playFromEvents 0.01 (0.015::Double) + ((proc () :: PIO.T (PCS.T Int Float) (SV.Vector (Stereo.T Float))) + . + MCS.filter [ + MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2, + MCS.controllerLinear Ctrl.modulation (0, 5) 2, + MCS.pitchBend 2 (hertz 250), + MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, + MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] + . + MCS.fromChannel (ChannelMsg.toChannel 0)) + + +flyChannelPacked :: + (Value.T VectorValue, Value.T VectorValue) -> + CausalP.T p (VectorValue, (VectorValue, VectorValue)) VectorValue +flyChannelPacked ear = + ((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id)) + &&& + (Arr.second + (2 * ((CausalPS.differentiate $# (0::Float, 0::Float)) + >>> + mapFunc euclideanNorm2d)) + >>> + CausalP.mix)) + >>> + arr (\((phase,volume), speed) -> (volume, (phase,speed))) + >>> + Arr.second (CausalPS.osciSimple Wave.saw) + >>> + CausalP.envelope + >>> + CausalPS.amplify 10 + + +flyPacked :: IO () +flyPacked = do + let slow = + Filt1.lowpassCausalPackedP $<# + Filt1Core.parameter (1/sampleRate::Float) + let fast = + Filt1.lowpassCausalPackedP $<# + Filt1Core.parameter (30/sampleRate::Float) + proc <- + CausalP.processIOCore + (PIn.controllerSet d5) + ((CausalPS.arrayElement d0 &&& + (liftA2 (,) + (CausalPS.arrayElement d2) + (liftA2 (,) + ((CausalPS.arrayElement d3 >>> slow) + + + CausalPS.arrayElement d1 * + (CausalP.fromSignal (GenPS.noise 366210 0.3) >>> fast >>> fast)) + ((CausalPS.arrayElement d4 >>> slow) + + + CausalPS.arrayElement d1 * + (CausalP.fromSignal (GenPS.noise 234298 0.3) >>> fast >>> fast))) + >>> + liftA2 Stereo.cons + (flyChannelPacked (-1,0)) + (flyChannelPacked ( 1,0)))) + >>> + CausalP.envelopeStereo + >>> + CausalP.mapSimple StereoInt.interleave) + POut.storableVector + playFromEvents 0.01 (vectorBlockSize/sampleRate) + (arr SigStL.unpackStereoStrict + . + (proc () :: PIO.T (PCS.T Int Float) (SV.Vector (StereoInt.T VectorSize Float))) + . + arr subsamplePCS + . + MCS.filter [ + MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2, + MCS.controllerLinear Ctrl.modulation (0, 5) 2, + MCS.pitchBend 2 (hertz 250), + MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, + MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] + . + MCS.fromChannel (ChannelMsg.toChannel 0)) diff --git a/example/Synthesizer/LLVM/Test.hs b/example/Synthesizer/LLVM/Test.hs new file mode 100644 --- /dev/null +++ b/example/Synthesizer/LLVM/Test.hs @@ -0,0 +1,1382 @@ +{-# LANGUAGE Rank2Types #-} +module Main where + +import Synthesizer.LLVM.LAC2011 () +import qualified Synthesizer.LLVM.LNdW2011 as LNdW2011 + +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth +import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 +import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP +import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func +import qualified Synthesizer.LLVM.Causal.Process as Causal +import qualified Synthesizer.LLVM.Simple.Signal as Sig +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) +import LLVM.Util.Arithmetic () -- Floating instance for TValue +import qualified LLVM.Core as LLVM +import Types.Data.Num (D4, D8, D16, ) +import qualified Types.Data.Num as TypeNum + +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core + +import Control.Arrow (Arrow, arr, (&&&), (^<<), (***), ) +import Control.Category ((<<<), (.), id, ) +import Control.Applicative (pure, liftA2, ) +import Control.Functor.HT (void, ) + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Sound.Sox.Option.Format as SoxOption +import qualified Sound.Sox.Play as SoxPlay +-- import qualified Synthesizer.ALSA.Storable.Play as Play + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt + +import Data.Word (Word32, ) +-- import qualified Data.Function.HT as F +import Data.List (genericLength, ) +import System.Random (randomRs, mkStdGen, ) + +import qualified System.IO as IO +-- import System.Exit (ExitCode, ) + +import Prelude hiding (fst, snd, id, (.), ) +import qualified Prelude as P + + +asMono :: vector Float -> vector Float +asMono = id + +asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) +asStereo = id + +asMonoPacked :: vector (Serial.Plain D4 Float) -> vector (Serial.Plain D4 Float) +asMonoPacked = id + +asMonoPacked16 :: vector (Serial.Plain D16 Float) -> vector (Serial.Plain D16 Float) +asMonoPacked16 = id + +asStereoInterleaved :: vector (StereoInt.T D4 Float) -> vector (StereoInt.T D4 Float) +asStereoInterleaved = id + +asWord32 :: vector Word32 -> vector Word32 +asWord32 = id + +asWord32Packed :: vector (Serial.Plain D4 Word32) -> vector (Serial.Plain D4 Word32) +asWord32Packed = id + + +{- | +> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01) + +Unfortunately: If you call :reload, +then the next attempt to play something will be answered by: + +ghci: JITEmitter.cpp:110: ::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed. +-} +playStereo :: Sig.T (Stereo.T (Value Float)) -> IO () +playStereo = + playStereoVector . + Sig.renderChunky (SVL.chunkSize 100000) + +playStereoVector :: SVL.Vector (Stereo.T Float) -> IO () +playStereoVector = + void . SoxPlay.simple SVL.hPut SoxOption.none 44100 + +playMono :: Sig.T (Value Float) -> IO () +playMono = + playMonoVector . + Sig.renderChunky (SVL.chunkSize 100000) + +playMonoVector :: SVL.Vector Float -> IO () +playMonoVector = + void . SoxPlay.simple SVL.hPut SoxOption.none 44100 + + +playFileMono :: FilePath -> IO () +playFileMono fileName = do + IO.withFile fileName IO.ReadMode $ \h -> + playStereo . + Sig.fromStorableVectorLazy . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h + return () + + +frequency :: Float -> Param.T p Float +frequency = return + + +saw :: IO () +saw = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + Sig.osciSaw 0 0.01 + +exponential :: IO () +exponential = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + Sig.exponential2 50000 1 + +triangle :: IO () +triangle = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + Sig.osci Wave.triangle 0.25 0.01 + +trianglePack :: IO () +trianglePack = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + SigP.mapSimple Wave.triangle $ + SigPS.packSmall $ + SigP.osciCore 0.25 (frequency 4.015803e-4) + +trianglePacked :: IO () +trianglePacked = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (CausalPS.osciSimple Wave.triangle + $< SigPS.constant 0.25 + $* SigPS.constant 0.01) + +triangleReplicate :: IO () +triangleReplicate = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (CausalPS.shapeModOsci + (\k p -> do + x <- Wave.triangle =<< Wave.replicate k p + y <- Wave.approxSine4 =<< Wave.halfEnvelope p + A.mul x y) + $< SigPS.rampInf 1000000 + $< SigPS.constant 0 + $* SigPS.constant 0.01) + +rationalSine :: IO () +rationalSine = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< (0.001 + SigPS.rampInf 10000000) + $< SigPS.constant 0 + $* SigPS.constant 0.01) + +rationalSineStereo :: IO () +rationalSineStereo = + SV.writeFile "speedtest.f32" $ + SigStL.unpackStereoStrict $ + asStereoInterleaved $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + SigP.mapSimple StereoInt.interleave $ + liftA2 Stereo.cons + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< (0.001 + SigPS.rampInf 10000000) + $< SigPS.constant (-0.25) + $* SigPS.constant 0.00999) + (CausalPS.shapeModOsci Wave.rationalApproxSine1 + $< (0.001 + SigPS.rampInf 10000000) + $< SigPS.constant 0.25 + $* SigPS.constant 0.01001) + + +pingSig :: Float -> Sig.T (Value Float) +pingSig freq = + Sig.envelope + (Sig.exponential2 50000 1) + (Sig.osciSaw 0.5 freq) + +pingSigP :: SigP.T Float (Value Float) +pingSigP = + let freq = id + in SigP.envelope + (SigP.exponential2 50000 1) + (SigP.osciSaw 0.5 freq) + +ping :: IO () +ping = + SV.writeFile "speedtest.f32" $ + asMono $ + Sig.render 10000000 $ + pingSig 0.01 + +pingSigPacked :: SigP.T Float (Serial.Value D4 Float) +pingSigPacked = + let freq = id + in SigP.envelope + (SigPS.exponential2 50000 1) + (SigPS.osciSimple Wave.saw 0 freq) + +pingPacked :: IO () +pingPacked = + SV.writeFile "speedtest.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) 0.01) $ + pingSigPacked + +pingUnpack :: IO () +pingUnpack = + SV.writeFile "speedtest.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 0.01) $ + SigPS.unpack $ + pingSigPacked + +pingSmooth :: IO () +pingSmooth = + SV.writeFile "speedtest-scalar.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 ()) $ + (Filt1.lowpassCausalP + $< (fmap Filt1Core.Parameter $ + SigP.mapSimple (A.sub (valueOf 1)) + (SigP.exponential2 50000 $# (1::Float))) + $* SigP.osciSimple Wave.triangle 0 (frequency 0.01)) + +pingSmoothPacked :: IO () +pingSmoothPacked = + SV.writeFile "speedtest-vector.f32" $ + asMonoPacked $ + (\xs -> SigP.render xs (div 10000000 4) ()) $ + (Filt1.lowpassCausalPackedP + $< (fmap Filt1Core.Parameter $ + SigP.mapSimple (A.sub (valueOf 1)) + (SigP.exponential2 (50000/4) $# (1::Float))) + $* SigPS.osciSimple Wave.triangle 0 0.01) + +stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float)) +stereoOsciSaw freq = + liftA2 Stereo.cons + (Sig.osciSaw 0.0 (freq*1.001) `Sig.mix` + Sig.osciSaw 0.2 (freq*1.003) `Sig.mix` + Sig.osciSaw 0.1 (freq*0.995)) + (Sig.osciSaw 0.1 (freq*1.005) `Sig.mix` + Sig.osciSaw 0.7 (freq*0.997) `Sig.mix` + Sig.osciSaw 0.5 (freq*0.999)) + +stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float)) +stereoOsciSawPacked freq = + let mix4 = + Frame.mixVector . + flip asTypeOf (undefined :: Value (Vector D4 Float)) + in liftA2 Stereo.cons + (Sig.map mix4 $ + Sig.osciPlain Wave.saw + (value $ constVector $ map constOf [0.0, 0.2, 0.1, 0.4]) + (value $ constVector $ + map (constOf . (freq*)) [1.001, 1.003, 0.995, 0.996])) + (Sig.map mix4 $ + Sig.osciPlain Wave.saw + (value $ constVector $ map constOf [0.1, 0.7, 0.5, 0.7]) + (value $ constVector $ + map (constOf . (freq*)) [1.005, 0.997, 0.999, 1.001])) + +stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float)) +stereoOsciSawPacked2 freq = + Sig.map (Frame.mixVectorToStereo . + flip asTypeOf (undefined :: Value (Vector D8 Float))) $ + Sig.osciPlain (Wave.trapezoidSkew (A.fromRational' 0.2)) + (valueOf $ + LLVM.toVector (0.0, 0.2, 0.1, 0.4, 0.1, 0.7, 0.5, 0.7)) + (value $ constVector $ + map (constOf . (freq*)) $ + [1.001, 1.003, 0.995, 0.996, 1.005, 0.997, 0.999, 1.001]) + +stereo :: IO () +stereo = + SV.writeFile "speedtest.f32" $ + asStereo $ + Sig.render 10000000 $ + Sig.amplifyStereo 0.25 $ + stereoOsciSawPacked2 0.01 + +lazy :: IO () +lazy = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + Sig.renderChunky (SVL.chunkSize 100000) + {- SVL.defaultChunkSize - too slow -} $ + Sig.envelope + (Sig.exponential2 50000 1) + (Sig.osci Wave.sine 0.5 0.01 :: Sig.T (Value Float)) + +lazyStereo :: IO () +lazyStereo = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 0.25 $ + stereoOsciSawPacked 0.01 + +packTake :: IO () +packTake = + SVL.writeFile "speedtest.f32" $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 1000)) () $ + SigPS.packRotate $ + (CausalP.take 5 $* + SigP.osciSimple Wave.saw 0 (frequency 0.01)) + +chord :: Float -> Sig.T (Stereo.T (Value Float)) +chord base = + {- + This exceeds available vector registers + and thus needs more stack accesses. + Thus it needs twice as much time as the simple mixing. + However doing all 32 oscillators in parallel + and mix them in one go might be still faster. + + foldl1 (Sig.zipWith Frame.mixStereoV) $ + -} + foldl1 Sig.mix $ + map (\f -> stereoOsciSawPacked2 (base*f)) $ + 0.25 : 1.00 : 1.25 : 1.50 : [] + +lazyChord :: IO () +lazyChord = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 0.1 $ + chord 0.005 + +filterSweepComplex :: IO () +filterSweepComplex = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 0.3 $ + Causal.apply BandPass.causal $ + Sig.zip + (Sig.map (BandPass.parameter (valueOf 100)) $ + Sig.map (\x -> 0.01 * exp (2 * return x)) $ + Sig.osci Wave.sine 0 (0.1/44100)) $ + chord 0.005 + +lfoSine :: + (Memory.C a) => + (forall r. Value Float -> LLVM.CodeGenFunction r a) -> + Param.T p Float -> + SigP.T p a +lfoSine f reduct = + SigP.mapSimple f $ + SigP.mapSimple (\x -> 0.01 * exp (2 * return x)) $ + SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100) + +filterSweep :: IO () +filterSweep = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (0.2 * + CtrlP.processCtrlRate 128 + (lfoSine (Filt2.bandpassParameter (valueOf 100))) + $* SigP.osciSimple Wave.saw 0 (frequency 0.01)) + +filterSweepPacked :: IO () +filterSweepPacked = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (0.2 * + CtrlPS.processCtrlRate 128 + (lfoSine (Filt2.bandpassParameter (valueOf 100))) + $* SigPS.osciSimple Wave.saw 0 0.01) + +exponentialFilter2Packed :: IO () +exponentialFilter2Packed = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 16) $ + asMonoPacked16 $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (Filt2.causalPackedP + $< (SigP.constant $# + Filt2Core.Parameter (1::Float) 0 0 0 0.99) + $* ( +-- (CausalP.delay1 $# Serial.fromList [0.1,0.01,0.001,0.0001::Float]) +-- (CausalP.delay1 $# Serial.fromList [1::Float]) + (CausalP.delay1 $# Serial.fromList ((1::Float):repeat 0)) + $* 0)) + +filterSweepPacked2 :: IO () +filterSweepPacked2 = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (0.2 * + CtrlP.processCtrlRate 128 + (lfoSine (Filt2P.bandpassParameter (valueOf 100))) + $* SigP.osciSimple Wave.saw 0 (frequency 0.01)) + +butterworthNoisePacked :: IO () +butterworthNoisePacked = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalPS.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSine (Butterworth.parameter TypeNum.d3 FiltR.Lowpass (valueOf 0.5))) + $* SigPS.noise 0 0.3) + +chebyshevNoisePacked :: IO () +chebyshevNoisePacked = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalPS.amplify 0.2 . + CtrlPS.processCtrlRate 128 + (lfoSine (Chebyshev.parameterA TypeNum.d5 FiltR.Lowpass (valueOf 0.5))) + $* SigPS.noise 0 0.3) + +{- +Provoke non-aligned vector accesses by calling alloca for a record of 5 floats +in LLVM-2.6. +However, the vector accesses are those of noise. +Using scalar Noise there is no problem. +-} +noiseAllocaBug :: IO () +noiseAllocaBug = + SVL.writeFile "speedtest.f32" $ + SVL.take (div 10000000 4) $ + asMonoPacked $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (CausalPS.amplify 0.2 . Filt2.causalPackedP + $< (SigP.mapSimple (const $ Memory.load =<< LLVM.alloca) $ + (SigP.constant $# (0::Float))) + $* SigPS.noise 0 0.3) + +noiseAllocaScalar :: IO () +noiseAllocaScalar = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ + (0.2 * Filt2.causalP + $< (SigP.mapSimple (const $ + (Memory.load =<< LLVM.alloca :: + LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $ + (SigP.constant $# (0::Float))) + $* SigP.noise 0 0.3) + + +upsample :: IO () +upsample = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + Sig.renderChunky (SVL.chunkSize 100000) $ + (let reduct = 128 :: Float + in Sig.interpolateConstant reduct $ + Sig.osci Wave.sine 0 (reduct*0.1/44100)) + + +filterSweepControlRateCausal :: + Causal.T + (Stereo.T (Value Float)) + (Stereo.T (Value Float)) +filterSweepControlRateCausal = + Causal.amplifyStereo 0.3 <<< + BandPass.causal <<< + Causal.feedFst + (let reduct = 128 + in Sig.interpolateConstant reduct $ + Sig.map (BandPass.parameter (valueOf 100)) $ + Sig.map (\x -> 0.01 * exp (2 * return x)) $ + Sig.osci Wave.sine 0 (reduct*0.1/44100)) + +filterSweepControlRateProc :: + Sig.T (Stereo.T (Value Float)) -> + Sig.T (Stereo.T (Value Float)) +filterSweepControlRateProc = + Causal.apply filterSweepControlRateCausal + +{- | +Trigonometric functions are very slow in LLVM +because they are translated to calls to C's math library. +Thus it is advantageous to compute filter parameters +at a lower rate and interpolate constantly. +-} +filterSweepControlRate :: IO () +filterSweepControlRate = + SVL.writeFile "speedtest.f32" $ + asStereo $ + SVL.take 10000000 $ + Sig.renderChunky (SVL.chunkSize 100000) $ + filterSweepControlRateProc $ + chord 0.005 + + +filterSweepMusic :: IO () +filterSweepMusic = + do music <- SV.readFile "lichter.f32" + SVL.writeFile "speedtest.f32" $ + asStereo $ + Sig.renderChunky (SVL.chunkSize 100000) $ + Sig.amplifyStereo 20 $ + filterSweepControlRateProc $ + Sig.fromStorableVector $ + (music :: SV.Vector (Stereo.T Float)) + + +playFilterSweepMusicLazy :: IO () +playFilterSweepMusicLazy = do + IO.withFile "lichter.f32" IO.ReadMode $ \h -> + playStereo . +-- Sig.amplifyStereo 1.125 . + Sig.amplifyStereo 20 . + filterSweepControlRateProc . + Sig.fromStorableVectorLazy . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h + return () + +playFilterSweepMusicCausal :: IO () +playFilterSweepMusicCausal = do + do music <- SV.readFile "lichter.f32" + _ <- SoxPlay.simple SV.hPut SoxOption.none 44100 $ + asStereo $ + Causal.applyStorable + (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $ + (music :: SV.Vector (Stereo.T Float)) + return () + +playFilterSweepMusicCausalLazy :: IO () +playFilterSweepMusicCausalLazy = do + IO.withFile "lichter.f32" IO.ReadMode $ \h -> + playStereoVector . + Causal.applyStorableChunky + (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) . + asStereo . snd + =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h + return () + +arrangeLazy :: IO () +arrangeLazy = do + IO.hSetBuffering IO.stdout IO.NoBuffering + arrange <- SigStL.makeArranger + print $ + arrange (SVL.chunkSize 2) $ + EventList.fromPairList $ + (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) : + (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) : + (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) : + -- repeat (2, SVL.empty) +-- (2, SVL.empty) : +-- (2, SVL.empty) : +-- (2::NonNeg.Int, error "undefined sound") : + error "end of list" + -- [] + + +{- | +This is inefficient because pingSig is compiled by LLVM +for every occurence of the sound! + +randomTones :: IO () +randomTones = do + playMonoVector $ + SigStL.arrange (SVL.chunkSize 12345) $ + EventList.fromPairList $ zip + (cycle $ map (flip div 16 . (44100*)) [1,2,3]) + (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) . + pingSig . (0.01*)) + [1,1.25,1.5,2]) + return () +-} + +{- | +So far we have not managed to compile signals +that depend on parameters. +Thus in order to avoid much recompilation, +we compile and render a few sounds in advance. +-} +pingTones :: [SVL.Vector Float] +pingTones = + map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) . + pingSig . (0.01*)) + [1,1.25,1.5,2] + +pingTonesIO :: IO [SVL.Vector Float] +pingTonesIO = + fmap + (\pingVec -> + map + (SVL.take 44100 . + pingVec (SVL.chunkSize 4321) . + (0.01*)) + [1,1.25,1.5,2]) + (SigP.runChunky pingSigP) + +{- +Arrange itself does not seem to have a space leak with temporary data. +However it may leak sound data. +This is not very likely because this would result in a large memory leak. + +Generate random tones in order to see whether generated sounds leak. +How does 'arrange' compare with 'concat'? +-} + +cycleTones :: IO () +cycleTones = do +-- playMono $ + pings <- pingTonesIO + SVL.writeFile "test.f32" $ +-- Play.auto (0.01::Double) 44100 $ + asMono $ +{- +after 13min runtime memory consumption increased from 2.5 to 3.9 +and we get lot of buffer underruns with this implementation of amplification +(renderChunky . amplify . fromStorableVector) +-} + Sig.renderChunky (SVL.chunkSize 432109) $ + Sig.amplify 0.1 $ + Sig.fromStorableVectorLazy $ +{- +after 20min memory consumption increased from 2.5 to 3.4 +and we get lot of buffer underruns with applyStorableChunky +-} +{- +applyStorableChunky applied to concatenated zero vectors +starts with memory consumption 1.0 and after an hour, it's still 1.1 +without buffer underruns. +-} +{- + CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $ + asMono $ +-} +{- +with chunksize 12345678 +after 50min runtime the memory consumption increased from 12.0 to 26.2 + +with chunksize 123 +after 25min runtime the memory consumption is constant 7.4 +however at start time there 5 buffer underruns, but no more +probably due to initial LLVM compilation + +with chunksize 1234567 and SVL.replicate instead of pingTones +we get memory consumption from 1.3 to 3.2 in 15min, +while producing lots of buffer underruns. +After 45min in total, it is still 3.2 of memory consumption. +Is this a memory leak, or isn't it? + +with chunksize 12345678 and SVL.replicate +we get from 5.6 to 10.2 in 3min +to 14.9 after total 13min. +-} +{- + SigStL.arrange (SVL.chunkSize 12345678) $ + EventList.fromPairList $ zip + (repeat (div 44100 8)) +-- (cycle $ map (flip div 4 . (44100*)) [1,2,3]) +-} +{- +With plain concatenation of those zero vectors +we stay constantly at 0.4 memory consumption and no buffer underruns over 30min. +-} + SVL.concat + (cycle pings) +-- (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0) + return () + + +tonesChunkSize :: SVL.ChunkSize +numTones :: Int + +{- +For one-time-compiled fill functions, +larger chunks have no relevant effect on the processing speed. +-} +(tonesChunkSize, numTones) = + (SVL.chunkSize 441, 200) +-- (SVL.chunkSize 44100, 200) + +fst :: Arrow arrow => arrow (a,b) a +fst = arr P.fst + +snd :: Arrow arrow => arrow (a,b) b +snd = arr P.snd + + +{-# NOINLINE makePing #-} +makePing :: IO ((Float,Float) -> SVL.Vector Float) +makePing = + let freq = snd + halfLife = fst + in fmap ($tonesChunkSize) $ + SigP.runChunky + (SigP.envelope + (SigP.exponential2 halfLife 1) + (SigP.osciSaw 0.5 freq)) + +tonesDown :: IO () +tonesDown = do + let dist = div 44100 10 + pingp <- makePing + arrange <- SigStL.makeArranger + playMonoVector $ + CausalP.applyStorableChunky (CausalP.amplify id) (0.03::Float) $ + arrange tonesChunkSize $ + EventList.fromPairList $ zip + (repeat (NonNeg.fromNumber dist)) + (map (SVL.take (numTones * dist) . curry pingp 50000) $ + iterate (0.999*) 0.01) + return () + + +vibes :: SigP.T (Float,Float) (Value Float) +vibes = + let freq = snd + modDepth = fst + halfLife = 5000 + -- sine = Wave.sine + sine = Wave.approxSine4 + in CausalP.envelope + $< SigP.exponential2 halfLife 1 + $* (((CausalP.osciSimple sine + $< (CausalP.envelope + $< SigP.exponential2 halfLife modDepth + $* (CausalP.osciSimple sine + $* SigP.constant (return (0::Float) &&& (2*freq))))) + <<< + CausalP.mapLinear (0.01*freq) freq + <<< + CausalP.osciSimple sine) + $* SigP.constant (return (0::Float, 0.0001::Float))) + +makeVibes :: IO ((Float,Float) -> SVL.Vector Float) +makeVibes = + fmap ($tonesChunkSize) $ + SigP.runChunky vibes + +vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> IO (SVL.Vector Float) +vibesCycleVector pingp = + (\evs -> fmap (\arrange -> arrange tonesChunkSize evs) SigStL.makeArranger) $ + EventList.fromPairList $ zip + (repeat 5000) + (map (SVL.take 50000 . pingp) $ + zip + (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0) + (cycle $ map (0.01*) [1, 1.25, 1.5, 2])) + +vibesCycle :: IO () +vibesCycle = do + sig <- vibesCycleVector =<< makeVibes + playMonoVector $ + CausalP.applyStorableChunky (CausalP.amplify id) (0.2::Float) sig + return () + +vibesEcho :: IO () +vibesEcho = do + sig <- vibesCycleVector =<< makeVibes + playMonoVector $ + CausalP.applyStorableChunky + (CausalP.amplify id <<< + CausalP.comb 0.5 7000) + (0.2::Float) sig + return () + +vibesReverb :: IO () +vibesReverb = do + sig <- vibesCycleVector =<< makeVibes + playMonoVector $ + CausalP.applyStorableChunky + (CausalP.amplify id <<< + CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000)) + (0.3::Float) sig + return () + +vibesReverbStereo :: IO () +vibesReverbStereo = do + sig <- vibesCycleVector =<< makeVibes + playStereoVector $ + CausalP.applyStorableChunky + (CausalP.amplifyStereo id <<< + CausalP.stereoFromChannels + (CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000)) + (CausalP.reverb (mkStdGen 857) 16 (0.9,0.97) (400,1000)) <<< + CausalP.mapSimple Frame.stereoFromMono) + (0.3::Float) sig + return () + + + +stair :: IO () +stair = + SVL.writeFile "speedtest.f32" $ + SVL.take 10000000 $ + asMono $ + flip (SigP.renderChunky tonesChunkSize) () $ + SigP.piecewiseConstant $ + return $ + EventListBT.fromPairList $ + zip + (iterate (/2) (1::Float)) + (iterate (2*) (1::NonNeg.Int)) + + +filterBass :: IO () +filterBass = do + playStereoVector $ + asStereo $ + flip (SigP.renderChunky tonesChunkSize) () $ + CausalP.apply + (BandPass.causalP + <<< + CausalP.feedSnd + (liftA2 Stereo.cons + (SigP.osciSimple Wave.saw 0 (frequency 0.001499)) + (SigP.osciSimple Wave.saw 0 (frequency 0.001501))) + <<< + CausalP.mapSimple (BandPass.parameter (valueOf (100::Float)))) $ + SigP.piecewiseConstant $ + return $ EventListBT.fromPairList $ + zip + (map (((0.03::Float)*) . (2**) . (/12) . fromInteger) $ + randomRs (0,12) (mkStdGen 998)) + (repeat (10000::NonNeg.Int)) + + return () + + +{- | +This function is not very efficient, +since it compiles an LLVM mixing routine +for every pair of mixer inputs. +-} +mixVectorRecompile :: + SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorRecompile xs ys = + Sig.renderChunky tonesChunkSize $ + Sig.mix + (Sig.fromStorableVectorLazy xs) + (Sig.fromStorableVectorLazy ys) + +mixVectorParamIO :: + IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float) +mixVectorParamIO = + fmap curry $ + fmap ($tonesChunkSize) $ + SigP.runChunky + (SigP.mix + (SigP.fromStorableVectorLazy fst) + (SigP.fromStorableVectorLazy snd)) + +mixVectorCausalIO :: + IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float) +mixVectorCausalIO = + CausalP.runStorableChunky + (CausalP.mix $< + SigP.fromStorableVectorLazy id) + +mixVectorCausal :: + SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorCausal = + CausalP.applyStorableChunky + (CausalP.mix $< + SigP.fromStorableVectorLazy id) + +mixVectorStereo :: + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) +mixVectorStereo = + CausalP.applyStorableChunky + (CausalP.mix $< + SigP.fromStorableVectorLazy id) + +mixVectorStereoIO :: + IO (SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float) -> + SVL.Vector (Stereo.T Float)) +mixVectorStereoIO = + CausalP.runStorableChunky + (CausalP.mix $< + SigP.fromStorableVectorLazy id) + +{- +slightly slower than mixVectorParam +-} +mixVectorHaskell :: + SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float +mixVectorHaskell = SVL.zipWith (+) + +toneMix :: IO () +toneMix = do + pingp <- makePing + mix <- mixVectorCausalIO + playMonoVector $ + Causal.applyStorableChunky (Causal.amplify 0.1) $ + foldl1 mix $ + map (curry pingp 1000000) $ + take numTones $ + iterate (*(2/3)) 0.01 + return () + +fadeEnvelope :: SigP.T (Int, Int) (Value Float) +fadeEnvelope = + let dur :: Param.T (Int, Int) Float + dur = fmap fromIntegral fst + in SigP.parabolaFadeIn dur + `SigP.append` + (CausalP.take snd $* (SigP.constant $# (1::Float))) + `SigP.append` + SigP.parabolaFadeOut dur + +fadeEnvelopeWrite :: IO () +fadeEnvelopeWrite = + SVL.writeFile "speedtest.f32" $ + asMono $ + SigP.renderChunky (SVL.chunkSize 1234) + fadeEnvelope (100000, 200000) + + +-- | normalize a list of numbers, such that they have a specific average +-- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs +normalizeLevel :: Fractional a => a -> [a] -> [a] +normalizeLevel newAvrg xs = + let avrg = sum xs / genericLength xs + in map ((newAvrg-avrg)+) xs + +stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float)) +stereoOsciSawP = + let freq = id + n = 5 + volume = pure $ recip $ sqrt $ fromIntegral n :: Param.T p Float + detunes = + normalizeLevel 1 $ take (2*n) $ + randomRs (0,0.03) $ mkStdGen 912 + phases = + randomRs (0,1) $ mkStdGen 54 + tones = + zipWith + (\phase detune -> + (SigP.osciSaw $# phase) (fmap (detune*) freq)) + phases detunes + (tonesLeft,tonesRight) = splitAt n tones + in SigP.amplifyStereo volume $ + liftA2 Stereo.cons + (foldl1 SigP.mix tonesLeft) + (foldl1 SigP.mix tonesRight) + +stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float) +stereoOsciSawVector = + SigP.renderChunky tonesChunkSize stereoOsciSawP + +stereoOsciSawChord :: [Float] -> SVL.Vector (Stereo.T Float) +stereoOsciSawChord = + foldl1 mixVectorStereo . map stereoOsciSawVector + +stereoOsciSawPad :: Int -> [Float] -> SVL.Vector (Stereo.T Float) +stereoOsciSawPad dur pitches = + let attack = 20000 + in CausalP.applyStorableChunky + (CausalP.envelopeStereo $< fadeEnvelope) + (attack, dur-attack) + (stereoOsciSawChord pitches) + +a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1, + a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2, + a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3, + a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float +a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 : + a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 : + a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 : + a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ = + iterate ((2 ** recip 12) *) (55/44100) + + +chordSequence :: [(Int, [Float])] +chordSequence = + (2, [f1, f2, a2, c3]) : + (1, [g1, g2, b2, d3]) : + (2, [c2, g2, c3, e3]) : + (1, [f1, a2, c3, f3]) : + (2, [g1, g2, b2, d3]) : + (1, [gs1, gs2, b2, e3]) : + (2, [a1, e2, a2, c3]) : + (1, [g1, g2, b2, d3]) : + (3, [c2, g2, c3, e3]) : + + (2, [f1, f2, a2, c3]) : + (1, [g1, g2, b2, d3]) : + (2, [c2, g2, c3, e3]) : + (1, [f1, a2, c3, f3]) : + (2, [g1, g2, b2, d3]) : + (1, [gs1, gs2, b2, e3]) : + (2, [a1, e2, a2, c3]) : + (1, [g1, g2, b2, e3]) : + (3, [c2, e2, g2, c3]) : + [] + + +withDur :: (Int -> a -> v) -> Int -> a -> (v, NonNeg.Int) +withDur f d ps = + let dur = d*30000 + in (f dur ps, NonNeg.fromNumber dur) + + +padMusic :: IO () +padMusic = do + arrange <- SigStL.makeArranger + playStereoVector $ + CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.1::Float) $ + arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (\(d,ps) -> withDur stereoOsciSawPad d ps) + chordSequence + return () + + +lowpassSweepControlRateCausal :: + CausalP.T p + (Stereo.T (Value Float)) + (Stereo.T (Value Float)) +lowpassSweepControlRateCausal = +-- CausalP.stereoFromVector $ + CausalP.stereoFromMono $ + UniFilter.lowpass ^<< + CtrlP.processCtrlRate 128 + (lfoSine (UniFilter.parameter (valueOf (10::Float)))) + + +moogSweepControlRateCausal :: + CausalP.T p + (Stereo.T (Value Float)) + (Stereo.T (Value Float)) +moogSweepControlRateCausal = +-- CausalP.stereoFromVector $ + CausalP.stereoFromMono $ + CtrlP.processCtrlRate 128 + (lfoSine (Moog.parameter TypeNum.d8 (valueOf (10::Float)))) + + +filterMusic :: IO () +filterMusic = do + arrange <- SigStL.makeArranger + playStereoVector $ + CausalP.applyStorableChunky + (CausalP.amplifyStereo id <<< + moogSweepControlRateCausal) (0.05::Float) $ + arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (\(d,ps) -> withDur stereoOsciSawPad d ps) + chordSequence + return () + + + +stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float)) +stereoOsciSawVectorIO = + fmap ($tonesChunkSize) $ + SigP.runChunky $ + stereoOsciSawP + +applyFadeEnvelopeIO :: + IO (Int -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float)) +applyFadeEnvelopeIO = + fmap + (\envelope dur sig -> + let attack = 20000 + in envelope (attack, dur-attack) sig) + (CausalP.runStorableChunky + (CausalP.envelopeStereo $< fadeEnvelope)) + +stereoOsciSawChordIO :: IO ([Float] -> SVL.Vector (Stereo.T Float)) +stereoOsciSawChordIO = do + sawv <- stereoOsciSawVectorIO + mix <- mixVectorStereoIO + return (foldl1 mix . map sawv) + +stereoOsciSawPadIO :: IO (Int -> [Float] -> SVL.Vector (Stereo.T Float)) +stereoOsciSawPadIO = do + chrd <- stereoOsciSawChordIO + envelope <- applyFadeEnvelopeIO + return $ + \ dur pitches -> envelope dur (chrd pitches) + +padMusicIO :: IO () +padMusicIO = do + arrange <- SigStL.makeArranger + pad <- stereoOsciSawPadIO + playStereoVector $ + CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.08::Float) $ + arrange tonesChunkSize $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (uncurry (withDur pad)) $ + chordSequence + return () + +{- +Apply the envelope separately to each tone of the chord +and mix all tones by 'arrange'. +-} +padMusicSeparate :: IO () +padMusicSeparate = do + arrange <- SigStL.makeArranger + osci <- stereoOsciSawVectorIO + env <- applyFadeEnvelopeIO + playStereoVector $ + CausalP.applyStorableChunky (CausalP.amplifyStereo id) (0.08::Float) $ + arrange tonesChunkSize $ + EventList.flatten $ + EventListTM.switchTimeR const $ + EventListMT.consTime 0 $ + EventListBT.fromPairList $ + map (uncurry (withDur (\d ps -> map (\p -> env d (osci p)) ps))) $ + chordSequence + return () + + +delay :: IO () +delay = + SVL.writeFile "speedtest.f32" $ + asMono $ + flip (SigP.renderChunky tonesChunkSize) (0, 10000) $ + CausalP.apply + ((CausalP.delay $# (0::Float)) fst + <<< CausalP.take snd) $ + SigP.osciSaw 0 (frequency 0.01) + +delayStereo :: IO () +delayStereo = + SVL.writeFile "speedtest.f32" $ + asStereo $ + flip (SigP.renderChunky tonesChunkSize) (7, 10000) $ + CausalP.apply + (CausalP.take snd + <<< + liftA2 Stereo.cons + id ((CausalP.delay $# (0::Float)) fst)) $ + SigP.osciSaw 0 (frequency 0.01) + + + +allpassControl :: + (TypeNum.NaturalT n) => + n -> + SigP.T Float (Allpass.CascadeParameter n (Value Float)) +allpassControl order = + let reduct = id + in SigP.interpolateConstant reduct $ + lfoSine (Allpass.flangerParameter order) reduct + +allpassPhaserCausal, allpassPhaserPipeline :: + SigP.T Float (Value Float) -> + SigP.T Float (Value Float) +allpassPhaserCausal = + let order = TypeNum.d16 + in CausalP.apply $ + 0.5 * + Allpass.phaserP <<< + CausalP.feedFst (allpassControl order) + +allpassPhaserPipeline = + let order = TypeNum.d16 + in -- (F.nest (TypeNum.fromIntegerT order) SigP.tail .) $ + (SigP.drop (return $ TypeNum.fromIntegerT order) .) $ + CausalP.apply $ + 0.5 * + Allpass.phaserPipelineP <<< + CausalP.feedFst (allpassControl order) + +allpassPhaser :: IO () +allpassPhaser = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) 128 $ + allpassPhaserPipeline $ + SigP.osciSaw 0 (frequency 0.01) + +noise :: IO () +noise = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (SigP.noise 0 0.3) + +noisePacked :: IO () +noisePacked = + SVL.writeFile "speedtest.f32" $ + asMonoPacked $ + SVL.take (div 10000000 4) $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (SigPS.noise 0 0.3) +-- (SigPS.pack (SigP.noise 0 0.3)) +-- (SigPS.packSmall (SigP.noise 0 0.3)) + +frequencyModulationStorable :: IO () +frequencyModulationStorable = do + smp <- SigP.runChunky (SigP.osciSaw 0 (frequency 0.01)) + SVL.writeFile "speedtest.f32" $ + asMono $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy $# + (SVL.take 1000000 $ asMono $ + smp (SVL.chunkSize 1000) ())) + $*# (0.3::Float)) + +frequencyModulation :: IO () +frequencyModulation = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (CausalP.frequencyModulationLinear + (SigP.osciSaw 0 (frequency 0.01)) + $* SigP.exponential2 500000 1) + +frequencyModulationStereo :: IO () +frequencyModulationStereo = do + smp <- SigP.runChunky (SigP.osciSaw 0 (frequency 0.01)) + SVL.writeFile "speedtest.f32" $ + asStereo $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (CausalP.stereoFromMono + (CausalP.frequencyModulationLinear + (SigP.fromStorableVectorLazy $# + (SVL.take 1000000 $ asMono $ + smp (SVL.chunkSize 1000) ()))) + $*# Stereo.cons (0.2999::Float) 0.3001) + +frequencyModulationProcess :: IO () +frequencyModulationProcess = + SVL.writeFile "speedtest.f32" . + asMono . + (\f -> + f () $ asMono $ + SigP.renderChunky (SVL.chunkSize 512) + (1 + 0.1 * SigP.osciSimple Wave.approxSine2 (pure (0::Float)) 0.0001) + ()) =<< + CausalP.runStorableChunky + (CausalP.frequencyModulationLinear + (CausalP.take 50000 $* + SigP.osciSaw 0 (frequency 0.01))) + + + +quantize :: IO () +quantize = +{- + SV.writeFile "speedtest.f32" $ + asMono $ + (\xs -> SigP.render xs 10000000 ()) $ +-} + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + ((CausalP.quantizeLift $# (5.5::Float)) id $* + SigP.osciSaw 0 (frequency 0.01)) + +quantizedFilterControl :: IO () +quantizedFilterControl = + SVL.writeFile "speedtest.f32" $ + asMono $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + CausalP.apply (0.3 * (UniFilter.lowpass ^<< CtrlP.process)) $ + SigP.zip + ((CausalP.quantizeLift $# (128::Float)) + (CausalP.mapSimple (UniFilter.parameter (valueOf 100)) <<< +-- (CausalP.mapSimple (Moog.parameter TypeNum.d8 (valueOf 100)) <<< + CausalP.mapSimple (\x -> 0.01 * exp (2 * return x))) + $* SigP.osciSimple Wave.approxSine2 0 (frequency (0.1/44100))) $ + SigP.osciSaw 0 (frequency 0.01) + + +arrowNonShared :: IO () +arrowNonShared = + SVL.writeFile "speedtest.f32" $ + asStereo $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (let osci = CausalP.osciSimple Wave.approxSine2 + in liftA2 Stereo.cons osci osci $* + SigP.constant (return (0::Float, 0.01::Float))) + +arrowShared :: IO () +arrowShared = + SVL.writeFile "speedtest.f32" $ + asStereo $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (let osci = Func.lift (CausalP.osciSimple Wave.approxSine2) + in Func.compile (liftA2 Stereo.cons osci osci) $* + SigP.constant (return (0::Float, 0.01::Float))) + +arrowIndependent :: IO () +arrowIndependent = + SVL.writeFile "speedtest.f32" $ + asStereo $ + SVL.take 10000000 $ + flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ + (let osci = CausalP.osciSimple Wave.approxSine2 + in Func.compile + (fmap (uncurry Stereo.cons) $ + osci *** osci Func.$& + Func.lift id) $* + SigP.constant (return ((0::Float, 0.01::Float), (0.25::Float, 0.01001::Float)))) + + +main :: IO () +main = do + LLVM.initializeNativeTarget + arrowIndependent diff --git a/jack/Synthesizer/LLVM/Server/JACK.hs b/jack/Synthesizer/LLVM/Server/JACK.hs new file mode 100644 --- /dev/null +++ b/jack/Synthesizer/LLVM/Server/JACK.hs @@ -0,0 +1,227 @@ +module Main where +-- module Synthesizer.LLVM.Server.JACK where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange + +import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorSize, vectorSize, ) + +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.Base as SVB +import Foreign.Marshal.Array (copyArray, ) + +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Absolute.TimeTime as EventListAbsTT +import qualified Data.EventList.Absolute.TimeMixed as EventListAbsTM + +import qualified Synthesizer.Zip as Zip + +import qualified Sound.JACK.Audio as JackAudio +import qualified Sound.JACK.MIDI as JackMIDI +import qualified Sound.JACK.Exception as JackExc +import qualified Sound.JACK as JACK + +import Data.IORef (newIORef, readIORef, writeIORef, ) + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message as Msg + +import qualified Control.Monad.Exception.Synchronous as Exc +import qualified Control.Monad.Trans.Class as MT + +import Control.Arrow (Arrow, (<<<), (^<<), arr, ) + +{- +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Chunky as NonNegChunky +-} +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import Prelude hiding (Real, id, ) + + +type StereoVector = StereoInt.T VectorSize Real + +type StrictTime = NonNegW.Integer + + +strictTimeFromNFrames :: JACK.NFrames -> StrictTime +strictTimeFromNFrames (JACK.NFrames n) = + NonNegW.fromNumberMsg "strictTimeFromNFrames" $ fromIntegral n + +writeBlock :: JackAudio.Port JACK.Output -> SV.Vector Real -> IO () +writeBlock output block = do + outArr <- + JackAudio.getBufferPtr output $ + JACK.NFrames $ fromIntegral $ SV.length block + SVB.withStartPtr (SV.map realToFrac block) $ + copyArray outArr + +{-# INLINE playFromEvents #-} +playFromEvents :: + (JACK.Client -> + (ports -> Exc.ExceptionalT JackExc.All IO ()) -> + Exc.ExceptionalT JackExc.All IO ()) -> + (ports -> block -> IO ()) -> + Option.T -> + (SampleRate Real -> + PIO.T Events block) -> + IO () +playFromEvents withOutPorts writeBlocks opt process = do + let Option.ClientName name = Option.clientName opt + JACK.handleExceptions $ + JACK.withClientDefault name $ \client -> + JACK.withPort client "input" $ \input -> + withOutPorts client $ \output -> do + sampleRate <- MT.lift $ JACK.getSampleRate client + case process (SampleRate $ fromIntegral sampleRate) of + PIO.Cons next create delete -> + {- + Is the use of 'bracket' correct? + I think 'delete' must be called with the final state, + not with the initial one. + -} + Exc.bracketT (MT.lift create) (MT.lift . delete) $ \start -> do + stateRef <- MT.lift $ newIORef start + let jackProcess nframes = do + evs <- JackMIDI.readEventsFromPort input nframes + MT.lift $ do + let deconsNFrames (JACK.NFrames n) = fromIntegral n + (block, state) <- + next + (EventListTT.collectCoincident $ + EventListTT.mapTime + (NonNegW.fromNumberMsg "JACK.playFromEvents") $ + EventListTT.fromAbsoluteEventList $ + EventListAbsTT.mapTime + (flip div (fromIntegral vectorSize) . + deconsNFrames) $ + EventListAbsTM.snocTime evs nframes) +{- + (EventListTT.collectCoincident $ + EventListTT.mapTime strictTimeFromNFrames $ + EventListTT.fromAbsoluteEventList $ + EventListAbsTM.snocTime evs nframes) +-} + =<< readIORef stateRef + writeIORef stateRef state + writeBlocks output block + JACK.withProcess client jackProcess $ + JACK.withActivation client $ MT.lift $ do + putStrLn $ "started " ++ name ++ "..." + JACK.waitForBreak +-- MT.lift $ readIORef stateRef + +playMonoFromEvents :: + Option.T -> + (SampleRate Real -> + PIO.T Events (SV.Vector Vector)) -> + IO () +playMonoFromEvents opt proc = + playFromEvents + (flip JACK.withPort "mono") + writeBlock + opt + (\sampleRate -> SigStL.unpackStrict ^<< proc sampleRate) + +playStereoFromEvents :: + Option.T -> + (SampleRate Real -> + PIO.T Events (Zip.T (SV.Vector Vector) (SV.Vector Vector))) -> + IO () +playStereoFromEvents opt proc = + playFromEvents + (\client f -> + JACK.withPort client "left" $ \left -> + JACK.withPort client "right" $ \right -> + f (left, right)) + (\(leftPort,rightPort) (Zip.Cons leftBlock rightBlock) -> + writeBlock leftPort leftBlock >> + writeBlock rightPort rightBlock) + opt + (\sampleRate -> + Zip.arrowSplit SigStL.unpackStrict SigStL.unpackStrict + ^<< + proc sampleRate) + + +keyboard :: IO () +keyboard = do + opt <- Option.get + proc <- Arrange.keyboard + + playMonoFromEvents opt $ proc (Option.channel opt) + + +type Events = MIO.Events Msg.T + +unconsStereo :: Stereo.T t -> (t, t) +unconsStereo x = + (Stereo.left x, Stereo.right x) + +keyboardFM :: IO () +keyboardFM = do + opt <- Option.get + playStereoFromEvents opt =<< + Arrange.keyboardFM (arr unconsStereo) (Option.channel opt) + + +keyboardDetuneFMCore :: + FilePath -> + IO (ChannelMsg.Channel -> VoiceMsg.Program -> + SampleRate Real -> + PIO.T + Events + (Zip.T (SV.Vector Vector) (SV.Vector Vector))) +keyboardDetuneFMCore = + Arrange.keyboardDetuneFMCore (arr unconsStereo) + +keyboardDetuneFM :: IO () +keyboardDetuneFM = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + playStereoFromEvents opt $ + proc (Option.channel opt) (VoiceMsg.toProgram 0) + +keyboardMultiChannel :: IO () +keyboardMultiChannel = do + opt <- Option.get + proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) + mix <- CausalP.processIO CausalP.mix + + playStereoFromEvents opt $ \ sampleRate -> + foldl1 + (\x y -> mix () <<< Zip.arrowFanout x y) + (map + (\chan -> + proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0) + sampleRate) + [0 .. 3]) + + +voder :: IO () +voder = do + opt <- Option.get + proc <- + Arrange.voder + (arr unconsStereo) + (Option.sampleDirectory opt) + + playStereoFromEvents opt $ \ sampleRate -> + proc (Option.channel opt) (VoiceMsg.toProgram 5) sampleRate + + +main :: IO () +main = keyboardMultiChannel diff --git a/render/Synthesizer/LLVM/Server/Render.hs b/render/Synthesizer/LLVM/Server/Render.hs new file mode 100644 --- /dev/null +++ b/render/Synthesizer/LLVM/Server/Render.hs @@ -0,0 +1,153 @@ +module Main (main) where +-- module Synthesizer.LLVM.Server.Render where + +import qualified Synthesizer.LLVM.Server.CausalPacked.Arrange as Arrange +import Synthesizer.LLVM.Server.CommonPacked + (vectorSize, vectorRate, ) + +import qualified Synthesizer.LLVM.Server.Option as Option +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.PiecewiseConstant.Signal as PC + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Storable.Signal as SigStL + +import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeMixed as EventListTM + +import qualified Synthesizer.Zip as Zip + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Sound.MIDI.File as MidiFile +import qualified Sound.MIDI.File.Event as FileEvent +import qualified Sound.MIDI.File.Load as Load + +import qualified Sound.Sox.Write as SoxWrite +import qualified Sound.Sox.Play as SoxPlay + +import Control.Arrow (Arrow, (<<<), arr, ) +import Control.Applicative ((<*>), ) + +import Data.Monoid (mempty, ) + +{- +import qualified Numeric.NonNegative.Chunky as NonNegChunky +import qualified Numeric.NonNegative.Class as NonNeg +-} +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import qualified System.Exit as Exit +import qualified System.IO as IO + +import Prelude hiding (Real, id, ) + + + +strictTimeFromChunkSize :: SVL.ChunkSize -> PC.StrictTime +strictTimeFromChunkSize (SVL.ChunkSize n) = + NonNegW.fromNumberMsg "strictTimeFromNFrames" $ fromIntegral n + + +keyboardMultiChannel :: + Option.T -> + IO (SampleRate Real -> + PIO.T (MIO.Events ChannelMsg.T) (SV.Vector (Stereo.T Real))) +keyboardMultiChannel opt = do + proc <- + Arrange.keyboardDetuneFMCore + (CausalP.mapSimple StereoInt.interleave) + (Option.sampleDirectory opt) + 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]) + +{- +This is the duration of rendering after the last MIDI event. + +Optimally we would stop rendering after the last sound ends. +Unfortunately with causal processes we have no way +to make the output audio stream longer than the input MIDI stream. +We might make the stream infinitely long +and add an End-Of-Stream marker in the MIDI input +that tells the 'arrange' process to stop after the last sound. +-} +padTime :: Integer +padTime = 2 + +render :: + Option.T -> + IO (MidiFile.T -> SVL.Vector (Stereo.T Real)) +render opt = do + proc <- keyboardMultiChannel opt + run <- PIO.runCont $ proc $ fmap fromIntegral $ Option.sampleRate opt + return $ + SVL.fromChunks . + run (const []) . + chopEvents (strictTimeFromChunkSize $ Option.chunkSize opt) . + flip EventListTM.snocTime + (NonNegW.fromNumberMsg "render end pad" $ + case Option.sampleRate opt of + SampleRate rate -> padTime * (fromIntegral $ div rate vectorSize)) . +-- flip EventListTM.snocTime (NonNegW.fromNumber 1) . +-- flip EventListTM.snocTime mempty . + EventList.collectCoincident . + EventList.mapMaybe (\ev -> + case ev of + FileEvent.MIDIEvent mev -> Just mev + _ -> Nothing) . + EventList.resample + (vectorRate $ fmap fromIntegral $ Option.sampleRate opt) . + (\(MidiFile.Cons typ division tracks) -> + MidiFile.mergeTracks typ $ + map (MidiFile.secondsFromTicks division) tracks) + +handleSoxExit :: IO Exit.ExitCode -> IO () +handleSoxExit sox = do + soxResult <- sox + case soxResult of + Exit.ExitSuccess -> return () + Exit.ExitFailure n -> do + IO.hPutStrLn IO.stderr $ + "'sox' aborted with exit code " ++ show n + Exit.exitFailure + +main :: IO () +main = do + (opt, midiPath, mWavePath) <- Option.get + case Option.sampleRate opt of + SampleRate rate -> + case mWavePath of + Nothing -> + handleSoxExit $ + SoxPlay.simple SVL.hPut mempty rate =<< + (render opt <*> Load.fromFile midiPath) + -- Rendering to SoX ends with an error code 13, but why? + Just wavePath -> + handleSoxExit $ + SoxWrite.simple SVL.hPut mempty wavePath rate =<< + (render opt <*> Load.fromFile midiPath) +{- + Just wavePath -> + SVL.writeFile wavePath =<< + (render opt <*> Load.fromFile midiPath) +-} diff --git a/src/Synthesizer/LLVM/ALSA/BendModulation.hs b/src/Synthesizer/LLVM/ALSA/BendModulation.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/ALSA/BendModulation.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- | -Various LLVM related instances of the BM.T type. -I have setup a separate module since these instances are orphan -and need several language extensions. --} -module Synthesizer.LLVM.ALSA.BendModulation ( - BM.T(..), - BM.deflt, - BM.shift, - ) where - -import qualified Synthesizer.MIDIValue.BendModulation as BM - -import qualified LLVM.Extra.Vector as Vector -import qualified LLVM.Extra.Class as Class -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Control as C -import qualified LLVM.Util.Loop as Loop -import qualified LLVM.Core as LLVM - -import Control.Applicative (liftA2, ) -import qualified Data.TypeLevel.Num as TypeNum - - -instance (Class.Zero a) => Class.Zero (BM.T a) where - zeroTuple = Class.zeroTuplePointed - -{- -instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BM.T a) where - buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) - -instance LLVM.IsTuple a => LLVM.IsTuple (BM.T a) where - tupleDesc = Class.tupleDescFoldable --} - -instance (Class.Undefined a) => Class.Undefined (BM.T a) where - undefTuple = Class.undefTuplePointed - -instance (C.Select a) => C.Select (BM.T a) where - select = C.selectTraversable - -{- -instance LLVM.CmpRet a b => - LLVM.CmpRet (BM.T a) (BM.T b) where --} - -instance Class.MakeValueTuple h l => - Class.MakeValueTuple (BM.T h) (BM.T l) where - valueTupleOf = Class.valueTupleOfFunctor - -memory :: - (Memory.C l s, LLVM.IsSized s ss) => - Memory.Record r (LLVM.Struct (s, (s, ()))) (BM.T l) -memory = - liftA2 BM.Cons - (Memory.element BM.bend TypeNum.d0) - (Memory.element BM.depth TypeNum.d1) - -instance - (Memory.C l s, LLVM.IsSized s ss) => - Memory.C (BM.T l) (LLVM.Struct (s, (s, ()))) where - load = Memory.loadRecord memory - store = Memory.storeRecord memory - decompose = Memory.decomposeRecord memory - compose = Memory.composeRecord memory - - -instance (Loop.Phi a) => Loop.Phi (BM.T a) where - phis = Class.phisTraversable - addPhis = Class.addPhisFoldable - - -instance (Vector.ShuffleMatch n v) => - Vector.ShuffleMatch n (BM.T v) where - shuffleMatch = Vector.shuffleMatchTraversable - -instance (Vector.Access n a v) => - Vector.Access n (BM.T a) (BM.T v) where - insert = Vector.insertTraversable - extract = Vector.extractTraversable diff --git a/src/Synthesizer/LLVM/ALSA/MIDI.hs b/src/Synthesizer/LLVM/ALSA/MIDI.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/ALSA/MIDI.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} -{- | -Convert MIDI events of a MIDI controller to a control signal. --} -module Synthesizer.LLVM.ALSA.MIDI ( - module Synthesizer.LLVM.ALSA.MIDI, - Gen.applyModulation, - ) where - -import qualified Synthesizer.Generic.ALSA.MIDI as Gen -import qualified Synthesizer.LLVM.ALSA.BendModulation as BM - -import Synthesizer.LLVM.CausalParameterized.Process (($>), ) -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import qualified Synthesizer.LLVM.Parameter as Param -import qualified Synthesizer.LLVM.Wave as Wave - -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Vector as Vector -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Class as Class -import qualified LLVM.Core as LLVM - -import qualified Data.TypeLevel.Num as TypeNum - -import Foreign.Storable (Storable, ) - -import qualified Algebra.RealField as RealField -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive - -import Control.Arrow (second, (<<<), (<<^), ) -import Control.Monad ({- liftM, -} liftM2, ) - --- import NumericPrelude.Base -import NumericPrelude.Numeric -import Prelude () - - -{- -{-# INLINE piecewiseConstantInit #-} -piecewiseConstantInit :: - (Storable y, Class.MakeValueTuple y yl, - Memory.C yl ym, LLVM.IsSized ym ys) => - y -> EventListTT.T LazyTime y -> SigP.T p yl -piecewiseConstantInit initial evs = - SigP.piecewiseConstant $# - (PC.subdivideInt $ - EventListMT.consBody initial evs) - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y, Storable y, Class.MakeValueTuple y yl, - Memory.C yl ym, LLVM.IsSized ym ys) => - Channel -> Controller -> - (y,y) -> y -> - Filter (SigP.T p yl) -controllerLinear chan ctrl bnd initial = - liftM (piecewiseConstantInit initial . - EventListTT.mapBody (MV.controllerLinear bnd)) $ - getControllerEvents chan ctrl - - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y, Storable y, Class.MakeValueTuple y yl, - Memory.C yl ym, LLVM.IsSized ym ys) => - Channel -> Controller -> - (y,y) -> y -> - Filter (SigP.T p yl) -controllerExponential chan ctrl bnd initial = - liftM (piecewiseConstantInit initial . - EventListTT.mapBody (MV.controllerExponential bnd)) $ - getControllerEvents chan ctrl - - -{- | -@pitchBend channel range center@: -emits frequencies on an exponential scale from -@center/range@ to @center*range@. --} -{-# INLINE pitchBend #-} -pitchBend :: - (Trans.C y, Storable y, Class.MakeValueTuple y yl, - Memory.C yl ym, LLVM.IsSized ym ys) => - Channel -> - y -> y -> - Filter (SigP.T p yl) -pitchBend chan range center = - liftM (piecewiseConstantInit center . - EventListTT.mapBody (MV.pitchBend range center)) $ - getSlice (maybePitchBend chan) --- getPitchBendEvents chan - -{-# INLINE channelPressure #-} -channelPressure :: - (Trans.C y, Storable y, Class.MakeValueTuple y yl, - Memory.C yl ym, LLVM.IsSized ym ys) => - Channel -> - y -> y -> - Filter (SigP.T p yl) -channelPressure chan maxVal initVal = - liftM (piecewiseConstantInit initVal . - EventListTT.mapBody (MV.controllerLinear (0,maxVal))) $ - getSlice (maybeChannelPressure chan) - - -{-# INLINE bendWheelPressure #-} -bendWheelPressure :: - (Ring.C a, LLVM.IsConst a, - RealField.C y, Trans.C y, - LLVM.IsConst y, SoV.Fraction y, SoV.Replicate a y, - Storable y, Class.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) => - Channel -> - Int -> y -> y -> y -> - Filter (SigP.T p (LLVM.Value y)) -bendWheelPressure chan - pitchRange speed wheelDepth pressDepth = - do bend <- pitchBend chan - (2^?(fromIntegral pitchRange/12) `asTypeOf` speed) 1 - fm <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0 - press <- channelPressure chan pressDepth 0 - return $ - SigP.envelope bend $ - SigP.mapSimple (A.add (LLVM.valueOf 1)) $ - SigP.envelope - (SigP.mix fm press) - (SigP.osciSimple Wave.approxSine2 zero $# speed) --} - - -frequencyFromBendModulation :: - (Ring.C a, LLVM.IsConst a, - Ring.C y, LLVM.IsConst y, - Memory.FirstClass y ym, LLVM.IsSized y ysize, LLVM.IsSized ym ymsize, - Storable y, Class.MakeValueTuple y (LLVM.Value y), - SoV.Fraction y, SoV.Replicate a y) => - Param.T p y -> - CausalP.T p (BM.T (LLVM.Value y)) (LLVM.Value y) -frequencyFromBendModulation speed = - CausalP.envelope - <<< - second - (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope - $> SigP.osciSimple Wave.approxSine2 zero speed) - <<^ - (\(BM.Cons b m) -> (b,m)) - - -frequencyFromBendModulationPacked :: - (RealField.C a, LLVM.IsConst a, LLVM.IsFloating a, - Memory.FirstClass a am, LLVM.IsSized a asize, LLVM.IsSized am amsize, - LLVM.IsPrimitive am, - Storable a, Class.MakeValueTuple a (LLVM.Value a), - Vector.Real a, SoV.Replicate a (LLVM.Vector n a), TypeNum.Pos n, - TypeNum.Mul n asize vsize, TypeNum.Pos vsize, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize) => - Param.T p a -> - CausalP.T p - (BM.T (LLVM.Value a)) - (LLVM.Value (LLVM.Vector n a)) -frequencyFromBendModulationPacked speed = - CausalP.envelope - <<< - second - (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope - $> SigPS.osciSimple Wave.approxSine2 zero speed) - <<< - CausalP.mapSimple - (\(BM.Cons b m) -> - liftM2 (,) (SoV.replicate b) (SoV.replicate m)) 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,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} @@ -13,7 +14,7 @@ import qualified LLVM.Extra.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory -- import qualified LLVM.Extra.Control as U -import LLVM.Extra.Class (MakeValueTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV @@ -36,7 +37,7 @@ import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) import Foreign.Ptr (FunPtr, ) import Control.Exception (bracket, ) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) +import qualified System.Unsafe as Unsafe import qualified Number.Ratio as Ratio import qualified Algebra.Field as Field @@ -46,10 +47,12 @@ import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, map, zip, zipWith, ) +import qualified Prelude as P + data T a b = - forall state packed size ioContext. - (Memory.C state packed, IsSized packed size) => + forall state ioContext. + (Memory.C state) => Cons (forall r c. (Phi c) => ioContext -> @@ -65,7 +68,7 @@ -- finalization from IO monad simple :: - (Memory.C state packed, IsSized packed size) => + (Memory.C state) => (forall r c. (Phi c) => a -> state -> Maybe.T r c (b, state)) -> @@ -98,7 +101,7 @@ mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ()) mapAccum :: - (Memory.C state packed, IsSized packed size) => + (Memory.C state) => (forall r. a -> state -> CodeGenFunction r (b, state)) -> (forall r. CodeGenFunction r state) -> @@ -198,6 +201,20 @@ x / y = zipWith A.fdiv <<< x&&&y +instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T a b) where + fromInteger n = pure (A.fromInteger' n) + negate x = map A.neg <<< x + x + y = zipWith A.add <<< x&&&y + x - y = zipWith A.sub <<< x&&&y + x * y = zipWith A.mul <<< x&&&y + abs x = map A.abs <<< x + signum x = map A.signum <<< x + +instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T a b) where + fromRational x = pure (A.fromRational' x) + x / y = zipWith A.fdiv <<< x&&&y + + mix :: (A.Additive a) => T (a, a) a @@ -229,11 +246,11 @@ applyStorable :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (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 = - unsafePerformIO $ + Unsafe.performIO $ bracket createIOContext deleteIOContext $ \ ioContext -> SVB.withStartPtr as $ \ aPtr len -> SVB.createAndTrim len $ \ bPtr -> do @@ -266,10 +283,9 @@ compileChunky :: - (Memory.C aValue aStruct, - Memory.C bValue bStruct, - Memory.C state stateStruct, - IsSized stateStruct stateSize) => + (Memory.C aValue, Memory.Struct aValue ~ aStruct, + Memory.C bValue, Memory.Struct bValue ~ bStruct, + Memory.C state, Memory.Struct state ~ stateStruct) => (forall r. aValue -> state -> Maybe.T r (Value Bool, (Value (Ptr bStruct), state)) (bValue, state)) -> @@ -314,8 +330,8 @@ But this way is disallowed for foreign finalizers. -} runStorableChunky :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (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 @@ -331,10 +347,10 @@ -} ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False - return $ \sig -> SVL.fromChunks $ unsafePerformIO $ do + return $ \sig -> SVL.fromChunks $ Unsafe.performIO $ do statePtr <- ForeignPtr.newInit stopFunc startFunc let go xt = - unsafeInterleaveIO $ + Unsafe.interleaveIO $ case xt of [] -> return [] x:xs -> SVB.withStartPtr x $ \aPtr size -> do @@ -356,12 +372,12 @@ applyStorableChunky :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (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 $ unsafePerformIO $ do + SVL.fromChunks $ Unsafe.performIO $ do ioContext <- createIOContext (startFunc, stopFunc, fill) <- compileChunky (next ioContext) (start ioContext) @@ -376,7 +392,7 @@ ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False let go xt = - unsafeInterleaveIO $ + Unsafe.interleaveIO $ case xt of [] -> return [] x:xs -> SVB.withStartPtr x $ \aPtr size -> do 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,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,7 +30,8 @@ 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.Class as Class +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM import LLVM.Core @@ -37,8 +39,8 @@ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -import qualified Data.TypeLevel.Num as TypeNum -import qualified Data.TypeLevel.Num.Sets as TypeSet +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) import Foreign.Storable (Storable, ) @@ -53,17 +55,19 @@ However it does not uniquely determine the input and output type, since the same filter can run on mono and stereo signals. -} -class C parameter a b | parameter a -> b, parameter b -> a where +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, - Memory.C parameter struct, IsSized struct ss, - Memory.FirstClass r rm, IsSized r rs, IsSized rm rmsize, + Memory.C parameter, + Memory.FirstClass r, IsSized r, IsSized (Memory.Stored r), Ring.C r, IsFloating r, Storable r, IsConst r, - Class.MakeValueTuple r (Value r), - LLVM.CmpRet r Bool) => + MakeValueTuple r, ValueTuple r ~ (Value r), + LLVM.CmpRet r, LLVM.CmpResult r ~ Bool) => Param.T p r -> (Param.T p r -> SigP.T p parameter) -> CausalP.T p a b @@ -78,91 +82,107 @@ -} instance - (SoV.PseudoModule a v, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - C (Filt1.Parameter (Value a)) - (Value v) (Filt1.Result (Value v)) where + (A.PseudoModule a 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.causalP instance - (SoV.PseudoModule a v, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - C (Filt2.Parameter (Value a)) - (Value v) (Value v) where + (A.PseudoModule a 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.causalP instance (Vector.Arithmetic a, SoV.RationalConstant a, - Memory.C (Value (Filt2P.State a)) am, IsSized am size {-, + 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.causalP instance (SoV.PseudoModule a v, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeSet.Nat n, - TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => + Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a), + Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v), + TypeNum.NaturalT n, + TypeNum.PositiveT (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.causalP instance - (SoV.PseudoModule a v, SoV.RationalConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - C (Allpass.Parameter (Value a)) - (Value v) (Value v) where + (A.PseudoModule a 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.causalP instance - (SoV.PseudoModule a v, SoV.RationalConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeNum.Nat n) => - C (Allpass.CascadeParameter n (Value a)) - (Value v) (Value v) where + (A.PseudoModule a v, A.RationalConstant a, + Memory.C a, Memory.C v, + TypeNum.NaturalT 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.cascadeP instance (SoV.PseudoModule a v, SoV.IntegerConstant a, Additive.C v, IsConst v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - Class.MakeValueTuple a (Value a), - Class.MakeValueTuple v (Value v), + Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a), + Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v), + MakeValueTuple a, ValueTuple a ~ (Value a), + MakeValueTuple v, ValueTuple v ~ (Value v), Storable v, - TypeSet.Nat n) => + TypeNum.NaturalT n) => C (Moog.Parameter n (Value a)) (Value v) (Value v) where + type Input (Moog.Parameter n (Value a)) (Value v) = Value v + type Output (Moog.Parameter n (Value a)) (Value v) = Value v process = Moog.causalP +{- +instance + (A.PseudoModule a v, A.RationalConstant a, + Memory.C a, Memory.C v, + TypeNum.NaturalT 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.causalP +-} instance - (SoV.PseudoModule a v, SoV.RationalConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - C (UniFilter.Parameter (Value a)) - (Value v) (UniFilter.Result (Value v)) where + (A.PseudoModule a 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.causalP instance - (IsFloating a, SoV.RationalConstant a, - Memory.FirstClass a am, IsSized a sa, IsSized am ams) => - C (ComplexFilt.Parameter (Value a)) - (Stereo.T (Value a)) (Stereo.T (Value a)) where + (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.causalP instance (Vector.Arithmetic a, IsConst a, - Memory.C (Value (Filt2P.State a)) am, IsSized am size) => + Memory.C (Value (Filt2P.State a))) => {- (Memory.FirstClass a am, Vector.Arithmetic a, LLVM.IsPrimitive am, IsSized am ams, @@ -170,4 +190,6 @@ -} 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.causalP 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,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,26 +20,28 @@ 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.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.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, IsArithmetic, IsFloating, IsConst, IsSized, - Vector, IsPrimitive, ) + (Value, IsFloating, IsConst, IsSized, ) -import qualified Data.TypeLevel.Num as TypeNum -import qualified Data.TypeLevel.Num.Sets as TypeSet +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) import Foreign.Storable (Storable, ) -import Control.Arrow ((<<<), first, ) +import Control.Arrow ((<<<), arr, first, ) import qualified Algebra.Field as Field -- import qualified Algebra.Module as Module @@ -54,30 +57,32 @@ However it does not uniquely determine the input and output type, since the same filter can run on mono and stereo signals. -} -class C parameter a b | parameter a -> b, parameter b -> a where +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, - Vector.Access n a av, - Vector.Access n b bv, - Memory.C parameter struct, IsSized struct ss, + Serial.Read av, n ~ Serial.Size av, a ~ Serial.Element av, + Serial.C bv, n ~ Serial.Size bv, b ~ Serial.Element bv, + Memory.C parameter, Field.C r, Storable r, IsFloating r, - Memory.FirstClass r rm, IsSized r rs, IsSized rm rms, IsConst r, - Class.MakeValueTuple r (Value r), - LLVM.CmpRet r Bool) => + Memory.FirstClass r, Memory.Stored r ~ rm, IsSized r, IsSized rm, IsConst r, + MakeValueTuple r, ValueTuple r ~ (Value r), + LLVM.CmpRet r, LLVM.CmpResult r ~ Bool) => Param.T p r -> (Param.T p r -> SigP.T p parameter) -> CausalP.T p av bv processCtrlRate reduct ctrlGen = withSize $ \n -> CausalP.applyFst process (SigP.interpolateConstant - (fmap (/ fromIntegral (TypeNum.toInt n)) reduct) + (fmap (/ fromInteger (TypeNum.fromIntegerT n)) reduct) (ctrlGen reduct)) withSize :: - (Vector.Access n a av, - Vector.Access n b bv) => + (Serial.Read av, n ~ Serial.Size av, + Serial.Read bv, n ~ Serial.Size bv) => (n -> CausalP.T p av bv) -> CausalP.T p av bv withSize f = f undefined @@ -89,73 +94,80 @@ -} instance - (IsArithmetic a, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos n, IsPrimitive a) => - C (Filt1.Parameter (Value a)) - (Value (Vector n a)) (Filt1.Result (Value (Vector n a))) where + (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.causalPackedP instance - (IsArithmetic a, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos n, IsPrimitive a, IsPrimitive am, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n ams vams, TypeNum.Pos vams) => - C (Filt2.Parameter (Value a)) - (Value (Vector n a)) (Value (Vector n a)) where + (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.causalPackedP instance - (IsArithmetic a, SoV.IntegerConstant a, IsPrimitive a, IsPrimitive am, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeSet.Nat n, - TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize, - TypeNum.Pos d, - TypeNum.Mul d as vas, TypeSet.Pos vas, - TypeNum.Mul d ams vams, TypeSet.Pos vams) => - C (Cascade.ParameterValue n a) - (Value (Vector d a)) (Value (Vector d a)) where + (A.PseudoModule (LLVM.Value a) 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.PositiveT (n :*: LLVM.UnknownSize), + TypeNum.NaturalT 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.causalPackedP instance - (IsArithmetic a, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos n, IsPrimitive a, IsPrimitive am) => - C (Allpass.Parameter (Value a)) - (Value (Vector n a)) (Value (Vector n a)) where + (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.causalPackedP instance - (IsArithmetic a, SoV.RationalConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos d, IsPrimitive a, - TypeNum.Nat n) => - C (Allpass.CascadeParameter n (Value a)) - (Value (Vector d a)) (Value (Vector d a)) where + (TypeNum.NaturalT 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.cascadePackedP instance (SoV.PseudoModule a a, SoV.IntegerConstant a, Additive.C a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Class.MakeValueTuple a (Value a), Storable a, - TypeNum.Pos d, IsPrimitive a, - TypeNum.Nat n) => + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + MakeValueTuple a, ValueTuple a ~ (Value a), Storable a, + TypeNum.PositiveT d, LLVM.IsPrimitive a, + TypeNum.NaturalT n) => C (Moog.Parameter n (Value a)) - (Value (Vector d a)) (Value (Vector d a)) where + (Serial.Value d a) (Serial.Value d a) where + type Input (Moog.Parameter n (Value a)) (Serial.Value d a) = (Serial.Value d a) + type Output (Moog.Parameter n (Value a)) (Serial.Value d a) = (Serial.Value d a) process = CausalPS.pack Moog.causalP <<< - first (CausalP.mapSimple Vector.replicate) + first (arr Serial.constant) instance - (SoV.PseudoModule a a, SoV.RationalConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos d, IsPrimitive a) => - C (UniFilter.Parameter (Value a)) - (Value (Vector d a)) (UniFilter.Result (Value (Vector d a))) where + (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a, + A.PseudoModule a 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.causalP <<< - first (CausalP.mapSimple Vector.replicate) + 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 @@ -1,5 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.CausalParameterized.Functional ( @@ -7,20 +7,24 @@ lift, ($&), (&|&), compile, + withArgs, MakeArguments, Arguments, makeArgs, ) where import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo 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, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Util.Loop (Phi, ) -import LLVM.Core (CodeGenFunction, IsSized, ) +import LLVM.Core (CodeGenFunction, ) +import qualified LLVM.Core as LLVM import qualified Number.Ratio as Ratio +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive @@ -39,8 +43,10 @@ import Foreign.Storable (Storable, ) -import System.IO.Unsafe (unsafePerformIO, ) +import Data.Tuple.HT (fst3, snd3, thd3, ) +import qualified System.Unsafe as Unsafe + import Prelude hiding ((.), ) @@ -49,37 +55,32 @@ -- | similar to @Causal.T p a b@ data Code p a b = - forall state packed size ioContext - startParamTuple startParamValue startParamPacked startParamSize - nextParamTuple nextParamValue nextParamPacked nextParamSize. + forall state ioContext startParamTuple nextParamTuple. (Storable startParamTuple, Storable nextParamTuple, - MakeValueTuple startParamTuple startParamValue, - MakeValueTuple nextParamTuple nextParamValue, - Memory.C startParamValue startParamPacked, - Memory.C nextParamValue nextParamPacked, - LLVM.IsSized startParamPacked startParamSize, - LLVM.IsSized nextParamPacked nextParamSize, - Memory.C state packed, - IsSized packed size) => + MakeValueTuple startParamTuple, + MakeValueTuple nextParamTuple, + Memory.C (ValueTuple startParamTuple), + Memory.C (ValueTuple nextParamTuple), + Memory.C state) => Code (forall r c. (Phi c) => - nextParamValue -> + ValueTuple nextParamTuple -> a -> state -> StateT Vault (Maybe.T r c) (b, state)) -- compute next value (forall r. - startParamValue -> + ValueTuple startParamTuple -> CodeGenFunction r state) -- initial state (p -> IO (ioContext, (nextParamTuple, startParamTuple))) {- initialization from IO monad - This will be run within unsafePerformIO, + This will be run within Unsafe.performIO, so no observable In/Out actions please! -} (ioContext -> IO ()) - -- finalization from IO monad, also run within unsafePerformIO + -- finalization from IO monad, also run within Unsafe.performIO @@ -141,22 +142,58 @@ f <*> x = fmap (uncurry ($)) $ f &|& x +lift0 :: (forall r. CodeGenFunction r out) -> T p inp out +lift0 f = lift (Causal.mapSimple (const f)) + +lift1 :: (forall r. a -> CodeGenFunction r out) -> T p inp a -> T p inp out +lift1 f x = Causal.mapSimple f $& x + +lift2 :: (forall r. a -> b -> CodeGenFunction r out) -> T p inp a -> T p inp b -> T p inp out +lift2 f x y = Causal.zipWithSimple f $& x&|&y + + +instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T p a b) where + fromInteger n = pure (A.fromInteger' n) + (+) = lift2 A.add + (-) = lift2 A.sub + (*) = lift2 A.mul + abs = lift1 A.abs + signum = lift1 A.signum + + instance (A.Additive b) => Additive.C (T p a b) where - zero = lift Additive.zero - negate x = Causal.mapSimple A.neg $& x - x + y = Causal.zipWithSimple A.add $& x&|&y - x - y = Causal.zipWithSimple A.sub $& x&|&y + zero = pure A.zero + (+) = lift2 A.add + (-) = lift2 A.sub + negate = lift1 A.neg instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T p a b) where one = pure A.one fromInteger n = pure (A.fromInteger' n) - x * y = Causal.zipWithSimple A.mul $& x&|&y + (*) = lift2 A.mul instance (A.Field b, A.RationalConstant b) => Field.C (T p a b) where fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) - x / y = Causal.zipWithSimple A.fdiv $& x&|&y + (/) = lift2 A.fdiv +instance (A.Transcendental b, A.RationalConstant b) => Algebraic.C (T p a b) where + sqrt = lift1 A.sqrt + root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n) + x^/r = lift2 A.pow x (Field.fromRational' r) +instance (A.Transcendental b, A.RationalConstant b) => Trans.C (T p a b) where + pi = lift0 A.pi + sin = lift1 A.sin + cos = lift1 A.cos + (**) = lift2 A.pow + exp = lift1 A.exp + log = lift1 A.log + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + infixr 0 $& ($&) :: Causal.T p b c -> T p a b -> T p a c @@ -200,7 +237,7 @@ tagUnique :: Code p inp out -> T p inp out tagUnique code = - unsafePerformIO $ + Unsafe.performIO $ fmap (flip tag code) Vault.newKey initialize :: Code p inp out -> Causal.T p inp out @@ -211,3 +248,60 @@ compile :: T p inp out -> Causal.T p inp out compile (Cons code) = initialize code + + +{- | +Using 'withArgs' you can simplify + +> let x = F.lift (arr fst) +> y = F.lift (arr (fst.snd)) +> z = F.lift (arr (snd.snd)) +> in F.compile (f x y z) + +to + +> withArgs $ \(x,(y,z)) -> f x y z +-} +withArgs :: + (MakeArguments inp) => + (Arguments (T p inp) inp -> T p inp out) -> Causal.T p inp out +withArgs = withArgsStart (lift Cat.id) + +withArgsStart :: + (MakeArguments inp) => + T p inp inp -> (Arguments (T p inp) inp -> T p inp out) -> Causal.T p inp out +withArgsStart fid f = compile (f (makeArgs fid)) + + +type family Arguments (f :: * -> *) (arg :: *) + +class MakeArguments arg where + makeArgs :: Functor f => f arg -> Arguments f arg + + +{- +I have thought about an Arg type, that marks where to stop descending. +This way we can throw away all of these FlexibleContext instances +and the user can freely choose the granularity of arguments. +However this does not work so easily, +because we would need a functional depedency from, say, +@(Arg a, Arg b)@ to @(a,b)@. +This is the opposite direction to the dependency we use currently. +-} +type instance Arguments f (LLVM.Value a) = f (LLVM.Value a) +instance MakeArguments (LLVM.Value a) where + makeArgs = id + +type instance Arguments f (Stereo.T a) = f (Stereo.T a) +instance MakeArguments (Stereo.T a) where + makeArgs = id + +type instance Arguments f (a,b) = (Arguments f a, Arguments f b) +instance (MakeArguments a, MakeArguments b) => + MakeArguments (a,b) where + makeArgs f = (makeArgs $ fmap fst f, makeArgs $ fmap snd f) + +type instance Arguments f (a,b,c) = (Arguments f a, Arguments f b, Arguments f c) +instance (MakeArguments a, MakeArguments b, MakeArguments c) => + MakeArguments (a,b,c) where + makeArgs f = (makeArgs $ fmap fst3 f, makeArgs $ fmap snd3 f, makeArgs $ fmap thd3 f) diff --git a/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs b/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/FunctionalPlug.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.LLVM.CausalParameterized.FunctionalPlug ( + T, + ($&), (&|&), + run, runPlugOut, + fromSignal, plug, askParameter, Input, + withArgs, withArgsPlugOut, + MakeArguments, Arguments, makeArgs, + ) where + +import qualified Synthesizer.LLVM.Plug.Input as PIn +import qualified Synthesizer.LLVM.Plug.Output as POut + +import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal +import qualified Synthesizer.LLVM.Parameterized.Signal as Sig + +import qualified Synthesizer.CausalIO.Process as PIO +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Zip as Zip + +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.StorableVector as SV + +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Core (CodeGenFunction, ) + +import qualified Number.Ratio as Ratio +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Control.Monad.Trans.Reader as MR +import qualified Control.Monad.Trans.State as MS + +import qualified Data.Set as Set +import qualified Data.Vault as Vault +import Data.Vault (Vault, ) +import Data.Unique (Unique, newUnique, ) +import Data.Maybe (fromMaybe, ) + +import Control.Arrow (Arrow, (^<<), (<<^), arr, first, second, ) +import Control.Category (Category, id, (.), ) +import Control.Applicative (Applicative, (<*>), pure, liftA2, ) + +import qualified System.Unsafe as Unsafe + +import Prelude hiding (id, (.), ) + + +{- | +This data type detects sharing. +-} +{- +There are two levels of the use of keys. +At the top level, in T's State monad, +we store an object id in order to check, +whether we have already seen a certain object. +If we encounter a known object +then we use the Simple constructor +and fetch the stored Causal output +within the causal process enclosed in Simple. +This and the causal process in the Plugged constructor +are the second level. +These arrows handle a Vault like a state monad +and insert all values they produce into the Vault. +-} +newtype T pp pl inp out = + Cons (MS.State (Set.Set Unique) (Core pp pl inp out)) + +{- +We need to hide the x and y types +since these types grow when combining Cores, +and then we could not define numeric instances. +-} +data Core pp pl inp out = + forall x y. CutG.Read x => + Plugged + (pp -> inp -> x) + (PIn.T x y) + (Causal.T pl (y, Vault) (out, Vault)) + | + {- + The Simple constructor is needed for reusing shared Causal processes + and for input without external representation. (a Plug.Input) + -} + Simple (Causal.T pl Vault (out, Vault)) + + +applyCore :: + Causal.T pl a b -> + Core pp pl inp a -> + Core pp pl inp b +applyCore f (Plugged prep plg process) = + Plugged prep plg (first f . process) +applyCore f (Simple process) = + Simple (first f . process) + +combineCore :: + Core pp pl inp a -> + Core pp pl inp b -> + Core pp pl inp (a,b) +combineCore (Plugged prepA plugA processA) (Plugged prepB plugB processB) = + Plugged + (\p -> Zip.arrowFanout (prepA p) (prepB p)) + (PIn.split plugA plugB) + ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB + . arr (\((a,v),b) -> (a,(b,v))) . + first processA <<^ (\((a,b),v) -> ((a,v),b))) +combineCore (Simple processA) (Plugged prepB plugB processB) = + Plugged prepB plugB + ((\(b,(a,v)) -> ((a,b), v)) ^<< second processA . processB) +combineCore (Plugged prepA plugA processA) (Simple processB) = + Plugged prepA plugA + ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA) +combineCore (Simple processA) (Simple processB) = + Simple ((\(a,(b,v)) -> ((a,b), v)) ^<< second processB . processA) + + +reuseCore :: Vault.Key out -> Core pp pl inp out +reuseCore key = + Simple (arr (\vault -> + (fromMaybe (error "key must have been lost") $ Vault.lookup key vault, + vault))) + + +tag :: + Unique -> Vault.Key out -> + MS.State (Set.Set Unique) (Core pp pl inp out) -> + T pp pl inp out +tag unique key stateCore = Cons $ do + alreadySeen <- MS.gets (Set.member unique) + if alreadySeen + then return $ reuseCore key + else do + MS.modify (Set.insert unique) + core <- stateCore + let store (a,v) = (a, Vault.insert key a v) + return $ + case core of + Plugged prep plg process -> + Plugged prep plg (store ^<< process) + Simple process -> + Simple (store ^<< process) + +tagUnique :: + MS.State (Set.Set Unique) (Core pp pl inp out) -> + T pp pl inp out +tagUnique core = + Unsafe.performIO $ + fmap ($ core) $ liftA2 tag newUnique Vault.newKey + + +infixr 0 $& + +($&) :: + Causal.T pl a b -> + T pp pl inp a -> + T pp pl inp b +f $& Cons core = + tagUnique $ fmap (applyCore f) core + + +infixr 3 &|& + +(&|&) :: + T pp pl inp a -> + T pp pl inp b -> + T pp pl inp (a,b) +Cons coreA &|& Cons coreB = + tagUnique $ liftA2 combineCore coreA coreB + + +instance Functor (Core pp pl inp) where + fmap f (Simple process) = Simple (fmap (first f) process) + fmap f (Plugged prep plg process) = Plugged prep plg (fmap (first f) process) + +instance Applicative (Core pp pl inp) where + pure a = lift0Core $ pure a + f <*> x = fmap (uncurry ($)) $ combineCore f x + +lift0Core :: (forall r. CodeGenFunction r out) -> Core pp pl inp out +lift0Core f = Simple (Causal.mapSimple (\v -> fmap (flip (,) v) f)) + + +instance Functor (T pp pl inp) where + fmap f (Cons x) = tagUnique $ fmap (fmap f) x + +instance Applicative (T pp pl inp) where + pure a = tagUnique $ pure $ pure a + f <*> x = fmap (uncurry ($)) $ f &|& x + + +lift0 :: (forall r. CodeGenFunction r out) -> T pp pl inp out +lift0 f = tagUnique $ pure $ lift0Core f + +lift1 :: (forall r. a -> CodeGenFunction r out) -> T pp pl inp a -> T pp pl inp out +lift1 f x = Causal.mapSimple f $& x + +lift2 :: (forall r. a -> b -> CodeGenFunction r out) -> T pp pl inp a -> T pp pl inp b -> T pp pl inp out +lift2 f x y = Causal.zipWithSimple f $& x&|&y + + +instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => Num (T pp pl a b) where + fromInteger n = pure (A.fromInteger' n) + (+) = lift2 A.add + (-) = lift2 A.sub + (*) = lift2 A.mul + abs = lift1 A.abs + signum = lift1 A.signum + + +instance (A.Additive b) => Additive.C (T pp pl a b) where + zero = pure A.zero + (+) = lift2 A.add + (-) = lift2 A.sub + negate = lift1 A.neg + +instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T pp pl a b) where + one = pure A.one + fromInteger n = pure (A.fromInteger' n) + (*) = lift2 A.mul + +instance (A.Field b, A.RationalConstant b) => Field.C (T pp pl a b) where + fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) + (/) = lift2 A.fdiv + +instance (A.Transcendental b, A.RationalConstant b) => Algebraic.C (T pp pl a b) where + sqrt = lift1 A.sqrt + root n x = lift2 A.pow x (Field.recip $ Ring.fromInteger n) + x^/r = lift2 A.pow x (Field.fromRational' r) + +instance (A.Transcendental b, A.RationalConstant b) => Trans.C (T pp pl a b) where + pi = lift0 A.pi + sin = lift1 A.sin + cos = lift1 A.cos + (**) = lift2 A.pow + exp = lift1 A.exp + log = lift1 A.log + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + + +fromSignal :: + Sig.T pl a -> + T pp pl inp a +fromSignal sig = + tagUnique $ pure $ Simple (Causal.feedFst sig) + + + +type Input pp a = MR.Reader (pp, a) + +plug :: + (CutG.Read b, PIn.Default b) => + Input pp a b -> + T pp pl a (PIn.Element b) +plug accessor = + tagUnique $ pure $ + Plugged + (curry $ MR.runReader accessor) + PIn.deflt + id + +askParameter :: Input pp a pp +askParameter = MR.asks fst + + +runPlugOut :: + T pp pl a x -> POut.T x b -> + IO (pp -> pl -> PIO.T a b) +runPlugOut (Cons core) pout = + case MS.evalState core Set.empty of + Plugged prep pin process -> + fmap (\f pp pl -> f pl <<^ prep pp) $ + Causal.processIOCore + pin + (fst ^<< process <<^ flip (,) Vault.empty) + pout + Simple _ -> + error "FunctionalPlug.runPlugOut: no substantial input available" + -- Simple process -> + -- Causal.processIOCore pin process pout + +run :: + (POut.Default b) => + T pp pl a (POut.Element b) -> + IO (pp -> pl -> PIO.T a b) +run f = runPlugOut f POut.deflt + + +{- | +Cf. 'F.withArgs'. +-} +withArgs :: + (MakeArguments a, POut.Default b) => + (Arguments (Input pp a) a -> T pp pl a (POut.Element b)) -> + IO (pp -> pl -> PIO.T a b) +withArgs f = withArgsPlugOut f POut.deflt + +withArgsPlugOut :: + (MakeArguments a) => + (Arguments (Input pp a) a -> T pp pl a x) -> + POut.T x b -> + IO (pp -> pl -> PIO.T a b) +withArgsPlugOut = withArgsPlugOutStart (MR.asks snd) + +withArgsPlugOutStart :: + (MakeArguments a) => + Input pp a a -> + (Arguments (Input pp a) a -> T pp pl a x) -> + POut.T x b -> + IO (pp -> pl -> PIO.T a b) +withArgsPlugOutStart fid f = runPlugOut (f (makeArgs fid)) + + + +type family Arguments (f :: * -> *) (arg :: *) + +class MakeArguments arg where + makeArgs :: Functor f => f arg -> Arguments f arg + + +type instance Arguments f (EventListBT.T i a) = f (EventListBT.T i a) +instance MakeArguments (EventListBT.T i a) where + makeArgs = id + +type instance Arguments f (SV.Vector a) = f (SV.Vector a) +instance MakeArguments (SV.Vector a) where + makeArgs = id + +type instance Arguments f (Zip.T a b) = (Arguments f a, Arguments f b) +instance (MakeArguments a, MakeArguments b) => + MakeArguments (Zip.T a b) where + makeArgs f = (makeArgs $ fmap Zip.first f, makeArgs $ fmap Zip.second f) 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 @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} @@ -42,13 +44,14 @@ import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A -import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Util.Loop (Phi, ) import LLVM.Core as LLVM -import Data.TypeLevel.Num (D2, ) -import Data.TypeLevel.Num.Ops ((:<:), ) -import qualified Data.TypeLevel.Num as TypeNum +import Types.Data.Num (D2, ) +import Types.Data.Ord ((:<:), ) +import qualified Types.Data.Num as TypeNum +import qualified Types.Data.Bool as TypeBool import qualified Control.Monad.HT as M import qualified Control.Arrow as Arr @@ -75,7 +78,7 @@ import Foreign.ForeignPtr (withForeignPtr, ) import Foreign.Ptr (FunPtr, ) import Control.Exception (bracket, ) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) +import qualified System.Unsafe as Unsafe import qualified Data.List as List @@ -110,26 +113,26 @@ provide constant input in a comfortable way -} ($*#) :: - (Storable ah, MakeValueTuple ah a, - Memory.C a am, IsSized am as) => + (Storable ah, MakeValueTuple ah, ValueTuple ah ~ a, + Memory.C a) => T p a b -> ah -> Sig.T p b proc $*# x = proc $* (Sig.constant $# x) ($<#) :: - (Storable ah, MakeValueTuple ah a, - Memory.C a am, IsSized am as) => + (Storable ah, MakeValueTuple ah, ValueTuple ah ~ a, + Memory.C a) => T p (a,b) c -> ah -> T p b c proc $<# x = proc $< (Sig.constant $# x) ($>#) :: - (Storable bh, MakeValueTuple bh b, - Memory.C b bm, IsSized bm bs) => + (Storable bh, MakeValueTuple bh, ValueTuple bh ~ b, + Memory.C b) => T p (a,b) c -> bh -> T p a c proc $># x = proc $> (Sig.constant $# x) mapAccumSimple :: - (Memory.C s struct, IsSized struct sa) => + (Memory.C s) => (forall r. a -> s -> CodeGenFunction r (b,s)) -> (forall r. CodeGenFunction r s) -> T p a b @@ -149,9 +152,8 @@ {-# INLINE feedbackControlled #-} feedbackControlled :: (Storable ch, - MakeValueTuple ch c, - Memory.C c cp, - IsSized cp cs) => + MakeValueTuple ch, ValueTuple ch ~ c, + Memory.C c) => Param.T p ch -> T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b feedbackControlled initial forth back = @@ -160,8 +162,11 @@ fromModifier :: - (Value.Flatten ah al, Value.Flatten bh bl, Value.Flatten ch cl, - Value.Flatten sh sl, Memory.C sl sp, IsSized sp ss) => + (Value.Flatten ah, Value.Registers ah ~ al, + Value.Flatten bh, Value.Registers bh ~ bl, + Value.Flatten ch, Value.Registers ch ~ cl, + Value.Flatten sh, Value.Registers sh ~ sl, + Memory.C sl) => Modifier.Simple sh ch ah bh -> T p (cl,al) bl fromModifier (Modifier.Simple initial step) = mapAccumSimple @@ -206,7 +211,8 @@ vectorize :: - (Vector.Access n a va, Vector.Access n b vb) => + (Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va, + Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) => T p a b -> T p va vb vectorize = vectorizeSize undefined @@ -217,20 +223,22 @@ However, LLVM neglects the order anyway. -} vectorizeSize :: - (Vector.Access n a va, Vector.Access n b vb) => + (Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va, + Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) => n -> T p a b -> T p va vb vectorizeSize n proc = foldl (\acc i -> replaceChannel i proc acc) (Arr.arr (const $ undefTuple)) $ - List.take (TypeNum.toInt n) [0 ..] + List.take (TypeNum.fromIntegerT n) [0 ..] {- | Given a vector process, replace the i-th output by output that is generated by a scalar process from the i-th input. -} replaceChannel :: - (Vector.Access n a va, Vector.Access n b vb) => + (Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va, + Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) => Int -> T p a b -> T p va vb -> T p va vb replaceChannel i channel proc = let li = valueOf $ fromIntegral i @@ -242,8 +250,10 @@ Read the i-th element from each array. -} arrayElement :: - (IsFirstClass a, LLVM.GetValue (LLVM.Array dim a) index a, - TypeNum.Nat index, TypeNum.Nat dim, index :<: dim) => + (IsFirstClass a, LLVM.GetValue (LLVM.Array dim a) index, + LLVM.ValueType (LLVM.Array dim a) index ~ a, + TypeNum.NaturalT index, TypeNum.NaturalT dim, + (index :<: dim) ~ TypeBool.True) => index -> T p (Value (LLVM.Array dim a)) (Value a) arrayElement i = mapSimple (\array -> LLVM.extractvalue array i) @@ -252,7 +262,8 @@ Read the i-th element from an aggregate type. -} element :: - (IsFirstClass a, LLVM.GetValue agg index a) => + (IsFirstClass a, LLVM.GetValue agg index, + LLVM.ValueType agg index ~ a) => index -> T p (Value agg) (Value a) element i = mapSimple (\array -> LLVM.extractvalue array i) @@ -272,10 +283,9 @@ You may also use '(+)' and a 'Sig.constant' signal or a number literal. -} raise :: - (IsArithmetic a, Storable a, - Memory.FirstClass a am, IsSized am amsize, - MakeValueTuple a (Value a), IsSized a size) => - Param.T p a -> T p (Value a) (Value a) + (A.Additive al, Storable a, + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => + Param.T p a -> T p al al raise = map Frame.mix @@ -299,18 +309,16 @@ You may also use '(*)' and a 'Sig.constant' signal or a number literal. -} amplify :: - (IsArithmetic a, Storable a, - Memory.FirstClass a am, IsSized am amsize, - MakeValueTuple a (Value a), IsSized a size) => - Param.T p a -> T p (Value a) (Value a) + (A.PseudoRing al, Storable a, + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => + Param.T p a -> T p al al amplify = map Frame.amplifyMono amplifyStereo :: - (IsArithmetic a, Storable a, - Memory.FirstClass a am, IsSized am amsize, - MakeValueTuple a (Value a), IsSized a size) => - Param.T p a -> T p (Stereo.T (Value a)) (Stereo.T (Value a)) + (A.PseudoRing al, Storable a, + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => + Param.T p a -> T p (Stereo.T al) (Stereo.T al) amplifyStereo = map Frame.amplifyStereo @@ -318,8 +326,8 @@ mapLinear :: (IsArithmetic a, Storable a, - Memory.FirstClass a am, IsSized am amsize, - MakeValueTuple a (Value a), IsSized a size) => + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + MakeValueTuple a, ValueTuple a ~ (Value a)) => Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapLinear depth center = map @@ -328,8 +336,9 @@ mapExponential :: (Trans.C a, IsFloating a, IsConst a, Storable a, - Memory.FirstClass a am, IsSized am amsize, - MakeValueTuple a (Value a), IsSized a size) => + SoV.TranscendentalConstant a, + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + MakeValueTuple a, ValueTuple a ~ (Value a)) => Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapExponential depth center = map @@ -348,12 +357,12 @@ that shall be used both for an oscillator and a frequency filter. -} quantizeLift :: - (Memory.C b struct, IsSized struct size, + (Memory.C b, Ring.C c, - IsFloating c, CmpRet c Bool, - Storable c, MakeValueTuple c (Value c), - Memory.FirstClass c cm, IsSized cm cmsize, - IsConst c, IsSized c sc) => + IsFloating c, CmpRet c, CmpResult c ~ Bool, + Storable c, MakeValueTuple c, ValueTuple c ~ (Value c), + Memory.FirstClass c, Memory.Stored c ~ cm, IsSized c, IsSized cm, + IsConst c) => Param.T p c -> T p a b -> T p a b @@ -388,7 +397,7 @@ thus we use 'SoV.addToPhase' which supports that. -} osciCore :: - (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, IsConst t, SoV.Fraction t, Additive.C t) => T p (Value t, Value t) (Value t) osciCore = @@ -404,7 +413,7 @@ -- (loop Additive.zero (arr snd &&& zipWithSimple SoV.incPhase)) osciSimple :: - (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, IsConst t, SoV.Fraction t, Additive.C t) => (forall r. Value t -> CodeGenFunction r y) -> T p (Value t, Value t) y @@ -412,7 +421,7 @@ mapSimple wave <<< osciCore shapeModOsci :: - (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, IsConst t, SoV.Fraction t, Additive.C t) => (forall r. c -> Value t -> CodeGenFunction r y) -> T p (c, (Value t, Value t)) y @@ -428,9 +437,8 @@ -} delay :: (Storable a, - MakeValueTuple a al, - Memory.C al ap, - IsSized ap as) => + MakeValueTuple a, ValueTuple a ~ al, + Memory.C al) => Param.T p a -> Param.T p Int -> T p al al delay initial time = mapSimple RingBuffer.oldest @@ -453,9 +461,8 @@ -} delay1 :: (Storable a, - MakeValueTuple a al, - Memory.C al ap, - IsSized ap as) => + MakeValueTuple a, ValueTuple a ~ al, + Memory.C al) => Param.T p a -> T p al al delay1 initial = loop initial (arr swap) @@ -464,9 +471,8 @@ differentiate :: (A.Additive al, Storable a, - MakeValueTuple a al, - Memory.C al ap, - IsSized ap as) => + MakeValueTuple a, ValueTuple a ~ al, + Memory.C al) => Param.T p a -> T p al al differentiate initial = Cat.id - delay1 initial @@ -476,8 +482,8 @@ -} comb :: (Ring.C a, Storable a, - IsArithmetic a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize) => + IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am) => Param.T p a -> Param.T p Int -> T p (Value a) (Value a) comb gain time = @@ -487,8 +493,8 @@ combStereo :: (Ring.C a, Storable a, - IsArithmetic a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize) => + IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am) => Param.T p a -> Param.T p Int -> T p (Stereo.T (Value a)) (Stereo.T (Value a)) combStereo gain time = @@ -505,13 +511,13 @@ -} reverb :: (Field.C a, Random a, Storable a, - IsArithmetic a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, + IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, RandomGen g) => g -> Int -> (a,a) -> (Int,Int) -> T p (Value a) (Value a) reverb rnd num gainRange timeRange = - amplify (return (recip (fromIntegral num))) <<< + amplify (return (recip (fromIntegral num) `asTypeOf` fst gainRange)) <<< (foldl (+) Cat.id $ List.take num $ List.map (\(g,t) -> comb $# g $# t) $ @@ -548,8 +554,8 @@ then we may add a more sensible initialization. -} pipeline :: - (Vector.Access n a v, Class.Zero v, - Memory.C v vp, IsSized vp s) => + (Vector.C v, a ~ Vector.Element v, + Class.Zero v, Memory.C v) => T p v v -> T p a a pipeline (Cons next start createIOContext deleteIOContext) = Cons (\param a0 (v0,s0) -> do @@ -583,11 +589,11 @@ The shrinking factor must be non-negative. -} frequencyModulationLinear :: - (-- Memory.C a struct, IsSized struct size, + (-- Memory.C a, Ring.C a, - IsFloating a, CmpRet a Bool, - Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, + IsFloating a, CmpRet a, CmpResult a ~ Bool, + Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsConst a) => Sig.T p (Value a) -> T p (Value a) (Value a) frequencyModulationLinear @@ -630,8 +636,8 @@ and thus they cannot read lazy Haskell data multiple times. -} trigger :: - (Storable a, MakeValueTuple a al, C.Select al, - Memory.C al as, IsSized as asize) => + (Storable a, MakeValueTuple a, ValueTuple a ~ al, C.Select al, + Memory.C al) => Param.T p a -> Sig.T p al -> T p (Value Bool) al @@ -655,8 +661,8 @@ On each restart the parameters of type @b@ are passed to the signal. triggerParam :: - (MakeValueTuple a al, - MakeValueTuple b bl) => + (MakeValueTuple a, ValueTuple a ~ al, + MakeValueTuple b, ValueTuple b ~ bl) => Param.T p a -> (Param.T p b -> Sig.T p a) -> T p (Value Bool, bl) al @@ -669,8 +675,8 @@ Exec.Importer (Ptr param -> Word32 -> Ptr a -> Ptr b -> IO Word32) runStorable :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, + Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO (p -> SV.Vector a -> SV.Vector b) runStorable (Cons next start createIOContext deleteIOContext) = do @@ -690,7 +696,7 @@ ret (pos :: Value Word32) return $ \p as -> - unsafePerformIO $ + Unsafe.performIO $ bracket (createIOContext p) (deleteIOContext . fst) $ \ (_,params) -> SVB.withStartPtr as $ \ aPtr len -> @@ -703,11 +709,11 @@ (Memory.castStorablePtr bPtr) applyStorable :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, + Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> p -> SV.Vector a -> SV.Vector b -applyStorable gen = unsafePerformIO $ runStorable gen +applyStorable gen = Unsafe.performIO $ runStorable gen @@ -717,14 +723,11 @@ compileChunky :: - (Memory.C valueA structA, - Memory.C valueB structB, - Memory.C state stateStruct, - IsSized stateStruct stateSize, - Memory.C startParamValue startParamStruct, - Memory.C nextParamValue nextParamStruct, - IsSized startParamStruct startParamSize, - IsSized nextParamStruct nextParamSize) => + (Memory.C valueA, Memory.Struct valueA ~ structA, + Memory.C valueB, Memory.Struct valueB ~ structB, + Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct, + Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct) => (forall r. nextParamValue -> valueA -> state -> @@ -767,18 +770,13 @@ Exec.Importer (Ptr stateStruct -> IO ()) compilePlugged :: - (Memory.C state stateStruct, - IsSized stateStruct stateSize, - Memory.C startParamValue startParamStruct, - Memory.C nextParamValue nextParamStruct, - IsSized startParamStruct startParamSize, - IsSized nextParamStruct nextParamSize, + (Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct, + Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct, Undefined stateIn, Phi stateIn, Undefined stateOut, Phi stateOut, - Memory.C paramValueIn paramStructIn, - Memory.C paramValueOut paramStructOut, - IsSized paramStructIn paramSizeIn, - IsSized paramStructOut paramSizeOut) => + Memory.C paramValueIn, Memory.Struct paramValueIn ~ paramStructIn, + Memory.C paramValueOut, Memory.Struct paramValueOut ~ paramStructOut) => (forall r. paramValueIn -> stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) -> @@ -834,8 +832,8 @@ runStorableChunky :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, + Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO (p -> SVL.Vector a -> SVL.Vector b) runStorableChunky proc = @@ -848,8 +846,8 @@ because it does not have the risk of a memory leak. -} runStorableChunkyCont :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, + Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO ((SVL.Vector a -> SVL.Vector b) -> p -> @@ -858,7 +856,7 @@ (startFunc, stopFunc, fill) <- compileChunky next start return $ \ procRest p sig -> - SVL.fromChunks $ unsafePerformIO $ do + SVL.fromChunks $ Unsafe.performIO $ do (ioContext, (nextParam, startParam)) <- createIOContext p when False $ DebugCnt.with DebugSt.dumpCounter $ do @@ -870,7 +868,7 @@ ForeignPtr.new (deleteIOContext ioContext) nextParam let go xt = - unsafeInterleaveIO $ + Unsafe.interleaveIO $ case xt of [] -> return [] x:xs -> SVB.withStartPtr x $ \aPtr size -> do @@ -894,12 +892,12 @@ go (SVL.chunks sig) applyStorableChunky :: - (Storable a, MakeValueTuple a valueA, Memory.C valueA structA, - Storable b, MakeValueTuple b valueB, Memory.C valueB structB) => + (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, + Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> p -> SVL.Vector a -> SVL.Vector b applyStorableChunky gen = - unsafePerformIO (runStorableChunky gen) + Unsafe.performIO (runStorableChunky gen) {- @@ -976,8 +974,8 @@ deleteIOContext ioContext) processIO :: - (Cut.Read a, PIn.Default a b, POut.Default c d) => - T p b c -> + (Cut.Read a, PIn.Default a, POut.Default d) => + T p (PIn.Element a) (POut.Element d) -> IO (p -> PIO.T a d) processIO proc = processIOCore PIn.deflt proc POut.deflt diff --git a/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs b/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs --- a/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs @@ -1,11 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.CausalParameterized.ProcessPacked where @@ -13,7 +11,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Frame as Frame -import qualified Synthesizer.LLVM.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified LLVM.Extra.ScalarOrVector as SoV @@ -23,13 +21,17 @@ import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C -import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Core as LLVM -import qualified Data.TypeLevel.Num as TypeNum -import Data.TypeLevel.Num.Ops ((:<:), ) +import qualified Types.Data.Bool as TypeBool +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) +import Types.Data.Ord ((:<:), ) +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS import qualified Control.Category as Cat import qualified Control.Arrow as Arr import Control.Arrow ((^<<), (<<<), ) @@ -52,28 +54,30 @@ then the last chunk is dropped. -} pack :: - (Vector.Access n a va, Vector.Access n b vb) => + (Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va, + Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) => T p a b -> T p va vb pack (Cons next start createIOContext deleteIOContext) = Cons (\param a s -> do - ((_,b2),(_,s2)) <- + r <- Maybe.lift $ Serial.readStart a + ((_,w2),(_,s2)) <- Maybe.fromBool $ C.whileLoop (valueOf True, - let b = undefTuple - in ((a,b), (valueOf $ (fromIntegral $ Vector.sizeInTuple b :: Word32), s))) - (\(cont,(_ab0,(i0,_s0))) -> + let w = undefTuple + in ((r,w), (valueOf $ (fromIntegral $ Serial.sizeOfIterator w :: Word32), s))) + (\(cont,(_rw0,(i0,_s0))) -> A.and cont =<< A.cmp CmpGT i0 (value LLVM.zero)) - (\(_,((a0,b0),(i0,s0))) -> Maybe.toBool $ do - ai <- Maybe.lift $ Vector.extract (valueOf 0) a0 + (\(_,((r0,w0),(i0,s0))) -> Maybe.toBool $ do + (ai,r1) <- Maybe.lift $ Serial.readNext r0 (bi,s1) <- next param ai s0 Maybe.lift $ do - a1 <- Vector.rotateDown a0 - b1 <- fmap snd $ Vector.shiftDown bi b0 + w1 <- Serial.writeNext bi w0 i1 <- A.dec i0 - return ((a1,b1),(i1,s1))) - return (b2, s2)) + return ((r1,w1),(i1,s1))) + b <- Maybe.lift $ Serial.writeStop w2 + return (b, s2)) start createIOContext deleteIOContext @@ -85,20 +89,17 @@ This is efficient only for simple input processes. -} packSmall :: - (Vector.Access n a va, Vector.Access n b vb) => + (Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va, + Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) => T p a b -> T p va vb packSmall (Cons next start createIOContext deleteIOContext) = Cons - (\param a s -> - let vundef = Class.undefTuple - in foldr - (\i rest (v0,s0) -> do - ai <- Maybe.lift $ Vector.extract (valueOf i) a - (bi,s1) <- next param ai s0 - v1 <- Maybe.lift $ Vector.insert (valueOf i) bi v0 - rest (v1,s1)) - return - (take (Vector.sizeInTuple vundef) [0..]) - (vundef, s)) + (\param a -> + MS.runStateT $ + (MT.lift . Maybe.lift . Serial.assemble) + =<< + mapM (MS.StateT . next param) + =<< + (MT.lift $ Maybe.lift $ Serial.extractAll a)) start createIOContext deleteIOContext @@ -111,144 +112,149 @@ In order to stay causal, we have to delay the output by @n@ samples. -} unpack :: - (Vector.Access n a va, Vector.Access n b vb, - Class.Zero va, Class.Undefined b, - Memory.C va vap, IsSized vap vas, - Memory.C vb vbp, IsSized vbp vbs) => + (Serial.Zero va, n ~ Serial.Size va, a ~ Serial.Element va, + Serial.Read vb, n ~ Serial.Size vb, b ~ Serial.Element vb, + Memory.C (Serial.WriteIt va), Memory.C (Serial.ReadIt vb), + Memory.C va, + Memory.C vb) => T p va vb -> T p a b unpack (Cons next start createIOContext deleteIOContext) = Cons - (\param ai ((a0,b0),(i0,s0)) -> do + (\param ai ((w0,r0),(i0,s0)) -> do endOfVector <- Maybe.lift $ A.cmp CmpEQ i0 (valueOf 0) - ((a2,b2),(i2,s2)) <- + ((w2,r2),(i2,s2)) <- Maybe.fromBool $ - C.ifThen endOfVector (valueOf True, ((a0,b0),(i0,s0))) $ do + C.ifThen endOfVector (valueOf True, ((w0,r0),(i0,s0))) $ do + a0 <- Serial.writeStop w0 (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0 + r1 <- Serial.readStart b1 + w1 <- Serial.writeStart return (cont1, - ((Class.undefTuple, b1), - (valueOf $ fromIntegral $ Vector.sizeInTuple a0, s1))) + ((w1, r1), + (valueOf $ fromIntegral $ Serial.size a0, s1))) Maybe.lift $ do - a3 <- fmap snd $ Vector.shiftDown ai a2 - (bi,b3) <- Vector.shiftDown (Class.undefTuple) b2 + w3 <- Serial.writeNext ai w2 + (bi,r3) <- Serial.readNext r2 i3 <- A.dec i2 - return (bi, ((a3,b3),(i3,s2)))) + return (bi, ((w3,r3),(i3,s2)))) (\p -> do s <- start p - return ((Class.zeroTuple, Class.undefTuple), (valueOf (0::Word32), s))) + w <- Serial.writeZero + return ((w, Class.undefTuple), (valueOf (0::Word32), s))) createIOContext deleteIOContext raise :: (Storable a, IsArithmetic a, IsConst a, - MakeValueTuple a (Value a), - Memory.FirstClass a am, - IsPrimitive a, IsSized a as, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => + MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + TypeNum.PositiveT n) => Param.T p a -> - T p (Value (Vector n a)) (Value (Vector n a)) + T p (Serial.Value n a) (Serial.Value n a) raise x = Causal.map Frame.mix (Serial.replicate ^<< x) amplify :: (Storable a, IsArithmetic a, IsConst a, - MakeValueTuple a (Value a), - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n asize vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => + MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + TypeNum.PositiveT n) => Param.T p a -> - T p (Value (Vector n a)) (Value (Vector n a)) + T p (Serial.Value n a) (Serial.Value n a) amplify p = Causal.map Frame.amplifyMono (Serial.replicate ^<< p) amplifyStereo :: (Storable a, IsArithmetic a, IsConst a, - MakeValueTuple a (Value a), - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n asize vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => + MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + TypeNum.PositiveT n) => Param.T p a -> - T p (Stereo.T (Value (Vector n a))) (Stereo.T (Value (Vector n a))) + T p (Stereo.T (Serial.Value n a)) (Stereo.T (Serial.Value n a)) amplifyStereo p = Causal.map Frame.amplifyStereo (Serial.replicate ^<< p) osciCore :: - (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t, Vector.Real t, IsPrimitive t, - TypeNum.Pos n, + TypeNum.PositiveT n, Additive.C t) => - T p (Value (Vector n t), Value (Vector n t)) (Value (Vector n t)) + T p (Serial.Value n t, Serial.Value n t) (Serial.Value n t) osciCore = - Causal.zipWithSimple SoV.addToPhase <<< + Causal.zipWithSimple A.addToPhase <<< Arr.second (Causal.mapAccumSimple (\a phase0 -> do - (phase1,b1) <- Vector.cumulate phase0 a - phase2 <- SoV.signedFraction phase1 + (phase1,b1) <- Serial.cumulate phase0 a + phase2 <- A.signedFraction phase1 return (b1,phase2)) (return (valueOf Additive.zero))) osciSimple :: - (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t, Vector.Real t, IsPrimitive t, - TypeNum.Pos n, + TypeNum.PositiveT n, Additive.C t) => - (forall r. Value (Vector n t) -> CodeGenFunction r y) -> - T p (Value (Vector n t), Value (Vector n t)) y + (forall r. Serial.Value n t -> CodeGenFunction r y) -> + T p (Serial.Value n t, Serial.Value n t) y osciSimple wave = Causal.mapSimple wave <<< osciCore shapeModOsci :: - (Memory.FirstClass t tm, IsSized t size, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t, Vector.Real t, IsPrimitive t, - TypeNum.Pos n, + TypeNum.PositiveT n, Additive.C t) => - (forall r. c -> Value (Vector n t) -> CodeGenFunction r y) -> - T p (c, (Value (Vector n t), Value (Vector n t))) y + (forall r. c -> Serial.Value n t -> CodeGenFunction r y) -> + T p (c, (Serial.Value n t, Serial.Value n t)) y shapeModOsci wave = Causal.zipWithSimple wave <<< Arr.second osciCore delay1 :: - (Vector.Access n al va, + (Serial.C va, n ~ Serial.Size va, al ~ Serial.Element va, Storable a, - MakeValueTuple a al, - Memory.C al ap, - IsSized ap as) => + MakeValueTuple a, ValueTuple a ~ al, + Memory.C al) => Param.T p a -> T p va va delay1 initial = Causal.loop initial $ - Causal.mapSimple (fmap swap . uncurry Vector.shiftUp . swap) + Causal.mapSimple (fmap swap . uncurry Serial.shiftUp . swap) differentiate :: - (Vector.Access n al va, + (Serial.C va, n ~ Serial.Size va, al ~ Serial.Element va, A.Additive va, Storable a, - MakeValueTuple a al, - Memory.C al ap, - IsSized ap as) => + MakeValueTuple a, ValueTuple a ~ al, + Memory.C al) => Param.T p a -> T p va va differentiate initial = Cat.id - delay1 initial arrayElement :: - (IsFirstClass a, SoV.Replicate a v, - LLVM.GetValue (LLVM.Array dim a) index a, - TypeNum.Nat index, TypeNum.Nat dim, index :<: dim) => - index -> T p (Value (LLVM.Array dim a)) (Value v) + (IsFirstClass a, LLVM.Value a ~ Serial.Element v, Serial.C v, + LLVM.GetValue (LLVM.Array dim a) index, + LLVM.ValueType (LLVM.Array dim a) index ~ a, + TypeNum.NaturalT index, TypeNum.NaturalT dim, + (index :<: dim) ~ TypeBool.True) => + index -> T p (Value (LLVM.Array dim a)) v arrayElement i = - Causal.mapSimple SoV.replicate <<< Causal.arrayElement i + Causal.mapSimple Serial.upsample <<< Causal.arrayElement i 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 @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} @@ -12,11 +13,9 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Core as LLVM -import LLVM.Extra.Class (MakeValueTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Util.Loop (Phi, ) -import LLVM.Core - (Value, valueOf, - IsSized, CodeGenFunction, ) +import LLVM.Core (Value, valueOf, CodeGenFunction, ) import qualified Control.Arrow as Arr import qualified Control.Category as Cat @@ -36,51 +35,45 @@ import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, ) +import qualified Prelude as P + data T p a b = - forall state packed size ioContext - startParamTuple startParamValue startParamPacked startParamSize - nextParamTuple nextParamValue nextParamPacked nextParamSize. + forall state ioContext startParamTuple nextParamTuple. (Storable startParamTuple, Storable nextParamTuple, - MakeValueTuple startParamTuple startParamValue, - MakeValueTuple nextParamTuple nextParamValue, - Memory.C startParamValue startParamPacked, - Memory.C nextParamValue nextParamPacked, - IsSized startParamPacked startParamSize, - IsSized nextParamPacked nextParamSize, - Memory.C state packed, - IsSized packed size) => + MakeValueTuple startParamTuple, + MakeValueTuple nextParamTuple, + Memory.C (ValueTuple startParamTuple), + Memory.C (ValueTuple nextParamTuple), + Memory.C state) => Cons (forall r c. (Phi c) => - nextParamValue -> + ValueTuple nextParamTuple -> a -> state -> Maybe.T r c (b, state)) -- compute next value (forall r. - startParamValue -> + ValueTuple startParamTuple -> CodeGenFunction r state) -- initial state (p -> IO (ioContext, (nextParamTuple, startParamTuple))) {- initialization from IO monad - This will be run within unsafePerformIO, + This will be run within Unsafe.performIO, so no observable In/Out actions please! -} (ioContext -> IO ()) - -- finalization from IO monad, also run within unsafePerformIO + -- finalization from IO monad, also run within Unsafe.performIO simple :: (Storable startParamTuple, Storable nextParamTuple, - MakeValueTuple startParamTuple startParamValue, - MakeValueTuple nextParamTuple nextParamValue, - Memory.C startParamValue startParamPacked, - Memory.C nextParamValue nextParamPacked, - IsSized startParamPacked startParamSize, - IsSized nextParamPacked nextParamSize, - Memory.C state packed, - IsSized packed size) => + MakeValueTuple startParamTuple, ValueTuple startParamTuple ~ startParamValue, + MakeValueTuple nextParamTuple, ValueTuple nextParamTuple ~ nextParamValue, + Memory.C startParamValue, + Memory.C nextParamValue, + Memory.C state) => (forall r c. (Phi c) => nextParamValue -> @@ -111,9 +104,9 @@ mapAccum :: - (Storable pnh, MakeValueTuple pnh pnl, Memory.C pnl pnp, IsSized pnp pns, - Storable psh, MakeValueTuple psh psl, Memory.C psl psp, IsSized psp pss, - Memory.C s struct, IsSized struct sa) => + (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl, + Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl, + Memory.C s) => (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) -> (forall r. psl -> CodeGenFunction r s) -> Param.T p pnh -> @@ -127,7 +120,7 @@ map :: - (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) => + (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => (forall r. pl -> a -> CodeGenFunction r b) -> Param.T p ph -> T p a b @@ -235,6 +228,20 @@ x / y = zipWithSimple A.fdiv <<< x&&&y +instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T p a b) where + fromInteger n = pure (A.fromInteger' n) + negate x = mapSimple A.neg <<< x + x + y = zipWithSimple A.add <<< x&&&y + x - y = zipWithSimple A.sub <<< x&&&y + x * y = zipWithSimple A.mul <<< x&&&y + abs x = mapSimple A.abs <<< x + signum x = mapSimple A.signum <<< x + +instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T p a b) where + fromRational x = pure (A.fromRational' x) + x / y = zipWithSimple A.fdiv <<< x&&&y + + {- | Not quite the loop of ArrowLoop because we need a delay of one time step @@ -247,9 +254,8 @@ -} loop :: (Storable ch, - MakeValueTuple ch c, - Memory.C c cp, - IsSized cp cs) => + MakeValueTuple ch, ValueTuple ch ~ c, + Memory.C c) => Param.T p ch -> T p (a,c) (b,c) -> T p a b loop initial (Cons next start createIOContext deleteIOContext) = Cons @@ -265,7 +271,7 @@ takeWhile :: - (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) => + (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => (forall r. pl -> a -> CodeGenFunction r (Value Bool)) -> Param.T p ph -> T p a a @@ -295,7 +301,7 @@ -} integrate :: (Storable a, A.Additive al, - MakeValueTuple a al, Memory.C al as, IsSized as size) => + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al integrate = @@ -303,7 +309,7 @@ integrate0 :: (Storable a, A.Additive al, - MakeValueTuple a al, Memory.C al as, IsSized as size) => + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al integrate0 = diff --git a/src/Synthesizer/LLVM/CausalParameterized/ProcessValue.hs b/src/Synthesizer/LLVM/CausalParameterized/ProcessValue.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/CausalParameterized/ProcessValue.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TypeFamilies #-} +{- | +This module provides functions similar to +"Synthesizer.LLVM.CausalParameterized.Process" +but expects functions that operate on 'Value.T'. +This way you can use common arithmetic operators +instead of LLVM assembly functions. +-} +module Synthesizer.LLVM.CausalParameterized.ProcessValue ( +-- simple, + mapAccum, map, mapSimple, + ) where + +import Synthesizer.LLVM.CausalParameterized.ProcessPrivate (T, ) +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified Synthesizer.LLVM.Simple.Value as Value + +import qualified LLVM.Extra.Memory as Memory +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) + +import Foreign.Storable.Tuple () +import Foreign.Storable (Storable, ) + +import Prelude hiding (map, ) + + +{- +simple :: + (Storable startParamTuple, + Storable nextParamTuple, + MakeValueTuple startParamTuple, ValueTuple startParamTuple ~ startParamValue, + MakeValueTuple nextParamTuple, ValueTuple nextParamTuple ~ nextParamValue, + Memory.C startParamValue, + Memory.C nextParamValue, + Memory.C state) => + (Value.T nextParamValue -> + Value.T a -> Value.T state -> Value.Maybe (Value.T b, Value.T state)) -> + (Value.T startParamValue -> Value.T state) -> + Param.T p nextParamTuple -> + Param.T p startParamTuple -> T p a b +simple f start = + Causal.simple + (\p a s -> + Value.flattenMaybe $ + next + (Value.constantValue p) + (Value.constantValue a) + (Value.constantValue s)) + (Value.unlift1 start) +-} + +map :: + (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => + (Value.T pl -> Value.T a -> Value.T b) -> + Param.T p ph -> + T p a b +map f = Causal.map (Value.unlift2 f) + +mapSimple :: + (Value.T a -> Value.T b) -> + T p a b +mapSimple f = + Causal.mapSimple (Value.unlift1 f) + +mapAccum :: + (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl, + Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl, + Memory.C s) => + (Value.T pnl -> Value.T a -> Value.T s -> (Value.T b, Value.T s)) -> + (Value.T psl -> Value.T s) -> + Param.T p pnh -> + Param.T p psh -> + T p a b +mapAccum next start = + Causal.mapAccum + (\p a s -> + Value.flatten $ + next + (Value.constantValue p) + (Value.constantValue a) + (Value.constantValue s)) + (Value.unlift1 start) diff --git a/src/Synthesizer/LLVM/Complex.hs b/src/Synthesizer/LLVM/Complex.hs --- a/src/Synthesizer/LLVM/Complex.hs +++ b/src/Synthesizer/LLVM/Complex.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Complex ( Complex.T(Complex.real, Complex.imag), @@ -17,10 +14,10 @@ import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM -import LLVM.Core (Value, ConstValue, Struct, IsConst, ) +import LLVM.Core (Value, ConstValue, IsConst, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import Control.Applicative (liftA2, ) @@ -31,8 +28,10 @@ import NumericPrelude.Base -} +type Struct a = LLVM.Struct (a, (a, ())) + constOf :: IsConst a => - Complex.T a -> ConstValue (Struct (a, (a, ()))) + Complex.T a -> ConstValue (Struct a) constOf x = LLVM.constStruct (LLVM.constOf $ Complex.real x, @@ -40,7 +39,7 @@ ())) unfold :: - Value (Struct (a, (a, ()))) -> Complex.T (Value.T a) + Value (Struct a) -> Complex.T (Value.T (Value a)) unfold x = Value.lift0 (LLVM.extractvalue x TypeNum.d0) Complex.+: @@ -61,16 +60,15 @@ memory :: - (Memory.C l s, LLVM.IsSized s ss) => - Memory.Record r (LLVM.Struct (s, (s, ()))) (Complex.T l) + (Memory.C l) => + Memory.Record r (Struct (Memory.Struct l)) (Complex.T l) memory = liftA2 (Complex.+:) (Memory.element Complex.real TypeNum.d0) (Memory.element Complex.imag TypeNum.d1) -instance - (Memory.C l s, LLVM.IsSized s ss) => - Memory.C (Complex.T l) (LLVM.Struct (s, (s, ()))) where +instance (Memory.C l) => Memory.C (Complex.T l) where + type Struct (Complex.T l) = Struct (Memory.Struct l) load = Memory.loadRecord memory store = Memory.storeRecord memory decompose = Memory.decomposeRecord memory 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 @@ -1,9 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {- | Data type that allows handling of piecewise constant signals independently from the source. @@ -25,16 +22,18 @@ import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Control (whileLoop, ) -import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import LLVM.Core as LLVM +import LLVM.Core (Value, valueOf, ) +import qualified LLVM.Core as LLVM -import Data.TypeLevel.Num (d0, d1, ) +import Types.Data.Num (d0, d1, ) import Data.Word (Word32, ) import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) +import Foreign.Ptr (Ptr, ) import qualified Synthesizer.LLVM.Alloc as Alloc import Control.Applicative (liftA2, ) @@ -61,17 +60,18 @@ zeroTuple = Cons Class.zeroTuple Class.zeroTuple +type Struct a = LLVM.Struct (Word32, (a, ())) + parameterMemory :: - (Memory.C a s, IsSized s ss) => - Memory.Record r (Struct (Word32, (s, ()))) (T a) + (Memory.C a) => + Memory.Record r (Struct (Memory.Struct a)) (T a) parameterMemory = liftA2 Cons (Memory.element (\(Cons len _y) -> len) d0) (Memory.element (\(Cons _len y) -> y) d1) -instance - (Memory.C a s, IsSized s ss) => - Memory.C (T a) (Struct (Word32, (s, ()))) where +instance (Memory.C a) => Memory.C (T a) where + type Struct (T a) = Struct (Memory.Struct a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory @@ -79,7 +79,7 @@ flatten :: - (Memory.C value struct, IsSized struct size) => + (Memory.C value) => SigP.T p (T value) -> SigP.T p value flatten (SigP.Cons next start createIOContext deleteIOContext) = @@ -89,7 +89,7 @@ Maybe.fromBool $ whileLoop (valueOf True, state0) (\(cont, (Cons len _y, _s)) -> - LLVM.and cont =<< A.cmp CmpEQ len (valueOf 0)) + LLVM.and cont =<< A.cmp LLVM.CmpEQ len (valueOf 0)) (\(_cont, (Cons _len _y, s)) -> Maybe.toBool $ next nextParam s) length2 <- Maybe.lift (A.dec length1) @@ -101,16 +101,16 @@ piecewiseConstant :: - (Storable a, MakeValueTuple a value, Memory.C value struct, IsSized struct size) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => Param.T p (EventList.T NonNeg.Int a) -> SigP.T p (T value) piecewiseConstant evs = SigP.Cons (\(stable, yPtr) () -> do len <- Maybe.lift $ do - nextFn <- staticFunction EventIt.nextCallBack - call nextFn stable yPtr + nextFn <- LLVM.staticFunction EventIt.nextCallBack + LLVM.call nextFn stable yPtr Maybe.guard =<< - Maybe.lift (A.cmp CmpNE len (valueOf 0)) + Maybe.lift (A.cmp LLVM.CmpNE len (valueOf 0)) y <- Maybe.lift $ Memory.load yPtr return (Cons len y, ())) return @@ -136,10 +136,10 @@ lazySize size = SigP.Cons (\stable () -> do len <- Maybe.lift $ do - nextFn <- staticFunction SizeIt.nextCallBack - call nextFn stable + nextFn <- LLVM.staticFunction SizeIt.nextCallBack + LLVM.call nextFn stable Maybe.guard =<< - Maybe.lift (A.cmp CmpNE len (valueOf 0)) + Maybe.lift (A.cmp LLVM.CmpNE len (valueOf 0)) return (Cons len (), ())) return (\p -> do diff --git a/src/Synthesizer/LLVM/Debug/Storable.hs b/src/Synthesizer/LLVM/Debug/Storable.hs --- a/src/Synthesizer/LLVM/Debug/Storable.hs +++ b/src/Synthesizer/LLVM/Debug/Storable.hs @@ -3,7 +3,7 @@ import qualified Synthesizer.LLVM.Debug.Counter as Counter -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import qualified LLVM.Core as LLVM import LLVM.Core (Array, ConstValue, constOf, ) @@ -17,17 +17,18 @@ import Foreign.Storable (Storable, peek, peekByteOff, sizeOf, alignment, ) import Foreign.Ptr (Ptr, castPtr, ) import Data.Word (Word8, Word32, ) -import System.IO.Unsafe (unsafePerformIO, ) +import qualified System.Unsafe as Unsafe import qualified Control.Monad.Trans.Reader as R import Control.Monad (when, ) +import Data.Maybe (fromMaybe, ) data Dump = Dump dumpCounter :: IORef.IORef (Counter.T Dump) dumpCounter = - unsafePerformIO $ Counter.new + Unsafe.performIO $ Counter.new format :: Storable a => a -> IO String format a = @@ -59,7 +60,7 @@ withConstArray :: Storable a => a -> - (forall n. TypeNum.Nat n => ConstValue (Array n ArrayElem) -> b) -> + (forall n. TypeNum.NaturalT n => ConstValue (Array n ArrayElem) -> b) -> IO b withConstArray a f = Marshal.with a $ \ptr -> do @@ -67,11 +68,13 @@ mapM (peekByteOff ptr) (takeWhile (< sizeOf a) [0,(sizeOf (undefined :: ArrayElem))..]) + :: IO [ArrayElem] return $ - TypeNum.reifyIntegral (length content) + fromMaybe (error "Debug.Storable.withConstArray: length must always be non-negative") $ + TypeNum.reifyNaturalD (fromIntegral (length content)) (\n -> let makeArray :: - TypeNum.Nat n => + TypeNum.NaturalT n => n -> [ConstValue ArrayElem] -> ConstValue (Array n ArrayElem) makeArray _ = LLVM.constArray 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,8 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Execution where import qualified LLVM.ExecutionEngine as EE @@ -15,30 +11,30 @@ import Control.Monad (liftM2, liftM3, ) import qualified Data.IORef as IORef -import System.IO.Unsafe (unsafePerformIO, ) +import qualified System.Unsafe as Unsafe import qualified Synthesizer.LLVM.Debug.Counter as Counter type Importer f = FunPtr f -> f -class Compile externFunction llvmFunction | - externFunction -> llvmFunction, - llvmFunction -> externFunction where - compile :: llvmFunction -> EE.EngineAccess externFunction +class Compile externFunction where + type LLVMFunction externFunction :: * + compile :: LLVMFunction externFunction -> EE.EngineAccess externFunction -instance Compile (FunPtr f) (LLVM.Function f) where +instance Compile (FunPtr f) where + type LLVMFunction (FunPtr f) = (LLVM.Function f) compile = EE.getPointerToFunction -instance (Compile efa lfa, Compile efb lfb) => - Compile (efa,efb) (lfa,lfb) where +instance (Compile fa, Compile fb) => Compile (fa,fb) where + type LLVMFunction (fa,fb) = (LLVMFunction fa, LLVMFunction fb) compile (fa,fb) = liftM2 (,) (compile fa) (compile fb) -instance (Compile efa lfa, Compile efb lfb, Compile efc lfc) => - Compile (efa,efb,efc) (lfa,lfb,lfc) where +instance (Compile fa, Compile fb, Compile fc) => Compile (fa,fb,fc) where + type LLVMFunction (fa,fb,fc) = (LLVMFunction fa, LLVMFunction fb, LLVMFunction fc) compile (fa,fb,fc) = liftM3 (,,) (compile fa) @@ -54,7 +50,7 @@ -} counter :: IORef.IORef (Counter.T BitCodeCnt) counter = - unsafePerformIO $ Counter.new + Unsafe.performIO $ Counter.new {- | @@ -85,8 +81,8 @@ -- this compiles once and is much faster than runFunction compileModule :: - (Compile externFunction llvmFunction) => - LLVM.CodeGenModule llvmFunction -> + (Compile externFunction) => + LLVM.CodeGenModule (LLVMFunction externFunction) -> IO externFunction compileModule = assembleModule compile diff --git a/src/Synthesizer/LLVM/Filter/Allpass.hs b/src/Synthesizer/LLVM/Filter/Allpass.hs --- a/src/Synthesizer/LLVM/Filter/Allpass.hs +++ b/src/Synthesizer/LLVM/Filter/Allpass.hs @@ -1,9 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Allpass ( @@ -18,26 +16,24 @@ import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 -import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Vector as Vector -import qualified LLVM.Extra.Memory as Memory +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM import LLVM.Extra.Class (Undefined, undefTuple, ) -import LLVM.Core - (Value, valueOf, Vector, - IsArithmetic, IsPrimitive, IsFloating, IsSized, - CodeGenFunction, ) +import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import Foreign.Storable (Storable, ) @@ -66,9 +62,8 @@ instance Class.Zero a => Class.Zero (Parameter a) where zeroTuple = Class.zeroTuplePointed -instance - (Memory.C a s, IsSized s ss) => - Memory.C (Parameter a) s where +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = Memory.Struct a load = Memory.loadNewtype Parameter store = Memory.storeNewtype (\(Parameter k) -> k) decompose = Memory.decomposeNewtype Parameter @@ -83,31 +78,30 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (Parameter ah) (Parameter al) where +instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where + type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -instance (Value.Flatten ah al) => - Value.Flatten (Parameter ah) (Parameter al) where +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor -instance (Vector.ShuffleMatch n v) => - Vector.ShuffleMatch n (Parameter v) where +instance (Vector.Simple v) => Vector.Simple (Parameter v) where + type Element (Parameter v) = Parameter (Vector.Element v) + type Size (Parameter v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable - -instance (Vector.Access n a v) => - Vector.Access n (Parameter a) (Parameter v) where - insert = Vector.insertTraversable extract = Vector.extractTraversable +instance (Vector.C v) => Vector.C (Parameter v) where + insert = Vector.insertTraversable + parameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a) => - Value a -> Value a -> - CodeGenFunction r (Parameter (Value a)) + (A.Transcendental a, A.RationalConstant a) => + a -> a -> CodeGenFunction r (Parameter a) parameter phase freq = Value.flatten $ Allpass.parameter @@ -120,9 +114,8 @@ (Phi, Undefined, Class.Zero, Storable, Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -instance - (Memory.C a s, IsSized s ss) => - Memory.C (CascadeParameter n a) s where +instance (Memory.C a) => Memory.C (CascadeParameter n a) where + type Struct (CascadeParameter n a) = Memory.Struct a load = Memory.loadNewtype CascadeParameter store = Memory.storeNewtype (\(CascadeParameter k) -> k) decompose = Memory.decomposeNewtype CascadeParameter @@ -137,47 +130,51 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (CascadeParameter n ah) (CascadeParameter n al) where +instance (Class.MakeValueTuple a) => Class.MakeValueTuple (CascadeParameter n a) where + type ValueTuple (CascadeParameter n a) = CascadeParameter n (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -instance (Value.Flatten ah al) => - Value.Flatten (CascadeParameter n ah) (CascadeParameter n al) where +instance (Value.Flatten a) => Value.Flatten (CascadeParameter n a) where + type Registers (CascadeParameter n a) = CascadeParameter n (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor -instance (Vector.ShuffleMatch m v) => - Vector.ShuffleMatch m (CascadeParameter n v) where +instance (Vector.Simple v) => Vector.Simple (CascadeParameter n v) where + type Element (CascadeParameter n v) = CascadeParameter n (Vector.Element v) + type Size (CascadeParameter n v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable -instance (Vector.Access m a v) => - Vector.Access m (CascadeParameter n a) (CascadeParameter n v) where +instance (Vector.C v) => Vector.C (CascadeParameter n v) where insert = Vector.insertTraversable - extract = Vector.extractTraversable +type instance F.Arguments f (CascadeParameter n a) = f (CascadeParameter n a) +instance F.MakeArguments (CascadeParameter n a) where + makeArgs = id + flangerParameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a, TypeNum.Nat n) => - n -> Value a -> - CodeGenFunction r (CascadeParameter n (Value a)) + (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) => + n -> a -> + CodeGenFunction r (CascadeParameter n a) flangerParameter order freq = Value.flatten $ CascadeParameter $ - Allpass.flangerParameter (TypeNum.toInt order) $ + Allpass.flangerParameter (TypeNum.fromIntegerT order) $ Value.constantValue freq flangerParameterPlain :: - (Trans.C a, TypeNum.Nat n) => + (Trans.C a, TypeNum.NaturalT n) => n -> a -> CascadeParameter n a flangerParameterPlain order freq = CascadeParameter $ - Allpass.flangerParameter (TypeNum.toInt order) freq + Allpass.flangerParameter (TypeNum.fromIntegerT order) freq modifier :: - (SoV.PseudoModule a v, SoV.IntegerConstant a) => + (A.PseudoModule a v, A.IntegerConstant a) => Modifier.Simple -- (Allpass.State (Value.T v)) (Value.T v, Value.T v) @@ -190,57 +187,43 @@ For Allpass cascade you may use the 'CausalP.pipeline' function. -} causalP :: - (SoV.RationalConstant a, IsArithmetic a, - SoV.PseudoModule a v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - CausalP.T p - (Parameter (Value a), Value v) (Value v) + (A.RationalConstant a, A.PseudoModule a v, Memory.C v) => + CausalP.T p (Parameter a, v) v causalP = CausalP.fromModifier modifier replicateStage :: - (TypeNum.Nat n) => + (TypeNum.NaturalT n) => n -> CausalP.T p (Parameter a, b) b -> CausalP.T p (CascadeParameter n a, b) b replicateStage order stg = CausalP.replicateControlled - (TypeNum.toInt order) + (TypeNum.fromIntegerT order) (stg <<< first (arr (\(CascadeParameter p) -> p))) cascadeP :: - (SoV.RationalConstant a, IsArithmetic a, - SoV.PseudoModule a v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeNum.Nat n) => - CausalP.T p - (CascadeParameter n (Value a), Value v) (Value v) + (A.RationalConstant a, A.PseudoModule a v, Memory.C v, + TypeNum.NaturalT n) => + CausalP.T p (CascadeParameter n a, v) v cascadeP = replicateStage undefined causalP half :: - (SoV.RationalConstant a, SoV.RationalConstant v, - IsFloating a, IsArithmetic v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeNum.Nat n) => - CausalP.T p - (CascadeParameter n (Value a), Value v) (Value v) + (A.RationalConstant a, A.PseudoModule a v) => + CausalP.T p (param a, v) v half = - CausalP.mapSimple - (\(_p,x) -> A.mul (A.fromRational' 0.5) x) + let scale :: A.PseudoModule a v => param a -> a -> v -> CodeGenFunction r v + scale _ = A.scale + in CausalP.mapSimple + (\(p,x) -> scale p (A.fromRational' 0.5) x) phaserP :: - (SoV.RationalConstant a, SoV.RationalConstant v, - IsFloating a, SoV.PseudoModule a v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeNum.Nat n) => - CausalP.T p - (CascadeParameter n (Value a), Value v) (Value v) + (A.RationalConstant a, A.RationalConstant v, + A.PseudoModule a v, Memory.C v, + TypeNum.NaturalT n) => + CausalP.T p (CascadeParameter n a, v) v phaserP = CausalP.mix <<< cascadeP &&& arr snd <<< @@ -252,13 +235,12 @@ but LLVM-2.6 does not yet do it. -} stage :: - (TypeNum.Pos n, IsPrimitive a, - IsArithmetic a, SoV.IntegerConstant a, SoV.PseudoModule a a, - Memory.FirstClass a am, IsSized a as, IsSized am ams) => + (Vector.Canonical n a, Vector.Construct n a ~ v, + A.PseudoModule a a, A.IntegerConstant a, Memory.C a) => n -> CausalP.T p - (CascadeParameter n (Value (Vector n a)), Value (Vector n a)) - (CascadeParameter n (Value (Vector n a)), Value (Vector n a)) + (CascadeParameter n v, v) + (CascadeParameter n v, v) stage _ = CausalP.vectorize (arr fst &&& @@ -277,73 +259,60 @@ and we get a delay by the number of pipeline stages. -} cascadePipelineP :: - (SoV.RationalConstant a, SoV.PseudoModule a a, --- IsSized (Vector n a) vas, - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n asize vasize, TypeNum.Pos vasize, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => - CausalP.T p - (CascadeParameter n (Value a), Value a) (Value a) + (Vector.Canonical n a, Vector.Construct n a ~ v, + A.PseudoModule a a, A.IntegerConstant a, Memory.C a, + Class.Zero v, Memory.C v) => + CausalP.T p (CascadeParameter n a, a) a cascadePipelineP = withSize $ \order -> snd ^<< CausalP.pipeline (stage order) vectorId :: - (Vector.Access n a v) => - n -> CausalP.T p v v + (Vector.Canonical n a) => + n -> CausalP.T p (Vector.Construct n a) (Vector.Construct n a) vectorId _ = Cat.id phaserPipelineP :: - (SoV.RationalConstant a, IsFloating a, SoV.PseudoModule a a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n asize vasize, TypeNum.Pos vasize, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => - CausalP.T p - (CascadeParameter n (Value a), Value a) (Value a) + (Vector.Canonical n a, Vector.Construct n a ~ v, + A.PseudoModule a a, A.RationalConstant a, Memory.C a, + Class.Zero v, Memory.C v) => + CausalP.T p (CascadeParameter n a, a) a phaserPipelineP = withSize $ \order -> CausalP.mix <<< cascadePipelineP &&& (CausalP.pipeline (vectorId order) <<^ snd) <<< --- (CausalP.delay (const zero) (const $ TypeNum.toInt order) <<^ snd) <<< +-- (CausalP.delay (const zero) (const $ TypeNum.fromIntegerT order) <<^ snd) <<< (arr fst &&& half) causalPackedP, causalNonRecursivePackedP :: - (Memory.FirstClass a am, IsSized a as, IsSized am ams, - SoV.IntegerConstant a, IsArithmetic a, - TypeNum.Pos n, IsPrimitive a) => - CausalP.T p - (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) + (Serial.C v, Serial.Element v ~ a, + Memory.C a, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + CausalP.T p (Parameter a, v) v causalPackedP = Filt1L.causalRecursivePackedP <<< (CausalP.mapSimple (\(Parameter k, _) -> - fmap Filt1.Parameter $ LLVM.neg k) &&& + fmap Filt1.Parameter $ A.neg k) &&& causalNonRecursivePackedP) causalNonRecursivePackedP = CausalP.mapAccumSimple (\(Parameter k, v0) x1 -> do - (_,v1) <- Vector.shiftUp x1 v0 - y <- A.add v1 =<< A.mul v0 =<< SoV.replicate k - let size = fromIntegral $ Vector.sizeInTuple v0 - u0 <- Vector.extract (valueOf $ size - 1) v0 + (_,v1) <- Serial.shiftUp x1 v0 + y <- A.add v1 =<< A.mul v0 =<< Serial.upsample k + let size = fromIntegral $ Serial.size v0 + u0 <- Serial.extract (LLVM.valueOf $ size - 1) v0 return (y, u0)) - (return (LLVM.value LLVM.zero)) + (return A.zero) cascadePackedP, phaserPackedP :: - (SoV.RationalConstant a, IsArithmetic a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos m, IsPrimitive a, - TypeNum.Nat n) => - CausalP.T p - (CascadeParameter n (Value a), Value (Vector m a)) (Value (Vector m a)) + (TypeNum.NaturalT n, + Serial.C v, Serial.Element v ~ a, + A.PseudoRing a, A.IntegerConstant a, Memory.C a, + A.PseudoRing v, A.RationalConstant v) => + CausalP.T p (CascadeParameter n a, v) v cascadePackedP = replicateStage undefined causalPackedP diff --git a/src/Synthesizer/LLVM/Filter/Butterworth.hs b/src/Synthesizer/LLVM/Filter/Butterworth.hs --- a/src/Synthesizer/LLVM/Filter/Butterworth.hs +++ b/src/Synthesizer/LLVM/Filter/Butterworth.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Butterworth ( parameter, Cascade.ParameterValue, @@ -22,12 +24,12 @@ import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, constOf, - IsConst, IsFloating, IsSized, + IsConst, IsFloating, IsSized, SizeOf, CodeGenFunction, ) import Data.Word (Word32, ) -import qualified Data.TypeLevel.Num as TypeNum -import qualified Data.TypeLevel.Num.Sets as TypeSet +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field @@ -39,17 +41,16 @@ parameter, parameterMalloc, _parameterAlloca :: - (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a as, - TypeSet.Nat n, - TypeNum.Mul n as sineSize, - TypeSet.Pos sineSize, - IsSized (Cascade.Parameter n a) paramSize) => + (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a, + TypeNum.NaturalT n, + TypeNum.PositiveT (n :*: SizeOf a), + IsSized (Cascade.ParameterStruct n a)) => n -> Passband -> Value a -> Value a -> CodeGenFunction r (Cascade.ParameterValue n a) parameter = parameterMalloc parameterMalloc n kind ratio freq = do - let order = 2 * TypeNum.toInt n + let order = 2 * TypeNum.fromIntegerT n partialRatio <- Value.decons (Butterworth.partialRatio order (Value.constantValue ratio)) let sines = @@ -63,7 +64,7 @@ s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) ps <- LLVM.malloc p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ()) - let len = valueOf $ (TypeNum.toNum n :: Word32) + let len = valueOf $ (TypeNum.fromIntegerT n :: Word32) _ <- U.arrayLoop len p s $ \ptri si -> do sinw <- LLVM.load si flip LLVM.store ptri =<< @@ -82,7 +83,7 @@ return (Cascade.ParameterValue pv) _parameterAlloca n kind ratio freq = do - let order = 2 * TypeNum.toInt n + let order = 2 * TypeNum.fromIntegerT n partialRatio <- Value.decons (Butterworth.partialRatio order (Value.constantValue ratio)) let sines = @@ -96,7 +97,7 @@ s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) ps <- LLVM.alloca p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ()) - let len = valueOf $ (TypeNum.toNum n :: Word32) + let len = valueOf $ (TypeNum.fromIntegerT n :: Word32) _ <- U.arrayLoop len p s $ \ptri si -> do sinw <- LLVM.load si flip LLVM.store ptri =<< 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 @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Chebyshev ( parameterA, parameterB, Cascade.ParameterValue, @@ -21,11 +23,12 @@ import qualified LLVM.Core as LLVM import LLVM.Core - (Value, valueOf, IsSized, IsFloating, CodeGenFunction, ) + (Value, valueOf, IsSized, SizeOf, IsFloating, CodeGenFunction, ) import Data.Word (Word32, ) -import qualified Data.TypeLevel.Num as TypeNum -import qualified Data.TypeLevel.Num.Sets as TypeSet +import qualified Types.Data.Bool as TypeBool +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) import qualified Synthesizer.LLVM.Complex as ComplexL @@ -45,11 +48,11 @@ by the first partial filter. -} parameterA, parameterB :: - (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a as, - TypeSet.Pos n, TypeNum.Mul n as sineSize, - TypeSet.Pos sineSize, - IsSized (Cascade.Parameter n a) paramSize, - TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => + (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a, + TypeNum.PositiveT n, TypeNum.IsNatural n ~ TypeBool.True, + TypeNum.PositiveT (n :*: SizeOf a), + IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize, + (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.PositiveT paramSize) => n -> Passband -> Value a -> Value a -> CodeGenFunction r (Cascade.ParameterValue n a) parameterA n kind ratio freq = do @@ -71,18 +74,17 @@ parameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a as, - TypeSet.Pos n, - TypeNum.Mul n as sineSize, - TypeSet.Pos sineSize, - IsSized (Cascade.Parameter n a) paramSize, - TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => - (Int -> Value.T a -> Value.T a -> - Complex.T (Value.T a) -> Filt2Core.Parameter (Value.T a)) -> + (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a, + TypeNum.PositiveT n, TypeNum.IsNatural n ~ TypeBool.True, + TypeNum.PositiveT (n :*: SizeOf a), + IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize, + (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.PositiveT paramSize) => + (Int -> Value.T (Value a) -> Value.T (Value a) -> + Complex.T (Value.T (Value a)) -> Filt2Core.Parameter (Value.T (Value a))) -> n -> Passband -> Value a -> Value a -> - CodeGenFunction r (Value (Cascade.Parameter n a)) + CodeGenFunction r (Value (Cascade.ParameterStruct n a)) parameter partialParameter n kind ratio freq = do - let order = 2 * TypeNum.toInt n + let order = 2 * TypeNum.fromIntegerT n let sines = (flip const :: n -> LLVM.Value (LLVM.Array n a) -> LLVM.Value (LLVM.Array n a)) n $ @@ -95,7 +97,7 @@ s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) ps <- LLVM.malloc p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ()) - let len = valueOf $ (TypeNum.toNum n :: Word32) + let len = valueOf $ (TypeNum.fromIntegerT n :: Word32) _ <- U.arrayLoop len p s $ \ptri si -> do c <- LLVM.load si flip LLVM.store ptri =<< diff --git a/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs b/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs --- a/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs +++ b/src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs @@ -1,11 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Filter.ComplexFirstOrder ( Parameter, parameter, causal, causalP, @@ -18,28 +12,22 @@ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Complex as Complex -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM -import LLVM.Core - (Value, Struct, value, valueOf, - IsArithmetic, IsFloating, IsSized, - CodeGenFunction, ) +import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (d0, d1, d2, ) +import Types.Data.Num (d0, d1, d2, ) import qualified Control.Applicative as App import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import Control.Applicative (liftA2, liftA3, (<*>), ) -import qualified Algebra.Transcendental as Trans - import NumericPrelude.Numeric import NumericPrelude.Base @@ -81,31 +69,33 @@ undefTuple = Class.undefTuplePointed +type ParameterStruct a = LLVM.Struct (a, (a, (a, ()))) + parameterMemory :: - (Memory.C l s, IsSized s ss) => - Memory.Record r (Struct (s, (s, (s, ())))) (Parameter l) + (Memory.C a) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) parameterMemory = liftA3 (\amp kr ki -> Parameter amp (kr Complex.+: ki)) (Memory.element (\(Parameter amp _) -> amp) d0) (Memory.element (\(Parameter _amp k) -> Complex.real k) d1) (Memory.element (\(Parameter _amp k) -> Complex.imag k) d2) -instance (Memory.C l s, IsSized s ss) => - Memory.C (Parameter l) (Struct (s, (s, (s, ())))) where +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Struct a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory compose = Memory.composeRecord parameterMemory -instance (Value.Flatten ah al) => - Value.Flatten (Parameter ah) (Parameter al) where +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor parameter, _parameter :: - (Trans.C a, IsFloating a, SoV.RationalConstant a) => - Value a -> Value a -> CodeGenFunction r (Parameter (Value a)) + (A.Transcendental a, A.RationalConstant a) => + a -> a -> CodeGenFunction r (Parameter a) parameter reson freq = let amp = recip $ Value.unfold reson in Value.flatten $ Parameter amp $ @@ -113,8 +103,8 @@ Value.unfold freq * Value.twoPi _parameter reson freq = do - amp <- A.fdiv (valueOf 1) reson - k <- A.sub (valueOf 1) amp + amp <- A.fdiv A.one reson + k <- A.sub A.one amp w <- A.mul freq =<< Value.decons Value.twoPi kr <- A.mul k =<< A.cos w ki <- A.mul k =<< A.sin w @@ -126,13 +116,13 @@ cannot be used directly, because Filt1C has complex amplitude -} next, _next :: - (IsArithmetic a, SoV.IntegerConstant a) => - (Parameter (Value a), Stereo.T (Value a)) -> - Complex.T (Value a) -> - CodeGenFunction r (Stereo.T (Value a), Complex.T (Value a)) + (A.PseudoRing a, A.IntegerConstant a) => + (Parameter a, Stereo.T a) -> + Complex.T a -> + CodeGenFunction r (Stereo.T a, Complex.T a) next inp state = let stereoFromComplex :: - Complex.T (Value a) -> Complex.T (Value.T a) -> + Complex.T a -> Complex.T (Value.T a) -> Stereo.T (Value.T a) stereoFromComplex _ c = Stereo.cons (Complex.real c) (Complex.imag c) @@ -156,27 +146,23 @@ start :: - (LLVM.IsType a, SoV.IntegerConstant a) => - CodeGenFunction r (Complex.T (Value a)) + (A.Additive a) => + CodeGenFunction r (Complex.T a) start = - return (value LLVM.zero Complex.+: value LLVM.zero) + return (A.zero Complex.+: A.zero) causal :: - (IsSized a sa, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized am amsize, - IsFloating a) => + (A.PseudoRing a, A.IntegerConstant a, Memory.C a) => Causal.T - (Parameter (Value a), Stereo.T (Value a)) - (Stereo.T (Value a)) + (Parameter a, Stereo.T a) + (Stereo.T a) causal = Causal.mapAccum next start causalP :: - (IsSized a sa, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized am amsize, - IsFloating a) => + (A.PseudoRing a, A.IntegerConstant a, Memory.C a) => CausalP.T p - (Parameter (Value a), Stereo.T (Value a)) - (Stereo.T (Value a)) + (Parameter a, Stereo.T a) + (Stereo.T a) causalP = CausalP.mapAccumSimple next start diff --git a/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs b/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs --- a/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs +++ b/src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs @@ -1,12 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked ( Parameter, parameter, causal, causalP, @@ -18,9 +14,10 @@ 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.Extra.Memory as Memory import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM @@ -28,18 +25,14 @@ (Value, valueOf, value, Struct, IsPrimitive, IsConst, IsFloating, IsSized, Vector, insertelement, - neg, CodeGenFunction, ) + CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (D4, d0, d1, ) +import qualified Types.Data.Num as TypeNum +import Types.Data.Num (D4, d0, d1, (:*:), ) import Control.Applicative (liftA2, ) -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 NumericPrelude.Numeric import NumericPrelude.Base @@ -66,8 +59,10 @@ type ParameterStruct a = Struct (Vector D4 a, (Vector D4 a, ())) parameterMemory :: - (Memory.FirstClass a am, - IsPrimitive a, IsPrimitive am) => + (Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsPrimitive am, + TypeNum.PositiveT (TypeNum.D4 :*: LLVM.SizeOf am), + IsSized am) => Memory.Record r (ParameterStruct am) (Parameter a) parameterMemory = liftA2 Parameter @@ -85,27 +80,28 @@ Memory.C (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where -} instance - (Memory.FirstClass a am, + (Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsPrimitive am, - IsSized (ParameterStruct am) s) => - Memory.C (Parameter a) (ParameterStruct am) where + IsSized am, + TypeNum.PositiveT (TypeNum.D4 :*: LLVM.SizeOf am)) => + Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Stored a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory compose = Memory.composeRecord parameterMemory parameter :: - (Trans.C a, - IsPrimitive a, IsConst a, IsFloating a) => + (SoV.TranscendentalConstant a, IsFloating a, IsPrimitive a) => Value a -> Value a -> CodeGenFunction r (Parameter a) parameter reson freq = do - amp <- A.fdiv (valueOf 1) reson - k <- A.sub (valueOf 1) amp + amp <- A.fdiv A.one reson + k <- A.sub A.one amp w <- A.mul freq =<< Value.decons Value.twoPi kr <- A.mul k =<< A.cos w ki <- A.mul k =<< A.sin w - kin <- neg ki + kin <- A.neg ki kvr <- Vector.assemble [kr,kin,amp, value LLVM.zero] kvi <- Vector.assemble [ki,kr, amp, value LLVM.zero] return (Parameter kvr kvi) @@ -145,7 +141,7 @@ causal :: (IsConst a, Vector.Arithmetic a, - Memory.C (Value (State a)) struct, IsSized struct size) => + Memory.C (Value (State a))) => {- (IsConst a, Vector.Arithmetic a, Memory.FirstClass a am, @@ -162,7 +158,7 @@ causalP :: (IsConst a, Vector.Arithmetic a, - Memory.C (Value (State a)) struct, IsSized struct size) => + Memory.C (Value (State a))) => {- (IsConst a, Vector.Arithmetic a, Memory.FirstClass a am, diff --git a/src/Synthesizer/LLVM/Filter/FirstOrder.hs b/src/Synthesizer/LLVM/Filter/FirstOrder.hs --- a/src/Synthesizer/LLVM/Filter/FirstOrder.hs +++ b/src/Synthesizer/LLVM/Filter/FirstOrder.hs @@ -1,11 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.FirstOrder ( Result(Result,lowpass_,highpass_), Parameter, parameter, @@ -21,33 +15,20 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value -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.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (Undefined, undefTuple, ) -import qualified Data.TypeLevel.Num as TypeNum - import qualified LLVM.Core as LLVM -import LLVM.Core - (Value, valueOf, Vector, - IsArithmetic, IsFloating, - IsPrimitive, IsSized, - CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) import Control.Arrow (arr, (&&&), (<<<), ) import Control.Monad (liftM2, foldM, ) -import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field --- import qualified Algebra.Module as Module --- import qualified Algebra.Ring as Ring - import NumericPrelude.Numeric import NumericPrelude.Base @@ -59,16 +40,15 @@ instance Undefined a => Undefined (Parameter a) where undefTuple = Class.undefTuplePointed -instance - (Memory.C a s, IsSized s ss) => - Memory.C (Parameter a) s where +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = Memory.Struct a load = Memory.loadNewtype Parameter store = Memory.storeNewtype (\(Parameter k) -> k) decompose = Memory.decomposeNewtype Parameter compose = Memory.composeNewtype (\(Parameter k) -> k) -instance (Value.Flatten ah al) => - Value.Flatten (Parameter ah) (Parameter al) where +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor @@ -80,15 +60,14 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (Parameter ah) (Parameter al) where +instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where + type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor parameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a) => - Value a -> - CodeGenFunction r (Parameter (Value a)) + (A.Transcendental a, A.RationalConstant a) => + a -> LLVM.CodeGenFunction r (Parameter a) parameter reson = Value.flatten $ FirstOrder.parameter @@ -96,7 +75,7 @@ lowpassModifier, highpassModifier :: - (SoV.PseudoModule a v, SoV.IntegerConstant a) => + (A.PseudoModule a v, A.IntegerConstant a) => Modifier.Simple -- (FirstOrder.State (Value.T v)) (Value.T v) @@ -106,11 +85,8 @@ highpassModifier = FirstOrder.highpassModifier causalP :: - (SoV.IntegerConstant a, SoV.PseudoModule a v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - CausalP.T p - (Parameter (Value a), Value v) (Result (Value v)) + (A.IntegerConstant a, A.PseudoModule a v, Memory.C v) => + CausalP.T p (Parameter a, v) (Result v) {- in contrast to CausalP.fromModifier this allows for sharing between lowpass and highpass channel @@ -123,20 +99,16 @@ <<< (lowpassCausalP &&& arr snd) lowpassCausalP, highpassCausalP :: - (SoV.IntegerConstant a, SoV.PseudoModule a v, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - CausalP.T p - (Parameter (Value a), Value v) (Value v) + (A.IntegerConstant a, A.PseudoModule a v, Memory.C v) => + CausalP.T p (Parameter a, v) v lowpassCausalP = CausalP.fromModifier lowpassModifier highpassCausalP = CausalP.fromModifier highpassModifier lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP :: - (Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos n, -- IsSized (Vector n a) vas, - SoV.IntegerConstant a, IsArithmetic a, IsPrimitive a) => - CausalP.T p - (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) + (Serial.C v, Serial.Element v ~ a, + Memory.C a, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + CausalP.T p (Parameter a, v) v highpassCausalPackedP = arr snd - lowpassCausalPackedP lowpassCausalPackedP = @@ -144,7 +116,7 @@ (arr fst &&& CausalP.mapSimple (\(FirstOrder.Parameter k, x) -> - A.mul x =<< SoV.replicate =<< A.sub (A.fromInteger' 1) k)) + A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k)) {- x = [x0, x1, x2, x3] @@ -164,16 +136,16 @@ CausalP.mapAccumSimple (\(FirstOrder.Parameter k, xk0) y1 -> do y1k <- A.mul k y1 - xk1 <- Vector.modify (valueOf 0) (A.add y1k) xk0 - let size = Vector.sizeInTuple xk0 - kv <- SoV.replicate k + xk1 <- Serial.modify (LLVM.valueOf 0) (A.add y1k) xk0 + let size = Serial.size xk0 + kv <- Serial.upsample k xk2 <- fmap fst $ foldM (\(y,k0) d -> liftM2 (,) (A.add y =<< - Vector.shiftUpMultiZero d =<< + Serial.shiftUpMultiZero d =<< A.mul y k0) (A.mul k0 k0)) (xk1,kv) @@ -185,16 +157,16 @@ (\(y,k0) d -> liftM2 (,) (A.add y =<< - Vector.shiftUpMultiZero d =<< + Serial.shiftUpMultiZero d =<< A.mul y =<< - SoV.replicate k0) + Serial.upsample k0) (A.mul k0 k0)) (xk1,k) (takeWhile (< size) $ iterate (2*) 1) -} - y0 <- Vector.extract (valueOf $ fromIntegral $ size - 1) xk2 + y0 <- Serial.extract (LLVM.valueOf $ fromIntegral $ size - 1) xk2 return (xk2, y0)) - (return (LLVM.value LLVM.zero)) + (return A.zero) {- We can also optimize filtering with time-varying filter parameter. @@ -237,12 +209,10 @@ causalPackedP :: - (SoV.IntegerConstant a, IsArithmetic a, IsPrimitive a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - TypeNum.Pos n) => - CausalP.T p - (Parameter (Value a), Value (Vector n a)) - (Result (Value (Vector n a))) + (Serial.C v, Serial.Element v ~ a, + Memory.C a, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + CausalP.T p (Parameter a, v) (Result v) causalPackedP = CausalP.mapSimple (\(l,x) -> do h <- A.sub x l diff --git a/src/Synthesizer/LLVM/Filter/Moog.hs b/src/Synthesizer/LLVM/Filter/Moog.hs --- a/src/Synthesizer/LLVM/Filter/Moog.hs +++ b/src/Synthesizer/LLVM/Filter/Moog.hs @@ -1,13 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Synthesizer.LLVM.Filter.Moog (Parameter, parameter, causalP, + causalInitP, ) where import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 @@ -18,23 +16,23 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified Synthesizer.LLVM.Parameter as Param import Foreign.Storable (Storable, ) import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class -import LLVM.Extra.Class (Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) -import LLVM.Core - (valueOf, Value, Struct, - IsConst, IsFloating, IsSized, - CodeGenFunction, ) +import qualified LLVM.Core as LLVM +import LLVM.Core (Value, IsConst, IsSized, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Data.TypeLevel.Num as TypeNum -import Data.TypeLevel.Num (d0, d1, ) +import qualified Types.Data.Num as TypeNum +import Types.Data.Num (d0, d1, ) import qualified Control.Arrow as Arrow import qualified Control.Applicative as App @@ -43,9 +41,6 @@ import Control.Arrow ((>>>), (&&&), ) import Control.Applicative (liftA2, ) -import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field --- import qualified Algebra.Module as Module import qualified Algebra.Additive as Additive import NumericPrelude.Numeric @@ -56,59 +51,63 @@ deriving (Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -instance (Phi a, TypeNum.Nat n) => +instance (Phi a, TypeNum.NaturalT n) => Phi (Parameter n a) where phis = Class.phisTraversable addPhis = Class.addPhisFoldable -instance (Undefined a, TypeNum.Nat n) => +instance (Undefined a, TypeNum.NaturalT n) => Undefined (Parameter n a) where undefTuple = Class.undefTuplePointed -instance (Class.Zero a, TypeNum.Nat n) => +instance (Class.Zero a, TypeNum.NaturalT n) => Class.Zero (Parameter n a) where zeroTuple = Class.zeroTuplePointed + +type ParameterStruct a = LLVM.Struct (a, (a, ())) + parameterMemory :: - (Memory.C a s, IsSized s ss, TypeNum.Nat n) => - Memory.Record r (Struct (s, (s, ()))) (Parameter n a) + (Memory.C a, TypeNum.NaturalT n) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter n a) parameterMemory = liftA2 (\f k -> Parameter (Moog.Parameter f k)) (Memory.element (Moog.feedback . getParam) d0) (Memory.element (Moog.lowpassParam . getParam) d1) instance - (Memory.C a s, IsSized s ss, TypeNum.Nat n) => - Memory.C (Parameter n a) (Struct (s, (s, ()))) where + (Memory.C a, TypeNum.NaturalT n) => + Memory.C (Parameter n a) where + type Struct (Parameter n a) = ParameterStruct (Memory.Struct a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory compose = Memory.composeRecord parameterMemory -instance (Value.Flatten ah al, TypeNum.Nat n) => - Value.Flatten (Parameter n ah) (Parameter n al) where +instance (Value.Flatten a, TypeNum.NaturalT n) => Value.Flatten (Parameter n a) where + type Registers (Parameter n a) = Parameter n (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor -instance (Vector.ShuffleMatch m v, TypeNum.Nat n) => - Vector.ShuffleMatch m (Parameter n v) where +instance (Vector.Simple v, TypeNum.NaturalT n) => Vector.Simple (Parameter n v) where + type Element (Parameter n v) = Parameter n (Vector.Element v) + type Size (Parameter n v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable - -instance (Vector.Access m a v, TypeNum.Nat n) => - Vector.Access m (Parameter n a) (Parameter n v) where - insert = Vector.insertTraversable extract = Vector.extractTraversable +instance (Vector.C v, TypeNum.NaturalT n) => Vector.C (Parameter n v) where + insert = Vector.insertTraversable + parameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a, TypeNum.Nat n) => - n -> Value a -> Value a -> - CodeGenFunction r (Parameter n (Value a)) + (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) => + n -> a -> a -> + CodeGenFunction r (Parameter n a) parameter order reson freq = Value.flatten $ - Parameter $ Moog.parameter (TypeNum.toInt order) + Parameter $ Moog.parameter (TypeNum.fromIntegerT order) (Pole (Value.constantValue reson) (Value.constantValue freq)) {- @@ -128,21 +127,19 @@ -} merge :: - (SoV.PseudoModule a v, SoV.IntegerConstant a, - Class.MakeValueTuple v (Value v), - Class.MakeValueTuple a (Value a)) => - (Parameter n (Value a), Value v) -> Value v -> - CodeGenFunction r (FirstOrder.Parameter (Value a), Value v) + (A.PseudoModule a v, A.IntegerConstant a) => + (Parameter n a, v) -> v -> + CodeGenFunction r (FirstOrder.Parameter a, v) merge (Parameter (Moog.Parameter f k), x) y0 = - let c :: (Class.MakeValueTuple a (Value a)) => Value a -> Value.T a + let c :: a -> Value.T a c = Value.constantValue in Value.flatten (fmap c k, c x - c f *> c y0) amplify :: - (SoV.PseudoModule a v, SoV.IntegerConstant a) => - Parameter n (Value a) -> - Value v -> - CodeGenFunction r (Value v) + (A.PseudoModule a v, A.IntegerConstant a) => + Parameter n a -> + v -> + CodeGenFunction r v amplify (Parameter (Moog.Parameter f _k)) y1 = Value.decons $ (1 + Value.constantValue f) *> Value.constantValue y1 @@ -151,36 +148,45 @@ (SoV.PseudoModule a v, SoV.IntegerConstant a, IsConst v, Additive.C v, Storable v, - Class.MakeValueTuple v (Value v), - Class.MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeNum.Nat n) => - CausalP.T p - (Parameter n (Value a), Value v) (Value v) + MakeValueTuple v, ValueTuple v ~ (Value v), + MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + Memory.FirstClass v, Memory.Stored v ~ vm, IsSized v, IsSized vm, + TypeNum.NaturalT n) => + CausalP.T p (Parameter n (Value a), Value v) (Value v) causalP = - causalPSize undefined + let withZero :: + (Additive.C v) => + (Param.T p v -> + CausalP.T p (Parameter n (Value a), Value v) (Value v)) -> + CausalP.T p (Parameter n (Value a), Value v) (Value v) + withZero proc = proc zero + in withZero causalInitP -causalPSize :: - (SoV.PseudoModule a v, SoV.IntegerConstant a, - IsConst v, Additive.C v, - Storable v, - Class.MakeValueTuple v (Value v), - Class.MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - TypeNum.Nat n) => - n -> - CausalP.T p - (Parameter n (Value a), Value v) (Value v) -causalPSize n = - let order = TypeNum.toInt n - feedZero = zero - selectOutput = snd `asTypeOf` const (valueOf feedZero) + +causalInitP :: + (A.PseudoModule a v, A.IntegerConstant a, + Storable vh, Class.MakeValueTuple vh, v ~ Class.ValueTuple vh, + Memory.C v, + TypeNum.NaturalT n) => + Param.T p vh -> CausalP.T p (Parameter n a, v) v +causalInitP = + causalInitPSize undefined + +causalInitPSize :: + (A.PseudoModule a v, A.IntegerConstant a, + Storable vh, Class.MakeValueTuple vh, v ~ Class.ValueTuple vh, + Memory.C v, + TypeNum.NaturalT n) => + n -> Param.T p vh -> CausalP.T p (Parameter n a, v) v +causalInitPSize n initial = + let order = TypeNum.fromIntegerT n + selectOutput :: Param.T p vh -> (b, Class.ValueTuple vh) -> Class.ValueTuple vh + selectOutput _ = snd in Arrow.arr fst &&& CausalP.feedbackControlled - (return feedZero) + initial (CausalP.zipWithSimple merge >>> CausalP.replicateControlled order Filt1.lowpassCausalP) - (Arrow.arr selectOutput) + (Arrow.arr (selectOutput initial)) >>> CausalP.zipWithSimple amplify 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 @@ -1,11 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.SecondOrder ( - Parameter, bandpassParameter, + Parameter(Parameter), + Filt2.c0, Filt2.c1, Filt2.c2, Filt2.d1, Filt2.d2, + bandpassParameter, ParameterStruct, composeParameter, decomposeParameter, -- for cascade causalP, causalPackedP, ) where @@ -16,38 +17,27 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value 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.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Monad as M import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM -import LLVM.Core - (Value, valueOf, Struct, - IsConst, IsArithmetic, IsFloating, - Vector, IsPrimitive, IsSized, - CodeGenFunction, ) +import LLVM.Core (CodeGenFunction, valueOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (d0, d1, d2, d3, d4, ) -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum +import Types.Data.Num (d0, d1, d2, d3, d4, ) import Control.Arrow (arr, (<<<), (&&&), ) import Control.Monad (liftM2, foldM, ) import Control.Applicative (pure, (<*>), ) import Synthesizer.ApplicativeUtility (liftA4, liftA5, ) -import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field --- import qualified Algebra.Module as Module --- import qualified Algebra.Ring as Ring - import NumericPrelude.Numeric import NumericPrelude.Base @@ -67,16 +57,16 @@ tupleDesc = Class.tupleDescFoldable -} -instance Class.MakeValueTuple h l => - Class.MakeValueTuple (Parameter h) (Parameter l) where +instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where + type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -type ParameterStruct a = Struct (a, (a, (a, (a, (a, ()))))) +type ParameterStruct a = LLVM.Struct (a, (a, (a, (a, (a, ()))))) parameterMemory :: - (Memory.C a s, IsSized s ss) => - Memory.Record r (ParameterStruct s) (Parameter a) + (Memory.C a) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) parameterMemory = liftA5 Parameter (Memory.element Filt2.c0 d0) @@ -86,8 +76,8 @@ (Memory.element Filt2.d2 d4) decomposeParameter :: - Value (ParameterStruct a) -> - CodeGenFunction r (Filt2.Parameter (Value a)) + LLVM.Value (ParameterStruct a) -> + CodeGenFunction r (Filt2.Parameter (LLVM.Value a)) decomposeParameter param = pure Filt2.Parameter <*> LLVM.extractvalue param TypeNum.d0 @@ -97,9 +87,9 @@ <*> LLVM.extractvalue param TypeNum.d4 composeParameter :: - (IsSized a size) => - Filt2.Parameter (Value a) -> - CodeGenFunction r (Value (ParameterStruct a)) + (LLVM.IsSized a) => + Filt2.Parameter (LLVM.Value a) -> + CodeGenFunction r (LLVM.Value (ParameterStruct a)) composeParameter (Filt2.Parameter c0_ c1_ c2_ d1_ d2_) = (\param -> LLVM.insertvalue param c0_ TypeNum.d0) =<< (\param -> LLVM.insertvalue param c1_ TypeNum.d1) =<< @@ -108,17 +98,16 @@ (\param -> LLVM.insertvalue param d2_ TypeNum.d4) =<< return (LLVM.value LLVM.undef) -instance - (Memory.C a s, IsSized s ss) => - Memory.C (Parameter a) (Struct (s, (s, (s, (s, (s, ())))))) where +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Struct a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory compose = Memory.composeRecord parameterMemory -instance (Value.Flatten ah al) => - Value.Flatten (Parameter ah) (Parameter al) where +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor @@ -131,9 +120,12 @@ instance Undefined a => Undefined (Filt2.State a) where undefTuple = Class.undefTuplePointed + +type StateStruct a = LLVM.Struct (a, (a, (a, (a, (a, ()))))) + stateMemory :: - (Memory.C a s, IsSized s ss) => - Memory.Record r (Struct (s, (s, (s, (s, (s, ())))))) (Filt2.State a) + (Memory.C a) => + Memory.Record r (StateStruct (Memory.Struct a)) (Filt2.State a) stateMemory = liftA4 Filt2.State (Memory.element Filt2.u1 d0) @@ -142,41 +134,39 @@ (Memory.element Filt2.y2 d3) -instance - (Memory.C a s, IsSized s ss) => - Memory.C (Filt2.State a) (Struct (s, (s, (s, (s, (s, ())))))) where +instance (Memory.C a) => Memory.C (Filt2.State a) where + type Struct (Filt2.State a) = StateStruct (Memory.Struct a) load = Memory.loadRecord stateMemory store = Memory.storeRecord stateMemory decompose = Memory.decomposeRecord stateMemory compose = Memory.composeRecord stateMemory -instance (Value.Flatten ah al) => - Value.Flatten (Filt2.State ah) (Filt2.State al) where +instance (Value.Flatten a) => Value.Flatten (Filt2.State a) where + type Registers (Filt2.State a) = Filt2.State (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor {-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} bandpassParameter :: - (Trans.C a, IsFloating a, IsConst a) => - Value a -> - Value a -> - CodeGenFunction r (Parameter (Value a)) + (A.Transcendental a, A.RationalConstant a) => + a -> a -> + CodeGenFunction r (Parameter a) bandpassParameter reson cutoff = do - rreson <- A.fdiv (valueOf 1) reson - k <- A.sub (valueOf 1) rreson - k2 <- LLVM.neg =<< A.mul k k + rreson <- A.fdiv A.one reson + k <- A.sub A.one rreson + k2 <- A.neg =<< A.mul k k kcos <- - A.mul (valueOf 2) =<< A.mul k =<< + A.mul (A.fromInteger' 2) =<< A.mul k =<< A.cos =<< A.mul cutoff =<< Value.decons Value.twoPi return $ Filt2.Parameter - rreson (valueOf zero) (valueOf zero) + rreson A.zero A.zero kcos k2 modifier :: - (SoV.PseudoModule a v, SoV.IntegerConstant a) => + (A.PseudoModule a v, A.IntegerConstant a) => Modifier.Simple (Filt2.State (Value.T v)) (Parameter (Value.T a)) @@ -185,11 +175,8 @@ Filt2.modifier causalP :: - (SoV.PseudoModule a v, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - CausalP.T p - (Parameter (Value a), Value v) (Value v) + (A.PseudoModule a v, A.IntegerConstant a, Memory.C v) => + CausalP.T p (Parameter a, v) v causalP = CausalP.fromModifier modifier @@ -199,45 +186,31 @@ -} causalPackedP, causalRecursivePackedP :: - (IsArithmetic a, SoV.IntegerConstant a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n asize vasize, TypeNum.Pos vasize, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => --- TypeNum.Pos n, IsPrimitive a, IsSized (Vector n a) as) => - CausalP.T p - (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) + (Serial.C v, Serial.Element v ~ a, + Memory.C v, Memory.C a, A.IntegerConstant v, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + CausalP.T p (Parameter a, v) v causalPackedP = causalRecursivePackedP <<< (arr fst &&& causalNonRecursivePackedP) _causalRecursivePackedPAlt, causalNonRecursivePackedP :: - (IsArithmetic a, SoV.IntegerConstant a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n asize vasize, TypeNum.Pos vasize, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => - CausalP.T p - (Parameter (Value a), Value (Vector n a)) (Value (Vector n a)) + (Serial.C v, Serial.Element v ~ a, + Memory.C a, A.IntegerConstant v, A.IntegerConstant a, + A.PseudoRing v, A.PseudoRing a) => + CausalP.T p (Parameter a, v) v causalNonRecursivePackedP = CausalP.mapAccumSimple (\(p, v0) (x1,x2) -> do - (_,v1) <- Vector.shiftUp x1 v0 - (_,v2) <- Vector.shiftUp x2 v1 - w0 <- A.mul v0 =<< SoV.replicate (Filt2.c0 p) - w1 <- A.mul v1 =<< SoV.replicate (Filt2.c1 p) - w2 <- A.mul v2 =<< SoV.replicate (Filt2.c2 p) + (u1n,v1) <- Serial.shiftUp x1 v0 + (u2n,v2) <- Serial.shiftUp x2 v1 + w0 <- A.mul v0 =<< Serial.upsample (Filt2.c0 p) + w1 <- A.mul v1 =<< Serial.upsample (Filt2.c1 p) + w2 <- A.mul v2 =<< Serial.upsample (Filt2.c2 p) y <- A.add w0 =<< A.add w1 w2 - let size = fromIntegral $ Vector.sizeInTuple v0 - u0 <- Vector.extract (valueOf $ size - 1) v0 - u1 <- Vector.extract (valueOf $ size - 2) v0 - return (y, (u0,u1))) - (return (LLVM.value LLVM.zero, LLVM.value LLVM.zero)) + return (y, (u1n,u2n))) + (return (A.zero, A.zero)) {- A filter of second order can be considered @@ -273,18 +246,18 @@ causalRecursivePackedP = CausalP.mapAccumSimple (\(p, x0) y1v -> do - let size = Vector.sizeInTuple x0 + let size = Serial.size x0 - d1v <- SoV.replicate (Filt2.d1 p) - d2v <- SoV.replicate (Filt2.d2 p) - d2vn <- LLVM.neg d2v + d1v <- Serial.upsample (Filt2.d1 p) + d2v <- Serial.upsample (Filt2.d2 p) + d2vn <- A.neg d2v - y1 <- Vector.extract (valueOf $ fromIntegral size - 1) y1v + y1 <- Serial.extract (valueOf $ fromIntegral size - 1) y1v xk1 <- - Vector.modify (valueOf 0) + Serial.modify (valueOf 0) (\u0 -> A.add u0 =<< A.mul (Filt2.d1 p) y1) =<< A.add x0 =<< A.mul d2v =<< - Vector.shiftDownMultiZero (size - 2) y1v + Serial.shiftDownMultiZero (size - 2) y1v -- let xk2 = xk1 xk2 <- @@ -301,8 +274,8 @@ and the first operand could be merged with the second operand of the previous step. -} - (Vector.shiftUpMultiZero d =<< A.mul y a) - (Vector.shiftUpMultiZero (2*d) =<< A.mul y b)) $ + (Serial.shiftUpMultiZero d =<< A.mul y a) + (Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $ liftM2 (,) (M.liftR2 A.sub (A.mul a a) @@ -312,25 +285,25 @@ (takeWhile (< size) $ iterate (2*) 1) return (xk2, xk2)) - (return (LLVM.value LLVM.zero)) + (return A.zero) _causalRecursivePackedPAlt = CausalP.mapAccumSimple (\(p, x0) (x1,x2) -> do - let size = Vector.sizeInTuple x0 + let size = Serial.size x0 -- let xk1 = x0 xk1 <- - Vector.modify (valueOf 0) + Serial.modify (valueOf 0) (\u0 -> A.add u0 =<< M.liftR2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<< - Vector.modify (valueOf 1) + Serial.modify (valueOf 1) (\u1 -> A.add u1 =<< A.mul (Filt2.d2 p) x1) x0 -- let xk2 = xk1 - d1v <- SoV.replicate (Filt2.d1 p) - d2v <- SoV.replicate =<< LLVM.neg (Filt2.d2 p) + d1v <- Serial.upsample (Filt2.d1 p) + d2v <- Serial.upsample =<< A.neg (Filt2.d2 p) xk2 <- fmap fst $ foldM @@ -338,8 +311,8 @@ liftM2 (,) (A.add y =<< M.liftR2 A.add - (Vector.shiftUpMultiZero d =<< A.mul y a) - (Vector.shiftUpMultiZero (2*d) =<< A.mul y b)) $ + (Serial.shiftUpMultiZero d =<< A.mul y a) + (Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $ liftM2 (,) (M.liftR2 A.sub (A.mul a a) @@ -348,10 +321,10 @@ (xk1,(d1v,d2v)) (takeWhile (< size) $ iterate (2*) 1) - y0 <- Vector.extract (valueOf $ fromIntegral size - 1) xk2 - y1 <- Vector.extract (valueOf $ fromIntegral size - 2) xk2 + y0 <- Serial.extract (valueOf $ fromIntegral size - 1) xk2 + y1 <- Serial.extract (valueOf $ fromIntegral size - 2) xk2 return (xk2, (y0,y1))) - (return (LLVM.value LLVM.zero, LLVM.value LLVM.zero)) + (return (A.zero, A.zero)) {- A filter of second order can also be represented 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 @@ -1,9 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} module Synthesizer.LLVM.Filter.SecondOrderCascade where import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 @@ -11,6 +10,9 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Memory as Memory @@ -19,12 +21,13 @@ import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.Core - (Value, valueOf, Vector, - IsArithmetic, IsPrimitive, IsSized, + (Value, valueOf, + IsArithmetic, IsSized, CodeGenFunction, ) -import qualified Data.TypeLevel.Num as TypeNum -import qualified Data.TypeLevel.Num.Sets as TypeSet +import qualified Types.Data.Bool as TypeBool +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) import Data.Word (Word32, ) @@ -40,10 +43,10 @@ import NumericPrelude.Base -type Parameter n a = LLVM.Array n (Filt2.ParameterStruct a) +type ParameterStruct n a = LLVM.Array n (Filt2.ParameterStruct a) newtype ParameterValue n a = - ParameterValue {parameterValue :: Value (Parameter n a)} + ParameterValue {parameterValue :: Value (ParameterStruct n a)} {- Automatic deriving is not allowed even with GeneralizedNewtypeDeriving because of IsSized constraint @@ -53,7 +56,7 @@ Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -} -instance (TypeNum.Nat n, IsSized a s) => +instance (TypeNum.NaturalT n, IsSized a) => Phi (ParameterValue n a) where phis bb (ParameterValue r) = fmap ParameterValue $ phis bb r @@ -62,17 +65,19 @@ (ParameterValue r') = addPhis bb r r' -instance (TypeNum.Nat n, IsSized a s) => +instance (TypeNum.NaturalT n, IsSized a) => Class.Undefined (ParameterValue n a) where undefTuple = ParameterValue Class.undefTuple -instance (TypeNum.Nat n, IsSized a s) => +instance (TypeNum.NaturalT n, IsSized a) => Class.Zero (ParameterValue n a) where zeroTuple = ParameterValue Class.zeroTuple -instance - (TypeNum.Nat n, Memory.FirstClass a am, IsSized a s, IsSized am ams) => - Memory.C (ParameterValue n a) (Parameter n am) where +instance (TypeNum.IntegerT n, TypeNum.IsNatural n ~ TypeBool.True, + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + TypeNum.PositiveT (n :*: LLVM.UnknownSize)) => + Memory.C (ParameterValue n a) where + type Struct (ParameterValue n a) = ParameterStruct n (Memory.Stored a) load = Memory.loadNewtype ParameterValue store = Memory.storeNewtype (\(ParameterValue k) -> k) decompose = Memory.decomposeNewtype ParameterValue @@ -92,12 +97,12 @@ fixSize _n = id causalP :: - (SoV.PseudoModule a v, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms, - IsArithmetic a, TypeSet.Nat n, - TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) => - CausalP.T p (ParameterValue n a, Value v) (Value v) + (A.PseudoModule (LLVM.Value a) v, + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + Memory.C v, + IsArithmetic a, SoV.IntegerConstant a, TypeNum.NaturalT n, + TypeNum.PositiveT (n :*: LLVM.UnknownSize)) => + CausalP.T p (ParameterValue n a, v) v causalP = withSize $ \n -> foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $ @@ -106,20 +111,19 @@ Filt2.causalP <<< Arrow.first (CausalP.mapSimple (\ps -> getStageParameter ps k))) - (take (TypeNum.toInt n) [0..]) + (take (TypeNum.fromIntegerT n) [0..]) causalPackedP :: - (IsArithmetic a, SoV.IntegerConstant a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a asize, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul d asize vasize, TypeNum.Pos vasize, - TypeNum.Mul d amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos d, - TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize, - TypeSet.Nat n) => - CausalP.T p - (ParameterValue n a, Value (Vector d a)) (Value (Vector d a)) + (A.PseudoModule (LLVM.Value a) 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.PositiveT (n :*: LLVM.UnknownSize), + TypeNum.NaturalT n) => + CausalP.T p (ParameterValue n a, v) v causalPackedP = withSize $ \n -> foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $ @@ -128,11 +132,11 @@ Filt2.causalPackedP <<< Arrow.first (CausalP.mapSimple (\ps -> getStageParameter ps k))) - (take (TypeNum.toInt n) [0..]) + (take (TypeNum.fromIntegerT n) [0..]) getStageParameter, getStageParameterMalloc, getStageParameterAlloca :: - (LLVM.IsFirstClass a, IsSized a as, SoV.IntegerConstant a, - TypeSet.Nat n, TypeNum.Mul n LLVM.UnknownSize s, TypeSet.Pos s) => + (LLVM.IsFirstClass a, IsSized a, SoV.IntegerConstant a, + TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) => ParameterValue n a -> Word32 -> CodeGenFunction r (Filt2Core.Parameter (Value a)) diff --git a/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs b/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs --- a/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs +++ b/src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs @@ -1,9 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} module Synthesizer.LLVM.Filter.SecondOrderPacked ( Parameter, bandpassParameter, State, causalP, ) where @@ -12,20 +11,22 @@ import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -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.Memory as Memory import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, Struct, - IsFirstClass, IsConst, IsFloating, + IsFirstClass, IsFloating, Vector, IsPrimitive, IsSized, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (D4, d0, d1, ) +import qualified Types.Data.Num as TypeNum +import Types.Data.Num (D4, d0, d1, (:*:), ) import Control.Applicative (liftA2, ) @@ -64,9 +65,9 @@ type ParameterStruct a = Struct (a, (Vector D4 a, ())) parameterMemory :: - (Memory.FirstClass a am, - IsSized a s, IsPrimitive a, - IsSized am ams, IsPrimitive am) => + (Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + IsPrimitive a, IsPrimitive am, + TypeNum.PositiveT (D4 :*: LLVM.SizeOf am)) => Memory.Record r (ParameterStruct am) (Parameter a) parameterMemory = liftA2 Parameter @@ -74,11 +75,11 @@ (Memory.element (\(Parameter _ cd) -> cd) d1) instance - (Memory.FirstClass a am, - IsSized a s, IsPrimitive a, - IsSized am ms, IsPrimitive am, - IsSized (ParameterStruct am) sms) => - Memory.C (Parameter a) (ParameterStruct am) where + (Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + IsPrimitive a, IsPrimitive am, + TypeNum.PositiveT (D4 :*: LLVM.SizeOf am)) => + Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Stored a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory @@ -90,7 +91,7 @@ {-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-} bandpassParameter :: - (Trans.C a, IsFloating a, IsConst a, IsPrimitive a) => + (Trans.C a, IsFloating a, SoV.TranscendentalConstant a, IsPrimitive a) => Value a -> Value a -> CodeGenFunction r (Parameter a) @@ -116,7 +117,7 @@ causalP :: (Vector.Arithmetic a, - Memory.C (Value (State a)) struct, IsSized struct size) => + Memory.C (Value (State a))) => {- (Vector.Arithmetic a, IsPrimitive am, Memory.FirstClass a am, 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 @@ -1,10 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Universal ( Result(Result, lowpass, highpass, bandpass, bandlimit), @@ -19,28 +13,24 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (Undefined, undefTuple, ) -import LLVM.Core - (Value, Struct, IsFloating, IsSized, CodeGenFunction, ) +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (d0, d1, d2, d3, d4, d5, ) +import Types.Data.Num (d0, d1, d2, d3, d4, d5, ) import Synthesizer.ApplicativeUtility (liftA6, ) -import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field --- import qualified Algebra.Module as Module --- import qualified Algebra.Ring as Ring - instance (Phi a) => Phi (Parameter a) where phis = Class.phisTraversable addPhis = Class.addPhisFoldable @@ -48,9 +38,12 @@ instance Undefined a => Undefined (Parameter a) where undefTuple = Class.undefTuplePointed + +type ParameterStruct a = LLVM.Struct (a, (a, (a, (a, (a, (a, ())))))) + parameterMemory :: - (Memory.C a s, IsSized s ss) => - Memory.Record r (Struct (s, (s, (s, (s, (s, (s, ()))))))) (Parameter a) + (Memory.C a) => + Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) parameterMemory = liftA6 Parameter (Memory.element Universal.k1 d0) @@ -61,9 +54,8 @@ (Memory.element Universal.ampLimit d5) -instance - (Memory.C a s, IsSized s ss) => - Memory.C (Parameter a) (Struct (s, (s, (s, (s, (s, (s, ()))))))) where +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = ParameterStruct (Memory.Struct a) load = Memory.loadRecord parameterMemory store = Memory.storeRecord parameterMemory decompose = Memory.decomposeRecord parameterMemory @@ -77,12 +69,12 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (Result ah) (Result al) where +instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Result a) where + type ValueTuple (Result a) = Result (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -instance (Value.Flatten ah al) => - Value.Flatten (Result ah) (Result al) where +instance (Value.Flatten a) => Value.Flatten (Result a) where + type Registers (Result a) = Result (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor @@ -95,26 +87,26 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (Parameter ah) (Parameter al) where +instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where + type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -instance (Value.Flatten ah al) => - Value.Flatten (Parameter ah) (Parameter al) where +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor -instance (Vector.ShuffleMatch d v) => - Vector.ShuffleMatch d (Parameter v) where +instance (Vector.Simple v) => Vector.Simple (Parameter v) where + type Element (Parameter v) = Parameter (Vector.Element v) + type Size (Parameter v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable - -instance (Vector.Access d a v) => - Vector.Access d (Parameter a) (Parameter v) where - insert = Vector.insertTraversable extract = Vector.extractTraversable +instance (Vector.C v) => Vector.C (Parameter v) where + insert = Vector.insertTraversable + instance (Phi a) => Phi (Result a) where phis = Class.phisTraversable addPhis = Class.addPhisFoldable @@ -122,20 +114,36 @@ instance Undefined a => Undefined (Result a) where undefTuple = Class.undefTuplePointed -instance (Vector.ShuffleMatch d v) => - Vector.ShuffleMatch d (Result v) where +instance (Vector.Simple v) => Vector.Simple (Result v) where + type Element (Result v) = Result (Vector.Element v) + type Size (Result v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable -instance (Vector.Access d a v) => - Vector.Access d (Result a) (Result v) where +instance (Vector.C v) => Vector.C (Result v) where insert = Vector.insertTraversable - extract = Vector.extractTraversable +instance (Serial.Sized v) => Serial.Sized (Result v) where + type Size (Result v) = Serial.Size v +instance (Serial.Read v) => Serial.Read (Result v) where + type Element (Result v) = Result (Serial.Element v) + type ReadIt (Result v) = Result (Serial.ReadIt v) + extract = Serial.extractTraversable + readStart = Serial.readStartTraversable + readNext = Serial.readNextTraversable + +instance (Serial.C v) => Serial.C (Result v) where + type WriteIt (Result v) = Result (Serial.WriteIt v) + insert = Serial.insertTraversable + writeStart = Serial.writeStartTraversable + writeNext = Serial.writeNextTraversable + writeStop = Serial.writeStopTraversable + + parameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a) => - Value a -> Value a -> - CodeGenFunction r (Parameter (Value a)) + (A.Transcendental a, A.RationalConstant a) => + a -> a -> CodeGenFunction r (Parameter a) parameter reson freq = Value.flatten $ Universal.parameter @@ -144,7 +152,7 @@ modifier :: - (SoV.PseudoModule a v, SoV.IntegerConstant a) => + (A.PseudoModule a v, A.IntegerConstant a) => Modifier.Simple (Universal.State (Value.T v)) (Parameter (Value.T a)) @@ -153,11 +161,8 @@ Universal.modifier causalP :: - (SoV.PseudoModule a v, SoV.IntegerConstant a, - Memory.FirstClass a am, IsSized a as, IsSized am ams, - Memory.FirstClass v vm, IsSized v vs, IsSized vm vms) => - CausalP.T p - (Parameter (Value a), Value v) (Result (Value v)) + (A.PseudoModule a v, A.IntegerConstant a, Memory.C v) => + CausalP.T p (Parameter a, v) (Result v) causalP = CausalP.fromModifier modifier diff --git a/src/Synthesizer/LLVM/Frame.hs b/src/Synthesizer/LLVM/Frame.hs --- a/src/Synthesizer/LLVM/Frame.hs +++ b/src/Synthesizer/LLVM/Frame.hs @@ -1,14 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Frame where import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector -import qualified LLVM.Extra.Class as Class -import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM @@ -16,14 +13,13 @@ (CodeGenFunction, Value, Vector, IsPrimitive, IsArithmetic, ) -import qualified Data.TypeLevel.Num as TypeNum -import Data.TypeLevel.Num (D2, D4, ) +import qualified Types.Data.Num as TypeNum +import Types.Data.Num (D2, D4, ) import Foreign.Storable.Tuple () -import Data.Word (Word32, ) - import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold import NumericPrelude.Numeric hiding (zero, one, div, signum, ) import NumericPrelude.Base @@ -56,7 +52,7 @@ Stereo.T (Value a) -> CodeGenFunction r (Value (Vector D2 a)) vectorFromStereo = - Vector.assemble . listFromStereo + Vector.assemble . Fold.toList quadroFromVector :: @@ -73,11 +69,7 @@ CodeGenFunction r (Value (Vector D4 a)) vectorFromQuadro = Vector.assemble . - concatMap listFromStereo . listFromStereo - -listFromStereo :: Stereo.T a -> [a] -listFromStereo s = - [Stereo.left s, Stereo.right s] + concatMap Fold.toList . Fold.toList mix :: @@ -99,13 +91,13 @@ stereoFromVector =<< A.add xv yv mixVector :: - (Vector.Arithmetic a, TypeNum.Pos n) => + (Vector.Arithmetic a, TypeNum.PositiveT n) => Value (Vector n a) -> CodeGenFunction r (Value a) mixVector = Vector.sum mixVectorToStereo :: - (Vector.Arithmetic a, TypeNum.Pos n) => + (Vector.Arithmetic a, TypeNum.PositiveT n) => Value (Vector n a) -> CodeGenFunction r (Stereo.T (Value a)) mixVectorToStereo = @@ -117,7 +109,7 @@ and components with odd index to the right channel. -} mixInterleavedVectorToStereo :: - (Vector.Arithmetic a, TypeNum.Pos n) => + (Vector.Arithmetic a, TypeNum.PositiveT n) => Value (Vector n a) -> CodeGenFunction r (Stereo.T (Value a)) mixInterleavedVectorToStereo = @@ -135,22 +127,3 @@ a -> Stereo.T a -> CodeGenFunction r (Stereo.T a) amplifyStereo x = Trav.mapM (A.mul x) - - -subsampleVector :: - (Vector.Access n a v) => - v -> CodeGenFunction r a -subsampleVector = - Vector.extract (LLVM.value LLVM.zero :: Value Word32) - - -signum :: - (SoV.IntegerConstant a, - LLVM.IsFirstClass a, - LLVM.CmpRet a Bool) => - Value a -> CodeGenFunction r (Value a) -signum x = do - negative <- A.cmp LLVM.CmpLT x Class.zeroTuple - positive <- A.cmp LLVM.CmpGT x Class.zeroTuple - C.select negative (A.fromInteger' (-1)) - =<< C.select positive (A.fromInteger' 1) (A.fromInteger' 0) diff --git a/src/Synthesizer/LLVM/Frame/SerialVector.hs b/src/Synthesizer/LLVM/Frame/SerialVector.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Frame/SerialVector.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | +A special vector type that represents a time-sequence of samples. +This way we can distinguish safely between LLVM vectors +used for parallel signals and pipelines and +those used for chunky processing of scalar signals. +For the chunky processing this data type allows us +to derive the factor from the type +that time constants have to be multiplied with. +-} +module Synthesizer.LLVM.Frame.SerialVector ( + T(Cons), + Plain, Value, + plain, value, constant, + + Read, Element, ReadIt, extract, readStart, readNext, + C, WriteIt, insert, writeStart, writeNext, writeStop, + Zero, writeZero, + Iterator(Iterator), ReadIterator, WriteIterator, ReadMode, WriteMode, + + Sized, Size, size, sizeOfIterator, + + insertTraversable, extractTraversable, + readStartTraversable, readNextTraversable, + writeStartTraversable, writeNextTraversable, writeStopTraversable, + + extractAll, assemble, modify, + upsample, subsample, + cumulate, iterate, reverse, + shiftUp, shiftUpMultiZero, shiftDownMultiZero, + replicate, replicateOf, fromList, + mapV, zipV, + ) where + +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F + +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Core as LLVM +import LLVM.Extra.Class + (MakeValueTuple, valueTupleOf, ) +import LLVM.Util.Loop (Phi, ) + +import qualified Types.Data.Num as TypeNum + +import qualified Foreign.Storable as St +import Data.Word (Word32, ) + +import Control.Monad (liftM2, liftM3, foldM, replicateM, (<=<), ) +import Control.Applicative (liftA2, ) +import qualified Control.Monad.Trans.State as MS +import qualified Control.Applicative as App +import qualified Data.Traversable as Trav + +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Tuple.HT (mapSnd, fst3, snd3, thd3, ) + +import Prelude hiding (Read, replicate, reverse, iterate, ) + + +{- +This datatype can be used for both Haskell vector and LLVM.Value Vector. +It should not contain tuples of vectors, +since the interpretation is: +"Everything inside Cons will be virtually concatenated." + +We tried to use distinct types (T n a) and (Value n a) +for Haskell and LLVM objects, respectively, +but then GHC-6.12.3 to GHC-7.4.1 could not perform the GeneralizedNewtypeDeriving, +because it was not able to add a (IsPositive n ~ True) constraint +to the instances. + +The disadvantage of this approach is, +that we cannot have a type that contains both parallel and serial data. +-} +newtype T v = Cons v + deriving ( + Eq, St.Storable, + Class.Zero, Class.Undefined, Phi, + A.Additive, A.PseudoRing, A.Field, A.Real, A.Fraction, + A.Algebraic, A.Transcendental, + A.IntegerConstant, A.RationalConstant, Num) +-- SoV.IntegerConstant, SoV.RationalConstant, SoV.TranscendentalConstant) + +instance (A.PseudoModule a v) => A.PseudoModule a (T v) where + scale a (Cons v) = fmap Cons $ A.scale a v + +type instance F.Arguments f (T v) = f (T v) +instance F.MakeArguments (T v) where + makeArgs = id + + +type Plain n a = T (LLVM.Vector n a) +type Value n a = T (LLVM.Value (LLVM.Vector n a)) + + +plain :: LLVM.Vector n a -> Plain n a +plain = Cons + +value :: LLVM.Value (LLVM.Vector n a) -> Value n a +value = Cons + + +replicate :: (TypeNum.PositiveT n) => a -> Plain n a +replicate x = Cons $ LLVM.vector [x] + +replicateOf :: (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsConst a) => a -> Value n a +replicateOf x = Cons $ LLVM.valueOf $ LLVM.vector [x] + +fromList :: (TypeNum.PositiveT n) => [a] -> Plain n a +fromList = Cons . LLVM.vector + +constant :: (TypeNum.PositiveT n) => a -> T (Vector.Constant n a) +constant = Cons . Vector.constant + + +newtype Iterator mode it v = Iterator {unIterator :: it} + deriving (Class.Undefined, Phi) + +type ReadIterator = Iterator ReadMode +type WriteIterator = Iterator WriteMode + +data ReadMode +data WriteMode + + +instance (Memory.C it) => Memory.C (Iterator mode it v) where + type Struct (Iterator mode it v) = Memory.Struct it + load = Memory.loadNewtype Iterator + store = Memory.storeNewtype (\(Iterator v) -> v) + decompose = Memory.decomposeNewtype Iterator + compose = Memory.composeNewtype (\(Iterator v) -> v) + + +fmapIt :: + (ita -> itb) -> (va -> vb) -> + Iterator mode ita va -> Iterator mode itb vb +fmapIt f _ (Iterator a) = Iterator (f a) + + +combineIt2 :: Iterator mode xa va -> Iterator mode xb vb -> Iterator mode (xa,xb) (va,vb) +combineIt2 (Iterator va) (Iterator vb) = Iterator (va,vb) + +combineIt3 :: Iterator mode xa va -> Iterator mode xb vb -> Iterator mode xc vc -> Iterator mode (xa,xb,xc) (va,vb,vc) +combineIt3 (Iterator va) (Iterator vb) (Iterator vc) = Iterator (va,vb,vc) + +combineItFunctor :: + (Functor f) => + f (Iterator mode x v) -> Iterator mode (f x) (f v) +combineItFunctor = + Iterator . fmap unIterator + +sequenceItFunctor :: + (Functor f) => + Iterator mode (f it) (f v) -> + f (Iterator mode it v) +sequenceItFunctor = + fmap Iterator . unIterator + + +class + (TypeNum.PositiveT (Size v), Sized v, + Phi (ReadIt v), Class.Undefined (ReadIt v), + Phi v, Class.Undefined v) => + Read v where + + type Element v :: * + type ReadIt v :: * + + extract :: LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r (Element v) + + extractAll :: v -> LLVM.CodeGenFunction r [Element v] + extractAll x = + mapM + (flip extract x . LLVM.valueOf) + (take (size x) [0..]) + + readStart :: v -> LLVM.CodeGenFunction r (ReadIterator (ReadIt v) v) + readNext :: + ReadIterator (ReadIt v) v -> + LLVM.CodeGenFunction r (Element v, ReadIterator (ReadIt v) v) + +class (Read v, Phi (WriteIt v), Class.Undefined (WriteIt v)) => C v where + type WriteIt v :: * + + insert :: LLVM.Value Word32 -> Element v -> v -> LLVM.CodeGenFunction r v + + assemble :: [Element v] -> LLVM.CodeGenFunction r v + assemble = + foldM (\v (k,x) -> insert (LLVM.valueOf k) x v) Class.undefTuple . + zip [0..] + + writeStart :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v) + writeNext :: + Element v -> WriteIterator (WriteIt v) v -> + LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v) + writeStop :: WriteIterator (WriteIt v) v -> LLVM.CodeGenFunction r v + +class (C v, Phi (WriteIt v), Class.Zero (WriteIt v)) => Zero v where + -- initializes the target with zeros + -- you may only call 'writeStop' on the result of 'writeZero' + writeZero :: LLVM.CodeGenFunction r (WriteIterator (WriteIt v) v) + +instance (Vector.Simple v) => Sized (T v) where + type Size (T v) = Vector.Size v + +{- | +This instance also allows to wrap tuples of vectors, +but you cannot reasonably use them, +because it would mean to serialize vectors with different element types. +-} +instance (Vector.Simple v) => Read (T v) where + + type Element (T v) = Vector.Element v + type ReadIt (T v) = v + + extract k (Cons v) = Vector.extract k v + + readStart (Cons v) = return $ Iterator v + readNext (Iterator v0) = do + x <- Vector.extract (LLVM.valueOf 0) v0 + v1 <- Vector.rotateDown v0 + return (x, Iterator v1) + + +instance (Vector.C v) => C (T v) where + type WriteIt (T v) = v + + insert k a (Cons v) = fmap Cons $ Vector.insert k a v + + writeStart = return (Iterator Class.undefTuple) + writeNext x (Iterator v0) = do + v1 <- fmap snd $ Vector.shiftDown x v0 + return (Iterator v1) + writeStop (Iterator v0) = return (Cons v0) + +instance (Vector.C v, Class.Zero v) => Zero (T v) where + writeZero = return (Iterator Class.zeroTuple) + + +instance + (Read va, Read vb, Size va ~ Size vb) => + Read (va, vb) where + + type Element (va, vb) = (Element va, Element vb) + type ReadIt (va, vb) = (ReadIt va, ReadIt vb) + + extract k (va,vb) = + liftM2 (,) + (extract k va) + (extract k vb) + + readStart (va,vb) = + liftM2 combineIt2 (readStart va) (readStart vb) + readNext it = do + (a, ita) <- readNext $ fmapIt fst fst it + (b, itb) <- readNext $ fmapIt snd snd it + return ((a,b), combineIt2 ita itb) + +instance + (C va, C vb, Size va ~ Size vb) => + C (va, vb) where + + type WriteIt (va, vb) = (WriteIt va, WriteIt vb) + + insert k (a,b) (va,vb) = + liftM2 (,) + (insert k a va) + (insert k b vb) + + writeStart = + liftM2 combineIt2 writeStart writeStart + writeNext (a,b) it = + liftM2 combineIt2 + (writeNext a $ fmapIt fst fst it) + (writeNext b $ fmapIt snd snd it) + writeStop it = + liftM2 (,) + (writeStop (fmapIt fst fst it)) + (writeStop (fmapIt snd snd it)) + +instance + (Zero va, Zero vb, Size va ~ Size vb) => + Zero (va, vb) where + + writeZero = + liftM2 combineIt2 writeZero writeZero + + +instance + (Read va, Read vb, Read vc, + Size va ~ Size vb, + Size vb ~ Size vc) => + Read (va, vb, vc) where + + type Element (va, vb, vc) = (Element va, Element vb, Element vc) + type ReadIt (va, vb, vc) = (ReadIt va, ReadIt vb, ReadIt vc) + + extract k (va,vb,vc) = + liftM3 (,,) + (extract k va) + (extract k vb) + (extract k vc) + + readStart (va,vb,vc) = + liftM3 combineIt3 (readStart va) (readStart vb) (readStart vc) + readNext it = do + (a, ita) <- readNext $ fmapIt fst3 fst3 it + (b, itb) <- readNext $ fmapIt snd3 snd3 it + (c, itc) <- readNext $ fmapIt thd3 thd3 it + return ((a,b,c), combineIt3 ita itb itc) + + +instance + (C va, C vb, C vc, + Size va ~ Size vb, + Size vb ~ Size vc) => + C (va, vb, vc) where + + type WriteIt (va, vb, vc) = (WriteIt va, WriteIt vb, WriteIt vc) + + insert k (a,b,c) (va,vb,vc) = + liftM3 (,,) + (insert k a va) + (insert k b vb) + (insert k c vc) + + writeStart = + liftM3 combineIt3 writeStart writeStart writeStart + writeNext (a,b,c) it = + liftM3 combineIt3 + (writeNext a $ fmapIt fst3 fst3 it) + (writeNext b $ fmapIt snd3 snd3 it) + (writeNext c $ fmapIt thd3 thd3 it) + writeStop it = + liftM3 (,,) + (writeStop (fmapIt fst3 fst3 it)) + (writeStop (fmapIt snd3 snd3 it)) + (writeStop (fmapIt thd3 thd3 it)) + +instance + (Zero va, Zero vb, Zero vc, + Size va ~ Size vb, + Size vb ~ Size vc) => + Zero (va, vb, vc) where + + writeZero = + liftM3 combineIt3 writeZero writeZero writeZero + + +instance (Read v) => Read (Stereo.T v) where + + type Element (Stereo.T v) = Stereo.T (Element v) + type ReadIt (Stereo.T v) = Stereo.T (ReadIt v) + + extract = extractTraversable + + readStart = readStartTraversable + readNext = readNextTraversable + +instance (C v) => C (Stereo.T v) where + + type WriteIt (Stereo.T v) = Stereo.T (WriteIt v) + + insert = insertTraversable + + writeStart = writeStartTraversable + writeNext = writeNextTraversable + writeStop = writeStopTraversable + +instance (Zero v) => Zero (Stereo.T v) where + + writeZero = + fmap combineItFunctor $ Trav.sequence $ App.pure writeZero + + +modify :: + (C v) => + LLVM.Value Word32 -> + (Element v -> LLVM.CodeGenFunction r (Element v)) -> + v -> LLVM.CodeGenFunction r v +modify k f v = do + flip (insert k) v =<< f =<< extract k v + + +subsample :: + (Read v) => + v -> LLVM.CodeGenFunction r (Element v) +subsample v = + extract (LLVM.value LLVM.zero :: LLVM.Value Word32) v + +-- this will be translated to an efficient pshufd +upsample :: + (C v) => + Element v -> LLVM.CodeGenFunction r v +upsample x = + withSize $ \n -> assemble $ List.replicate n x + + +cumulate :: + (Vector.Arithmetic a, TypeNum.PositiveT n) => + LLVM.Value a -> Value n a -> + LLVM.CodeGenFunction r (LLVM.Value a, Value n a) +cumulate x (Cons v) = + fmap (mapSnd Cons) $ Vector.cumulate x v + + +iterate :: + (C v) => + (Element v -> LLVM.CodeGenFunction r (Element v)) -> + Element v -> LLVM.CodeGenFunction r v +iterate f x = + withSize $ \n -> + assemble =<< + (flip MS.evalStateT x $ + replicateM n $ + MS.StateT $ \x0 -> do x1 <- f x0; return (x0,x1)) + +reverse :: + (C v) => + v -> LLVM.CodeGenFunction r v +reverse = + assemble . List.reverse <=< extractAll + +shiftUp :: + (C v) => + Element v -> v -> LLVM.CodeGenFunction r (Element v, v) +shiftUp x v = + ListHT.switchR + (return (x,v)) + (\ys0 y -> fmap ((,) y) $ assemble (x:ys0)) + =<< + extractAll v + + +shiftUpMultiZero :: + (C v, A.Additive (Element v)) => + Int -> v -> LLVM.CodeGenFunction r v +shiftUpMultiZero n v = + assemble . take (size v) . (List.replicate n A.zero ++) =<< extractAll v + +shiftDownMultiZero :: + (C v, A.Additive (Element v)) => + Int -> v -> LLVM.CodeGenFunction r v +shiftDownMultiZero n v = + assemble . take (size v) . (++ List.repeat A.zero) . List.drop n + =<< extractAll v + + +insertTraversable :: + (C v, Trav.Traversable f, App.Applicative f) => + LLVM.Value Word32 -> f (Element v) -> f v -> LLVM.CodeGenFunction r (f v) +insertTraversable n a v = + Trav.sequence (liftA2 (insert n) a v) + +extractTraversable :: + (Read v, Trav.Traversable f) => + LLVM.Value Word32 -> f v -> LLVM.CodeGenFunction r (f (Element v)) +extractTraversable n v = + Trav.mapM (extract n) v + + +readStartTraversable :: + (Trav.Traversable f, App.Applicative f, Read v) => + f v -> LLVM.CodeGenFunction r (ReadIterator (f (ReadIt v)) (f v)) +readNextTraversable :: + (Trav.Traversable f, App.Applicative f, Read v) => + ReadIterator (f (ReadIt v)) (f v) -> + LLVM.CodeGenFunction r (f (Element v), ReadIterator (f (ReadIt v)) (f v)) + +readStartTraversable v = + fmap combineItFunctor $ Trav.mapM readStart v + +readNextTraversable it = do + st <- Trav.mapM readNext $ sequenceItFunctor it + return (fmap fst st, combineItFunctor $ fmap snd st) + + +writeStartTraversable :: + (Trav.Traversable f, App.Applicative f, C v) => + LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v)) +writeNextTraversable :: + (Trav.Traversable f, App.Applicative f, C v) => + f (Element v) -> WriteIterator (f (WriteIt v)) (f v) -> + LLVM.CodeGenFunction r (WriteIterator (f (WriteIt v)) (f v)) +writeStopTraversable :: + (Trav.Traversable f, App.Applicative f, C v) => + WriteIterator (f (WriteIt v)) (f v) -> LLVM.CodeGenFunction r (f v) + +writeStartTraversable = + fmap combineItFunctor $ Trav.sequence $ App.pure writeStart + +writeNextTraversable x it = + fmap combineItFunctor $ Trav.sequence $ + liftA2 writeNext x $ sequenceItFunctor it + +writeStopTraversable = Trav.mapM writeStop . sequenceItFunctor + + +instance (MakeValueTuple v) => MakeValueTuple (T v) where + type ValueTuple (T v) = T (Class.ValueTuple v) + valueTupleOf (Cons v) = Cons (Class.valueTupleOf v) + +instance (Memory.C v) => Memory.C (T v) where + type Struct (T v) = Memory.Struct v + load = Memory.loadNewtype Cons + store = Memory.storeNewtype (\(Cons v) -> v) + decompose = Memory.decomposeNewtype Cons + compose = Memory.composeNewtype (\(Cons v) -> v) + + +mapV :: (Functor m) => + (LLVM.Value (LLVM.Vector n a) -> m (LLVM.Value (LLVM.Vector n b))) -> + Value n a -> m (Value n b) +mapV f (Cons x) = fmap Cons (f x) + +zipV :: (Functor m) => + (c -> d) -> + (LLVM.Value (LLVM.Vector n a) -> + LLVM.Value (LLVM.Vector n b) -> + m c) -> + Value n a -> + Value n b -> + m d +zipV g f (Cons x) (Cons y) = + fmap g (f x y) + + + +withSize :: Sized v => (Int -> m v) -> m v +withSize = + let sz :: (Sized v) => Size v -> (Int -> m v) -> m v + sz n f = f (TypeNum.fromIntegerT n) + in sz undefined + +size :: Sized v => v -> Int +size = + let sz :: (Sized v) => Size v -> v -> Int + sz n _ = TypeNum.fromIntegerT n + in sz undefined + +sizeOfIterator :: Sized v => Iterator mode it v -> Int +sizeOfIterator = + let sz :: Sized v => v -> Iterator mode it v -> Int + sz v _ = fromIntegral $ size v + in sz undefined + + +{- | +The type parameter @value@ shall be a virtual LLVM register +or a wrapper around one or more virtual LLVM registers. +-} +class (TypeNum.PositiveT (Size valueTuple)) => Sized valueTuple where + type Size valueTuple :: * + serialSize :: valueTuple -> Size valueTuple + serialSize _ = error "serial size is a type number and has no value" + +{- | +Basic LLVM types are all counted as scalar values, even LLVM Vectors. +This means that an LLVM Vector can be used for parallel handling of data. +-} +instance Sized (LLVM.Value a) where + type Size (LLVM.Value a) = TypeNum.D1 + +instance (Sized value) => Sized (Stereo.T value) where + type Size (Stereo.T value) = Size value + +instance + (Sized value0, Sized value1, + Size value0 ~ Size value1) => + Sized (value0, value1) where + type Size (value0, value1) = Size value0 + +instance + (Sized value0, Sized value1, Sized value2, + Size value0 ~ Size value1, + Size value1 ~ Size value2) => + Sized (value0, value1, value2) where + type Size (value0, value1, value2) = Size value0 diff --git a/src/Synthesizer/LLVM/Frame/Stereo.hs b/src/Synthesizer/LLVM/Frame/Stereo.hs --- a/src/Synthesizer/LLVM/Frame/Stereo.hs +++ b/src/Synthesizer/LLVM/Frame/Stereo.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Re-export functions from "Sound.Frame.Stereo" @@ -16,6 +13,8 @@ Stereo.arrowFromMonoControlled, Stereo.arrowFromChannels, interleave, + sequence, + liftApplicative, ) where import qualified Synthesizer.Frame.Stereo as Stereo @@ -28,24 +27,36 @@ import qualified LLVM.Core as LLVM import LLVM.Extra.Class (Undefined, undefTuple, - MakeValueTuple, valueTupleOf, ) + MakeValueTuple, ValueTuple, valueTupleOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Data.TypeLevel.Num (d0, d1, ) +import Types.Data.Num (d0, d1, ) import Control.Monad (liftM2, ) -import Control.Applicative (liftA2, ) +import Control.Applicative (Applicative, liftA2, ) import qualified Data.Traversable as Trav +import Prelude hiding (sequence, ) + -- if it turns out to be useful, we may move it to sample-frame package interleave :: (Stereo.T a, Stereo.T b) -> Stereo.T (a,b) -interleave (p,f) = +interleave = uncurry (liftA2 (,)) + +-- if it turns out to be useful, we may move it to sample-frame package +sequence :: (Functor f) => f (Stereo.T a) -> Stereo.T (f a) +sequence x = Stereo.cons - (Stereo.left p, Stereo.left f) - (Stereo.right p, Stereo.right f) + (fmap Stereo.left x) + (fmap Stereo.right x) +liftApplicative :: + (Applicative f) => + (f a -> f b) -> f (Stereo.T a) -> f (Stereo.T b) +liftApplicative proc = + Trav.sequenceA . fmap proc . sequence + instance (Class.Zero a) => Class.Zero (Stereo.T a) where zeroTuple = Stereo.cons Class.zeroTuple Class.zeroTuple @@ -56,11 +67,11 @@ select = C.selectTraversable {- -instance LLVM.CmpRet a b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where +instance LLVM.CmpRet a, LLVM.CmpResult a ~ b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where -} -instance MakeValueTuple h l => - MakeValueTuple (Stereo.T h) (Stereo.T l) where +instance (MakeValueTuple h) => MakeValueTuple (Stereo.T h) where + type ValueTuple (Stereo.T h) = Stereo.T (ValueTuple h) valueTupleOf s = Stereo.cons (Class.valueTupleOf $ Stereo.left s) @@ -87,25 +98,28 @@ addPhis bb (Stereo.right x) (Stereo.right y) -instance (Vector.ShuffleMatch n v) => Vector.ShuffleMatch n (Stereo.T v) where +instance (Vector.Simple v) => Vector.Simple (Stereo.T v) where + type Element (Stereo.T v) = Stereo.T (Vector.Element v) + type Size (Stereo.T v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable - -instance (Vector.Access n a v) => Vector.Access n (Stereo.T a) (Stereo.T v) where - insert = Vector.insertTraversable extract = Vector.extractTraversable +instance (Vector.C v) => Vector.C (Stereo.T v) where + insert = Vector.insertTraversable + +type Struct a = LLVM.Struct (a, (a, ())) + memory :: - (Memory.C l s, LLVM.IsSized s ss) => - Memory.Record r (LLVM.Struct (s, (s, ()))) (Stereo.T l) + (Memory.C l) => + Memory.Record r (Struct (Memory.Struct l)) (Stereo.T l) memory = liftA2 Stereo.cons (Memory.element Stereo.left d0) (Memory.element Stereo.right d1) -instance - (Memory.C l s, LLVM.IsSized s ss) => - Memory.C (Stereo.T l) (LLVM.Struct (s, (s, ()))) where +instance (Memory.C l) => Memory.C (Stereo.T l) where + type Struct (Stereo.T l) = Struct (Memory.Struct l) load = Memory.loadRecord memory store = Memory.storeRecord memory decompose = Memory.decomposeRecord memory diff --git a/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs b/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs --- a/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs +++ b/src/Synthesizer/LLVM/Frame/StereoInterleaved.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Represent a vector of Stereo values in two vectors @@ -23,33 +23,37 @@ -} module Synthesizer.LLVM.Frame.StereoInterleaved ( T, - Value, + Value(Value), interleave, deinterleave, + assemble, extractAll, + amplify, ) where import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Core as LLVM import LLVM.Extra.Class (Undefined, undefTuple, MakeValueTuple, valueTupleOf, ) import LLVM.Core - (Vector, Struct, IsSized, ) + (Vector, IsSized, SizeOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -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.Vector as Vector -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import Foreign.Ptr (castPtr, ) import qualified Foreign.Storable as St -- import Data.Word (Word32, ) +import qualified Data.Foldable as Fold import Control.Monad (liftM2, ) import Control.Applicative (liftA2, ) @@ -61,34 +65,53 @@ data Value n a = Value (LLVM.Value (Vector n a)) (LLVM.Value (Vector n a)) +withSize :: (TypeNum.IntegerT n) => (Int -> m (Value n a)) -> m (Value n a) +withSize = + let sz :: (TypeNum.IntegerT n) => n -> (Int -> m (Value n a)) -> m (Value n a) + sz n f = f (TypeNum.fromIntegerT n) + in sz undefined + + interleave :: - (LLVM.IsPrimitive a, TypeNum.Pos n) => - Stereo.T (LLVM.Value (Vector n a)) -> + (LLVM.IsPrimitive a, TypeNum.PositiveT n) => + Stereo.T (Serial.Value n a) -> LLVM.CodeGenFunction r (Value n a) interleave x = - uncurry (liftM2 Value) . - mapPair (Vector.assemble, Vector.assemble) . - splitAt (Vector.sizeInTuple x) . - concatMap (\s -> [Stereo.left s, Stereo.right s]) =<< - Vector.extractAll x + assemble =<< Serial.extractAll x deinterleave :: - (LLVM.IsPrimitive a, TypeNum.Pos n) => + (LLVM.IsPrimitive a, TypeNum.PositiveT n) => Value n a -> - LLVM.CodeGenFunction r (Stereo.T (LLVM.Value (Vector n a))) -deinterleave (Value v0 v1) = - Vector.assemble . - (let aux (l:r:xs) = Stereo.cons l r : aux xs - aux [] = [] - aux _ = error "odd number of stereo elements" - in aux) =<< + LLVM.CodeGenFunction r (Stereo.T (Serial.Value n a)) +deinterleave v = + Serial.assemble =<< extractAll v + +assemble :: + (LLVM.IsPrimitive a, TypeNum.IntegerT n, TypeNum.PositiveT n) => + [Stereo.T (LLVM.Value a)] -> LLVM.CodeGenFunction r (Value n a) +assemble x = + withSize $ \n -> + uncurry (liftM2 Value) . + mapPair (Vector.assemble, Vector.assemble) . + splitAt n . + concatMap Fold.toList $ x + +extractAll :: + (LLVM.IsPrimitive a, TypeNum.IntegerT n, TypeNum.PositiveT n) => + Value n a -> LLVM.CodeGenFunction r [Stereo.T (LLVM.Value a)] +extractAll (Value v0 v1) = + fmap + (let aux (l:r:xs) = Stereo.cons l r : aux xs + aux [] = [] + aux _ = error "odd number of stereo elements" + in aux) $ liftM2 (++) (Vector.extractAll v0) (Vector.extractAll v1) instance - (TypeNum.Pos n, LLVM.IsPrimitive a, St.Storable a) => + (TypeNum.PositiveT n, LLVM.IsPrimitive a, St.Storable a) => St.Storable (T n a) where sizeOf ~(Cons v0 v1) = St.sizeOf v0 + St.sizeOf v1 alignment ~(Cons v _) = St.alignment v @@ -102,96 +125,124 @@ in St.pokeElemOff p 0 v0 >> St.pokeElemOff p 1 v1 -instance (TypeNum.Pos n, LLVM.IsPrimitive a) => Class.Zero (Value n a) where +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Class.Zero (Value n a) where zeroTuple = Value (LLVM.value LLVM.zero) (LLVM.value LLVM.zero) -instance (TypeNum.Pos n, LLVM.IsPrimitive a) => Undefined (Value n a) where +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Undefined (Value n a) where undefTuple = Value (LLVM.value LLVM.undef) (LLVM.value LLVM.undef) {- Can only be implemented by ifThenElse since the atomic 'select' command wants a bool vector. -instance (TypeNum.Pos n, LLVM.IsPrimitive a, Phi a) => C.Select (Value n a) where +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, Phi a) => C.Select (Value n a) where select b (Value x0 x1) (Value y0 y1) = liftM2 Value (C.select b x0 y0) (C.select b x1 y1) -instance LLVM.CmpRet a b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where +instance LLVM.CmpRet a, LLVM.CmpResult a ~ b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where -} -instance (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsConst a) => - MakeValueTuple (T n a) (Value n a) where +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsConst a) => + MakeValueTuple (T n a) where + type ValueTuple (T n a) = Value n a valueTupleOf (Cons v0 v1) = Value (LLVM.valueOf v0) (LLVM.valueOf v1) -instance (TypeNum.Pos n, LLVM.IsPrimitive a) => Phi (Value n a) where +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Phi (Value n a) where phis bb = mapV (phis bb) addPhis bb = zipV (\_ _ -> ()) (addPhis bb) -{- -instance Vector.ShuffleMatch n (Value n a) where - shuffleMatch = Vector.shuffleMatchAccess --} -{- -We cannot make an instance of Vector.Access, -since we defined the functional dependencies in a way, -that vector size and element type uniquely defines the vector type. +instance (TypeNum.PositiveT n) => Serial.Sized (Value n a) where + type Size (Value n a) = n -instance Vector.Access n (Stereo.T a) (Value n a) where +{- | +The implementation of 'extract' may need to perform +arithmetics at run-time and is thus a bit inefficient. +-} +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.Read (Value n a) where + type Element (Value n a) = Stereo.T (LLVM.Value a) + type ReadIt (Value n a) = Value n a -insert :: - LLVM.Value Word32 -> - LLVM.Value a -> - Value n a -> - LLVM.CodeGenFunction r (Value n a) -insert k a (Value v0 v1) = do - k20 <- A.add k k - k21 <- A.inc k20 - select (k20>= - Vector.insert k21 (Stereo.right a) + extract k (Value v0 v1) = + let size = LLVM.valueOf $ fromIntegral $ Vector.sizeInTuple v0 + ext j = do + b <- A.cmp LLVM.CmpLT j size + C.ifThenElse b + (Vector.extract j v0) + (do j1 <- A.sub j size + Vector.extract j1 v1) + in do + k20 <- A.add k k + k21 <- A.inc k20 + liftM2 Stereo.cons (ext k20) (ext k21) -extract :: - LLVM.Value Word32 -> - Value n a -> - LLVM.CodeGenFunction r (LLVM.Value a) -extract k (Value v0 v1) = do - k20 <- A.add k k - k21 <- A.inc k20 - liftM2 Value - (Vector.extract k20 v) - (Vector.extract k21 v) + extractAll = extractAll + readStart = return . Serial.Iterator + readNext (Serial.Iterator v) = do + xt <- extractAll v + case xt of + x:xs -> fmap ((,) x . Serial.Iterator) $ assemble xs + [] -> error "StereoInterleaved.readNext: size zero" -With this instance, -both 'interleave' and 'deinterleave' could then be written this way: - Vector.assemble =<< - mapM (flip Vector.extract x) (take (Vector.size x) [0..]) +{- | +The implementation of 'insert' may need to perform +arithmetics at run-time and is thus a bit inefficient. -} +instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.C (Value n a) where + type WriteIt (Value n a) = Value n a + insert k x v = + let size = LLVM.valueOf $ fromIntegral $ Serial.size v + ins j c (Value v0 v1) = do + b <- A.cmp LLVM.CmpLT j size + C.ifThenElse b + (do w0 <- Vector.insert j c v0 + return $ Value w0 v1) + (do j1 <- A.sub j size + w1 <- Vector.insert j1 c v1 + return $ Value v0 w1) + in do + k20 <- A.add k k + k21 <- A.inc k20 + ins k21 (Stereo.right x) =<< ins k20 (Stereo.left x) v + + assemble = assemble + + writeStart = return (Serial.Iterator Class.undefTuple) + writeNext x (Serial.Iterator v) = do + xs <- extractAll v + fmap Serial.Iterator $ assemble $ tail xs ++ [x] + writeStop (Serial.Iterator v) = return v + + +type Struct n a = LLVM.Struct (Vector n a, (Vector n a, ())) + memory :: - (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsPrimitive am, - Memory.FirstClass a am) => - Memory.Record r (Struct (Vector n am, (Vector n am, ()))) (Value n a) + (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsPrimitive am, + Memory.FirstClass a, Memory.Stored a ~ am, + IsSized am, TypeNum.PositiveT (n TypeNum.:*: SizeOf am)) => + Memory.Record r (Struct n am) (Value n a) memory = liftA2 Value (Memory.element (\(Value v _) -> v) TypeNum.d0) (Memory.element (\(Value _ v) -> v) TypeNum.d1) instance - (TypeNum.Pos n, - Memory.FirstClass a am, - LLVM.IsPrimitive a, IsSized a as, - TypeNum.Mul n as vs, TypeNum.Pos vs, - LLVM.IsPrimitive am, IsSized am amsize, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize) => - Memory.C (Value n a) (Struct (Vector n am, (Vector n am, ()))) where + (TypeNum.PositiveT n, + Memory.FirstClass a, Memory.Stored a ~ am, + LLVM.IsPrimitive a, IsSized a, + TypeNum.PositiveT (n TypeNum.:*: SizeOf a), + LLVM.IsPrimitive am, IsSized am, + TypeNum.PositiveT (n TypeNum.:*: SizeOf am)) => + Memory.C (Value n a) where + type Struct (Value n a) = Struct n (Memory.Stored a) load = Memory.loadRecord memory store = Memory.storeRecord memory decompose = Memory.decomposeRecord memory @@ -201,12 +252,25 @@ This instance allows to run @arrange@ on interleaved stereo vectors. -} instance - (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) => + (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) => A.Additive (Value n a) where zero = Value A.zero A.zero add = zipV Value A.add sub = zipV Value A.sub neg = mapV A.neg + + +scale :: + (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) => + LLVM.Value a -> Value n a -> LLVM.CodeGenFunction r (Value n a) +scale a v = do + av <- SoV.replicate a + mapV (A.mul av) v + +amplify :: + (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) => + a -> Value n a -> LLVM.CodeGenFunction r (Value n a) +amplify a = scale (LLVM.valueOf a) mapV :: (Monad m) => diff --git a/src/Synthesizer/LLVM/Generator/Exponential2.hs b/src/Synthesizer/LLVM/Generator/Exponential2.hs --- a/src/Synthesizer/LLVM/Generator/Exponential2.hs +++ b/src/Synthesizer/LLVM/Generator/Exponential2.hs @@ -1,9 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Exponential curve with controllable delay. @@ -23,23 +21,24 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Parameter as Param -import qualified Synthesizer.LLVM.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A -import LLVM.Extra.Class (Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import qualified LLVM.Core as LLVM import LLVM.Core - (Value, valueOf, Vector, - IsArithmetic, IsPrimitive, IsFloating, IsSized, + (Value, IsArithmetic, IsPrimitive, IsFloating, IsSized, SizeOf, CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) import Foreign.Storable (Storable, ) import qualified Foreign.Storable @@ -96,9 +95,8 @@ instance Class.Zero a => Class.Zero (Parameter a) where zeroTuple = Class.zeroTuplePointed -instance - (Memory.C a s, IsSized s ss) => - Memory.C (Parameter a) s where +instance (Memory.C a) => Memory.C (Parameter a) where + type Struct (Parameter a) = Memory.Struct a load = Memory.loadNewtype Parameter store = Memory.storeNewtype (\(Parameter k) -> k) decompose = Memory.decomposeNewtype Parameter @@ -113,29 +111,29 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (Parameter ah) (Parameter al) where +instance (MakeValueTuple a) => MakeValueTuple (Parameter a) where + type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -instance (Value.Flatten ah al) => - Value.Flatten (Parameter ah) (Parameter al) where +instance (Value.Flatten a) => Value.Flatten (Parameter a) where + type Registers (Parameter a) = Parameter (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor -instance (Vector.ShuffleMatch n v) => - Vector.ShuffleMatch n (Parameter v) where +instance (Vector.Simple v) => Vector.Simple (Parameter v) where + type Element (Parameter v) = Parameter (Vector.Element v) + type Size (Parameter v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable -instance (Vector.Access n a v) => - Vector.Access n (Parameter a) (Parameter v) where +instance (Vector.C v) => Vector.C (Parameter v) where insert = Vector.insertTraversable - extract = Vector.extractTraversable parameter :: - (Trans.C a, SoV.RationalConstant a, IsFloating a) => + (Trans.C a, SoV.TranscendentalConstant a, IsFloating a) => Value a -> CodeGenFunction r (Parameter (Value a)) parameter halfLife = @@ -150,11 +148,10 @@ causalP :: - (Memory.FirstClass a am, IsSized a as, IsSized am ams, SoV.IntegerConstant a, - IsArithmetic a, - Storable a, Class.MakeValueTuple a (Value a)) => + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.PseudoRing al) => Param.T p a -> - CausalP.T p (Parameter (Value a)) (Value a) + CausalP.T p (Parameter al) al causalP initial = CausalP.loop initial (arr snd &&& CausalP.zipWithSimple (\(Parameter a) -> A.mul a)) @@ -222,17 +219,18 @@ poke = Store.poke +type ParameterPackedStruct a = LLVM.Struct (a, (a, ())) + memory :: - (Memory.C l s, IsSized s ss) => - Memory.Record r (LLVM.Struct (s, (s, ()))) (ParameterPacked l) + (Memory.C a) => + Memory.Record r (ParameterPackedStruct (Memory.Struct a)) (ParameterPacked a) memory = liftA2 ParameterPacked (Memory.element ppFeedback TypeNum.d0) (Memory.element ppCurrent TypeNum.d1) -instance - (Memory.C l s, IsSized s ss) => - Memory.C (ParameterPacked l) (LLVM.Struct (s, (s, ()))) where +instance (Memory.C a) => Memory.C (ParameterPacked a) where + type Struct (ParameterPacked a) = ParameterPackedStruct (Memory.Struct a) load = Memory.loadRecord memory store = Memory.storeRecord memory decompose = Memory.decomposeRecord memory @@ -247,48 +245,43 @@ tupleDesc = Class.tupleDescFoldable -} -instance (Class.MakeValueTuple ah al) => - Class.MakeValueTuple (ParameterPacked ah) (ParameterPacked al) where +instance (MakeValueTuple a) => MakeValueTuple (ParameterPacked a) where + type ValueTuple (ParameterPacked a) = ParameterPacked (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor -instance (Value.Flatten ah al) => - Value.Flatten (ParameterPacked ah) (ParameterPacked al) where +instance (Value.Flatten a) => Value.Flatten (ParameterPacked a) where + type Registers (ParameterPacked a) = ParameterPacked (Value.Registers a) flatten = Value.flattenTraversable unfold = Value.unfoldFunctor - -instance (Vector.ShuffleMatch m v) => - Vector.ShuffleMatch m (ParameterPacked v) where - shuffleMatch = Vector.shuffleMatchTraversable - -instance (Vector.Access m a v) => - Vector.Access m (ParameterPacked a) (ParameterPacked v) where - insert = Vector.insertTraversable - extract = Vector.extractTraversable +type instance F.Arguments f (ParameterPacked a) = f (ParameterPacked a) +instance F.MakeArguments (ParameterPacked a) where + makeArgs = id withSize :: - (n -> m (param (Value (Vector n a)))) -> - m (param (Value (Vector n a))) + (Serial.C v, Serial.Size v ~ n, TypeNum.PositiveT n) => + (n -> m (param v)) -> + m (param v) withSize f = f undefined parameterPacked :: - (Trans.C a, SoV.RationalConstant a, IsFloating a, - IsPrimitive a, TypeNum.Pos n) => - Value a -> - CodeGenFunction r (ParameterPacked (Value (Vector n a))) + (Serial.C v, Serial.Element v ~ a, + A.PseudoRing v, A.RationalConstant v, + A.Transcendental a, A.RationalConstant a) => + a -> CodeGenFunction r (ParameterPacked v) parameterPacked halfLife = withSize $ \n -> do feedback <- - SoV.replicate =<< - A.pow (valueOf 0.5) =<< - A.fdiv (valueOf $ fromIntegral $ TypeNum.toInt n) halfLife + Serial.upsample =<< + A.pow (A.fromRational' 0.5) =<< + A.fdiv (A.fromInteger' $ TypeNum.fromIntegerT n) halfLife k <- - A.pow (valueOf 0.5) =<< - A.fdiv (valueOf 1) halfLife + A.pow (A.fromRational' 0.5) =<< + A.fdiv (A.fromInteger' 1) halfLife current <- - Vector.iterate (A.mul k) (valueOf 1) + Serial.iterate (A.mul k) (A.fromInteger' 1) return $ ParameterPacked feedback current {- Value.flatten $ parameterPackedPlain $ @@ -296,29 +289,31 @@ -} withSizePlain :: - (n -> param (Vector n a)) -> - param (Vector n a) + (n -> param (Serial.Plain n a)) -> + param (Serial.Plain n a) withSizePlain f = f undefined parameterPackedPlain :: (Trans.C a, - TypeNum.Pos n) => - a -> ParameterPacked (Vector n a) + TypeNum.PositiveT n) => + a -> ParameterPacked (Serial.Plain n a) parameterPackedPlain halfLife = withSizePlain $ \n -> ParameterPacked - (Serial.replicate (0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife))) - (LLVM.vector $ iterate (0.5 ** recip halfLife *) one) + (Serial.replicate (0.5 ** (fromInteger (TypeNum.fromIntegerT n) / halfLife))) + (Serial.fromList $ iterate (0.5 ** recip halfLife *) one) causalPackedP :: - (Memory.FirstClass a am, IsSized a as, IsSized am ams, SoV.IntegerConstant a, - Storable a, Class.MakeValueTuple a (Value a), - IsArithmetic a, TypeNum.Pos n, - IsPrimitive a, TypeNum.Mul n as vs, TypeNum.Pos vs, - IsPrimitive am, TypeNum.Mul n ams vms, TypeNum.Pos vms) => + (IsArithmetic a, SoV.IntegerConstant a, + Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + IsPrimitive a, IsPrimitive am, + TypeNum.PositiveT (n :*: SizeOf a), + TypeNum.PositiveT (n :*: SizeOf am), + TypeNum.PositiveT n) => Param.T p a -> - CausalP.T p (ParameterPacked (Value (Vector n a))) (Value (Vector n a)) + CausalP.T p (ParameterPacked (Serial.Value n a)) (Serial.Value n a) causalPackedP initial = CausalP.loop (Serial.replicate ^<< initial) diff --git a/src/Synthesizer/LLVM/LAC2011.hs b/src/Synthesizer/LLVM/LAC2011.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/LAC2011.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Synthesizer.LLVM.LAC2011 where - -import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass -import qualified Synthesizer.LLVM.Filter.Allpass as Allpass -import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth -import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev -import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 -import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 -import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P -import qualified Synthesizer.LLVM.Filter.Moog as Moog -import qualified Synthesizer.LLVM.Filter.Universal as UniFilter -import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP -import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Causal.Process as Causal -import qualified Synthesizer.LLVM.Simple.Signal as Gen -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import qualified Synthesizer.LLVM.Frame as Frame -import qualified Synthesizer.LLVM.Wave as Wave -import qualified Synthesizer.LLVM.Parameter as Param - -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Class as C -import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) -import LLVM.Util.Arithmetic () -- Floating instance for TValue -import qualified LLVM.Core as LLVM -import Data.TypeLevel.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, ) -import qualified Data.TypeLevel.Num as TypeNum - -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS -import qualified Synthesizer.LLVM.Parameterized.Signal as GenP -import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ) -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import qualified Synthesizer.Plain.Filter.Recursive as FiltR -import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core -import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core - -import Control.Arrow (Arrow, arr, (&&&), (^<<), ) -import Control.Category ((<<<), (.), id, ) -import Control.Monad ((<=<), ) -import Control.Applicative (liftA2, pure, ) -import Data.Traversable (traverse, ) - -import Foreign.Storable (Storable, ) -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Numeric.NonNegative.Wrapper as NonNeg - -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo - -import qualified Sound.Sox.Option.Format as SoxOption -import qualified Sound.Sox.Frame as SoxFrame -import qualified Sound.Sox.Play as SoxPlay - -import qualified Sound.ALSA.PCM as ALSA -import qualified Synthesizer.Storable.ALSA.Play as Play - -import Data.Word (Word32, ) --- import qualified Data.Function.HT as F -import Data.List (genericLength, ) -import System.Random (randomRs, mkStdGen, ) - -import qualified System.IO as IO --- import System.Exit (ExitCode, ) - -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 (fst, snd, id, (.), ) -import qualified NumericPrelude.Base as P - - -asMono :: vector Float -> vector Float -asMono = id - -asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) -asStereo = id - -asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float) -asMonoPacked = id - -asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float) -asMonoPacked16 = id - -asWord32 :: vector Word32 -> vector Word32 -asWord32 = id - -asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32) -asWord32Packed = id - - -playStereo :: Gen.T (Stereo.T (Value Float)) -> IO () -playStereo = - playStereoStream . - Gen.renderChunky (SVL.chunkSize 100000) - -playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () -playStereoStream = playStreamSox - -playMono :: Gen.T (Value Float) -> IO () -playMono = - playMonoStream . - Gen.renderChunky (SVL.chunkSize 100000) - -playMonoParam :: GenP.T () (Value Float) -> IO () -playMonoParam = - playMonoStream . - ($ ()) . - ($ SVL.chunkSize 100000) <=< - GenP.runChunky - -playMonoPacked :: GenP.T () (Value (Vector D4 Float)) -> IO () -playMonoPacked = - playMonoStream . - SigStL.unpack . - ($ ()) . - ($ SVL.chunkSize 100000) <=< - GenP.runChunky - -playMonoStream :: SVL.Vector Float -> IO () -playMonoStream = playStreamSox - - -{- -play :: - (C.MakeValueTuple y a, Memory.C a struct) => - Gen.T a -> IO () -play = - playStreamSox . - 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 = - fmap (const ()) . - SoxPlay.simple SVL.hPut SoxOption.none 44100 - - -sampleRate :: Ring.C a => a -sampleRate = 44100 - -intSecond :: Ring.C a => Float -> a -intSecond t = fromInteger $ round $ t * sampleRate - -second :: Field.C a => a -> a -second t = t * sampleRate - -hertz :: Field.C a => a -> a -hertz f = f / sampleRate - -{- -second :: Float -> Param.T p Float -second t = return (t * sampleRate) - -hertz :: Float -> Param.T p Float -hertz f = return (f / sampleRate) --} - -sine :: IO () -sine = - playMono (0.99 * Gen.osci Wave.sine 0 (hertz 440)) - -ping :: IO () -ping = - playMono (Gen.exponential2 (second 1) 1 * Gen.osci Wave.triangle 0 (hertz 440)) - -tremolo :: IO () -tremolo = - playMono (Gen.osci Wave.sine 0 (hertz 0.3) * Gen.osci Wave.triangle 0 (hertz 440)) - - -stereo :: IO () -stereo = - playStereo (liftA2 Stereo.cons (Gen.osci Wave.triangle 0 (hertz 439)) (Gen.osci Wave.triangle 0 (hertz 441))) - -stereoFancy :: IO () -stereoFancy = - playStereo (traverse (Gen.osci Wave.triangle 0 . hertz) (Stereo.cons 439 441)) - - -fst :: Arrow arrow => arrow (a,b) a -fst = arr P.fst - -snd :: Arrow arrow => arrow (a,b) b -snd = arr P.snd - - -pingParam :: IO (Float -> SVL.Vector Float) -pingParam = - fmap ($ SVL.chunkSize 1024) $ - GenP.runChunky $ - GenP.exponential2 (second 0.3) 1 * GenP.osciSimple Wave.triangle 0 id - -playPingParam :: IO () -playPingParam = do - png <- pingParam - playMonoStream (SVL.take (intSecond 1) $ png (hertz 880)) - -melody :: IO (SVL.Vector Float) -melody = do - png <- pingParam - return $ SVL.concat $ map (SVL.take (intSecond 0.2) . png . hertz) $ cycle [440, 550, 660, 880] - -playMelody :: IO () -playMelody = do - mel <- melody - playMonoStream mel - -pingParam2 :: IO ((Float, Float) -> SVL.Vector Float) -pingParam2 = - fmap ($ SVL.chunkSize 1024) $ - GenP.runChunky $ - GenP.exponential2 (second 0.3) fst * GenP.osciSimple Wave.triangle 0 snd - -playMelody2 :: IO () -playMelody2 = do - png <- pingParam2 - playMonoStream $ SVL.concat $ map (SVL.take (intSecond 0.2) . png) $ zip (map sin $ [0,0.1..]) (cycle $ map hertz [440, 550, 660, 880]) - - -retard :: GenP.T p (Value Float) -> GenP.T p (Value Float) -retard xs = - CausalP.frequencyModulationLinear xs . - CausalP.mapSimple (A.fdiv (LLVM.valueOf 1)) $* - GenP.rampCore (1 / second 10) 1 - -playRetarded :: IO () -playRetarded = do - mel <- melody - playMonoParam $ retard $ GenP.fromStorableVectorLazy $ pure $ mel - - - -pingGen :: GenP.T p (Value Float) -pingGen = - GenP.exponential2 (second 0.5) 0.7 * - GenP.osciSimple Wave.triangle 0 (hertz 440) - -zerop :: Param.T p Float -zerop = pure zero - -delayp :: Param.T p Int -> CausalP.T p (Value Float) (Value Float) -delayp = CausalP.delay zerop - -delay :: IO () -delay = - playMonoParam $ - pingGen + 0.7 * (delayp (intSecond 0.5) $* pingGen) - -delayArrow :: IO () -delayArrow = - playMonoParam - ((id + 0.7 * delayp (intSecond 0.5)) $* pingGen) - -comb :: IO () -comb = - playMonoParam $ - (CausalP.loop zerop - (id &&& 0.7 * delayp (intSecond 0.5) - <<< CausalP.mix) $* - pingGen) - - -lfoSine :: - Param.T p Float -> - GenP.T p (Moog.Parameter D8 (Value Float)) -lfoSine reduct = - CausalP.mapSimple (Moog.parameter d8 (valueOf (30::Float))) . - CausalP.mapExponential 2 (hertz 700) $* - GenP.osciSimple Wave.sine 0 (reduct * hertz 0.1) - -filterSweep :: IO () -filterSweep = - playMonoParam $ - (0.2 * CtrlP.processCtrlRate 128 lfoSine - $* GenP.noise 0 0.3) - - -pingPacked :: IO () -pingPacked = - playMonoPacked (GenPS.exponential2 (second 1) 1 * GenPS.osciSimple Wave.triangle 0 (hertz 440)) - - - -{- -Module can be loaded into GHCi only when synthesizer-llvm was installed with -$ cabal install --enable-shared - -In contrast to that, you have to install with -$ cabal install -fbuildTests -fbuildExamples --enable-shared --disable-library-profiling --ghc-option=-dynamic -for build the executables. -But then GHCi complains: - -$ ghci -GHCi, version 6.12.3: http://www.haskell.org/ghc/ :? for help -Loading package ghc-prim ... linking ... done. -Loading package integer-gmp ... linking ... done. -Loading package base ... linking ... done. -Loading package ffi-1.0 ... linking ... done. -[1 of 1] Compiling Main ( src/Synthesizer/LLVM/Test.hs, interpreted ) - -src/Synthesizer/LLVM/Test.hs:4:0: - Bad interface file: /home/thielema/.cabal/lib/synthesizer-llvm-0.3/ghc-6.12.3/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hi - mismatched interface file ways (wanted "", got "dyn") -Failed, modules loaded: none. --} diff --git a/src/Synthesizer/LLVM/LNdW2011.hs b/src/Synthesizer/LLVM/LNdW2011.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/LNdW2011.hs +++ /dev/null @@ -1,543 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Synthesizer.LLVM.LNdW2011 where - -import qualified Synthesizer.LLVM.Plug.Input as PIn -import qualified Synthesizer.LLVM.Plug.Output as POut -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS -import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSelection as MCS -import qualified Synthesizer.CausalIO.ALSA.Process as PALSA -import qualified Synthesizer.CausalIO.Process as PIO -import qualified Synthesizer.MIDIValue as MV -import qualified Synthesizer.Zip as Zip -import Synthesizer.EventList.ALSA.MIDI (ClientName(ClientName)) - -import qualified Sound.MIDI.Controller as Ctrl -import qualified Sound.MIDI.Message.Channel as ChannelMsg - -import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass -import qualified Synthesizer.LLVM.Filter.Allpass as Allpass -import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth -import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev -import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 -import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 -import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P -import qualified Synthesizer.LLVM.Filter.Moog as Moog -import qualified Synthesizer.LLVM.Filter.Universal as UniFilter -import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP -import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Causal.Process as Causal -import qualified Synthesizer.LLVM.Simple.Signal as Gen -import qualified Synthesizer.LLVM.Simple.Value as Value -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import qualified Synthesizer.LLVM.Frame as Frame -import qualified Synthesizer.LLVM.Wave as Wave -import qualified Synthesizer.LLVM.Parameter as Param - -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Class as C -import LLVM.Core (Value, value, valueOf, constVector, constOf, ) -import LLVM.Util.Arithmetic () -- Floating instance for TValue -import qualified LLVM.Core as LLVM -import Data.TypeLevel.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, ) -import qualified Data.TypeLevel.Num as TypeNum - -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS -import qualified Synthesizer.LLVM.Parameterized.Signal as GenP -import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ($<#), ) -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import qualified Synthesizer.Plain.Filter.Recursive as FiltR -import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core -import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core - -import qualified Synthesizer.Causal.Spatial as Spatial - -import qualified Control.Arrow as Arr -import Control.Arrow (Arrow, arr, (&&&), (^<<), ) -import Control.Category ((<<<), (.), id, (>>>), ) -import Control.Monad ((<=<), ) -import Control.Applicative (liftA2, pure, ) -import Data.Traversable (traverse, ) - -import Foreign.Storable (Storable, ) -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Class as NonNeg - -import qualified Control.Monad.Trans.State as State - -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt - -import qualified Sound.Sox.Option.Format as SoxOption -import qualified Sound.Sox.Frame as SoxFrame -import qualified Sound.Sox.Play as SoxPlay - -import qualified Sound.ALSA.PCM as ALSA -import qualified Synthesizer.Storable.ALSA.Play as Play - -import Data.Word (Word32, ) --- import qualified Data.Function.HT as F -import Data.List (genericLength, ) -import System.Random (randomRs, mkStdGen, ) - -import qualified System.IO as IO --- import System.Exit (ExitCode, ) - -import qualified Algebra.NormedSpace.Euclidean as NormedEuc -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.IntegralDomain as Integral - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (fst, snd, id, (.), ) -import qualified NumericPrelude.Base as P - - -asMono :: vector Float -> vector Float -asMono = id - -asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) -asStereo = id - -asMonoPacked :: vector Vector -> vector Vector -asMonoPacked = id - -asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float) -asMonoPacked16 = id - -asWord32 :: vector Word32 -> vector Word32 -asWord32 = id - -asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32) -asWord32Packed = id - - -playStereo :: Gen.T (Stereo.T (Value Float)) -> IO () -playStereo = - playStereoStream . - Gen.renderChunky (SVL.chunkSize 100000) - -playStereoStream :: SVL.Vector (Stereo.T Float) -> IO () -playStereoStream = playStreamSox - -playMono :: Gen.T (Value Float) -> IO () -playMono = - playMonoStream . - Gen.renderChunky (SVL.chunkSize 100000) - -playMonoParam :: GenP.T () (Value Float) -> IO () -playMonoParam = - playMonoStream . - ($ ()) . - ($ SVL.chunkSize 100000) <=< - GenP.runChunky - -playMonoPacked :: GenP.T () (Value Vector) -> IO () -playMonoPacked = - playMonoStream . - SigStL.unpack . - ($ ()) . - ($ SVL.chunkSize 100000) <=< - GenP.runChunky - -playMonoStream :: SVL.Vector Float -> IO () -playMonoStream = playStreamSox - - -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 = - fmap (const ()) . - SoxPlay.simple SVL.hPut SoxOption.none 44100 - - -sampleRate :: Ring.C a => a -sampleRate = 44100 - -type Vector = LLVM.Vector VectorSize Float -type VectorSize = TypeNum.D4 - -vectorSize :: Int -vectorSize = TypeNum.toInt (undefined :: VectorSize) - -vectorRate :: Field.C a => a -vectorRate = sampleRate / fromIntegral vectorSize - - - -intSecond :: Ring.C a => Float -> a -intSecond t = fromInteger $ round $ t * sampleRate - -second :: Field.C a => a -> a -second t = t * sampleRate - -hertz :: Field.C a => a -> a -hertz f = f / sampleRate - - - -fst :: Arrow arrow => arrow (a,b) a -fst = arr P.fst - -snd :: Arrow arrow => arrow (a,b) b -snd = arr P.snd - - -playFromEvents :: - (ALSA.SampleFmt a, Additive.C a) => - Double -> - Double -> - PIO.T PALSA.Events (SV.Vector a) -> - IO () -playFromEvents latency period = - PALSA.playFromEvents - Play.defaultDevice (ClientName "Haskell-LLVM-demo") - latency period sampleRate - - -modulation :: IO () -modulation = do - proc <- - CausalP.processIO - (0.95 * (CausalP.osciSimple Wave.approxSine4 $< 0)) - playFromEvents 0.01 (0.015::Double) - ((proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float)) - . - PALSA.controllerExponential - (ChannelMsg.toChannel 0) - Ctrl.modulation - (hertz 500, hertz 2000) (hertz 1000)) - - -vectorBlockSize :: Double -vectorBlockSize = fromIntegral $ 150*vectorSize - -subsample :: (Integral.C t) => t -> t -> State.State t t -subsample step t = - State.state $ \r -> divMod (r+t) step -{- - do modify (t+) - (q,r) <- gets (flip divMod step) - put r - return q --} - -subsampleBT :: EventListBT.T NonNegW.Int a -> EventListBT.T NonNegW.Int a -subsampleBT = - flip State.evalState NonNeg.zero . - EventListBT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" vectorSize)) - -modulationPacked :: IO () -modulationPacked = do - proc <- - CausalP.processIO - (0.95 * (CausalPS.osciSimple Wave.approxSine4 $< 0) - . - CausalP.mapSimple SoV.replicate) - playFromEvents 0.01 (vectorBlockSize/sampleRate) - (arr SigStL.unpackStrict - . - (proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector)) - . - arr subsampleBT - . - PALSA.controllerExponential - (ChannelMsg.toChannel 0) - Ctrl.modulation - (hertz 500, hertz 2000) (hertz 1000)) - - -bubbles :: IO () -bubbles = do - proc <- - CausalP.processIO - (0.95 * (CausalP.osciSimple Wave.sine $< 0) - . - (fst.fst * (1 + snd.fst * snd)) - . - Arr.second (CausalP.osciSimple Wave.saw $< 0)) - playFromEvents 0.01 (0.015::Double) - ((proc () :: - PIO.T - (Zip.T - (Zip.T - (EventListBT.T NonNegW.Int Float) - (EventListBT.T NonNegW.Int Float)) - (EventListBT.T NonNegW.Int Float)) - (SV.Vector Float)) - . - PIO.zip - (PIO.zip - (PALSA.controllerExponential - (ChannelMsg.toChannel 0) - Ctrl.modulation - (hertz 500, hertz 2000) (hertz 1000)) - (PALSA.controllerLinear - (ChannelMsg.toChannel 0) - Ctrl.timbre - (-1, 1) (-0.1))) - (PALSA.controllerExponential - (ChannelMsg.toChannel 0) - Ctrl.soundVariation - (hertz 1, hertz 10) (hertz 1))) - -bubblesSet :: IO () -bubblesSet = do - proc <- - CausalP.processIOCore - (PIn.controllerSet d6) - (CausalP.arrayElement d0 * - (CausalP.osciSimple Wave.sine $< 0) - . - (CausalP.arrayElement d1 - * - (1 - CausalP.arrayElement d2 * - (CausalP.osciSimple Wave.saw $< 0) . - CausalP.arrayElement d3) - * - (1 - CausalP.arrayElement d4 * - (CausalP.osciSimple Wave.saw $< 0) . - CausalP.arrayElement d5))) - POut.storableVector - 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)) - - -subsamplePCS :: PCS.T key a -> PCS.T key a -subsamplePCS = - PCS.mapStream $ - flip State.evalState NonNeg.zero . - EventListTT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" $ fromIntegral vectorSize)) - -bubblesPacked :: IO () -bubblesPacked = do - proc <- - CausalP.processIOCore - (PIn.controllerSet d6) - (CausalPS.arrayElement d0 * - (CausalPS.osciSimple Wave.approxSine4 $< 0) - . - (CausalPS.arrayElement d1 - * - (1 - CausalPS.arrayElement d2 * - (CausalPS.osciSimple Wave.saw $< 0) . - CausalPS.arrayElement d3) - * - (1 - CausalPS.arrayElement d4 * - (CausalPS.osciSimple Wave.saw $< 0) . - CausalPS.arrayElement d5))) - POut.storableVector - playFromEvents 0.01 (vectorBlockSize/sampleRate) - (arr SigStL.unpackStrict - . - (proc () :: PIO.T (PCS.T Int Float) (SV.Vector Vector)) - . - 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)) - - -moveAround2dFloat :: - Float -> Float -> (Float, Float) -> - CausalP.T p - (Value Float, Value Float) - (Value Float, Value Float) -moveAround2dFloat att sonicDelay (earX,earY) = - CausalP.mapSimple - (Value.flatten . - Spatial.moveAround - (Value.constant att) (Value.constant sonicDelay) - (Value.constant earX, Value.constant earY) . - Value.unfold) - -moveAround2d :: - (Ring.C a, LLVM.IsConst a, SoV.Replicate a v, LLVM.IsFloating v) => - a -> a -> (a, a) -> - CausalP.T p - (Value v, Value v) - (Value v, Value v) -moveAround2d att sonicDelay (earX,earY) = --- (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . Euc.norm . subtract ear - CausalP.mapSimple $ \(objX,objY) -> do - dist <- - euclideanNorm2d =<< liftA2 (,) - (A.sub objX (SoV.replicateOf earX)) - (A.sub objY (SoV.replicateOf earY)) - delay <- A.mul dist (SoV.replicateOf sonicDelay) - volume <- A.fdiv (SoV.replicateOf Ring.one) - =<< A.square =<< A.add dist (SoV.replicateOf att) - return (delay, volume) - -euclideanNorm2d :: - (LLVM.IsFloating a) => - (Value a, Value a) -> - LLVM.CodeGenFunction r (Value a) -euclideanNorm2d (x,y) = do - x2 <- A.square x - y2 <- A.square y - A.sqrt =<< A.add x2 y2 - -flyChannel :: - (Float, Float) -> - CausalP.T p (Value Float, Value Float) (Value Float) -flyChannel ear = - ((moveAround2d 1 0.1 ear >>> Arr.first (negate id)) - &&& - (250/sampleRate + - 2 * (CausalP.mapSimple euclideanNorm2d <<< (CausalP.differentiate $# (0::Float, 0::Float))))) - >>> - arr (\((phase,volume), speed) -> (volume, (phase,speed))) - >>> - Arr.second (CausalP.osciSimple Wave.saw) - >>> - CausalP.envelope - >>> - CausalP.amplify 10 - -fly :: IO () -fly = do - let slow = - Filt1.lowpassCausalP $<# - Filt1Core.parameter (1/sampleRate::Float) - let fast = - Filt1.lowpassCausalP $<# - Filt1Core.parameter (30/sampleRate::Float) - proc <- - CausalP.processIOCore - (PIn.controllerSet d4) - ((CausalP.arrayElement d0 &&& - (liftA2 (,) - ((CausalP.arrayElement d2 >>> slow) - + - CausalP.arrayElement d1 * - (CausalP.fromSignal (GenP.noise 366210 0.3) >>> fast >>> fast)) - ((CausalP.arrayElement d3 >>> slow) - + - CausalP.arrayElement d1 * - (CausalP.fromSignal (GenP.noise 234298 0.3) >>> fast >>> fast)) - >>> - liftA2 Stereo.cons - (flyChannel (-1,0)) - (flyChannel ( 1,0)))) - >>> - CausalP.envelopeStereo) - POut.storableVector - playFromEvents 0.01 (0.015::Double) - ((proc () :: PIO.T (PCS.T Int Float) (SV.Vector (Stereo.T Float))) - . - MCS.filter [ - MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2, - MCS.controllerLinear Ctrl.modulation (0, 5) 2, -{- - MCS.pitchBend (hertz 500, hertz 2000) (hertz 1000), --} - MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, - MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] - . - MCS.fromChannel (ChannelMsg.toChannel 0)) - - -flyChannelPacked :: - (Float, Float) -> - CausalP.T p (Value Vector, Value Vector) (Value Vector) -flyChannelPacked ear = - ((moveAround2d 1 0.1 ear >>> Arr.first (negate id)) - &&& - (250/sampleRate + - 2 * (CausalP.mapSimple euclideanNorm2d <<< (CausalPS.differentiate $# (0::Float, 0::Float))))) - >>> - arr (\((phase,volume), speed) -> (volume, (phase,speed))) - >>> - Arr.second (CausalPS.osciSimple Wave.saw) - >>> - CausalP.envelope - >>> - CausalPS.amplify 10 - -flyPacked :: IO () -flyPacked = do - let slow = - Filt1.lowpassCausalPackedP $<# - Filt1Core.parameter (1/sampleRate::Float) - let fast = - Filt1.lowpassCausalPackedP $<# - Filt1Core.parameter (30/sampleRate::Float) - proc <- - CausalP.processIOCore - (PIn.controllerSet d4) - ((CausalPS.arrayElement d0 &&& - (liftA2 (,) - ((CausalPS.arrayElement d2 >>> slow) - + - CausalPS.arrayElement d1 * - (CausalP.fromSignal (GenPS.noise 366210 0.3) >>> fast >>> fast)) - ((CausalPS.arrayElement d3 >>> slow) - + - CausalPS.arrayElement d1 * - (CausalP.fromSignal (GenPS.noise 234298 0.3) >>> fast >>> fast)) - >>> - liftA2 Stereo.cons - (flyChannelPacked (-1,0)) - (flyChannelPacked ( 1,0)))) - >>> - CausalP.envelopeStereo - >>> - CausalP.mapSimple StereoInt.interleave) - POut.storableVector - playFromEvents 0.01 (vectorBlockSize/sampleRate) - (arr SigStL.unpackStereoStrict - . - (proc () :: PIO.T (PCS.T Int Float) (SV.Vector (StereoInt.T VectorSize Float))) - . - arr subsamplePCS - . - MCS.filter [ - MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2, - MCS.controllerLinear Ctrl.modulation (0, 5) 2, -{- - MCS.pitchBend (hertz 500, hertz 2000) (hertz 1000), --} - MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, - MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] - . - MCS.fromChannel (ChannelMsg.toChannel 0)) diff --git a/src/Synthesizer/LLVM/MIDI.hs b/src/Synthesizer/LLVM/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/MIDI.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{- | +Convert MIDI events of a MIDI controller to a control signal. +-} +module Synthesizer.LLVM.MIDI ( + module Synthesizer.LLVM.MIDI, + Gen.applyModulation, + ) where + +import qualified Synthesizer.MIDI.Generic as Gen +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import Synthesizer.LLVM.CausalParameterized.Process (($>), ) +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Parameter as Param +import qualified Synthesizer.LLVM.Wave as Wave + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Core as LLVM +import LLVM.Core (IsSized, SizeOf, ) + +import qualified Types.Data.Bool as TypeBool +import qualified Types.Data.Num as TypeNum +import Types.Data.Num.Ops ((:*:), ) + +import Foreign.Storable (Storable, ) + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Control.Arrow (second, (<<<), (<<^), ) +import Control.Monad ({- liftM, -} liftM2, ) + +-- import NumericPrelude.Base +import NumericPrelude.Numeric +import Prelude () + + +{- +{-# INLINE piecewiseConstantInit #-} +piecewiseConstantInit :: + (Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl, + Memory.C yl ym, LLVM.IsSized ym ys) => + y -> EventListTT.T LazyTime y -> SigP.T p yl +piecewiseConstantInit initial evs = + SigP.piecewiseConstant $# + (PC.subdivideInt $ + EventListMT.consBody initial evs) + + +{-# INLINE controllerLinear #-} +controllerLinear :: + (Field.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl, + Memory.C yl ym, LLVM.IsSized ym ys) => + Channel -> Controller -> + (y,y) -> y -> + Filter (SigP.T p yl) +controllerLinear chan ctrl bnd initial = + liftM (piecewiseConstantInit initial . + EventListTT.mapBody (MV.controllerLinear bnd)) $ + getControllerEvents chan ctrl + + +{-# INLINE controllerExponential #-} +controllerExponential :: + (Trans.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl, + Memory.C yl ym, LLVM.IsSized ym ys) => + Channel -> Controller -> + (y,y) -> y -> + Filter (SigP.T p yl) +controllerExponential chan ctrl bnd initial = + liftM (piecewiseConstantInit initial . + EventListTT.mapBody (MV.controllerExponential bnd)) $ + getControllerEvents chan ctrl + + +{- | +@pitchBend channel range center@: +emits frequencies on an exponential scale from +@center/range@ to @center*range@. +-} +{-# INLINE pitchBend #-} +pitchBend :: + (Trans.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl, + Memory.C yl ym, LLVM.IsSized ym ys) => + Channel -> + y -> y -> + Filter (SigP.T p yl) +pitchBend chan range center = + liftM (piecewiseConstantInit center . + EventListTT.mapBody (MV.pitchBend range center)) $ + getSlice (maybePitchBend chan) +-- getPitchBendEvents chan + +{-# INLINE channelPressure #-} +channelPressure :: + (Trans.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl, + Memory.C yl ym, LLVM.IsSized ym ys) => + Channel -> + y -> y -> + Filter (SigP.T p yl) +channelPressure chan maxVal initVal = + liftM (piecewiseConstantInit initVal . + EventListTT.mapBody (MV.controllerLinear (0,maxVal))) $ + getSlice (maybeChannelPressure chan) + + +{-# INLINE bendWheelPressure #-} +bendWheelPressure :: + (Ring.C a, LLVM.IsConst a, + RealField.C y, Trans.C y, + LLVM.IsConst y, SoV.Fraction y, a ~ SoV.Scalar y, SoV.Replicate y, + Storable y, Class.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) => + Channel -> + Int -> y -> y -> y -> + Filter (SigP.T p (LLVM.Value y)) +bendWheelPressure chan + pitchRange speed wheelDepth pressDepth = + do bend <- pitchBend chan + (2^?(fromIntegral pitchRange/12) `asTypeOf` speed) 1 + fm <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0 + press <- channelPressure chan pressDepth 0 + return $ + SigP.envelope bend $ + SigP.mapSimple (A.add (LLVM.valueOf 1)) $ + SigP.envelope + (SigP.mix fm press) + (SigP.osciSimple Wave.approxSine2 zero $# speed) +-} + + +frequencyFromBendModulation :: + (Additive.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl, + A.PseudoRing yl, A.Fraction yl, A.IntegerConstant yl, Memory.C yl) => + Param.T p y -> + CausalP.T p (BM.T yl) yl +frequencyFromBendModulation speed = + CausalP.envelope + <<< + second + (CausalP.mapSimple (A.add (A.fromInteger' 1)) <<< CausalP.envelope + $> SigP.osciSimple Wave.approxSine2 zero speed) + <<^ + (\(BM.Cons b m) -> (b,m)) + + +frequencyFromBendModulationPacked :: + (RealField.C a, LLVM.IsConst a, LLVM.IsFloating a, + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, + LLVM.IsPrimitive am, + Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ (LLVM.Value a), + Vector.Real a, SoV.IntegerConstant a, + TypeNum.PositiveT n, TypeNum.IsPositive n ~ TypeBool.True, + TypeNum.PositiveT (n :*: SizeOf a), + TypeNum.PositiveT (n :*: SizeOf am)) => + Param.T p a -> + CausalP.T p (BM.T (LLVM.Value a)) (Serial.Value n a) +frequencyFromBendModulationPacked speed = + CausalP.envelope + <<< + second + (CausalP.mapSimple (A.add (A.fromInteger' 1)) <<< CausalP.envelope + $> SigPS.osciSimple Wave.approxSine2 zero speed) + <<< + CausalP.mapSimple + (\(BM.Cons b m) -> + liftM2 (,) (Serial.upsample b) (Serial.upsample m)) diff --git a/src/Synthesizer/LLVM/MIDI/BendModulation.hs b/src/Synthesizer/LLVM/MIDI/BendModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/MIDI/BendModulation.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- | +Various LLVM related instances of the BM.T type. +I have setup a separate module since these instances are orphan +and need several language extensions. +-} +module Synthesizer.LLVM.MIDI.BendModulation ( + BM.T(..), + BM.deflt, + BM.shift, + ) where + +import qualified Synthesizer.MIDI.Value.BendModulation as BM +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F + +import qualified LLVM.Extra.Vector as Vector +import qualified LLVM.Extra.Class as Class +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Control as C +import qualified LLVM.Util.Loop as Loop +import qualified LLVM.Core as LLVM + +import Control.Applicative (liftA2, ) +import qualified Types.Data.Num as TypeNum + + +instance (Class.Zero a) => Class.Zero (BM.T a) where + zeroTuple = Class.zeroTuplePointed + +{- +instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BM.T a) where + buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f) + +instance LLVM.IsTuple a => LLVM.IsTuple (BM.T a) where + tupleDesc = Class.tupleDescFoldable +-} + +instance (Class.Undefined a) => Class.Undefined (BM.T a) where + undefTuple = Class.undefTuplePointed + +instance (C.Select a) => C.Select (BM.T a) where + select = C.selectTraversable + +{- +instance LLVM.CmpRet a, LLVM.CmpResult a ~ b => + LLVM.CmpRet (BM.T a) (BM.T b) where +-} + +instance Class.MakeValueTuple h => + Class.MakeValueTuple (BM.T h) where + type ValueTuple (BM.T h) = BM.T (Class.ValueTuple h) + valueTupleOf = Class.valueTupleOfFunctor + + +type Struct a = LLVM.Struct (a, (a, ())) + +memory :: + (Memory.C l) => + Memory.Record r (Struct (Memory.Struct l)) (BM.T l) +memory = + liftA2 BM.Cons + (Memory.element BM.bend TypeNum.d0) + (Memory.element BM.depth TypeNum.d1) + +instance (Memory.C l) => Memory.C (BM.T l) where + type Struct (BM.T l) = Struct (Memory.Struct l) + load = Memory.loadRecord memory + store = Memory.storeRecord memory + decompose = Memory.decomposeRecord memory + compose = Memory.composeRecord memory + + +instance (Loop.Phi a) => Loop.Phi (BM.T a) where + phis = Class.phisTraversable + addPhis = Class.addPhisFoldable + + +instance (Vector.Simple v) => Vector.Simple (BM.T v) where + type Element (BM.T v) = BM.T (Vector.Element v) + type Size (BM.T v) = Vector.Size v + shuffleMatch = Vector.shuffleMatchTraversable + extract = Vector.extractTraversable + +instance (Vector.C v) => Vector.C (BM.T v) where + insert = Vector.insertTraversable + + +type instance F.Arguments f (BM.T a) = f (BM.T a) +instance F.MakeArguments (BM.T a) where + makeArgs = id 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 @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Parameter where import qualified LLVM.Extra.Class as Class @@ -68,7 +69,7 @@ For small loop counts and simple loop bodies the loop might get unrolled. -} value :: - Class.MakeValueTuple tuple value => + (Class.MakeValueTuple tuple, Class.ValueTuple tuple ~ value) => T p tuple -> value -> value value (Constant a) _ = Class.valueTupleOf a value (Variable _) v = v 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 @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Parameterized.Signal ( @@ -39,16 +39,17 @@ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.ScalarOrVector as SoV import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) -import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Core as LLVM import qualified LLVM.Util.Loop as Loop -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import Control.Monad.HT ((<=<), ) import Control.Monad (liftM2, liftM3, when, ) import Control.Arrow ((^<<), ) import Control.Applicative (liftA2, ) +import Control.Functor.HT (void, ) import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField @@ -63,11 +64,10 @@ import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, ) import qualified Synthesizer.LLVM.Alloc as Alloc -import Foreign.ForeignPtr - (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, ) +import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, ) import Foreign.Ptr (FunPtr, nullPtr, ) import Control.Exception (bracket, ) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) +import qualified System.Unsafe as Unsafe import qualified Synthesizer.LLVM.Debug.Storable as DebugSt import qualified Synthesizer.LLVM.Debug.Counter as Counter @@ -86,9 +86,9 @@ mapAccum :: - (Storable pnh, MakeValueTuple pnh pnl, Memory.C pnl pnp, IsSized pnp pns, - Storable psh, MakeValueTuple psh psl, Memory.C psl psp, IsSized psp pss, - Memory.C s struct, IsSized struct sa) => + (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl, + Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl, + Memory.C s) => (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) -> (forall r. psl -> CodeGenFunction r s) -> Param.T p pnh -> @@ -216,11 +216,11 @@ or if the input value differs from the last processed one by a certain amount. -} interpolateConstant :: - (Memory.C a struct, IsSized struct size, + (Memory.C a, Ring.C b, - IsFloating b, CmpRet b Bool, - Storable b, MakeValueTuple b (Value b), IsConst b, - Memory.FirstClass b bm, IsSized b bsize, IsSized bm bmsize) => + IsFloating b, CmpRet b, CmpResult b ~ Bool, + Storable b, MakeValueTuple b, ValueTuple b ~ (Value b), IsConst b, + Memory.FirstClass b, IsSized b, IsSized (Memory.Stored b)) => Param.T p b -> T p a -> T p a interpolateConstant k (Cons next start createIOContext deleteIOContext) = @@ -274,14 +274,14 @@ amplify :: (A.PseudoRing al, Storable a, - MakeValueTuple a al, Memory.C al am, IsSized am as) => + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al -> T p al amplify = map Frame.amplifyMono amplifyStereo :: (A.PseudoRing al, Storable a, - MakeValueTuple a al, Memory.C al am, IsSized am as) => + MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p (Stereo.T al) -> T p (Stereo.T al) amplifyStereo = map Frame.amplifyStereo @@ -290,8 +290,8 @@ -- * signal generators constant :: - (Storable a, MakeValueTuple a al, - Memory.C al packed, IsSized packed s) => + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al) => Param.T p a -> T p al constant x = simple @@ -302,15 +302,15 @@ exponentialCore :: - (Storable a, MakeValueTuple a al, - Memory.C al am, IsSized am as, A.PseudoRing al) => + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.PseudoRing al) => Param.T p a -> Param.T p a -> T p al exponentialCore = iterate A.mul exponential2 :: - (Trans.C a, Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a s, IsSized am amsize, + (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a), IsArithmetic a, IsConst a) => Param.T p a -> Param.T p a -> T p (Value a) exponential2 halfLife = @@ -318,8 +318,8 @@ exponentialBoundedCore :: - (Storable a, MakeValueTuple a al, - Memory.C al am, IsSized am as, A.PseudoRing al, A.Real al) => + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.PseudoRing al, A.Real al) => Param.T p a -> Param.T p a -> Param.T p a -> T p al exponentialBoundedCore bound decay = @@ -334,8 +334,8 @@ The initial value and the bound value must be positive. -} exponentialBounded2 :: - (Trans.C a, Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a s, IsSized am amsize, + (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a), SoV.Real a, IsConst a) => Param.T p a -> Param.T p a -> Param.T p a -> T p (Value a) @@ -344,19 +344,18 @@ osciCore :: - (Storable t, MakeValueTuple t tl, - Memory.C tl tm, IsSized tm ts, A.Fraction tl) => + (Storable t, MakeValueTuple t, ValueTuple t ~ tl, + Memory.C tl, A.Fraction tl) => Param.T p t -> Param.T p t -> T p tl osciCore phase freq = iterate A.incPhase freq phase osci :: - (Storable t, MakeValueTuple t (Value t), - Storable c, MakeValueTuple c cl, - Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize, - Memory.C cl cp, IsSized cp cs, - SoV.Fraction t, IsConst t) => - (forall r. cl -> Value t -> CodeGenFunction r y) -> + (Storable t, MakeValueTuple t, ValueTuple t ~ tl, + Storable c, MakeValueTuple c, ValueTuple c ~ cl, + Memory.C cl, + Memory.C tl, A.Fraction tl, A.IntegerConstant tl) => + (forall r. cl -> tl -> CodeGenFunction r y) -> Param.T p c -> Param.T p t -> Param.T p t -> T p y osci wave waveParam phase freq = @@ -364,37 +363,32 @@ osciCore phase freq osciSimple :: - (Storable t, MakeValueTuple t (Value t), - Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize, - SoV.Fraction t, IsConst t) => - (forall r. Value t -> CodeGenFunction r y) -> + (Storable t, MakeValueTuple t, ValueTuple t ~ tl, + Memory.C tl, A.Fraction tl, A.IntegerConstant tl) => + (forall r. tl -> CodeGenFunction r y) -> Param.T p t -> Param.T p t -> T p y osciSimple wave = osci (const wave) (return ()) osciSaw :: - (Ring.C a0, IsConst a0, SoV.Replicate a0 a, - Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, - SoV.Fraction a, IsPrimitive a, IsConst a) => - Param.T p a -> Param.T p a -> T p (Value a) + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.PseudoRing al, A.Fraction al, A.IntegerConstant al) => + Param.T p a -> Param.T p a -> T p al osciSaw = osciSimple Wave.saw rampCore :: - (Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, - IsArithmetic a, IsConst a) => - Param.T p a -> Param.T p a -> T p (Value a) + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.Additive al, A.IntegerConstant al) => + Param.T p a -> Param.T p a -> T p al rampCore = iterate A.add parabolaCore :: - (Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, - IsArithmetic a, IsConst a) => - Param.T p a -> Param.T p a -> Param.T p a -> T p (Value a) + (Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.Additive al, A.IntegerConstant al) => + Param.T p a -> Param.T p a -> Param.T p a -> T p al parabolaCore d2 d1 start = Causal.apply (Causal.integrate start) $ rampCore d2 d1 @@ -403,10 +397,9 @@ rampInf, rampSlope, parabolaFadeInInf, parabolaFadeOutInf :: - (Field.C a, Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, - IsArithmetic a, IsConst a) => - Param.T p a -> T p (Value a) + (Field.C a, Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.Additive al, A.IntegerConstant al) => + Param.T p a -> T p al rampSlope slope = rampCore slope Additive.zero rampInf dur = rampSlope (recip dur) @@ -439,10 +432,9 @@ ramp, parabolaFadeIn, parabolaFadeOut, parabolaFadeInMap, parabolaFadeOutMap :: - (RealField.C a, Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, - IsArithmetic a, IsConst a) => - Param.T p a -> T p (Value a) + (RealField.C a, Storable a, MakeValueTuple a, ValueTuple a ~ al, + Memory.C al, A.PseudoRing al, A.IntegerConstant al) => + Param.T p a -> T p al ramp dur = Causal.apply (Causal.take (fmap round dur)) $ @@ -458,12 +450,12 @@ parabolaFadeInMap dur = -- t*(2-t) - Causal.apply (Causal.mapSimple (\t -> A.mul t =<< A.sub (valueOf 2) t)) $ + Causal.apply (Causal.mapSimple (\t -> A.mul t =<< A.sub (A.fromInteger' 2) t)) $ ramp dur parabolaFadeOutMap dur = -- 1-t^2 - Causal.apply (Causal.mapSimple (\t -> A.sub (valueOf 1) =<< A.mul t t)) $ + Causal.apply (Causal.mapSimple (\t -> A.sub (A.fromInteger' 1) =<< A.mul t t)) $ ramp dur @@ -486,9 +478,9 @@ -} noise :: (Algebraic.C a, IsFloating a, IsConst a, - NumberOfElements TypeNum.D1 a, - Memory.C (Value a) as, IsSized as sas, - IsSized a ps, MakeValueTuple a (Value a), Storable a) => + NumberOfElements a ~ TypeNum.D1, + Memory.C (Value a), + IsSized a, MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) => Param.T p Word32 -> Param.T p a -> T p (Value a) @@ -506,11 +498,11 @@ and thus we use it, since the arguments are below 2^31. -} int31tofp :: - (IsFloating a, LLVM.NumberOfElements TypeNum.D1 a) => + (IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) => Value Word32 -> CodeGenFunction r (Value a) int31tofp = LLVM.inttofp <=< - (LLVM.bitcastUnify :: + (LLVM.bitcast :: Value Word32 -> CodeGenFunction r (Value Int32)) noiseCore, noiseCoreAlt :: @@ -528,7 +520,7 @@ -- * conversion from and to storable vectors fromStorableVector :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => Param.T p (SV.Vector a) -> T p value fromStorableVector selectVec = @@ -545,7 +537,7 @@ let (fp,s,l) = SVB.toForeignPtr $ Param.get selectVec p in return (fp, ((), - (Memory.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s, + (Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s, fromIntegral l :: Word32)))) -- keep the foreign ptr alive touchForeignPtr @@ -556,7 +548,7 @@ and advances to the next chunk in the sequence. -} fromStorableVectorLazy :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => Param.T p (SVL.Vector a) -> T p value fromStorableVectorLazy sig = @@ -586,7 +578,7 @@ piecewiseConstant :: - (Storable a, MakeValueTuple a value, Memory.C value struct, IsSized struct size) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => Param.T p (EventList.T NonNeg.Int a) -> T p value piecewiseConstant = @@ -610,7 +602,7 @@ Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32) run :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> IO (Int -> p -> SV.Vector a) run (Cons next start createIOContext deleteIOContext) = @@ -629,7 +621,7 @@ ret (pos :: Value Word32) return $ \len p -> - unsafePerformIO $ + Unsafe.performIO $ bracket (createIOContext p) (deleteIOContext . fst) $ \ (_,params) -> SVB.createAndTrim len $ \ ptr -> @@ -642,9 +634,9 @@ This is not really a function, see 'renderChunky'. -} render :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> Int -> p -> SV.Vector a -render gen = unsafePerformIO $ run gen +render gen = Unsafe.performIO $ run gen foreign import ccall safe "dynamic" derefChunkPtr :: @@ -652,13 +644,10 @@ moduleChunky :: - (Memory.C value struct, - Memory.C state stateStruct, - IsSized stateStruct stateSize, - Memory.C startParamValue startParamStruct, - Memory.C nextParamValue nextParamStruct, - IsSized startParamStruct startParamSize, - IsSized nextParamStruct nextParamSize) => + (Memory.C value, Memory.Struct value ~ struct, + Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct, + Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct) => (forall r. nextParamValue -> state -> Maybe.T r (Value Bool, state) (value, state)) -> @@ -689,13 +678,10 @@ ret (pos :: Value Word32)) compileChunky :: - (Memory.C value struct, - Memory.C state stateStruct, - IsSized stateStruct stateSize, - Memory.C startParamValue startParamStruct, - Memory.C nextParamValue nextParamStruct, - IsSized startParamStruct startParamSize, - IsSized nextParamStruct nextParamSize) => + (Memory.C value, Memory.Struct value ~ struct, + Memory.C state, Memory.Struct state ~ stateStruct, + Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct, + Memory.C nextParamValue, Memory.Struct nextParamValue ~ nextParamStruct) => (forall r. nextParamValue -> state -> Maybe.T r (Value Bool, state) (value, state)) -> @@ -711,16 +697,16 @@ debugMain :: forall struct stateStruct - startParamValue startParamStruct startParamSize - nextParamValue nextParamStruct nextParamSize. + startParamValue startParamStruct + nextParamValue nextParamStruct. (Storable startParamValue, Storable nextParamValue, LLVM.IsType struct, LLVM.IsType stateStruct, LLVM.IsType startParamStruct, LLVM.IsType nextParamStruct, - IsSized startParamStruct startParamSize, - IsSized nextParamStruct nextParamSize) => + IsSized startParamStruct, + IsSized nextParamStruct) => CodeGenModule (Function (Ptr startParamStruct -> IO (Ptr stateStruct)), Function (Ptr stateStruct -> IO ()), @@ -735,17 +721,17 @@ DebugSt.withConstArray nextParam (\arr -> do ptr <- LLVM.alloca LLVM.store (value arr) ptr - LLVM.bitcastUnify ptr) + LLVM.bitcast ptr) -} nextArray <- DebugSt.withConstArray nextParam (\arr -> do ptr <- LLVM.alloca - LLVM.store (value arr) =<< LLVM.bitcastUnify ptr + LLVM.store (value arr) =<< LLVM.bitcast ptr return ptr) startArray <- DebugSt.withConstArray startParam (\arr -> do ptr <- LLVM.alloca - LLVM.store (value arr) =<< LLVM.bitcastUnify ptr + LLVM.store (value arr) =<< LLVM.bitcast ptr return ptr) m <- LLVM.newModule @@ -760,7 +746,7 @@ basePtr = LLVM.valueOf nullPtr buffer <- LLVM.call mallocBytes =<< - LLVM.bitcastUnify =<< + LLVM.bitcast =<< LLVM.getElementPtr basePtr (chunkSize, ()) nextPtr <- nextArray _done <- @@ -781,13 +767,13 @@ this means that the signal is shortened. -} runChunkyPattern :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> IO (SVP.LazySize -> p -> SVL.Vector a) runChunkyPattern (Cons next start createIOContext deleteIOContext) = do (startFunc, stopFunc, fill) <- compileChunky next start return $ - \ lazysize p -> SVL.fromChunks $ unsafePerformIO $ do + \ lazysize p -> SVL.fromChunks $ Unsafe.performIO $ do (ioContext, (nextParam, startParam)) <- createIOContext p {- @@ -798,14 +784,14 @@ DebugSt.dump "next-param" nextParam DebugSt.dump "start-param" startParam - when False $ fmap (const ()) $ + when False $ void $ debugMain (moduleChunky next start) (nextParam, startParam) statePtr <- ForeignPtr.newParam stopFunc startFunc startParam nextParamPtr <- ForeignPtr.new (deleteIOContext ioContext) nextParam let go cs = - unsafeInterleaveIO $ + Unsafe.interleaveIO $ case cs of [] -> return [] SVL.ChunkSize size : rest -> do @@ -825,7 +811,7 @@ go (Chunky.toChunks lazysize) runChunky :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> IO (SVL.ChunkSize -> p -> SVL.Vector a) runChunky sig = @@ -843,8 +829,8 @@ and I assume that you use this package exclusively for performance reasons. -} renderChunky :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => SVL.ChunkSize -> T p value -> p -> SVL.Vector a renderChunky size gen = - unsafePerformIO (runChunky gen) size + Unsafe.performIO (runChunky gen) size diff --git a/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs b/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs --- a/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs +++ b/src/Synthesizer/LLVM/Parameterized/SignalPacked.hs @@ -1,9 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} @@ -28,7 +26,7 @@ import Synthesizer.LLVM.Parameterized.Signal (T(Cons), ) import qualified Synthesizer.LLVM.Parameterized.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param -import qualified Synthesizer.LLVM.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Random as Rnd import qualified LLVM.Extra.Memory as Memory @@ -36,15 +34,19 @@ import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Control as U -import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A -import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Bool as TypeBool +import qualified Types.Data.Num as TypeNum +import Types.Data.Num ((:*:), ) import LLVM.Core as LLVM +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS import Control.Monad.HT ((<=<), ) +import Control.Monad (replicateM, ) -- we can also use <$> for parameters import Control.Arrow ((^<<), ) import Control.Applicative (liftA2, ) @@ -70,33 +72,45 @@ If the signal length is not divisible by the chunk size, then the last chunk is dropped. -} -pack, packRotate, packIndex :: - (Vector.Access n a v) => +pack, packRotate :: + (Serial.C v, a ~ Serial.Element v) => T p a -> T p v pack = packRotate packRotate (Cons next start createIOContext deleteIOContext) = Cons (\param s -> do - (v2,_,s2) <- + wInit <- Maybe.lift $ Serial.writeStart + (w2,_,s2) <- Maybe.fromBool $ U.whileLoop (valueOf True, - let v = undefTuple - in (v, valueOf $ (fromIntegral $ Vector.sizeInTuple v :: Word32), s)) - (\(cont,(_v0,i0,_s0)) -> + (wInit, + valueOf $ (fromIntegral $ Serial.sizeOfIterator wInit :: Word32), + s)) + (\(cont,(_w0,i0,_s0)) -> A.and cont =<< A.cmp CmpGT i0 (value LLVM.zero)) - (\(_,(v0,i0,s0)) -> Maybe.toBool $ do + (\(_,(w0,i0,s0)) -> Maybe.toBool $ do (a,s1) <- next param s0 Maybe.lift $ do - v1 <- fmap snd $ Vector.shiftDown a v0 + w1 <- Serial.writeNext a w0 i1 <- A.dec i0 - return (v1,i1,s1)) - return (v2, s2)) + return (w1,i1,s1)) + v <- Maybe.lift $ Serial.writeStop w2 + return (v, s2)) start createIOContext deleteIOContext +{- +We could reformulate it in terms of WriteIterator +that accesses elements using LLVM.extract. +We might move the loop counter into the Iterator, +but we have to assert that the counter is not duplicated. + +packIndex :: + (Serial.C v, a ~ Serial.Element v) => + T p a -> T p v packIndex (Cons next start createIOContext deleteIOContext) = Cons (\param s -> do (v2,_,s2) <- @@ -106,7 +120,7 @@ (\(cont,(v0,i0,_s0)) -> A.and cont =<< A.cmp CmpLT i0 - (valueOf $ fromIntegral $ Vector.sizeInTuple v0)) + (valueOf $ fromIntegral $ Serial.size v0)) (\(_,(v0,i0,s0)) -> Maybe.toBool $ do (a,s1) <- next param s0 Maybe.lift $ do @@ -117,6 +131,7 @@ start createIOContext deleteIOContext +-} {- | @@ -126,54 +141,62 @@ This is efficient only for simple input generators. -} packSmall :: - (Vector.Access n a v, Class.Zero v) => + (Serial.C v, a ~ Serial.Element v) => T p a -> T p v packSmall (Cons next start createIOContext deleteIOContext) = Cons - (\param s -> - let vundef = undefTuple - in foldr - (\i rest (v0,s0) -> do - (a,s1) <- next param s0 - v1 <- Maybe.lift $ Vector.insert (valueOf i) a v0 - rest (v1,s1)) - return - (take (Vector.sizeInTuple vundef) [0..]) - (vundef, s)) + (\param -> + MS.runStateT $ + case undefined of + vundef -> + fmap (flip asTypeOf vundef) . + MT.lift . Maybe.lift . Serial.assemble + =<< + replicateM (Serial.size vundef) (MS.StateT $ next param)) start createIOContext deleteIOContext -unpack, unpackRotate, unpackIndex :: - (Vector.Access n a v, Memory.C v vp, IsSized vp vs) => +unpack, unpackRotate :: + (Serial.Read v, a ~ Serial.Element v, Memory.C (Serial.ReadIt v)) => T p v -> T p a unpack = unpackRotate unpackRotate (Cons next start createIOContext deleteIOContext) = Cons - (\param (i0,v0,s0) -> do + (\param (i0,r0,s0) -> do endOfVector <- - Maybe.lift $ A.cmp CmpEQ i0 (valueOf 0) - (i2,v2,s2) <- + Maybe.lift $ A.cmp CmpEQ i0 (valueOf (0::Word32)) + (i2,r2,s2) <- Maybe.fromBool $ - U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do + U.ifThen endOfVector (valueOf True, (i0,r0,s0)) $ do (cont1, (v1,s1)) <- Maybe.toBool $ next param s0 - return (cont1, (valueOf $ fromIntegral $ Vector.sizeInTuple v0, v1, s1)) + r1 <- Serial.readStart v1 + return (cont1, (valueOf $ fromIntegral $ Serial.size v1, r1, s1)) Maybe.lift $ do - a <- Vector.extract (valueOf 0 `asTypeOf` i0) v2 - v3 <- Vector.rotateDown v2 + (a,r3) <- Serial.readNext r2 i3 <- A.dec i2 - return (a, (i3,v3,s2))) + return (a, (i3,r3,s2))) (\p -> do s <- start p return (valueOf 0, undefTuple, s)) createIOContext deleteIOContext + +{- +We could reformulate it in terms of ReadIterator +that accesses elements using LLVM.extract. +We might move the loop counter into the Iterator, +but we have to assert that the counter is not duplicated. + +unpackIndex :: + (Serial.C v, a ~ Serial.Element v, Memory.C v) => + T p v -> T p a unpackIndex (Cons next start createIOContext deleteIOContext) = Cons (\param (i0,v0,s0) -> do endOfVector <- Maybe.lift $ A.cmp CmpGE i0 - (valueOf $ fromIntegral $ Vector.sizeInTuple v0) + (valueOf $ fromIntegral $ Serial.size v0) (i2,v2,s2) <- Maybe.fromBool $ U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do @@ -186,106 +209,107 @@ (\p -> do s <- start p let v = undefTuple - return (valueOf $ fromIntegral $ Vector.sizeInTuple v, v, s)) + return (valueOf $ fromIntegral $ Serial.size v, v, s)) createIOContext deleteIOContext +-} withSize :: - (n -> T p (Value (Vector n a))) -> - T p (Value (Vector n a)) + (n -> T p (Serial.Value n a)) -> + T p (Serial.Value n a) withSize f = f undefined withSizeRing :: - (Ring.C b, TypeNum.Nat n) => - (b -> T p (Value (Vector n a))) -> - T p (Value (Vector n a)) + (Ring.C b, TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + (b -> T p (Serial.Value n a)) -> + T p (Serial.Value n a) withSizeRing f = - withSize $ \n -> f (fromIntegral $ TypeNum.toInt n) + withSize $ \n -> f (fromInteger $ TypeNum.fromIntegerT n) constant :: - (Storable a, MakeValueTuple a (Value a), + (Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), IsConst a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a as, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => - Param.T p a -> T p (Value (Vector n a)) + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + Param.T p a -> T p (Serial.Value n a) constant x = Sig.constant (Serial.replicate ^<< x) exponential2 :: - (Trans.C a, Storable a, MakeValueTuple a (Value a), + (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), IsArithmetic a, IsConst a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a as, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => - Param.T p a -> Param.T p a -> T p (Value (Vector n a)) + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + Param.T p a -> Param.T p a -> T p (Serial.Value n a) exponential2 halfLife start = withSizeRing $ \n -> Sig.exponentialCore (Serial.replicate ^<< 0.5 ** (n / halfLife)) (liftA2 - (\h -> LLVM.vector . List.iterate (0.5 ** recip h *)) + (\h -> Serial.fromList . List.iterate (0.5 ** recip h *)) halfLife start) exponentialBounded2 :: - (Trans.C a, Storable a, MakeValueTuple a (Value a), + (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), Vector.Real a, IsConst a, - Memory.FirstClass a am, - IsPrimitive a, IsSized a as, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - TypeNum.Pos n) => + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => Param.T p a -> Param.T p a -> Param.T p a -> - T p (Value (Vector n a)) + T p (Serial.Value n a) exponentialBounded2 bound halfLife start = withSizeRing $ \n -> Sig.exponentialBoundedCore (fmap (Serial.replicate) bound) (Serial.replicate ^<< 0.5 ** (n / halfLife)) (liftA2 - (\h -> LLVM.vector . List.iterate (0.5 ** recip h *)) + (\h -> Serial.fromList . List.iterate (0.5 ** recip h *)) halfLife start) osciCore :: - (Storable t, MakeValueTuple t (Value t), - Memory.FirstClass t tm, - IsPrimitive t, IsSized t tsize, - IsPrimitive tm, IsSized tm tmsize, - TypeNum.Mul n tsize vtsize, TypeNum.Pos vtsize, - TypeNum.Mul n tmsize vmsize, TypeNum.Pos vmsize, + (Storable t, MakeValueTuple t, ValueTuple t ~ (Value t), + Memory.FirstClass t, Memory.Stored t ~ tm, + IsPrimitive t, IsSized t, SizeOf t ~ tsize, + IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize, + TypeNum.PositiveT (n :*: tsize), + TypeNum.PositiveT (n :*: tmsize), Vector.Real t, IsFloating t, RealField.C t, IsConst t, - TypeNum.Pos n) => - Param.T p t -> Param.T p t -> T p (Value (Vector n t)) + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + Param.T p t -> Param.T p t -> T p (Serial.Value n t) osciCore phase freq = withSizeRing $ \n -> Sig.osciCore (liftA2 - (\f -> LLVM.vector . List.iterate (fraction . (f +))) + (\f -> Serial.fromList . List.iterate (fraction . (f +))) freq phase) (fmap - (\f -> LLVM.vector [fraction (n * f)]) + (\f -> Serial.replicate (fraction (n * f))) freq) osci :: - (Storable t, MakeValueTuple t (Value t), - Storable c, MakeValueTuple c cl, - Memory.FirstClass t tm, - IsPrimitive t, IsSized t tsize, - IsPrimitive tm, IsSized tm tmsize, - TypeNum.Mul n tsize vtsize, TypeNum.Pos vtsize, - TypeNum.Mul n tmsize vmsize, TypeNum.Pos vmsize, - Memory.C cl cp, IsSized cp cs, + (Storable t, MakeValueTuple t, ValueTuple t ~ (Value t), + Storable c, MakeValueTuple c, ValueTuple c ~ cl, + Memory.FirstClass t, Memory.Stored t ~ tm, + IsPrimitive t, IsSized t, SizeOf t ~ tsize, + IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize, + TypeNum.PositiveT (n :*: tsize), + TypeNum.PositiveT (n :*: tmsize), + Memory.C cl, Vector.Real t, IsFloating t, RealField.C t, IsConst t, - TypeNum.Pos n) => - (forall r. cl -> Value (Vector n t) -> CodeGenFunction r y) -> + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + (forall r. cl -> Serial.Value n t -> CodeGenFunction r y) -> Param.T p c -> Param.T p t -> Param.T p t -> T p y osci wave waveParam phase freq = @@ -293,15 +317,15 @@ osciCore phase freq osciSimple :: - (Storable t, MakeValueTuple t (Value t), - Memory.FirstClass t tm, - IsPrimitive t, IsSized t tsize, - IsPrimitive tm, IsSized tm tmsize, - TypeNum.Mul n tsize vtsize, TypeNum.Pos vtsize, - TypeNum.Mul n tmsize vmsize, TypeNum.Pos vmsize, + (Storable t, MakeValueTuple t, ValueTuple t ~ (Value t), + Memory.FirstClass t, Memory.Stored t ~ tm, + IsPrimitive t, IsSized t, SizeOf t ~ tsize, + IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize, + TypeNum.PositiveT (n :*: tsize), + TypeNum.PositiveT (n :*: tmsize), Vector.Real t, IsFloating t, RealField.C t, IsConst t, - TypeNum.Pos n) => - (forall r. Value (Vector n t) -> CodeGenFunction r y) -> + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + (forall r. Serial.Value n t -> CodeGenFunction r y) -> Param.T p t -> Param.T p t -> T p y osciSimple wave = osci (const wave) (return ()) @@ -309,18 +333,19 @@ rampInf, rampSlope, parabolaFadeInInf, parabolaFadeOutInf :: - (RealField.C a, Storable a, MakeValueTuple a (Value a), - Memory.FirstClass a am, - IsPrimitive a, IsSized a as, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - IsArithmetic a, IsConst a, TypeNum.Pos n) => - Param.T p a -> T p (Value (Vector n a)) + (RealField.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a), + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + IsArithmetic a, SoV.IntegerConstant a, + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => + Param.T p a -> T p (Serial.Value n a) rampSlope slope = withSizeRing $ \n -> Sig.rampCore - (fmap (\s -> LLVM.vector [n * s]) slope) - (fmap (\s -> LLVM.vector (List.iterate (s +) 0)) slope) + (fmap (\s -> Serial.replicate (n * s)) slope) + (fmap (\s -> Serial.fromList (List.iterate (s +) 0)) slope) rampInf dur = rampSlope (recip dur) parabolaFadeInInf dur = withSizeRing $ \n -> @@ -328,15 +353,15 @@ (fmap (\dr -> let d = n / dr - in LLVM.vector [-2*d*d]) dur) + in Serial.replicate (-2*d*d)) dur) (fmap (\dr -> let d = n / dr - in LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d))) + in Serial.fromList $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d))) dur) (fmap (\dr -> - LLVM.vector $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0) + Serial.fromList $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0) dur) parabolaFadeOutInf dur = withSizeRing $ \n -> @@ -344,15 +369,15 @@ (fmap (\dr -> let d = n / dr - in LLVM.vector [-2*d*d]) dur) + in Serial.replicate (-2*d*d)) dur) (fmap (\dr -> let d = n / dr - in LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d)) + in Serial.fromList $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d)) dur) (fmap (\dr -> - LLVM.vector $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0) + Serial.fromList $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0) dur) @@ -360,24 +385,26 @@ For the mysterious rate parameter see 'Sig.noise'. -} noise :: - (Algebraic.C a, IsFloating a, IsConst a, - TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s, - Memory.FirstClass a am, - IsPrimitive a, IsSized a as, - IsPrimitive am, IsSized am amsize, - TypeNum.Mul n as vas, TypeNum.Pos vas, - TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize, - MakeValueTuple a (Value a), Storable a) => + (Algebraic.C a, IsFloating a, SoV.IntegerConstant a, + TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True, + TypeNum.PositiveT (n :*: TypeNum.D32), + Memory.FirstClass a, Memory.Stored a ~ am, + IsPrimitive a, IsSized a, SizeOf a ~ as, + IsPrimitive am, IsSized am, SizeOf am ~ amsize, + TypeNum.PositiveT (n :*: as), + TypeNum.PositiveT (n :*: amsize), + MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) => Param.T p Word32 -> Param.T p a -> - T p (Value (Vector n a)) + T p (Serial.Value n a) noise seed rate = - let m2 = fromInteger $ div Rnd.modulus 2 - in Sig.map (\r y -> - A.mul r - =<< flip A.sub (SoV.replicateOf $ m2+1) - =<< int31tofp y) - (Serial.replicate ^<< sqrt (3 * rate) / return m2) $ + let m2 = div Rnd.modulus 2 + in Sig.map + (\r y -> + A.mul r + =<< flip A.sub (A.fromInteger' $ m2+1) + =<< int31tofp y) + (Serial.replicate ^<< sqrt (3 * rate) / return (fromInteger m2)) $ noiseCore seed {- @@ -386,25 +413,29 @@ -} int31tofp :: (IsFloating a, IsPrimitive a, - TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s) => - Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n a)) + TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) => + Serial.Value n Word32 -> CodeGenFunction r (Serial.Value n a) int31tofp = + Serial.mapV $ LLVM.inttofp <=< - (LLVM.bitcastUnify :: - (TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s) => + (LLVM.bitcast :: + (TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Int32))) noiseCore, noiseCoreAlt :: - (TypeNum.Pos n, TypeNum.Mul n TypeNum.D32 s, TypeNum.Pos s) => + (TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True, + TypeNum.PositiveT (n :*: TypeNum.D32)) => Param.T p Word32 -> - T p (Value (Vector n Word32)) + T p (Serial.Value n Word32) noiseCore seed = + fmap Serial.value $ Sig.iterate (const Rnd.nextVector) (return ()) (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed) noiseCoreAlt seed = + fmap Serial.value $ Sig.iterate (const Rnd.nextVector64) (return ()) (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed) 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 @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Parameterized.SignalPrivate where @@ -8,8 +10,8 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A -import LLVM.Extra.Class (MakeValueTuple, ) -import LLVM.Core (IsSized, CodeGenFunction, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) +import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, ) import Control.Arrow ((&&&), ) @@ -26,7 +28,9 @@ import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) +import qualified Prelude as P + {- In this attempt we use a Haskell value as parameter supply. This is okay, since the Haskell value will be converted to internal parameters @@ -55,48 +59,42 @@ Consider a signal algorithm, where the LFO frequency is a parameter. -} data T p a = - forall state packed size ioContext - startParamTuple startParamValue startParamPacked startParamSize - nextParamTuple nextParamValue nextParamPacked nextParamSize. + forall state ioContext startParamTuple nextParamTuple. (Storable startParamTuple, Storable nextParamTuple, - MakeValueTuple startParamTuple startParamValue, - MakeValueTuple nextParamTuple nextParamValue, - Memory.C startParamValue startParamPacked, - Memory.C nextParamValue nextParamPacked, - IsSized startParamPacked startParamSize, - IsSized nextParamPacked nextParamSize, - Memory.C state packed, - IsSized packed size) => + MakeValueTuple startParamTuple, + MakeValueTuple nextParamTuple, + Memory.C (ValueTuple startParamTuple), + Memory.C (ValueTuple nextParamTuple), + Memory.C state) => Cons (forall r c. (Phi c) => - nextParamValue -> + ValueTuple nextParamTuple -> state -> Maybe.T r c (a, state)) -- compute next value (forall r. - startParamValue -> + ValueTuple startParamTuple -> CodeGenFunction r state) -- initial state (p -> IO (ioContext, (nextParamTuple, startParamTuple))) {- initialization from IO monad - This will be run within unsafePerformIO, + This will be run within Unsafe.performIO, so no observable In/Out actions please! -} (ioContext -> IO ()) - -- finalization from IO monad, also run within unsafePerformIO + -- finalization from IO monad, also run within Unsafe.performIO simple :: (Storable startParamTuple, Storable nextParamTuple, - MakeValueTuple startParamTuple startParamValue, - MakeValueTuple nextParamTuple nextParamValue, - Memory.C startParamValue startParamPacked, - Memory.C nextParamValue nextParamPacked, - IsSized startParamPacked startParamSize, - IsSized nextParamPacked nextParamSize, - Memory.C state packed, - IsSized packed size) => + MakeValueTuple startParamTuple, + MakeValueTuple nextParamTuple, + ValueTuple startParamTuple ~ startParamValue, + ValueTuple nextParamTuple ~ nextParamValue, + Memory.C startParamValue, + Memory.C nextParamValue, + Memory.C state) => (forall r c. (Phi c) => nextParamValue -> @@ -114,7 +112,7 @@ map :: - (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) => + (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => (forall r. pl -> a -> CodeGenFunction r b) -> Param.T p ph -> T p a -> T p b @@ -138,7 +136,7 @@ zipWith :: - (Storable ph, MakeValueTuple ph pl, Memory.C pl pp, IsSized pp ps) => + (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => (forall r. pl -> a -> b -> CodeGenFunction r c) -> Param.T p ph -> T p a -> T p b -> T p c @@ -204,11 +202,23 @@ (/) = zipWithSimple A.fdiv +instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T p a) where + fromInteger n = pure (A.fromInteger' n) + negate = mapSimple A.neg + (+) = zipWithSimple A.add + (-) = zipWithSimple A.sub + (*) = zipWithSimple A.mul + abs = mapSimple A.abs + signum = mapSimple A.signum + +instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T p a) where + fromRational x = pure (A.fromRational' x) + (/) = zipWithSimple A.fdiv + + iterate :: - (Storable ph, MakeValueTuple ph pl, - Memory.C pl pp, IsSized pp ps, - Storable a, MakeValueTuple a al, - Memory.C al packed, IsSized packed s) => + (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl, + Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => (forall r. pl -> al -> CodeGenFunction r al) -> Param.T p ph -> Param.T p a -> T p al diff --git a/src/Synthesizer/LLVM/Plug/Input.hs b/src/Synthesizer/LLVM/Plug/Input.hs --- a/src/Synthesizer/LLVM/Plug/Input.hs +++ b/src/Synthesizer/LLVM/Plug/Input.hs @@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Plug.Input where @@ -17,9 +16,9 @@ import qualified LLVM.Extra.Control as C import qualified LLVM.Core as LLVM -import LLVM.Extra.Class (MakeValueTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import Control.Applicative (liftA2, ) @@ -27,7 +26,7 @@ import Data.Tuple.HT (mapFst, mapPair, swap, ) -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS +import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS import qualified Synthesizer.Generic.Signal as SigG import qualified Data.EventList.Relative.BodyTime as EventListBT import qualified Data.EventList.Relative.MixedTime as EventListMT @@ -43,6 +42,8 @@ import qualified Foreign.ForeignPtr as FPtr import Foreign.Storable (Storable, pokeElemOff, ) +import qualified System.Unsafe as Unsafe + import Data.Word (Word32, ) @@ -54,32 +55,29 @@ via an instance of 'Synthesizer.Generic.Cut.Read'. -} data T a b = - forall state packed size ioContext - paramTuple paramValue paramPacked paramSize. + forall state ioContext paramTuple. (Storable paramTuple, - MakeValueTuple paramTuple paramValue, - Memory.C paramValue paramPacked, - LLVM.IsSized paramPacked paramSize, - Memory.C state packed, - LLVM.IsSized packed size) => + MakeValueTuple paramTuple, + Memory.C (ValueTuple paramTuple), + Memory.C state) => Cons (forall r. - paramValue -> + ValueTuple paramTuple -> state -> LLVM.CodeGenFunction r (b, state)) -- compute next value (forall r. - paramValue -> + ValueTuple paramTuple -> LLVM.CodeGenFunction r state) -- initial state (a -> IO (ioContext, paramTuple)) {- initialization from IO monad This is called once input chunk. - This will be run within unsafePerformIO, + This will be run within Unsafe.performIO, so no observable In/Out actions please! -} (ioContext -> IO ()) {- - finalization from IO monad, also run within unsafePerformIO + finalization from IO monad, also run within Unsafe.performIO -} @@ -88,20 +86,22 @@ Cons (\p s -> fmap (mapFst f) $ next p s) start create delete -class Default a b | a -> b where - deflt :: T a b +class Default a where + type Element a :: * + deflt :: T a (Element a) -instance - (Default a c, Default b d) => - Default (Zip.T a b) (c,d) where +instance (Default a, Default b) => Default (Zip.T a b) where + type Element (Zip.T a b) = (Element a, Element b) deflt = split deflt deflt -instance Default SigG.LazySize () where +instance Default SigG.LazySize where + type Element SigG.LazySize = () deflt = lazySize instance - (Storable a, MakeValueTuple a value, Memory.C value struct) => - Default (SV.Vector a) value where + (Storable a, MakeValueTuple a, Memory.C (Class.ValueTuple a)) => + Default (SV.Vector a) where + type Element (SV.Vector a) = Class.ValueTuple a deflt = storableVector @@ -112,9 +112,9 @@ see the versioning history for an according hack. -} instance - (Storable a, MakeValueTuple a value, - Memory.C value struct, LLVM.IsSized struct size) => - Default (EventListBT.T NonNegW.Int a) value where + (Storable a, MakeValueTuple a, Memory.C (ValueTuple a)) => + Default (EventListBT.T NonNegW.Int a) where + type Element (EventListBT.T NonNegW.Int a) = ValueTuple a deflt = piecewiseConstant @@ -143,17 +143,22 @@ deleteA ca >> deleteB cb) -lazySize :: - T SigG.LazySize () -lazySize = +fanout :: T a b -> T a c -> T a (b,c) +fanout f g = rmap (\a -> Zip.Cons a a) $ split f g + +lazySize :: T SigG.LazySize () +lazySize = ignore + +ignore :: T a () +ignore = Cons (\ _ _ -> return ((), ())) return - (\ _lazySize -> return ((), ())) + (\ _a -> return ((), ())) (const $ return ()) storableVector :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T (SV.Vector a) value storableVector = Cons @@ -166,7 +171,7 @@ let (fp,s,_l) = SVB.toForeignPtr vec in return (fp, Memory.castStorablePtr $ - FPtr.unsafeForeignPtrToPtr fp `Array.advancePtr` s)) + Unsafe.foreignPtrToPtr fp `Array.advancePtr` s)) -- keep the foreign ptr alive FPtr.touchForeignPtr @@ -176,8 +181,8 @@ but here we do not accept early exit. -} piecewiseConstant :: - (Storable a, MakeValueTuple a value, - Memory.C value struct, LLVM.IsSized struct size) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, + Memory.C value) => T (EventListBT.T NonNegW.Int a) value piecewiseConstant = case rmap (uncurry Zip.Cons . @@ -207,10 +212,9 @@ in order to forbid writing to the array. -} controllerSet :: - (TypeNum.Nat n, Memory.FirstClass a b, - Storable a, MakeValueTuple a (LLVM.Value a), - LLVM.IsSized a asize, - LLVM.IsSized b bsize) => + (TypeNum.NaturalT n, + Storable a, MakeValueTuple a, ValueTuple a ~ LLVM.Value a, + Memory.FirstClass a, LLVM.IsSized a, LLVM.IsSized (Memory.Stored a)) => n -> T (PCS.T Int a) (LLVM.Value (LLVM.Array n a)) controllerSet n = case storableVector of @@ -225,7 +229,7 @@ LLVM.getElementPtr arrPtr (i, ()) return (len1, s1))) length3 <- A.dec length2 - arr <- LLVM.load =<< LLVM.bitcastUnify arrPtr + arr <- LLVM.load =<< LLVM.bitcast arrPtr return (arr, (length3, s2))) (\((_, initialTime), param) -> do state <- start param @@ -244,9 +248,9 @@ bt) -- FIXME: handle memory exhaustion - arr <- Array.mallocArray (TypeNum.toInt n) + arr <- Array.mallocArray (TypeNum.fromIntegerT n) flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) -> - if i >= TypeNum.toInt n + if i >= TypeNum.fromIntegerT n then error "Plug.Input.controllerSet: array too small" else pokeElemOff arr i a diff --git a/src/Synthesizer/LLVM/Plug/Output.hs b/src/Synthesizer/LLVM/Plug/Output.hs --- a/src/Synthesizer/LLVM/Plug/Output.hs +++ b/src/Synthesizer/LLVM/Plug/Output.hs @@ -1,20 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Plug.Output where import qualified Synthesizer.Zip as Zip import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM -import LLVM.Extra.Class (MakeValueTuple, ) import Control.Monad (liftM2, ) @@ -26,26 +24,25 @@ import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) +import qualified System.Unsafe as Unsafe + import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, ) data T a b = - forall state packed size ioContext - paramTuple paramValue paramPacked paramSize. + forall state ioContext paramTuple. (Storable paramTuple, - MakeValueTuple paramTuple paramValue, - Memory.C paramValue paramPacked, - LLVM.IsSized paramPacked paramSize, - Memory.C state packed, - LLVM.IsSized packed size) => + Class.MakeValueTuple paramTuple, + Memory.C (Class.ValueTuple paramTuple), + Memory.C state) => Cons (forall r. - paramValue -> + Class.ValueTuple paramTuple -> a -> state -> LLVM.CodeGenFunction r state) -- compute next value (forall r. - paramValue -> + Class.ValueTuple paramTuple -> LLVM.CodeGenFunction r state) -- initial state (Int -> IO (ioContext, paramTuple)) @@ -53,28 +50,29 @@ This is called once per output chunk with the number of input samples. This number is also the maximum possible number of output samples. - This will be run within unsafePerformIO, + This will be run within Unsafe.performIO, so no observable In/Out actions please! -} (Int -> ioContext -> IO b) {- - finalization from IO monad, also run within unsafePerformIO + finalization from IO monad, also run within Unsafe.performIO The integer argument is the actually produced size of data. We must clip the allocated output vectors accordingly. -} -class Default a b | b -> a where - deflt :: T a b +class Default b where + type Element b :: * + deflt :: T (Element b) b -instance - (Default a c, Default b d) => - Default (a,b) (Zip.T c d) where +instance (Default c, Default d) => Default (Zip.T c d) where + type Element (Zip.T c d) = (Element c, Element d) deflt = split deflt deflt instance - (Storable a, MakeValueTuple a value, Memory.C value struct) => - Default value (SV.Vector a) where + (Storable a, Class.MakeValueTuple a, Memory.C (Class.ValueTuple a)) => + Default (SV.Vector a) where + type Element (SV.Vector a) = Class.ValueTuple a deflt = storableVector @@ -100,7 +98,8 @@ storableVector :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Class.MakeValueTuple a, value ~ Class.ValueTuple a, + Memory.C value, Storable a) => T value (SV.Vector a) storableVector = Cons (\ _ a p -> @@ -112,7 +111,7 @@ let (fp,s,_l) = SVB.toForeignPtr vec return (vec, Memory.castStorablePtr $ - FPtr.unsafeForeignPtrToPtr fp `Array.advancePtr` s)) + Unsafe.foreignPtrToPtr fp `Array.advancePtr` s)) (\len vec -> do let (fp,_s,_l) = SVB.toForeignPtr vec -- keep the foreign ptr alive diff --git a/src/Synthesizer/LLVM/Random.hs b/src/Synthesizer/LLVM/Random.hs --- a/src/Synthesizer/LLVM/Random.hs +++ b/src/Synthesizer/LLVM/Random.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {- | Very simple random number generator according to Knuth which should be fast and should suffice for generating just noise. @@ -18,7 +19,8 @@ zext, trunc, lshr, value, valueOf, vector, undef, constOf, constVector, bitcast, ) import qualified LLVM.Core as LLVM -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Bool as TypeBool +import qualified Types.Data.Num as TypeNum import Data.Function.HT (nest, ) @@ -119,7 +121,7 @@ fromIntegral $ nest n next 1 vectorSeed :: - (TypeNum.Pos n) => + (TypeNum.IntegerT n, TypeNum.IsPositive n ~ TypeBool.True) => Word32 -> Vector n Word32 vectorSeed seed = let n = Vector.size $ valueOf v @@ -130,7 +132,7 @@ vector64 = id nextVector :: - (TypeNum.Pos n) => + (TypeNum.PositiveT n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32)) nextVector s = @@ -261,7 +263,7 @@ (constVector $ map constOf [0,2]) splitVector31to64 :: - (TypeNum.Pos n) => + (TypeNum.PositiveT n) => Value (Vector n Word64) -> CodeGenFunction r (Value (Vector n Word64), Value (Vector n Word64)) splitVector31to64 x = do @@ -313,7 +315,7 @@ as in the approach that is implemented here. -} nextVectorGeneric :: - (TypeNum.Pos n) => + (TypeNum.PositiveT n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32)) nextVectorGeneric s = do @@ -362,7 +364,7 @@ otherwise select corresponding elements from the second vector. -} selectNonNegativeGeneric :: - (TypeNum.Pos n) => + (TypeNum.PositiveT n) => Value (Vector n Int32) -> Value (Vector n Int32) -> CodeGenFunction r (Value (Vector n Int32)) @@ -372,7 +374,7 @@ splitVector31 :: - (TypeNum.Pos n) => + (TypeNum.PositiveT n) => Value (Vector n Word64) -> CodeGenFunction r (Value (Vector n Word32), Value (Vector n Word32)) splitVector31 x = do @@ -385,7 +387,7 @@ but unfortunately calls the expensive __umoddi3. -} nextVector64 :: - (TypeNum.Pos n) => + (TypeNum.PositiveT n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32)) nextVector64 s = 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,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.RingBuffer ( T, track, index, oldest, @@ -14,7 +15,7 @@ import qualified LLVM.Extra.Class as Class import qualified LLVM.Core as LLVM -import LLVM.Core (CodeGenFunction, Value, IsSized, ) +import LLVM.Core (CodeGenFunction, Value, ) import Data.Word (Word32, ) import Foreign.Storable.Tuple () @@ -39,9 +40,8 @@ then the minimum index is zero and the maximum index is @time@. -} index :: - (Memory.C al ap, - IsSized ap as) => - Value Word32 -> T ap -> CodeGenFunction r al + (Memory.C a) => + Value Word32 -> T (Memory.Struct 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, ()) @@ -52,9 +52,8 @@ this is equivalent to @index time@ but more efficient. -} oldest :: - (Memory.C al ap, - IsSized ap as) => - T ap -> CodeGenFunction r al + (Memory.C a) => + T (Memory.Struct a) -> CodeGenFunction r a oldest rb = Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ()) @@ -72,10 +71,9 @@ -} track :: (Storable a, - Class.MakeValueTuple a al, - Memory.C al ap, - IsSized ap as) => - Param.T p a -> Param.T p Int -> CausalP.T p al (T ap) + Class.MakeValueTuple a, Class.ValueTuple a ~ al, + Memory.C al) => + Param.T p a -> Param.T p Int -> CausalP.T p al (T (Memory.Struct al)) track initial time = let time32 = fmap (fromIntegral :: Int -> Word32) time in CausalP.Cons diff --git a/src/Synthesizer/LLVM/SerialVector.hs b/src/Synthesizer/LLVM/SerialVector.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/SerialVector.hs +++ /dev/null @@ -1,17 +0,0 @@ -{- | -A special vector type that represents a time-sequence of samples. -This way we can distinguish safely between LLVM vectors -used for parallel signals and pipelines and -those used for chunky processing of scalar signals. -For the chunky processing this data type allows us -to derive the factor from the type -that time constants have to be multiplied with. --} -module Synthesizer.LLVM.SerialVector where - -import qualified Data.TypeLevel.Num.Sets as TypeSet -import qualified LLVM.Core as LLVM - - -replicate :: (TypeSet.Pos n) => a -> LLVM.Vector n a -replicate x = LLVM.vector [x] diff --git a/src/Synthesizer/LLVM/Server.hs b/src/Synthesizer/LLVM/Server.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Main where - -import qualified Synthesizer.LLVM.Server.CausalPacked.Test as ServerCausalTest -import qualified Synthesizer.LLVM.Server.CausalPacked.Run as ServerCausal -import qualified Synthesizer.LLVM.Server.Packed.Test as ServerPackedTest -import qualified Synthesizer.LLVM.Server.Packed.Run as ServerPacked -import qualified Synthesizer.LLVM.Server.Scalar.Test as ServerScalarTest -import qualified Synthesizer.LLVM.Server.Scalar.Run as ServerScalar - -import qualified LLVM.Core as LLVM - - -part :: Int -part = 106 - -main :: IO () -main = - LLVM.initializeNativeTarget >> - case part of - 000 -> ServerScalar.pitchBend - 001 -> ServerScalar.frequencyModulation - 002 -> ServerScalar.keyboard - 003 -> ServerScalar.keyboardStereo - 004 -> ServerScalar.keyboardMulti - 005 -> ServerScalar.keyboardStereoMulti - 100 -> ServerPacked.frequencyModulation - 101 -> ServerPacked.keyboard - 102 -> ServerPacked.keyboardStereo - 103 -> ServerPacked.keyboardFM - 104 -> ServerPacked.keyboardFMMulti - 105 -> ServerPacked.keyboardDetuneFM - 106 -> ServerPacked.keyboardFilter -- there is still a leak when playing for a long time with arcStrings - 150 -> ServerCausal.keyboard - 151 -> ServerCausal.keyboardFM - 152 -> ServerCausal.keyboardDetuneFM - 153 -> ServerCausal.keyboardMultiChannel - 200 -> ServerScalarTest.pitchBend0 - 201 -> ServerScalarTest.pitchBend1 - 202 -> ServerScalarTest.pitchBend2 - 203 -> ServerScalarTest.sequencePress - 300 -> ServerPackedTest.adsr - 301 -> ServerPackedTest.sequencePlain - 302 -> ServerPackedTest.sequenceLLVM - 303 -> ServerPackedTest.sequencePitchBendCycle - 304 -> ServerPackedTest.sequencePitchBendSimple - 305 -> ServerPackedTest.sequencePitchBend - 306 -> ServerPackedTest.sequenceModulated - 307 -> ServerPackedTest.sequencePress - 308 -> ServerPackedTest.sequenceModulatedLong - 309 -> ServerPackedTest.sequenceModulatedLongFM - 310 -> ServerPackedTest.sequenceModulatedRepeat - 311 -> ServerPackedTest.sequenceSample - 312 -> ServerPackedTest.sequenceSample1 -- leak --- 313 -> ServerPackedTest.testSequenceSample1a -- leak - 320 -> ServerPackedTest.sequenceSample2 -- leak - 321 -> ServerPackedTest.sequenceSample3 -- leak - 322 -> ServerPackedTest.sequenceSample4 -- leak - 323 -> ServerPackedTest.sequenceFM1 -- leak - 324 -> ServerPackedTest.bellNoiseStereoTest - 400 -> ServerCausalTest.render - 401 -> ServerCausalTest.sequenceNothing - 402 -> ServerCausalTest.sequenceSingleLong - 403 -> ServerCausalTest.sequenceSingleShort - 404 -> ServerCausalTest.sequenceLoop - 405 -> ServerCausalTest.sequenceStaccato - 406 -> ServerCausalTest.sequenceControlled - 407 -> ServerCausalTest.sequenceControlledModulated - 408 -> ServerCausalTest.sampledSound - _ -> error "not implemented server part" diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs @@ -0,0 +1,427 @@ +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.SampledSound as Sample +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +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.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 MV +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Class.Check as Check + +import Control.Arrow (Arrow, (<<<), (<<^), (^<<), arr, first, ) +import Control.Category (id, ) +import Control.Monad (guard, ) + +import qualified Data.List.HT as ListHT + +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) + (MV.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) + (MV.controllerExponential bnds) + initial + + +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 <- CausalSt.makeArranger + amp <- + CausalP.processIO + (emitStereo <<< + CausalP.envelopeStereo <<< + first (CausalP.mapSimple Serial.upsample)) + + tine <- Instr.tineStereoFM + ping <- Instr.pingStereoReleaseFM + filterSaw <- Instr.filterSawStereoFM + bellNoise <- Instr.bellNoiseStereoFM + + wind <- Instr.wind + windPhaser <- Instr.windPhaser + string <- Instr.softStringShapeFM + fmString <- Instr.fmStringStereoFM + arcs <- sequence $ + Instr.cosineStringStereoFM : + Instr.arcSawStringStereoFM : + Instr.arcSineStringStereoFM : + Instr.arcSquareStringStereoFM : + Instr.arcTriangleStringStereoFM : + [] + + tmt0 <- Instr.makeSampledSounds smpDir Sample.tomatensalat + hal0 <- Instr.makeSampledSounds smpDir Sample.hal + grp0 <- Instr.makeSampledSounds smpDir Sample.graphentheorie + + let 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) + + 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)) + + 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 + + bank = + Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $ + [tineProc, pingProc, filterSawProc, bellNoiseProc, + stringProc, fmStringProc] ++ + map makeArc arcs ++ windProc : windPhaserProc : + map sampled (tmt0 ++ hal0 ++ grp0) + + return $ \chan initPgm rate -> + amp () + <<< + (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float) + <<^ Zip.second) + &+& + (arrange + <<< + arr shortTime + <<< + MIO.sequenceModulatedMultiProgram chan initPgm + (\pgm -> Map.findWithDefault pingProc pgm bank rate)) + <<< + id &+& MCS.fromChannel chan + + +data Phoneme = Phoneme Bool VoiceMsg.Pitch + +instance Check.C Phoneme where + note _chan (Phoneme on p) = + Just (VoiceMsg.normalVelocity, p, on) + + +voderSplit :: + (Check.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.partitionMaybe $ \ev -> do + (_v,p,b) <- Check.note chan ev + guard $ p < VoiceMsg.toPitch 53 + return $ Phoneme b p) + +voder :: + (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) +voder emitStereo smpDir = do + carrier <- keyboardDetuneFMCore id smpDir + voice <- Speech.phoneme + 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 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 @@ -1,17 +1,24 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Rank2Types #-} +{- | +This module contains some instruments with Causal arrow interface. +The interface is a bit low-level +since you have to write the transformations of the Haskell-side +separately from the computations on the LLVM side. +A nicer integration is used in +"Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug". +However, we preserve this module in order to show +how things work internally. +-} module Synthesizer.LLVM.Server.CausalPacked.Instrument where -import Synthesizer.LLVM.Server.Packed.Instrument - (Vector, vectorTime, vectorSize, - SampleInfo, SampledSound(..), loadSound, - sampleStart, sampleLength, - sampleLoopStart, sampleLoopLength, - stereoNoise, noiseReference, sumNested, ) +import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise, ) +import Synthesizer.LLVM.Server.CommonPacked import Synthesizer.LLVM.Server.Common hiding (Instrument, ) +import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.LLVM.Storable.Process as PSt -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa +import qualified Synthesizer.MIDI.CausalIO.Process as MIO import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO @@ -22,6 +29,7 @@ import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS @@ -31,8 +39,8 @@ import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Wave as WaveL -import qualified Synthesizer.LLVM.ALSA.BendModulation as BM -import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.MIDI as MIDIL import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Zip as Zip @@ -44,61 +52,50 @@ import System.FilePath ((), ) -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Monad as LM import qualified LLVM.Core as LLVM -import qualified Data.TypeLevel.Num as TypeNum +import qualified Types.Data.Num as TypeNum import qualified Data.Traversable as Trav -import Control.Arrow (Arrow, arr, first, second, (&&&), (***), (<<^), (^<<), ) +import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<), ) import Control.Category (id, (.), ) import Control.Monad (liftM2, liftM3, (<=<), ) -import Control.Applicative (Applicative, pure, liftA2, liftA3, ) +import Control.Applicative (pure, liftA2, liftA3, ) import Data.Monoid (mappend, ) -import Data.Tuple.HT (swap, mapPair, ) import qualified Number.DimensionTerm as DN -{- -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky --} -import qualified Algebra.Additive as Additive - import NumericPrelude.Numeric import NumericPrelude.Base hiding (id, (.), ) -type Param p = Param.T (SampleRate Real, p) -type CausalP p = CausalP.T (SampleRate Real, p) - -type Instrument a sig = SampleRate a -> PAlsa.Instrument a sig +type Instrument a sig = SampleRate a -> MIO.Instrument a sig type Control = EventListBT.T PC.ShortStrictTime type Time = DN.Time Real type Frequency = DN.Frequency Real +type BendModControl = Control (BM.T Real) +type DetuneBendModControl = Zip.T (Control Real) (Control (BM.T Real)) +type PIOId a = PIO.T a a + + stereoFrequenciesFromDetuneBendModulation :: Param p Real -> - CausalP p - (LLVM.Value Real, BM.T (LLVM.Value Real)) - (Stereo.T (LLVM.Value Vector)) -stereoFrequenciesFromDetuneBendModulation speed = - CausalP.envelopeStereo - . - (MIDIL.frequencyFromBendModulationPacked speed - *** - CausalP.mapSimple (Trav.mapM SoV.replicate) - . - liftA2 Stereo.cons (one + id) (one - id)) - . - arr swap + (FuncP p inp (LLVM.Value Real), + FuncP p inp (BM.T (LLVM.Value Real))) -> + FuncP p inp (Stereo.T VectorValue) +stereoFrequenciesFromDetuneBendModulation speed (detune, freq) = + CausalP.envelopeStereo $& + (MIDIL.frequencyFromBendModulationPacked speed $& freq) + &|& + (CausalP.mapSimple (Trav.mapM Serial.upsample) $& + liftA2 Stereo.cons (one + detune) (one - detune)) frequencyFromSampleRate :: SampleRate a -> DN.Frequency a @@ -123,21 +120,13 @@ takeThreshold :: Param.T p Real -> - CausalP.T p (LLVM.Value Vector) (LLVM.Value Vector) + CausalP.T p VectorValue VectorValue takeThreshold = CausalP.takeWhile (\threshold y -> - A.cmp LLVM.CmpLE threshold =<< Frame.subsampleVector y) + A.cmp LLVM.CmpLE threshold =<< Serial.subsample y) -liftStereo :: - (Applicative f) => - (f a -> f b) -> f (Stereo.T a) -> f (Stereo.T b) -liftStereo proc freqs = - liftA2 Stereo.cons - (proc $ fmap Stereo.left freqs) - (proc $ fmap Stereo.right freqs) - fanoutShorten :: (CutG.Transform a, CutG.Transform b, CutG.Transform c) => PIO.T a b -> PIO.T a c -> PIO.T a (Zip.T b c) @@ -146,22 +135,28 @@ Zip.arrowSecondShorten b . arr (\x -> Zip.Cons x x) + +type EnvelopeControl = + Zip.T MIO.GateChunk + (Zip.T (Control Time) (Control Time)) + +type WithEnvelopeControl remainder = + Zip.T MIO.GateChunk + (Zip.T + (Zip.T (Control Time) (Control Time)) + remainder) + reorderEnvelopeControl :: (Arrow arrow, CutG.Read remainder) => arrow - (Zip.T PAlsa.GateChunk - (Zip.T - (Zip.T (Control Time) (Control Time)) - remainder)) - (Zip.T - (Zip.T PAlsa.GateChunk - (Zip.T (Control Time) (Control Time))) - remainder) + (WithEnvelopeControl remainder) + (Zip.T EnvelopeControl remainder) reorderEnvelopeControl = arr $ \(Zip.Cons gate (Zip.Cons times ctrl)) -> Zip.consChecked "ping gate ctrl" (Zip.consChecked "ping gate times" gate times) ctrl + ping :: IO (Instrument Real (SV.Vector Vector)) ping = fmap (\proc sampleRate vel freq -> @@ -180,7 +175,7 @@ pingReleaseEnvelope :: IO (Real -> Real -> SampleRate Real -> Real -> - PIO.T PAlsa.GateChunk (SV.Vector Vector)) + PIO.T MIO.GateChunk (SV.Vector Vector)) pingReleaseEnvelope = liftM2 (\sustain release dec rel sr vel -> @@ -227,8 +222,7 @@ Maybe Real -> IO (SampleRate Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T (Control Time) (Control Time))) + EnvelopeControl (SV.Vector Vector)) pingControlledEnvelope threshold = liftM2 @@ -258,31 +252,26 @@ pingStereoReleaseFM :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk + (WithEnvelopeControl (Zip.T - (Zip.T (Control Time) (Control Time)) + (Zip.T (Control Real) (Control Time)) (Zip.T (Zip.T (Control Real) (Control Time)) - (Zip.T - (Zip.T (Control Real) (Control Time)) - (Zip.T (Control Real) (Control (BM.T Real))))))) + DetuneBendModControl))) (SV.Vector (Stereo.T Vector))) pingStereoReleaseFM = liftA2 (\osc env sr vel freq -> osc (sr, ()) . - (Zip.arrowSecond $ Zip.arrowSecond $ - Zip.arrowSecond $ Zip.arrowSecond $ - arr $ transposeModulation sr freq) - . - (Zip.arrowSecond $ Zip.arrowSecond $ - Zip.arrowFirst $ Zip.arrowSecond $ - arr $ halfLifeControl sr) - . - (Zip.arrowSecond $ - Zip.arrowFirst $ Zip.arrowSecond $ - arr $ halfLifeControl sr) + Zip.arrowSecond + (Zip.arrowSplit + (Zip.arrowSecond $ arr $ halfLifeControl sr) + ((Zip.arrowSecond $ Zip.arrowSecond $ + arr $ transposeModulation sr freq) + . + (Zip.arrowFirst $ Zip.arrowSecond $ + arr $ halfLifeControl sr))) . Zip.arrowFirstShorten (env sr vel) . @@ -291,25 +280,21 @@ (CausalP.envelopeStereo . second - (let fm = F.lift (arr (snd.snd)) - shape = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst)) - shapeDecay = F.lift (arr (snd.fst)) + (F.withArgs $ \((shape0,shapeDecay),((phase,phaseDecay),fm)) -> + let shape = CausalP.mapSimple Serial.upsample $& shape0 shapeCtrl = - 1/3.14 + (shape-1/3.14) * + 1/pi + (shape-1/pi) * (Exp.causalPackedP (1::Param.T p Real) $& shapeDecay) freqs = stereoFrequenciesFromDetuneBendModulation - (frequencyConst 10) $& fm - phase = F.lift (arr (fst.fst.snd)) - phaseDecay = F.lift (arr (snd.fst.snd)) + (frequencyConst 10) fm expo = - (CausalP.mapSimple SoV.replicate $& phase) * + (CausalP.mapSimple Serial.upsample $& phase) * (Exp.causalPackedP (1::Param.T p Real) $& phaseDecay) osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1 - in F.compile $ - liftA2 Stereo.cons + in liftA2 Stereo.cons (osci $& shapeCtrl &|& (expo &|& fmap Stereo.left freqs)) - (osci $& shapeCtrl &|& (Additive.negate expo &|& fmap Stereo.right freqs))))) + (osci $& shapeCtrl &|& (negate expo &|& fmap Stereo.right freqs))))) (pingControlledEnvelope (Just 0.01)) @@ -317,29 +302,23 @@ filterSawStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk + (WithEnvelopeControl (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T - (Zip.T (Control Frequency) (Control Time)) - (Zip.T (Control Real) (Control (BM.T Real)))))) + (Zip.T (Control Frequency) (Control Time)) + DetuneBendModControl)) (SV.Vector (Stereo.T Vector))) filterSawStereoFM = liftA2 (\osc env sr vel freq -> osc (sr, ()) . - (Zip.arrowSecond $ Zip.arrowSecond $ - Zip.arrowSecond $ - arr $ transposeModulation sr freq) - . - (Zip.arrowSecond $ - Zip.arrowFirst $ Zip.arrowSecond $ - arr $ halfLifeControl sr) - . - (Zip.arrowSecond $ - Zip.arrowFirst $ Zip.arrowFirst $ - arr $ frequencyControl sr) + Zip.arrowSecond + (Zip.arrowSplit + (Zip.arrowSplit + (arr $ frequencyControl sr) + (arr $ halfLifeControl sr)) + (Zip.arrowSecond $ + arr $ transposeModulation sr freq)) . Zip.arrowFirstShorten (env sr vel) . @@ -348,27 +327,24 @@ (CausalP.envelopeStereo . second - (let fm = F.lift (arr snd) - cutoff = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst)) - cutoffDecay = F.lift (arr (snd.fst)) - freqs = + (F.withArgs $ \((cutoff,cutoffDecay),fm) -> + let freqs = stereoFrequenciesFromDetuneBendModulation - (frequencyConst 10) $& fm + (frequencyConst 10) fm {- bound control in order to avoid too low resonant frequency, which makes the filter instable -} expo = takeThreshold (frequencyConst 100) $& - (CausalP.mapSimple SoV.replicate $& cutoff) * + (CausalP.mapSimple Serial.upsample $& cutoff) * (Exp.causalPackedP (1::Param.T p Real) $& cutoffDecay) - in F.compile $ - CausalP.stereoFromMonoControlled + in CausalP.stereoFromMonoControlled (UniFilter.lowpass ^<< CtrlPS.process) $& (CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real) (CausalP.mapSimple (UniFilter.parameter (LLVM.valueOf 10) <=< - Frame.subsampleVector)) + Serial.subsample)) $& expo) &|& @@ -380,12 +356,10 @@ tineStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk + (WithEnvelopeControl (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T - (Zip.T (Control Real) (Control Real)) - (Zip.T (Control Real) (Control (BM.T Real)))))) + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) (SV.Vector (Stereo.T Vector))) tineStereoFM = liftA2 @@ -403,13 +377,13 @@ (CausalP.envelopeStereo . second - (let vel = number id - fm = F.lift (arr snd) + (F.withArgs $ \((index0,depth0), fm) -> + let vel = number id freqs = stereoFrequenciesFromDetuneBendModulation - (frequencyConst 5) $& fm - index = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst)) - depth = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst)) + (frequencyConst 5) fm + index = CausalP.mapSimple Serial.upsample $& index0 + depth = CausalP.mapSimple Serial.upsample $& depth0 expo = F.lift $ CausalP.fromSignal $ SigPS.exponential2 (timeConst 1) (1 + vel) @@ -420,19 +394,17 @@ $& zero &|& index*freq) &|& freq - in F.compile $ liftStereo osci freqs))) + in Stereo.liftApplicative osci freqs))) (pingControlledEnvelope (Just 0.01)) bellNoiseStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk + (WithEnvelopeControl (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T - (Zip.T (Control Real) (Control Real)) - (Zip.T (Control Real) (Control (BM.T Real)))))) + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) (SV.Vector (Stereo.T Vector))) bellNoiseStereoFM = liftA3 @@ -448,9 +420,7 @@ (env sr (vel*0.5)) (let shortenTimes :: Real -> - PIO.T - (Zip.T (Control Time) (Control Time)) - (Zip.T (Control Time) (Control Time)) + PIOId (Zip.T (Control Time) (Control Time)) shortenTimes n = let rn = recip n in (Zip.arrowFirst $ arr $ fmap $ DN.scale rn) @@ -466,12 +436,8 @@ . reorderEnvelopeControl) (CausalP.processIO - (let env1 = F.lift (arr (fst.fst)) - env4 = F.lift (arr (fst.snd.fst)) - env7 = F.lift (arr (snd.snd.fst)) - fm = F.lift (arr (snd.snd)) - noiseAmp = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd)) - noiseReson = F.lift (arr (snd.fst.snd)) + (F.withArgs $ \((env1,(env4,env7)),((noiseAmp0,noiseReson),fm)) -> + let noiseAmp = CausalP.mapSimple Serial.upsample $& noiseAmp0 noiseParam = CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real) @@ -482,7 +448,7 @@ (SigPS.noise 12 (noiseReference 20000))) freqs = stereoFrequenciesFromDetuneBendModulation - (frequencyConst 5) $& fm + (frequencyConst 5) fm osci amp env n = CausalPS.amplifyStereo amp $& CausalP.envelopeStereo $& @@ -494,15 +460,14 @@ CausalPS.amplifyStereo n $& freqs) - in F.compile $ - (CausalP.envelopeStereo $& + in (CausalP.envelopeStereo $& (noiseAmp * env1) &|& - liftStereo + Stereo.liftApplicative (\freq -> CtrlPS.process $& (noiseParam $& noiseReson &|& - (CausalP.mapSimple Frame.subsampleVector $& freq)) + (CausalP.mapSimple Serial.subsample $& freq)) &|& noise) freqs) @@ -516,10 +481,7 @@ stringControlledEnvelope :: IO (SampleRate Real -> Real -> - PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T (Control Time) (Control Time))) - (SV.Vector Vector)) + PIO.T EnvelopeControl (SV.Vector Vector)) stringControlledEnvelope = liftM3 (\attack sustain release sr vel -> @@ -558,11 +520,11 @@ windCore :: F.T (SampleRate Real, p) a (LLVM.Value Real) -> F.T (SampleRate Real, p) a (BM.T (LLVM.Value Real)) -> - F.T (SampleRate Real, p) a (Stereo.T (LLVM.Value Vector)) + F.T (SampleRate Real, p) a (Stereo.T VectorValue) windCore reson fm = let modu = - CausalP.mapSimple Frame.subsampleVector $& - (fmap (`asTypeOf` (undefined :: LLVM.Value Vector)) $ + CausalP.mapSimple Serial.subsample $& + (fmap (`asTypeOf` (undefined :: VectorValue)) $ (MIDIL.frequencyFromBendModulationPacked (frequencyConst 0.2) $& fm)) in CausalP.stereoFromMonoControlled CtrlPS.process $& @@ -575,10 +537,7 @@ wind :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T (Control Real) (Control (BM.T Real))))) + (WithEnvelopeControl DetuneBendModControl) (SV.Vector (Stereo.T Vector))) wind = liftA2 @@ -592,11 +551,7 @@ . reorderEnvelopeControl) (CausalP.processIO - (let env = F.lift (arr fst) - reson = F.lift (arr (fst.snd)) - fm = F.lift (arr (snd.snd)) - - in F.compile $ + (F.withArgs $ \(env,(reson,fm)) -> CausalP.envelopeStereo $& env &|& windCore reson fm)) @@ -606,12 +561,9 @@ windPhaser :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T (Control Real) - (Zip.T (Control Frequency) - (Zip.T (Control Real) (Control (BM.T Real))))))) + (WithEnvelopeControl + (Zip.T (Control Real) + (Zip.T (Control Frequency) DetuneBendModControl))) (SV.Vector (Stereo.T Vector))) windPhaser = liftA2 @@ -619,28 +571,21 @@ osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ - Zip.arrowSecond $ Zip.arrowSecond $ - arr $ transposeModulation sr freq) - . - (Zip.arrowSecond $ Zip.arrowSecond $ - Zip.arrowFirst $ - arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) . - frequencyControl sr) + Zip.arrowSplit + (arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) . + frequencyControl sr) + (Zip.arrowSecond $ + arr $ transposeModulation sr freq)) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO - (let env = F.lift (arr fst) - phaserMix = - F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd)) - phaserFreq = F.lift (arr (fst.snd.snd)) - reson = F.lift (arr (fst.snd.snd.snd)) - fm = F.lift (arr (snd.snd.snd.snd)) + (F.withArgs $ \(env,(phaserMix0,(phaserFreq,(reson,fm)))) -> + let phaserMix = CausalP.mapSimple Serial.upsample $& phaserMix0 noise = windCore reson fm - in F.compile $ - CausalP.envelopeStereo $& + in CausalP.envelopeStereo $& env &|& ((CausalP.envelopeStereo $& (1 - phaserMix) &|& noise) + @@ -652,8 +597,8 @@ phaserOsci :: - (Param.T p Real -> Param.T p Real -> CausalP.T p a (LLVM.Value Vector)) -> - CausalP.T p a (Stereo.T (LLVM.Value Vector)) + (Param.T p Real -> Param.T p Real -> CausalP.T p a VectorValue) -> + CausalP.T p a (Stereo.T VectorValue) phaserOsci osci = CausalPS.amplifyStereo 0.25 . @@ -667,19 +612,15 @@ StringInstrument = SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T - (Control Real) - (Zip.T (Control Real) (Control (BM.T Real)))))) + (WithEnvelopeControl + (Zip.T (Control Real) DetuneBendModControl)) (SV.Vector (Stereo.T Vector)) softStringShapeCore :: (forall r. - LLVM.Value Vector -> - LLVM.Value Vector -> - LLVM.CodeGenFunction r (LLVM.Value Vector)) -> + VectorValue -> + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> IO StringInstrument softStringShapeCore wave = liftA2 @@ -697,9 +638,9 @@ (CausalP.envelopeStereo . second - (let fm = F.lift (arr (snd.snd)) - det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd)) - shape = F.lift (CausalP.mapSimple SoV.replicate . arr fst) + (F.withArgs $ \(shape0,(det0,fm)) -> + let det = CausalP.mapSimple Serial.upsample $& det0 + shape = CausalP.mapSimple Serial.upsample $& shape0 modu = MIDIL.frequencyFromBendModulationPacked (frequencyConst 5) $& fm @@ -707,11 +648,11 @@ Param.T (mod,fm) Real -> Param.T (mod,fm) Real -> CausalP.T (mod,fm) - (LLVM.Value Vector, + (VectorValue, {- wave shape parameter -} - (LLVM.Value Vector, LLVM.Value Vector) + (VectorValue, VectorValue) {- detune, frequency modulation -}) - (LLVM.Value Vector) + VectorValue osci p d = CausalPS.shapeModOsci wave . @@ -722,14 +663,13 @@ . first (one + CausalPS.amplify d)) - in F.compile $ - phaserOsci osci $& shape &|& det &|& modu))) + in phaserOsci osci $& shape &|& det &|& modu))) stringControlledEnvelope arcStringStereoFM :: (forall r. - LLVM.Value Vector -> - LLVM.CodeGenFunction r (LLVM.Value Vector)) -> + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> IO StringInstrument arcStringStereoFM wave = softStringShapeCore @@ -756,12 +696,10 @@ fmStringStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk + (WithEnvelopeControl (Zip.T - (Zip.T (Control Time) (Control Time)) - (Zip.T - (Zip.T (Control Real) (Control Real)) - (Zip.T (Control Real) (Control (BM.T Real)))))) + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) (SV.Vector (Stereo.T Vector))) fmStringStereoFM = liftA2 @@ -776,14 +714,13 @@ . reorderEnvelopeControl) (CausalP.processIO - (let env = F.lift (arr fst) - fm = F.lift (arr (snd.snd.snd)) - det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd.snd)) - shape = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst.snd)) + (F.withArgs $ \(env,((depth0,shape0),(det0,fm))) -> + let det = CausalP.mapSimple Serial.upsample $& det0 + shape = CausalP.mapSimple Serial.upsample $& shape0 depth = CausalP.envelope $& env &|& - F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd)) + (CausalP.mapSimple Serial.upsample $& depth0) modu = MIDIL.frequencyFromBendModulationPacked (frequencyConst 5) $& fm @@ -792,11 +729,11 @@ Param.T (mod,fm) Real -> Param.T (mod,fm) Real -> CausalP.T (mod,fm) - ((LLVM.Value Vector, LLVM.Value Vector) + ((VectorValue, VectorValue) {- phase modulation depth, modulator distortion -}, - (LLVM.Value Vector, LLVM.Value Vector) + (VectorValue, VectorValue) {- detune, frequency modulation -}) - (LLVM.Value Vector) + VectorValue osci p d = CausalPS.osciSimple WaveL.approxSine2 . @@ -813,8 +750,7 @@ (CausalP.envelope . first (one + CausalPS.amplify d)) - in F.compile $ - CausalP.envelopeStereo $& + in CausalP.envelopeStereo $& env &|& (phaserOsci osci $& (depth &|& shape) &|& (det &|& modu)))) stringControlledEnvelope @@ -822,11 +758,10 @@ sampledSound :: - IO (SampledSound -> + IO (Sample.T -> SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T (Control Real) (Control (BM.T Real)))) + (Zip.T MIO.GateChunk DetuneBendModControl) (SV.Vector (Stereo.T Vector))) sampledSound = liftA2 @@ -837,36 +772,25 @@ Without (periodic) frequency modulation we could just split the piecewise constant control curve @fm@. -} - let pos = samplePositions smp + let pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel - (attack,sustain) = - mapPair - (SigSt.drop (sampleStart pos), - SigSt.take (sampleLoopLength pos)) $ - SigSt.splitAt (sampleLoopStart pos) $ - sampleData smp - release = - SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ - SigSt.take (sampleStart pos + sampleLength pos) $ - sampleData smp + (attack, sustain, release) = Sample.parts smp osci smpBody = osc (sr, (amp, smpBody)) in mappend (osci (attack `SigSt.append` - SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) . Gate.shorten) (osci release <<^ Zip.second) . Zip.arrowSecond - ((id :: PIO.T - (SV.Vector (Stereo.T Vector)) - (SV.Vector (Stereo.T Vector))) + ((id :: PIOId (SV.Vector (Stereo.T Vector))) . freqMod (sr, ()) . (Zip.arrowSecond $ arr $ - transposeModulation sr (freq * samplePeriod smp)))) + transposeModulation sr (freq * Sample.period smp)))) (CausalP.processIO (let amp = number fst smp = signal snd @@ -882,20 +806,87 @@ (SigP.fromStorableVectorLazy smp) {- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -})))) (CausalP.processIO - (stereoFrequenciesFromDetuneBendModulation (frequencyConst 3))) + (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3))) makeSampledSounds :: FilePath -> - SampleInfo -> + Sample.Info -> IO [SampleRate Real -> Real -> Real -> PIO.T - (Zip.T PAlsa.GateChunk - (Zip.T (Control Real) (Control (BM.T Real)))) + (Zip.T MIO.GateChunk DetuneBendModControl) (SV.Vector (Stereo.T Vector))] makeSampledSounds dir (file, positions, period) = do liftA2 (\makeSmp smp -> - map (\pos -> makeSmp (SampledSound smp pos period)) + map (\pos -> makeSmp (Sample.Cons smp pos period)) positions) sampledSound - (loadSound (dir file)) + (Sample.load (dir file)) + + +{- | +mainly for testing purposes +-} +sampledSoundMono :: + IO (Sample.T -> + SampleRate Real -> Real -> Real -> + PIO.T + (Zip.T MIO.GateChunk BendModControl) + (SV.Vector Vector)) +sampledSoundMono = + liftA2 + (\osc freqMod smp sr vel freq -> + {- + We split the frequency modulation signal + in order to get a smooth frequency modulation curve. + Without (periodic) frequency modulation + we could just split the piecewise constant control curve @fm@. + -} + let pos = Sample.positions smp + amp = 2 * amplitudeFromVelocity vel + (attack, sustain, release) = Sample.parts smp + osci smpBody = osc (sr, (amp, smpBody)) + in mappend + (osci + (attack `SigSt.append` + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)) + . + Gate.shorten) + (osci release <<^ Zip.second) + . + Zip.arrowSecond + ((id :: PIOId (SV.Vector Vector)) + . + freqMod (sr, ()) + . + (arr $ transposeModulation sr (freq * Sample.period smp)))) + (CausalP.processIO + (let amp = number fst + smp = signal snd + in CausalPS.amplify amp + . + CausalPS.pack + (CausalP.frequencyModulationLinear + {- + (SigP.fromStorableVector $ + fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp) + -} + (SigP.fromStorableVectorLazy smp) + {- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -}))) + (CausalP.processIO + (MIDIL.frequencyFromBendModulationPacked (frequencyConst 3))) + +makeSampledSoundsMono :: + FilePath -> + Sample.Info -> + IO [SampleRate Real -> Real -> Real -> + PIO.T + (Zip.T MIO.GateChunk BendModControl) + (SV.Vector Vector)] +makeSampledSoundsMono dir (file, positions, period) = do + liftA2 + (\makeSmp smp -> + map (\pos -> makeSmp (Sample.Cons smp pos period)) + positions) + sampledSoundMono + (Sample.load (dir file)) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs b/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/InstrumentPlug.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +{- | +The Instruments in this module have the same causal arrow interface +as the ones in "Synthesizer.LLVM.Server.CausalPacked.Instrument", +but here we use the higher level interface +of the "Synthesizer.LLVM.CausalParameterized.FunctionalPlug" module. +-} +module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug where + +import Synthesizer.LLVM.Server.CausalPacked.Instrument ( + Control, DetuneBendModControl, + WithEnvelopeControl, + pingControlledEnvelope, + reorderEnvelopeControl, ) +import Synthesizer.LLVM.Server.CommonPacked ( + Param, Vector, VectorValue, ) +import Synthesizer.LLVM.Server.Common ( + SampleRate, Real, + frequencyConst, timeConst, + number, transposeModulation, ) + +import qualified Synthesizer.CausalIO.Process as PIO + +import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&), ) +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP +import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Wave as WaveL + +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.LLVM.MIDI as MIDIL +import qualified Synthesizer.Zip as Zip + +import qualified Data.StorableVector as SV + +import qualified LLVM.Core as LLVM + +import qualified Data.Traversable as Trav +import Control.Category (id, (.), ) +import Control.Applicative (liftA2, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id, (.), ) + + +type FuncP pp pl = FP.T pp (SampleRate Real, pl) + + +stereoFrequenciesFromDetuneBendModulation :: + Param pl Real -> + (FuncP pp pl inp (LLVM.Value Real), + FuncP pp pl inp (BM.T (LLVM.Value Real))) -> + FuncP pp pl inp (Stereo.T VectorValue) +stereoFrequenciesFromDetuneBendModulation speed (detune, freq) = + CausalP.envelopeStereo $& + (MIDIL.frequencyFromBendModulationPacked speed $& freq) + &|& + (CausalP.mapSimple (Trav.mapM Serial.upsample) $& + liftA2 Stereo.cons (one + detune) (one - detune)) + +tineStereoFM :: + IO (SampleRate Real -> Real -> Real -> + PIO.T + (WithEnvelopeControl + (Zip.T + (Zip.T (Control Real) (Control Real)) + DetuneBendModControl)) + (SV.Vector (Stereo.T Vector))) +tineStereoFM = + liftA2 + (\osc env sr vel freq -> + osc (sr, freq) (sr, vel) + . + Zip.arrowFirstShorten (env sr vel) + . + reorderEnvelopeControl) + (FP.withArgs $ \(env, ((index0,depth0), (detune,fm))) -> + let vel = number id + freqs = + stereoFrequenciesFromDetuneBendModulation + (frequencyConst 5) + (FP.plug detune, + FP.plug $ liftA2 (uncurry transposeModulation) FP.askParameter fm) + index = CausalP.mapSimple Serial.upsample $& FP.plug index0 + depth = CausalP.mapSimple Serial.upsample $& FP.plug depth0 + expo = + FP.fromSignal $ + SigPS.exponential2 (timeConst 1) (1 + vel) + osci freq = + CausalPS.osciSimple WaveL.approxSine2 $& + expo * depth * + (CausalPS.osciSimple WaveL.approxSine2 + $& zero &|& index*freq) + &|& + freq + in CausalP.envelopeStereo $& + FP.plug env &|& Stereo.liftApplicative osci freqs) + (pingControlledEnvelope (Just 0.01)) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Run.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Run.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/CausalPacked/Run.hs +++ /dev/null @@ -1,424 +0,0 @@ -module Synthesizer.LLVM.Server.CausalPacked.Run where - -import Synthesizer.LLVM.Server.Packed.Run - (StereoVector, - controllerVolume, controllerDetune, - controllerTimbre0, controllerTimbre1, ) -import qualified Sound.MIDI.Controller as Ctrl - -import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr -import qualified Synthesizer.LLVM.Server.Packed.Instrument as InstrP -import qualified Synthesizer.LLVM.Server.Packed.Run as RunP -import qualified Synthesizer.LLVM.Server.Option as Option -import Synthesizer.LLVM.Server.Common - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.EventList.ALSA.MIDI as Ev - -import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSet as MCS -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa -import qualified Synthesizer.CausalIO.Process as PIO - -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Storable.Process as CausalSt -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt - -import qualified LLVM.Extra.ScalarOrVector as SoV - -import qualified Data.StorableVector as SV - -import qualified Data.EventList.Relative.TimeTime as EventListTT - --- import qualified Synthesizer.LLVM.ALSA.BendModulation as BM -import qualified Synthesizer.Zip as Zip - -import qualified Sound.ALSA.PCM as PCM - -import qualified Synthesizer.Dimensional.MIDIValuePlain as MV -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Sound.MIDI.Message.Channel as ChannelMsg -import qualified Sound.MIDI.ALSA.Check as Check - -import Control.Arrow (Arrow, (<<<), (<<^), (^<<), (***), arr, first, ) -import Control.Category (id, ) - -import qualified Data.Map as Map -{- -import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) --} - -import qualified Number.DimensionTerm as DN -import qualified Algebra.DimensionTerm as Dim - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Additive as Additive - -{- -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Chunky as NonNegChunky --} -import qualified Numeric.NonNegative.Wrapper as NonNegW - -import Prelude hiding (Real, id, ) - - - - -playFromEvents :: - (PCM.SampleFmt a, Additive.C a) => - Option.T -> - PIO.T (EventListTT.T Ev.StrictTime [Event.T]) (SV.Vector a) -> - IO () -playFromEvents opt = - PAlsa.playFromEvents - (Option.device opt) - (Option.clientName opt) - 0.01 - (Option.periodTime opt::Double) - (case Option.sampleRate opt of - SampleRate sr -> fromInteger sr) - -keyboard :: IO () -keyboard = do - opt <- Option.get - arrange <- CausalSt.makeArranger - amp <- CausalP.processIO (CausalPS.amplify $# 0.2) - - ping <- Instr.pingRelease - - playFromEvents opt $ - arr SigStL.unpackStrict - <<< - amp () - <<< - arrange - <<< - arr (EventListTT.mapTime - (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)) - <<< - PAlsa.sequenceCore - (Option.channel opt) - (\ _pgm -> ping 0.8 0.1 (Option.sampleRate opt)) - - -infixr 3 &+& - -(&+&) :: - (Arrow arrow) => - arrow a b -> arrow a c -> arrow a (Zip.T b c) -(&+&) = Zip.arrowFanout - -controllerExponentialDirect :: - (Trans.C y, Dim.C v) => - Option.T -> - VoiceMsg.Controller -> - (DN.T v y, DN.T v y) -> - DN.T v y -> - PIO.T PAlsa.Events (Instr.Control (DN.T v y)) -controllerExponentialDirect opt ctrl bnds initial = - PAlsa.slice - (Check.controller (Option.channel opt) ctrl) - (MV.controllerExponential bnds) - initial - -keyboardFM :: IO () -keyboardFM = do - opt <- Option.get - arrange <- CausalSt.makeArranger - amp <- - CausalP.processIO - (CausalP.mapSimple StereoInt.interleave <<< - (CausalPS.amplifyStereo $# 0.2)) - - ping <- Instr.pingStereoReleaseFM - - playFromEvents opt $ - arr SigStL.unpackStereoStrict - <<< - amp () - <<< - arrange - <<< - arr (EventListTT.mapTime - (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)) - <<< - -- ToDo: fetch parameters from controllers - PAlsa.sequenceModulated - (Option.channel opt) - (\ _pgm -> ping (Option.sampleRate opt)) - <<< - id &+& - ((controllerExponentialDirect opt - Ctrl.attackTime (DN.time 0.25, DN.time 2.5) (DN.time 0.8) - &+& - controllerExponentialDirect opt - Ctrl.releaseTime (DN.time 0.03, DN.time 0.3) (DN.time 0.1)) - &+& - ((PAlsa.controllerExponential (Option.channel opt) controllerTimbre0 (1/pi,0.01) 0.05 - &+& - controllerExponentialDirect opt controllerTimbre1 - (DN.time 0.01, DN.time 10) - (DN.time 5)) - &+& - ((PAlsa.controllerLinear (Option.channel opt) Ctrl.soundController5 (0,2) 1 - &+& - controllerExponentialDirect opt Ctrl.soundController7 - (DN.time 0.25, DN.time 2.5) - (DN.time 0.8)) - &+& - (PAlsa.controllerLinear (Option.channel opt) controllerDetune (0,0.005) 0.001 - &+& - PAlsa.bendWheelPressure (Option.channel opt) 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) - (MV.controllerExponential bnds) - initial - -keyboardDetuneFMCore :: - FilePath -> - IO (ChannelMsg.Channel -> VoiceMsg.Program -> - SampleRate Real -> - PIO.T - (EventListTT.T Ev.StrictTime [Event.T]) - (SV.Vector StereoVector)) -keyboardDetuneFMCore smpDir = do - arrange <- CausalSt.makeArranger - amp <- - CausalP.processIO - (CausalP.mapSimple StereoInt.interleave <<< - CausalP.envelopeStereo <<< - first (CausalP.mapSimple SoV.replicate)) - - tine <- Instr.tineStereoFM - ping <- Instr.pingStereoReleaseFM - filterSaw <- Instr.filterSawStereoFM - bellNoise <- Instr.bellNoiseStereoFM - - wind <- Instr.wind - windPhaser <- Instr.windPhaser - string <- Instr.softStringShapeFM - fmString <- Instr.fmStringStereoFM - arcs <- sequence $ - Instr.cosineStringStereoFM : - Instr.arcSawStringStereoFM : - Instr.arcSineStringStereoFM : - Instr.arcSquareStringStereoFM : - Instr.arcTriangleStringStereoFM : - [] - - tmt0 <- Instr.makeSampledSounds smpDir InstrP.tomatensalat - hal0 <- Instr.makeSampledSounds smpDir InstrP.hal - grp0 <- Instr.makeSampledSounds smpDir InstrP.graphentheorie - - let 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) - - 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 RunP.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)) - - 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 - - bank = - Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $ - [tineProc, pingProc, filterSawProc, bellNoiseProc, - stringProc, fmStringProc] ++ - map makeArc arcs ++ windProc : windPhaserProc : - map sampled (tmt0 ++ hal0 ++ grp0) - - return $ \chan initPgm rate -> - amp () - <<< - (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float) - <<^ Zip.second) - &+& - (arrange - <<< - arr (EventListTT.mapTime - (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)) - <<< - PAlsa.sequenceModulatedMultiProgram chan initPgm - (\pgm -> Map.findWithDefault pingProc pgm bank rate)) - <<< - id &+& MCS.fromChannel chan - -keyboardDetuneFM :: IO () -keyboardDetuneFM = do - opt <- Option.get - proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) - playFromEvents opt $ - arr SigStL.unpackStereoStrict - <<< - proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt) - -keyboardMultiChannel :: IO () -keyboardMultiChannel = do - opt <- Option.get - proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) - mix <- - CausalP.processIO $ - CausalP.mapSimple StereoInt.interleave <<< - CausalP.mix <<< - CausalP.mapSimple StereoInt.deinterleave *** - CausalP.mapSimple StereoInt.deinterleave - - playFromEvents opt $ - arr SigStL.unpackStereoStrict - <<< - foldl1 - (\x y -> mix () <<< Zip.arrowFanout x y) - (map - (\chan -> - proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0) - (Option.sampleRate opt)) - [0 .. 3]) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.LLVM.Server.CausalPacked.Speech where + +import Synthesizer.LLVM.Server.CausalPacked.Instrument + (Control, Frequency, frequencyControl, ) +import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorValue, ) +import Synthesizer.LLVM.Server.Common (SampleRate, Real, frequency, ) + +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.CausalIO.Gate as Gate +import qualified Synthesizer.CausalIO.Process as PIO + +import Synthesizer.LLVM.CausalParameterized.Process (($<), ) +import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&), ) +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP +import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP + +import qualified Synthesizer.Zip as Zip +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Synthesizer.PiecewiseConstant.Signal as PC + +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) + +import qualified Data.StorableVector as SV + +import qualified LLVM.Core as LLVM + +import Control.Arrow (Arrow, arr, (^<<), ) +import Control.Category ((.), ) +import Control.Applicative (liftA, liftA3, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (id, (.), ) + + +{- +stimmhaft +a, e, i, o, u, ä, ö, ü +l, m, n, ng + +Diphtong +ai, oi, au, ui, ei + +stimmlos/Zischlaute +f, h, w, s, sch, th, ch (weich), ch (kochen), r + +explosiv +b, p, g, k, d, t +-} + +{- +Formanten: +a - 700 Hz +i - 400 Hz, 2200 Hz +o - 600 Hz, 3000 Hz +f - white noise +sch - highpass cutoff 1500 Hz +-} + +phoneme :: + IO (SampleRate Real -> VoiceMsg.Pitch -> + PIO.T (Zip.T MIO.GateChunk (SV.Vector (Stereo.T Vector))) + (SV.Vector (Stereo.T Vector))) +phoneme = + liftA + (\osc sr p -> + case formants p of + Nothing -> arr $ const SV.empty + Just fs -> + osc (sr, fs) + . + Gate.shorten) + (CausalP.processIO + (CausalP.stereoFromMono + (let lowpass q f = + UniFilter.bandpass + ^<< + CtrlPS.process + $< + SigP.constant + (UniFilter.parameter . Pole q ^<< frequency f) + in lowpass 100 fst + lowpass 20 snd))) + +formants :: VoiceMsg.Pitch -> Maybe (Real, Real) +formants p = + case VoiceMsg.fromPitch p - 36 of + 00 -> Just ( 320, 800) -- u + 02 -> Just ( 500, 1000) -- o + 04 -> Just (1000, 1400) -- a + 05 -> Just (1500, 500) -- oe + 07 -> Just (1650, 320) -- ue + 09 -> Just (1800, 700) -- ae + 11 -> Just (2300, 500) -- e + 12 -> Just (3200, 320) -- i + _ -> Nothing + + +type Input a = FP.Input (SampleRate Real) a + +plugUniFilterParameter :: + Input a (Control Real) -> + Input a (Control Frequency) -> + FP.T (SampleRate Real) pl a (UniFilter.Parameter (LLVM.Value Real)) +plugUniFilterParameter reson freq = + FP.plug $ + liftA3 + (\resonChunk freqChunk sr -> + PC.zipWith + (\ r f -> UniFilter.parameter $ Pole r f) + resonChunk $ frequencyControl sr freqChunk) + reson freq FP.askParameter + + +type FormantControl = + Zip.T (Control Real) + (Zip.T (Control Real) (Control Frequency)) + +singleFormant :: + (Input inp (Control Real), + (Input inp (Control Real), Input inp (Control Frequency))) -> + Input inp (SV.Vector (Stereo.T Vector)) -> + FP.T (SampleRate Real) pl inp (Stereo.T VectorValue) +singleFormant (amp, (reson, freq)) x = + CausalP.envelopeStereo $& + (CausalP.mapSimple Serial.upsample $& FP.plug amp) + &|& + (CausalP.stereoFromMonoControlled + (UniFilter.bandpass ^<< CtrlPS.process) $& + plugUniFilterParameter reson freq + &|& + FP.plug x) + +filterFormant :: + IO (SampleRate Real -> + PIO.T + (Zip.T FormantControl (SV.Vector (Stereo.T Vector))) + (SV.Vector (Stereo.T Vector))) +filterFormant = + liftA + (\filt sr -> filt sr (sr, ())) + (FP.withArgs $ \(fmt, x) -> singleFormant fmt x) + +filterFormants :: + IO (SampleRate Real -> + PIO.T (Zip.T + (Zip.T FormantControl + (Zip.T FormantControl + (Zip.T FormantControl + (Zip.T FormantControl FormantControl)))) + (SV.Vector (Stereo.T Vector))) + (SV.Vector (Stereo.T Vector))) +filterFormants = + liftA + (\filt sr -> filt sr (sr, ())) + (FP.withArgs $ \((fmt0, (fmt1, (fmt2, (fmt3, fmt4)))), x) -> + foldl1 (+) $ map (flip singleFormant x) [fmt0, fmt1, fmt2, fmt3, fmt4]) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Test.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Test.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/CausalPacked/Test.hs +++ /dev/null @@ -1,346 +0,0 @@ -module Synthesizer.LLVM.Server.CausalPacked.Test where - -import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr -import qualified Synthesizer.LLVM.Server.CausalPacked.Run as Run -import qualified Synthesizer.LLVM.Server.Packed.Instrument as InstrP -import qualified Synthesizer.LLVM.Server.Option as Option -import Synthesizer.LLVM.Server.Packed.Instrument - (vectorSize, ) -import Synthesizer.LLVM.Server.Packed.Run - (controllerVolume, controllerDetune, - controllerTimbre0, controllerTimbre1, ) -import Synthesizer.LLVM.Server.CausalPacked.Run ((&+&), ) -import Synthesizer.LLVM.Server.Common hiding - (Instrument, ) - -import qualified Sound.ALSA.Sequencer.Event as Event --- import qualified Sound.ALSA.Sequencer.Connect as Connect -import qualified Sound.ALSA.Sequencer.Address as Addr -import qualified Synthesizer.Generic.ALSA.MIDI as Gen - -import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt - -import qualified Sound.MIDI.Controller as Ctrl - -import qualified Synthesizer.CausalIO.Gate as Gate -import qualified Synthesizer.Zip as Zip - -import qualified Synthesizer.Storable.ALSA.Play as Play -import Synthesizer.Storable.ALSA.MIDI (Instrument, ) - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS -import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSet as MCS -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa -import qualified Synthesizer.CausalIO.Process as PIO - -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Storable.Process as CausalSt -import qualified Synthesizer.LLVM.Storable.Signal as SigStL - -import qualified LLVM.Extra.ScalarOrVector as SoV - -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.TimeMixed as EventListTM - -import Control.Arrow ((<<<), (<<^), arr, first, ) -import Control.Category (id, ) -import Control.Monad.Trans.State (evalState, ) - -import qualified Data.Map as Map - -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW --- import qualified Numeric.NonNegative.Chunky as NonNegChunky - -import qualified Number.DimensionTerm as DN - -import Algebra.IntegralDomain (divUp, ) -{- -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Additive as Additive --} - -import Data.Word (Word8, Word32, ) -import Data.Int (Int32, ) - -import Foreign.Storable (Storable, ) -import qualified System.IO as IO -import Control.Exception (bracket, ) - --- import NumericPrelude.Numeric (zero, round, (^?), ) -import Prelude hiding (Real, round, break, id, ) - - -vectorChunkSize :: SVL.ChunkSize -vectorChunkSize = - case Play.defaultChunkSize of - SVL.ChunkSize size -> - SVL.ChunkSize (divUp size vectorSize) - -sampleRatePlain :: Num a => a -sampleRatePlain = Option.defaultSampleRate - -sampleRate :: Option.SampleRate Real -sampleRate = Option.SampleRate Option.defaultSampleRate - -{- | -try to reproduce a space leak --} -sequencePlain :: IO () -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)) $ - let evs = EventList.cons 10 [] evs - in evs - - -chopEvents :: - (NonNeg.C time, Num time) => - time -> - EventListTT.T time body -> - [EventListTT.T time body] -chopEvents chunkSize = - let go evs = - let (chunk,rest) = EventListTT.splitAtTime chunkSize evs - in if EventListTT.duration chunk == 0 - then [] - else chunk : go rest - in go - --- see playFromEvents -writeTest :: - (Storable a) => - PIO.T t (SV.Vector a) -> [t] -> IO () -writeTest (PIO.Cons next create delete) evsChunky = - IO.withFile "/tmp/test.f32" IO.WriteMode $ \h -> - bracket create delete $ - let loop evs s0 = - case evs of - [] -> return () - chunk : rest -> do - (pcm, s1) <- next chunk s0 - SV.hPut h pcm - loop rest s1 - in loop evsChunky - -render :: IO () -render = do - ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky --- ping <- Instr.ping -- not leaky - - writeTest (ping sampleRate 10 440) $ - replicate 10000 $ Gate.chunk 512 Nothing - -sequenceEvents :: [PAlsa.Events] -> IO () -sequenceEvents evs = do - arrange <- CausalSt.makeArranger - - ping <- Instr.pingRelease $/ 1 $/ 0.1 -- leaky --- ping <- Instr.ping -- not leaky - - let proc = - arrange - <<< - arr (EventListTT.mapTime - (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)) - <<< - PAlsa.sequenceCore - Option.defaultChannel - (\ _pgm -> ping sampleRate) - - writeTest proc evs - -sequenceNothing :: IO () -sequenceNothing = - sequenceEvents $ - let evs = EventList.cons 10 [] evs - in chopEvents 512 $ EventListTM.takeTime (10^(7::Int)) evs - - -noteEvent :: - Event.NoteEv -> - Word8 -> - Word8 -> - Word8 -> - Event.T -noteEvent mode chan pitch velocity = - -- Event.simple (Connect.toSubscribers Addr.subscribers) $ - Event.simple Addr.subscribers $ - Event.NoteEv mode $ Event.simpleNote chan pitch velocity - -ctrlEvent :: - Word8 -> - Word32 -> - Int32 -> - Event.T -ctrlEvent chan cc cval = - -- Event.simple (Connect.toSubscribers Addr.subscribers) $ - Event.simple Addr.subscribers $ - Event.CtrlEv Event.Controller $ - Event.Ctrl chan cc cval - -sequenceSingleLong :: IO () -sequenceSingleLong = do - sequenceEvents $ - let evs = EventList.cons 10 [] evs - in chopEvents 512 $ - EventListTM.takeTime (10^(7::Int)) $ - EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs - -sequenceSingleShort :: IO () -sequenceSingleShort = do - sequenceEvents $ - let evs = EventList.cons 10 [] evs - in chopEvents 512 $ - EventListTM.takeTime (10^(7::Int)) $ - EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ - EventList.cons 10 [noteEvent Event.NoteOff 0 60 64] evs - -{- -Although it consumes constant memory, -the memory usage is quite high, -e.g. 40MB for chunk size 100000 and peiod 1100. -This might be caused by the large overlapping in the release phases. -You need only 6MB heap for the same chunksize and period 11000. --} -sequenceLoop :: IO () -sequenceLoop = do - sequenceEvents $ - let evs = - EventList.cons 11001 - [noteEvent Event.NoteOff 0 60 50, - noteEvent Event.NoteOn 0 60 50] evs - in chopEvents 100000 $ - EventListTM.takeTime (10^(7::Int)) $ - EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs - -sequenceStaccato :: IO () -sequenceStaccato = do - sequenceEvents $ - let evs = - EventList.cons 551 [noteEvent Event.NoteOff 0 60 50] $ - EventList.cons 550 [noteEvent Event.NoteOn 0 60 50] evs - in chopEvents 100000 $ - EventListTM.takeTime (10^(7::Int)) $ - EventList.cons 0 [noteEvent Event.NoteOn 0 60 50] evs - - - -sequenceControlledEvents :: [PAlsa.Events] -> IO () -sequenceControlledEvents chunkedEvents = do - opt <- Option.get - arrange <- CausalSt.makeArranger - amp <- - CausalP.processIO - (CausalP.mapSimple StereoInt.interleave <<< - CausalP.envelopeStereo <<< - first (CausalP.mapSimple SoV.replicate)) - - ping <- Instr.pingStereoReleaseFM - - let timeControlPercussive = - Run.controllerExponentialDim Ctrl.attackTime - (DN.time 0.1, DN.time 2.5) (DN.time 0.8) - &+& - Run.controllerExponentialDim Ctrl.releaseTime - (DN.time 0.03, DN.time 0.3) (DN.time 0.1) - - frequencyControlPercussive = - MCS.controllerLinear controllerDetune (0,0.005) 0.001 - &+& - MCS.bendWheelPressure 2 0.04 0.03 - - pingProc vel freq = - ping (Option.sampleRate opt) vel freq - <<< - Zip.arrowSecond - (timeControlPercussive - &+& - ((MCS.controllerExponential controllerTimbre0 (0.3,10) 0.05 - &+& - Run.controllerExponentialDim controllerTimbre1 - (DN.time 0.01, DN.time 10) (DN.time 5)) - &+& - ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2 - &+& - Run.controllerExponentialDim Ctrl.soundController7 - (DN.time 0.03, DN.time 1) (DN.time 0.5)) - &+& - frequencyControlPercussive))) - - let proc = - arr SigStL.unpackStereoStrict - <<< - amp () - <<< - (MCS.controllerExponential controllerVolume (0.001, 1) (0.2::Float) - <<^ Zip.second) - &+& - (arrange - <<< - arr (EventListTT.mapTime - (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)) - <<< - PAlsa.sequenceModulated - (Option.channel opt) (\ _pgm -> pingProc)) - <<< - id &+& MCS.fromChannel (Option.channel opt) - - writeTest proc chunkedEvents - - -sequenceControlled :: IO () -sequenceControlled = - sequenceControlledEvents $ - let evs = EventList.cons 10 [] evs - in chopEvents 512 $ - EventListTM.takeTime (10^(7::Int)) $ - EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] evs - -sequenceControlledModulated :: IO () -sequenceControlledModulated = - sequenceControlledEvents $ - chopEvents 512 $ - EventListTM.takeTime (10^(7::Int)) $ - EventList.cons 0 [noteEvent Event.NoteOn 0 60 64] $ - EventList.fromPairList $ - map (\ev -> (10,[ev])) $ cycle $ - map (ctrlEvent 0 1) [0..127] - - -sampledSound :: IO () -sampledSound = do - opt <- Option.get - - amp <- - CausalP.processIO - (CausalP.mapSimple StereoInt.interleave) - - tomatoSmps <- - Instr.makeSampledSounds (Option.sampleDirectory opt) InstrP.tomatensalat - - let tomato smp vel freq = - smp sampleRate vel freq - <<< - Zip.arrowSecond - (MCS.controllerLinear controllerDetune (0,0.005) 0.001 - &+& - MCS.bendWheelPressure 2 0.04 0.03) - - writeTest - (arr SigStL.unpackStereoStrict - <<< - amp () - <<< - tomato (head tomatoSmps) 0 440) $ - replicate 20 $ - Zip.consChecked "Test.sampledSound" - (Gate.chunk 512 Nothing) - (PCS.Cons Map.empty (EventListTT.pause 512)) diff --git a/src/Synthesizer/LLVM/Server/Common.hs b/src/Synthesizer/LLVM/Server/Common.hs --- a/src/Synthesizer/LLVM/Server/Common.hs +++ b/src/Synthesizer/LLVM/Server/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Server.Common ( Real, SampleRate(SampleRate), @@ -5,55 +6,54 @@ frequency, time, number, control, signal, parameter, frequencyConst, timeConst, ($/), - play, - startMessage, + + chopEvents, piecewiseConstant, transposeModulation, amplitudeFromVelocity, - makeNote, - ) where -import qualified Synthesizer.LLVM.Server.Option as Option -import Synthesizer.LLVM.Server.Option (SampleRate(SampleRate), ) + controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, + controllerFilterCutoff, controllerFilterResonance, + controllerVolume, + ) where -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.ALSA.Sequencer.Address as Addr -import qualified Sound.ALSA.Sequencer.Client as Client -import qualified Sound.ALSA.Sequencer.Port as Port -import qualified Sound.ALSA.Sequencer.Queue as Queue -import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import qualified Sound.MIDI.Controller as Ctrl +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Sound.ALSA.PCM as ALSA -import qualified Synthesizer.Storable.ALSA.Play as Play -import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt +import qualified Synthesizer.MIDI.Storable as MidiSt import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.LLVM.ALSA.BendModulation as BM +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM 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.Class as Class -import qualified LLVM.Core as LLVM -import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.EventList.Relative.TimeTime as EventListTT + +import qualified Numeric.NonNegative.Class as NonNeg + import Foreign.Storable (Storable, ) import Control.Arrow (arr, (^<<), ) -import qualified Algebra.Additive as Additive +import Prelude hiding (Real, ) -import Data.Word (Word8, ) -import NumericPrelude.Numeric (zero, round, ) -import Prelude hiding (Real, round, break, ) +newtype SampleRate a = SampleRate a + deriving (Show) +instance Functor SampleRate where + fmap f (SampleRate sr) = SampleRate (f sr) + type Real = Float -type Instrument a sig = SampleRate a -> AlsaSt.Instrument a sig +type Instrument a sig = SampleRate a -> MidiSt.Instrument a sig frequency :: (p -> Real) -> Param.T (SampleRate Real, p) Real @@ -91,29 +91,25 @@ f $/ x = fmap ($x) f --- ToDo: do not record the empty chunk that is inserted for latency -{-# INLINE play #-} -play :: - (Additive.C y, ALSA.SampleFmt y) => - Option.T -> Double -> SigSt.T y -> IO () -play opts rate = - Play.auto (Play.makeSink - (Option.device opts) (Option.periodTime opts) (round rate)) . - SigSt.append (SigSt.replicate (Option.chunkSize opts) (Option.latency opts) zero) --- FiltG.delayPosLazySize (Option.chunkSize opts) (Option.latency opts) --- FiltG.delayPos (Option.latency opts) - - -startMessage :: String -startMessage = - "run 'aconnect' to connect to the MIDI controller" +-- might be moved to event-list package +chopEvents :: + (NonNeg.C time, Num time) => + time -> + EventListTT.T time body -> + [EventListTT.T time body] +chopEvents chunkSize = + let go evs = + let (chunk,rest) = EventListTT.splitAtTime chunkSize evs + in if EventListTT.duration chunk == 0 + then [] + else chunk : go rest + in go piecewiseConstant :: (Storable a, - Class.MakeValueTuple a al, - Memory.C al am, - LLVM.IsSized am as) => + Class.MakeValueTuple a, Class.ValueTuple a ~ al, + Memory.C al) => Param.T p (PC.T a) -> SigP.T p al piecewiseConstant pc = SigP.piecewiseConstant @@ -134,24 +130,13 @@ amplitudeFromVelocity vel = 4**vel --- cf. synthesizer-alsa:Synthesizer.Storable.ALSA.Server.Test -makeNote :: Event.NoteEv -> Word8 -> Event.T -makeNote typ pit = - Event.Cons - { Event.highPriority = False - , Event.tag = 0 - , Event.queue = Queue.direct - , Event.timestamp = - Event.RealTime $ RealTime.fromInteger 0 - , Event.source = Addr.Cons { - Addr.client = Client.subscribers, - Addr.port = Port.unknown - } - , Event.dest = Addr.Cons { - Addr.client = Client.subscribers, - Addr.port = Port.unknown - } - , Event.body = - Event.NoteEv typ - (Event.simpleNote 0 pit 64) - } +controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, + controllerFilterCutoff, controllerFilterResonance, + controllerVolume :: VoiceMsg.Controller +controllerAttack = Ctrl.attackTime +controllerDetune = Ctrl.chorusDepth -- Ctrl.effect3Depth +controllerTimbre0 = Ctrl.soundVariation +controllerTimbre1 = Ctrl.timbre +controllerFilterCutoff = Ctrl.effect4Depth +controllerFilterResonance = Ctrl.effect5Depth +controllerVolume = Ctrl.volume diff --git a/src/Synthesizer/LLVM/Server/CommonPacked.hs b/src/Synthesizer/LLVM/Server/CommonPacked.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/CommonPacked.hs @@ -0,0 +1,69 @@ +module Synthesizer.LLVM.Server.CommonPacked where + +import Synthesizer.LLVM.Server.Common + +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial + +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified Data.List.Match as Match + +import qualified Algebra.Additive as Additive + +import qualified Types.Data.Num as TypeNum + +import Control.Arrow (arr, ) + +import NumericPrelude.Numeric ((+), (-), (*), ) +import Prelude hiding (Real, (+), (-), (*), ) + + +sumNested :: (Additive.C a) => [a] -> a +sumNested [] = Additive.zero +sumNested xs@(_:rs) = + let ys = xs ++ Match.take rs (sum2 ys) + in last ys + +sum2 :: (Additive.C a) => [a] -> [a] +sum2 (x:y:rest) = (x+y) : sum2 rest +sum2 xs = xs + + +-- maybe this can be merged into a PCS.controllerDiscrete +stair :: Real -> Real +stair i = + let n = fromIntegral (round i :: Int) + r = i - n + in n + 0.01*r + + +type Param p = Param.T (SampleRate Real, p) +type SigP p = SigP.T (SampleRate Real, p) +type CausalP p = CausalP.T (SampleRate Real, p) +type FuncP p = F.T (SampleRate Real, p) + + +type Vector = Serial.Plain VectorSize Real +type VectorValue = Serial.Value VectorSize Real +type VectorSize = TypeNum.D4 + + +vectorSize :: Int +vectorSize = TypeNum.fromIntegerT (undefined :: VectorSize) + +vectorRate :: Fractional a => SampleRate a -> a +vectorRate (SampleRate sampleRate) = + sampleRate / fromIntegral vectorSize + + +vectorTime :: (p -> Real) -> Param p Real +vectorTime param = + arr (\(SampleRate sampleRate, p) -> + param p * sampleRate / fromIntegral vectorSize) + +noiseReference :: Real -> Param p Real +noiseReference freq = + arr (\(SampleRate sampleRate, _p) -> sampleRate/freq) diff --git a/src/Synthesizer/LLVM/Server/Option.hs b/src/Synthesizer/LLVM/Server/Option.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/Option.hs +++ /dev/null @@ -1,196 +0,0 @@ -module Synthesizer.LLVM.Server.Option ( - T(..), - get, - defaultChannel, - Play.defaultChunkSize, - defaultSampleRate, - defaultLatency, - SampleRate(SampleRate), - sampleRate, - ) where - -import qualified Synthesizer.Storable.ALSA.Play as Play -import qualified Synthesizer.Generic.Signal as SigG -import qualified Data.StorableVector.Lazy as SVL -import Synthesizer.EventList.ALSA.MIDI (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 NumericPrelude.Numeric as NP -import Prelude hiding (Real, ) - - -data T = - Cons { - device :: Play.Device, - clientName :: ClientName, - channel, extraChannel :: ChannelMsg.Channel, - sampleDirectory :: FilePath, - sampleRateInt :: SampleRate Integer, - chunkSize :: SVL.ChunkSize, - lazySize :: SigG.LazySize, - periodTime :: Double, - latency :: Int - } - deriving (Show) - - -deflt :: T -deflt = - Cons { - device = Play.defaultDevice, - clientName = defaultClientName, - channel = defaultChannel, - extraChannel = ChannelMsg.toChannel 1, - sampleDirectory = "speech", - sampleRateInt = SampleRate defaultSampleRate, - chunkSize = Play.defaultChunkSize, - lazySize = error "Option.lazySize must be initialized after option parsing", - periodTime = error "Option.periodTime must be initialized after option parsing", - 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 - -- 256 - 1024 - - -newtype SampleRate a = SampleRate a - deriving (Show) - -instance Functor SampleRate where - fmap f (SampleRate sr) = SampleRate (f sr) - - -sampleRate :: Num a => T -> SampleRate a -sampleRate = fmap fromInteger . sampleRateInt - - -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{sampleRateInt = SampleRate 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" : - [] - - -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 - fmap - (\actual -> - case chunkSize actual of - SVL.ChunkSize size -> - actual { - lazySize = SigG.LazySize size, - periodTime = - NP.fromIntegral size NP./ - case sampleRate actual of SampleRate sr -> sr - }) $ - foldl (>>=) - (return deflt) - opts 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 @@ -23,6 +23,12 @@ where d is the tone period and f is non-linear, maybe chaotic function. In order to limit the appearance of chaotic waveforms, we could combine this with a lowpass filter. + let attack and release depend on On and Off velocity + tineStereoFM: + continuous control of the modulation index + by linear interpolation of waves between modulations with integral indices. + E.g. modulation index 2.3 means + 0.7*modulation with index 2 and 0.3*modulation with index 3. effects: reverb and controllable delay @@ -67,45 +73,42 @@ {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Server.Packed.Instrument where +import Synthesizer.LLVM.Server.CommonPacked import Synthesizer.LLVM.Server.Common -import qualified Synthesizer.LLVM.ALSA.BendModulation as BM -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC -import qualified Synthesizer.EventList.ALSA.MIDI as Ev +import qualified Synthesizer.LLVM.Server.SampledSound as Sample +import qualified Synthesizer.LLVM.MIDI.BendModulation as BM +import qualified Synthesizer.MIDI.PiecewiseConstant as PC +import qualified Synthesizer.MIDI.EventList as Ev -import qualified Sound.Sox.Read as SoxRead -import qualified Sound.Sox.Option.Format as SoxOption import System.FilePath ((), ) -import Control.Exception (bracket, ) -import Synthesizer.Storable.ALSA.MIDI (chunkSizesFromLazyTime, ) +import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime, ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.Moog as MoogL -import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL +import qualified Synthesizer.LLVM.MIDI as MIDIL import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Frame as Frame -import qualified Synthesizer.LLVM.SerialVector as Serial +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), ) +import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), ) import Synthesizer.LLVM.Parameterized.Signal (($#), ) -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Monad as LM import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM -import qualified Data.TypeLevel.Num as TypeNum - -import Control.Arrow.Monad ((=<<<), listen, ) -import qualified Data.HList as HL +import qualified Types.Data.Num as TypeNum import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Storable.Signal as SigSt @@ -118,11 +121,9 @@ import Control.Category (id, ) import Control.Applicative (liftA2, liftA3, ) import Data.Traversable (traverse, ) - -import qualified Data.List.Match as Match -import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) +import qualified Data.Traversable as Trav -import Data.Int (Int32, ) +import Data.Tuple.HT (fst3, snd3, thd3, ) {- import qualified Numeric.NonNegative.Class as NonNeg @@ -137,43 +138,6 @@ -sumNested :: (Additive.C a) => [a] -> a -sumNested [] = Additive.zero -sumNested xs@(_:rs) = - let ys = xs ++ Match.take rs (sum2 ys) - in last ys - -sum2 :: (Additive.C a) => [a] -> [a] -sum2 (x:y:rest) = (x+y) : sum2 rest -sum2 xs = xs - - -type Param p = Param.T (SampleRate Real, p) -type SigP p = SigP.T (SampleRate Real, p) -type CausalP p = CausalP.T (SampleRate Real, p) - - -type Vector = LLVM.Vector VectorSize Real -type VectorSize = TypeNum.D4 - - -vectorSize :: Int -vectorSize = TypeNum.toInt (undefined :: VectorSize) - -vectorRate :: Fractional a => SampleRate a -> a -vectorRate (SampleRate sampleRate) = - sampleRate / fromIntegral vectorSize - - -vectorTime :: (p -> Real) -> Param p Real -vectorTime param = - arr (\(SampleRate sampleRate, p) -> - param p * sampleRate / fromIntegral vectorSize) - -noiseReference :: Real -> Param p Real -noiseReference freq = - arr (\(SampleRate sampleRate, _p) -> sampleRate/freq) - frequencyControl :: (p -> PC.T Real) -> Param p (PC.T Real) frequencyControl param = arr (\(SampleRate sampleRate, p) -> fmap (/sampleRate) $ param p) @@ -196,11 +160,11 @@ frequencyFromBendModulation :: {- (Storable a, - Class.MakeValueTuple a (Value a)) => + Class.MakeValueTuple a, ValueTuple a ~ (Value a)) => -} Param p Real -> Param p (PC.T (BM.T Real)) -> - SigP p (LLVM.Value Vector) + SigP p VectorValue frequencyFromBendModulation speed fmFreq = MIDIL.frequencyFromBendModulationPacked speed $* piecewiseConstant fmFreq @@ -208,7 +172,7 @@ stereoFrequenciesFromDetuneBendModulation :: Param p Real -> Param p (PC.T Real, PC.T (BM.T Real)) -> - SigP p (Stereo.T (LLVM.Value Vector)) + SigP p (Stereo.T VectorValue) stereoFrequenciesFromDetuneBendModulation speed detFmFreq = (CausalP.envelopeStereo $< frequencyFromBendModulation speed @@ -219,13 +183,13 @@ (fmap (\(det,_fm) -> det) detFmFreq) piecewiseConstantVector :: - Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector) + Param.T p (PC.T Real) -> SigP.T p VectorValue {- (Storable a, - Class.MakeValueTuple a al, + Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al am, LLVM.IsSized am as) => - Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al) + Param.T p (PC.T a) -> SigP.T p (Serial.Value n al) -} piecewiseConstantVector = piecewiseConstant . fmap (fmap (Serial.replicate)) @@ -294,10 +258,10 @@ (sr, ((phase, phaseDecay), shape, (detune,fm,freq))) (env dec rel vcsize sr vel dur)) (CausalP.runStorableChunky - (let phase = number (fst.fst3) - decay = time (snd.fst3) - shape = control snd3 - fm = detuneModulation thd3 + (let phase = number (fst.fst3) :: Param ((Real,a), b, c) Real + decay = time (snd.fst3) :: Param ((a,Real), b, c) Real + shape = control snd3 :: Param (a, PC.T Real, c) (PC.T Real) + fm = detuneModulation thd3 :: Param (a, b, (PC.T Real, PC.T (BM.T Real), Real)) (PC.T Real, PC.T (BM.T Real)) in CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled (CausalPS.shapeModOsci WaveL.rationalApproxSine1) @@ -330,6 +294,10 @@ (let phs = control (fst.fst) shp = control (snd.fst) fm = detuneModulation snd + chanOsci :: + CausalP p + ((VectorValue, VectorValue), VectorValue) + VectorValue chanOsci = ((CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< @@ -346,6 +314,9 @@ $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm))) pingReleaseEnvelope + +type Triple a = (a, a, a) + bellStereoFM :: IO (Real -> Real -> PC.T Real -> @@ -364,6 +335,13 @@ vel = number snd3 env4 = signal (fst.thd3) env7 = signal (snd.thd3) + osci :: + (Triple VectorValue -> VectorValue) -> + Param.T p Real -> + Param.T p Real -> + CausalP.T p + (Triple VectorValue, Stereo.T VectorValue) + (Stereo.T VectorValue) osci sel v d = CausalP.envelopeStereo <<< @@ -414,6 +392,14 @@ vel = number (fst3.thd3) env4 = signal (snd3.thd3) env7 = signal (thd3.thd3) + + osci :: + (Triple VectorValue -> VectorValue) -> + Param.T p Real -> + Param.T p Real -> + CausalP.T p + (Triple VectorValue, VectorValue) + VectorValue osci sel v d = CausalP.envelope <<< @@ -423,6 +409,13 @@ (CausalPS.osciSimple WaveL.approxSine4 $< zero) <<< CausalPS.amplify d)) + + noise :: + (Triple VectorValue -> VectorValue) -> + Param (a, (PC.T Real, PC.T Real), c) Real -> + CausalP (a, (PC.T Real, PC.T Real), c) + (Triple VectorValue, VectorValue) + VectorValue noise sel d = (CausalP.envelope $< piecewiseConstantVector noiseAmp) @@ -446,7 +439,7 @@ <<< CausalP.feedFst (piecewiseConstant noiseReson) <<< - CausalP.mapSimple Frame.subsampleVector + CausalP.mapSimple Serial.subsample <<< CausalPS.amplify d)) in liftA2 Stereo.cons @@ -570,7 +563,7 @@ (let fm = modulation id osci :: Param.T fm Real -> - CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector) + CausalP.T fm VectorValue VectorValue osci d = (CausalPS.osciSimple WaveL.saw $< zero) <<< CausalPS.amplify d @@ -616,8 +609,8 @@ Param p (PC.T Real) -> Param p Real -> CausalP p - (Stereo.T (LLVM.Value Vector)) - (Stereo.T (LLVM.Value Vector)) + (Stereo.T VectorValue) + (Stereo.T VectorValue) tineControlledProc index depth vel = CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) @@ -637,12 +630,11 @@ &&& id tineControlledFnProc index depth vel = - ((\freq -> - CausalP.stereoFromMono - (CausalPS.osciSimple WaveL.approxSine2) - <<< - Stereo.interleave - ^<< + F.withArgs $ \freq -> + CausalP.stereoFromMono + (CausalPS.osciSimple WaveL.approxSine2) + $& + liftA2 (liftA2 (,)) ((CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) @@ -653,13 +645,9 @@ <<< (CausalP.envelopeStereo $< piecewiseConstantVector index) - <<< - listen freq) - &&& - listen freq) --- =<<< listen HL.hNil - =<<< arr HL.hHead) - <<< arr (\freq -> HL.hCons freq HL.hNil) + $& + freq) + freq tineControlledFM :: IO (Real -> Real -> @@ -691,13 +679,18 @@ Param p (PC.T Real) -> Param p Real -> CausalP p - (Stereo.T (LLVM.Value Vector)) - (Stereo.T (LLVM.Value Vector)) + (Stereo.T VectorValue) + (Stereo.T VectorValue) fenderProc fade index depth vel = - ((\stereoFreq -> - let channel_n_1 freq = + F.withArgs $ \stereoFreq -> + let {- + channel_n_1 :: + FuncP p VectorValue VectorValue -> + FuncP p VectorValue VectorValue + -} + channel_n_1 freq = CausalPS.osciSimple WaveL.approxSine2 - <<< + $& ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) @@ -707,32 +700,35 @@ <<< (CausalP.envelope $< piecewiseConstantVector index) - <<< + $& freq) - &&& + &|& freq + {- + channel_1_2 :: + FuncP p VectorValue VectorValue -> + FuncP p VectorValue VectorValue + -} channel_1_2 freq = CausalPS.osciSimple WaveL.approxSine2 - <<< + $& ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero) - <<< + $& freq) - &&& - (CausalPS.amplify 2 <<< freq) + &|& + (CausalPS.amplify 2 $& freq) in (CausalP.stereoFromMonoControlled (fadeProcess - (channel_n_1 id) - (channel_1_2 id)) + (F.compile $ channel_n_1 $ F.lift id) + (F.compile $ channel_1_2 $ F.lift id)) $< piecewiseConstantVector fade) - <<< - listen stereoFreq) - =<<< arr HL.hHead) - <<< arr (\freq -> HL.hCons freq HL.hNil) + $& + stereoFreq fenderFM :: IO (Real -> Real -> @@ -764,8 +760,8 @@ Param p Real -> Param p (PC.T Real) -> CausalP p - (Stereo.T (LLVM.Value Vector)) - (Stereo.T (LLVM.Value Vector)) + (Stereo.T VectorValue) + (Stereo.T VectorValue) fmModulator vel n depth = (CausalP.envelopeStereo $< SigP.envelope @@ -849,11 +845,11 @@ vel = number (fst.thd3) fm = detuneModulation (snd.thd3) partial :: - LLVM.Value Vector -> Int32 -> LLVM.Value Vector -> - LLVM.CodeGenFunction r (LLVM.Value Vector) + VectorValue -> Int -> VectorValue -> + LLVM.CodeGenFunction r VectorValue partial amp n t = A.mul amp =<< - WaveL.partial WaveL.approxSine2 (LLVM.valueOf n) t + WaveL.partial WaveL.approxSine2 n t in CausalP.envelopeStereo $> (CausalP.stereoFromMono (CausalPS.shapeModOsci @@ -893,13 +889,14 @@ Param p (PC.T Real) -> Param p Real -> CausalP p - (Stereo.T (LLVM.Value Vector)) - (Stereo.T (LLVM.Value Vector)) + (Stereo.T VectorValue) + (Stereo.T VectorValue) resonantFMSynthProc reson index depth vel = - ((\stereoFreq -> - let chan freq = + F.withArgs $ \stereoFreq -> + let -- chan :: FuncP p inp VectorValue -> FuncP p inp VectorValue + chan freq = CausalPS.osciSimple WaveL.approxSine2 - <<< + $& ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) @@ -908,27 +905,24 @@ UniFilter.lowpass ^<< CtrlPS.process - <<< + $& (CausalP.zipWithSimple UniFilterL.parameter <<< CausalP.feedFst (piecewiseConstant reson) <<< (CausalP.envelope $< piecewiseConstant index) <<< - CausalP.mapSimple Frame.subsampleVector - <<< + CausalP.mapSimple Serial.subsample + $& freq) - &&& + &|& ((CausalPS.osciSimple WaveL.saw $< zero) - <<< + $& freq)) - &&& + &|& freq - in CausalP.stereoFromMono (chan id) - <<< - listen stereoFreq) - =<<< arr HL.hHead) - <<< arr (\freq -> HL.hCons freq HL.hNil) + in Trav.traverse chan $ + Stereo.sequence stereoFreq resonantFMSynth :: IO (Real -> Real -> @@ -956,8 +950,8 @@ phaserOsci :: - (Param.T p Real -> CausalP.T p a (LLVM.Value Vector)) -> - CausalP.T p a (Stereo.T (LLVM.Value Vector)) + (Param.T p Real -> CausalP.T p a VectorValue) -> + CausalP.T p a (Stereo.T VectorValue) phaserOsci osci = CausalPS.amplifyStereo 0.25 <<< @@ -980,8 +974,8 @@ osci :: Param.T (det,fm) Real -> CausalP.T (det,fm) - (LLVM.Value Vector, LLVM.Value Vector) - (LLVM.Value Vector) + (VectorValue, VectorValue) + VectorValue osci d = (CausalPS.osciSimple WaveL.saw $< zero) <<< @@ -1021,8 +1015,8 @@ arcStringStereoFM :: (forall r. - LLVM.Value Vector -> - LLVM.CodeGenFunction r (LLVM.Value Vector)) -> + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> IO (Real -> PC.T Real -> PC.T Real -> @@ -1037,9 +1031,9 @@ softStringShapeCore :: (forall r. - LLVM.Value Vector -> - LLVM.Value Vector -> - LLVM.CodeGenFunction r (LLVM.Value Vector)) -> + VectorValue -> + VectorValue -> + LLVM.CodeGenFunction r VectorValue) -> IO (Real -> PC.T Real -> PC.T Real -> @@ -1055,11 +1049,11 @@ osci :: Param.T (mod,fm) Real -> CausalP.T (mod,fm) - (LLVM.Value Vector, + (VectorValue, {- wave shape parameter -} - (LLVM.Value Vector, LLVM.Value Vector) + (VectorValue, VectorValue) {- detune, frequency modulation -}) - (LLVM.Value Vector) + VectorValue osci d = CausalPS.shapeModOsci wave <<< @@ -1095,11 +1089,11 @@ osci :: Param.T (mod,fm) Real -> CausalP.T (mod,fm) - ((LLVM.Value Vector, LLVM.Value Vector) + ((VectorValue, VectorValue) {- phase modulation depth, modulator distortion -}, - (LLVM.Value Vector, LLVM.Value Vector) + (VectorValue, VectorValue) {- detune, frequency modulation -}) - (LLVM.Value Vector) + VectorValue osci d = CausalPS.osciSimple WaveL.approxSine2 <<< @@ -1132,7 +1126,7 @@ softStringReleaseEnvelope -stereoNoise :: SigP p (Stereo.T (LLVM.Value Vector)) +stereoNoise :: SigP p (Stereo.T VectorValue) stereoNoise = traverse (\uid -> SigPS.noise uid (noiseReference 20000)) @@ -1141,13 +1135,13 @@ windCore :: Param p (PC.T Real) -> Param p (PC.T (BM.T Real)) -> - SigP p (Stereo.T (LLVM.Value Vector)) + SigP p (Stereo.T VectorValue) windCore reson fm = CausalP.stereoFromMonoControlled CtrlPS.process $< SigP.zipWithSimple (MoogL.parameter TypeNum.d8) (piecewiseConstant reson) - (SigP.mapSimple Frame.subsampleVector + (SigP.mapSimple Serial.subsample (frequencyFromBendModulation (frequencyConst 0.2) fm)) $* stereoNoise @@ -1199,7 +1193,7 @@ ((CausalP.stereoFromMonoControlled (fadeProcess (arr snd) CtrlPS.process <<< - first (CausalP.mapSimple SoV.replicate) + first (CausalP.mapSimple Serial.upsample) <<^ (\((k,p),x) -> (k,(p,x)))) $< SigP.zip @@ -1337,11 +1331,11 @@ osci :: Param.T p Real -> CausalP.T p - (LLVM.Value Vector, + (VectorValue, {- wave shrink/replication factor -} - (LLVM.Value Vector, LLVM.Value Vector) + (VectorValue, VectorValue) {- detune, frequency modulation -}) - (LLVM.Value Vector) + VectorValue osci d = CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< @@ -1365,22 +1359,8 @@ adsr -data SamplePositions = - SamplePositions { - sampleStart, sampleLength, - sampleLoopStart, sampleLoopLength :: Int - } - -data SampledSound = - SampledSound { - sampleData :: SigSt.T Real, - samplePositions :: SamplePositions, - samplePeriod :: Real - } - - sampledSound :: - IO (SampledSound -> + IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSound = @@ -1395,24 +1375,15 @@ let fmSig = freqMod (chunkSizesFromLazyTime (PC.duration fm)) - (sr, (fm, freq*samplePeriod smp)) :: SigSt.T Vector - pos = samplePositions smp + (sr, (fm, freq * Sample.period smp)) :: SigSt.T Vector + pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel - (attack,sustain) = - mapPair - (SigSt.drop (sampleStart pos), - SigSt.take (sampleLoopLength pos)) $ - SigSt.splitAt (sampleLoopStart pos) $ - sampleData smp - release = - SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ - SigSt.take (sampleStart pos + sampleLength pos) $ - sampleData smp + (attack, sustain, release) = Sample.parts smp in (\cont -> osc cont (sr, (amp, attack `SigSt.append` - SVL.cycle (SigSt.take (sampleLoopLength pos) sustain), + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain), chunkSizesFromLazyTime dur)) fmSig) (osc (const SigSt.empty) @@ -1440,7 +1411,7 @@ sampledSoundLeaky :: - IO (SampledSound -> + IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSoundLeaky = @@ -1456,24 +1427,15 @@ SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm)) - (sr, (fm, freq*samplePeriod smp)) :: SigSt.T Vector) - pos = samplePositions smp + (sr, (fm, freq * Sample.period smp)) :: SigSt.T Vector) + pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel - (attack,sustain) = - mapPair - (SigSt.drop (sampleStart pos), - SigSt.take (sampleLoopLength pos)) $ - SigSt.splitAt (sampleLoopStart pos) $ - sampleData smp - release = - SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ - SigSt.take (sampleStart pos + sampleLength pos) $ - sampleData smp + (attack, sustain, release) = Sample.parts smp in osc (sr, (amp, attack `SigSt.append` - SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))) + SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))) sustainFM `SigSt.append` osc (sr, (amp,release)) releaseFM) @@ -1494,19 +1456,10 @@ (frequencyFromBendModulation (frequencyConst 3) (modulation id))) -loadSound :: FilePath -> IO (SVL.Vector Real) -loadSound path = - bracket (SoxRead.open SoxOption.none path) SoxRead.close $ - SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize) - - -type SampleInfo = (FilePath, [SamplePositions], Real) - - -- ToDo: flag failure if files cannot be found, or just remain silent makeSampledSounds :: FilePath -> - SampleInfo -> + Sample.Info -> IO [-- PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)] @@ -1519,50 +1472,7 @@ -} liftA2 (\makeSmp smp -> - map (\pos -> makeSmp (SampledSound smp pos period)) + map (\pos -> makeSmp (Sample.Cons smp pos period)) positions) sampledSound - (loadSound (dir file)) - - -tomatensalatPositions :: [SamplePositions] -tomatensalatPositions = - SamplePositions 0 29499 12501 15073 : - SamplePositions 29499 31672 38163 17312 : - SamplePositions 67379 28610 81811 10667 : - SamplePositions 95989 31253 106058 16111 : - SamplePositions 127242 38596 136689 11514 : - [] - -tomatensalat :: SampleInfo -tomatensalat = - ("tomatensalat2.wav", tomatensalatPositions, 324.5) - - -halPositions :: [SamplePositions] -halPositions = --- SamplePositions 2371 25957 7362 6321 : - SamplePositions 2371 25957 (2371+25957) 1 : - SamplePositions 40546 34460 63540 9546 : - SamplePositions 79128 32348 94367 14016 : - SamplePositions 112027 21227 125880 5500 : - SamplePositions 146057 23235 168941 352 : - [] - -hal :: SampleInfo -hal = - ("haskell-in-leipzig2.wav", halPositions, 316) - - -graphentheoriePositions :: [SamplePositions] -graphentheoriePositions = - SamplePositions 0 29524 13267 14768 : - SamplePositions 29524 35333 47624 9968 : - SamplePositions 64857 31189 73818 16408 : - SamplePositions 96046 31312 106206 18504 : - SamplePositions 127358 32127 132469 16530 : - [] - -graphentheorie :: SampleInfo -graphentheorie = - ("graphentheorie0.wav", graphentheoriePositions, 301.15) + (Sample.load (dir file)) diff --git a/src/Synthesizer/LLVM/Server/Packed/Run.hs b/src/Synthesizer/LLVM/Server/Packed/Run.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/Packed/Run.hs +++ /dev/null @@ -1,504 +0,0 @@ -module Synthesizer.LLVM.Server.Packed.Run where - -import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr -import qualified Synthesizer.LLVM.Server.Option as Option -import Synthesizer.LLVM.Server.Packed.Instrument - (Vector, VectorSize, vectorSize, ) -import Synthesizer.LLVM.Server.Common - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.EventList.ALSA.MIDI as Ev -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS -import qualified Synthesizer.Generic.ALSA.MIDI as Gen - -import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo - -import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import qualified Synthesizer.LLVM.Wave as WaveL -import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($<), ($*), ) -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import qualified LLVM.Core as LLVM - -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL - -import qualified Synthesizer.Plain.Filter.Recursive as FiltR -import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter - -import qualified Sound.MIDI.Controller as Ctrl -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Sound.MIDI.Message.Channel as ChannelMsg - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.MixedTime as EventListMT - -import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, ) -import Control.Arrow ((<<<), (^<<), arr, first, {- second, -} ) -import Control.Applicative (pure, {- liftA, liftA2, -} liftA3, (<*>), ) -import Control.Monad.Trans.State (evalState, ) - -{- -import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) - -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky --} -import Algebra.IntegralDomain (divUp, ) - -import NumericPrelude.Numeric (zero, round, (^?), ) -import Prelude hiding (Real, round, break, ) - - - -vectorChunkSize :: Option.T -> SVL.ChunkSize -vectorChunkSize opts = - case Option.chunkSize opts of - SVL.ChunkSize size -> - SVL.ChunkSize (divUp size vectorSize) - -sampleRate :: Num a => Option.T -> a -sampleRate opt = - case Option.sampleRate opt of - SampleRate sr -> sr - - -{-# INLINE withMIDIEventsMono #-} -withMIDIEventsMono :: - Option.T -> - (Option.T -> Double -> SigSt.T Real -> IO b) -> - (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b -withMIDIEventsMono opt action proc = - let rate = sampleRate opt - in do - putStrLn startMessage - Ev.withMIDIEvents - (Option.clientName opt) - (Option.periodTime opt) (rate / fromIntegral vectorSize) $ - action opt rate . SigStL.unpack . proc - - -type StereoVector = StereoInt.T VectorSize Real - -{-# INLINE withMIDIEventsStereo #-} -withMIDIEventsStereo :: - Option.T -> - (Option.T -> Double -> SigSt.T (Stereo.T Real) -> IO b) -> - (EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) -> - IO b -withMIDIEventsStereo opt action proc = - let rate = sampleRate opt - in do - putStrLn startMessage - Ev.withMIDIEvents - (Option.clientName opt) - (Option.periodTime opt) (rate / fromIntegral vectorSize) $ - action opt rate . SigStL.unpackStereo . proc - - --- maybe this can be merged into a PCS.controllerDiscrete -stair :: Real -> Real -stair i = - let n = fromIntegral (round i :: Int) - r = i - n - in n + 0.01*r - - -frequencyModulation :: IO () -frequencyModulation = do - opt <- Option.get - osc <- - SigP.runChunky - ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector)) - $* Instr.frequencyFromBendModulation - (frequencyConst 10) - (Instr.modulation (\fm -> (fm,880)))) - withMIDIEventsMono opt play $ - osc (vectorChunkSize opt) . (,) (Option.sampleRate opt) . - evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) - - - -keyboard :: IO () -keyboard = do - opt <- Option.get - sound <- - Instr.pingRelease - $/ 0.4 $/ 0.1 $/ vectorChunkSize opt $/ Option.sampleRate opt - amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2) - arrange <- SigStL.makeArranger - withMIDIEventsMono opt play $ - (amp () :: SigSt.T Vector -> SigSt.T Vector) . - arrange (vectorChunkSize opt) . - evalState (Gen.sequence (Option.channel opt) sound) - -keyboardStereo :: IO () -keyboardStereo = do - opt <- Option.get - sound <- - Instr.pingStereoRelease - $/ 0.4 $/ 0.1 $/ vectorChunkSize opt $/ Option.sampleRate opt - amp <- - CausalP.runStorableChunky - (CausalP.mapSimple StereoInt.interleave <<< - (CausalPS.amplifyStereo $# 0.2)) - arrange <- SigStL.makeArranger - withMIDIEventsStereo opt play $ - (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) . - arrange (vectorChunkSize opt) . - evalState (Gen.sequence (Option.channel opt) sound) - - -keyboardFM :: IO () -keyboardFM = do - opt <- Option.get - str <- Instr.softStringFM - amp <- - CausalP.runStorableChunky - (CausalP.mapSimple StereoInt.interleave <<< - (CausalP.amplifyStereo $# 0.2)) - arrange <- SigStL.makeArranger - withMIDIEventsStereo opt play $ - (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) . - arrange (vectorChunkSize opt) . - evalState - (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 - Gen.sequenceModulated - fm (Option.channel opt) (flip str (Option.sampleRate opt))) - -keyboardFMMulti :: IO () -keyboardFMMulti = do - opt <- Option.get - str <- Instr.softStringFM - tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 $/ vectorChunkSize opt - amp <- - CausalP.runStorableChunky - (CausalP.mapSimple StereoInt.interleave <<< - (CausalP.amplifyStereo $# 0.2)) - arrange <- SigStL.makeArranger - withMIDIEventsStereo opt play $ - (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) . - arrange (vectorChunkSize opt) . - evalState - (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 - Gen.sequenceModulatedMultiProgram - fm (Option.channel opt) - (VoiceMsg.toProgram 1) - (map (\sound fmlocal -> sound fmlocal $ Option.sampleRate opt) [str, tin])) - - -controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, - controllerFilterCutoff, controllerFilterResonance, - controllerVolume :: VoiceMsg.Controller -controllerAttack = Ctrl.attackTime -controllerDetune = Ctrl.chorusDepth -- Ctrl.effect3Depth -controllerTimbre0 = Ctrl.soundVariation -controllerTimbre1 = Ctrl.timbre -controllerFilterCutoff = Ctrl.effect4Depth -controllerFilterResonance = Ctrl.effect5Depth -controllerVolume = Ctrl.volume - -controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, - controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 - :: VoiceMsg.Controller -controllerFMDepth1 = Ctrl.soundController3 -controllerFMDepth2 = Ctrl.soundController5 -controllerFMDepth3 = Ctrl.soundController7 -controllerFMDepth4 = Ctrl.soundController8 -controllerFMPartial1 = Ctrl.generalPurpose1 -controllerFMPartial2 = Ctrl.generalPurpose2 -controllerFMPartial3 = Ctrl.effect1Depth -controllerFMPartial4 = Ctrl.effect2Depth - -keyboardDetuneFMCore :: - FilePath -> - SVL.ChunkSize -> - IO (ChannelMsg.Channel -> VoiceMsg.Program -> - SampleRate Real -> - Ev.Filter (SigSt.T StereoVector)) -keyboardDetuneFMCore smpDir vcsize = do - str0 <- Instr.softStringDetuneFM - ssh0 <- Instr.softStringShapeFM - css0 <- Instr.cosineStringStereoFM - asw0 <- Instr.arcSawStringStereoFM - asn0 <- Instr.arcSineStringStereoFM - asq0 <- Instr.arcSquareStringStereoFM - atr0 <- Instr.arcTriangleStringStereoFM - wnd0 <- Instr.wind - wnp0 <- Instr.windPhaser - fms0 <- Instr.fmStringStereoFM - tin0 <- Instr.tineStereoFM - tnc0 <- Instr.tineControlledFM - fnd0 <- Instr.fenderFM - tnb0 <- Instr.tineBankFM - rfm0 <- Instr.resonantFMSynth - png0 <- Instr.pingStereoRelease - pngFM0 <- Instr.pingStereoReleaseFM - sqr0 <- Instr.squareStereoReleaseFM - bel0 <- Instr.bellStereoFM - ben0 <- Instr.bellNoiseStereoFM - flt0 <- Instr.filterSawStereoFM - brs0 <- Instr.brass - tmt0 <- Instr.makeSampledSounds smpDir Instr.tomatensalat - hal0 <- Instr.makeSampledSounds smpDir Instr.hal - grp0 <- Instr.makeSampledSounds smpDir Instr.graphentheorie - - let evHead = - fmap (EventListMT.switchBodyL - (error "empty controller stream") const) - flt = evalState $ - liftA6 (\rel -> flt0 (4*rel) rel) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - (evHead $ - PCS.controllerExponential controllerTimbre0 (100,10000) 1000) - (evHead $ - PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1) - (pure vcsize) - (PCS.bendWheelPressure 2 0.04 0.03) - png = - (\rel -> png0 (4*rel) rel vcsize) . - evalState - (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - pngFM = evalState $ - liftA6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - (evHead $ - PCS.controllerLinear controllerTimbre0 (0,1) 1) - (PCS.controllerExponential controllerTimbre1 (1/pi,0.001) 0.05) - (pure vcsize) - (PCS.bendWheelPressure 2 0.04 0.03) - sqr = evalState $ - liftA6 (\rel -> sqr0 (4*rel) rel) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) - (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25) - (pure vcsize) - (PCS.bendWheelPressure 2 0.04 0.03) - tin = evalState $ - liftA3 (\rel -> tin0 (4*rel) rel) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - (pure vcsize) - (PCS.bendWheelPressure 2 0.04 0.03) - tnc = evalState $ - liftA6 (\rel -> tnc0 (4*rel) rel) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - (fmap (fmap stair) $ - PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) - (PCS.controllerLinear controllerTimbre1 (0,1.5) 1) - (pure vcsize) - (PCS.bendWheelPressure 2 0.04 0.03) - fnd = evalState $ - pure (\rel -> fnd0 (4*rel) rel) - <*> (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - <*> (fmap (fmap stair) $ - PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14) - <*> (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3) - <*> (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25) - <*> (pure vcsize) - <*> (PCS.bendWheelPressure 2 0.04 0.03) - tnb = evalState $ - pure (\rel -> tnb0 (4*rel) rel) - <*> (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0) - <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0) - <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0) - <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0) - <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1) - <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0) - <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0) - <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0) - <*> (pure vcsize) - <*> (PCS.bendWheelPressure 2 0.04 0.03) - rfm = evalState $ - pure (\rel -> rfm0 (4*rel) rel) - <*> (evHead $ - PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) - <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - <*> (PCS.controllerExponential controllerTimbre1 (1,100) 30) - <*> (PCS.controllerLinear controllerTimbre0 (1,15) 3) - <*> (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1) - <*> (pure vcsize) - <*> (PCS.bendWheelPressure 2 0.04 0.03) - bel = evalState $ - liftA4 (\rel -> bel0 (2*rel) rel) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) - (PCS.controllerLinear controllerDetune (0,0.005) 0.001) - (pure vcsize) - (PCS.bendWheelPressure 2 0.05 0.02) - ben = evalState $ - liftA5 (\rel -> ben0 (2*rel) rel) - (evHead $ - PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) - (PCS.controllerLinear controllerTimbre0 (0,1) 0.3) - (PCS.controllerExponential controllerTimbre1 (1,1000) 100) - (pure vcsize) - (PCS.bendWheelPressure 2 0.05 0.02) - str = evalState $ - liftA3 str0 - (evHead $ - PCS.controllerExponential controllerAttack (0.02,2) 0.5) - (PCS.controllerLinear controllerDetune (0,0.01) 0.005) - (PCS.bendWheelPressure 2 0.04 0.03) - ssh = evalState $ - liftA4 ssh0 - (evHead $ - PCS.controllerExponential controllerAttack (0.02,2) 0.5) - (PCS.controllerLinear controllerDetune (0,0.01) 0.005) - (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) - (PCS.bendWheelPressure 2 0.04 0.03) - makeArc gen = evalState $ - liftA4 gen - (evHead $ - PCS.controllerExponential controllerAttack (0.02,2) 0.5) - (PCS.controllerLinear controllerDetune (0,0.01) 0.005) - (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5) - (PCS.bendWheelPressure 2 0.04 0.03) - css = makeArc css0 - asw = makeArc asw0 - asn = makeArc asn0 - asq = makeArc asq0 - atr = makeArc atr0 - fms = evalState $ - liftA5 fms0 - (evHead $ - PCS.controllerExponential controllerAttack (0.02,2) 0.5) - (PCS.controllerLinear controllerDetune (0,0.01) 0.005) - (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2) - (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1) - (PCS.bendWheelPressure 2 0.04 0.03) - wnd = evalState $ - liftA3 wnd0 - (evHead $ - PCS.controllerExponential controllerAttack (0.02,2) 0.5) - (PCS.controllerExponential controllerTimbre1 (1,1000) 100) - (PCS.bendWheelPressure 12 0.8 0) - wnp = evalState $ - liftA5 wnp0 - (evHead $ - PCS.controllerExponential controllerAttack (0.02,2) 0.5) - (PCS.controllerLinear controllerTimbre0 (0,1) 0.5) - (PCS.controllerExponential controllerDetune (50,5000) 500) - (PCS.controllerExponential controllerTimbre1 (1,1000) 100) - (PCS.bendWheelPressure 12 0.8 0) - brs = evalState $ - liftA6 - (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) - (evHead $ - PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) - (PCS.controllerLinear controllerDetune (0,0.01) 0.005) - (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) - (evHead $ - PCS.controllerLinear controllerTimbre1 (1,5) 3) - (pure vcsize) - (PCS.bendWheelPressure 2 0.04 0.03) - freqMod = - evalState - (PCS.bendWheelPressure 2 0.04 0.03) - - arrange <- SigStL.makeArranger - amp <- - CausalP.runStorableChunky - (CausalP.mapSimple StereoInt.interleave <<< - CausalP.envelopeStereo $< - Instr.piecewiseConstantVector (arr id)) - return - (\chan pgm sr -> do - volume <- - PC.controllerExponential chan - controllerVolume - (0.001, 1) 0.2 - - ctrls <- PCS.fromChannel chan - - fmap (amp volume . arrange vcsize) $ - Gen.sequenceModulatedMultiProgram - ctrls chan pgm - (map (\sound fm -> sound fm $ sr) $ - [tnc, fnd, pngFM, flt, bel, ben, sqr, brs, - ssh, fms, css, asn, atr, asq, asw, wnp] ++ - map (.freqMod) tmt0 ++ - map (.freqMod) hal0 ++ - map (.freqMod) grp0 ++ - [str, wnd, png, rfm, tin, tnb])) - - -keyboardDetuneFM :: IO () -keyboardDetuneFM = do - opt <- Option.get - proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt) - withMIDIEventsStereo opt play $ - evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt)) - -keyboardFilter :: IO () -keyboardFilter = do - opt <- Option.get - proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt) - mix <- CausalP.runStorableChunky - (CausalP.mapSimple StereoInt.interleave <<< - CausalP.mix <<< - first (CausalPS.amplifyStereo 0.5 <<< - CausalP.mapSimple StereoInt.deinterleave) - $< SigP.fromStorableVectorLazy (arr id)) - - lowpass0 <- - CausalP.runStorableChunky $ --- CausalPS.amplifyStereo 0.1 <<< - CausalPS.pack - (CausalP.stereoFromMonoControlled - (UniFilter.lowpass ^<< UniFilterL.causalP) $< - (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) - (piecewiseConstant (arr id))) - <<< - CausalP.mapSimple StereoInt.deinterleave - let lowpass :: - PC.T Real -> PC.T Real -> - SigSt.T StereoVector -> SigSt.T (Stereo.T Vector) - lowpass resons freqs = - lowpass0 (fmap UniFilter.parameter - (PC.zipWith FiltR.Pole resons - (fmap (/ sampleRate opt) freqs))) - - withMIDIEventsStereo opt play $ - evalState - (do {- - It is important to retrieve the global controllers - before they are filtered out by PCS.fromChannel. - -} - let freqBnd v = 880 * 2^?(v/24) - freq <- - PC.controllerExponential (Option.extraChannel opt) - controllerFilterCutoff - (freqBnd (-64), freqBnd 63) 5000 - resonance <- - PC.controllerExponential (Option.extraChannel opt) - controllerFilterResonance - (1, 100) 1 - filterMusic <- - proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) (Option.sampleRate opt) - pureMusic <- - proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt) - return - (pureMusic `mix` - lowpass resonance freq filterMusic)) diff --git a/src/Synthesizer/LLVM/Server/Packed/Test.hs b/src/Synthesizer/LLVM/Server/Packed/Test.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/Packed/Test.hs +++ /dev/null @@ -1,727 +0,0 @@ -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 Synthesizer.LLVM.Server.Packed.Instrument - (Vector, vectorSize, - sampleStart, sampleLength, - sampleLoopStart, sampleLoopLength, - samplePositions, sampleData, samplePeriod, ) -import Synthesizer.LLVM.Server.Common hiding - (Instrument, ) - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC -import qualified Synthesizer.Generic.ALSA.MIDI as Gen - -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo - -import qualified Synthesizer.Storable.ALSA.Play as Play -import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, ) - -import qualified Synthesizer.LLVM.ALSA.BendModulation as BM -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import Synthesizer.LLVM.CausalParameterized.Process (($*), ) - -import qualified LLVM.Core as LLVM - -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy.Pattern as SVP -import qualified Data.StorableVector.Lazy as SVL --- import qualified Data.StorableVector as SV - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT - -import Control.Arrow ((<<<), arr, ) -import Control.Applicative (pure, liftA, liftA2, ) -import Control.Monad.Trans.State (evalState, ) - -import Data.Tuple.HT (mapPair, ) - -{- -import qualified Numeric.NonNegative.Class as NonNeg --} -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky - -import Algebra.IntegralDomain (divUp, ) -{- -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Additive as Additive --} - --- import NumericPrelude.Numeric (zero, round, (^?), ) -import Prelude hiding (Real, round, break, ) - - -vectorChunkSize :: SVL.ChunkSize -vectorChunkSize = - case Play.defaultChunkSize of - SVL.ChunkSize size -> - SVL.ChunkSize (divUp size vectorSize) - -sampleRatePlain :: Num a => a -sampleRatePlain = Option.defaultSampleRate - -sampleRate :: Option.SampleRate Real -sampleRate = Option.SampleRate Option.defaultSampleRate - -{- | -try to reproduce a space leak --} -sequencePlain :: IO () -sequencePlain = - SVL.writeFile "test.f32" $ --- print $ last $ SVL.chunks $ - CutSt.arrange Option.defaultChunkSize $ - evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Real)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequenceLLVM :: IO () -sequenceLLVM = do - arrange <- SigStL.makeArranger - SVL.writeFile "test.f32" $ --- print $ last $ SVL.chunks $ - arrange vectorChunkSize $ - evalState (Gen.sequence Option.defaultChannel (error "no sound" :: Instrument Real Vector)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequencePitchBendCycle :: IO () -sequencePitchBendCycle = do - arrange <- SigStL.makeArranger - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (let -- fm = error "undefined pitch bend" - fm = EventListBT.cons 1 10 fm - in Gen.sequenceModulated fm Option.defaultChannel - (error "no sound" :: - PC.T Real -> Instrument Real Vector)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequencePitchBendSimple :: IO () -sequencePitchBendSimple = do - arrange <- SigStL.makeArranger - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (let fm y = EventListBT.cons y 10 (fm (2-y)) - in Gen.sequenceModulated (fm 1) Option.defaultChannel - (error "no sound" :: - PC.T Real -> Instrument Real Vector)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequencePitchBend :: IO () -sequencePitchBend = do - arrange <- SigStL.makeArranger - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (do fm <- PC.pitchBend Option.defaultChannel 2 0.01 - Gen.sequenceModulated fm Option.defaultChannel - (error "no sound" :: - PC.T Real -> Instrument Real Vector)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequenceModulated :: IO () -sequenceModulated = do - arrange <- SigStL.makeArranger - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 - Gen.sequenceModulated fm Option.defaultChannel - (error "no sound" :: - PC.T (BM.T Real) -> - Instrument Real Vector)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequenceModulatedLong :: IO () -sequenceModulatedLong = do - arrange <- SigStL.makeArranger --- sound <- Instr.softStringReleaseEnvelope $/ sampleRate - sound <- Instr.softString $/ sampleRate -- space leak --- sound <- Instr.pingReleaseEnvelope $/ 1 $/ sampleRate -- no space leak --- sound <- Instr.pingRelease $/ 1 $/ 1 $/ sampleRate -- no space leak - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState (Gen.sequence Option.defaultChannel 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] $ - evs 10 - -sequenceModulatedLongFM :: IO () -sequenceModulatedLongFM = do - arrange <- SigStL.makeArranger - sound <- Instr.softStringFM - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 - Gen.sequenceModulated fm Option.defaultChannel - (\fmlocal -> sound fmlocal $ sampleRate)) $ - let evs t = EventList.cons t [] (evs (20-t)) - in EventList.cons 10 [makeNote Event.NoteOn 60] $ - EventList.cons 10 [makeNote Event.NoteOn 64] $ - evs 10 - -sequenceModulatedRepeat :: IO () -sequenceModulatedRepeat = do - arrange <- SigStL.makeArranger - sound <- Instr.softStringFM - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 - Gen.sequenceModulated fm Option.defaultChannel - (\fmlocal -> sound fmlocal $ sampleRate)) $ - let evs t = - EventList.cons t [makeNote Event.NoteOn 60] $ - EventList.cons t [makeNote Event.NoteOff 60] $ - evs (20-t) - in evs 10 - -sequencePress :: IO () -sequencePress = do - arrange <- SigStL.makeArranger --- sound <- Instr.softString $/ sampleRate --- sound <- Instr.softStringReleaseEnvelope $/ sampleRate - sound <- Instr.pingReleaseEnvelope $/ 1 $/ 1 $/ vectorChunkSize $/ sampleRate - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (Gen.sequence Option.defaultChannel (\ _freq -> sound)) $ - let evs t = - EventList.cons t [makeNote Event.NoteOn 60] $ - EventList.cons t [makeNote Event.NoteOff 60] $ - evs (20-t) - in evs 10 - - -sampledSoundTest0 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundTest0 = - liftA - (\osc smp _fm _vel _freq _dur -> - osc Option.defaultChunkSize (sampleData smp)) - (SigP.runChunky - (let smp = arr id - in fmap (\x -> Stereo.cons x x) $ - SigPS.pack $ - SigP.fromStorableVectorLazy smp)) - -sampledSoundTest1 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundTest1 = - liftA - (\osc smp _fm _vel _freq _dur -> - osc Option.defaultChunkSize (sampleData smp)) - (SigP.runChunky - (let smp = arr id - in CausalP.stereoFromMono - (CausalPS.pack - (CausalP.frequencyModulationLinear - (SigP.fromStorableVectorLazy smp))) - $* liftA2 Stereo.cons - (SigPS.constant 0.999) - (SigPS.constant 1.001))) --- $* (SigPS.constant $# Stereo.cons 0.999 1.001))) - -sampledSoundTest2 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundTest2 = - liftA - (\osc smp fm _vel freq dur -> - let pos = samplePositions smp - body = - SigSt.take (sampleLength pos) $ - SigSt.drop (sampleStart pos) $ - sampleData smp - in SVP.take (chunkSizesFromLazyTime dur) $ - osc Option.defaultChunkSize - (sampleRate, (body, (fm, freq * samplePeriod smp)))) - (SigP.runChunky - (let smp = signal fst - fm = Instr.modulation snd - in (CausalP.stereoFromMono - (CausalPS.pack - (CausalP.frequencyModulationLinear - (SigP.fromStorableVectorLazy smp))) - <<< - liftA2 Stereo.cons - (CausalPS.amplify 0.999) - (CausalPS.amplify 1.001)) - $* Instr.frequencyFromBendModulation (frequencyConst 3) fm)) - -sampledSoundTest3SpaceLeak :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundTest3SpaceLeak = - liftA - (\osc smp _fm vel freq dur -> - {- - We split the frequency modulation signal - in order to get a smooth frequency modulation curve. - Without (periodic) frequency modulation - we could just split the piecewise constant control curve @fm@. - -} - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) - pos = samplePositions smp - amp = 2 * amplitudeFromVelocity vel - (attack,sustain) = - mapPair - (SigSt.drop (sampleStart pos), - SigSt.take (sampleLoopLength pos)) $ - SigSt.splitAt (sampleLoopStart pos) $ - sampleData smp - release = - SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ - SigSt.take (sampleStart pos + sampleLength pos) $ - sampleData smp - in osc - (amp, - attack `SigSt.append` - SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) - sustainFM - `SigSt.append` - osc (amp,release) releaseFM) - (CausalP.runStorableChunky - (let smp = arr snd - amp = arr fst - in CausalPS.amplifyStereo amp - <<< - CausalP.stereoFromMono - (CausalPS.pack - (CausalP.frequencyModulationLinear - (SigP.fromStorableVectorLazy smp))) - <<< - liftA2 Stereo.cons - (CausalPS.amplify 0.999) - (CausalPS.amplify 1.001))) - -sampledSoundTest4NoSpaceLeak :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundTest4NoSpaceLeak = - liftA - (\freqMod smp fm _vel freq dur -> - {- - We split the frequency modulation signal - in order to get a smooth frequency modulation curve. - Without (periodic) frequency modulation - we could just split the piecewise constant control curve @fm@. - -} - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (freqMod - (chunkSizesFromLazyTime (PC.duration fm)) - (sampleRate, (fm, freq*samplePeriod smp)) :: SigSt.T Vector) - in SigSt.map - (\x -> Stereo.cons x x) - (sustainFM `SigSt.append` releaseFM)) - (SigP.runChunkyPattern - (Instr.frequencyFromBendModulation - (frequencyConst 3) (Instr.modulation id))) - -sampledSoundTest5LargeSpaceLeak :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundTest5LargeSpaceLeak = - liftA2 - (\osc freqMod smp fm vel freq dur -> - {- - We split the frequency modulation signal - in order to get a smooth frequency modulation curve. - Without (periodic) frequency modulation - we could just split the piecewise constant control curve @fm@. - -} - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (freqMod - (chunkSizesFromLazyTime (PC.duration fm)) - (sampleRate, (fm, freq*samplePeriod smp)) :: SigSt.T Vector) - pos = samplePositions smp - amp = 2 * amplitudeFromVelocity vel - (attack,sustain) = - mapPair - (SigSt.drop (sampleStart pos), - SigSt.take (sampleLoopLength pos)) $ - SigSt.splitAt (sampleLoopStart pos) $ - sampleData smp - release = - SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ - SigSt.take (sampleStart pos + sampleLength pos) $ - sampleData smp - in osc - (amp, - attack `SigSt.append` - SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) - sustainFM - `SigSt.append` - osc (amp,release) releaseFM) - (CausalP.runStorableChunky - (arr (\x -> Stereo.cons x x))) - (SigP.runChunkyPattern - (Instr.frequencyFromBendModulation - (frequencyConst 3) (Instr.modulation id))) - - -sampledSoundSmallSpaceLeak4 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundSmallSpaceLeak4 = - liftA - (\osc smp _fm _vel freq dur -> - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) - in osc () sustainFM - `SigSt.append` - SigSt.map (\x -> Stereo.cons x x) releaseFM) - (CausalP.runStorableChunky - (arr (\x -> Stereo.cons x x))) - -sampledSoundSmallSpaceLeak4a :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundSmallSpaceLeak4a = - liftA - (\osc smp _fm _vel freq dur -> - case SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) of - (sustainFM, releaseFM) -> - osc () sustainFM - `SigSt.append` - SigSt.map (\x -> Stereo.cons x x) releaseFM) - (CausalP.runStorableChunky - (arr (\x -> Stereo.cons x x))) - -sampledSoundNoSmallSpaceLeak3 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundNoSmallSpaceLeak3 = - pure - (\smp _fm _vel freq dur -> - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) - in SigSt.map (\x -> Stereo.cons x x) sustainFM - `SigSt.append` - SigSt.map (\x -> Stereo.cons x x) releaseFM) - -{-# NOINLINE amplifySVL #-} -amplifySVL :: SVL.Vector Vector -> SVL.Vector Vector -amplifySVL = SigSt.map (2*) - -sampledSoundNoSmallSpaceLeak2 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundNoSmallSpaceLeak2 = - liftA - (\osc smp _fm _vel freq dur -> - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) - in osc () - (amplifySVL sustainFM - `SigSt.append` - amplifySVL releaseFM)) - (CausalP.runStorableChunky - (arr (\x -> Stereo.cons x x))) - -sampledSoundSmallSpaceLeak1 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundSmallSpaceLeak1 = - liftA - (\osc smp _fm _vel freq dur -> - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) - in osc () sustainFM - `SigSt.append` - osc () releaseFM) - (CausalP.runStorableChunky - (arr (\x -> Stereo.cons x x))) - -sampledSoundSmallSpaceLeak0 :: - IO (Instr.SampledSound -> - PC.T (BM.T Real) -> - Instrument Real (Stereo.T Vector)) -sampledSoundSmallSpaceLeak0 = - liftA - (\osc smp _fm vel freq dur -> - {- - We split the frequency modulation signal - in order to get a smooth frequency modulation curve. - Without (periodic) frequency modulation - we could just split the piecewise constant control curve @fm@. - -} - let (sustainFM, releaseFM) = - SVP.splitAt (chunkSizesFromLazyTime dur) $ - (SigSt.repeat Option.defaultChunkSize - (LLVM.vector [freq*samplePeriod smp/sampleRatePlain]) - :: SigSt.T Vector) - pos = samplePositions smp - amp = 2 * amplitudeFromVelocity vel - (attack,sustain) = - mapPair - (SigSt.drop (sampleStart pos), - SigSt.take (sampleLoopLength pos)) $ - SigSt.splitAt (sampleLoopStart pos) $ - sampleData smp - release = - SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ - SigSt.take (sampleStart pos + sampleLength pos) $ - sampleData smp - in osc - (amp, - attack `SigSt.append` - SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) - sustainFM - `SigSt.append` - osc (amp,release) releaseFM) - (CausalP.runStorableChunky - (arr (\x -> Stereo.cons x x))) - - - -sequenceSample :: IO () -sequenceSample = do - arrange <- SigStL.makeArranger - sampler <- sampledSoundTest2 - let sound = - sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) - (Instr.SamplePositions 0 100000 50000 50000) - 100) - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (do fm <- PC.bendWheelPressure Option.defaultChannel 2 0.04 0.03 - Gen.sequenceModulated fm Option.defaultChannel sound) $ - let evs t = EventList.cons t [] (evs (20-t)) - in EventList.cons 10 [makeNote Event.NoteOn 60] $ - evs 10 - -{- -sequenceSample1 :: IO () -sequenceSample1 = do - sampler <- Instr.sampledSound - let sound = - sampler (SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) - (SamplePositions 0 100000 50000 50000) - 100) - SVL.writeFile "test.f32" $ - sound -{- - (let evs f = - EventListBT.cons (BM.Cons 0.001 f) 10 (evs (0.02-f)) - in evs 0.01) --} - (let evs t = - EventListBT.cons (BM.Cons 0.01 0.001) t (evs (20-t)) - in evs 10) -{- - (PCS.Cons - (Map.singleton - (PC.Controller VoiceMsg.modulation) 1) - (let evs t = EventList.cons t [] (evs (20-t)) - in EventListMT.consTime 10 $ evs 10)) --} - 0.01 1 --- (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) - (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) --} - -sequenceSample1 :: IO () -sequenceSample1 = do - sampler <- sampledSoundSmallSpaceLeak4a - let sound = - sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) - (Instr.SamplePositions 0 100000 50000 50000) - 100) - SVL.writeFile "test.f32" $ - sound - (let evs = EventListBT.cons (BM.Cons 0.01 0.001) 1 evs - in evs) - 0.01 1 - (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10) - -{- -sequenceSample1a :: IO () -sequenceSample1a = do -{- - makeStereoLLVM <- - CausalP.runStorableChunky2 -- NoSpaceLeak - (arr (\x -> Stereo.cons x x)) - let stereoLLVM = makeStereoLLVM () --} - stereoLLVM <- CausalP.runStorableChunky3 - let stereoPlain = SigSt.map (\x -> Stereo.cons x x) - SVL.writeFile "test.f32" $ - let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 - !(sustainFM, releaseFM) = - SVP.splitAt dur $ - (SigSt.repeat Option.defaultChunkSize (LLVM.vector [1]) - :: SigSt.T Vector) - in case 3::Int of - -- no leak - 0 -> stereoLLVM $ sustainFM `SigSt.append` releaseFM - -- no leak - 1 -> stereoPlain $ sustainFM `SigSt.append` releaseFM - -- no leak - 2 -> stereoPlain sustainFM `SigSt.append` stereoPlain releaseFM - -- leak - 3 -> stereoLLVM sustainFM `SigSt.append` stereoPlain releaseFM - -- no leak - 4 -> stereoPlain sustainFM `SigSt.append` stereoLLVM releaseFM - -- leak - 5 -> stereoLLVM sustainFM `SigSt.append` stereoLLVM releaseFM --} - -sequenceSample2 :: IO () -sequenceSample2 = do - arrange <- SigStL.makeArranger - sampler <- sampledSoundTest2 - let sound = - sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) - (Instr.SamplePositions 0 100000 50000 50000) - 100) - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (do bend <- PC.pitchBend Option.defaultChannel 2 0.01 - let fm = fmap (\t -> BM.Cons t t) bend - Gen.sequenceModulated fm Option.defaultChannel sound) $ - let evs t = EventList.cons t [] (evs (20-t)) - in EventList.cons 10 [makeNote Event.NoteOn 60] $ - evs 10 - -{- -Interestingly, when the program aborts because of heap exhaustion, -then the generated file has size 137MB independent of the heap size -(I tried sizes from 1MB to 64MB). --} -sequenceSample3 :: IO () -sequenceSample3 = do - arrange <- SigStL.makeArranger - sampler <- sampledSoundTest2 - let sound = - sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) - (Instr.SamplePositions 0 100000 50000 50000) - 100) - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (let evs = - EventListBT.cons (BM.Cons 0.01 0.001) 10 evs - in Gen.sequence Option.defaultChannel (sound evs)) $ - let evs = EventList.cons 10 [] evs - in EventList.cons 10 [makeNote Event.NoteOn 60] evs - -sequenceSample4 :: IO () -sequenceSample4 = do - arrange <- SigStL.makeArranger - sampler <- Instr.sampledSound --- sampler <- sampledSoundTest2 - let sound = - sampler (Instr.SampledSound (SigSt.replicate Option.defaultChunkSize 100000 0) - (Instr.SamplePositions 0 100000 50000 50000) - 100) - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (let evs = - EventListBT.cons (BM.Cons 0.01 0.001) 10 evs - in Gen.sequenceCore - Option.defaultChannel Gen.errorNoProgram - (Gen.Modulator () return - (return . Gen.renderInstrumentIgnoreProgram (sound evs sampleRate)))) $ - let evs = EventList.cons 10 [] evs - in EventList.cons 10 [makeNote Event.NoteOn 60] evs - -sequenceFM1 :: IO () -sequenceFM1 = do - arrange <- SigStL.makeArranger - sound <- Instr.softStringFM $/ - let evs = - EventListBT.cons (BM.Cons 0.01 0.001) 10 evs - in evs --- sound <- Instr.softStringReleaseEnvelope - SVL.writeFile "test.f32" $ - arrange vectorChunkSize $ - evalState - (Gen.sequenceCore - Option.defaultChannel Gen.errorNoProgram - (Gen.Modulator () return - (return . Gen.renderInstrumentIgnoreProgram (sound sampleRate)))) $ - let evs = EventList.cons 10 [] evs - in EventList.cons 10 [makeNote Event.NoteOn 60] evs -{- - sound - 0.01 1 - (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10) --} - - -adsr :: IO () -adsr = do - env <- Instr.adsr - SVL.writeFile "adsr.f32" $ - env 0.2 2 0.15 0.3 0.5 vectorChunkSize sampleRate (-0.5) 88200 - - -constCtrl :: a -> PC.T a -constCtrl x = - let xs = EventListBT.cons x 10000 xs - in xs - -bellNoiseStereoTest :: IO () -bellNoiseStereoTest = do - str <- Instr.bellNoiseStereoFM - SVL.writeFile "bellnoise.f32" $ - str 0.3 0.1 (constCtrl 0.3) (constCtrl 100) - vectorChunkSize - (constCtrl (BM.Cons 1 0.01)) sampleRate 0 440 - 100000 diff --git a/src/Synthesizer/LLVM/Server/SampledSound.hs b/src/Synthesizer/LLVM/Server/SampledSound.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/SampledSound.hs @@ -0,0 +1,100 @@ +module Synthesizer.LLVM.Server.SampledSound where + +import Synthesizer.LLVM.Server.Common (Real, ) + +import qualified Sound.Sox.Read as SoxRead +import qualified Sound.Sox.Option.Format as SoxOption +import Control.Exception (bracket, ) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import Data.Tuple.HT (mapPair, ) + +import Prelude hiding (Real, length, ) + + + +data T = + Cons { + body :: SigSt.T Real, + positions :: Positions, + period :: Real + } + +data Positions = + Positions { + start, length, + loopStart, loopLength :: Int + } + + +load :: FilePath -> IO (SVL.Vector Real) +load path = + bracket (SoxRead.open SoxOption.none path) SoxRead.close $ + SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize) + + +type Info = (FilePath, [Positions], Real) + + +parts :: T -> (SigSt.T Real, SigSt.T Real, SigSt.T Real) +parts smp = + let pos = positions smp + (attack,sustain) = + mapPair + (SigSt.drop (start pos), + SigSt.take (loopLength pos)) $ + SigSt.splitAt (loopStart pos) $ + body smp + release = + SigSt.drop (loopStart pos + loopLength pos) $ + SigSt.take (start pos + length pos) $ + body smp + in (attack, sustain, release) + + + +-- * examples + +tomatensalatPositions :: [Positions] +tomatensalatPositions = + Positions 0 29499 12501 15073 : + Positions 29499 31672 38163 17312 : + Positions 67379 28610 81811 10667 : + Positions 95989 31253 106058 16111 : + Positions 127242 38596 136689 11514 : + [] + +tomatensalat :: Info +tomatensalat = + ("tomatensalat2.wav", tomatensalatPositions, 324.5) + + +halPositions :: [Positions] +halPositions = +-- Positions 2371 25957 7362 6321 : + Positions 2371 25957 (2371+25957) 1 : + Positions 40546 34460 63540 9546 : + Positions 79128 32348 94367 14016 : + Positions 112027 21227 125880 5500 : + Positions 146057 23235 168941 352 : + [] + +hal :: Info +hal = + ("haskell-in-leipzig2.wav", halPositions, 316) + + +graphentheoriePositions :: [Positions] +graphentheoriePositions = + Positions 0 29524 13267 14768 : + Positions 29524 35333 47624 9968 : + Positions 64857 31189 73818 16408 : + Positions 96046 31312 106206 18504 : + Positions 127358 32127 132469 16530 : + [] + +graphentheorie :: Info +graphentheorie = + ("graphentheorie0.wav", graphentheoriePositions, 301.15) 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 @@ -10,8 +10,8 @@ import qualified LLVM.Core as LLVM -import qualified Synthesizer.EventList.ALSA.MIDI as Ev -import Synthesizer.Storable.ALSA.MIDI (chunkSizesFromLazyTime, ) +import qualified Synthesizer.MIDI.EventList as Ev +import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime, ) import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy.Pattern as SigStV @@ -160,7 +160,8 @@ (attack, sustain) = SigSt.splitAt attackTimeInt $ env (chunkSizesFromLazyTime dur) - (attackTimeInt, amplitudeFromVelocity vel) + (fromIntegral attackTimeInt :: Real, + amplitudeFromVelocity vel) release = SigSt.reverse attack in attack `SigSt.append` sustain `SigSt.append` release) (let amp = arr snd @@ -168,7 +169,7 @@ in SigP.runChunkyPattern $ flip SigP.append (SigP.constant amp) $ SigP.amplify amp $ - (SigP.parabolaFadeIn (fmap fromIntegral attackTime))) + (SigP.parabolaFadeIn attackTime)) softString :: IO (Instrument Real (Stereo.T Real)) softString = diff --git a/src/Synthesizer/LLVM/Server/Scalar/Run.hs b/src/Synthesizer/LLVM/Server/Scalar/Run.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/Scalar/Run.hs +++ /dev/null @@ -1,147 +0,0 @@ -module Synthesizer.LLVM.Server.Scalar.Run where - -import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr -import qualified Synthesizer.LLVM.Server.Option as Option -import Synthesizer.LLVM.Server.Common - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Data.EventList.Relative.TimeBody as EventList - -import qualified Synthesizer.EventList.ALSA.MIDI as Ev -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC -import qualified Synthesizer.Generic.ALSA.MIDI as Gen - -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo - -import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import qualified Synthesizer.LLVM.Wave as WaveL -import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), ) -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import qualified Synthesizer.Storable.Signal as SigSt - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import Control.Arrow ((<<<), arr, ) -import Control.Monad.Trans.State (evalState, ) - -import NumericPrelude.Numeric (zero, (*>), ) -import Prelude hiding (Real, break, ) - - -sampleRate :: Num a => Option.T -> a -sampleRate opt = - case Option.sampleRate opt of - SampleRate sr -> sr - -{-# INLINE withMIDIEvents #-} -withMIDIEvents :: - Option.T -> - (Option.T -> Double -> a -> IO b) -> - (EventList.T Ev.StrictTime [Event.T] -> a) -> IO b -withMIDIEvents opt action proc = - let rate = sampleRate opt - in do - putStrLn startMessage - Ev.withMIDIEvents - (Option.clientName opt) (Option.periodTime opt) rate $ - action opt rate . proc - - - -pitchBend :: IO () -pitchBend = do - opt <- Option.get - osc <- - SigP.runChunky - ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) - $* piecewiseConstant (arr id)) - withMIDIEvents opt play $ - (id :: SigSt.T Real -> SigSt.T Real) . - osc (Option.chunkSize opt) . - evalState (PC.pitchBend (Option.channel opt) 2 (880/sampleRate opt::Real)) - - -frequencyModulation :: IO () -frequencyModulation = do - opt <- Option.get - osc <- - SigP.runChunky - (((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) - <<< (MIDIL.frequencyFromBendModulation $# (10/sampleRate opt::Real))) - $* piecewiseConstant (arr (transposeModulation (Option.sampleRate opt) 880))) - withMIDIEvents opt play $ - (id :: SigSt.T Real -> SigSt.T Real) . - osc (Option.chunkSize opt) . - evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) - - - -keyboard :: IO () -keyboard = do - opt <- Option.get --- sound <- Instr.pingDur -{- - sound <- - fmap (\s vel _freq dur -> s vel dur) $ - (Instr.pingReleaseEnvelope $/ 0.4 $/ 0.1) --} - sound <- Instr.pingRelease $/ 0.4 $/ 0.1 - amp <- CausalP.runStorableChunky (CausalP.amplify $# 0.2) - arrange <- SigStL.makeArranger - withMIDIEvents opt play $ - (amp () :: SigSt.T Real -> SigSt.T Real) . - arrange (Option.chunkSize opt) . - evalState - (Gen.sequence - (Option.channel opt) - (sound (Option.chunkSize opt) (Option.sampleRate opt))) - -keyboardStereo :: IO () -keyboardStereo = do - opt <- Option.get - sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 - amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) - arrange <- SigStL.makeArranger - withMIDIEvents opt play $ - (amp () :: SigSt.T (Stereo.T Real) -> SigSt.T (Stereo.T Real)) . - arrange (Option.chunkSize opt) . - evalState - (Gen.sequence - (Option.channel opt) - (sound (Option.chunkSize opt) (Option.sampleRate opt))) - -keyboardMulti :: IO () -keyboardMulti = do - opt <- Option.get - png <- Instr.pingDur - pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1 $/ Option.chunkSize opt - tin <- Instr.tine $/ 0.4 $/ 0.1 $/ Option.chunkSize opt - arrange <- SigStL.makeArranger - withMIDIEvents opt play $ --- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) . - SigSt.map (0.2*) . - arrange (Option.chunkSize opt) . - evalState (Gen.sequenceMultiProgram (Option.channel opt) - (VoiceMsg.toProgram 2) - (map (\sound -> sound $ Option.sampleRate opt) $ - [png, pngRel, tin])) - -keyboardStereoMulti :: IO () -keyboardStereoMulti = do - opt <- Option.get - png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 $/ Option.chunkSize opt - tin <- Instr.tineStereo $/ 0.4 $/ 0.1 $/ Option.chunkSize opt - str <- Instr.softString - arrange <- SigStL.makeArranger - withMIDIEvents opt play $ --- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate opt::Real) . - SigSt.map ((0.2::Real)*>) . - arrange (Option.chunkSize opt) . - evalState (Gen.sequenceMultiProgram (Option.channel opt) - (VoiceMsg.toProgram 1) - (map (\sound -> sound $ Option.sampleRate opt) $ - [png, tin, str])) diff --git a/src/Synthesizer/LLVM/Server/Scalar/Test.hs b/src/Synthesizer/LLVM/Server/Scalar/Test.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Server/Scalar/Test.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Synthesizer.LLVM.Server.Scalar.Test where - -import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr -import qualified Synthesizer.LLVM.Server.Option as Option -import Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents, ) -import Synthesizer.LLVM.Server.Common - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC -import qualified Synthesizer.Generic.ALSA.MIDI as Gen - -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import qualified Synthesizer.LLVM.Wave as WaveL -import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), ) - -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL - -import qualified Data.EventList.Relative.TimeBody as EventList - -import Control.Arrow (arr, ) -import Control.Monad.Trans.State (evalState, ) - -import NumericPrelude.Numeric (zero, ) -import Prelude hiding (Real, ) - - -sampleRate :: Real -sampleRate = - Option.defaultSampleRate - - -pitchBend0 :: IO () -pitchBend0 = do - osc <- - SigP.runChunky - ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) - $* 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)) $ - let evs = EventList.cons 100 [] evs - in EventList.cons 0 [] evs - -pitchBend1 :: IO () -pitchBend1 = do - opt <- Option.get - osc <- - SigP.runChunky - ((CausalP.osciSimple WaveL.triangle $<# (zero::Real)) - $* piecewiseConstant (arr id)) - withMIDIEvents opt (\ _opt _rate -> SVL.writeFile "test.f32") $ - (id :: SigSt.T Real -> SigSt.T Real) . - osc Option.defaultChunkSize . - evalState (PC.pitchBend Option.defaultChannel 2 (880/sampleRate)) - -pitchBend2 :: IO () -pitchBend2 = do - opt <- Option.get - withMIDIEvents opt (\ _opt _rate -> print) id - - - -sequencePress :: IO () -sequencePress = do --- arrange <- SigStL.makeArranger --- sound <- Instr.softString --- sound <- Instr.softStringReleaseEnvelope --- sound <- Instr.pingReleaseEnvelope $/ 1 $/ Option.defaultChunkSize --- sound <- Instr.pingDur --- sound <- Instr.pingDurTake - let sound = Instr.dummy Option.defaultChunkSize (SampleRate sampleRate) - SVL.writeFile "test.f32" $ - CutSt.arrange Option.defaultChunkSize $ - evalState - (do Gen.sequence Option.defaultChannel sound) $ - let evs t = - EventList.cons t [makeNote Event.NoteOn 60] $ - EventList.cons t [makeNote Event.NoteOff 60] $ - evs (20-t) - in evs 10 - 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 @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} @@ -23,7 +24,7 @@ import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (whileLoop, ifThen, ) -import LLVM.Extra.Class (MakeValueTuple, Undefined, undefTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) @@ -42,16 +43,17 @@ import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, ) import qualified Synthesizer.LLVM.Alloc as Alloc -import Foreign.ForeignPtr - (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, ) +import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, ) import Foreign.Ptr (FunPtr, nullPtr, ) import Control.Exception (bracket, ) -import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, ) +import qualified System.Unsafe as Unsafe 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. @@ -63,8 +65,8 @@ > newtype T a = Cons (Causal.T () a) -} data T a = - forall state packed size ioContext. - (Memory.C state packed, IsSized packed size) => + forall state ioContext. + (Memory.C state) => Cons (forall r c. (Phi c) => ioContext -> @@ -76,14 +78,14 @@ -- initial state (IO ioContext) {- initialization from IO monad - This will be run within unsafePerformIO, + This will be run within Unsafe.performIO, so no observable In/Out actions please! -} (ioContext -> IO ()) - -- finalization from IO monad, also run within unsafePerformIO + -- finalization from IO monad, also run within Unsafe.performIO simple :: - (Memory.C state packed, IsSized packed size) => + (Memory.C state) => (forall r c. state -> Maybe.T r c (a, state)) -> (forall r. CodeGenFunction r state) -> @@ -108,7 +110,7 @@ createIOContext deleteIOContext mapAccum :: - (Memory.C s struct, IsSized struct sa) => + (Memory.C s) => (forall r. a -> s -> CodeGenFunction r (b,s)) -> (forall r. CodeGenFunction r s) -> T a -> T b @@ -177,14 +179,27 @@ (/) = 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 + {- | Stretch signal in time by a certain factor. -} interpolateConstant :: - (Memory.C a struct, IsSized struct size, - Memory.FirstClass b bm, IsSized b bsize, IsSized bm bmsize, + (Memory.C a, + Memory.FirstClass b, Memory.Stored b ~ bm, IsSized b, IsSized bm, Ring.C b, - IsFloating b, CmpRet b Bool, IsConst b) => + IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool, IsConst b) => b -> T a -> T a interpolateConstant k (Cons next start createIOContext deleteIOContext) = @@ -244,7 +259,7 @@ iterate :: - (Memory.FirstClass a am, IsSized a asize, IsSized am amsize, IsConst a) => + (Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsConst a) => (forall r. Value a -> CodeGenFunction r (Value a)) -> Value a -> T (Value a) iterate f initial = @@ -254,14 +269,14 @@ exponential2 :: (Trans.C a, IsArithmetic a, - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, IsConst a) => + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsConst a) => a -> a -> T (Value a) exponential2 halfLife = iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf osciPlain :: - (Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t) => (forall r. Value t -> CodeGenFunction r y) -> Value t -> Value t -> T y @@ -271,7 +286,7 @@ phase osci :: - (Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize, + (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t) => (forall r. Value t -> CodeGenFunction r y) -> t -> t -> T y @@ -279,8 +294,8 @@ osciPlain wave (valueOf phase) (valueOf freq) osciSaw :: - (Ring.C a0, IsConst a0, SoV.Replicate a0 a, - Memory.FirstClass a am, IsSized a asize, IsSized am amsize, + (SoV.IntegerConstant a, + Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, SoV.Fraction a, IsConst a) => a -> a -> T (Value a) osciSaw = osci Wave.saw @@ -288,7 +303,7 @@ fromStorableVector :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => SV.Vector a -> T value fromStorableVector xs = @@ -302,7 +317,7 @@ l1 <- A.dec l0 return (y1,(p1,l1))) (const $ return - (valueOf (Memory.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s), + (valueOf (Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s), valueOf (fromIntegral l :: Word32))) -- keep the foreign ptr alive (return fp) @@ -314,7 +329,7 @@ and advances to the next chunk in the sequence. -} fromStorableVectorLazy :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => SVL.Vector a -> T value fromStorableVectorLazy sig = @@ -342,7 +357,7 @@ {- compile :: - (Memory.C value struct) => + (Memory.C value) => T value -> CodeGenModule (Function (Word32 -> Ptr struct -> IO Word32)) -} @@ -355,10 +370,10 @@ or compile once. -} render :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => Int -> T value -> SV.Vector a render len (Cons next start createIOContext deleteIOContext) = - unsafePerformIO $ + Unsafe.performIO $ bracket createIOContext deleteIOContext $ \ ioContext -> SVB.createAndTrim len $ \ ptr -> do fill <- @@ -379,9 +394,8 @@ compileChunky :: - (Memory.C value struct, - Memory.C state stateStruct, - IsSized stateStruct stateSize) => + (Memory.C value, Memory.Struct value ~ struct, + Memory.C state, Memory.Struct state ~ stateStruct) => (forall r. state -> Maybe.T r (Value Bool, state) (value, state)) -> (forall r. @@ -420,7 +434,7 @@ runChunky :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (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 @@ -433,7 +447,7 @@ ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False let go = - unsafeInterleaveIO $ do + Unsafe.interleaveIO $ do v <- withForeignPtr statePtr $ \sptr -> SVB.createAndTrim size $ @@ -450,7 +464,7 @@ fmap SVL.fromChunks go renderChunky :: - (Storable a, MakeValueTuple a value, Memory.C value struct) => + (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => SVL.ChunkSize -> T value -> SVL.Vector a renderChunky size sig = - unsafePerformIO (runChunky size sig) + Unsafe.performIO (runChunky size sig) 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 @@ -1,24 +1,25 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Synthesizer.LLVM.Simple.Value ( T, decons, - twoPi, + twoPi, square, sqrt, + max, min, limit, lift0, lift1, lift2, + unlift0, unlift1, unlift2, constantValue, constant, - Flatten(flatten, unfold), flattenTraversable, unfoldFunctor, + + Flatten(flatten, unfold), Registers, + flattenTraversable, unfoldFunctor, + flattenFunction, ) where -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A -import LLVM.Core - (CodeGenFunction, - Value, valueOf, CmpRet, - IsArithmetic, IsConst, IsType, IsFloating, ) +import LLVM.Core (CodeGenFunction, ) import qualified LLVM.Core as LLVM import qualified Synthesizer.Basic.Phase as Phase @@ -28,7 +29,6 @@ import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM2, liftM3, ) -import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -- import qualified Algebra.NormedSpace.Maximum as NormedMax @@ -48,10 +48,11 @@ import qualified Data.Traversable as Trav -import System.IO.Unsafe (unsafePerformIO, ) +import qualified System.Unsafe as Unsafe -import NumericPrelude.Numeric -import NumericPrelude.Base +import qualified Prelude as P +import NumericPrelude.Numeric hiding (pi, sqrt, ) +import NumericPrelude.Base hiding (min, max, ) {- @@ -68,9 +69,9 @@ > t -> t -> T (Value y) -} -newtype T a = Cons {code :: forall r. Compute r (Value a)} +newtype T a = Cons {code :: forall r. Compute r a} -decons :: T a -> (forall r. LLVM.CodeGenFunction r (Value a)) +decons :: T a -> (forall r. LLVM.CodeGenFunction r a) decons value = MS.evalStateT (code value) Vault.empty @@ -78,12 +79,12 @@ type Compute r a = MS.StateT Vault.Vault (LLVM.CodeGenFunction r) a -consUnique :: (forall r. Compute r (Value a)) -> T a +consUnique :: (forall r. Compute r a) -> T a consUnique code0 = - unsafePerformIO $ + Unsafe.performIO $ fmap (consKey code0) Vault.newKey -consKey :: (forall r. Compute r (Value a)) -> Vault.Key (Value a) -> T a +consKey :: (forall r. Compute r a) -> Vault.Key a -> T a consKey code0 key = Cons (do ma <- MS.gets (Vault.lookup key) @@ -98,13 +99,13 @@ We do not require a numeric prelude superclass, thus also LLVM only types like vectors are instances. -} -instance (IsArithmetic a, IsType a) => Additive.C (T a) where - zero = constantValue (LLVM.value LLVM.zero) +instance (A.Additive a) => Additive.C (T a) where + zero = constantValue A.zero (+) = lift2 A.add (-) = lift2 A.sub negate = lift1 A.neg -instance (IsArithmetic a, SoV.IntegerConstant a) => +instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where one = constantValue (A.fromInteger' 1) (*) = lift2 A.mul @@ -115,15 +116,15 @@ The difference to Module instances on Haskell tuples is, that LLVM vectors cannot be nested. -} -instance (SoV.PseudoModule a v, SoV.IntegerConstant a) => +instance (A.PseudoModule a v, A.IntegerConstant a) => Module.C (T a) (T v) where - (*>) = lift2 SoV.scale + (*>) = lift2 A.scale -instance (IsArithmetic a, SoV.IntegerConstant a) => Enum (T a) where - succ x = x + one - pred x = x - one +instance (A.Additive a, A.IntegerConstant a) => Enum (T a) where + succ x = x + constantValue A.one + pred x = x - constantValue A.one fromEnum _ = error "CodeGenFunction Value: fromEnum" - toEnum = fromIntegral + toEnum = constantValue . A.fromInteger' . fromIntegral {- instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T a) where @@ -136,7 +137,7 @@ toInteger _ = error "CodeGenFunction Value: toInteger" -} -instance (IsFloating a, SoV.RationalConstant a) => Field.C (T a) where +instance (A.Field a, A.RationalConstant a) => Field.C (T a) where (/) = lift2 A.fdiv fromRational' = constantValue . A.fromRational' . fromRational' @@ -146,13 +147,13 @@ properFraction _ = error "CodeGenFunction Value: properFraction" -} -instance (IsFloating a, SoV.RationalConstant a) => Algebraic.C (T a) where +instance (A.Transcendental a, A.RationalConstant a) => Algebraic.C (T a) where sqrt = lift1 A.sqrt root n x = lift2 A.pow x (1 / fromInteger n) x^/r = lift2 A.pow x (fromRational' r) -instance (IsFloating a, SoV.RationalConstant a, Trans.C a) => Trans.C (T a) where - pi = constant pi +instance (A.Transcendental a, A.RationalConstant a) => Trans.C (T a) where + pi = lift0 A.pi sin = lift1 A.sin cos = lift1 A.cos (**) = lift2 A.pow @@ -163,71 +164,118 @@ acos _ = error "LLVM missing intrinsic: acos" atan _ = error "LLVM missing intrinsic: atan" -{- - sinh x = (exp x - exp (-x)) / 2 - cosh x = (exp x + exp (-x)) / 2 - asinh x = log (x + sqrt (x*x + 1)) - acosh x = log (x + sqrt (x*x - 1)) - atanh x = (log (1 + x) - log (1 - x)) / 2 --} +instance + (A.PseudoRing a, A.Real a, A.IntegerConstant a) => + P.Num (T a) where + fromInteger = constantValue . A.fromInteger' + (+) = lift2 A.add + (-) = lift2 A.sub + (*) = lift2 A.mul + negate = lift1 A.neg + abs = lift1 A.abs + signum = lift1 A.signum +instance + (A.Field a, A.Real a, A.RationalConstant a) => + P.Fractional (T a) where + fromRational = + constantValue . A.fromRational' . P.fromRational + (/) = lift2 A.fdiv + +instance + (A.Transcendental a, A.Real a, A.RationalConstant a) => + P.Floating (T a) where + pi = lift0 A.pi + sin = lift1 A.sin + cos = lift1 A.cos + (**) = lift2 A.pow + exp = lift1 A.exp + log = lift1 A.log + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 + + twoPi :: - (IsFloating a, IsConst a, Trans.C a) => + (A.Transcendental a, A.RationalConstant a) => T a -twoPi = constant (2*pi) -{- -twoPi :: - (Cmp a b, P.Floating a, IsConst a, IsFloating a) => - Compute r a -twoPi = P.fromInteger 2 P.* P.pi +twoPi = 2 * Trans.pi + +square :: + (A.PseudoRing a) => + T a -> T a +square = lift1 A.square + +{- | +The same as 'Algebraic.sqrt', +but needs only Algebraic constraint, not Transcendental. -} +sqrt :: + (A.Algebraic a) => + T a -> T a +sqrt = lift1 A.sqrt -instance (SoV.Real a, SoV.IntegerConstant a, CmpRet a Bool) => + +min, max :: (A.Real a) => T a -> T a -> T a +min = lift2 A.min +max = lift2 A.max + +limit :: (A.Real a) => (T a, T a) -> T a -> T a +limit (l,u) = max l . min u + + +instance (A.Real a, A.PseudoRing a, A.IntegerConstant a) => Absolute.C (T a) where abs = lift1 A.abs - signum = lift1 Frame.signum + signum = lift1 A.signum {- For useful instances with different scalar and vector type, we would need a more flexible superclass. -} -instance (SoV.Real a, SoV.IntegerConstant a, CmpRet a Bool, - SoV.PseudoModule a a) => +instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) => NormedSum.C (T a) (T a) where norm = lift1 A.abs -instance (SoV.Real a, SoV.IntegerConstant a, CmpRet a Bool, - SoV.PseudoModule a a) => +instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) => NormedEuc.Sqr (T a) (T a) where normSqr = lift1 A.square instance - (Algebraic.C a, NormedEuc.Sqr (T a) (T v), SoV.RationalConstant a, IsFloating a) => + (NormedEuc.Sqr (T a) (T v), + A.RationalConstant a, A.Algebraic a) => NormedEuc.C (T a) (T v) where - norm = NormedEuc.defltNorm + norm = lift1 A.sqrt . NormedEuc.normSqr {- -instance (Ring.C a, IsArithmetic a, IsConst a, CmpRet a Bool) => +instance (A.Real a, A.IntegerConstant a, A.PseudoModule a a) => NormedMax.C (T a) (T a) where norm = lift1 A.abs -} lift0 :: - (forall r. CodeGenFunction r (Value a)) -> + (forall r. CodeGenFunction r a) -> T a lift0 f = consUnique $ MT.lift $ f lift1 :: - (forall r. Value a -> CodeGenFunction r (Value b)) -> + (forall r. a -> CodeGenFunction r b) -> T a -> T b lift1 f x = consUnique $ MT.lift . f =<< code x lift2 :: - (forall r. Value a -> Value b -> CodeGenFunction r (Value c)) -> + (forall r. a -> b -> CodeGenFunction r c) -> T a -> T b -> T c lift2 f x y = consUnique $ do @@ -236,61 +284,102 @@ MT.lift $ f xv yv -constantValue :: Value a -> T a +unlift0 :: + T a -> + (forall r. CodeGenFunction r a) +unlift0 = decons + +unlift1 :: + (T a -> T b) -> + (forall r. a -> CodeGenFunction r b) +unlift1 f x = + decons (f (constantValue x)) + +unlift2 :: + (T a -> T b -> T c) -> + (forall r. a -> b -> CodeGenFunction r c) +unlift2 f x y = + decons (f (constantValue x) (constantValue y)) + + +constantValue :: a -> T a constantValue x = consUnique (return x) -constant :: (IsConst a) => a -> T a -constant = constantValue . valueOf +constant :: (LLVM.IsConst a) => a -> T (LLVM.Value a) +constant = constantValue . LLVM.valueOf -class Flatten value register | value -> register where - flatten :: value -> CodeGenFunction r register - unfold :: register -> value +class Flatten value where + type Registers value :: * + flatten :: value -> CodeGenFunction r (Registers value) + unfold :: (Registers value) -> value flattenTraversable :: - (Flatten value register, Trav.Traversable f) => - f value -> CodeGenFunction r (f register) + (Flatten value, Trav.Traversable f) => + f value -> CodeGenFunction r (f (Registers value)) flattenTraversable = Trav.mapM flatten unfoldFunctor :: - (Flatten value register, Functor f) => - f register -> f value + (Flatten value, Functor f) => + f (Registers value) -> f value unfoldFunctor = fmap unfold -instance (Flatten ah al, Flatten bh bl) => - Flatten (ah,bh) (al,bl) where +flattenFunction :: + (Flatten a, Flatten b) => + (a -> b) -> (Registers a -> CodeGenFunction r (Registers b)) +flattenFunction f = + flatten . f . unfold + +{- +This function is hardly useful, +since most functions are not of type +@(Registers a -> (forall r. CodeGenFunction r (Registers b)))@ +but of type +@(forall r. Registers a -> CodeGenFunction r (Registers b))@. +We would also need a method unfoldF. +See ValueUnfoldF for some implementations. + +unfoldFunction :: + (Flatten a, Flatten b) => + (Registers a -> (forall r. CodeGenFunction r (Registers b))) -> (a -> b) +unfoldFunction f x = + unfoldF (f =<< flatten x) +-} + + +instance (Flatten a, Flatten b) => Flatten (a,b) where + type Registers (a,b) = (Registers a, Registers b) flatten (a,b) = liftM2 (,) (flatten a) (flatten b) unfold (a,b) = (unfold a, unfold b) -instance (Flatten ah al, Flatten bh bl, Flatten ch cl) => - Flatten (ah,bh,ch) (al,bl,cl) where +instance (Flatten a, Flatten b, Flatten c) => Flatten (a,b,c) where + type Registers (a,b,c) = (Registers a, Registers b, Registers c) flatten (a,b,c) = liftM3 (,,) (flatten a) (flatten b) (flatten c) unfold (a,b,c) = (unfold a, unfold b, unfold c) -instance Flatten v r => - Flatten (Stereo.T v) (Stereo.T r) where +instance Flatten a => Flatten (Stereo.T a) where + type Registers (Stereo.T a) = Stereo.T (Registers a) flatten = flattenTraversable unfold = unfoldFunctor -instance Flatten v r => - Flatten (Complex.T v) (Complex.T r) where +instance Flatten a => Flatten (Complex.T a) where + type Registers (Complex.T a) = Complex.T (Registers a) flatten s = liftM2 (Complex.+:) (flatten $ Complex.real s) (flatten $ Complex.imag s) unfold = unfoldFunctor -instance - (RealRing.C v, Flatten v r) => - Flatten (Phase.T v) r where +instance (RealRing.C a, Flatten a) => Flatten (Phase.T a) where + type Registers (Phase.T a) = Registers a flatten s = flatten $ Phase.toRepresentative s unfold s = @@ -298,9 +387,12 @@ Phase.fromRepresentative $ unfold s -instance Flatten (T a) (Value a) where +instance Flatten (T a) where + type Registers (T a) = a flatten = decons unfold = constantValue -instance Flatten () () where + +instance Flatten () where + type Registers () = () flatten = return unfold = id diff --git a/src/Synthesizer/LLVM/Simple/Vanilla.hs b/src/Synthesizer/LLVM/Simple/Vanilla.hs --- a/src/Synthesizer/LLVM/Simple/Vanilla.hs +++ b/src/Synthesizer/LLVM/Simple/Vanilla.hs @@ -1,11 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Simple.Vanilla where import qualified Synthesizer.LLVM.Simple.Signal as Sig @@ -40,7 +35,7 @@ iterateVal :: - (Memory.FirstClass a am, IsSized a asize, IsSized am amsize) => + (Memory.C a) => (Value.T a -> Value.T a) -> Value.T a -> Sig.T (Value.T a) iterateVal f initial = @@ -52,7 +47,7 @@ (Value.decons initial) iterate :: - (Value.Flatten a reg, Memory.C reg packed, IsSized packed size) => + (Value.Flatten a, Value.Registers a ~ reg, Memory.C reg) => (a -> a) -> (a -> Sig.T a) iterate f initial = @@ -72,11 +67,11 @@ osciReg :: - (RealRing.C (Value.T t), - Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize, + (RealRing.C (Value.T (Value t)), + Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t, IsFirstClass y) => - Wave.T (Value.T t) (Value.T y) -> + Wave.T (Value.T (Value t)) (Value.T (Value y)) -> Value t -> Value t -> Sig.T (Value y) osciReg wave phase freq = Sig.map @@ -85,24 +80,23 @@ Sig.iterate (SoV.incPhase freq) phase osciVal :: - (RealRing.C (Value.T t), - Memory.FirstClass t tm, IsSized t tsize, IsSized tm tmsize, + (RealRing.C (Value.T (Value t)), + Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t) => - Wave.T (Value.T t) y -> - Value.T t -> Value.T t -> Sig.T y + Wave.T (Value.T (Value t)) y -> + Value.T (Value t) -> Value.T (Value t) -> Sig.T y osciVal wave phase freq = map (Wave.apply wave . Phase.fromRepresentative) $ iterateVal (incPhaseVal freq) phase incPhaseVal :: (SoV.Fraction a, IsArithmetic a) => - Value.T a -> Value.T a -> Value.T a + Value.T (Value a) -> Value.T (Value a) -> Value.T (Value a) incPhaseVal = Value.lift2 SoV.incPhase osci :: (RealRing.C t, - Value.Flatten t reg, - Memory.C reg struct, IsSized struct size, + Value.Flatten t, Value.Registers t ~ reg, Memory.C reg, SoV.Fraction t, IsConst t) => Wave.T t y -> Phase.T t -> t -> Sig.T y diff --git a/src/Synthesizer/LLVM/Storable/Process.hs b/src/Synthesizer/LLVM/Storable/Process.hs --- a/src/Synthesizer/LLVM/Storable/Process.hs +++ b/src/Synthesizer/LLVM/Storable/Process.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} {- | Functions on lazy storable vectors that are implemented using LLVM. -} @@ -9,6 +8,7 @@ continuePacked, ) where +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.CausalIO.Process as PIO @@ -26,15 +26,15 @@ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Core as LLVM -import LLVM.Extra.Class (MakeValueTuple, ) -import qualified Data.TypeLevel.Num as TypeNum +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) +import qualified Types.Data.Num as TypeNum import qualified Control.Arrow as Arr import qualified Data.Foldable as Fold import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, ) -import System.IO.Unsafe (unsafePerformIO, ) +import qualified System.Unsafe as Unsafe import NumericPrelude.Numeric import NumericPrelude.Base @@ -50,7 +50,7 @@ -} makeArranger :: (Storable a, A.Additive value, - MakeValueTuple a value, Memory.C value struct, + MakeValueTuple a, ValueTuple a ~ value, Memory.C value, Arr.Arrow arrow) => IO (arrow (EventListTT.T NonNeg.Int (SV.Vector a)) @@ -67,7 +67,7 @@ AbsEventList.mapTime NonNeg.toNumber $ EventList.toAbsoluteEventList 0 $ EventListTM.switchTimeR const now - in unsafePerformIO $ + in Unsafe.performIO $ SVB.createAndTrim sz $ \dstPtr -> do fill (fromIntegral sz) dstPtr Fold.forM_ xs $ \(i,s) -> @@ -81,10 +81,10 @@ continuePacked :: - (CutG.Transform a, Storable b, LLVM.IsPrimitive b, TypeNum.Pos n) => - PIO.T a (SV.Vector (LLVM.Vector n b)) -> - (b -> PIO.T a (SV.Vector (LLVM.Vector n b))) -> - PIO.T a (SV.Vector (LLVM.Vector n b)) + (CutG.Transform a, Storable b, LLVM.IsPrimitive b, TypeNum.PositiveT n) => + PIO.T a (SV.Vector (Serial.Plain n b)) -> + (b -> PIO.T a (SV.Vector (Serial.Plain n b))) -> + PIO.T a (SV.Vector (Serial.Plain n b)) continuePacked proc0 proc1 = PIO.continueChunk proc0 (proc1 Arr.<<^ SV.last . SigStL.unpackStrict) 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 @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} {- | Functions on lazy storable vectors that are implemented using LLVM. @@ -21,10 +21,10 @@ import qualified Synthesizer.LLVM.Execution as Exec import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Control (arrayLoop, ) +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoVector @@ -39,12 +39,11 @@ import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) -import LLVM.Extra.Class (MakeValueTuple, ) +import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Core (Linkage(ExternalLinkage), createNamedFunction, ret, - IsSized, IsPrimitive, getElementPtr, - Vector, ) -import qualified Data.TypeLevel.Num as TypeNum + IsPrimitive, getElementPtr, ) +import qualified Types.Data.Num as TypeNum import qualified Control.Category as Cat @@ -56,7 +55,7 @@ import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, ) -import System.IO.Unsafe (unsafePerformIO, ) +import qualified System.Unsafe as Unsafe import NumericPrelude.Numeric import NumericPrelude.Base @@ -71,34 +70,34 @@ It would also need copying since the source data may not be aligned properly. -} unpackStrict :: - (Storable a, IsPrimitive a, TypeNum.Pos n) => - SV.Vector (Vector n a) -> SV.Vector a + (Storable a, IsPrimitive a, TypeNum.PositiveT n) => + SV.Vector (Serial.Plain n a) -> SV.Vector a unpackStrict v = - let getDim :: (TypeNum.Pos n) => SV.Vector (Vector n a) -> n -> Int - getDim _ = TypeNum.toInt + let getDim :: (TypeNum.PositiveT n) => SV.Vector (Serial.Plain n a) -> n -> Int + getDim _ = TypeNum.fromIntegerT d = getDim v undefined (fptr,s,l) = SVB.toForeignPtr v in SVB.SV (castForeignPtr fptr) (s*d) (l*d) unpack :: - (Storable a, IsPrimitive a, TypeNum.Pos n) => - SVL.Vector (Vector n a) -> SVL.Vector a + (Storable a, IsPrimitive a, TypeNum.PositiveT n) => + SVL.Vector (Serial.Plain n a) -> SVL.Vector a unpack = SVL.fromChunks . map unpackStrict . SVL.chunks unpackStereoStrict :: - (Storable a, IsPrimitive a, TypeNum.Pos n) => + (Storable a, IsPrimitive a, TypeNum.PositiveT n) => SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a) unpackStereoStrict v = - let getDim :: (TypeNum.Pos n) => SV.Vector (StereoVector.T n a) -> n -> Int - getDim _ = TypeNum.toInt + let getDim :: (TypeNum.PositiveT n) => SV.Vector (StereoVector.T n a) -> n -> Int + getDim _ = TypeNum.fromIntegerT d = getDim v undefined (fptr,s,l) = SVB.toForeignPtr v in SVB.SV (castForeignPtr fptr) (s*d) (l*d) unpackStereo :: - (Storable a, IsPrimitive a, TypeNum.Pos n) => + (Storable a, IsPrimitive a, TypeNum.PositiveT n) => SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a) unpackStereo = SVL.fromChunks . map unpackStereoStrict . SVL.chunks @@ -108,26 +107,28 @@ This is for instance necessary for stereo signals where the data layout of packed and unpacked data is different, thus simple casting of the data is not possible. -However, for vectorized Stereo data the StereoInterleaved +However, for vectorized Stereo data the StereoInterleaved type still uses vector operations for interleaving and thus is more efficient. -} makeUnpackGenericStrict :: - (Vector.Access n va vv, - Storable a, MakeValueTuple a va, Memory.C va as, IsSized as asize, - Storable v, MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) => + (Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv, + Memory.C (Serial.ReadIt vv), + Storable a, MakeValueTuple a, ValueTuple a ~ va, Memory.C va, + Storable v, MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) => IO (SV.Vector v -> SV.Vector a) makeUnpackGenericStrict = let vectorSize :: - (Vector.Access n al vl, Storable v, MakeValueTuple v vl) => + (Serial.C vl, n ~ Serial.Size vl, al ~ Serial.Element vl, Storable v, MakeValueTuple v, ValueTuple v ~ vl) => SV.Vector v -> n vectorSize _ = undefined - in fmap (\f v -> f (TypeNum.toInt (vectorSize v) * SV.length v) v) $ + in fmap (\f v -> f (TypeNum.fromIntegerT (vectorSize v) * SV.length v) v) $ SigP.run (SigPS.unpack $ SigP.fromStorableVector Cat.id) makeUnpackGeneric :: - (Vector.Access n va vv, - Storable a, MakeValueTuple a va, Memory.C va as, IsSized as asize, - Storable v, MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) => + (Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv, + Memory.C (Serial.ReadIt vv), + Storable a, MakeValueTuple a, ValueTuple a ~ va, Memory.C va, + Storable v, MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) => IO (SVL.Vector v -> SVL.Vector a) makeUnpackGeneric = fmap (\f -> SVL.fromChunks . map f . SVL.chunks) $ @@ -135,10 +136,10 @@ makeReverser :: - (Storable a, Vector.ShuffleMatch n value, - MakeValueTuple a value, Memory.C value struct) => + (Storable a, Serial.C value, + MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => value -> IO (Word32 -> Ptr a -> Ptr a -> IO ()) --- (Memory.C a struct, Vector.ShuffleMatch n a) => +-- (Memory.C a struct, Serial.C a) => -- IO (Word32 -> Ptr struct -> Ptr struct -> IO ()) makeReverser dummy = fmap (\f len srcPtr dstPtr -> @@ -150,27 +151,27 @@ _ <- arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do ptrAj1 <- getElementPtr ptrAj0 (-1 :: Int32, ()) flip Memory.store ptrBi - =<< Vector.reverse + =<< Serial.reverse . flip asTypeOf dummy =<< Memory.load ptrAj1 return ptrAj1 ret () makeReversePackedStrict :: - (Storable v, Vector.Access n va vv, - MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) => + (Storable v, Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv, + MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) => IO (SV.Vector v -> SV.Vector v) makeReversePackedStrict = do rev <- makeReverser undefined return $ \v -> - unsafePerformIO $ + Unsafe.performIO $ SVB.withStartPtr v $ \ptrA len -> SVB.create len $ \ptrB -> rev (fromIntegral len) ptrA ptrB makeReversePacked :: - (Storable v, Vector.Access n va vv, - MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) => + (Storable v, Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv, + MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) => IO (SVL.Vector v -> SVL.Vector v) makeReversePacked = fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $ @@ -201,10 +202,10 @@ (\body l -> SVL.append body (y l)) x continuePacked :: - (TypeNum.Pos n, Storable a, IsPrimitive a) => - SVL.Vector (Vector n a) -> - (a -> SVL.Vector (Vector n a)) -> - SVL.Vector (Vector n a) + (TypeNum.PositiveT n, Storable a, IsPrimitive a) => + SVL.Vector (Serial.Plain n a) -> + (a -> SVL.Vector (Serial.Plain n a)) -> + SVL.Vector (Serial.Plain n a) continuePacked x y = SVL.fromChunks $ withLast SV.empty @@ -228,8 +229,8 @@ -} continuePackedGeneric :: {- - (Storable v, Vector.Access n a v, - MakeValueTuple v vv, Memory.C vv vs, IsSized vs vsize) => + (Storable v, Serial.C v, n ~ Serial.Size v, a ~ Serial.Element v, + MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) => -} (Storable v, Storable a) => (SV.Vector v -> SV.Vector a) -> @@ -269,7 +270,7 @@ it also simplifies type inference. -} fillBuffer :: - (MakeValueTuple a value, Memory.C value struct) => + (MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => value -> IO (Word32 -> Ptr a -> IO ()) fillBuffer x = fmap (\f len ptr -> f len (Memory.castStorablePtr ptr)) $ @@ -287,7 +288,7 @@ makeMixer :: (Storable a, A.Additive value, - MakeValueTuple a value, Memory.C value struct) => + MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => value -> IO (Word32 -> Ptr a -> Ptr a -> IO ()) makeMixer dummy = fmap (\f len srcPtr dstPtr -> @@ -321,7 +322,7 @@ -} makeArranger :: (Storable a, A.Additive value, - MakeValueTuple a value, Memory.C value struct) => + MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => IO (SVL.ChunkSize -> EventList.T NonNeg.Int (SVL.Vector a) -> SVL.Vector a) @@ -337,7 +338,7 @@ EventList.toAbsoluteEventList 0 $ EventListTM.switchTimeR const now (chunk,newAcc) = - unsafePerformIO $ + Unsafe.performIO $ SVB.createAndTrim' sz $ \ptr -> do fill (fromIntegral sz) ptr newAcc0 <- flip mapM acc $ addToBuffer mixer sz ptr 0 @@ -364,7 +365,7 @@ {-# DEPRECATED arrange "better use makeArranger" #-} arrange :: (Storable a, A.Additive value, - MakeValueTuple a value, Memory.C value struct) => + MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => SVL.ChunkSize -> EventList.T NonNeg.Int (SVL.Vector a) {-^ A list of pairs: (relative start time, signal part), @@ -373,4 +374,4 @@ -> SVL.Vector a {-^ The mixed signal. -} arrange = - unsafePerformIO makeArranger + Unsafe.performIO makeArranger diff --git a/src/Synthesizer/LLVM/Test.hs b/src/Synthesizer/LLVM/Test.hs deleted file mode 100644 --- a/src/Synthesizer/LLVM/Test.hs +++ /dev/null @@ -1,1336 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Main where - -import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass -import qualified Synthesizer.LLVM.Filter.Allpass as Allpass -import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth -import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev -import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 -import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2 -import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P -import qualified Synthesizer.LLVM.Filter.Moog as Moog -import qualified Synthesizer.LLVM.Filter.Universal as UniFilter -import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP -import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS -import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func -import qualified Synthesizer.LLVM.Causal.Process as Causal -import qualified Synthesizer.LLVM.Simple.Signal as Sig -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import qualified Synthesizer.LLVM.Frame as Frame -import qualified Synthesizer.LLVM.Wave as Wave -import qualified Synthesizer.LLVM.Parameter as Param - -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Arithmetic as A -import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) -import LLVM.Util.Arithmetic () -- Floating instance for TValue -import qualified LLVM.Core as LLVM -import Data.TypeLevel.Num (D4, D8, D16, ) -import qualified Data.TypeLevel.Num as TypeNum - -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ) -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import qualified Synthesizer.Plain.Filter.Recursive as FiltR -import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core -import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core - -import Control.Arrow (Arrow, arr, (&&&), (^<<), (***), ) -import Control.Category ((<<<), (.), id, ) -import Control.Applicative (pure, liftA2, ) - -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Numeric.NonNegative.Wrapper as NonNeg - -import qualified Sound.Sox.Option.Format as SoxOption -import qualified Sound.Sox.Play as SoxPlay --- import qualified Synthesizer.Storable.ALSA.Play as Play - -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo - -import Data.Word (Word32, ) --- import qualified Data.Function.HT as F -import Data.List (genericLength, ) -import System.Random (randomRs, mkStdGen, ) - -import qualified System.IO as IO --- import System.Exit (ExitCode, ) - -import Prelude hiding (fst, snd, id, (.), ) -import qualified Prelude as P - - -asMono :: vector Float -> vector Float -asMono = id - -asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float) -asStereo = id - -asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float) -asMonoPacked = id - -asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float) -asMonoPacked16 = id - -asWord32 :: vector Word32 -> vector Word32 -asWord32 = id - -asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32) -asWord32Packed = id - - -{- | -> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01) - -Unfortunately: If you call :reload, -then the next attempt to play something will be answered by: - -ghci: JITEmitter.cpp:110: ::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed. --} -playStereo :: Sig.T (Stereo.T (Value Float)) -> IO () -playStereo = - playStereoVector . - Sig.renderChunky (SVL.chunkSize 100000) - -playStereoVector :: SVL.Vector (Stereo.T Float) -> IO () -playStereoVector = - fmap (const ()) . - SoxPlay.simple SVL.hPut SoxOption.none 44100 - -playMono :: Sig.T (Value Float) -> IO () -playMono = - playMonoVector . - Sig.renderChunky (SVL.chunkSize 100000) - -playMonoVector :: SVL.Vector Float -> IO () -playMonoVector = - fmap (const ()) . - SoxPlay.simple SVL.hPut SoxOption.none 44100 - - -playFileMono :: FilePath -> IO () -playFileMono fileName = do - IO.withFile fileName IO.ReadMode $ \h -> - playStereo . - Sig.fromStorableVectorLazy . - asStereo . snd - =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h - return () - - -saw :: IO () -saw = - SV.writeFile "speedtest.f32" $ - asMono $ - Sig.render 10000000 $ - Sig.osciSaw 0 0.01 - -exponential :: IO () -exponential = - SV.writeFile "speedtest.f32" $ - asMono $ - Sig.render 10000000 $ - Sig.exponential2 50000 1 - -triangle :: IO () -triangle = - SV.writeFile "speedtest.f32" $ - asMono $ - Sig.render 10000000 $ - Sig.osci Wave.triangle 0.25 0.01 - -trianglePack :: IO () -trianglePack = - SV.writeFile "speedtest.f32" $ - asMonoPacked $ - (\xs -> SigP.render xs (div 10000000 4) ()) $ - SigP.mapSimple Wave.triangle $ - SigPS.packSmall $ - (SigP.osciCore $# (0.25::Float)) 4.015803e-4 - -trianglePacked :: IO () -trianglePacked = - SV.writeFile "speedtest.f32" $ - asMonoPacked $ - (\xs -> SigP.render xs (div 10000000 4) ()) $ - (CausalPS.osciSimple Wave.triangle - $< SigPS.constant 0.25 - $* SigPS.constant 0.01) - -triangleReplicate :: IO () -triangleReplicate = - SV.writeFile "speedtest.f32" $ - asMonoPacked $ - (\xs -> SigP.render xs (div 10000000 4) ()) $ - (CausalPS.shapeModOsci - (\k p -> do - x <- Wave.triangle =<< Wave.replicate k p - y <- Wave.approxSine4 =<< Wave.halfEnvelope p - A.mul x y) - $< SigPS.rampInf 1000000 - $< SigPS.constant 0 - $* SigPS.constant 0.01) - -rationalSine :: IO () -rationalSine = - SV.writeFile "speedtest.f32" $ - asMonoPacked $ - (\xs -> SigP.render xs (div 10000000 4) ()) $ - (CausalPS.shapeModOsci Wave.rationalApproxSine1 - $< SigP.mapSimple (A.add (valueOf 0.001)) (SigPS.rampInf 10000000) - $< SigPS.constant 0 - $* SigPS.constant 0.01) - - -pingSig :: Float -> Sig.T (Value Float) -pingSig freq = - Sig.envelope - (Sig.exponential2 50000 1) - (Sig.osciSaw 0.5 freq) - -pingSigP :: SigP.T Float (Value Float) -pingSigP = - let freq = id - in SigP.envelope - (SigP.exponential2 50000 1) - (SigP.osciSaw 0.5 freq) - -ping :: IO () -ping = - SV.writeFile "speedtest.f32" $ - asMono $ - Sig.render 10000000 $ - pingSig 0.01 - -pingSigPacked :: SigP.T Float (Value (Vector D4 Float)) -pingSigPacked = - let freq = id - in SigP.envelope - (SigPS.exponential2 50000 1) - (SigPS.osciSimple Wave.saw 0 freq) - -pingPacked :: IO () -pingPacked = - SV.writeFile "speedtest.f32" $ - asMonoPacked $ - (\xs -> SigP.render xs (div 10000000 4) 0.01) $ - pingSigPacked - -pingUnpack :: IO () -pingUnpack = - SV.writeFile "speedtest.f32" $ - asMono $ - (\xs -> SigP.render xs 10000000 0.01) $ - SigPS.unpack $ - pingSigPacked - -pingSmooth :: IO () -pingSmooth = - SV.writeFile "speedtest-scalar.f32" $ - asMono $ - (\xs -> SigP.render xs 10000000 ()) $ - (Filt1.lowpassCausalP - $< (fmap Filt1Core.Parameter $ - SigP.mapSimple (A.sub (valueOf 1)) - (SigP.exponential2 50000 $# (1::Float))) - $* SigP.osciSimple Wave.triangle 0 0.01) - -pingSmoothPacked :: IO () -pingSmoothPacked = - SV.writeFile "speedtest-vector.f32" $ - asMonoPacked $ - (\xs -> SigP.render xs (div 10000000 4) ()) $ - (Filt1.lowpassCausalPackedP - $< (fmap Filt1Core.Parameter $ - SigP.mapSimple (A.sub (valueOf 1)) - (SigP.exponential2 (50000/4) $# (1::Float))) - $* SigPS.osciSimple Wave.triangle 0 0.01) - -stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float)) -stereoOsciSaw freq = - liftA2 Stereo.cons - (Sig.osciSaw 0.0 (freq*1.001) `Sig.mix` - Sig.osciSaw 0.2 (freq*1.003) `Sig.mix` - Sig.osciSaw 0.1 (freq*0.995)) - (Sig.osciSaw 0.1 (freq*1.005) `Sig.mix` - Sig.osciSaw 0.7 (freq*0.997) `Sig.mix` - Sig.osciSaw 0.5 (freq*0.999)) - -stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float)) -stereoOsciSawPacked freq = - let mix4 = - Frame.mixVector . - flip asTypeOf (undefined :: Value (Vector D4 Float)) - in liftA2 Stereo.cons - (Sig.map mix4 $ - Sig.osciPlain Wave.saw - (value $ constVector $ map constOf [0.0, 0.2, 0.1, 0.4]) - (value $ constVector $ - map (constOf . (freq*)) [1.001, 1.003, 0.995, 0.996])) - (Sig.map mix4 $ - Sig.osciPlain Wave.saw - (value $ constVector $ map constOf [0.1, 0.7, 0.5, 0.7]) - (value $ constVector $ - map (constOf . (freq*)) [1.005, 0.997, 0.999, 1.001])) - -stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float)) -stereoOsciSawPacked2 freq = - Sig.map (Frame.mixVectorToStereo . - flip asTypeOf (undefined :: Value (Vector D8 Float))) $ - Sig.osciPlain (Wave.trapezoidSkew (SoV.replicateOf 0.2)) - (valueOf $ - LLVM.toVector (0.0, 0.2, 0.1, 0.4, 0.1, 0.7, 0.5, 0.7)) - (value $ constVector $ - map (constOf . (freq*)) $ - [1.001, 1.003, 0.995, 0.996, 1.005, 0.997, 0.999, 1.001]) - -stereo :: IO () -stereo = - SV.writeFile "speedtest.f32" $ - asStereo $ - Sig.render 10000000 $ - Sig.amplifyStereo 0.25 $ - stereoOsciSawPacked2 0.01 - -lazy :: IO () -lazy = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asMono $ - Sig.renderChunky (SVL.chunkSize 100000) - {- SVL.defaultChunkSize - too slow -} $ - Sig.envelope - (Sig.exponential2 50000 1) - (Sig.osci Wave.sine 0.5 0.01 :: Sig.T (Value Float)) - -lazyStereo :: IO () -lazyStereo = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asStereo $ - Sig.renderChunky (SVL.chunkSize 100000) $ - Sig.amplifyStereo 0.25 $ - stereoOsciSawPacked 0.01 - -packTake :: IO () -packTake = - SVL.writeFile "speedtest.f32" $ - asMonoPacked $ - flip (SigP.renderChunky (SVL.chunkSize 1000)) () $ - SigPS.packRotate $ - (CausalP.take 5 $* - SigP.osciSimple Wave.saw 0 0.01) - -chord :: Float -> Sig.T (Stereo.T (Value Float)) -chord base = - {- - This exceeds available vector registers - and thus needs more stack accesses. - Thus it needs twice as much time as the simple mixing. - However doing all 32 oscillators in parallel - and mix them in one go might be still faster. - - foldl1 (Sig.zipWith Frame.mixStereoV) $ - -} - foldl1 Sig.mix $ - map (\f -> stereoOsciSawPacked2 (base*f)) $ - 0.25 : 1.00 : 1.25 : 1.50 : [] - -lazyChord :: IO () -lazyChord = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asStereo $ - Sig.renderChunky (SVL.chunkSize 100000) $ - Sig.amplifyStereo 0.1 $ - chord 0.005 - -filterSweepComplex :: IO () -filterSweepComplex = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asStereo $ - Sig.renderChunky (SVL.chunkSize 100000) $ - Sig.amplifyStereo 0.3 $ - Causal.apply BandPass.causal $ - Sig.zip - (Sig.map (BandPass.parameter (valueOf 100)) $ - Sig.map (\x -> 0.01 * exp (2 * return x)) $ - Sig.osci Wave.sine 0 (0.1/44100)) $ - chord 0.005 - -lfoSine :: - (Memory.C a ap, LLVM.IsSized ap asize) => - (forall r. Value Float -> LLVM.CodeGenFunction r a) -> - Param.T p Float -> - SigP.T p a -lfoSine f reduct = - SigP.mapSimple f $ - SigP.mapSimple (\x -> 0.01 * exp (2 * return x)) $ - SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100) - -filterSweep :: IO () -filterSweep = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asMono $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalP.amplify 0.2 . - CtrlP.processCtrlRate 128 - (lfoSine (Filt2.bandpassParameter (valueOf 100))) - $* SigP.osciSimple Wave.saw 0 0.01) - -filterSweepPacked :: IO () -filterSweepPacked = - SVL.writeFile "speedtest.f32" $ - SVL.take (div 10000000 4) $ - asMonoPacked $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalP.amplify 0.2 . - CtrlPS.processCtrlRate 128 - (lfoSine (Filt2.bandpassParameter (valueOf 100))) - $* SigPS.osciSimple Wave.saw 0 0.01) - -exponentialFilter2Packed :: IO () -exponentialFilter2Packed = - SVL.writeFile "speedtest.f32" $ - SVL.take (div 10000000 16) $ - asMonoPacked16 $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (Filt2.causalPackedP - $< (SigP.constant $# - Filt2Core.Parameter (1::Float) 0 0 0 0.99) - $* ( --- (CausalP.delay1 $# LLVM.vector [0.1,0.01,0.001,0.0001::Float]) --- (CausalP.delay1 $# LLVM.vector [1::Float]) - (CausalP.delay1 $# LLVM.vector ((1::Float):repeat 0)) - $* (SigP.constant $# LLVM.vector [0::Float]))) - -filterSweepPacked2 :: IO () -filterSweepPacked2 = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asMono $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalP.amplify 0.2 . - CtrlP.processCtrlRate 128 - (lfoSine (Filt2P.bandpassParameter (valueOf 100))) - $* SigP.osciSimple Wave.saw 0 0.01) - -butterworthNoisePacked :: IO () -butterworthNoisePacked = - SVL.writeFile "speedtest.f32" $ - SVL.take (div 10000000 4) $ - asMonoPacked $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalPS.amplify 0.2 . - CtrlPS.processCtrlRate 128 - (lfoSine (Butterworth.parameter TypeNum.d3 FiltR.Lowpass (valueOf 0.5))) - $* SigPS.noise 0 0.3) - -chebyshevNoisePacked :: IO () -chebyshevNoisePacked = - SVL.writeFile "speedtest.f32" $ - SVL.take (div 10000000 4) $ - asMonoPacked $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalPS.amplify 0.2 . - CtrlPS.processCtrlRate 128 - (lfoSine (Chebyshev.parameterA TypeNum.d5 FiltR.Lowpass (valueOf 0.5))) - $* SigPS.noise 0 0.3) - -{- -Provoke non-aligned vector accesses by calling alloca for a record of 5 floats -in LLVM-2.6. -However, the vector accesses are those of noise. -Using scalar Noise there is no problem. --} -noiseAllocaBug :: IO () -noiseAllocaBug = - SVL.writeFile "speedtest.f32" $ - SVL.take (div 10000000 4) $ - asMonoPacked $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalPS.amplify 0.2 . Filt2.causalPackedP - $< (SigP.mapSimple (const $ Memory.load =<< LLVM.alloca) $ - (SigP.constant $# (0::Float))) - $* SigPS.noise 0 0.3) - -noiseAllocaScalar :: IO () -noiseAllocaScalar = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asMono $ - flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ - (CausalP.amplify 0.2 . Filt2.causalP - $< (SigP.mapSimple (const $ - (Memory.load =<< LLVM.alloca :: - LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $ - (SigP.constant $# (0::Float))) - $* SigP.noise 0 0.3) - - -upsample :: IO () -upsample = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asMono $ - Sig.renderChunky (SVL.chunkSize 100000) $ - (let reduct = 128 :: Float - in Sig.interpolateConstant reduct $ - Sig.osci Wave.sine 0 (reduct*0.1/44100)) - - -filterSweepControlRateCausal :: - Causal.T - (Stereo.T (Value Float)) - (Stereo.T (Value Float)) -filterSweepControlRateCausal = - Causal.amplifyStereo 0.3 <<< - BandPass.causal <<< - Causal.feedFst - (let reduct = 128 - in Sig.interpolateConstant reduct $ - Sig.map (BandPass.parameter (valueOf 100)) $ - Sig.map (\x -> 0.01 * exp (2 * return x)) $ - Sig.osci Wave.sine 0 (reduct*0.1/44100)) - -filterSweepControlRateProc :: - Sig.T (Stereo.T (Value Float)) -> - Sig.T (Stereo.T (Value Float)) -filterSweepControlRateProc = - Causal.apply filterSweepControlRateCausal - -{- | -Trigonometric functions are very slow in LLVM -because they are translated to calls to C's math library. -Thus it is advantageous to compute filter parameters -at a lower rate and interpolate constantly. --} -filterSweepControlRate :: IO () -filterSweepControlRate = - SVL.writeFile "speedtest.f32" $ - asStereo $ - SVL.take 10000000 $ - Sig.renderChunky (SVL.chunkSize 100000) $ - filterSweepControlRateProc $ - chord 0.005 - - -filterSweepMusic :: IO () -filterSweepMusic = - do music <- SV.readFile "lichter.f32" - SVL.writeFile "speedtest.f32" $ - asStereo $ - Sig.renderChunky (SVL.chunkSize 100000) $ - Sig.amplifyStereo 20 $ - filterSweepControlRateProc $ - Sig.fromStorableVector $ - (music :: SV.Vector (Stereo.T Float)) - - -playFilterSweepMusicLazy :: IO () -playFilterSweepMusicLazy = do - IO.withFile "lichter.f32" IO.ReadMode $ \h -> - playStereo . --- Sig.amplifyStereo 1.125 . - Sig.amplifyStereo 20 . - filterSweepControlRateProc . - Sig.fromStorableVectorLazy . - asStereo . snd - =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h - return () - -playFilterSweepMusicCausal :: IO () -playFilterSweepMusicCausal = do - do music <- SV.readFile "lichter.f32" - _ <- SoxPlay.simple SV.hPut SoxOption.none 44100 $ - asStereo $ - Causal.applyStorable - (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $ - (music :: SV.Vector (Stereo.T Float)) - return () - -playFilterSweepMusicCausalLazy :: IO () -playFilterSweepMusicCausalLazy = do - IO.withFile "lichter.f32" IO.ReadMode $ \h -> - playStereoVector . - Causal.applyStorableChunky - (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) . - asStereo . snd - =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h - return () - -arrangeLazy :: IO () -arrangeLazy = do - IO.hSetBuffering IO.stdout IO.NoBuffering - print $ - SigStL.arrange (SVL.chunkSize 2) $ - EventList.fromPairList $ - (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) : - (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) : - (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) : - -- repeat (2, SVL.empty) --- (2, SVL.empty) : --- (2, SVL.empty) : --- (2::NonNeg.Int, error "undefined sound") : - error "end of list" - -- [] - - -{- | -This is inefficient because pingSig is compiled by LLVM -for every occurence of the sound! - -randomTones :: IO () -randomTones = do - playMonoVector $ - SigStL.arrange (SVL.chunkSize 12345) $ - EventList.fromPairList $ zip - (cycle $ map (flip div 16 . (44100*)) [1,2,3]) - (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) . - pingSig . (0.01*)) - [1,1.25,1.5,2]) - return () --} - -{- | -So far we have not managed to compile signals -that depend on parameters. -Thus in order to avoid much recompilation, -we compile and render a few sounds in advance. --} -pingTones :: [SVL.Vector Float] -pingTones = - map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) . - pingSig . (0.01*)) - [1,1.25,1.5,2] - -pingTonesIO :: IO [SVL.Vector Float] -pingTonesIO = - fmap - (\pingVec -> - map - (SVL.take 44100 . - pingVec (SVL.chunkSize 4321) . - (0.01*)) - [1,1.25,1.5,2]) - (SigP.runChunky pingSigP) - -{- -Arrange itself does not seem to have a space leak with temporary data. -However it may leak sound data. -This is not very likely because this would result in a large memory leak. - -Generate random tones in order to see whether generated sounds leak. -How does 'arrange' compare with 'concat'? --} - -cycleTones :: IO () -cycleTones = do --- playMono $ - pings <- pingTonesIO - SVL.writeFile "test.f32" $ --- Play.auto (0.01::Double) 44100 $ - asMono $ -{- -after 13min runtime memory consumption increased from 2.5 to 3.9 -and we get lot of buffer underruns with this implementation of amplification -(renderChunky . amplify . fromStorableVector) --} - Sig.renderChunky (SVL.chunkSize 432109) $ - Sig.amplify 0.1 $ - Sig.fromStorableVectorLazy $ -{- -after 20min memory consumption increased from 2.5 to 3.4 -and we get lot of buffer underruns with applyStorableChunky --} -{- -applyStorableChunky applied to concatenated zero vectors -starts with memory consumption 1.0 and after an hour, it's still 1.1 -without buffer underruns. --} -{- - CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $ - asMono $ --} -{- -with chunksize 12345678 -after 50min runtime the memory consumption increased from 12.0 to 26.2 - -with chunksize 123 -after 25min runtime the memory consumption is constant 7.4 -however at start time there 5 buffer underruns, but no more -probably due to initial LLVM compilation - -with chunksize 1234567 and SVL.replicate instead of pingTones -we get memory consumption from 1.3 to 3.2 in 15min, -while producing lots of buffer underruns. -After 45min in total, it is still 3.2 of memory consumption. -Is this a memory leak, or isn't it? - -with chunksize 12345678 and SVL.replicate -we get from 5.6 to 10.2 in 3min -to 14.9 after total 13min. --} -{- - SigStL.arrange (SVL.chunkSize 12345678) $ - EventList.fromPairList $ zip - (repeat (div 44100 8)) --- (cycle $ map (flip div 4 . (44100*)) [1,2,3]) --} -{- -With plain concatenation of those zero vectors -we stay constantly at 0.4 memory consumption and no buffer underruns over 30min. --} - SVL.concat - (cycle pings) --- (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0) - return () - - -tonesChunkSize :: SVL.ChunkSize -numTones :: Int - -{- -For one-time-compiled fill functions, -larger chunks have no relevant effect on the processing speed. --} -(tonesChunkSize, numTones) = - (SVL.chunkSize 441, 200) --- (SVL.chunkSize 44100, 200) - -fst :: Arrow arrow => arrow (a,b) a -fst = arr P.fst - -snd :: Arrow arrow => arrow (a,b) b -snd = arr P.snd - - -{-# NOINLINE makePing #-} -makePing :: IO ((Float,Float) -> SVL.Vector Float) -makePing = - let freq = snd - halfLife = fst - in fmap ($tonesChunkSize) $ - SigP.runChunky - (SigP.envelope - (SigP.exponential2 halfLife 1) - (SigP.osciSaw 0.5 freq)) - -tonesDown :: IO () -tonesDown = do - let dist = div 44100 10 - pingp <- makePing - playMonoVector $ - CausalP.applyStorableChunky (CausalP.amplify id) 0.03 $ - SigStL.arrange tonesChunkSize $ - EventList.fromPairList $ zip - (repeat (NonNeg.fromNumber dist)) - (map (SVL.take (numTones * dist) . curry pingp 50000) $ - iterate (0.999*) 0.01) - return () - - -vibes :: SigP.T (Float,Float) (Value Float) -vibes = - let freq = snd - modDepth = fst - halfLife = 5000 - -- sine = Wave.sine - sine = Wave.approxSine4 - in CausalP.envelope - $< SigP.exponential2 halfLife 1 - $* (((CausalP.osciSimple sine - $< (CausalP.envelope - $< SigP.exponential2 halfLife modDepth - $* (CausalP.osciSimple sine - $* SigP.constant (return (0::Float) &&& (2*freq))))) - <<< - CausalP.mapLinear (0.01*freq) freq - <<< - CausalP.osciSimple sine) - $* SigP.constant (return (0::Float, 0.0001::Float))) - -makeVibes :: IO ((Float,Float) -> SVL.Vector Float) -makeVibes = - fmap ($tonesChunkSize) $ - SigP.runChunky vibes - -vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> SVL.Vector Float -vibesCycleVector pingp = - SigStL.arrange tonesChunkSize $ - EventList.fromPairList $ zip - (repeat 5000) - (map (SVL.take 50000 . pingp) $ - zip - (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0) - (cycle $ map (0.01*) [1, 1.25, 1.5, 2])) - -vibesCycle :: IO () -vibesCycle = do - pingp <- makeVibes - playMonoVector $ - CausalP.applyStorableChunky (CausalP.amplify id) 0.2 $ - vibesCycleVector pingp - return () - -vibesEcho :: IO () -vibesEcho = do - pingp <- makeVibes - playMonoVector $ - CausalP.applyStorableChunky - (CausalP.amplify id <<< - CausalP.comb 0.5 7000) - 0.2 $ - vibesCycleVector pingp - return () - -vibesReverb :: IO () -vibesReverb = do - pingp <- makeVibes - playMonoVector $ - CausalP.applyStorableChunky - (CausalP.amplify id <<< - CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000)) - 0.3 $ - vibesCycleVector pingp - return () - -vibesReverbStereo :: IO () -vibesReverbStereo = do - pingp <- makeVibes - playStereoVector $ - CausalP.applyStorableChunky - (CausalP.amplifyStereo id <<< - CausalP.stereoFromChannels - (CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000)) - (CausalP.reverb (mkStdGen 857) 16 (0.9,0.97) (400,1000)) <<< - CausalP.mapSimple Frame.stereoFromMono) - 0.3 $ - vibesCycleVector pingp - return () - - - -stair :: IO () -stair = - SVL.writeFile "speedtest.f32" $ - SVL.take 10000000 $ - asMono $ - flip (SigP.renderChunky tonesChunkSize) () $ - SigP.piecewiseConstant $ - return $ - EventListBT.fromPairList $ - zip - (iterate (/2) (1::Float)) - (iterate (2*) (1::NonNeg.Int)) - - -filterBass :: IO () -filterBass = do - playStereoVector $ - asStereo $ - flip (SigP.renderChunky tonesChunkSize) () $ - CausalP.apply - (BandPass.causalP - <<< - CausalP.feedSnd - (liftA2 Stereo.cons - (SigP.osciSimple Wave.saw 0 0.001499) - (SigP.osciSimple Wave.saw 0 0.001501)) - <<< - CausalP.mapSimple (BandPass.parameter (valueOf (100::Float)))) $ - SigP.piecewiseConstant $ - return $ EventListBT.fromPairList $ - zip - (map (((0.03::Float)*) . (2**) . (/12) . fromInteger) $ - randomRs (0,12) (mkStdGen 998)) - (repeat (10000::NonNeg.Int)) - - return () - - -{- | -This function is not very efficient, -since it compiles an LLVM mixing routine -for every pair of mixer inputs. --} -mixVectorRecompile :: - SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float -mixVectorRecompile xs ys = - Sig.renderChunky tonesChunkSize $ - Sig.mix - (Sig.fromStorableVectorLazy xs) - (Sig.fromStorableVectorLazy ys) - -mixVectorParamIO :: - IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float) -mixVectorParamIO = - fmap curry $ - fmap ($tonesChunkSize) $ - SigP.runChunky - (SigP.mix - (SigP.fromStorableVectorLazy fst) - (SigP.fromStorableVectorLazy snd)) - -mixVectorCausalIO :: - IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float) -mixVectorCausalIO = - CausalP.runStorableChunky - (CausalP.mix $< - SigP.fromStorableVectorLazy id) - -mixVectorCausal :: - SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float -mixVectorCausal = - CausalP.applyStorableChunky - (CausalP.mix $< - SigP.fromStorableVectorLazy id) - -mixVectorStereo :: - SVL.Vector (Stereo.T Float) -> - SVL.Vector (Stereo.T Float) -> - SVL.Vector (Stereo.T Float) -mixVectorStereo = - CausalP.applyStorableChunky - (CausalP.mix $< - SigP.fromStorableVectorLazy id) - -mixVectorStereoIO :: - IO (SVL.Vector (Stereo.T Float) -> - SVL.Vector (Stereo.T Float) -> - SVL.Vector (Stereo.T Float)) -mixVectorStereoIO = - CausalP.runStorableChunky - (CausalP.mix $< - SigP.fromStorableVectorLazy id) - -{- -slightly slower than mixVectorParam --} -mixVectorHaskell :: - SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float -mixVectorHaskell = SVL.zipWith (+) - -toneMix :: IO () -toneMix = do - pingp <- makePing - mix <- mixVectorCausalIO - playMonoVector $ - Causal.applyStorableChunky (Causal.amplify 0.1) $ - foldl1 mix $ - map (curry pingp 1000000) $ - take numTones $ - iterate (*(2/3)) 0.01 - return () - -fadeEnvelope :: SigP.T (Int, Int) (Value Float) -fadeEnvelope = - SigP.parabolaFadeIn (fmap fromIntegral fst) - `SigP.append` - (CausalP.take snd $* (SigP.constant $# (1::Float))) - `SigP.append` - SigP.parabolaFadeOut (fmap fromIntegral fst) - -fadeEnvelopeWrite :: IO () -fadeEnvelopeWrite = - SVL.writeFile "speedtest.f32" $ - asMono $ - SigP.renderChunky (SVL.chunkSize 1234) - fadeEnvelope (100000, 200000) - - --- | normalize a list of numbers, such that they have a specific average --- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs -normalizeLevel :: Fractional a => a -> [a] -> [a] -normalizeLevel newAvrg xs = - let avrg = sum xs / genericLength xs - in map ((newAvrg-avrg)+) xs - -stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float)) -stereoOsciSawP = - let freq = id - n = 5 - volume = pure $ recip $ sqrt $ fromIntegral n :: Param.T p Float - detunes = - normalizeLevel 1 $ take (2*n) $ - randomRs (0,0.03) $ mkStdGen 912 - phases = - randomRs (0,1) $ mkStdGen 54 - tones = - zipWith - (\phase detune -> - (SigP.osciSaw $# phase) (fmap (detune*) freq)) - phases detunes - (tonesLeft,tonesRight) = splitAt n tones - in SigP.amplifyStereo volume $ - liftA2 Stereo.cons - (foldl1 SigP.mix tonesLeft) - (foldl1 SigP.mix tonesRight) - -stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float) -stereoOsciSawVector = - SigP.renderChunky tonesChunkSize stereoOsciSawP - -stereoOsciSawChord :: [Float] -> SVL.Vector (Stereo.T Float) -stereoOsciSawChord = - foldl1 mixVectorStereo . map stereoOsciSawVector - -stereoOsciSawPad :: Int -> [Float] -> SVL.Vector (Stereo.T Float) -stereoOsciSawPad dur pitches = - let attack = 20000 - in CausalP.applyStorableChunky - (CausalP.envelopeStereo $< fadeEnvelope) - (attack, dur-attack) - (stereoOsciSawChord pitches) - -a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1, - a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2, - a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3, - a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float -a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 : - a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 : - a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 : - a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ = - iterate ((2 ** recip 12) *) (55/44100) - - -chordSequence :: [(Int, [Float])] -chordSequence = - (2, [f1, f2, a2, c3]) : - (1, [g1, g2, b2, d3]) : - (2, [c2, g2, c3, e3]) : - (1, [f1, a2, c3, f3]) : - (2, [g1, g2, b2, d3]) : - (1, [gs1, gs2, b2, e3]) : - (2, [a1, e2, a2, c3]) : - (1, [g1, g2, b2, d3]) : - (3, [c2, g2, c3, e3]) : - - (2, [f1, f2, a2, c3]) : - (1, [g1, g2, b2, d3]) : - (2, [c2, g2, c3, e3]) : - (1, [f1, a2, c3, f3]) : - (2, [g1, g2, b2, d3]) : - (1, [gs1, gs2, b2, e3]) : - (2, [a1, e2, a2, c3]) : - (1, [g1, g2, b2, e3]) : - (3, [c2, e2, g2, c3]) : - [] - - -withDur :: (Int -> a -> v) -> Int -> a -> (v, NonNeg.Int) -withDur f d ps = - let dur = d*30000 - in (f dur ps, NonNeg.fromNumber dur) - - -padMusic :: IO () -padMusic = do - playStereoVector $ - CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.1 $ - SigStL.arrange tonesChunkSize $ - EventListTM.switchTimeR const $ - EventListMT.consTime 0 $ - EventListBT.fromPairList $ - map (\(d,ps) -> withDur stereoOsciSawPad d ps) - chordSequence - return () - - -lowpassSweepControlRateCausal :: - CausalP.T p - (Stereo.T (Value Float)) - (Stereo.T (Value Float)) -lowpassSweepControlRateCausal = --- CausalP.stereoFromVector $ - CausalP.stereoFromMono $ - UniFilter.lowpass ^<< - CtrlP.processCtrlRate 128 - (lfoSine (UniFilter.parameter (valueOf (10::Float)))) - - -moogSweepControlRateCausal :: - CausalP.T p - (Stereo.T (Value Float)) - (Stereo.T (Value Float)) -moogSweepControlRateCausal = --- CausalP.stereoFromVector $ - CausalP.stereoFromMono $ - CtrlP.processCtrlRate 128 - (lfoSine (Moog.parameter TypeNum.d8 (valueOf (10::Float)))) - - -filterMusic :: IO () -filterMusic = do - playStereoVector $ - CausalP.applyStorableChunky - (CausalP.amplifyStereo id <<< - moogSweepControlRateCausal) 0.05 $ - SigStL.arrange tonesChunkSize $ - EventListTM.switchTimeR const $ - EventListMT.consTime 0 $ - EventListBT.fromPairList $ - map (\(d,ps) -> withDur stereoOsciSawPad d ps) - chordSequence - return () - - - -stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float)) -stereoOsciSawVectorIO = - fmap ($tonesChunkSize) $ - SigP.runChunky $ - stereoOsciSawP - -applyFadeEnvelopeIO :: - IO (Int -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float)) -applyFadeEnvelopeIO = - fmap - (\envelope dur sig -> - let attack = 20000 - in envelope (attack, dur-attack) sig) - (CausalP.runStorableChunky - (CausalP.envelopeStereo $< fadeEnvelope)) - -stereoOsciSawChordIO :: IO ([Float] -> SVL.Vector (Stereo.T Float)) -stereoOsciSawChordIO = do - sawv <- stereoOsciSawVectorIO - mix <- mixVectorStereoIO - return (foldl1 mix . map sawv) - -stereoOsciSawPadIO :: IO (Int -> [Float] -> SVL.Vector (Stereo.T Float)) -stereoOsciSawPadIO = do - chrd <- stereoOsciSawChordIO - envelope <- applyFadeEnvelopeIO - return $ - \ dur pitches -> envelope dur (chrd pitches) - -padMusicIO :: IO () -padMusicIO = do - pad <- stereoOsciSawPadIO - playStereoVector $ - CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $ - SigStL.arrange tonesChunkSize $ - EventListTM.switchTimeR const $ - EventListMT.consTime 0 $ - EventListBT.fromPairList $ - map (uncurry (withDur pad)) $ - chordSequence - return () - -{- -Apply the envelope separately to each tone of the chord -and mix all tones by 'arrange'. --} -padMusicSeparate :: IO () -padMusicSeparate = do - osci <- stereoOsciSawVectorIO - env <- applyFadeEnvelopeIO - playStereoVector $ - CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $ - SigStL.arrange tonesChunkSize $ - EventList.flatten $ - EventListTM.switchTimeR const $ - EventListMT.consTime 0 $ - EventListBT.fromPairList $ - map (uncurry (withDur (\d ps -> map (\p -> env d (osci p)) ps))) $ - chordSequence - return () - - -delay :: IO () -delay = - SVL.writeFile "speedtest.f32" $ - asMono $ - flip (SigP.renderChunky tonesChunkSize) (0, 10000) $ - CausalP.apply - ((CausalP.delay $# (0::Float)) fst - <<< CausalP.take snd) $ - SigP.osciSaw 0 0.01 - -delayStereo :: IO () -delayStereo = - SVL.writeFile "speedtest.f32" $ - asStereo $ - flip (SigP.renderChunky tonesChunkSize) (7, 10000) $ - CausalP.apply - (CausalP.take snd - <<< - liftA2 Stereo.cons - id ((CausalP.delay $# (0::Float)) fst)) $ - SigP.osciSaw 0 0.01 - - - -allpassControl :: - (TypeNum.Nat n) => - n -> - SigP.T Float (Allpass.CascadeParameter n (Value Float)) -allpassControl order = - let reduct = id - in SigP.interpolateConstant reduct $ - lfoSine (Allpass.flangerParameter order) reduct - -allpassPhaserCausal, allpassPhaserPipeline :: - SigP.T Float (Value Float) -> - SigP.T Float (Value Float) -allpassPhaserCausal = - let order = TypeNum.d16 - in CausalP.apply $ - CausalP.amplify 0.5 <<< - Allpass.phaserP <<< - CausalP.feedFst (allpassControl order) - -allpassPhaserPipeline = - let order = TypeNum.d16 - in -- (F.nest (TypeNum.toInt order) SigP.tail .) $ - (SigP.drop (return $ TypeNum.toInt order) .) $ - CausalP.apply $ - CausalP.amplify 0.5 <<< - Allpass.phaserPipelineP <<< - CausalP.feedFst (allpassControl order) - -allpassPhaser :: IO () -allpassPhaser = - SVL.writeFile "speedtest.f32" $ - asMono $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) 128 $ - allpassPhaserPipeline $ - (SigP.osciSaw 0 0.01) - -noise :: IO () -noise = - SVL.writeFile "speedtest.f32" $ - asMono $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (SigP.noise 0 0.3) - -noisePacked :: IO () -noisePacked = - SVL.writeFile "speedtest.f32" $ - asMonoPacked $ - SVL.take (div 10000000 4) $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (SigPS.noise 0 0.3) --- (SigPS.pack (SigP.noise 0 0.3)) --- (SigPS.packSmall (SigP.noise 0 0.3)) - -frequencyModulationStorable :: IO () -frequencyModulationStorable = do - smp <- SigP.runChunky (SigP.osciSaw 0 0.01) - SVL.writeFile "speedtest.f32" $ - asMono $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (CausalP.frequencyModulationLinear - (SigP.fromStorableVectorLazy $# - (SVL.take 1000000 $ asMono $ - smp (SVL.chunkSize 1000) ())) - $*# (0.3::Float)) - -frequencyModulation :: IO () -frequencyModulation = - SVL.writeFile "speedtest.f32" $ - asMono $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (CausalP.frequencyModulationLinear - (SigP.osciSaw 0 0.01) - $* SigP.exponential2 500000 1) - -frequencyModulationStereo :: IO () -frequencyModulationStereo = do - smp <- SigP.runChunky (SigP.osciSaw 0 0.01) - SVL.writeFile "speedtest.f32" $ - asStereo $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (CausalP.stereoFromMono - (CausalP.frequencyModulationLinear - (SigP.fromStorableVectorLazy $# - (SVL.take 1000000 $ asMono $ - smp (SVL.chunkSize 1000) ()))) - $*# Stereo.cons (0.2999::Float) 0.3001) - - -quantize :: IO () -quantize = -{- - SV.writeFile "speedtest.f32" $ - asMono $ - (\xs -> SigP.render xs 10000000 ()) $ --} - SVL.writeFile "speedtest.f32" $ - asMono $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - ((CausalP.quantizeLift $# (5.5::Float)) id $* - SigP.osciSaw 0 0.01) - -quantizedFilterControl :: IO () -quantizedFilterControl = - SVL.writeFile "speedtest.f32" $ - asMono $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - CausalP.apply (CausalP.amplify 0.3 <<< UniFilter.lowpass ^<< CtrlP.process) $ - SigP.zip - ((CausalP.quantizeLift $# (128::Float)) - (CausalP.mapSimple (UniFilter.parameter (valueOf 100)) <<< --- (CausalP.mapSimple (Moog.parameter TypeNum.d8 (valueOf 100)) <<< - CausalP.mapSimple (\x -> 0.01 * exp (2 * return x))) - $* (SigP.osciSimple Wave.approxSine2 $# (0::Float)) (0.1/44100)) $ - (SigP.osciSaw $# (0::Float)) 0.01 - - -arrowNonShared :: IO () -arrowNonShared = - SVL.writeFile "speedtest.f32" $ - asStereo $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (let osci = CausalP.osciSimple Wave.approxSine2 - in liftA2 Stereo.cons osci osci $* - SigP.constant (return (0::Float, 0.01::Float))) - -arrowShared :: IO () -arrowShared = - SVL.writeFile "speedtest.f32" $ - asStereo $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (let osci = Func.lift (CausalP.osciSimple Wave.approxSine2) - in Func.compile (liftA2 Stereo.cons osci osci) $* - SigP.constant (return (0::Float, 0.01::Float))) - -arrowIndependent :: IO () -arrowIndependent = - SVL.writeFile "speedtest.f32" $ - asStereo $ - SVL.take 10000000 $ - flip (SigP.renderChunky (SVL.chunkSize 100000)) () $ - (let osci = CausalP.osciSimple Wave.approxSine2 - in Func.compile - (fmap (uncurry Stereo.cons) $ - osci *** osci Func.$& - Func.lift id) $* - SigP.constant (return ((0::Float, 0.01::Float), (0.25::Float, 0.01001::Float)))) - - -main :: IO () -main = do - LLVM.initializeNativeTarget - arrowIndependent diff --git a/src/Synthesizer/LLVM/Wave.hs b/src/Synthesizer/LLVM/Wave.hs --- a/src/Synthesizer/LLVM/Wave.hs +++ b/src/Synthesizer/LLVM/Wave.hs @@ -1,88 +1,78 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Wave where import qualified Synthesizer.LLVM.Simple.Value as Value -import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Monad as M -import qualified LLVM.Core as LLVM -import LLVM.Core - (Value, CodeGenFunction, - IsFloating, IsArithmetic, IsConst, ) +import LLVM.Core (CodeGenFunction, ) import Control.Monad.HT ((<=<), ) -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring - import NumericPrelude.Numeric import NumericPrelude.Base hiding (replicate, ) saw :: - (Ring.C a, IsConst a, SoV.Replicate a v, IsArithmetic v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.IntegerConstant a) => + a -> CodeGenFunction r a saw = - A.sub (SoV.replicateOf 1) <=< - A.mul (SoV.replicateOf 2) + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) square :: - (Ring.C a, IsConst a, - SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.IntegerConstant a, A.Fraction a) => + a -> CodeGenFunction r a square = - A.sub (SoV.replicateOf 1) <=< - A.mul (SoV.replicateOf 2) <=< - SoV.truncate <=< - A.mul (SoV.replicateOf 2) + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) <=< + A.truncate <=< + A.mul (A.fromInteger' 2) triangle :: - (Field.C a, IsConst a, - SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> CodeGenFunction r a triangle = - flip A.sub (SoV.replicateOf 1) <=< - SoV.abs <=< - flip A.sub (SoV.replicateOf 2) <=< - A.mul (SoV.replicateOf 4) <=< - SoV.incPhase (SoV.replicateOf 0.75) + flip A.sub (A.fromInteger' 1) <=< + A.abs <=< + flip A.sub (A.fromInteger' 2) <=< + A.mul (A.fromInteger' 4) <=< + A.incPhase (A.fromRational' 0.75) approxSine2 :: - (Ring.C a, IsConst a, SoV.Replicate a v, SoV.Real v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.IntegerConstant a, A.Fraction a) => + a -> CodeGenFunction r a approxSine2 t = do x <- saw t - A.mul (SoV.replicateOf 4) =<< + A.mul (A.fromInteger' 4) =<< A.mul x =<< - A.sub (SoV.replicateOf 1) =<< - SoV.abs x + A.sub (A.fromInteger' 1) =<< + A.abs x approxSine3 :: - (Field.C a, IsConst a, - SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> CodeGenFunction r a approxSine3 t = do x <- triangle t - A.mul (SoV.replicateOf 0.5) =<< + A.mul (A.fromRational' 0.5) =<< A.mul x =<< - A.sub (SoV.replicateOf 3) =<< + A.sub (A.fromInteger' 3) =<< A.mul x x approxSine4 :: - (Field.C a, IsConst a, SoV.Replicate a v, SoV.Real v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.RationalConstant a, A.Real a) => + a -> CodeGenFunction r a approxSine4 t = do x <- saw t - ax <- SoV.abs x - sax <- A.sub (SoV.replicateOf 1) ax - A.mul (SoV.replicateOf (16/5)) =<< + ax <- A.abs x + sax <- A.sub (A.fromInteger' 1) ax + A.mul (A.fromRational' (16/5)) =<< A.mul x =<< A.mul sax =<< - A.add (SoV.replicateOf 1) =<< + A.add (A.fromInteger' 1) =<< A.mul sax ax {- | @@ -91,18 +81,18 @@ We have chosen this scaling in order to stay with field operations. -} rationalApproxCosine1, rationalApproxSine1 :: - (Field.C a, IsConst a, SoV.Replicate a v, SoV.Real v, IsFloating v) => - Value v -> Value v -> CodeGenFunction r (Value v) + (A.Field a, A.RationalConstant a, A.Real a) => + a -> a -> CodeGenFunction r a rationalApproxCosine1 k t = do num2 <- A.square =<< A.mul k =<< - A.add (SoV.replicateOf (-1)) =<< - A.mul (SoV.replicateOf 2) t + A.add (A.fromInteger' (-1)) =<< + A.mul (A.fromInteger' 2) t den2 <- A.square =<< A.mul t =<< - A.sub (SoV.replicateOf 1) t + A.sub (A.fromInteger' 1) t M.liftR2 A.fdiv (A.sub num2 den2) (A.add num2 den2) @@ -110,31 +100,29 @@ rationalApproxSine1 k t = do num <- A.mul k =<< - A.add (SoV.replicateOf (-1)) =<< - A.mul (SoV.replicateOf 2) t + A.add (A.fromInteger' (-1)) =<< + A.mul (A.fromInteger' 2) t den <- A.mul t =<< - A.sub (SoV.replicateOf 1) t + A.sub (A.fromInteger' 1) t M.liftR2 A.fdiv - (A.mul (SoV.replicateOf (-2)) =<< A.mul num den) + (A.mul (A.fromInteger' (-2)) =<< A.mul num den) (M.liftR2 A.add (A.square num) (A.square den)) trapezoidSkew :: - (Field.C a, IsConst a, - SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => - Value v -> Value v -> CodeGenFunction r (Value v) + (A.Field a, A.RationalConstant a, A.Real a) => + a -> a -> CodeGenFunction r a trapezoidSkew p = - SoV.max (SoV.replicateOf (-1)) <=< - SoV.min (SoV.replicateOf 1) <=< + A.max (A.fromInteger' (-1)) <=< + A.min (A.fromInteger' 1) <=< flip A.fdiv p <=< - A.sub (SoV.replicateOf 1) <=< - A.mul (SoV.replicateOf 2) + A.sub (A.fromInteger' 1) <=< + A.mul (A.fromInteger' 2) sine :: - (Trans.C a, IsFloating a, IsConst a) => --- Value a -> TValue r a - Value a -> CodeGenFunction r (Value a) + (A.Transcendental a, A.RationalConstant a) => + a -> CodeGenFunction r a sine t = A.sin =<< A.mul t =<< Value.decons Value.twoPi @@ -150,14 +138,13 @@ shrinks a triangle wave such that 2.5 periods fit into one. -} replicate :: - (Field.C a, IsConst a, - SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => - Value v -> Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> a -> CodeGenFunction r a replicate k = - SoV.fraction <=< + A.fraction <=< A.mul k <=< - flip A.sub (SoV.replicateOf 0.5) <=< - SoV.incPhase (SoV.replicateOf 0.5) + flip A.sub (A.fromRational' 0.5) <=< + A.incPhase (A.fromRational' 0.5) {- | Preprocess the phase such that the first half of a wave @@ -171,23 +158,18 @@ generated using 'replicate'. -} halfEnvelope :: - (Field.C a, IsConst a, - SoV.Replicate a v, SoV.Fraction v, SoV.Real v) => - Value v -> CodeGenFunction r (Value v) + (A.PseudoRing a, A.RationalConstant a, A.Fraction a) => + a -> CodeGenFunction r a halfEnvelope = - A.mul (SoV.replicateOf 0.5) <=< - SoV.incPhase (SoV.replicateOf 0.5) + A.mul (A.fromRational' 0.5) <=< + A.incPhase (A.fromRational' 0.5) partial :: - (LLVM.IsPrimitive i, LLVM.IsPrimitive a, - LLVM.IsInteger i, IsFloating a, - SoV.Replicate a v, SoV.Fraction v) => - (Value v -> CodeGenFunction r (Value v)) -> - Value i -> - (Value v -> CodeGenFunction r (Value v)) + (A.Fraction v, A.PseudoRing v, A.IntegerConstant v) => + (v -> CodeGenFunction r v) -> + Int -> + (v -> CodeGenFunction r v) partial w n t = w =<< - SoV.signedFraction =<< - A.mul t =<< - SoV.replicate =<< - LLVM.inttofp n + A.signedFraction =<< + A.mul t (A.fromInteger' (fromIntegral n)) diff --git a/src/Test/Main.hs b/src/Test/Main.hs deleted file mode 100644 --- a/src/Test/Main.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import qualified Test.Synthesizer.LLVM.Filter as Filter -import qualified Test.Synthesizer.LLVM.Packed as Packed - -import qualified LLVM.Core as LLVM - -import Data.Tuple.HT (mapFst, ) - - -prefix :: String -> [(String, IO ())] -> [(String, IO ())] -prefix msg = - map (mapFst (\str -> msg ++ "." ++ str)) - -main :: IO () -main = do - LLVM.initializeNativeTarget - mapM_ (\(name,test) -> putStr (name ++ ": ") >> test) $ - concat $ - prefix "Filter" Filter.tests : - prefix "Packed" Packed.tests : - [] diff --git a/src/Test/Synthesizer/LLVM/Filter.hs b/src/Test/Synthesizer/LLVM/Filter.hs deleted file mode 100644 --- a/src/Test/Synthesizer/LLVM/Filter.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Rank2Types #-} -module Test.Synthesizer.LLVM.Filter (tests) where - -import qualified Synthesizer.LLVM.Filter.Allpass as Allpass -import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder -import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder -import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP -import qualified Synthesizer.LLVM.Filter.Universal as UniFilter -import qualified Synthesizer.LLVM.Filter.Moog as Moog -import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter -import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP - -import qualified Synthesizer.Plain.Filter.Recursive.Allpass as AllpassCore -import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore -import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilterCore -import qualified Synthesizer.Plain.Filter.Recursive.Moog as MoogCore -import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore - -import qualified Synthesizer.LLVM.Parameter as Param -import qualified LLVM.Extra.Memory as Memory -import qualified Synthesizer.LLVM.Wave as Wave -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ) -import Synthesizer.LLVM.Parameterized.Signal (($#), ) - -import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) --- import qualified Synthesizer.Storable.Signal as SigSt -import qualified Synthesizer.Interpolation.Module as Ip -import qualified Synthesizer.Causal.Interpolation as InterpC -import qualified Synthesizer.Causal.Filter.NonRecursive as FiltC -import qualified Synthesizer.Causal.Displacement as DispC -import qualified Synthesizer.Causal.Process as CausalS -import qualified Synthesizer.Basic.Wave as WaveCore -import qualified Synthesizer.State.Displacement as DispS -import qualified Synthesizer.State.Oscillator as OsciS -import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.Basic.Phase as Phase - -import qualified Data.StorableVector.Lazy as SVL -import Data.StorableVector.Lazy (ChunkSize, ) - -import Test.Synthesizer.LLVM.Utility - (checkSimilarity, checkSimilarityState, rangeFromInt, ) - -import qualified Control.Category as Cat -import Control.Category ((<<<), ) -import Control.Arrow ((&&&), (^<<), (<<^), ) - -import LLVM.Core (Value, Vector, ) -import qualified LLVM.Core as LLVM -import qualified Data.TypeLevel.Num as TypeNum -import Data.TypeLevel.Num (D4, ) - -import qualified Number.Complex as Complex -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo - -import Test.QuickCheck (quickCheck, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -signalLength :: Int -signalLength = 10000 - - -limitFloat :: SVL.Vector Float -> SVL.Vector Float -limitFloat = SVL.take signalLength - -{- -limitStereoFloat :: SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float) -limitStereoFloat = SVL.take signalLength --} - - -lfoSine :: - (Memory.C a ap, LLVM.IsSized ap asize) => - (forall r. Value Float -> LLVM.CodeGenFunction r a) -> - Param.T p Float -> - SigP.T p a -lfoSine f reduct = - SigP.interpolateConstant reduct $ - SigP.mapSimple f $ - CausalP.apply (CausalP.mapExponential 2 0.01) $ - SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct) - -allpassControl :: - (TypeNum.Nat n) => - n -> - Param.T p Float -> - SigP.T p (Allpass.CascadeParameter n (Value Float)) -allpassControl order = - lfoSine (Allpass.flangerParameter order) - -allpassPhaserCausal, allpassPhaserPipeline :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Value Float) -allpassPhaserCausal reduct = - CausalP.apply - (Allpass.phaserP - $< allpassControl TypeNum.d16 reduct) - -allpassPhaserPipeline reduct xs = - let order = TypeNum.d16 - in (SigP.drop $# TypeNum.toInt order) $ - (Allpass.phaserPipelineP - $< allpassControl order reduct - $* xs) - -allpassPipeline :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -allpassPipeline = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - in checkSimilarity 1e-2 limitFloat - (allpassPhaserCausal reduct tone) - (allpassPhaserPipeline reduct tone) - - - -{- | -Shrink control signal in time -since we can only handle one control parameter per vector chunk. --} -applyPacked :: - (Memory.C c cp, LLVM.IsSized cp cs) => - CausalP.T p - (c, Value (Vector D4 Float)) - (Value (Vector D4 Float)) -> - SigP.T p c -> - SigP.T p (Value (Vector D4 Float)) -> - SigP.T p (Value (Vector D4 Float)) -applyPacked proc cs xs = - proc - $< ((SigP.interpolateConstant $# - (recip $ TypeNum.toNum TypeNum.d4 :: Float)) cs) - $* xs - - -allpassPhaserPacked :: - Param.T p Float -> - SigP.T p (Value (Vector D4 Float)) -> - SigP.T p (Value (Vector D4 Float)) -allpassPhaserPacked reduct = - applyPacked Allpass.phaserPackedP - (allpassControl TypeNum.d16 reduct) - -allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -allpassPacked = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneP = SigPS.osciSimple Wave.triangle phase freq - in checkSimilarity 1e-2 limitFloat - (allpassPhaserCausal reduct tone) - (SigPS.unpack $ allpassPhaserPacked reduct toneP) - - -interpolateConstant :: Float -> SigS.T a -> SigS.T a -interpolateConstant reduct xs = - CausalS.apply (InterpC.relative Ip.constant 0 xs) $ - SigS.repeat $ recip reduct - - -{-# INLINE lfoSineCore #-} -lfoSineCore :: - (Float -> a) -> - Float -> - SigS.T a -lfoSineCore f reduct = - interpolateConstant reduct $ - SigS.map f $ - DispS.mapExponential 2 0.01 $ - OsciS.static WaveCore.sine zero (reduct * 0.1/44100) - -{-# INLINE allpassPhaserCore #-} -allpassPhaserCore :: - Float -> - SigS.T Float -> - SigS.T Float -allpassPhaserCore reduct = - let order = 16 - in CausalS.apply $ - FiltC.amplify 0.5 <<< - DispC.mix <<< - ((CausalS.applyFst (AllpassCore.cascadeCausal order) $ - lfoSineCore (AllpassCore.flangerParameter order) reduct) - &&& - Cat.id) - -allpassCore :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -allpassCore = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneS p = - OsciS.static WaveCore.triangle - (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) - in checkSimilarityState 1e-2 limitFloat - (allpassPhaserCausal reduct tone) - (\p -> allpassPhaserCore (Param.get reduct p) (toneS p)) - - - -diracImpulse :: SigP.T p (Value Float) -diracImpulse = - (CausalP.delay1 $# (one::Float)) $* - (SigP.constant $# (zero::Float)) - -firstOrderConstant :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Value Float) -firstOrderConstant cutOff xs = - FirstOrder.lowpassCausalP - $< SigP.constant (FirstOrderCore.parameter ^<< cutOff) - $* xs - -firstOrderExponential :: IO (ChunkSize -> (Int,Int) -> Bool) -firstOrderExponential = - let cutOff = rangeFromInt (0.001, 0.01) <<^ fst - gain = exp(-2*pi*cutOff) - in checkSimilarity 1e-2 limitFloat - (SigP.amplify (recip (1 - gain)) $ - firstOrderConstant cutOff diracImpulse) - (SigP.exponentialCore gain $# (one :: Float)) - -firstOrderCausal :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Value Float) -firstOrderCausal reduct xs = - FirstOrder.lowpassCausalP - $< lfoSine FirstOrder.parameter reduct - $* xs - -{-# INLINE firstOrderCore #-} -firstOrderCore :: - Float -> - SigS.T Float -> - SigS.T Float -firstOrderCore reduct = - CausalS.apply $ - CausalS.applyFst FirstOrderCore.lowpassCausal $ - lfoSineCore FirstOrderCore.parameter reduct - -firstOrder :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -firstOrder = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneS p = - OsciS.static WaveCore.triangle - (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) - in checkSimilarityState 1e-2 limitFloat - (firstOrderCausal reduct tone) - (\p -> firstOrderCore (Param.get reduct p) (toneS p)) - -firstOrderCausalPacked :: - Param.T p Float -> - SigP.T p (Value (Vector D4 Float)) -> - SigP.T p (Value (Vector D4 Float)) -firstOrderCausalPacked reduct = - applyPacked - (FirstOrder.lowpassCausalPackedP) - (lfoSine FirstOrder.parameter reduct) - -firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -firstOrderPacked = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneP = SigPS.osciSimple Wave.triangle phase freq - in checkSimilarity 1e-2 limitFloat - (firstOrderCausal reduct tone) - (SigPS.unpack $ firstOrderCausalPacked reduct toneP) - - -secondOrderCausal :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Value Float) -secondOrderCausal reduct xs = - SecondOrder.causalP - $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct - $* xs - -secondOrderCausalPacked :: - Param.T p Float -> - SigP.T p (Value (Vector D4 Float)) -> - SigP.T p (Value (Vector D4 Float)) -secondOrderCausalPacked reduct = - applyPacked SecondOrder.causalPackedP - (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct) - -secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -secondOrderPacked = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneP = SigPS.osciSimple Wave.triangle phase freq - in checkSimilarity 1e-2 limitFloat - (secondOrderCausal reduct tone) - (SigPS.unpack $ secondOrderCausalPacked reduct toneP) - -secondOrderCausalPacked2 :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Value Float) -secondOrderCausalPacked2 reduct xs = - SecondOrderP.causalP - $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct - $* xs - -secondOrderPacked2 :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -secondOrderPacked2 = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - in checkSimilarity 1e-2 limitFloat - (secondOrderCausal reduct tone) - (secondOrderCausalPacked2 reduct tone) - - -{- -limitUniFilter :: - SVL.Vector (UniFilterCore.Result Float) -> - SVL.Vector (UniFilterCore.Result Float) -limitUniFilter = SVL.take signalLength --} - -universalCausal :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (UniFilter.Result (Value Float)) -universalCausal reduct xs = - UniFilter.causalP - $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct - $* xs - -{-# INLINE universalCore #-} -universalCore :: - Float -> - SigS.T Float -> - SigS.T (UniFilterCore.Result Float) -universalCore reduct = - CausalS.apply $ - CausalS.applyFst UniFilterCore.causal $ - lfoSineCore (UniFilterCore.parameter . Pole 10) reduct - -universal :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -universal = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneS p = - OsciS.static WaveCore.triangle - (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) - in checkSimilarityState 1e-2 limitFloat - (fmap UniFilter.lowpass $ - universalCausal reduct tone) - (\p -> - SigS.map UniFilterCore.lowpass $ - universalCore (Param.get reduct p) (toneS p)) -{- - checkSimilarityState 1e-2 limitUniFilter - (universalCausal reduct tone) - (\p -> universalCore (Param.get reduct p) (toneS p)) --} - - -moogCausal :: - (TypeNum.Nat n) => - n -> - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Value Float) -moogCausal order reduct xs = - Moog.causalP - $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct - $* xs - -{-# INLINE moogCore #-} -moogCore :: - Int -> - Float -> - SigS.T Float -> - SigS.T Float -moogCore order reduct = - CausalS.apply $ - CausalS.applyFst (MoogCore.lowpassCausal order) $ - lfoSineCore (MoogCore.parameter order . Pole 10) reduct - -moog :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -moog = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - order = TypeNum.d6 - tone = SigP.osciSimple Wave.triangle phase freq - toneS p = - OsciS.static WaveCore.triangle - (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) - in checkSimilarityState 1e-2 limitFloat - (moogCausal order reduct tone) - (\p -> moogCore (TypeNum.toInt order) (Param.get reduct p) (toneS p)) - - -complexCausal :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Stereo.T (Value Float)) -complexCausal reduct = - CausalP.apply $ - (ComplexFilter.causalP - $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct) - <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero)) - -complexCausalPacked :: - Param.T p Float -> - SigP.T p (Value Float) -> - SigP.T p (Stereo.T (Value Float)) -complexCausalPacked reduct = - CausalP.apply $ - (ComplexFilterP.causalP - $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct) - <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero)) - -complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -complexPacked = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - in checkSimilarity 1e-2 limitFloat - (fmap Stereo.left $ - complexCausal reduct tone) - (fmap Stereo.left $ - complexCausalPacked reduct tone) - -{-# INLINE complexCore #-} -complexCore :: - Float -> - SigS.T Float -> - SigS.T (Stereo.T Float) -complexCore reduct = - CausalS.apply $ - (\x -> Stereo.cons (Complex.real x) (Complex.imag x)) ^<< - CausalS.applyFst ComplexFilterCore.causal - (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct) - -complex :: IO (ChunkSize -> ((Int,Int), Int) -> Bool) -complex = - let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst - phase = rangeFromInt (0, 0.99) <<^ snd . fst - reduct = rangeFromInt (10, 100) <<^ snd - tone = SigP.osciSimple Wave.triangle phase freq - toneS p = - OsciS.static WaveCore.triangle - (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) - in checkSimilarityState 1e-2 limitFloat - (fmap Stereo.left $ - complexCausal reduct tone) - (\p -> - SigS.map ((0.1*) . Stereo.left) $ - complexCore (Param.get reduct p) (toneS p)) -{- - in checkSimilarityState 1e-2 limitStereoFloat - (complexCausal reduct tone) - (\p -> complexCore (Param.get reduct p) (toneS p)) --} - - -tests :: [(String, IO ())] -tests = - ("secondOrderPacked", quickCheck =<< secondOrderPacked) : - ("secondOrderPacked2", quickCheck =<< secondOrderPacked2) : - ("firstOrderExponential", quickCheck =<< firstOrderExponential) : - ("firstOrder", quickCheck =<< firstOrder) : - ("firstOrderPacked", quickCheck =<< firstOrderPacked) : - ("universal", quickCheck =<< universal) : - ("allpassPacked", quickCheck =<< allpassPacked) : - ("allpassPipeline", quickCheck =<< allpassPipeline) : - ("allpassCore", quickCheck =<< allpassCore) : - ("moog", quickCheck =<< moog) : - ("complexPacked", quickCheck =<< complexPacked) : - ("complex", quickCheck =<< complex) : - [] diff --git a/src/Test/Synthesizer/LLVM/Packed.hs b/src/Test/Synthesizer/LLVM/Packed.hs deleted file mode 100644 --- a/src/Test/Synthesizer/LLVM/Packed.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.Synthesizer.LLVM.Packed (tests) where - -import Test.Synthesizer.LLVM.Utility - (checkSimilarity, checkEquality, rangeFromInt, ) - -import qualified Synthesizer.LLVM.Wave as Wave -import qualified Synthesizer.LLVM.Parameter as Param - -import LLVM.Core (Value, Vector, ) -import Data.TypeLevel.Num (D4, ) -import qualified Data.TypeLevel.Num as TypeNum - -import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP -import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP -import Synthesizer.LLVM.Parameterized.Signal (($#), ) -import Synthesizer.LLVM.CausalParameterized.Process (($*), ) - -import qualified Synthesizer.LLVM.Storable.Signal as SigStL -import qualified Data.StorableVector.Lazy as SVL -import Data.StorableVector.Lazy (ChunkSize, ) - -import Control.Arrow ((^<<), (<<^), (<<<), ) - -import Data.Word (Word32, ) - -import Test.QuickCheck (quickCheck, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -signalLength :: Int -signalLength = 10000 - - -limitFloat :: SVL.Vector Float -> SVL.Vector Float -limitFloat = SVL.take signalLength - -{- -limitPackedFloat :: - SVL.Vector (Vector D4 Float) -> SVL.Vector (Vector D4 Float) -limitPackedFloat = SVL.take (div signalLength 4) --} - -constant :: IO (ChunkSize -> Int -> Bool) -constant = - let y = rangeFromInt (-1, 1) - in checkSimilarity 1e-3 limitFloat - (SigP.constant y) - (SigPS.unpack (SigPS.constant y :: - SigP.T Int (Value (Vector D4 Float)))) - -ramp :: IO (ChunkSize -> Int -> Bool) -ramp = - let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) - in checkSimilarity 1e-3 limitFloat - (SigP.rampInf dur) - (SigPS.unpack (SigPS.rampInf dur :: - SigP.T Int (Value (Vector D4 Float)))) - -parabolaFadeIn :: IO (ChunkSize -> Int -> Bool) -parabolaFadeIn = - let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) - in checkSimilarity 1e-3 limitFloat - (SigP.parabolaFadeInInf dur) - (SigPS.unpack (SigPS.parabolaFadeInInf dur :: - SigP.T Int (Value (Vector D4 Float)))) - -parabolaFadeOut :: IO (ChunkSize -> Int -> Bool) -parabolaFadeOut = - let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) - in checkSimilarity 1e-3 limitFloat - (SigP.parabolaFadeOutInf dur) - (SigPS.unpack (SigPS.parabolaFadeOutInf dur :: - SigP.T Int (Value (Vector D4 Float)))) - -parabolaFadeInMap :: IO (ChunkSize -> Int -> Bool) -parabolaFadeInMap = - let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) - in checkSimilarity 1e-3 limitFloat - (SigP.parabolaFadeIn dur) - (SigP.parabolaFadeInMap dur) - -parabolaFadeOutMap :: IO (ChunkSize -> Int -> Bool) -parabolaFadeOutMap = - let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) - in checkSimilarity 1e-3 limitFloat - (SigP.parabolaFadeOut dur) - (SigP.parabolaFadeOutMap dur) - -exponential2 :: IO (ChunkSize -> (Int,Int) -> Bool) -exponential2 = - let halfLife = rangeFromInt (1000,10000) <<^ fst - start = rangeFromInt ( -1, 1) <<^ snd - in checkSimilarity 1e-3 limitFloat - (SigP.exponential2 halfLife start) - (SigPS.unpack (SigPS.exponential2 halfLife start :: - SigP.T (Int,Int) (Value (Vector D4 Float)))) - -exponential2Static :: IO (ChunkSize -> (Int,Int) -> Bool) -exponential2Static = - let halfLife = rangeFromInt (1000,10000) <<^ fst - start = rangeFromInt ( -1, 1) <<^ snd - in checkSimilarity 1e-3 limitFloat - (SigP.exponential2 halfLife start) - (Exp.causalP start <<< - CausalP.mapSimple Exp.parameter $* - SigP.constant halfLife) - -exponential2PackedStatic :: IO (ChunkSize -> (Int,Int) -> Bool) -exponential2PackedStatic = - let halfLife = rangeFromInt (1000,10000) <<^ fst - start = rangeFromInt ( -1, 1) <<^ snd - in checkSimilarity 1e-3 (limitFloat . SigStL.unpack) - (SigPS.exponential2 halfLife start :: - SigP.T (Int,Int) (Value (Vector D4 Float))) - (Exp.causalPackedP start <<< - CausalP.mapSimple Exp.parameterPacked $* - SigP.constant halfLife) - -exponential2Controlled :: IO (ChunkSize -> ((Int,Int), (Int,Int)) -> Bool) -exponential2Controlled = - let halfLife = rangeFromInt (1000,10000) <<^ (fst.fst) - start = rangeFromInt ( -1, 1) <<^ (snd.fst) - -- this is the LFO frequency measured at vector-rate - freq = rangeFromInt (0.0001, 0.001) <<^ (fst.snd) - phase = rangeFromInt (0, 0.99) <<^ (snd.snd) - lfo = - CausalP.mapExponential 2 halfLife $* - SigP.osciSimple Wave.approxSine2 phase freq - in checkSimilarity 1e-3 limitFloat - (Exp.causalP start <<< - CausalP.mapSimple Exp.parameter $* - SigP.interpolateConstant - (fromIntegral (TypeNum.toInt TypeNum.d4) :: Param.T p Float) - lfo) - (SigPS.unpack - (Exp.causalPackedP start <<< - CausalP.mapSimple Exp.parameterPacked $* - lfo :: - SigP.T ((Int,Int),(Int,Int)) (Value (Vector D4 Float)))) - -osci :: IO (ChunkSize -> (Int,Int) -> Bool) -osci = - let freq = rangeFromInt (0.001, 0.01) <<^ fst - phase = rangeFromInt (0, 0.99) <<^ snd - in checkSimilarity 1e-2 limitFloat - (SigP.osciSimple Wave.approxSine2 phase freq) - (SigPS.unpack (SigPS.osciSimple Wave.approxSine2 phase freq :: - SigP.T (Int,Int) (Value (Vector D4 Float)))) - - - -limitWord32 :: SVL.Vector Word32 -> SVL.Vector Word32 -limitWord32 = SVL.take signalLength - -limitPackedWord32 :: - SVL.Vector (Vector D4 Word32) -> SVL.Vector (Vector D4 Word32) -limitPackedWord32 = SVL.take (div signalLength 4) - - -noise :: IO (ChunkSize -> () -> Bool) -noise = - checkEquality limitWord32 - (SigP.noiseCore $# 0) - (SigP.noiseCoreAlt $# 0) - -noiseVector :: IO (ChunkSize -> () -> Bool) -noiseVector = - checkEquality limitPackedWord32 - (SigPS.noiseCore $# 0) - (SigPS.noiseCoreAlt $# 0) - -noiseScalarVector :: IO (ChunkSize -> () -> Bool) -noiseScalarVector = - checkEquality limitPackedWord32 - (SigPS.noiseCore $# 0) - (SigPS.packSmall (SigP.noiseCore $# 0)) - - -tests :: [(String, IO ())] -tests = - ("constant", quickCheck =<< constant) : - ("ramp", quickCheck =<< ramp) : - ("parabolaFadeIn", quickCheck =<< parabolaFadeIn) : - ("parabolaFadeOut", quickCheck =<< parabolaFadeOut) : - ("parabolaFadeInMap", quickCheck =<< parabolaFadeInMap) : - ("parabolaFadeOutMap", quickCheck =<< parabolaFadeOutMap) : - ("exponential2", quickCheck =<< exponential2) : - ("exponential2Static", quickCheck =<< exponential2Static) : - ("exponential2PackedStatic", quickCheck =<< exponential2PackedStatic) : - ("exponential2Controlled", quickCheck =<< exponential2Controlled) : - ("osci", quickCheck =<< osci) : - ("noise", quickCheck =<< noise) : - ("noiseVector", quickCheck =<< noiseVector) : - ("noiseScalarVector", quickCheck =<< noiseScalarVector) : - [] diff --git a/src/Test/Synthesizer/LLVM/Utility.hs b/src/Test/Synthesizer/LLVM/Utility.hs deleted file mode 100644 --- a/src/Test/Synthesizer/LLVM/Utility.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.Synthesizer.LLVM.Utility where - -import qualified Synthesizer.LLVM.Parameter as Param -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Class as Class - -import qualified Synthesizer.LLVM.Parameterized.Signal as SigP - -import qualified Synthesizer.State.Signal as SigS - -import Control.Arrow (arr, ) -import Control.Monad (liftM, liftM2, ) - -import qualified Data.StorableVector.Lazy as SVL -import Data.StorableVector.Lazy (ChunkSize, ) -import Foreign.Storable (Storable, ) - -import qualified Algebra.RealRing as RealRing - -import System.Random (Random, randomR, mkStdGen, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -rangeFromInt :: Random a => (a,a) -> Param.T Int a -rangeFromInt rng = - arr $ fst . randomR rng . mkStdGen - - -{-# INLINE checkSimilarityState #-} -checkSimilarityState :: - (RealRing.C a, Storable a, - Class.MakeValueTuple a av, - Memory.C av ap) => - a -> - (SVL.Vector a -> SVL.Vector a) -> - SigP.T p av -> - (p -> SigS.T a) -> - IO (ChunkSize -> p -> Bool) -checkSimilarityState tol limit gen0 sig1 = - let render sig = - fmap - (\func chunkSize -> - limit . func chunkSize) $ - SigP.runChunky sig - in liftM - (\sig0 chunkSize p -> - SigS.foldR (&&) True $ - -- dangerous, since shortened signals would be tolerated - SigS.zipWith (\x y -> abs(x-y) < tol) - (SigS.fromStorableSignal (sig0 chunkSize p)) - (sig1 p)) - (render gen0) - - -{-# INLINE checkSimilarity #-} -checkSimilarity :: - (RealRing.C b, Storable b, - Storable a, - Class.MakeValueTuple a av, Memory.C av ap) => - b -> - (SVL.Vector a -> SVL.Vector b) -> - SigP.T p av -> SigP.T p av -> - IO (ChunkSize -> p -> Bool) -checkSimilarity tol limit gen0 gen1 = - let render sig = - fmap - (\func chunkSize -> - limit . func chunkSize) $ - SigP.runChunky sig - in liftM2 - (\sig0 sig1 chunkSize p -> - SigS.foldR (&&) True $ - -- dangerous, since shortened signals would be tolerated - SigS.zipWith (\x y -> abs(x-y) < tol) - (SigS.fromStorableSignal (sig0 chunkSize p)) - (SigS.fromStorableSignal (sig1 chunkSize p))) - (render gen0) - (render gen1) - - -checkEquality :: - (Eq a, Storable a, - Class.MakeValueTuple a av, - Memory.C av ap) => - (SVL.Vector a -> SVL.Vector a) -> - SigP.T p av -> SigP.T p av -> - IO (ChunkSize -> p -> Bool) -checkEquality limit gen0 gen1 = - let render sig = - fmap - (\func chunkSize -> - limit . func chunkSize) $ - SigP.runChunky sig - in liftM2 - (\sig0 sig1 chunkSize p -> - sig0 chunkSize p == sig1 chunkSize p) - (render gen0) - (render gen1) 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.3 +Version: 0.5 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -12,14 +12,33 @@ Efficient signal processing using runtime compilation and vector instructions. It uses LLVM library, thus it is not bound to a specific CPU. - If you compile with Cabal flag @buildExamples@ - you get the executable @synthi-llvm-server@, - that is a realtime software synthesizer - that receives MIDI events via ALSA - and in response plays some tones via ALSA. + There are some example executables that you can build + with Cabal flag @buildExamples@: + . + * @synthi-llvm-render@: + Render a MIDI file into an audio file + using some arbitrary instruments. + . + * @synthi-llvm-alsa@: + A realtime software synthesizer + that receives MIDI events via ALSA + and in response plays tones via ALSA. + If you have no ALSA (or Linux at all), + then you can disable this example with @-f-alsa@. + . + * @synthi-llvm-jack@: + The same realtime software synthesizer using JACK. + If you have no JACK, + then you can disable this example with @-f-jack@. + . + * @synthi-llvm-example@: + Not very useful as an executable. + You should better load the according module into GHCi + and play around with it. Stability: Experimental -Tested-With: GHC==6.10.4, GHC==6.12.3, GHC==7.0.4, GHC==7.2.1 -Cabal-Version: >=1.6 +Tested-With: GHC==6.10.4, GHC==6.12.3 +Tested-With: GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.6.3 +Cabal-Version: >=1.14 Build-Type: Simple Flag buildExamples @@ -30,8 +49,16 @@ description: Build test suite default: False +Flag alsa + description: Build ALSA synthesizer if examples are built + default: True + +Flag jack + description: Build JACK synthesizer if examples are built + default: True + Source-Repository this - Tag: 0.3 + Tag: 0.5 Type: darcs Location: code.haskell.org:/srv/code/synthesizer/llvm/ @@ -42,46 +69,41 @@ Library Build-Depends: - llvm-extra >= 0.3 && <0.4, + llvm-extra >=0.4.1 && <0.5, -- llvm must be imported with restrictive version bounds, -- because we import implicitly and unqualified - llvm >=0.10 && <0.10.1, - type-level >=0.2.3 && <0.3, - functional-arrow >=0.0 && <0.1, - vault >=0.1 && <0.2, - HList >=0.2 && <0.3, - synthesizer-core >=0.5 && <0.6, - -- for ALSA.BendModulation - synthesizer-alsa >=0.4 && <0.5, - alsa-seq >=0.5 && <0.6, - alsa-pcm >=0.5 && <0.6, - midi-alsa >= 0.1.2 && <0.2, - midi >= 0.1.6 && <0.2, + llvm-tf >=3.0 && <3.0.1, + tfp >=0.7 && <0.8, + vault >=0.1 && <0.3, + synthesizer-core >=0.6 && <0.7, + 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, sample-frame-np >=0.0.1 && <0.1, sample-frame >=0.0.1 && <0.1, storablevector >=0.2.6 && <0.3, - numeric-prelude >=0.3 && <0.4, + unsafe >=0.0 && <0.1, + numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2, - -- data-accessor >=0.1 && <0.2, - filepath >=1.1 && <1.3, - random >= 1.0 && < 1.1, - containers >=0.1 && <0.5, - transformers >=0.2 && <0.3, - utility-ht >=0.0.1 && <0.1 + filepath >=1.1 && <1.4, + random >=1.0 && <1.1, + containers >=0.1 && <0.6, + transformers >=0.2 && <0.4, + utility-ht >=0.0.8 && <0.1 Build-Depends: -- base-4 needed for Control.Category - base >= 4 && <5 + base >=4 && <5 + Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000 CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP + Default-Extensions: CPP Hs-source-dirs: src Exposed-Modules: @@ -96,10 +118,12 @@ Synthesizer.LLVM.Storable.Process Synthesizer.LLVM.Causal.Process Synthesizer.LLVM.CausalParameterized.Process + Synthesizer.LLVM.CausalParameterized.ProcessValue Synthesizer.LLVM.CausalParameterized.ProcessPacked Synthesizer.LLVM.CausalParameterized.Controlled Synthesizer.LLVM.CausalParameterized.ControlledPacked Synthesizer.LLVM.CausalParameterized.Functional + Synthesizer.LLVM.CausalParameterized.FunctionalPlug Synthesizer.LLVM.Plug.Input Synthesizer.LLVM.Plug.Output Synthesizer.LLVM.Filter.Allpass @@ -116,24 +140,23 @@ Synthesizer.LLVM.Generator.Exponential2 Synthesizer.LLVM.RingBuffer Synthesizer.LLVM.ConstantPiece - Synthesizer.LLVM.SerialVector + Synthesizer.LLVM.Frame.SerialVector Synthesizer.LLVM.Frame Synthesizer.LLVM.Frame.Stereo Synthesizer.LLVM.Frame.StereoInterleaved Synthesizer.LLVM.Complex Synthesizer.LLVM.Wave - Synthesizer.LLVM.Server.Common - Synthesizer.LLVM.Server.Packed.Test - Synthesizer.LLVM.Server.Packed.Run + Synthesizer.LLVM.MIDI + Synthesizer.LLVM.MIDI.BendModulation Synthesizer.LLVM.Server.Packed.Instrument - Synthesizer.LLVM.Server.Scalar.Test - Synthesizer.LLVM.Server.Scalar.Run Synthesizer.LLVM.Server.Scalar.Instrument Synthesizer.LLVM.Server.CausalPacked.Instrument - Synthesizer.LLVM.Server.CausalPacked.Run - Synthesizer.LLVM.Server.CausalPacked.Test - Synthesizer.LLVM.ALSA.MIDI - Synthesizer.LLVM.ALSA.BendModulation + 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.Random @@ -145,28 +168,86 @@ Synthesizer.LLVM.Debug.Counter Synthesizer.LLVM.Debug.StablePtr Synthesizer.LLVM.Debug.Storable - Synthesizer.LLVM.Server.Option -- may be moved to llvm-extra Synthesizer.LLVM.Execution -- shall be removed when Foreign.Marshal.Alloc is fixed Synthesizer.LLVM.Alloc - Synthesizer.LLVM.LAC2011 - Synthesizer.LLVM.LNdW2011 Executable synthi-llvm-example - If !flag(buildExamples) + If flag(buildExamples) && flag(alsa) + Build-Depends: + synthesizer-llvm, + + llvm-extra >=0.4.1 && <0.5, + llvm-tf, + tfp >=0.7 && <0.8, + synthesizer-core >=0.6 && <0.7, + 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, + sample-frame-np >=0.0.1 && <0.1, + sample-frame >=0.0.1 && <0.1, + 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 >=1.0 && <1.1, + containers >=0.1 && <0.6, + transformers >=0.2 && <0.4, + utility-ht >=0.0.8 && <0.1, + + synthesizer-alsa >=0.5 && <0.6, + alsa-pcm >=0.6 && <0.7, + base >=4 && <5 + Else Buildable: False - GHC-Options: -Wall + Default-Language: Haskell98 + GHC-Options: -Wall + GHC-Prof-Options: -auto-all If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000 CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP - Hs-Source-Dirs: src + Default-Extensions: CPP + Hs-Source-Dirs: example Main-Is: Synthesizer/LLVM/Test.hs + Other-Modules: + Synthesizer.LLVM.LAC2011 + Synthesizer.LLVM.LNdW2011 -Executable synthi-llvm-server - If !flag(buildExamples) +Executable synthi-llvm-alsa + If flag(buildExamples) && flag(alsa) + Build-Depends: + synthesizer-llvm, + + llvm-extra >=0.4.1 && <0.5, + llvm-tf, + tfp >=0.7 && <0.8, + synthesizer-core >=0.6 && <0.7, + 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, + sample-frame-np >=0.0.1 && <0.1, + sample-frame >=0.0.1 && <0.1, + storablevector >=0.2.6 && <0.3, + numeric-prelude >=0.3 && <0.5, + non-negative >=0.1 && <0.2, + event-list >=0.1 && <0.2, + filepath >=1.1 && <1.4, + containers >=0.1 && <0.6, + transformers >=0.2 && <0.4, + utility-ht >=0.0.8 && <0.1, + + synthesizer-alsa >=0.5 && <0.6, + midi-alsa >=0.2.1 && <0.3, + alsa-seq >=0.6 && <0.7, + alsa-pcm >=0.6 && <0.7, + base >=4 && <5 + Else Buildable: False + Default-Language: Haskell98 -- -threaded -debug GHC-Options: -Wall GHC-Options: -rtsopts @@ -174,29 +255,129 @@ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000 CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP - Hs-Source-Dirs: src + Default-Extensions: CPP + Hs-Source-Dirs: alsa Main-Is: Synthesizer/LLVM/Server.hs Other-Modules: - Synthesizer.LLVM.Server.Packed.Instrument Synthesizer.LLVM.Server.Packed.Test Synthesizer.LLVM.Server.Packed.Run - Synthesizer.LLVM.Server.Scalar.Instrument Synthesizer.LLVM.Server.Scalar.Test Synthesizer.LLVM.Server.Scalar.Run - Synthesizer.LLVM.Server.Common + Synthesizer.LLVM.Server.CausalPacked.Run + Synthesizer.LLVM.Server.CausalPacked.Test + Synthesizer.LLVM.Server.ALSA + Synthesizer.LLVM.Server.Option +Executable synthi-llvm-jack + If flag(buildExamples) && flag(jack) + Build-Depends: + synthesizer-llvm, + + jack >=0.7 && <0.8, + + llvm-extra >=0.4.1 && <0.5, + llvm-tf, + tfp >=0.7 && <0.8, + synthesizer-core >=0.6 && <0.7, + 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, + sample-frame-np >=0.0.1 && <0.1, + sample-frame >=0.0.1 && <0.1, + storablevector >=0.2.6 && <0.3, + numeric-prelude >=0.3 && <0.5, + non-negative >=0.1 && <0.2, + explicit-exception >=0.1.7 && <0.2, + event-list >=0.1 && <0.2, + filepath >=1.1 && <1.4, + containers >=0.1 && <0.6, + transformers >=0.2 && <0.4, + utility-ht >=0.0.8 && <0.1, + + base >=4 && <5 + + Else + Buildable: False + Default-Language: Haskell98 + -- -threaded -debug + GHC-Options: -Wall + GHC-Options: -rtsopts + GHC-Prof-Options: -auto-all + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + Hs-Source-Dirs: jack + Main-Is: Synthesizer/LLVM/Server/JACK.hs + +Executable synthi-llvm-render + If flag(buildExamples) + Build-Depends: + synthesizer-llvm, + + llvm-extra >=0.4.1 && <0.5, + llvm-tf, + tfp >=0.7 && <0.8, + sox >=0.2.1 && <0.3, + synthesizer-core >=0.6 && <0.7, + 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, + sample-frame-np >=0.0.1 && <0.1, + sample-frame >=0.0.1 && <0.1, + storablevector >=0.2.6 && <0.3, + numeric-prelude >=0.3 && <0.5, + non-negative >=0.1 && <0.2, + explicit-exception >=0.1.7 && <0.2, + event-list >=0.1 && <0.2, + filepath >=1.1 && <1.4, + containers >=0.1 && <0.6, + transformers >=0.2 && <0.4, + utility-ht >=0.0.8 && <0.1, + + base >=4 && <5 + + Else + Buildable: False + Default-Language: Haskell98 + -- -threaded -debug + GHC-Options: -Wall + GHC-Options: -rtsopts + GHC-Prof-Options: -auto-all + If impl(ghc>=7.0) + GHC-Options: -fwarn-unused-do-bind + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Default-Extensions: CPP + Hs-Source-Dirs: render + Main-Is: Synthesizer/LLVM/Server/Render.hs + Executable synthi-llvm-test If flag(buildTests) - Build-Depends: QuickCheck >= 1 && <3 + Build-Depends: + synthesizer-llvm, + + llvm-extra >=0.4.1 && <0.5, + llvm-tf, + tfp >=0.7 && <0.8, + synthesizer-core >=0.6 && <0.7, + storablevector >=0.2.6 && <0.3, + numeric-prelude >=0.3 && <0.5, + random >=1.0 && <1.1, + utility-ht >=0.0.8 && <0.1, + + QuickCheck >=1 && <3, + base >=4 && <5 Else Buildable: False + Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind -fcontext-stack=1000 CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP - Hs-Source-Dirs: src + Default-Extensions: CPP + Hs-Source-Dirs: testsuite Main-Is: Test/Main.hs Other-Modules: Test.Synthesizer.LLVM.Filter diff --git a/testsuite/Test/Main.hs b/testsuite/Test/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import qualified Test.Synthesizer.LLVM.Filter as Filter +import qualified Test.Synthesizer.LLVM.Packed as Packed + +import qualified LLVM.Core as LLVM + +import Data.Tuple.HT (mapFst, ) + + +prefix :: String -> [(String, IO ())] -> [(String, IO ())] +prefix msg = + map (mapFst (\str -> msg ++ "." ++ str)) + +main :: IO () +main = do + LLVM.initializeNativeTarget + mapM_ (\(name,test) -> putStr (name ++ ": ") >> test) $ + concat $ + prefix "Filter" Filter.tests : + prefix "Packed" Packed.tests : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Filter.hs b/testsuite/Test/Synthesizer/LLVM/Filter.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Filter.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +module Test.Synthesizer.LLVM.Filter (tests) where + +import qualified Synthesizer.LLVM.Filter.Allpass as Allpass +import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder +import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder +import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP +import qualified Synthesizer.LLVM.Filter.Universal as UniFilter +import qualified Synthesizer.LLVM.Filter.Moog as Moog +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter +import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP + +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as AllpassCore +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilterCore +import qualified Synthesizer.Plain.Filter.Recursive.Moog as MoogCore +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore + +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Parameter as Param +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ) +import Synthesizer.LLVM.Parameterized.Signal (($#), ) + +import Synthesizer.Plain.Filter.Recursive (Pole(Pole)) +-- import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Interpolation.Module as Ip +import qualified Synthesizer.Causal.Interpolation as InterpC +import qualified Synthesizer.Causal.Filter.NonRecursive as FiltC +import qualified Synthesizer.Causal.Displacement as DispC +import qualified Synthesizer.Causal.Process as CausalS +import qualified Synthesizer.Basic.Wave as WaveCore +import qualified Synthesizer.State.Displacement as DispS +import qualified Synthesizer.State.Oscillator as OsciS +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize, ) + +import Test.Synthesizer.LLVM.Utility + (checkSimilarity, checkSimilarityState, rangeFromInt, + CheckSimilarity, CheckSimilarityState, ) + +import qualified Control.Category as Cat +import Control.Category ((<<<), ) +import Control.Arrow ((&&&), (^<<), (<<^), ) + +import qualified LLVM.Extra.Memory as Memory + +import LLVM.Core (Value, ) +import qualified LLVM.Core as LLVM +import qualified Types.Data.Num as TypeNum +import Types.Data.Num (D4, ) + +import qualified Number.Complex as Complex +import qualified Synthesizer.LLVM.Frame.Stereo as Stereo + +import Test.QuickCheck (quickCheck, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +type SimFloat = CheckSimilarity Float +type SimStateFloat = CheckSimilarityState Float +type VectorValue = Serial.Value D4 Float + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: SVL.Vector Float -> SVL.Vector Float +limitFloat = SVL.take signalLength + +{- +limitStereoFloat :: SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float) +limitStereoFloat = SVL.take signalLength +-} + + +lfoSine :: + (Memory.C a) => + (forall r. Value Float -> LLVM.CodeGenFunction r a) -> + Param.T p Float -> + SigP.T p a +lfoSine f reduct = + SigP.interpolateConstant reduct $ + SigP.mapSimple f $ + CausalP.apply (CausalP.mapExponential 2 0.01) $ + SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct) + +allpassControl :: + (TypeNum.NaturalT n) => + n -> + Param.T p Float -> + SigP.T p (Allpass.CascadeParameter n (Value Float)) +allpassControl order = + lfoSine (Allpass.flangerParameter order) + +allpassPhaserCausal, allpassPhaserPipeline :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +allpassPhaserCausal reduct = + CausalP.apply + (Allpass.phaserP + $< allpassControl TypeNum.d16 reduct) + +allpassPhaserPipeline reduct xs = + let order = TypeNum.d16 + in (SigP.drop $# TypeNum.fromIntegerT order) $ + (Allpass.phaserPipelineP + $< allpassControl order reduct + $* xs) + +allpassPipeline :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) +allpassPipeline = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (allpassPhaserCausal reduct tone) + (allpassPhaserPipeline reduct tone) + + + +{- | +Shrink control signal in time +since we can only handle one control parameter per vector chunk. +-} +applyPacked :: + (Memory.C c) => + CausalP.T p (c, VectorValue) VectorValue -> + SigP.T p c -> + SigP.T p VectorValue -> + SigP.T p VectorValue +applyPacked proc cs xs = + proc + $< ((SigP.interpolateConstant $# + (recip $ TypeNum.fromIntegerT TypeNum.d4 :: Float)) cs) + $* xs + + +allpassPhaserPacked :: + Param.T p Float -> + SigP.T p VectorValue -> + SigP.T p VectorValue +allpassPhaserPacked reduct = + applyPacked Allpass.phaserPackedP + (allpassControl TypeNum.d16 reduct) + +allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) +allpassPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneP = SigPS.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (allpassPhaserCausal reduct tone) + (SigPS.unpack $ allpassPhaserPacked reduct toneP) + + +interpolateConstant :: Float -> SigS.T a -> SigS.T a +interpolateConstant reduct xs = + CausalS.apply (InterpC.relative Ip.constant 0 xs) $ + SigS.repeat $ recip reduct + + +{-# INLINE lfoSineCore #-} +lfoSineCore :: + (Float -> a) -> + Float -> + SigS.T a +lfoSineCore f reduct = + interpolateConstant reduct $ + SigS.map f $ + DispS.mapExponential 2 0.01 $ + OsciS.static WaveCore.sine zero (reduct * 0.1/44100) + +{-# INLINE allpassPhaserCore #-} +allpassPhaserCore :: + Float -> + SigS.T Float -> + SigS.T Float +allpassPhaserCore reduct = + let order = 16 + in CausalS.apply $ + FiltC.amplify 0.5 <<< + DispC.mix <<< + ((CausalS.applyFst (AllpassCore.cascadeCausal order) $ + lfoSineCore (AllpassCore.flangerParameter order) reduct) + &&& + Cat.id) + +allpassCore :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat) +allpassCore = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (allpassPhaserCausal reduct tone) + (\p -> allpassPhaserCore (Param.get reduct p) (toneS p)) + + + +diracImpulse :: SigP.T p (Value Float) +diracImpulse = + (CausalP.delay1 $# (one::Float)) $* + (SigP.constant $# (zero::Float)) + +firstOrderConstant :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +firstOrderConstant cutOff xs = + FirstOrder.lowpassCausalP + $< SigP.constant (FirstOrderCore.parameter ^<< cutOff) + $* xs + +firstOrderExponential :: IO (ChunkSize -> (Int,Int) -> SimFloat) +firstOrderExponential = + let cutOff = rangeFromInt (0.001, 0.01) <<^ fst + gain = exp(-2*pi*cutOff) + in checkSimilarity 1e-2 limitFloat + (SigP.amplify (recip (1 - gain)) $ + firstOrderConstant cutOff diracImpulse) + (SigP.exponentialCore gain $# (one :: Float)) + +firstOrderCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +firstOrderCausal reduct xs = + FirstOrder.lowpassCausalP + $< lfoSine FirstOrder.parameter reduct + $* xs + +{-# INLINE firstOrderCore #-} +firstOrderCore :: + Float -> + SigS.T Float -> + SigS.T Float +firstOrderCore reduct = + CausalS.apply $ + CausalS.applyFst FirstOrderCore.lowpassCausal $ + lfoSineCore FirstOrderCore.parameter reduct + +firstOrder :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat) +firstOrder = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (firstOrderCausal reduct tone) + (\p -> firstOrderCore (Param.get reduct p) (toneS p)) + +firstOrderCausalPacked :: + Param.T p Float -> + SigP.T p VectorValue -> + SigP.T p VectorValue +firstOrderCausalPacked reduct = + applyPacked + (FirstOrder.lowpassCausalPackedP) + (lfoSine FirstOrder.parameter reduct) + +firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) +firstOrderPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneP = SigPS.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (firstOrderCausal reduct tone) + (SigPS.unpack $ firstOrderCausalPacked reduct toneP) + + +secondOrderCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +secondOrderCausal reduct xs = + SecondOrder.causalP + $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct + $* xs + +secondOrderCausalPacked :: + Param.T p Float -> + SigP.T p VectorValue -> + SigP.T p VectorValue +secondOrderCausalPacked reduct = + applyPacked SecondOrder.causalPackedP + (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct) + +secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) +secondOrderPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneP = SigPS.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (secondOrderCausal reduct tone) + (SigPS.unpack $ secondOrderCausalPacked reduct toneP) + +secondOrderCausalPacked2 :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +secondOrderCausalPacked2 reduct xs = + SecondOrderP.causalP + $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct + $* xs + +secondOrderPacked2 :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) +secondOrderPacked2 = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (secondOrderCausal reduct tone) + (secondOrderCausalPacked2 reduct tone) + + +{- +limitUniFilter :: + SVL.Vector (UniFilterCore.Result Float) -> + SVL.Vector (UniFilterCore.Result Float) +limitUniFilter = SVL.take signalLength +-} + +universalCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (UniFilter.Result (Value Float)) +universalCausal reduct xs = + UniFilter.causalP + $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct + $* xs + +{-# INLINE universalCore #-} +universalCore :: + Float -> + SigS.T Float -> + SigS.T (UniFilterCore.Result Float) +universalCore reduct = + CausalS.apply $ + CausalS.applyFst UniFilterCore.causal $ + lfoSineCore (UniFilterCore.parameter . Pole 10) reduct + +universal :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat) +universal = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (fmap UniFilter.lowpass $ + universalCausal reduct tone) + (\p -> + SigS.map UniFilterCore.lowpass $ + universalCore (Param.get reduct p) (toneS p)) +{- + checkSimilarityState 1e-2 limitUniFilter + (universalCausal reduct tone) + (\p -> universalCore (Param.get reduct p) (toneS p)) +-} + + +moogCausal :: + (TypeNum.NaturalT n) => + n -> + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Value Float) +moogCausal order reduct xs = + Moog.causalP + $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct + $* xs + +{-# INLINE moogCore #-} +moogCore :: + Int -> + Float -> + SigS.T Float -> + SigS.T Float +moogCore order reduct = + CausalS.apply $ + CausalS.applyFst (MoogCore.lowpassCausal order) $ + lfoSineCore (MoogCore.parameter order . Pole 10) reduct + +moog :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat) +moog = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + order = TypeNum.d6 + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (moogCausal order reduct tone) + (\p -> moogCore (TypeNum.fromIntegerT order) (Param.get reduct p) (toneS p)) + + +complexCausal :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Stereo.T (Value Float)) +complexCausal reduct = + CausalP.apply $ + (ComplexFilter.causalP + $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct) + <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero)) + +complexCausalPacked :: + Param.T p Float -> + SigP.T p (Value Float) -> + SigP.T p (Stereo.T (Value Float)) +complexCausalPacked reduct = + CausalP.apply $ + (ComplexFilterP.causalP + $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct) + <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero)) + +complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat) +complexPacked = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + in checkSimilarity 1e-2 limitFloat + (fmap Stereo.left $ + complexCausal reduct tone) + (fmap Stereo.left $ + complexCausalPacked reduct tone) + +{-# INLINE complexCore #-} +complexCore :: + Float -> + SigS.T Float -> + SigS.T (Stereo.T Float) +complexCore reduct = + CausalS.apply $ + (\x -> Stereo.cons (Complex.real x) (Complex.imag x)) ^<< + CausalS.applyFst ComplexFilterCore.causal + (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct) + +complex :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat) +complex = + let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst + phase = rangeFromInt (0, 0.99) <<^ snd . fst + reduct = rangeFromInt (10, 100) <<^ snd + tone = SigP.osciSimple Wave.triangle phase freq + toneS p = + OsciS.static WaveCore.triangle + (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) + in checkSimilarityState 1e-2 limitFloat + (fmap Stereo.left $ + complexCausal reduct tone) + (\p -> + SigS.map ((0.1*) . Stereo.left) $ + complexCore (Param.get reduct p) (toneS p)) +{- + in checkSimilarityState 1e-2 limitStereoFloat + (complexCausal reduct tone) + (\p -> complexCore (Param.get reduct p) (toneS p)) +-} + + +tests :: [(String, IO ())] +tests = + ("secondOrderPacked", quickCheck =<< secondOrderPacked) : + ("secondOrderPacked2", quickCheck =<< secondOrderPacked2) : + ("firstOrderExponential", quickCheck =<< firstOrderExponential) : + ("firstOrder", quickCheck =<< firstOrder) : + ("firstOrderPacked", quickCheck =<< firstOrderPacked) : + ("universal", quickCheck =<< universal) : + ("allpassPacked", quickCheck =<< allpassPacked) : + ("allpassPipeline", quickCheck =<< allpassPipeline) : + ("allpassCore", quickCheck =<< allpassCore) : + ("moog", quickCheck =<< moog) : + ("complexPacked", quickCheck =<< complexPacked) : + ("complex", quickCheck =<< complex) : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Packed.hs b/testsuite/Test/Synthesizer/LLVM/Packed.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Packed.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Synthesizer.LLVM.Packed (tests) where + +import Test.Synthesizer.LLVM.Utility + (checkSimilarity, checkEquality, rangeFromInt, + CheckSimilarity, CheckEquality, ) + +import qualified Synthesizer.LLVM.Wave as Wave +import qualified Synthesizer.LLVM.Parameter as Param + +import Types.Data.Num (D4, ) +import qualified Types.Data.Num as TypeNum + +import qualified Synthesizer.LLVM.Frame.SerialVector as Serial +import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP +import Synthesizer.LLVM.Parameterized.Signal (($#), ) +import Synthesizer.LLVM.CausalParameterized.Process (($*), ) + +import qualified Synthesizer.LLVM.Storable.Signal as SigStL +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize, ) + +import Control.Arrow ((^<<), (<<^), (<<<), ) + +import Data.Word (Word32, ) + +import Test.QuickCheck (quickCheck, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +type SimFloat = CheckSimilarity Float +type VectorValue = Serial.Value D4 Float + +signalLength :: Int +signalLength = 10000 + + +limitFloat :: SVL.Vector Float -> SVL.Vector Float +limitFloat = SVL.take signalLength + + +durFromInt :: Param.T Int Float +durFromInt = + fromIntegral ^<< rangeFromInt (signalLength,2*signalLength) + +{- +limitPackedFloat :: + SVL.Vector (Serial.Plain D4 Float) -> SVL.Vector (Serial.Plain D4 Float) +limitPackedFloat = SVL.take (div signalLength 4) +-} + +constant :: IO (ChunkSize -> Int -> SimFloat) +constant = + let y = rangeFromInt (-1, 1) + in checkSimilarity 1e-3 limitFloat + (SigP.constant y) + (SigPS.unpack (SigPS.constant y :: SigP.T Int VectorValue)) + +ramp :: IO (ChunkSize -> Int -> SimFloat) +ramp = + let dur = durFromInt + in checkSimilarity 1e-3 limitFloat + (SigP.rampInf dur) + (SigPS.unpack (SigPS.rampInf dur :: SigP.T Int VectorValue)) + +parabolaFadeIn :: IO (ChunkSize -> Int -> SimFloat) +parabolaFadeIn = + let dur = durFromInt + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeInInf dur) + (SigPS.unpack (SigPS.parabolaFadeInInf dur :: + SigP.T Int VectorValue)) + +parabolaFadeOut :: IO (ChunkSize -> Int -> SimFloat) +parabolaFadeOut = + let dur = durFromInt + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeOutInf dur) + (SigPS.unpack (SigPS.parabolaFadeOutInf dur :: + SigP.T Int VectorValue)) + +parabolaFadeInMap :: IO (ChunkSize -> Int -> SimFloat) +parabolaFadeInMap = + let dur = durFromInt + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeIn dur) + (SigP.parabolaFadeInMap dur) + +parabolaFadeOutMap :: IO (ChunkSize -> Int -> SimFloat) +parabolaFadeOutMap = + let dur = durFromInt + in checkSimilarity 1e-3 limitFloat + (SigP.parabolaFadeOut dur) + (SigP.parabolaFadeOutMap dur) + +exponential2 :: IO (ChunkSize -> (Int,Int) -> SimFloat) +exponential2 = + let halfLife = rangeFromInt (1000,10000) <<^ fst + start = rangeFromInt ( -1, 1) <<^ snd + in checkSimilarity 1e-3 limitFloat + (SigP.exponential2 halfLife start) + (SigPS.unpack (SigPS.exponential2 halfLife start :: + SigP.T (Int,Int) VectorValue)) + +exponential2Static :: IO (ChunkSize -> (Int,Int) -> SimFloat) +exponential2Static = + let halfLife = rangeFromInt (1000,10000) <<^ fst + start = rangeFromInt ( -1, 1) <<^ snd + in checkSimilarity 1e-3 limitFloat + (SigP.exponential2 halfLife start) + (Exp.causalP start <<< + CausalP.mapSimple Exp.parameter $* + SigP.constant halfLife) + +exponential2PackedStatic :: IO (ChunkSize -> (Int,Int) -> SimFloat) +exponential2PackedStatic = + let halfLife = rangeFromInt (1000,10000) <<^ fst + start = rangeFromInt ( -1, 1) <<^ snd + in checkSimilarity 1e-3 (limitFloat . SigStL.unpack) + (SigPS.exponential2 halfLife start :: + SigP.T (Int,Int) VectorValue) + (Exp.causalPackedP start <<< + CausalP.mapSimple Exp.parameterPacked $* + SigP.constant halfLife) + +exponential2Controlled :: IO (ChunkSize -> ((Int,Int), (Int,Int)) -> SimFloat) +exponential2Controlled = + let halfLife = rangeFromInt (1000,10000) <<^ (fst.fst) + start = rangeFromInt ( -1, 1) <<^ (snd.fst) + -- this is the LFO frequency measured at vector-rate + freq = rangeFromInt (0.0001, 0.001) <<^ (fst.snd) + phase = rangeFromInt (0, 0.99 :: Float) <<^ (snd.snd) + lfo = + CausalP.mapExponential 2 halfLife $* + SigP.osciSimple Wave.approxSine2 phase freq + in checkSimilarity 1e-3 limitFloat + (Exp.causalP start <<< + CausalP.mapSimple Exp.parameter $* + SigP.interpolateConstant + (TypeNum.fromIntegerT TypeNum.d4 :: Param.T p Float) + lfo) + (SigPS.unpack + (Exp.causalPackedP start <<< + CausalP.mapSimple Exp.parameterPacked $* + lfo :: SigP.T ((Int,Int),(Int,Int)) VectorValue)) + +osci :: IO (ChunkSize -> (Int,Int) -> SimFloat) +osci = + let freq = rangeFromInt (0.001, 0.01) <<^ fst + phase = rangeFromInt (0, 0.99) <<^ snd + in checkSimilarity 1e-2 limitFloat + (SigP.osciSimple Wave.approxSine2 phase freq) + (SigPS.unpack (SigPS.osciSimple Wave.approxSine2 phase freq :: + SigP.T (Int,Int) VectorValue)) + + + +limitWord32 :: SVL.Vector Word32 -> SVL.Vector Word32 +limitWord32 = SVL.take signalLength + +limitPackedWord32 :: + SVL.Vector (Serial.Plain D4 Word32) -> SVL.Vector (Serial.Plain D4 Word32) +limitPackedWord32 = SVL.take (div signalLength 4) + + +noise :: IO (ChunkSize -> () -> CheckEquality Word32) +noise = + checkEquality limitWord32 + (SigP.noiseCore $# 0) + (SigP.noiseCoreAlt $# 0) + +noiseVector :: IO (ChunkSize -> () -> CheckEquality (Serial.Plain D4 Word32)) +noiseVector = + checkEquality limitPackedWord32 + (SigPS.noiseCore $# 0) + (SigPS.noiseCoreAlt $# 0) + +noiseScalarVector :: IO (ChunkSize -> () -> CheckEquality (Serial.Plain D4 Word32)) +noiseScalarVector = + checkEquality limitPackedWord32 + (SigPS.noiseCore $# 0) + (SigPS.packSmall (SigP.noiseCore $# 0)) + + +tests :: [(String, IO ())] +tests = + ("constant", quickCheck =<< constant) : + ("ramp", quickCheck =<< ramp) : + ("parabolaFadeIn", quickCheck =<< parabolaFadeIn) : + ("parabolaFadeOut", quickCheck =<< parabolaFadeOut) : + ("parabolaFadeInMap", quickCheck =<< parabolaFadeInMap) : + ("parabolaFadeOutMap", quickCheck =<< parabolaFadeOutMap) : + ("exponential2", quickCheck =<< exponential2) : + ("exponential2Static", quickCheck =<< exponential2Static) : + ("exponential2PackedStatic", quickCheck =<< exponential2PackedStatic) : + ("exponential2Controlled", quickCheck =<< exponential2Controlled) : + ("osci", quickCheck =<< osci) : + ("noise", quickCheck =<< noise) : + ("noiseVector", quickCheck =<< noiseVector) : + ("noiseScalarVector", quickCheck =<< noiseScalarVector) : + [] diff --git a/testsuite/Test/Synthesizer/LLVM/Utility.hs b/testsuite/Test/Synthesizer/LLVM/Utility.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Utility.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +module Test.Synthesizer.LLVM.Utility where + +import qualified Synthesizer.LLVM.Parameterized.Signal as SigP +import qualified Synthesizer.LLVM.Parameter as Param + +import qualified Synthesizer.State.Signal as SigS + +import Control.Arrow (arr, ) +import Control.Monad (liftM, liftM2, ) + +import qualified Data.StorableVector.Lazy as SVL +import Data.StorableVector.Lazy (ChunkSize, ) +import Foreign.Storable (Storable, ) + +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Class as Class + +import System.Random (Random, randomR, mkStdGen, ) + +import qualified Test.QuickCheck as QC + +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Absolute as Absolute + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +rangeFromInt :: Random a => (a,a) -> Param.T Int a +rangeFromInt rng = + arr $ fst . randomR rng . mkStdGen + + +render :: + (Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al) => + (SVL.Vector a -> sig) -> + SigP.T p (Class.ValueTuple a) -> IO (ChunkSize -> p -> sig) +render limit sig = + fmap + (\func chunkSize -> + limit . func chunkSize) $ + SigP.runChunky sig + + +data CheckSimilarityState a = + CheckSimilarityState a (SVL.Vector a) (SigS.T a) + +instance (Storable a, Ord a, Absolute.C a) => + QC.Testable (CheckSimilarityState a) where + property (CheckSimilarityState tol xs ys) = + QC.property $ + SigS.foldR (&&) True $ + -- dangerous, since shortened signals would be tolerated + SigS.zipWith (\x y -> abs(x-y) < tol) + (SigS.fromStorableSignal xs) ys + +{-# INLINE checkSimilarityState #-} +checkSimilarityState :: + (RealRing.C a, Storable a, + Class.MakeValueTuple a, Class.ValueTuple a ~ av, + Memory.C av) => + a -> + (SVL.Vector a -> SVL.Vector a) -> + SigP.T p av -> + (p -> SigS.T a) -> + IO (ChunkSize -> p -> CheckSimilarityState a) +checkSimilarityState tol limit gen0 sig1 = + liftM + (\sig0 chunkSize p -> + CheckSimilarityState tol (sig0 chunkSize p) (sig1 p)) + (render limit gen0) + + +data CheckSimilarity a = + CheckSimilarity a (SVL.Vector a) (SVL.Vector a) + +instance (Storable a, Ord a, Absolute.C a) => QC.Testable (CheckSimilarity a) where + property (CheckSimilarity tol xs ys) = + QC.property $ + SigS.foldR (&&) True $ + -- dangerous, since shortened signals would be tolerated + SigS.zipWith (\x y -> abs(x-y) < tol) + (SigS.fromStorableSignal xs) + (SigS.fromStorableSignal ys) + +{-# INLINE checkSimilarity #-} +checkSimilarity :: + (RealRing.C b, Storable b, + Storable a, + Class.MakeValueTuple a, Class.ValueTuple a ~ av, Memory.C av) => + b -> + (SVL.Vector a -> SVL.Vector b) -> + SigP.T p av -> SigP.T p av -> + IO (ChunkSize -> p -> CheckSimilarity b) +checkSimilarity tol limit gen0 gen1 = + liftM2 + (\sig0 sig1 chunkSize p -> + CheckSimilarity tol (sig0 chunkSize p) (sig1 chunkSize p)) + (render limit gen0) + (render limit gen1) + + +{- | +Instead of testing on equality immediately +we use this interim data type. +This allows us to inspect the signals that are compared. +-} +data CheckEquality a = + CheckEquality (SVL.Vector a) (SVL.Vector a) + +instance (Storable a, Eq a) => QC.Testable (CheckEquality a) where + property (CheckEquality x y) = QC.property (x==y) + +checkEquality :: + (Eq a, Storable a, + Class.MakeValueTuple a, Class.ValueTuple a ~ av, + Memory.C av) => + (SVL.Vector a -> SVL.Vector a) -> + SigP.T p av -> SigP.T p av -> + IO (ChunkSize -> p -> CheckEquality a) +checkEquality limit gen0 gen1 = + liftM2 + (\sig0 sig1 chunkSize p -> + CheckEquality (sig0 chunkSize p) (sig1 chunkSize p)) + (render limit gen0) + (render limit gen1)