-- 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 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 = forall a. Pretty a => a -> String prettys instance Pretty Warp where pretty :: Warp -> Text pretty (WarpFunction Function f) = Text "((Warp " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Function -> ScoreTime -> RealTime _warp Function f ScoreTime 0) forall a. Semigroup a => a -> a -> a <> Text "--" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Function -> ScoreTime -> RealTime _warp Function f ScoreTime 1) forall a. Semigroup a => a -> a -> a <> Text "))" pretty (WarpLinear (Linear RealTime shift RealTime stretch)) = Text "((Warp *" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty RealTime stretch forall a. Semigroup a => a -> a -> a <> Text "+" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty RealTime shift 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) = forall a. a -> Maybe a Just Linear linear is_linear Warp _ = forall a. Maybe a Nothing is_identity :: Warp -> Bool is_identity :: Warp -> Bool is_identity (WarpLinear (Linear RealTime shift RealTime stretch)) = RealTime shift forall a. Eq a => a -> a -> Bool == RealTime 0 Bool -> Bool -> Bool && RealTime stretch 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 forall a. Num a => a -> a -> a * Linear -> RealTime _stretch Linear w 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 forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. Fractional a => a -> a -> a / Linear -> RealTime _stretch Linear w) forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 forall a b. (a -> b) -> a -> b $ 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 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 forall a. Ord a => a -> a -> Bool < ScoreTime 0 = ScoreTime -> RealTime to_real ScoreTime t | Bool otherwise = Y -> RealTime RealTime.seconds forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). Signal kind -> RealTime -> Y Signal.at Warp signal (ScoreTime -> RealTime to_real ScoreTime t) backward :: RealTime -> ScoreTime backward RealTime t | RealTime t forall a. Ord a => a -> a -> Bool < RealTime 0 = RealTime -> ScoreTime to_score RealTime t | Bool otherwise = Y -> ScoreTime ScoreTime.from_double forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). Signal kind -> RealTime -> Y Signal.at Warp inverted RealTime t where inverted :: Warp inverted = 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 forall a b. (a -> b) -> a -> b $ RealTime -> RealTime -> Linear Linear (RealTime shift1 forall a. Num a => a -> a -> a + RealTime shift2 forall a. Num a => a -> a -> a * RealTime stretch1) (RealTime stretch1 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 forall a b. (a -> b) -> a -> b $ Function { _warp :: ScoreTime -> RealTime _warp = ScoreTime -> RealTime warp1 forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> ScoreTime to_score forall b c a. (b -> c) -> (a -> b) -> a -> c . ScoreTime -> RealTime warp2 , _unwarp :: RealTime -> ScoreTime _unwarp = RealTime -> ScoreTime unwarp2 forall b c a. (b -> c) -> (a -> b) -> a -> c . ScoreTime -> RealTime to_real 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)) 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 forall a b. (a -> b) -> a -> b $ Function { _warp :: ScoreTime -> RealTime _warp = ScoreTime -> RealTime warp forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. Num a => a -> a -> a +ScoreTime x) , _unwarp :: RealTime -> ScoreTime _unwarp = forall a. Num a => a -> a -> a subtract ScoreTime x forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> ScoreTime unwarp } shift ScoreTime x (WarpLinear Linear linear) = Linear -> Warp WarpLinear forall a b. (a -> b) -> a -> b $ Linear { _shift :: RealTime _shift = Linear -> RealTime _shift Linear linear forall a. Num a => a -> a -> a + Linear -> RealTime _stretch Linear linear 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 forall a b. (a -> b) -> a -> b $ Function { _warp :: ScoreTime -> RealTime _warp = ScoreTime -> RealTime warp forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. Num a => a -> a -> a *ScoreTime factor) , _unwarp :: RealTime -> ScoreTime _unwarp = (forall a. Fractional a => a -> a -> a /ScoreTime factor) forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> ScoreTime unwarp } stretch ScoreTime factor (WarpLinear Linear linear) = Linear -> Warp WarpLinear 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 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 = forall {k1} {k2} (kind1 :: k1) (kind2 :: k2). Signal kind1 -> Signal kind2 Signal.coerce forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {k} (kind :: k). (RealTime -> RealTime) -> Signal kind -> Signal kind Signal.map_x (ScoreTime -> RealTime to_real 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 -}