module Sound.DF.UGen where
import Control.Monad
import Sound.DF.Node
uniform_operator :: Type -> Int -> String -> [Node] -> Node
uniform_operator t n s ps =
if all (\p -> node_type p == t) ps
then A s ps (replicate n (Port t 1))
else error (show ("output operator", ps))
out1 :: Node -> Node
out1 p = uniform_operator Real_Type 0 "df_out1" [p]
out2 :: (Node, Node) -> Node
out2 (p, q) = uniform_operator Real_Type 0 "df_out2" [p, q]
out3 :: (Node, Node, Node) -> Node
out3 (p, q, r) = uniform_operator Real_Type 0 "df_out3" [p, q, r]
sample_rate :: Node
sample_rate = A "df_sample_rate" [] [Port Real_Type 1]
eq :: Node -> Node -> Node
eq = numerical_comparison_operator "df_eq"
select2 :: Node -> Node -> Node -> Node
select2 p q r =
if node_type p == Boolean_Type &&
node_type q == node_type r
then A "df_select2" [p, q, r] [Port (node_type q) 1]
else error (show ("select2", p, q, r))
logical_operator :: String -> Node -> Node -> Node
logical_operator s p q =
if node_type p == Boolean_Type && node_type q == Boolean_Type
then A s [p, q] [Port Boolean_Type 1]
else error (show ("logical operator", s, p, q))
n_and :: Node -> Node -> Node
n_and = logical_operator "df_and"
n_or :: Node -> Node -> Node
n_or = logical_operator "df_or"
b_read :: Node -> Node -> Node
b_read p q =
if node_type p == Integer_Type && node_type q == Integer_Type
then A "df_b_read" [p, q] [Port Real_Type 1]
else error (show ("b_read", p, q))
b_write :: Node -> Node -> Node -> Node
b_write p q r =
if node_type p == Integer_Type &&
node_type q == Integer_Type &&
node_type r == Real_Type
then A "df_b_write" [p, q, r] []
else error (show ("b_write", p, q, r))
white_noise_u :: Node -> Node
white_noise_u p = A "df_random" [p] [Port Real_Type 1]
pan2 :: Node -> Node -> (Node, Node)
pan2 p q = (p * q, p * (q 1.0))
swap :: a -> b -> (b, a)
swap = flip (,)
split :: a -> (a, a)
split p = (p, p)
unit_delay :: ID m => Constant -> Node -> m Node
unit_delay y0 = rec y0 . swap
iir1 :: ID m => Constant -> (Node -> Node -> Node) -> Node -> m Node
iir1 y0 f i = rec y0 (split . f i)
iir2 :: ID m => (Node -> Node -> Node -> Node) -> Node -> m Node
iir2 f i = recm
(Real_Constant 0)
(liftM split . (\y1 -> do y2 <- unit_delay (Real_Constant 0) y1
return (f i y1 y2)))
fir1 :: ID m => (Node -> Node -> Node) -> Node -> m Node
fir1 f i = do x1 <- unit_delay (Real_Constant 0) i
return (f i x1)
fir2 :: ID m => (Node -> Node -> Node -> Node) -> Node -> m Node
fir2 f i = do x1 <- unit_delay (Real_Constant 0) i
x2 <- unit_delay (Real_Constant 0) x1
return (f i x1 x2)
biquad :: ID m => (Node -> Node -> Node -> Node -> Node -> Node) -> Node -> m Node
biquad f i = recm
(Real_Constant 0)
(liftM split . (\y1 -> do x1 <- unit_delay (Real_Constant 0) i
x2 <- unit_delay (Real_Constant 0) x1
y2 <- unit_delay (Real_Constant 0) y1
return (f i x1 x2 y1 y2)))
counter :: ID m => Constant -> Node -> m Node
counter y0 = iir1 y0 (+)
radians_per_sample :: Node
radians_per_sample = two_pi / sample_rate
hz_to_incr :: Node -> Node -> Node -> Node
hz_to_incr r hz sr = (r / sr) * hz
two_pi :: Floating a => a
two_pi = 2.0 * pi
clipr :: Node -> Node -> Node
clipr p q = select2 (q `n_gte` p) (q p) q
phasor :: ID m => Constant -> Node -> Node -> m Node
phasor ip r = iir1 ip (\x y1 -> clipr r (x + y1))
sin_osc :: ID m => Node -> Double -> m Node
sin_osc f ip =
do p <- phasor (Real_Constant ip) two_pi (hz_to_incr two_pi f sample_rate)
return (sin p)
lf_saw :: ID m => Node -> Double -> m Node
lf_saw f ip = do p <- phasor (Real_Constant ip) 2.0 (hz_to_incr 2.0 f sample_rate)
return (p 1.0)
lf_pulse :: ID m => Node -> Double -> Node -> m Node
lf_pulse f ip w =
do p <- phasor (Real_Constant ip) 1.0 (hz_to_incr 1.0 f sample_rate)
return (select2 (p `n_gte` w) 0.0 1.0)
midi_cps :: Floating a => a -> a
midi_cps a = 440.0 * (2.0 ** ((a 69.0) * (1.0 / 12.0)))
mul_add :: Num a => a -> a -> a -> a
mul_add i m a = (i * m) + a
calc_fb :: Floating a => a -> a -> a
calc_fb delayt decayt = exp ((log 0.001 * delayt) / decayt)
delay :: ID m => Node -> Node -> Node -> m Node
delay b s n =
do wi <- phasor (Integer_Constant 0) n 1
let ri = clipr n (wi + 1)
return (mrg (b_read b ri) (b_write b wi s))
buf_comb_n :: ID m => Node -> Node -> Node -> Node -> m Node
buf_comb_n b s dlt dct =
do let n = n_lrint (dlt * sample_rate)
fb = calc_fb dlt dct
c i = do x <- delay b i n
return (split (s + (fb * x)))
recm (Real_Constant 0) c
rlpf :: ID m => Node -> Node -> Node -> m Node
rlpf i f r =
let qr = max 0.001 r
pf = f * radians_per_sample
d = tan (pf * qr * 0.5)
c = (1.0 d) / (1.0 + d)
b1 = (1.0 + c) * cos pf
b2 = negate c
a0 = (1.0 + c b1) * 0.25
in iir2 (\x y1 y2 -> a0 * x + b1 * y1 + b2 * y2) i
clip2 :: Node -> Node -> Node
clip2 p q =
let nq = negate q
in min q (max p nq)
white_noise :: Node -> Node
white_noise p = white_noise_u p * 2.0 1.0
white_noise_m :: ID m => m Node
white_noise_m =
do i <- generateID
return (white_noise (n_integer_constant i))
brown_noise_m :: ID m => m Node
brown_noise_m =
do w <- white_noise_m
let w8 = w / 8.0
iir1
(Real_Constant 0)
(\x y1 -> let z = x + y1
r = select2 (z `n_lt` (1.0)) ((2.0) z) z
in select2 (z `n_gt` 1.0) (2.0 z) r)
w8
bpz2 :: ID m => Node -> m Node
bpz2 = fir2 (\x _ x2 -> (x x2) * 0.5)
brz2 :: ID m => Node -> m Node
brz2 = fir2 (\x _ x2 -> (x + x2) * 0.5)
lpz1 :: ID m => Node -> m Node
lpz1 = fir1 (\x x1 -> (x + x1) * 0.5)
lpz2 :: ID m => Node -> m Node
lpz2 = fir2 (\x x1 x2 -> (x + (2.0 * x1) + x2) * 0.25)
one_pole :: ID m => Node -> Node -> m Node
one_pole i cf = iir1
(Real_Constant 0)
(\x y1 -> ((1.0 abs cf) * x) + (cf * y1))
i
one_zero :: ID m => Node -> Node -> m Node
one_zero i cf = fir1 (\x x1 -> ((1.0 abs cf) * x) + (cf * x1)) i
sos :: ID m => Node -> Node -> Node -> Node -> Node -> Node -> m Node
sos i a0 a1 a2 b1 b2 =
let f x x1 x2 y1 y2 = a0*x + a1*x1 + a2*x2 + b1*y1 + b2*y2
in biquad f i
impulse :: ID m => Node -> Double -> m Node
impulse f ip =
do let i = hz_to_incr 1.0 f sample_rate
p <- phasor (Real_Constant ip) 1.0 i
x1 <- unit_delay (Real_Constant 0) p
let s = (x1 `n_lt` 0.5) `n_and` (p `n_gte` 0.5)
return (select2 s 1.0 0.0)
resonz :: ID m => Node -> Node -> Node -> m Node
resonz i f rq =
let ff = f * radians_per_sample
b = ff * rq
r = 1.0 b * 0.5
two_r = 2.0 * r
r2 = r * r
ct = (two_r * cos ff) / (1.0 + r2)
b1 = two_r * ct
b2 = negate r2
a0 = (1.0 r2) * 0.5
in iir2 (\x y1 y2 -> let y0 = x + b1 * y1 + b2 * y2
in a0 * (y0 y2)) i
latch :: ID m => Node -> Node -> m Node
latch i t = iir1
(Real_Constant 0)
(\x y1 -> select2 (t `n_gt` 0.0) x y1)
i
lin_lin :: Fractional a => a -> a -> a -> a -> a -> a
lin_lin i in_l in_r out_l out_r =
let s = (out_r out_l) / (in_r in_l)
o = out_l (s * in_l)
in (i * s) + o
lin_exp :: Floating a => a -> a -> a -> a -> a -> a
lin_exp i in_l in_r out_l out_r =
let rt = out_r / out_l
rn = 1.0 / (in_r in_l)
rr = rn * negate in_l
in out_l * (rt ** (i * rn + rr))
decay :: ID m => Node -> Node -> m Node
decay i dt =
let b1 = exp (log 0.001 / (dt * sample_rate))
in iir1 (Real_Constant 0) (\x y1 -> x + b1 * y1) i
decay2 :: ID m => Node -> Node -> Node -> m Node
decay2 i atk dcy = liftM2 () (decay i dcy) (decay i atk)
delay1 :: ID m => Node -> m Node
delay1 = iir1 (Real_Constant 0) (\_ y1 -> y1)
delay2 :: ID m => Node -> m Node
delay2 = iir2 (\_ _ y2 -> y2)
lag :: ID m => Node -> Node -> m Node
lag i t = let b1 = exp (log (0.001 / (t * sample_rate)))
in iir1 (Real_Constant 0) (\x y1 -> x + b1 * (y1 x)) i
lag2 :: ID m => Node -> Node -> m Node
lag2 i t = do a <- lag i t
lag a t
lag3 :: ID m => Node -> Node -> m Node
lag3 i t = do a <- lag i t
b <- lag a t
lag b t