-- Copyright 2013 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 module Derive.PSignal ( PSignal, sig_scale_id , Scale(..), no_scale -- * construct / destruct , from_pairs, from_sample, from_segments , to_pairs, to_segments , constant , constant_val , prepend , ErrorText , to_nn , unfoldr -- * query , null , at, at_negative, segment_at , interpolate , head, last -- , before -- , drop_at_after -- , drop_before_strict, drop_before_at, within -- * transform , drop_after, clip_after , drop_before, clip_before , shift , apply_controls, apply_control, apply_environ , map_y_linear -- ** hacks , drop_discontinuity_at -- * Pitch , Transposed, Pitch , RawPitch, PitchConfig(..) , symbolic_pitch , pitch_scale_id, pitch_transposers , pitch_scale, pitch_eval_nn, pitch_eval_note, pitch_config, pitch_controls , PitchError(..) , pitch, coerce , apply_config, apply, add_control, pitch_nn, pitch_note -- ** create , constant_pitch, nn_pitch ) where import Prelude hiding (head, last, null) import qualified Data.Either as Either import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Util.Lists as Lists import qualified Util.Segment as Segment import Util.Segment (Sample(..)) import qualified Derive.DeriveT as DeriveT import Derive.DeriveT (PSignal(..), Pitch, PitchConfig(..), PitchError(..), RawPitch(..), Scale(..), Transposed, _signal, coerce, interpolate, pitch, pitch_nn, pitch_note) import qualified Derive.ScoreT as ScoreT import qualified Perform.Pitch as Pitch import qualified Perform.Signal as Signal import Global import Types -- Signal imported from DeriveT. -- | Set of transposers for the signal. Transposers are documented in -- 'pscale_transposers'. -- -- A Signal can contain pitches from multiple scales, though I don't think this -- should ever happen. But if it does, the first pitch wins. sig_transposers :: PSignal -> Set ScoreT.Control sig_transposers :: PSignal -> Set Control sig_transposers = Scale -> Set Control pscale_transposers forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Scale sig_scale -- | Get the scale id of the signal. -- -- A PSignal can contain pitches from multiple scales, though I don't think this -- should ever happen. But if it does, the first pitch wins. sig_scale_id :: PSignal -> Pitch.ScaleId sig_scale_id :: PSignal -> ScaleId sig_scale_id = Scale -> ScaleId pscale_scale_id forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Scale sig_scale sig_scale :: PSignal -> Scale sig_scale :: PSignal -> Scale sig_scale = forall b a. b -> (a -> b) -> Maybe a -> b maybe Scale no_scale (forall a. RawPitch a -> Scale pitch_scale forall b c a. (b -> c) -> (a -> b) -> a -> c . forall y. Sample y -> y sy) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> Maybe a Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> [Sample y] Segment.to_samples forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal modify :: (Segment.Boxed Pitch -> Segment.Boxed Pitch) -> PSignal -> PSignal modify :: (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify Boxed Pitch -> Boxed Pitch f = Boxed Pitch -> PSignal PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . Boxed Pitch -> Boxed Pitch f forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal no_scale :: Scale no_scale :: Scale no_scale = ScaleId -> Set Control -> Scale Scale ScaleId "no-scale" forall a. Monoid a => a mempty -- * construct / destruct from_pairs :: [(RealTime, Pitch)] -> PSignal from_pairs :: [(RealTime, Pitch)] -> PSignal from_pairs = Boxed Pitch -> PSignal PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (v :: * -> *) y. Vector v (Sample y) => [(RealTime, y)] -> SignalS v y Segment.from_pairs from_sample :: RealTime -> Pitch -> PSignal from_sample :: RealTime -> Pitch -> PSignal from_sample RealTime x Pitch y = [(RealTime, Pitch)] -> PSignal from_pairs [(RealTime x, Pitch y)] from_segments :: [Segment.Segment Pitch] -> PSignal from_segments :: [Segment Pitch] -> PSignal from_segments = Boxed Pitch -> PSignal PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (v :: * -> *) y. Vector v (Sample y) => [Segment y] -> SignalS v y Segment.from_segments to_pairs :: PSignal -> [(RealTime, Pitch)] to_pairs :: PSignal -> [(RealTime, Pitch)] to_pairs = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> [(RealTime, y)] Segment.to_pairs forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal to_samples :: PSignal -> [Segment.Sample Pitch] to_samples :: PSignal -> [Sample Pitch] to_samples = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> [Sample y] Segment.to_samples forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal to_segments :: PSignal -> [Segment.Segment Pitch] to_segments :: PSignal -> [Segment Pitch] to_segments = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> [Segment y] Segment.to_segments forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal constant :: Pitch -> PSignal constant :: Pitch -> PSignal constant = Boxed Pitch -> PSignal PSignal forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (v :: * -> *) y. Vector v (Sample y) => y -> SignalS v y Segment.constant constant_val :: PSignal -> Maybe Pitch constant_val :: PSignal -> Maybe Pitch constant_val = forall (v :: * -> *) a. Vector v (Sample a) => SignalS v a -> Maybe a Segment.constant_val forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal prepend :: PSignal -> PSignal -> PSignal prepend :: PSignal -> PSignal -> PSignal prepend PSignal sig1 PSignal sig2 = Boxed Pitch -> PSignal PSignal forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => Maybe (y -> y -> Bool) -> Interpolate y -> SignalS v y -> SignalS v y -> SignalS v y Segment.prepend forall a. Maybe a Nothing Interpolate Pitch interpolate (PSignal -> Boxed Pitch _signal PSignal sig1) (PSignal -> Boxed Pitch _signal PSignal sig2) type ErrorText = Text -- | Flatten a signal to a non-transposeable Signal.NoteNumber. -- TODO I could probably avoid the intermediate list to_nn :: PSignal -> (Signal.NoteNumber, [(RealTime, ErrorText)]) to_nn :: PSignal -> (NoteNumber, [(RealTime, ErrorText)]) to_nn = forall {k} {a} {kind :: k}. Ord a => ([a], [(RealTime, Y)]) -> (Signal kind, [a]) extract forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. [Either a b] -> ([a], [b]) Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall {a} {a}. (a, RawPitch a) -> Either (a, ErrorText) (a, Y) eval forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> [(RealTime, Pitch)] to_pairs where extract :: ([a], [(RealTime, Y)]) -> (Signal kind, [a]) extract ([a] errs, [(RealTime, Y)] nns) = (forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind Signal.from_pairs [(RealTime, Y)] nns, forall a. Ord a => [a] -> [a] Lists.uniqueSort [a] errs) eval :: (a, RawPitch a) -> Either (a, ErrorText) (a, Y) eval (a x, RawPitch a pitch) = case Transposed -> Either PitchError NoteNumber pitch_nn (forall a b. RawPitch a -> RawPitch b coerce RawPitch a pitch) of Left PitchError err -> forall a b. a -> Either a b Left (a x, forall a. RawPitch a -> PitchError -> ErrorText DeriveT.detailed_error RawPitch a pitch PitchError err) Right (Pitch.NoteNumber Y nn) -> forall a b. b -> Either a b Right (a x, Y nn) unfoldr :: (state -> Maybe ((RealTime, Pitch), state)) -> state -> PSignal unfoldr :: forall state. (state -> Maybe ((RealTime, Pitch), state)) -> state -> PSignal unfoldr state -> Maybe ((RealTime, Pitch), state) gen state state = Boxed Pitch -> PSignal PSignal forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y state. Vector v (Sample y) => (state -> Maybe ((RealTime, y), state)) -> state -> SignalS v y Segment.unfoldr state -> Maybe ((RealTime, Pitch), state) gen state state -- * query null :: PSignal -> Bool null :: PSignal -> Bool null = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool Segment.null forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal at :: PSignal -> RealTime -> Maybe Pitch at :: PSignal -> RealTime -> Maybe Pitch at = forall (v :: * -> *) y. Vector v (Sample y) => Interpolate y -> SignalS v y -> RealTime -> Maybe y Segment.at Interpolate Pitch interpolate forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal at_negative :: PSignal -> RealTime -> Maybe Pitch at_negative :: PSignal -> RealTime -> Maybe Pitch at_negative = forall (v :: * -> *) y. Vector v (Sample y) => Interpolate y -> SignalS v y -> RealTime -> Maybe y Segment.at_negative Interpolate Pitch interpolate forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal segment_at :: PSignal -> RealTime -> Maybe (Segment.Segment Pitch) segment_at :: PSignal -> RealTime -> Maybe (Segment Pitch) segment_at = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> RealTime -> Maybe (Segment y) Segment.segment_at forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal head, last :: PSignal -> Maybe (RealTime, Pitch) head :: PSignal -> Maybe (RealTime, Pitch) head = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Maybe (RealTime, y) Segment.head forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal last :: PSignal -> Maybe (RealTime, Pitch) last = forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Maybe (RealTime, y) Segment.last forall b c a. (b -> c) -> (a -> b) -> a -> c . PSignal -> Boxed Pitch _signal -- * transform drop_after, drop_before :: RealTime -> PSignal -> PSignal drop_after :: RealTime -> PSignal -> PSignal drop_after RealTime x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => RealTime -> SignalS v y -> SignalS v y Segment.drop_after RealTime x drop_before :: RealTime -> PSignal -> PSignal drop_before RealTime x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => RealTime -> SignalS v y -> SignalS v y Segment.drop_before RealTime x clip_after, clip_before :: RealTime -> PSignal -> PSignal clip_after :: RealTime -> PSignal -> PSignal clip_after RealTime x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => Interpolate y -> RealTime -> SignalS v y -> SignalS v y Segment.clip_after Interpolate Pitch interpolate RealTime x clip_before :: RealTime -> PSignal -> PSignal clip_before RealTime x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => Interpolate y -> RealTime -> SignalS v y -> SignalS v y Segment.clip_before Interpolate Pitch interpolate RealTime x shift :: RealTime -> PSignal -> PSignal shift :: RealTime -> PSignal -> PSignal shift RealTime x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify (forall v. RealTime -> Signal v -> Signal v Segment.shift RealTime x) type ControlMap = Map ScoreT.Control (ScoreT.Typed Signal.Control) -- | Resample the signal according to the 'sig_transposers' and apply the given -- controls to the signal. -- -- Controls are /added/ so if this is not correct for a given control then -- this will do the wrong thing. Transpose signals should be additive so it'll -- be ok as long as you only apply transposing signals and only apply the -- complete ControlMap once at the end (i.e. "Perform.Midi.Convert"). {-# SCC apply_controls #-} apply_controls :: ControlMap -> PSignal -> PSignal apply_controls :: ControlMap -> PSignal -> PSignal apply_controls ControlMap cmap PSignal psig = case forall a. [a] -> Maybe a Lists.head (PSignal -> [(RealTime, Pitch)] to_pairs PSignal psig) of Maybe (RealTime, Pitch) Nothing -> forall a. Monoid a => a mempty Just (RealTime start, Pitch _) -> RealTime -> PSignal make1 RealTime start where make1 :: RealTime -> PSignal make1 RealTime start = [(RealTime, Pitch)] -> PSignal from_pairs forall a b. (a -> b) -> a -> b $ forall {a} {b}. Eq a => [(a, b)] -> [(a, b)] drop1 forall a b. (a -> b) -> a -> b $ forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe forall {b}. (RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, RawPitch b) make forall a b. (a -> b) -> a -> b $ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)] zip3 [RealTime] xs [Maybe Pitch] pitch_resamples [[Y]] control_resamples where -- Discard transpose samples before the pitch starts. The -- Signal.at_after below should ensure there is at most one of these, -- plus one for the transition from zero added by -- 'Segment.add_zero_transition'. make :: (RealTime, Maybe Pitch, [Y]) -> Maybe (RealTime, RawPitch b) make (RealTime _, Maybe Pitch Nothing, [Y] _) = forall a. Maybe a Nothing make (RealTime x, Just Pitch pitch, [Y] controls) = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ (RealTime x,) forall a b. (a -> b) -> a -> b $ forall a b. RawPitch a -> RawPitch b coerce forall a b. (a -> b) -> a -> b $ ControlValMap -> Pitch -> Transposed apply ControlValMap cmap2 Pitch pitch where cmap2 :: ControlValMap cmap2 = forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList (forall a b. [a] -> [b] -> [(a, b)] zip [Control] control_names [Y] controls) forall a. Semigroup a => a -> a -> a <> RealTime -> ControlMap -> ControlValMap controls_at RealTime x ControlMap non_transposers control_resamples :: [[Y]] control_resamples | forall (t :: * -> *) a. Foldable t => t a -> Bool List.null [[Sample Y]] control_samples = forall a. Int -> a -> [a] replicate (forall (t :: * -> *) a. Foldable t => t a -> Int length [RealTime] xs) [] | Bool otherwise = forall a. [[a]] -> [[a]] Lists.rotate forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map ([RealTime] -> [Sample Y] -> [Y] Segment.resample_num [RealTime] xs) [[Sample Y]] control_samples pitch_resamples :: [Maybe Pitch] pitch_resamples = forall y. Interpolate y -> [RealTime] -> [Sample y] -> [Maybe y] Segment.resample_maybe Interpolate Pitch interpolate [RealTime] xs forall a b. (a -> b) -> a -> b $ PSignal -> [Sample Pitch] to_samples PSignal psig control_samples :: [[Sample Y]] control_samples = forall a b. (a -> b) -> [a] -> [b] map (forall y. y -> [Sample y] -> [Sample y] Segment.add_zero_transition Y 0 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {k} (kind :: k). Signal kind -> [Sample Y] Signal.to_samples forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind Signal.drop_before RealTime start) [Signal ControlSig] control_signals (([Control] control_names, [Signal ControlSig] control_signals), ControlMap non_transposers) = PSignal -> ControlMap -> (([Control], [Signal ControlSig]), ControlMap) unzip_controls PSignal psig ControlMap cmap xs :: [RealTime] xs = [[RealTime]] -> [RealTime] Segment.sample_xs ([RealTime] pitch_xs forall a. a -> [a] -> [a] : [[RealTime]] control_xs) pitch_xs :: [RealTime] pitch_xs = forall a b. (a -> b) -> [a] -> [b] map forall y. Sample y -> RealTime Segment.sx forall a b. (a -> b) -> a -> b $ PSignal -> [Sample Pitch] to_samples PSignal psig control_xs :: [[RealTime]] control_xs = forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map forall y. Sample y -> RealTime Signal.sx) [[Sample Y]] control_samples -- If the control and pitch starts at the same place, I'll get an extra -- pre-transposed pitch. It's just confusing clutter, especially if the -- transpose is invalid, at which point I'm just left with the original -- pitch. drop1 :: [(a, b)] -> [(a, b)] drop1 ((a x1, b _) : xs :: [(a, b)] xs@((a x2, b _) : [(a, b)] _)) | a x1 forall a. Eq a => a -> a -> Bool == a x2 = [(a, b)] xs drop1 [(a, b)] xs = [(a, b)] xs -- | Separate transposing from non-transposing controls. -- -- This discards the ScoreT.Type, since 'apply' doesn't use that. The -- usual type distinctions like chromatic or diatonic instead get separate -- controls. unzip_controls :: PSignal -> ControlMap -> (([ScoreT.Control], [Signal.Control]), ControlMap) unzip_controls :: PSignal -> ControlMap -> (([Control], [Signal ControlSig]), ControlMap) unzip_controls PSignal psig ControlMap cmap = ( forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall a b. (a -> b) -> [a] -> [b] map forall a. Typed a -> a ScoreT.val_of) (forall a b. [(a, b)] -> ([a], [b]) unzip [(Control, Typed (Signal ControlSig))] transposers) , forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList [(Control, Typed (Signal ControlSig))] non_transposers ) where ([(Control, Typed (Signal ControlSig))] transposers, [(Control, Typed (Signal ControlSig))] non_transposers) = forall a. (a -> Bool) -> [a] -> ([a], [a]) List.partition ((forall a. Ord a => a -> Set a -> Bool `Set.member` PSignal -> Set Control sig_transposers PSignal psig) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toAscList ControlMap cmap -- | Not exported, use the one in Derive.Score instead. controls_at :: RealTime -> ControlMap -> Map ScoreT.Control Signal.Y controls_at :: RealTime -> ControlMap -> ControlValMap controls_at RealTime t = forall a b k. (a -> b) -> Map k a -> Map k b Map.map ((forall {k} (kind :: k). Signal kind -> RealTime -> Y `Signal.at` RealTime t) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Typed a -> a ScoreT.val_of) -- | 'apply_controls' specialized for a single control. apply_control :: ScoreT.Control -> ScoreT.Typed Signal.Control -> PSignal -> PSignal apply_control :: Control -> Typed (Signal ControlSig) -> PSignal -> PSignal apply_control Control cont Typed (Signal ControlSig) sig = ControlMap -> PSignal -> PSignal apply_controls (forall k a. k -> a -> Map k a Map.singleton Control cont Typed (Signal ControlSig) sig) -- | Apply an environ to all the pitches in the signal. Unlike -- 'apply_controls', this doesn't have to resample the signal. {-# SCC apply_environ #-} apply_environ :: DeriveT.Environ -> PSignal -> PSignal apply_environ :: Environ -> PSignal -> PSignal apply_environ Environ env = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => (y -> y) -> SignalS v y -> SignalS v y Segment.map_y_linear forall a b. (a -> b) -> a -> b $ forall a b. PitchConfig -> RawPitch a -> RawPitch b apply_config (Environ -> ControlValMap -> PitchConfig PitchConfig Environ env forall a. Monoid a => a mempty) map_y_linear :: (Pitch -> Pitch) -> PSignal -> PSignal map_y_linear :: (Pitch -> Pitch) -> PSignal -> PSignal map_y_linear = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (v :: * -> *) y. Vector v (Sample y) => (y -> y) -> SignalS v y -> SignalS v y Segment.map_y_linear -- ** hacks drop_discontinuity_at :: RealTime -> PSignal -> PSignal drop_discontinuity_at :: RealTime -> PSignal -> PSignal drop_discontinuity_at RealTime x = (Boxed Pitch -> Boxed Pitch) -> PSignal -> PSignal modify forall a b. (a -> b) -> a -> b $ forall (v :: * -> *) y. Vector v (Sample y) => RealTime -> SignalS v y -> SignalS v y Segment.drop_discontinuity_at RealTime x -- * Pitch -- | This is like pretty for pitch, but just shows the symbolic note name. symbolic_pitch :: RawPitch a -> Text symbolic_pitch :: forall a. RawPitch a -> ErrorText symbolic_pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall a. Show a => a -> ErrorText showt Note -> ErrorText Pitch.note_text forall b c a. (b -> c) -> (a -> b) -> a -> c . Transposed -> Either PitchError Note pitch_note forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. RawPitch a -> RawPitch b coerce pitch_scale_id :: RawPitch a -> Pitch.ScaleId pitch_scale_id :: forall a. RawPitch a -> ScaleId pitch_scale_id = Scale -> ScaleId pscale_scale_id forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. RawPitch a -> Scale pitch_scale pitch_transposers :: Pitch -> Set ScoreT.Control pitch_transposers :: Pitch -> Set Control pitch_transposers = Scale -> Set Control pscale_transposers forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. RawPitch a -> Scale pitch_scale pitch_controls :: PitchConfig -> Map ScoreT.Control Signal.Y pitch_controls :: PitchConfig -> ControlValMap pitch_controls (PitchConfig Environ _ ControlValMap controls) = ControlValMap controls -- | Apply a config to a pitch. apply_config :: PitchConfig -> RawPitch a -> RawPitch b apply_config :: forall a b. PitchConfig -> RawPitch a -> RawPitch b apply_config PitchConfig c RawPitch a pitch = RawPitch a pitch { pitch_config :: PitchConfig pitch_config = PitchConfig c forall a. Semigroup a => a -> a -> a <> forall a. RawPitch a -> PitchConfig pitch_config RawPitch a pitch } -- | Apply just the controls part of a config to a pitch. apply :: Map ScoreT.Control Signal.Y -> Pitch -> Transposed apply :: ControlValMap -> Pitch -> Transposed apply ControlValMap controls | forall k a. Map k a -> Bool Map.null ControlValMap controls = forall a b. RawPitch a -> RawPitch b coerce | Bool otherwise = forall a b. PitchConfig -> RawPitch a -> RawPitch b apply_config (Environ -> ControlValMap -> PitchConfig PitchConfig forall a. Monoid a => a mempty ControlValMap controls) add_control :: ScoreT.Control -> Double -> RawPitch a -> RawPitch a add_control :: forall a. Control -> Y -> RawPitch a -> RawPitch a add_control Control control Y val RawPitch a pitch = RawPitch a pitch { pitch_config :: PitchConfig pitch_config = PitchConfig config forall a. Semigroup a => a -> a -> a <> forall a. RawPitch a -> PitchConfig pitch_config RawPitch a pitch } where config :: PitchConfig config = Environ -> ControlValMap -> PitchConfig PitchConfig forall a. Monoid a => a mempty (forall k a. k -> a -> Map k a Map.singleton Control control Y val) -- ** create -- | Create a Pitch that only emits the given NoteNumber, and doesn't respond -- to transposition. constant_pitch :: Pitch.ScaleId -> Pitch.Note -> Pitch.NoteNumber -> Pitch constant_pitch :: ScaleId -> Note -> NoteNumber -> Pitch constant_pitch ScaleId scale_id Note note NoteNumber nn = Scale -> (PitchConfig -> Either PitchError NoteNumber) -> (PitchConfig -> Either PitchError Note) -> PitchConfig -> Pitch pitch (ScaleId -> Set Control -> Scale Scale ScaleId scale_id forall a. Monoid a => a mempty) (forall a b. a -> b -> a const (forall a b. b -> Either a b Right NoteNumber nn)) (forall a b. a -> b -> a const (forall a b. b -> Either a b Right Note note)) forall a. Monoid a => a mempty -- | Like 'constant_pitch', but easier to use, but uses no_scale, which means -- the result will be unparseable. nn_pitch :: Pitch.NoteNumber -> Pitch nn_pitch :: NoteNumber -> Pitch nn_pitch NoteNumber nn = Scale -> (PitchConfig -> Either PitchError NoteNumber) -> (PitchConfig -> Either PitchError Note) -> PitchConfig -> Pitch pitch Scale no_scale (forall a b. a -> b -> a const (forall a b. b -> Either a b Right NoteNumber nn)) (forall a b. a -> b -> a const (forall a b. b -> Either a b Right (ErrorText -> Note Pitch.Note (forall a. Pretty a => a -> ErrorText pretty NoteNumber nn)))) forall a. Monoid a => a mempty