-- Copyright 2016 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds, KindSignatures, TypeOperators, TypeApplications #-}
-- | Low level rendering of 'Sample.Sample's.
module Synth.Sampler.RenderSample (
    render
    , ratioCloseEnough
    , envelopeDuration
    , predictFileDuration
#ifdef TESTING
    , module Synth.Sampler.RenderSample
#endif
) where
import           GHC.TypeLits (KnownNat)

import qualified Util.Audio.Audio as Audio
import qualified Util.Audio.File as File
import qualified Util.Audio.Resample as Resample
import qualified Util.Audio.Rubberband as Rubberband
import qualified Util.Num as Num
import qualified Util.Segment as Segment
import qualified Util.Test.ApproxEq as ApproxEq

import qualified Perform.RealTime as RealTime
import qualified Synth.Lib.AUtil as AUtil
import qualified Synth.Sampler.Sample as Sample
import qualified Synth.Shared.Config as Config
import qualified Synth.Shared.Signal as Signal

import           Global
import           Synth.Types


render :: Resample.Config -> RealTime -> Sample.Sample -> IO AUtil.Audio
render :: Config -> X -> Sample -> IO Audio
render Config
config X
start (Sample.Sample SamplePath
filename Frames
offset Signal
envelope Signal
pan Signal
ratios
        Stretch
stretch) = do
    (IO ()
close, Audio
audio) <- forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
Frames -> SamplePath -> IO (IO (), AudioIO rate chan)
File.readFromClose Frames
offset SamplePath
filename
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        X -> Signal -> Audio -> Audio
applyPan X
nowS Signal
pan forall a b. (a -> b) -> a -> b
$
        IO () -> X -> Signal -> Audio -> Audio
applyEnvelope IO ()
close X
nowS Signal
envelope forall a b. (a -> b) -> a -> b
$
        forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
Config -> Signal -> X -> AudioIO rate chan -> AudioIO rate chan
resample Config
config Signal
ratios X
start forall a b. (a -> b) -> a -> b
$
        -- This has to go right after file read, since it doesn't stream and
        -- doesn't have saveable state.  The lack of streaming though means
        -- that I read the entire sample into memory, and also don't get the
        -- early-abort if applyEnvelope goes to 0.
        --
        -- TODO I don't restore rubberband's internal state though, so it seems
        -- like this could yield artifacts.
        Stretch -> Audio -> Audio
applyRubberband Stretch
stretch forall a b. (a -> b) -> a -> b
$
        Audio
audio
    where
    nowS :: X
nowS = Frames -> X
AUtil.toSeconds Frames
now
    -- The sample stream thinks it's starting at a relative frame 0, so I need
    -- to shift all the signals back so they also line up to frame 0.
    now :: Frames
now = Config -> Frames
Resample._now Config
config

-- | This is polymorphic in chan, though it's only used with 2.  I experimented
-- reading mono files as 1, and expanding the channel after resample and
-- envelope, but the time improvement was tiny, so I dropped it.  It seems like
-- even fancy resampling is cheap compared to read and write time.
resample :: (KnownNat rate, KnownNat chan)
    => Resample.Config -> Signal.Signal -> RealTime
    -> Audio.AudioIO rate chan -> Audio.AudioIO rate chan
resample :: forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
Config -> Signal -> X -> AudioIO rate chan -> AudioIO rate chan
resample Config
config Signal
ratiosUnshifted X
start Audio (ResourceT IO) rate chan
audio
    -- Don't do any work if it's close enough to 1.  This is likely to be
    -- common, so worth optimizing.
    | Just Double
val <- forall {k} (kind :: k). X -> Signal kind -> Maybe Double
Signal.constant_val_from X
0 Signal
ratios, Double -> Bool
ratioCloseEnough Double
val =
        forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(HasCallStack, MonadIO m) =>
Bool -> Text -> Audio m rate chan -> Audio m rate chan
Audio.assertIn (Maybe SavedState
state forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing)
            (Text
"expected no state for un-resampled, got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Maybe SavedState
state) forall a b. (a -> b) -> a -> b
$
        -- resampleBy synchronizes, but File.readFrom doesn't.
        forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(Monad m, KnownNat chan) =>
