-- 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.Seq as Seq

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 = (Pitch -> Pitch)
-> (Transpose -> Pitch) -> PitchOrTranspose -> Pitch
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Pitch -> Pitch
forall a. a -> a
id ((Transpose -> Pitch -> Pitch) -> Pitch -> Transpose -> Pitch
forall a b c. (a -> b -> c) -> b -> a -> c
flip Transpose -> Pitch -> Pitch
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 =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs PSignal -> Deriver PSignal)
-> Generator PSignal
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude (Text -> CallName
Derive.CallName (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name_suffix))
        Tags
Tags.prev Doc
doc
    (WithArgDoc (PassedArgs PSignal -> Deriver PSignal)
 -> Generator PSignal)
-> WithArgDoc (PassedArgs PSignal -> Deriver PSignal)
-> Generator PSignal
forall a b. (a -> b) -> a -> b
$ Parser (PitchOrTranspose, Duration, arg, Maybe Pitch)
-> ((PitchOrTranspose, Duration, arg, Maybe Pitch)
    -> PassedArgs PSignal -> Deriver PSignal)
-> WithArgDoc (PassedArgs PSignal -> Deriver PSignal)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    (PitchOrTranspose
 -> Duration
 -> arg
 -> Maybe Pitch
 -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
-> Parser PitchOrTranspose
-> Parser
     (Duration
      -> arg
      -> Maybe Pitch
      -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PitchOrTranspose
pitch_arg
    Parser
  (Duration
   -> arg
   -> Maybe Pitch
   -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
-> Parser Duration
-> Parser
     (arg
      -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Duration -> Parser Duration)
-> ((GetTime PSignal, Text) -> Parser Duration)
-> InterpolatorTime PSignal
-> Parser Duration
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Parser Duration -> Parser Duration
forall a. a -> a
id (Parser Duration -> (GetTime PSignal, Text) -> Parser Duration
forall a b. a -> b -> a
const (Parser Duration -> (GetTime PSignal, Text) -> Parser Duration)
-> Parser Duration -> (GetTime PSignal, Text) -> Parser Duration
forall a b. (a -> b) -> a -> b
$ Duration -> Parser Duration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Duration -> Parser Duration) -> Duration -> Parser Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration RealTime
0) InterpolatorTime PSignal
interpolator_time
    Parser
  (arg
   -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
-> Parser arg
-> Parser
     (Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser arg
get_arg Parser
  (Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch))
-> Parser (Maybe Pitch)
-> Parser (PitchOrTranspose, Duration, arg, Maybe Pitch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Pitch)
from_env
    ) (((PitchOrTranspose, Duration, arg, Maybe Pitch)
  -> PassedArgs PSignal -> Deriver PSignal)
 -> WithArgDoc (PassedArgs PSignal -> Deriver PSignal))
-> ((PitchOrTranspose, Duration, arg, Maybe Pitch)
    -> PassedArgs PSignal -> Deriver PSignal)
-> WithArgDoc (PassedArgs PSignal -> Deriver PSignal)
forall a b. (a -> b) -> a -> b
$ \(PitchOrTranspose
to, Duration
time, arg
curve_arg, Maybe Pitch
from) PassedArgs PSignal
args -> do
        Duration
time <- if PassedArgs PSignal -> TrackTime
forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs PSignal
args TrackTime -> TrackTime -> Bool
forall a. Eq a => a -> a -> Bool
== TrackTime
0
            then case InterpolatorTime PSignal
interpolator_time of
                Left Parser Duration
_ -> Duration -> Deriver State Error 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 (RealTime -> Duration)
-> Deriver State Error RealTime -> Deriver State Error Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs PSignal -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_duration PassedArgs PSignal
args
        (RealTime
start, RealTime
end) <- PassedArgs PSignal -> Duration -> Deriver (RealTime, RealTime)
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)
            (RealTime -> RealTime -> RealTime
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) (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
start RealTime
end) PitchOrTranspose
to
    where
    doc :: Doc
doc = Text -> Doc
Doc.Doc (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Text
"Interpolate from the previous value to the given one."
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Parser Duration -> Text)
-> ((GetTime PSignal, Text) -> Text)
-> InterpolatorTime PSignal
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Parser Duration -> Text
forall a b. a -> b -> a
const Text
"") ((Text
" "<>) (Text -> Text)
-> ((GetTime PSignal, Text) -> Text)
-> (GetTime PSignal, Text)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GetTime PSignal, Text) -> Text
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 = ArgName -> Doc -> Parser PitchOrTranspose
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 = ArgName
-> EnvironDefault -> Maybe Pitch -> Doc -> Parser (Maybe Pitch)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"from" EnvironDefault
Sig.Both Maybe Pitch
forall a. Maybe a
Nothing
    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 Maybe Pitch -> Maybe Pitch -> Maybe Pitch
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((RealTime, Pitch) -> Pitch
forall a b. (a, b) -> b
snd ((RealTime, Pitch) -> Pitch)
-> Maybe (RealTime, Pitch) -> Maybe Pitch
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 = [[(Symbol, Generator PSignal)]] -> [(Symbol, Generator PSignal)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (Text -> CurveD -> InterpolatorTime PSignal -> Generator PSignal)
-> Symbol -> CurveD -> [(Symbol, Generator PSignal)]
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 -> PSignal -> Deriver PSignal
forall (m :: * -> *) a. Monad m => a -> m a
return (PSignal -> Deriver PSignal) -> PSignal -> Deriver PSignal
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
_ -> PSignal
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 State Error RealTime
Call.get_srate
    PSignal -> Deriver PSignal
forall (m :: * -> *) a. Monad m => a -> m a
return (PSignal -> Deriver PSignal) -> PSignal -> Deriver PSignal
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> RealTime
x2 = PSignal
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 ([(RealTime, Pitch)] -> PSignal) -> [(RealTime, Pitch)] -> PSignal
forall a b. (a -> b) -> a -> b
$ (RealTime -> (RealTime, Pitch))
-> [RealTime] -> [(RealTime, Pitch)]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double) -> RealTime -> (RealTime, Pitch)
make Double -> Double
curvef) ([RealTime] -> [(RealTime, Pitch)])
-> [RealTime] -> [(RealTime, Pitch)]
forall a b. (a -> b) -> a -> b
$
            RealTime -> RealTime -> RealTime -> [RealTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range_end RealTime
x1 RealTime
x2 (RealTime
1RealTime -> RealTime -> RealTime
forall 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 RealTime -> RealTime -> Bool
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
        (Double -> Pitch) -> (RealTime -> Double) -> RealTime -> Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
curvef (Double -> Double) -> (RealTime -> Double) -> RealTime -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double -> Double
forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize (RealTime -> Double
secs RealTime
x1) (RealTime -> Double
secs RealTime
x2) (Double -> Double) -> (RealTime -> Double) -> RealTime -> Double
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 =
    (RealTime -> Pitch -> PSignal)
-> (RealTime -> Pitch -> RealTime -> Pitch -> PSignal)
-> [(RealTime, Pitch)]
-> PSignal
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)