module Synthesizer.State.ToneModulation (
Cell,
makeCell,
interpolateCell,
Prototype,
makePrototype,
sampledToneCell,
oscillatorCells,
checkNonNeg,
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)
{-# 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) =
forall t y. T t y -> t -> T y -> y
Interpolation.func T a y
ipLeap a
qLeap forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> b) -> T a -> T b
SigS.map (forall t y. T t y -> t -> T y -> y
Interpolation.func T b y
ipStep b
qStep forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall sig. Read sig => sig -> Int
SigG.length sig v
tone
(Int
lower,Int
upper) =
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 forall a. Ord a => a -> a -> Bool
> Int
upper
then forall a. HasCallStack => [Char] -> a
error [Char]
"min>max"
else (forall a b. (C a, C b) => a -> b
fromIntegral Int
lower, 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) =
forall a. C a => Int -> a -> (a, T a) -> (Int, (a, a))
ToneMod.flattenShapePhase (forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoPeriodInt Prototype sig a v
p) (forall (sig :: * -> *) a v. Prototype sig a v -> a
protoPeriod Prototype sig a v
p)
(forall a. Ord a => (a, a) -> a -> a
limit (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,
forall a. (a -> a) -> a -> T a
SigS.iterate (forall sig. Transform sig => Int -> sig -> sig
SigG.drop (forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoPeriodInt Prototype sig a v
p)) forall a b. (a -> b) -> a -> b
$
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Int
n forall a. C a => a -> a -> a
- forall (sig :: * -> *) a v. Prototype sig a v -> Int
protoIpOffset Prototype sig a v
p) forall a b. (a -> b) -> a -> b
$
forall (sig :: * -> *) a v. Prototype sig a v -> sig v
protoSignal Prototype sig a v
p)
{-# DEPRECATED oscillatorCells "This function recomputes the shape and phase signals. Better use Causal.ToneModulation.oscillatorCells" #-}
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 = 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) =
forall a b. T (a, b) -> (T a, T b)
SigS.unzip forall a b. (a -> b) -> a -> b
$
forall t. C t => Int -> t -> (t, T t) -> (T t, T t) -> T (Coords t)
oscillatorCoords Int
periodInt t
period
(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 forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith
(\(Int
k,(t, t)
q) (Int
_n,sig y
ptr) ->
((t, t)
q, forall (sig :: * -> *) y.
Transform sig y =>
Int -> sig y -> Cell sig y
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
checkNonNeg forall a b. (a -> b) -> a -> b
$ Int
periodIntforall a. C a => a -> a -> a
+Int
k) sig y
ptr))
T (Int, (t, t))
coords forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> T a -> b) -> T a -> b
SigS.switchL (forall a. HasCallStack => [Char] -> a
error [Char]
"list of pointers must not be empty") (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) forall a b. (a -> b) -> a -> b
$
forall acc x. (acc -> x -> acc) -> acc -> T x -> T acc
SigS.scanL
(\ (Int
n,sig y
ptr) Int
d -> forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
SigG.dropMarginRem Int
margin (Int
nforall a. C a => a -> a -> a
+Int
d) sig y
ptr)
(Int
0, sig y
sampledTone)
(forall b a. b -> (a -> T a -> b) -> T a -> b
SigS.switchL T Int
skips
(\Int
s -> forall a. a -> T a -> T a
SigS.cons (Int
s forall a. C a => a -> a -> a
- (Int
ipOffset forall a. C a => a -> a -> a
+ Int
periodInt)))
T Int
skips)
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
xforall a. Ord a => a -> a -> Bool
<forall a. C a => a
zero
then forall a. HasCallStack => [Char] -> a
error ([Char]
"unexpected negative number: " forall a. [a] -> [a] -> [a]
++ 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 =
forall a. (a -> Bool) -> T a -> T a
SigS.takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sig. Read sig => sig -> Bool
SigG.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. (a -> a) -> a -> T a
SigS.iterate (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 =
forall acc x. (acc -> x -> acc) -> acc -> T x -> T acc
SigS.scanL
(\(Int
_,t
s) t
c -> forall a b. (C a, C b) => a -> (b, a)
splitFraction (t
sforall a. C a => a -> a -> a
+t
c))
(forall a b. (C a, C b) => a -> (b, a)
splitFraction t
shape0) T t
shapes
phases :: T (T t)
phases =
let Just (t
s,T t
ss) =
forall a. T a -> Maybe (a, T a)
SigS.viewL forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> T a -> T b
SigS.map (\(Int
n,t
_) -> forall a b. (C a, C b) => a -> b
fromIntegral Int
n forall a. C a => a -> a -> a
/ t
period) forall a b. (a -> b) -> a -> b
$
T (Int, t)
shapeOffsets
in forall a. C a => T a -> T a (T a)
Osci.freqMod
(forall a. C a => a -> T a -> T a
Phase.decrement t
s T t
phase)
forall (sig :: * -> *) a b.
(Transform sig a, Transform sig b) =>
T a b -> sig a -> sig b
`Causal.apply`
(forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith (-) T t
freqs T t
ss)
in forall a b c. (a -> b -> c) -> T a -> T b -> T c
SigS.zipWith
(\(Int
d,t
s) T t
p -> (Int
d, 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 =
forall t. (C t, Ord t) => 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, 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
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, T t
xs)
else (t
xMin,
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
xforall a. C a => a -> a -> a
-t
lim
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 T t
xs)