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

-- | Utilities dealing with speeds.
module Derive.Call.Speed where
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck
import qualified Derive.ValType as ValType
import qualified Derive.Warp as Warp

import qualified Perform.RealTime as RealTime
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


data Speed = Score !ScoreTime | Real !RealTime
    deriving (Int -> Speed -> ShowS
[Speed] -> ShowS
Speed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Speed] -> ShowS
$cshowList :: [Speed] -> ShowS
show :: Speed -> String
$cshow :: Speed -> String
showsPrec :: Int -> Speed -> ShowS
$cshowsPrec :: Int -> Speed -> ShowS
Show)

-- TODO this is a lot of boilerplate just to participate in Typecheck.
instance Typecheck.Typecheck Speed where
    from_val :: Val -> Checked Speed
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
Typecheck.coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        case Type
typ of
            Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Speed
Real (Double -> RealTime
RealTime.seconds Double
val)
            Type
ScoreT.Real -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Speed
Real (Double -> RealTime
RealTime.seconds Double
val)
            Type
ScoreT.Score -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Speed
Score (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy Speed -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
Typecheck.num_to_type
instance Typecheck.ToVal Speed where
    to_val :: Speed -> Val
to_val (Score ScoreTime
a) = forall a. ToVal a => a -> Val
Typecheck.to_val ScoreTime
a
    to_val (Real RealTime
a) = forall a. ToVal a => a -> Val
Typecheck.to_val RealTime
a
instance Typecheck.TypecheckNum Speed where
    num_type :: Proxy Speed -> NumType
num_type Proxy Speed
_ = NumType
ValType.TTime
instance ShowVal.ShowVal Speed where
    show_val :: Speed -> Text
show_val (Score ScoreTime
s) = forall a. ShowVal a => a -> Text
ShowVal.show_val ScoreTime
s
    show_val (Real RealTime
s) = forall a. ShowVal a => a -> Text
ShowVal.show_val RealTime
s

arg :: Sig.Parser Typecheck.RealTimeFunctionT
arg :: Parser RealTimeFunctionT
arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"speed" EnvironDefault
Derive.Both (Int
10 :: Int)
    Doc
"Repeat at this speed.  If it's a RealTime, the value is the number of\
    \ repeats per second, which will be unaffected by the tempo. If it's\
    \ a ScoreTime, the value is the number of repeats per ScoreTime\
    \ unit, and will stretch along with tempo changes."

-- | Get start times until the end of the range, at the given speed.
starts :: Derive.Time t => Typecheck.RealTimeFunctionT -> (t, t)
    -> Bool -- ^ If True, include a sample at the end time.
    -> Derive.Deriver [RealTime]
starts :: forall t.
Time t =>
RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime]
starts (Typecheck.RealTimeFunctionT TimeT
ttype Function
speed) (t
start_, t
end_) Bool
include_end = do
    let take_until :: a -> [a] -> [a]
take_until a
e = if Bool
include_end then forall a. a -> a
id else forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
<a
e)
    case TimeT
ttype of
        TimeT
ScoreT.TReal -> do
            (RealTime
start, RealTime
end) <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver RealTime
Derive.real t
start_ forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Time a => a -> Deriver RealTime
Derive.real t
end_
            forall {a}. Ord a => a -> [a] -> [a]
take_until RealTime
end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function -> RealTime -> RealTime -> Deriver [RealTime]
real_starts Function
speed RealTime
start RealTime
end
        TimeT
ScoreT.TScore -> do
            (ScoreTime
start, ScoreTime
end) <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver ScoreTime
Derive.score t
start_ forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Time a => a -> Deriver ScoreTime
Derive.score t
end_
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Time a => a -> Deriver RealTime
Derive.real forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Ord a => a -> [a] -> [a]
take_until ScoreTime
end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                Function -> ScoreTime -> ScoreTime -> Deriver [ScoreTime]
score_starts Function
speed ScoreTime
start ScoreTime
end

-- | Get start times for a changing speed.  The difference with 'starts' is
-- that the start and end speeds can be different types.
starts_curve :: ControlUtil.CurveF -> Speed -> Speed -> (RealTime, RealTime)
    -> Bool -- ^ If True, include a sample at the end time.
    -> Derive.Deriver [RealTime]
starts_curve :: CurveF
-> Speed
-> Speed
-> (RealTime, RealTime)
-> Bool
-> Deriver [RealTime]
starts_curve CurveF
curve Speed
start_speed Speed
end_speed (RealTime
start, RealTime
end) Bool
include_end = do
    RealTime
start_dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start (Speed -> Duration
speed_to_duration Speed
start_speed)
    RealTime
end_dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
end (Speed -> Duration
speed_to_duration Speed
end_speed)
    let dur_at :: RealTime -> RealTime
dur_at = Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurveF -> RealTime -> Double -> RealTime -> Double -> Function
ControlUtil.make_function CurveF
curve
            RealTime
