-- 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 -}