module Synthesizer.Causal.ToneModulation (
   ToneModS.interpolateCell,
   seekCell,
   oscillatorCells,
   oscillatorSuffixes,
   integrateFractional,
   integrateFractionalClip,
   -- for testing
   limitRelativeShapes,
   limitMinRelativeValues,
   ) where

import qualified Synthesizer.Basic.ToneModulation as ToneMod
import qualified Synthesizer.Basic.Phase as Phase
import qualified Synthesizer.State.ToneModulation as ToneModS
import qualified Synthesizer.Interpolation as Interpolation
import qualified Synthesizer.Causal.Oscillator.Core as Osci
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Generic.Signal as SigG

import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), )
import Control.Monad.Trans.State (state, )

{- for testing in GHCi
import qualified Synthesizer.Plain.ToneModulation as ToneModL
import qualified Synthesizer.State.Signal as SigS
import Data.Tuple.HT (mapFst, mapSnd, swap, )
-}
import Data.Tuple.HT (mapFst, )

import qualified Algebra.RealField             as RealField
import qualified Algebra.Ring                  as Ring
import qualified Algebra.Additive              as Additive

import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude ()



oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>
    Interpolation.Margin ->
    Interpolation.Margin ->
    Int -> t -> sig y -> (t, Phase.T t) ->
    Causal.T (t,t) ((t,t), ToneModS.Cell sig y)
oscillatorCells :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, t), Cell sig y)
oscillatorCells
       Margin
marginLeap Margin
marginStep Int
periodInt t
period sig y
sampledTone (t
shape0, T t
phase) =
    forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Int -> t -> ((t, T t), sig y) -> ((t, t), Cell sig y)
seekCell Int
periodInt t
period
     forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<< forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, T t), sig y)
oscillatorSuffixes Margin
marginLeap Margin
marginStep
            Int
periodInt t
period sig y
sampledTone (t
shape0, T t
phase)
{-
*Synthesizer.Causal.ToneModulation> let shapes = [0.3,2.4,0.2,2.1,1.2,1.5::Double]; phases = [0.43,0.72,0.91,0.37,0.42,0.22::Double]
*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0
*Synthesizer.Causal.ToneModulation> mapM_ (print . mapSnd List.transpose) $ ToneModL.oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)
*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases)
-}


seekCell :: (RealField.C t, SigG.Transform sig y) =>
    Int -> t ->
    ((t, Phase.T t), sig y) ->
    ((t,t), ToneModS.Cell sig y)
seekCell :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Int -> t -> ((t, T t), sig y) -> ((t, t), Cell sig y)
seekCell Int
periodInt t
period =
    (\((t, T t)
sp,sig y
ptr) ->
       let (Int
k,(t, t)
q) = forall a. C a => Int -> a -> (a, T a) -> (Int, (a, a))
ToneMod.flattenShapePhase Int
periodInt t
period (t, T t)
sp
       in  ((t, t)
q, forall (sig :: * -> *) y.
Transform sig y =>
Int -> sig y -> Cell sig y
ToneModS.makeCell Int
periodInt forall a b. (a -> b) -> a -> b
$
               forall sig. Transform sig => Int -> sig -> sig
SigG.drop (forall a. (Ord a, C a, Show a) => a -> a
ToneModS.checkNonNeg forall a b. (a -> b) -> a -> b
$ Int
periodIntforall a. C a => a -> a -> a
+Int
k) sig y
ptr))


{- |
In contrast to the counterpart of this function for plain lists,
it does not use sophisticated list transposition tricks,
but seeks through the prototype signal using 'drop'.
Since 'drop' is used in an inner loop, it must be fast.
This is true for StorableVectors.
-}
oscillatorSuffixes :: (RealField.C t, SigG.Transform sig y) =>
    Interpolation.Margin ->
    Interpolation.Margin ->
    Int -> t ->
    sig y -> (t, Phase.T t) ->
    Causal.T (t,t) ((t, Phase.T t), sig y)
oscillatorSuffixes :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, T t), sig y)
oscillatorSuffixes
       Margin
marginLeap Margin
marginStep Int
periodInt t
period sig y
sampledTone (t
shape0, T t
phase) =
    let margin :: Int
margin =
           Margin -> Margin -> Int -> Int
ToneMod.interpolationNumber Margin
marginLeap Margin
marginStep Int
periodInt
        ipOffset :: Int
ipOffset =
           Int
periodInt forall a. C a => a -> a -> a
+
           Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt
        (t
shape0min, T t t
shapeLimiter) =
           forall t. (C t, Ord t) => t -> t -> (t, T t t)
limitMinRelativeValues (forall a b. (C a, C b) => a -> b
fromIntegral Int
ipOffset) t
shape0
        ((Int
skip0,(t, T t)
coord0), T (t, t) (Skip t)
coordinator) =
           forall t. C t => t -> (t, T t) -> (Skip t, T (t, t) (Skip t))
