module Synthesizer.State.ToneModulation 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.Transcendental as Trans import qualified Algebra.RealField as RealField -- import qualified Algebra.Field as Field -- import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import Data.Ord.HT (limit, ) import NumericPrelude.Numeric -- import qualified Prelude as P 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 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 } {-# INLINE sampledToneCell #-} 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 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 Osci.freqMod (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) -}