-- Copyright 2017 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

-- | Functions for the 'Warp'.
module Derive.Warp (
    Warp, Linear(..), is_linear, is_identity, warp, unwarp
    , identity, from_signal, compose
    , shift, stretch
    -- * utils
    , unwarp_signal
    -- * compose_hybrid
    , compose_hybrid
) where
import qualified Control.DeepSeq as DeepSeq

import qualified Ui.ScoreTime as ScoreTime
import qualified Perform.RealTime as RealTime
import Perform.RealTime (to_score)
import qualified Perform.Signal as Signal

import Global
import Types


{- | The 'Warp' keeps track of the ScoreTime -> RealTime function, as well
    as its inverse.

    This treats linear warps specially, since they're common and allow some
    optimizations.

    The main transformation is 'compose', but 'shift' and 'stretch' are
    shortcuts for composing with @f(x) = y + shift@ or @f(x) = y * stretch@,
    respectively.

    The confusing thing is that shift and stretch compose with the *input* of
    the function, so @shift n@ is @(`compose` shift n identity)@.  This means
    that @shift 1 . stretch 2@ is actually @(*2) . (+1)@, which makes
    compositions look backwards.  It turns out this is more convenient since
    Deriver level shift and stretch go in left-to-right order since monadic
    effects go left to right:

    > Reader.runReader (Reader.local (+1) . Reader.local (*2) $ Reader.ask) 0

    is 2, not 1.

    There is probably some kind of theory to do with positive position or
    negative position or some such thing, but my tiny brain can't quite get a
    handle on it, so all I can say is that this is the way that makes things
    work out right.
-}
data Warp = WarpFunction !Function | WarpLinear !Linear

data Function = Function {
    Function -> ScoreTime -> RealTime
_warp :: !(ScoreTime -> RealTime)
    , Function -> RealTime -> ScoreTime
_unwarp :: !(RealTime -> ScoreTime)
    -- -- | For debugging.  TODO keep all of them?  Or is it a memory leak?
    -- , _signal :: !Signal.Warp
    }

data Linear = Linear { Linear -> RealTime
_shift :: !RealTime, Linear -> RealTime
_stretch :: !RealTime }
    deriving (Int -> Linear -> ShowS
[Linear] -> ShowS
Linear -> String
(Int -> Linear -> ShowS)
-> (Linear -> String) -> ([Linear] -> ShowS) -> Show Linear
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Linear] -> ShowS
$cshowList :: [Linear] -> ShowS
show :: Linear -> String
$cshow :: Linear -> String
showsPrec :: Int -> Linear -> ShowS
$cshowsPrec :: Int -> Linear -> ShowS
Show)

instance Show Warp where show :: Warp -> String
show = Warp -> String
forall a. Pretty a => a -> String
prettys
instance Pretty Warp where
    pretty :: Warp -> Text
pretty (WarpFunction Function
f) = Text
"((Warp " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty (Function -> ScoreTime -> RealTime
_warp Function
f ScoreTime
0) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty (Function -> ScoreTime -> RealTime
_warp Function
f ScoreTime
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
    pretty (WarpLinear (Linear RealTime
shift RealTime
stretch)) =
        Text
"((Warp *" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
stretch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
shift Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"

-- | I can't really rnf functions, but maybe there will be data in here someday.
instance DeepSeq.NFData Warp where rnf :: Warp -> ()
rnf Warp
_ = ()

is_linear :: Warp -> Maybe Linear
is_linear :: Warp -> Maybe Linear
is_linear (WarpLinear Linear
linear) = Linear -> Maybe Linear
forall a. a -> Maybe a
Just Linear
linear
is_linear Warp
_ = Maybe Linear
forall a. Maybe a
Nothing

is_identity :: Warp -> Bool
is_identity :: Warp -> Bool
is_identity (WarpLinear (Linear RealTime
shift RealTime
stretch)) = RealTime
shift RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
0 Bool -> Bool -> Bool
&& RealTime
stretch RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
1
is_identity Warp
_ = Bool
False

warp :: Warp -> ScoreTime -> RealTime
warp :: Warp -> ScoreTime -> RealTime
warp (WarpFunction Function
f) ScoreTime
t = Function -> ScoreTime -> RealTime
_warp Function
f ScoreTime
t
warp (WarpLinear Linear
w) ScoreTime
t = ScoreTime -> RealTime
to_real ScoreTime
t RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* Linear -> RealTime
_stretch Linear
w RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ Linear -> RealTime
_shift Linear
w

-- | The inverse of 'warp'.  I originally would fail when the RealTime
-- doesn't occur in the Warp, but now I extend it in the same way as
-- 'warp'.  Failing caused awkwardness with events at the end of the score.
unwarp :: Warp -> RealTime -> ScoreTime
unwarp :: Warp -> RealTime -> ScoreTime
unwarp (WarpFunction Function
f) = Function -> RealTime -> ScoreTime
_unwarp Function
f
unwarp (WarpLinear Linear
w) = RealTime -> ScoreTime
to_score (RealTime -> ScoreTime)
-> (RealTime -> RealTime) -> RealTime -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime -> RealTime -> RealTime
forall a. Fractional a => a -> a -> a
/ Linear -> RealTime
_stretch Linear
w) (RealTime -> RealTime)
-> (RealTime -> RealTime) -> RealTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
subtract (Linear -> RealTime
_shift Linear
w)

