module Sound.SC3.UGen.Bindings.Composite where
import Control.Monad
import Data.List
import Data.List.Split
import Data.Maybe
import Sound.SC3.Common.Envelope
import Sound.SC3.UGen.Bindings.DB
import Sound.SC3.UGen.Bindings.HW
import Sound.SC3.UGen.Bindings.Monad
import Sound.SC3.UGen.Enum
import Sound.SC3.UGen.Identifier
import Sound.SC3.UGen.Math
import Sound.SC3.UGen.Rate
import Sound.SC3.UGen.Type
import Sound.SC3.UGen.UGen
import Sound.SC3.UGen.UId
asLocalBuf :: ID i => i -> [UGen] -> UGen
asLocalBuf i xs =
let b = localBuf i 1 (fromIntegral (length xs))
s = setBuf' b xs 0
in mrg2 b s
bLowPassCoef :: Floating a => a -> a -> a -> (a,a,a,a,a)
bLowPassCoef sr freq rq =
let w0 = pi * 2 * freq * (1 / sr)
cos_w0 = cos w0
i = 1 cos_w0
alpha = sin w0 * 0.5 * rq
b0rz = recip (1 + alpha)
a0 = i * 0.5 * b0rz
a1 = i * b0rz
b1 = cos_w0 * 2 * b0rz
b2 = (1 alpha) * negate b0rz
in (a0,a1,a0,b1,b2)
bufRdN :: Int -> Rate -> UGen -> UGen -> Loop -> UGen
bufRdN n r b p l = bufRd n r b p l NoInterpolation
bufRdL :: Int -> Rate -> UGen -> UGen -> Loop -> UGen
bufRdL n r b p l = bufRd n r b p l LinearInterpolation
bufRdC :: Int -> Rate -> UGen -> UGen -> Loop -> UGen
bufRdC n r b p l = bufRd n r b p l CubicInterpolation
changed :: UGen -> UGen -> UGen
changed input threshold = abs (hpz1 input) >* threshold
choose :: ID m => m -> UGen -> UGen
choose e = lchoose e . mceChannels
chooseM :: UId m => UGen -> m UGen
chooseM = liftUId choose
clearLocalBuf :: ID a => a -> UGen -> UGen -> UGen
clearLocalBuf z nc nf = clearBuf (localBuf z nc nf)
dcons :: ID m => (m,m,m) -> UGen -> UGen -> UGen
dcons (z0,z1,z2) x xs =
let i = dseq z0 1 (mce2 0 1)
a = dseq z1 1 (mce2 x xs)
in dswitch z2 i a
dconsM :: (UId m) => UGen -> UGen -> m UGen
dconsM x xs = do
i <- dseqM 1 (mce2 0 1)
a <- dseqM 1 (mce2 x xs)
dswitchM i a
dynKlang :: Rate -> UGen -> UGen -> UGen -> UGen
dynKlang r fs fo s =
let gen (f:a:ph:xs) = sinOsc r (f * fs + fo) ph * a + gen xs
gen _ = 0
in gen (mceChannels s)
dynKlank :: UGen -> UGen -> UGen -> UGen -> UGen -> UGen
dynKlank i fs fo ds s =
let gen (f:a:d:xs) = ringz i (f * fs + fo) (d * ds) * a + gen xs
gen _ = 0
in gen (mceChannels s)
fft' :: UGen -> UGen -> UGen
fft' buf i = fft buf i 0.5 0 1 0
ffta :: ID i => i -> UGen -> UGen -> UGen -> UGen -> UGen -> UGen -> UGen
ffta z nf i h wt a ws =
let b = localBuf z 1 nf
in fft b i h wt a ws
firstPrivateBus :: UGen
firstPrivateBus = numInputBuses + numOutputBuses
freqShift_hilbert :: UGen -> UGen -> UGen -> UGen
freqShift_hilbert i f p =
let o = sinOsc AR f (mce [p + 0.5 * pi, p])
h = hilbert i
in mix (h * o)
ifft' :: UGen -> UGen
ifft' buf = ifft buf 0 0
klanx_spec_f :: (a -> [b]) -> ([b] -> c) -> a -> a -> a -> c
klanx_spec_f f g fr am z = g ((concat . transpose) [f fr,f am,f z])
klangSpec :: [UGen] -> [UGen] -> [UGen] -> UGen
klangSpec = klanx_spec_f id mce
klangSpec' :: Real n => [n] -> [n] -> [n] -> UGen
klangSpec' = klanx_spec_f (map constant) mce
klangSpec_mce :: UGen -> UGen -> UGen -> UGen
klangSpec_mce = klanx_spec_f mceChannels mce
klankSpec :: [UGen] -> [UGen] -> [UGen] -> UGen
klankSpec = klanx_spec_f id mce
klankSpec' :: Real n => [n] -> [n] -> [n] -> UGen
klankSpec' = klanx_spec_f (map constant) mce
klankSpec_mce :: UGen -> UGen -> UGen -> UGen
klankSpec_mce = klanx_spec_f mceChannels mce
lchoose :: ID m => m -> [UGen] -> UGen
lchoose e a = select (iRand e 0 (fromIntegral (length a))) (mce a)
lchooseM :: UId m => [UGen] -> m UGen
lchooseM = liftUId lchoose
linExp_b :: UGen -> UGen -> UGen -> UGen
linExp_b i = linExp i (1) 1
linExp_u :: UGen -> UGen -> UGen -> UGen
linExp_u i = linExp i 0 1
linLin :: UGen -> UGen -> UGen -> UGen -> UGen -> UGen
linLin = linlin_ma
linLin_u :: UGen -> UGen -> UGen -> UGen
linLin_u i = linLin i 0 1
linLin_b :: UGen -> UGen -> UGen -> UGen
linLin_b i = linLin i (1) 1
localIn' :: Int -> Rate -> UGen
localIn' nc r = localIn nc r (mce (replicate nc 0))
makeFadeEnv :: Double -> UGen
makeFadeEnv fadeTime =
let dt = control KR "fadeTime" (realToFrac fadeTime)
gate_ = control KR "gate" 1
startVal = dt <=* 0
env = Envelope [startVal,1,0] [1,1] [EnvLin,EnvLin] (Just 1) Nothing
in envGen KR gate_ 1 0 dt RemoveSynth env
mceN :: UGen -> UGen
mceN = constant . length . mceChannels
mix :: UGen -> UGen
mix = sum_opt . mceChannels
mixN :: Int -> UGen -> UGen
mixN n u =
let xs = transpose (chunksOf n (mceChannels u))
in mce (map sum xs)
mixFill :: Integral n => Int -> (n -> UGen) -> UGen
mixFill n f = mix (mce (map f [0 .. fromIntegral n 1]))
mixFillM :: (Integral n,Monad m) => Int -> (n -> m UGen) -> m UGen
mixFillM n f = liftM sum (mapM f [0 .. fromIntegral n 1])
mouseButton' :: Rate -> UGen -> UGen -> UGen -> UGen
mouseButton' rt l r tm =
let o = lfClipNoise 'z' rt 1
in lag (linLin o (1) 1 l r) tm
mouseR :: ID a => a -> Rate -> UGen -> UGen -> Warp -> UGen -> UGen
mouseR z rt l r ty tm =
let f = case ty of
Linear -> linLin
Exponential -> linExp
_ -> undefined
in lag (f (lfNoise1 z rt 1) (1) 1 l r) tm
mouseX' :: Rate -> UGen -> UGen -> Warp -> UGen -> UGen
mouseX' = mouseR 'x'
mouseY' :: Rate -> UGen -> UGen -> Warp -> UGen -> UGen
mouseY' = mouseR 'y'
onsetType :: Num a => String -> a
onsetType s =
let t = ["power", "magsum", "complex", "rcomplex", "phase", "wphase", "mkl"]
in fromIntegral (fromMaybe 3 (elemIndex s t))
onsets' :: UGen -> UGen -> UGen -> UGen
onsets' c t o = onsets c t o 1 0.1 10 11 1 0
packFFTSpec :: [UGen] -> [UGen] -> UGen
packFFTSpec m p =
let interleave x = concat . zipWith (\a b -> [a,b]) x
in mce (interleave m p)
pc_calcAccumSize :: Int -> Int -> Int
pc_calcAccumSize fft_size ir_length =
let partition_size = fft_size `div` 2
num_partitions = (ir_length `div` partition_size) + 1
in fft_size * num_partitions
pmOsc :: Rate -> UGen -> UGen -> UGen -> UGen -> UGen
pmOsc r cf mf pm mp = sinOsc r cf (sinOsc r mf mp * pm)
poll' :: UGen -> UGen -> UGen -> UGen -> UGen
poll' t i l tr =
let t' = if isConstant t then impulse KR t 0 else t
in mrg [i,poll t' i l tr]
privateIn :: Int -> Rate -> UGen -> UGen
privateIn nc rt k = in' nc rt (k + firstPrivateBus)
privateOut :: UGen -> UGen -> UGen
privateOut k = out (k + firstPrivateBus)
pvcollect :: UGen -> UGen -> (UGen -> UGen -> UGen -> (UGen, UGen)) -> UGen -> UGen -> UGen -> UGen
pvcollect c nf f from to z =
let m = unpackFFT c nf from to 0
p = unpackFFT c nf from to 1
i = [from .. to]
e = zipWith3 f m p i
mp = uncurry packFFTSpec (unzip e)
in packFFT c nf from to z mp
rand0 :: ID a => a -> UGen -> UGen
rand0 z = rand z 0
rand0M :: UId m => UGen -> m UGen
rand0M = randM 0
rand2 :: ID a => a -> UGen -> UGen
rand2 z n = rand z (negate n) n
rand2M :: UId m => UGen -> m UGen
rand2M n = randM (negate n) n
runningSumRMS :: UGen -> UGen -> UGen
runningSumRMS z n = sqrt (runningSum (z * z) n * recip n)
selectX :: UGen -> UGen -> UGen
selectX ix xs =
let s0 = select (roundTo ix 2) xs
s1 = select (trunc ix 2 + 1) xs
in xFade2 s0 s1 (fold2 (ix * 2 1) 1) 1
setBuf' :: UGen -> [UGen] -> UGen -> UGen
setBuf' b xs o = setBuf b o (fromIntegral (length xs)) (mce xs)
silent :: Int -> UGen
silent n = let s = dc AR 0 in mce (replicate n s)
soundIn :: UGen -> UGen
soundIn u =
let r = in' 1 AR (numOutputBuses + u)
in case u of
MCE_U m ->
let n = mceProxies m
in if all (==1) (zipWith () (tail n) n)
then in' (length n) AR (numOutputBuses + head n)
else r
_ -> r
splay :: UGen -> UGen -> UGen -> UGen -> Bool -> UGen
splay i s l c lc =
let n = max 2 (fromIntegral (fromMaybe 1 (mceDegree i)))
m = n 1
p = map ( (+ (1.0)) . (* (2 / m)) ) [0 .. m]
a = if lc then sqrt (1 / n) else 1
in mix (pan2 i (mce p * s + c) 1) * l * a
sum_opt :: [UGen] -> UGen
sum_opt l =
case l of
p:q:r:s:l' -> sum_opt (sum4 p q r s : l')
p:q:r:l' -> sum_opt (sum3 p q r : l')
_ -> sum l
tap :: Int -> UGen -> UGen -> UGen
tap numChannels bufnum delaytime =
let n = delaytime * negate sampleRate
in playBuf numChannels AR bufnum 1 0 n Loop DoNothing
tChoose :: ID m => m -> UGen -> UGen -> UGen
tChoose z t a = select (tIRand z 0 (mceN a) t) a
tChooseM :: (UId m) => UGen -> UGen -> m UGen
tChooseM t a = do
r <- tIRandM 0 (constant (length (mceChannels a))) t
return (select r a)
triAS :: Int -> UGen -> UGen
triAS n f0 =
let mk_freq i = f0 * fromIntegral i
mk_amp i = if even i then 0 else 1 / fromIntegral (i * i)
mk_ph i = if i + 1 `mod` 4 == 0 then pi else 0
m = [1,3 .. n]
param = zip3 (map mk_freq m) (map mk_ph m) (map mk_amp m)
in sum (map (\(fr,ph,am) -> sinOsc AR fr ph * am) param)
tWChoose :: ID m => m -> UGen -> UGen -> UGen -> UGen -> UGen
tWChoose z t a w n =
let i = tWindex z t n w
in select i a
tWChooseM :: (UId m) => UGen -> UGen -> UGen -> UGen -> m UGen
tWChooseM t a w n = do
i <- tWindexM t n w
return (select i a)
unpackFFT :: UGen -> UGen -> UGen -> UGen -> UGen -> [UGen]
unpackFFT c nf from to w = map (\i -> unpack1FFT c nf i w) [from .. to]
wrapOut :: Maybe Double -> UGen -> UGen
wrapOut fadeTime z =
let bus = control KR "out" 0
in if isSink z
then z
else out bus (z * maybe 1 makeFadeEnv fadeTime)
playBufCF :: Int -> UGen -> UGen -> UGen -> UGen -> Loop -> UGen -> Int -> UGen
playBufCF nc bufnum rate trigger startPos loop lag' n =
let trigger' = if rateOf trigger == DR
then tDuty AR trigger 0 DoNothing 1 0
else trigger
index' = stepper trigger' 0 0 (constant n 1) 1 0
on = map
(\i -> inRange index' (i 0.5) (i + 0.5))
[0 .. constant n 1]
rate' = case rateOf rate of
DR -> map (\on' -> demand on' 0 rate) on
KR -> map (gate rate) on
AR -> map (gate rate) on
IR -> map (const rate) on
startPos' = if rateOf startPos == DR
then demand trigger' 0 startPos
else startPos
lag'' = 1 / lag'
s = map
(\(on',r) -> let p = playBuf nc AR bufnum r on' startPos' loop DoNothing
in p * sqrt (slew on' lag'' lag''))
(zip on rate')
in sum s
osc1 :: Rate -> UGen -> UGen -> DoneAction -> UGen
osc1 rt buf dur doneAction =
let ph = line rt 0 (bufFrames IR buf 1) dur doneAction
in bufRd 1 rt buf ph NoLoop LinearInterpolation