-- 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 <- BlockId -> m Block forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id State state <- m State forall (m :: * -> *). M m => m State Ui.get [TrackInfo] -> m [TrackInfo] forall (m :: * -> *) a. Monad m => a -> m a return ([TrackInfo] -> m [TrackInfo]) -> [TrackInfo] -> m [TrackInfo] 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 _})) <- [TrackNum] -> [Track] -> [(TrackNum, Track)] forall a b. [a] -> [b] -> [(a, b)] zip [TrackNum 0..] (Block -> [Track] Block.block_tracks Block block) Track track <- [Track] -> (Track -> [Track]) -> Maybe Track -> [Track] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (Track -> [Track] -> [Track] forall a. a -> [a] -> [a] :[]) (TrackId -> Map TrackId Track -> Maybe Track forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup TrackId tid Map TrackId Track tracks) TrackInfo -> [TrackInfo] forall (m :: * -> *) a. Monad m => a -> m a return (TrackInfo -> [TrackInfo]) -> TrackInfo -> [TrackInfo] 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 <- BlockId -> m TrackTree forall (m :: * -> *). M m => BlockId -> m TrackTree track_tree_of BlockId block_id case ((TrackInfo, [TrackInfo], [TrackInfo]) -> Bool) -> [(TrackInfo, [TrackInfo], [TrackInfo])] -> Maybe (TrackInfo, [TrackInfo], [TrackInfo]) forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a List.find (\(TrackInfo t, [TrackInfo] _, [TrackInfo] _) -> TrackInfo -> TrackId Ui.track_id TrackInfo t TrackId -> TrackId -> Bool forall a. Eq a => a -> a -> Bool == TrackId track_id) (TrackTree -> [(TrackInfo, [TrackInfo], [TrackInfo])] forall a. [Tree a] -> [(a, [a], [a])] Trees.flatPaths TrackTree tree) of Maybe (TrackInfo, [TrackInfo], [TrackInfo]) Nothing -> Maybe ([TrackInfo], [TrackInfo]) -> m (Maybe ([TrackInfo], [TrackInfo])) forall (m :: * -> *) a. Monad m => a -> m a return Maybe ([TrackInfo], [TrackInfo]) forall a. Maybe a Nothing Just (TrackInfo track, [TrackInfo] parents, [TrackInfo] children) -> Maybe ([TrackInfo], [TrackInfo]) -> m (Maybe ([TrackInfo], [TrackInfo])) forall (m :: * -> *) a. Monad m => a -> m a return (Maybe ([TrackInfo], [TrackInfo]) -> m (Maybe ([TrackInfo], [TrackInfo]))) -> Maybe ([TrackInfo], [TrackInfo]) -> m (Maybe ([TrackInfo], [TrackInfo])) forall a b. (a -> b) -> a -> b $ ([TrackInfo], [TrackInfo]) -> Maybe ([TrackInfo], [TrackInfo]) forall a. a -> Maybe a Just ([TrackInfo] parents, TrackInfo track TrackInfo -> [TrackInfo] -> [TrackInfo] 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 = BlockId -> TrackId -> m (Maybe ([TrackInfo], [TrackInfo])) forall (m :: * -> *). M m => BlockId -> TrackId -> m (Maybe ([TrackInfo], [TrackInfo])) parents_children_of BlockId block_id TrackId track_id m (Maybe ([TrackInfo], [TrackInfo])) -> (Maybe ([TrackInfo], [TrackInfo]) -> m [TrackInfo]) -> m [TrackInfo] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just ([TrackInfo] _, TrackInfo _ : [TrackInfo] children) -> [TrackInfo] -> m [TrackInfo] forall (m :: * -> *) a. Monad m => a -> m a return [TrackInfo] children Maybe ([TrackInfo], [TrackInfo]) _ -> Text -> m [TrackInfo] forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw (Text -> m [TrackInfo]) -> Text -> m [TrackInfo] forall a b. (a -> b) -> a -> b $ Text "no children of " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> (BlockId, TrackId) -> Text 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 <- BlockId -> TrackId -> m [TrackInfo] forall (m :: * -> *). M m => BlockId -> TrackId -> m [TrackInfo] get_children_of BlockId block_id (TrackId -> m [TrackInfo]) -> m TrackId -> m [TrackInfo] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< BlockId -> TrackNum -> m TrackId forall (m :: * -> *). M m => BlockId -> TrackNum -> m TrackId Ui.get_event_track_at BlockId block_id TrackNum parent Bool -> m Bool forall (m :: * -> *) a. Monad m => a -> m a return (Bool -> m Bool) -> Bool -> m Bool forall a b. (a -> b) -> a -> b $ TrackNum child TrackNum -> [TrackNum] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` (TrackInfo -> TrackNum) -> [TrackInfo] -> [TrackNum] 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 <- BlockId -> m Skeleton forall (m :: * -> *). M m => BlockId -> m Skeleton Ui.get_skeleton BlockId block_id [TrackInfo] tracks <- BlockId -> m [TrackInfo] forall (m :: * -> *). M m => BlockId -> m [TrackInfo] tracks_of BlockId block_id TrackNum ntracks <- (Block -> TrackNum) -> m Block -> m TrackNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ([TracklikeId] -> TrackNum forall (t :: * -> *) a. Foldable t => t a -> TrackNum length ([TracklikeId] -> TrackNum) -> (Block -> [TracklikeId]) -> Block -> TrackNum forall b c a. (b -> c) -> (a -> b) -> a -> c . Block -> [TracklikeId] Block.block_tracklike_ids) (BlockId -> m Block forall (m :: * -> *). M m => BlockId -> m Block Ui.get_block BlockId block_id) let by_tracknum :: Map TrackNum TrackInfo by_tracknum = [(TrackNum, TrackInfo)] -> Map TrackNum TrackInfo forall k a. Ord k => [(k, a)] -> Map k a Map.fromList ([(TrackNum, TrackInfo)] -> Map TrackNum TrackInfo) -> [(TrackNum, TrackInfo)] -> Map TrackNum TrackInfo forall a b. (a -> b) -> a -> b $ [TrackNum] -> [TrackInfo] -> [(TrackNum, TrackInfo)] forall a b. [a] -> [b] -> [(a, b)] zip ((TrackInfo -> TrackNum) -> [TrackInfo] -> [TrackNum] forall a b. (a -> b) -> [a] -> [b] map TrackInfo -> TrackNum Ui.track_tracknum [TrackInfo] tracks) [TrackInfo] tracks let (TrackTree resolved, [TrackNum] missing) = Map TrackNum TrackInfo -> [Tree TrackNum] -> (TrackTree, [TrackNum]) 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 = (TrackNum -> Bool) -> [TrackNum] -> [TrackNum] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> (TrackNum -> Bool) -> TrackNum -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Skeleton -> TrackNum -> Bool Skeleton.lonely_vertex Skeleton skel) [TrackNum] missing Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless ([TrackNum] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [TrackNum] really_missing) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ Text -> m () forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw (Text -> m ()) -> Text -> m () forall a b. (a -> b) -> a -> b $ Text "skeleton of " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> BlockId -> Text forall a. Show a => a -> Text showt BlockId block_id Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text " names missing tracknums: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> [TrackNum] -> Text forall a. Show a => a -> Text showt [TrackNum] really_missing TrackTree -> m TrackTree 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 = (Tree TrackNum -> ([Tree a], [TrackNum]) -> ([Tree a], [TrackNum])) -> ([Tree a], [TrackNum]) -> [Tree TrackNum] -> ([Tree a], [TrackNum]) forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr ((Maybe (Tree a), [TrackNum]) -> ([Tree a], [TrackNum]) -> ([Tree a], [TrackNum]) forall {a} {a}. (Maybe a, [a]) -> ([a], [a]) -> ([a], [a]) cat_tree ((Maybe (Tree a), [TrackNum]) -> ([Tree a], [TrackNum]) -> ([Tree a], [TrackNum])) -> (Tree TrackNum -> (Maybe (Tree a), [TrackNum])) -> Tree TrackNum -> ([Tree a], [TrackNum]) -> ([Tree a], [TrackNum]) 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 TrackNum -> Map TrackNum a -> Maybe a forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup TrackNum tracknum Map TrackNum a tracknums of Maybe a Nothing -> (Maybe (Tree a) forall a. Maybe a Nothing, [TrackNum tracknum]) Just a track_info -> let ([Tree a] subforest, [TrackNum] missing) = Map TrackNum a -> [Tree TrackNum] -> ([Tree a], [TrackNum]) forall a. Map TrackNum a -> [Tree TrackNum] -> ([Tree a], [TrackNum]) resolve_track_tree Map TrackNum a tracknums [Tree TrackNum] subs in (Tree a -> Maybe (Tree a) forall a. a -> Maybe a Just (a -> [Tree a] -> Tree a 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 [a] -> [a] -> [a] forall a. [a] -> [a] -> [a] ++ [a] all_missing) Just a tree -> (a tree a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] forest, [a] missing [a] -> [a] -> [a] 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 = (Tree TrackInfo -> m TrackTree) -> TrackTree -> m TrackTree 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) = m Bool -> m TrackTree -> m TrackTree -> m TrackTree forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a ifM (TrackInfo -> m Bool disabled TrackInfo track) ((Tree TrackInfo -> m TrackTree) -> TrackTree -> m TrackTree forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM Tree TrackInfo -> m TrackTree strip TrackTree subs) ((Tree TrackInfo -> TrackTree -> TrackTree forall a. a -> [a] -> [a] :[]) (Tree TrackInfo -> TrackTree) -> (TrackTree -> Tree TrackInfo) -> TrackTree -> TrackTree forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackInfo -> TrackTree -> Tree TrackInfo forall a. a -> [Tree a] -> Tree a Tree.Node TrackInfo track (TrackTree -> TrackTree) -> m TrackTree -> m TrackTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Tree TrackInfo -> m TrackTree) -> TrackTree -> m TrackTree 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 = (Set TrackFlag -> Bool) -> m (Set TrackFlag) -> m Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (TrackFlag Block.Disable `Set.member`) (m (Set TrackFlag) -> m Bool) -> (TrackInfo -> m (Set TrackFlag)) -> TrackInfo -> m Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . BlockId -> TrackNum -> m (Set TrackFlag) forall (m :: * -> *). M m => BlockId -> TrackNum -> m (Set TrackFlag) Ui.track_flags BlockId block_id (TrackNum -> m (Set TrackFlag)) -> (TrackInfo -> TrackNum) -> TrackInfo -> m (Set TrackFlag) 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 (TrackNum -> Track -> ShowS) -> (Track -> String) -> ([Track] -> ShowS) -> Show Track 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 ScoreTime -> ScoreTime -> ScoreTime 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", Text -> Doc forall a. Pretty a => a -> Doc Pretty.format Text title) , (Text "events", Events -> Doc forall a. Pretty a => a -> Doc Pretty.format Events events) , (Text "track_id", Maybe TrackId -> Doc forall a. Pretty a => a -> Doc Pretty.format Maybe TrackId track_id) , (Text "block_id", Maybe BlockId -> Doc forall a. Pretty a => a -> Doc Pretty.format Maybe BlockId block_id) , (Text "start", ScoreTime -> Doc forall a. Pretty a => a -> Doc Pretty.format ScoreTime start) , (Text "end", ScoreTime -> Doc forall a. Pretty a => a -> Doc Pretty.format ScoreTime end) , (Text "sliced", Sliced -> Doc forall a. Pretty a => a -> Doc Pretty.format Sliced sliced) , (Text "around", ([Event], [Event]) -> Doc forall a. Pretty a => a -> Doc Pretty.format ([Event], [Event]) around) , (Text "shifted", ScoreTime -> Doc forall a. Pretty a => a -> Doc Pretty.format ScoreTime shifted) , (Text "voice", Maybe TrackNum -> Doc 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 = Maybe TrackId forall a. Maybe a Nothing , track_block_id :: Maybe BlockId track_block_id = Maybe BlockId 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 = Maybe TrackNum 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 (Sliced -> Sliced -> Bool) -> (Sliced -> Sliced -> Bool) -> Eq Sliced 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 (TrackNum -> Sliced -> ShowS) -> (Sliced -> String) -> ([Sliced] -> ShowS) -> Show Sliced 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 = Sliced -> Text 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 (BlockId, TrackId) -> Maybe (BlockId, TrackId) 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 <- BlockId -> m TrackTree forall (m :: * -> *). M m => BlockId -> m TrackTree track_tree_of BlockId block_id ScoreTime end <- BlockId -> m ScoreTime forall (m :: * -> *). M m => BlockId -> m ScoreTime Ui.block_ruler_end BlockId block_id BlockId -> ScoreTime -> TrackTree -> m EventsTree 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 = (Tree (TrackInfo, Maybe TrackNum) -> m EventsNode) -> [Tree (TrackInfo, Maybe TrackNum)] -> m EventsTree forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Tree (TrackInfo, Maybe TrackNum) -> m EventsNode forall {f :: * -> *}. M f => Tree (TrackInfo, Maybe TrackNum) -> f EventsNode resolve ([Tree (TrackInfo, Maybe TrackNum)] -> m EventsTree) -> (TrackTree -> [Tree (TrackInfo, Maybe TrackNum)]) -> TrackTree -> m EventsTree forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackTree -> [Tree (TrackInfo, Maybe TrackNum)] track_voices where resolve :: Tree (TrackInfo, Maybe TrackNum) -> f EventsNode resolve (Tree.Node (Ui.TrackInfo Text title TrackId track_id TrackNum _ Track _, Maybe TrackNum voice) [Tree (TrackInfo, Maybe TrackNum)] subs) = Track -> EventsTree -> EventsNode forall a. a -> [Tree a] -> Tree a Tree.Node (Track -> EventsTree -> EventsNode) -> f Track -> f (EventsTree -> EventsNode) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Text -> TrackId -> Maybe TrackNum -> f Track forall {m :: * -> *}. M m => Text -> TrackId -> Maybe TrackNum -> m Track make Text title TrackId track_id Maybe TrackNum voice f (EventsTree -> EventsNode) -> f EventsTree -> f EventsNode forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Tree (TrackInfo, Maybe TrackNum) -> f EventsNode) -> [Tree (TrackInfo, Maybe TrackNum)] -> f EventsTree forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Tree (TrackInfo, Maybe TrackNum) -> f EventsNode 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 <- TrackId -> m Events forall (m :: * -> *). M m => TrackId -> m Events Ui.get_events TrackId track_id Track -> m Track forall (m :: * -> *) a. Monad m => a -> m a return (Track -> m Track) -> Track -> m Track 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 = TrackId -> Maybe TrackId forall a. a -> Maybe a Just TrackId track_id , track_block_id :: Maybe BlockId track_block_id = BlockId -> Maybe BlockId 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 <- BlockId -> TrackTree -> m TrackTree forall (m :: * -> *). M m => BlockId -> TrackTree -> m TrackTree strip_disabled_tracks BlockId block_id (TrackTree -> m TrackTree) -> m TrackTree -> m TrackTree forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< BlockId -> m TrackTree 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 <- BlockId -> m ScoreTime forall (m :: * -> *). M m => BlockId -> m ScoreTime Ui.block_end BlockId block_id BlockId -> ScoreTime -> TrackTree -> m EventsTree 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 :: EventsNode -> Set TrackId track_children = (Set TrackId -> TrackId -> Set TrackId) -> Set TrackId -> [TrackId] -> Set TrackId forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' ((TrackId -> Set TrackId -> Set TrackId) -> Set TrackId -> TrackId -> Set TrackId forall a b c. (a -> b -> c) -> b -> a -> c flip TrackId -> Set TrackId -> Set TrackId forall a. Ord a => a -> Set a -> Set a Set.insert) Set TrackId forall a. Set a Set.empty ([TrackId] -> Set TrackId) -> (EventsNode -> [TrackId]) -> EventsNode -> Set TrackId forall b c a. (b -> c) -> (a -> b) -> a -> c . (Track -> Maybe TrackId) -> [Track] -> [TrackId] forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe Track -> Maybe TrackId track_id ([Track] -> [TrackId]) -> (EventsNode -> [Track]) -> EventsNode -> [TrackId] forall b c a. (b -> c) -> (a -> b) -> a -> c . EventsNode -> [Track] 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 = (Tree (TrackInfo, TrackNum) -> Tree (TrackInfo, Maybe TrackNum)) -> [Tree (TrackInfo, TrackNum)] -> [Tree (TrackInfo, Maybe TrackNum)] forall a b. (a -> b) -> [a] -> [b] map (((TrackInfo, TrackNum) -> (TrackInfo, Maybe TrackNum)) -> Tree (TrackInfo, TrackNum) -> Tree (TrackInfo, Maybe TrackNum) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (TrackInfo, TrackNum) -> (TrackInfo, Maybe TrackNum) forall {a}. (TrackInfo, a) -> (TrackInfo, Maybe a) only_inst) ([Tree (TrackInfo, TrackNum)] -> [Tree (TrackInfo, Maybe TrackNum)]) -> [Tree (TrackInfo, TrackNum)] -> [Tree (TrackInfo, Maybe TrackNum)] forall a b. (a -> b) -> a -> b $ (TrackInfo -> Maybe Instrument) -> TrackTree -> [Tree (TrackInfo, TrackNum)] 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 (Instrument -> Maybe Instrument) -> (TrackInfo -> Maybe Instrument) -> TrackInfo -> Maybe Instrument forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< Text -> Maybe Instrument ParseTitle.title_to_instrument (Text -> Maybe Instrument) -> (TrackInfo -> Text) -> TrackInfo -> Maybe 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 Instrument -> Instrument -> Bool forall a. Eq a => a -> a -> Bool == Instrument ScoreT.empty_instrument then Maybe Instrument forall a. Maybe a Nothing else Instrument -> Maybe Instrument 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, a -> Maybe a forall a. a -> Maybe a Just a voice) | Bool otherwise = (TrackInfo track, Maybe a 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 = (Map k TrackNum, f (g (a, TrackNum))) -> f (g (a, TrackNum)) forall a b. (a, b) -> b snd ((Map k TrackNum, f (g (a, TrackNum))) -> f (g (a, TrackNum))) -> (f (g a) -> (Map k TrackNum, f (g (a, TrackNum)))) -> f (g a) -> f (g (a, TrackNum)) forall b c a. (b -> c) -> (a -> b) -> a -> c . ((Map k TrackNum -> g a -> (Map k TrackNum, g (a, TrackNum))) -> Map k TrackNum -> f (g a) -> (Map k TrackNum, f (g (a, TrackNum))) forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) Traversable.mapAccumL ((Map k TrackNum -> g a -> (Map k TrackNum, g (a, TrackNum))) -> Map k TrackNum -> f (g a) -> (Map k TrackNum, f (g (a, TrackNum)))) -> ((Map k TrackNum -> a -> (Map k TrackNum, (a, TrackNum))) -> Map k TrackNum -> g a -> (Map k TrackNum, g (a, TrackNum))) -> (Map k TrackNum -> a -> (Map k TrackNum, (a, TrackNum))) -> Map k TrackNum -> f (g a) -> (Map k TrackNum, f (g (a, TrackNum))) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Map k TrackNum -> a -> (Map k TrackNum, (a, TrackNum))) -> Map k TrackNum -> g a -> (Map k TrackNum, g (a, TrackNum)) forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) Traversable.mapAccumL) Map k TrackNum -> a -> (Map k TrackNum, (a, TrackNum)) forall {b}. Num b => Map k b -> a -> (Map k b, (a, b)) go Map k TrackNum forall a. Monoid a => a mempty where go :: Map k b -> a -> (Map k b, (a, b)) go Map k b counts a x = (k -> b -> Map k b -> Map k b forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert (a -> k key a x) (b nb -> b -> b forall a. Num a => a -> a -> a +b 1) Map k b counts, (a x, b n)) where n :: b n = b -> k -> Map k b -> b forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault b 0 (a -> k key a x) Map k b counts