Frames -> Frames -> Audio m rate chan -> Audio m rate chan
Audio.synchronizeToSize (Config -> Frames
Resample._now Config
config)
            (Config -> Frames
Resample._blockSize Config
config) (forall {rate :: Nat}. Audio (ResourceT IO) rate chan
silence forall a. Semigroup a => a -> a -> a
<> Audio (ResourceT IO) rate chan
audio)
    | Bool
otherwise =
        -- If I'm prepending silence, tweak resample's idea of _now.  It uses
        -- that to align its output blocks.  Also, since that's the real sample
        -- start time, I use it to shift ratios to 0, as mentioned in 'render'.
        let config2 :: Config
config2 = Frames -> Config -> Config
addNow Frames
silenceF Config
config
        in forall {rate :: Nat}. Audio (ResourceT IO) rate chan
silence forall a. Semigroup a => a -> a -> a
<> forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
Config -> Signal -> AudioIO rate chan -> AudioIO rate chan
Resample.resampleBy Config
config2 Signal
ratios Audio (ResourceT IO) rate chan
audio
    where
    sampleStart :: X
sampleStart = Frames -> X
AUtil.toSeconds forall a b. (a -> b) -> a -> b
$ Config -> Frames
Resample._now Config
config forall a. Num a => a -> a -> a
+ Frames
silenceF
    -- The resample always starts at 0 in the ratios, so shift it back to
    -- account for when the sample starts.
    ratios :: Signal
ratios = forall {k} (kind :: k). X -> Signal kind -> Signal kind
Signal.shift (-X
sampleStart) Signal
ratiosUnshifted
    silence :: Audio (ResourceT IO) rate chan
silence = forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(Monad m, KnownNat chan) =>
Frames -> Audio m rate chan -> Audio m rate chan
Audio.take Frames
silenceF forall (m :: * -> *) (chan :: Nat) (rate :: Nat).
(Monad m, KnownNat chan) =>
Audio m rate chan
Audio.silence
    silenceF :: Frames
silenceF = forall a. Ord a => a -> a -> a
max Frames
0 (X -> Frames
AUtil.toFrames X
start forall a. Num a => a -> a -> a
- Config -> Frames
Resample._now Config
config)
    state :: Maybe SavedState
state = Config -> Maybe SavedState
Resample._state Config
config

-- | More or less a semitone / 100 cents / 10.  Anything narrower than this
-- probably isn't perceptible.
ratioCloseEnough :: Signal.Y -> Bool
ratioCloseEnough :: Double -> Bool
ratioCloseEnough Double
val = forall a. ApproxEq a => Double -> a -> a -> Bool
ApproxEq.eq Double
close Double
val Double
1
    where
    close :: Double
close = Double
1.05 forall a. Fractional a => a -> a -> a
/ Double
1000

addNow :: Audio.Frames -> Resample.Config -> Resample.Config
addNow :: Frames -> Config -> Config
addNow Frames
frames Config
config = Config
config { _now :: Frames
Resample._now = Frames
frames forall a. Num a => a -> a -> a
+ Config -> Frames
Resample._now Config
config }

applyEnvelope :: IO () -> RealTime -> Signal.Signal -> AUtil.Audio
    -> AUtil.Audio
applyEnvelope :: IO () -> X -> Signal -> Audio -> Audio
applyEnvelope IO ()
close X
start Signal
sig
    | Just Double
val <- forall {k} (kind :: k). X -> Signal kind -> Maybe Double
Signal.constant_val_from X
start Signal
sig =
        if forall a. ApproxEq a => Double -> a -> a -> Bool
ApproxEq.eq Double
0.01 Double
val Double
1 then forall a. a -> a
id
            else forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
Monad m =>
Float -> Audio m rate chan -> Audio m rate chan
Audio.gain (Float -> Float
AUtil.dbToLinear (Double -> Float
Num.d2f Double
val))
    | Bool
otherwise = Audio1 -> Audio -> Audio
AUtil.volume forall a b. (a -> b) -> a -> b
$ Audio1 -> Audio1
clipEnd forall a b. (a -> b) -> a -> b
$ X -> Signal -> Audio1
realizeSignal X
start Signal
sig
    where
    clipEnd :: Audio1 -> Audio1
