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