-- Copyright 2014 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 that emit 'PSignal.PSignal's.
module Derive.Call.PitchUtil where
import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Util.Lists as Lists

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import           Derive.Call.ControlUtil (Curve, SRate)
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Sig as Sig

import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime

import           Global
import           Types


type PitchOrTranspose = Either PSignal.Pitch Pitch.Transpose

resolve_pitch_transpose :: PSignal.Pitch -> PitchOrTranspose -> PSignal.Pitch
resolve_pitch_transpose :: Pitch -> PitchOrTranspose -> Pitch
resolve_pitch_transpose Pitch
pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Pitch
pitch)

-- * interpolator call

interpolator_call :: Text -> ControlUtil.CurveD
    -> ControlUtil.InterpolatorTime Derive.Pitch
    -> Derive.Generator Derive.Pitch
interpolator_call :: Text -> CurveD -> InterpolatorTime PSignal -> Generator PSignal
interpolator_call Text
name_suffix (ControlUtil.CurveD Text
name Parser arg
get_arg arg -> Curve
curve)
        InterpolatorTime PSignal
interpolator_time =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude (Text -> CallName
Derive.CallName (Text
name forall a. Semigroup a => a -> a -> a
<> Text
name_suffix))
        Tags
Tags.prev Doc
doc
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PitchOrTranspose
pitch_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration RealTime
0) InterpolatorTime PSignal
interpolator_time
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser arg
get_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Pitch)
from_env
    ) forall a b. (a -> b) -> a -> b
$ \(PitchOrTranspose
to, Duration
time, arg
curve_arg, Maybe Pitch
from) PassedArgs PSignal
args -> do
        Duration
time <- if forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs PSignal
args forall a. Eq a => a -> a -> Bool
== TrackTime
0
            then case InterpolatorTime PSignal
interpolator_time of
                Left Parser Duration
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Duration
time
                Right (GetTime PSignal
get_time, Text
_) -> GetTime PSignal
get_time PassedArgs PSignal
args
            else RealTime -> Duration
DeriveT.RealDuration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PassedArgs a -> Deriver RealTime
Args.real_duration PassedArgs PSignal
args
        (RealTime
start, RealTime
end) <- forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
Call.duration_from_start PassedArgs PSignal
args Duration
time
        Curve
-> RealTime
-> Maybe Pitch
-> RealTime
-> PitchOrTranspose
-> Deriver PSignal
make_segment_from (arg -> Curve
curve arg
curve_arg)
            (forall a. Ord a => a -> a -> a
min RealTime
start RealTime
end) (Maybe Pitch -> PassedArgs PSignal -> Maybe Pitch
prev_val Maybe Pitch
from PassedArgs PSignal
args) (forall a. Ord a => a -> a -> a
max RealTime
start RealTime
end) PitchOrTranspose
to
    where
    doc :: Doc
doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Text
"Interpolate from the previous value to the given one."
        forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Text
"") ((Text
" "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) InterpolatorTime PSignal
interpolator_time
    -- The only difference between this and ControlUtil.interpolator_call is
    -- the 'interpolate' call and 'pitch_arg'.

pitch_arg :: Sig.Parser PitchOrTranspose
pitch_arg :: Parser PitchOrTranspose
pitch_arg = forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"pitch"
    Doc
"Destination pitch, or a transposition from the previous one."

-- | Use this for calls that start from the previous value, to give a way
-- to override that behaviour.
from_env :: Sig.Parser (Maybe PSignal.Pitch)
from_env :: Parser (Maybe Pitch)
from_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"from" EnvironDefault
Sig.Both (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
    Doc
"Start from this pitch. If unset, use the previous pitch."

prev_val :: Maybe PSignal.Pitch -> Derive.PitchArgs -> Maybe PSignal.Pitch
prev_val :: Maybe Pitch -> PassedArgs PSignal -> Maybe Pitch
prev_val Maybe Pitch
from PassedArgs PSignal
args = Maybe Pitch
from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs PSignal -> Maybe (RealTime, Pitch)
Args.prev_pitch PassedArgs PSignal
args)

-- | Pitch version of 'ControlUtil.interpolator_variations'.
interpolator_variations :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
interpolator_variations :: [(Symbol, Generator PSignal)]
interpolator_variations = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ forall a call.
Taggable a =>
(Text -> CurveD -> InterpolatorTime a -> call)
-> Symbol -> CurveD -> [(Symbol, call)]
ControlUtil.interpolator_variations_ Text -> CurveD -> InterpolatorTime PSignal -> Generator PSignal
interpolator_call Symbol
sym CurveD
curve
    | (Symbol
sym, CurveD
curve) <- [(Symbol, CurveD)]
ControlUtil.standard_curves
    ]


-- * interpolate

-- | Make a curve segment from the previous value, if there was one.
make_segment_from :: Curve -> RealTime -> Maybe PSignal.Pitch -> RealTime
    -> PitchOrTranspose -> Derive.Deriver PSignal.PSignal
