module Synthesizer.State.ToneModulation (
   Cell,
   makeCell,
   interpolateCell,

   Prototype,
   makePrototype,
   sampledToneCell,

   oscillatorCells,

   -- needed in Causal.ToneModulation
   checkNonNeg,

   -- for testing
   oscillatorCoords,
   limitRelativeShapes,
   limitMinRelativeValues,
   ) where

import qualified Synthesizer.Basic.ToneModulation as ToneMod
import qualified Synthesizer.Causal.Oscillator.Core as Osci

import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Interpolation as Interpolation

import qualified Synthesizer.Generic.Signal as SigG

import qualified Synthesizer.State.Signal as SigS

import qualified Synthesizer.Basic.Phase as Phase

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

import Data.Ord.HT (limit, )

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


type Cell sig y = SigS.T (sig y)

{- |
cells are organised in a transposed style,
when compared with Plain.ToneModulation
-}
{-# INLINE interpolateCell #-}
interpolateCell ::
   (SigG.Read sig y) =>
   Interpolation.T a y ->
   Interpolation.T b y ->
   (a, b) ->
   Cell sig y -> y
interpolateCell :: forall (sig :: * -> *) y a b.
Read sig y =>
T a y -> T b y -> (a, b) -> Cell sig y -> y
interpolateCell T a y
ipLeap T b y
ipStep (a
qLeap,b
qStep) =
   T a y -> a -> T y -> y
forall t y. T t y -> t -> T y -> y
Interpolation.func T a y
ipLeap a
qLeap (T y -> y) -> (Cell sig y -> T y) -> Cell sig y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (sig y -> y) -> Cell sig y -> T y
forall a b. (a -> b) -> T a -> T b
SigS.map (T b y -> b -> T y -> y
forall t y. T t y -> t -> T y -> y
Interpolation.func T b y
ipStep b
qStep (T y -> y) -> (sig y -> T y) -> sig y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig y -> T y
forall y. Storage (sig y) => sig y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState)



data Prototype sig a v =
   Prototype {
      forall (sig :: * -> *) a v. Prototype sig a v -> Margin
protoMarginLeap,
      forall (sig :: * -> *) a v. Prototype sig a v -> Margin
protoMarginStep  :: Interpolation.Margin,
      forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoIpOffset    :: Int,
      forall (sig :: * -> *) a v. Prototype sig a v -> a
protoPeriod      :: a,
      forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoPeriodInt   :: Int,
      forall (sig :: * -> *) a v. Prototype sig a v -> (a, a)
protoShapeLimits :: (a,a),
      forall (sig :: * -> *) a v. Prototype sig a v -> sig v
protoSignal      :: sig v
   }


makePrototype ::
   (RealField.C a, SigG.Read sig v) =>
   Interpolation.Margin ->
   Interpolation.Margin ->
   a -> sig v -> Prototype sig a v
makePrototype :: forall a (sig :: * -> *) v.
(C a, Read sig v) =>
Margin -> Margin -> a -> sig v -> Prototype sig a v
makePrototype Margin
marginLeap Margin
marginStep a
period sig v
tone =
   let periodInt :: Int
periodInt = a -> Int
forall b. C b => a -> b
forall a b. (C a, C b) => a -> b
round a
period
       ipOffset :: Int
ipOffset =
          Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt
       len :: Int
len = sig v -> Int
forall sig. Read sig => sig -> Int
SigG.length sig v
tone
       (Int
lower,Int
upper) =
          Margin -> Margin -> Int -> Int -> (Int, Int)
forall t. C t => Margin -> Margin -> Int -> t -> (t, t)
ToneMod.shapeLimits Margin
marginLeap Margin
marginStep Int
periodInt Int
len
       limits :: (a, a)
limits =
          if Int
lower Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
upper
            then [Char] -> (a, a)
forall a. HasCallStack => [Char] -> a
error [Char]
"min>max"
            else (Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
lower, Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
upper)

   in  Prototype {
          protoMarginLeap :: Margin
protoMarginLeap  = Margin
marginLeap,
          protoMarginStep :: Margin
protoMarginStep  = Margin
marginStep,
          protoIpOffset :: Int
protoIpOffset    = Int
ipOffset,
          protoPeriod :: a
protoPeriod      = a
period,
          protoPeriodInt :: Int
protoPeriodInt   = Int
periodInt,
          protoShapeLimits :: (a, a)
protoShapeLimits = (a, a)
limits,
          protoSignal :: sig v
protoSignal      = sig v
tone
       }

{-# INLINE sampledToneCell #-}
sampledToneCell ::
   (RealField.C a, SigG.Transform sig v) =>
   Prototype sig a v -> a -> Phase.T a -> ((a,a), Cell sig v)
sampledToneCell :: forall a (sig :: * -> *) v.
(C a, Transform sig v) =>
Prototype sig a v -> a -> T a -> ((a, a), Cell sig v)
sampledToneCell Prototype sig a v
p a
shape T a
phase =
   let (Int
n, (a, a)
q) =
          Int -> a -> (a, T a) -> (Int, (a, a))
forall a. C a => Int -> a -> (a, T a) -> (Int, (a, a))
ToneMod.flattenShapePhase (Prototype sig a v -> Int
forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoPeriodInt Prototype sig a v
p) (Prototype sig a v -> a
forall (sig :: * -> *) a v. Prototype sig a v -> a
protoPeriod Prototype sig a v
p)
             ((a, a) -> a -> a
forall a. Ord a => (a, a) -> a -> a
limit (Prototype sig a v -> (a, a)
forall (sig :: * -> *) a v. Prototype sig a v -> (a, a)
protoShapeLimits Prototype sig a v
p) a
shape, T a
phase)
   in  ((a, a)
q,
        (sig v -> sig v) -> sig v -> T (sig v)
forall a. (a -> a) -> a -> T a
SigS.iterate (Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Prototype sig a v -> Int
forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoPeriodInt Prototype sig a v
p)) (sig v -> T (sig v)) -> sig v -> T (sig v)
forall a b. (a -> b) -> a -> b
$
        Int -> sig v -> sig v
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Int
n Int -> Int -> Int
forall a. C a => a -> a -> a
- Prototype sig a v -> Int
forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoIpOffset Prototype sig a v
p) (sig v -> sig v) -> sig v -> sig v
forall a b. (a -> b) -> a -> b
$
        Prototype sig a v -> sig v
forall (sig :: * -> *) a v. Prototype sig a v -> sig v
protoSignal Prototype sig a v
p)