-- | 1:1 identity warp.  Previously I could detect this to optimize it away,
-- but since 'compose' is cheap now, I might not need that anymore.
identity :: Warp
identity :: Warp
identity = Linear -> Warp
WarpLinear (RealTime -> RealTime -> Linear
Linear RealTime
0 RealTime
1)

signal_identity :: Warp
signal_identity :: Warp
signal_identity = Warp -> Warp
from_signal (Warp -> Warp) -> Warp -> Warp
forall a b. (a -> b) -> a -> b
$ [(RealTime, Y)] -> Warp
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs
    [(RealTime
0, Y
0), (RealTime
RealTime.large, RealTime -> Y
RealTime.to_seconds RealTime
RealTime.large)]

-- | Create a Warp from a signal and its inverse.  This assumes the signal
-- is monotonically increasing.
--
-- Times <0 always pass through unchanged.  This is because warps start at 0,
-- since tracks start at 0, but events may be moved before it.  Since there's
-- no tempo data there, I need to make something up, and I might as well make
-- up id.
-- TODO error on empty signal? or id?
from_signal :: Signal.Warp -> Warp
from_signal :: Warp -> Warp
from_signal Warp
signal = Function -> Warp
WarpFunction (Function -> Warp) -> Function -> Warp
forall a b. (a -> b) -> a -> b
$ Function
    { _warp :: ScoreTime -> RealTime
_warp = ScoreTime -> RealTime
forward
    , _unwarp :: RealTime -> ScoreTime
_unwarp = RealTime -> ScoreTime
backward
    }
    where
    forward :: ScoreTime -> RealTime
forward ScoreTime
t
        | ScoreTime
t ScoreTime -> ScoreTime -> Bool
forall a. Ord a => a -> a -> Bool
< ScoreTime
0 = ScoreTime -> RealTime
to_real ScoreTime
t
        | Bool
otherwise = Y -> RealTime
RealTime.seconds (Y -> RealTime) -> Y -> RealTime
forall a b. (a -> b) -> a -> b
$ RealTime -> Warp -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at (ScoreTime -> RealTime
to_real ScoreTime
t) Warp
signal
    backward :: RealTime -> ScoreTime
backward RealTime
t
        | RealTime
t RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
< RealTime
0 = RealTime -> ScoreTime
to_score RealTime
t
        | Bool
otherwise = Y -> ScoreTime
ScoreTime.from_double (Y -> ScoreTime) -> Y -> ScoreTime
forall a b. (a -> b) -> a -> b
$ RealTime -> Warp -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
t Warp
inverted
        where inverted :: Warp
inverted = Warp -> Warp
forall {k} (kind :: k). Signal kind -> Signal kind
Signal.invert Warp
signal

compose :: Warp -> Warp -> Warp
compose :: Warp -> Warp -> Warp
compose (WarpLinear (Linear RealTime
shift1 RealTime
stretch1))
        (WarpLinear (Linear RealTime
shift2 RealTime
stretch2)) =
    Linear -> Warp
WarpLinear (Linear -> Warp) -> Linear -> Warp
forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> Linear
Linear (RealTime
shift1 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
shift2 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* RealTime
stretch1) (RealTime
stretch1 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* RealTime
stretch2)
compose (WarpFunction (Function ScoreTime -> RealTime
warp1 RealTime -> ScoreTime
unwarp1))
        (WarpFunction (Function ScoreTime -> RealTime
warp2 RealTime -> ScoreTime
unwarp2)) =
    Function -> Warp
WarpFunction (Function -> Warp) -> Function -> Warp
forall a b. (a -> b) -> a -> b
$ Function
        { _warp :: ScoreTime -> RealTime
_warp = ScoreTime -> RealTime
warp1 (ScoreTime -> RealTime)
-> (ScoreTime -> ScoreTime) -> ScoreTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> ScoreTime
to_score (RealTime -> ScoreTime)
-> (ScoreTime -> RealTime) -> ScoreTime -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> RealTime
warp2
        , _unwarp :: RealTime -> ScoreTime
_unwarp = RealTime -> ScoreTime
unwarp2 (RealTime -> ScoreTime)
-> (RealTime -> RealTime) -> RealTime -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> RealTime
to_real (ScoreTime -> RealTime)
-> (RealTime -> ScoreTime) -> RealTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> ScoreTime
unwarp1
        }
