-- 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 {- | Support for high level score modifications. This is companion to "Cmd.ModifyEvents", which is for low level transformations. The main interface to this is "Cmd.Repl.LNote". The score language is code to to be interpreted, not data to be manipulated. This is good for flexibility, but bad for direct transformation. Therefore, all the functions in here rely on a certain amount of conventional structure to tame the flexibility. The lowest level, represented by a list of 'Note's, assumes that each note track has a single \"branch\" of control tracks underneath it, and each note event has control values within its extent, so each note can be sliced out and treated as a unit. So it doesn't support note tracks with multiple parallel children, and it doesn't support order-dependent control tracks, which means that relative controls are out too (TODO actually a relative control track is fine as long as there's only one). Also, since notes only carry along the controls directly underneath them, they can wind up with different control values when they are placed on a different track (TODO it would be possible to deal with this too, by copying the events forward). I initially attempted to support trees of control tracks in full generality, or even just an ordered list of controls, but there's a problem when different Notes have different controls: where do the control tracks get merged into a tree, relative to each other? Not only do I have to invent an order, but it has to be linear, since there's also no information to merge into a branching skeleton. Since I can't create one with 'Note's, I felt Notes shouldn't be able to parse them either. The 'Note's can be annotated with additional data, such as pitch, but of course will make it more specialized and reliant on convention. For instance, the pitches have to be extracted from the pitch events, which will fail unless there's an easily parseable pitch in there. TODO it should be possible to get the pitch out of the derivation by finding the corresponding Score.Event by looking for its stack. -} module Cmd.ModifyNotes where import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Tree as Tree import qualified Data.Vector as Vector import qualified Util.Lens as Lens import qualified Util.Lists as Lists import qualified Util.Maps as Maps import qualified Util.Pretty as Pretty import qualified Util.Trees as Trees import qualified Cmd.Cmd as Cmd import qualified Cmd.Create as Create import qualified Cmd.Selection as Selection import qualified Derive.PSignal as PSignal import qualified Derive.ParseTitle as ParseTitle import qualified Derive.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Derive.Stack as Stack import qualified Perform.Pitch as Pitch import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.TrackTree as TrackTree import qualified Ui.Types as Types import qualified Ui.Ui as Ui import Global import Types -- | This represents a single event on a note track. data Note = Note { Note -> TrackTime note_start :: !TrackTime , Note -> TrackTime note_duration :: !TrackTime , Note -> Error note_text :: !Text -- | This is the contents of the child tracks, where they overlap this -- Note's range. , Note -> Controls note_controls :: !Controls , Note -> Index note_index :: !Index , Note -> [TrackId] note_control_track_ids :: ![TrackId] } deriving (Note -> Note -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Note -> Note -> Bool $c/= :: Note -> Note -> Bool == :: Note -> Note -> Bool $c== :: Note -> Note -> Bool Eq, Index -> Note -> ShowS [Note] -> ShowS Note -> String forall a. (Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Note] -> ShowS $cshowList :: [Note] -> ShowS show :: Note -> String $cshow :: Note -> String showsPrec :: Index -> Note -> ShowS $cshowsPrec :: Index -> Note -> ShowS Show) note_end :: Note -> TrackTime note_end :: Note -> TrackTime note_end Note note = Note -> TrackTime note_start Note note forall a. Num a => a -> a -> a + Note -> TrackTime note_duration Note note start :: Note :-> TrackTime start = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a Lens.lens Note -> TrackTime note_start (\TrackTime -> TrackTime f Note r -> Note r { note_start :: TrackTime note_start = TrackTime -> TrackTime f (Note -> TrackTime note_start Note r) }) duration :: Note :-> TrackTime duration = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a Lens.lens Note -> TrackTime note_duration (\TrackTime -> TrackTime f Note r -> Note r { note_duration :: TrackTime note_duration = TrackTime -> TrackTime f (Note -> TrackTime note_duration Note r) }) text :: Note :-> Error text = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a Lens.lens Note -> Error note_text (\Error -> Error f Note r -> Note r { note_text :: Error note_text = Error -> Error f (Note -> Error note_text Note r) }) controls :: Note :-> Controls controls = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a Lens.lens Note -> Controls note_controls (\Controls -> Controls f Note r -> Note r { note_controls :: Controls note_controls = Controls -> Controls f (Note -> Controls note_controls Note r) }) index :: Note :-> Index index = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a Lens.lens Note -> Index note_index (\Index -> Index f Note r -> Note r { note_index :: Index note_index = Index -> Index f (Note -> Index note_index Note r) }) end :: Note :-> TrackTime end = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a Lens.lens Note -> TrackTime note_end (\TrackTime -> TrackTime f Note r -> Note r { note_start :: TrackTime note_start = TrackTime -> TrackTime f (Note -> TrackTime note_end Note r) forall a. Num a => a -> a -> a - Note -> TrackTime note_duration Note r }) note_min :: Note -> TrackTime note_min :: Note -> TrackTime note_min Note n = forall a. Ord a => a -> a -> a min (Note -> TrackTime note_start Note n) (Note -> TrackTime note_end Note n) note_max :: Note -> TrackTime note_max :: Note -> TrackTime note_max Note n = forall a. Ord a => a -> a -> a max (Note -> TrackTime note_start Note n) (Note -> TrackTime note_end Note n) note_orientation :: Note -> Types.Orientation note_orientation :: Note -> Orientation note_orientation = TrackTime -> Orientation Event.orientation_of forall b c a. (b -> c) -> (a -> b) -> a -> c . Note -> TrackTime note_duration -- | Each note has an Index, which indicates which of the selected note tracks -- it came from, or should be written to. type Index = Int instance Pretty Note where format :: Note -> Doc format (Note TrackTime start TrackTime dur Error text Controls controls Index index [TrackId] control_track_ids) = Doc -> [(Error, Doc)] -> Doc Pretty.record Doc title forall a b. (a -> b) -> a -> b $ (if Error text forall a. Eq a => a -> a -> Bool == forall a. Monoid a => a mempty then [] else [(Error "text", forall a. Pretty a => a -> Doc Pretty.format Error text)]) forall a. [a] -> [a] -> [a] ++ [ (Error "controls", forall a. Pretty a => a -> Doc Pretty.format Controls controls) , (Error "index", forall a. Pretty a => a -> Doc Pretty.format Index index) , (Error "control_track_ids", forall a. Pretty a => a -> Doc Pretty.format [TrackId] control_track_ids) ] where title :: Doc title = Error -> Doc Pretty.text Error "Note" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc Pretty.format (TrackTime start, TrackTime dur) notes_overlap :: Note -> Note -> Bool notes_overlap :: Note -> Note -> Bool notes_overlap Note n1 Note n2 = Bool -> Bool not forall a b. (a -> b) -> a -> b $ Note -> TrackTime note_min Note n1 forall a. Ord a => a -> a -> Bool >= Note -> TrackTime note_max Note n2 Bool -> Bool -> Bool || Note -> TrackTime note_max Note n1 forall a. Ord a => a -> a -> Bool <= Note -> TrackTime note_min Note n2 -- * controls type Controls = Map Control Events.Events -- | A simplified version of 'ParseTitle.ControlType', since Notes don't -- support all the forms of control tracks. Put Pitch first so it sorts first, -- to support the convention of putting the pitch track right after the note -- track. data Control = Pitch Pitch.ScaleId | Control ScoreT.Control deriving (Control -> Control -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Control -> Control -> Bool $c/= :: Control -> Control -> Bool == :: Control -> Control -> Bool $c== :: Control -> Control -> Bool Eq, Eq Control Control -> Control -> Bool Control -> Control -> Ordering Control -> Control -> Control forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Control -> Control -> Control $cmin :: Control -> Control -> Control max :: Control -> Control -> Control $cmax :: Control -> Control -> Control >= :: Control -> Control -> Bool $c>= :: Control -> Control -> Bool > :: Control -> Control -> Bool $c> :: Control -> Control -> Bool <= :: Control -> Control -> Bool $c<= :: Control -> Control -> Bool < :: Control -> Control -> Bool $c< :: Control -> Control -> Bool compare :: Control -> Control -> Ordering $ccompare :: Control -> Control -> Ordering Ord, Index -> Control -> ShowS [Control] -> ShowS Control -> String forall a. (Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Control] -> ShowS $cshowList :: [Control] -> ShowS show :: Control -> String $cshow :: Control -> String showsPrec :: Index -> Control -> ShowS $cshowsPrec :: Index -> Control -> ShowS Show) instance Pretty Control where pretty :: Control -> Error pretty = Control -> Error control_to_title control_to_title :: Control -> Text control_to_title :: Control -> Error control_to_title Control control = case Control control of Control Control c -> Typed Control -> Error ParseTitle.control_to_title forall a b. (a -> b) -> a -> b $ forall a. a -> Typed a ScoreT.untyped Control c Pitch ScaleId scale_id -> ScaleId -> Error ParseTitle.scale_to_title ScaleId scale_id type Error = Text title_to_control :: Text -> Either Error Control title_to_control :: Error -> Either Error Control title_to_control Error title = Error -> Either Error ControlType ParseTitle.parse_control_type Error title forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case ParseTitle.Control (Right (ScoreT.Typed Type ScoreT.Untyped Control c)) Maybe TrackCall Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Control -> Control Control Control c ParseTitle.Pitch ScaleId scale_id (Right PControl pcontrol) | PControl pcontrol forall a. Eq a => a -> a -> Bool == PControl ScoreT.default_pitch -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ ScaleId -> Control Pitch ScaleId scale_id ControlType _ -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Error "complicated controls unsupported: " forall a. Semigroup a => a -> a -> a <> Error title -- | Put the pitch tracks next to the note, the rest go in alphabetical order. sorted_controls :: Controls -> [(Control, Events.Events)] sorted_controls :: Controls -> [(Control, Events)] sorted_controls = forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn (forall {a}. Num a => Control -> (a, Control) key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [(k, a)] Map.toList where key :: Control -> (a, Control) key c :: Control c@(Pitch {}) = (a 0, Control c) key c :: Control c@(Control {}) = (a 1, Control c) -- * selection -- | Modify notes. type ModifyNotes m = BlockId -> [(Note, TrackId)] -> m [Note] notes :: Monad m => ([Note] -> [Note]) -> ModifyNotes m notes :: forall (m :: * -> *). Monad m => ([Note] -> [Note]) -> ModifyNotes m notes [Note] -> [Note] f BlockId _ = forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . [Note] -> [Note] f forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst -- | Modify a single note. note :: Monad m => (Note -> Note) -> ModifyNotes m note :: forall (m :: * -> *). Monad m => (Note -> Note) -> ModifyNotes m note Note -> Note f BlockId _ = forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (Note -> Note f forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) -- | Modify notes on the selected tracks. Only the top level note tracks are -- affected, so you can select an entire block and not worry about mangling -- parent controls. -- -- This may add new tracks, but will not delete tracks that are made empty. -- It could, but it seems easy enough to delete the tracks by hand once -- I verify that the transformation worked. TODO revisit this if it's annoying selection :: Cmd.M m => ModifyNotes m -> m () selection :: forall (m :: * -> *). M m => ModifyNotes m -> m () selection ModifyNotes m modify = do [(Note, TrackId)] old_notes <- forall (m :: * -> *). M m => m [(Note, TrackId)] selected_notes BlockId block_id <- forall (m :: * -> *). M m => m BlockId Cmd.get_focused_block [Note] new_notes <- ModifyNotes m modify BlockId block_id [(Note, TrackId)] old_notes -- Clear selected events before merging in new ones. let ranges :: [(TrackId, Range)] ranges = [(Note, TrackId)] -> [(TrackId, Range)] remove_ranges [(Note, TrackId)] old_notes forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [(TrackId, Range)] ranges forall a b. (a -> b) -> a -> b $ \(TrackId track_id, Range range) -> forall (m :: * -> *). M m => TrackId -> Range -> m () Ui.remove_events_range TrackId track_id Range range forall (m :: * -> *). M m => BlockId -> [TrackId] -> [NoteTrack] -> m () write_tracks BlockId block_id (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(TrackId, Range)] ranges) ([Note] -> [NoteTrack] merge_notes [Note] new_notes) remove_ranges :: [(Note, TrackId)] -> [(TrackId, Events.Range)] remove_ranges :: [(Note, TrackId)] -> [(TrackId, Range)] remove_ranges = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap ([Note], TrackId) -> [(TrackId, Range)] range forall b c a. (b -> c) -> (a -> b) -> a -> c . forall b a. Ord b => [(a, b)] -> [(NonNull a, b)] Lists.groupSnd where range :: ([Note], TrackId) -> [(TrackId, Range)] range ([], TrackId _) = [] -- shouldn't happen, per Lists.groupSnd's postcondition range (notes :: [Note] notes@(Note note : [Note] _), TrackId track_id) = (TrackId track_id, TrackTime -> TrackTime -> Range Events.Range TrackTime start TrackTime end) forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map (, TrackTime -> TrackTime -> Range Events.Range TrackTime start TrackTime end) (Note -> [TrackId] note_control_track_ids Note note) where start :: TrackTime start = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a minimum forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map Note -> TrackTime note_min [Note] notes end :: TrackTime end = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a maximum forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map Note -> TrackTime note_max [Note] notes -- All Notes with the same TrackId should also have the same -- note_control_track_ids. -- | Find the top-level note tracks in the selection, and reduce them down to -- Notes. selected_notes :: Cmd.M m => m [(Note, TrackId)] selected_notes :: forall (m :: * -> *). M m => m [(Note, TrackId)] selected_notes = do let is_note :: (TrackId, b) -> m Bool is_note = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Error -> Bool ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => TrackId -> m Error Ui.get_track_title forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst [(TrackId, [Event])] sel <- forall (m :: * -> *) a. Applicative m => (a -> m Bool) -> [a] -> m [a] filterM forall {b}. (TrackId, b) -> m Bool is_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m [(TrackId, [Event])] Selection.events TrackTree tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree TrackTree.track_tree_of forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m BlockId Cmd.get_focused_block forall (m :: * -> *). M m => TrackTree -> [(TrackId, [Event])] -> m [(Note, TrackId)] slice_tracks TrackTree tree [(TrackId, [Event])] sel -- ** annotated transformations type Annotated a m = [(Note, a)] -> m [Note] annotate_nns :: Cmd.M m => Annotated (Maybe Pitch.NoteNumber) m -> ModifyNotes m annotate_nns :: forall (m :: * -> *). M m => Annotated (Maybe NoteNumber) m -> ModifyNotes m annotate_nns Annotated (Maybe NoteNumber) m modify = forall (m :: * -> *). M m => Annotated (Maybe Transposed, ControlValMap) m -> ModifyNotes m annotate_controls (Annotated (Maybe NoteNumber) m modify forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (Transposed -> Maybe NoteNumber eval forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< forall a b. (a, b) -> a fst))) where eval :: Transposed -> Maybe NoteNumber eval = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a b. a -> b -> a const forall a. Maybe a Nothing) forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . Transposed -> Either PitchError NoteNumber PSignal.pitch_nn annotate_controls :: Cmd.M m => Annotated (Maybe PSignal.Transposed, ScoreT.ControlValMap) m -> ModifyNotes m annotate_controls :: forall (m :: * -> *). M m => Annotated (Maybe Transposed, ControlValMap) m -> ModifyNotes m annotate_controls Annotated (Maybe Transposed, ControlValMap) m modify BlockId block_id [(Note, TrackId)] note_track_ids = do Vector Event events <- Performance -> Vector Event Cmd.perf_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m Performance Cmd.get_performance BlockId block_id Annotated (Maybe Transposed, ControlValMap) m modify forall a b. (a -> b) -> a -> b $ [(Note, TrackId)] -> Vector Event -> [(Note, (Maybe Transposed, ControlValMap))] find_controls [(Note, TrackId)] note_track_ids Vector Event events -- | This finds the controls of each note by looking for its corresponding -- event in the performance. TODO matching by stack seems like it could be -- inaccurate, and inefficient too. Shouldn't I look up the signal directly -- from the performance? find_controls :: [(Note, TrackId)] -> Vector.Vector Score.Event -> [(Note, (Maybe PSignal.Transposed, ScoreT.ControlValMap))] find_controls :: [(Note, TrackId)] -> Vector Event -> [(Note, (Maybe Transposed, ControlValMap))] find_controls [(Note, TrackId)] note_track_ids Vector Event events = forall a b. [a] -> [b] -> [(a, b)] zip (forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(Note, TrackId)] note_track_ids) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (Maybe Event -> (Maybe Transposed, ControlValMap) extract forall b c a. (b -> c) -> (a -> b) -> a -> c . Vector Event -> (Note, TrackId) -> Maybe Event convert Vector Event events) [(Note, TrackId)] note_track_ids where convert :: Vector Event -> (Note, TrackId) -> Maybe Event convert Vector Event events (Note note, TrackId track_id) = TrackId -> Note -> Vector Event -> Maybe Event find_event TrackId track_id Note note Vector Event events extract :: Maybe Event -> (Maybe Transposed, ControlValMap) extract Maybe Event Nothing = (forall a. Maybe a Nothing, forall a. Monoid a => a mempty) extract (Just Event event) = ( Event -> Maybe Transposed Score.initial_pitch Event event , RealTime -> Event -> ControlValMap Score.event_controls_at (Event -> RealTime Score.event_start Event event) Event event ) find_event :: TrackId -> Note -> Vector.Vector Score.Event -> Maybe Score.Event find_event :: TrackId -> Note -> Vector Event -> Maybe Event find_event TrackId track_id Note note = forall a. (a -> Bool) -> Vector a -> Maybe a Vector.find forall a b. (a -> b) -> a -> b $ \Event event -> TrackId -> TrackTime -> TrackTime -> Stack -> Bool stack_matches TrackId track_id (Note -> TrackTime note_start Note note) (Note -> TrackTime note_end Note note) forall a b. (a -> b) -> a -> b $ Event -> Stack Score.event_stack Event event stack_matches :: TrackId -> TrackTime -> TrackTime -> Stack.Stack -> Bool stack_matches :: TrackId -> TrackTime -> TrackTime -> Stack -> Bool stack_matches TrackId track_id TrackTime start TrackTime end = [Frame] -> Bool find_track forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackTime -> TrackTime -> [Frame] -> [Frame] find_region TrackTime start TrackTime end forall b c a. (b -> c) -> (a -> b) -> a -> c . Stack -> [Frame] Stack.innermost where find_region :: TrackTime -> TrackTime -> [Frame] -> [Frame] find_region TrackTime start TrackTime end = forall a. Index -> [a] -> [a] drop Index 1 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] dropWhile (forall a. Eq a => a -> a -> Bool /= TrackTime -> TrackTime -> Frame Stack.Region TrackTime start TrackTime end) -- Find the Track, but abort if I see a region or block find_track :: [Frame] -> Bool find_track [Frame] frames = case [Frame] frames of Stack.Track TrackId tid : [Frame] _ -> TrackId track_id forall a. Eq a => a -> a -> Bool == TrackId tid Stack.Call {} : [Frame] rest -> [Frame] -> Bool find_track [Frame] rest [Frame] _ -> Bool False -- * read slice_tracks :: Ui.M m => TrackTree.TrackTree -> [(TrackId, [Event.Event])] -> m [(Note, TrackId)] slice_tracks :: forall (m :: * -> *). M m => TrackTree -> [(TrackId, [Event])] -> m [(Note, TrackId)] slice_tracks TrackTree tree = forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM forall (m :: * -> *). M m => (Index, (TrackId, [Event])) -> m [(Note, TrackId)] slice forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. [a] -> [b] -> [(a, b)] zip [Index 0..] where slice :: Ui.M m => (Index, (TrackId, [Event.Event])) -> m [(Note, TrackId)] slice :: forall (m :: * -> *). M m => (Index, (TrackId, [Event])) -> m [(Note, TrackId)] slice (Index index, (TrackId track_id, [Event] events)) = case forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a) Trees.find ((forall a. Eq a => a -> a -> Bool ==TrackId track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> TrackId Ui.track_id) TrackTree tree of Maybe (Tree TrackInfo) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return [] Just (Tree.Node TrackInfo _track TrackTree subs) -> do [Tree (TrackInfo, Events)] subs <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall {f :: * -> *}. M f => TrackInfo -> f (TrackInfo, Events) get_events) TrackTree subs [Note] notes <- forall (m :: * -> *) err a. (Stack, M m) => (err -> Error) -> Either err a -> m a Ui.require_right forall a. a -> a id forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (Index -> [Tree (TrackInfo, Events)] -> Event -> Either Error Note slice_note Index index [Tree (TrackInfo, Events)] subs) [Event] events forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (, TrackId track_id) [Note] notes get_events :: TrackInfo -> f (TrackInfo, Events) get_events TrackInfo track = (TrackInfo track,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => TrackId -> m Events Ui.get_events (TrackInfo -> TrackId Ui.track_id TrackInfo track) -- | The whole thing fails if a title is unparseable or the control tracks have -- a fork in the skeleton. -- -- This is similar to 'Derive.Slice.slice' and I initially spent some time -- trying to reuse it, but it's different enough that most of the work that -- slice does doesn't apply here. slice_note :: Index -> [Tree.Tree (Ui.TrackInfo, Events.Events)] -> Event.Event -> Either Error Note slice_note :: Index -> [Tree (TrackInfo, Events)] -> Event -> Either Error Note slice_note Index index [Tree (TrackInfo, Events)] subs Event event = do [(Control, Events)] controls <- (TrackTime, TrackTime) -> [Tree (TrackInfo, Events)] -> Either Error [(Control, Events)] extract_controls (Event -> (TrackTime, TrackTime) Event.range Event event) [Tree (TrackInfo, Events)] subs forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Note { note_start :: TrackTime note_start = Event -> TrackTime Event.start Event event , note_duration :: TrackTime note_duration = Event -> TrackTime Event.duration Event event , note_text :: Error note_text = Event -> Error Event.text Event event , note_controls :: Controls note_controls = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [(Control, Events)] controls , note_index :: Index note_index = Index index , note_control_track_ids :: [TrackId] note_control_track_ids = forall a b. (a -> b) -> [a] -> [b] map (TrackInfo -> TrackId Ui.track_id 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 (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a. Tree a -> [a] Tree.flatten [Tree (TrackInfo, Events)] subs } extract_controls :: (TrackTime, TrackTime) -> [Tree.Tree (Ui.TrackInfo, Events.Events)] -> Either Error [(Control, Events.Events)] extract_controls :: (TrackTime, TrackTime) -> [Tree (TrackInfo, Events)] -> Either Error [(Control, Events)] extract_controls (TrackTime, TrackTime) range [Tree (TrackInfo, Events)] tracks = case [Tree (TrackInfo, Events)] tracks of [] -> forall (m :: * -> *) a. Monad m => a -> m a return [] [Tree.Node (TrackInfo track, Events events) [Tree (TrackInfo, Events)] subs] -> do Control control <- forall a. Error -> Either Error a -> Either Error a annotate (forall a. Show a => a -> Error showt (TrackInfo -> TrackId Ui.track_id TrackInfo track)) forall a b. (a -> b) -> a -> b $ Error -> Either Error Control title_to_control (TrackInfo -> Error Ui.track_title TrackInfo track) [(Control, Events)] rest <- (TrackTime, TrackTime) -> [Tree (TrackInfo, Events)] -> Either Error [(Control, Events)] extract_controls (TrackTime, TrackTime) range [Tree (TrackInfo, Events)] subs forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ (Control control, (TrackTime, TrackTime) -> Events -> Events slice (TrackTime, TrackTime) range Events events) forall a. a -> [a] -> [a] : [(Control, Events)] rest [Tree (TrackInfo, Events)] _ -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Error ">1 subtrack: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Error showt (forall a b. (a -> b) -> [a] -> [b] map (TrackInfo -> TrackId Ui.track_id forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Tree a -> a Tree.rootLabel) [Tree (TrackInfo, Events)] tracks) where slice :: (TrackTime, TrackTime) -> Events -> Events slice (TrackTime start, TrackTime end) Events e = Range -> Events -> Events Events.in_range (TrackTime -> TrackTime -> Range Events.Range TrackTime start TrackTime end) Events e annotate :: Text -> Either Error a -> Either Error a annotate :: forall a. Error -> Either Error a -> Either Error a annotate Error prefix = forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ((Error prefix forall a. Semigroup a => a -> a -> a <> Error ": ") <>) -- * write data NoteTrack = NoteTrack Events.Events Controls deriving (NoteTrack -> NoteTrack -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: NoteTrack -> NoteTrack -> Bool $c/= :: NoteTrack -> NoteTrack -> Bool == :: NoteTrack -> NoteTrack -> Bool $c== :: NoteTrack -> NoteTrack -> Bool Eq, Index -> NoteTrack -> ShowS [NoteTrack] -> ShowS NoteTrack -> String forall a. (Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [NoteTrack] -> ShowS $cshowList :: [NoteTrack] -> ShowS show :: NoteTrack -> String $cshow :: NoteTrack -> String showsPrec :: Index -> NoteTrack -> ShowS $cshowsPrec :: Index -> NoteTrack -> ShowS Show) instance Semigroup NoteTrack where NoteTrack Events events1 Controls controls1 <> :: NoteTrack -> NoteTrack -> NoteTrack <> NoteTrack Events events2 Controls controls2 = Events -> Controls -> NoteTrack NoteTrack (Events events1 forall a. Semigroup a => a -> a -> a <> Events events2) (forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a Maps.mappend Controls controls1 Controls controls2) instance Monoid NoteTrack where mempty :: NoteTrack mempty = Events -> Controls -> NoteTrack NoteTrack forall a. Monoid a => a mempty forall a. Monoid a => a mempty mappend :: NoteTrack -> NoteTrack -> NoteTrack mappend = forall a. Semigroup a => a -> a -> a (<>) merge_notes :: [Note] -> [NoteTrack] merge_notes :: [Note] -> [NoteTrack] merge_notes = forall a b. (a -> b) -> [a] -> [b] map [Note] -> NoteTrack make_track forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Ord key => (a -> key) -> [a] -> [[a]] Lists.groupSort Note -> Index note_index where make_track :: [Note] -> NoteTrack make_track :: [Note] -> NoteTrack make_track = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall a. Semigroup a => a -> a -> a (<>) forall a. Monoid a => a mempty forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Note -> NoteTrack note_track note_track :: Note -> NoteTrack note_track Note note = Events -> Controls -> NoteTrack NoteTrack (Event -> Events Events.singleton Event event) (Note -> Controls note_controls Note note) where event :: Event event = TrackTime -> TrackTime -> Error -> Event Event.event (Note -> TrackTime note_start Note note) (Note -> TrackTime note_duration Note note) (Note -> Error note_text Note note) -- | Write NoteTracks to the given block. It may create new tracks, but won't -- delete ones that are made empty. write_tracks :: Ui.M m => BlockId -> [TrackId] -- ^ The TrackIds are expected to line up with NoteTracks. -- If there are more NoteTracks than TrackIds, new tracks will be created. -> [NoteTrack] -> m () write_tracks :: forall (m :: * -> *). M m => BlockId -> [TrackId] -> [NoteTrack] -> m () write_tracks BlockId block_id [TrackId] track_ids [NoteTrack] tracks = do TrackTree old_tree <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m TrackTree extract_note_trees BlockId block_id [TrackId] track_ids forall (m :: * -> *) a b c. Applicative m => (a -> b -> m c) -> [a] -> [b] -> m () zipWithM_ forall {m :: * -> *}. M m => Tree TrackInfo -> NoteTrack -> m () merge TrackTree old_tree [NoteTrack] tracks Index next_tracknum <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m Index tracknum_after BlockId block_id [TrackId] track_ids forall {m :: * -> *}. M m => Index -> [NoteTrack] -> m () create Index next_tracknum (forall a. Index -> [a] -> [a] drop (forall (t :: * -> *) a. Foldable t => t a -> Index length TrackTree old_tree) [NoteTrack] tracks) where merge :: Tree TrackInfo -> NoteTrack -> m () merge (Tree.Node TrackInfo track TrackTree subs) (NoteTrack Events events Controls controls) = do forall (m :: * -> *). M m => TrackId -> [Event] -> m () Ui.insert_events (TrackInfo -> TrackId Ui.track_id TrackInfo track) (Events -> [Event] Events.ascending Events events) forall (m :: * -> *). M m => BlockId -> TrackId -> TrackTree -> [(Control, Events)] -> m () merge_controls BlockId block_id (TrackInfo -> TrackId Ui.track_id TrackInfo track) TrackTree subs forall a b. (a -> b) -> a -> b $ Controls -> [(Control, Events)] sorted_controls Controls controls -- | Create new tracks. create :: Index -> [NoteTrack] -> m () create Index _ [] = forall (m :: * -> *) a. Monad m => a -> m a return () create Index tracknum (NoteTrack Events events Controls controls : [NoteTrack] rest) | Events -> Bool Events.null Events events = Index -> [NoteTrack] -> m () create Index tracknum [NoteTrack] rest | Bool otherwise = do let tracks :: [(Error, Events)] tracks = (Error ">", Events events) forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first Control -> Error control_to_title) (Controls -> [(Control, Events)] sorted_controls Controls controls) forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ (forall a b. [a] -> [b] -> [(a, b)] zip [Index tracknum..] [(Error, Events)] tracks) forall a b. (a -> b) -> a -> b $ \(Index n, (Error title, Events events)) -> forall (m :: * -> *). M m => BlockId -> Index -> Error -> Events -> m TrackId Create.track BlockId block_id Index n Error title Events events forall (m :: * -> *). M m => BlockId -> [Edge] -> m () Ui.add_edges BlockId block_id forall a b. (a -> b) -> a -> b $ forall a. Index -> [a] -> [a] take (forall (t :: * -> *) a. Foldable t => t a -> Index length [(Error, Events)] tracks forall a. Num a => a -> a -> a - Index 1) forall a b. (a -> b) -> a -> b $ forall a b. [a] -> [b] -> [(a, b)] zip [Index tracknum..] [Index tracknumforall a. Num a => a -> a -> a +Index 1..] Maybe TrackInfo parent <- forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing) (forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe TrackInfo) parent_of BlockId block_id) (forall a. [a] -> Maybe a Lists.head [TrackId] track_ids) forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust Maybe TrackInfo parent forall a b. (a -> b) -> a -> b $ \TrackInfo p -> forall (m :: * -> *). M m => BlockId -> [Edge] -> m () Ui.add_edges BlockId block_id [(TrackInfo -> Index Ui.track_tracknum TrackInfo p, Index tracknum)] Index -> [NoteTrack] -> m () create (Index tracknum forall a. Num a => a -> a -> a + forall (t :: * -> *) a. Foldable t => t a -> Index length [(Error, Events)] tracks) [NoteTrack] rest extract_note_trees :: Ui.M m => BlockId -> [TrackId] -> m TrackTree.TrackTree extract_note_trees :: forall (m :: * -> *). M m => BlockId -> [TrackId] -> m TrackTree extract_note_trees BlockId block_id [TrackId] track_ids = forall a. (a -> Bool) -> [Tree a] -> [Tree a] Trees.findAll (Set TrackId -> TrackInfo -> Bool wanted_track (forall a. Ord a => [a] -> Set a Set.fromList [TrackId] track_ids)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m TrackTree TrackTree.track_tree_of BlockId block_id where -- | Accept the top level note tracks. wanted_track :: Set TrackId -> TrackInfo -> Bool wanted_track Set TrackId track_ids TrackInfo track = Error -> Bool ParseTitle.is_note_track (TrackInfo -> Error Ui.track_title TrackInfo track) Bool -> Bool -> Bool && TrackInfo -> TrackId Ui.track_id TrackInfo track forall a. Ord a => a -> Set a -> Bool `Set.member` Set TrackId track_ids merge_controls :: Ui.M m => BlockId -> TrackId -> TrackTree.TrackTree -> [(Control, Events.Events)] -> m () merge_controls :: forall (m :: * -> *). M m => BlockId -> TrackId -> TrackTree -> [(Control, Events)] -> m () merge_controls BlockId block_id TrackId note_track_id TrackTree tree [(Control, Events)] controls = do -- Don't use Ui.track_tracknum because it will be out of date if -- an earlier merge inserted a new track. Index next_tracknum <- forall (m :: * -> *). M m => BlockId -> [TrackId] -> m Index tracknum_after BlockId block_id forall a b. (a -> b) -> a -> b $ TrackId note_track_id forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map TrackInfo -> TrackId Ui.track_id [TrackInfo] tracks forall {m :: * -> *}. M m => Index -> [(Control, Events)] -> m () go Index next_tracknum [(Control, Events)] controls where go :: Index -> [(Control, Events)] -> m () go Index _ [] = forall (m :: * -> *) a. Monad m => a -> m a return () go Index tracknum ((Control control, Events events) : [(Control, Events)] controls) = case Control -> Maybe TrackInfo find Control control of Just TrackInfo track -> do forall (m :: * -> *). M m => TrackId -> [Event] -> m () Ui.insert_events (TrackInfo -> TrackId Ui.track_id TrackInfo track) (Events -> [Event] Events.ascending Events events) Index -> [(Control, Events)] -> m () go Index tracknum [(Control, Events)] controls Maybe TrackInfo Nothing -> do forall (m :: * -> *). M m => BlockId -> Index -> Error -> Events -> m TrackId Create.track BlockId block_id Index tracknum (Control -> Error control_to_title Control control) Events events -- Link the new track into the skeleton below the bottom control. Maybe TrackInfo parent <- forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe TrackInfo) bottom_track BlockId block_id TrackId note_track_id forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust Maybe TrackInfo parent forall a b. (a -> b) -> a -> b $ \TrackInfo p -> forall (m :: * -> *). M m => BlockId -> [Edge] -> m () Ui.add_edges BlockId block_id [(TrackInfo -> Index Ui.track_tracknum TrackInfo p, Index tracknum)] Index -> [(Control, Events)] -> m () go (Index tracknumforall a. Num a => a -> a -> a +Index 1) [(Control, Events)] controls find :: Control -> Maybe TrackInfo find Control control = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a List.find ((forall a. Eq a => a -> a -> Bool == Control -> Error control_to_title Control control) forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> Error Ui.track_title) [TrackInfo] tracks tracks :: [TrackInfo] tracks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a. Tree a -> [a] Tree.flatten TrackTree tree -- | Get the tracknum after the given tracks. tracknum_after :: Ui.M m => BlockId -> [TrackId] -> m TrackNum tracknum_after :: forall (m :: * -> *). M m => BlockId -> [TrackId] -> m Index tracknum_after BlockId block_id [TrackId] track_ids = do [Index] tracknums <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall (m :: * -> *). M m => BlockId -> TrackId -> m Index Ui.get_tracknum_of BlockId block_id) [TrackId] track_ids forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *). M m => BlockId -> m Index Ui.track_count BlockId block_id) (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. Num a => a -> a -> a +Index 1)) (forall a. Ord a => [a] -> Maybe a Lists.maximum [Index] tracknums) -- | Get the bottom track below the given TrackId. If there are more than one, -- pick the one with the highest TrackNum. bottom_track :: Ui.M m => BlockId -> TrackId -> m (Maybe Ui.TrackInfo) bottom_track :: forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe TrackInfo) bottom_track BlockId block_id TrackId track_id = do TrackTree tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree TrackTree.track_tree_of BlockId block_id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (a -> k) -> [a] -> Maybe a Lists.maximumOn TrackInfo -> Index Ui.track_tracknum forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Tree a -> [a] Trees.leaves forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall a. (a -> Bool) -> [Tree a] -> Maybe (Tree a) Trees.find ((forall a. Eq a => a -> a -> Bool ==TrackId track_id) forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> TrackId Ui.track_id) TrackTree tree parent_of :: Ui.M m => BlockId -> TrackId -> m (Maybe Ui.TrackInfo) parent_of :: forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe TrackInfo) parent_of BlockId block_id TrackId track_id = do TrackTree tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree TrackTree.track_tree_of BlockId block_id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. [a] -> Maybe a Lists.head [ TrackInfo track | (TrackInfo track, [TrackInfo] _, [TrackInfo] children) <- forall a. [Tree a] -> [(a, [a], [a])] Trees.flatPaths TrackTree tree , TrackId track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` forall a b. (a -> b) -> [a] -> [b] map TrackInfo -> TrackId Ui.track_id [TrackInfo] children ]