-- 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 Ui.TrackTree where import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Traversable as Traversable import qualified Data.Tree as Tree import qualified Util.Pretty as Pretty import qualified Util.Trees as Trees import qualified Derive.ParseTitle as ParseTitle import qualified Derive.ScoreT as ScoreT import qualified Ui.Block as Block import qualified Ui.Event as Event import qualified Ui.Events as Events import qualified Ui.Skeleton as Skeleton import qualified Ui.Track as Track import qualified Ui.Types as Types import qualified Ui.Ui as Ui import Global import Types -- | A TrackTree is the Skeleton resolved to the tracks it references. type TrackTree = [Tree.Tree Ui.TrackInfo] tracks_of :: Ui.M m => BlockId -> m [Ui.TrackInfo] tracks_of :: forall (m :: * -> *). M m => BlockId -> m [TrackInfo] tracks_of BlockId block_id = do Block block <- forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id State state <- forall (m :: * -> *). M m => m State Ui.get forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Block -> Map TrackId Track -> [TrackInfo] track_info Block block (State -> Map TrackId Track Ui.state_tracks State state) where track_info :: Block -> Map TrackId Track -> [TrackInfo] track_info Block block Map TrackId Track tracks = do (TrackNum i, btrack :: Track btrack@(Block.Track { tracklike_id :: Track -> TracklikeId Block.tracklike_id = Block.TId TrackId tid RulerId _})) <- forall a b. [a] -> [b] -> [(a, b)] zip [TrackNum 0..] (Block -> [Track] Block.block_tracks Block block) Track track <- forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (forall a. a -> [a] -> [a] :[]) (forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup TrackId tid Map TrackId Track tracks) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Ui.TrackInfo { track_title :: Text track_title = Track -> Text Track.track_title Track track , track_id :: TrackId track_id = TrackId tid , track_tracknum :: TrackNum track_tracknum = TrackNum i , track_block :: Track track_block = Track btrack } -- | Return @(parents, self : children)@. parents_children_of :: Ui.M m => BlockId -> TrackId -> m (Maybe ([Ui.TrackInfo], [Ui.TrackInfo])) parents_children_of :: forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe ([TrackInfo], [TrackInfo])) parents_children_of BlockId block_id TrackId track_id = do TrackTree tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree track_tree_of BlockId block_id case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a List.find (\(TrackInfo t, [TrackInfo] _, [TrackInfo] _) -> TrackInfo -> TrackId Ui.track_id TrackInfo t forall a. Eq a => a -> a -> Bool == TrackId track_id) (forall a. [Tree a] -> [(a, [a], [a])] Trees.flatPaths TrackTree tree) of Maybe (TrackInfo, [TrackInfo], [TrackInfo]) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing Just (TrackInfo track, [TrackInfo] parents, [TrackInfo] children) -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just ([TrackInfo] parents, TrackInfo track forall a. a -> [a] -> [a] : [TrackInfo] children) -- | This is like 'parents_children_of', but only the children, and it doesn't -- include the given TrackId. get_children_of :: Ui.M m => BlockId -> TrackId -> m [Ui.TrackInfo] get_children_of :: forall (m :: * -> *). M m => BlockId -> TrackId -> m [TrackInfo] get_children_of BlockId block_id TrackId track_id = forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe ([TrackInfo], [TrackInfo])) parents_children_of BlockId block_id TrackId track_id forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just ([TrackInfo] _, TrackInfo _ : [TrackInfo] children) -> forall (m :: * -> *) a. Monad m => a -> m a return [TrackInfo] children Maybe ([TrackInfo], [TrackInfo]) _ -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw forall a b. (a -> b) -> a -> b $ Text "no children of " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (BlockId block_id, TrackId track_id) is_child_of :: Ui.M m => BlockId -> TrackNum -> TrackNum -> m Bool is_child_of :: forall (m :: * -> *). M m => BlockId -> TrackNum -> TrackNum -> m Bool is_child_of BlockId block_id TrackNum parent TrackNum child = do [TrackInfo] children <- forall (m :: * -> *). M m => BlockId -> TrackId -> m [TrackInfo] get_children_of BlockId block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => BlockId -> TrackNum -> m TrackId Ui.get_event_track_at BlockId block_id TrackNum parent forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ TrackNum child forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` forall a b. (a -> b) -> [a] -> [b] map TrackInfo -> TrackNum Ui.track_tracknum [TrackInfo] children -- | Combine the skeleton with the tracks to create a TrackTree. -- -- TODO this is pretty complicated. If I stored the tracks as a tree in the -- first place and generated the skeleton from that then this would all go -- away. But that would mean redoing all the "Ui.Skeleton" operations for -- trees. And the reason I didn't do it in the first place was the hassle of -- graph operations on a Data.Tree. track_tree_of :: Ui.M m => BlockId -> m TrackTree track_tree_of :: forall (m :: * -> *). M m => BlockId -> m TrackTree track_tree_of BlockId block_id = do Skeleton skel <- forall (m :: * -> *). M m => BlockId -> m Skeleton Ui.get_skeleton BlockId block_id [TrackInfo] tracks <- forall (m :: * -> *). M m => BlockId -> m [TrackInfo] tracks_of BlockId block_id TrackNum ntracks <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (t :: * -> *) a. Foldable t => t a -> TrackNum length forall b c a. (b -> c) -> (a -> b) -> a -> c . Block -> [TracklikeId] Block.block_tracklike_ids) (forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id) let by_tracknum :: Map TrackNum TrackInfo by_tracknum = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList forall a b. (a -> b) -> a -> b $ forall a b. [a] -> [b] -> [(a, b)] zip (forall a b. (a -> b) -> [a] -> [b] map TrackInfo -> TrackNum Ui.track_tracknum [TrackInfo] tracks) [TrackInfo] tracks let (TrackTree resolved, [TrackNum] missing) = forall a. Map TrackNum a -> [Tree TrackNum] -> ([Tree a], [TrackNum]) resolve_track_tree Map TrackNum TrackInfo by_tracknum (TrackNum -> Skeleton -> [Tree TrackNum] Skeleton.to_forest TrackNum ntracks Skeleton skel) -- Rulers and dividers should show up as missing. They're ok as long as -- they have no edges. let really_missing :: [TrackNum] really_missing = forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . Skeleton -> TrackNum -> Bool Skeleton.lonely_vertex Skeleton skel) [TrackNum] missing forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (forall (t :: * -> *) a. Foldable t => t a -> Bool null [TrackNum] really_missing) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw forall a b. (a -> b) -> a -> b $ Text "skeleton of " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt BlockId block_id forall a. Semigroup a => a -> a -> a <> Text " names missing tracknums: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt [TrackNum] really_missing forall (m :: * -> *) a. Monad m => a -> m a return TrackTree resolved -- | Resolve the TrackNum indices in a tree into whatever values as given by -- a map. resolve_track_tree :: Map TrackNum a -> [Tree.Tree TrackNum] -> ([Tree.Tree a], [TrackNum]) -- ^ resolved tree, and missing TrackNums resolve_track_tree :: forall a. Map TrackNum a -> [Tree TrackNum] -> ([Tree a], [TrackNum]) resolve_track_tree Map TrackNum a tracknums = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (forall {a} {a}. (Maybe a, [a]) -> ([a], [a]) -> ([a], [a]) cat_tree forall b c a. (b -> c) -> (a -> b) -> a -> c . Tree TrackNum -> (Maybe (Tree a), [TrackNum]) go) ([], []) where go :: Tree TrackNum -> (Maybe (Tree a), [TrackNum]) go (Tree.Node TrackNum tracknum [Tree TrackNum] subs) = case forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup TrackNum tracknum Map TrackNum a tracknums of Maybe a Nothing -> (forall a. Maybe a Nothing, [TrackNum tracknum]) Just a track_info -> let ([Tree a] subforest, [TrackNum] missing) = forall a. Map TrackNum a -> [Tree TrackNum] -> ([Tree a], [TrackNum]) resolve_track_tree Map TrackNum a tracknums [Tree TrackNum] subs in (forall a. a -> Maybe a Just (forall a. a -> [Tree a] -> Tree a Tree.Node a track_info [Tree a] subforest), [TrackNum] missing) cat_tree :: (Maybe a, [a]) -> ([a], [a]) -> ([a], [a]) cat_tree (Maybe a maybe_tree, [a] missing) ([a] forest, [a] all_missing) = case Maybe a maybe_tree of Maybe a Nothing -> ([a] forest, [a] missing forall a. [a] -> [a] -> [a] ++ [a] all_missing) Just a tree -> (a tree forall a. a -> [a] -> [a] : [a] forest, [a] missing forall a. [a] -> [a] -> [a] ++ [a] all_missing) strip_disabled_tracks :: Ui.M m => BlockId -> TrackTree -> m TrackTree strip_disabled_tracks :: forall (m :: * -> *). M m => BlockId -> TrackTree -> m TrackTree strip_disabled_tracks BlockId block_id = forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM Tree TrackInfo -> m TrackTree strip where strip :: Tree TrackInfo -> m TrackTree strip (Tree.Node TrackInfo track TrackTree subs) = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a ifM (TrackInfo -> m Bool disabled TrackInfo track) (forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM Tree TrackInfo -> m TrackTree strip TrackTree subs) ((forall a. a -> [a] -> [a] :[]) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> [Tree a] -> Tree a Tree.Node TrackInfo track forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM Tree TrackInfo -> m TrackTree strip TrackTree subs) disabled :: TrackInfo -> m Bool disabled = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (TrackFlag Block.Disable `Set.member`) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Set TrackFlag) Ui.track_flags BlockId block_id forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> TrackNum Ui.track_tracknum type EventsTree = [EventsNode] type EventsNode = Tree.Tree Track data Track = Track { Track -> Text track_title :: !Text -- | Events on this track. These are shifted by -- 'Derive.Slice.slice_notes', so they are in ScoreTime, not TrackTime. , Track -> Events track_events :: !Events.Events -- | This goes into the stack when the track is evaluated. Inverted tracks -- will carry the TrackId of the track they were inverted from, so they'll -- show up in the stack twice. This means they can record their environ -- as it actually is when the notes are evaluated, rather than its -- pre-invert value, which is likely to not have the right scale. , Track -> Maybe TrackId track_id :: !(Maybe TrackId) -- | The block these events came from. A track can appear in multiple -- blocks, but can only appear once in each block. , Track -> Maybe BlockId track_block_id :: !(Maybe BlockId) -- | The relative start and end of this slice of track. Like -- 'track_events', this is in ScoreTime, not TrackTime. , Track -> ScoreTime track_start :: !ScoreTime , Track -> ScoreTime track_end :: !ScoreTime -- | True if this is a sliced track. That means it's a fragment of -- a track and certain track-level things should be skipped. , Track -> Sliced track_sliced :: !Sliced -- | These events are not evaluated, but go in -- 'Derive.Derive.ctx_prev_events' and ctx_next_events. This is so that -- sliced calls (such as inverting calls) can see previous and following -- events. Shifted along with 'track_events'. , Track -> ([Event], [Event]) track_around :: !([Event.Event], [Event.Event]) -- | If the events have been shifted from their original positions on the -- track, add this to them to put them back in TrackTime. , Track -> ScoreTime track_shifted :: !TrackTime -- | This is the track's track voice, as defined in 'Environ.track_voices'. -- Originally I tried to keep it all within "Derive.Call.BlockUtil", but -- it gets complicated with child tracks and slicing. Putting it in -- 'Track' ensures it can't get lost. , Track -> Maybe TrackNum track_voice :: !(Maybe Int) } deriving (TrackNum -> Track -> ShowS [Track] -> ShowS Track -> String forall a. (TrackNum -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Track] -> ShowS $cshowList :: [Track] -> ShowS show :: Track -> String $cshow :: Track -> String showsPrec :: TrackNum -> Track -> ShowS $cshowsPrec :: TrackNum -> Track -> ShowS Show) track_range :: Track -> (TrackTime, TrackTime) track_range :: Track -> (ScoreTime, ScoreTime) track_range Track track = (Track -> ScoreTime track_shifted Track track, Track -> ScoreTime track_shifted Track track forall a. Num a => a -> a -> a + Track -> ScoreTime track_end Track track) instance Pretty Track where format :: Track -> Doc format (Track Text title Events events Maybe TrackId track_id Maybe BlockId block_id ScoreTime start ScoreTime end Sliced sliced ([Event], [Event]) around ScoreTime shifted Maybe TrackNum voice) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "Track" [ (Text "title", forall a. Pretty a => a -> Doc Pretty.format Text title) , (Text "events", forall a. Pretty a => a -> Doc Pretty.format Events events) , (Text "track_id", forall a. Pretty a => a -> Doc Pretty.format Maybe TrackId track_id) , (Text "block_id", forall a. Pretty a => a -> Doc Pretty.format Maybe BlockId block_id) , (Text "start", forall a. Pretty a => a -> Doc Pretty.format ScoreTime start) , (Text "end", forall a. Pretty a => a -> Doc Pretty.format ScoreTime end) , (Text "sliced", forall a. Pretty a => a -> Doc Pretty.format Sliced sliced) , (Text "around", forall a. Pretty a => a -> Doc Pretty.format ([Event], [Event]) around) , (Text "shifted", forall a. Pretty a => a -> Doc Pretty.format ScoreTime shifted) , (Text "voice", forall a. Pretty a => a -> Doc Pretty.format Maybe TrackNum voice) ] make_track :: Text -> Events.Events -> ScoreTime -> Track make_track :: Text -> Events -> ScoreTime -> Track make_track Text title Events events ScoreTime end = Track { track_title :: Text track_title = Text title , track_events :: Events track_events = Events events , track_id :: Maybe TrackId track_id = forall a. Maybe a Nothing , track_block_id :: Maybe BlockId track_block_id = forall a. Maybe a Nothing , track_start :: ScoreTime track_start = ScoreTime 0 , track_end :: ScoreTime track_end = ScoreTime end , track_sliced :: Sliced track_sliced = Sliced NotSliced , track_around :: ([Event], [Event]) track_around = ([], []) , track_shifted :: ScoreTime track_shifted = ScoreTime 0 , track_voice :: Maybe TrackNum track_voice = forall a. Maybe a Nothing } data Sliced = -- | An intact track, unchanged from the score. -- -- It's confusing to say track_sliced track == NotSliced, and I could pick -- something like Intact, but there's no precedent for that terminology. NotSliced -- | A "Derive.Slice"d fragment, and certain track-level things should be -- skipped. | Sliced !Types.Orientation -- | Set on the fake track created by inversion. | Inversion deriving (Sliced -> Sliced -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Sliced -> Sliced -> Bool $c/= :: Sliced -> Sliced -> Bool == :: Sliced -> Sliced -> Bool $c== :: Sliced -> Sliced -> Bool Eq, TrackNum -> Sliced -> ShowS [Sliced] -> ShowS Sliced -> String forall a. (TrackNum -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Sliced] -> ShowS $cshowList :: [Sliced] -> ShowS show :: Sliced -> String $cshow :: Sliced -> String showsPrec :: TrackNum -> Sliced -> ShowS $cshowsPrec :: TrackNum -> Sliced -> ShowS Show) instance Pretty Sliced where pretty :: Sliced -> Text pretty = forall a. Show a => a -> Text showt block_track_id :: Track -> Maybe (BlockId, TrackId) block_track_id :: Track -> Maybe (BlockId, TrackId) block_track_id Track track = do BlockId bid <- Track -> Maybe BlockId track_block_id Track track TrackId tid <- Track -> Maybe TrackId track_id Track track forall (m :: * -> *) a. Monad m => a -> m a return (BlockId bid, TrackId tid) events_tree_of :: Ui.M m => BlockId -> m EventsTree events_tree_of :: forall (m :: * -> *). M m => BlockId -> m EventsTree events_tree_of BlockId block_id = do TrackTree info_tree <- forall (m :: * -> *). M m => BlockId -> m TrackTree track_tree_of BlockId block_id ScoreTime end <- forall (m :: * -> *). M m => BlockId -> m ScoreTime Ui.block_ruler_end BlockId block_id forall (m :: * -> *). M m => BlockId -> ScoreTime -> TrackTree -> m EventsTree events_tree BlockId block_id ScoreTime end TrackTree info_tree events_tree :: Ui.M m => BlockId -> ScoreTime -> [Tree.Tree Ui.TrackInfo] -> m EventsTree events_tree :: forall (m :: * -> *). M m => BlockId -> ScoreTime -> TrackTree -> m EventsTree events_tree BlockId block_id ScoreTime end = forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall {f :: * -> *}. M f => Tree (TrackInfo, Maybe TrackNum) -> f (Tree Track) resolve forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackTree -> [Tree (TrackInfo, Maybe TrackNum)] track_voices where resolve :: Tree (TrackInfo, Maybe TrackNum) -> f (Tree Track) resolve (Tree.Node (Ui.TrackInfo Text title TrackId track_id TrackNum _ Track _, Maybe TrackNum voice) [Tree (TrackInfo, Maybe TrackNum)] subs) = forall a. a -> [Tree a] -> Tree a Tree.Node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall {m :: * -> *}. M m => Text -> TrackId -> Maybe TrackNum -> m Track make Text title TrackId track_id Maybe TrackNum voice forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Tree (TrackInfo, Maybe TrackNum) -> f (Tree Track) resolve [Tree (TrackInfo, Maybe TrackNum)] subs make :: Text -> TrackId -> Maybe TrackNum -> m Track make Text title TrackId track_id Maybe TrackNum voice = do Events events <- forall (m :: * -> *). M m => TrackId -> m Events Ui.get_events TrackId track_id forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ (Text -> Events -> ScoreTime -> Track make_track Text title Events events ScoreTime end) { track_id :: Maybe TrackId track_id = forall a. a -> Maybe a Just TrackId track_id , track_block_id :: Maybe BlockId track_block_id = forall a. a -> Maybe a Just BlockId block_id , track_voice :: Maybe TrackNum track_voice = Maybe TrackNum voice } -- | Get the EventsTree of a block. Strip disabled tracks. block_events_tree :: Ui.M m => BlockId -> m EventsTree block_events_tree :: forall (m :: * -> *). M m => BlockId -> m EventsTree block_events_tree BlockId block_id = do TrackTree info_tree <- forall (m :: * -> *). M m => BlockId -> TrackTree -> m TrackTree strip_disabled_tracks BlockId block_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => BlockId -> m TrackTree track_tree_of BlockId block_id -- This is the end of the last event or ruler, not -- Ui.block_logical_range. The reason is that functions that look at -- track_end are expecting the physical end, e.g. -- Control.derive_control uses it to put the last sample on the tempo -- track. ScoreTime end <- forall (m :: * -> *). M m => BlockId -> m ScoreTime Ui.block_end BlockId block_id forall (m :: * -> *). M m => BlockId -> ScoreTime -> TrackTree -> m EventsTree events_tree BlockId block_id ScoreTime end TrackTree info_tree -- | All the children of this EventsNode with TrackIds. track_children :: EventsNode -> Set TrackId track_children :: Tree Track -> Set TrackId track_children = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (forall a b c. (a -> b -> c) -> b -> a -> c flip forall a. Ord a => a -> Set a -> Set a Set.insert) forall a. Set a Set.empty forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe Track -> Maybe TrackId track_id forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Tree a -> [a] Tree.flatten -- | Each note track with an instrument gets a count and maximum count, so they -- can go in 'Environ.track_voice' and 'Environ.track_voices'. track_voices :: [Tree.Tree Ui.TrackInfo] -> [Tree.Tree (Ui.TrackInfo, Maybe Int)] track_voices :: TrackTree -> [Tree (TrackInfo, Maybe TrackNum)] track_voices TrackTree tracks = forall a b. (a -> b) -> [a] -> [b] map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall {a}. (TrackInfo, a) -> (TrackInfo, Maybe a) only_inst) forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) (g :: * -> *) k a. (Traversable f, Traversable g, Ord k) => (a -> k) -> f (g a) -> f (g (a, TrackNum)) count_occurrences TrackInfo -> Maybe Instrument inst_of TrackTree tracks where inst_of :: TrackInfo -> Maybe Instrument inst_of = Instrument -> Maybe Instrument not_empty forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< Text -> Maybe Instrument ParseTitle.title_to_instrument forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> Text Ui.track_title where not_empty :: Instrument -> Maybe Instrument not_empty Instrument inst = if Instrument inst forall a. Eq a => a -> a -> Bool == Instrument ScoreT.empty_instrument then forall a. Maybe a Nothing else forall a. a -> Maybe a Just Instrument inst only_inst :: (TrackInfo, a) -> (TrackInfo, Maybe a) only_inst (TrackInfo track, a voice) | Just Instrument _ <- TrackInfo -> Maybe Instrument inst_of TrackInfo track = (TrackInfo track, forall a. a -> Maybe a Just a voice) | Bool otherwise = (TrackInfo track, forall a. Maybe a Nothing) -- | For each element, give its index amount its equals, and the total number -- of elements equal to it. count_occurrences :: (Traversable f, Traversable g, Ord k) => (a -> k) -> f (g a) -> f (g (a, Int)) count_occurrences :: forall (f :: * -> *) (g :: * -> *) k a. (Traversable f, Traversable g, Ord k) => (a -> k) -> f (g a) -> f (g (a, TrackNum)) count_occurrences a -> k key = forall a b. (a, b) -> b snd 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) Traversable.mapAccumL 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) Traversable.mapAccumL) forall {b}. Num b => Map k b -> a -> (Map k b, (a, b)) go forall a. Monoid a => a mempty where go :: Map k b -> a -> (Map k b, (a, b)) go Map k b counts a x = (forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert (a -> k key a x) (b nforall a. Num a => a -> a -> a +b 1) Map k b counts, (a x, b n)) where n :: b n = forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault b 0 (a -> k key a x) Map k b counts