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

-- | Interpolate between two different scales.
module Derive.Scale.Interpolate where
import qualified Util.Doc as Doc
import qualified Derive.Args as Args
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Scales as Scales
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig

import qualified Perform.Pitch as Pitch

import           Global


scales :: [Scale.Definition]
scales :: [Definition]
scales = (Environ -> LookupScale -> Either PitchError Scale) -> [Definition]
scale_make forall a b. (a -> b) -> a -> b
$ \Environ
env (Scale.LookupScale Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup) -> do
    (ScaleId
from_id, ScaleId
to_id) <- Environ -> Either PitchError (ScaleId, ScaleId)
environ_from_to Environ
env
    let find :: Key -> ScaleId -> Either PitchError Scale
find Key
msg ScaleId
scale_id = forall a. a -> Maybe a -> a
fromMaybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> PitchError
DeriveT.PitchError Key
msg) forall a b. (a -> b) -> a -> b
$
            Environ -> ScaleId -> Maybe (Either PitchError Scale)
lookup Environ
env2 ScaleId
scale_id
        -- This should avoid an infinite loop if from_id is itself
        -- interpolate.
        env2 :: Environ
env2 = Key -> Environ -> Environ
Env.delete Key
scale_from forall a b. (a -> b) -> a -> b
$ Key -> Environ -> Environ
Env.delete Key
scale_to Environ
env
    Scale
from <- Key -> ScaleId -> Either PitchError Scale
find (Key
"from scale " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty ScaleId
from_id) ScaleId
from_id
    Scale
to <- Key -> ScaleId -> Either PitchError Scale
find (Key
"to scale " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty ScaleId
to_id) ScaleId
to_id
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Scale -> Scale -> Scale
make Scale
from Scale
to
    where
    scale_make :: (Environ -> LookupScale -> Either PitchError Scale) -> [Definition]
scale_make = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleId
-> (Key, DocumentedCall)
-> (Environ -> LookupScale -> Either PitchError Scale)
-> Definition
Scale.Make ScaleId
scale_id (Key
"same as from scale", DocumentedCall
doc)

make :: Scale.Scale -> Scale.Scale -> Scale.Scale
make :: Scale -> Scale -> Scale
make Scale
from Scale
to = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Key
scale_pattern = Key
"same as `from` scale"
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers =
        Scale -> Set Control
Scale.scale_transposers Scale
from forall a. Semigroup a => a -> a -> a
<> Scale -> Set Control
Scale.scale_transposers Scale
to
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
from
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = Scale -> Environ -> Pitch -> Either PitchError Note
Scale.scale_show Scale
from
    , scale_bottom :: Pitch
scale_bottom = Scale -> Pitch
Scale.scale_bottom Scale
from
    , scale_layout :: Layout
scale_layout = Scale -> Layout
Scale.scale_layout Scale
from
    , scale_transpose :: Transpose
scale_transpose = Scale -> Transpose
Scale.scale_transpose Scale
from
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Scale -> Enharmonics
Scale.scale_enharmonics Scale
from
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = Note -> Maybe ValCall
to_call
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = Environ -> Input -> Either PitchError Note
to_note
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = (Environ -> Input -> Either PitchError Note)
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
Scales.computed_input_to_nn Environ -> Input -> Either PitchError Note
to_note Note -> Maybe ValCall
to_call
    , scale_call_doc :: DocumentedCall
scale_call_doc = DocumentedCall
doc
    }
    where
    to_call :: Note -> Maybe ValCall
to_call = Scale -> Scale -> Note -> Maybe ValCall
note_to_call Scale
from Scale
to
    to_note :: Environ -> Input -> Either PitchError Note
to_note = Scale -> Environ -> Input -> Either PitchError Note
Scale.scale_input_to_note Scale
from

doc :: Derive.DocumentedCall
doc :: DocumentedCall
doc = ValCall -> DocumentedCall
Derive.extract_val_doc forall a b. (a -> b) -> a -> b
$ ValCall -> ValCall -> ValCall
interpolated_degree ValCall
dummy ValCall
dummy
    where
    dummy :: ValCall
dummy = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale CallName
"dummy" forall a. Monoid a => a
mempty Doc
"" forall a b. (a -> b) -> a -> b
$
        forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Tagged
_args -> forall (m :: * -> *) a. Monad m => a -> m a
return (Y
0 :: Double)

scale_id :: Pitch.ScaleId
scale_id :: ScaleId
scale_id = ScaleId
"interpolate"

scale_at :: ScoreT.Control
scale_at :: Control
scale_at = Control
"scale-at"

note_to_call :: Scale.Scale -> Scale.Scale -> Pitch.Note -> Maybe Derive.ValCall
note_to_call :: Scale -> Scale -> Note -> Maybe ValCall
note_to_call Scale
from Scale
to Note
note =
    ValCall -> ValCall -> ValCall