integrateFractional t
period (t
shape0min, T t
phase)
    in  (\(((Bool
b,Int
n),sig y
ptr), sp :: (t, T t)
sp@(t
_,T t
p)) ->
           (if Bool
b
              then (forall a. C a => a
zero, forall a. C a => a -> T a -> T a
Phase.increment (forall a b. (C a, C b) => a -> b
fromIntegral Int
n forall a. C a => a -> a -> a
/ t
period) T t
p)
              else (t, T t)
sp,
            sig y
ptr))
        forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
        (forall acc x. (acc -> x -> acc) -> acc -> T x acc
Causal.scanL
           (\ ((Bool
_,Int
n),sig y
ptr) Int
d -> forall (sig :: * -> *) y.
Transform sig y =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin Int
margin (Int
nforall a. C a => a -> a -> a
+Int
d) sig y
ptr)
           (forall (sig :: * -> *) y.
Transform sig y =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin Int
margin (Int
skip0 forall a. C a => a -> a -> a
- Int
ipOffset) sig y
sampledTone)
         forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
***
         forall x. x -> T x x
Causal.consInit (t, T t)
coord0)
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
        T (t, t) (Skip t)
coordinator
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
        forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Causal.first T t t
shapeLimiter
{-
*Synthesizer.Causal.ToneModulation> let shapes = replicate 10 (2.6::Double); phases = cycle [0.43,0.72,0.91,0.37,0.42,0.22::Double]
*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0
*Synthesizer.Causal.ToneModulation> mapM_ (print . swap . mapSnd (mapSnd (map head))) $ ToneModL.oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)
*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases)
-}

{- ToDo:
Both lengthAtMost and dropMarginRem seek through the list.
Maybe an improved version of dropMargin could avoid this.
E.g. dropMarginRem :: Int -> Int -> sig y -> (Maybe Int, sig y),
where return value (Just 0) means,
that drop could actually drop the requested number of elements,
but that we reached the end of the list.
-}
dropMargin :: (SigG.Transform sig y) =>
   Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin :: forall (sig :: * -> *) y.
Transform sig y =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin Int
margin Int
n sig y
xs =
   forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ((,) (forall sig. Transform sig => Int -> sig -> Bool
SigG.lengthAtMost (Int
marginforall a. C a => a -> a -> a
+Int
n) sig y
xs)) forall a b. (a -> b) -> a -> b
$
   forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
SigG.dropMarginRem Int
margin (forall a. (Ord a, C a, Show a) => a -> a
ToneModS.checkNonNeg Int
n) sig y
xs

regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t
regroup :: forall t. (Int, t) -> T t -> Skip t
regroup (Int
d,t
s) T t
p = (Int
d, (t
s,T t
p))

integrateFractional :: (RealField.C t) =>
    t ->
    (t, Phase.T t) ->
    (ToneMod.Skip t, Causal.T (t,t) (ToneMod.Skip t))
integrateFractional :: forall t. C t => t -> (t, T t) -> (Skip t, T (t, t) (Skip t))
integrateFractional t
period (t
shape0, T t
phase) =
    let sf0 :: (Int, t)
sf0 = forall a b. (C a, C b) => a -> (b, a)
splitFraction t
shape0
        -- shapeOffsets :: RealField.C t => Causal.T t (Int,t)
        shapeOffsets :: T t (Int, t)
shapeOffsets =
           forall a s b. (a -> State s b) -> s -> T a b
Causal.fromState
              (\t
c -> forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$ \t
s0 ->
                 let s1 :: (Int, t)
s1 = forall a b. (C a, C b) => a -> (b, a)
splitFraction (t
s0forall a. C a => a -> a -> a
+t
c)
                 in  ((Int, t)
s1, forall a b. (a, b) -> b
snd (Int, t)
s1))
              (forall a b. (a, b) -> b
snd (Int, t)
sf0)
        scale :: (a, b) -> t
scale (a
n,b
_) = forall a b. (C a, C b) => a -> b
fromIntegral a
n forall a. C a => a -> a -> a
/ t
period
        -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)
        phase0 :: T t
phase0 = forall a. C a => a -> T a -> T a
Phase.decrement (forall {a} {b}. C a => (a, b) -> t
scale (Int, t)
sf0) T t
phase
        phases :: T ((Int, b), t) (T t)
phases =
           forall a. C a => T a -> T a (T a)
Osci.freqModSync T t
phase0
              forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (\((Int, b)
s,t
f) -> t
f forall a. C a => a -> a -> a
- forall {a} {b}. C a => (a, b) -> t
scale (Int, b)
s)
    in  (forall t. (Int, t) -> T t -> Skip t
regroup (Int, t)
sf0 T t
phase0,
         forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall t. (Int, t) -> T t -> Skip t
regroup
         forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
         (forall a b. (a -> b) -> T a b
Causal.map forall a b. (a, b) -> a
fst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall {b}. T ((Int, b), t) (T t)
phases)
         forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
         forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first T t (Int, t)
shapeOffsets)

