synthesizer-0.2: src/Synthesizer/State/ToneModulation.hs
module Synthesizer.State.ToneModulation where
import qualified Synthesizer.Basic.ToneModulation as ToneMod
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.Transcendental as Trans
import qualified Algebra.RealField as RealField
-- import qualified Algebra.Field as Field
-- import qualified Algebra.Real as Real
-- import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import Data.Ord.HT (limit, )
import NumericPrelude
-- import qualified Prelude as P
import PreludeBase
import Prelude ()
type Cell sig y = SigS.T (sig y)
-- cells are organised in a transposed style, when compared with Plain.ToneModulation
interpolateCell ::
(SigG.Read sig y) =>
Interpolation.T a y ->
Interpolation.T b y ->
(a, b) ->
Cell sig y -> y
interpolateCell ipLeap ipStep (qLeap,qStep) =
Interpolation.func ipLeap qLeap .
SigS.map (Interpolation.func ipStep qStep . SigG.toState)
data Prototype sig a v =
Prototype {
protoMarginLeap,
protoMarginStep :: Interpolation.Margin,
protoIpOffset :: Int,
protoPeriod :: a,
protoPeriodInt :: Int,
protoShapeLimits :: (a,a),
protoSignal :: sig v
}
makePrototype ::
(RealField.C a, SigG.Read sig v) =>
Interpolation.Margin ->
Interpolation.Margin ->
a -> sig v -> Prototype sig a v
makePrototype marginLeap marginStep period tone =
let periodInt = round period
ipOffset =
ToneMod.interpolationOffset marginLeap marginStep periodInt
len = SigG.length tone
(lower,upper) =
ToneMod.shapeLimits marginLeap marginStep periodInt len
limits =
if lower > upper
then error "min>max"
else
(fromIntegral lower, fromIntegral upper)
in Prototype {
protoMarginLeap = marginLeap,
protoMarginStep = marginStep,
protoIpOffset = ipOffset,
protoPeriod = period,
protoPeriodInt = periodInt,
protoShapeLimits = limits,
protoSignal = tone
}
sampledToneCell ::
(RealField.C a, SigG.Transform sig v) =>
Prototype sig a v -> a -> Phase.T a -> ((a,a), Cell sig v)
sampledToneCell p shape phase =
let (n, q) =
ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p)
(limit (protoShapeLimits p) shape, phase)
in (q,
SigS.iterate (SigG.drop (protoPeriodInt p)) $
SigG.drop (n - protoIpOffset p) $
protoSignal 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
marginLeap marginStep period sampledTone shapes freqs =
let periodInt = round period
margin =
ToneMod.interpolationNumber marginLeap marginStep periodInt
ipOffset =
ToneMod.interpolationOffset marginLeap marginStep periodInt
(skips,coords) =
-- unzip requires recomputation
SigS.unzip $
oscillatorCoords periodInt period
(limitRelativeShapes marginLeap marginStep periodInt shapes)
freqs
in SigS.zipWith
{-
n will be zero within the data body.
It's only needed for extrapolation at the end.
Is it really needed?
-}
(\(k,q) (_n,ptr) ->
(q, makeCell periodInt $
SigG.drop (checkNonNeg $ periodInt+k) ptr))
coords $
SigS.switchL (error "list of pointers must not be empty") (flip const) $
SigS.scanL
(\ (n,ptr) d -> SigG.dropMarginRem margin (n+d) ptr)
(0, sampledTone)
(SigS.switchL skips
(\s -> SigS.cons (s - (ipOffset + periodInt)))
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 x =
if x<zero
then error ("unexpected negative number: " ++ show x)
else x
makeCell :: (SigG.Transform sig y) => Int -> sig y -> Cell sig y
makeCell periodInt =
SigS.takeWhile (not . SigG.null) .
SigS.iterate (SigG.drop periodInt)
oscillatorCoords :: (RealField.C t) =>
Int -> t ->
(t, SigS.T t) -> (Phase.T t, SigS.T t) ->
SigS.T (ToneMod.Coords t)
oscillatorCoords periodInt period
(shape0, shapes) (phase, freqs) =
let shapeOffsets =
SigS.scanL
(\(_,s) c -> splitFraction (s+c))
(splitFraction shape0) shapes
phases =
-- FIXME: could be made without the dangerous irrefutable pattern
let Just (s,ss) =
SigS.viewL $
SigS.map (\(n,_) -> fromIntegral n / period) $
shapeOffsets
in freqsToPhases
(Phase.decrement s phase) -- phase - s
`Causal.apply`
(SigS.zipWith (-) freqs ss)
in SigS.zipWith
(\(d,s) p -> (d, ToneMod.flattenShapePhase periodInt period (s,p)))
shapeOffsets
phases
limitRelativeShapes :: (RealField.C t) =>
Interpolation.Margin ->
Interpolation.Margin ->
Int -> (t, SigS.T t) -> (t, SigS.T t)
limitRelativeShapes marginLeap marginStep periodInt =
limitMinRelativeValues $ fromIntegral $
ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt
limitMinRelativeValues :: (Additive.C t, Ord t) =>
t -> (t, SigS.T t) -> (t, SigS.T t)
limitMinRelativeValues xMin (x0, xs) =
let x1 = xMin-x0
in if x1<=zero
then (x0, xs)
else (xMin,
SigS.crochetL
(\x lim ->
let d = x-lim
in Just $ if d>=zero
then (d,zero) else (zero, negate d)) x1 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)
-}
-- * handling of phases as needed for oscillators
{-# INLINE freqsToPhases #-}
{- |
Convert a list of phase steps into a list of momentum phases.
phase is a number in the interval [0,1).
freq contains the phase steps.
The last element is omitted.
-}
freqsToPhases :: RealField.C a =>
Phase.T a -> Causal.T a (Phase.T a)
freqsToPhases =
Causal.scanL (flip Phase.increment)
{- |
Like 'freqsToPhases' but the first element is omitted.
-}
{-# INLINE freqsToPhasesSync #-}
freqsToPhasesSync :: RealField.C a =>
Phase.T a -> Causal.T a (Phase.T a)
freqsToPhasesSync =
Causal.crochetL
(\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1))