start (Function
RealTime.to_seconds RealTime
start_dur)
            RealTime
end (Function
RealTime.to_seconds RealTime
end_dur)
    let take_until :: a -> [a] -> [a]
take_until a
e = if Bool
include_end then forall a. a -> a
id else forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
<a
e)
    forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        forall {a}. Ord a => a -> [a] -> [a]
take_until RealTime
end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Num a, Ord a, Show a) =>
(a -> a) -> a -> a -> Either Text [a]
duration_starts RealTime -> RealTime
dur_at RealTime
start RealTime
end

speed_to_duration :: Speed -> DeriveT.Duration
speed_to_duration :: Speed -> Duration
speed_to_duration (Score ScoreTime
t) = ScoreTime -> Duration
DeriveT.ScoreDuration (ScoreTime
1forall a. Fractional a => a -> a -> a
/ScoreTime
t)
speed_to_duration (Real RealTime
t) = RealTime -> Duration
DeriveT.RealDuration (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
t)

-- | Emit RealTimes at the given speed, which may change over time.  The speed
-- is taken as hertz in real time, and must be >0.
--
-- This returns samples up to and including the end.
real_starts :: ScoreT.Function -> RealTime -> RealTime
    -> Derive.Deriver [RealTime]
real_starts :: Function -> RealTime -> RealTime -> Deriver [RealTime]
real_starts Function
speed_sig RealTime
start RealTime
end = forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
    forall a.
(Num a, Ord a, Show a) =>
(a -> a) -> a -> a -> Either Text [a]
duration_starts (Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
1/) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
speed_sig) RealTime
start RealTime
end

-- | Emit ScoreTimes at the given speed, which may change over time.  The
-- ScoreTimes are emitted as the reciprocal of the signal at the given point
-- in time, so it must be >0.
--
-- The result is that the speed of the emitted samples should depend on the
-- tempo in effect.
--
-- This returns samples up to and including the end.
score_starts :: ScoreT.Function -> ScoreTime -> ScoreTime
    -> Derive.Deriver [ScoreTime]
score_starts :: Function -> ScoreTime -> ScoreTime -> Deriver [ScoreTime]
score_starts Function
speed_sig ScoreTime
start ScoreTime
end = do
    ScoreTime -> ScoreTime
dur_sig <- Function -> Deriver (ScoreTime -> ScoreTime)
convert_score_signal Function
speed_sig
    forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        forall a.
(Num a, Ord a, Show a) =>
(a -> a) -> a -> a -> Either Text [a]
duration_starts ScoreTime -> ScoreTime
dur_sig ScoreTime
start (ScoreTime
end forall a. Num a => a -> a -> a
+ ScoreTime
ScoreTime.eta)

-- | Convert a function from RealTime to a ScoreTime duration to a function
-- from ScoreTime to ScoreTime duration.
convert_score_signal :: ScoreT.Function
    -> Derive.Deriver (ScoreTime -> ScoreTime)
convert_score_signal :: Function -> Deriver (ScoreTime -> ScoreTime)
convert_score_signal Function
f = do
    Warp
warp <- Deriver Warp
Internal.get_warp
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> ScoreTime
ScoreTime.from_double forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
1/) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warp -> ScoreTime -> RealTime
Warp.warp Warp
warp

duration_starts :: (Num a, Ord a, Show a) => (a -> a) -> a -> a
    -> Either Text [a]
duration_starts :: forall a.
(Num a, Ord a, Show a) =>
(a -> a) -> a -> a -> Either Text [a]
duration_starts a -> a
dur_at a
start a
end = a -> a -> a -> Either Text [a]
sample (a -> a
dur_at a
start) a
0 a
start
    where
    sample :: a -> a -> a -> Either Text [a]
sample a
prev_dur a
n a
t0
        | a
t forall a. Ord a => a -> a -> Bool
> a
end = forall (m :: * -> *) a. Monad m => a -> m a
return []
        | a
dur forall a. Ord a => a -> a -> Bool
<= a
0 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"duration <= 0: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
dur forall a. Semigroup a => a -> a -> a
<> Text
" at " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
t
        -- Avoid loss of precision for the common case of a constant speed
        -- signal.
        | a
dur forall a. Eq a => a -> a -> Bool
== a
prev_dur = (a
t:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> a -> Either Text [a]
sample a
prev_dur (a
nforall a. Num a => a -> a -> a
+a
1) a
t0
        | Bool
otherwise = (a
t:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> a -> a -> Either Text [a]
sample a
dur a
0 (a
tforall a. Num a => a -> a -> a
+a
dur)
            where
            t :: a
t = a
t0 forall a. Num a => a -> a -> a
+ a
prev_dur forall a. Num a => a -> a -> a
* a
n
            dur :: a
dur = a -> a
dur_at a
t