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 Data.Tuple.HT (mapPair, fst3, snd3, thd3, )
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Chunky as NonNegChunky
-}
import Algebra.IntegralDomain (divUp, )
import NumericPrelude.Numeric (zero, (^?), (+), )
import Prelude hiding (Real, break, (+), )
{-# INLINE withMIDIEventsMono #-}
withMIDIEventsMono ::
Option.T ->
Output handle (SigSt.T Real) a ->
(SigSt.ChunkSize -> SampleRate Real ->
EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO a
withMIDIEventsMono opt output process = do
putStrLn startMessage
case output opt of
(open,close,write) ->
bracket open (close . snd) $ \((chunkSize,rate),h) ->
let rrate = fromIntegral rate :: Double
in Ev.withMIDIEvents
(Option.clientName opt)
(fromIntegral chunkSize / rrate)
(rrate / fromIntegral vectorSize)
(write h .
SigStL.unpack .
process (SigSt.chunkSize $ divUp chunkSize vectorSize)
(Option.SampleRate $ fromIntegral rate))
type StereoVector = StereoInt.T VectorSize Real
{-# INLINE withMIDIEventsStereo #-}
withMIDIEventsStereo ::
Option.T ->
Output handle (SigSt.T (Stereo.T Real)) a ->
(SigSt.ChunkSize -> SampleRate Real ->
EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) ->
IO a
withMIDIEventsStereo opt output process = do
putStrLn startMessage
case output opt of
(open,close,write) ->
bracket open (close . snd) $ \((chunkSize,rate),h) ->
let rrate = fromIntegral rate :: Double
in Ev.withMIDIEvents
(Option.clientName opt)
(fromIntegral chunkSize / rrate)
(rrate / fromIntegral vectorSize)
(write h .
SigStL.unpackStereo .
process (SigSt.chunkSize $ divUp chunkSize vectorSize)
(Option.SampleRate $ fromIntegral rate))
frequencyModulation :: IO ()
frequencyModulation = do
opt <- Option.get
osc <-
SigP.runChunky
((CausalPS.osciSimple WaveL.triangle $< zero)
$* Instr.frequencyFromBendModulation
(frequencyConst 10)
(Instr.modulation (\fm -> (fm,880))))
withMIDIEventsMono opt play $ \vectorChunkSize sampleRate ->
osc vectorChunkSize . (,) sampleRate .
evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real))
keyboard :: IO ()
keyboard = do
opt <- Option.get
sound <- Instr.pingRelease $/ 0.4 $/ 0.1
amp <- CausalP.runStorableChunky (CausalPS.amplify (arr id))
arrange <- SigStL.makeArranger
withMIDIEventsMono opt play $ \vectorChunkSize sampleRate ->
(amp :: Real -> SigSt.T Vector -> SigSt.T Vector) 0.2 .
arrange vectorChunkSize .
evalState
(Gen.sequence (Option.channel opt) $
sound vectorChunkSize sampleRate)
keyboardStereo :: IO ()
keyboardStereo = do
opt <- Option.get
sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1
amp <-
CausalP.runStorableChunky
(CausalP.mapSimple StereoInt.interleave <<<
CausalPS.amplifyStereo (arr id))
arrange <- SigStL.makeArranger
withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->
(amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 .
arrange vectorChunkSize .
evalState
(Gen.sequence (Option.channel opt) $
sound vectorChunkSize sampleRate)
keyboardFM :: IO ()
keyboardFM = do
opt <- Option.get
str <- Instr.softStringFM
amp <-
CausalP.runStorableChunky
(CausalP.mapSimple StereoInt.interleave <<<
CausalPS.amplifyStereo (arr id))
arrange <- SigStL.makeArranger
withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->
(amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 .
arrange vectorChunkSize .
evalState
(do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03
Gen.sequenceModulated
fm (Option.channel opt) (flip str sampleRate))
keyboardFMMulti :: IO ()
keyboardFMMulti = do
opt <- Option.get
str <- Instr.softStringFM
tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1
amp <-
CausalP.runStorableChunky
(CausalP.mapSimple StereoInt.interleave <<<
CausalPS.amplifyStereo (arr id))
arrange <- SigStL.makeArranger
withMIDIEventsStereo opt play $ \vectorChunkSize sampleRate ->
(amp :: Real -> SigSt.T (Stereo.T Vector) -> SigSt.T StereoVector) 0.2 .
arrange vectorChunkSize .
evalState
(do fm <- PC.bendWheelPressure (Option.channel opt) 2 0.04 0.03
Gen.sequenceModulatedMultiProgram
fm (Option.channel opt)
(VoiceMsg.toProgram 1)
(map (\sound fmlocal -> sound fmlocal $ sampleRate)
[str, tin vectorChunkSize]))
controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,
controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4
:: VoiceMsg.Controller
controllerFMDepth1 = Ctrl.soundController3
controllerFMDepth2 = Ctrl.soundController5
controllerFMDepth3 = Ctrl.soundController7
controllerFMDepth4 = Ctrl.soundController8
controllerFMPartial1 = Ctrl.generalPurpose1
controllerFMPartial2 = Ctrl.generalPurpose2
controllerFMPartial3 = Ctrl.effect1Depth
controllerFMPartial4 = Ctrl.effect2Depth
keyboardDetuneFMCore ::
(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))