make_segment_from :: Curve
-> RealTime
-> Maybe Pitch
-> RealTime
-> PitchOrTranspose
-> Deriver PSignal
make_segment_from Curve
curve RealTime
start Maybe Pitch
maybe_from RealTime
end PitchOrTranspose
to = case Maybe Pitch
maybe_from of
    Maybe Pitch
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case PitchOrTranspose
to of
        Left Pitch
to -> RealTime -> Pitch -> PSignal
PSignal.from_sample RealTime
start Pitch
to
        Right Transpose
_ -> forall a. Monoid a => a
mempty
    Just Pitch
from -> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> Deriver PSignal
make_segment Curve
curve RealTime
start Pitch
from RealTime
end
        (Pitch -> PitchOrTranspose -> Pitch
resolve_pitch_transpose Pitch
from PitchOrTranspose
to)

make_segment :: Curve -> RealTime -> PSignal.Pitch -> RealTime
    -> PSignal.Pitch -> Derive.Deriver PSignal.PSignal
make_segment :: Curve -> RealTime -> Pitch -> RealTime -> Pitch -> Deriver PSignal
make_segment Curve
curve RealTime
x1 Pitch
y1 RealTime
x2 Pitch
y2 = do
    RealTime
srate <- Deriver RealTime
Call.get_srate
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime
-> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> PSignal
segment RealTime
srate Curve
curve RealTime
x1 Pitch
y1 RealTime
x2 Pitch
y2

type Interpolate = RealTime -> PSignal.Pitch -> RealTime -> PSignal.Pitch
    -- ^ start -> starty -> end -> endy
    -> PSignal.PSignal

-- | Interpolate between the given points.
-- TODO(polymorphic-signals) same as ControlUtil.segment, well except Eq use
segment :: SRate -> Curve -> RealTime -> PSignal.Pitch -> RealTime
    -> PSignal.Pitch -> PSignal.PSignal
segment :: RealTime
-> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> PSignal
segment RealTime
srate Curve
curve RealTime
x1 Pitch
y1 RealTime
x2 Pitch
y2
    | RealTime
x1 forall a. Ord a => a -> a -> Bool
> RealTime
x2 = forall a. Monoid a => a
mempty -- if x1 == x2 I still need to make a vertical segment
    -- I can't optimize y1==y2, which means flat breakpoints on a nonlinear
    -- curve get redundant samples.
    | Bool
otherwise = case Curve
curve of
        Curve
ControlUtil.Linear -> [(RealTime, Pitch)] -> PSignal
PSignal.from_pairs [(RealTime
x1, Pitch
y1), (RealTime
x2, Pitch
y2)]
        ControlUtil.Function Double -> Double
curvef -> [(RealTime, Pitch)] -> PSignal
PSignal.from_pairs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double) -> RealTime -> (RealTime, Pitch)
make Double -> Double
curvef) forall a b. (a -> b) -> a -> b
$
            forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.rangeEnd RealTime
x1 RealTime
x2 (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
srate)
    where
    make :: (Double -> Double) -> RealTime -> (RealTime, Pitch)
make Double -> Double
curvef RealTime
x
        -- Otherwise if x1==x2 then I get y1.
        | RealTime
x forall a. Ord a => a -> a -> Bool
>= RealTime
x2 = (RealTime
x2, Pitch
y2)
        | Bool
otherwise = (RealTime
x, (Double -> Double) -> RealTime -> Pitch
y_at Double -> Double
curvef RealTime
x)
    y_at :: (Double -> Double) -> RealTime -> Pitch
y_at Double -> Double
curvef = Pitch -> Pitch -> Double -> Pitch
Pitches.interpolated Pitch
y1 Pitch
y2
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
curvef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize (RealTime -> Double
secs RealTime
x1) (RealTime -> Double
secs RealTime
x2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Double
secs
        where secs :: RealTime -> Double
secs = RealTime -> Double
RealTime.to_seconds

-- * breakpoints

-- | Create line segments between the given breakpoints.
breakpoints :: SRate -> Curve -> [(RealTime, PSignal.Pitch)] -> PSignal.PSignal
breakpoints :: RealTime -> Curve -> [(RealTime, Pitch)] -> PSignal
breakpoints RealTime
_ Curve
ControlUtil.Linear = [(RealTime, Pitch)] -> PSignal
PSignal.from_pairs
breakpoints RealTime
srate Curve
curve =
    forall sig y.
Monoid sig =>
(RealTime -> y -> sig)
-> (RealTime -> y -> RealTime -> y -> sig)
-> [(RealTime, y)]
-> sig
ControlUtil.signal_breakpoints RealTime -> Pitch -> PSignal
PSignal.from_sample (RealTime
-> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> PSignal
segment RealTime
srate Curve
curve)