interpolated_degree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scale -> Note -> Maybe ValCall
Scale.scale_note_to_call Scale
from Note
note
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scale -> Note -> Maybe ValCall
Scale.scale_note_to_call Scale
to Note
note

interpolated_degree :: Derive.ValCall -> Derive.ValCall -> Derive.ValCall
interpolated_degree :: ValCall -> ValCall -> ValCall
interpolated_degree ValCall
from ValCall
to = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale CallName
"pitch" forall a. Monoid a => a
mempty
    (Doc
"Emit a pitch between two scales. The scales are in the "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Key
scale_from forall a. Semigroup a => a -> a -> a
<> Doc
" and " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Key
scale_to
    forall a. Semigroup a => a -> a -> a
<> Doc
" environ values, and keys are from " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Key
key_from forall a. Semigroup a => a -> a -> a
<> Doc
" and "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Key
key_to forall a. Semigroup a => a -> a -> a
<> Doc
". If " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Key
scale_to forall a. Semigroup a => a -> a -> a
<> Doc
" isn't set, it defaults to "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Key
scale_from forall a. Semigroup a => a -> a -> a
<> Doc
". The " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
doc Control
scale_at
    forall a. Semigroup a => a -> a -> a
<> Doc
" control ranges from 0 to 1\
    \ and controls the interpolation between the scales. For this to work, the\
    \ scales must have the same degree names, since there's no way to manually\
    \ specify a correspondence between scale degrees."
    ) 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 (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"passed to `from` and `to` scales") forall a b. (a -> b) -> a -> b
$
    \[Val]
_vals PassedArgs Tagged
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args
        Y
n <- forall a. a -> Maybe a -> a
fromMaybe Y
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Control -> RealTime -> Deriver (Maybe Y)
Derive.untyped_control_at Control
scale_at RealTime
start
        let apply :: Key -> ValCall -> Deriver (RawPitch a)
apply Key
key = forall a. Key -> Key -> Deriver a -> Deriver a
rename_environ Key
key Key
EnvKey.key
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ScoreTime -> ValCall -> Deriver (RawPitch a)
Eval.apply_pitch (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Tagged
args)
        if Y
n forall a. Ord a => a -> a -> Bool
<= Y
0 then forall {a}. Key -> ValCall -> Deriver (RawPitch a)
apply Key
key_from ValCall
from
            else if Y
n forall a. Ord a => a -> a -> Bool
>= Y
1 then forall {a}. Key -> ValCall -> Deriver (RawPitch a)
apply Key
key_to ValCall
to
            else do
                RawPitch Untransposed_
p1 <- forall {a}. Key -> ValCall -> Deriver (RawPitch a)
apply Key
key_from ValCall
from
                RawPitch Untransposed_
p2 <- forall {a}. Key -> ValCall -> Deriver (RawPitch a)
apply Key
key_to ValCall
to
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RawPitch Untransposed_
-> RawPitch Untransposed_ -> Y -> RawPitch Untransposed_
Pitches.interpolated RawPitch Untransposed_
p1 RawPitch Untransposed_
p2 Y
n
    where
    doc :: ShowVal.ShowVal a => a -> Doc.Doc
    doc :: forall a. ShowVal a => a -> Doc
doc = forall a. ShowVal a => a -> Doc
ShowVal.doc

rename_environ :: Env.Key -> Env.Key -> Derive.Deriver a -> Derive.Deriver a
rename_environ :: forall a. Key -> Key -> Deriver a -> Deriver a
rename_environ Key
from Key
to Deriver a
deriver = do
    Maybe Val
maybe_val :: Maybe DeriveT.Val <- forall a. Typecheck a => Key -> Deriver (Maybe a)
Derive.lookup_val Key
from
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall val a. ToVal val => Key -> val -> Deriver a -> Deriver a
Derive.with_val Key
to) Maybe Val
maybe_val Deriver a
deriver


-- * util

environ_from_to :: Env.Environ
    -> Either DeriveT.PitchError (Pitch.ScaleId, Pitch.ScaleId)
environ_from_to :: Environ -> Either PitchError (ScaleId, ScaleId)
environ_from_to Environ
env = do
    ScaleId
from <- forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Key -> Environ -> Either PitchError val
Scales.read_environ (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> ScaleId
Expr.str_to_scale_id) forall a. Maybe a
Nothing
        Key
scale_from Environ
env
    ScaleId
to <- forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Key -> Environ -> Either PitchError val
Scales.read_environ (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> ScaleId
Expr.str_to_scale_id) (forall a. a -> Maybe a
Just ScaleId
from)
        Key
scale_to Environ
env
    forall (m :: * -> *) a. Monad m => a -> m a
return (ScaleId
from, ScaleId
to)

key_from, key_to :: Env.Key
key_from :: Key
key_from = Key
"key-from"
key_to :: Key
key_to = Key
"key-to"