clipEnd = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id
        (forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(Monad m, KnownNat rate, KnownNat chan) =>
m () -> Double -> Audio m rate chan -> Audio m rate chan
Audio.takeCloseS (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
close) forall b c a. (b -> c) -> (a -> b) -> a -> c
. X -> Double
RealTime.to_seconds)
        (X -> Signal -> Maybe X
envelopeDuration X
start Signal
sig)

applyPan :: RealTime -> Signal.Signal -> AUtil.Audio -> AUtil.Audio
applyPan :: X -> Signal -> Audio -> Audio
applyPan X
start Signal
sig
    | Just Double
val <- forall {k} (kind :: k). X -> Signal kind -> Maybe Double
Signal.constant_val_from X
start Signal
sig =
        forall (m :: * -> *) (rate :: Nat).
Monad m =>
Float -> Audio m rate Channels -> Audio m rate Channels
Audio.panConstant (Double -> Float
Num.d2f Double
val)
    | Bool
otherwise = forall (m :: * -> *) (rate :: Nat).
Monad m =>
Audio m rate 1 -> Audio m rate Channels -> Audio m rate Channels
Audio.pan (X -> Signal -> Audio1
realizeSignal X
start Signal
sig)

realizeSignal :: RealTime -> Signal.Signal -> AUtil.Audio1
realizeSignal :: X -> Signal -> Audio1
realizeSignal X
start Signal
sig = forall (m :: * -> *) (rate :: Nat).
(Monad m, KnownNat rate) =>
Bool -> [(Double, Double)] -> Audio m rate 1
Audio.linear Bool
True forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (X -> Double
RealTime.to_seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract X
start)) forall a b. (a -> b) -> a -> b
$
    forall {k} (kind :: k). X -> Signal kind -> [(X, Double)]
Signal.clip_before_pairs X
start Signal
sig

-- | Get the duration implied by the envelope, or Nothing if the envelope won't
-- shorten the duration.
--
-- If the envelope ends on a 0, I can clip the sample short.  Not just for
-- performance, but because checkpoints rely on the note durations being
-- accurate.
envelopeDuration :: RealTime -> Signal.Signal -> Maybe RealTime
envelopeDuration :: X -> Signal -> Maybe X
envelopeDuration X
start = forall {a}. (Eq a, Num a) => [(X, a)] -> Maybe X
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Signal kind -> [(X, Double)]
Signal.to_pairs_desc
    where
    go :: [(X, a)] -> Maybe X
go [(X
_, a
0)] = forall a. a -> Maybe a
Just X
0
    go ((X
_, a
0) : xys :: [(X, a)]
xys@((X
_, a
0) : [(X, a)]
_)) = [(X, a)] -> Maybe X
go [(X, a)]
xys
    go ((X
x, a
0) : [(X, a)]
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max X
0 (X
x forall a. Num a => a -> a -> a
- X
start)
    go [(X, a)]
_ = forall a. Maybe a
Nothing

-- * rubberband

applyRubberband :: Sample.Stretch -> AUtil.Audio -> AUtil.Audio
applyRubberband :: Stretch -> Audio -> Audio
applyRubberband (Sample.Stretch StretchMode
mode Double
timeRatio Double
pitchRatio) Audio
audio
    | Double -> Bool
stretchThreshold Double
timeRatio Bool -> Bool -> Bool
&& Double -> Bool
stretchThreshold Double
pitchRatio = Audio
audio
    | Bool
otherwise = forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
Config -> AudioIO rate chan -> AudioIO rate chan
Rubberband.offline Config
config Audio
audio
    where
    config :: Config
config = Config
Rubberband.config
        { _options :: [Option]
Rubberband._options = StretchMode -> [Option]
modeToOptions StretchMode
mode
        , _timeRatio :: Double
Rubberband._timeRatio = Double
timeRatio
        , _pitchRatio :: Double
Rubberband._pitchRatio = Double
pitchRatio
        }

modeToOptions :: Sample.StretchMode -> [Rubberband.Option]
modeToOptions :: StretchMode -> [Option]
modeToOptions = \case
    StretchMode
Sample.StretchDefault -> []
    StretchMode
Sample.StretchPercussive -> [Option]
Rubberband.percussiveOptions

stretchThreshold :: Double -> Bool
stretchThreshold :: Double -> Bool
stretchThreshold = forall a. ApproxEq a => Double -> a -> a -> Bool
ApproxEq.eq Double
0.01 Double
1

-- * duration

-- | Predict how long a sample will be if resampled with the given ratio
-- signal.
predictFileDuration :: Double -> Signal.Signal -> FilePath -> IO Audio.Frames
predictFileDuration :: Double -> Signal -> SamplePath -> IO Frames
predictFileDuration Double
timeRatio Signal
ratios SamplePath
fname =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Frames -> Frames
stretch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Frames -> Frames
predictDuration Signal
ratios) forall a b. (a -> b) -> a -> b
$
        forall a. SamplePath -> Maybe a -> IO a
