{-# LANGUAGE NoImplicitPrelude #-}
{- |
Copyright   :  (c) Henning Thielemann 2006
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes


Avoid importing this module.
Better use functions from
"Synthesizer.Plain.Oscillator" and
"Synthesizer.Basic.Wave"

Input data is interpreted as samples of data on a cylinder
in the following form:

> |*          |
> |   *       |
> |      *    |
> |         * |
> | *         |
> |    *      |
> |       *   |
> |          *|
> |  *        |
> |     *     |
> |        *  |


> -----------
> *
>     *
>         *
>  *
>      *
>          *
>   *
>       *
>           *
>    *
>        *
> -----------

We have to interpolate in the parallelograms.

-}
module Synthesizer.Plain.ToneModulation (
   Cell,
   interpolateCell,

   Prototype,
   makePrototype,
   sampledToneCell,

   oscillatorCells,
   seekCell,
   oscillatorSuffixes,

   -- this function fits better in the Oscillator module
   freqsToPhases,

   -- for testing
   dropFrac,
   dropRem,
   propDropFrac,
   propDropRem,
   oscillatorCoords,
   integrateFractional,
   limitRelativeShapes,
   limitMinRelativeValues,
   limitMaxRelativeValues,
   limitMaxRelativeValuesNonNeg,
   ) where

import qualified Synthesizer.Basic.ToneModulation as ToneMod
import qualified Synthesizer.Basic.Phase as Phase

import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.Plain.Interpolation as Interpolation
import Synthesizer.Interpolation (Margin, )

import Control.Monad (guard, )

import qualified Data.List       as List
import qualified Data.List.HT    as ListHT
import qualified Data.List.Match as ListMatch
import Data.Array (Array, (!), listArray, )
import Data.Tuple.HT (mapPair, mapSnd, forcePair, )
import Data.Ord.HT (limit, )

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

import qualified Number.NonNegative       as NonNeg
import qualified Number.NonNegativeChunky as Chunky

import NumericPrelude.Numeric
import NumericPrelude.Base



-- * general helpers

type Cell y = Sig.T (Sig.T y)

interpolateCell ::
   Interpolation.T a y ->
   Interpolation.T b y ->
   (a, b) ->
   Cell y -> y
interpolateCell :: forall a y b. T a y -> T b y -> (a, b) -> Cell y -> y
interpolateCell T a y
ipLeap T b y
ipStep (a
qLeap,b
qStep) =
   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) -> (Cell y -> T y) -> Cell y -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (T y -> y) -> Cell y -> T y
forall a b. (a -> b) -> [a] -> [b]
map (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)


-- * array based shape variable wave

data Prototype t y =
   Prototype {
      forall t y. Prototype t y -> Margin
protoMarginLeap,
      forall t y. Prototype t y -> Margin
protoMarginStep  :: Margin,
      forall t y. Prototype t y -> Int
protoIpOffset    :: Int,
      forall t y. Prototype t y -> t
protoPeriod      :: t,
      forall t y. Prototype t y -> Int
protoPeriodInt   :: Int,
      forall t y. Prototype t y -> (t, t)
protoShapeLimits :: (t,t),
      forall t y. Prototype t y -> Array Int y
protoArray       :: Array Int y
   }


makePrototype :: (RealField.C t) =>
   Margin ->
   Margin ->
   Int -> t -> Sig.T y -> Prototype t y
makePrototype :: forall t y.
C t =>
Margin -> Margin -> Int -> t -> T y -> Prototype t y
makePrototype Margin
marginLeap Margin
marginStep Int
periodInt t
period T y
tone =
   let ipOffset :: Int
ipOffset =
          Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt
       len :: Int
len = T y -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length T y
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 :: (t, t)
limits =
          if Int
lower Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
upper
            then [Char] -> (t, t)
forall a. HasCallStack => [Char] -> a
error [Char]
"min>max"
            else (Int -> t
forall a b. (C a, C b) => a -> b
fromIntegral Int
lower, Int -> t
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 :: t
protoPeriod      = t
period,
          protoPeriodInt :: Int
protoPeriodInt   = Int
periodInt,
          protoShapeLimits :: (t, t)
protoShapeLimits = (t, t)
limits,
          protoArray :: Array Int y
protoArray       = (Int, Int) -> T y -> Array Int y
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int -> Int
forall a. Enum a => a -> a
pred Int
len) T y
tone
       }

