-- 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