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

-- | Calls to do with intonation and tuning.
module Derive.C.Post.Retune (library) where
import qualified Util.Num as Num
import qualified Util.Segment as Segment
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.Sig as Sig

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

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
    [ (Symbol
"retune", Transformer Note
c_retune)
    , (Symbol
"realize-retune", Transformer Note
c_realize_retune)
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"retune"

-- | (time, dist)
type RetuneArg = (RealTime, Pitch.NoteNumber)

retune_arg :: Text
retune_arg :: Text
retune_arg = Text
"retune"

c_retune :: Derive.Transformer Derive.Note
c_retune :: Transformer Note
c_retune = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"retune" Tags
Tags.delayed
    Doc
"Notes start with some detuning, and adjust to the desired pitch.  This\
    \ effect is scaled by the time and pitch distance from the previous note,\
    \ as documeneted in 'Derive.Call.Post.Retune.pitch_scale'."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (Double
0.15 :: Double)
        Doc
"RealTime to get to the intended pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dist" (Double
0.15 :: Double)
        Doc
"Out of tune distance, in NNs. Presumably this should be set to a\
        \ control function with a bimodal distribution."
    ) forall a b. (a -> b) -> a -> b
$ \(RealTime
time, NoteNumber
dist) PassedArgs Note
_args -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (RealTime -> NoteNumber -> Note -> Note
put RealTime
time NoteNumber
dist))
    where put :: RealTime -> NoteNumber -> Note -> Note
put RealTime
time NoteNumber
dist = forall a. Typeable a => Text -> a -> Note -> Note
Score.put_arg Text
retune_arg ((RealTime
time, NoteNumber
dist) :: RetuneArg)

c_realize_retune :: Derive.Transformer Derive.Note
c_realize_retune :: Transformer Note
c_realize_retune = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"retune-realize"
    Tags
Tags.realize_delayed Doc
"Perform annotations added by `retune`."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_args Deriver (Stream Note)
deriver -> do
        RealTime
srate <- Deriver RealTime
Call.get_srate
        forall a b.
(a -> Note) -> (a -> Deriver [b]) -> Stream a -> Deriver (Stream b)
Post.emap_m_ forall a b. (a, b) -> b
snd (RealTime -> (Maybe Note, Note) -> Deriver State Error [Note]
realize RealTime
srate) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a)
Post.prev_by Note -> (Instrument, Maybe Text)
Post.hand_key
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Stream Note)
deriver
    where
    realize :: RealTime -> (Maybe Note, Note) -> Deriver State Error [Note]
realize RealTime
srate (Maybe Note
prev, Note
event) = do
        (Note
event, Maybe (RealTime, NoteNumber)
maybe_arg) <- 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. Typeable a => Text -> Note -> Either Text (Note, Maybe a)
Score.take_arg Text
retune_arg Note
event
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (RealTime, NoteNumber)
maybe_arg of
            Maybe (RealTime, NoteNumber)
Nothing -> [Note
event]
            Just (RealTime, NoteNumber)
arg -> [RealTime -> (RealTime, NoteNumber) -> Maybe Note -> Note -> Note
realize_retune RealTime
srate (RealTime, NoteNumber)
arg Maybe Note
prev Note
event]

realize_retune :: ControlUtil.SRate -> RetuneArg -> Maybe Score.Event
    -> Score.Event -> Score.Event
realize_retune :: RealTime -> (RealTime, NoteNumber) -> Maybe Note -> Note -> Note
realize_retune RealTime
srate (RealTime
time, NoteNumber
max_dist) Maybe Note
prev Note
event
    | NoteNumber
dist forall a. Eq a => a -> a -> Bool
== NoteNumber
0 = Note
event
    | Bool
otherwise = Control -> Note -> Note
add_nn_transpose Control
curve Note
event
    where
    dist :: NoteNumber
dist = (RealTime, NoteNumber) -> NoteNumber -> NoteNumber
calculate_retune (Maybe Note -> Note -> (RealTime, NoteNumber)
pitch_distance Maybe Note
prev Note
event) NoteNumber
max_dist
    curve :: Control
curve = RealTime
-> RealTime -> NoteNumber -> RealTime -> RealTime -> Control
retune_curve RealTime
srate RealTime
time NoteNumber
dist (Note -> RealTime
Score.event_start Note
event)
        (Note -> RealTime
Score.event_end Note
event)

-- | Transpose an event by adding to its nn transpose control.
add_nn_transpose :: Signal.Control -> Score.Event -> Score.Event
add_nn_transpose :: Control -> Note -> Note
add_nn_transpose Control
curve = Control -> (Control -> Control) -> Note -> Note
Score.modify_signal Control
Controls.nn (Control -> Control -> Control
Signal.sig_add Control
curve)

retune_curve :: ControlUtil.SRate -> RealTime -> Pitch.NoteNumber -> RealTime
     -> RealTime -> Signal.Control