sampledToneCell :: (RealField.C t) =>
   Prototype t y -> t -> Phase.T t -> ((t,t), Cell y)
sampledToneCell :: forall t y. C t => Prototype t y -> t -> T t -> ((t, t), Cell y)
sampledToneCell Prototype t y
p t
shape T t
phase =
   let (Int
n, (t, t)
q) =
          Int -> t -> (t, T t) -> (Int, (t, t))
forall a. C a => Int -> a -> (a, T a) -> (Int, (a, a))
ToneMod.flattenShapePhase (Prototype t y -> Int
forall t y. Prototype t y -> Int
protoPeriodInt Prototype t y
p) (Prototype t y -> t
forall t y. Prototype t y -> t
protoPeriod Prototype t y
p)
             ((t, t) -> t -> t
forall a. Ord a => (a, a) -> a -> a
limit (Prototype t y -> (t, t)
forall t y. Prototype t y -> (t, t)
protoShapeLimits Prototype t y
p) t
shape, T t
phase)
   in  ((t, t)
q,
        (Int -> T y) -> [Int] -> [T y]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> y) -> [Int] -> T y
forall a b. (a -> b) -> [a] -> [b]
map (Prototype t y -> Array Int y
forall t y. Prototype t y -> Array Int y
protoArray Prototype t y
p Array Int y -> Int -> y
forall i e. Ix i => Array i e -> i -> e
! ) ([Int] -> T y) -> (Int -> [Int]) -> Int -> T y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Prototype t y -> Int
forall t y. Prototype t y -> Int
protoPeriodInt Prototype t y
p Int -> Int -> Int
forall a. C a => a -> a -> a
+)) ([Int] -> [T y]) -> [Int] -> [T y]
forall a b. (a -> b) -> a -> b
$
        Int -> [Int]
forall a. Enum a => a -> [a]
enumFrom (Int
n Int -> Int -> Int
forall a. C a => a -> a -> a
- Prototype t y -> Int
forall t y. Prototype t y -> Int
protoIpOffset Prototype t y
p))


{-
  M = ((1,1)^T, (periodRound, period-periodRound)^T)

  equation for the line
   0 = (nStep - offset ipStep) +
       (nLeap - offset ipLeap) * periodInt

   <(1,periodInt), (offset ipStep, offset ipLeap)>
        = <(1,periodInt), (nStep,nLeap)>
   d = <a,x>
     = <a,M^-1*M*x>
     = <(M^-T)*a,M*x>
     = <(M^-T)*a,y>
   b = (M^-T)*a
   required:
      y0 such that y1=0
      y0 such that y1=period

   The line {x : d = <a,x>} converted to (shape,phase) coordinates
   has constant shape and meets all phases.
-}



-- * lazy oscillator


oscillatorCells :: (RealField.C t) =>
    Margin ->
    Margin ->
    Int -> t ->
    Sig.T y -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T ((t,t), Cell y)
oscillatorCells :: forall t y.
C t =>
Margin
-> Margin
-> Int
-> t
-> T y
-> (t, T t)
-> (T t, T t)
-> T ((t, t), Cell y)
oscillatorCells
       Margin
marginLeap Margin
marginStep Int
periodInt t
period T y
sampledTone (t, T t)
shapes (T t, T t)
freqs =
    (((t, T t), Cell y) -> ((t, t), Cell y))
-> [((t, T t), Cell y)] -> [((t, t), Cell y)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> t -> ((t, T t), Cell y) -> ((t, t), Cell y)
forall t y.
C t =>
Int -> t -> ((t, T t), Cell y) -> ((t, t), Cell y)
seekCell Int
periodInt t
period) ([((t, T t), Cell y)] -> [((t, t), Cell y)])
-> [((t, T t), Cell y)] -> [((t, t), Cell y)]
forall a b. (a -> b) -> a -> b
$
    Margin
