module Synthesizer.LLVM.Server.Packed.Run where import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.LLVM.Server.Option as Option import Synthesizer.LLVM.Server.ALSA (Output, play, startMessage) import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorSize, vectorSize, stair) import Synthesizer.LLVM.Server.Common import qualified Synthesizer.ALSA.EventList as Ev import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.MIDI.EventList as MidiEv import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS import qualified Synthesizer.MIDI.Generic as Gen import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*)) import Synthesizer.LLVM.Parameter (($#)) 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 qualified System.Path.PartClass as PathClass import qualified System.Path as Path import qualified Control.Applicative.HT as App import Control.Arrow ((<<<), (^<<), arr) import Control.Applicative (pure, liftA2, liftA3, (<*>)) import Control.Monad.Trans.State (evalState) import Control.Exception (bracket) import Algebra.IntegralDomain (divUp) import NumericPrelude.Numeric (zero, (^?), (+)) import Prelude hiding (Real, break, (+)) {-# INLINE withMIDIEventsMono #-} withMIDIEventsMono :: Option.T -> Output handle (SigSt.T Real) a -> (SigSt.ChunkSize -> SampleRate Real -> EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO a withMIDIEventsMono opt output process = do putStrLn startMessage case output opt of (open,close,write) -> bracket open (close . snd) $ \((chunkSize,rate),h) -> let rrate = fromIntegral rate :: Double in Ev.withMIDIEvents (Option.clientName opt) (fromIntegral chunkSize / rrate) (rrate / fromIntegral vectorSize) (write h . SigStL.unpack . process (SigSt.chunkSize $ divUp chunkSize vectorSize) (Option.SampleRate $ fromIntegral rate)) type StereoVector = StereoInt.T VectorSize Real {-# INLINE withMIDIEventsStereo #-} withMIDIEventsStereo :: Option.T -> Output handle (SigSt.T (Stereo.T Real)) a -> (SigSt.ChunkSize -> SampleRate Real -> EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) -> IO a withMIDIEventsStereo opt output process = do putStrLn startMessage case output opt of (open,close,write) -> bracket open (close . snd) $ \((chunkSize,rate),h) -> let rrate = fromIntegral rate :: Double in Ev.withMIDIEvents (Option.clientName opt) (fromIntegral chunkSize / rrate) (rrate / fromIntegral vectorSize) (write h . SigStL.unpackStereo . process (SigSt.chunkSize $ divUp chunkSize vectorSize) (Option.SampleRate $ fromIntegral rate)) frequencyModulation :: IO () frequencyModulation = do opt <- Option.get osc <- SigP.runChunky ((CausalPS.osciSimple WaveL.triangle $< zero) $* Instr.frequencyFromBendModulation (frequencyConst 10) (Instr.modulation (\fm -> (fm,880)))) withMIDIEventsMono opt play $ \vectorChunkSize sampleRate -> osc vectorChunkSize . (,) sampleRate . evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real)) keyboard :: IO () keyboard = do opt <- Option.get sound <- Instr.pingRelease $/ 0.4 $/ 0.1 amp <- CausalP.runStorableChunky (CausalPS.amplify (arr id)) arrange <- SigStL.makeArranger withMIDIEventsMono opt play $ \vectorChunkSize sampleRate -> (amp :: Real -> SigSt.T Vector -> SigSt.T Vector) 0.2 . arrange vectorChunkSize . evalState (Gen.sequence (Option.channel opt) $ sound vectorChunkSize sampleRate) keyboardStereo :: IO () keyboardStereo = do opt <- Option.get sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1 amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< CausalPS.amplifyStereo (arr id)) arrange <- SigStL.makeArranger withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 . arrange vectorChunkSize . evalState (Gen.sequence (Option.channel opt) $ sound vectorChunkSize sampleRate) keyboardFM :: IO () keyboardFM = do opt <- Option.get str <- Instr.softStringFM amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< CausalPS.amplifyStereo (arr id)) arrange <- SigStL.makeArranger withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 . arrange vectorChunkSize . evalState (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 Gen.sequenceModulated fm (Option.channel opt) (flip str sampleRate)) keyboardFMMulti :: IO () keyboardFMMulti = do opt <- Option.get str <- Instr.softStringFM tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1 amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< CausalPS.amplifyStereo (arr id)) arrange <- SigStL.makeArranger withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> (amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 . arrange vectorChunkSize . evalState (do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03 Gen.sequenceModulatedMultiProgram fm (Option.channel opt) (VoiceMsg.toProgram 1) (map (\sound fmlocal -> sound fmlocal $ sampleRate) [str, tin vectorChunkSize])) controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4, controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4 :: VoiceMsg.Controller controllerFMDepth1 = Ctrl.soundController3 controllerFMDepth2 = Ctrl.soundController5 controllerFMDepth3 = Ctrl.soundController7 controllerFMDepth4 = Ctrl.soundController8 controllerFMPartial1 = Ctrl.generalPurpose1 controllerFMPartial2 = Ctrl.generalPurpose2 controllerFMPartial3 = Ctrl.effect1Depth controllerFMPartial4 = Ctrl.effect2Depth keyboardDetuneFMCore :: (PathClass.AbsRel ar) => Path.Dir ar -> IO (ChannelMsg.Channel -> VoiceMsg.Program -> SVL.ChunkSize -> SampleRate Real -> MidiEv.Filter Event.T (SigSt.T StereoVector)) keyboardDetuneFMCore smpDir = do str0 <- Instr.softStringDetuneFM ssh0 <- Instr.softStringShapeFM css0 <- Instr.cosineStringStereoFM asw0 <- Instr.arcSawStringStereoFM asn0 <- Instr.arcSineStringStereoFM asq0 <- Instr.arcSquareStringStereoFM atr0 <- Instr.arcTriangleStringStereoFM wnd0 <- Instr.wind wnp0 <- Instr.windPhaser fms0 <- Instr.fmStringStereoFM tin0 <- Instr.tineStereoFM tnc0 <- Instr.tineControlledFM fnd0 <- Instr.fenderFM tnb0 <- Instr.tineBankFM rfm0 <- Instr.resonantFMSynth png0 <- Instr.pingStereoRelease pngFM0 <- Instr.pingStereoReleaseFM sqr0 <- Instr.squareStereoReleaseFM bel0 <- Instr.bellStereoFM ben0 <- Instr.bellNoiseStereoFM flt0 <- Instr.filterSawStereoFM brs0 <- Instr.brass syllables <- liftA2 map Instr.sampledSound $ fmap concat $ mapM (Sample.loadRanges smpDir) $ Sample.tomatensalat : Sample.hal : Sample.graphentheorie : [] arrange <- SigStL.makeArranger amp <- CausalP.runStorableChunky (CausalP.mapSimple StereoInt.interleave <<< CausalP.envelopeStereo $< Instr.piecewiseConstantVector (arr id)) return $ \chan pgm vcsize sr -> do let evHead = fmap (EventListMT.switchBodyL (error "empty controller stream") const) flt = evalState $ App.lift6 (\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 $ App.lift6 (\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 $ App.lift6 (\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 $ App.lift6 (\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 $ App.lift4 (\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 $ App.lift5 (\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 $ App.lift4 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 $ App.lift4 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 $ App.lift5 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 $ App.lift5 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 $ App.lift6 (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) (evHead $ PCS.controllerExponential controllerAttack (0.01,0.1) 0.01) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) (evHead $ PCS.controllerLinear controllerTimbre1 (1,5) 3) (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) freqMod = evalState (PCS.bendWheelPressure 2 0.04 0.03) volume <- PC.controllerExponential chan controllerVolume (0.001, 1) 0.2 ctrls <- PCS.fromChannel chan fmap (amp volume . arrange vcsize) $ Gen.sequenceModulatedMultiProgram ctrls chan pgm (map (\sound fm -> sound fm $ sr) $ [tnc, fnd, pngFM, flt, bel, ben, sqr, brs, ssh, fms, css, asn, atr, asq, asw, wnp] ++ map (.freqMod) syllables ++ [str, wnd, png, rfm, tin, tnb]) keyboardDetuneFM :: IO () keyboardDetuneFM = do opt <- Option.get proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) vectorChunkSize sampleRate) keyboardFilter :: IO () keyboardFilter = do opt <- Option.get proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) mix <- CausalP.runStorableChunky $ arr id + (CausalP.mapSimple (StereoInt.amplify 0.5) <<< CausalP.fromSignal (SigP.fromStorableVectorLazy (arr id))) lowpass0 <- CausalP.runStorableChunky $ CausalP.mapSimple StereoInt.interleave <<< -- CausalPS.amplifyStereo 0.1 <<< CausalPS.pack (CausalP.stereoFromMonoControlled (UniFilter.lowpass ^<< UniFilterL.causal) $< (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real)) (piecewiseConstant (arr id))) <<< CausalP.mapSimple StereoInt.deinterleave let lowpass :: Option.SampleRate Real -> PC.T Real -> PC.T Real -> SigSt.T StereoVector -> SigSt.T StereoVector lowpass (Option.SampleRate sr) resons freqs = lowpass0 $ fmap UniFilter.parameter $ PC.zipWith FiltR.Pole resons $ fmap (/ sr) freqs withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate -> evalState (do {- It is important to retrieve the global controllers before they are filtered out by PCS.fromChannel. -} let freqBnd v = 880 * 2^?(v/24) freq <- PC.controllerExponential (Option.extraChannel opt) controllerFilterCutoff (freqBnd (-64), freqBnd 63) 5000 resonance <- PC.controllerExponential (Option.extraChannel opt) controllerFilterResonance (1, 100) 1 filterMusic <- proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) vectorChunkSize sampleRate pureMusic <- proc (Option.channel opt) (VoiceMsg.toProgram 0) vectorChunkSize sampleRate return (pureMusic `mix` lowpass sampleRate resonance freq filterMusic))