module Synthesizer.LLVM.Server.Packed.Run where import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr import qualified Synthesizer.LLVM.Server.Option as Option import Synthesizer.LLVM.Server.Packed.Instrument (Vector, VectorSize, vectorSize, ) import Synthesizer.LLVM.Server.Common import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.EventList.ALSA.MIDI as Ev import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS import qualified Synthesizer.Generic.ALSA.MIDI as Gen import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($<), ($*), ) import Synthesizer.LLVM.Parameterized.Signal (($#), ) import qualified LLVM.Core as LLVM import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter import qualified Sound.MIDI.Controller as Ctrl import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.MixedTime as EventListMT import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, ) import Control.Arrow ((<<<), (^<<), arr, first, {- second, -} ) import Control.Applicative (pure, {- liftA, liftA2, -} liftA3, (<*>), ) import Control.Monad.Trans.State (evalState, ) {- import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky -} import Algebra.IntegralDomain (divUp, ) import NumericPrelude.Numeric (zero, round, (^?), ) import Prelude hiding (Real, round, break, ) vectorChunkSize :: Option.T -> SVL.ChunkSize vectorChunkSize opts = case Option.chunkSize opts of SVL.ChunkSize size -> SVL.ChunkSize (divUp size vectorSize) sampleRate :: Num a => Option.T -> a sampleRate opt = case Option.sampleRate opt of SampleRate sr -> sr {-# INLINE withMIDIEventsMono #-} withMIDIEventsMono :: Option.T -> (Option.T -> Double -> SigSt.T Real -> IO b) -> (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b withMIDIEventsMono opt action proc = let rate = sampleRate opt in do putStrLn startMessage Ev.withMIDIEvents (Option.clientName opt) (Option.periodTime opt) (rate / fromIntegral vectorSize) $ action opt rate . SigStL.unpack . proc type StereoVector = StereoInt.T VectorSize Real {-# INLINE withMIDIEventsStereo #-} withMIDIEventsStereo :: Option.T -> (Option.T -> Double -> SigSt.T (Stereo.T Real) -> IO b) -> (EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) -> IO b withMIDIEventsStereo opt action proc = let rate = sampleRate opt in do putStrLn startMessage Ev.withMIDIEvents (Option.clientName opt) (Option.periodTime opt) (rate / fromIntegral vectorSize) $ action opt rate . SigStL.unpackStereo . proc -- maybe this can be merged into a PCS.controllerDiscrete stair :: Real -> Real stair i = let n = fromIntegral (round i :: Int) r = i - n in n + 0.01*r frequencyModulation :: IO () frequencyModulation = do opt <- Option.get osc <- SigP.runChunky ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector)) $* Instr.frequencyFromBendModulation (frequencyConst 10) (Instr.modulation (\fm -> (fm,880)))) withMIDIEventsMono opt play $ osc (vectorChunkSize opt) . (,) (Option.sampleRate opt) . evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) keyboard :: IO () keyboard = do opt <- Option.get sound <- Instr.pingRelease $/ 0.4 $/ 0.1 $/ vectorChunkSize opt $/ Option.sampleRate opt amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2) arrange <- SigStL.makeArranger withMIDIEventsMono opt play $ (amp () :: SigSt.T Vector -> SigSt.T Vector) . arrange (vectorChunkSize opt) . evalState (Gen.sequence (Option.channel opt) sound) keyboardStereo :: IO () keyboardStereo = do opt <- Option.get sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 $/ vectorChunkSize opt $/ Option.sampleRate opt amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< (CausalPS.amplifyStereo $# 0.2)) arrange <- SigStL.makeArranger withMIDIEventsStereo opt play $ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) . arrange (vectorChunkSize opt) . evalState (Gen.sequence (Option.channel opt) sound) keyboardFM :: IO () keyboardFM = do opt <- Option.get str <- Instr.softStringFM amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< (CausalP.amplifyStereo $# 0.2)) arrange <- SigStL.makeArranger withMIDIEventsStereo opt play $ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) . arrange (vectorChunkSize opt) . evalState (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 Gen.sequenceModulated fm (Option.channel opt) (flip str (Option.sampleRate opt))) keyboardFMMulti :: IO () keyboardFMMulti = do opt <- Option.get str <- Instr.softStringFM tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 $/ vectorChunkSize opt amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< (CausalP.amplifyStereo $# 0.2)) arrange <- SigStL.makeArranger withMIDIEventsStereo opt play $ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) . arrange (vectorChunkSize opt) . evalState (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 Gen.sequenceModulatedMultiProgram fm (Option.channel opt) (VoiceMsg.toProgram 1) (map (\sound fmlocal -> sound fmlocal $ Option.sampleRate opt) [str, tin])) controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1, controllerFilterCutoff, controllerFilterResonance, controllerVolume :: VoiceMsg.Controller controllerAttack = Ctrl.attackTime controllerDetune = Ctrl.chorusDepth -- Ctrl.effect3Depth controllerTimbre0 = Ctrl.soundVariation controllerTimbre1 = Ctrl.timbre controllerFilterCutoff = Ctrl.effect4Depth controllerFilterResonance = Ctrl.effect5Depth controllerVolume = Ctrl.volume controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 :: VoiceMsg.Controller controllerFMDepth1 = Ctrl.soundController3 controllerFMDepth2 = Ctrl.soundController5 controllerFMDepth3 = Ctrl.soundController7 controllerFMDepth4 = Ctrl.soundController8 controllerFMPartial1 = Ctrl.generalPurpose1 controllerFMPartial2 = Ctrl.generalPurpose2 controllerFMPartial3 = Ctrl.effect1Depth controllerFMPartial4 = Ctrl.effect2Depth keyboardDetuneFMCore :: FilePath -> SVL.ChunkSize -> IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real -> Ev.Filter (SigSt.T StereoVector)) keyboardDetuneFMCore smpDir vcsize = do str0 <- Instr.softStringDetuneFM ssh0 <- Instr.softStringShapeFM css0 <- Instr.cosineStringStereoFM asw0 <- Instr.arcSawStringStereoFM asn0 <- Instr.arcSineStringStereoFM asq0 <- Instr.arcSquareStringStereoFM atr0 <- Instr.arcTriangleStringStereoFM wnd0 <- Instr.wind wnp0 <- Instr.windPhaser fms0 <- Instr.fmStringStereoFM tin0 <- Instr.tineStereoFM tnc0 <- Instr.tineControlledFM fnd0 <- Instr.fenderFM tnb0 <- Instr.tineBankFM rfm0 <- Instr.resonantFMSynth png0 <- Instr.pingStereoRelease pngFM0 <- Instr.pingStereoReleaseFM sqr0 <- Instr.squareStereoReleaseFM bel0 <- Instr.bellStereoFM ben0 <- Instr.bellNoiseStereoFM flt0 <- Instr.filterSawStereoFM brs0 <- Instr.brass tmt0 <- Instr.makeSampledSounds smpDir Instr.tomatensalat hal0 <- Instr.makeSampledSounds smpDir Instr.hal grp0 <- Instr.makeSampledSounds smpDir Instr.graphentheorie let evHead = fmap (EventListMT.switchBodyL (error "empty controller stream") const) flt = evalState $ liftA6 (\rel -> flt0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (evHead $ PCS.controllerExponential controllerTimbre0 (100,10000) 1000) (evHead $ PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) png = (\rel -> png0 (4*rel) rel vcsize) . evalState (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) pngFM = evalState $ liftA6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (evHead $ PCS.controllerLinear controllerTimbre0 (0,1) 1) (PCS.controllerExponential controllerTimbre1 (1/pi,0.001) 0.05) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) sqr = evalState $ liftA6 (\rel -> sqr0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) tin = evalState $ liftA3 (\rel -> tin0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) tnc = evalState $ liftA6 (\rel -> tnc0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (fmap (fmap stair) $ PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2) (PCS.controllerLinear controllerTimbre1 (0,1.5) 1) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) fnd = evalState $ pure (\rel -> fnd0 (4*rel) rel) <*> (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) <*> (fmap (fmap stair) $ PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14) <*> (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3) <*> (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25) <*> (pure vcsize) <*> (PCS.bendWheelPressure 2 0.04 0.03) tnb = evalState $ pure (\rel -> tnb0 (4*rel) rel) <*> (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0) <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0) <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0) <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0) <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1) <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0) <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0) <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0) <*> (pure vcsize) <*> (PCS.bendWheelPressure 2 0.04 0.03) rfm = evalState $ pure (\rel -> rfm0 (4*rel) rel) <*> (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001) <*> (PCS.controllerExponential controllerTimbre1 (1,100) 30) <*> (PCS.controllerLinear controllerTimbre0 (1,15) 3) <*> (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1) <*> (pure vcsize) <*> (PCS.bendWheelPressure 2 0.04 0.03) bel = evalState $ liftA4 (\rel -> bel0 (2*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (pure vcsize) (PCS.bendWheelPressure 2 0.05 0.02) ben = evalState $ liftA5 (\rel -> ben0 (2*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) (PCS.controllerLinear controllerTimbre0 (0,1) 0.3) (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (pure vcsize) (PCS.bendWheelPressure 2 0.05 0.02) str = evalState $ liftA3 str0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.bendWheelPressure 2 0.04 0.03) ssh = evalState $ liftA4 ssh0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) (PCS.bendWheelPressure 2 0.04 0.03) makeArc gen = evalState $ liftA4 gen (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5) (PCS.bendWheelPressure 2 0.04 0.03) css = makeArc css0 asw = makeArc asw0 asn = makeArc asn0 asq = makeArc asq0 atr = makeArc atr0 fms = evalState $ liftA5 fms0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2) (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1) (PCS.bendWheelPressure 2 0.04 0.03) wnd = evalState $ liftA3 wnd0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 12 0.8 0) wnp = evalState $ liftA5 wnp0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerTimbre0 (0,1) 0.5) (PCS.controllerExponential controllerDetune (50,5000) 500) (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 12 0.8 0) brs = evalState $ liftA6 (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) (evHead $ PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) (evHead $ PCS.controllerLinear controllerTimbre1 (1,5) 3) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) freqMod = evalState (PCS.bendWheelPressure 2 0.04 0.03) arrange <- SigStL.makeArranger amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< CausalP.envelopeStereo $< Instr.piecewiseConstantVector (arr id)) return (\chan pgm sr -> do volume <- PC.controllerExponential chan controllerVolume (0.001, 1) 0.2 ctrls <- PCS.fromChannel chan fmap (amp volume . arrange vcsize) $ Gen.sequenceModulatedMultiProgram ctrls chan pgm (map (\sound fm -> sound fm $ sr) $ [tnc, fnd, pngFM, flt, bel, ben, sqr, brs, ssh, fms, css, asn, atr, asq, asw, wnp] ++ map (.freqMod) tmt0 ++ map (.freqMod) hal0 ++ map (.freqMod) grp0 ++ [str, wnd, png, rfm, tin, tnb])) keyboardDetuneFM :: IO () keyboardDetuneFM = do opt <- Option.get proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt) withMIDIEventsStereo opt play $ evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt)) keyboardFilter :: IO () keyboardFilter = do opt <- Option.get proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt) mix <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< CausalP.mix <<< first (CausalPS.amplifyStereo 0.5 <<< CausalP.mapSimple StereoInt.deinterleave) $< SigP.fromStorableVectorLazy (arr id)) lowpass0 <- CausalP.runStorableChunky $ -- CausalPS.amplifyStereo 0.1 <<< CausalPS.pack (CausalP.stereoFromMonoControlled (UniFilter.lowpass ^<< UniFilterL.causalP) $< (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) (piecewiseConstant (arr id))) <<< CausalP.mapSimple StereoInt.deinterleave let lowpass :: PC.T Real -> PC.T Real -> SigSt.T StereoVector -> SigSt.T (Stereo.T Vector) lowpass resons freqs = lowpass0 (fmap UniFilter.parameter (PC.zipWith FiltR.Pole resons (fmap (/ sampleRate opt) freqs))) withMIDIEventsStereo opt play $ evalState (do {- It is important to retrieve the global controllers before they are filtered out by PCS.fromChannel. -} let freqBnd v = 880 * 2^?(v/24) freq <- PC.controllerExponential (Option.extraChannel opt) controllerFilterCutoff (freqBnd (-64), freqBnd 63) 5000 resonance <- PC.controllerExponential (Option.extraChannel opt) controllerFilterResonance (1, 100) 1 filterMusic <- proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) (Option.sampleRate opt) pureMusic <- proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt) return (pureMusic `mix` lowpass resonance freq filterMusic))