module Csound.Air (
osc, oscBy, saw, isaw, pulse, sqr, tri, blosc,
unipolar, bipolar, on, uon, uosc, uoscBy, usaw, uisaw, upulse, usqr, utri, ublosc,
rndh, urndh, rndi, urndi, white, pink,
leg, xeg,
onIdur, lindur, expdur, linendur,
onDur, lindurBy, expdurBy, linendurBy,
once, onceBy, several,
oscLins, oscElins, oscExps, oscEexps, oscLine,
fadeIn, fadeOut, fades, expFadeIn, expFadeOut, expFades,
Lfo, lfo,
lp, hp, bp, br, alp,
blp, bhp, bbp, bbr,
mlp,
readSnd, loopSnd, loopSndBy,
readWav, loopWav,
readSnd1, loopSnd1, loopSndBy1,
readWav1, loopWav1,
lengthSnd, segments,
takeSnd, delaySnd, segmentSnd, repeatSnd, toMono,
toSpec, fromSpec, mapSpec, scaleSpec, addSpec, scalePitch,
mean, vibrate, randomPitch, chorusPitch, resons, resonsBy, modes, dryWet,
odds, evens,
AdsrBound(..), AdsrInit(..),
linAdsr, expAdsr,
classicWaves,
masterVolume, masterVolumeKnob,
reverbsc1, rever1, rever2, reverTime,
smallRoom, smallHall, largeHall, magicCave,
smallRoom2, smallHall2, largeHall2, magicCave2,
echo, fdelay, fvdelay, fvdelays, funDelays,
distortion,
chorus,
flange,
phase1, harmPhase, powerPhase
) where
import Data.List(intersperse, isSuffixOf)
import Data.Boolean
import Csound.Typed
import Csound.Typed.Opcode hiding (display, lfo)
import Csound.Typed.Gui
import Csound.Control.Gui(funnyRadio)
import Csound.Control.Evt(metroE, eventList)
import Csound.Control.Instr(withDur, sched)
import Csound.Tab(sine, sines4)
osc :: Sig -> Sig
osc cps = oscil3 1 cps sine
oscBy :: Tab -> Sig -> Sig
oscBy tb cps = oscil3 1 cps tb
unipolar :: Sig -> Sig
unipolar a = 0.5 + 0.5 * a
bipolar :: Sig -> Sig
bipolar a = 2 * a 1
uosc :: Sig -> Sig
uosc = unipolar . osc
uoscBy :: Tab -> Sig -> Sig
uoscBy tb = unipolar . oscBy tb
usaw :: Sig -> Sig
usaw = unipolar . saw
uisaw :: Sig -> Sig
uisaw = unipolar . isaw
usqr :: Sig -> Sig
usqr = unipolar . sqr
utri :: Sig -> Sig
utri = unipolar . tri
upulse :: Sig -> Sig
upulse = unipolar . pulse
ublosc :: Tab -> Sig -> Sig
ublosc tb = unipolar . blosc tb
on :: Sig -> Sig -> Sig -> Sig
on a b x = uon a b $ unipolar x
uon :: Sig -> Sig -> Sig -> Sig
uon a b x = a + (b a) * x
rndh :: Sig -> SE Sig
rndh = randh 1
rndi :: Sig -> SE Sig
rndi = randi 1
urndh :: Sig -> SE Sig
urndh = fmap unipolar . rndh
urndi :: Sig -> SE Sig
urndi = fmap unipolar . rndi
white :: SE Sig
white = noise 1 0
pink :: SE Sig
pink = pinkish 1
leg :: D -> D -> D -> D -> Sig
leg = madsr
xeg :: D -> D -> D -> D -> Sig
xeg a d s r = mxadsr a d (s + 0.00001) r
onIdur :: [D] -> [D]
onIdur = onDur idur
onDur :: D -> [D] -> [D]
onDur dur xs = case xs of
a:b:as -> a : b * dur : onDur dur as
_ -> xs
lindur :: [D] -> Sig
lindur = linseg . onIdur
expdur :: [D] -> Sig
expdur = expseg . onIdur
lindurBy :: D -> [D] -> Sig
lindurBy dt = linseg . onDur dt
expdurBy :: D -> [D] -> Sig
expdurBy dt = expseg . onDur dt
linendur :: Sig -> D -> D -> Sig
linendur = linendurBy idur
linendurBy :: D -> Sig -> D -> D -> Sig
linendurBy dt asig ris dec = linen asig (ris * dt) dt (dec * dt)
fadeIn :: D -> Sig
fadeIn att = linseg [0, att, 1]
fadeOut :: D -> Sig
fadeOut dec = linsegr [1] dec 0
expFadeIn :: D -> Sig
expFadeIn att = expseg [0.0001, att, 1]
expFadeOut :: D -> Sig
expFadeOut dec = expsegr [1] dec 0.0001
fades :: D -> D -> Sig
fades att dec = fadeIn att * fadeOut dec
expFades :: D -> D -> Sig
expFades att dec = expFadeIn att * expFadeOut dec
type Lfo = Sig
lfo :: (Sig -> Sig) -> Sig -> Sig -> Sig
lfo shape depth rate = depth * shape rate
lp :: Sig -> Sig -> Sig -> Sig
lp cf q a = bqrez a cf q
hp :: Sig -> Sig -> Sig -> Sig
hp cf q a = bqrez a cf q `withD` 1
bp :: Sig -> Sig -> Sig -> Sig
bp cf q a = bqrez a cf q `withD` 2
br :: Sig -> Sig -> Sig -> Sig
br cf q a = bqrez a cf q `withD` 3
alp :: Sig -> Sig -> Sig -> Sig
alp cf q a = bqrez a cf q `withD` 4
bhp :: Sig -> Sig -> Sig
bhp = flip buthp
blp :: Sig -> Sig -> Sig
blp = flip butlp
bbp :: Sig -> Sig -> Sig -> Sig
bbp freq band a = butbp a freq band
bbr :: Sig -> Sig -> Sig -> Sig
bbr freq band a = butbr a freq band
mlp :: Sig -> Sig -> Sig -> Sig
mlp cf q asig = moogladder asig cf q
takeSnd :: Sigs a => D -> a -> a
takeSnd dt asig = trigs (const $ return asig) $ eventList [(0, dt, unit)]
delaySnd :: Sigs a => D -> a -> a
delaySnd dt asig = trigs (const $ return asig) $ eventList [(dt, 1, unit)]
segmentSnd ::Sigs a => D -> D -> a -> a
segmentSnd del dur asig = trigs (const $ return asig) $ eventList [(del, dur, unit)]
repeatSnd :: Sigs a => D -> a -> a
repeatSnd dt asig = sched (const $ return asig) $ segments dt
isMp3 :: String -> Bool
isMp3 name = ".mp3" `isSuffixOf` name
toMono :: (Sig, Sig) -> Sig
toMono (a, b) = 0.5 * a + 0.5 * b
lengthSnd :: String -> D
lengthSnd fileName
| isMp3 fileName = mp3len $ text fileName
| otherwise = filelen $ text fileName
segments :: D -> Evt (D, Unit)
segments dt = withDur dt $ metroE (sig $ recip dt)
readSnd :: String -> (Sig, Sig)
readSnd fileName
| isMp3 fileName = mp3in (text fileName)
| otherwise = diskin2 (text fileName) 1
loopSndBy :: D -> String -> (Sig, Sig)
loopSndBy dt fileName = repeatSnd dt $ readSnd fileName
loopSnd :: String -> (Sig, Sig)
loopSnd fileName = loopSndBy (lengthSnd fileName) fileName
readWav :: Sig -> String -> (Sig, Sig)
readWav speed fileName = diskin2 (text fileName) speed
loopWav :: Sig -> String -> (Sig, Sig)
loopWav speed fileName = flip withDs [0, 1] $ ar2 $ diskin2 (text fileName) speed
readSnd1 :: String -> Sig
readSnd1 fileName
| isMp3 fileName = toMono $ readSnd fileName
| otherwise = diskin2 (text fileName) 1
loopSndBy1 :: D -> String -> Sig
loopSndBy1 dt fileName = repeatSnd dt $ readSnd1 fileName
loopSnd1 :: String -> Sig
loopSnd1 fileName = loopSndBy1 (lengthSnd fileName) fileName
readWav1 :: Sig -> String -> Sig
readWav1 speed fileName = diskin2 (text fileName) speed
loopWav1 :: Sig -> String -> Sig
loopWav1 speed fileName = flip withDs [0, 1] $ diskin2 (text fileName) speed
toSpec :: Sig -> Spec
toSpec asig = pvsanal asig 1024 256 1024 1
fromSpec :: Spec -> Sig
fromSpec = pvsynth
mapSpec :: (Spec -> Spec) -> Sig -> Sig
mapSpec f = fromSpec . f . toSpec
scaleSpec :: Sig -> Sig -> Sig
scaleSpec k = mapSpec $ \x -> pvscale x k
addSpec :: Sig -> Sig -> Sig
addSpec hz = mapSpec $ \x -> pvshift x hz 0
scalePitch :: Sig -> Sig -> Sig
scalePitch n = scaleSpec (semitone n)
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
oscLins :: [D] -> Sig -> Sig
oscLins points cps = loopseg cps 0 0 (fmap sig points)
oscElins :: [D] -> Sig -> Sig
oscElins points = oscLins (intersperse 1 points)
oscLine :: D -> D -> Sig -> Sig
oscLine a b cps = oscElins [a, b, a] (cps / 2)
oscExps :: [D] -> Sig -> Sig
oscExps points cps = looptseg cps 0 (fmap sig points)
oscEexps :: [D] -> Sig -> Sig
oscEexps points = oscExps (insertOnes points)
where insertOnes xs = case xs of
a:b:as -> a:1:b:insertOnes as
_ -> xs
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 .. n1]
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
reverbsc1 :: Sig -> Sig -> Sig -> Sig
reverbsc1 x k co = 0.5 * (a + b)
where (a, b) = ar2 $ reverbsc x x k co
data AdsrBound = AdsrBound
{ attBound :: Double
, decBound :: Double
, relBound :: Double }
data AdsrInit = AdsrInit
{ attInit :: Double
, decInit :: Double
, susInit :: Double
, relInit :: Double }
expEps :: Fractional a => a
expEps = 0.00001
linAdsr :: String -> AdsrBound -> AdsrInit -> Source Sig
linAdsr = genAdsr $ \a d s r -> linsegr [0, a, 1, d, s] r 0
expAdsr :: String -> AdsrBound -> AdsrInit -> Source Sig
expAdsr = genAdsr $ \a d s r -> expsegr [double expEps, a, 1, d, s] r (double expEps)
genAdsr :: (D -> D -> D -> D -> Sig)
-> String -> AdsrBound -> AdsrInit -> Source Sig
genAdsr mkAdsr name b inits = source $ do
(gatt, att) <- knob "A" (linSpan expEps $ attBound b) (attInit inits)
(gdec, dec) <- knob "D" (linSpan expEps $ decBound b) (decInit inits)
(gsus, sus) <- knob "S" (linSpan expEps 1) (susInit inits)
(grel, rel) <- knob "R" (linSpan expEps $ relBound b) (relInit inits)
let val = mkAdsr (ir att) (ir dec) (ir sus) (ir rel)
gui <- setTitle name $ hor [gatt, gdec, gsus, grel]
return (gui, val)
classicWaves :: String -> Int -> Source (Sig -> Sig)
classicWaves name initVal = funnyRadio name
[ ("osc", osc)
, ("tri", tri)
, ("sqr", sqr)
, ("saw", saw)]
initVal
masterVolume :: Source Sig
masterVolume = slider "master" uspan 0.5
masterVolumeKnob :: Source Sig
masterVolumeKnob = knob "master" uspan 0.5
reverTime :: Sig -> Sig -> Sig
reverTime dt a = nreverb a dt 0.3
rever1 :: Sig -> Sig -> (Sig, Sig)
rever1 fbk a = reverbsc a a fbk 12000
rever2 :: Sig -> Sig -> Sig -> (Sig, Sig)
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 :: Sig -> Sig -> (Sig, Sig)
smallRoom2 = rever2 0.6
smallHall2 :: Sig -> Sig -> (Sig, Sig)
smallHall2 = rever2 0.8
largeHall2 :: Sig -> Sig -> (Sig, Sig)
largeHall2 = rever2 0.9
magicCave2 :: Sig -> Sig -> (Sig, Sig)
magicCave2 = rever2 0.99
echo :: D -> Sig -> Sig -> SE Sig
echo len fb = fdelay len fb 1
fdelay :: D -> Sig -> Sig -> Sig -> SE Sig
fdelay len = fvdelay len (sig len)
fvdelay :: D -> Sig -> Sig -> Sig -> Sig -> SE Sig
fvdelay len dt fb mx a = do
_ <- delayr len
aDel <- deltap3 dt
delayw $ a + fb * aDel
return $ a + (aDel * mx)
fvdelays :: D -> [(Sig, Sig)] -> Sig -> Sig -> SE Sig
fvdelays len dtArgs mx a = funDelays len (zip dts fs) mx a
where
(dts, fbks) = unzip dtArgs
fs = map (*) fbks
funDelays :: D -> [(Sig, Sig -> Sig)] -> Sig -> 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
distortion :: Sig -> Sig -> Sig
distortion pre asig = distort1 asig pre 0.5 0 0 `withD` 1
chorus :: Sig -> Sig -> Sig -> 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 -> Sig -> Sig -> 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 -> Sig -> Sig -> Sig -> Sig
phase1 ord alfo fbk mx asig = ntrpol asig (phaser1 asig (20 + unipolar alfo) ord fbk) mx
harmPhase :: Sig -> Lfo -> Sig -> Sig -> Sig -> Sig -> 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 -> Sig -> Sig -> Sig -> Sig
powerPhase ord alfo q sep fbk mx asig = ntrpol asig (phaser2 asig (20 + unipolar alfo) q ord 2 sep fbk) mx