{-# Language FlexibleContexts #-}
module Csound.Air.Misc(
mean, vibrate, randomPitch, chorusPitch, resons, resonsBy, modes, dryWet,
once, onceBy, several, fromMono,
odds, evens,
rndPan, rndPan2, rndVol, gaussVol,
selector,
writeHifi,
arpeggi, arpBy,
lpJoy,
delaySig, delay1k,
wshaper, genSaturator, saturator, mildSaturator, hardSaturator, hardSaturator2,
funSeq, funPar,
ticks, nticks,
ticks2, nticks2,
ticks3, nticks3,
ticks4, nticks4,
testDrone, testDrone2, testDrone3, testDrone4
) where
import Control.Monad
import Data.Boolean
import Data.Default
import Csound.Dynamic hiding (int)
import Csound.Typed
import Csound.Typed.Opcode hiding (metro)
import Csound.Control.Gui
import Csound.Control.Evt
import Csound.Control.Instr
import Csound.Tab
import Csound.Air.Wave
import Csound.Air.Patch
import Csound.Air.Envelope
import Csound.Air.Filter
import Csound.SigSpace
import Csound.IO(writeSndBy)
import Csound.Options(setRates)
import Csound.Typed.Plugins(delay1k)
odds :: [a] -> [a]
odds as = fmap snd $ filter fst $ zip (cycle [True, False]) as
evens :: [a] -> [a]
evens as
| null as = []
| otherwise = odds $ tail as
once :: Tab -> Sig
once = onceBy idur
onceBy :: D -> Tab -> Sig
onceBy dt tb = kr $ oscBy tb (1 / sig dt)
several :: Tab -> Sig -> Sig
several tb rate = kr $ oscil3 1 (rate / sig idur) tb
mean :: Fractional a => [a] -> a
mean xs = sum xs / (fromIntegral $ length xs)
vibrate :: Sig -> Sig -> (Sig -> a) -> (Sig -> a)
vibrate vibDepth vibRate f cps = f (cps * (1 + kvib))
where kvib = vibDepth * kr (osc vibRate)
randomPitch :: Sig -> Sig -> (Sig -> a) -> (Sig -> SE a)
randomPitch rndAmp rndCps f cps = fmap go $ randh (cps * rndAmp) rndCps
where go krand = f (cps + krand)
chorusPitch :: Int -> Sig -> (Sig -> Sig) -> Sig -> Sig
chorusPitch n wid = phi dts
where
phi :: [Sig] -> (Sig -> Sig) -> Sig -> Sig
phi ks f = \cps -> mean $ fmap (f . (+ cps)) ks
dts = fmap (\x -> - wid + fromIntegral x * dt) [0 .. n-1]
dt = 2 * wid / fromIntegral n
resons :: [(Sig, Sig)] -> Sig -> Sig
resons = resonsBy bp
resonsBy :: (cps -> bw -> Sig -> Sig) -> [(cps, bw)] -> Sig -> Sig
resonsBy filt ps asig = mean $ fmap (( $ asig) . uncurry filt) ps
dryWet :: Sig -> (Sig -> Sig) -> Sig -> Sig
dryWet k ef asig = k * asig + (1 - k) * ef asig
modes :: [(Sig, Sig)] -> Sig -> Sig -> Sig
modes = relResonsBy (\cf q asig -> mode asig cf q)
relResonsBy :: (Sig -> a -> Sig -> Sig) -> [(Sig, a)] -> Sig -> Sig -> Sig
relResonsBy resonator ms baseCps apulse = (recip normFactor * ) $ sum $ fmap (\(cf, q) -> harm cf q apulse) ms
where
gate :: Sig -> Sig
gate cps = ifB (sig getSampleRate >* pi * cps) 1 0
normFactor = sum $ fmap (gate . (* baseCps) . fst) ms
harm cf q x = g * resonator (1 - g + g * cps) q x
where cps = cf * baseCps
g = gate cps
fromMono :: Sig -> (Sig, Sig)
fromMono a = (a, a)
rndPan2 :: Sig2 -> SE Sig2
rndPan2 (a, b) = rndPan $ mean [a, b]
rndPan :: Sig -> SE Sig2
rndPan a = do
fmap (pan2 a . sig) (rnd (1 :: D))
gaussVol :: SigSpace a => D -> a -> SE a
gaussVol k a = do
level <- fmap ir $ gauss (sig k)
return $ mul (sig $ level + 1) a
rndVol :: SigSpace a => (D, D) -> a -> SE a
rndVol (kMin, kMax) a = do
level <- rnd (1 :: D)
return $ mul (sig $ kMin + (kMax - kMin) * level) a
writeHifi :: D -> String -> SE Sig2 -> IO ()
writeHifi n fileName a = writeSndBy (setRates 48000 10) fileName $ fmap (setDur $ n) a
selector :: (Num a, SigSpace a) => [a] -> Sig -> a
selector as k = sum $ zipWith choice [0..] as
where choice n a = mul (port (ifB (sig (int n) ==* k) 1 0) 0.02) a
arpeggi :: SigSpace a => [Sig] -> [Sig] -> (Sig -> a) -> Sig -> a
arpeggi = arpBy triSeq sqrSeq
arpBy :: SigSpace a => ([Sig] -> Sig -> Sig) -> ([Sig] -> Sig -> Sig) -> [Sig] -> [Sig] -> (Sig -> a) -> Sig -> a
arpBy ampWave cpsWave amps cpss wave dt = mul (ampWave amps dt) $ wave $ cpsWave cpss dt
lpJoy :: Source (Sig -> Sig)
lpJoy = lift1 (\(cps, res) -> mlp cps res) $ joy (expSpan 100 17000) (linSpan 0.05 0.95) (1400, 0.5)
funSeq :: [a -> a] -> a -> a
funSeq = foldl (.) id
funPar :: Num a => [a -> a] -> a -> a
funPar fs a = sum $ fmap ($ a) fs
delaySig :: D -> Sig -> Sig
delaySig nsamples asig = delay asig nsamples
data TrSpec = TrSpec {
trDur :: D
, trTune :: D
, trCps :: D
, trRnd :: Maybe D
}
rndAmp :: Sig -> SE Sig
rndAmp a = do
k <- birnd 0.09
return $ a * (1 + sig k)
rndVal :: D -> D -> D -> SE D
rndVal total amount x = do
k <- birnd amount
return $ x + k * total
rndDur amt x = rndVal x amt x
rndCps amt x = rndVal x (amt / 10) x
rndTune amt x = rndVal 0.7 amt x
rndSpec ::TrSpec -> SE TrSpec
rndSpec spec = do
dur <- rndDur'
tune <- rndTune'
cps <- rndCps'
return $ spec
{ trDur = dur
, trTune = tune
, trCps = cps }
where
rndDur' = (maybe return rndDur $ (trRnd spec)) $ trDur spec
rndTune' = (maybe return rndTune $ (trRnd spec)) $ trTune spec
rndCps' = (maybe return rndCps $ (trRnd spec)) $ trCps spec
addDur' dt x = xtratim dt >> return x
addDur = addDur' 0.1
getAccent :: Int -> [D]
getAccent n = 1 : replicate (n - 1) 0.5
nticks :: [Int] -> Sig -> Sig
nticks = nticks' rimShot'
nticks2 :: [Int] -> Sig -> Sig
nticks2 = nticks' claves'
nticks3 :: [Int] -> Sig -> Sig
nticks3 = nticks' maraca'
nticks4 :: [Int] -> Sig -> Sig
nticks4 = nticks' highConga'
nticks' :: (TrSpec -> SE Sig) -> [Int] -> Sig -> Sig
nticks' drum ns = genTicks drum (cycleE $ ns >>= getAccent)
ticks :: Int -> Sig -> Sig
ticks = ticks' rimShot'
ticks2 :: Int -> Sig -> Sig
ticks2 = ticks' claves'
ticks3 :: Int -> Sig -> Sig
ticks3 = ticks' maraca'
ticks4 :: Int -> Sig -> Sig
ticks4 = ticks' highConga'
ticks' :: (TrSpec -> SE Sig) -> Int -> Sig -> Sig
ticks' drum n
| n <= 1 = genTicks drum (devt 0.5)
| otherwise = genTicks drum (cycleE $ getAccent n)
genTicks :: (TrSpec -> SE Sig) -> (Tick -> Evt D) -> Sig -> Sig
genTicks drum f x = mul 3 $ mlp 4000 0.1 $
sched (\amp -> mul (sig amp) $ drum (TrSpec (amp + 1) 0 (1200 * (amp + 0.5)) (Just 0.05))) $
withDur 0.5 $ f $ metro (x / 60)
rimShot' spec = pureRimShot' =<< rndSpec spec
pureRimShot' :: TrSpec -> SE Sig
pureRimShot' spec = rndAmp =<< addDur =<< (mul 0.8 $ aring + anoise)
where
dur = trDur spec
tune = trTune spec
cps = trCps spec
fullDur = 0.027 * dur
aenv1 = expsega [1,fullDur,0.001]
ifrq1 = sig $ cps * octave tune
aring = mul (0.5 * (aenv1 - 0.001)) $ at (bbp ifrq1 (ifrq1 * 8)) $ rndOscBy tabTR808RimShot ifrq1
aenv2 = expsega [1, 0.002, 0.8, 0.005, 0.5, fullDur-0.002-0.005, 0.0001]
kcf = expsegr [4000, fullDur, 20] fullDur 20
anoise = mul (aenv2 - 0.001) $ fmap (blp kcf) $ noise 1 0
tabTR808RimShot = setSize 1024 $ sines [0.971,0.269,0.041,0.054,0.011,0.013,0.08,0.0065,0.005,0.004,0.003,0.003,0.002,0.002,0.002,0.002,0.002,0.001,0.001,0.001,0.001,0.001,0.002,0.001,0.001]
claves' :: TrSpec -> SE Sig
claves' spec = rndAmp =<< addDur =<< asig
where
dur = trDur spec
tune = trTune spec
cps = trCps spec
ifrq = cps * octave tune
dt = 0.045 * dur
aenv = expsega [1, dt, 0.001]
afmod = expsega [3,0.00005,1]
asig = mul (- 0.4 * (aenv-0.001)) $ rndOsc (sig ifrq * afmod)
highConga' :: TrSpec -> SE Sig
highConga' = genConga 0.22
genConga :: D -> TrSpec -> SE Sig
genConga dt spec = rndAmp =<< addDur =<< asig
where
dur = trDur spec
tune = trTune spec
cps = trCps spec
ifrq = cps * octave tune
fullDur = dt * dur
aenv = transeg [0.7,1/ifrq,1,1,fullDur,-6,0.001]
afmod = expsega [3,0.25/ifrq,1]
asig = mul (-0.25 * aenv) $ rndOsc (sig ifrq * afmod)
maraca' :: TrSpec -> SE Sig
maraca' spec = rndAmp =<< addDur =<< anoise
where
dur = trDur spec
tune = trTune spec
cps = trCps spec
fullDur = 0.07* dur
otune = sig $ octave tune
iHPF = limit (6000 * otune) 20 (sig getSampleRate / 2)
iLPF = limit (12000 * otune) 20 (sig getSampleRate / 3)
aenv = expsega [0.4,0.014* dur,1,0.01 * dur, 0.05, 0.05 * dur, 0.001]
anoise = mul aenv $ fmap (blp iLPF . bhp iHPF) $ noise 0.75 0
testDrone cps = atNote (deepPad razorPad) (0.8, cps)
testDrone2 cps = atNote (deepPad nightPad) (0.8, cps)
testDrone3 cps = atNote (deepPad caveOvertonePad) (0.8, cps)
testDrone4 cps = atNote (deepPad pwEnsemble) (0.8, cps)
pwEnsemble = withSmallHall $ polySynt $ at fromMono . mul 0.55 . onCps impPwEnsemble
nightPad = withLargeHall $ polySynt $ mul 0.48 . at fromMono . onCps (mul (fadeOut 1) . impNightPad 0.5)
data RazorPad = RazorPad { razorPadSpeed :: Sig }
instance Default RazorPad where
def = RazorPad 0.5
razorPad = razorPad' def
razorPad' (RazorPad speed) = withLargeHall' 0.35 $ polySynt $ at fromMono . mul 0.6 . onCps (uncurry $ impRazorPad speed)
overtonePad = withLargeHall' 0.35 $ polySynt overtoneInstr
overtoneInstr :: CsdNote D -> SE Sig2
overtoneInstr = mul 0.65 . at fromMono . mixAt 0.25 (mlp 1500 0.1) . onCps (\cps -> mul (fades 0.25 1.2) (tibetan 11 0.012 cps) + mul (fades 0.25 1) (tibetan 13 0.015 (cps * 0.5)))
caveOvertonePad = FxChain (fx1 0.2 (magicCave2 . mul 0.8)) $ polySynt overtoneInstr
impPwEnsemble :: Sig -> SE Sig
impPwEnsemble x = mul 0.3 $ at (mlp (3500 + x * 2) 0.1) $ mul (leg 0.5 0 1 1) $ sum
[ f 0.2 0.11 2 (x * cent (-6))
, f 0.8 (-0.1) 1.8 (x * cent 6)
, f 0.2 0.11 2 (x * 0.5) ]
where f a b c = rndPw (a + b * tri c)
tibetan :: Int -> Sig -> D -> Sig
tibetan n off cps = chorusPitch n (2 * off * fromIntegral n) (oscBy wave) (sig cps)
where wave = ifB (cps `lessThan` 230) (waveBy 5) (ifB (cps `lessThan` 350) (waveBy 3) (waveBy 1))
waveBy x = sines $ [0.3, 0, 0, 0] ++ replicate x 0.1
impRazorPad speed amp cps = f cps + 0.75 * f (cps * 0.5)
where f cps = mul (leg 0.5 0 1 1) $ genRazor (filt 1 mlp) speed amp cps
genRazor filter speed amp cps = mul amp $ do
a1 <- ampSpline 0.01
a2 <- ampSpline 0.02
return $ filter (1000 + 2 * cps + 500 * amp) 0.1 $ mean [
fosc 1 3 (a1 * uosc (speed)) cps
, fosc 3 1 (a2 * uosc (speed + 0.2)) cps
, fosc 1 7 (a1 * uosc (speed - 0.15)) cps ]
where ampSpline c = rspline ( amp) (3.5 + amp) ((speed / 4) * (c - 0.1)) ((speed / 4) * (c + 0.1))
impNightPad :: D -> Sig -> Sig
impNightPad dt = (fadeIn dt * ) . stringPad 1
stringPad :: Sig -> Sig -> Sig
stringPad amp cps = blp (900 + amp * 300) $ chorusPitch 3 0.1 f cps
where f x = poscil 1 x giwave
giwave :: Tab
giwave = sines [1, 0.5, 0.33, 0.25, 0.0, 0.1, 0.1, 0.1]
fx1 :: Sig -> (a -> a) -> [GenFxSpec a]
fx1 dw f = [return $ FxSpec dw (return . f)]
magicCave2 :: Sig2 -> Sig2
magicCave2 = rever2 0.99
smallHall2 :: Sig2 -> Sig2
smallHall2 = rever2 0.8
largeHall2 :: Sig2 -> Sig2
largeHall2 = rever2 0.9
rever2 :: Feedback -> Sig2 -> Sig2
rever2 fbk (a1, a2) = (a1 + wa1, a2 + wa2)
where (wa1, wa2) = reverbsc a1 a2 fbk 12000
type Feedback = Sig
wshaper :: Tab -> Sig -> Sig -> Sig
wshaper t amt asig = tablei (10 * amt * asig / 20) t `withDs` [1, 0.5]
genSaturator :: Double -> Sig -> Sig -> Sig
genSaturator rad amt = wshaper (tanhSigmoid rad) amt
mildSaturator :: Sig -> Sig -> Sig
mildSaturator = genSaturator 1
saturator :: Sig -> Sig -> Sig
saturator = genSaturator 1.5
hardSaturator :: Sig -> Sig -> Sig
hardSaturator = genSaturator 3.5
hardSaturator2 :: Sig -> Sig -> Sig
hardSaturator2 = genSaturator 6.5