{- |
Delays output by one element and shorten it by one element at the end.
-}
integrateFractionalClip :: (RealField.C t) =>
    t ->
    (t, Phase.T t) ->
    Causal.T (t,t) (ToneMod.Skip t)
integrateFractionalClip :: forall t. C t => t -> (t, T t) -> T (t, t) (Skip t)
integrateFractionalClip t
period (t
shape0, T t
phase) =
    let sf0 :: (Int, t)
sf0 = forall a b. (C a, C b) => a -> (b, a)
splitFraction t
shape0
        -- shapeOffsets :: RealField.C t => Causal.T t (Int,t)
        shapeOffsets :: T t (Int, t)
shapeOffsets =
           forall a s b. (a -> State s b) -> s -> T a b
Causal.fromState
              (\t
c -> forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$ \t
s0 ->
                 let s1 :: (Int, t)
s1 = forall a b. (C a, C b) => a -> (b, a)
splitFraction (t
s0forall a. C a => a -> a -> a
+t
c)
                 in  ((Int, t)
s1, forall a b. (a, b) -> b
snd (Int, t)
s1))
              (forall a b. (a, b) -> b
snd (Int, t)
sf0)
        scale :: (a, b) -> t
scale (a
n,b
_) = forall a b. (C a, C b) => a -> b
fromIntegral a
n forall a. C a => a -> a -> a
/ t
period
        -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)
        phases :: T ((Int, b), t) (T t)
phases =
           forall a. C a => T a -> T a (T a)
Osci.freqMod
              (forall a. C a => a -> T a -> T a
Phase.decrement (forall {a} {b}. C a => (a, b) -> t
scale (Int, t)
sf0) T t
phase)
              forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (\((Int, b)
s,t
f) -> t
f forall a. C a => a -> a -> a
- forall {a} {b}. C a => (a, b) -> t
scale (Int, b)
s)
    in  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall t. (Int, t) -> T t -> Skip t
regroup
        forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
        ((forall x. x -> T x x
Causal.consInit (Int, t)
sf0 forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ forall a b. (a, b) -> a
fst) forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall {b}. T ((Int, b), t) (T t)
phases)
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
        forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first T t (Int, t)
shapeOffsets
{-
test to automate:
*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double]
*Synthesizer.Generic.ToneModulation> ToneMod.oscillatorCoords 9 10 (2.3,shapes) (Phase.fromRepresentative 0.6, phases)
[(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))]

*Synthesizer.Generic.ToneModulation> ToneModS.oscillatorCoords 9 10 (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases)
StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))]

*Synthesizer.Generic.ToneModulation> Data.Tuple.HT.mapSnd (flip Causal.apply $ SigS.fromList (zip shapes phases)) $ oscillatorCoords 9 10 (2.3, Phase.fromRepresentative 0.6)
((2,(-6,(0.63,0.6299999999999999))),StateSignal.fromList [(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))])

*Synthesizer.Generic.ToneModulation> oscillatorCoords' 9 10 (2.3, Phase.fromRepresentative 0.6) `Causal.apply` SigS.fromList (zip shapes phases)
StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))]
-}

limitRelativeShapes :: (Ring.C t, Ord t) =>
    Interpolation.Margin ->
    Interpolation.Margin ->
    Int -> t -> (t, Causal.T t t)
limitRelativeShapes :: forall t.
(C t, Ord t) =>
Margin -> Margin -> Int -> t -> (t, T t t)
limitRelativeShapes Margin
marginLeap Margin
marginStep Int
periodInt =
    forall t. (C t, Ord t) => t -> t -> (t, T t t)
limitMinRelativeValues forall a b. (a -> b) -> a -> b
$ forall a b. (C a, C b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
    Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt forall a. C a => a -> a -> a
+ Int
periodInt

limitMinRelativeValues :: (Additive.C t, Ord t) =>
   t -> t -> (t, Causal.T t t)
limitMinRelativeValues :: forall t. (C t, Ord t) => t -> t -> (t, T t t)
limitMinRelativeValues t
xMin t
x0 =
   let x1 :: t
x1 = t
xMinforall a. C a => a -> a -> a
-t
x0
   in  if t
x1forall a. Ord a => a -> a -> Bool
<=forall a. C a => a
zero
         then (t
x0, forall a. T a a
Causal.id)
         else (t
xMin,
               forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x y
Causal.crochetL
                  (\t
x t
lim -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                     let d :: t
d = t
xforall a. C a => a -> a -> a
-t
lim
                     in  if t
dforall a. Ord a => a -> a -> Bool
>=forall a. C a => a
zero
                           then (t
d,forall a. C a => a
zero) else (forall a. C a => a
zero, forall a. C a => a -> a
negate t
d)) t
x1)