File.throwEnoent SamplePath
fname forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SamplePath -> IO (Maybe Frames)
File.duration SamplePath
fname
    where
    stretch :: Frames -> Frames
stretch
        | Double -> Bool
stretchThreshold Double
timeRatio = forall a. a -> a
id
        | Bool
otherwise = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Double
timeRatio) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

type FramesF = Double

toFramesF :: Audio.Frames -> FramesF
toFramesF :: Frames -> Double
toFramesF = forall a b. (Integral a, Num b) => a -> b
fromIntegral

predictDuration :: Signal.Signal -> Audio.Frames -> Audio.Frames
predictDuration :: Signal -> Frames -> Frames
predictDuration Signal
ratios Frames
sampleDur = case forall {k} (kind :: k). X -> Signal kind -> Maybe Double
Signal.constant_val_from X
0 Signal
ratios of
    -- I can also do this optimization if it's constant over the duration of
    -- the sample.  But to know if that's the case I have to do an integral
    -- intersection and I think that's the same as the non-optimized case.
    Just Double
y -> Double -> Frames
toFrames forall a b. (a -> b) -> a -> b
$ Frames -> Double
toFramesF Frames
sampleDur forall a. Num a => a -> a -> a
* Double
y
    Maybe Double
Nothing -> Double -> Frames
toFrames forall a b. (a -> b) -> a -> b
$
        Double -> Double -> [Segment Double] -> Double
go (Frames -> Double
toFramesF Frames
sampleDur) Double
0 (forall {k} (kind :: k). X -> Signal kind -> [Segment Double]
Signal.clip_before_segments X
0 Signal
ratios)
    where
    toFrames :: Double -> Frames
toFrames = Int -> Frames
Audio.Frames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling
    go :: Double -> Double -> [Segment Double] -> Double
go !Double
input !Double
output segments :: [Segment Double]
segments@(Segment.Segment X
x1 Double
y1 X
x2 Double
y2 : [Segment Double]
rest)
        | Double
input forall a. Ord a => a -> a -> Bool
<= Double
0 = Double
output
        | Double
y1 forall a. Ord a => a -> a -> Bool
<= Double
0 Bool -> Bool -> Bool
|| Double
y2 forall a. Ord a => a -> a -> Bool
<= Double
0 =
            forall a. HasCallStack => SamplePath -> a
error forall a b. (a -> b) -> a -> b
$ SamplePath
"ratio went to 0: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> SamplePath
prettys (forall a. [a] -> a
head [Segment Double]
segments)
        -- TODO verify this is the same
        --  | y1 == y2 = go (input - consumed) (output + consumed * y1) segments
        | Bool
otherwise = Double -> Double -> [Segment Double] -> Double
go (Double
input forall a. Num a => a -> a -> a
- Double
consumed) (Double
output forall a. Num a => a -> a -> a
+ Double
generated)
            (if X
now forall a. Ord a => a -> a -> Bool
>= X
x2 then [Segment Double]
rest else [Segment Double]
segments)
        where
        now :: X
now = -- Debug.tracesp "now"
              --   (input, output, output+generated, head segments) $
            Double -> X