compose (WarpLinear Linear
linear) (WarpFunction Function
f) =
    Warp -> Warp -> Warp
compose (Linear -> Warp
to_function Linear
linear) (Function -> Warp
WarpFunction Function
f)
compose (WarpFunction Function
f) (WarpLinear Linear
linear) =
    Warp -> Warp -> Warp
compose (Function -> Warp
WarpFunction Function
f) (Linear -> Warp
to_function Linear
linear)

to_function :: Linear -> Warp
to_function :: Linear -> Warp
to_function Linear
w = ScoreTime -> Warp -> Warp
stretch (RealTime -> ScoreTime
to_score (Linear -> RealTime
_stretch Linear
w)) (Warp -> Warp) -> Warp -> Warp
forall a b. (a -> b) -> a -> b
$
    ScoreTime -> Warp -> Warp
shift (RealTime -> ScoreTime
to_score (Linear -> RealTime
_shift Linear
w)) Warp
signal_identity

-- | "See 'Warp'.
shift :: ScoreTime -> Warp -> Warp
shift :: ScoreTime -> Warp -> Warp
shift ScoreTime
0 Warp
w = Warp
w
shift ScoreTime
x (WarpFunction (Function ScoreTime -> RealTime
warp RealTime -> ScoreTime
unwarp)) = Function -> Warp
WarpFunction (Function -> Warp) -> Function -> Warp
forall a b. (a -> b) -> a -> b
$ Function
    { _warp :: ScoreTime -> RealTime
_warp = ScoreTime -> RealTime
warp (ScoreTime -> RealTime)
-> (ScoreTime -> ScoreTime) -> ScoreTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ScoreTime
x)
    , _unwarp :: RealTime -> ScoreTime
_unwarp = ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
subtract ScoreTime
x (ScoreTime -> ScoreTime)
-> (RealTime -> ScoreTime) -> RealTime -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> ScoreTime
unwarp
    }
shift ScoreTime
x (WarpLinear Linear
linear) = Linear -> Warp
WarpLinear (Linear -> Warp) -> Linear -> Warp
forall a b. (a -> b) -> a -> b
$ Linear
    { _shift :: RealTime
_shift = Linear -> RealTime
_shift Linear
linear RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ Linear -> RealTime
_stretch Linear
linear RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* ScoreTime -> RealTime
to_real ScoreTime
x
    , _stretch :: RealTime
_stretch = Linear -> RealTime
_stretch Linear
linear
    }

-- | See 'Warp'.
--
-- Previously, this would disallow <=0 stretch, but it turns out to be useful
-- to stretch events to 0, and to negative durations.
stretch :: ScoreTime -> Warp -> Warp
stretch :: ScoreTime -> Warp -> Warp
stretch ScoreTime
1 Warp
w = Warp
w
stretch ScoreTime
factor (WarpFunction (Function ScoreTime -> RealTime
warp RealTime -> ScoreTime
unwarp)) = Function -> Warp
WarpFunction (Function -> Warp) -> Function -> Warp
forall a b. (a -> b) -> a -> b
$ Function
    { _warp :: ScoreTime -> RealTime
_warp = ScoreTime -> RealTime
warp (ScoreTime -> RealTime)
-> (ScoreTime -> ScoreTime) -> ScoreTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
*ScoreTime
factor)
    , _unwarp :: RealTime -> ScoreTime
_unwarp = (ScoreTime -> ScoreTime -> ScoreTime
forall a. Fractional a => a -> a -> a
/ScoreTime
factor) (ScoreTime -> ScoreTime)
-> (RealTime -> ScoreTime) -> RealTime -> ScoreTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> ScoreTime
unwarp
    }
stretch ScoreTime
factor (WarpLinear Linear
linear) = Linear -> Warp
WarpLinear (Linear -> Warp) -> Linear -> Warp
forall a b. (a -> b) -> a -> b
$ Linear
    { _shift :: RealTime
_shift = Linear -> RealTime
_shift Linear
linear
    , _stretch :: RealTime
_stretch = ScoreTime -> RealTime
to_real ScoreTime
factor RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* Linear -> RealTime
_stretch Linear
linear
    }

-- * utils

