diff --git a/src/Synthesizer/ALSA/CausalIO/Process.hs b/src/Synthesizer/ALSA/CausalIO/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/CausalIO/Process.hs @@ -0,0 +1,96 @@ +module Synthesizer.ALSA.CausalIO.Process ( + Events, + playFromEvents, + Output, + playFromEventsWithParams, + ) where + +import qualified Synthesizer.ALSA.EventList as MIDIEv + +import qualified Synthesizer.ALSA.Storable.Play as Play +import Synthesizer.MIDI.EventList (StrictTime, ) + +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Sound.ALSA.PCM as PCM +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Data.EventList.Relative.TimeTime as EventListTT + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import qualified Data.StorableVector as SV + +import Control.Exception (bracket, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + + +type Events = EventListTT.T StrictTime [Event.T] + +playFromEvents :: + (RealField.C time, PCM.SampleFmt a, Additive.C a) => + Play.Device -> MIDIEv.ClientName -> time -> time -> PCM.SampleFreq -> + PIO.T Events (SV.Vector a) -> + IO () +playFromEvents device name latency beat rate + (PIO.Cons next create delete) = + let sink = Play.makeSink device beat rate + rateFloat = fromIntegral rate + in MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList -> + PCM.withSoundSink sink $ \to -> +{- + Play.writeLazy sink to + (SVL.replicate + (SVL.chunkSize $ round (beat * rateFloat)) + (round (latency * rateFloat)) + (zero::Float)) +-} + Play.write sink to + (SV.replicate (round (latency * rateFloat)) zero) >> + (bracket create delete $ \state -> + let loop getEvs0 s0 = + case getEvs0 of + [] -> return () + getEvents : getEvs1 -> do + evs <- getEvents + (pcm, s1) <- next evs s0 + Play.write sink to pcm + loop getEvs1 s1 + in loop getEventsList state) + + +type Output handle signal a = + (IO ((PCM.Size, PCM.SampleFreq), handle), + handle -> IO (), + handle -> signal -> IO a) + +playFromEventsWithParams :: + Output handle signal () -> + MIDIEv.ClientName -> + ((PCM.Size, PCM.SampleFreq) -> PIO.T Events signal) -> + IO () +playFromEventsWithParams (open, close, write) name process = + bracket open (close . snd) $ \(p@(period,rate),h) -> + let rateFloat = fromIntegral rate :: Double + beat = fromIntegral period / rateFloat + in MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList -> + case process p of + PIO.Cons next create delete -> do +{- + write + (SV.replicate (round (latency * rateFloat)) zero) +-} + bracket create delete $ \state -> + let loop getEvs0 s0 = + case getEvs0 of + [] -> return () + getEvents : getEvs1 -> do + evs <- getEvents + (chunk, s1) <- next evs s0 + write h chunk + loop getEvs1 s1 + in loop getEventsList state diff --git a/src/Synthesizer/ALSA/Dimensional/Play.hs b/src/Synthesizer/ALSA/Dimensional/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Dimensional/Play.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.ALSA.Dimensional.Play where + +import qualified Synthesizer.ALSA.Storable.Play as Play + +import qualified Synthesizer.Dimensional.Rate as Rate +import qualified Synthesizer.Dimensional.Amplitude as Amp + +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Signal.Private as SigA + +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified Synthesizer.Storable.Signal as SigSt + +import qualified Sound.ALSA.PCM as ALSA + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +-- import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.Module as Module +import qualified Algebra.RealRing as RealRing +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +import Foreign.Storable (Storable, ) + +-- import NumericPrelude.Numeric +import NumericPrelude.Base + + +type Device = String + +type RenderedStorableSignal u t v y yv = + SigA.T (Rate.Dimensional u t) (Amp.Dimensional v y) (SigSt.T yv) + +type StorableSignal s v y yv = + SigA.T (Rate.Phantom s) (Amp.Dimensional v y) (SigSt.T yv) + + +makeSink :: + (ALSA.SampleFmt y, RealRing.C t) => + Device {- ^ ALSA output device -} -> + DN.Time t {- ^ period (buffer) size expressed in seconds -} -> + DN.Frequency t {- ^ sample rate -} -> + ALSA.SoundSink ALSA.Pcm y +makeSink device periodTime rate = + Play.makeSink device + (DN.toNumberWithDimension Dim.time periodTime) + (RealRing.round (DN.toNumberWithDimension Dim.frequency rate)) + + +{-# INLINE timeVoltageStorable #-} +timeVoltageStorable :: + (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) => + Device -> + DN.Time t-> + RenderedStorableSignal Dim.Time t Dim.Voltage y yv -> + IO () +timeVoltageStorable device period sig = + Play.auto (makeSink device period (SigA.actualSampleRate sig)) + (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig) + +{-# INLINE timeVoltageMonoStorableToInt16 #-} +timeVoltageMonoStorableToInt16 :: + (Storable y, RealRing.C y, RealRing.C t) => + Device -> + DN.Time t-> + RenderedStorableSignal Dim.Time t Dim.Voltage y y -> + IO () +timeVoltageMonoStorableToInt16 device period sig = + Play.monoToInt16 (makeSink device period (SigA.actualSampleRate sig)) + (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig) + +{-# INLINE timeVoltageStereoStorableToInt16 #-} +timeVoltageStereoStorableToInt16 :: + (Storable y, Module.C y y, RealRing.C y, RealRing.C t) => + Device -> + DN.Time t-> + RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) -> + IO () +timeVoltageStereoStorableToInt16 device period sig = + Play.stereoToInt16 (makeSink device period (SigA.actualSampleRate sig)) + (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig) + + +{-# INLINE renderTimeVoltageStorable #-} +renderTimeVoltageStorable :: + (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) => + Device -> + DN.Time t-> + DN.T Dim.Frequency t -> + (forall s. Proc.T s Dim.Time t + (StorableSignal s Dim.Voltage y yv)) -> + IO () +renderTimeVoltageStorable device period rate sig = + timeVoltageStorable device period (SigA.render rate sig) + +{-# INLINE renderTimeVoltageMonoStorableToInt16 #-} +renderTimeVoltageMonoStorableToInt16 :: + (Storable y, RealRing.C y, RealRing.C t) => + Device -> + DN.Time t-> + DN.T Dim.Frequency t -> + (forall s. Proc.T s Dim.Time t + (StorableSignal s Dim.Voltage y y)) -> + IO () +renderTimeVoltageMonoStorableToInt16 device period rate sig = + timeVoltageMonoStorableToInt16 device period (SigA.render rate sig) + +{-# INLINE renderTimeVoltageStereoStorableToInt16 #-} +renderTimeVoltageStereoStorableToInt16 :: + (Storable y, Module.C y y, RealRing.C y, RealRing.C t) => + Device -> + DN.Time t-> + DN.T Dim.Frequency t -> + (forall s. Proc.T s Dim.Time t + (StorableSignal s Dim.Voltage y (Stereo.T y))) -> + IO () +renderTimeVoltageStereoStorableToInt16 device period rate sig = + timeVoltageStereoStorableToInt16 device period (SigA.render rate sig) diff --git a/src/Synthesizer/ALSA/Dimensional/Server.hs b/src/Synthesizer/ALSA/Dimensional/Server.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Dimensional/Server.hs @@ -0,0 +1,18 @@ +module Main where + +import qualified Synthesizer.ALSA.Dimensional.Server.Run as Run +import qualified Synthesizer.ALSA.Dimensional.Server.Test as Test + +main :: IO () +main = + case 106::Int of + 001 -> Test.sequence1 + 100 -> Run.volume + 101 -> Run.pitchBend + 102 -> Run.volumePitchBend1 + 103 -> Run.keyboard + 104 -> Run.keyboardMulti + 105 -> Run.keyboardFM + 106 -> Run.keyboardDetuneFM + 107 -> Run.keyboardFilter + _ -> error "not implemented" diff --git a/src/Synthesizer/ALSA/Dimensional/Server/Common.hs b/src/Synthesizer/ALSA/Dimensional/Server/Common.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Dimensional/Server/Common.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +module Synthesizer.ALSA.Dimensional.Server.Common where + +import qualified Synthesizer.ALSA.Dimensional.Play as Play + +import qualified Sound.ALSA.PCM as ALSA +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Synthesizer.ALSA.EventList as MIDIEv + +import qualified Synthesizer.ALSA.Storable.Play as PlaySt + +import qualified Synthesizer.Dimensional.Rate.Filter as FiltR +import qualified Synthesizer.Dimensional.Process as Proc + +import Synthesizer.Dimensional.Process (($:), ) + +import qualified Data.StorableVector.Lazy as SVL + +import qualified Sound.MIDI.Message.Channel as ChannelMsg + +import qualified Data.EventList.Relative.TimeBody as EventList + +-- import qualified Numeric.NonNegative.Class as NonNeg +-- import qualified Numeric.NonNegative.Wrapper as NonNegW +-- import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (break, ) + + + +channel :: ChannelMsg.Channel +channel = ChannelMsg.toChannel 0 + + +sampleRate :: Ring.C a => DN.Frequency a +-- sampleRate = DN.frequency 48000 +sampleRate = DN.frequency 44100 + +latency :: Field.C a => DN.Time a +latency = DN.time 0 +-- latency = DN.time 0.01 + +{- +chunkSize :: SVL.ChunkSize +chunkSize = Play.defaultChunkSize +-} + +periodTime :: Field.C a => DN.Time a +periodTime = + let (SVL.ChunkSize size) = PlaySt.defaultChunkSize + in DN.scale (fromIntegral size) $ DN.unrecip sampleRate + +device :: Play.Device +device = PlaySt.defaultDevice + +clientName :: MIDIEv.ClientName +clientName = MIDIEv.ClientName "Haskell-Synthesizer" + + +type Real = Double + + +{-# INLINE withMIDIEvents #-} +withMIDIEvents :: + Field.C t => + (DN.Time t -> DN.Frequency t -> + (forall s. Proc.T s Dim.Time t + (Play.StorableSignal s Dim.Voltage y yv)) -> + IO b) -> + (EventList.T MIDIEv.StrictTime [Event.T] -> + forall s. Proc.T s Dim.Time t + (Play.StorableSignal s Dim.Voltage y yv)) -> + IO b +withMIDIEvents action proc = + MIDIEv.withMIDIEvents clientName + (DN.toNumberWithDimension Dim.time periodTime :: Double) + (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $ + \ sig -> action periodTime sampleRate (proc sig) + +{-# INLINE play #-} +play :: + (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) => + DN.Time t -> + DN.Frequency t -> + (forall s. Proc.T s Dim.Time t + (Play.StorableSignal s Dim.Voltage y yv)) -> + IO () +play period rate sig = + Play.renderTimeVoltageStorable device period rate + (FiltR.delay latency $: sig) diff --git a/src/Synthesizer/ALSA/Dimensional/Server/Run.hs b/src/Synthesizer/ALSA/Dimensional/Server/Run.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Dimensional/Server/Run.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.ALSA.Dimensional.Server.Run where + +import Synthesizer.ALSA.Dimensional.Server.Common +import qualified Synthesizer.MIDI.Dimensional.Example.Instrument as Instr + +import qualified Synthesizer.MIDI.Dimensional as MIDI + +import qualified Synthesizer.ALSA.Storable.Play as PlaySt + +import qualified Synthesizer.Dimensional.Causal.Process as Causal +import qualified Synthesizer.Dimensional.Causal.Oscillator as Osci +import qualified Synthesizer.Dimensional.Causal.Filter as Filt +import qualified Synthesizer.Dimensional.Causal.FilterParameter as FiltP +import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc + +import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR +import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA +import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA +import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA +import qualified Synthesizer.Dimensional.Signal.Private as SigA +import qualified Synthesizer.Dimensional.Wave as WaveD + +import Synthesizer.Dimensional.Causal.Process ((<<<), ) +import Synthesizer.Dimensional.Wave ((&*~), ) +import Synthesizer.Dimensional.Process (($:), (.:), ) +import Control.Applicative (liftA2, liftA3, ) + +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Number.DimensionTerm as DN + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (break, ) + + + +channelVolume :: VoiceMsg.Controller +channelVolume = VoiceMsg.modulation + + +volume :: IO () +volume = + putStrLn "run 'aconnect' to connect to the MIDI controller" >> + (withMIDIEvents play $ + \evs -> + liftA3 + (\env osci vol -> + Causal.apply + (Causal.applySnd env osci) $ + MIDI.piecewiseConstant $ vol) + Filt.envelopeScalarDimension + (OsciR.static (DN.voltage 1 &*~ Wave.sine) zero (DN.frequency (880::Real))) + (MIDI.runFilter evs (MIDI.controllerLinear channel channelVolume + (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real))))) + +pitchBend :: IO () +pitchBend = + withMIDIEvents play $ + \evs -> + liftA2 Causal.apply + (Osci.freqMod (DN.voltage (1::Real) &*~ Wave.sine) zero) + (fmap MIDI.piecewiseConstant $ + MIDI.runFilter evs + (MIDI.pitchBend channel 2 (DN.frequency (880::Real)))) + +-- preserve chunk structure of channel volume +volumePitchBend0 :: IO () +volumePitchBend0 = + putStrLn "run 'aconnect' to connect to the MIDI controller" >> + (withMIDIEvents play $ + \evs -> + liftA3 + (\osci env (freq,vol) -> + Causal.apply + (Causal.applySnd env (osci $ SigA.restore freq)) $ + MIDI.piecewiseConstant vol) + (OsciR.freqMod (DN.voltage 1 &*~ Wave.sine) zero) + Filt.envelopeScalarDimension + (MIDI.runFilter evs $ liftA2 (,) + (MIDI.pitchBend channel 2 (DN.frequency (880::Real))) + (MIDI.controllerLinear channel channelVolume + (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real))))) + +-- preserve chunk structure of pitch bender +volumePitchBend1 :: IO () +volumePitchBend1 = + putStrLn "run 'aconnect' to connect to the MIDI controller" >> + (withMIDIEvents play $ + \evs -> + liftA3 + (\osci env (freq,vol) -> + Causal.apply + (Causal.applyFst env (SigA.restore vol) <<< osci) $ + MIDI.piecewiseConstant freq) + (Osci.freqMod (DN.voltage 1 &*~ Wave.sine) zero) + Filt.envelopeScalarDimension + (MIDI.runFilter evs $ liftA2 (,) + (MIDI.pitchBend channel 2 (DN.frequency (880::Real))) + (MIDI.controllerLinear channel channelVolume + (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real))))) + + +keyboard :: IO () +keyboard = + withMIDIEvents play $ + \evs -> + MIDI.runFilter evs + (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.ping) + + +keyboardMulti :: IO () +keyboardMulti = + withMIDIEvents play $ + \evs -> + MIDI.runFilter evs + (MIDI.sequenceMultiProgram PlaySt.defaultChunkSize (DN.voltage 1) channel + (VoiceMsg.toProgram 0) + [Instr.ping, Instr.pingRelease]) +-- [Instr.string]) + + +keyboardFM :: IO () +keyboardFM = + withMIDIEvents play $ + \evs -> + fmap (FiltA.amplify 0.3) $ + (MIDI.runFilter evs + (MIDI.sequenceModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingReleaseFM $: + MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03)) +-- MIDI.pitchBend channel (2 ** recip 12) (DN.scalar one))) + + +extraController :: VoiceMsg.Controller +extraController = + VoiceMsg.vectorX +-- VoiceMsg.toController 21 + +extraController1 :: VoiceMsg.Controller +extraController1 = + VoiceMsg.modulation +-- VoiceMsg.vectorY +-- VoiceMsg.toController 22 + + +keyboardDetuneFM :: IO () +keyboardDetuneFM = + withMIDIEvents play $ + \evs -> + fmap (FiltA.amplify 0.3) $ + (MIDI.runFilter evs + (MIDI.sequenceMultiModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingStereoDetuneFM + (fmap MIDI.applyModulation + (MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03) .: + fmap MIDI.applyModulation + (MIDI.controllerLinear channel extraController (0, 0.005) 0)) + )) + + +keyboardFilter :: IO () +keyboardFilter = + withMIDIEvents play $ + \evs -> + liftA3 + (\osci filt (music,speed,depth) -> + (FiltP.lowpassFromUniversal <<< + filt (CtrlA.constant 10) + (DispA.mapExponential 4 (DN.frequency 1000) $ + FiltA.envelope (SigA.restore depth) $ + osci (SigA.restore speed))) + `Causal.apply` + FiltA.amplify 0.2 music) + (OsciR.freqMod (WaveD.flat Wave.sine) zero) + (CProc.runSynchronous2 FiltP.universal) +-- FiltR.universal + (MIDI.runFilter evs + (liftA3 (,,) + (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.string) + (MIDI.controllerExponential channel extraController + (DN.frequency 0.1, DN.frequency 5) (DN.frequency 0.2)) + (MIDI.controllerLinear channel extraController1 + (0, 1 :: DN.Scalar Real) 0.5) + )) diff --git a/src/Synthesizer/ALSA/Dimensional/Server/Test.hs b/src/Synthesizer/ALSA/Dimensional/Server/Test.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Dimensional/Server/Test.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Rank2Types #-} +module Synthesizer.ALSA.Dimensional.Server.Test where + +import Synthesizer.ALSA.Dimensional.Server.Common +import Synthesizer.MIDI.Dimensional.Example.Instrument (ping, ) + +import qualified Synthesizer.ALSA.Storable.Play as PlaySt + +import qualified Synthesizer.MIDI.Dimensional as MIDI +import qualified Synthesizer.MIDI.EventList as MIDIEv +import qualified Synthesizer.MIDI.Generic as MidiG + +import qualified Synthesizer.Dimensional.Signal.Private as SigA +import qualified Synthesizer.Dimensional.Process as Proc + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding (break, ) + + + +sequence1 :: IO () +sequence1 = +-- print =<< +-- File.renderTimeVoltageMonoDoubleToInt16 sampleRate "test.wav" + SVL.writeFile "test.f32" + (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) + (SigA.render sampleRate + (let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t)) + {- + evs0 = + EventList.cons 10 [makeNote AlsaMidi.NoteOn 60] $ + EventList.cons 10 [makeNote AlsaMidi.NoteOn 64] $ + evs 10 + -} + in MIDI.runFilter (evs 10) + (MIDI.sequence PlaySt.defaultChunkSize + (DN.voltage 1) channel ping)))) + +sequence2 :: + EventList.T MIDIEv.StrictTime [SigSt.T Real] +sequence2 = + fmap (map SigA.body) $ + flip Proc.process sampleRate + (let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t)) + in MIDI.runFilter (evs 10) + (MIDI.prepareTones channel MidiG.errorNoProgram + (const ping))) diff --git a/src/Synthesizer/ALSA/EventList.hs b/src/Synthesizer/ALSA/EventList.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/EventList.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.ALSA.EventList where + +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.Port.InfoMonad as PortInfo +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.Queue as Queue +import qualified Sound.ALSA.Sequencer.Time as Time +import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import qualified Sound.ALSA.Sequencer as SndSeq +import qualified Sound.ALSA.Exception as AlsaExc + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Relative.MixedBody as EventListMB +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Absolute.TimeBody as AbsEventList + +import Sound.MIDI.ALSA.Check () + +import System.IO.Unsafe (unsafeInterleaveIO, ) +import Control.Concurrent (threadDelay) +import System.Time (ClockTime(TOD), getClockTime, ) + +import Control.Monad.Trans.State + (evalState, modify, get, ) + +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW + +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import Data.Tuple.HT (mapPair, mapSnd, ) +import Data.Ord.HT (limit, ) +import Control.Monad (liftM, liftM2, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +The @time@ type needs high precision, +so you will certainly have to instantiate it with 'Double'. +'Float' has definitely not enough bits. +-} +getTimeSeconds :: Field.C time => IO time +getTimeSeconds = + fmap clockTimeToSeconds getClockTime + +clockTimeToSeconds :: Field.C time => ClockTime -> time +clockTimeToSeconds (TOD secs picos) = + fromInteger secs + fromInteger picos * 1e-12 + +wait :: RealField.C time => time -> IO () +wait t1 = + do t0 <- getTimeSeconds + threadDelay $ floor $ 1e6*(t1-t0) + + +{- +We cannot easily turn this into a custom type, +since we need Maybe Event.T sometimes. +-} +type StampedEvent time = (time, Event.T) + + +{- | +only use it for non-blocking sequencers + +We ignore ALSA time stamps and use the time of fetching the event, +because I don't know whether the ALSA time stamps are in sync with getClockTime. +-} +getStampedEvent :: + (Field.C time, SndSeq.AllowInput mode) => + SndSeq.T mode -> IO (StampedEvent time) +getStampedEvent h = + liftM2 (,) + getTimeSeconds + (Event.input h) + +{- | only use it for non-blocking sequencers -} +getWaitingStampedEvents :: + (Field.C time, SndSeq.AllowInput mode) => + SndSeq.T mode -> IO [StampedEvent time] +getWaitingStampedEvents h = + let loop = + AlsaExc.catch + (liftM2 (:) (getStampedEvent h) loop) + (const $ return []) + in loop + +{- | +RealTime.toFractional for NumericPrelude. +-} +realTimeToField :: (Field.C a) => RealTime.T -> a +realTimeToField (RealTime.Cons s n) = + fromIntegral s + fromIntegral n / (10^9) + +addStamp :: + (RealField.C time) => + Event.T -> StampedEvent time +addStamp ev = + (case Event.time ev of + Time.Cons Time.Absolute (Time.Real t) -> realTimeToField t + _ -> error "unsupported time stamp type", + ev) + +{- | only use it for blocking sequencers -} +getStampedEventsUntilTime :: + (RealField.C time, + SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => + SndSeq.T mode -> + Queue.T -> Port.T -> time -> + IO [StampedEvent time] +getStampedEventsUntilTime h q p t = + fmap (map addStamp) $ getEventsUntilTime h q p t + + +{- | +The client id may differ from the receiving sequencer. +I do not know, whether there are circumstances, where this is useful. +-} +getEventsUntilEcho :: + (SndSeq.AllowInput mode) => + Client.T -> SndSeq.T mode -> IO [Event.T] +getEventsUntilEcho c h = + let loop = do + ev <- Event.input h + let abort = + case Event.body ev of + Event.CustomEv Event.Echo _ -> + c == Addr.client (Event.source ev) + _ -> False + if abort + then return [] + else liftM (ev:) loop + in loop + +{- | +Get events until a certain point in time. +It sends itself an Echo event in order to measure time. +-} +getEventsUntilTime :: + (RealField.C time, + SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => + SndSeq.T mode -> + Queue.T -> Port.T -> time -> + IO [Event.T] +getEventsUntilTime h q p t = do + c <- Client.getId h + _ <- Event.output h $ + makeEcho c q p t (Event.Custom 0 0 0) + _ <- Event.drainOutput h + getEventsUntilEcho c h + + +getWaitingEvents :: + (SndSeq.AllowInput mode) => + SndSeq.T mode -> IO [Event.T] +getWaitingEvents h = + let loop = + AlsaExc.catch + (liftM2 (:) (Event.input h) loop) + (const $ return []) + in loop + + + +type StrictTime = NonNegW.Integer +newtype ClientName = ClientName String + deriving (Show) + +{- +ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs +-} +{- +Maybe it is better to not use type variable for sample rate, +because ALSA supports only integers, +and if ALSA sample rate and sample rate do not match due to rounding errors, +then play and event fetching get out of sync over the time. +-} +withMIDIEvents :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime [Event.T] -> IO a) -> IO a +withMIDIEvents = + withMIDIEventsBlockEcho + + +{- +as a quick hack, we neglect the ALSA time stamp and use getTime or so +-} +withMIDIEventsNonblockWaitGrouped :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime [Event.T] -> IO a) -> IO a +withMIDIEventsNonblockWaitGrouped name beat rate proc = + withInPort name SndSeq.Nonblock $ \ h _p -> + do start <- getTimeSeconds + l <- lazySequence $ + flip map (iterate (beat+) start) $ \t -> + wait t >> + liftM + (\evs -> (t, evs)) + (getWaitingEvents h) +{- + liftM2 (,) + getTimeSeconds + (getWaitingEvents h) +-} + proc $ + discretizeTime rate $ + AbsEventList.fromPairList l + +{- +With this function latency becomes longer and longer if xruns occur, +but the latency is not just adapted, +but ones xruns occur, this implies more and more xruns. +-} +withMIDIEventsNonblockWaitDefer :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a +withMIDIEventsNonblockWaitDefer name beat rate proc = + withInPort name SndSeq.Nonblock $ \ h _p -> + do start <- getTimeSeconds + l <- lazySequence $ + flip map (iterate (beat+) start) $ \t -> + wait t >> + liftM + (\ es -> (t, Nothing) : map (mapSnd Just) es) + (getWaitingStampedEvents h) + proc $ + discretizeTime rate $ + {- + delay events that are in wrong order + disadvantage: we cannot guarantee a beat with a minimal period + -} + flip evalState start $ + AbsEventList.mapTimeM (\t -> modify (max t) >> get) $ + AbsEventList.fromPairList $ concat l + +{- +We risk and endless skipping when the beat is too short. +(Or debug output slows down processing.) +-} +withMIDIEventsNonblockWaitSkip :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a +withMIDIEventsNonblockWaitSkip name beat rate proc = + withInPort name SndSeq.Nonblock $ \ h _p -> + do start <- getTimeSeconds + l <- lazySequence $ + flip map (iterate (beat+) start) $ \t -> + do wait t + t0 <- getTimeSeconds + -- print (t-start,t0-start) + es <- + if t0>=t+beat + then return [] + else getWaitingStampedEvents h + return $ + (t0, Nothing) : + map (mapSnd Just) es + proc $ + discretizeTime rate $ + AbsEventList.fromPairList $ concat l + +withMIDIEventsNonblockWaitMin :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a +withMIDIEventsNonblockWaitMin name beat rate proc = + withInPort name SndSeq.Nonblock $ \ h _p -> + do start <- getTimeSeconds + l <- lazySequence $ + flip map (iterate (beat+) start) $ \t -> + wait t >> + liftM + (\ es -> + (minimum $ t : map fst es, Nothing) : + map (mapSnd Just) es) + (getWaitingStampedEvents h) +{- + mapM_ print $ EventList.toPairList $ + discretizeTime rate $ + AbsEventList.fromPairList $ concat l + proc undefined +-} + proc $ + discretizeTime rate $ + AbsEventList.fromPairList $ concat l + +withMIDIEventsNonblockConstantPause :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a +withMIDIEventsNonblockConstantPause name beat rate proc = + withInPort name SndSeq.Nonblock $ \ h _p -> + do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> + liftM2 (:) + (liftM (\t->(t,Nothing)) getTimeSeconds) + (liftM (map (mapSnd Just)) (getWaitingStampedEvents h)) + proc $ + discretizeTime rate $ + AbsEventList.fromPairList $ concat l + +withMIDIEventsNonblockSimple :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime Event.T -> IO a) -> IO a +withMIDIEventsNonblockSimple name beat rate proc = + withInPort name SndSeq.Nonblock $ \ h _p -> + do l <- ioToLazyList $ + threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> + getWaitingStampedEvents h + proc $ + discretizeTime rate $ + AbsEventList.fromPairList $ concat l + + +setTimestamping :: + SndSeq.T mode -> Port.T -> Queue.T -> IO () +setTimestamping h p q = + PortInfo.modify h p $ do + PortInfo.setTimestamping True + PortInfo.setTimestampReal True + PortInfo.setTimestampQueue q + +withMIDIEventsBlockEcho :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime [Event.T] -> IO a) -> IO a +withMIDIEventsBlockEcho name beat rate proc = + withInPort name SndSeq.Block $ \ h p -> + Queue.with h $ \ q -> + do setTimestamping h p q + Queue.control h q Event.QueueStart Nothing + _ <- Event.drainOutput h + + proc . + discretizeTime rate . + AbsEventList.fromPairList . + concat =<< + (lazySequence $ + flip map (iterate (beat+) 0) $ \t -> + let end = t+beat + in -- (\act -> do evs <- act; print evs; return evs) $ + -- add a laziness break + fmap ((t,[]) :) $ + fmap (map (mapPair (limit (t,end), (:[])))) $ + getStampedEventsUntilTime h q p end) + +{- | +This is like withMIDIEventsBlockEcho +but collects all events at the beginning of the beats. +This way, further processing steps may collapse +all controller events within one beat to one event. +-} +withMIDIEventsBlockEchoQuantised :: (RealField.C time) => + ClientName -> time -> time -> + (EventList.T StrictTime [Event.T] -> IO a) -> IO a +withMIDIEventsBlockEchoQuantised name beat rate proc = + withInPort name SndSeq.Block $ \ h p -> + Queue.with h $ \ q -> + do Queue.control h q Event.QueueStart Nothing + _ <- Event.drainOutput h + + proc . + discretizeTime rate . + AbsEventList.fromPairList =<< + (lazySequence $ + flip map (iterate (beat+) 0) $ \t -> + liftM + (\evs -> (t, evs)) + (getEventsUntilTime h q p (t+beat))) + +{- | +Make sure, that @beat@ is an integer multiple of @recip rate@. +Since we round time within each chunk, +we would otherwise accumulate rounding errors over time. +-} +withMIDIEventsChunked :: + (RealField.C time) => + ClientName -> time -> time -> + ([IO (EventListTT.T StrictTime [Event.T])] -> IO a) -> + IO a +withMIDIEventsChunked name beat rate proc = + withInPort name SndSeq.Block $ \ h p -> + Queue.with h $ \ q -> + do setTimestamping h p q + Queue.control h q Event.QueueStart Nothing + _ <- Event.drainOutput h + + proc $ + map + (\t -> + let end = t+beat + in liftM + (\evs -> + EventListTM.switchBodyR + (error "withMIDIEventsChunked: empty list, but there must be at least the end event") + const $ + discretizeTime rate $ + AbsEventList.fromPairList $ + (t,[]) : + {- + FIXME: This is a quick hack in order to assert + that all events are within one chunk + and do not lie on the boundary. + -} + map (mapPair (limit (t , end - recip rate), (:[]))) evs ++ + (end, []) : + []) + (getStampedEventsUntilTime h q p end)) + (iterate (beat+) 0) + +withMIDIEventsChunkedQuantised :: + (RealField.C time) => + ClientName -> time -> time -> + ([IO (EventList.T StrictTime [Event.T])] -> IO a) -> + IO a +withMIDIEventsChunkedQuantised name beat rate proc = + withInPort name SndSeq.Block $ \ h p -> + Queue.with h $ \ q -> + do Queue.control h q Event.QueueStart Nothing + _ <- Event.drainOutput h + + proc $ + map + (\t -> + liftM + (\evs -> + EventList.cons NonNeg.zero evs $ + EventList.singleton + (NonNegW.fromNumberMsg "chunked time conversion" $ + round (beat*rate)) []) + (getEventsUntilTime h q p (t+beat))) + (iterate (beat+) 0) + +makeEcho :: + RealField.C time => + Client.T -> Queue.T -> Port.T -> + time -> Event.Custom -> Event.T +makeEcho c q p t dat = + (Event.simple + (Addr.Cons { + Addr.client = c, + Addr.port = Port.unknown + }) + (Event.CustomEv Event.Echo dat)) + { Event.queue = q + , Event.time = + Time.consAbs $ Time.Real $ RealTime.fromInteger $ + floor (10^9 * t) + , Event.dest = Addr.Cons { + Addr.client = c, + Addr.port = p + } + } + +withMIDIEventsBlock :: (RealField.C time) => + ClientName -> time -> + (EventList.T StrictTime Event.T -> IO a) -> IO a +withMIDIEventsBlock name rate proc = + withInPort name SndSeq.Block $ \ h _p -> + do l <- ioToLazyList $ getStampedEvent h + proc $ + discretizeTime rate $ + AbsEventList.fromPairList l + +withInPort :: + ClientName -> + SndSeq.BlockMode -> + (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t +withInPort (ClientName name) blockMode act = + SndSeq.with SndSeq.defaultName blockMode $ \h -> + Client.setName h name >> + Port.withSimple h "input" + (Port.caps [Port.capWrite, Port.capSubsWrite]) + Port.typeMidiGeneric + (act h) + +{- | +We first discretize the absolute time values, +then we compute differences, +in order to avoid rounding errors in further computations. +-} +discretizeTime :: (RealField.C time) => + time -> AbsEventList.T time a -> EventList.T StrictTime a +discretizeTime sampleRate = + EventListMB.mapTimeHead (const $ NonNegW.fromNumber zero) . -- clear first time since it is an absolute system time stamp + EventList.fromAbsoluteEventList . + AbsEventList.mapTime + (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*)) + + + +ioToLazyList :: IO a -> IO [a] +ioToLazyList m = + let go = unsafeInterleaveIO $ liftM2 (:) m go + in go + +lazySequence :: [IO a] -> IO [a] +lazySequence [] = return [] +lazySequence (m:ms) = + unsafeInterleaveIO $ liftM2 (:) m $ lazySequence ms diff --git a/src/Synthesizer/ALSA/Storable/Play.hs b/src/Synthesizer/ALSA/Storable/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Storable/Play.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Play audio signals via ALSA. +The module could also be called @Output@, +because with a @file@ sink, data can also be written to disk. +-} +module Synthesizer.ALSA.Storable.Play ( + -- * auxiliary functions + Device, + defaultDevice, + defaultChunkSize, + makeSink, + write, + writeLazy, + -- * play functions + auto, + autoAndRecord, + autoAndRecordMany, + monoToInt16, + stereoToInt16, + ) where + +import qualified Sound.ALSA.PCM as ALSA + +import qualified Synthesizer.Frame.Stereo as Stereo +import qualified Synthesizer.Basic.Binary as BinSmp + +import qualified Sound.Sox.Frame as SoxFrame +import qualified Sound.Sox.Write as SoxWrite +import qualified Sound.Sox.Option.Format as SoxOption + +import Foreign.Storable (Storable, ) +import Foreign.Marshal.Array (advancePtr, ) +import Foreign.Ptr (Ptr, minusPtr, ) +import Data.Int (Int16, ) +import qualified System.IO as IO +import qualified System.Exit as Exit + +-- import qualified Synthesizer.State.Signal as SigS + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.Base as SVB + +import qualified Algebra.RealRing as RealRing + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +{- | +A suggested default chunk size. +It is not used by the functions in this module. +-} +{- +Better move to Storable.Server.Common or Dimensional.Server.Common? +-} +defaultChunkSize :: SigSt.ChunkSize +defaultChunkSize = SigSt.chunkSize 512 +{- +At some epochs this chunk size leads to buffer underruns. +I cannot reproduce this: +Some months it works this way on Suse but not on Ubuntu or vice versa. +Other months it works the other way round. +defaultChunkSize = SigSt.chunkSize 256 +-} + + +type Device = String + +defaultDevice :: Device +defaultDevice = "default" + + +{- | +Useful values for the output device are + +* @\"default\"@ for mixing with the output of other applications. + +* @\"plughw:0,0\"@ for accessing sound output in an exclusive way. + +* @\"tee:default,'output.raw',raw\"@ for playing and simultaneously writing raw data to disk. + +* @\"tee:default,'output.wav',wav\"@ for playing and writing to WAVE file format. + Note that the length cannot be written, + when the program is terminated, + leaving the file in an invalid format. +-} +makeSink :: + (ALSA.SampleFmt y, RealRing.C t) => + Device {- ^ ALSA output device -} -> + t {- ^ period (buffer) size expressed in seconds -} -> + ALSA.SampleFreq {- ^ sample rate -} -> + ALSA.SoundSink ALSA.Pcm y +makeSink device periodTime rate = + ALSA.alsaSoundSinkTime device + (ALSA.SoundFmt { + ALSA.sampleFreq = rate + }) $ + ALSA.SoundBufferTime + (round (5000000*periodTime)) + (round (1000000*periodTime)) + +{- +alsaOpen: only few buffer underruns with + let buffer_time = 200000 -- 0.20s + period_time = 40000 -- 0.04s + +However the delay is still perceivable. + +Latency for keyboard playback might be better with: + let buffer_time = 50000 -- 0.05s + period_time = 10000 -- 0.01s +but we get too much underruns, +without actually achieving the required latency. +-} +{-# INLINE auto #-} +auto :: + (ALSA.SampleFmt y) => + ALSA.SoundSink handle y -> + SigSt.T y -> IO () +auto sink ys = + ALSA.withSoundSink sink $ \to -> + writeLazy sink to ys + +{-# INLINE writeLazy #-} +writeLazy :: + (Storable y) => + ALSA.SoundSink handle y -> handle y -> + SVL.Vector y -> IO () +writeLazy sink to ys = + mapM_ (write sink to) (SVL.chunks ys) + +{-# INLINE write #-} +write :: + (Storable y) => + ALSA.SoundSink handle y -> handle y -> + SVB.Vector y -> IO () +write sink to c = + SVB.withStartPtr c $ \ptr size -> + ALSA.soundSinkWrite sink to ptr size + + +-- cf. Alsa.hs +{-# INLINE arraySize #-} +arraySize :: Storable y => Ptr y -> Int -> Int +arraySize p n = advancePtr p n `minusPtr` p + +{- | +Play a signal and write it to disk via SoX simultaneously. +Consider using 'auto' with @tee@ device. +-} +{-# INLINE autoAndRecord #-} +autoAndRecord :: + (ALSA.SampleFmt y, SoxFrame.C y) => + FilePath -> + ALSA.SoundFmt y -> + ALSA.SoundSink handle y -> + SigSt.T y -> IO Exit.ExitCode +autoAndRecord fileName fmt sink = + let rate = ALSA.sampleFreq fmt + in (\act -> + SoxWrite.simple act SoxOption.none fileName rate) $ \h ys -> + ALSA.withSoundSink sink $ \to -> + flip mapM_ (SVL.chunks ys) $ \c -> + SVB.withStartPtr c $ \ptr size -> + ALSA.soundSinkWrite sink to ptr size >> + IO.hPutBuf h ptr (arraySize ptr size) + + +{- | +Play a signal and write it to multiple files. +The Functor @f@ may be @Maybe@ for no or one file to write, +or @[]@ for many files to write. +-} +{-# INLINE autoAndRecordMany #-} +autoAndRecordMany :: + (ALSA.SampleFmt y, SoxFrame.C y, + Trav.Traversable f) => + f FilePath -> + ALSA.SoundFmt y -> + ALSA.SoundSink handle y -> + SigSt.T y -> IO (f Exit.ExitCode) +autoAndRecordMany fileNames fmt sink = + let rate = ALSA.sampleFreq fmt + in (\act -> + SoxWrite.manyExtended act SoxOption.none SoxOption.none fileNames rate) $ \hs ys -> + ALSA.withSoundSink sink $ \to -> + flip mapM_ (SVL.chunks ys) $ \c -> + SVB.withStartPtr c $ \ptr size -> + ALSA.soundSinkWrite sink to ptr size >> + Fold.traverse_ (\h -> IO.hPutBuf h ptr (arraySize ptr size)) hs + + +{-# INLINE monoToInt16 #-} +monoToInt16 :: + (Storable y, RealRing.C y) => + ALSA.SoundSink handle Int16 -> + SigSt.T y -> IO () +monoToInt16 sink xs = + auto sink (SigSt.map BinSmp.int16FromCanonical xs) + +{-# INLINE stereoToInt16 #-} +stereoToInt16 :: + (Storable y, RealRing.C y) => + ALSA.SoundSink handle (Stereo.T Int16) -> + SigSt.T (Stereo.T y) -> IO () +stereoToInt16 sink xs = + auto sink (SigSt.map (fmap BinSmp.int16FromCanonical) xs) diff --git a/src/Synthesizer/ALSA/Storable/Server.hs b/src/Synthesizer/ALSA/Storable/Server.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Storable/Server.hs @@ -0,0 +1,113 @@ +module Main where + +import qualified Synthesizer.ALSA.Storable.Server.Run as Run +import qualified Synthesizer.ALSA.Storable.Server.Test as Test +import Synthesizer.ALSA.Storable.Server.Common + (Real, play, sampleRate, chunkSize, periodTime, ) + +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.ALSA.Storable.Play as Play +import qualified Synthesizer.Storable.Oscillator as OsciSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import NumericPrelude.Numeric (zero, ) +import Prelude hiding (Real, break, id, (.), ) + + +{- +This program has still a very slowly growing memory leak. +-} +main :: IO () +main = + case 208::Int of + 001 -> print Test.keyboard3 + 002 -> play (periodTime::Real) sampleRate Test.keyboard3 + 003 -> Test.speed + 004 -> Test.frequency1 + 005 -> Test.frequency2 + 006 -> Test.frequency3 +{- + 007 -> Test.frequency4 +-} + 008 -> Test.keyboard1 + 009 -> SigSt.writeFile "test.f32" Test.keyboard2 + 010 -> SigSt.writeFile "test.f32" Test.keyboard3 + 011 -> SigSt.writeFile "test.f32" Test.keyboard4 + 012 -> SigSt.writeFile "test.f32" Test.keyboard5 +{- + 013 -> Test.keyboard6 + 014 -> Test.keyboard7 +-} + 015 -> Test.arrangeSpaceLeak0 + 016 -> Test.arrangeSpaceLeak1 + 018 -> Test.arrangeSpaceLeak3 + 019 -> Test.arrangeSpaceLeak4 + 020 -> Test.chordSpaceLeak1 +-- 021 -> Test.chordSpaceLeak2 +-- 022 -> Test.chordSpaceLeak3 +-- 023 -> Test.chordSpaceLeak4 + 023 -> Test.sequencePitchBend + 024 -> Test.sequencePitchBend1 + 025 -> Test.sequencePitchBend2 + 026 -> Test.sequencePitchBend3 + 027 -> Test.sequencePitchBend4 + 028 -> Test.sequencePitchBend4a + 029 -> Test.sequencePitchBend4b + 030 -> Test.sequencePitchBend4c + 031 -> Test.sequencePitchBend4d + 032 -> Test.sequencePitchBend4e + 033 -> Test.sequencePitchBend5 + 040 -> Test.sequenceStaccato + 050 -> Test.speed + 051 -> Test.speedChunky + 052 -> Test.speedArrange + 053 -> Play.auto +{- + (ALSA.alsaSoundSinkTime Play.defaultDevice + (ALSA.SoundFmt { + ALSA.sampleFreq = sampleRate + }) $ + ALSA.SoundBufferTime + (round (5000000*periodTime::Real)) + (round (1000000*periodTime::Real)) + ) $ +-} +{- + (ALSA.fileSoundSink "test.f32" + (ALSA.SoundFmt { + ALSA.sampleFreq = sampleRate + })) $ +-} + (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $ + SVL.cycle $ + SigSt.take 100000 $ + OsciSt.static chunkSize (fmap (0.9*) Wave.sine) zero (1/100::Real) + 054 -> Play.auto + (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $ + OsciSt.static chunkSize (fmap (0.9*) Wave.sine) + zero (600/sampleRate::Real) + 055 -> play (periodTime::Real) sampleRate $ + OsciSt.static chunkSize (fmap (0.9*) Wave.sine) + zero (600/sampleRate::Real) + 100 -> Run.volume + 101 -> Run.frequency + 102 -> Run.frequencyCausal + 103 -> Run.pitchBend + 104 -> Run.volumeFrequency + 105 -> Run.volumeFrequencyCausal + 200 -> Run.keyboard + 201 -> Run.keyboardMulti + 202 -> Run.keyboardStereo + 203 -> Run.keyboardPitchbend + 204 -> Run.keyboardFM + 205 -> Run.keyboardDetuneFM + 206 -> Run.keyboardFilter + 207 -> Run.keyboardSample + 208 -> Run.keyboardVariousStereo + 209 -> Run.keyboardSampleTFM + 210 -> Run.keyboardNoisyTone + 211 -> Run.keyboardFilteredNoisyTone + 300 -> Run.keyboardCausal + _ -> error "not implemented server part" diff --git a/src/Synthesizer/ALSA/Storable/Server/Common.hs b/src/Synthesizer/ALSA/Storable/Server/Common.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Storable/Server/Common.hs @@ -0,0 +1,101 @@ +module Synthesizer.ALSA.Storable.Server.Common where + +import qualified Sound.ALSA.PCM as ALSA +import qualified Sound.ALSA.Sequencer.Event as Event + +import qualified Synthesizer.ALSA.Storable.Play as Play +import qualified Synthesizer.ALSA.EventList as MIDIEv +import Synthesizer.ALSA.EventList (StrictTime, ) + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL + +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import Sound.MIDI.Message.Channel (Channel, ) + +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified Sound.Sox.Frame as SoxFrame +import qualified System.Exit as Exit + +import Control.Category ((.), ) + +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric (zero, round, ) +import Prelude hiding (Real, round, break, id, (.), ) + + +channel :: Channel +channel = ChannelMsg.toChannel 0 + +sampleRate :: Num a => a +-- sampleRate = 24000 +-- sampleRate = 48000 +sampleRate = 44100 + +latency :: Int +latency = 0 +-- latency = 256 +-- latency = 1000 + +chunkSize :: SVL.ChunkSize +chunkSize = Play.defaultChunkSize + +lazySize :: SigG.LazySize +lazySize = + let (SVL.ChunkSize size) = chunkSize + in SigG.LazySize size + +periodTime :: Field.C t => t +periodTime = + let (SVL.ChunkSize size) = chunkSize + in ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate + +device :: Play.Device +device = Play.defaultDevice + +clientName :: MIDIEv.ClientName +clientName = MIDIEv.ClientName "Haskell-Synthesizer" + + +type Real = Float + + +{-# INLINE withMIDIEvents #-} +withMIDIEvents :: + (Double -> Double -> a -> IO b) -> + (EventList.T StrictTime [Event.T] -> a) -> IO b +withMIDIEvents action proc = + let rate = sampleRate + per = periodTime + in MIDIEv.withMIDIEvents clientName per rate $ + action per rate . proc + + +{-# INLINE play #-} +play :: + (RealField.C t, Additive.C y, ALSA.SampleFmt y) => + t -> t -> SigSt.T y -> IO () +play period rate = + Play.auto (Play.makeSink device period (round rate)) . + SigSt.append (SigSt.replicate chunkSize latency zero) +-- FiltG.delayPosLazySize chunkSize latency +-- FiltG.delayPos latency + +-- ToDo: do not record the empty chunk that is inserted for latency +{-# INLINE playAndRecord #-} +playAndRecord :: + (RealField.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) => + FilePath -> t -> t -> SigSt.T y -> IO Exit.ExitCode +playAndRecord fileName period rate = + let intRate = round rate + in Play.autoAndRecord fileName + (ALSA.SoundFmt {ALSA.sampleFreq = intRate}) + (Play.makeSink device period intRate) . + SigSt.append (SigSt.replicate chunkSize latency zero) diff --git a/src/Synthesizer/ALSA/Storable/Server/Run.hs b/src/Synthesizer/ALSA/Storable/Server/Run.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Storable/Server/Run.hs @@ -0,0 +1,331 @@ +module Synthesizer.ALSA.Storable.Server.Run where + +import qualified Synthesizer.MIDI.Example.Instrument as Instr +import Synthesizer.ALSA.Storable.Server.Common + (Real, withMIDIEvents, play, device, clientName, + sampleRate, lazySize, chunkSize, periodTime, channel, ) + +import qualified Synthesizer.MIDI.CausalIO.Process as MIO +import qualified Synthesizer.MIDI.Storable as MidiSt +import Synthesizer.MIDI.Storable (applyModulation, ) + +import qualified Synthesizer.ALSA.CausalIO.Process as PAlsa +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.Causal.Oscillator as OsciC +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC + +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.Interpolation.Module as Ip + +import qualified Synthesizer.Storable.Oscillator as OsciSt +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable, ) + +import qualified Synthesizer.Generic.Loop as LoopG +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import Control.Monad.Trans.State (evalState, ) +import Control.Category ((.), ) +import Control.Arrow (arr, second, (&&&), ) + +import Data.Tuple.HT (mapSnd, ) + +import NumericPrelude.Numeric (zero, (*>), (^?), ) +import Prelude hiding (Real, round, break, id, (.), ) + + + +volume :: IO () +volume = + putStrLn "run 'aconnect' to connect to the MIDI controller" >> + (withMIDIEvents play $ + SigSt.zipWith (*) + (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) . + evalState (MidiSt.controllerLinear channel VoiceMsg.mainVolume (0,1) (0.2::Real))) + +frequency :: IO () +frequency = + withMIDIEvents play $ + OsciSt.freqMod chunkSize Wave.sine zero . + evalState (MidiSt.controllerExponential channel VoiceMsg.modulation + (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real)) + + +{-# INLINE storableChunk #-} +storableChunk :: + (SigG.Read sig a, Storable a) => + sig a -> SV.Vector a +storableChunk chunk = + SigS.toStrictStorableSignal (SigG.length chunk) $ + SigG.toState chunk + +frequencyCausal :: IO () +frequencyCausal = + PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate + ((PIO.fromCausal $ + Causal.applyStorableChunk $ + OsciC.freqMod (fmap (0.99*) Wave.sine) zero) + . + arr storableChunk + . + (MIO.controllerExponential channel VoiceMsg.modulation + (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real))) + + +pitchBend :: IO () +pitchBend = + withMIDIEvents play $ + OsciSt.freqMod chunkSize Wave.sine zero . + evalState (MidiSt.pitchBend channel 2 (880/sampleRate::Real)) + +volumeFrequency :: IO () +volumeFrequency = + putStrLn "run 'aconnect' to connect to the MIDI controller" >> + (withMIDIEvents play $ + evalState (do + vol <- MidiSt.controllerLinear channel VoiceMsg.mainVolume (0,1) 0.5 + freq <- MidiSt.pitchBend channel 2 (880/sampleRate::Real) + return $ + SigSt.zipWith (*) vol + (OsciSt.freqMod chunkSize Wave.sine zero freq))) + +volumeFrequencyCausal :: IO () +volumeFrequencyCausal = + PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate + ((PIO.fromCausal $ + Causal.applyStorableChunk $ + FiltNRC.envelope + . + second (OsciC.freqMod Wave.sine zero)) + . + arr (uncurry (SV.zipWith (,))) + . + (arr storableChunk + . + MIO.controllerLinear channel VoiceMsg.mainVolume (0,0.99) (0.5::Real) + &&& + arr storableChunk + . + MIO.pitchBend channel 2 (880/sampleRate::Real))) + + +keyboard :: IO () +keyboard = + withMIDIEvents play $ +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . + SigSt.map (0.2*) . + evalState (MidiSt.sequence chunkSize channel Instr.tine) + +keyboardMulti :: IO () +keyboardMulti = + withMIDIEvents play $ +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . + SigSt.map (0.2*) . + evalState (MidiSt.sequenceMultiProgram chunkSize channel + (VoiceMsg.toProgram 2) + [Instr.pingDur, Instr.pingRelease, Instr.tine]) + +keyboardStereo :: IO () +keyboardStereo = + withMIDIEvents play $ +-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . + SigSt.map ((0.2::Real)*>) . + evalState (MidiSt.sequenceMultiProgram chunkSize channel + (VoiceMsg.toProgram 1) + [Instr.pingStereoRelease, Instr.tineStereo, + Instr.softString, Instr.softStringCausal]) + +keyboardPitchbend :: IO () +keyboardPitchbend = + withMIDIEvents play $ + SigSt.map ((0.2::Real)*>) . + evalState + (do bend <- MidiSt.pitchBend channel (2^?(2/12)) 1 + MidiSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) + +keyboardFM :: IO () +keyboardFM = + withMIDIEvents play $ + SigSt.map ((0.2::Real)*>) . + evalState + (do fm <- MidiSt.bendWheelPressure channel + 2 (10/sampleRate) 0.04 0.03 + MidiSt.sequenceModulated chunkSize fm channel Instr.stringStereoFM) + +keyboardDetuneFM :: IO () +keyboardDetuneFM = + withMIDIEvents play $ + SigSt.map ((0.2::Real)*>) . + evalState + (do fm <- MidiSt.bendWheelPressure channel + 2 (10/sampleRate) 0.04 0.03 + detune <- MidiSt.controllerLinear channel + VoiceMsg.vectorX (0,0.005) 0 + MidiSt.sequenceMultiModulated + chunkSize channel Instr.stringStereoDetuneFM + (applyModulation fm . + applyModulation detune)) + + +keyboardFilter :: IO () +keyboardFilter = + withMIDIEvents play $ + SigSt.map (0.2*) . + evalState + (do music <- MidiSt.sequence chunkSize channel Instr.pingRelease + freq <- MidiSt.controllerLinear channel + -- VoiceMsg.vectorY + (VoiceMsg.toController 21) + (100/sampleRate, 5000/sampleRate) + (700/sampleRate) + return $ + SigS.toStorableSignal chunkSize $ + SigS.map UniFilter.lowpass $ + SigS.modifyModulated + UniFilter.modifier + (SigS.map UniFilter.parameter $ + SigS.zipWith FiltR.Pole + (SigS.repeat (5 :: Real)) + (SigS.fromStorableSignal freq)) $ + SigS.fromStorableSignal music) + + +keyboardSample :: IO () +keyboardSample = + do piano <- Instr.readPianoSample + string <- Instr.readStringSample + let loopedString = mapSnd (LoopG.simple 8750 500) string + fadedString = mapSnd (LoopG.fade (undefined::Real) 8750 500) string + timeSineString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlSine 8750 500 string + timeZigZagString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlZigZag 8750 500 string + withMIDIEvents play $ + SigSt.map (0.2*) . + evalState (MidiSt.sequenceMultiProgram chunkSize channel + (VoiceMsg.toProgram 5) $ + Instr.sampledSound piano : + Instr.sampledSound string : + Instr.sampledSound loopedString : + Instr.sampledSound fadedString : + Instr.sampledSound timeSineString : + Instr.sampledSound timeZigZagString : + Instr.sampledSoundTimeLoop Instr.loopTimeModSine string 8750 500 : + Instr.sampledSoundTimeLoop Instr.loopTimeModZigZag string 8750 500 : + []) + + +keyboardVariousStereo :: IO () +keyboardVariousStereo = + do piano <- Instr.readPianoSample + string <- Instr.readStringSample + let loopedString = + LoopG.timeReverse lazySize Ip.linear Ip.linear + LoopG.timeControlZigZag 8750 500 string + withMIDIEvents play $ + SigSt.map ((0.2::Real)*>) . + evalState (MidiSt.sequenceMultiProgram chunkSize channel + (VoiceMsg.toProgram 0) $ + Instr.pingStereoRelease : + Instr.tineStereo : + Instr.softString : + Instr.sampledSoundDetuneStereo 0.001 piano : + Instr.sampledSoundDetuneStereo 0.002 loopedString : + Instr.sampledSoundDetuneStereoRelease 0.1 0.001 piano : + Instr.sampledSoundDetuneStereoRelease 0.3 0.002 loopedString : + []) + + +keyboardSampleTFM :: IO () +keyboardSampleTFM = + do instr <- Instr.readPianoSample + withMIDIEvents play $ + evalState + (do fm <- MidiSt.bendWheelPressure channel + 2 (10/sampleRate) 0.04 0.03 + speed <- MidiSt.controllerLinear channel + (VoiceMsg.toController 22) + (0,2) 1 + offset <- MidiSt.controllerLinear channel + (VoiceMsg.toController 21) + (0, fromIntegral (SVL.length (snd instr))) 0 + MidiSt.sequenceMultiModulated + chunkSize channel (Instr.timeModulatedSample instr) + (applyModulation fm . + applyModulation speed . + applyModulation offset)) + + +keyboardNoisePipe :: IO () +keyboardNoisePipe = + withMIDIEvents play $ + evalState + (do fm <- MidiSt.bendWheelPressure channel + 2 (10/sampleRate) 0.04 0.03 + resonance <- + MidiSt.controllerExponential channel + (VoiceMsg.toController 23) + (1, 100) 10 + MidiSt.sequenceMultiModulated + chunkSize channel Instr.colourNoise + (applyModulation fm . + applyModulation resonance)) + + +keyboardNoisyTone :: IO () +keyboardNoisyTone = + withMIDIEvents play $ + evalState + (do fm <- MidiSt.bendWheelPressure channel + 2 (10/sampleRate) 0.04 0.03 + speed <- MidiSt.controllerLinear channel + (VoiceMsg.toController 21) + (0,0.5) 0.1 + MidiSt.sequenceMultiModulated + chunkSize channel Instr.toneFromNoise + (applyModulation fm . + applyModulation speed)) + + +keyboardFilteredNoisyTone :: IO () +keyboardFilteredNoisyTone = + withMIDIEvents play $ + evalState + (do fm <- MidiSt.bendWheelPressure channel + 2 (10/sampleRate) 0.04 0.03 + {- + speed must never be zero, + since this requires to fetch unlimited data from future. + -} + speed <- MidiSt.controllerLinear channel + (VoiceMsg.toController 21) + (0.05,0.5) 0.1 + cutoff <- MidiSt.controllerExponential channel + (VoiceMsg.toController 22) + (1, 30) 10 + resonance <- MidiSt.controllerExponential channel + (VoiceMsg.toController 23) + (1, 20) 5 + MidiSt.sequenceMultiModulated + chunkSize channel Instr.toneFromFilteredNoise + (applyModulation fm . + applyModulation speed . + applyModulation cutoff . + applyModulation resonance)) + + + +keyboardCausal :: IO () +keyboardCausal = + PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate $ + arr (SV.map (0.2*)) + . + MIO.sequenceStorable channel (\ _pgm -> Instr.pingReleaseCausal) diff --git a/src/Synthesizer/ALSA/Storable/Server/Test.hs b/src/Synthesizer/ALSA/Storable/Server/Test.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ALSA/Storable/Server/Test.hs @@ -0,0 +1,582 @@ +module Synthesizer.ALSA.Storable.Server.Test where + +import qualified Synthesizer.MIDI.Example.Instrument as Instr +import Synthesizer.ALSA.Storable.Server.Common + (Real, withMIDIEvents, play, + sampleRate, chunkSize, channel, ) + +import qualified Sound.ALSA.Sequencer.Address as Addr +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.MIDI.Storable as MidiSt +import Synthesizer.MIDI.Storable ( + Instrument, chunkSizesFromLazyTime, ) + +import qualified Synthesizer.MIDI.EventList as MIDIEv +import Synthesizer.MIDI.EventList ( + LazyTime, StrictTime, Note(..), NoteBoundary(..), + matchNoteEvents, getSlice, getControllerEvents, ) + +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.Causal.Process as Causal +import Control.Arrow ((<<<), ) + +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Storable.Oscillator as OsciSt +import qualified Synthesizer.Storable.Signal as SigSt +-- import qualified Data.StorableVector.Lazy.Builder as Bld +import qualified Data.StorableVector.Lazy.Pattern as SigStV +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector as SV + +import qualified Synthesizer.State.Signal as SigS + +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import Sound.MIDI.Message.Channel.Voice (normalVelocity, ) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import Data.EventList.Relative.MixedBody ((/.), (./), ) + +import qualified Control.Monad.Trans.State.Strict as MS +import Control.Monad.Trans.State (evalState, gets, ) +import Control.Category ((.), ) + +import Data.Traversable (traverse, ) + +-- import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Chunky as NonNegChunky + +import Data.Maybe.HT (toMaybe, ) + +import NumericPrelude.Numeric (zero, round, (^?), ) +import Prelude hiding (Real, round, break, id, (.), ) + + + +frequency1 :: IO () +frequency1 = + withMIDIEvents play $ + const + (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real)) + +frequency2 :: IO () +frequency2 = + withMIDIEvents (const $ const print) $ + evalState (getControllerEvents channel VoiceMsg.mainVolume) + +frequency3 :: IO () +frequency3 = + withMIDIEvents (const $ const print) $ + evalState (getSlice Just) + + +keyboard1 :: IO () +keyboard1 = + withMIDIEvents play $ + const (Instr.ping 0 440) + +keyboard2 :: SigSt.T Real +keyboard2 = + let music :: Real -> EventList.T StrictTime (SigSt.T Real) + music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1) + in CutSt.arrange chunkSize $ + EventList.mapTime fromIntegral $ music 42 + +keyboard3 :: SigSt.T Real +keyboard3 = + let time :: Real -> Int + time t = round (t * sampleRate) + music :: Real -> EventList.T StrictTime (SigSt.T Real) + music x = + fromIntegral (time 0.2) /. + SigSt.take (time 0.4) (Instr.ping 0 x) ./ + music (x*1.01) + in CutSt.arrange chunkSize $ + EventList.mapTime fromIntegral $ music 110 + +makeLazyTime :: Real -> LazyTime +makeLazyTime t = + NonNegChunky.fromNumber $ + NonNegW.fromNumberMsg "keyboard time" $ + round (t * sampleRate) + +makeStrictTime :: Real -> StrictTime +makeStrictTime t = + NonNegW.fromNumberMsg "keyboard time" $ + round (t * sampleRate) + +pitch :: Int -> VoiceMsg.Pitch +pitch = VoiceMsg.toPitch + +defaultProgram :: VoiceMsg.Program +defaultProgram = VoiceMsg.toProgram 0 + +embedDefaultProgram :: + EventList.T StrictTime [NoteBoundary Bool] -> + EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)] +embedDefaultProgram = + fmap (fmap (\(NoteBoundary p v b) -> + NoteBoundary p v (toMaybe b defaultProgram))) + +keyboard4 :: SigSt.T Real +keyboard4 = + let {- + idInstr :: Real -> Real -> SigSt.T Real + idInstr _vel freq = SigSt.repeat chunkSize freq + -} +-- inf = time 0.4 + inf + music :: Int -> EventList.T StrictTime Note + music p = + makeStrictTime 0.2 /. +-- (pitch p, normalVelocity, inf) ./ + Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./ + music (p+1) + in CutSt.arrange chunkSize $ + EventList.mapTime fromIntegral $ + fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $ + music 0 + + +notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool) +notes0 p = + makeStrictTime 0.2 /. + (let (oct,pc) = divMod p 12 + in (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct))) + ./ + notes0 (p+1) + +notes1 :: EventList.T StrictTime (NoteBoundary Bool) +notes1 = + makeStrictTime 0.2 /. + (NoteBoundary (pitch 50) normalVelocity True) ./ + makeStrictTime 0.2 /. + (NoteBoundary (pitch 52) normalVelocity True) ./ + makeStrictTime 0.2 /. + (NoteBoundary (pitch 54) normalVelocity True) ./ + makeStrictTime 0.2 /. +-- (NoteBoundary (pitch 50) normalVelocity False) ./ + undefined + +notes2 :: EventList.T StrictTime [NoteBoundary Bool] +notes2 = + makeStrictTime 0.2 /. + [] ./ + makeStrictTime 0.2 /. + [] ./ + makeStrictTime 0.2 /. + [NoteBoundary (pitch 50) normalVelocity True] ./ + makeStrictTime 0.2 /. + [NoteBoundary (pitch 52) normalVelocity True] ./ + makeStrictTime 0.2 /. + [NoteBoundary (pitch 54) normalVelocity True] ./ + makeStrictTime 0.2 /. + [NoteBoundary (pitch 50) normalVelocity False] ./ + undefined + +notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)] +notes3 = + embedDefaultProgram $ + notes2 + +keyboard5 :: SigSt.T Real +keyboard5 = + CutSt.arrange chunkSize $ + EventList.mapTime fromIntegral $ + Gen.flatten $ + fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $ + matchNoteEvents $ + notes3 + +keyboard6 :: EventList.T StrictTime [Note] +keyboard6 = + matchNoteEvents $ + embedDefaultProgram $ + fmap (:[]) $ + notes1 + +keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)] +keyboard7 = + fmap (map (\ ~(Note _ p v _d) -> (p,v))) $ + keyboard6 + + +emptyEvents :: StrictTime -> EventList.T StrictTime [Event.T] +emptyEvents time = + let evs = EventList.cons time [] evs + in evs + + +arrangeSpaceLeak0 :: IO () +arrangeSpaceLeak0 = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState (Gen.sequence channel + (error "no sound" :: Instrument Real Real)) $ + emptyEvents 10 + +arrangeSpaceLeak1 :: IO () +arrangeSpaceLeak1 = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState + (Gen.sequenceModulated + (SigSt.iterate chunkSize (1+) 0) channel + (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $ + emptyEvents 10 + +makeNote :: Event.NoteEv -> Event.Pitch -> Event.T +makeNote typ pit = + Event.simple Addr.subscribers $ Event.NoteEv typ $ + Event.simpleNote (Event.Channel 0) pit Event.normalVelocity + +{- +a space leak can only be observed for more than one note, +maybe our 'break' improvement fixed the case for one played note +-} +arrangeSpaceLeak3 :: IO () +arrangeSpaceLeak3 = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState + (Gen.sequenceModulated + (SigSt.iterate chunkSize (1e-7 +) 1) channel + Instr.stringStereoFM) $ +-- (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $ + let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t)) + in -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $ + -- EventList.cons 10 [makeNote MIDI.NoteOn 64] $ + evs 10 + +arrangeSpaceLeak4 :: IO () +arrangeSpaceLeak4 = + SVL.writeFile "test.f32" $ + evalState + (do bend <- MidiSt.pitchBend channel (2^?(2/12)) 1 + MidiSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $ + let evs t = EventList.cons t ([]::[Event.T]) (evs (20-t)) + in evs 10 + +chordSpaceLeak1 :: IO () +chordSpaceLeak1 = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState (Gen.sequence channel Instr.pingDur) $ + let evs t = EventList.cons t [] (evs (20-t)) + in EventList.cons 10 [makeNote Event.NoteOn $ Event.Pitch 60] $ + EventList.cons 10 [makeNote Event.NoteOn $ Event.Pitch 64] $ + evs 10 + + +sequencePitchBend :: IO () +sequencePitchBend = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState + (let fm y = (EventListBT.cons $! y) 10 (fm (2-y)) + in Gen.sequenceModulated (fm 1) channel + (error "no sound" :: + PC.T Real -> Instrument Real Real)) $ + emptyEvents 10 + +sequencePitchBend1 :: IO () +sequencePitchBend1 = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState + (let fm y = EventListBT.cons y 10 (fm (2-y)) + instr :: PC.T Real -> Instrument Real Real + instr = error "no sound" + in Gen.sequenceCore + channel Gen.errorNoProgram + (Gen.Modulator (fm 1) Gen.advanceModulationChunk + (\note -> gets $ \c -> + Gen.renderInstrumentIgnoreProgram (instr c) note))) $ + emptyEvents 10 + +sequencePitchBend2 :: IO () +sequencePitchBend2 = + SVL.writeFile "test.f32" $ + let fm y = EventListBT.cons y 10 (fm (2-y)) + -- fm = EventListBT.cons 1 10 fm + instr :: PC.T Real -> Instrument Real Real + instr = error "no sound" + evs = EventList.cons 10 [] evs + md = + Gen.Modulator + (fm 1) + Gen.advanceModulationChunkPC + -- Gen.advanceModulationChunk + (\note -> gets $ \c -> + Gen.renderInstrumentIgnoreProgram (instr c) note) + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + Gen.applyModulator md $ + evs + +sequencePitchBend3 :: IO () +sequencePitchBend3 = + SVL.writeFile "test.f32" $ + let fm y = EventListBT.cons y 10 (fm (2-y)) + -- fm = EventListBT.cons 1 10 fm + instr :: PC.T Real -> Instrument Real Real + instr = error "no sound" + evs = EventList.cons 10 [] evs + modEvent note = + gets $ \c -> + Gen.renderInstrumentIgnoreProgram (instr c) note + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + flip evalState (fm 1) . + EventList.traverse + Gen.advanceModulationChunk + (traverse modEvent) $ + evs + +sequencePitchBend4 :: IO () +sequencePitchBend4 = + SVL.writeFile "test.f32" $ + let fm y = y : fm (2-y) + -- fm = repeat 1 + instr :: [Real] -> Instrument Real Real + instr = error "no sound" + evs = EventList.cons 10 [] evs + modEvent note = + gets $ \c -> + Gen.renderInstrumentIgnoreProgram (instr c) note + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + flip evalState (fm 1) . + EventList.traverse + Gen.advanceModulationChunk + (traverse modEvent) $ + evs + +sequencePitchBend4a :: IO () +sequencePitchBend4a = + SVL.writeFile "test.f32" $ + let fm y = y : fm (2-y) + -- fm = repeat 1 + instr :: [Real] -> Instrument Real Real + instr = error "no sound" + evs = EventList.cons 10 [] evs + modEvent note = + MS.gets $ \c -> + Gen.renderInstrumentIgnoreProgram (instr c) note + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + flip MS.evalState (fm 1) . + EventList.traverse + Gen.advanceModulationChunkStrict + (traverse modEvent) $ + evs + +sequencePitchBend4b :: IO () +sequencePitchBend4b = + SVL.writeFile "test.f32" $ + let fm y = y : fm (2-y) + -- fm = repeat 1 + instr :: [Real] -> Instrument Real Real + instr = error "no sound" + evs = EventList.cons 10 [] evs + in CutSt.arrange chunkSize . + Gen.flatten $ + EventList.foldrPair + (\t bs0 go s0 -> + let s1 = tail s0 + bs1 = + map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0 + in EventList.cons + (if null s1 then t else t) bs1 $ + go s1) + (const EventList.empty) evs (fm 1) + +sequencePitchBend4c :: IO () +sequencePitchBend4c = + SVL.writeFile "test.f32" $ + let fm y = y : fm (2-y) + -- fm = repeat 1 + instr :: [Real] -> Instrument Real Real + instr = error "no sound" + in CutSt.arrange chunkSize . + Gen.flatten . + EventList.fromPairList $ + foldr + (\(t,bs0) go s0 -> + let s1 = tail s0 + bs1 = + map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0 + in (if null s1 then t else t, bs1) : + go s1) + (const []) + (repeat (10,[])) + (fm 1) + +sequencePitchBend4d :: IO () +sequencePitchBend4d = + SVL.writeFile "test.f32" $ + let fm y = y : fm (2-y) + -- fm = repeat 1 + in CutSt.arrange chunkSize . + EventList.fromPairList $ + foldr + (\(t,b) go s0 -> + let s1 = tail s0 + in (if null s1 then t else t, + if null s1 then b else b) : + go s1) + (const []) + (repeat (10, SigSt.empty :: SigSt.T Real)) + (fm 1 :: [Real]) + +sequencePitchBend4e :: IO () +sequencePitchBend4e = + writeFile "test.txt" $ + foldr + (\c go s0 -> + let s1 = tail s0 + in (if null s1 then c else c) : + go s1) + (const []) + (repeat 'a') + (iterate not False) + -- (repeat True) + +sequencePitchBend5 :: IO () +sequencePitchBend5 = + SVL.writeFile "test.f32" $ + let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0 + instr :: SigSt.T Real -> Instrument Real Real + instr = error "no sound" + evs = EventList.cons 10 [] evs + modEvent note = + gets $ \c -> + Gen.renderInstrumentIgnoreProgram (instr c) note + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + flip evalState (fm 1e-6) . + EventList.traverse + Gen.advanceModulationChunk + (traverse modEvent) $ + evs + +dummySound :: Instrument Real Real +dummySound = + \vel freq dur -> + SigStV.take (chunkSizesFromLazyTime dur) $ + SigSt.repeat chunkSize (vel + 1e-3*freq) + +sequenceStaccato :: IO () +sequenceStaccato = + SVL.writeFile "test.f32" $ + let evs t = + EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $ + EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $ + evs (20-t) + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + EventList.mapBody + (map (Gen.renderInstrumentIgnoreProgram dummySound)) . + MIDIEv.matchNoteEvents . + MIDIEv.embedPrograms defaultProgram $ + evs 10 + +sequenceStaccato3 :: IO () +sequenceStaccato3 = + SVL.writeFile "test.f32" $ + let evs t = + EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $ + EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $ + evs (20-t) + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + EventList.mapBody + (map (Gen.renderInstrumentIgnoreProgram dummySound)) . + MIDIEv.matchNoteEvents $ + evs 10 + +sequenceStaccato2 :: IO () +sequenceStaccato2 = + SVL.writeFile "test.f32" $ + let p = Event.Pitch 60 + evs t = + EventList.cons t [makeNote Event.NoteOn p] $ + EventList.cons t [makeNote Event.NoteOff p] $ + evs (20-t) + in CutSt.arrange chunkSize . + EventList.mapTime fromIntegral . + Gen.flatten . + EventList.mapBody + (map (Gen.renderInstrumentIgnoreProgram dummySound)) . + MIDIEv.matchNoteEvents . + MIDIEv.embedPrograms defaultProgram . + evalState (MIDIEv.getNoteEvents channel) $ + evs 10 + +sequenceStaccato1 :: IO () +sequenceStaccato1 = + SVL.writeFile "test.f32" $ + CutSt.arrange chunkSize $ + evalState (Gen.sequence channel dummySound) $ + let p = Event.Pitch 60 + evs t = + EventList.cons t [makeNote Event.NoteOn p] $ + EventList.cons t [makeNote Event.NoteOff p] $ + evs (20-t) + in evs 10 + + +speed :: IO () +speed = + let _sig = + Causal.apply + (Instr.softStringCausalProcess 440 <<< + Instr.softStringReleaseEnvelopeCausalProcess 0) + (SigS.repeat True) + sig = + Causal.apply + (Instr.softStringCausalProcess 440) + (SigS.repeat 1) + in SV.writeFile "speed.f32" $ + SigS.runViewL sig + (\next s -> fst $ SV.unfoldrN 1000000 next s) + +speedChunky :: IO () +speedChunky = + let sig = + Causal.apply + (Instr.softStringCausalProcess 440 <<< + Instr.softStringReleaseEnvelopeCausalProcess 0) + (SigS.repeat True) + in SVL.writeFile "speed.f32" $ + SigSt.take 1000000 $ + SigS.toStorableSignal (SVL.chunkSize 100) sig +{- + SigS.runViewL sig + (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s)) +-} + +speedArrange :: IO () +speedArrange = + let sig = + Causal.apply + (Instr.softStringCausalProcess 440 <<< + Instr.softStringReleaseEnvelopeCausalProcess 0) + (SigS.repeat True) + sigSt = + SigS.toStorableSignal (SVL.chunkSize 100) sig + in SVL.writeFile "speed.f32" $ + SigSt.take 1000000 $ + CutSt.arrangeEquidist (SVL.chunkSize 100) $ + EventList.fromPairList [(10000,sigSt)] diff --git a/src/Synthesizer/CausalIO/ALSA/MIDIControllerSelection.hs b/src/Synthesizer/CausalIO/ALSA/MIDIControllerSelection.hs deleted file mode 100644 --- a/src/Synthesizer/CausalIO/ALSA/MIDIControllerSelection.hs +++ /dev/null @@ -1,112 +0,0 @@ -module Synthesizer.CausalIO.ALSA.MIDIControllerSelection ( - fromChannel, - filter, - T(Cons), - - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - ) where - -import qualified Synthesizer.CausalIO.Process as PIO -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv -import qualified Synthesizer.MIDIValue as MV - -import qualified Sound.ALSA.Sequencer.Event as Event - --- import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.TimeTime as EventListTT - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field - -import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import Data.Tuple.HT (mapSnd, ) - -import Control.Arrow (Arrow, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding ((.), filter, ) -import Prelude () - - - -fromChannel :: - (Arrow arrow) => - MIDIEv.Channel -> - arrow - (EventListTT.T MIDIEv.StrictTime [Event.T]) - (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)]) -fromChannel chan = - PAlsa.mapMaybe $ PCS.maybeController chan - - --- see PCS.mapInsertMany -mapInsertMany :: - (Ord key) => - [(key,a)] -> Map.Map key a -> Map.Map key a -mapInsertMany assignments inits = - foldl (flip (uncurry Map.insert)) inits assignments - - - -data T a = - Cons PCS.Controller (Int -> a) a - -filter :: - [T a] -> - PIO.T - (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)]) - (PCS.T Int a) -filter mapping = - let dict = - Map.fromList $ - zipWith (\n (Cons cc f _init) -> (cc, (n, f))) - [0 ..] mapping - in PIO.mapAccum - (\evs curMap -> - let ctrlEvs = - fmap (Maybe.mapMaybe (\(cc, val) -> - fmap (mapSnd ($val)) $ Map.lookup cc dict)) evs - in (PCS.Cons curMap ctrlEvs, - mapInsertMany - (concat $ EventListTT.getBodies ctrlEvs) - curMap)) - (Map.fromList $ zip [0..] $ - map (\(Cons _cc _f initVal) -> initVal) mapping) - - -controllerLinear :: - (Field.C y) => - MIDIEv.Controller -> - (y,y) -> y -> - T y -controllerLinear ctrl bnd initial = - Cons (PCS.Controller ctrl) (MV.controllerLinear bnd) initial - -controllerExponential :: - (Trans.C y) => - MIDIEv.Controller -> - (y,y) -> y -> - T y -controllerExponential ctrl bnd initial = - Cons (PCS.Controller ctrl) (MV.controllerExponential bnd) initial - -pitchBend :: - (Trans.C y) => - y -> y -> - T y -pitchBend range center = - Cons PCS.PitchBend (MV.pitchBend range center) center - -channelPressure :: - (Trans.C y) => - y -> y -> - T y -channelPressure maxVal initial = - Cons PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial diff --git a/src/Synthesizer/CausalIO/ALSA/MIDIControllerSet.hs b/src/Synthesizer/CausalIO/ALSA/MIDIControllerSet.hs deleted file mode 100644 --- a/src/Synthesizer/CausalIO/ALSA/MIDIControllerSet.hs +++ /dev/null @@ -1,156 +0,0 @@ -module Synthesizer.CausalIO.ALSA.MIDIControllerSet ( - T, - fromChannel, - slice, PCS.Controller(..), - - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - bendWheelPressure, - ) where - -import qualified Synthesizer.CausalIO.Process as PIO -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS -import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv -import qualified Synthesizer.MIDIValue.BendModulation as BM -import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP -import qualified Synthesizer.MIDIValue as MV - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Sound.ALSA.Sequencer.Event as Event - --- import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.MixedTime as EventListMT - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field -import qualified Algebra.RealRing as RealRing - -import qualified Control.Monad.Trans.State as MS - -import qualified Data.Accessor.Basic as Acc - -import qualified Data.Map as Map - -import Data.Traversable (Traversable, traverse, ) -import Data.Foldable (traverse_, ) - -import Control.Arrow (Arrow, arr, ) -import Control.Category ((.), ) - -import qualified Data.Maybe as Maybe -import Data.Maybe.HT (toMaybe, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding ((.), ) -import Prelude () - - - --- see PCS.mapInsertMany -mapInsertMany :: - (Ord key) => - [(key,a)] -> Map.Map key a -> Map.Map key a -mapInsertMany assignments inits = - foldl (flip (uncurry Map.insert)) inits assignments - - -fromChannel :: - MIDIEv.Channel -> - PIO.T - (EventListTT.T MIDIEv.StrictTime [Event.T]) - (PCS.T PCS.Controller Int) -fromChannel chan = - (PIO.traverse Map.empty $ \evs0 -> do - initial <- MS.get - fmap (PCS.Cons initial) $ - traverse (\ys -> MS.modify (mapInsertMany ys) >> return ys) evs0) - . - PAlsa.mapMaybe (PCS.maybeController chan) - - -type T arrow y = - arrow - (PCS.T PCS.Controller Int) - (EventListBT.T PC.ShortStrictTime y) - - -slice :: - (Arrow arrow) => - PCS.Controller -> - (Int -> y) {- ^ This might be a function from "Synthesizer.MIDIValue" - or "Synthesizer.Dimensional.MIDIValue" -} -> - y -> - T arrow y -slice c f deflt = - arr $ \(PCS.Cons initial stream) -> - let yin = maybe deflt f $ Map.lookup c initial - in PC.subdivideLongStrict $ - EventListMT.consBody yin $ - flip MS.evalState yin $ - traverse - (\ys -> traverse_ (MS.put . f) ys >> MS.get) $ - fmap - (Maybe.mapMaybe - (\(ci,a) -> toMaybe (c==ci) a)) - stream - - -controllerLinear :: - (Field.C y, Arrow arrow) => - MIDIEv.Controller -> - (y,y) -> y -> - T arrow y -controllerLinear ctrl bnd initial = - slice (PCS.Controller ctrl) (MV.controllerLinear bnd) initial - -controllerExponential :: - (Trans.C y, Arrow arrow) => - MIDIEv.Controller -> - (y,y) -> y -> - T arrow y -controllerExponential ctrl bnd initial = - slice (PCS.Controller ctrl) (MV.controllerExponential bnd) initial - -pitchBend :: - (Trans.C y, Arrow arrow) => - y -> y -> - T arrow y -pitchBend range center = - slice PCS.PitchBend (MV.pitchBend range center) center - -channelPressure :: - (Trans.C y, Arrow arrow) => - y -> y -> - T arrow y -channelPressure maxVal initial = - slice PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial - -bendWheelPressure :: - (RealRing.C y, Trans.C y, Arrow arrow) => - Int -> y -> y -> - T arrow (BM.T y) -bendWheelPressure pitchRange wheelDepth pressDepth = - arr $ \(PCS.Cons initial stream) -> - let set key field = - maybe id (Acc.set field) $ - Map.lookup key initial - yin = - set PCS.PitchBend BWP.bend $ - set (PCS.Controller VoiceMsg.modulation) BWP.wheel $ - set PCS.Pressure BWP.pressure $ - BWP.deflt - in PC.subdivideLongStrict $ - fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $ - EventListMT.consBody yin $ - flip MS.evalState yin $ - traverse (\ys0 -> traverse_ MS.put ys0 >> MS.get) $ - fmap Maybe.catMaybes $ - flip MS.evalState BWP.deflt $ - traverse (traverse PCS.checkBendWheelPressure) stream diff --git a/src/Synthesizer/CausalIO/ALSA/Process.hs b/src/Synthesizer/CausalIO/ALSA/Process.hs deleted file mode 100644 --- a/src/Synthesizer/CausalIO/ALSA/Process.hs +++ /dev/null @@ -1,728 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Synthesizer.CausalIO.ALSA.Process ( - Events, - playFromEvents, - - slice, - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - bendWheelPressure, - constant, - - Instrument, - Bank, - GateChunk, - noteEvents, - embedPrograms, - applyInstrument, - applyModulatedInstrument, - flattenControlSchedule, - applyModulation, - arrangeStorable, - sequenceCore, - sequenceModulated, - sequenceModulatedMultiProgram, - sequenceStorable, - - -- auxiliary function - initWith, - mapMaybe, - ) where - -import qualified Synthesizer.CausalIO.Gate as Gate -import qualified Synthesizer.CausalIO.Process as PIO - -import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv -import qualified Synthesizer.Storable.ALSA.Play as Play -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Generic.Cut as CutG -import qualified Synthesizer.Zip as Zip -import Synthesizer.EventList.ALSA.MIDI (StrictTime, ) - -import qualified Synthesizer.MIDIValue.BendModulation as BM -import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP -import qualified Synthesizer.MIDIValue as MV - -import qualified Sound.ALSA.PCM as PCM -import qualified Sound.ALSA.Sequencer.Event as Event - -import qualified Sound.MIDI.ALSA.Check as Check -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import Control.DeepSeq (NFData, rnf, ) - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Absolute.TimeBody as AbsEventList - -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Class as NonNeg - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealField as RealField -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field -import qualified Algebra.Additive as Additive -import qualified Algebra.ToInteger as ToInteger - -import qualified Data.StorableVector as SV -import qualified Data.StorableVector.ST.Strict as SVST -import Foreign.Storable (Storable, ) - -import Control.Exception (bracket, ) - -import qualified Control.Monad.Trans.Writer as MW -import qualified Control.Monad.Trans.State as MS -import qualified Control.Monad.Trans.Class as MT -import Control.Monad.IO.Class (liftIO, ) - -import qualified Data.Traversable as Trav -import Data.Traversable (Traversable, ) -import Data.Foldable (traverse_, ) - -import Control.Arrow (Arrow, arr, (^<<), (<<^), ) -import Control.Category ((.), ) - -import qualified Data.Map as Map - -import qualified Data.List.HT as ListHT -import qualified Data.Maybe as Maybe -import Data.Monoid (Monoid, mempty, mappend, ) -import Data.Maybe (maybeToList, ) -import Data.Tuple.HT (mapFst, mapPair, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding ((.), sequence, ) -import Prelude () - - -type Events = EventListTT.T StrictTime [Event.T] - -playFromEvents :: - (RealField.C time, PCM.SampleFmt a, Additive.C a) => - Play.Device -> MIDIEv.ClientName -> time -> time -> PCM.SampleFreq -> - PIO.T Events (SV.Vector a) -> - IO () -playFromEvents device name latency beat rate - (PIO.Cons next create delete) = - let sink = Play.makeSink device beat rate - rateFloat = fromIntegral rate - in MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList -> - PCM.withSoundSink sink $ \to -> -{- - Play.writeLazy sink to - (SVL.replicate - (SVL.chunkSize $ round (beat * rateFloat)) - (round (latency * rateFloat)) - (zero::Float)) --} - Play.write sink to - (SV.replicate (round (latency * rateFloat)) zero) >> - (bracket create delete $ \state -> - let loop getEvs0 s0 = - case getEvs0 of - [] -> return () - getEvents : getEvs1 -> do - evs <- getEvents - (pcm, s1) <- next evs s0 - Play.write sink to pcm - loop getEvs1 s1 - in loop getEventsList state) - - -initWith :: - (y -> c) -> - c -> - PIO.T - (EventListTT.T StrictTime [y]) - (EventListBT.T PC.ShortStrictTime c) -initWith f initial = - PIO.traverse initial $ - \evs0 -> do - y0 <- MS.get - fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $ - Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0 - -slice :: - (Event.T -> Maybe Int) -> - (Int -> y) -> y -> - PIO.T - Events - (EventListBT.T PC.ShortStrictTime y) -slice select f initial = - initWith f initial . mapMaybe select - - - -mapMaybe :: - (Arrow arrow, Functor f) => - (a -> Maybe b) -> - arrow (f [a]) (f [b]) -mapMaybe f = - arr $ fmap $ Maybe.mapMaybe f - -catMaybes :: - (Arrow arrow, Functor f) => - arrow (f [Maybe a]) (f [a]) -catMaybes = - arr $ fmap Maybe.catMaybes - -traverse :: - (Traversable f) => - s -> (a -> MS.State s b) -> - PIO.T (f [a]) (f [b]) -traverse initial f = - PIO.traverse initial (Trav.traverse (Trav.traverse f)) - - -controllerLinear :: - (Field.C y) => - MIDIEv.Channel -> - MIDIEv.Controller -> - (y,y) -> y -> - PIO.T - Events - (EventListBT.T PC.ShortStrictTime y) -controllerLinear chan ctrl bnd initial = - slice (Check.controller chan ctrl) - (MV.controllerLinear bnd) initial - -controllerExponential :: - (Trans.C y) => - MIDIEv.Channel -> - MIDIEv.Controller -> - (y,y) -> y -> - PIO.T - Events - (EventListBT.T PC.ShortStrictTime y) -controllerExponential chan ctrl bnd initial = - slice (Check.controller chan ctrl) - (MV.controllerExponential bnd) initial - -pitchBend :: - (Trans.C y) => - MIDIEv.Channel -> - y -> y -> - PIO.T - Events - (EventListBT.T PC.ShortStrictTime y) -pitchBend chan range center = - slice (Check.pitchBend chan) - (MV.pitchBend range center) center - -channelPressure :: - (Trans.C y) => - MIDIEv.Channel -> - y -> y -> - PIO.T - Events - (EventListBT.T PC.ShortStrictTime y) -channelPressure chan maxVal initial = - slice (Check.channelPressure chan) - (MV.controllerLinear (zero,maxVal)) initial - -bendWheelPressure :: - (RealRing.C y, Trans.C y) => - MIDIEv.Channel -> - Int -> y -> y -> - PIO.T - Events - (EventListBT.T PC.ShortStrictTime (BM.T y)) -bendWheelPressure chan - pitchRange wheelDepth pressDepth = - let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth - in initWith toBM (toBM BWP.deflt) - . - catMaybes - . - traverse BWP.deflt (AlsaPC.checkBendWheelPressure chan) - - --- might be moved to synthesizer-core -constant :: - (Arrow arrow) => - y -> arrow Events (EventListBT.T PC.ShortStrictTime y) -constant y = arr $ - EventListBT.singleton y . - NonNegW.fromNumberMsg "CausalIO.ALSA.constant" . - fromIntegral . - EventListTT.duration - -_constant :: - (Arrow arrow, CutG.Read input) => - y -> arrow input (EventListBT.T PC.ShortStrictTime y) -_constant y = arr $ - EventListBT.singleton y . - NonNegW.fromNumberMsg "CausalIO.ALSA.constant" . - CutG.length - - - -noteEvents :: - (Arrow arrow) => - MIDIEv.Channel -> - arrow - (EventListTT.T StrictTime [Event.T]) - (EventListTT.T StrictTime - [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)]) -noteEvents chan = - mapMaybe $ MIDIEv.checkNoteEvent chan - - -embedPrograms :: - MIDIEv.Program -> - PIO.T - (EventListTT.T StrictTime - [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)]) - (EventListTT.T StrictTime - [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)]) -embedPrograms initPgm = - catMaybes . - traverse initPgm MIDIEv.embedProgramState - - -type GateChunk = Gate.Chunk MIDIEv.Velocity -type Instrument y chunk = y -> y -> PIO.T GateChunk chunk -type Bank y chunk = MIDIEv.Program -> Instrument y chunk - - - -{- -for distinction of notes with the same pitch - -We must use Integer instead of Int, in order to avoid an overflow -that would invalidate the check for unmatched NoteOffs -that is based on comparison of the NoteIds. -We cannot re-use NoteIds easily, -since the events at one time point are handled out of order. --} -newtype NoteId = NoteId Integer - deriving (Show, Eq, Ord) - -succNoteId :: NoteId -> NoteId -succNoteId (NoteId n) = NoteId (n+1) - -flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId] -flattenNoteIdRange (start,afterEnd) = - takeWhile ( rnf (NonNegW.toNumber t)) . - unwrapNoteOffList - -instance Monoid NoteOffList where - mempty = NoteOffList (EventListTT.pause mempty) - mappend (NoteOffList xs) (NoteOffList ys) = - NoteOffList (mappend xs ys) - -{- | -The function defined here are based on the interpretation -of event lists as piecewise constant signals. -They do not fit to the interpretation of atomic events. -Because e.g. it makes no sense to split an atomic event into two instances by splitAt, -and it is also not clear, whether dropping the first chunk -shall leave a chunk of length zero -or remove that chunk completely. --} -instance CutG.Transform NoteOffList where - take n (NoteOffList xs) = - NoteOffList $ - EventListTT.takeTime - (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs - drop n (NoteOffList xs) = - NoteOffList $ - EventListTT.dropTime - (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs - splitAt n (NoteOffList xs) = - mapPair (NoteOffList, NoteOffList) $ - EventListTT.splitAtTime - (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs - - -- cf. ChunkySize.dropMarginRem - dropMarginRem = - CutG.dropMarginRemChunky - (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList) - - reverse (NoteOffList xs) = - NoteOffList . EventListTT.reverse $ xs - - -findEvent :: - (a -> Bool) -> - EventListTT.T StrictTime [a] -> - (EventListTT.T StrictTime [a], Maybe a) -findEvent p = - EventListTT.foldr - (\t -> mapFst (EventListMT.consTime t)) - (\evs rest -> - case ListHT.break p evs of - (prefix, suffix) -> - mapFst (EventListMT.consBody prefix) $ - case suffix of - [] -> rest - ev:_ -> (EventListTT.pause mempty, Just ev)) - (EventListBT.empty, Nothing) - -gateFromNoteOffs :: - (MIDIEv.Pitch, NoteId) -> - NoteOffList -> - GateChunk -gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) = - let dur = EventListTT.duration noteOffs - (sustain, mEnd) = - findEvent - (\bnd -> - case bnd of - -- AllNotesOff -> True - NoteBoundary endPitch _ noteId -> - pitchNoteId == (endPitch, noteId)) - noteOffs - in Gate.chunk dur $ - flip fmap mEnd $ \end -> - (EventListTT.duration sustain, - case end of - NoteBoundary _ endVel _ -> endVel - {- - AllNotesOff -> - VoiceMsg.toVelocity VoiceMsg.normalVelocity -} ) - - -data NoteBoundary a = - NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a --- | AllSoundOff - deriving (Eq, Show) - -{- | -We count NoteIds per pitch, -such that the pair (pitch,noteId) identifies a note. -We treat nested notes in a first-in-first-out order (FIFO). -E.g. - -> On, On, On, Off, Off, Off - -is interpreted as - -> On 0, On 1, On 2, Off 0, Off 1, Off 2 - -NoteOffs without previous NoteOns are thrown away. --} -assignNoteIds :: - (Traversable f) => - PIO.T - (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)]) - (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) -assignNoteIds = - fmap concat - ^<< - traverse Map.empty (\bnd -> - case bnd of - MIDIEv.AllNotesOff -> do - notes <- MS.get - MS.put Map.empty - return $ - concatMap (\(pitch, range) -> - map - (\noteId -> - NoteBoundary pitch - (VoiceMsg.toVelocity VoiceMsg.normalVelocity) - (noteId, Nothing)) - (flattenNoteIdRange range)) $ - Map.toList notes - MIDIEv.NoteBoundary pitch vel mpgm -> - fmap (fmap (\noteId -> - NoteBoundary pitch vel (noteId,mpgm))) $ - case mpgm of - Nothing -> do - mNoteId <- MS.gets (Map.lookup pitch) - case mNoteId of - Nothing -> return [] - Just (nextNoteOffId, nextNoteOnId) -> - if nextNoteOffId >= nextNoteOnId - then return [] - else do - MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId)) - return [nextNoteOffId] - Just _ -> do - mNoteId <- MS.gets (Map.lookup pitch) - let (nextNoteOffId, nextNoteOnId) = - case mNoteId of - Nothing -> (NoteId 0, NoteId 0) - Just ids -> ids - - MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId)) - return [nextNoteOnId]) - -applyInstrumentCore :: - (Arrow arrow, Trans.C y) => - ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) -> - (MIDIEv.Program -> y -> y -> PIO.T gateCtrl chunk) -> - arrow - (EventListTT.T StrictTime - [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) - (Zip.T - NoteOffList - (EventListTT.T StrictTime [PIO.T noteOffListCtrl chunk])) -applyInstrumentCore makeGate bank = arr $ - uncurry Zip.Cons . - mapFst NoteOffList . - EventListTT.unzip . - fmap (ListHT.unzipEithers . fmap (\ev -> - case ev of --- MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff - NoteBoundary pitch vel (noteId, mpgm) -> - case mpgm of - Nothing -> Left $ NoteBoundary pitch vel noteId - Just pgm -> - Right $ - bank pgm (MV.velocity vel) - (MV.frequencyFromPitch pitch) - <<^ - makeGate (pitch, noteId))) - -applyInstrument :: - (Arrow arrow, Trans.C y) => - Bank y chunk -> - arrow - (EventListTT.T StrictTime - [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) - (Zip.T - NoteOffList - (EventListTT.T StrictTime [PIO.T NoteOffList chunk])) -applyInstrument = applyInstrumentCore gateFromNoteOffs - - -type ModulatedBank y ctrl chunk = - MIDIEv.Program -> y -> y -> - PIO.T (Zip.T GateChunk ctrl) chunk - -applyModulatedInstrument :: - (Arrow arrow, Trans.C y, CutG.Read ctrl) => - ModulatedBank y ctrl chunk -> - arrow - (Zip.T - (EventListTT.T StrictTime - [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) - ctrl) - (Zip.T - (Zip.T NoteOffList ctrl) - (EventListTT.T StrictTime - [PIO.T (Zip.T NoteOffList ctrl) chunk])) -applyModulatedInstrument bank = - (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) -> - Zip.Cons (Zip.Cons noteOffs ctrl) events) - ^<< - Zip.arrowFirst - (applyInstrumentCore - (Zip.arrowFirst . gateFromNoteOffs) bank) - - -{- | -Turn an event list with bundles of elements -into an event list with single events. -ToDo: Move to event-list package? --} -flatten :: - (NonNeg.C time) => - a -> - EventListTT.T time [a] -> - EventListTT.T time a -flatten empty = - EventListTT.foldr - EventListMT.consTime - (\bt xs -> - uncurry EventListMT.consBody $ - case bt of - [] -> (empty, xs) - b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs)) - EventListBT.empty - - -flattenControlSchedule :: - (Monoid chunk, Arrow arrow) => - arrow - (Zip.T ctrl - (EventListTT.T StrictTime [PIO.T ctrl chunk])) - (Zip.T ctrl - (EventListTT.T StrictTime (PIO.T ctrl chunk))) -flattenControlSchedule = arr $ - \(Zip.Cons ctrl evs) -> - -- Zip.consChecked "flattenControlSchedule" ctrl $ - Zip.Cons ctrl $ - flatten (arr (const mempty)) evs - - - -data CausalState a b = - forall state. - CausalState - (a -> state -> IO (b, state)) - (state -> IO ()) - state - -_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b) -_applyChunkSimple (CausalState next delete state0) input = do - (output, state1) <- next input state0 - return (output, CausalState next delete state1) - -applyChunk :: - (CutG.Read a, CutG.Read b) => - CausalState a b -> a -> IO (b, Maybe (CausalState a b)) -applyChunk (CausalState next delete state0) input = do - (output, state1) <- next input state0 - cs <- - if CutG.length output < CutG.length input - then do - delete state1 - return Nothing - else return $ Just $ CausalState next delete state1 - return (output, cs) - --- could be moved to synthesizer-core -applyModulation :: - (CutG.Transform ctrl, CutG.NormalForm ctrl, - CutG.Read chunk, - Monoid time, ToInteger.C time) => - PIO.T - (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk))) - (EventListTT.T time chunk) -applyModulation = PIO.Cons - (\(Zip.Cons ctrl evs) acc0 -> do - acc1 <- mapM (flip applyChunk ctrl) acc0 - let (accChunks, acc2) = unzip acc1 - - (newChunks, newAcc) <- - MW.runWriterT $ - flip MS.evalStateT ctrl $ - EventListTT.mapM - (\time -> do - ctrl_ <- MS.gets (CutG.drop (fromIntegral time)) - MS.put ctrl_ - return (case CutG.evaluateHead ctrl_ of () -> time)) - (\(PIO.Cons next create delete) -> do - state0 <- liftIO create - (chunk, state1) <- - liftIO . applyChunk (CausalState next delete state0) - =<< MS.get - MT.lift $ MW.tell $ maybeToList state1 - return chunk) - evs - - return - (EventListTM.prependBodyEnd - (EventList.fromPairList $ - map ((,) mempty) accChunks) - newChunks, - Maybe.catMaybes acc2 ++ newAcc)) - - (return []) - (mapM_ (\(CausalState _ close state) -> close state)) - -arrangeStorable :: - (Arrow arrow, Storable a, Additive.C a) => - arrow - (EventListTT.T StrictTime (SV.Vector a)) - (SV.Vector a) -arrangeStorable = - arr $ \evs -> - SVST.runSTVector (do - v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero - mapM_ (uncurry $ CutSt.addChunkToBuffer v) $ - AbsEventList.toPairList $ - AbsEventList.mapTime fromIntegral $ - EventList.toAbsoluteEventList 0 $ - EventListTM.switchTimeR const evs - return v) - - - -sequenceCore :: - (Monoid chunk, CutG.Read chunk, Trans.C y) => - MIDIEv.Channel -> - Bank y chunk -> - PIO.T Events (EventListTT.T StrictTime chunk) -sequenceCore channel bank = - applyModulation - . - flattenControlSchedule - . - applyInstrument bank - . - assignNoteIds - . - embedPrograms (VoiceMsg.toProgram 0) - . - noteEvents channel - - -sequenceModulated :: - (Monoid chunk, CutG.Read chunk, - CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => - MIDIEv.Channel -> - ModulatedBank y ctrl chunk -> - PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk) -sequenceModulated channel bank = - applyModulation - . - flattenControlSchedule - . - applyModulatedInstrument bank - . - Zip.arrowFirst - (assignNoteIds - . - embedPrograms (VoiceMsg.toProgram 0) - . - noteEvents channel) - - -sequenceModulatedMultiProgram :: - (Monoid chunk, CutG.Read chunk, - CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => - MIDIEv.Channel -> - MIDIEv.Program -> - ModulatedBank y ctrl chunk -> - PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk) -sequenceModulatedMultiProgram channel initPgm bank = - applyModulation - . - flattenControlSchedule - . - applyModulatedInstrument bank - . - Zip.arrowFirst - (assignNoteIds - . - embedPrograms initPgm - . - noteEvents channel) - - -sequenceStorable :: - (Storable a, Additive.C a, Trans.C y) => - MIDIEv.Channel -> - Bank y (SV.Vector a) -> - PIO.T Events (SV.Vector a) -sequenceStorable channel bank = - arrangeStorable - . - sequenceCore channel bank diff --git a/src/Synthesizer/Dimensional/ALSA/MIDI.hs b/src/Synthesizer/Dimensional/ALSA/MIDI.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/MIDI.hs +++ /dev/null @@ -1,451 +0,0 @@ -{- | -Convert MIDI events of a MIDI controller to a control signal. --} -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Dimensional.ALSA.MIDI where - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC -import qualified Synthesizer.EventList.ALSA.MIDI as AlsaEL -import qualified Synthesizer.Generic.ALSA.MIDI as AlsaG -import Synthesizer.EventList.ALSA.MIDI - (Channel, Controller, Note(Note), Program, ) -import Synthesizer.Generic.ALSA.MIDI (errorNoProgram, ) - -import qualified Sound.ALSA.Sequencer.Event as Event - -import qualified Synthesizer.Dimensional.MIDIValue as DMV -import qualified Synthesizer.MIDIValue as MV -import qualified Sound.MIDI.ALSA.Check as Check - -import qualified Synthesizer.Dimensional.Causal.Process as Causal -import qualified Synthesizer.Dimensional.Causal.Filter as Filt - -import qualified Synthesizer.Dimensional.Rate as Rate -import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR -import qualified Synthesizer.Dimensional.Signal.Private as SigA -import qualified Synthesizer.Dimensional.Process as Proc -import qualified Synthesizer.Dimensional.Amplitude as Amp -import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA -import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA -import qualified Synthesizer.Dimensional.Wave as WaveD --- import qualified Synthesizer.Dimensional.RateAmplitude.Cut as CutA - -import qualified Synthesizer.Basic.Wave as Wave - -import Synthesizer.Dimensional.Causal.Process ((<<<), ) -import Synthesizer.Dimensional.Process (($:), ) - -import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.ChunkySize as ChunkySize - -import qualified Synthesizer.Generic.Cut as CutG -import qualified Synthesizer.Generic.Signal2 as SigG2 -import qualified Synthesizer.Generic.Signal as SigG -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Storable.Signal as SigSt --- import qualified Data.StorableVector.Lazy.Pattern as SigStV -import qualified Data.StorableVector.Lazy as SVL - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -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.MixedTime as EventListMT --- import qualified Data.EventList.Relative.BodyTime as EventListBT - -import Foreign.Storable (Storable, ) - --- import qualified Algebra.NonNegative as NonNeg -import qualified Number.NonNegative as NonNegW -import qualified Number.NonNegativeChunky as Chunky - --- import qualified Numeric.NonNegative.Class as NonNeg98 --- import qualified Numeric.NonNegative.Wrapper as NonNegW98 -import qualified Numeric.NonNegative.Chunky as Chunky98 - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Module as Module -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field --- import qualified Algebra.Additive as Additive - -import Control.Category (Category, (.), ) -import Control.Applicative (Applicative, pure, (<*>), liftA2, ) -import Control.Monad.Trans.State (State, evalState, state, gets, ) -import Control.Monad (liftM, ) - -import NumericPrelude.Base hiding (id, (.), ) -import NumericPrelude.Numeric -import Prelude (RealFrac, ) - - -type Signal s v y signal = - AmpSignal s (Amp.Dimensional v y) signal - -type AmpSignal s amp signal = - SigA.T (Rate.Phantom s) amp signal - -{- | -This type ensures that all signals generated from the event list -share the same sample rate. --} -newtype Filter s u t a = - Filter (AlsaEL.Filter (Proc.T s u t a)) - -{-# INLINE runFilter #-} -runFilter :: - EventList.T AlsaEL.StrictTime [Event.T] -> - Filter s u t a -> Proc.T s u t a -runFilter evs (Filter f) = - evalState f evs - -instance Functor (Filter s u t) where - fmap f (Filter flt) = - Filter (fmap (fmap f) flt) - -instance Applicative (Filter s u t) where - pure x = Filter (pure (pure x)) - Filter f <*> Filter x = - Filter (liftA2 (<*>) f x) - - -{-# INLINE piecewiseConstant #-} -piecewiseConstant :: - (SigG.Write sig y) => - SigA.T rate amp (AlsaPC.T y) -> - SigA.T rate amp (sig y) -piecewiseConstant = - SigA.processBody AlsaG.piecewiseConstant - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y, Ord y, Dim.C u, Dim.C v) => - Channel -> Controller -> - (DN.T v y, DN.T v y) -> DN.T v y -> - Filter s u t (Signal s v y (AlsaPC.T y)) -controllerLinear chan ctrl bnd initial = - Filter $ - liftM - (let amp = max initial (uncurry max bnd) - in return . SigA.fromBody amp . - AlsaPC.initWith - (DMV.controllerLinear amp bnd) (DN.divToScalar initial amp)) $ - AlsaEL.getControllerEvents chan ctrl - - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y, Ord y, Dim.C u, Dim.C v) => - Channel -> Controller -> - (DN.T v y, DN.T v y) -> DN.T v y -> - Filter s u t (Signal s v y (AlsaPC.T y)) -controllerExponential chan ctrl bnd initial = - Filter $ - liftM - (let amp = max initial (uncurry max bnd) - in return . SigA.fromBody amp . - AlsaPC.initWith - (DMV.controllerExponential amp bnd) (DN.divToScalar initial amp)) $ - AlsaEL.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, Ord y, Dim.C u, Dim.C v) => - Channel -> - y -> DN.T v y -> - Filter s u t (Signal s v y (AlsaPC.T y)) -pitchBend chan range center = - Filter $ - liftM - (let amp = DN.scale (max range (recip range)) center - in return . SigA.fromBody amp . - AlsaPC.initWith - (DMV.pitchBend amp range center) (DN.divToScalar center amp)) $ - AlsaEL.getSlice (Check.pitchBend chan) --- AlsaEL.getPitchBendEvents chan - - -{-# INLINE channelPressure #-} -channelPressure :: - (Trans.C y, Ord y, Dim.C u, Dim.C v) => - Channel -> - DN.T v y -> DN.T v y -> - Filter s u t (Signal s v y (AlsaPC.T y)) -channelPressure chan maxVal initVal = - Filter $ - liftM - (return . SigA.fromBody maxVal . - AlsaPC.initWith - (DMV.controllerLinear maxVal (zero,maxVal)) - (DN.divToScalar initVal maxVal)) $ - AlsaEL.getSlice (Check.channelPressure chan) --- AlsaEL.getPitchBendEvents chan - - -{-# INLINE bendWheelPressure #-} -bendWheelPressure :: - (SigG.Write sig q, SigG2.Transform sig q q, - RealField.C q, Trans.C q, Module.C q q, Dim.C u) => - Channel -> - Int -> DN.T (Dim.Recip u) q -> q -> q -> - Filter s u q (Signal s Dim.Scalar q (sig q)) -bendWheelPressure chan - pitchRange speed wheelDepth pressDepth = - pure - (\bend fm press osci env -> - let modu = - DispA.raise 1 $ - FiltA.envelope - osci - (DispA.mix - (SigA.restore fm) - (SigA.restore press)) - - in Causal.apply - (env <<< Causal.feedSnd modu <<< Causal.canonicalizeFlat) - (piecewiseConstant bend)) - - $: pitchBend chan (2^?(fromIntegral pitchRange/12)) (DN.scalar 1) - $: controllerLinear chan VoiceMsg.modulation (zero, DN.scalar wheelDepth) zero - $: channelPressure chan (DN.scalar pressDepth) 0 - - $: Filter (return $ OsciR.static (WaveD.flat Wave.sine) zero speed) - $: Filter (return $ Filt.envelope) - - -type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract ChunkySize.T --- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract SigStV.LazySize --- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract AlsaEL.LazyTime - -type Instrument s u v q signal = - ModulatedInstrument s u q (Signal s v q signal) - -type ModulatedInstrument s u q signal = - q -> DN.T (Dim.Recip u) q -> - Proc.T s u q (LazyTime s -> signal) - -type Bank s u q signal = - Program -> ModulatedInstrument s u q signal - - -{-# INLINE chunkySizeFromLazyTime #-} -chunkySizeFromLazyTime :: AlsaEL.LazyTime -> ChunkySize.T -chunkySizeFromLazyTime = - Chunky.fromChunks . - map (SigG.LazySize . NonNegW.toNumber) . - concatMap PC.chopLongTime . - Chunky98.toChunks . - Chunky98.normalize - - -{-# INLINE renderInstrument #-} -renderInstrument :: - (Trans.C q) => - Bank s Dim.Time q signal -> - Note -> - Proc.T s Dim.Time q signal -renderInstrument instrument (Note pgm pitch vel dur) = - fmap ($ SigA.abstractFromBody $ chunkySizeFromLazyTime dur) $ - instrument pgm - (MV.velocity vel) - (DMV.frequencyFromPitch pitch) - -{- | -Instrument parameters are: -velocity from -1 to 1 -(0 is the normal pressure, no pressure aka NoteOff is not supported), -frequency is given in Hertz --} -{-# INLINE makeInstrumentSounds #-} -makeInstrumentSounds :: - (Trans.C q) => - Bank s Dim.Time q signal -> - EventList.T time [Note] -> - Proc.T s Dim.Time q (EventList.T time [signal]) -makeInstrumentSounds bank = - EventList.mapBodyM (mapM (renderInstrument bank)) - - -{-# INLINE sequence #-} -sequence :: - (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) => - SVL.ChunkSize -> - DN.T v q -> - Channel -> - Instrument s Dim.Time v q (SigSt.T y) -> - Filter s Dim.Time q (Signal s v q (SigSt.T y)) -sequence chunkSize amp chan instr = - fmap (renderSequence chunkSize amp) $ - prepareTones chan errorNoProgram (const instr) - -{- -{-# INLINE sequence #-} -sequence :: - (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) => - SVL.ChunkSize -> - DN.T v q -> - Channel -> - Instrument s Dim.Time v q y -> - Filter (Proc.T s Dim.Time q (Signal s v q (SigSt.T y))) -sequence chunkSize amp chan instr = - fmap ((CutA.arrangeStorableVolume undefined {- chunkSize -} amp undefined $:) . - fmap - (EventListTM.switchTimeR const . - EventListTT.mapTime fromIntegral . - AlsaSt.insertBreaksGen (SigA.fromBody amp SigSt.empty)) . - makeInstrumentSounds instr . - AlsaEL.matchNoteEvents) $ - AlsaEL.getNoteEvents chan --} - - -{-# INLINE sequenceModulated #-} -sequenceModulated :: - (CutG.Transform ctrl, CutG.NormalForm ctrl, - RealFrac q, Storable y, - Module.C q y, Trans.C q, Dim.C v) => - SVL.ChunkSize -> - DN.T v q -> - Channel -> - ModulatedInstrument s Dim.Time q - (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y)) -> - Filter s Dim.Time q - (AmpSignal s amp ctrl -> Signal s v q (SigSt.T y)) -sequenceModulated chunkSize amp chan instr = - fmap (flip $ \ctrl -> - renderSequence chunkSize amp . - applyModulator (applyModulation ctrl)) $ - prepareTones chan errorNoProgram (const instr) - -{-# INLINE sequenceModulated2 #-} -sequenceModulated2 :: - (CutG.Transform ctrl0, CutG.NormalForm ctrl0, - CutG.Transform ctrl1, CutG.NormalForm ctrl1, - RealFrac q, Storable y, - Module.C q y, Trans.C q, Dim.C v) => - SVL.ChunkSize -> - DN.T v q -> - Channel -> - ModulatedInstrument s Dim.Time q - (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y)) -> - Filter s Dim.Time q - (AmpSignal s amp0 ctrl0 -> AmpSignal s amp1 ctrl1 -> Signal s v q (SigSt.T y)) -sequenceModulated2 chunkSize amp chan instr = - fmap (\evs ctrl0 ctrl1 -> - renderSequence chunkSize amp . - applyModulator - (applyModulation ctrl1 . - applyModulation ctrl0) - $ evs) $ - prepareTones chan errorNoProgram (const instr) - - -{-# INLINE sequenceMultiModulated #-} -sequenceMultiModulated :: - (RealFrac q, Storable y, - Module.C q y, Trans.C q, Dim.C v) => - SVL.ChunkSize -> - DN.T v q -> - Channel -> - ModulatedInstrument s Dim.Time q instrument -> - Filter s Dim.Time q - (AlsaG.Modulator instrument (Signal s v q (SigSt.T y))) -> - Filter s Dim.Time q (Signal s v q (SigSt.T y)) -sequenceMultiModulated chunkSize amp chan instr modu = - fmap (renderSequence chunkSize amp) $ - (fmap applyModulator modu $: - prepareTones chan errorNoProgram (const instr)) - -{-# INLINE prepareTones #-} -prepareTones :: - (RealFrac q, Trans.C q) => - -- ToDo: use time value - Channel -> - Program -> - Bank s Dim.Time q signal -> - Filter s Dim.Time q (EventList.T AlsaEL.StrictTime [signal]) -prepareTones chan initPgm instr = - Filter $ - fmap (makeInstrumentSounds instr . - AlsaEL.matchNoteEvents . - AlsaEL.embedPrograms initPgm) $ - AlsaEL.getNoteEvents chan - -{-# INLINE applyModulation #-} -applyModulation :: - (CutG.Transform signal, CutG.NormalForm signal) => - AmpSignal s amp signal -> - AlsaG.Modulator (AmpSignal s amp signal -> body) body -applyModulation ctrl = - AlsaG.Modulator ctrl advanceModulationChunk gets - -{-# INLINE applyModulator #-} -applyModulator :: - AlsaG.Modulator a b -> - EventList.T AlsaEL.StrictTime [a] -> - EventList.T AlsaEL.StrictTime [b] -applyModulator = - AlsaG.applyModulator - -{-# INLINE renderSequence #-} -renderSequence :: - (Storable y, Module.C q y, Dim.C u, Field.C q) => - SVL.ChunkSize -> - DN.T u q -> - EventList.T AlsaEL.StrictTime [Signal s u q (SigSt.T y)] -> - Signal s u q (SigSt.T y) -renderSequence chunkSize amp = - SigA.fromBody amp . - CutSt.arrangeEquidist chunkSize . - {- This concatenates times across empty events, - and thus is too strict. - EventList.flatten . - -} - AlsaG.flatten . - EventList.mapTime fromIntegral . - EventList.mapBody (map (SigA.vectorSamples (flip DN.divToScalar amp))) - - -{-# INLINE advanceModulationChunky #-} -advanceModulationChunky :: - (CutG.Transform signal, CutG.NormalForm signal) => - AlsaEL.LazyTime -> State (AmpSignal s amp signal) AlsaEL.LazyTime -advanceModulationChunky = - liftM Chunky98.fromChunks . - mapM advanceModulationChunk . - Chunky98.toChunks - -{-# INLINE advanceModulationChunk #-} -advanceModulationChunk :: - (CutG.Transform signal, CutG.NormalForm signal) => - AlsaEL.StrictTime -> State (AmpSignal s amp signal) AlsaEL.StrictTime -advanceModulationChunk t = state $ \xs -> - let ys = SigA.processBody (CutG.drop (fromIntegral t)) xs - in (AlsaG.evaluateVectorHead (SigA.body ys) t, ys) - - -{-# INLINE sequenceMultiProgram #-} -sequenceMultiProgram :: - (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) => - SVL.ChunkSize -> - DN.T v q -> - Channel -> - Program -> --- Bank s Dim.Time q (Signal s v q (SigSt.T y)) -> - [Instrument s Dim.Time v q (SigSt.T y)] -> - Filter s Dim.Time q (Signal s v q (SigSt.T y)) -sequenceMultiProgram chunkSize amp chan initPgm instrs = - let bank = AlsaEL.makeInstrumentArray instrs - in fmap (renderSequence chunkSize amp) $ - prepareTones chan initPgm $ - AlsaEL.getInstrumentFromArray bank initPgm diff --git a/src/Synthesizer/Dimensional/ALSA/Play.hs b/src/Synthesizer/Dimensional/ALSA/Play.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/Play.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Rank2Types #-} -module Synthesizer.Dimensional.ALSA.Play where - -import qualified Synthesizer.Storable.ALSA.Play as Play - -import qualified Synthesizer.Dimensional.Rate as Rate -import qualified Synthesizer.Dimensional.Amplitude as Amp - -import qualified Synthesizer.Dimensional.Process as Proc -import qualified Synthesizer.Dimensional.Signal.Private as SigA - -import qualified Synthesizer.Frame.Stereo as Stereo - -import qualified Synthesizer.Storable.Signal as SigSt - -import qualified Sound.ALSA.PCM as ALSA - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - --- import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.Module as Module -import qualified Algebra.RealRing as RealRing --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring - -import Foreign.Storable (Storable, ) - --- import NumericPrelude.Numeric -import NumericPrelude.Base - - -type Device = String - -type RenderedStorableSignal u t v y yv = - SigA.T (Rate.Dimensional u t) (Amp.Dimensional v y) (SigSt.T yv) - -type StorableSignal s v y yv = - SigA.T (Rate.Phantom s) (Amp.Dimensional v y) (SigSt.T yv) - - -makeSink :: - (ALSA.SampleFmt y, RealRing.C t) => - Device {- ^ ALSA output device -} -> - DN.Time t {- ^ period (buffer) size expressed in seconds -} -> - DN.Frequency t {- ^ sample rate -} -> - ALSA.SoundSink y ALSA.Pcm -makeSink device periodTime rate = - Play.makeSink device - (DN.toNumberWithDimension Dim.time periodTime) - (RealRing.round (DN.toNumberWithDimension Dim.frequency rate)) - - -{-# INLINE timeVoltageStorable #-} -timeVoltageStorable :: - (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) => - Device -> - DN.Time t-> - RenderedStorableSignal Dim.Time t Dim.Voltage y yv -> - IO () -timeVoltageStorable device period sig = - Play.auto (makeSink device period (SigA.actualSampleRate sig)) - (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig) - -{-# INLINE timeVoltageMonoStorableToInt16 #-} -timeVoltageMonoStorableToInt16 :: - (Storable y, RealRing.C y, RealRing.C t) => - Device -> - DN.Time t-> - RenderedStorableSignal Dim.Time t Dim.Voltage y y -> - IO () -timeVoltageMonoStorableToInt16 device period sig = - Play.monoToInt16 (makeSink device period (SigA.actualSampleRate sig)) - (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig) - -{-# INLINE timeVoltageStereoStorableToInt16 #-} -timeVoltageStereoStorableToInt16 :: - (Storable y, Module.C y y, RealRing.C y, RealRing.C t) => - Device -> - DN.Time t-> - RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) -> - IO () -timeVoltageStereoStorableToInt16 device period sig = - Play.stereoToInt16 (makeSink device period (SigA.actualSampleRate sig)) - (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig) - - -{-# INLINE renderTimeVoltageStorable #-} -renderTimeVoltageStorable :: - (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) => - Device -> - DN.Time t-> - DN.T Dim.Frequency t -> - (forall s. Proc.T s Dim.Time t - (StorableSignal s Dim.Voltage y yv)) -> - IO () -renderTimeVoltageStorable device period rate sig = - timeVoltageStorable device period (SigA.render rate sig) - -{-# INLINE renderTimeVoltageMonoStorableToInt16 #-} -renderTimeVoltageMonoStorableToInt16 :: - (Storable y, RealRing.C y, RealRing.C t) => - Device -> - DN.Time t-> - DN.T Dim.Frequency t -> - (forall s. Proc.T s Dim.Time t - (StorableSignal s Dim.Voltage y y)) -> - IO () -renderTimeVoltageMonoStorableToInt16 device period rate sig = - timeVoltageMonoStorableToInt16 device period (SigA.render rate sig) - -{-# INLINE renderTimeVoltageStereoStorableToInt16 #-} -renderTimeVoltageStereoStorableToInt16 :: - (Storable y, Module.C y y, RealRing.C y, RealRing.C t) => - Device -> - DN.Time t-> - DN.T Dim.Frequency t -> - (forall s. Proc.T s Dim.Time t - (StorableSignal s Dim.Voltage y (Stereo.T y))) -> - IO () -renderTimeVoltageStereoStorableToInt16 device period rate sig = - timeVoltageStereoStorableToInt16 device period (SigA.render rate sig) diff --git a/src/Synthesizer/Dimensional/ALSA/Server.hs b/src/Synthesizer/Dimensional/ALSA/Server.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/Server.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Main where - -import qualified Synthesizer.Dimensional.ALSA.Server.Run as Run -import qualified Synthesizer.Dimensional.ALSA.Server.Test as Test - -main :: IO () -main = - case 106::Int of - 001 -> Test.sequence1 - 100 -> Run.volume - 101 -> Run.pitchBend - 102 -> Run.volumePitchBend1 - 103 -> Run.keyboard - 104 -> Run.keyboardMulti - 105 -> Run.keyboardFM - 106 -> Run.keyboardDetuneFM - 107 -> Run.keyboardFilter - _ -> error "not implemented" diff --git a/src/Synthesizer/Dimensional/ALSA/Server/Common.hs b/src/Synthesizer/Dimensional/ALSA/Server/Common.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/Server/Common.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} -module Synthesizer.Dimensional.ALSA.Server.Common where - -import qualified Synthesizer.Dimensional.ALSA.Play as Play - -import qualified Sound.ALSA.PCM as ALSA -import qualified Sound.ALSA.Sequencer.Event as Event - -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv - -import qualified Synthesizer.Storable.ALSA.Play as PlaySt - -import qualified Synthesizer.Dimensional.Rate.Filter as FiltR -import qualified Synthesizer.Dimensional.Process as Proc - -import Synthesizer.Dimensional.Process (($:), ) - -import qualified Data.StorableVector.Lazy as SVL - -import qualified Sound.MIDI.Message.Channel as ChannelMsg - -import qualified Data.EventList.Relative.TimeBody as EventList - --- import qualified Numeric.NonNegative.Class as NonNeg --- import qualified Numeric.NonNegative.Wrapper as NonNegW --- import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky - -import qualified Algebra.Module as Module -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (break, ) - - - -channel :: ChannelMsg.Channel -channel = ChannelMsg.toChannel 0 - - -sampleRate :: Ring.C a => DN.Frequency a --- sampleRate = DN.frequency 48000 -sampleRate = DN.frequency 44100 - -latency :: Field.C a => DN.Time a -latency = DN.time 0 --- latency = DN.time 0.01 - -{- -chunkSize :: SVL.ChunkSize -chunkSize = Play.defaultChunkSize --} - -periodTime :: Field.C a => DN.Time a -periodTime = - let (SVL.ChunkSize size) = PlaySt.defaultChunkSize - in DN.scale (fromIntegral size) $ DN.unrecip sampleRate - -device :: Play.Device -device = PlaySt.defaultDevice - -clientName :: MIDIEv.ClientName -clientName = MIDIEv.ClientName "Haskell-Synthesizer" - - -type Real = Double - - -{-# INLINE withMIDIEvents #-} -withMIDIEvents :: - Field.C t => - (DN.Time t -> DN.Frequency t -> - (forall s. Proc.T s Dim.Time t - (Play.StorableSignal s Dim.Voltage y yv)) -> - IO b) -> - (EventList.T MIDIEv.StrictTime [Event.T] -> - forall s. Proc.T s Dim.Time t - (Play.StorableSignal s Dim.Voltage y yv)) -> - IO b -withMIDIEvents action proc = - MIDIEv.withMIDIEvents clientName - (DN.toNumberWithDimension Dim.time periodTime :: Double) - (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $ - \ sig -> action periodTime sampleRate (proc sig) - -{-# INLINE play #-} -play :: - (Module.C y yv, ALSA.SampleFmt yv, RealField.C t) => - DN.Time t -> - DN.Frequency t -> - (forall s. Proc.T s Dim.Time t - (Play.StorableSignal s Dim.Voltage y yv)) -> - IO () -play period rate sig = - Play.renderTimeVoltageStorable device period rate - (FiltR.delay latency $: sig) diff --git a/src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs b/src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Rank2Types #-} -module Synthesizer.Dimensional.ALSA.Server.Instrument where - -import Synthesizer.Dimensional.ALSA.Server.Common -import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC - -import qualified Synthesizer.Dimensional.Causal.Process as Causal -import qualified Synthesizer.Dimensional.Causal.Filter as Filt - -import qualified Synthesizer.Dimensional.Rate as Rate -import qualified Synthesizer.Dimensional.Rate.Cut as CutR -import qualified Synthesizer.Dimensional.Rate.Control as CtrlR -import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR -import qualified Synthesizer.Dimensional.Rate.Filter as FiltR -import qualified Synthesizer.Dimensional.Amplitude as Amp -import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA -import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA -import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat -import qualified Synthesizer.Dimensional.Amplitude.Analysis as AnaA -import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA -import qualified Synthesizer.Dimensional.RateAmplitude.Control as CtrlD -import qualified Synthesizer.Dimensional.ChunkySize.Signal as SigC -import qualified Synthesizer.Dimensional.Signal.Private as SigA -import qualified Synthesizer.Dimensional.Process as Proc - -import Synthesizer.Dimensional.Causal.Process ((<<<), ) -import Synthesizer.Dimensional.Wave ((&*~), ) -import Synthesizer.Dimensional.Process (($:), ) -import Synthesizer.Dimensional.Signal ((&*^), ) -import Control.Applicative (liftA3, ) - -import qualified Synthesizer.Basic.Wave as Wave -import qualified Synthesizer.Frame.Stereo as Stereo - -import qualified Synthesizer.Storable.Signal as SigSt - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (break, ) - - -{-# INLINE ping #-} -ping :: MIDI.Instrument s Dim.Time Dim.Voltage Real (SigSt.T Real) -ping vel freq = - fmap (flip SigC.store) - (FiltR.envelope - $: CtrlR.exponential2 (DN.time 0.2) - $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq) - - -{- -Generating the envelope requires great care: - - you must avoid an append function that determines the common volume automatically, - because the volume of the second part is only known after the first part is complete - - you must terminate the release phase, - otherwise you get an infinite signal for every played note --} -{-# INLINE pingReleaseEnvelope #-} -pingReleaseEnvelope :: - Real -> - Proc.T s Dim.Time Real - (MIDI.LazyTime s -> - SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real)) -pingReleaseEnvelope vel = - Proc.withParam $ \dur -> - do decay <- - fmap (SigC.store dur) $ - CtrlR.exponential2 (DN.time 0.4) - end <- fmap (AnaA.endPrimitive zero) $ fmap ($decay) SigA.embedSampleRate - release <- - SigA.store (DN.time 0.01) $: - (CutR.take (DN.time 0.3) $: - fmap Flat.canonicalize - (DN.scalar end &*^ CtrlR.exponential2 (DN.time 0.1))) - append <- CutR.append - return $ (DispA.inflate (DN.fromNumber $ 4**vel) (append decay release)) --- return $ DispA.inflate (DN.fromNumber $ 4**vel) decay - -{- - Proc.withParam $ \dur -> - liftA2 - (\embed env -> - let x = SigC.store dur env - y = AnaA.end $ embed x - in ) - SigA.embedSampleRate - (FiltR.envelope - $: CtrlR.exponential2 (DN.time 0.2) - $: OsciR.static (DN.voltage (4**vel) &*~ Wave.saw) zero freq) --} - -{-# INLINE pingRelease #-} -pingRelease :: MIDI.Instrument s Dim.Time Dim.Voltage Real (SigSt.T Real) -pingRelease vel freq = - liftA3 - (\env ctrl osci dur -> - Causal.apply - (env <<< Causal.feedSnd osci) - (ctrl dur)) - Filt.envelopeScalarDimension - (pingReleaseEnvelope vel) - (OsciR.static (DN.voltage 1 &*~ Wave.saw) zero freq) - - -{-# INLINE pingReleaseFM #-} -pingReleaseFM :: - MIDI.ModulatedInstrument s Dim.Time Real - (MIDI.Signal s Dim.Scalar Real (SigSt.T Real) -> - MIDI.Signal s Dim.Voltage Real (SigSt.T Real)) -pingReleaseFM vel freq = - liftA3 - (\env ctrl osci dur fm -> - Causal.apply - (env <<< - Causal.feedSnd (osci (FiltA.amplifyScalarDimension freq $ SigA.restore fm))) - (ctrl dur)) - Filt.envelopeScalarDimension - (pingReleaseEnvelope vel) - (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero) - - -{-# INLINE pingStereoDetuneFM #-} -pingStereoDetuneFM :: - MIDI.ModulatedInstrument s Dim.Time Real - (MIDI.Signal s Dim.Scalar Real (PC.T Real) -> - MIDI.Signal s Dim.Scalar Real (SigSt.T Real) -> - MIDI.Signal s Dim.Voltage Real (SigSt.T (Stereo.T Real))) -pingStereoDetuneFM vel freq = - liftA3 - (\env ctrl osci dur detuneSt fmSt -> - let fm = SigA.restore fmSt - detune = SigA.restore detuneSt - osciChan d = - osci (FiltA.amplifyScalarDimension freq - (FiltA.envelope (DispA.raise 1 d) fm)) - in SigA.rewriteAmplitudeDimension Dim.identityLeft $ - Causal.apply - (env <<< - Causal.feedSnd (CutA.mergeStereo - (osciChan detune) - (osciChan $ FiltA.negate detune))) - (ctrl dur)) - Filt.envelopeVectorDimension - (pingReleaseEnvelope vel) - (OsciR.freqMod (DN.voltage 1 &*~ Wave.saw) zero) - - -{- INLINE stringReleaseEnvelope -} -stringReleaseEnvelope :: - Real -> - Proc.T s Dim.Time Real - (MIDI.LazyTime s -> - SigA.T (Rate.Phantom s) (Amp.Dimensional Dim.Scalar Real) (SigSt.T Real)) -stringReleaseEnvelope vel = - Proc.withParam $ \dur -> - do let attackTime = DN.time 1 - cnst <- CtrlR.constant - {- - release <- take attackTime beginning - would yield a space leak, thus we first split 'beginning' - and then concatenate it again - -} - {- - We can not easily generate attack and sustain separately, - because we want to use the chunk structure implied by 'dur'. - -} - (attack, sustain) <- - CutR.splitAt attackTime $: - (fmap (SigC.store dur . - flip CutA.appendPrimitive cnst . - DispA.map sin . Flat.canonicalize) - (CtrlD.line attackTime (0, DN.scalar (pi/2)))) - let release = CutA.reverse attack --- infixr 5 append - append <- CutR.append - return $ - DispA.inflate (DN.fromNumber $ 4**vel) $ - attack `append` sustain `append` release - -{- INLINE string -} -string :: - MIDI.ModulatedInstrument s Dim.Time Real - (MIDI.Signal s Dim.Voltage Real (SigSt.T (Stereo.T Real))) -string vel freq = - liftA3 - (\env ctrl osci dur -> - SigA.rewriteAmplitudeDimension Dim.identityLeft $ - Causal.apply - (env <<< Causal.feedSnd osci) - (ctrl dur)) - Filt.envelopeVectorDimension - (stringReleaseEnvelope vel) - (Proc.pure CutA.mergeStereo - $: (Proc.pure DispA.mix - $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.005 freq) - $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.998 freq)) - $: (Proc.pure DispA.mix - $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 1.002 freq) - $: OsciR.static (DN.voltage 0.5 &*~ Wave.saw) zero (DN.scale 0.995 freq))) diff --git a/src/Synthesizer/Dimensional/ALSA/Server/Run.hs b/src/Synthesizer/Dimensional/ALSA/Server/Run.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/Server/Run.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Dimensional.ALSA.Server.Run where - -import Synthesizer.Dimensional.ALSA.Server.Common -import qualified Synthesizer.Dimensional.ALSA.Server.Instrument as Instr - -import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI - -import qualified Synthesizer.Storable.ALSA.Play as PlaySt - -import qualified Synthesizer.Dimensional.Causal.Process as Causal -import qualified Synthesizer.Dimensional.Causal.Oscillator as Osci -import qualified Synthesizer.Dimensional.Causal.Filter as Filt -import qualified Synthesizer.Dimensional.Causal.FilterParameter as FiltP -import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc - -import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR -import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA -import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA -import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA -import qualified Synthesizer.Dimensional.Signal.Private as SigA -import qualified Synthesizer.Dimensional.Wave as WaveD - -import Synthesizer.Dimensional.Causal.Process ((<<<), ) -import Synthesizer.Dimensional.Wave ((&*~), ) -import Synthesizer.Dimensional.Process (($:), (.:), ) -import Control.Applicative (liftA2, liftA3, ) - -import qualified Synthesizer.Basic.Wave as Wave - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import qualified Number.DimensionTerm as DN - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (break, ) - - - -channelVolume :: VoiceMsg.Controller -channelVolume = VoiceMsg.modulation - - -volume :: IO () -volume = - putStrLn "run 'aconnect' to connect to the MIDI controller" >> - (withMIDIEvents play $ - \evs -> - liftA3 - (\env osci vol -> - Causal.apply - (Causal.applySnd env osci) $ - MIDI.piecewiseConstant $ vol) - Filt.envelopeScalarDimension - (OsciR.static (DN.voltage 1 &*~ Wave.sine) zero (DN.frequency (880::Real))) - (MIDI.runFilter evs (MIDI.controllerLinear channel channelVolume - (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real))))) - -pitchBend :: IO () -pitchBend = - withMIDIEvents play $ - \evs -> - liftA2 Causal.apply - (Osci.freqMod (DN.voltage (1::Real) &*~ Wave.sine) zero) - (fmap MIDI.piecewiseConstant $ - MIDI.runFilter evs - (MIDI.pitchBend channel 2 (DN.frequency (880::Real)))) - --- preserve chunk structure of channel volume -volumePitchBend0 :: IO () -volumePitchBend0 = - putStrLn "run 'aconnect' to connect to the MIDI controller" >> - (withMIDIEvents play $ - \evs -> - liftA3 - (\osci env (freq,vol) -> - Causal.apply - (Causal.applySnd env (osci $ SigA.restore freq)) $ - MIDI.piecewiseConstant vol) - (OsciR.freqMod (DN.voltage 1 &*~ Wave.sine) zero) - Filt.envelopeScalarDimension - (MIDI.runFilter evs $ liftA2 (,) - (MIDI.pitchBend channel 2 (DN.frequency (880::Real))) - (MIDI.controllerLinear channel channelVolume - (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real))))) - --- preserve chunk structure of pitch bender -volumePitchBend1 :: IO () -volumePitchBend1 = - putStrLn "run 'aconnect' to connect to the MIDI controller" >> - (withMIDIEvents play $ - \evs -> - liftA3 - (\osci env (freq,vol) -> - Causal.apply - (Causal.applyFst env (SigA.restore vol) <<< osci) $ - MIDI.piecewiseConstant freq) - (Osci.freqMod (DN.voltage 1 &*~ Wave.sine) zero) - Filt.envelopeScalarDimension - (MIDI.runFilter evs $ liftA2 (,) - (MIDI.pitchBend channel 2 (DN.frequency (880::Real))) - (MIDI.controllerLinear channel channelVolume - (DN.scalar 0, DN.scalar 1) (DN.scalar (1::Real))))) - - -keyboard :: IO () -keyboard = - withMIDIEvents play $ - \evs -> - MIDI.runFilter evs - (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.ping) - - -keyboardMulti :: IO () -keyboardMulti = - withMIDIEvents play $ - \evs -> - MIDI.runFilter evs - (MIDI.sequenceMultiProgram PlaySt.defaultChunkSize (DN.voltage 1) channel - (VoiceMsg.toProgram 0) - [Instr.ping, Instr.pingRelease]) --- [Instr.string]) - - -keyboardFM :: IO () -keyboardFM = - withMIDIEvents play $ - \evs -> - fmap (FiltA.amplify 0.3) $ - (MIDI.runFilter evs - (MIDI.sequenceModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingReleaseFM $: - MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03)) --- MIDI.pitchBend channel (2 ** recip 12) (DN.scalar one))) - - -extraController :: VoiceMsg.Controller -extraController = - VoiceMsg.vectorX --- VoiceMsg.toController 21 - -extraController1 :: VoiceMsg.Controller -extraController1 = - VoiceMsg.modulation --- VoiceMsg.vectorY --- VoiceMsg.toController 22 - - -keyboardDetuneFM :: IO () -keyboardDetuneFM = - withMIDIEvents play $ - \evs -> - fmap (FiltA.amplify 0.3) $ - (MIDI.runFilter evs - (MIDI.sequenceMultiModulated PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.pingStereoDetuneFM - (fmap MIDI.applyModulation - (MIDI.bendWheelPressure channel 2 (DN.frequency 10) 0.04 0.03) .: - fmap MIDI.applyModulation - (MIDI.controllerLinear channel extraController (0, 0.005) 0)) - )) - - -keyboardFilter :: IO () -keyboardFilter = - withMIDIEvents play $ - \evs -> - liftA3 - (\osci filt (music,speed,depth) -> - (FiltP.lowpassFromUniversal <<< - filt (CtrlA.constant 10) - (DispA.mapExponential 4 (DN.frequency 1000) $ - FiltA.envelope (SigA.restore depth) $ - osci (SigA.restore speed))) - `Causal.apply` - FiltA.amplify 0.2 music) - (OsciR.freqMod (WaveD.flat Wave.sine) zero) - (CProc.runSynchronous2 FiltP.universal) --- FiltR.universal - (MIDI.runFilter evs - (liftA3 (,,) - (MIDI.sequence PlaySt.defaultChunkSize (DN.voltage 1) channel Instr.string) - (MIDI.controllerExponential channel extraController - (DN.frequency 0.1, DN.frequency 5) (DN.frequency 0.2)) - (MIDI.controllerLinear channel extraController1 - (0, 1 :: DN.Scalar Real) 0.5) - )) diff --git a/src/Synthesizer/Dimensional/ALSA/Server/Test.hs b/src/Synthesizer/Dimensional/ALSA/Server/Test.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/ALSA/Server/Test.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Rank2Types #-} -module Synthesizer.Dimensional.ALSA.Server.Test where - -import Synthesizer.Dimensional.ALSA.Server.Instrument (ping, ) -import Synthesizer.Dimensional.ALSA.Server.Common -import qualified Synthesizer.Dimensional.ALSA.MIDI as MIDI - -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv - -import qualified Synthesizer.Storable.ALSA.Play as PlaySt -import qualified Synthesizer.Generic.ALSA.MIDI as AlsaG - -import qualified Synthesizer.Dimensional.Signal.Private as SigA -import qualified Synthesizer.Dimensional.Process as Proc - -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL - -import qualified Data.EventList.Relative.TimeBody as EventList - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (break, ) - - - -sequence1 :: IO () -sequence1 = --- print =<< --- File.renderTimeVoltageMonoDoubleToInt16 sampleRate "test.wav" - SVL.writeFile "test.f32" - (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) - (SigA.render sampleRate - (let evs t = EventList.cons t [] (evs (20-t)) - {- - evs0 = - EventList.cons 10 [makeNote AlsaMidi.NoteOn 60] $ - EventList.cons 10 [makeNote AlsaMidi.NoteOn 64] $ - evs 10 - -} - in MIDI.runFilter (evs 10) - (MIDI.sequence PlaySt.defaultChunkSize - (DN.voltage 1) channel ping)))) - -sequence2 :: - EventList.T MIDIEv.StrictTime [SigSt.T Real] -sequence2 = - fmap (map SigA.body) $ - flip Proc.process sampleRate - (let evs t = EventList.cons t [] (evs (20-t)) - in MIDI.runFilter (evs 10) - (MIDI.prepareTones channel AlsaG.errorNoProgram - (const ping))) diff --git a/src/Synthesizer/Dimensional/MIDIValue.hs b/src/Synthesizer/Dimensional/MIDIValue.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/MIDIValue.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Functions for converting MIDI controller and key values -to something meaningful for signal processing. --} -module Synthesizer.Dimensional.MIDIValue ( - controllerLinear, - controllerExponential, - pitchBend, - MV.frequencyFromPitch, - ) where - -import qualified Synthesizer.Dimensional.MIDIValuePlain as MV - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field --- import qualified Algebra.Additive as Additive - -import NumericPrelude.Numeric --- import NumericPrelude.Base - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y, Dim.C v) => - DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y -controllerLinear amp bnd n = - DN.divToScalar (MV.controllerLinear bnd n) amp - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y, Dim.C v) => - DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y -controllerExponential amp bnd n = - DN.divToScalar (MV.controllerExponential bnd n) amp - -{-# INLINE pitchBend #-} -pitchBend :: - (Trans.C y, Dim.C v) => - DN.T v y -> y -> DN.T v y -> Int -> y -pitchBend amp range center n = - DN.divToScalar (MV.pitchBend range center n) amp diff --git a/src/Synthesizer/Dimensional/MIDIValuePlain.hs b/src/Synthesizer/Dimensional/MIDIValuePlain.hs deleted file mode 100644 --- a/src/Synthesizer/Dimensional/MIDIValuePlain.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Functions for converting MIDI controller and key values -to something meaningful for signal processing. --} -module Synthesizer.Dimensional.MIDIValuePlain ( - controllerLinear, - controllerExponential, - pitchBend, - frequencyFromPitch, - ) where - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field --- import qualified Algebra.Additive as Additive - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y, Dim.C v) => - (DN.T v y, DN.T v y) -> Int -> DN.T v y -controllerLinear (lower,upper) n = - let k = fromIntegral n / 127 - in DN.scale (1-k) lower + DN.scale k upper - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y, Dim.C v) => - (DN.T v y, DN.T v y) -> Int -> DN.T v y -controllerExponential (lower,upper) n = - let k = fromIntegral n / 127 - in case error "MIDIValue.controllerExponential dimension" of - d -> - DN.fromNumberWithDimension d $ - DN.toNumberWithDimension d lower ** (1-k) * - DN.toNumberWithDimension d upper ** k - -{-# INLINE pitchBend #-} -pitchBend :: - (Trans.C y, Dim.C v) => - y -> DN.T v y -> Int -> DN.T v y -pitchBend range center n = - DN.scale (range ** (fromIntegral n / 8192)) center - -{- | -Convert pitch to frequency according to the default tuning -in MIDI 1.0 Detailed Specification. --} -{-# INLINE frequencyFromPitch #-} -frequencyFromPitch :: - (Trans.C y) => - VoiceMsg.Pitch -> DN.Frequency y -frequencyFromPitch pitch = - DN.scale - (2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12)) - (DN.frequency 440) diff --git a/src/Synthesizer/EventList/ALSA/MIDI.hs b/src/Synthesizer/EventList/ALSA/MIDI.hs deleted file mode 100644 --- a/src/Synthesizer/EventList/ALSA/MIDI.hs +++ /dev/null @@ -1,769 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.EventList.ALSA.MIDI where - -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.Port.Info as PortInfo -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.ALSA.Sequencer.Queue as Queue -import qualified Sound.ALSA.Sequencer.RealTime as RealTime -import qualified Sound.ALSA.Sequencer as SndSeq -import qualified Sound.ALSA.Exception as AlsaExc - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.MixedBody as EventListMB --- import qualified Data.EventList.Relative.BodyMixed as EventListBM -import qualified Data.EventList.Relative.TimeMixed as EventListTM --- import qualified Data.EventList.Relative.MixedTime as EventListMT --- import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.BodyBody as EventListBB -import qualified Data.EventList.Absolute.TimeBody as AbsEventList - -import qualified Sound.MIDI.Message.Channel as ChannelMsg -import qualified Sound.MIDI.Message.Channel.Mode as Mode -import qualified Sound.MIDI.ALSA.Check as Check -import qualified Sound.MIDI.ALSA as MALSA - -import Data.Accessor.Basic ((^.), ) - -import System.IO.Unsafe (unsafeInterleaveIO, ) -import Control.Concurrent (threadDelay) -import System.Time (ClockTime(TOD), getClockTime, ) - -import Control.Monad.Trans.State - (State, state, evalState, modify, get, gets, put, ) -import Data.Traversable (traverse, ) - -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky --- import Data.Monoid (Monoid, mconcat, mappend, ) - -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field --- import qualified Algebra.Additive as Additive - -import Data.Array (Array, listArray, (!), bounds, inRange, ) - -import qualified Data.List.HT as ListHT -import Data.Tuple.HT (mapPair, mapFst, mapSnd, ) -import Data.Ord.HT (limit, ) -import Data.Maybe.HT (toMaybe, ) -import Data.Maybe (catMaybes, isNothing, ) -import Control.Monad.HT ((<=<), ) -import Control.Monad (liftM, liftM2, guard, mzero, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base --- import qualified Prelude as P - --- import Debug.Trace (trace, ) - - -{- | -The @time@ type needs high precision, -so you will certainly have to instantiate it with 'Double'. -'Float' has definitely not enough bits. --} -getTimeSeconds :: Field.C time => IO time -getTimeSeconds = - fmap clockTimeToSeconds getClockTime - -clockTimeToSeconds :: Field.C time => ClockTime -> time -clockTimeToSeconds (TOD secs picos) = - fromInteger secs + fromInteger picos * 1e-12 - -wait :: RealField.C time => time -> IO () -wait t1 = - do t0 <- getTimeSeconds - threadDelay $ floor $ 1e6*(t1-t0) - - -{- -We cannot easily turn this into a custom type, -since we need Maybe Event.T sometimes. --} -type StampedEvent time = (time, Event.T) - - -{- | -only use it for non-blocking sequencers - -We ignore ALSA time stamps and use the time of fetching the event, -because I don't know whether the ALSA time stamps are in sync with getClockTime. --} -getStampedEvent :: - (Field.C time, SndSeq.AllowInput mode) => - SndSeq.T mode -> IO (StampedEvent time) -getStampedEvent h = - liftM2 (,) - getTimeSeconds - (Event.input h) - -{- | only use it for non-blocking sequencers -} -getWaitingStampedEvents :: - (Field.C time, SndSeq.AllowInput mode) => - SndSeq.T mode -> IO [StampedEvent time] -getWaitingStampedEvents h = - let loop = - AlsaExc.catch - (liftM2 (:) (getStampedEvent h) loop) - (const $ return []) - in loop - -{- | -RealTime.toFractional for NumericPrelude. --} -realTimeToField :: (Field.C a) => RealTime.T -> a -realTimeToField (RealTime.Cons s n) = - fromIntegral s + fromIntegral n / (10^9) - -addStamp :: - (RealField.C time) => - Event.T -> StampedEvent time -addStamp ev = - (case Event.timestamp ev of - Event.RealTime t -> realTimeToField t - _ -> error "unsupported time stamp type", - ev) - -{- | only use it for blocking sequencers -} -getStampedEventsUntilTime :: - (RealField.C time, - SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => - SndSeq.T mode -> - Queue.T -> Port.T -> time -> - IO [StampedEvent time] -getStampedEventsUntilTime h q p t = - fmap (map addStamp) $ getEventsUntilTime h q p t - - -{- | -The client id may differ from the receiving sequencer. -I do not know, whether there are circumstances, where this is useful. --} -getEventsUntilEcho :: - (SndSeq.AllowInput mode) => - Client.T -> SndSeq.T mode -> IO [Event.T] -getEventsUntilEcho c h = - let loop = do - ev <- Event.input h - let abort = - case Event.body ev of - Event.CustomEv Event.Echo _ -> - c == Addr.client (Event.source ev) - _ -> False - if abort - then return [] - else liftM (ev:) loop - in loop - -{- | -Get events until a certain point in time. -It sends itself an Echo event in order to measure time. --} -getEventsUntilTime :: - (RealField.C time, - SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => - SndSeq.T mode -> - Queue.T -> Port.T -> time -> - IO [Event.T] -getEventsUntilTime h q p t = do - c <- Client.getId h - _ <- Event.output h $ - makeEcho c q p t (Event.Custom 0 0 0) - _ <- Event.drainOutput h - getEventsUntilEcho c h - - -getWaitingEvents :: - (SndSeq.AllowInput mode) => - SndSeq.T mode -> IO [Event.T] -getWaitingEvents h = - let loop = - AlsaExc.catch - (liftM2 (:) (Event.input h) loop) - (const $ return []) - in loop - - - -type StrictTime = NonNegW.Integer -newtype ClientName = ClientName String - deriving (Show) - -{- -ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs --} -{- -Maybe it is better to not use type variable for sample rate, -because ALSA supports only integers, -and if ALSA sample rate and sample rate do not match due to rounding errors, -then play and event fetching get out of sync over the time. --} -withMIDIEvents :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime [Event.T] -> IO a) -> IO a -withMIDIEvents = - withMIDIEventsBlockEcho - - -{- -as a quick hack, we neglect the ALSA time stamp and use getTime or so --} -withMIDIEventsNonblockWaitGrouped :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime [Event.T] -> IO a) -> IO a -withMIDIEventsNonblockWaitGrouped name beat rate proc = - withInPort name SndSeq.Nonblock $ \ h _p -> - do start <- getTimeSeconds - l <- lazySequence $ - flip map (iterate (beat+) start) $ \t -> - wait t >> - liftM - (\evs -> (t, evs)) - (getWaitingEvents h) -{- - liftM2 (,) - getTimeSeconds - (getWaitingEvents h) --} - proc $ - discretizeTime rate $ - AbsEventList.fromPairList l - -{- -With this function latency becomes longer and longer if xruns occur, -but the latency is not just adapted, -but ones xruns occur, this implies more and more xruns. --} -withMIDIEventsNonblockWaitDefer :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a -withMIDIEventsNonblockWaitDefer name beat rate proc = - withInPort name SndSeq.Nonblock $ \ h _p -> - do start <- getTimeSeconds - l <- lazySequence $ - flip map (iterate (beat+) start) $ \t -> - wait t >> - liftM - (\ es -> (t, Nothing) : map (mapSnd Just) es) - (getWaitingStampedEvents h) - proc $ - discretizeTime rate $ - {- - delay events that are in wrong order - disadvantage: we cannot guarantee a beat with a minimal period - -} - flip evalState start $ - AbsEventList.mapTimeM (\t -> modify (max t) >> get) $ - AbsEventList.fromPairList $ concat l - -{- -We risk and endless skipping when the beat is too short. -(Or debug output slows down processing.) --} -withMIDIEventsNonblockWaitSkip :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a -withMIDIEventsNonblockWaitSkip name beat rate proc = - withInPort name SndSeq.Nonblock $ \ h _p -> - do start <- getTimeSeconds - l <- lazySequence $ - flip map (iterate (beat+) start) $ \t -> - do wait t - t0 <- getTimeSeconds - -- print (t-start,t0-start) - es <- - if t0>=t+beat - then return [] - else getWaitingStampedEvents h - return $ - (t0, Nothing) : - map (mapSnd Just) es - proc $ - discretizeTime rate $ - AbsEventList.fromPairList $ concat l - -withMIDIEventsNonblockWaitMin :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a -withMIDIEventsNonblockWaitMin name beat rate proc = - withInPort name SndSeq.Nonblock $ \ h _p -> - do start <- getTimeSeconds - l <- lazySequence $ - flip map (iterate (beat+) start) $ \t -> - wait t >> - liftM - (\ es -> - (minimum $ t : map fst es, Nothing) : - map (mapSnd Just) es) - (getWaitingStampedEvents h) -{- - mapM_ print $ EventList.toPairList $ - discretizeTime rate $ - AbsEventList.fromPairList $ concat l - proc undefined --} - proc $ - discretizeTime rate $ - AbsEventList.fromPairList $ concat l - -withMIDIEventsNonblockConstantPause :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a -withMIDIEventsNonblockConstantPause name beat rate proc = - withInPort name SndSeq.Nonblock $ \ h _p -> - do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> - liftM2 (:) - (liftM (\t->(t,Nothing)) getTimeSeconds) - (liftM (map (mapSnd Just)) (getWaitingStampedEvents h)) - proc $ - discretizeTime rate $ - AbsEventList.fromPairList $ concat l - -withMIDIEventsNonblockSimple :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime Event.T -> IO a) -> IO a -withMIDIEventsNonblockSimple name beat rate proc = - withInPort name SndSeq.Nonblock $ \ h _p -> - do l <- ioToLazyList $ - threadDelay (round $ flip asTypeOf rate $ beat*1e6) >> - getWaitingStampedEvents h - proc $ - discretizeTime rate $ - AbsEventList.fromPairList $ concat l - - -setTimestamping :: - SndSeq.T mode -> Port.T -> Queue.T -> IO () -setTimestamping h p q = do - info <- PortInfo.get h p - PortInfo.setTimestamping info True - PortInfo.setTimestampReal info True - PortInfo.setTimestampQueue info q - PortInfo.set h p info - -withMIDIEventsBlockEcho :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime [Event.T] -> IO a) -> IO a -withMIDIEventsBlockEcho name beat rate proc = - withInPort name SndSeq.Block $ \ h p -> - Queue.with h $ \ q -> - do setTimestamping h p q - Queue.control h q Event.QueueStart 0 Nothing - _ <- Event.drainOutput h - - proc . - discretizeTime rate . - AbsEventList.fromPairList . - concat =<< - (lazySequence $ - flip map (iterate (beat+) 0) $ \t -> - let end = t+beat - in -- (\act -> do evs <- act; print evs; return evs) $ - -- add a laziness break - fmap ((t,[]) :) $ - fmap (map (mapPair (limit (t,end), (:[])))) $ - getStampedEventsUntilTime h q p end) - -{- | -This is like withMIDIEventsBlockEcho -but collects all events at the beginning of the beats. -This way, further processing steps may collapse -all controller events within one beat to one event. --} -withMIDIEventsBlockEchoQuantised :: (RealField.C time) => - ClientName -> time -> time -> - (EventList.T StrictTime [Event.T] -> IO a) -> IO a -withMIDIEventsBlockEchoQuantised name beat rate proc = - withInPort name SndSeq.Block $ \ h p -> - Queue.with h $ \ q -> - do Queue.control h q Event.QueueStart 0 Nothing - _ <- Event.drainOutput h - - proc . - discretizeTime rate . - AbsEventList.fromPairList =<< - (lazySequence $ - flip map (iterate (beat+) 0) $ \t -> - liftM - (\evs -> (t, evs)) - (getEventsUntilTime h q p (t+beat))) - -{- | -Make sure, that @beat@ is an integer multiple of @recip rate@. -Since we round time within each chunk, -we would otherwise accumulate rounding errors over time. --} -withMIDIEventsChunked :: - (RealField.C time) => - ClientName -> time -> time -> - ([IO (EventListTT.T StrictTime [Event.T])] -> IO a) -> - IO a -withMIDIEventsChunked name beat rate proc = - withInPort name SndSeq.Block $ \ h p -> - Queue.with h $ \ q -> - do setTimestamping h p q - Queue.control h q Event.QueueStart 0 Nothing - _ <- Event.drainOutput h - - proc $ - map - (\t -> - let end = t+beat - in liftM - (\evs -> - EventListTM.switchBodyR - (error "withMIDIEventsChunked: empty list, but there must be at least the end event") - const $ - discretizeTime rate $ - AbsEventList.fromPairList $ - (t,[]) : - {- - FIXME: This is a quick hack in order to assert - that all events are within one chunk - and do not lie on the boundary. - -} - map (mapPair (limit (t , end - recip rate), (:[]))) evs ++ - (end, []) : - []) - (getStampedEventsUntilTime h q p end)) - (iterate (beat+) 0) - -withMIDIEventsChunkedQuantised :: - (RealField.C time) => - ClientName -> time -> time -> - ([IO (EventList.T StrictTime [Event.T])] -> IO a) -> - IO a -withMIDIEventsChunkedQuantised name beat rate proc = - withInPort name SndSeq.Block $ \ h p -> - Queue.with h $ \ q -> - do Queue.control h q Event.QueueStart 0 Nothing - _ <- Event.drainOutput h - - proc $ - map - (\t -> - liftM - (\evs -> - EventList.cons NonNeg.zero evs $ - EventList.singleton - (NonNegW.fromNumberMsg "chunked time conversion" $ - round (beat*rate)) []) - (getEventsUntilTime h q p (t+beat))) - (iterate (beat+) 0) - -makeEcho :: - RealField.C time => - Client.T -> Queue.T -> Port.T -> - time -> Event.Custom -> Event.T -makeEcho c q p t dat = - Event.Cons - { Event.highPriority = False - , Event.tag = 0 - , Event.queue = q - , Event.timestamp = - Event.RealTime $ RealTime.fromInteger $ - floor (10^9 * t) - , Event.source = Addr.Cons { - Addr.client = c, - Addr.port = Port.unknown - } - , Event.dest = Addr.Cons { - Addr.client = c, - Addr.port = p - } - , Event.body = Event.CustomEv Event.Echo dat - } - -withMIDIEventsBlock :: (RealField.C time) => - ClientName -> time -> - (EventList.T StrictTime Event.T -> IO a) -> IO a -withMIDIEventsBlock name rate proc = - withInPort name SndSeq.Block $ \ h _p -> - do l <- ioToLazyList $ getStampedEvent h - proc $ - discretizeTime rate $ - AbsEventList.fromPairList l - -withInPort :: - ClientName -> - SndSeq.BlockMode -> - (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t -withInPort (ClientName name) blockMode act = - SndSeq.with SndSeq.defaultName blockMode $ \h -> - Client.setName h name >> - Port.withSimple h "input" - (Port.caps [Port.capWrite, Port.capSubsWrite]) - Port.typeMidiGeneric - (act h) - -{- | -We first discretize the absolute time values, -then we compute differences, -in order to avoid rounding errors in further computations. --} -discretizeTime :: (RealField.C time) => - time -> AbsEventList.T time a -> EventList.T StrictTime a -discretizeTime sampleRate = - EventListMB.mapTimeHead (const $ NonNegW.fromNumber zero) . -- clear first time since it is an absolute system time stamp - EventList.fromAbsoluteEventList . - AbsEventList.mapTime - (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*)) - - --- * event filters - -type Filter = State (EventList.T StrictTime [Event.T]) - - -{- -Maybe we could use StorableVector.Pattern.LazySize -or we could use synthesizer-core/ChunkySize. -What package should we rely on? -Which one is more portable? - -We do not use this type for timing in event lists anymore. -It worked in principle but left us with a couple of memory leaks, -that I could never identify and eliminate completely. --} -type LazyTime = NonNegChunky.T NonNegW.Integer - - -{- | -We turn the strict time values into lazy ones -according to the breaks by our beat. -However for the laziness breaks we ignore the events that are filtered out. -That is we loose laziness granularity -but hopefully gain efficiency by larger blocks. --} -getSlice :: - (Event.T -> Maybe a) -> - Filter (EventList.T StrictTime [a]) -getSlice f = - state $ - EventList.unzip . - fmap (ListHT.partitionMaybe f) - - -type Channel = ChannelMsg.Channel -type Controller = ChannelMsg.Controller -type Pitch = ChannelMsg.Pitch -type Velocity = ChannelMsg.Velocity -type Program = ChannelMsg.Program - - -getControllerEvents :: - Channel -> Controller -> - Filter (EventList.T StrictTime [Int]) -getControllerEvents chan ctrl = - getSlice (Check.controller chan ctrl) - -{- -getControllerEvents :: - Channel -> Controller -> - Filter (EventList.T StrictTime (Maybe Int)) -getControllerEvents chan ctrl = - fmap (fmap (fmap snd . ListHT.viewR)) $ - getSlice (Check.controller chan ctrl) --} - -data NoteBoundary a = - NoteBoundary Pitch Velocity a - | AllNotesOff - deriving (Eq, Show) - -data Note = Note Program Pitch Velocity LazyTime - deriving (Eq, Show) - - -{- -We could also provide a function which filters for specific programs/presets. --} -getNoteEvents :: - Channel -> - Filter (EventList.T StrictTime [Either Program (NoteBoundary Bool)]) -getNoteEvents chan = - getSlice $ checkNoteEvent chan - -checkNoteEvent :: - Channel -> Event.T -> - Maybe (Either Program (NoteBoundary Bool)) -checkNoteEvent chan e = - case Event.body e of - Event.NoteEv notePart note -> - do guard (note ^. MALSA.noteChannel == chan) - let (part,vel) = - MALSA.normalNoteFromEvent notePart note - press <- - case part of - Event.NoteOn -> return True - Event.NoteOff -> return False - _ -> mzero - return $ Right $ NoteBoundary - (note ^. MALSA.notePitch) vel press - Event.CtrlEv Event.PgmChange ctrl -> - do guard (ctrl ^. MALSA.ctrlChannel == chan) - return $ Left $ ctrl ^. MALSA.ctrlProgram - {- - We do not handle AllSoundOff here, - since this would also mean to clear reverb buffers - and this cannot be handled here. - -} - Event.CtrlEv Event.Controller ctrl -> - do guard (ctrl ^. MALSA.ctrlControllerMode == - MALSA.Mode Mode.AllNotesOff) - return $ Right AllNotesOff - _ -> mzero - -embedPrograms :: - Program -> - EventList.T StrictTime [Either Program (NoteBoundary Bool)] -> - EventList.T StrictTime [NoteBoundary (Maybe Program)] -embedPrograms initPgm = - fmap catMaybes . - flip evalState initPgm . - traverse (traverse embedProgramState) - -embedProgramState :: - Either Program (NoteBoundary Bool) -> - State Program (Maybe (NoteBoundary (Maybe Program))) -embedProgramState = - -- evaluate program for every event in order to prevent a space leak - (\n -> state (\s -> (seq s n, s))) - <=< - either - (\pgm -> put pgm >> return Nothing) - (\bnd -> - gets (Just . - case bnd of - AllNotesOff -> const AllNotesOff - NoteBoundary p v press -> - NoteBoundary p v . toMaybe press)) - - -matchNoteEvents :: - EventList.T StrictTime [NoteBoundary (Maybe Program)] -> - EventList.T StrictTime [Note] -matchNoteEvents = - matchNoteEventsCore $ \bndOn -> case bndOn of - AllNotesOff -> Nothing - NoteBoundary pitchOn velOn pressOn -> - flip fmap pressOn $ \pgm -> - (\bndOff -> - case bndOff of - AllNotesOff -> True - NoteBoundary pitchOff _velOff pressOff -> - pitchOn == pitchOff && isNothing pressOff, - Note pgm pitchOn velOn) - -matchNoteEventsCore :: - (noteBnd -> - Maybe (noteBnd -> Bool, LazyTime -> Note)) -> - EventList.T StrictTime [noteBnd] -> - EventList.T StrictTime [Note] -matchNoteEventsCore methods = - let recourseEvents = - EventListMB.switchBodyL $ \evs0 xs0 -> case evs0 of - [] -> ([], xs0) - ev:evs -> - case methods ev of - Nothing -> - recourseEvents (EventListMB.consBody evs xs0) - Just (check, cons) -> - case durationRemove check (EventListMB.consBody evs xs0) of - (dur, xs1) -> - mapFst - (cons dur :) - (recourseEvents xs1) - recourse = - EventList.switchL EventList.empty $ \(t,evs0) xs0 -> - let (evs1,xs1) = recourseEvents (EventListMB.consBody evs0 xs0) - in EventList.cons t evs1 $ recourse xs1 - in recourse - - -{- -durationRemove Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char]) --} -{- | -Search for specific event, -return its time stamp and remove it. --} -durationRemove :: - (NonNeg.C time) => - (body -> Bool) -> - EventListBB.T time [body] -> - (NonNegChunky.T time, EventListBB.T time [body]) -durationRemove p = - let errorEndOfList = - (error "no matching body element found", - error "list ended before matching element found") - recourse = - EventListMB.switchBodyL $ \evs xs0 -> - let (prefix, suffix0) = break p evs - (suffix1, rest) = - case suffix0 of - [] -> ([], - flip (EventListMB.switchTimeL errorEndOfList) xs0 $ \t xs1 -> - mapPair - (NonNegChunky.fromChunks . (t:) . - NonNegChunky.toChunks, - EventListMB.consTime t) $ - recourse xs1) - _:ys -> (ys, (NonNeg.zero, xs0)) - in mapSnd - (EventListMB.consBody (prefix++suffix1)) - rest - in recourse - -durationRemoveTB :: - (NonNeg.C time) => - (body -> Bool) -> - EventList.T time [body] -> - (NonNegChunky.T time, EventList.T time [body]) -durationRemoveTB p = - let errorEndOfList = - (error "no matching body element found", - error "list ended before matching element found") - recourse = - EventList.switchL errorEndOfList $ \(t,evs) xs -> - let (prefix, suffix0) = break p evs - (suffix1, rest) = - case suffix0 of - [] -> ([], recourse xs) - _:ys -> (ys, (NonNeg.zero, xs)) - in mapPair - (NonNegChunky.fromChunks . (t:) . - NonNegChunky.toChunks, - EventList.cons t (prefix++suffix1)) - rest - in recourse - - -makeInstrumentArray :: [instr] -> Array Program instr -makeInstrumentArray instrs = - listArray - (ChannelMsg.toProgram 0, ChannelMsg.toProgram (length instrs - 1)) - instrs - -getInstrumentFromArray :: Array Program instr -> Program -> Program -> instr -getInstrumentFromArray bank defltPgm pgm = - bank ! - if inRange (bounds bank) pgm - then pgm else defltPgm - - - -ioToLazyList :: IO a -> IO [a] -ioToLazyList m = - let go = unsafeInterleaveIO $ liftM2 (:) m go - in go - -lazySequence :: [IO a] -> IO [a] -lazySequence [] = return [] -lazySequence (m:ms) = - unsafeInterleaveIO $ liftM2 (:) m $ lazySequence ms diff --git a/src/Synthesizer/Generic/ALSA/MIDI.hs b/src/Synthesizer/Generic/ALSA/MIDI.hs deleted file mode 100644 --- a/src/Synthesizer/Generic/ALSA/MIDI.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{- | -Convert MIDI events of a MIDI controller to a control signal. --} -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Generic.ALSA.MIDI where - -import Synthesizer.EventList.ALSA.MIDI - (LazyTime, StrictTime, Filter, Channel, - Program, embedPrograms, makeInstrumentArray, getInstrumentFromArray, - Note(Note), matchNoteEvents, getNoteEvents, ) - -import qualified Sound.MIDI.Message.Channel as ChannelMsg - -import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.Generic.Cut as CutG -import qualified Synthesizer.Generic.Signal as SigG - -import qualified Synthesizer.MIDIValue as MV - --- import qualified Data.EventList.Relative.TimeTime as EventListTT --- import qualified Data.EventList.Relative.TimeMixed as EventListTM --- import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Relative.MixedBody as EventListMB -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.TimeBody as EventList - -import Data.Monoid (Monoid, mempty, ) - -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky - -import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field --- import qualified Algebra.Additive as Additive - -import Control.Arrow (Arrow, arr, first, ) -import Control.Category (Category, id, (.), ) -import qualified Control.Monad.Trans.State.Strict as MS -import Control.Monad.Trans.State - (State, evalState, runState, state, gets, put, get, ) -import Control.Monad (liftM, ) -import Data.Traversable (traverse, ) -import Data.Foldable (traverse_, ) - -import Control.DeepSeq (NFData, ) - -import NumericPrelude.Base hiding (id, (.), ) -import NumericPrelude.Numeric -import Prelude () - - - -replicateLong :: - (SigG.Write sig y) => - StrictTime -> y -> sig y -replicateLong tl y = - CutG.concat $ - map (\t -> - SigG.replicate --- (SigG.LazySize $ fromIntegral $ maxBound::Int) - SigG.defaultLazySize - (NonNegW.toNumber t) y) $ - PC.chopLongTime tl - -{- -ToDo: move to Generic.Signal --} -{-# INLINE piecewiseConstant #-} -piecewiseConstant :: - (SigG.Write sig y) => - EventListBT.T StrictTime y -> sig y -piecewiseConstant = - EventListBT.foldrPair - (\y t -> SigG.append (replicateLong t y)) - SigG.empty - -{-# INLINE piecewiseConstantInit #-} -piecewiseConstantInit :: - (SigG.Write sig y) => - y -> EventList.T StrictTime y -> sig y -piecewiseConstantInit initial = - (\ ~(t,rest) -> - SigG.append (replicateLong t initial) rest) - . - EventList.foldr - (,) - (\y ~(t,rest) -> - SigG.append (replicateLong t y) rest) - (0, SigG.empty) - -{-# INLINE piecewiseConstantInitWith #-} -piecewiseConstantInitWith :: - (SigG.Write sig c) => - (y -> c) -> - c -> EventList.T StrictTime [y] -> sig c -piecewiseConstantInitWith f initial = - piecewiseConstantInit initial . - flip evalState initial . - traverse (\evs -> traverse_ (put . f) evs >> get) - - - -type Instrument y signal = y -> y -> LazyTime -> signal -type Bank y signal = Program -> Instrument y signal - -{- | -Instrument parameters are: -velocity from -1 to 1 (0 is the normal pressure, no pressure aka NoteOff is not supported), -frequency is given in Hertz --} -renderInstrument :: - (Trans.C y) => - Bank y signal -> - Note -> - signal -renderInstrument instrument (Note pgm pitch vel dur) = - instrument pgm - (MV.velocity vel) - (MV.frequencyFromPitch pitch) - dur - -renderInstrumentIgnoreProgram :: - (Trans.C y) => - Instrument y signal -> - Note -> - signal -renderInstrumentIgnoreProgram instrument = - renderInstrument (const instrument) - - -{- | -Turn an event list with bundles of elements -into an event list with single events. --} -flatten :: - (Monoid signal, NonNeg.C time) => - EventList.T time [signal] -> - EventList.T time signal -flatten = - EventList.foldr - EventListMB.consTime - (\bt xs -> - uncurry EventListMB.consBody $ - case bt of - [] -> (mempty, xs) - b:bs -> (b, foldr (EventList.cons NonNeg.zero) xs bs)) - EventList.empty - - -applyModulation :: - (CutG.Transform signal, CutG.NormalForm signal) => - signal -> - Modulator (signal -> instr, note) (instr, note) -applyModulation ctrl = - first $ - Modulator ctrl advanceModulationChunk gets - -{- | -We have to evaluate the head value at each 'drop' -in order to avoid growing thunks that lead to a space leak. --} -evaluateVectorHead :: - (CutG.NormalForm signal) => - signal -> t -> t -evaluateVectorHead xs t = - case CutG.evaluateHead xs of () -> t --- if CutG.null xs then t else t - -advanceModulation :: - (CutG.Transform signal, CutG.NormalForm signal) => - LazyTime -> State signal LazyTime -advanceModulation = - liftM NonNegChunky.fromChunks . - mapM advanceModulationChunk . - NonNegChunky.toChunks - -advanceModulationChunk :: - (CutG.Transform signal, CutG.NormalForm signal) => - StrictTime -> State signal StrictTime -advanceModulationChunk t = state $ \xs -> - let ys = CutG.drop (fromIntegral t) xs - in (evaluateVectorHead ys t, ys) - -advanceModulationChunkStrict :: - (CutG.Transform signal, CutG.NormalForm signal) => - StrictTime -> MS.State signal StrictTime -advanceModulationChunkStrict t = MS.state $ \xs -> - let ys = CutG.drop (fromIntegral t) xs - in (evaluateVectorHead ys t, ys) - -advanceModulationChunkPC :: - (NFData body) => - StrictTime -> - State (EventListBT.T StrictTime body) StrictTime -advanceModulationChunkPC t = state $ \xs -> - let ys = - EventListBT.fromPairList $ tail $ - EventListBT.toPairList xs - in (evaluateVectorHead ys t, ys) - -type FilterSequence signal = - Filter (EventList.T PC.ShortStrictTime signal) - -{- | -The state action for the time -should just return the argument time. -However we need this time (or alternatively another result type) -for triggering the 'drop' in 'advanceModulationChunk'. -Without this strict evaluation, -the drop will be delayed until the control curve is actually needed. --} -data Modulator note signal = - forall state. - Modulator - state - (StrictTime -> State state StrictTime) - (note -> State state signal) - -instance Category Modulator where - id = Modulator () return return - (Modulator yInit yTime yBody) . (Modulator xInit xTime xBody) = - let compose ym xm r0 = - state $ \(xState0,yState0) -> - let (r1, xState1) = runState (xm r0) xState0 - (r2, yState1) = runState (ym r1) yState0 - in (r2, (xState1,yState1)) - in Modulator - (xInit,yInit) - (compose yTime xTime) - (compose yBody xBody) - -instance Arrow Modulator where - arr f = Modulator () return (return . f) - first (Modulator xInit xTime xBody) = - Modulator xInit xTime - (\(a0,c) -> fmap (\a1 -> (a1,c)) $ xBody a0) - - -applyModulator :: - Modulator a b -> - EventList.T StrictTime [a] -> - EventList.T StrictTime [b] -applyModulator - (Modulator modulatorInit modulatorTime modulatorBody) = - flip evalState modulatorInit . - EventList.traverse modulatorTime (traverse modulatorBody) - - -{-# INLINE sequenceCore #-} -sequenceCore :: - (Monoid signal) => - Channel -> - Program -> - Modulator Note signal -> - FilterSequence signal -sequenceCore chan initPgm md = - fmap (EventList.mapTime fromIntegral . - flatten . - applyModulator md . - matchNoteEvents . - embedPrograms initPgm) $ - getNoteEvents chan - - -errorNoProgram :: Program -errorNoProgram = - ChannelMsg.toProgram 0 -{- -Since we compute the current program strictly in embedPrograms, -initializing with undefined does no longer work. - error "MIDI program not initialized" --} - - -{-# INLINE sequence #-} -sequence :: - (Monoid signal, Trans.C y) => - Channel -> - Instrument y signal -> - FilterSequence signal -sequence chan instr = - sequenceCore chan errorNoProgram - (Modulator () return - (return . renderInstrumentIgnoreProgram instr)) - - -{-# INLINE sequenceModulated #-} -sequenceModulated :: - (CutG.Transform ctrl, CutG.NormalForm ctrl, - Monoid signal, Trans.C y) => - ctrl -> - Channel -> - (ctrl -> Instrument y signal) -> - FilterSequence signal -sequenceModulated ctrl chan instr = - sequenceCore chan errorNoProgram - (Modulator ctrl advanceModulationChunk - (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note)) - - -{-# INLINE sequenceMultiModulated #-} -sequenceMultiModulated :: - (Monoid signal, Trans.C y) => - Channel -> - instrument -> - Modulator (instrument, Note) (Instrument y signal, Note) -> - FilterSequence signal -sequenceMultiModulated chan instr - (Modulator modulatorInit modulatorTime modulatorBody) = - sequenceCore chan errorNoProgram - (Modulator modulatorInit modulatorTime - (fmap (uncurry renderInstrumentIgnoreProgram) . - modulatorBody . - (,) instr)) - -{-# INLINE sequenceMultiProgram #-} -sequenceMultiProgram :: - (Monoid signal, Trans.C y) => - Channel -> - Program -> - [Instrument y signal] -> - FilterSequence signal -sequenceMultiProgram chan initPgm instrs = - let bank = makeInstrumentArray instrs - in sequenceCore chan initPgm - (Modulator () return - (return . renderInstrument - (getInstrumentFromArray bank initPgm))) - -{-# INLINE sequenceModulatedMultiProgram #-} -sequenceModulatedMultiProgram :: - (CutG.Transform ctrl, CutG.NormalForm ctrl, - Monoid signal, Trans.C y) => - ctrl -> - Channel -> - Program -> - [ctrl -> Instrument y signal] -> - FilterSequence signal -sequenceModulatedMultiProgram ctrl chan initPgm instrs = - let bank = makeInstrumentArray instrs - in sequenceCore chan initPgm - (Modulator - ctrl advanceModulationChunk - (\note -> gets $ \c -> renderInstrument - (\pgm -> getInstrumentFromArray bank initPgm pgm c) note)) diff --git a/src/Synthesizer/MIDIValue.hs b/src/Synthesizer/MIDIValue.hs deleted file mode 100644 --- a/src/Synthesizer/MIDIValue.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Functions for converting MIDI controller and key values -to something meaningful for signal processing. --} -module Synthesizer.MIDIValue where - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field - -import NumericPrelude.Numeric --- import NumericPrelude.Base - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y) => - (y,y) -> Int -> y -controllerLinear (lower,upper) n = - let k = fromIntegral n / 127 - in (1-k) * lower + k * upper - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y) => - (y,y) -> Int -> y -controllerExponential (lower,upper) n = - let k = fromIntegral n / 127 - in lower**(1-k) * upper**k - -{-# INLINE pitchBend #-} -pitchBend :: - (Trans.C y) => - y -> y -> Int -> y -pitchBend range center n = - center * range ** (fromIntegral n / 8192) - -{-# INLINE velocity #-} -velocity :: - (Field.C y) => - VoiceMsg.Velocity -> y -velocity vel = - fromIntegral (VoiceMsg.fromVelocity vel - 64)/63 - -{- | -Convert pitch to frequency according to the default tuning -in MIDI 1.0 Detailed Specification. --} -{-# INLINE frequencyFromPitch #-} -frequencyFromPitch :: - (Trans.C y) => - VoiceMsg.Pitch -> y -frequencyFromPitch pitch = - 440 * 2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12) diff --git a/src/Synthesizer/MIDIValue/BendModulation.hs b/src/Synthesizer/MIDIValue/BendModulation.hs deleted file mode 100644 --- a/src/Synthesizer/MIDIValue/BendModulation.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Combine pitchbend and modulation in one data type. --} -module Synthesizer.MIDIValue.BendModulation where - -import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP -import qualified Synthesizer.MIDIValue as MV - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Ring as Ring - -import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), ) -import qualified Foreign.Storable.Traversable as Store - -import qualified Data.Foldable as Fold -import qualified Data.Traversable as Trav - -import Control.Applicative (Applicative, (<*>), pure, liftA2, ) - -import Control.DeepSeq (NFData, rnf, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -{- | -'bend' is a frequency factor -and 'depth' is a modulation depth to be interpreted by the instrument. --} -data T a = Cons {bend, depth :: a} - deriving (Show, Eq) - -deflt :: (Ring.C a) => T a -deflt = Cons one zero - - -instance (NFData a) => NFData (T a) where - rnf bm = - case rnf (bend bm) of () -> rnf (depth bm) - - -instance Functor T where - {-# INLINE fmap #-} - fmap f (Cons b m) = Cons (f b) (f m) - --- useful for defining 'peek' instance -instance Applicative T where - {-# INLINE pure #-} - pure a = Cons a a - {-# INLINE (<*>) #-} - (Cons fb fm) <*> (Cons b m) = - Cons (fb b) (fm m) - -instance Fold.Foldable T where - {-# INLINE foldMap #-} - foldMap = Trav.foldMapDefault - --- this allows for kinds of generic programming -instance Trav.Traversable T where - {-# INLINE sequenceA #-} - sequenceA (Cons b m) = - liftA2 Cons b m - - -force :: T a -> T a -force ~(Cons a b) = (Cons a b) - -instance (Storable a) => Storable (T a) where - {-# INLINE sizeOf #-} - sizeOf = Store.sizeOf . force - {-# INLINE alignment #-} - alignment = Store.alignment . force - {-# INLINE peek #-} - peek = Store.peekApplicative - {-# INLINE poke #-} - poke = Store.poke - - - -{- | -Multiply the pitch bend by a given factor. -This way you can e.g. shift the pitch bend from around 1 -to the actual frequency. --} -shift :: - (Ring.C a) => - a -> T a -> T a -shift k (Cons b d) = Cons (k*b) d - -fromBendWheelPressure :: - (RealRing.C a, Trans.C a) => - Int -> a -> a -> - BWP.T -> T a -fromBendWheelPressure - pitchRange wheelDepth pressDepth bwp = - Cons - (MV.pitchBend (2^?(fromIntegral pitchRange/12)) 1 (BWP.bend_ bwp)) - (MV.controllerLinear (0,wheelDepth) (BWP.wheel_ bwp) + - MV.controllerLinear (0,pressDepth) (BWP.pressure_ bwp)) diff --git a/src/Synthesizer/MIDIValue/BendWheelPressure.hs b/src/Synthesizer/MIDIValue/BendWheelPressure.hs deleted file mode 100644 --- a/src/Synthesizer/MIDIValue/BendWheelPressure.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.MIDIValue.BendWheelPressure where - -import qualified Data.Accessor.Basic as Accessor - -import Control.DeepSeq (NFData, rnf, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -data T = Cons {bend_, wheel_, pressure_ :: Int} - deriving (Show, Eq) - -deflt :: T -deflt = Cons 0 0 0 - - -bend, wheel, pressure :: Accessor.T T Int -bend = - Accessor.fromSetGet - (\b (Cons _ w p) -> Cons b w p) - bend_ - -wheel = - Accessor.fromSetGet - (\w (Cons b _ p) -> Cons b w p) - wheel_ - -pressure = - Accessor.fromSetGet - (\p (Cons b w _) -> Cons b w p) - pressure_ - - -instance NFData T where - rnf (Cons b w p) = - case (rnf b, rnf w, rnf p) of - ((), (), ()) -> () diff --git a/src/Synthesizer/PiecewiseConstant/ALSA/MIDI.hs b/src/Synthesizer/PiecewiseConstant/ALSA/MIDI.hs deleted file mode 100644 --- a/src/Synthesizer/PiecewiseConstant/ALSA/MIDI.hs +++ /dev/null @@ -1,188 +0,0 @@ -{- | -Convert MIDI events of a MIDI controller to a control signal. --} -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.PiecewiseConstant.ALSA.MIDI ( - T, - duration, - PC.zipWith, - - initWith, - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - bendWheelPressure, - checkBendWheelPressure, - bendWheelPressureZip, - ) where - -import qualified Synthesizer.EventList.ALSA.MIDI as Ev -import Synthesizer.EventList.ALSA.MIDI (LazyTime, StrictTime, Filter, Channel, ) - -import qualified Sound.MIDI.ALSA.Check as Check -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.MIDIValue.BendModulation as BM -import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP -import qualified Synthesizer.MIDIValue as MV - -import qualified Synthesizer.PiecewiseConstant.Signal as PC - --- import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.TimeBody as EventList - -import qualified Numeric.NonNegative.Class as NonNeg --- import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field - -import qualified Data.Accessor.Monad.Trans.State as AccState -import Control.Monad.Trans.State (State, evalState, state, get, put, ) -import Control.Monad (liftM, liftM2, msum, ) -import Data.Traversable (traverse, sequence, ) -import Data.Foldable (traverse_, ) - -import qualified Data.List.HT as ListHT -import qualified Data.List as List -import Data.Either (Either(Left, Right), ) -import Data.Maybe (maybe, ) -import Data.Function ((.), ($), flip, ) - -import NumericPrelude.Numeric -import Prelude as P (Maybe, fmap, (>>), ) - - -type T = EventListBT.T StrictTime - - -duration :: T y -> LazyTime -duration = - NonNegChunky.fromChunks . EventListBT.getTimes - - -{-# INLINE initWith #-} -initWith :: - (y -> c) -> - c -> EventList.T StrictTime [y] -> T c -initWith f initial = -{- - EventListTM.switchBodyR EventListBT.empty - (\xs _ -> EventListMT.consBody initial xs) . --} - EventListMT.consBody initial . - flip EventListTM.snocTime NonNeg.zero . - flip evalState initial . - traverse - (\ys -> traverse_ (put . f) ys >> get) - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y) => - Channel -> Ev.Controller -> - (y,y) -> y -> - Filter (T y) -controllerLinear chan ctrl bnd initial = - liftM (initWith (MV.controllerLinear bnd) initial) $ - Ev.getControllerEvents chan ctrl - - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y) => - Channel -> Ev.Controller -> - (y,y) -> y -> - Filter (T y) -controllerExponential chan ctrl bnd initial = - liftM (initWith (MV.controllerExponential bnd) initial) $ - Ev.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) => - Channel -> - y -> y -> - Filter (T y) -pitchBend chan range center = - liftM (initWith (MV.pitchBend range center) center) $ - Ev.getSlice (Check.pitchBend chan) --- getPitchBendEvents chan - -{-# INLINE channelPressure #-} -channelPressure :: - (Trans.C y) => - Channel -> - y -> y -> - Filter (T y) -channelPressure chan maxVal initVal = - liftM (initWith (MV.controllerLinear (0,maxVal)) initVal) $ - Ev.getSlice (Check.channelPressure chan) - - -{-# INLINE bendWheelPressure #-} -bendWheelPressure :: - (RealRing.C y, Trans.C y) => - Channel -> - Int -> y -> y -> - Filter (T (BM.T y)) -bendWheelPressure chan - pitchRange wheelDepth pressDepth = - let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth - in liftM (initWith toBM (toBM BWP.deflt)) $ - state $ - EventList.unzip . - fmap ListHT.unzipEithers . - flip evalState BWP.deflt . - traverse (traverse (separateBWP chan)) - -separateBWP :: Channel -> Event.T -> State BWP.T (Either BWP.T Event.T) -separateBWP chan ev = - fmap (maybe (Right ev) Left) $ - checkBendWheelPressure chan ev - -{- | -I hesitate to move this to MIDIValue or BendWheelPressure module -because it depends on ALSA specific Event. --} -checkBendWheelPressure :: - Channel -> Event.T -> State BWP.T (Maybe BWP.T) -checkBendWheelPressure chan ev = - sequence $ - (fmap (>> get)) $ - msum $ List.map ($ev) $ - (fmap (AccState.set BWP.bend) . Check.pitchBend chan) : - (fmap (AccState.set BWP.wheel) . Check.controller chan VoiceMsg.modulation) : - (fmap (AccState.set BWP.pressure) . Check.channelPressure chan) : - [] - -{- | -This one is certainly not as efficient as 'bendWheelPressure' -since it first slices the event list -and then zips the slices together. --} -{-# INLINE bendWheelPressureZip #-} -bendWheelPressureZip :: - (RealRing.C y, Trans.C y) => - Channel -> - Int -> y -> y -> - Filter (T (BM.T y)) -bendWheelPressureZip chan - pitchRange wheelDepth pressDepth = - liftM2 (PC.zipWith BM.Cons) - (pitchBend chan (2^?(fromIntegral pitchRange/12)) 1) - (liftM2 (PC.zipWith (+)) - (controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0) - (channelPressure chan pressDepth 0)) diff --git a/src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs b/src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs deleted file mode 100644 --- a/src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs +++ /dev/null @@ -1,379 +0,0 @@ -{- | -Treat a stream of MIDI events as parallel streams of MIDI controller events. --} -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet ( - T(Cons), - mapStream, - - Controller(Controller,PitchBend,Pressure), - fromChannel, - maybeController, - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - bendWheelPressure, - checkBendWheelPressure, - bendWheelPressureZip, - - -- * internal data needed in synthesizer-llvm - initial, stream, - ) where - -import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.EventList.ALSA.MIDI as Ev -import Synthesizer.EventList.ALSA.MIDI (StrictTime, Channel, ) - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.MIDI.ALSA.Check as Check -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Synthesizer.MIDIValue.BendModulation as BM -import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP -import qualified Synthesizer.MIDIValue as MV - -import qualified Synthesizer.Generic.Cut as CutG -import Control.DeepSeq (NFData, rnf, ) - -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Relative.BodyTime as EventListBT --- import qualified Data.EventList.Relative.TimeBody as EventListTB - -import qualified Numeric.NonNegative.Class as NonNeg98 --- import qualified Numeric.NonNegative.Wrapper as NonNegW --- import qualified Numeric.NonNegative.Chunky as NonNegChunky --- import Numeric.NonNegative.Class ((-|), ) - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field -import qualified Algebra.Additive as Additive - -import qualified Data.Map as Map -import Data.Map (Map, ) - -import qualified Data.Accessor.Monad.Trans.State as AccState -import qualified Data.Accessor.Basic as Acc -import Control.Monad.Trans.State (State, evalState, state, get, put, ) -import Control.Monad (liftM2, msum, ) -import Data.Traversable (traverse, ) -import Data.Foldable (traverse_, ) -import Data.Monoid (Monoid, mempty, mappend, ) - -import Data.Maybe.HT (toMaybe, ) -import Data.Tuple.HT (mapFst, mapPair, ) -import qualified Data.List.HT as ListHT -import qualified Data.List as List - -import NumericPrelude.Numeric -import NumericPrelude.Base -import qualified Prelude as P - (Num, Integral, fromInteger, fromIntegral, toInteger, sum, ) - - -{- -This data structure stores the initial values of all supported controllers -and an event list of all changes of individal controllers. --} -data T key a = - Cons { - initial :: Map key a, - stream :: EventListTT.T StrictTime [(key, a)] - } - deriving Show - - -mapStream :: - (EventListTT.T StrictTime [(key, a)] -> - EventListTT.T StrictTime [(key, a)]) -> - T key a -> T key a -mapStream f s = Cons (initial s) (f (stream s)) - - -data Controller = - Controller VoiceMsg.Controller - | PitchBend - | Pressure - deriving (Show, Eq, Ord) - -instance NFData Controller where - rnf (Controller c) = - rnf (VoiceMsg.fromController c) - rnf _ = () - - -fromChannel :: - Channel -> - Ev.Filter (T Controller Int) -fromChannel chan = - fmap (Cons Map.empty) $ - fmap (flip EventListTM.snocTime NonNeg98.zero) $ - Ev.getSlice (maybeController chan) - -maybeController :: - Channel -> Event.T -> Maybe (Controller, Int) -maybeController chan e = msum $ - (fmap (mapFst Controller) $ Check.anyController chan e) : - (fmap ((,) PitchBend) $ Check.pitchBend chan e) : - (fmap ((,) Pressure) $ Check.channelPressure chan e) : - [] - - -instance CutG.Read (T key a) where - null = - List.null . List.filter (> P.fromInteger 0) . - EventListTT.getTimes . stream - length = - fromIntegral . P.toInteger . - P.sum . EventListTT.getTimes . stream - -instance Monoid (T key y) where - mempty = Cons Map.empty (EventListTT.pause mempty) - mappend x y = - Cons - (initial x) - (EventListTT.append (stream x) (flatten y)) - -instance (NFData key, NFData a) => CutG.NormalForm (T key a) where - evaluateHead xs = rnf (initial xs) - -{- | -Prepend the initial values as events to the event-list. --} -flatten :: - T key a -> EventListTT.T StrictTime [(key, a)] -flatten xs = - EventListTT.cons - mempty (Map.toList $ initial xs) - (stream xs) - - -mapInsertMany :: - (Ord key) => - [(key,a)] -> Map key a -> Map key a -mapInsertMany assignments inits = - foldl (flip (uncurry Map.insert)) inits assignments - - -reverseList :: - (Ord key) => - (Map key a, [(key,a)]) -> - (Map key a, [(key,a)]) -reverseList (inits,xs) = - foldl - (\(inits0,ys) (key,a) -> - let (ma,inits1) = - Map.insertLookupWithKey - (\ _k new _old -> new) key a inits0 - in (inits1, - maybe - (error "MIDIControllerSet.reverse: uninitialized controller") - ((,) key) ma - : ys)) - (inits, []) - xs - -{- | -For reverse you must make sure, -that all controller events have an corresponding initial value. -Controllers that miss an initial value -their last constant piece will be undefined. --} -instance (Ord key) => CutG.Transform (T key y) where - take n = - mapStream (EventListTT.takeTime (P.fromIntegral n)) - - drop n0 xs = - let recourse n inits = - EventListMT.switchTimeL $ \t xs1 -> - let (b,d) = snd $ NonNeg98.split t n - in mapStream (EventListTT.forceTimeHead) $ - if not b - then Cons inits (EventListMT.consTime d xs1) - else - flip (EventListMT.switchBodyL - (Cons inits (EventListTT.pause mempty))) xs1 $ \assignments xs2 -> - recourse d (mapInsertMany assignments inits) xs2 - in recourse (P.fromIntegral n0) (initial xs) (stream xs) - - -- cf. ChunkySize.dropMarginRem - dropMarginRem n m xs = - List.foldl' - (\(mi,xsi) k -> (mi-k, CutG.drop k xsi)) - (m, xs) - (List.map P.fromIntegral $ EventListTT.getTimes $ - EventListTT.takeTime (P.fromIntegral m) $ - EventListTT.dropTime (P.fromIntegral n) $ - stream xs) - - -- cf. StorableVector.Lazy.splitAt - splitAt n0 xs = - let recourse n inits = - EventListMT.switchTimeL $ \t xs1 -> - let (m, ~(b,d)) = NonNeg98.split t n - in mapPair - (EventListMT.consTime m, - mapStream (EventListTT.forceTimeHead)) $ - if not b - then - (EventListBT.empty, - Cons inits (EventListMT.consTime d xs1)) - else - flip (EventListMT.switchBodyL - (EventListBT.empty, - Cons inits (EventListTT.pause mempty))) xs1 $ \keyAs xs2 -> - mapFst (EventListMT.consBody keyAs) $ - recourse d (mapInsertMany keyAs inits) xs2 - in mapFst (Cons (initial xs)) $ - recourse (P.fromIntegral n0) (initial xs) (stream xs) - - reverse xs = - EventListTT.foldl - (\(inits,ys) t -> Cons inits $ EventListMT.consTime t ys) - (\(Cons inits0 ys) evs0 -> - let (inits1, evs1) = reverseList (inits0, evs0) - in (inits1, EventListMT.consBody evs1 ys)) - (initial xs, EventListBT.empty) - (stream xs) -{- -*Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet Data.EventList.Relative.MixedTime> CutG.reverse $ Cons (Map.singleton 'a' GT) (2 /. [('a',EQ)] ./ 3 /. empty) :: T Char Ordering --} - - - -type Filter = State (T Controller Int) - - -_errorUninitialized :: Controller -> Int -_errorUninitialized c = - error $ - "getSlice: uninitialized controller " ++ show c - -{-# INLINE getSlice #-} -getSlice :: - Controller -> - (Int -> a) -> - a -> Filter (PC.T a) -getSlice c f deflt = - state $ \xs -> - let (ys,zs) = - EventListTT.unzip $ - fmap - (ListHT.partitionMaybe - (\(ci,a) -> toMaybe (c==ci) a)) - (stream xs) - (yin0,zis) = - Map.updateLookupWithKey - (\ _k _a -> Nothing) c - (initial xs) - yin1 = maybe deflt f yin0 - fill = - flip evalState yin1 . - traverse - (\ys0 -> traverse_ (put . f) ys0 >> get) - in (EventListMT.consBody yin1 (fill ys), - Cons zis zs) - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Field.C y) => - Ev.Controller -> (y,y) -> y -> Filter (PC.T y) -controllerLinear ctrl bnd = - getSlice (Controller ctrl) (MV.controllerLinear bnd) - - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Trans.C y) => - Ev.Controller -> (y,y) -> y -> Filter (PC.T y) -controllerExponential ctrl bnd = - getSlice (Controller ctrl) (MV.controllerExponential bnd) - - - -{- | -@pitchBend channel range center@: -emits frequencies on an exponential scale from -@center/range@ to @center*range@. --} -{-# INLINE pitchBend #-} -pitchBend :: - (Trans.C y) => - y -> y -> - Filter (PC.T y) -pitchBend range center = - getSlice PitchBend (MV.pitchBend range center) center - -{-# INLINE channelPressure #-} -channelPressure :: - (Trans.C y) => - y -> y -> - Filter (PC.T y) -channelPressure maxVal = - getSlice Pressure (MV.controllerLinear (Additive.zero,maxVal)) - - - --- adapted from getSlice -{-# INLINE bendWheelPressure #-} -bendWheelPressure :: - (RealRing.C y, Trans.C y) => - Int -> y -> y -> - Filter (PC.T (BM.T y)) -bendWheelPressure pitchRange wheelDepth pressDepth = - state $ \xs -> - let (ys,zs) = - EventListTT.unzip $ - fmap ListHT.unzipEithers $ - flip evalState BWP.deflt $ - traverse (traverse separateBWP) (stream xs) - move key field (bwp,mp) = - mapFst (maybe bwp (\y -> Acc.set field y bwp)) $ - Map.updateLookupWithKey - (\ _k _a -> Nothing) key mp - (yin,zis) = - move PitchBend BWP.bend $ - move (Controller VoiceMsg.modulation) BWP.wheel $ - move Pressure BWP.pressure $ - (BWP.deflt, initial xs) - fill = - flip evalState yin . - traverse - (\ys0 -> traverse_ put ys0 >> get) - in (fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $ - EventListMT.consBody yin (fill ys), - Cons zis zs) - -separateBWP :: - (Controller, Int) -> State BWP.T (Either BWP.T (Controller, Int)) -separateBWP ev = - fmap (maybe (Right ev) Left) $ - checkBendWheelPressure ev - -checkBendWheelPressure :: - (Controller, Int) -> State BWP.T (Maybe BWP.T) -checkBendWheelPressure (ctrl,val) = - let update field = AccState.set field val >> fmap Just get - in case ctrl of - PitchBend -> update BWP.bend - Pressure -> update BWP.pressure - Controller cc -> - if cc == VoiceMsg.modulation - then update BWP.wheel - else return $ Nothing - - -{-# INLINE bendWheelPressureZip #-} -bendWheelPressureZip :: - (RealRing.C y, Trans.C y) => - Int -> y -> y -> - Filter (PC.T (BM.T y)) -bendWheelPressureZip pitchRange wheelDepth pressDepth = - liftM2 (PC.zipWith BM.Cons) - (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1) - (liftM2 (PC.zipWith (+)) - (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0) - (channelPressure pressDepth 0)) diff --git a/src/Synthesizer/Storable/ALSA/MIDI.hs b/src/Synthesizer/Storable/ALSA/MIDI.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/MIDI.hs +++ /dev/null @@ -1,319 +0,0 @@ -{- | -Convert MIDI events of a MIDI controller to a control signal. --} -{-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Storable.ALSA.MIDI ( - chunkSizesFromLazyTime, - piecewiseConstant, - piecewiseConstantInit, - piecewiseConstantInitWith, - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - bendWheelPressure, - - Instrument, Bank, - sequenceCore, - sequence, - sequenceModulated, - sequenceMultiModulated, - applyModulation, - advanceModulationLazy, - advanceModulationStrict, - advanceModulationChunky, - sequenceMultiProgram, - - Gen.renderInstrument, - Gen.renderInstrumentIgnoreProgram, - Gen.evaluateVectorHead, - Gen.advanceModulationChunk, - ) where - -import Synthesizer.EventList.ALSA.MIDI - (LazyTime, StrictTime, Filter, Note, - Program, Channel, Controller, - getControllerEvents, getSlice, ) -import qualified Synthesizer.Generic.ALSA.MIDI as Gen -import qualified Synthesizer.MIDIValue as MV - -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy.Pattern as SigStV -import qualified Data.StorableVector.Lazy as SVL - -import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.State.Oscillator as OsciS -import qualified Synthesizer.State.Displacement as DispS -import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS -import qualified Synthesizer.Basic.Wave as Wave - -import qualified Sound.MIDI.ALSA.Check as Check -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import qualified Synthesizer.PiecewiseConstant.Signal as PC --- import qualified Data.EventList.Relative.TimeTime as EventListTT --- import qualified Data.EventList.Relative.MixedTime as EventListMT --- import qualified Data.EventList.Relative.MixedBody as EventListMB -import qualified Data.EventList.Relative.BodyTime as EventListBT --- import qualified Data.EventList.Relative.BodyMixed as EventListBM --- import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Data.EventList.Relative.TimeBody as EventList - -import Foreign.Storable (Storable, ) - --- import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field -import qualified Algebra.Additive as Additive - -import Control.Monad.Trans.State (State, evalState, state, modify, put, get, ) -import Control.Monad (liftM, ) -import Data.Traversable (traverse, ) -import Data.Foldable (traverse_, ) - -import NumericPrelude.Base hiding (sequence, ) -import NumericPrelude.Numeric - - - -chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize -chunkSizesFromStrictTime = - NonNegChunky.fromChunks . - map (SVL.ChunkSize . NonNegW.toNumber) . - PC.chopLongTime - - -chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize -chunkSizesFromLazyTime = - NonNegChunky.fromChunks . - map (SVL.ChunkSize . NonNegW.toNumber) . - concatMap PC.chopLongTime . - NonNegChunky.toChunks . - NonNegChunky.normalize - - - -{- -ToDo: move to Storable.Signal --} -{-# INLINE piecewiseConstant #-} -piecewiseConstant :: - (Storable y) => - EventListBT.T StrictTime y -> SigSt.T y -piecewiseConstant = - EventListBT.foldrPair - (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y)) - SigSt.empty - -{-# INLINE piecewiseConstantInit #-} -piecewiseConstantInit :: - (Storable y) => - y -> EventList.T StrictTime y -> SigSt.T y -piecewiseConstantInit initial = - (\ ~(t,rest) -> - SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) initial) rest) - . - EventList.foldr - (,) - (\y ~(t,rest) -> - SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y) rest) - (0, SigSt.empty) -{- - piecewiseConstant . --- EventListBM.switchBodyR const . --- EventListBM.snocTime NonNeg.zero . --- EventListMB.consBody initial . - -- switchBodyR causes a space leak - EventListTM.switchBodyR EventListBT.empty - (\xs _ -> EventListMT.consBody initial xs) --} - -{-# INLINE piecewiseConstantInitWith #-} -piecewiseConstantInitWith :: - (Storable c) => - (y -> c) -> - c -> EventList.T StrictTime [y] -> SigSt.T c -piecewiseConstantInitWith f initial = - piecewiseConstantInit initial . - flip evalState initial . - traverse (\evs -> traverse_ (put . f) evs >> get) - - -{-# INLINE controllerLinear #-} -controllerLinear :: - (Storable y, Field.C y) => - Channel -> Controller -> - (y,y) -> y -> - Filter (SigSt.T y) -controllerLinear chan ctrl bnd initial = - liftM (piecewiseConstantInitWith (MV.controllerLinear bnd) initial) $ - getControllerEvents chan ctrl - - -{-# INLINE controllerExponential #-} -controllerExponential :: - (Storable y, Trans.C y) => - Channel -> Controller -> - (y,y) -> y -> - Filter (SigSt.T y) -controllerExponential chan ctrl bnd initial = - liftM (piecewiseConstantInitWith (MV.controllerExponential bnd) initial) $ - getControllerEvents chan ctrl - - -{- | -@pitchBend channel range center@: -emits frequencies on an exponential scale from -@center/range@ to @center*range@. --} -{-# INLINE pitchBend #-} -pitchBend :: - (Storable y, Trans.C y) => - Channel -> - y -> y -> - Filter (SigSt.T y) -pitchBend chan range center = - liftM (piecewiseConstantInitWith (MV.pitchBend range center) center) $ - getSlice (Check.pitchBend chan) --- getPitchBendEvents chan - -{-# INLINE channelPressure #-} -channelPressure :: - (Storable y, Trans.C y) => - Channel -> - y -> y -> - Filter (SigSt.T y) -channelPressure chan maxVal initVal = - liftM (piecewiseConstantInitWith (MV.controllerLinear (0,maxVal)) initVal) $ - getSlice (Check.channelPressure chan) - - -{- -We could use 'getBendWheelPressureSignal' here, -but this may be less efficient. --} -{-# INLINE bendWheelPressure #-} -bendWheelPressure :: - (Storable y, RealRing.C y, Trans.C y) => - Channel -> - Int -> y -> y -> y -> - Filter (SigSt.T y) -bendWheelPressure chan - pitchRange speed wheelDepth pressDepth = - do bend <- pitchBend chan (2^?(fromIntegral pitchRange/12)) 1 - fm <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0 - press <- channelPressure chan pressDepth 0 - return $ - flip (SigS.zipWithStorable (*)) bend $ - SigS.map (1+) $ - FiltNRS.envelope - (DispS.mix - (SigS.fromStorableSignal fm) - (SigS.fromStorableSignal press)) - (OsciS.static Wave.sine zero speed) - - -type Instrument y yv = Gen.Instrument y (SigSt.T yv) -type Bank y yv = Gen.Bank y (SigSt.T yv) - - -{-# INLINE sequenceCore #-} -sequenceCore :: - (Storable yv, Additive.C yv) => - SVL.ChunkSize -> - Channel -> - Program -> - Gen.Modulator Note (SigSt.T yv) -> - Filter (SigSt.T yv) -sequenceCore chunkSize chan pgm modu = - fmap (CutSt.arrangeEquidist chunkSize) $ - Gen.sequenceCore chan pgm modu - - -{-# INLINE sequence #-} -sequence :: - (Storable yv, Additive.C yv, Trans.C y) => - SVL.ChunkSize -> - Channel -> - Instrument y yv -> - Filter (SigSt.T yv) -sequence chunkSize chan bank = - fmap (CutSt.arrangeEquidist chunkSize) $ - Gen.sequence chan bank - - -{-# INLINE sequenceModulated #-} -sequenceModulated :: - (Storable c, Storable yv, Additive.C yv, Trans.C y) => - SVL.ChunkSize -> - SigSt.T c -> - Channel -> - (SigSt.T c -> Instrument y yv) -> - Filter (SigSt.T yv) -sequenceModulated chunkSize modu chan instr = - fmap (CutSt.arrangeEquidist chunkSize) $ - Gen.sequenceModulated modu chan instr - - -{-# INLINE sequenceMultiModulated #-} -sequenceMultiModulated :: - (Storable yv, Additive.C yv, Trans.C y) => - SVL.ChunkSize -> - Channel -> - instrument -> - Gen.Modulator (instrument, Note) (Instrument y yv, Note) -> - Filter (SigSt.T yv) -sequenceMultiModulated chunkSize chan instr modu = - fmap (CutSt.arrangeEquidist chunkSize) $ - Gen.sequenceMultiModulated chan instr modu - - -applyModulation :: - (Storable c) => - SigSt.T c -> - Gen.Modulator (SigSt.T c -> instr, note) (instr, note) -applyModulation = - Gen.applyModulation - -advanceModulationLazy, advanceModulationStrict, advanceModulationChunky :: - (Storable a) => - LazyTime -> State (SigSt.T a) LazyTime - -{- -This one drops lazily, -such that the control signal will be cached until it is used. -That is, if for a long time no new note is played, -more and more memory will be allocated. --} -advanceModulationLazy t = - modify (SigStV.drop (chunkSizesFromLazyTime t)) >> return t - -{- -This one is too strict, -because the complete drop is forced -also if only the first chunk of the lazy time is requested. --} -advanceModulationStrict t = state $ \xs -> - let ys = SigStV.drop (chunkSizesFromLazyTime t) xs - in (Gen.evaluateVectorHead ys t, ys) - -advanceModulationChunky = - Gen.advanceModulation - - -{-# INLINE sequenceMultiProgram #-} -sequenceMultiProgram :: - (Storable yv, Additive.C yv, Trans.C y) => - SVL.ChunkSize -> - Channel -> - Program -> - [Instrument y yv] -> - Filter (SigSt.T yv) -sequenceMultiProgram chunkSize chan pgm bank = - fmap (CutSt.arrangeEquidist chunkSize) $ - Gen.sequenceMultiProgram chan pgm bank diff --git a/src/Synthesizer/Storable/ALSA/Play.hs b/src/Synthesizer/Storable/ALSA/Play.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/Play.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Play audio signals via ALSA. -The module could also be called @Output@, -because with a @file@ sink, data can also be written to disk. --} -module Synthesizer.Storable.ALSA.Play ( - -- * auxiliary functions - Device, - defaultDevice, - defaultChunkSize, - makeSink, - write, - writeLazy, - -- * play functions - auto, - autoAndRecord, - autoAndRecordMany, - monoToInt16, - stereoToInt16, - ) where - -import qualified Sound.ALSA.PCM as ALSA - -import qualified Synthesizer.Frame.Stereo as Stereo -import qualified Synthesizer.Basic.Binary as BinSmp - -import qualified Sound.Sox.Frame as SoxFrame -import qualified Sound.Sox.Write as SoxWrite -import qualified Sound.Sox.Option.Format as SoxOption - -import Foreign.Storable (Storable, ) -import Foreign.Marshal.Array (advancePtr, ) -import Foreign.Ptr (Ptr, minusPtr, ) -import Data.Int (Int16, ) -import qualified System.IO as IO -import qualified System.Exit as Exit - --- import qualified Synthesizer.State.Signal as SigS - -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector.Base as SVB - -import qualified Algebra.RealRing as RealRing - -import qualified Data.Traversable as Trav -import qualified Data.Foldable as Fold - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -{- | -A suggested default chunk size. -It is not used by the functions in this module. --} -{- -Better move to Storable.Server.Common or Dimensional.Server.Common? --} -defaultChunkSize :: SigSt.ChunkSize -defaultChunkSize = SigSt.chunkSize 512 -{- -At some epochs this chunk size leads to buffer underruns. -I cannot reproduce this: -Some months it works this way on Suse but not on Ubuntu or vice versa. -Other months it works the other way round. -defaultChunkSize = SigSt.chunkSize 256 --} - - -type Device = String - -defaultDevice :: Device -defaultDevice = "default" - - -{- | -Useful values for the output device are - -* @\"default\"@ for mixing with the output of other applications. - -* @\"plughw:0,0\"@ for accessing sound output in an exclusive way. - -* @\"tee:default,'output.raw',raw\"@ for playing and simultaneously writing raw data to disk. - -* @\"tee:default,'output.wav',wav\"@ for playing and writing to WAVE file format. - Note that the length cannot be written, - when the program is terminated, - leaving the file in an invalid format. --} -makeSink :: - (ALSA.SampleFmt y, RealRing.C t) => - Device {- ^ ALSA output device -} -> - t {- ^ period (buffer) size expressed in seconds -} -> - ALSA.SampleFreq {- ^ sample rate -} -> - ALSA.SoundSink y ALSA.Pcm -makeSink device periodTime rate = - ALSA.alsaSoundSinkTime device - (ALSA.SoundFmt { - ALSA.sampleFreq = rate - }) $ - ALSA.SoundBufferTime - (round (5000000*periodTime)) - (round (1000000*periodTime)) - -{- -alsaOpen: only few buffer underruns with - let buffer_time = 200000 -- 0.20s - period_time = 40000 -- 0.04s - -However the delay is still perceivable. - -Latency for keyboard playback might be better with: - let buffer_time = 50000 -- 0.05s - period_time = 10000 -- 0.01s -but we get too much underruns, -without actually achieving the required latency. --} -{-# INLINE auto #-} -auto :: - (ALSA.SampleFmt y) => - ALSA.SoundSink y handle -> - SigSt.T y -> IO () -auto sink ys = - ALSA.withSoundSink sink $ \to -> - writeLazy sink to ys - -{-# INLINE writeLazy #-} -writeLazy :: - (Storable a) => - ALSA.SoundSink a handle -> handle -> - SVL.Vector a -> IO () -writeLazy sink to ys = - mapM_ (write sink to) (SVL.chunks ys) - -{-# INLINE write #-} -write :: - (Storable a) => - ALSA.SoundSink a handle -> handle -> - SVB.Vector a -> IO () -write sink to c = - SVB.withStartPtr c $ \ptr size -> - ALSA.soundSinkWrite sink to ptr size - - --- cf. Alsa.hs -{-# INLINE arraySize #-} -arraySize :: Storable y => Ptr y -> Int -> Int -arraySize p n = advancePtr p n `minusPtr` p - -{- | -Play a signal and write it to disk via SoX simultaneously. -Consider using 'auto' with @tee@ device. --} -{-# INLINE autoAndRecord #-} -autoAndRecord :: - (ALSA.SampleFmt y, SoxFrame.C y) => - FilePath -> - ALSA.SoundSink y handle -> - SigSt.T y -> IO Exit.ExitCode -autoAndRecord fileName sink = - let rate = ALSA.sampleFreq $ ALSA.soundSinkFmt sink - in (\act -> - SoxWrite.simple act SoxOption.none fileName rate) $ \h ys -> - ALSA.withSoundSink sink $ \to -> - flip mapM_ (SVL.chunks ys) $ \c -> - SVB.withStartPtr c $ \ptr size -> - ALSA.soundSinkWrite sink to ptr size >> - IO.hPutBuf h ptr (arraySize ptr size) - - -{- | -Play a signal and write it to multiple files. -The Functor @f@ may be @Maybe@ for no or one file to write, -or @[]@ for many files to write. --} -{-# INLINE autoAndRecordMany #-} -autoAndRecordMany :: - (ALSA.SampleFmt y, SoxFrame.C y, - Trav.Traversable f) => - f FilePath -> - ALSA.SoundSink y handle -> - SigSt.T y -> IO (f Exit.ExitCode) -autoAndRecordMany fileNames sink = - let rate = ALSA.sampleFreq $ ALSA.soundSinkFmt sink - in (\act -> - SoxWrite.manyExtended act SoxOption.none SoxOption.none fileNames rate) $ \hs ys -> - ALSA.withSoundSink sink $ \to -> - flip mapM_ (SVL.chunks ys) $ \c -> - SVB.withStartPtr c $ \ptr size -> - ALSA.soundSinkWrite sink to ptr size >> - Fold.traverse_ (\h -> IO.hPutBuf h ptr (arraySize ptr size)) hs - - -{-# INLINE monoToInt16 #-} -monoToInt16 :: - (Storable y, RealRing.C y) => - ALSA.SoundSink Int16 handle -> - SigSt.T y -> IO () -monoToInt16 sink xs = - auto sink (SigSt.map BinSmp.int16FromCanonical xs) - -{-# INLINE stereoToInt16 #-} -stereoToInt16 :: - (Storable y, RealRing.C y) => - ALSA.SoundSink (Stereo.T Int16) handle -> - SigSt.T (Stereo.T y) -> IO () -stereoToInt16 sink xs = - auto sink (SigSt.map (fmap BinSmp.int16FromCanonical) xs) diff --git a/src/Synthesizer/Storable/ALSA/Server.hs b/src/Synthesizer/Storable/ALSA/Server.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/Server.hs +++ /dev/null @@ -1,113 +0,0 @@ -module Main where - -import qualified Synthesizer.Storable.ALSA.Server.Run as Run -import qualified Synthesizer.Storable.ALSA.Server.Test as Test -import Synthesizer.Storable.ALSA.Server.Common - (Real, play, sampleRate, chunkSize, periodTime, ) - -import qualified Synthesizer.Basic.Wave as Wave - -import qualified Synthesizer.Storable.ALSA.Play as Play -import qualified Synthesizer.Storable.Oscillator as OsciSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL - -import NumericPrelude.Numeric (zero, ) -import Prelude hiding (Real, break, id, (.), ) - - -{- -This program has still a very slowly growing memory leak. --} -main :: IO () -main = - case 208::Int of - 001 -> print Test.keyboard3 - 002 -> play (periodTime::Real) sampleRate Test.keyboard3 - 003 -> Test.speed - 004 -> Test.frequency1 - 005 -> Test.frequency2 - 006 -> Test.frequency3 -{- - 007 -> Test.frequency4 --} - 008 -> Test.keyboard1 - 009 -> SigSt.writeFile "test.f32" Test.keyboard2 - 010 -> SigSt.writeFile "test.f32" Test.keyboard3 - 011 -> SigSt.writeFile "test.f32" Test.keyboard4 - 012 -> SigSt.writeFile "test.f32" Test.keyboard5 -{- - 013 -> Test.keyboard6 - 014 -> Test.keyboard7 --} - 015 -> Test.arrangeSpaceLeak0 - 016 -> Test.arrangeSpaceLeak1 - 018 -> Test.arrangeSpaceLeak3 - 019 -> Test.arrangeSpaceLeak4 - 020 -> Test.chordSpaceLeak1 --- 021 -> Test.chordSpaceLeak2 --- 022 -> Test.chordSpaceLeak3 --- 023 -> Test.chordSpaceLeak4 - 023 -> Test.sequencePitchBend - 024 -> Test.sequencePitchBend1 - 025 -> Test.sequencePitchBend2 - 026 -> Test.sequencePitchBend3 - 027 -> Test.sequencePitchBend4 - 028 -> Test.sequencePitchBend4a - 029 -> Test.sequencePitchBend4b - 030 -> Test.sequencePitchBend4c - 031 -> Test.sequencePitchBend4d - 032 -> Test.sequencePitchBend4e - 033 -> Test.sequencePitchBend5 - 040 -> Test.sequenceStaccato - 050 -> Test.speed - 051 -> Test.speedChunky - 052 -> Test.speedArrange - 053 -> Play.auto -{- - (ALSA.alsaSoundSinkTime Play.defaultDevice - (ALSA.SoundFmt { - ALSA.sampleFreq = sampleRate - }) $ - ALSA.SoundBufferTime - (round (5000000*periodTime::Real)) - (round (1000000*periodTime::Real)) - ) $ --} -{- - (ALSA.fileSoundSink "test.f32" - (ALSA.SoundFmt { - ALSA.sampleFreq = sampleRate - })) $ --} - (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $ - SVL.cycle $ - SigSt.take 100000 $ - OsciSt.static chunkSize (fmap (0.9*) Wave.sine) zero (1/100::Real) - 054 -> Play.auto - (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $ - OsciSt.static chunkSize (fmap (0.9*) Wave.sine) - zero (600/sampleRate::Real) - 055 -> play (periodTime::Real) sampleRate $ - OsciSt.static chunkSize (fmap (0.9*) Wave.sine) - zero (600/sampleRate::Real) - 100 -> Run.volume - 101 -> Run.frequency - 102 -> Run.frequencyCausal - 103 -> Run.pitchBend - 104 -> Run.volumeFrequency - 105 -> Run.volumeFrequencyCausal - 200 -> Run.keyboard - 201 -> Run.keyboardMulti - 202 -> Run.keyboardStereo - 203 -> Run.keyboardPitchbend - 204 -> Run.keyboardFM - 205 -> Run.keyboardDetuneFM - 206 -> Run.keyboardFilter - 207 -> Run.keyboardSample - 208 -> Run.keyboardVariousStereo - 209 -> Run.keyboardSampleTFM - 210 -> Run.keyboardNoisyTone - 211 -> Run.keyboardFilteredNoisyTone - 300 -> Run.keyboardCausal - _ -> error "not implemented server part" diff --git a/src/Synthesizer/Storable/ALSA/Server/Common.hs b/src/Synthesizer/Storable/ALSA/Server/Common.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/Server/Common.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Synthesizer.Storable.ALSA.Server.Common where - -import qualified Sound.ALSA.PCM as ALSA -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.Storable.ALSA.Play as Play - -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv -import Synthesizer.EventList.ALSA.MIDI (Channel, StrictTime, ) - -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL - -import qualified Synthesizer.Generic.Signal as SigG - -import qualified Sound.MIDI.Message.Channel as ChannelMsg - -import qualified Data.EventList.Relative.TimeBody as EventList - -import qualified Sound.Sox.Frame as SoxFrame -import qualified System.Exit as Exit - -import Control.Category ((.), ) - -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.Additive as Additive - -import NumericPrelude.Numeric (zero, round, ) -import Prelude hiding (Real, round, break, id, (.), ) - - -channel :: Channel -channel = ChannelMsg.toChannel 0 - -sampleRate :: Num a => a --- sampleRate = 24000 --- sampleRate = 48000 -sampleRate = 44100 - -latency :: Int -latency = 0 --- latency = 256 --- latency = 1000 - -chunkSize :: SVL.ChunkSize -chunkSize = Play.defaultChunkSize - -lazySize :: SigG.LazySize -lazySize = - let (SVL.ChunkSize size) = chunkSize - in SigG.LazySize size - -periodTime :: Field.C t => t -periodTime = - let (SVL.ChunkSize size) = chunkSize - in ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate - -device :: Play.Device -device = Play.defaultDevice - -clientName :: MIDIEv.ClientName -clientName = MIDIEv.ClientName "Haskell-Synthesizer" - - -type Real = Float - - -{-# INLINE withMIDIEvents #-} -withMIDIEvents :: - (Double -> Double -> a -> IO b) -> - (EventList.T StrictTime [Event.T] -> a) -> IO b -withMIDIEvents action proc = - let rate = sampleRate - per = periodTime - in MIDIEv.withMIDIEvents clientName per rate $ - action per rate . proc - - -{-# INLINE play #-} -play :: - (RealField.C t, Additive.C y, ALSA.SampleFmt y) => - t -> t -> SigSt.T y -> IO () -play period rate = - Play.auto (Play.makeSink device period (round rate)) . - SigSt.append (SigSt.replicate chunkSize latency zero) --- FiltG.delayPosLazySize chunkSize latency --- FiltG.delayPos latency - --- ToDo: do not record the empty chunk that is inserted for latency -{-# INLINE playAndRecord #-} -playAndRecord :: - (RealField.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) => - FilePath -> t -> t -> SigSt.T y -> IO Exit.ExitCode -playAndRecord fileName period rate = - Play.autoAndRecord fileName (Play.makeSink device period (round rate)) . - SigSt.append (SigSt.replicate chunkSize latency zero) diff --git a/src/Synthesizer/Storable/ALSA/Server/Instrument.hs b/src/Synthesizer/Storable/ALSA/Server/Instrument.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/Server/Instrument.hs +++ /dev/null @@ -1,486 +0,0 @@ -module Synthesizer.Storable.ALSA.Server.Instrument where - -import Synthesizer.Storable.ALSA.Server.Common - -import Synthesizer.Storable.ALSA.MIDI ( - Instrument, chunkSizesFromLazyTime, ) - -import Synthesizer.EventList.ALSA.MIDI (LazyTime, ) - -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa -import qualified Synthesizer.CausalIO.Gate as Gate -import qualified Synthesizer.CausalIO.Process as PIO - -import qualified Synthesizer.Basic.Wave as Wave -import qualified Synthesizer.Frame.Stereo as Stereo - -import qualified Synthesizer.Causal.Process as Causal -import qualified Synthesizer.Causal.Oscillator as OsciC -import qualified Synthesizer.Causal.Interpolation as Interpolation -import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC -import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC -import qualified Synthesizer.Interpolation.Module as Ip -import Control.Arrow ((<<<), (^<<), (<<^), (***), ) - -import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy.Pattern as SigStV -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV - -import qualified Synthesizer.Generic.Wave as WaveG -import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.State.Control as CtrlS -import qualified Synthesizer.State.Noise as NoiseS -import qualified Synthesizer.State.Oscillator as OsciS -import qualified Synthesizer.State.Displacement as DispS -import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS -import qualified Synthesizer.Plain.Filter.Recursive as FiltR -import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter --- import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG --- import qualified Synthesizer.Basic.Phase as Phase - -import qualified Sound.Sox.Read as SoxRead -import qualified Sound.Sox.Option.Format as SoxOption - -import Control.Monad.Trans.State (get, modify, ) -import Control.Monad (mzero, ) -import Control.Category ((.), ) - -import NumericPrelude.Numeric (zero, round, (*>), ) -import Prelude hiding (Real, round, break, id, (.), ) - - - -{-# INLINE amplitudeFromVelocity #-} -amplitudeFromVelocity :: Real -> Real -amplitudeFromVelocity vel = 4**vel - -{-# INLINE ping #-} -ping :: Real -> Real -> SigSt.T Real -ping vel freq = - SigS.toStorableSignal chunkSize $ - FiltNRS.envelope (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $ - OsciS.static Wave.saw zero (freq/sampleRate) - -pingDur :: Instrument Real Real -pingDur vel freq dur = - SigStV.take (chunkSizesFromLazyTime dur) $ - ping vel freq - -pingCausal :: PAlsa.Instrument Real (SV.Vector Real) -pingCausal vel freq = - (PIO.fromCausal $ - Causal.applyStorableChunk $ - Causal.feed $ - FiltNRS.envelope - (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $ - OsciS.static Wave.saw zero (freq/sampleRate)) - <<< - Gate.toStorableVector - -pingReleaseEnvelope :: Real -> LazyTime -> SigSt.T Real -pingReleaseEnvelope vel dur = - SigSt.switchR SigSt.empty - (\body x -> - SigSt.append body $ - SigS.toStorableSignal chunkSize $ - SigS.take (round (0.3*sampleRate :: Real)) $ - CtrlS.exponential2 (0.1*sampleRate) x) $ - SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel) - -pingRelease :: Instrument Real Real -pingRelease vel freq dur = - SigS.zipWithStorable (*) - (OsciS.static Wave.saw zero (freq/sampleRate)) - (pingReleaseEnvelope vel dur) - -pingStereoRelease :: Instrument Real (Stereo.T Real) -pingStereoRelease vel freq dur = --- SigS.zipWithStorable (\y c -> fmap (c*) y) - SigS.zipWithStorable (flip (*>)) - (SigS.zipWith Stereo.cons - (OsciS.static Wave.saw zero (freq*0.999/sampleRate)) - (OsciS.static Wave.saw zero (freq*1.001/sampleRate))) - (pingReleaseEnvelope vel dur) - -pingReleaseEnvelopeCausal :: Real -> PIO.T PAlsa.GateChunk (SV.Vector Real) -pingReleaseEnvelopeCausal vel = - PIO.continue - ((PIO.fromCausal $ - Causal.applyStorableChunk $ Causal.feed $ - CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel)) - <<< - Gate.toStorableVector - {- - <<< - arr (\x -> trace (show x) x) -}) - (\y -> -- trace ("continue with " ++ show y) $ - (PIO.fromCausal $ - Causal.applyStorableChunk $ Causal.feed $ - SigS.take (round (1*sampleRate :: Real)) $ - CtrlS.exponential2 (0.1*sampleRate) y) - <<< - Gate.allToStorableVector) - -pingReleaseCausal :: PAlsa.Instrument Real (SV.Vector Real) -pingReleaseCausal vel freq = - (PIO.fromCausal $ - Causal.applyStorableChunk $ - FiltNRC.envelope <<< - Causal.feedFst (OsciS.static Wave.saw zero (freq/sampleRate))) - <<< - pingReleaseEnvelopeCausal vel - -tine :: Instrument Real Real -tine vel freq dur = - SigS.zipWithStorable (*) - (OsciS.phaseMod Wave.sine (freq/sampleRate) - (FiltNRS.envelope - (CtrlS.exponential (1*sampleRate) (vel+1)) - (OsciS.static Wave.sine zero (2*freq/sampleRate)))) - (pingReleaseEnvelope 0 dur) - -tineStereo :: Instrument Real (Stereo.T Real) -tineStereo vel freq dur = - let ctrl f = - FiltNRS.envelope - (CtrlS.exponential (1*sampleRate) (vel+1)) - (OsciS.static Wave.sine zero (2*f/sampleRate)) - in SigS.zipWithStorable (flip (*>)) - (SigS.zipWith Stereo.cons - (OsciS.phaseMod Wave.sine (freq*0.995/sampleRate) (ctrl freq)) - (OsciS.phaseMod Wave.sine (freq*1.005/sampleRate) (ctrl freq))) - (pingReleaseEnvelope 0 dur) - - -softStringReleaseEnvelope :: - Real -> LazyTime -> SigSt.T Real -softStringReleaseEnvelope vel dur = - let attackTime = sampleRate - amp = amplitudeFromVelocity vel - cnst = CtrlS.constant amp - {- - release <- take attackTime beginning - would yield a space leak, thus we first split 'beginning' - and then concatenate it again - -} - {- - We can not easily generate attack and sustain separately, - because we want to use the chunk structure implied by 'dur'. - -} - (attack, sustain) = - SigSt.splitAt attackTime $ - SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - flip SigS.append cnst $ - SigS.map ((amp*) . sin) $ - CtrlS.line attackTime (0, pi/2) - release = SigSt.reverse attack - in attack `SigSt.append` sustain `SigSt.append` release - --- it's better to avoid inlining here -softString :: Instrument Real (Stereo.T Real) -softString vel freq dur = - let f = freq/sampleRate - {-# INLINE osci #-} - osci d = - OsciS.static Wave.saw zero (d * f) - in flip (SigS.zipWithStorable (flip (*>))) - (softStringReleaseEnvelope vel dur) - (SigS.map ((0.3::Real)*>) $ - SigS.zipWith Stereo.cons - (DispS.mix - (osci 1.005) - (osci 0.998)) - (DispS.mix - (osci 1.002) - (osci 0.995))) - - -softStringReleaseEnvelopeCausal :: - Real -> LazyTime -> SigSt.T Real -softStringReleaseEnvelopeCausal vel dur = - Causal.apply - (softStringReleaseEnvelopeCausalProcess vel) - (SigSt.append - (SigStV.replicate (chunkSizesFromLazyTime dur) True) - (SigSt.repeat chunkSize False)) - - -{-# INLINE softStringReleaseEnvelopeCausalProcess #-} -softStringReleaseEnvelopeCausalProcess :: - Real -> Causal.T Bool Real -softStringReleaseEnvelopeCausalProcess vel = - let vol = amplitudeFromVelocity vel - attackTime = sampleRate - {-# INLINE sine #-} - sine x = sin (x*pi/(2*attackTime)) - in Causal.fromStateMaybe - (\b -> - get >>= \n -> - if b - then - if n==attackTime - then return vol - else - modify (1+) >> - return (vol * sine n) - else - if n==0 - then mzero - else - modify (subtract 1) >> - return (vol * sine n)) - zero - -{-# INLINE softStringCausalProcess #-} -softStringCausalProcess :: Real -> Causal.T Real (Stereo.T Real) -softStringCausalProcess freq = - let f = freq/sampleRate - {-# INLINE osci #-} - osci d = - OsciS.static Wave.saw zero (d * f) - in Causal.applySnd - (Causal.map (uncurry (*>))) - (SigS.map ((0.3::Real)*>) $ - SigS.zipWith Stereo.cons - (DispS.mix - (osci 1.005) - (osci 0.998)) - (DispS.mix - (osci 1.002) - (osci 0.995))) - -softStringCausal :: Instrument Real (Stereo.T Real) -softStringCausal vel freq dur = - Causal.apply - (softStringCausalProcess freq <<< - softStringReleaseEnvelopeCausalProcess vel) - (SigSt.append - (SigStV.replicate (chunkSizesFromLazyTime dur) True) - (SigSt.repeat chunkSize False)) - - -stringStereoFM :: SigSt.T Real -> Instrument Real (Stereo.T Real) -stringStereoFM fmSt vel freq dur = - let fm = SigS.fromStorableSignal fmSt - in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - FiltNRS.amplifyVector (amplitudeFromVelocity vel) $ - SigS.zipWith Stereo.cons - (OsciS.freqMod Wave.saw zero $ - FiltNRS.amplify (freq*0.999/sampleRate) fm) - (OsciS.freqMod Wave.saw zero $ - FiltNRS.amplify (freq*1.001/sampleRate) fm) - -stringStereoDetuneFM :: - SigSt.T Real -> SigSt.T Real -> Instrument Real (Stereo.T Real) -stringStereoDetuneFM detuneSt fmSt vel freq dur = - let fm = SigS.fromStorableSignal fmSt - detune = SigS.fromStorableSignal detuneSt - {-# INLINE osci #-} - osci = - OsciS.freqMod Wave.saw zero . - FiltNRS.amplify (freq/sampleRate) . - FiltNRS.envelope fm - in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - FiltNRS.amplifyVector (amplitudeFromVelocity vel) $ - SigS.zipWith Stereo.cons - (osci $ SigS.map (1-) detune) - (osci $ SigS.map (1+) detune) - -{-# INLINE sampledSoundGenerator #-} -sampledSoundGenerator :: (Real, SigSt.T Real) -> Real -> SigS.T Real -sampledSoundGenerator (period, sample) freq = - Causal.apply - (Interpolation.relativeZeroPad zero Ip.linear zero - (SigS.fromStorableSignal sample)) $ - SigS.repeat (freq/sampleRate*period) - -sampledSound :: (Real, SigSt.T Real) -> Instrument Real Real -sampledSound sound vel freq dur = - SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - SigS.map ((amplitudeFromVelocity vel) *) $ - sampledSoundGenerator sound freq - -sampledSoundDetuneStereo :: - Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real) -sampledSoundDetuneStereo detune sound vel freq dur = - SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - SigS.map ((amplitudeFromVelocity vel) *>) $ - SigS.zipWith Stereo.cons - (sampledSoundGenerator sound (freq*(1-detune))) - (sampledSoundGenerator sound (freq*(1+detune))) - -sampleReleaseEnvelope :: Real -> Real -> LazyTime -> SigSt.T Real -sampleReleaseEnvelope halfLife vel dur = - let amp = amplitudeFromVelocity vel - in SigSt.append - (SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - CtrlS.constant amp) - (SigS.toStorableSignal chunkSize $ - SigS.take (round (5*halfLife*sampleRate :: Real)) $ - CtrlS.exponential2 (halfLife*sampleRate) amp) - -sampledSoundDetuneStereoRelease :: - Real -> Real -> (Real, SigSt.T Real) -> Instrument Real (Stereo.T Real) -sampledSoundDetuneStereoRelease release detune sound vel freq dur = - flip (SigS.zipWithStorable (flip (*>))) - (sampleReleaseEnvelope release vel dur) $ - SigS.zipWith Stereo.cons - (sampledSoundGenerator sound (freq*(1-detune))) - (sampledSoundGenerator sound (freq*(1+detune))) - - -readPianoSample :: IO (Real, SigSt.T Real) -readPianoSample = - fmap ((,) 96) $ - SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<< - SoxRead.open SoxOption.none "a-piano3" - -readStringSample :: IO (Real, SigSt.T Real) -readStringSample = - fmap ((,) 64) $ - SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<< - SoxRead.open SoxOption.none "strings7.s8" - - -{- | -Resample a sampled sound with a smooth loop -using our time manipulation algorithm. -Time is first controlled linearly, -then switches to a sine or triangular control. -Loop start must be large enough in order provide enough spare data -for interpolation at the beginning -and loop start plus length must preserve according space at the end. -One period is enough space for linear interpolation. -The infinite sound we generate is not just a cycle, -that uses bounded space. -Instead we need to compute all the time. -In order to avoid duplicate interpolation, -we have merged resampling and time looping. --} -{-# INLINE sampledSoundTimeLoop #-} -sampledSoundTimeLoop :: - (Real -> Real -> Real -> Real -> SigS.T Real) -> - (Real, SigSt.T Real) -> Real -> Real -> Instrument Real Real -sampledSoundTimeLoop loopTimeMod - (period, sample) loopLen loopStart vel freq dur = - let wave = WaveG.sampledTone Ip.linear Ip.linear period sample - in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - (((0.2 * amplitudeFromVelocity vel) *) ^<< - OsciC.shapeMod wave zero (freq/sampleRate)) - `Causal.apply` - loopTimeMod period (loopLen/2) (loopStart + loopLen/2) freq - -{- -Graphics.Gnuplot.Simple.plotList [] (SigS.toList $ SigS.take 20000 $ loopTimeMod 64 1000 2000 440) --} -loopTimeModSine :: Real -> Real -> Real -> Real -> SigS.T Real -loopTimeModSine period loopDepth loopCenter freq = - let rate = freq*period/sampleRate - in SigS.append - (SigS.takeWhile (loopCenter>=) $ - SigS.iterate (rate+) zero) - (SigS.map (\t -> loopCenter + loopDepth * sin t) $ - SigS.iterate ((rate/loopDepth)+) zero) - -loopTimeModZigZag :: Real -> Real -> Real -> Real -> SigS.T Real -loopTimeModZigZag period loopDepth loopCenter freq = - let rate = freq*period/sampleRate - in SigS.append - (SigS.takeWhile (loopCenter>=) $ - SigS.iterate (rate+) zero) - (SigS.map (\t -> loopCenter + loopDepth * t) $ - OsciS.static Wave.triangle zero (rate/(4*loopDepth))) - - - -timeModulatedSample :: (Real, SigSt.T Real) -> - SigSt.T Real -> SigSt.T Real -> SigSt.T Real -> Instrument Real Real -timeModulatedSample (period, sample) offsetMod speedMod freqMod vel freq dur = - let wave = WaveG.sampledTone Ip.linear Ip.linear period sample - in SigStV.take (chunkSizesFromLazyTime dur) $ -{- - (((0.2 * amplitudeFromVelocity vel) *) ^<< - OsciC.freqMod Wave.saw zero <<< - Causal.map ((freq/sampleRate) *)) - `Causal.apply` freqMod --} - (((0.2 * amplitudeFromVelocity vel) *) ^<< - OsciC.shapeFreqMod wave zero <<< - (uncurry (+) ^<< Causal.feedFst offsetMod <<< IntegC.run) *** - Causal.map ((freq/sampleRate) *)) - `Causal.applyFst` speedMod - `Causal.apply` freqMod - - -colourNoise :: - SigSt.T Real -> SigSt.T Real -> - Instrument Real Real -colourNoise resonanceMod freqMod vel freq dur = - SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - ((((sqrt sampleRate/2000 * amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<< - UniFilter.causal) - `Causal.applyFst` - SigS.zipWith - (\r f -> UniFilter.parameter $ FiltR.Pole r (f*freq/sampleRate)) - (SigS.fromStorableSignal resonanceMod) - (SigS.fromStorableSignal freqMod) - `Causal.apply` NoiseS.white - - -toneFromNoise :: - SigSt.T Real -> SigSt.T Real -> - Instrument Real Real -toneFromNoise speedMod freqMod vel freq dur = - SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - (((0.1 * amplitudeFromVelocity vel) *) ^<< - OsciC.shapeFreqModFromSampledTone - Ip.linear Ip.linear - 100 (SigS.toStorableSignal chunkSize NoiseS.white) - zero zero <<< - Causal.second (Causal.map ((freq/sampleRate)*))) - `Causal.applyFst` - SigS.fromStorableSignal speedMod - `Causal.apply` - SigS.fromStorableSignal freqMod - -{- -I like to control the filter parameters -before phase and time modulation. -Unfortunately this means, -that we have to translate those control signals back -using the speed profile, which is tricky. -We need an inverse frequency modulation, that is: - -freqMod ctrl (invFreqMod ctrl signal) = signal - -The problem is, that the chunk boundaries will not match. -invFreqMod must be a StorableSignal function and it is not causal -in any of its inputs. --} -toneFromFilteredNoise :: - SigSt.T Real -> SigSt.T Real -> - SigSt.T Real -> SigSt.T Real -> - Instrument Real Real -toneFromFilteredNoise resonanceMod cutoffMod speedMod freqMod vel freq dur = - let period = 100 - filtNoise = - ((((amplitudeFromVelocity vel) *) . UniFilter.lowpass) ^<< - UniFilter.causal <<< Causal.feedSnd NoiseS.white - <<^ (\(r,f) -> UniFilter.parameter $ - FiltR.Pole r (f/period))) - `Causal.applyFst` - FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod resonanceMod - `Causal.apply` - FiltNRSt.inverseFrequencyModulationFloor chunkSize speedMod cutoffMod - in SigStV.take (chunkSizesFromLazyTime dur) $ - (((0.1 * amplitudeFromVelocity vel) *) ^<< - OsciC.shapeFreqModFromSampledTone - Ip.linear Ip.linear - period filtNoise - zero zero <<< - Causal.second (Causal.map ((freq/sampleRate)*))) - `Causal.applyFst` speedMod - `Causal.apply` freqMod diff --git a/src/Synthesizer/Storable/ALSA/Server/Run.hs b/src/Synthesizer/Storable/ALSA/Server/Run.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/Server/Run.hs +++ /dev/null @@ -1,330 +0,0 @@ -module Synthesizer.Storable.ALSA.Server.Run where - -import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr -import Synthesizer.Storable.ALSA.Server.Common - (Real, withMIDIEvents, play, device, clientName, - sampleRate, lazySize, chunkSize, periodTime, channel, ) - -import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt -import Synthesizer.Storable.ALSA.MIDI (applyModulation, ) - -import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa -import qualified Synthesizer.CausalIO.Process as PIO - -import qualified Synthesizer.Causal.Oscillator as OsciC -import qualified Synthesizer.Causal.Process as Causal -import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC - -import qualified Synthesizer.Basic.Wave as Wave - -import qualified Synthesizer.Interpolation.Module as Ip - -import qualified Synthesizer.Storable.Oscillator as OsciSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV -import Foreign.Storable (Storable, ) - -import qualified Synthesizer.Generic.Loop as LoopG -import qualified Synthesizer.Generic.Signal as SigG -import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.Plain.Filter.Recursive as FiltR -import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import Control.Monad.Trans.State (evalState, ) -import Control.Category ((.), ) -import Control.Arrow (arr, second, (&&&), ) - -import Data.Tuple.HT (mapSnd, ) - -import NumericPrelude.Numeric (zero, (*>), (^?), ) -import Prelude hiding (Real, round, break, id, (.), ) - - - -volume :: IO () -volume = - putStrLn "run 'aconnect' to connect to the MIDI controller" >> - (withMIDIEvents play $ - SigSt.zipWith (*) - (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) . - evalState (AlsaSt.controllerLinear channel VoiceMsg.mainVolume (0,1) (0.2::Real))) - -frequency :: IO () -frequency = - withMIDIEvents play $ - OsciSt.freqMod chunkSize Wave.sine zero . - evalState (AlsaSt.controllerExponential channel VoiceMsg.modulation - (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real)) - - -{-# INLINE storableChunk #-} -storableChunk :: - (SigG.Read sig a, Storable a) => - sig a -> SV.Vector a -storableChunk chunk = - SigS.toStrictStorableSignal (SigG.length chunk) $ - SigG.toState chunk - -frequencyCausal :: IO () -frequencyCausal = - PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate - ((PIO.fromCausal $ - Causal.applyStorableChunk $ - OsciC.freqMod (fmap (0.99*) Wave.sine) zero) - . - arr storableChunk - . - (PAlsa.controllerExponential channel VoiceMsg.modulation - (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real))) - - -pitchBend :: IO () -pitchBend = - withMIDIEvents play $ - OsciSt.freqMod chunkSize Wave.sine zero . - evalState (AlsaSt.pitchBend channel 2 (880/sampleRate::Real)) - -volumeFrequency :: IO () -volumeFrequency = - putStrLn "run 'aconnect' to connect to the MIDI controller" >> - (withMIDIEvents play $ - evalState (do - vol <- AlsaSt.controllerLinear channel VoiceMsg.mainVolume (0,1) 0.5 - freq <- AlsaSt.pitchBend channel 2 (880/sampleRate::Real) - return $ - SigSt.zipWith (*) vol - (OsciSt.freqMod chunkSize Wave.sine zero freq))) - -volumeFrequencyCausal :: IO () -volumeFrequencyCausal = - PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate - ((PIO.fromCausal $ - Causal.applyStorableChunk $ - FiltNRC.envelope - . - second (OsciC.freqMod Wave.sine zero)) - . - arr (uncurry (SV.zipWith (,))) - . - (arr storableChunk - . - PAlsa.controllerLinear channel VoiceMsg.mainVolume (0,0.99) (0.5::Real) - &&& - arr storableChunk - . - PAlsa.pitchBend channel 2 (880/sampleRate::Real))) - - -keyboard :: IO () -keyboard = - withMIDIEvents play $ --- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . - SigSt.map (0.2*) . - evalState (AlsaSt.sequence chunkSize channel Instr.tine) - -keyboardMulti :: IO () -keyboardMulti = - withMIDIEvents play $ --- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . - SigSt.map (0.2*) . - evalState (AlsaSt.sequenceMultiProgram chunkSize channel - (VoiceMsg.toProgram 2) - [Instr.pingDur, Instr.pingRelease, Instr.tine]) - -keyboardStereo :: IO () -keyboardStereo = - withMIDIEvents play $ --- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) . - SigSt.map ((0.2::Real)*>) . - evalState (AlsaSt.sequenceMultiProgram chunkSize channel - (VoiceMsg.toProgram 1) - [Instr.pingStereoRelease, Instr.tineStereo, - Instr.softString, Instr.softStringCausal]) - -keyboardPitchbend :: IO () -keyboardPitchbend = - withMIDIEvents play $ - SigSt.map ((0.2::Real)*>) . - evalState - (do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1 - AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) - -keyboardFM :: IO () -keyboardFM = - withMIDIEvents play $ - SigSt.map ((0.2::Real)*>) . - evalState - (do fm <- AlsaSt.bendWheelPressure channel - 2 (10/sampleRate) 0.04 0.03 - AlsaSt.sequenceModulated chunkSize fm channel Instr.stringStereoFM) - -keyboardDetuneFM :: IO () -keyboardDetuneFM = - withMIDIEvents play $ - SigSt.map ((0.2::Real)*>) . - evalState - (do fm <- AlsaSt.bendWheelPressure channel - 2 (10/sampleRate) 0.04 0.03 - detune <- AlsaSt.controllerLinear channel - VoiceMsg.vectorX (0,0.005) 0 - AlsaSt.sequenceMultiModulated - chunkSize channel Instr.stringStereoDetuneFM - (applyModulation fm . - applyModulation detune)) - - -keyboardFilter :: IO () -keyboardFilter = - withMIDIEvents play $ - SigSt.map (0.2*) . - evalState - (do music <- AlsaSt.sequence chunkSize channel Instr.pingRelease - freq <- AlsaSt.controllerLinear channel - -- VoiceMsg.vectorY - (VoiceMsg.toController 21) - (100/sampleRate, 5000/sampleRate) - (700/sampleRate) - return $ - SigS.toStorableSignal chunkSize $ - SigS.map UniFilter.lowpass $ - SigS.modifyModulated - UniFilter.modifier - (SigS.map UniFilter.parameter $ - SigS.zipWith FiltR.Pole - (SigS.repeat (5 :: Real)) - (SigS.fromStorableSignal freq)) $ - SigS.fromStorableSignal music) - - -keyboardSample :: IO () -keyboardSample = - do piano <- Instr.readPianoSample - string <- Instr.readStringSample - let loopedString = mapSnd (LoopG.simple 8750 500) string - fadedString = mapSnd (LoopG.fade (undefined::Real) 8750 500) string - timeSineString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlSine 8750 500 string - timeZigZagString = LoopG.timeReverse lazySize Ip.linear Ip.linear LoopG.timeControlZigZag 8750 500 string - withMIDIEvents play $ - SigSt.map (0.2*) . - evalState (AlsaSt.sequenceMultiProgram chunkSize channel - (VoiceMsg.toProgram 5) $ - Instr.sampledSound piano : - Instr.sampledSound string : - Instr.sampledSound loopedString : - Instr.sampledSound fadedString : - Instr.sampledSound timeSineString : - Instr.sampledSound timeZigZagString : - Instr.sampledSoundTimeLoop Instr.loopTimeModSine string 8750 500 : - Instr.sampledSoundTimeLoop Instr.loopTimeModZigZag string 8750 500 : - []) - - -keyboardVariousStereo :: IO () -keyboardVariousStereo = - do piano <- Instr.readPianoSample - string <- Instr.readStringSample - let loopedString = - LoopG.timeReverse lazySize Ip.linear Ip.linear - LoopG.timeControlZigZag 8750 500 string - withMIDIEvents play $ - SigSt.map ((0.2::Real)*>) . - evalState (AlsaSt.sequenceMultiProgram chunkSize channel - (VoiceMsg.toProgram 0) $ - Instr.pingStereoRelease : - Instr.tineStereo : - Instr.softString : - Instr.sampledSoundDetuneStereo 0.001 piano : - Instr.sampledSoundDetuneStereo 0.002 loopedString : - Instr.sampledSoundDetuneStereoRelease 0.1 0.001 piano : - Instr.sampledSoundDetuneStereoRelease 0.3 0.002 loopedString : - []) - - -keyboardSampleTFM :: IO () -keyboardSampleTFM = - do instr <- Instr.readPianoSample - withMIDIEvents play $ - evalState - (do fm <- AlsaSt.bendWheelPressure channel - 2 (10/sampleRate) 0.04 0.03 - speed <- AlsaSt.controllerLinear channel - (VoiceMsg.toController 22) - (0,2) 1 - offset <- AlsaSt.controllerLinear channel - (VoiceMsg.toController 21) - (0, fromIntegral (SVL.length (snd instr))) 0 - AlsaSt.sequenceMultiModulated - chunkSize channel (Instr.timeModulatedSample instr) - (applyModulation fm . - applyModulation speed . - applyModulation offset)) - - -keyboardNoisePipe :: IO () -keyboardNoisePipe = - withMIDIEvents play $ - evalState - (do fm <- AlsaSt.bendWheelPressure channel - 2 (10/sampleRate) 0.04 0.03 - resonance <- - AlsaSt.controllerExponential channel - (VoiceMsg.toController 23) - (1, 100) 10 - AlsaSt.sequenceMultiModulated - chunkSize channel Instr.colourNoise - (applyModulation fm . - applyModulation resonance)) - - -keyboardNoisyTone :: IO () -keyboardNoisyTone = - withMIDIEvents play $ - evalState - (do fm <- AlsaSt.bendWheelPressure channel - 2 (10/sampleRate) 0.04 0.03 - speed <- AlsaSt.controllerLinear channel - (VoiceMsg.toController 21) - (0,0.5) 0.1 - AlsaSt.sequenceMultiModulated - chunkSize channel Instr.toneFromNoise - (applyModulation fm . - applyModulation speed)) - - -keyboardFilteredNoisyTone :: IO () -keyboardFilteredNoisyTone = - withMIDIEvents play $ - evalState - (do fm <- AlsaSt.bendWheelPressure channel - 2 (10/sampleRate) 0.04 0.03 - {- - speed must never be zero, - since this requires to fetch unlimited data from future. - -} - speed <- AlsaSt.controllerLinear channel - (VoiceMsg.toController 21) - (0.05,0.5) 0.1 - cutoff <- AlsaSt.controllerExponential channel - (VoiceMsg.toController 22) - (1, 30) 10 - resonance <- AlsaSt.controllerExponential channel - (VoiceMsg.toController 23) - (1, 20) 5 - AlsaSt.sequenceMultiModulated - chunkSize channel Instr.toneFromFilteredNoise - (applyModulation fm . - applyModulation speed . - applyModulation cutoff . - applyModulation resonance)) - - - -keyboardCausal :: IO () -keyboardCausal = - PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate $ - arr (SV.map (0.2*)) - . - PAlsa.sequenceStorable channel (\ _pgm -> Instr.pingReleaseCausal) diff --git a/src/Synthesizer/Storable/ALSA/Server/Test.hs b/src/Synthesizer/Storable/ALSA/Server/Test.hs deleted file mode 100644 --- a/src/Synthesizer/Storable/ALSA/Server/Test.hs +++ /dev/null @@ -1,602 +0,0 @@ -module Synthesizer.Storable.ALSA.Server.Test where - -import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr -import Synthesizer.Storable.ALSA.Server.Common - (Real, withMIDIEvents, play, - sampleRate, chunkSize, channel, ) - -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.ALSA.Sequencer.Event as Event - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC -import qualified Synthesizer.Generic.ALSA.MIDI as Gen -import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt -import Synthesizer.Storable.ALSA.MIDI ( - Instrument, chunkSizesFromLazyTime, ) - -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv -import Synthesizer.EventList.ALSA.MIDI ( - LazyTime, StrictTime, Note(..), NoteBoundary(..), - matchNoteEvents, getSlice, getControllerEvents, ) - -import qualified Synthesizer.Basic.Wave as Wave - -import qualified Synthesizer.Causal.Process as Causal -import Control.Arrow ((<<<), ) - -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Storable.Oscillator as OsciSt -import qualified Synthesizer.Storable.Signal as SigSt --- import qualified Data.StorableVector.Lazy.Builder as Bld -import qualified Data.StorableVector.Lazy.Pattern as SigStV -import qualified Data.StorableVector.Lazy as SVL -import qualified Data.StorableVector as SV - -import qualified Synthesizer.State.Signal as SigS - -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT -import Data.EventList.Relative.MixedBody ((/.), (./), ) - -import qualified Control.Monad.Trans.State.Strict as MS -import Control.Monad.Trans.State (evalState, gets, ) -import Control.Category ((.), ) - -import Data.Traversable (traverse, ) - --- import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Chunky as NonNegChunky - -import Data.Maybe.HT (toMaybe, ) - -import NumericPrelude.Numeric (zero, round, (^?), ) -import Prelude hiding (Real, round, break, id, (.), ) - - -import Data.Word (Word8, ) - - -frequency1 :: IO () -frequency1 = - withMIDIEvents play $ - const - (OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real)) - -frequency2 :: IO () -frequency2 = - withMIDIEvents (const $ const print) $ - evalState (getControllerEvents channel VoiceMsg.mainVolume) - -frequency3 :: IO () -frequency3 = - withMIDIEvents (const $ const print) $ - evalState (getSlice Just) - - -keyboard1 :: IO () -keyboard1 = - withMIDIEvents play $ - const (Instr.ping 0 440) - -keyboard2 :: SigSt.T Real -keyboard2 = - let music :: Real -> EventList.T StrictTime (SigSt.T Real) - music x = 5 /. SigSt.replicate chunkSize 6 x ./ music (x+1) - in CutSt.arrange chunkSize $ - EventList.mapTime fromIntegral $ music 42 - -keyboard3 :: SigSt.T Real -keyboard3 = - let time :: Real -> Int - time t = round (t * sampleRate) - music :: Real -> EventList.T StrictTime (SigSt.T Real) - music x = - fromIntegral (time 0.2) /. - SigSt.take (time 0.4) (Instr.ping 0 x) ./ - music (x*1.01) - in CutSt.arrange chunkSize $ - EventList.mapTime fromIntegral $ music 110 - -makeLazyTime :: Real -> LazyTime -makeLazyTime t = - NonNegChunky.fromNumber $ - NonNegW.fromNumberMsg "keyboard time" $ - round (t * sampleRate) - -makeStrictTime :: Real -> StrictTime -makeStrictTime t = - NonNegW.fromNumberMsg "keyboard time" $ - round (t * sampleRate) - -normalVelocity :: VoiceMsg.Velocity -normalVelocity = - VoiceMsg.toVelocity VoiceMsg.normalVelocity - -pitch :: Int -> VoiceMsg.Pitch -pitch = VoiceMsg.toPitch - -defaultProgram :: VoiceMsg.Program -defaultProgram = VoiceMsg.toProgram 0 - -embedDefaultProgram :: - EventList.T StrictTime [NoteBoundary Bool] -> - EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)] -embedDefaultProgram = - fmap (fmap (\(NoteBoundary p v b) -> - NoteBoundary p v (toMaybe b defaultProgram))) - -keyboard4 :: SigSt.T Real -keyboard4 = - let {- - idInstr :: Real -> Real -> SigSt.T Real - idInstr _vel freq = SigSt.repeat chunkSize freq - -} --- inf = time 0.4 + inf - music :: Int -> EventList.T StrictTime Note - music p = - makeStrictTime 0.2 /. --- (pitch p, normalVelocity, inf) ./ - Note defaultProgram (pitch p) normalVelocity (makeLazyTime 0.4) ./ - music (p+1) - in CutSt.arrange chunkSize $ - EventList.mapTime fromIntegral $ - fmap (Gen.renderInstrumentIgnoreProgram Instr.pingDur) $ - music 0 - - -notes0 :: Int -> EventList.T StrictTime (NoteBoundary Bool) -notes0 p = - makeStrictTime 0.2 /. - (let (oct,pc) = divMod p 12 - in (NoteBoundary (pitch (50 + pc)) normalVelocity (even oct))) - ./ - notes0 (p+1) - -notes1 :: EventList.T StrictTime (NoteBoundary Bool) -notes1 = - makeStrictTime 0.2 /. - (NoteBoundary (pitch 50) normalVelocity True) ./ - makeStrictTime 0.2 /. - (NoteBoundary (pitch 52) normalVelocity True) ./ - makeStrictTime 0.2 /. - (NoteBoundary (pitch 54) normalVelocity True) ./ - makeStrictTime 0.2 /. --- (NoteBoundary (pitch 50) normalVelocity False) ./ - undefined - -notes2 :: EventList.T StrictTime [NoteBoundary Bool] -notes2 = - makeStrictTime 0.2 /. - [] ./ - makeStrictTime 0.2 /. - [] ./ - makeStrictTime 0.2 /. - [NoteBoundary (pitch 50) normalVelocity True] ./ - makeStrictTime 0.2 /. - [NoteBoundary (pitch 52) normalVelocity True] ./ - makeStrictTime 0.2 /. - [NoteBoundary (pitch 54) normalVelocity True] ./ - makeStrictTime 0.2 /. - [NoteBoundary (pitch 50) normalVelocity False] ./ - undefined - -notes3 :: EventList.T StrictTime [NoteBoundary (Maybe VoiceMsg.Program)] -notes3 = - embedDefaultProgram $ - notes2 - -keyboard5 :: SigSt.T Real -keyboard5 = - CutSt.arrange chunkSize $ - EventList.mapTime fromIntegral $ - Gen.flatten $ - fmap (map (Gen.renderInstrumentIgnoreProgram Instr.pingDur)) $ - matchNoteEvents $ - notes3 - -keyboard6 :: EventList.T StrictTime [Note] -keyboard6 = - matchNoteEvents $ - embedDefaultProgram $ - fmap (:[]) $ - notes1 - -keyboard7 :: EventList.T StrictTime [(VoiceMsg.Pitch, VoiceMsg.Velocity)] -keyboard7 = - fmap (map (\ ~(Note _ p v _d) -> (p,v))) $ - keyboard6 - -arrangeSpaceLeak0 :: IO () -arrangeSpaceLeak0 = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState (Gen.sequence channel - (error "no sound" :: Instrument Real Real)) $ - let evs = EventList.cons 10 [] evs - in evs - -arrangeSpaceLeak1 :: IO () -arrangeSpaceLeak1 = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1+) 0) channel - (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $ - let evs = EventList.cons 10 [] evs - in evs - -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) - } - -{- -a space leak can only be observed for more than one note, -maybe our 'break' improvement fixed the case for one played note --} -arrangeSpaceLeak3 :: IO () -arrangeSpaceLeak3 = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1e-7 +) 1) channel - Instr.stringStereoFM) $ --- (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $ - let evs t = EventList.cons t [] (evs (20-t)) - in -- EventList.cons 10 [makeNote MIDI.NoteOn 60] $ - -- EventList.cons 10 [makeNote MIDI.NoteOn 64] $ - evs 10 - -arrangeSpaceLeak4 :: IO () -arrangeSpaceLeak4 = - SVL.writeFile "test.f32" $ - evalState - (do bend <- AlsaSt.pitchBend channel (2^?(2/12)) 1 - AlsaSt.sequenceModulated chunkSize bend channel Instr.stringStereoFM) $ - let evs t = EventList.cons t [] (evs (20-t)) - in evs 10 - -chordSpaceLeak1 :: IO () -chordSpaceLeak1 = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState (Gen.sequence channel Instr.pingDur) $ - 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 - - -sequencePitchBend :: IO () -sequencePitchBend = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState - (let fm y = (EventListBT.cons $! y) 10 (fm (2-y)) - in Gen.sequenceModulated (fm 1) channel - (error "no sound" :: - PC.T Real -> Instrument Real Real)) $ - let evs = EventList.cons 10 [] evs - in evs - -sequencePitchBend1 :: IO () -sequencePitchBend1 = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState - (let fm y = EventListBT.cons y 10 (fm (2-y)) - instr :: PC.T Real -> Instrument Real Real - instr = error "no sound" - in Gen.sequenceCore - channel Gen.errorNoProgram - (Gen.Modulator (fm 1) Gen.advanceModulationChunk - (\note -> gets $ \c -> - Gen.renderInstrumentIgnoreProgram (instr c) note))) $ - let evs = EventList.cons 10 [] evs - in evs - -sequencePitchBend2 :: IO () -sequencePitchBend2 = - SVL.writeFile "test.f32" $ - let fm y = EventListBT.cons y 10 (fm (2-y)) - -- fm = EventListBT.cons 1 10 fm - instr :: PC.T Real -> Instrument Real Real - instr = error "no sound" - evs = EventList.cons 10 [] evs - md = - Gen.Modulator - (fm 1) - Gen.advanceModulationChunkPC - -- Gen.advanceModulationChunk - (\note -> gets $ \c -> - Gen.renderInstrumentIgnoreProgram (instr c) note) - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - Gen.applyModulator md $ - evs - -sequencePitchBend3 :: IO () -sequencePitchBend3 = - SVL.writeFile "test.f32" $ - let fm y = EventListBT.cons y 10 (fm (2-y)) - -- fm = EventListBT.cons 1 10 fm - instr :: PC.T Real -> Instrument Real Real - instr = error "no sound" - evs = EventList.cons 10 [] evs - modEvent note = - gets $ \c -> - Gen.renderInstrumentIgnoreProgram (instr c) note - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - flip evalState (fm 1) . - EventList.traverse - Gen.advanceModulationChunk - (traverse modEvent) $ - evs - -sequencePitchBend4 :: IO () -sequencePitchBend4 = - SVL.writeFile "test.f32" $ - let fm y = y : fm (2-y) - -- fm = repeat 1 - instr :: [Real] -> Instrument Real Real - instr = error "no sound" - evs = EventList.cons 10 [] evs - modEvent note = - gets $ \c -> - Gen.renderInstrumentIgnoreProgram (instr c) note - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - flip evalState (fm 1) . - EventList.traverse - Gen.advanceModulationChunk - (traverse modEvent) $ - evs - -sequencePitchBend4a :: IO () -sequencePitchBend4a = - SVL.writeFile "test.f32" $ - let fm y = y : fm (2-y) - -- fm = repeat 1 - instr :: [Real] -> Instrument Real Real - instr = error "no sound" - evs = EventList.cons 10 [] evs - modEvent note = - MS.gets $ \c -> - Gen.renderInstrumentIgnoreProgram (instr c) note - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - flip MS.evalState (fm 1) . - EventList.traverse - Gen.advanceModulationChunkStrict - (traverse modEvent) $ - evs - -sequencePitchBend4b :: IO () -sequencePitchBend4b = - SVL.writeFile "test.f32" $ - let fm y = y : fm (2-y) - -- fm = repeat 1 - instr :: [Real] -> Instrument Real Real - instr = error "no sound" - evs = EventList.cons 10 [] evs - in CutSt.arrange chunkSize . - Gen.flatten $ - EventList.foldrPair - (\t bs0 go s0 -> - let s1 = tail s0 - bs1 = - map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0 - in EventList.cons - (if null s1 then t else t) bs1 $ - go s1) - (const EventList.empty) evs (fm 1) - -sequencePitchBend4c :: IO () -sequencePitchBend4c = - SVL.writeFile "test.f32" $ - let fm y = y : fm (2-y) - -- fm = repeat 1 - instr :: [Real] -> Instrument Real Real - instr = error "no sound" - in CutSt.arrange chunkSize . - Gen.flatten . - EventList.fromPairList $ - foldr - (\(t,bs0) go s0 -> - let s1 = tail s0 - bs1 = - map (Gen.renderInstrumentIgnoreProgram (instr s1)) bs0 - in (if null s1 then t else t, bs1) : - go s1) - (const []) - (repeat (10,[])) - (fm 1) - -sequencePitchBend4d :: IO () -sequencePitchBend4d = - SVL.writeFile "test.f32" $ - let fm y = y : fm (2-y) - -- fm = repeat 1 - in CutSt.arrange chunkSize . - EventList.fromPairList $ - foldr - (\(t,b) go s0 -> - let s1 = tail s0 - in (if null s1 then t else t, - if null s1 then b else b) : - go s1) - (const []) - (repeat (10, SigSt.empty :: SigSt.T Real)) - (fm 1 :: [Real]) - -sequencePitchBend4e :: IO () -sequencePitchBend4e = - writeFile "test.txt" $ - foldr - (\c go s0 -> - let s1 = tail s0 - in (if null s1 then c else c) : - go s1) - (const []) - (repeat 'a') - (iterate not False) - -- (repeat True) - -sequencePitchBend5 :: IO () -sequencePitchBend5 = - SVL.writeFile "test.f32" $ - let fm y = SigSt.iterate (SVL.ChunkSize 1) (y+) 0 - instr :: SigSt.T Real -> Instrument Real Real - instr = error "no sound" - evs = EventList.cons 10 [] evs - modEvent note = - gets $ \c -> - Gen.renderInstrumentIgnoreProgram (instr c) note - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - flip evalState (fm 1e-6) . - EventList.traverse - Gen.advanceModulationChunk - (traverse modEvent) $ - evs - -dummySound :: Instrument Real Real -dummySound = - \vel freq dur -> - SigStV.take (chunkSizesFromLazyTime dur) $ - SigSt.repeat chunkSize (vel + 1e-3*freq) - -sequenceStaccato :: IO () -sequenceStaccato = - SVL.writeFile "test.f32" $ - let evs t = - EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity True] $ - EventList.cons t [Right $ NoteBoundary (pitch 60) normalVelocity False] $ - evs (20-t) - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - EventList.mapBody - (map (Gen.renderInstrumentIgnoreProgram dummySound)) . - MIDIEv.matchNoteEvents . - MIDIEv.embedPrograms defaultProgram $ - evs 10 - -sequenceStaccato3 :: IO () -sequenceStaccato3 = - SVL.writeFile "test.f32" $ - let evs t = - EventList.cons t [NoteBoundary (pitch 60) normalVelocity (Just defaultProgram)] $ - EventList.cons t [NoteBoundary (pitch 60) normalVelocity Nothing] $ - evs (20-t) - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - EventList.mapBody - (map (Gen.renderInstrumentIgnoreProgram dummySound)) . - MIDIEv.matchNoteEvents $ - evs 10 - -sequenceStaccato2 :: IO () -sequenceStaccato2 = - SVL.writeFile "test.f32" $ - let evs t = - EventList.cons t [makeNote Event.NoteOn 60] $ - EventList.cons t [makeNote Event.NoteOff 60] $ - evs (20-t) - in CutSt.arrange chunkSize . - EventList.mapTime fromIntegral . - Gen.flatten . - EventList.mapBody - (map (Gen.renderInstrumentIgnoreProgram dummySound)) . - MIDIEv.matchNoteEvents . - MIDIEv.embedPrograms defaultProgram . - evalState (MIDIEv.getNoteEvents channel) $ - evs 10 - -sequenceStaccato1 :: IO () -sequenceStaccato1 = - SVL.writeFile "test.f32" $ - CutSt.arrange chunkSize $ - evalState (Gen.sequence channel dummySound) $ - let evs t = - EventList.cons t [makeNote Event.NoteOn 60] $ - EventList.cons t [makeNote Event.NoteOff 60] $ - evs (20-t) - in evs 10 - - -speed :: IO () -speed = - let _sig = - Causal.apply - (Instr.softStringCausalProcess 440 <<< - Instr.softStringReleaseEnvelopeCausalProcess 0) - (SigS.repeat True) - sig = - Causal.apply - (Instr.softStringCausalProcess 440) - (SigS.repeat 1) - in SV.writeFile "speed.f32" $ - SigS.runViewL sig - (\next s -> fst $ SV.unfoldrN 1000000 next s) - -speedChunky :: IO () -speedChunky = - let sig = - Causal.apply - (Instr.softStringCausalProcess 440 <<< - Instr.softStringReleaseEnvelopeCausalProcess 0) - (SigS.repeat True) - in SVL.writeFile "speed.f32" $ - SigSt.take 1000000 $ - SigS.toStorableSignal (SVL.chunkSize 100) sig -{- - SigS.runViewL sig - (\next s -> SVL.take 1000000 (SVL.unfoldr (SVL.chunkSize 100) next s)) --} - -speedArrange :: IO () -speedArrange = - let sig = - Causal.apply - (Instr.softStringCausalProcess 440 <<< - Instr.softStringReleaseEnvelopeCausalProcess 0) - (SigS.repeat True) - sigSt = - SigS.toStorableSignal (SVL.chunkSize 100) sig - in SVL.writeFile "speed.f32" $ - SigSt.take 1000000 $ - CutSt.arrangeEquidist (SVL.chunkSize 100) $ - EventList.fromPairList [(10000,sigSt)] diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -1,203 +0,0 @@ -module Main where - -import Synthesizer.Storable.ALSA.Server.Test (makeNote, ) - -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC - -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Synthesizer.Generic.ALSA.MIDI as Gen -import qualified Synthesizer.Storable.ALSA.Play as Play -import Synthesizer.Storable.ALSA.MIDI ( - Instrument, chunkSizesFromLazyTime, ) - -import qualified Synthesizer.Basic.Wave as Wave -import qualified Synthesizer.Frame.Stereo as Stereo - -import Foreign.Storable (Storable, ) - -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Storable.Signal as SigSt -import qualified Data.StorableVector.Lazy as SVL - -import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.State.Oscillator as OsciS -import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS - -import qualified Sound.MIDI.Message.Channel as ChannelMsg -import Sound.MIDI.Message.Channel (Channel, ) - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT --- import Data.EventList.Relative.MixedBody ((/.), (./), ) - -import Control.Monad.Trans.State (evalState, ) -import Control.Monad (when, ) - -import qualified Algebra.Additive as Additive - -import NumericPrelude.Numeric (zero, (^?), ) -import Prelude hiding (Real, break, ) - - -import qualified System.IO as IO - - - -channel :: Channel -channel = ChannelMsg.toChannel 0 - -sampleRate :: Num a => a --- sampleRate = 24000 --- sampleRate = 48000 -sampleRate = 44100 - -latency :: Int -latency = 0 --- latency = 256 --- latency = 1000 - -chunkSize :: SVL.ChunkSize -chunkSize = Play.defaultChunkSize - -consNone :: - time -> - EventList.T time [body] -> - EventList.T time [body] -consNone t = EventList.cons t [] - -consSingle :: - time -> body -> - EventList.T time [body] -> - EventList.T time [body] -consSingle t b = EventList.cons t [b] - - -type Real = Float - - -evaluatePrefix :: - (Storable a, Additive.C a, Eq a) => - SVL.Vector a -> Bool -evaluatePrefix = - (\x -> x==x) . - SVL.foldl' (Additive.+) zero . - SVL.take 100000 - - -sequenceSpaceLeakEmpty :: Bool -sequenceSpaceLeakEmpty = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState (Gen.sequence channel - (error "no sound" :: Instrument Real Real)) $ - let evs = consNone 10 evs - in evs - -sequenceSpaceLeakModulatedEmpty :: Bool -sequenceSpaceLeakModulatedEmpty = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1+) 0) channel - (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $ - let evs = consNone 10 evs - in evs - - -sequenceSpaceLeakLazyDrop :: Bool -sequenceSpaceLeakLazyDrop = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState - (let fm y = (EventListBT.cons $! y) 10 (fm (2-y)) - in Gen.sequenceModulated (fm 1) channel - (error "no sound" :: - PC.T Real -> Instrument Real Real)) $ - let evs = consNone 10 evs - in evs - - -stringStereoFM :: SigSt.T Real -> Instrument Real (Stereo.T Real) -stringStereoFM fmSt vel freq dur = - let fm = SigS.fromStorableSignal fmSt - in SigS.toStorableSignalVary (chunkSizesFromLazyTime dur) $ - FiltNRS.amplifyVector (4^?vel) $ - SigS.zipWith Stereo.cons - (OsciS.freqMod Wave.saw zero $ - FiltNRS.amplify (freq*0.999/sampleRate) fm) - (OsciS.freqMod Wave.saw zero $ - FiltNRS.amplify (freq*1.001/sampleRate) fm) - - -sequenceSpaceLeakModulatedInfinite :: Bool -sequenceSpaceLeakModulatedInfinite = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1e-7 +) 1) channel - stringStereoFM) $ - let evs t = consNone t (evs (20-t)) - in consSingle 10 (makeNote Event.NoteOn 60) $ - evs 10 - -sequenceSpaceLeakModulatedChordStep :: Bool -sequenceSpaceLeakModulatedChordStep = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1e-7 +) 1) channel - stringStereoFM) $ - let evs t = consNone t (evs (20-t)) - in consSingle 10 (makeNote Event.NoteOn 60) $ - consSingle 10 (makeNote Event.NoteOn 64) $ - consSingle 10 (makeNote Event.NoteOn 67) $ - evs 10 - -sequenceSpaceLeakModulatedChordSimultaneous :: Bool -sequenceSpaceLeakModulatedChordSimultaneous = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1e-7 +) 1) channel - stringStereoFM) $ - let evs t = EventList.cons t [] (evs (20-t)) - in EventList.cons 10 - [makeNote Event.NoteOn 60, - makeNote Event.NoteOn 64, - makeNote Event.NoteOn 67] $ - evs 10 - -sequenceSpaceLeakStaccato :: Bool -sequenceSpaceLeakStaccato = - evaluatePrefix $ - CutSt.arrange chunkSize $ - evalState - (Gen.sequenceModulated - (SigSt.iterate chunkSize (1e-7 +) 1) channel - stringStereoFM) $ - let evs t = - consSingle t (makeNote Event.NoteOn 60) $ - consSingle t (makeNote Event.NoteOff 60) $ - evs (20-t) - in evs 10 - - -test :: String -> Bool -> IO () -test name result = do - putStr name - IO.hFlush IO.stdout - when result (putStrLn " ok") - -main :: IO () -main = do - test "sequenceSpaceLeakEmpty" sequenceSpaceLeakEmpty - test "sequenceSpaceLeakModulatedEmpty" sequenceSpaceLeakModulatedEmpty - test "sequenceSpaceLeakLazyDrop" sequenceSpaceLeakLazyDrop - test "sequenceSpaceLeakModulatedInfinite" sequenceSpaceLeakModulatedInfinite - test "sequenceSpaceLeakModulatedChordStep" sequenceSpaceLeakModulatedChordStep - test "sequenceSpaceLeakModulatedChordSimultaneous" sequenceSpaceLeakModulatedChordSimultaneous - test "sequenceSpaceLeakStaccato" sequenceSpaceLeakStaccato diff --git a/synthesizer-alsa.cabal b/synthesizer-alsa.cabal --- a/synthesizer-alsa.cabal +++ b/synthesizer-alsa.cabal @@ -1,5 +1,5 @@ Name: synthesizer-alsa -Version: 0.4 +Version: 0.5 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -13,12 +13,13 @@ that can be used for audio effects. As demonstration there is a keyboard controlled music synthesizer. Stability: Experimental -Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3, GHC==7.0.4, GHC==7.2.1 +Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3 +Tested-With: GHC==7.0.4, GHC==7.2.1 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository this - Tag: 0.4 + Tag: 0.5 Type: darcs Location: http://code.haskell.org/synthesizer/alsa/ @@ -37,37 +38,28 @@ description: Build example executables default: False -Flag buildTests - description: Build test executables - default: False - Library Build-Depends: - synthesizer-dimensional >=0.6 && <0.7, - synthesizer-core >=0.5 && <0.6, + synthesizer-midi >=0.6 && <0.7, + synthesizer-dimensional >=0.7 && <0.8, + synthesizer-core >=0.6 && <0.7, + midi-alsa >=0.2 && <0.3, + midi >=0.2 && <0.3, sox >=0.2.1 && <0.3, - midi-alsa >=0.1.2 && <0.2, - alsa-seq >=0.5.1 && <0.6, - alsa-pcm >=0.5 && <0.6, + alsa-seq >=0.6 && <0.7, + alsa-pcm >=0.6 && <0.7, alsa-core >=0.5 && <0.6, - midi >=0.1.1 && <0.2, - storable-record >=0.0.2 && <0.1, storablevector >=0.2.5 && <0.3, - deepseq >=1.1 && <1.2, - numeric-prelude >=0.3 && <0.4, + numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2, - data-accessor-transformers >=0.2.1 && <0.3, - data-accessor >=0.2.1 && <0.3, - containers >=0.1 && <0.5, - array >=0.1 && <0.4, - transformers >=0.2 && <0.3, + transformers >=0.2 && <0.4, utility-ht >=0.0.1 && <0.1 If flag(splitBase) Build-Depends: random >= 1.0 && < 1.1, - old-time >= 1.0 && < 1.1, + old-time >= 1.0 && < 1.2, base >= 3 && <5 Else Build-Depends: @@ -81,24 +73,10 @@ GHC-Options: -Wall Hs-source-dirs: src Exposed-modules: - Synthesizer.EventList.ALSA.MIDI - Synthesizer.Storable.ALSA.MIDI - Synthesizer.Storable.ALSA.Play - Synthesizer.PiecewiseConstant.ALSA.MIDI - Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet - Synthesizer.Generic.ALSA.MIDI - Synthesizer.Dimensional.ALSA.MIDI - Synthesizer.Dimensional.ALSA.Play - Synthesizer.CausalIO.ALSA.Process - Synthesizer.CausalIO.ALSA.MIDIControllerSet - Synthesizer.CausalIO.ALSA.MIDIControllerSelection - -- these modules would be better located in midi package, - -- but they are based on NumericPrelude - Synthesizer.MIDIValue - Synthesizer.MIDIValue.BendModulation - Synthesizer.MIDIValue.BendWheelPressure - Synthesizer.Dimensional.MIDIValue - Synthesizer.Dimensional.MIDIValuePlain + Synthesizer.ALSA.EventList + Synthesizer.ALSA.Storable.Play + Synthesizer.ALSA.Dimensional.Play + Synthesizer.ALSA.CausalIO.Process Executable realtimesynth If !flag(buildExamples) @@ -113,11 +91,10 @@ Extensions: CPP Hs-Source-Dirs: src Other-modules: - Synthesizer.Storable.ALSA.Server.Common - Synthesizer.Storable.ALSA.Server.Instrument - Synthesizer.Storable.ALSA.Server.Test - Synthesizer.Storable.ALSA.Server.Run - Main-Is: Synthesizer/Storable/ALSA/Server.hs + Synthesizer.ALSA.Storable.Server.Common + Synthesizer.ALSA.Storable.Server.Test + Synthesizer.ALSA.Storable.Server.Run + Main-Is: Synthesizer/ALSA/Storable/Server.hs Executable synthicate If !flag(buildExamples) @@ -132,22 +109,7 @@ Extensions: CPP Hs-Source-Dirs: src Other-modules: - Synthesizer.Dimensional.ALSA.Server.Common - Synthesizer.Dimensional.ALSA.Server.Instrument - Synthesizer.Dimensional.ALSA.Server.Test - Synthesizer.Dimensional.ALSA.Server.Run - Main-Is: Synthesizer/Dimensional/ALSA/Server.hs - -Executable test - If !flag(buildTests) - Buildable: False - If flag(optimizeAdvanced) - GHC-Options: -O2 -fvia-C -optc-O2 -optc-msse3 -optc-ffast-math - GHC-Options: -Wall -fexcess-precision -threaded --- -ddump-simpl-stats -ddump-asm - If impl(ghc>=7.0) - GHC-Options: -fwarn-unused-do-bind - CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP - Hs-Source-Dirs: src - Main-Is: Test.hs + Synthesizer.ALSA.Dimensional.Server.Common + Synthesizer.ALSA.Dimensional.Server.Test + Synthesizer.ALSA.Dimensional.Server.Run + Main-Is: Synthesizer/ALSA/Dimensional/Server.hs