-> Margin
-> Int
-> t
-> T y
-> (t, T t)
-> (T t, T t)
-> [((t, T t), Cell y)]
forall t y.
C t =>
Margin
-> Margin
-> Int
-> t
-> T y
-> (t, T t)
-> (T t, T t)
-> T ((t, T t), Cell y)
oscillatorSuffixes
        Margin
marginLeap Margin
marginStep Int
periodInt t
period T y
sampledTone (t, T t)
shapes (T t, T t)
freqs

seekCell :: (RealField.C t) =>
    Int -> t ->
    ((t, Phase.T t), Cell y) -> ((t,t), Cell y)
seekCell :: forall t y.
C t =>
Int -> t -> ((t, T t), Cell y) -> ((t, t), Cell y)
seekCell Int
periodInt t
period =
    {- n will be zero within the data.
       We would need it only for extrapolation at the end.
       But this does not happen, since we limit the shape control parameter accordingly.
    -}
    (\((t, T t)
coords, Cell y
ptr) ->
       let (Int
k,(t, t)
q) = 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, T t)
coords
       in  if Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0
             then [Char] -> ((t, t), Cell y)
forall a. HasCallStack => [Char] -> a
error [Char]
"ToneModulation.oscillatorCells: k>0"
             else ((t, t)
q, Int -> Cell y -> Cell y
forall a. Int -> [a] -> [a]
drop (Int
periodIntInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
k) Cell y
ptr))

oscillatorSuffixes :: (RealField.C t) =>
    Margin ->
    Margin ->
    Int -> t -> Sig.T y ->
    (t, Sig.T t) -> (Phase.T t, Sig.T t) ->
    Sig.T ((t, Phase.T t), Cell y)
oscillatorSuffixes :: forall t y.
C t =>
Margin
-> Margin
-> Int
-> t
-> T y
-> (t, T t)
-> (T t, T t)
-> T ((t, T t), Cell y)
oscillatorSuffixes
       Margin
marginLeap Margin
marginStep Int
periodInt t
period T y
sampledTone (t, T t)
shapes (T t, T t)
freqs =
    let ptrs :: [T y]
ptrs =
           [T y] -> [T y]
forall a. [[a]] -> [[a]]
List.transpose ([T y] -> [T y]) -> [T y] -> [T y]
forall a b. (a -> b) -> a -> b
$
           (T y -> Bool) -> [T y] -> [T y]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (T y -> Bool) -> T y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T y -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([T y] -> [T y]) -> [T y] -> [T y]
forall a b. (a -> b) -> a -> b
$
           (T y -> T y) -> T y -> [T y]
forall a. (a -> a) -> a -> [a]
iterate (Int -> T y -> T y
forall a. Int -> [a] -> [a]
drop Int
periodInt) T y
sampledTone
        ipOffset :: Int
ipOffset =
           Int
periodInt Int -> Int -> Int
forall a. C a => a -> a -> a
+
           Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt
{- I tried to switch integrateFractional and limitRelativeShapes
   in order to have a position where I can easily add phase distortion.
   However, limitting skip values after integrateFractional
   does not work this way, since once we start setting skip values to zero,
   we had to clear the fractional parts of the shape coordinate, too.
        (firstSkip:allSkips,coords) =
           unzip $
           integrateFractional period shapes freqs
        (skip,skips) =
           limitRelativeShapes marginLeap marginStep
              periodInt sampledTone (firstSkip,allSkips)
-}
        (Int
skip:[Int]
skips,[(t, T t)]
coords) =
           [(Int, (t, T t))] -> ([Int], [(t, T t)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, (t, T t))] -> ([Int], [(t, T t)]))
-> [(Int, (t, T t))] -> ([Int], [(t, T t)])
forall a b. (a -> b) -> a -> b
$
           t -> (t, T t) -> (T t, T t) -> [(Int, (t, T t))]
