-- | Data flow node functions, or unit generators.
module Sound.DF.Uniform.GADT.UGen.Monadic where

import Control.Monad {- base -}
import Data.Int {- base -}
import Data.Maybe {- base -}

import Sound.DF.Uniform.GADT.DF
import Sound.DF.Uniform.GADT.UGen
import Sound.DF.Uniform.LL.UId
import Sound.DF.Uniform.LL.K

-- | Single place infinite impulse response filter with indicated
-- initial value.
--
-- > import Data.Int
-- > import Sound.DF.Uniform.GADT
-- > draw =<< iir1_m (0::Int32) (+) 1
-- > draw =<< iir1_m (0::Float) (+) 1
iir1_m :: (K' a,UId m) => a -> (Binary_Op (DF a)) -> DF a -> m (DF a)
iir1_m y0 f i = rec_m y0 (split . f i)

-- | /r/ = right hand edge, /ip/ = initial phase, /x/ = increment
--
-- > draw =<< phasor_m 9.0 (4.5::Float) 0.5
-- > drawM (phasor_m 9 (0::Int32) 1)
phasor_m :: (K_Num a,UId m) => DF a -> a -> DF a -> m (DF a)
phasor_m r ip = iir1_m ip (\x y1 -> clipr r (x + y1))

-- * Array

-- | Allocate /n/ second array, variant of 'df_vec'.
a_alloc_sec_m :: UId m => Float -> m (DF (Vec Float))
a_alloc_sec_m z =
    let z' = ceiling (z * k_sample_rate) + 1 + 1
    in df_vec_m (replicate z' 0)

-- | Array delay.
--
-- > do {a <- df_vec_m [0,1,2]
-- >    ;d <- a_delay a 0.0 0
-- >    ;draw (a_delay a 0.0 0)}
--
-- > do {f <- sin_osc 0.1 0.0
-- >    ;o <- sin_osc (f * 200.0 + 600.0) 0.0
-- >    ;a <- df_vec_m (replicate 48000 0)
-- >    ;d <- a_delay a o 24000
-- >    ;audition [] (out2 (o * 0.1) (d * 0.05))}
a_delay_m :: UId m => DF (Vec Float) -> DF Float -> DF Int32 -> m (DF Float)
a_delay_m a s n = do
  wi <- phasor_m n 0 1
  return (a_delay_ph a s n wi)

-- | Array fill function (sin).
a_tbl_sin_m :: UId m => Int -> m (DF (Vec Float))
a_tbl_sin_m = df_vec_m . tbl_sin

-- * Osc

-- | 'phasor' for table of /z/ places. /ip/ is in (0,1).
--
-- > drawM (phasor 64.0 (0.0::Float) (hz_to_incr k_sample_rate 64.0 330.0))
-- > drawM (tbl_phasor 64 0.0 330.0)
tbl_phasor_m :: UId m => Int -> Float -> DF Float -> m (DF Float)
tbl_phasor_m z ip f =
  let z_r = fromIntegral z
      z_c = K z_r
      ip_c = ip * z_r
  in phasor_m z_c ip_c (hz_to_incr w_sample_rate z_c f)

-- | Table lookup oscillator. /ip/ is in (0,1).
--
-- > do {a <- a_tbl_sin 256
-- >    ;f <- a_osc a 4.0 0.0
-- >    ;o <- a_osc a (f * 200.0 + 400.0) 0.0
-- >    ;audition [] (out1 (o * 0.1))}
--
-- Cancellation:
--
-- > do {a <- a_tbl_sin 256
-- >    ;o1 <- a_osc a 440.0 0.0
-- >    ;o2 <- a_osc a 440.0 0.5
-- >    ;audition [] (out1 (o1 + o2))}
a_osc_m :: UId m => DF (Vec Float) -> DF Float -> Float -> m (DF Float)
a_osc_m a f ip = do
  let z = fromMaybe 0 (df_tbl_size a)
  p <- tbl_phasor_m z ip f
  return (a_lerp a p)

-- * Filter constructors.

-- | Single sample delay with indicated initial value.
--
-- > drawM (unit_delay_m (0::Int32) 1)
-- > drawM (unit_delay_m (0.0::Float) 1.0)
--
-- > do {c <- counter_m 0 1.0
-- >    ;d <- unit_delay_m 0 c
-- >    ;audition_text 12 (out2 c d)}
unit_delay_m :: (K' a,UId m) => a -> DF a -> m (DF a)
unit_delay_m y0 s = rec_m y0 (\i -> (i,s))

-- | Two place infinite impulse response filter.  Inputs are: /f/=
-- function @(\x0 y1 y2 -> y0)@, /i/ = input signal.
--
-- > do {c1 <- iir2 (\x y1 _ -> x + y1) 0.001
-- >    ;o1 <- sin_osc (c1 + 220.0) 0
-- >    ;c2 <- iir2 (\x _ y2 -> x + y2) 0.001
-- >    ;o2 <- sin_osc (c2 + 220.0) 0
-- >    ;audition [] (out2 (o1 * 0.1) (o2 * 0.1))}
iir2_m :: (K_Num a,UId m) => (Ternary_Op (DF a)) -> DF a -> m (DF a)
iir2_m f i =
    rec_mM
    0
    (liftM split . (\y1 -> do
                      y2 <- unit_delay_m 0 y1
                      return (f i y1 y2)))

-- | Single place finite impulse response filter.
fir1_m :: UId m => (Binary_Op (DF Float)) -> DF Float -> m (DF Float)
fir1_m f i = do
  x1 <- unit_delay_m 0 i
  return (f i x1)

-- | Two place finite impulse response filter.
fir2_m :: UId m => (Ternary_Op (DF Float)) -> DF Float -> m (DF Float)
fir2_m f i = do
  x1 <- unit_delay_m 0.0 i
  x2 <- unit_delay_m 0.0 x1
  return (f i x1 x2)

-- | Ordinary biquad filter section.
biquad_m :: UId m => (Quinary_Op (DF Float)) -> DF Float -> m (DF Float)
biquad_m f i =
    rec_mM
    0.0
    (liftM split . (\y1 -> do
                      x1 <- unit_delay_m 0.0 i
                      x2 <- unit_delay_m 0.0 x1
                      y2 <- unit_delay_m 0.0 y1
                      return (f i x1 x2 y1 y2)))

-- * Counter

-- | Counter from indicated initial value.
--
-- > draw =<< counter (0::Int32) 1
-- > drawM (counter (0.0::Float) 1.0)
--
-- > audition_text 10 . out1 =<< counter_m 0.0 1.0
counter_m :: (K_Num a,UId m) => a -> DF a -> m (DF a)
counter_m y0 n = unit_delay_m y0 =<< iir1_m y0 (+) n

-- * Buffer

-- | Buffer delay.
--
-- > drawM (buf_delay 0 0.0 0)
buf_delay_m :: UId m => DF Int32 -> DF Float-> DF Int32 -> m (DF Float)
buf_delay_m b s n = do
  wi <- phasor_m n 0 1
  let ri = clipr n (wi + 1)
  return (mrg (b_read b ri) (b_write b wi s))

-- | Non-interpolating comb filter.  Inputs are: /b/ = buffer index,
-- /i/ = input signal, /dl/ = delay time, /dc/ = decay time.
--
-- All times are in seconds.  The decay time is the time for the
-- echoes to decay by @60@ decibels. If this time is negative then the
-- feedback coefficient will be negative, thus emphasizing only odd
-- harmonics at an octave lower.
--
-- > drawM (fmap out1 (buf_comb_n 0 0.0 0.0 0.0))
--
-- Comb used as a resonator. The resonant fundamental is equal to
-- reciprocal of the delay time.
--
-- > import qualified Sound.SC3 as S
--
-- > do {n <- white_noise_m
-- >    ;dt <- let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01
-- >           in fmap f (lf_saw 0.1 0.0)
-- >    ;c <- buf_comb_n 0 (n * 0.1) dt 0.2
-- >    ;audition [S.b_alloc 0 48000 1] (out1 c)}
--
-- Comb used as an echo.
--
-- > do {i <- impulse 0.5 0.0
-- >    ;n <- white_noise_m
-- >    ;e <- decay (i * 0.5) 0.2
-- >    ;c <- buf_comb_n 0 (e * n) 0.2 3.0
-- >    ;audition [S.b_alloc 0 48000 1] (out1 c)}
buf_comb_n_m :: UId m => DF Int32 -> DF Float -> DF Float -> DF Float -> m (DF Float)
buf_comb_n_m b s dlt dct = do
  let n = df_lrintf (dlt * w_sample_rate)
      fb = calc_fb dlt dct
      c i = do x <- buf_delay_m b i n
               return (split (s + (fb * x)))
  rec_mM 0.0 c

-- * Comb

-- | Array variant of 'buf_comb_n'.  Max delay time is in seconds.
--
-- > do {n <- white_noise_m
-- >    ;dt <- let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01
-- >           in fmap f (lf_saw 0.1 0.0)
-- >    ;c <- comb_n 0.1 (n * 0.1) dt 0.2
-- >    ;audition [] (out1 c)}
--
-- > do {i <- impulse 0.5 0.0
-- >    ;n <- white_noise_m
-- >    ;e <- decay (i * 0.5) 0.2
-- >    ;c <- comb_n 0.2 (e * n) 0.2 3.0
-- >    ;audition [] (out1 c)}
comb_n_m :: UId m => Float -> DF Float -> DF Float -> DF Float -> m (DF Float)
comb_n_m z s dlt dct = do
  a <- a_alloc_sec_m z
  let n = df_lrintf (dlt * w_sample_rate)
      fb = calc_fb dlt dct
      c i = do x <- a_delay_m a i n
               return (split (s + (fb * x)))
  rec_mM 0.0 c

-- * Noise

-- | White noise (-1,1).  Generates noise whose spectrum has equal
-- power at all frequencies.
--
-- > do {n <- white_noise_m
-- >    ;audition [] (out1 (n * 0.1))}
white_noise_m :: UId m => m (DF Float)
white_noise_m = do
  i <- generateId
  return (white_noise (fromIntegral i))

-- | Brown noise (-1,1).  Generates noise whose spectrum falls off in
-- power by 6 dB per octave.
--
-- > do {n <- brown_noise_m
-- >    ;audition [] (out1 (n * 0.1))}
--
-- > do {n <- brown_noise_m
-- >    ;let f = lin_exp n (-1.0) 1.0 64.0 9600.0
-- >     in do {o <- sin_osc f 0
-- >           ;audition [] (out1 (o * 0.1))}}
brown_noise_m :: UId m => m (DF Float)
brown_noise_m = do
  w <- white_noise_m
  let w8 = w / 8.0
  iir1_m 0.0 brown_noise_f w8

-- * Osc

-- | Sine oscillator.  Inputs are: /f/ = frequency (in hz), /ip/ =
-- initial phase.
--
-- > do {o <- sin_osc 440.0 0.0
-- >    ;audition [] (out1 (o * 0.1))}
--
-- Used as both Oscillator and LFO.
--
-- > do {f <- sin_osc 4.0 0.0
-- >    ;o <- sin_osc (f * 200.0 + 400.0) 0.0
-- >    ;audition [] (out1 (o * 0.1))}
--
-- Cancellation.
--
-- > do {o1 <- sin_osc 440.0 0.0
-- >    ;o2 <- sin_osc 440.0 pi
-- >    ;audition [] (out1 (o1 + o2))}
sin_osc_m :: UId m => DF Float -> Float -> m (DF Float)
sin_osc_m f ip = do
  p <- phasor_m two_pi ip (hz_to_incr w_sample_rate two_pi f)
  return (sin p)

-- | Impulse oscillator (non band limited).
-- Outputs non band limited single sample impulses.
-- Inputs are: /f/ = frequency (in hertz), /ip/ = phase offset (0..1)
--
-- > do {o <- impulse 800.0 0.0
-- >    ;audition [] (out1 (o * 0.1))}
--
-- > do {f <- fmap (\x -> x * 2500.0 + 2505.0) (sin_osc 0.25 0.0)
-- >    ;o <- impulse f 0.0
-- >    ;audition [] (out1 (o * 0.1))}
impulse_m :: UId m => DF Float -> Float -> m (DF Float)
impulse_m f ip = do
  let i = hz_to_incr w_sample_rate 1.0 f
  p <- phasor_m 1.0 ip i
  x1 <- unit_delay_m 0.0 p
  let s = (x1 `df_lt` 0.5) `df_and` (p `df_gte` 0.5)
  return (select2 s 1.0 0.0)

-- * LF Osc.

-- | Non-band limited sawtooth oscillator.  Output ranges from -1 to +1.
-- Inputs are: /f/ = frequency (in hertz), /ip/ = initial phase (0,2).
--
-- > do {o <- lf_saw 500.0 1.0
-- >    ;audition [] (out1 (o * 0.1))}
--
-- Used as both Oscillator and LFO.
--
-- > do {f <- lf_saw 4.0 0.0
-- >    ;o <- lf_saw (f * 400.0 + 400.0) 0.0
-- >    ;audition [] (out1 (o * 0.1))}
lf_saw_m :: UId m => DF Float -> Float -> m (DF Float)
lf_saw_m f ip = do
  p <- phasor_m 2.0 ip (hz_to_incr w_sample_rate 2.0 f)
  return (p - 1.0)

-- | Non-band-limited pulse oscillator. Outputs a high value of one
-- and a low value of zero. Inputs are: /f/ = frequency (in hertz),
-- /ip/ = initial phase (0,1), /w/ = pulse width duty cycle (0,1).
--
-- > do {o1 <- fmap (\x -> x * 200.0 + 200.0) (lf_pulse 3.0 0.0 0.3)
-- >    ;o2 <- fmap (\x -> x * 0.1) (lf_pulse o1 0.0 0.2)
-- >    ;audition [] (out1 o2)}
lf_pulse_m :: UId m => DF Float -> Float -> DF Float -> m (DF Float)
lf_pulse_m f ip w = do
  p <- phasor_m 1.0 ip (hz_to_incr w_sample_rate 1.0 f)
  return (select2 (p `df_gte` w) 0.0 1.0)

-- * Filters

-- | Two zero fixed midpass filter.
bpz2_m :: UId m => DF Float -> m (DF Float)
bpz2_m = fir2_m (\x _ x2 -> (x - x2) * 0.5)

-- | Two zero fixed midcut filter.
brz2_m :: UId m => DF Float -> m (DF Float)
brz2_m = fir2_m (\x _ x2 -> (x + x2) * 0.5)

-- | Two point average filter
lpz1_m :: UId m => DF Float -> m (DF Float)
lpz1_m = fir1_m (\x x1 -> (x + x1) * 0.5)

-- | Two zero fixed lowpass filter
lpz2_m :: UId m => DF Float -> m (DF Float)
lpz2_m = fir2_m (\x x1 x2 -> (x + (2.0 * x1) + x2) * 0.25)

-- | One pole filter.
--
-- > do {n <- white_noise_m
-- >    ;f <- one_pole (n * 0.5) 0.95
-- >    ;audition [] (out1 f)}
one_pole_m :: UId m => DF Float -> DF Float -> m (DF Float)
one_pole_m i cf = iir1_m 0.0 (one_pole_f cf) i

-- | One zero filter.
--
-- > do {n <- white_noise_m
-- >    ;f <- one_zero (n * 0.5) 0.5
-- >    ;audition [] (out1 f)}
one_zero_m :: UId m => DF Float -> DF Float -> m (DF Float)
one_zero_m i cf = fir1_m (\x x1 -> ((1.0 - abs cf) * x) + (cf * x1)) i

-- | Second order filter section.
sos_m :: UId m => DF Float -> DF Float -> DF Float -> DF Float -> DF Float -> DF Float -> m (DF Float)
sos_m i a0 a1 a2 b1 b2 = biquad_m (sos_f a0 a1 a2 b1 b2) i

-- | A two pole resonant filter with zeroes at z = +/- 1. Based on
-- K. Steiglitz, \"A Note on Constant-Gain Digital Resonators\",
-- /Computer Music Journal/, vol 18, no. 4, pp. 8-10, Winter 1994.
-- The reciprocal of Q is used rather than Q because it saves a divide
-- operation inside the unit generator.
--
-- Inputs are: /i/ = input signal, /f/ = resonant frequency (in
-- hertz), /rq/ = bandwidth ratio (reciprocal of Q);where /rq/ =
-- bandwidth / centerFreq.
--
-- > do {n <- white_noise_m
-- >    ;r <- resonz (n * 0.5) 440.0 0.1
-- >    ;audition [] (out1 r)}
--
-- Modulate frequency
--
-- > do {n <- white_noise_m
-- >    ;f <- fmap (\x -> x * 3500.0 + 4500.0) (lf_saw 0.1 0.0)
-- >    ;r <- resonz (n * 0.5) f 0.05
-- >    ;audition [] (out1 r)}
resonz_m :: UId m => DF Float -> DF Float -> DF Float -> m (DF Float)
resonz_m i f rq = iir2_m (resonz_f f rq) i

-- | Resonant low pass filter. Inputs are: /i/ = input signal, /f/ =
-- frequency (hertz), /rq/ = reciprocal of Q (resonance).
--
-- > do {n <- white_noise_m
-- >    ;f <- fmap (\x -> x * 40.0 + 220.0) (sin_osc 0.5 0.0)
-- >    ;r <- rlpf n f 0.1
-- >    ;audition [] (out1 r)}
rlpf_m :: UId m => DF Float -> DF Float -> DF Float -> m (DF Float)
rlpf_m i f r = iir2_m (rlpf_f f r) i

-- * Triggers

-- | Sample and hold. Holds input signal value when triggered.  Inputs
-- are: /i/ = input signal, /t/ = trigger.
--
-- > do {n <- white_noise_m
-- >    ;i <- impulse_m 9.0 0.0
-- >    ;l <- latch_m n (trigger i)
-- >    ;o <- sin_osc (l * 400.0 + 500.0) 0.0
-- >    ;audition [] (out1 (o * 0.2))}
latch_m :: (K_Num a,UId m) => DF a -> DF Bool -> m (DF a)
latch_m i t = iir1_m 0 (select2 t) i

-- * Decays

-- | Exponential decay. Inputs are: /i/ = input signal, /t/ = decay
-- time.  This is essentially the same as Integrator except that
-- instead of supplying the coefficient directly, it is caculated from
-- a 60 dB decay time. This is the time required for the integrator to
-- lose 99.9 % of its value or -60dB. This is useful for exponential
-- decaying envelopes triggered by impulses.
--
-- Used as an envelope.
--
-- > do {n <- brown_noise_m
-- >    ;f <- lf_saw 0.1 0.0
-- >    ;i <- impulse (lin_lin f (-1.0) 1.0 2.0 5.0) 0.25
-- >    ;e <- decay i 0.2
-- >    ;audition [] (out1 (e * n))}
decay_m :: UId m => DF Float -> DF Float -> m (DF Float)
decay_m i dt = iir1_m 0.0 (decay_f dt) i

-- | Exponential decay (equivalent to @decay dcy - decay atk@).
decay2_m :: UId m => DF Float -> DF Float -> DF Float -> m (DF Float)
decay2_m i atk dcy = liftM2 (-) (decay_m i dcy) (decay_m i atk)

-- * Delays

-- | Single sample delay.
delay1_m :: (K_Num a,UId m) => DF a -> m (DF a)
delay1_m = iir1_m 0 (\_ y1 -> y1)

-- | Two sample delay.
delay2_m :: (K_Num a,UId m) => DF a -> m (DF a)
delay2_m = iir2_m (\_ _ y2 -> y2)

-- * Lags

-- | Simple averaging filter.  Inputs are: /i/ = input signal, /t/ =
-- lag time.
--
-- > do {s <- sin_osc 0.05 0.0
-- >    ;let f = lin_lin s (-1.0) 1.0 220.0 440.0
-- >     in do {o <- sin_osc f 0.0
-- >           ;f' <- lag f 1.0
-- >           ;o' <- sin_osc f' 0.0
-- >           ;audition [] (out2 (o * 0.2) (o' * 0.2))}}
lag_m :: UId m => DF Float -> DF Float -> m (DF Float)
lag_m i t = iir1_m 0 (lag_f t) i

-- | Nested lag filter.
lag2_m :: UId m => DF Float -> DF Float -> m (DF Float)
lag2_m i t = do
  a <- lag_m i t
  lag_m a t

-- | Twice nested lag filter.
lag3_m :: UId m => DF Float -> DF Float -> m (DF Float)
lag3_m i t = do
  a <- lag_m i t
  b <- lag_m a t
  lag_m b t