unwarp_signal :: Warp -> Signal.Control -> Signal.Display
unwarp_signal :: Warp -> Control -> Display
unwarp_signal Warp
w = Control -> Display
forall {k1} {k2} (kind1 :: k1) (kind2 :: k2).
Signal kind1 -> Signal kind2
Signal.coerce (Control -> Display) -> (Control -> Control) -> Control -> Display
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime -> RealTime) -> Control -> Control
forall {k} (kind :: k).
(RealTime -> RealTime) -> Signal kind -> Signal kind
Signal.map_x (ScoreTime -> RealTime
to_real (ScoreTime -> RealTime)
-> (RealTime -> ScoreTime) -> RealTime -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warp -> RealTime -> ScoreTime
unwarp Warp
w)

to_real :: ScoreTime -> RealTime
to_real :: ScoreTime -> RealTime
to_real = ScoreTime -> RealTime
RealTime.from_score


-- * compose_hybrid

-- TODO I'll need a different approach.  Can't I modify the signal and then
-- compose normally?
compose_hybrid :: Warp -> Warp -> Warp
compose_hybrid :: Warp -> Warp -> Warp
compose_hybrid Warp
_ Warp
_ = Warp
identity

{-
-- | This is like 'compose', but implements a kind of \"semi-absolute\"
-- composition.  The idea is that it's normal composition until the second
-- signal has a slope of zero.  Normally this would be a discontinuity, but
-- is special cased to force the output to a 1\/1 line.  In effect, it's as
-- if the flat segment were whatever slope is necessary to to generate a slope
-- of 1 when composed with the first signal.
compose_hybrid :: Warp -> Warp -> Warp
compose_hybrid f g = Signal $ run initial $ Vector.generateM (length g) gen
    where
    -- If 'g' starts with a flat segment, I need to start the linear bit in the
    -- right place.
    initial = (at_linear (y_to_x y) f, 0)
        where y = maybe 0 snd (head g)
    run state m = Identity.runIdentity $ Monad.State.evalStateT m state
    -- Where h = f•g:
    -- If g(x_t) == g(x_t-1), then this is a flat segment.
    -- h(x) is simply h(x_t-1) + (x_t - x_t-1), but I have to store an
    -- offset that represents where the signal would be were just right to
    -- produce a slope of 1, so I work backwards:
    -- offset = f-1(h(x)) - g(x_t-1)
    --
    -- If g(x_t) > g(x_t-1), then this is a normal positive slope, and I
    -- have to add the offset: h(x) = f(g(x + offset)).
    --
    -- So the state is (h(x_t-1), offset).
    gen i
        | gy0 == gy = gen_flat gx gx0 gy0
        | otherwise = gen_normal gx gy
        where
        Sample gx gy = Vector.unsafeIndex (sig_vec g) i
        Sample gx0 gy0
            | i == 0 = Sample 0 0
            | otherwise = Vector.unsafeIndex (sig_vec g) (i-1)
    gen_flat gx gx0 gy0 = do
        (y0, _) <- Monad.State.get
        let y = y0 + x_to_y (gx - gx0)
            offset = inverse_at_extend y f - y_to_x gy0
        Monad.State.put (y, offset)
        return $ Sample gx y
    gen_normal gx gy = do
        (_, offset) <- Monad.State.get
        let y = at_linear (y_to_x gy + offset) f
        Monad.State.put (y, offset)
        return $ Sample gx y

-- | This is like 'inverse_at', except that if the Y value is past the end
-- of the signal, it extends the signal as far as necessary.  When used for
-- warp composition or unwarping, this means that the parent warp is too small
-- for the child.  Normally this shouldn't happen, but if it does it's
-- sometimes better to make something up than crash.
--
-- The rules for extension are the same as 'at_linear_extend', and this
-- function should be the inverse of that one.  This ensures that if you warp
-- and then unwarp a time, you get your original time back.
inverse_at_extend :: Y -> Warp -> X
inverse_at_extend y (Signal vec)
    | TimeVector.null vec = y_to_x y
    -- Nothing means the line is flat and will never reach Y.  I pick a big
    -- X instead of crashing.
    | otherwise = fromMaybe RealTime.large $ TimeVector.x_at x0 y0 x1 y1 y
    where
    -- Has to be the highest index, or it gets hung up on a flat segment.
    i = index_above_y y vec
    (Sample x0 y0, Sample x1 y1)
        | len == 1 =
            let at0@(Sample x0 y0) = index 0
            in (at0, Sample (x0+1) (y0+1))
        | i >= TimeVector.length vec = (index (i-2), index (i-1))
        | i == 0 = (index 0, index 1)
        | otherwise = (index (i-1), index i)
        where len = TimeVector.length vec
    index = TimeVector.index vec

index_above_y :: Y -> TimeVector.Unboxed -> Int
index_above_y y vec = go 0 (TimeVector.length vec)
    where
    go low high
        | low == high = low
        | y >= sy (TimeVector.unsafeIndex vec mid) = go (mid+1) high
        | otherwise = go low mid
        where mid = (low + high) `div` 2

-}