frameToSeconds (Double
output forall a. Num a => a -> a -> a
+ Double
generated)
        -- The number of samples consumed by a ratio segment is the area under
        -- the curve.  But if I run out of input, I need to find the place
        -- where the integral intersects the amount of time left.

        -- The min of where the curve crosess y (runs out of samples), or
        -- just the integral at (x2-x1).
        consumed :: Double
consumed =
            -- Debug.trace_ret "consumed" (input, lineIntegral n k delta) $
            forall a. Ord a => a -> a -> a
min Double
input (Double -> Double -> Double -> Double
lineIntegral Double
n Double
k Double
delta)
        generated :: Double
generated
            | forall a. RealFloat a => a -> Bool
isNaN Double
cross =
                -- Debug.trace_ret "generated" ((n, k, input), (delta, cross)) $
                    Double
delta
            | Bool
otherwise =
                -- Debug.trace_ret "generated" ((n, k, input), (delta, cross)) $
                forall a. Ord a => a -> a -> a
min Double
delta Double
cross
            where cross :: Double
cross = Double -> Double -> Double -> Double
integralCrossesAt Double
n Double
k Double
input
        -- The ratio multiplies the length of the output.  So it winds up being
        -- the integral of the inverse of the curve.  This is the same thing
        -- that happens for tempo curves.  It's because ratio 2 means I consume
        -- input at 1/2 rate, which leads to output*2.
        n :: Double
n = (Double
1forall a. Fractional a => a -> a -> a
/Double
y2 forall a. Num a => a -> a -> a
- Double
1forall a. Fractional a => a -> a -> a
/Double
y1) forall a. Fractional a => a -> a -> a
/ Double
delta
        k :: Double
k = Double
1 forall a. Fractional a => a -> a -> a
/ Double
y1
        delta :: Double
delta = Frames -> Double
toFramesF forall a b. (a -> b) -> a -> b
$ X -> Frames
AUtil.toFrames (X
x2 forall a. Num a => a -> a -> a
- X
x1)

    -- Unreached, because the last segment extends to RealTime.large.
    go Double
_ Double
_ [] = forall a. HasCallStack => SamplePath -> a
error SamplePath
"ran out of segments"

frameToSeconds :: FramesF -> RealTime
frameToSeconds :: Double -> X
frameToSeconds Double
frames =
    Double -> X
RealTime.seconds forall a b. (a -> b) -> a -> b
$ Double
frames forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
Config.samplingRate

-- | Given a line with slope @n@ and offset @k@, find where its integral
-- crosses a @y@ value.  NaN means it reaches that value.
integralCrossesAt :: Double -> Double -> Double -> Double
integralCrossesAt :: Double -> Double -> Double -> Double
integralCrossesAt Double
n Double
k Double
y
    | Double
n forall a. Eq a => a -> a -> Bool
== Double
0 = Double
y forall a. Fractional a => a -> a -> a
/ Double
k
    {-
        nx^2/2 + kx = y
        nx^2 + 2kx = 2y
        nx^2 + 2kx - 2y = 0
        -- quadratic formula, where a = n, b = 2k, c = -2y
        x = (-2k ± sqrt ((2k)^2 - 4n(-2y))) / 2n
        -- I want the right side, so take + only:
        x = (-2k + sqrt ((2k)^2 + 8ny)) / 2n
    -}
    | Bool
otherwise = (-Double
2forall a. Num a => a -> a -> a
*Double
k forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sqrt ((Double
2forall a. Num a => a -> a -> a
*Double
k)forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 forall a. Num a => a -> a -> a
+ Double
8forall a. Num a => a -> a -> a
*Double
nforall a. Num a => a -> a -> a
*Double
y)) forall a. Fractional a => a -> a -> a
/ (Double
2forall a. Num a => a -> a -> a
*Double
n)

-- | Integral of a line with slope @n@ and offset @k@ at @x@.
lineIntegral :: Double -> Double -> Double -> Double
lineIntegral :: Double -> Double -> Double -> Double
lineIntegral Double
n Double
k Double
x = (Double
n forall a. Num a => a -> a -> a
* Double
xforall a b. (Num a, Integral b) => a -> b -> a
^Integer
2) forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
+ Double
kforall a. Num a => a -> a -> a
*Double
x