forall t. C t => t -> (t, T t) -> (T t, T t) -> T (Skip t)
integrateFractional t
period
              (Margin -> Margin -> Int -> T y -> (t, T t) -> (t, T t)
forall t y.
(C t, Ord t) =>
Margin -> Margin -> Int -> T y -> (t, T t) -> (t, T t)
limitRelativeShapes Margin
marginLeap Margin
marginStep Int
periodInt T y
sampledTone (t, T t)
shapes)
              (T t, T t)
freqs
    in  [(t, T t)] -> [[T y]] -> [((t, T t), [T y])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(t, T t)]
coords ([[T y]] -> [((t, T t), [T y])]) -> [[T y]] -> [((t, T t), [T y])]
forall a b. (a -> b) -> a -> b
$
        ((Int, [T y]) -> [T y]) -> [(Int, [T y])] -> [[T y]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
n,[T y]
ptr) ->
               if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0
                 then [Char] -> [T y]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [T y]) -> [Char] -> [T y]
forall a b. (a -> b) -> a -> b
$ [Char]
"ToneModulation.oscillatorCells: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                              [Char]
"limit of shape parameter is buggy"
                 else [T y]
ptr) ([(Int, [T y])] -> [[T y]]) -> [(Int, [T y])] -> [[T y]]
forall a b. (a -> b) -> a -> b
$
        [(Int, [T y])] -> [(Int, [T y])]
forall a. HasCallStack => [a] -> [a]
tail ([(Int, [T y])] -> [(Int, [T y])])
-> [(Int, [T y])] -> [(Int, [T y])]
forall a b. (a -> b) -> a -> b
$
        ((Int, [T y]) -> Int -> (Int, [T y]))
-> (Int, [T y]) -> [Int] -> [(Int, [T y])]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl
           {- since we clip the coordinates before calling oscillatorCells
              we do not need 'dropRem', since 'drop' would never go beyond the list end -}
           (\ (Int
n,[T y]
ptr0) Int
d0 -> Int -> [T y] -> (Int, [T y])
forall a. Int -> T a -> (Int, T a)
dropRem (Int
nInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
d0) [T y]
ptr0)
           (Int
0,[T y]
ptrs)
           ((Int
skip Int -> Int -> Int
forall a. C a => a -> a -> a
- Int
ipOffset) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
skips)

dropFrac :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a)
dropFrac :: forall i a. C i => i -> T a -> (Int, i, T a)
dropFrac =
   let recourse :: a -> b -> [a] -> (a, b, [a])
recourse a
acc b
n [a]
xt =
          if b
nb -> b -> Bool
forall a. Ord a => a -> a -> Bool
>=b
1
            then
               case [a]
xt of
                  a
_:[a]
xs -> a -> b -> [a] -> (a, b, [a])
recourse (a -> a
forall a. Enum a => a -> a
succ a
acc) (b
nb -> b -> b
forall a. C a => a -> a -> a
-b
1) [a]
xs
                  [] -> (a
acc, b
n, [])
            else (a
acc,b
n,[a]
xt)
   in  Int -> i -> [a] -> (Int, i, [a])
forall {b} {a} {a}.
(Ord b, C b, Enum a) =>
a -> b -> [a] -> (a, b, [a])
recourse Int
0

dropFrac' :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a)
dropFrac' :: forall i a. C i => i -> T a -> (Int, i, T a)
dropFrac' =
   let recourse :: t -> a -> [a] -> (t, a, [a])
recourse t
acc a
n [a]
xt =
          (t, a, [a])
-> ((a, [a]) -> (t, a, [a])) -> Maybe (a, [a]) -> (t, a, [a])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
             (t
acc,a
n,[a]
xt)
             (t -> a -> [a] -> (t, a, [a])
recourse (t -> t
forall a. Enum a => a -> a
succ t
acc) (a
na -> a -> a
forall a. C a => a -> a -> a
-a
1) ([a] -> (t, a, [a]))
-> ((a, [a]) -> [a]) -> (a, [a]) -> (t, a, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd)
             (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
na -> a -> Bool
forall a. Ord a => a -> a -> Bool
>=a
1) Maybe () -> Maybe (a, [a]) -> Maybe (a, [a])
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
ListHT.viewL [a]
xt)
   in  Int -> i -> [a] -> (Int, i, [a])
