module Sound.SC3.UGen.Bindings.Composite where
import Control.Monad
import Data.List
import qualified Data.List.Split as Split
import Data.Maybe
import Sound.SC3.Common.Envelope
import Sound.SC3.Common.Math
import Sound.SC3.Common.Math.Filter.BEQ
import Sound.SC3.Common.UId
import Sound.SC3.UGen.Bindings.DB
import qualified Sound.SC3.UGen.Bindings.DB.External as External
import Sound.SC3.UGen.Bindings.HW
import Sound.SC3.UGen.Bindings.Monad
import Sound.SC3.UGen.Enum
import Sound.SC3.UGen.Math
import Sound.SC3.UGen.Rate
import Sound.SC3.UGen.Type
import Sound.SC3.UGen.UGen
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
bLowPass4 :: UGen -> UGen -> UGen -> UGen
bLowPass4 i f rq =
let (a0, a1, a2, b1, b2) = bLowPassCoef sampleRate f rq
flt z = sos z a0 a1 a2 b1 b2
in flt (flt i)
bHiPass4 :: UGen -> UGen -> UGen -> UGen
bHiPass4 i f rq =
let (a0, a1, a2, b1, b2) = bHiPassCoef sampleRate f rq
flt z = sos z a0 a1 a2 b1 b2
in flt (flt i)
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 = liftUId1 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)
exprange :: UGen -> UGen -> UGen -> UGen
exprange l r s = linExp s (-1) 1 l r
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)
hilbertFIR :: UGen -> UGen -> UGen
hilbertFIR s b =
let c0 = fft' b s
c1 = pv_PhaseShift90 c0
delay = bufDur KR b
in mce2 (delayN s delay delay) (ifft' c1)
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_k :: Real n => [n] -> [n] -> [n] -> UGen
klangSpec_k = 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_k :: Real n => [n] -> [n] -> [n] -> UGen
klankSpec_k = 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 = liftUId1 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 0
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 (Split.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
pv_calcPVRecSize :: Double -> Int -> Double -> Double -> Int
pv_calcPVRecSize dur frame_size hop sample_rate =
let frame_size' = fromIntegral frame_size
raw_size = ceiling ((dur * sample_rate) / frame_size') * frame_size
in ceiling (fromIntegral raw_size * recip hop + 3)
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]
varLag_env :: UGen -> UGen -> Envelope_Curve UGen -> UGen -> UGen
varLag_env in_ time curve start =
let rt = rateOf in_
e = Envelope [start,in_] [time] [curve] Nothing Nothing 0
time_ch = if rateOf time == IR then 0 else changed time 0
tr = changed in_ 0 + time_ch + impulse rt 0 0
in envGen rt tr 1 0 1 DoNothing e
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
fm7_mx :: [[UGen]] -> [[UGen]] -> UGen
fm7_mx ctlMatrix modMatrix = External.fm7 AR (mce (concat ctlMatrix)) (mce (concat modMatrix))
pulseDPW :: Rate -> UGen -> UGen -> UGen
pulseDPW rt freq width =
let o1 = External.sawDPW rt freq 0
o2 = External.sawDPW rt freq (wrap_hs (-1,1) (width+width))
in o1 - o2