{-# Language FlexibleContexts #-}
module Csound.Air.Fx(
reverbsc1, rever1, rever2, reverTime,
smallRoom, smallHall, largeHall, magicCave,
smallRoom2, smallHall2, largeHall2, magicCave2,
room, chamber, hall, cave,
monoIR, stereoIR, stereoIR2, pmonoIR, pstereoIR, pstereoIR2,
monoIR', stereoIR', stereoIR2',
ZConvSpec(..), zconv, zconv',
MaxDelayTime, DelayTime, Feedback, Balance,
echo, fvdelay, fvdelays, funDelays, tabDelay,
PingPongSpec(..), pingPong, pingPong', csdPingPong,
EchoGain, RandomSpreadSig,
tapeRead, tapeWrite,
tapeEcho,
distortion,
DepthSig, RateSig, WidthSig, ToneSig,
chorus,
flange,
phase1, harmPhase, powerPhase,
DriveSig, SensitivitySig, BaseCps, Resonance, TimeSig, BitsReductionSig, FoldoverSig,
TremWaveSig, RatioSig, FftSize,
fxDistort, stChorus2, fxPhaser,
fxFlanger, analogDelay, fxEcho, fxFilter,
fxWhite, fxPink, equalizer, eq4, eq7,
fxGain,
fxAnalogDelay, fxDistortion, fxFollower, fxReverse, fxLoFi, fxChorus2, fxAutoPan, fxTrem, fxPitchShifter, fxFreqShifter,
fxCompress,
audaciousEq,
trackerSplice, pitchShifterDelay
) where
import Data.Boolean
import Data.Default
import Csound.Typed
import Csound.Tab(sines4, startEnds, setSize, elins, newTab, tabSizeSecondsPower2, tablewa, sec2rel)
import Csound.Typed.Opcode
import Csound.SigSpace
import Csound.Tab
import Csound.Air.Wave(Lfo, unipolar, oscBy, utri, white, pink)
import Csound.Air.Filter
import Csound.Typed.Plugins hiding(pitchShifterDelay,
fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi,
fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2)
import qualified Csound.Typed.Plugins as P(pitchShifterDelay,
fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi,
fxPanTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong, tapeRead, tapeWrite)
reverbsc1 :: Sig -> Feedback -> ToneSig -> Sig
reverbsc1 x k co = 0.5 * (a + b)
where (a, b) = ar2 $ reverbsc x x k co
reverTime :: DelayTime -> Sig -> Sig
reverTime dt a = nreverb a dt 0.3
rever1 :: Feedback -> Sig -> (Sig, Sig)
rever1 fbk a = reverbsc a a fbk 12000
rever2 :: Feedback -> Sig2 -> Sig2
rever2 fbk (a1, a2) = (a1 + wa1, a2 + wa2)
where (wa1, wa2) = reverbsc a1 a2 fbk 12000
smallRoom :: Sig -> (Sig, Sig)
smallRoom = rever1 0.6
smallHall :: Sig -> (Sig, Sig)
smallHall = rever1 0.8
largeHall :: Sig -> (Sig, Sig)
largeHall = rever1 0.9
magicCave :: Sig -> (Sig, Sig)
magicCave = rever1 0.99
smallRoom2 :: Sig2 -> Sig2
smallRoom2 = rever2 0.6
smallHall2 :: Sig2 -> Sig2
smallHall2 = rever2 0.8
largeHall2 :: Sig2 -> Sig2
largeHall2 = rever2 0.9
magicCave2 :: Sig2 -> Sig2
magicCave2 = rever2 0.99
room :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
room mx ain = mixAt mx smallRoom2 ain
chamber :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
chamber mx ain = mixAt mx smallHall2 ain
hall :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
hall mx ain = mixAt mx largeHall2 ain
cave :: MixAt Sig2 Sig2 a => Sig -> a -> AtOut Sig2 Sig2 a
cave mx ain = mixAt mx magicCave2 ain
monoIR :: FilePath -> Sig -> Sig
monoIR = monoIR' def
monoIR' :: ZConvSpec -> FilePath -> Sig -> Sig
monoIR' spec fileName ain = zconv' spec (wavLeft fileName) ain
stereoIR :: FilePath -> Sig2 -> Sig2
stereoIR = stereoIR' def
stereoIR' :: ZConvSpec -> FilePath -> Sig2 -> Sig2
stereoIR' spec fileName (ainL, ainR) = (zconv' spec (wavLeft fileName) ainL, zconv' spec (wavRight fileName) ainR)
stereoIR2 :: (FilePath, FilePath) -> Sig2 -> Sig2
stereoIR2 = stereoIR2' def
stereoIR2' :: ZConvSpec -> (FilePath, FilePath) -> Sig2 -> Sig2
stereoIR2' spec (file1, file2) (ainL, ainR) = (monoIR' spec file1 ainL, monoIR' spec file2 ainR)
pmonoIR :: FilePath -> Sig -> Sig
pmonoIR fileName ain = pconvolve ain (text fileName)
pstereoIR :: FilePath -> Sig2 -> Sig2
pstereoIR fileName (ainL, ainR) = pconvolve ((ainL + ainR) * 0.5) (text fileName)
pstereoIR2 :: (FilePath, FilePath) -> Sig2 -> Sig2
pstereoIR2 (file1, file2) (ainL, ainR) = (pmonoIR file1 ainL, pmonoIR file2 ainR)
type MaxDelayTime = D
type DelayTime = Sig
type Feedback = Sig
type Balance = Sig
echo :: MaxDelayTime -> Feedback -> Sig -> Sig
echo len fb x = x + flanger x (sig len) fb `withD` (len + 0.005)
fvdelay :: MaxDelayTime -> DelayTime -> Feedback -> Sig -> Sig
fvdelay len dt fb a = a + flanger a dt fb `withD` len
fvdelays :: MaxDelayTime -> [(DelayTime, Feedback)] -> Balance -> Sig -> SE Sig
fvdelays len dtArgs mx a = funDelays len (zip dts fs) mx a
where
(dts, fbks) = unzip dtArgs
fs = map (*) fbks
funDelays :: MaxDelayTime -> [(DelayTime, Sig -> Sig)] -> Balance -> Sig -> SE Sig
funDelays len dtArgs mx a = do
_ <- delayr len
aDels <- mapM deltap3 dts
delayw $ a + sum (zipWith ($) fs aDels)
return $ a + mx * sum aDels
where (dts, fs) = unzip dtArgs
tabDelay :: (Tab -> Sig -> SE Sig) -> MaxDelayTime -> DelayTime -> Feedback -> Balance -> Sig -> SE Sig
tabDelay go maxLength delTim kfeed kbalance asig = do
buf <- newTab tabLen
ptrRef <- newRef (0 :: Sig)
aresRef <- newRef (0 :: Sig)
ptr <- readRef ptrRef
when1 (ptr >=* sig tabLen) $ do
writeRef ptrRef 0
ptr <- readRef ptrRef
let kphs = (ptr / sig tabLen) - (delTim/(sig $ tabLen / getSampleRate))
awet <-go buf (wrap kphs 0 1)
writeRef aresRef $ asig + kfeed * awet
ares <- readRef aresRef
writeRef ptrRef =<< tablewa buf ares 0
return $ (1 - kbalance) * asig + kbalance * awet
where
tabLen = tabSizeSecondsPower2 maxLength
data PingPongSpec = PingPongSpec {
pingPongMaxTime :: MaxDelayTime,
pingPongDamp :: Sig,
pingPongWidth :: Sig
}
instance Default PingPongSpec where
def = PingPongSpec {
pingPongMaxTime = 5,
pingPongDamp = 3500,
pingPongWidth = 0.6
}
pingPong :: DelayTime -> Feedback -> Balance -> Sig2 -> Sig2
pingPong delTime feedback mixLevel (ainL, ainR) = pingPong' def delTime feedback mixLevel (ainL, ainR)
pingPong' :: PingPongSpec -> DelayTime -> Feedback -> Balance -> Sig2 -> Sig2
pingPong' (PingPongSpec maxTime damp width) delTime feedback mixLevel (ainL, ainR) =
csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR)
csdPingPong :: MaxDelayTime -> DelayTime -> Sig -> Feedback -> Sig -> Balance -> Sig2 -> Sig2
csdPingPong maxTime delTime damp feedback width mixLevel (ainL, ainR) = P.fxPingPong maxTime mixLevel width damp delTime feedback (ainL, ainR)
type DepthSig = Sig
type RateSig = Sig
type WidthSig = Sig
type ToneSig = Sig
distortion :: Sig -> Sig -> Sig
distortion pre asig = distort1 asig pre 0.5 0 0 `withD` 1
chorus :: DepthSig -> RateSig -> Balance -> Sig -> SE Sig
chorus depth rate mx asig = do
_ <- delayr 1.2
adelSig <- deltap3 (0.03 * depth * oscBy fn (3 * rate) + 0.01)
delayw asig
return $ ntrpol asig adelSig mx
where fn = sines4 [(0.5, 1, 180, 1)]
flange :: Lfo -> Feedback -> Balance -> Sig -> Sig
flange alfo fbk mx asig = ntrpol asig (flanger asig ulfo fbk) mx
where ulfo = 0.0001 + 0.02 * unipolar alfo
phase1 :: Sig -> Lfo -> Feedback -> Balance -> Sig -> Sig
phase1 ord alfo fbk mx asig = ntrpol asig (phaser1 asig (20 + unipolar alfo) ord fbk) mx
harmPhase :: Sig -> Lfo -> Sig -> Sig -> Feedback -> Balance -> Sig -> Sig
harmPhase ord alfo q sep fbk mx asig = ntrpol asig (phaser2 asig (20 + unipolar alfo) q ord 1 sep fbk) mx
powerPhase :: Sig -> Lfo -> Sig -> Sig -> Feedback -> Balance -> Sig -> Sig
powerPhase ord alfo q sep fbk mx asig = ntrpol asig (phaser2 asig (20 + unipolar alfo) q ord 2 sep fbk) mx
expScale :: Sig -> (Sig, Sig) -> Sig -> Sig
expScale steep (min, max) a = scale (expcurve a steep) max min
logScale :: Sig -> (Sig, Sig) -> Sig -> Sig
logScale steep (min, max) a = scale (logcurve a steep) max min
dryWetMix :: Sig -> (Sig, Sig)
dryWetMix kmix = (kDry, kWet)
where
iWet = setSize 1024 $ elins [0, 1, 1]
iDry = setSize 1024 $ elins [1, 1, 0]
kWet = kr $ table kmix iWet `withD` 1
kDry = kr $ table kmix iDry `withD` 1
fxWet :: (Num a, SigSpace a) => Sig -> a -> a -> a
fxWet mix ain aout = mul dry ain + mul wet aout
where (dry, wet) = dryWetMix mix
fxDistort :: Feedback -> Sig -> ToneSig -> Sig -> Sig
fxDistort klevel kdrive ktone ain = aout * (scale klevel 0.8 0) * kGainComp1
where
aout = blp kLPF $ distort1 ain kpregain kpostgain 0 0
drive = expScale 8 (0.01, 0.4) kdrive
kGainComp1 = logScale 700 (5,1) ktone
kpregain = 100 * drive
kpostgain = 0.5 * ((1 - drive) * 0.4 + 0.6)
kLPF = logScale 700 (200, 12000) ktone
stChorus2 :: Balance -> RateSig -> DepthSig -> WidthSig -> Sig2 -> Sig2
stChorus2 kmix krate' kdepth kwidth (al, ar) = fxWet kmix (al, ar) (aoutL, aoutR)
where
krate = expScale 20 (0.001, 7) krate'
ilfoshape = setSize 131072 $ sines4 [(1, 0.5, 0, 0.5)]
kporttime = linseg [0, 0.001, 0.02]
kChoDepth = interp $ portk (kdepth*0.01) kporttime
amodL = osciliktp krate ilfoshape 0
amodR = osciliktp krate ilfoshape (kwidth*0.5)
vdel mod x = vdelay x (mod * kChoDepth * 1000) (1.2 * 1000)
aChoL = vdel amodL al
aChoR = vdel amodR ar
aoutL = 0.6 * (aChoL + al)
aoutR = 0.6 * (aChoR + ar)
analogDelay :: Balance -> Feedback -> DelayTime -> ToneSig -> Sig -> Sig
analogDelay kmix kfback ktime ktone ain = P.fxAnalogDelay kmix kfback ktime ktone ain
fxFilter :: Sig -> Sig -> Sig -> Sig -> Sig
fxFilter kLPF' kHPF' kgain' ain = mul kgain $ app (blp kLPF) $ app (bhp kHPF) $ ain
where
app f = f . f
kLPF = scaleFreq kLPF'
kHPF = scaleFreq kHPF'
kgain = scale kgain' 20 0
scaleFreq x = expScale 4 (20, 20000) x
equalizer :: [(Sig, Sig)] -> Sig -> Sig -> Sig
equalizer fs gain ain0 = case fs of
[] -> ain
x:[] -> g 0 x ain
x:y:[] -> mean [g 1 x ain, g 2 y ain]
x:xs -> mean $ (g 1 x ain : ) $ (fmap (\y -> g 0 y ain) (init xs)) ++ [g 2 (last xs) ain]
where
iQ = 1
iEQcurve = skipNorm $ setSize 4096 $ startEnds [1/64,4096,7.9,64]
iGainCurve = skipNorm $ setSize 4096 $ startEnds [0.5,4096,3,4]
g ty (gain, freq) asig = pareq asig freq (table gain iEQcurve `withD` 1) iQ `withD` ty
kgain = table gain iGainCurve `withD` 1
ain = kgain * ain0
eq7 :: [Sig] -> Sig -> Sig -> Sig
eq7 gs = equalizer (zip gs $ fmap (100 * ) [1, 2, 4, 8, 16, 32, 64])
eq4 :: [Sig] -> Sig -> Sig -> Sig
eq4 gs = equalizer (zip gs $ fmap (100 * ) [1, 4, 16, 64])
fxGain :: SigSpace a => Sig -> a -> a
fxGain = mul
fxWhite :: Sig -> Sig -> Sig -> SE Sig
fxWhite freq depth ain = do
noise <- white
return $ ain + 0.5 * depth * blp cps noise
where cps = expScale 4 (20, 20000) freq
fxPink :: Sig -> Sig -> Sig -> SE Sig
fxPink freq depth ain = do
noise <- pink
return $ ain + 0.5 * depth * blp cps noise
where cps = expScale 4 (20, 20000) freq
fxEcho :: D -> Sig -> Sig -> Sig -> Sig
fxEcho maxLen ktime fback = fvdelay (5 * maxLen) (sig maxLen * 0.95 * kTime) fback
where
kporttime = linseg [0,0.001,0.1]
kTime = portk ktime (kporttime*3)
trackerSplice :: D -> Sig -> Sig -> Sig -> SE Sig
trackerSplice maxLength segLengthSeconds kmode asig = do
setksmps 1
kindxRef <- newRef (0 :: Sig)
ksampRef <- newRef (1 :: D)
aoutRef <- newRef (0 :: Sig)
buf <- newTab (tabSizeSecondsPower2 maxLength)
let segLength = segLengthSeconds * sig getSampleRate
andx = phasor (sig $ getSampleRate / ftlen buf)
andx1 = delay andx 1
tabw asig (andx * sig (ftlen buf)) buf
ksamp <- readRef ksampRef
let apos = samphold (andx1 * sig (ftlen buf)) (sig ksamp)
whens [
(kmode >=* 1 &&* kmode `lessThan` 2, do
kindx <- readRef kindxRef
writeRef kindxRef $ ifB (kindx >* segLength) 0 (kindx + 1)
kindx <- readRef kindxRef
when1 (kindx + apos >* sig (ftlen buf)) $ do
writeRef kindxRef $ (-segLength)
kindx <- readRef kindxRef
writeRef aoutRef $ table (apos + kindx) buf `withDs` [0, 1]
writeRef ksampRef 0
), (kmode >=* 2 &&* kmode `lessThan` 3, do
kindx <- readRef kindxRef
writeRef kindxRef $ ifB ((kindx+apos) <=* 0) (sig (ftlen buf) - apos) (kindx-1)
kindx <- readRef kindxRef
writeRef aoutRef $ table (apos+kindx) buf `withDs` [0, 1]
writeRef ksampRef 0
)] (do
writeRef ksampRef 1
writeRef aoutRef asig)
aout <-readRef aoutRef
return aout
mean :: Fractional a => [a] -> a
mean xs = sum xs / (fromIntegral $ length xs)
pitchShifterDelay :: MaxDelayTime -> (Feedback, Feedback) -> DelayTime -> Sig -> Sig -> Sig
pitchShifterDelay maxDelayTime (fb1, fb2) dlt ratio ain = P.pitchShifterDelay maxDelayTime (fb1, fb2) dlt ratio ain
fxAnalogDelay :: Balance -> DelayTime -> Feedback -> ToneSig -> Sig -> Sig
fxAnalogDelay kmix kdelay kfback ktone ain = P.fxAnalogDelay kmix kdelay kfback ktone ain
type DriveSig = Sig
fxDistortion :: DriveSig -> ToneSig -> Sig -> Sig
fxDistortion kdrive ktone ain = P.fxDistortion 1 kdrive ktone ain
type SensitivitySig = Sig
type BaseCps = Sig
type Resonance = Sig
fxFollower :: SensitivitySig -> BaseCps -> Resonance -> Sig -> Sig
fxFollower ksens kbaseFreq kreson = P.fxEnvelopeFollower ksens kbaseFreq (0.99 * kreson)
type TimeSig = Sig
fxReverse :: TimeSig -> Sig -> Sig
fxReverse ktime = P.fxReverse ktime
fxFlanger :: RateSig -> DepthSig -> DelayTime -> Feedback -> Sig -> Sig
fxFlanger krate kdepth kdelay kfback ain = P.fxFlanger krate kdepth kdelay kfback ain
fxPhaser :: RateSig -> DepthSig -> BaseCps -> Feedback -> Sig -> Sig
fxPhaser krate kdepth cps kfback ain = P.fxPhaser krate kdepth (6 + 5 * cps) kfback ain
type BitsReductionSig = Sig
type FoldoverSig = Sig
fxLoFi :: BitsReductionSig -> FoldoverSig -> Sig -> Sig
fxLoFi kbits kfold ain = P.fxLoFi (0.6 * kbits) kfold ain
fxChorus2 :: RateSig -> DepthSig -> WidthSig -> Sig2 -> Sig2
fxChorus2 krate kdepth kwidth ain = P.fxChorus2 krate kdepth kwidth ain
type TremWaveSig = Sig
fxAutoPan :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2
fxAutoPan tremWave kdepth krate = P.fxPanTrem kdepth krate 0 tremWave
fxTrem :: TremWaveSig -> DepthSig -> RateSig -> Sig2 -> Sig2
fxTrem tremWave kdepth krate = P.fxPanTrem kdepth krate 1 tremWave
type RatioSig = Sig
type FftSize = D
fxPitchShifter :: FftSize -> Balance -> RatioSig -> Feedback -> Sig -> Sig
fxPitchShifter ifftSize kmix ratio kfback = P.fxPitchShifter ifftSize kmix ratio kfback
fxFreqShifter :: Balance -> Sig -> Sig -> Feedback -> Sig -> Sig
fxFreqShifter kmix freq kmul kfback = P.fxFreqShifter kmix freq kmul kfback
fxCompress :: Sig -> (Sig, Sig) -> Sig -> (Sig, Sig) -> Sig -> Sig -> Sig
fxCompress thresh (loknee, hiknee) ratio (att, rel) gain x = gain' * compress x x thresh' loknee' hiknee' ratio' att' rel' 0.05
where
gain' = ampdb $ onLin (-36, 36) gain
thresh' = onLin (0, 120) thresh
att' = onExp (0, 1) att
rel' = onExp (0, 1) rel
ratio' = onExp (1, 30000) ratio
loknee' = onLin (0, 120) loknee
hiknee' = onLin (0, 120) hiknee
onLin (min, max) val = min + val * (max - min)
onExp (min, max) val = scale (expcurve val 4) max min
type EchoGain = Sig
type RandomSpreadSig = Sig
tapeEcho :: Int -> DelayTime -> Feedback -> EchoGain -> ToneSig -> RandomSpreadSig -> Sig -> SE Sig
tapeEcho n dt fb echoGain ktoneNorm spread ain = do
aDummy <- delayr minDt
aout <- fmap ((\echoes -> tone (ain + echoGain * echoes) ktone) . sum . zipWith (*) halves) $
mapM (\step -> tapeRead ain (dt * step) spread) doubles
tapeWrite ain aout fb
return aout
where
halves = take n $ iterate ( / 2) 1
doubles = take n $ iterate ( * 2) 1
minDt = int $ 16 `max` (n * 4)
ktone = fromNormTone ktoneNorm
fromNormTone :: Sig -> Sig
fromNormTone ktoneNorm = portk (scale (expcurve ktoneNorm 4) 12000 100) 0.1