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