module Synthesizer.LLVM.Server.Packed.Run where import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr import Synthesizer.LLVM.Server.Packed.Instrument (Vector, vectorSize, vectorChunkSize, ) import Synthesizer.LLVM.Server.Common import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.EventList.ALSA.MIDI as Ev import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS import qualified Synthesizer.Generic.ALSA.MIDI as Gen import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($<), ($*), ) import Synthesizer.LLVM.Parameterized.Signal (($#), ) import qualified LLVM.Core as LLVM import qualified Synthesizer.Storable.Signal as SigSt import qualified 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 qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.MixedTime as EventListMT import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, ) import Control.Arrow ((<<<), (^<<), {- (<<^), -} (&&&), {- (***), -} arr, first, {- second, -} ) import Control.Applicative (pure, {- liftA, -} liftA2, liftA3, (<*>), ) import Control.Monad.Trans.State (evalState, ) {- import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky -} -- import qualified Algebra.RealRing as RealRing import qualified Algebra.Additive as Additive import NumericPrelude.Numeric (zero, round, ) import Prelude hiding (Real, round, break, ) {-# INLINE withMIDIEventsMono #-} withMIDIEventsMono :: (Double -> Double -> SigSt.T Real -> IO b) -> (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b withMIDIEventsMono action proc = let rate = sampleRate per = periodTime in Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $ action per rate . SigStL.unpack . proc {-# INLINE withMIDIEventsStereo #-} withMIDIEventsStereo :: (Double -> Double -> SigSt.T (Stereo.T Real) -> IO b) -> (EventList.T Ev.StrictTime [Event.T] -> SigSt.T (Stereo.T Vector)) -> IO b withMIDIEventsStereo action proc = let rate = sampleRate per = periodTime in do unpack <- SigStL.makeUnpackGeneric Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $ action per rate . unpack . proc -- maybe this can be merged into a PCS.controllerDiscrete stair :: Real -> Real stair i = let n = fromIntegral (round i :: Int) r = i - n in n + 0.01*r frequencyModulation :: IO () frequencyModulation = do osc <- SigP.runChunky ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector)) $* Instr.frequencyFromBendModulation 10 (arr id &&& pure 880)) withMIDIEventsMono play $ osc vectorChunkSize . evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real)) keyboard :: IO () keyboard = do sound <- Instr.pingRelease $/ 0.4 $/ 0.1 amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2) arrange <- SigStL.makeArranger withMIDIEventsMono play $ (amp () :: SigSt.T Vector -> SigSt.T Vector) . evalState (Gen.sequence (arrange vectorChunkSize) channel sound) keyboardStereo :: IO () keyboardStereo = do sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) arrange <- SigStL.makeArranger withMIDIEventsStereo play $ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) . evalState (Gen.sequence (arrange vectorChunkSize) channel sound) keyboardFM :: IO () keyboardFM = do str <- Instr.softStringFM amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) arrange <- SigStL.makeArranger withMIDIEventsStereo play $ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) . evalState (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 Gen.sequenceModulated (arrange vectorChunkSize) fm channel str) keyboardFMMulti :: IO () keyboardFMMulti = do str <- Instr.softStringFM tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2) arrange <- SigStL.makeArranger withMIDIEventsStereo play $ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) . evalState (do fm <- PC.bendWheelPressure channel 2 0.04 0.03 Gen.sequenceModulatedMultiProgram (arrange vectorChunkSize) fm channel (VoiceMsg.toProgram 1) [str, tin]) controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, controllerFilterCutoff, controllerFilterResonance, controllerGlobal, controllerVolume :: VoiceMsg.Controller [controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, controllerFilterCutoff, controllerFilterResonance, controllerGlobal, controllerVolume] = map VoiceMsg.toController [21, 22, 23, 24, 91, 93, 82, 83] controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 :: VoiceMsg.Controller [controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4] = map VoiceMsg.toController [25, 26, 27, 28, 70, 71, 72, 73] keyboardDetuneFMCore :: IO (ChannelMsg.Channel -> VoiceMsg.Program -> Ev.Filter (SigSt.T (Stereo.T Vector))) keyboardDetuneFMCore = do str0 <- Instr.softStringDetuneFM ssh0 <- Instr.softStringShapeFM css0 <- Instr.cosineStringStereoFM asw0 <- Instr.arcSawStringStereoFM asn0 <- Instr.arcSineStringStereoFM asq0 <- Instr.arcSquareStringStereoFM atr0 <- Instr.arcTriangleStringStereoFM wnd0 <- Instr.wind wnp0 <- Instr.windPhaser fms0 <- Instr.fmStringStereoFM tin0 <- Instr.tineStereoFM tnc0 <- Instr.tineControlledFM fnd0 <- Instr.fenderFM tnb0 <- Instr.tineBankFM rfm0 <- Instr.resonantFMSynth png0 <- Instr.pingStereoRelease pngFM0 <- Instr.pingStereoReleaseFM sqr0 <- Instr.squareStereoReleaseFM bel0 <- Instr.bellStereoFM ben0 <- Instr.bellNoiseStereoFM flt0 <- Instr.filterSawStereoFM brs0 <- Instr.brass tmt0 <- Instr.makeSampledSounds Instr.tomatensalat hal0 <- Instr.makeSampledSounds Instr.hal grp0 <- Instr.makeSampledSounds Instr.graphentheorie let evHead = fmap (EventListMT.switchBodyL (error "empty controller stream") const) flt = evalState $ liftA5 (\rel -> flt0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (evHead $ PCS.controllerExponential controllerTimbre0 (100,10000) 1000) (evHead $ PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1) (PCS.bendWheelPressure 2 0.04 0.03) png = (\rel -> png0 (4*rel) rel) . evalState (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) pngFM = evalState $ liftA5 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (evHead $ PCS.controllerLinear controllerTimbre0 (0,1) 1) (PCS.controllerExponential controllerTimbre1 (0.3,0.001) 0.05) (PCS.bendWheelPressure 2 0.04 0.03) sqr = evalState $ liftA5 (\rel -> sqr0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05) (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25) (PCS.bendWheelPressure 2 0.04 0.03) tin = evalState $ liftA2 (\rel -> tin0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.bendWheelPressure 2 0.04 0.03) tnc = evalState $ liftA5 (\rel -> tnc0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (fmap (fmap stair) $ PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) (PCS.controllerLinear controllerTimbre1 (0,1.5) 1) (PCS.bendWheelPressure 2 0.04 0.03) fnd = evalState $ liftA6 (\rel -> fnd0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (fmap (fmap stair) $ PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14) (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3) (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25) (PCS.bendWheelPressure 2 0.04 0.03) tnb = evalState $ pure (\rel -> tnb0 (4*rel) rel) <*> (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0) <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0) <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0) <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0) <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1) <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0) <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0) <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0) <*> (PCS.bendWheelPressure 2 0.04 0.03) rfm = evalState $ liftA6 (\rel -> rfm0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (PCS.controllerExponential controllerTimbre1 (1,100) 30) (PCS.controllerLinear controllerTimbre0 (1,15) 3) (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1) (PCS.bendWheelPressure 2 0.04 0.03) bel = evalState $ liftA3 (\rel -> bel0 (2*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (PCS.bendWheelPressure 2 0.05 0.02) ben = evalState $ liftA4 (\rel -> ben0 (2*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) (PCS.controllerLinear controllerTimbre0 (0,1) 0.3) (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 2 0.05 0.02) str = evalState $ liftA3 str0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.bendWheelPressure 2 0.04 0.03) ssh = evalState $ liftA4 ssh0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05) (PCS.bendWheelPressure 2 0.04 0.03) makeArc gen = evalState $ liftA4 gen (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5) (PCS.bendWheelPressure 2 0.04 0.03) css = makeArc css0 asw = makeArc asw0 asn = makeArc asn0 asq = makeArc asq0 atr = makeArc atr0 fms = evalState $ liftA5 fms0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2) (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1) (PCS.bendWheelPressure 2 0.04 0.03) wnd = evalState $ liftA3 wnd0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 12 0.8 0) wnp = evalState $ liftA5 wnp0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerTimbre0 (0,1) 0.5) (PCS.controllerExponential controllerDetune (50,5000) 500) (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 12 0.8 0) brs = evalState $ liftA5 (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) (evHead $ PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05) (evHead $ PCS.controllerLinear controllerTimbre1 (1,5) 3) (PCS.bendWheelPressure 2 0.04 0.03) freqMod = evalState (PCS.bendWheelPressure 2 0.04 0.03) arrange <- SigStL.makeArranger amp <- CausalP.runStorableChunky (CausalP.envelopeStereo $< Instr.piecewiseConstantVector (arr id)) return (\chan pgm -> do volume <- PC.controllerExponential chan controllerVolume (0.001, 1) 0.2 ctrls <- PCS.fromChannel chan fmap (amp volume) $ Gen.sequenceModulatedMultiProgram (arrange vectorChunkSize) ctrls chan pgm ([tnc, fnd, pngFM, flt, bel, ben, sqr, brs, ssh, fms, css, asn, atr, asq, asw, wnp] ++ map (.freqMod) tmt0 ++ map (.freqMod) hal0 ++ map (.freqMod) grp0 ++ [str, wnd, png, rfm, tin, tnb])) keyboardDetuneFM :: IO () keyboardDetuneFM = do proc <- keyboardDetuneFMCore withMIDIEventsStereo play $ evalState (proc channel (VoiceMsg.toProgram 0)) keyboardFilter :: IO () keyboardFilter = do proc <- keyboardDetuneFMCore mix <- CausalP.runStorableChunky (CausalP.mixStereo <<< first (CausalPS.amplifyStereo 0.5) $< SigP.fromStorableVectorLazy (arr id)) lowpass0 <- CausalP.runStorableChunky $ -- CausalPS.amplifyStereo 0.1 <<< CausalPS.pack (CausalP.stereoFromMonoControlled (UniFilter.lowpass ^<< UniFilterL.causalP) $< (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) (piecewiseConstant (arr id))) let lowpass :: PC.T Real -> PC.T Real -> SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector) lowpass resons freqs = lowpass0 (fmap UniFilter.parameter (PC.zipWith FiltR.Pole resons (fmap (/sampleRate) freqs))) withMIDIEventsStereo (playAndRecord "/gentoo/server-llvm.f32") $ -- withMIDIEventsStereo play $ evalState (do {- It is important to retrieve the global controllers before they are filtered out by PCS.fromChannel. -} let altChannel = (ChannelMsg.toChannel 1) freq <- PC.controllerExponential altChannel controllerFilterCutoff (100, 5000) 5000 resonance <- PC.controllerExponential altChannel controllerFilterResonance (1, 100) 1 filterMusic <- proc altChannel (VoiceMsg.toProgram 8) pureMusic <- proc channel (VoiceMsg.toProgram 0) return (pureMusic `mix` lowpass resonance freq filterMusic))