forall {t} {a} {a}.
(Enum t, C a, Ord a) =>
t -> a -> [a] -> (t, a, [a])
recourse Int
0

propDropFrac :: (RealField.C i, Eq a) => i -> Sig.T a -> Bool
propDropFrac :: forall i a. (C i, Eq a) => i -> T a -> Bool
propDropFrac i
n T a
xs =
   i -> T a -> (Int, i, T a)
forall i a. C i => i -> T a -> (Int, i, T a)
dropFrac i
n T a
xs (Int, i, T a) -> (Int, i, T a) -> Bool
forall a. Eq a => a -> a -> Bool
== i -> T a -> (Int, i, T a)
forall i a. C i => i -> T a -> (Int, i, T a)
dropFrac' i
n T a
xs



dropRem :: Int -> Sig.T a -> (Int, Sig.T a)
dropRem :: forall a. Int -> T a -> (Int, T a)
dropRem =
   let recourse :: a -> [a] -> (a, [a])
recourse a
n [a]
xt =
          if a
na -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
0
            then
               case [a]
xt of
                  a
_:[a]
xs -> a -> [a] -> (a, [a])
recourse (a -> a
forall a. Enum a => a -> a
pred a
n) [a]
xs
                  [] -> (a
n, [])
            else (a
n,[a]
xt)
   in  Int -> [a] -> (Int, [a])
forall {a} {a}. (Ord a, C a, Enum a) => a -> [a] -> (a, [a])
recourse

dropRem' :: Int -> Sig.T a -> (Int, Sig.T a)
dropRem' :: forall a. Int -> T a -> (Int, T a)
dropRem' =
   let recourse :: a -> [a] -> (a, [a])
recourse a
n [a]
xt =
          (a, [a]) -> ((a, [a]) -> (a, [a])) -> Maybe (a, [a]) -> (a, [a])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
             (a
n,[a]
xt)
             (a -> [a] -> (a, [a])
recourse (a -> a
forall a. Enum a => a -> a
pred a
n) ([a] -> (a, [a])) -> ((a, [a]) -> [a]) -> (a, [a]) -> (a, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [a]) -> [a]
forall a b. (a, b) -> b
snd)
             (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
na -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
0) Maybe () -> Maybe (a, [a]) -> Maybe (a, [a])
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
ListHT.viewL [a]
xt)
   in  Int -> [a] -> (Int, [a])
forall {a} {a}. (Enum a, Ord a, C a) => a -> [a] -> (a, [a])
recourse

propDropRem :: (Eq a) => Int -> Sig.T a -> Bool
propDropRem :: forall a. Eq a => Int -> T a -> Bool
propDropRem Int
n T a
xs =
   Int -> T a -> (Int, T a)
forall a. Int -> T a -> (Int, T a)
dropRem Int
n T a
xs (Int, T a) -> (Int, T a) -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> T a -> (Int, T a)
forall a. Int -> T a -> (Int, T a)
dropRem' Int
n T a
xs

{-
*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropRem n (xs::[Int]))
OK, passed 100 tests.
*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropFrac (n::Rational) (xs::[Int]))
OK, passed 100 tests.
-}


oscillatorCoords :: (RealField.C t) =>
    Int -> t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.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, T t)
shapes (T t, T t)
freqs =
   ((Int, (t, T t)) -> Coords t) -> [(Int, (t, T t))] -> [Coords t]
forall a b. (a -> b) -> [a] -> [b]
map (((t, T t) -> (Int, (t, t))) -> (Int, (t, T t)) -> Coords t
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (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)) ([(Int, (t, T t))] -> [Coords t])
-> [(Int, (t, T t))] -> [Coords t]
forall a b. (a -> b) -> a -> b
$
   t -> (t, T t) -> (T t, T t) -> [(Int, (t, T t))]
forall t. C t => t -> (t, T t) -> (T t, T t) -> T (Skip t)
integrateFractional t
period (t, T t)
shapes (T t, T t)
freqs
{-
mapM print $ take 30 $ let period = 1/0.07::Double in oscillatorCoords (round period) period 0 0 (repeat 0.1) (repeat 0.01)

*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 1) (repeat 0.07)