-- * lazy oscillator

{-# DEPRECATED oscillatorCells "This function recomputes the shape and phase signals. Better use Causal.ToneModulation.oscillatorCells" #-}
{- |
This function should not be used,
since it requires recomputation of @shapes@ and @freqs@ lists.
-}
oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>
    Interpolation.Margin ->
    Interpolation.Margin ->
    t -> sig y -> (t, SigS.T t) -> (Phase.T t, SigS.T t) ->
    SigS.T ((t,t), Cell sig y)
oscillatorCells :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> t
-> sig y
-> (t, T t)
-> (T t, T t)
-> T ((t, t), Cell sig y)
oscillatorCells
       Margin
marginLeap Margin
marginStep t
period sig y
sampledTone (t, T t)
shapes (T t, T t)
freqs =
    let periodInt :: Int
periodInt = t -> Int
forall b. C b => t -> b
forall a b. (C a, C b) => a -> b
round t
period
        margin :: Int
margin =
           Margin -> Margin -> Int -> Int
ToneMod.interpolationNumber Margin
marginLeap Margin
marginStep Int
periodInt
        ipOffset :: Int
ipOffset =
           Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt
        (T Int
skips,T (Int, (t, t))
coords) =
           -- unzip requires recomputation
           T (Int, (Int, (t, t))) -> (T Int, T (Int, (t, t)))
forall a b. T (a, b) -> (T a, T b)
SigS.unzip (T (Int, (Int, (t, t))) -> (T Int, T (Int, (t, t))))
-> T (Int, (Int, (t, t))) -> (T Int, T (Int, (t, t)))
forall a b. (a -> b) -> a -> b
$
           Int -> t -> (t, T t) -> (T t, T t) -> T (Int, (Int, (t, t)))
forall t. C t => Int -> t -> (t, T t) -> (T t, T t) -> T (Coords t)
oscillatorCoords Int
periodInt t
period
              (Margin -> Margin -> Int -> (t, T t) -> (t, T t)
forall t. C t => Margin -> Margin -> Int -> (t, T t) -> (t, T t)
limitRelativeShapes Margin
marginLeap Margin
marginStep Int
periodInt (t, T t)
shapes)
              (T t, T t)
freqs
    in  ((Int, (t, t)) -> (Int, sig y) -> ((t, t), Cell sig y))
-> T (Int, (t, t)) -> T (Int, sig y) -> T ((t, t), Cell sig y)
forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith
           {-
           n will be zero within the data body.
           It's only needed for extrapolation at the end.
           Is it really needed?
           -}
           (\(Int
k,(t, t)
q) (Int
_n,sig y
ptr) ->
               ((t, t)
q, Int -> sig y -> Cell sig y
forall (sig :: * -> *) y.
Transform sig y =>
Int -> sig y -> Cell sig y
makeCell Int
periodInt (sig y -> Cell sig y) -> sig y -> Cell sig y
forall a b. (a -> b) -> a -> b
$
                      Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Int -> Int
forall a. (Ord a, C a, Show a) => a -> a
checkNonNeg (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
periodIntInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
k) sig y
ptr))
           T (Int, (t, t))
coords (T (Int, sig y) -> T ((t, t), Cell sig y))
-> T (Int, sig y) -> T ((t, t), Cell sig y)
forall a b. (a -> b) -> a -> b
$
        T (Int, sig y)
-> ((Int, sig y) -> T (Int, sig y) -> T (Int, sig y))
-> T (Int, sig y)
-> T (Int, sig y)
forall b a. b -> (a -> T a -> b) -> T a -> b
SigS.switchL ([Char] -> T (Int, sig y)
forall a. HasCallStack => [Char] -> a
error [Char]
"list of pointers must not be empty") ((T (Int, sig y) -> (Int, sig y) -> T (Int, sig y))
-> (Int, sig y) -> T (Int, sig y) -> T (Int, sig y)
forall a b c. (a -> b -> c) -> b -> a -> c
flip T (Int, sig y) -> (Int, sig y) -> T (Int, sig y)
forall a b. a -> b -> a
const) (T (Int, sig y) -> T (Int, sig y))
-> T (Int, sig y) -> T (Int, sig y)
forall a b. (a -> b) -> a -> b
$
        ((Int, sig y) -> Int -> (Int, sig y))
-> (Int, sig y) -> T Int -> T (Int, sig y)
forall acc x. (acc -> x -> acc) -> acc -> T x -> T acc
SigS.scanL
           (\ (Int
n,sig y
ptr) Int
d -> Int -> Int -> sig y -> (Int, sig y)
forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
SigG.dropMarginRem Int
margin (Int
nInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
d) sig y
ptr)
           (Int
0, sig y
sampledTone)
           (T Int -> (Int -> T Int -> T Int) -> T Int -> T Int
forall b a. b -> (a -> T a -> b) -> T a -> b
SigS.switchL T Int
skips
               (\Int
s -> Int -> T Int -> T Int
forall a. a -> T a -> T a
SigS.cons (Int
s Int -> Int -> Int
forall a. C a => a -> a -> a
- (Int
ipOffset Int -> Int -> Int
forall a. C a => a -> a -> a
+ Int
periodInt)))
               T Int
skips)
{-
*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double]
*Synthesizer.Generic.ToneModulation> let marginLeap = Interpolation.Margin 1 3; marginStep = Interpolation.Margin 2 2
*Synthesizer.Generic.ToneModulation> List.map (Data.Tuple.HT.mapSnd List.transpose) $ ToneMod.oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)
[((0.28888888888888875,0.40000000000000124),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"]),((0.8588888888888888,0.27000000000000046),["bcdefghijklmnopqrstuvwxyz","klmnopqrstuvwxyz","tuvwxyz"]),((0.13888888888888884,0.7500000000000004),["hijklmnopqrstuvwxyz","qrstuvwxyz","z"]),((0.2288888888888887,0.9400000000000017),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])]
*Synthesizer.Generic.ToneModulation> oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases)
StateSignal.fromList [((0.4,0.3999999999999999),StateSignal.fromList ["fghijklmnopqrstuvwxyz","opqrstuvwxyz","xyz"]),((0.97,0.2699999999999996),StateSignal.fromList ["abcdefghijklmnopqrstuvwxyz","jklmnopqrstuvwxyz","stuvwxyz"]),((0.25,0.75),StateSignal.fromList ["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])]

They do only match when input list is large enough
-}

checkNonNeg :: (Ord a, Additive.C a, Show a) => a -> a
checkNonNeg :: forall a. (Ord a, C a, Show a) => a -> a
checkNonNeg a
x =
   if a
xa -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
forall a. C a => a
zero
     then [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"unexpected negative number: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
x)
     else a
x

makeCell :: (SigG.Transform sig y) => Int -> sig y -> Cell sig y
makeCell :: forall (sig :: * -> *) y.
Transform sig y =>
Int -> sig y -> Cell sig y
makeCell Int
periodInt =
   (sig y -> Bool) -> T (sig y) -> T (sig y)
forall a. (a -> Bool) -> T a -> T a
SigS.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (sig y -> Bool) -> sig y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig y -> Bool
forall sig. Read sig => sig -> Bool
SigG.null) (T (sig y) -> T (sig y))
-> (sig y -> T (sig y)) -> sig y -> T (sig y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (sig y -> sig y) -> sig y -> T (sig y)
forall a. (a -> a) -> a -> T a
SigS.iterate (Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop Int
periodInt)


oscillatorCoords :: (RealField.C t) =>
    Int -> t ->
    (t, SigS.T t) -> (Phase.T t, SigS.T t) ->
    SigS.T (ToneMod.Coords t)
oscillatorCoords :: forall t. C t => Int -> t -> (t, T t) -> (T t, T t) -> T (Coords t)
oscillatorCoords Int
periodInt t
period
       (t
shape0, T t
shapes) (T t
phase, T t
freqs) =
    let shapeOffsets :: T (Int, t)
shapeOffsets =
           ((Int, t) -> t -> (Int, t)) -> (Int, t) -> T t -> T (Int, t)
forall acc x. (acc -> x -> acc) -> acc -> T x -> T acc
SigS.scanL
              (\(Int
_,t
s) t
c -> t -> (Int, t)
forall b. C b => t -> (b, t)
forall a b. (C a, C b) => a -> (b, a)
splitFraction (t
st -> t -> t
forall a. C a => a -> a -> a
+t
c))
              (t -> (Int, t)
forall b. C b => t -> (b, t)
forall a b. (C a, C b) => a -> (b, a)
splitFraction t
shape0) T t
shapes
        phases :: T (T t)
phases =
           -- FIXME: could be made without the dangerous irrefutable pattern
           let Just (t
s,T t
ss) =
                  T t -> Maybe (t, T t)
forall a. T a -> Maybe (a, T a)
SigS.viewL (T t -> Maybe (t, T t)) -> T t -> Maybe (t, T t)
forall a b. (a -> b) -> a -> b
$
                  ((Int, t) -> t) -> T (Int, t) -> T t
forall a b. (a -> b) -> T a -> T b
SigS.map (\(Int
n,t
_) -> Int -> t
forall a b. (C a, C b) => a -> b
fromIntegral Int
n t -> t -> t
forall a. C a => a -> a -> a
/ t
period) (T (Int, t) -> T t) -> T (Int, t) -> T t
forall a b. (a -> b) -> a -> b
$
                  T (Int, t)
shapeOffsets
           in  T t -> T t (T t)
forall a. C a => T a -> T a (T a)
Osci.freqMod
                  (t -> T t -> T t
forall a. C a => a -> T a -> T a
Phase.decrement t
s T t
phase)  -- phase - s
               T t (T t) -> T t -> T (T t)
forall (sig :: * -> *) a b.
(Transform sig a, Transform sig b) =>
T a b -> sig a -> sig b
`Causal.apply`
                  ((t -> t -> t) -> T t -> T t -> T t
forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith (-) T t
freqs T t
ss)
    in  ((Int, t) -> T t -> Coords t)
-> T (Int, t) -> T (T t) -> T (Coords t)
forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith
           (\(Int
d,t
s) T t
p -> (Int
d, Int -> t -> (t, T t) -> (Int, (t, t))
forall a. C a => Int -> a -> (a, T a) -> (Int, (a, a))
ToneMod.flattenShapePhase Int
periodInt t
period (t
s,T t
p)))
           T (Int, t)
shapeOffsets
           T (T t)
phases

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

limitMinRelativeValues :: (Additive.C t, Ord t) =>
   t -> (t, SigS.T t) -> (t, SigS.T t)
limitMinRelativeValues :: forall t. (C t, Ord t) => t -> (t, T t) -> (t, T t)
limitMinRelativeValues t
xMin (t
x0, T t
xs) =
   let x1 :: t
x1 = t
xMint -> t -> t
forall a. C a => a -> a -> a
-t
x0
   in  if t
x1t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<=t
forall a. C a => a
zero
         then (t
x0, T t
xs)
         else (t
xMin,
               (t -> t -> Maybe (t, t)) -> t -> T t -> T t
forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
SigS.crochetL
                  (\t
x t
lim ->
                     let d :: t
d = t
xt -> t -> t
forall a. C a => a -> a -> a
-t
lim
                     in  (t, t) -> Maybe (t, t)
forall a. a -> Maybe a
Just ((t, t) -> Maybe (t, t)) -> (t, t) -> Maybe (t, t)
forall a b. (a -> b) -> a -> b
$ if t
dt -> t -> Bool
forall a. Ord a => a -> a -> Bool
>=t
forall a. C a => a
zero
                           then (t
d,t
forall a. C a => a
zero) else (t
forall a. C a => a
zero, t -> t
forall a. C a => a -> a
negate t
d)) t
x1 T t
xs)
{-
Test.QuickCheck.test (\x (y,zi) -> let z=List.map abs zi in  Data.Tuple.HT.mapSnd SigS.toList (limitMinRelativeValues x (y, SigS.fromList z)) == ToneMod.limitMinRelativeValues (x::Int) y z)
-}