module Csound.Catalog.Wave.Ac(
pulseWidth,
xanadu1, xanadu2, stringPad, toneWheel,
guitar, harpsichord, xing,
fmMod, filteredChorus, plainString, fmTubularBell,
delayedString, melody, rhodes,
) where
import Data.List
import Csound.Base
pulseWidth :: Sig -> Sig -> Sig
pulseWidth amp cps = asignal
where
ilforate = 2.3
isawlvl = 0.5
ipwmlvl = 0.5
ipwm = 0.2
ipwmlfo = 0.1
ivcffrq = 800
ienvflt = 200
ikbdflt = 0.1
klfo = kr $ osc ilforate
asaw = oscBy (elins [-1, 1]) cps
apwm = table (0.5 + asaw / 2 + (klfo * ipwmlfo + ipwm)) (lins [-1, 50, -1, 0, 1, 50, 1]) `withD` 1
awaves = isawlvl * asaw + ipwmlvl * apwm
asignal = amp * butlp awaves (ivcffrq + cps * ikbdflt + ienvflt * amp)
giwave :: Tab
giwave = sines [1, 0.5, 0.33, 0.25, 0.0, 0.1, 0.1, 0.1]
xanaduPlucks :: D -> D -> D -> (Sig, Sig, Sig)
xanaduPlucks cps vibrAmp vibrCps = (phi vib, phi shift, phi (-shift))
where phi asig = pluck 1 (cpsoct $ oct + asig) cps giwave 1
shift = 8/1200
vib = kr $ poscil (sig vibrAmp) (sig vibrCps) cosine
oct = sig $ octcps cps
xanadu1 :: D -> SE Sig
xanadu1 cps = do
_ <- delayr 2
~ [tap1, tap2, d1, d2] <- mapM deltap3 [f1, f2, 2, 1.1]
delayw $ g * damping
return $ damping * mean [gleft, tap1, d1, gright, tap2, d2]
where (g, gleft, gright) = xanaduPlucks cps (1/120) (cps/50)
f1 = expseg [0.01, 10, 1]
f2 = expseg [0.015, 15, 1.055]
damping = 1
xanadu2 :: D -> SE Sig
xanadu2 cps = do
_ <- delayr 0.4
~ [d1, d2] <- mapM deltap3 [0.07, 0.105]
delayw $ g * damping
return $ damping * mean [d1, gleft, d2, gright]
where (g, gleft, gright) = xanaduPlucks cps (1/80) 6.1
damping = 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
toneWheel :: D -> Sig
toneWheel cps = asignal
where
ikey = 12 * int' (cps - 6) + 100 * (cps - 6)
wheels =
[ ifB (ikey - 12 >* 12) gitonewheel1 gitonewheel2
, ifB (ikey + 7 >* 12) gitonewheel1 gitonewheel2
, ifB (ikey >* 12) gitonewheel1 gitonewheel2
, sine ]
iphase = 0.5
harm w fqc tabId phs = poscil (sig w) (sig $ fqc * cps) (wheels !! tabId) `withD` (iphase / (ikey - phs))
asignal = ( / 9) $ mean $ zipWith4 harm
[8, 8, 8, 8, 3, 2, 1, 0, 4]
[0.5, 1.4983, 1, 2, 2.9966, 4, 5.0397, 5.9932, 8]
([0, 1, 2, 3] ++ repeat 3)
[-12, 7, 0, 12, 19, 24, 28, 31, 36]
gitonewheel1 = sines [1, 0.02, 0.01]
gitonewheel2 = sines [1, 0, 0.2, 0, 0.1, 0, 0.05, 0, 0.02]
guitar :: D -> Sig
guitar cps = asignal
where
asigcomp = pluck 1 440 440 def 1
asig = pluck 1 (sig cps) cps def 1
af x cf wid = x * reson asig cf wid
asignal = balance (0.4 * asig + sum [af 0.6 110 80, af 1 220 100, af 0.6 440 80]) asigcomp
harpsichord :: D -> Sig
harpsichord cps = 0.5 * asignal
where
aenvelope = ar $ transeg [1, 10, -5.0, 0]
apluck = pluck 1 (sig cps) cps def 1
aharp = poscil aenvelope (sig cps) (lins [-1, 1024, 1, 1024, -1])
asignal = apluck + balance apluck aharp
xing :: D -> Sig -> Sig
xing xdur cps = asignal
where
amps xs dt vib freq phs = ar (loopseg xs (sig $ 1/xdur)) * (1 + poscil vibEnv freq sine `withD` phs)
where vibEnv = ar $ loopseg [0, dt, vib, sig xdur - dt, 0] (sig $ 1/xdur)
f vol freq = poscil vol (sig freq * cps) sine
norm = 32310
asignal = (sig $ 1 / norm) * sum
[ f (amps env1 0.05 0.3 6.7 0.8) 1
, f (amps env2 0.12 0.5 10.5 0 ) 2.7
, f (amps env3 0.02 0.8 70 0 ) 4.95
]
env1 = [ 0,0.001,5200,0.001,800,0.001,3000,0.0025,1100,0.002
, 2800,0.0015,1500,0.001,2100,0.011,1600,0.03,1400,0.95
, 700,1,320,1,180,1,90,1,40,1,20,1,12,1,6,1,3,1,0,1,0]
env2 = [ 0,0.0009,22000,0.0005,7300,0.0009,11000,0.0004,5500
, 0.0006,15000,0.0004,5500,0.0008,2200,0.055,7300,0.02
, 8500,0.38,5000,0.5,300,0.5,73,0.5,5,5,0,1,1]
env3 = [ 0,0.001,3000,0.001,1000,0.0017,12000,0.0013
, 3700,0.001,12500,0.0018,3000,0.0012,1200,0.001
, 1400,0.0017,6000,0.0023,200,0.001,3000,0.001,1200
, 0.0015,8000,0.001,1800,0.0015,6000,0.08,1200,0.2
, 200,0.2,40,0.2,10,0.4,0,1,0]
fmMod :: D -> Sig -> Sig
fmMod xdur cps = asignal
where
iattack = 0.25
irelease = 0.3333
ip6 = 0.3
ip7 = 2.2
ishift = 4 / 12000
ipch = cps
ioct = octcps cps
amodi = ar $ loopseg [0, iattack, 5, sig xdur, 2, irelease, 0] (sig $ 1 / xdur)
amodr = ar $ loopseg [ip6, 1, ip7, 1, ip6] (sig $ 0.5 / xdur)
a1 = amodi * (amodr - 1 / amodr) / 2
a2 = amodi * (amodr + 1 / amodr) / 2
a1ndx = abs $ a1 / 10
a3 = tablei a1ndx (skipNorm $ bessels 20) `withD` 1
ao1 = poscil a1 ipch cosine
a4 = exp $ -0.5 * a3 + ao1
ao2 = poscil (a2 * ipch) cps cosine
aleft = poscil a4 (ao2 + cpsoct (ioct + ishift)) sine
aright = poscil a4 (ao2 + cpsoct (ioct - ishift)) sine
asignal = 0.5 * (aleft + aright)
filteredChorus :: D -> Sig -> Sig
filteredChorus xdur cps = asignal
where
a ~~ b = loopseg [sig a, 1, sig b, 1, sig a] (sig $ 1 / (xdur * 2))
filt cf1 bw1 cf2 bw2 x = balance (bp cf2 bw2 $ bp cf1 bw1 x) x
harm fqc = poscil ((sig $ idb)) fqc $ sines
[ 0.28, 1, 0.74, 0.66, 0.78, 0.48, 0.05, 0.33, 0.12
, 0.08, 0.01, 0.54, 0.19, 0.08, 0.05, 0.16, 0.01, 0.11, 0.3, 0.02, 0.2]
a1s x = mean $ fmap (harm . (* cpsoct (octcps cps + x))) [1, 0.999, 1.001]
rvb dt dh x = 0.5 * (x + reverb2 x dt dh)
idb = 1.5
asignal = mean
[ rvb 5 0.3 $ filt (40 ~~ 800) 40 (220 ~~ 440) ((440 ~~ 220) * 0.8) $ a1s (-0.01)
, rvb 4 0.2 $ filt (800 ~~ 40) 40 (440 ~~ 220) ((220 ~~ 440) * 0.8) $ a1s 0.01
]
plainString :: D -> Sig
plainString cps = wgpluck2 0.1 1.0 cps 0.25 0.05
rhodes :: Sig -> Sig
rhodes cps = asignal
where
iindex = 4.1
icrossfade = 3.1
ivibedepth = 0.2
iviberate = 6
ifn1 = sine
ifn2 = cosine
ifn3 = sine
ifn4 = sines [0]
ivibefn = sine
asignal = fmrhode 1 cps iindex icrossfade ivibedepth iviberate ifn1 ifn2 ifn3 ifn4 ivibefn
fmTubularBell :: Sig -> Sig
fmTubularBell cps = asignal
where
iindex = 1.5
icrossfade = 2.03
ivibedepth = 0.2
iviberate = 6
ifn1 = sine
ifn2 = sines [1, 0.4, 0.2, 0.1, 0.1, 0.05]
ifn3 = sine
ifn4 = sine
ivibefn = cosine
asignal = fmbell 1 cps iindex icrossfade ivibedepth iviberate `withTabs` [ifn1, ifn2, ifn3, ifn4, ivibefn]
delayedString :: D -> Sig
delayedString cps = asignal
where
ioctave = octcps cps
idetune = 4 / 1200
kvibrato = poscil (1 / 120) 7 sine
awave det fn = pluck 1 (cpsoct $ sig ioctave + det) cps fn 1
ag = awave kvibrato sine
agleft = awave idetune sine
agright = awave (- idetune) cosine
imsleft = 0.2 * 1000
imsright = 0.21 * 1000
noclick x = linseg [0, 0.1, x, 1, x]
adelayleft = vdelay ag (noclick imsleft) (imsleft + 100)
adelayright = vdelay ag (noclick imsright) (imsright + 100)
asignal = mean [agleft, adelayleft, agright, adelayright]
melody :: D -> Sig -> SE Sig
melody xdur cps = do
k1000 <- randi 1 10
let k100 = cps + loopseg [0, 0.5, 1, sig xdur, 1] (sig $ 1/xdur) * poscil 1 (5 + k1000) sine
a1 = poscil k1 k100 (sines [1, 0.4, 0.2, 0.1, 0.1, 0.05])
a2 = tablei a1 ip6 `withDs` [1, 0.5]
a3 = balance a2 a1
a4 = foscil 1 (k100 + 0.04) 1 2.005 k20 sine
a5 = poscil 1 k100 sine
a6 = a3 * 0.1 + a4 * 0.1 + a5 * 0.8
a7 = comb a6 0.5 (1 / ir cps)
a8 = a6 * 0.9 + a7 * 0.1
asignal = balance a8 a1
return asignal
where
iattack = 0.05
isustain = xdur
irelease = 0.1
ip6 = skipNorm $ lins [-1, 150, 0.1, 110, 0, 252, 0]
k1 = linseg [1, xdur, 0.5] * linenr 0.5 (xdur * 0.3) (xdur * 0.2) 0.01
k20 = linseg [1.485, iattack, 1.5, isustain + irelease, 1.485]