*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 0.25) (repeat 0.0175)
-}


integrateFractional :: (RealField.C t) =>
    t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Skip t)
integrateFractional :: forall t. C t => t -> (t, T t) -> (T t, T t) -> T (Skip t)
integrateFractional t
period (t
shape0, T t
shapes) (T t
phase, T t
freqs) =
    let shapeOffsets :: [(Int, t)]
shapeOffsets =
           ((Int, t) -> t -> (Int, t)) -> (Int, t) -> T t -> [(Int, t)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
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 =
           let (t
s:T t
ss) = ((Int, t) -> t) -> [(Int, t)] -> T t
forall a b. (a -> b) -> [a] -> [b]
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) [(Int, t)]
shapeOffsets
           in  T t -> T t -> T (T t)
forall a. C a => T a -> T a -> T (T a)
freqsToPhases
                  (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 a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) T t
freqs T t
ss)
    in  ((Int, t) -> T t -> Skip t) -> [(Int, t)] -> T (T t) -> [Skip t]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
           (\(Int
d,t
s) T t
p -> (Int
d, (t
s,T t
p)))
           [(Int, t)]
shapeOffsets
           T (T t)
phases


-- this function fits better in the Oscillator module
{- |
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
-}
freqsToPhases :: RealRing.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)
freqsToPhases :: forall a. C a => T a -> T a -> T (T a)
freqsToPhases T a
phase T a
freq = (T a -> a -> T a) -> T a -> T a -> [T a]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl ((a -> T a -> T a) -> T a -> a -> T a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> T a -> T a
forall a. C a => a -> T a -> T a
Phase.increment) T a
phase T a
freq



limitRelativeShapes :: (Ring.C t, Ord t) =>
    Margin ->
    Margin ->
    Int -> Sig.T y -> (t, Sig.T t) -> (t, Sig.T t)
limitRelativeShapes :: forall t y.
(C t, Ord t) =>
Margin -> Margin -> Int -> T y -> (t, T t) -> (t, T t)
limitRelativeShapes Margin
marginLeap Margin
marginStep Int
periodInt T y
sampledTone =
    let -- len = List.genericLength sampledTone
        len :: T (T t)
len = [T t] -> T (T t)
forall a. C a => [a] -> T a
Chunky.fromChunks (T y -> T t -> [T t]
forall a b. [a] -> b -> [b]
ListMatch.replicate T y
sampledTone T t
forall a. C a => a
one)
        (T (T t)
minShape, T (T t)
maxShape) =
           Margin -> Margin -> Int -> T (T t) -> (T (T t), T (T t))
forall t. C t => Margin -> Margin -> Int -> t -> (t, t)
ToneMod.shapeLimits Margin
marginLeap Margin
marginStep Int
periodInt T (T t)
len
        fromChunky :: T (T t) -> t
fromChunky = T t -> t
forall a. T a -> a
NonNeg.toNumber   (T t -> t) -> (T (T t) -> T t) -> T (T t) -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T (T t) -> T t
forall a. C a => T a -> a
Chunky.toNumber
        toChunky :: t -> T (T t)
