{-# LANGUAGE NoImplicitPrelude #-}
{- |
Several functions that add a loop to a sampled sound.
This way you can obtain an infinite sound
that consumes only finite space.
-}
module Synthesizer.Generic.Loop (
   simple,
   fade,

   timeReverse,
   TimeControl,
   timeControlSine,
   timeControlZigZag,
   ) where

import qualified Synthesizer.Generic.Signal    as SigG
import qualified Synthesizer.Generic.Cut       as CutG
import qualified Synthesizer.Generic.Wave      as WaveG

import qualified Synthesizer.Basic.Wave        as Wave
import qualified Synthesizer.Basic.Phase       as Phase

import qualified Synthesizer.State.Signal      as SigS
import qualified Synthesizer.State.Control     as CtrlS
import qualified Synthesizer.State.Oscillator  as OsciS

import qualified Synthesizer.Interpolation as Interpolation

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Module         as Module
import qualified Algebra.RealField      as RealField
import qualified Algebra.RealRing       as RealRing

import NumericPrelude.Numeric
import NumericPrelude.Base


{- |
Most simple of looping:
You give start and length of the loop body
and this part is repeated.
The data behind start+length is ignored.
-}
simple :: (CutG.Transform sig) => Int -> Int -> sig -> sig
simple :: forall sig. Transform sig => Int -> Int -> sig -> sig
simple Int
len Int
start sig
xs =
   let (sig
prefix, sig
suffix) = Int -> sig -> (sig, sig)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
start sig
xs
       loopBody :: sig
loopBody = Int -> sig -> sig
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
len sig
suffix
   in  sig -> sig -> sig
forall sig. Monoid sig => sig -> sig -> sig
CutG.append sig
prefix (sig -> sig
forall sig. Monoid sig => sig -> sig
CutG.cycle sig
loopBody)

{- |
Create a smooth loop by cross-fading a part
with delayed versions of itself.
The loop length will be rounded to the next smaller even number.
-}
fade :: (SigG.Transform sig yv, Trans.C y, Module.C y yv) =>
   y -> Int -> Int -> sig yv -> sig yv
fade :: forall (sig :: * -> *) yv y.
(Transform sig yv, C y, C y yv) =>
y -> Int -> Int -> sig yv -> sig yv
fade y
dummy Int
loopLen2 Int
start sig yv
xs =
   let loopLen :: Int
loopLen = Int -> Int -> Int
forall a. C a => a -> a -> a
div Int
loopLen2 Int
2
       (sig yv
prefix, sig yv
loopOut) = Int -> sig yv -> (sig yv, sig yv)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt (Int
startInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
loopLen) sig yv
xs
       loopIn :: sig yv
loopIn = Int -> sig yv -> sig yv
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
start sig yv
prefix
       loopBody :: sig yv
loopBody =
          (y -> yv -> yv -> yv) -> T y -> T yv -> sig yv -> sig yv
forall (sig :: * -> *) c d a b.
(Transform sig c, Transform sig d) =>
(a -> b -> c -> d) -> T a -> T b -> sig c -> sig d
SigG.zipWithState3
             (\y
s yv
x yv
y ->
                let s2 :: y
s2 = y
0.5y -> y -> y
forall a. C a => a -> a -> a
*y
s y -> y -> y
forall a. a -> a -> a
`asTypeOf` y
dummy
                in  (y
0.5y -> y -> y
forall a. C a => a -> a -> a
-y
s2)y -> yv -> yv
forall a v. C a v => a -> v -> v
*>yv
x yv -> yv -> yv
forall a. C a => a -> a -> a
+ (y
0.5y -> y -> y
forall a. C a => a -> a -> a
+y
s2)y -> yv -> yv
forall a v. C a v => a -> v -> v
*>yv
y)
             (y -> y -> T y
forall a. C a => a -> a -> T a
CtrlS.cosine y
0 (Int -> y
forall a b. (C a, C b) => a -> b
fromIntegral Int
loopLen))
             (sig yv -> T yv
forall y. Storage (sig y) => sig y -> T y
forall (sig :: * -> *) y.
(Read0 sig, Storage (sig y)) =>
sig y -> T y
SigG.toState sig yv
loopIn)
             sig yv
loopOut
   in  sig yv -> sig yv -> sig yv
forall sig. Monoid sig => sig -> sig -> sig
CutG.append sig yv
prefix (sig yv -> sig yv
forall sig. Monoid sig => sig -> sig
CutG.cycle sig yv
loopBody)

{- |
Resample a sampled sound with a smooth loop
using our time manipulation algorithm.
Time is first controlled linearly,
then switches to a sine or triangular control.
Loop start must be large enough in order provide enough spare data
for interpolation at the beginning
and loop start plus length must preserve according space at the end.
One period is enough space for linear interpolation.

In order to get a loopable sound with finite space
we have to reduce the loop length to a multiple of a wave period.
We will also modify the period a little bit,
such that in our loop body there is an integral number of periods.

We return the modified period and the looped sound.
-}
{-# INLINE timeReverse #-}
timeReverse ::
   (SigG.Write sig yv, RealField.C q, Module.C q yv) =>
   SigG.LazySize ->
   Interpolation.T q yv ->
   Interpolation.T q yv ->
   TimeControl q ->
   q -> q -> (q, sig yv) -> (q, sig yv)
timeReverse :: forall (sig :: * -> *) yv q.
(Write sig yv, C q, C q yv) =>
LazySize
-> T q yv
-> T q yv
-> TimeControl q
-> q
-> q
-> (q, sig yv)
-> (q, sig yv)
timeReverse LazySize
lazySize T q yv
ipLeap T q yv
ipStep
      TimeControl q
timeCtrlWave q
loopLen q
loopStart (q
period0, sig yv
sample) =
   let (q
period, T q
timeCtrl) =
          TimeControl q -> q -> q -> (q, T q)
forall a. C a => TimeControl a -> a -> a -> (a, T a)
timeControl TimeControl q
timeCtrlWave q
period0 (q
loopLenq -> q -> q
forall a. C a => a -> a -> a
/q
2)
       wave :: q -> T q yv
wave = T q yv -> T q yv -> q -> sig yv -> q -> T q yv
forall a (sig :: * -> *) v.
(C a, Transform sig v) =>
T a v -> T a v -> a -> sig v -> a -> T a v
WaveG.sampledTone T q yv
ipLeap T q yv
ipStep q
period sig yv
sample
       loopCenter :: Int
loopCenter = q -> Int
forall b. C b => q -> b
forall a b. (C a, C b) => a -> b
round (q -> Int) -> q -> Int
forall a b. (a -> b) -> a -> b
$ q
loopStart q -> q -> q
forall a. C a => a -> a -> a
+ q
loopLenq -> q -> q
forall a. C a => a -> a -> a
/q
2
       loop :: sig yv
loop =
          LazySize -> T yv -> sig yv
forall (sig :: * -> *) y. Write sig y => LazySize -> T y -> sig y
SigG.fromState LazySize
lazySize (T yv -> sig yv) -> T yv -> sig yv
forall a b. (a -> b) -> a -> b
$
          (q -> T q yv) -> T q -> T q -> T q -> T yv
forall a c b. C a => (c -> T a b) -> T a -> T c -> T a -> T b
OsciS.shapeFreqMod q -> T q yv
wave
             (q -> T q
forall a. C a => a -> T a
Phase.fromRepresentative (q -> T q) -> q -> T q
forall a b. (a -> b) -> a -> b
$ Int -> q
forall a b. (C a, C b) => a -> b
fromIntegral Int
loopCenter q -> q -> q
forall a. C a => a -> a -> a
/ q
period)
             ((q -> q) -> T q -> T q
forall a b. (a -> b) -> T a -> T b
SigS.map (Int -> q
forall a b. (C a, C b) => a -> b
fromIntegral Int
loopCenter q -> q -> q
forall a. C a => a -> a -> a
+) T q
timeCtrl)
             (q -> T q
forall a. a -> T a
SigS.repeat (q -> q
forall a. C a => a -> a
recip q
period))
   in  (q
period,
        sig yv -> sig yv -> sig yv
forall sig. Monoid sig => sig -> sig -> sig
CutG.append
           (Int -> sig yv -> sig yv
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
loopCenter sig yv
sample)
           (sig yv -> sig yv
forall sig. Monoid sig => sig -> sig
CutG.cycle sig yv
loop))

timeControl ::
   (RealField.C a) =>
   TimeControl a ->
   a -> a -> (a, SigS.T a)
timeControl :: forall a. C a => TimeControl a -> a -> a -> (a, T a)
timeControl (TimeControl a
slope T a a
wave) a
period0 a
loopDepth0 =
   let numberOfWaves :: a
numberOfWaves =
          Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$
          (a -> Int
forall b. C b => a -> b
forall a b. (C a, C b) => a -> b
floor(a
slopea -> a -> a
forall a. C a => a -> a -> a
*a
loopDepth0a -> a -> a
forall a. C a => a -> a -> a
/a
period0) :: Int)
       loopLenInt :: Int
loopLenInt = a -> Int
forall b. C b => a -> b
forall a b. (C a, C b) => a -> b
floor (a
numberOfWaves a -> a -> a
forall a. C a => a -> a -> a
* a
period0)
       loopLen :: a
loopLen = Int -> a
forall a b. (C a, C b) => a -> b
fromIntegral Int
loopLenInt
       period :: a
period = a
loopLen a -> a -> a
forall a. C a => a -> a -> a
/ a
numberOfWaves
       loopDepth :: a
loopDepth = a
loopLen a -> a -> a
forall a. C a => a -> a -> a
/ a
slope
   in  (a
period,
        Int -> T a -> T a
forall a. Int -> T a -> T a
SigS.take Int
loopLenInt (T a -> T a) -> T a -> T a
forall a b. (a -> b) -> a -> b
$
        (a -> a) -> T a -> T a
forall a b. (a -> b) -> T a -> T b
SigS.map (a
loopDepth a -> a -> a
forall a. C a => a -> a -> a
*) (T a -> T a) -> T a -> T a
forall a b. (a -> b) -> a -> b
$
        T a a -> T a -> a -> T a
forall a b. C a => T a b -> T a -> a -> T b
OsciS.static T a a
wave T a
forall a. C a => a
zero (a -> a
forall a. C a => a -> a
recip a
loopLen))


data TimeControl a = TimeControl a (Wave.T a a)

timeControlSine :: (Trans.C a) => TimeControl a
timeControlSine :: forall a. C a => TimeControl a
timeControlSine = a -> T a a -> TimeControl a
forall a. a -> T a a -> TimeControl a
TimeControl (a
2a -> a -> a
forall a. C a => a -> a -> a
*a
forall a. C a => a
pi) T a a
forall a. C a => T a a
Wave.sine

timeControlZigZag :: (RealRing.C a) => TimeControl a
timeControlZigZag :: forall a. C a => TimeControl a
timeControlZigZag = a -> T a a -> TimeControl a
forall a. a -> T a a -> TimeControl a
TimeControl a
4 T a a
forall a. (Ord a, C a) => T a a
Wave.triangle