-- 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 {- | Post-processing utils. These are transformers that directly modify the output of a deriver, as opposed to simply modifying the 'Derive.Dynamic'. Unfortunately things are complicated by the presence of 'LEvent.Log's in the output stream. I haven't been able to figure out how to cleanly abstract that away, so I wind up with a collection of functions to handle specific kinds of maps. There are variants for each axis: - monadic vs. pure - state vs. stateless - 1:1 vs. 1:many - preserves order vs. doesn't preserve order TODO One big problem with this is the permutations. Another is that I should be able to fuse composed maps, but I think it'll mostly be defeated by the monadic bits, and maybe state. But even monadic bits should be theoretically fusible since I don't mind if the effects (i.e. exceptions) are interleaved. A job for pipes maybe? -} module Derive.Call.Post where import qualified Data.DList as DList import qualified Data.List as List import qualified Data.Set as Set import qualified Util.Lists as Lists import qualified Util.Log as Log import qualified Derive.Call as Call import qualified Derive.Call.NoteUtil as NoteUtil import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Deriver.Internal as Internal import qualified Derive.Env as Env import qualified Derive.EnvKey as EnvKey import qualified Derive.Expr as Expr import qualified Derive.LEvent as LEvent import qualified Derive.PSignal as PSignal import qualified Derive.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Derive.Stack as Stack import qualified Derive.Stream as Stream import Derive.Stream (Stream) import qualified Derive.Typecheck as Typecheck import qualified Perform.RealTime as RealTime import qualified Perform.Signal as Signal import qualified Ui.ScoreTime as ScoreTime import Global import Types -- * map events -- 'emap' is kind of an ugly name, but at least it's consistent and short. -- I previously used 'map', but it turns out replacing the Prelude map is -- really confusing. -- ** non-monadic -- | 1:1 non-monadic map without state. -- -- TODO this is expected to not destroy the order, but that isn't checked. -- That means either the event doesn't move, or it doesn't move past its -- neighbors. Way back when events didn't have their start times, I could -- express this by only mapping over the event, but I'm not sure how to do it -- now. And in any case, "don't destroy order" is more permissive than "don't -- move." emap1_ :: (a -> b) -> Stream a -> Stream b emap1_ :: forall a b. (a -> b) -> Stream a -> Stream b emap1_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap -- | Map on Score.Events. The function is allowed to move the events, since it -- sorts them afterwards. emap1_ord_ :: (a -> Score.Event) -> Stream a -> Stream Score.Event emap1_ord_ :: forall a. (a -> Event) -> Stream a -> Stream Event emap1_ord_ a -> Event f = Stream Event -> Stream Event Stream.sort forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Event f -- | 1:1 non-monadic map with state. This is like mapAccumL. emap1 :: (state -> a -> (state, b)) -> state -> Stream a -> (state, Stream b) emap1 :: forall state a b. (state -> a -> (state, b)) -> state -> Stream a -> (state, Stream b) emap1 state -> a -> (state, b) f state state = forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL state -> LEvent a -> (state, LEvent b) go state state forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where go :: state -> LEvent a -> (state, LEvent b) go state state (LEvent.Log Msg log) = (state state, forall a. Msg -> LEvent a LEvent.Log Msg log) go state state (LEvent.Event a event) = forall a. a -> LEvent a LEvent.Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> state -> a -> (state, b) f state state a event -- | 1:n non-monadic map with state. emap :: (state -> a -> (state, [Score.Event])) -> state -> Stream a -> (state, Stream Score.Event) emap :: forall state a. (state -> a -> (state, [Event])) -> state -> Stream a -> (state, Stream Event) emap state -> a -> (state, [Event]) f state state = forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second [Stream Event] -> Stream Event Stream.merge_asc_lists forall b c a. (b -> c) -> (a -> b) -> a -> c . forall state a b. (state -> a -> (state, [b])) -> state -> Stream a -> (state, [Stream b]) emap_groups state -> a -> (state, [Event]) f state state where emap_groups :: (state -> a -> (state, [b])) -> state -> Stream a -> (state, [Stream b]) emap_groups :: forall state a b. (state -> a -> (state, [b])) -> state -> Stream a -> (state, [Stream b]) emap_groups state -> a -> (state, [b]) f state state = forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL state -> LEvent a -> (state, Stream b) go state state forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where go :: state -> LEvent a -> (state, Stream b) go state state (LEvent.Log Msg log) = (state state, forall a. [Msg] -> Stream a Stream.from_logs [Msg log]) go state state (LEvent.Event a event) = forall a. [a] -> Stream a Stream.from_sorted_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> state -> a -> (state, [b]) f state state a event -- | This is 'emap', but it promises to emit events in sorted order. -- TODO except that's not enforced, and maybe I should just always sort. emap_asc :: (state -> a -> (state, [Score.Event])) -> state -> Stream a -> (state, Stream Score.Event) emap_asc :: forall state a. (state -> a -> (state, [Event])) -> state -> Stream a -> (state, Stream Event) emap_asc = forall state a. (state -> a -> (state, [Event])) -> state -> Stream a -> (state, Stream Event) emap -- | 'emap' without state. emap_ :: (a -> [Score.Event]) -> Stream a -> Stream Score.Event emap_ :: forall a. (a -> [Event]) -> Stream a -> Stream Event emap_ a -> [Event] f = [Stream Event] -> Stream Event Stream.merge_asc_lists forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall {a}. LEvent [a] -> Stream a flatten forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> [Event] f where flatten :: LEvent [a] -> Stream a flatten (LEvent.Log Msg log) = forall a. [Msg] -> Stream a Stream.from_logs [Msg log] flatten (LEvent.Event [a] events) = forall a. [a] -> Stream a Stream.from_sorted_events [a] events emap_asc_ :: (a -> [Score.Event]) -> Stream a -> Stream Score.Event emap_asc_ :: forall a. (a -> [Event]) -> Stream a -> Stream Event emap_asc_ = forall a. (a -> [Event]) -> Stream a -> Stream Event emap_ -- ** monadic -- | Apply a function to the non-log events. -- TODO assumes the function doesn't destroy the order. apply :: ([a] -> [b]) -> Stream.Stream a -> Stream.Stream b apply :: forall a b. ([a] -> [b]) -> Stream a -> Stream b apply [a] -> [b] f Stream a stream = forall e. [Msg] -> Stream e -> Stream e Stream.merge_logs [Msg] logs forall a b. (a -> b) -> a -> b $ forall a. [a] -> Stream a Stream.from_sorted_events ([a] -> [b] f [a] events) where ([a] events, [Msg] logs) = forall a. Stream a -> ([a], [Msg]) Stream.partition Stream a stream apply_m :: Functor f => ([a] -> f [b]) -> Stream.Stream a -> f (Stream.Stream b) apply_m :: forall (f :: * -> *) a b. Functor f => ([a] -> f [b]) -> Stream a -> f (Stream b) apply_m [a] -> f [b] f Stream a stream = forall e. [Msg] -> Stream e -> Stream e Stream.merge_logs [Msg] logs forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> Stream a Stream.from_sorted_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [a] -> f [b] f [a] events where ([a] events, [Msg] logs) = forall a. Stream a -> ([a], [Msg]) Stream.partition Stream a stream -- | 1:1 monadic map without state. emap1m_ :: (a -> Score.Event) -> (a -> Derive.Deriver b) -> Stream a -> Derive.Deriver (Stream b) emap1m_ :: forall a b. (a -> Event) -> (a -> Deriver b) -> Stream a -> Deriver (Stream b) emap1m_ a -> Event event_of a -> Deriver b f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a b. Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM LEvent a -> Deriver State Error (Maybe (LEvent b)) process forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where process :: LEvent a -> Deriver State Error (Maybe (LEvent b)) process (LEvent.Log Msg log) = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a. Msg -> LEvent a LEvent.Log Msg log process (LEvent.Event a a) = forall a. Event -> Deriver a -> Deriver (Maybe a) Derive.with_event (a -> Event event_of a a) forall a b. (a -> b) -> a -> b $ forall a. a -> LEvent a LEvent.Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> Deriver b f a a -- | Monadic map with state. The event type is polymorphic, so you can use -- 'LEvent.zip' and co. to zip up unthreaded state, constructed with 'control' -- and 'nexts' and such. emap_m :: (a -> Score.Event) -> (state -> a -> Derive.Deriver (state, [b])) -- ^ Process an event. Exceptions are caught and logged. -> state -> Stream a -> Derive.Deriver (state, Stream b) emap_m :: forall a state b. (a -> Event) -> (state -> a -> Deriver (state, [b])) -> state -> Stream a -> Deriver (state, Stream b) emap_m a -> Event event_of state -> a -> Deriver (state, [b]) f state state = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. DList a -> [a] DList.toList)) forall b c a. (b -> c) -> (a -> b) -> a -> c . state -> [LEvent a] -> Deriver State Error (state, DList (LEvent b)) go state state forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where go :: state -> [LEvent a] -> Deriver State Error (state, DList (LEvent b)) go state state [] = forall (m :: * -> *) a. Monad m => a -> m a return (state state, forall a. Monoid a => a mempty) go state state (LEvent.Log Msg log : [LEvent a] events) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a. a -> DList a -> DList a DList.cons (forall a. Msg -> LEvent a LEvent.Log Msg log)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> state -> [LEvent a] -> Deriver State Error (state, DList (LEvent b)) go state state [LEvent a] events go state state (LEvent.Event a event : [LEvent a] events) = do (state state, [b] output) <- forall a. a -> Maybe a -> a fromMaybe (state state, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Event -> Deriver a -> Deriver (Maybe a) Derive.with_event (a -> Event event_of a event) (state -> a -> Deriver (state, [b]) f state state a event) (state final, DList (LEvent b) outputs) <- state -> [LEvent a] -> Deriver State Error (state, DList (LEvent b)) go state state [LEvent a] events forall (m :: * -> *) a. Monad m => a -> m a return (state final, forall a. [a] -> DList a DList.fromList (forall a b. (a -> b) -> [a] -> [b] map forall a. a -> LEvent a LEvent.Event [b] output) forall a. Semigroup a => a -> a -> a <> DList (LEvent b) outputs) -- TODO this could also take [(a, LEvent Score.Event)] and omit 'event_of' -- since it's always 'snd', but this is basically the same as the separate -- annots approach I had earlier, and forces you to have a () annotation -- if you don't want one. emap_asc_m :: (a -> Score.Event) -> (state -> a -> Derive.Deriver (state, [Score.Event])) -- ^ Process an event. Exceptions are caught and logged. -> state -> Stream a -> Derive.Deriver (state, Stream Score.Event) emap_asc_m :: forall a state. (a -> Event) -> (state -> a -> Deriver (state, [Event])) -> state -> Stream a -> Deriver (state, Stream Event) emap_asc_m a -> Event event_of state -> a -> Deriver (state, [Event]) f state state = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second [[LEvent Event]] -> Stream Event merge) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) state x y. Monad m => (state -> x -> m (state, y)) -> state -> [x] -> m (state, [y]) Lists.mapAccumLM state -> LEvent a -> Deriver State Error (state, [LEvent Event]) go state state forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where merge :: [[LEvent Event]] -> Stream Event merge = [Stream Event] -> Stream Event Stream.merge_asc_lists forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a. [LEvent a] -> Stream a Stream.from_sorted_list go :: state -> LEvent a -> Deriver State Error (state, [LEvent Event]) go state state (LEvent.Event a event) = forall b a. b -> (a -> b) -> Maybe a -> b maybe (state state, []) (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. a -> LEvent a LEvent.Event)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Event -> Deriver a -> Deriver (Maybe a) Derive.with_event (a -> Event event_of a event) (state -> a -> Deriver (state, [Event]) f state state a event) go state state (LEvent.Log Msg log) = forall (m :: * -> *) a. Monad m => a -> m a return (state state, [forall a. Msg -> LEvent a LEvent.Log Msg log]) -- | 'emap_m' without the state. emap_m_ :: (a -> Score.Event) -> (a -> Derive.Deriver [b]) -> Stream a -> Derive.Deriver (Stream b) emap_m_ :: forall a b. (a -> Event) -> (a -> Deriver [b]) -> Stream a -> Deriver (Stream b) emap_m_ a -> Event event_of a -> Deriver [b] f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a state b. (a -> Event) -> (state -> a -> Deriver (state, [b])) -> state -> Stream a -> Deriver (state, Stream b) emap_m a -> Event event_of (\() a e -> (,) () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> Deriver [b] f a e) () emap_asc_m_ :: (a -> Score.Event) -> (a -> Derive.Deriver [Score.Event]) -> Stream a -> Derive.Deriver (Stream Score.Event) emap_asc_m_ :: forall a. (a -> Event) -> (a -> Deriver [Event]) -> Stream a -> Deriver (Stream Event) emap_asc_m_ a -> Event event_of a -> Deriver [Event] f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a, b) -> b snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a state. (a -> Event) -> (state -> a -> Deriver (state, [Event])) -> state -> Stream a -> Deriver (state, Stream Event) emap_asc_m a -> Event event_of (\() a e -> (,) () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> Deriver [Event] f a e) () -- | Postprocess each event with a NoteDeriver. This is necessary if you need -- to generate more notes, e.g. with 'Call.note'. emap_s_ :: (a -> Score.Event) -> (a -> Derive.NoteDeriver) -> Stream a -> Derive.NoteDeriver emap_s_ :: forall a. (a -> Event) -> (a -> Deriver (Stream Event)) -> Stream a -> Deriver (Stream Event) emap_s_ a -> Event event_of a -> Deriver (Stream Event) f = forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM LEvent a -> Deriver (Stream Event) go forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where go :: LEvent a -> Deriver (Stream Event) go (LEvent.Log Msg log) = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. [Msg] -> Stream a Stream.from_logs [Msg log] go (LEvent.Event a a) = forall a. a -> Maybe a -> a fromMaybe forall a. Monoid a => a mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Event -> Deriver a -> Deriver (Maybe a) Derive.with_event (a -> Event event_of a a) (a -> Deriver (Stream Event) f a a) merge_asc :: [[Score.Event]] -> [Score.Event] merge_asc :: [[Event]] -> [Event] merge_asc = forall k a. Ord k => (a -> k) -> [[a]] -> [a] Lists.mergeAscLists Event -> RealTime Score.event_start -- * only -- | Only process the events that match, otherwise pass unchanged. only :: (a -> event) -> (event -> Bool) -> (a -> event) -> a -> event only :: forall a event. (a -> event) -> (event -> Bool) -> (a -> event) -> a -> event only a -> event event_of event -> Bool match a -> event f a a = if event -> Bool match (a -> event event_of a a) then a -> event f a a else a -> event event_of a a has_instrument :: [ScoreT.Instrument] -> Score.Event -> Bool has_instrument :: [Instrument] -> Event -> Bool has_instrument [Instrument] wanted = (forall a. Ord a => a -> Set a -> Bool `Set.member` Set Instrument set) forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Instrument Score.event_instrument where set :: Set Instrument set = forall a. Ord a => [a] -> Set a Set.fromList [Instrument] wanted -- ** unthreaded state control :: ScoreT.Function -> Stream Score.Event -> [Signal.Y] control :: Function -> Stream Event -> [Y] control Function f = forall a b. (a -> b) -> [a] -> [b] map (Function f forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> RealTime Score.event_start) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [a] Stream.events_of real_time_control :: ScoreT.Function -> Stream Score.Event -> [RealTime] real_time_control :: Function -> Stream Event -> [RealTime] real_time_control Function f = forall a b. (a -> b) -> [a] -> [b] map Y -> RealTime RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c . Function -> Stream Event -> [Y] control Function f -- | Take a typed signal to RealTime durations. duration_control :: ScoreT.TimeT -> ScoreT.Function -> Stream Score.Event -> Derive.Deriver [RealTime] duration_control :: TimeT -> Function -> Stream Event -> Deriver [RealTime] duration_control TimeT time_t Function f Stream Event events = do let starts :: [RealTime] starts = forall a b. (a -> b) -> [a] -> [b] map Event -> RealTime Score.event_start (forall a. Stream a -> [a] Stream.events_of Stream Event events) case TimeT time_t of TimeT ScoreT.TReal -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Y -> RealTime RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c . Function f) [RealTime] starts TimeT ScoreT.TScore -> forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (\RealTime t -> forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver State Error RealTime Call.real_duration RealTime t (Y -> ScoreTime ScoreTime.from_double (Function f RealTime t))) [RealTime] starts -- | Zip each event up with its neighbors. neighbors :: Stream a -> Stream ([a], a, [a]) neighbors :: forall a. Stream a -> Stream ([a], a, [a]) neighbors Stream a events = forall a b. (a -> b) -> Stream a -> Stream b emap1_ (\([a] ps, [a] ns, a e) -> ([a] ps, a e, [a] ns)) forall a b. (a -> b) -> a -> b $ forall a b c. ([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a) Stream.zip3_on forall a. [a] -> [[a]] prevs forall a. [a] -> [[a]] nexts Stream a events -- | Zip each event with its nearest neighbor with the same key. A key might -- be 'Score.event_instrument', 'hand_key', or 'voice_key'. -- -- TODO it's awkward how calls that are not instrument-specific still have to -- choose between hand or voice when they want the next \"relevant\" note. -- Perhaps hand and voice should be merged into a single concept. They have to -- be distinct for the lilypond backend though. neighbors_by :: Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a) neighbors_by :: forall key a. Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a) neighbors_by a -> key key = forall a b. (a -> b) -> Stream a -> Stream b emap1_ ([a], a, [a]) -> (Maybe a, a, Maybe a) extract forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> Stream ([a], a, [a]) neighbors where extract :: ([a], a, [a]) -> (Maybe a, a, Maybe a) extract ([a] ps, a e, [a] ns) = ([a] -> Maybe a same [a] ps, a e, [a] -> Maybe a same [a] ns) where same :: [a] -> Maybe a same = forall a. [a] -> Maybe a Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] filter ((forall a. Eq a => a -> a -> Bool == a -> key key a e) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> key key) nexts_by :: Eq key => (a -> key) -> Stream a -> Stream (a, [a]) nexts_by :: forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, [a]) nexts_by a -> key key = forall a b. (a -> b) -> Stream a -> Stream b emap1_ ([a], a) -> (a, [a]) extract forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a) Stream.zip_on forall a. [a] -> [[a]] nexts where extract :: ([a], a) -> (a, [a]) extract ([a] ns, a e) = (a e, [a] -> [a] same [a] ns) where same :: [a] -> [a] same = forall a. (a -> Bool) -> [a] -> [a] filter ((forall a. Eq a => a -> a -> Bool == a -> key key a e) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> key key) -- | Like 'neighbors_by', but only the next neighbor. next_by :: Eq key => (a -> key) -> Stream a -> Stream (a, Maybe a) next_by :: forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, Maybe a) next_by a -> key key = forall a b. (a -> b) -> Stream a -> Stream b emap1_ forall {a} {a} {b}. (a, a, b) -> (a, b) extract forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a) neighbors_by a -> key key where extract :: (a, a, b) -> (a, b) extract (a _, a e, b n) = (a e, b n) prev_by :: Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a) prev_by :: forall key a. Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a) prev_by a -> key key = forall a b. (a -> b) -> Stream a -> Stream b emap1_ forall {a} {b} {c}. (a, b, c) -> (a, b) extract forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a) neighbors_by a -> key key where extract :: (a, b, c) -> (a, b) extract (a p, b e, c _) = (a p, b e) hand_key :: Score.Event -> (ScoreT.Instrument, Maybe Text) hand_key :: Event -> (Instrument, Maybe Text) hand_key Event e = ( Event -> Instrument Score.event_instrument Event e , forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.hand forall a b. (a -> b) -> a -> b $ Event -> Environ Score.event_environ Event e ) voice_key :: Score.Event -> (ScoreT.Instrument, Int) voice_key :: Event -> (Instrument, Int) voice_key Event e = ( Event -> Instrument Score.event_instrument Event e , forall a. a -> Maybe a -> a fromMaybe Int 0 forall a b. (a -> b) -> a -> b $ forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.voice forall a b. (a -> b) -> a -> b $ Event -> Environ Score.event_environ Event e ) -- | Extract subsequent events. nexts :: [a] -> [[a]] nexts :: forall a. [a] -> [[a]] nexts = forall a. Int -> [a] -> [a] drop Int 1 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [[a]] List.tails -- | Extract previous events. prevs :: [a] -> [[a]] prevs :: forall a. [a] -> [[a]] prevs = forall b a. (b -> a -> b) -> b -> [a] -> [b] scanl (forall a b c. (a -> b -> c) -> b -> a -> c flip (:)) [] -- ** misc maps -- | Apply a function on the first Event of an LEvent stream. -- TODO this shouldn't destroy the order, but it isn't checkded. map_first :: (a -> Derive.Deriver a) -> Stream a -> Derive.Deriver (Stream.Stream a) map_first :: forall a. (a -> Deriver a) -> Stream a -> Deriver (Stream a) map_first a -> Deriver a f = forall a. (a -> Stream a -> Deriver (Stream a)) -> Stream a -> Deriver (Stream a) map_head_tail forall a b. (a -> b) -> a -> b $ \a e Stream a es -> do a e <- a -> Deriver a f a e forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall a b. (a -> b) -> a -> b $ forall a. a -> LEvent a LEvent.Event a e forall a. a -> [a] -> [a] : forall a. Stream a -> [LEvent a] Stream.to_list Stream a es -- | Transform the first event and the rest of the events. map_head_tail :: (a -> Stream.Stream a -> Derive.Deriver (Stream.Stream a)) -> Stream a -> Derive.Deriver (Stream.Stream a) map_head_tail :: forall a. (a -> Stream a -> Deriver (Stream a)) -> Stream a -> Deriver (Stream a) map_head_tail a -> Stream a -> Deriver (Stream a) f = [LEvent a] -> Deriver (Stream a) go forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where go :: [LEvent a] -> Deriver (Stream a) go [] = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Stream a Stream.empty go (LEvent.Log Msg log : [LEvent a] rest) = forall a. Msg -> Stream a -> Stream a Stream.merge_log Msg log forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [LEvent a] -> Deriver (Stream a) go [LEvent a] rest go (LEvent.Event a event : [LEvent a] rest) = a -> Stream a -> Deriver (Stream a) f a event (forall a. [LEvent a] -> Stream a Stream.from_sorted_list [LEvent a] rest) -- * signal control_range :: Derive.ControlDeriver -> Derive.Deriver (Signal.Control, (RealTime, RealTime), [Log.Msg]) control_range :: ControlDeriver -> Deriver (Control, (RealTime, RealTime), [Msg]) control_range ControlDeriver deriver = do (Control sig, [Msg] logs) <- forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first forall a. Monoid a => [a] -> a mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> ([a], [Msg]) Stream.partition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ControlDeriver deriver let range :: (RealTime, RealTime) range = case (forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y) Signal.head Control sig, forall {k} (kind :: k). Signal kind -> Maybe (RealTime, Y) Signal.last Control sig) of (Just (RealTime s, Y _), Just (RealTime e, Y _)) -> (RealTime s, RealTime e) (Maybe (RealTime, Y), Maybe (RealTime, Y)) _ -> (RealTime 0, RealTime 0) forall (m :: * -> *) a. Monad m => a -> m a return (Control sig, (RealTime, RealTime) range, [Msg] logs) pitch_range :: Derive.PitchDeriver -> Derive.Deriver (PSignal.PSignal, (RealTime, RealTime), [Log.Msg]) pitch_range :: PitchDeriver -> Deriver (PSignal, (RealTime, RealTime), [Msg]) pitch_range PitchDeriver deriver = do (PSignal sig, [Msg] logs) <- forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first forall a. Monoid a => [a] -> a mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> ([a], [Msg]) Stream.partition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> PitchDeriver deriver let range :: (RealTime, RealTime) range = case (PSignal -> Maybe (RealTime, Pitch) PSignal.head PSignal sig, PSignal -> Maybe (RealTime, Pitch) PSignal.last PSignal sig) of (Just (RealTime s, Pitch _), Just (RealTime e, Pitch _)) -> (RealTime s, RealTime e) (Maybe (RealTime, Pitch), Maybe (RealTime, Pitch)) _ -> (RealTime 0, RealTime 0) forall (m :: * -> *) a. Monad m => a -> m a return (PSignal sig, (RealTime, RealTime) range, [Msg] logs) -- | Transform a pitch or control signal. signal :: Monoid sig => (sig -> sig) -> Derive.Deriver (Stream.Stream sig) -> Derive.Deriver (Stream.Stream sig) signal :: forall sig. Monoid sig => (sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig) signal sig -> sig f Deriver (Stream sig) deriver = do (sig sig, [Msg] logs) <- forall sig. Monoid sig => Deriver (Stream sig) -> Deriver (sig, [Msg]) derive_signal Deriver (Stream sig) deriver forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall a b. (a -> b) -> a -> b $ forall a. a -> LEvent a LEvent.Event (sig -> sig f sig sig) forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map forall a. Msg -> LEvent a LEvent.Log [Msg] logs derive_signal :: Monoid sig => Derive.Deriver (Stream.Stream sig) -> Derive.Deriver (sig, [Log.Msg]) derive_signal :: forall sig. Monoid sig => Deriver (Stream sig) -> Deriver (sig, [Msg]) derive_signal Deriver (Stream sig) deriver = do ([sig] chunks, [Msg] logs) <- forall a. Stream a -> ([a], [Msg]) Stream.partition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver (Stream sig) deriver forall (m :: * -> *) a. Monad m => a -> m a return (forall a. Monoid a => [a] -> a mconcat [sig] chunks, [Msg] logs) -- * delayed events {- | Make a delayed event. A delayed event should be realized by an accompanying postproc call. It has an 'EnvKey.args', which are the arguments to the postproc call, and so it's a little bit like a closure or a delayed thunk. It's awkward because you have to manually call the postproc, which then has to extract the args and re-typecheck them. I considered storing actual thunks as functions, and running a generic postproc which forces them, but I think each one is likely to require a different context. E.g. previous and next events for the same instrument, or with the same hand, or map over groups of events, etc. TODO wait until I have more experience. TODO this stuff is now unused, but maybe I'll find a use for it again some day. -} make_delayed :: Derive.PassedArgs a -> RealTime -> [DeriveT.Val] -> Derive.NoteDeriver make_delayed :: forall a. PassedArgs a -> RealTime -> [Val] -> Deriver (Stream Event) make_delayed PassedArgs a args RealTime start [Val] event_args = do Dynamic dyn <- forall a. (Dynamic -> a) -> Deriver a Internal.get_dynamic forall a. a -> a id forall a. a -> Stream a Stream.from_event forall b c a. (b -> c) -> (a -> b) -> a -> c . [Val] -> Event -> Event delayed_event [Val] event_args forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. PassedArgs a -> Dynamic -> RealTime -> RealTime -> Text -> Flags -> Deriver Event NoteUtil.make_event PassedArgs a args Dynamic dyn RealTime start RealTime 0 Text "" forall a. Monoid a => a mempty delayed_event :: [DeriveT.Val] -> Score.Event -> Score.Event delayed_event :: [Val] -> Event -> Event delayed_event [Val] args = (Environ -> Environ) -> Event -> Event Score.modify_environ forall a b. (a -> b) -> a -> b $ forall a. ToVal a => Text -> a -> Environ -> Environ Env.insert_val Text EnvKey.args ([Val] -> Val DeriveT.VList [Val] args) -- | Return the args if this is a delayed event created by the given call. delayed_args :: Expr.Symbol -> Score.Event -> Maybe [DeriveT.Val] delayed_args :: Symbol -> Event -> Maybe [Val] delayed_args (Expr.Symbol Text call) Event event | forall a. [a] -> Maybe a Lists.head (Stack -> [Frame] Stack.innermost (Event -> Stack Score.event_stack Event event)) forall a. Eq a => a -> a -> Bool == forall a. a -> Maybe a Just (Text -> Frame Stack.Call Text call) = forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.args (Event -> Environ Score.event_environ Event event) | Bool otherwise = forall a. Maybe a Nothing -- * modify events -- | Like 'add_environ', but check the type. put_environ :: Typecheck.ToVal a => Env.Key -> a -> Score.Event -> Either Text Score.Event put_environ :: forall a. ToVal a => Text -> a -> Event -> Either Text Event put_environ Text name a val Event event = case forall a. ToVal a => Text -> a -> Environ -> Either Text Environ Env.put_val Text name a val (Event -> Environ Score.event_environ Event event) of Left Text err -> forall a b. a -> Either a b Left Text err Right Environ env -> forall a b. b -> Either a b Right forall a b. (a -> b) -> a -> b $ Event event { event_environ :: Environ Score.event_environ = Environ env } add_environ :: Typecheck.ToVal a => Env.Key -> a -> Score.Event -> Score.Event add_environ :: forall a. ToVal a => Text -> a -> Event -> Event add_environ Text name a val = (Environ -> Environ) -> Event -> Event Score.modify_environ forall a b. (a -> b) -> a -> b $ forall a. ToVal a => Text -> a -> Environ -> Environ Env.insert_val Text name a val set_instrument :: (ScoreT.Instrument, Derive.Instrument) -- ^ unaliased instrument name, from 'Derive.get_instrument' -> Score.Event -> Score.Event set_instrument :: (Instrument, Instrument) -> Event -> Event set_instrument (Instrument score_inst, Instrument inst) = Instrument -> Environ -> Event -> Event Score.set_instrument Instrument score_inst (Instrument -> Environ Derive.inst_environ Instrument inst) -- * misc -- | Like 'Derive.with_event_stack', but directly add the event's innermost -- stack to a log msg. -- TODO unused add_event_stack :: Score.Event -> Log.Msg -> Log.Msg add_event_stack :: Event -> Msg -> Msg add_event_stack = forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. a -> a id (BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg with_stack forall b c a. (b -> c) -> (a -> b) -> a -> c . Stack -> Maybe (BlockId, TrackId, (ScoreTime, ScoreTime)) Stack.block_track_region_of forall b c a. (b -> c) -> (a -> b) -> a -> c . Event -> Stack Score.event_stack where with_stack :: (BlockId, TrackId, (ScoreTime, ScoreTime)) -> Msg -> Msg with_stack (BlockId block_id, TrackId track_id, (ScoreTime s, ScoreTime e)) Msg msg = Msg msg { msg_stack :: Maybe Stack Log.msg_stack = Msg -> Maybe Stack add_stack Msg msg } where add_stack :: Msg -> Maybe Stack add_stack = forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . Stack -> Stack add forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Maybe a -> a fromMaybe Stack Stack.empty forall b c a. (b -> c) -> (a -> b) -> a -> c . Msg -> Maybe Stack Log.msg_stack add :: Stack -> Stack add = Frame -> Stack -> Stack Stack.add (ScoreTime -> ScoreTime -> Frame Stack.Region ScoreTime s ScoreTime e) forall b c a. (b -> c) -> (a -> b) -> a -> c . Frame -> Stack -> Stack Stack.add (TrackId -> Frame Stack.Track TrackId track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c . Frame -> Stack -> Stack Stack.add (BlockId -> Frame Stack.Block BlockId block_id)