toChunky   = T t -> T (T t)
forall a. C a => a -> T a
Chunky.fromNumber (T t -> T (T t)) -> (t -> T t) -> t -> T (T t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> T t
forall a. (Ord a, C a) => a -> T a
NonNeg.fromNumber
    in  (T (T t) -> t, [T (T t)] -> T t)
-> (T (T t), [T (T t)]) -> (t, T t)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (T (T t) -> t
fromChunky, (T (T t) -> t) -> [T (T t)] -> T t
forall a b. (a -> b) -> [a] -> [b]
map T (T t) -> t
fromChunky) ((T (T t), [T (T t)]) -> (t, T t))
-> ((t, T t) -> (T (T t), [T (T t)])) -> (t, T t) -> (t, T t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (T (T t) -> [T (T t)] -> (T (T t), [T (T t)]))
-> (T (T t), [T (T t)]) -> (T (T t), [T (T t)])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (T (T t) -> T (T t) -> [T (T t)] -> (T (T t), [T (T t)])
forall a. (C a, Ord a) => a -> a -> T a -> (a, T a)
limitMaxRelativeValuesNonNeg T (T t)
maxShape) ((T (T t), [T (T t)]) -> (T (T t), [T (T t)]))
-> ((t, T t) -> (T (T t), [T (T t)]))
-> (t, T t)
-> (T (T t), [T (T t)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (t -> T (T t), T t -> [T (T t)])
-> (t, T t) -> (T (T t), [T (T t)])
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (t -> T (T t)
toChunky, (t -> T (T t)) -> T t -> [T (T t)]
forall a b. (a -> b) -> [a] -> [b]
map t -> T (T t)
toChunky) ((t, T t) -> (T (T t), [T (T t)]))
-> ((t, T t) -> (t, T t)) -> (t, T t) -> (T (T t), [T (T t)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (t -> T t -> (t, T t)) -> (t, T t) -> (t, T t)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (t -> t -> T t -> (t, T t)
forall a. (C a, Ord a) => a -> a -> T a -> (a, T a)
limitMinRelativeValues (T (T t) -> t
fromChunky T (T t)
minShape))
{-
*Synthesizer.Plain.Oscillator> let ip = Interpolation.linear in limitRelativeShapes ip ip 13 (take 100 $ iterate (1+) (0::Double)) (0::Double, cycle [0.5,1.5])
(13.0,[0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5*** Exception: Numeric.NonNegative.Chunky.-: negative number
-}


limitMinRelativeValues :: (Additive.C a, Ord a) =>
   a -> a -> Sig.T a -> (a, Sig.T a)
limitMinRelativeValues :: forall a. (C a, Ord a) => a -> a -> T a -> (a, T a)
limitMinRelativeValues a
xMin a
x0 T a
xs =
   let ([(a, a)]
ys,[(a, a)]
zs) =
          ((a, a) -> Bool) -> [(a, a)] -> ([(a, a)], [(a, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
forall a. C a => a
zero)(a -> Bool) -> ((a, a) -> a) -> (a, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, a) -> a
forall a b. (a, b) -> a
fst) (T a -> T a -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a -> a -> a) -> a -> T a -> T a
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl a -> a -> a
forall a. C a => a -> a -> a
(+) (a
x0a -> a -> a
forall a. C a => a -> a -> a
-a
xMin) T a
xs) (a
x0a -> T a -> T a
forall a. a -> [a] -> [a]
:T a
xs))
   in  case [(a, a)]
ys of
          [] -> (a
x0,T a
xs)
          ((a, a)
_:[(a, a)]
yr) -> (a
xMin, [(a, a)] -> a -> T a
forall a b. [a] -> b -> [b]
ListMatch.replicate [(a, a)]
yr a
forall a. C a => a
zero T a -> T a -> T a
forall a. [a] -> [a] -> [a]
++
              case [(a, a)]
zs of
                 [] -> []
                 ((a, a)
z:[(a, a)]
zr) -> (a, a) -> a
forall a b. (a, b) -> a
fst (a, a)
z a -> T a -> T a
forall a. a -> [a] -> [a]
: ((a, a) -> a) -> [(a, a)] -> T a
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> a
forall a b. (a, b) -> b
snd [(a, a)]
zr)

limitMaxRelativeValues :: (Additive.C a, Ord a) =>
   a -> a -> Sig.T a -> (a, Sig.T a)
limitMaxRelativeValues :: forall a. (C a, Ord a) => a -> a -> T a -> (a, T a)
limitMaxRelativeValues a
xMax a
x0 T a
xs =
   let (T a
ys,T a
zs) =
          (a -> Bool) -> T a -> (T a, T a)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
forall a. C a => a
zero) ((a -> a -> a) -> a -> T a -> T a
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (-) (a
xMaxa -> a -> a
forall a. C a => a -> a -> a
-a
x0) T a
xs)
   in  (a, T a) -> (a, T a)
forall a b. (a, b) -> (a, b)
forcePair ((a, T a) -> (a, T a)) -> (a, T a) -> (a, T a)
forall a b. (a -> b) -> a -> b
$
       (a, T a) -> (T a -> a -> (a, T a)) -> T a -> (a, T a)
forall b a. b -> ([a] -> a -> b) -> [a] -> b
ListHT.switchR
          (a
xMax, T a -> a -> T a
forall a b. [a] -> b -> [b]
ListMatch.replicate T a
xs a
forall a. C a => a
zero)
          (\ T a
yl a
yr -> (a
x0, T a -> T a -> T a
forall b a. [b] -> [a] -> [a]
ListMatch.take T a
yl T a
xs T a -> T a -> T a
forall a. [a] -> [a] -> [a]
++ T a -> T a -> T a
forall b a. [b] -> [a] -> [a]
ListMatch.take T a
zs (a
yr a -> T a -> T a
forall a. a -> [a] -> [a]
: a -> T a
forall a. a -> [a]
repeat a
forall a. C a => a
zero)))
          T a
ys

{- |
Avoids negative numbers and thus can be used with Chunky numbers.
-}
limitMaxRelativeValuesNonNeg :: (Additive.C a, Ord a) =>
   a -> a -> Sig.T a -> (a, Sig.T a)
limitMaxRelativeValuesNonNeg :: forall a. (C a, Ord a) => a -> a -> T a -> (a, T a)
limitMaxRelativeValuesNonNeg a
xMax a
x0 T a
xs =
   let ([(Bool, a)]
ys,[(Bool, a)]
zs) =
          ((Bool, a) -> Bool) -> [(Bool, a)] -> ([(Bool, a)], [(Bool, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool, a) -> Bool
forall a b. (a, b) -> a
fst (((Bool, a) -> a -> (Bool, a)) -> (Bool, a) -> T a -> [(Bool, a)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Bool
_,a
acc) a
d -> a -> a -> (Bool, a)
forall a. (C a, Ord a) => a -> a -> (Bool, a)
safeSub a
acc a
d) (a -> a -> (Bool, a)
forall a. (C a, Ord a) => a -> a -> (Bool, a)
safeSub a
xMax a
x0) T a
xs)
   in  (a, T a) -> (a, T a)
forall a b. (a, b) -> (a, b)
forcePair ((a, T a) -> (a, T a)) -> (a, T a) -> (a, T a)
forall a b. (a -> b) -> a -> b
$
       (a, T a)
-> ([(Bool, a)] -> (Bool, a) -> (a, T a))
-> [(Bool, a)]
-> (a, T a)
forall b a. b -> ([a] -> a -> b) -> [a] -> b
ListHT.switchR
          (a
xMax, T a -> a -> T a
forall a b. [a] -> b -> [b]
ListMatch.replicate T a
xs a
forall a. C a => a
zero)
          (\ [(Bool, a)]
yl ~(Bool
_,a
yr) -> (a
x0, [(Bool, a)] -> T a -> T a
forall b a. [b] -> [a] -> [a]
ListMatch.take [(Bool, a)]
yl T a
xs T a -> T a -> T a
forall a. [a] -> [a] -> [a]
++ [(Bool, a)] -> T a -> T a
forall b a. [b] -> [a] -> [a]
ListMatch.take [(Bool, a)]
zs (a
yr a -> T a -> T a
forall a. a -> [a] -> [a]
: a -> T a
forall a. a -> [a]
repeat a
forall a. C a => a
zero)))
          [(Bool, a)]
ys
{-
*Synthesizer.Plain.Oscillator> limitMaxRelativeValuesNonNeg (let inf = 1+inf in inf) (0::Chunky.T NonNeg.Rational) (repeat 2.5)
-}

safeSub :: (Additive.C a, Ord a) => a -> a -> (Bool, a)
safeSub :: forall a. (C a, Ord a) => a -> a -> (Bool, a)
safeSub a
a a
b = (a
aa -> a -> Bool
forall a. Ord a => a -> a -> Bool
>=a
b, a
aa -> a -> a
forall a. C a => a -> a -> a
-a
b)