scale_from, scale_to :: Env.Key
scale_from :: Key
scale_from = Key
"scale-from"
scale_to :: Key
scale_to = Key
"scale-to"

{- Notes from the implementation: NOTE [make-scale]

    Scale with arguments: *interpolate scale-from=from scale-to=to

    I don't think I can use environ vals, because all the various scale
    functions don't have access to it.

    If I want a scale with arguments, it winds up being like Environ, except
    that I can rely on it being in the track title instead of having to look up
    an environ.  But I would need to generate the scale with a val call, e.g.
    'scale = (interpolate-scale from to)', and now I can't really write it
    directly '*interpolate ..?'.

    The Key is analogous, and its from the environ.  So perhaps all the
    functions that take a Key should take Environ instead.  Everyone who needs
    a Key already makes you look up in the Environ anyway, why not pass the
    whole thing?

    Not just Environ, it also needs LookupScale.

    type LookupScale = Pitch.ScaleId -> Maybe Scale.  Maybe I could use the
    LookupPattern thing for scales, so *interpolate-from-to will have access to
    those and be able to bake them into the scale creation.  This would also
    solve the problem with scale_transposers and scale_layout.

    What about same scale with different keys?  Environ lends itself to that:
    from-scale, from-key, to-scale, to-key.

    Or, I could do both, and pass Environ to LookupScale.  But then the from
    and to scales are fixed when the scale is created.  Actually it's created
    again every time the scale is looked up.  Maybe that's not so great?  But
    actually all it does is make some closures and I'm constantly doing that
    anyway.

    *interpolate.from.to - Otherwise Cmd.get_scale calls all need environ,
    which means they have to look in the performance, which may not be present.
    Doesn't work for keys, but I need key-from key-to anyway.  It's a pretty
    bogus way to pass arguments though.

    Getting from the Environ is not so bad because it's already doing that for
    the scale itself.

    Scale degree calls create a ValCall, but they don't look in environ.  That
    happens on NN conversion, so the environ always comes out of the
    Score.Event, which means that the interpolate scale degree can't influence
    the environ its callees see.

    Shouldn't calls look in the environ and put those values into their
    closure?  Why pass environ to conversion?  I recall it had to do with the
    tuning var.  So in convert, inst_environ goes before the event environ.
    How exactly should inst environ interact?  It should be added to the
    environ as a default.

    I think this had to do with kotekan calls, because it evaluates the pitch,
    and then sets a new instrument.  If I took environ back out then the tuning
    is set, and can't be changed if you switch the instrument.  But perhaps
    that means kotekan should work on derivers, not as a postproc.  I.e. you
    can't just change the instrument of an event by updating
    Score.event_instrument.

    Postproc, e.g. Gangsa.c_unison, could either create a new instrument, e.g.
    Util.pitched_note (event_pitch e) etc.  Or it could just know about tuning,
    and explicitly apply that to the Score.event_pitch.  But I'd need to
    preserve a way to apply environ to pitches, and then it's unclear whether
    it should take priority, etc.  Seems messy.

    ChromaticScales.smap_semis_to_nn needs a key, where that's scale specific
    (e.g.  Environ.tuning).  The thing is, it uses Environ.key too, it just may
    want additional things.

    So, only pitch_nn needs it.  So pass SemisToNn directly to it.

    Except, rederive_event does not work, because I need to actually
    re-evaluate the pitch in order to capture the new environ.  Just pulling it
    from the old event doesn't do that.

    Perhaps 'unison' wanting to be a postproc is wrong in general.  I could
    just derive the whole thing twice.  But then I don't get the behaviour
    where I can apply it to a whole score and only the pasang instruments are
    split.  Also for kempyung I'd have to rederive with +3 transpose and the
    note call has to know to wrap into range.  That means +3 transpose and then
    +kempyung, so if it sees the pitch is out of range, it knows it can
    transpose -3.  What about nyogcag?  It would have to be a note transformer
    since it needs each note separately.

    Ok, so maybe I do want to go back to being able to retune a note.  But
    I don't want to unconditionally replace the environ with the inst's
    environ, because then I can't override it.  It should be as if the event
    was derived with that instrument in the first place.

    So, put Environ back into PitchConfig.  But it's not applied in Convert
    like control signals, instead applied in ScaleDegree and then manually when
    you change the instrument.

    I suppose this means I can't configure a pitch with a transposition...  no
    wait, I can because it applies it directly.  So do the same for environ.
    So interpolate could also do that.  But I want to make sure to not override
    those values later on.  This isn't a problem for controls because they are
    added, but env vals replace.

    So... capture at pitch creation time, but switching instruments overrides
    with the instrument env vars.

    I apply PitchConfig by composing it on to the functions, but that means
    I can't override existing values.  Actually I still can, but a separate
    field seems clearer.
-}