module Csound.Air.Patch(
CsdNote, Instr, Fx, Fx1, Fx2, FxSpec(..), DryWetRatio,
Patch1, Patch2, Patch(..), PolySyntSpec(..), MonoSyntSpec(..),
polySynt, monoSynt,
mapPatchInstr, mapMonoPolyInstr, transPatch, dryPatch, getPatchFx,
setFxMix, setFxMixes,
setMidiChn,
atMidi,
atSched,
atSchedUntil,
atSco,
atNote,
addInstrFx, addPreFx, addPostFx,
harmonPatch, deepPad,
patchWhen,
mixInstr,
withSmallRoom, withSmallRoom',
withSmallHall, withSmallHall',
withLargeHall, withLargeHall',
withMagicCave, withMagicCave',
sfPatch, sfPatchHall,
onMonoSyntSpec, setMonoSharp, setMonoHold,
patchByNameMidi,
atMidiTemp,
patchByNameMidiTemp
) where
import Data.Boolean
import Data.Default
import Control.Monad
import Control.Applicative
import Control.Arrow(second)
import Csound.Typed
import Csound.SigSpace
import Csound.Control.Midi
import Csound.Control.Instr
import Csound.Control.Sf
import Csound.Air.Fx
import Csound.Typed.Opcode(cpsmidinn, ampdb)
import Csound.Tuning
import Csound.Types
type CsdNote a = (a, a)
type Instr a b = CsdNote a -> SE b
type Fx a = a -> SE a
type DryWetRatio = Sig
type Fx1 = Fx Sig
type Fx2 = Fx Sig2
data FxSpec a = FxSpec
{ fxMix :: DryWetRatio
, fxFun :: Fx a
}
type Patch1 = Patch Sig
type Patch2 = Patch Sig2
data MonoSyntSpec = MonoSyntSpec
{ monoSyntChn :: MidiChn
, monoSyntHold :: Bool
, monoSyntSlideTime :: D
, monoSyntRelease :: D }
instance Default MonoSyntSpec where
def = MonoSyntSpec
{ monoSyntChn = ChnAll
, monoSyntHold = False
, monoSyntSlideTime = 0.01
, monoSyntRelease = 0.1 }
data PolySyntSpec = PolySyntSpec
{ polySyntChn :: MidiChn }
instance Default PolySyntSpec where
def = PolySyntSpec { polySyntChn = ChnAll }
data Patch a
= MonoSynt MonoSyntSpec (Instr Sig a)
| PolySynt PolySyntSpec (Instr D a)
| FxChain [FxSpec a] (Patch a)
| SplitPatch (Patch a) D (Patch a)
| LayerPatch [(Sig, Patch a)]
polySynt :: (Instr D a) -> Patch a
polySynt = PolySynt def
monoSynt :: (Instr Sig a) -> Patch a
monoSynt = MonoSynt def
mapMonoPolyInstr :: (Instr Sig a -> Instr Sig a) -> (Instr D a -> Instr D a) -> Patch a -> Patch a
mapMonoPolyInstr mono poly x = case x of
MonoSynt spec instr -> MonoSynt spec (mono instr)
PolySynt spec instr -> PolySynt spec (poly instr)
FxChain fxs p -> FxChain fxs (rec p)
LayerPatch xs -> LayerPatch (mapSnd rec xs)
SplitPatch a dt b -> SplitPatch (rec a) dt (rec b)
where
rec = mapMonoPolyInstr mono poly
mapPatchInstr :: (Instr D a -> Instr D a) -> Patch a -> Patch a
mapPatchInstr f x = case x of
MonoSynt _ _ -> x
PolySynt spec instr -> PolySynt spec $ f instr
FxChain fxs p -> FxChain fxs $ rec p
LayerPatch xs -> LayerPatch (mapSnd rec xs)
SplitPatch a dt b -> SplitPatch (rec a) dt (rec b)
where
rec = mapPatchInstr f
dryPatch :: Patch a -> Patch a
dryPatch x = case x of
MonoSynt spec instr -> x
PolySynt spec instr -> x
FxChain _ p -> dryPatch p
SplitPatch a dt b -> SplitPatch (dryPatch a) dt (dryPatch b)
LayerPatch xs -> LayerPatch $ mapSnd dryPatch xs
setFxMix :: Sig -> Patch a -> Patch a
setFxMix a = setFxMixes [a]
setFxMixes :: [Sig] -> Patch a -> Patch a
setFxMixes ks p = case p of
FxChain fxs x -> FxChain (zipFirst (\k x -> x { fxMix = k }) ks fxs) x
_ -> p
where
zipFirst f xs ys = case (xs, ys) of
(_, []) -> []
([], bs) -> bs
(a:as, b:bs) -> f a b : zipFirst f as bs
instance SigSpace a => SigSpace (Patch a) where
mapSig f x =
case x of
MonoSynt spec instr -> MonoSynt spec $ fmap (mapSig f) . instr
PolySynt spec instr -> PolySynt spec $ fmap (mapSig f) . instr
FxChain fxs p -> FxChain fxs $ mapSig f p
SplitPatch a dt b -> SplitPatch (mapSig f a) dt (mapSig f b)
LayerPatch xs -> FxChain [FxSpec 1 (return . mapSig f)] $ LayerPatch xs
mapSnd :: (a -> b) -> [(c, a)] -> [(c, b)]
mapSnd f = fmap (second f)
wet :: (SigSpace a, Sigs a) => FxSpec a -> Fx a
wet (FxSpec k fx) asig = fmap ((mul (1 k) asig + ) . mul k) $ fx asig
getPatchFx :: (SigSpace a, Sigs a) => [FxSpec a] -> Fx a
getPatchFx xs = foldr (<=<) return $ fmap wet xs
atNote :: (SigSpace a, Sigs a) => Patch a -> CsdNote D -> SE a
atNote p note@(amp, cps) = case p of
MonoSynt spec instr -> instr (sig amp, sig cps)
PolySynt spec instr -> instr note
FxChain fxs p -> getPatchFx fxs =<< rec p
LayerPatch xs -> onLayered xs rec
SplitPatch a t b -> getSplit (cps `lessThan` t) (rec a) (rec b)
where
rec x = atNote x note
getSplit :: (Num a, Tuple a) => BoolD -> SE a -> SE a -> SE a
getSplit cond a b = do
ref <- newRef 0
whenElseD cond
(mixRef ref =<< a)
(mixRef ref =<< b)
readRef ref
midiChn :: Sigs a => MidiChn -> (Msg -> SE a) -> SE a
midiChn chn = case chn of
ChnAll -> midi
Chn n -> midin n
Pgm pgm chn -> pgmidi pgm chn
atMidi :: (SigSpace a, Sigs a) => Patch a -> SE a
atMidi x = case x of
MonoSynt spec instr -> monoSynt spec instr
PolySynt spec instr -> midiChn (polySyntChn spec) (instr . ampCps)
FxChain fxs p -> getPatchFx fxs =<< atMidi p
LayerPatch xs -> onLayered xs atMidi
SplitPatch a dt b -> genMidiSplitPatch ampCps a dt b
where
monoSynt spec instr = instr =<< getArg
where
getArg
| monoSyntHold spec = holdMsg chn port
| otherwise = monoMsg chn port rel
port = monoSyntSlideTime spec
rel = monoSyntRelease spec
chn = monoSyntChn spec
atMidiTemp :: (SigSpace a, Sigs a) => Temp -> Patch a -> SE a
atMidiTemp tm x = case x of
MonoSynt spec instr -> monoSynt spec instr
PolySynt spec instr -> midiChn (polySyntChn spec) (instr . ampCps' tm)
FxChain fxs p -> getPatchFx fxs =<< atMidiTemp tm p
LayerPatch xs -> onLayered xs (atMidiTemp tm)
SplitPatch a cps b -> genMidiSplitPatch (ampCps' tm) a cps b
where
monoSynt spec instr = instr =<< getArg
where
getArg
| monoSyntHold spec = holdMsgTemp tm chn port
| otherwise = monoMsgTemp tm chn port rel
port = monoSyntSlideTime spec
rel = monoSyntRelease spec
chn = monoSyntChn spec
genMidiSplitPatch :: (SigSpace a, Sigs a) => (Msg -> (D, D)) -> Patch a -> D -> Patch a -> SE a
genMidiSplitPatch midiArg = genSplitPatch $ \chn instr -> midiChn chn (instr . midiArg)
genSplitPatch :: (SigSpace a, Sigs a) => (MidiChn -> (CsdNote D -> SE a) -> SE a) -> Patch a -> D -> Patch a -> SE a
genSplitPatch playInstr a dt b = liftA2 (+) (leftSplit dt a) (rightSplit dt b)
where
leftSplit dt a = onCondPlay ( `lessThan` dt) a
rightSplit dt a = onCondPlay ( `greaterThanEquals` dt) a
onCondPlay cond x = case x of
MonoSynt spec instr -> error "Split doesn't work for monophonic synths. Pleas use only polyphonic synths."
PolySynt spec instr -> playInstr (polySyntChn spec) (restrictPolyInstr cond instr)
FxChain fxs p -> getPatchFx fxs =<< onCondPlay cond p
LayerPatch xs -> onLayered xs (onCondPlay cond)
SplitPatch a dt b -> liftA2 (+)
(onCondPlay (\x -> cond x &&* (x `lessThan` dt)) a)
(onCondPlay (\x -> cond x &&* (x `greaterThanEquals` dt)) b)
restrictPolyInstr :: (Sigs a) => (D -> BoolD) -> (CsdNote D -> SE a) -> CsdNote D -> SE a
restrictPolyInstr cond instr note@(amp, cps) = do
ref <- newRef 0
whenElseD (cond cps)
(writeRef ref =<< instr note)
(writeRef ref 0)
readRef ref
atSched :: (SigSpace a, Sigs a) => Patch a -> Evt (Sco (CsdNote D)) -> SE a
atSched x evt = case x of
MonoSynt _ instr -> error "atSched is not defined for monophonic synthesizers"
PolySynt _ instr -> playInstr instr
FxChain fxs p -> getPatchFx fxs =<< atSched p evt
LayerPatch xs -> onLayered xs (\patch -> atSched patch evt)
SplitPatch a t b -> genSplitPatch (const playInstr) a t b
where playInstr instr = return $ sched instr evt
atSchedUntil :: (SigSpace a, Sigs a) => Patch a -> Evt (CsdNote D) -> Evt b -> SE a
atSchedUntil x evt stop = case x of
MonoSynt _ instr -> error "atSchedUntil is not defined for monophonic synthesizers"
PolySynt _ instr -> playInstr instr
FxChain fxs p -> getPatchFx fxs =<< atSchedUntil p evt stop
LayerPatch xs -> onLayered xs (\patch -> atSchedUntil patch evt stop)
SplitPatch a cps b -> genSplitPatch (const playInstr) a cps b
where playInstr instr = return $ schedUntil instr evt stop
atSco :: (SigSpace a, Sigs a) => Patch a -> Sco (CsdNote D) -> Sco (Mix a)
atSco x sc = case x of
MonoSynt _ instr -> error "atSco is not defined for monophonic synthesizers"
PolySynt _ instr -> sco instr sc
FxChain fxs p -> eff (getPatchFx fxs) $atSco p sc
LayerPatch xs -> har $ fmap (\(vol, p) -> atSco (mul vol p) sc) xs
SplitPatch a cps b -> undefined
scoSplitPatch :: (SigSpace a, Sigs a) => Patch a -> D -> Patch a -> Sco (CsdNote D) -> Sco (Mix a)
scoSplitPatch a dt b sc = har [leftSplit dt a, rightSplit dt b]
where
leftSplit dt a = onCondPlay ( `lessThan` dt) a
rightSplit dt a = onCondPlay ( `greaterThanEquals` dt) a
onCondPlay cond x = case x of
MonoSynt spec instr -> error "Split doesn't work for monophonic synths. Pleas use only polyphonic synths."
PolySynt spec instr -> sco (restrictPolyInstr cond instr) sc
FxChain fxs p -> eff (getPatchFx fxs) $ atSco p sc
LayerPatch xs -> har $ fmap (\(vol, p) -> atSco (mul vol p) sc) xs
SplitPatch a dt b -> har
[ onCondPlay (\x -> cond x &&* (x `lessThan` dt)) a
, onCondPlay (\x -> cond x &&* (x `greaterThanEquals` dt)) b ]
onLayered :: (SigSpace a, Sigs a) => [(Sig, Patch a)] -> (Patch a -> SE a) -> SE a
onLayered xs f = fmap sum $ mapM (\(vol, p) -> fmap (mul vol) $ f p) xs
onMonoSyntSpec :: (MonoSyntSpec -> MonoSyntSpec) -> Patch a -> Patch a
onMonoSyntSpec f x = case x of
MonoSynt spec instr -> MonoSynt (f spec) instr
PolySynt spec instr -> PolySynt spec instr
FxChain fxs p -> FxChain fxs $ onMonoSyntSpec f p
LayerPatch xs -> LayerPatch $ mapSnd (onMonoSyntSpec f) xs
SplitPatch a cps b -> SplitPatch (onMonoSyntSpec f a) cps (onMonoSyntSpec f b)
setMidiChn :: MidiChn -> Patch a -> Patch a
setMidiChn chn x = case x of
MonoSynt spec instr -> MonoSynt (spec { monoSyntChn = chn }) instr
PolySynt spec instr -> PolySynt (spec { polySyntChn = chn }) instr
FxChain fxs p -> FxChain fxs $ go p
LayerPatch xs -> LayerPatch $ mapSnd go xs
SplitPatch a cps b -> SplitPatch (go a) cps (go b)
where go = setMidiChn chn
setMonoSharp :: Patch a -> Patch a
setMonoSharp = onMonoSyntSpec (\x -> x { monoSyntSlideTime = 0.005, monoSyntRelease = 0.05 })
setMonoHold :: Patch a -> Patch a
setMonoHold = onMonoSyntSpec (\x -> x { monoSyntHold = True })
transPatch :: D -> Patch a -> Patch a
transPatch k = mapMonoPolyInstr (\instr -> instr . second ( * sig k)) (\instr -> instr . second ( * k))
addInstrFx :: Fx a -> Patch a -> Patch a
addInstrFx f p = mapPatchInstr (\instr -> f <=< instr) p
addPreFx :: DryWetRatio -> Fx a -> Patch a -> Patch a
addPreFx dw f p = case p of
FxChain fxs (PolySynt spec instr) -> FxChain (addFx fxs) (PolySynt spec instr)
FxChain fxs (MonoSynt spec instr) -> FxChain (addFx fxs) (MonoSynt spec instr)
PolySynt spec instr -> FxChain fxSpec $ PolySynt spec instr
MonoSynt spec instr -> FxChain fxSpec $ MonoSynt spec instr
LayerPatch xs -> LayerPatch $ mapSnd (addPreFx dw f) xs
SplitPatch a cps b -> SplitPatch (addPreFx dw f a) cps (addPreFx dw f b)
where
addFx xs = xs ++ fxSpec
fxSpec = [FxSpec dw f]
addPostFx :: DryWetRatio -> Fx a -> Patch a -> Patch a
addPostFx dw f p = case p of
FxChain fxs rest -> FxChain (fxSpec : fxs) rest
_ -> FxChain [fxSpec] p
where fxSpec = FxSpec dw f
patchWhen :: (Sigs a) => BoolSig -> Patch a -> Patch a
patchWhen cond x = case x of
MonoSynt spec instr -> MonoSynt spec (playWhen cond instr)
PolySynt spec instr -> PolySynt spec (playWhen cond instr)
FxChain fxs p -> FxChain (fmap (mapFun (playWhen cond)) fxs) (rec p)
LayerPatch xs -> LayerPatch $ mapSnd rec xs
SplitPatch a cps b -> SplitPatch (rec a) cps (rec b)
where
rec = patchWhen cond
mapFun f x = x { fxFun = f $ fxFun x }
mixInstr :: (SigSpace b, Num b) => Sig -> Patch b -> Patch b -> Patch b
mixInstr k f p = LayerPatch [(k, f), (1, p)]
harmonPatch :: (SigSpace b, Sigs b) => [Sig] -> [D] -> Patch b -> Patch b
harmonPatch amps freqs = tfmInstr monoTfm polyTfm
where
monoTfm instr = \(amp, cps) -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ instr (amp, cps * f)) amps (fmap sig freqs)
polyTfm instr = \(amp, cps) -> fmap sum $ zipWithM (\a f -> fmap (mul a) $ instr (amp, cps * f)) amps freqs
deepPad :: (SigSpace b, Sigs b) => Patch b -> Patch b
deepPad = harmonPatch (fmap (* 0.75) [1, 0.5]) [1, 0.5]
tfmInstr :: ((CsdNote Sig -> SE b) -> (CsdNote Sig -> SE b)) -> ((CsdNote D -> SE b) -> (CsdNote D -> SE b)) -> Patch b -> Patch b
tfmInstr monoTfm polyTfm x = case x of
MonoSynt spec instr -> MonoSynt spec $ monoTfm instr
PolySynt spec instr -> PolySynt spec $ polyTfm instr
FxChain fxs p -> FxChain fxs $ rec p
SplitPatch a cps b -> SplitPatch (rec a) cps (rec b)
LayerPatch xs -> LayerPatch $ mapSnd rec xs
where
rec = tfmInstr monoTfm polyTfm
mapSnd f = fmap (second f)
withSmallRoom :: Patch2 -> Patch2
withSmallRoom = withSmallRoom' 0.25
withSmallRoom' :: DryWetRatio -> Patch2 -> Patch2
withSmallRoom' = withRever smallRoom2
withSmallHall :: Patch2 -> Patch2
withSmallHall = withSmallHall' 0.25
withSmallHall' :: DryWetRatio -> Patch2 -> Patch2
withSmallHall' = withRever smallHall2
withLargeHall :: Patch2 -> Patch2
withLargeHall = withLargeHall' 0.25
withLargeHall' :: DryWetRatio -> Patch2 -> Patch2
withLargeHall' = withRever largeHall2
withMagicCave :: Patch2 -> Patch2
withMagicCave = withMagicCave' 0.25
withMagicCave' :: DryWetRatio -> Patch2 -> Patch2
withMagicCave' = withRever magicCave2
withRever :: (Sig2 -> Sig2) -> DryWetRatio -> Patch2 -> Patch2
withRever fx ratio p = addPostFx ratio (return . fx) p
sfPatchHall :: Sf -> Patch2
sfPatchHall = withSmallHall . sfPatch
sfPatch :: Sf -> Patch2
sfPatch sf = PolySynt def $ \(amp, cps) -> return $ sfCps sf 0.5 amp cps
patchByNameMidi :: (SigSpace a, Sigs a) => String -> Patch a -> SE a
patchByNameMidi = genPatchByNameMidi cpsmidinn cpsmidinn
patchByNameMidiTemp :: (SigSpace a, Sigs a) => Temp -> String -> Patch a -> SE a
patchByNameMidiTemp tm = genPatchByNameMidi (cpsmidi'Sig tm) (cpsmidi'D tm)
genPatchByNameMidi :: forall a . (SigSpace a, Sigs a) => (Sig -> Sig) -> (D -> D) -> String -> Patch a -> SE a
genPatchByNameMidi monoKey2cps polyKey2cps name x = case x of
MonoSynt spec instr -> monoSynt spec instr
PolySynt spec instr -> polySynt spec instr
FxChain fxs p -> getPatchFx fxs =<< rec p
LayerPatch xs -> onLayered xs rec
SplitPatch a cps b -> splitPatch a cps b
where
rec = genPatchByNameMidi monoKey2cps polyKey2cps name
monoSynt spec instr = instr =<< fmap convert (trigNamedMono portTime relTime name)
where
convert (vol, pch) = (vel2ampSig vol, monoKey2cps pch)
portTime = monoSyntSlideTime spec
relTime = monoSyntRelease spec
polySynt spec instr = trigByNameMidi name go
where
go :: (D, D, Unit) -> SE a
go (pitch, vol, _) = instr (vel2amp vol, polyKey2cps pitch)
splitPatch a cps b = genSplitPatch polySynt a cps b
vel2amp :: D -> D
vel2amp vol = ((vol / 64) ** 2) / 2
vel2ampSig :: Sig -> Sig
vel2ampSig vol = ((vol / 64) ** 2) / 2