retune_curve :: RealTime
-> RealTime -> NoteNumber -> RealTime -> RealTime -> Control
retune_curve RealTime
srate RealTime
time NoteNumber
dist RealTime
start RealTime
end =
    RealTime
-> Curve -> RealTime -> Double -> RealTime -> Double -> Control
ControlUtil.segment RealTime
srate Curve
curve
        RealTime
start (NoteNumber -> Double
Pitch.nn_to_double NoteNumber
dist) (forall a. Ord a => a -> a -> a
min RealTime
end (RealTime
start forall a. Num a => a -> a -> a
+ RealTime
time)) Double
0
    where
    -- Adjust quickly at first, then slow down.
    curve :: Curve
curve = (Double -> Double) -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
ControlUtil.expon (-Double
4)

-- | Get the pitch and the time ago it was established.
-- TODO this gets the start of the segment, so if it's sloped, this isn't the
-- current pitch.  What should happen with notes that already have some pitch
-- variation is dependent on how I want this to work, but for now start of the
-- segment still seems reasonable.
pitch_distance :: Maybe Score.Event -> Score.Event
    -> (RealTime, Pitch.NoteNumber)
pitch_distance :: Maybe Note -> Note -> (RealTime, NoteNumber)
pitch_distance Maybe Note
prev Note
cur = forall a. a -> Maybe a -> a
fromMaybe (RealTime
0, NoteNumber
0) forall a b. (a -> b) -> a -> b
$
    forall {b}. Num b => (RealTime, b) -> b -> (RealTime, b)
distance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RealTime -> Note -> Maybe (RealTime, NoteNumber)
get_last RealTime
x2 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Note
prev) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Note -> Maybe NoteNumber
Score.initial_nn Note
cur
    where
    x2 :: RealTime
x2 = Note -> RealTime
Score.event_start Note
cur
    distance :: (RealTime, b) -> b -> (RealTime, b)
distance (RealTime
x1, b
y1) b
y2 = (RealTime
x2 forall a. Num a => a -> a -> a
- RealTime
x1, b
y2 forall a. Num a => a -> a -> a
- b
y1)
    get_last :: RealTime -> Note -> Maybe (RealTime, NoteNumber)
get_last RealTime
x Note
event = do
        Segment Pitch
segment <- PSignal -> RealTime -> Maybe (Segment Pitch)
PSignal.segment_at (Note -> PSignal
Score.event_pitch Note
event) RealTime
x
        NoteNumber
nn <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Transposed -> Either PitchError NoteNumber
PSignal.pitch_nn forall a b. (a -> b) -> a -> b
$
            Note -> RealTime -> Pitch -> Transposed
Score.apply_controls Note
event RealTime
x forall a b. (a -> b) -> a -> b
$ forall y. Segment y -> y
Segment._y1 Segment Pitch
segment
        forall a. a -> Maybe a
Just (forall y. Segment y -> RealTime
Segment._x1 Segment Pitch
segment, NoteNumber
nn)

calculate_retune :: (RealTime, Pitch.NoteNumber)
    -> Pitch.NoteNumber -> Pitch.NoteNumber
calculate_retune :: (RealTime, NoteNumber) -> NoteNumber -> NoteNumber
calculate_retune (RealTime
time_diff, NoteNumber
nn_diff) NoteNumber
max_dist =
    NoteNumber
max_dist forall a. Num a => a -> a -> a
* RealTime -> NoteNumber -> NoteNumber
pitch_scale RealTime
time_diff NoteNumber
nn_diff

-- | Scale the nn distance from 0 to 1 based on the pitch and time distance to
-- the last pitch sample of the previous note.
--
-- An octave is the most inaccurate.  Unison is totally accurate.  0 time is
-- the most inaccurate, while 1 second is still a little bit inaccurate.
pitch_scale :: RealTime -> Pitch.NoteNumber -> Pitch.NoteNumber
pitch_scale :: RealTime -> NoteNumber -> NoteNumber
pitch_scale RealTime
time_diff NoteNumber
nn_diff =
    forall a. Real a => a -> NoteNumber
Pitch.nn (RealTime -> Double
RealTime.to_seconds RealTime
time_scale) forall a. Num a => a -> a -> a
* NoteNumber
nn_scale
    where
    nn_scale :: NoteNumber
nn_scale = forall a. Ord a => a -> a -> a -> a
Num.clamp NoteNumber
0 NoteNumber
12 (forall a. Num a => a -> a
abs NoteNumber
nn_diff) forall a. Fractional a => a -> a -> a
/ NoteNumber
12
    time_scale :: RealTime
time_scale = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale RealTime
0.15 RealTime
1 forall a b. (a -> b) -> a -> b
$ RealTime
1 forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a -> a
Num.clamp RealTime
0 RealTime
1 (forall a. Num a => a -> a
abs RealTime
time_diff)