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, readSegWav,
tempoLoopWav, tempoReadWav,
readSnd1, loopSnd1, loopSndBy1,
readWav1, loopWav1, readSegWav1,
tempoLoopWav1, tempoReadWav1,
LoopMode(..), ramSnd, ramSnd1,
SampleFormat(..),
writeSigs, writeWav, writeAiff, writeWav1, writeAiff1,
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.Types(Sig2)
import Csound.Tab(sine, sines4, mp3s, wavs)
import Csound.SigSpace(mapSig)
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
readSegWav :: D -> D -> Sig -> String -> (Sig, Sig)
readSegWav start end speed fileName = takeSnd (end start) $ diskin2 (text fileName) speed `withDs` [start, 1]
tempoReadWav :: Sig -> String -> (Sig, Sig)
tempoReadWav speed fileName = mapSig (scaleSpec (1 / abs speed)) $ diskin2 (text fileName) speed
tempoLoopWav :: Sig -> String -> (Sig, Sig)
tempoLoopWav speed fileName = mapSig (scaleSpec (1 / abs speed)) $ 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
readSegWav1 :: D -> D -> Sig -> String -> Sig
readSegWav1 start end speed fileName = takeSnd (end start) $ diskin2 (text fileName) speed `withDs` [start, 1]
tempoReadWav1 :: Sig -> String -> Sig
tempoReadWav1 speed fileName = scaleSpec (1 / abs speed) $ readWav1 speed fileName
tempoLoopWav1 :: Sig -> String -> Sig
tempoLoopWav1 speed fileName = scaleSpec (1 / abs speed) $ loopWav1 speed fileName
data LoopMode = Once | Loop | Bounce
deriving (Show, Eq, Enum)
ramSnd :: LoopMode -> Sig -> String -> Sig2
ramSnd loopMode speed file = loscil3 1 speed t `withDs` [1, int $ fromEnum loopMode]
where t
| isMp3 file = mp3s file 0
| otherwise = wavs file 0 0
ramSnd1 :: LoopMode -> Sig -> String -> Sig
ramSnd1 loopMode speed file
| isMp3 file = (\(aleft, aright) -> 0.5 * (aleft + aright)) $ loscil3 1 speed (mp3s file 0) `withDs` [1, int $ fromEnum loopMode]
| otherwise = loscil3 1 speed (wavs file 0 1) `withDs` [1, int $ fromEnum loopMode]
data SampleFormat
= NoHeaderFloat32
| NoHeaderInt16
| HeaderInt16
| UlawSamples
| Int16
| Int32
| Float32
| Uint8
| Int24
| Float64
deriving (Eq, Ord, Enum)
writeSigs :: FormatType -> SampleFormat -> String -> [Sig] -> SE ()
writeSigs fmt sample file = fout (text file) formatToInt
where
formatToInt = int $ formatTypeToInt fmt * 10 + fromEnum sample
formatTypeToInt :: FormatType -> Int
formatTypeToInt x = case x of
Wav -> 1
Aiff -> 2
Raw -> 3
Ircam -> 4
_ -> error $ "Format " ++ (show x) ++ " is not supported in the writeSnd."
writeWav :: String -> (Sig, Sig) -> SE ()
writeWav file = writeSigs Wav Int16 file . \(a, b) -> [a, b]
writeAiff :: String -> (Sig, Sig) -> SE ()
writeAiff file = writeSigs Aiff Int16 file . \(a, b) -> [a, b]
writeWav1 :: String -> Sig -> SE ()
writeWav1 file = writeWav file . \x -> (x, x)
writeAiff1 :: String -> Sig -> SE ()
writeAiff1 file = writeAiff file . \x -> (x, x)
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 -> 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
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