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

{- | TrackWarps are collected throughout derivation each time there is a new
    warp context.  By the end, they represent a complete mapping from ScoreTime
    to RealTime and back again, and can be used to create a TempoFunction and
    InverseTempoFunction, among other things.
-}
module Derive.TrackWarp (
    Track(..), WarpMap, TrackWarp(..)
    , collect_track_warps
    , get_track_trees
    -- * functions on TrackWarp
    , tempo_func, closest_warp, inverse_tempo_func
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree

import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
import qualified Derive.Stack as Stack
import qualified Derive.Warp as Warp
import qualified Perform.Transport as Transport
import qualified Ui.TrackTree as TrackTree
import qualified Ui.Ui as Ui

import Global
import Types


-- | Collected warp for a single track.
-- start end warp block_id (tempo track if there is one)
data Track = Track !RealTime !RealTime !Warp.Warp !BlockId !(Maybe TrackId)
    deriving (Int -> Track -> ShowS
[Track] -> ShowS
Track -> String
(Int -> Track -> ShowS)
-> (Track -> String) -> ([Track] -> ShowS) -> Show Track
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Track] -> ShowS
$cshowList :: [Track] -> ShowS
show :: Track -> String
$cshow :: Track -> String
showsPrec :: Int -> Track -> ShowS
$cshowsPrec :: Int -> Track -> ShowS
Show)

instance Pretty Track where
    format :: Track -> Doc
format (Track RealTime
start RealTime
end Warp
warp BlockId
block_id Maybe TrackId
track_id) =
        (RealTime, RealTime, Warp, BlockId, Maybe TrackId) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (RealTime
start, RealTime
end, Warp
warp, BlockId
block_id, Maybe TrackId
track_id)

instance DeepSeq.NFData Track where
    rnf :: Track -> ()
rnf (Track RealTime
_ RealTime
_ Warp
_ BlockId
_ Maybe TrackId
track_id) = Maybe TrackId -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf Maybe TrackId
track_id

-- | Each 'Track' is collected at the Stack of the track it represents.
-- A Track is only saved when the warp changes, which is likely a tempo
-- track.  'collect_warps' then fills in the rest of the tracks.
type WarpMap = Map Stack.Stack Track

-- | Each track warp is a warp indexed by the block and tracks it covers.
-- These are used by the play monitor to figure out where the play position
-- indicator is at a given point in real time.
data TrackWarp = TrackWarp {
    -- | The range over which this warp's 'tw_warp' can be used.
    TrackWarp -> RealTime
tw_start :: !RealTime
    , TrackWarp -> RealTime
tw_end :: !RealTime
    , TrackWarp -> BlockId
tw_block :: !BlockId
    , TrackWarp -> Set TrackId
tw_tracks :: !(Set TrackId)
    , TrackWarp -> Warp
tw_warp :: !Warp.Warp
    } deriving (Int -> TrackWarp -> ShowS
[TrackWarp] -> ShowS
TrackWarp -> String
(Int -> TrackWarp -> ShowS)
-> (TrackWarp -> String)
-> ([TrackWarp] -> ShowS)
-> Show TrackWarp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrackWarp] -> ShowS
$cshowList :: [TrackWarp] -> ShowS
show :: TrackWarp -> String
$cshow :: TrackWarp -> String
showsPrec :: Int -> TrackWarp -> ShowS
$cshowsPrec :: Int -> TrackWarp -> ShowS
Show)

instance Pretty TrackWarp where
    format :: TrackWarp -> Doc
format (TrackWarp RealTime
start RealTime
end BlockId
block Set TrackId
tracks Warp
warp) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"TrackWarp"
        [ (Text
"start", RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RealTime
start)
        , (Text
"end", RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RealTime
end)
        , (Text
"block", BlockId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format BlockId
block)
        , (Text
"tracks", Set TrackId -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Set TrackId
tracks)
        , (Text
"warp", Warp -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Warp
warp)
        ]

instance DeepSeq.NFData TrackWarp where
    rnf :: TrackWarp -> ()
rnf TrackWarp
tw = Set TrackId -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf (TrackWarp -> Set TrackId
tw_tracks TrackWarp
tw) () -> () -> ()
`seq` Warp -> ()
forall a. NFData a => a -> ()
DeepSeq.rnf (TrackWarp -> Warp
tw_warp TrackWarp
tw)

convert :: (Track, [TrackId]) -> TrackWarp
convert :: (Track, [TrackId]) -> TrackWarp
convert (Track RealTime
start RealTime
end Warp
warp BlockId
block_id Maybe TrackId
maybe_track_id, [TrackId]
tracks) =
    TrackWarp
        { tw_start :: RealTime
tw_start = RealTime
start
        , tw_end :: RealTime
tw_end = RealTime
end
        , tw_block :: BlockId
tw_block = BlockId
block_id
        , tw_tracks :: Set TrackId
tw_tracks = [TrackId] -> Set TrackId
forall a. Ord a => [a] -> Set a
Set.fromList [TrackId]
track_ids
        , tw_warp :: Warp
tw_warp = Warp
warp
        }
    where track_ids :: [TrackId]
track_ids = [TrackId] -> (TrackId -> [TrackId]) -> Maybe TrackId -> [TrackId]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TrackId]
tracks (TrackId -> [TrackId] -> [TrackId]
forall a. a -> [a] -> [a]
:[TrackId]
tracks) Maybe TrackId
maybe_track_id

-- | Collect 'Track's together into TrackWarps'.
collect_track_warps :: [(BlockId, [Tree.Tree TrackId])] -> WarpMap
    -> [TrackWarp]
collect_track_warps :: [(BlockId, [Tree TrackId])] -> WarpMap -> [TrackWarp]
collect_track_warps [(BlockId, [Tree TrackId])]
blocks =
    (TrackWarp -> Bool) -> [TrackWarp] -> [TrackWarp]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TrackWarp -> Bool) -> TrackWarp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TrackId -> Bool
forall a. Set a -> Bool
Set.null (Set TrackId -> Bool)
-> (TrackWarp -> Set TrackId) -> TrackWarp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackWarp -> Set TrackId
tw_tracks) ([TrackWarp] -> [TrackWarp])
-> (WarpMap -> [TrackWarp]) -> WarpMap -> [TrackWarp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Track, [TrackId]) -> TrackWarp)
-> [(Track, [TrackId])] -> [TrackWarp]
forall a b. (a -> b) -> [a] -> [b]
map (Track, [TrackId]) -> TrackWarp
convert ([(Track, [TrackId])] -> [TrackWarp])
-> (WarpMap -> [(Track, [TrackId])]) -> WarpMap -> [TrackWarp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(BlockId, [Tree TrackId])] -> WarpMap -> [(Track, [TrackId])]
collect_warps [(BlockId, [Tree TrackId])]
blocks
    -- There will be a TrackWarp with a null 'tw_tracks' if there are multiple
    -- tempo tracks at the top level.

get_track_trees :: Ui.M m => m [(BlockId, [Tree.Tree TrackId])]
get_track_trees :: forall (m :: * -> *). M m => m [(BlockId, [Tree TrackId])]
get_track_trees = do
    [BlockId]
block_ids <- m [BlockId]
forall (m :: * -> *). M m => m [BlockId]
Ui.all_block_ids
    [BlockId] -> [[Tree TrackId]] -> [(BlockId, [Tree TrackId])]
forall a b. [a] -> [b] -> [(a, b)]
zip [BlockId]
block_ids ([[Tree TrackId]] -> [(BlockId, [Tree TrackId])])
-> ([[Tree TrackInfo]] -> [[Tree TrackId]])
-> [[Tree TrackInfo]]
-> [(BlockId, [Tree TrackId])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Tree TrackInfo] -> [Tree TrackId])
-> [[Tree TrackInfo]] -> [[Tree TrackId]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree TrackInfo -> Tree TrackId)
-> [Tree TrackInfo] -> [Tree TrackId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TrackInfo -> TrackId) -> Tree TrackInfo -> Tree TrackId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TrackInfo -> TrackId
Ui.track_id)) ([[Tree TrackInfo]] -> [(BlockId, [Tree TrackId])])
-> m [[Tree TrackInfo]] -> m [(BlockId, [Tree TrackId])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (BlockId -> m [Tree TrackInfo])
-> [BlockId] -> m [[Tree TrackInfo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BlockId -> m [Tree TrackInfo]
forall (m :: * -> *). M m => BlockId -> m [Tree TrackInfo]
TrackTree.track_tree_of [BlockId]
block_ids

{- | The WarpMap only has TrackWarps for tempo tracks.  But I want to have
    playback cursors on all tracks, and be able to start play from any track.
    So this will extend a Track of a block or a track to all of its
    children.  This assumes that no one else is fiddling with the Warp.

    Previously I would collect TrackWarps on every track, which is more
    technically correct.  However, due to note inversion, that wounds up
    collecting a Track for every single note, and just sorting all of the
    stacks was at the top of the profile output.
-}
collect_warps :: [(BlockId, [Tree.Tree TrackId])] -> WarpMap
    -> [(Track, [TrackId])]
collect_warps :: [(BlockId, [Tree TrackId])] -> WarpMap -> [(Track, [TrackId])]
collect_warps [(BlockId, [Tree TrackId])]
blocks WarpMap
wmap =
    [(Track
tw, Stack -> [TrackId]
get_children Stack
stack) | (Stack
stack, Track
tw) <- WarpMap -> [(Stack, Track)]
forall k a. Map k a -> [(k, a)]
Map.toList WarpMap
wmap]
    where
    get_children :: Stack -> [TrackId]
get_children Stack
stack = [TrackId]
-> ([Tree TrackId] -> [TrackId])
-> Maybe [Tree TrackId]
-> [TrackId]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Tree TrackId] -> [TrackId]
child_tracks (Maybe [Tree TrackId] -> [TrackId])
-> Maybe [Tree TrackId] -> [TrackId]
forall a b. (a -> b) -> a -> b
$ case Stack -> Maybe (BlockId, Maybe TrackId)
get_block_track Stack
stack of
        Just (BlockId
block_id, Maybe TrackId
Nothing) -> BlockId -> Map BlockId [Tree TrackId] -> Maybe [Tree TrackId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id Map BlockId [Tree TrackId]
block_children
        Just (BlockId
block_id, Just TrackId
track_id) ->
            (BlockId, TrackId)
-> Map (BlockId, TrackId) [Tree TrackId] -> Maybe [Tree TrackId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BlockId
block_id, TrackId
track_id) Map (BlockId, TrackId) [Tree TrackId]
track_children
        Maybe (BlockId, Maybe TrackId)
Nothing -> Maybe [Tree TrackId]
forall a. Maybe a
Nothing
    get_block_track :: Stack -> Maybe (BlockId, Maybe TrackId)
get_block_track Stack
stack = case Stack -> [UiFrame]
Stack.to_ui_innermost Stack
stack of
        (Just BlockId
block_id, Maybe TrackId
track_id, Maybe (TrackTime, TrackTime)
_) : [UiFrame]
_ -> (BlockId, Maybe TrackId) -> Maybe (BlockId, Maybe TrackId)
forall a. a -> Maybe a
Just (BlockId
block_id, Maybe TrackId
track_id)
        [UiFrame]
_ -> Maybe (BlockId, Maybe TrackId)
forall a. Maybe a
Nothing
    -- If a block doesn't have a toplevel tempo track, it gets an implicit
    -- one, which of course won't have its own TrackId.
    block_children :: Map BlockId [Tree TrackId]
block_children = [(BlockId, [Tree TrackId])] -> Map BlockId [Tree TrackId]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (BlockId
block_id, [Tree TrackId]
tracks)
        | (BlockId
block_id, [Tree TrackId]
tracks) <- [(BlockId, [Tree TrackId])]
blocks
        ]
    track_children :: Map (BlockId, TrackId) [Tree TrackId]
track_children = [((BlockId, TrackId), [Tree TrackId])]
-> Map (BlockId, TrackId) [Tree TrackId]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ ((BlockId
block_id, TrackId
track_id), [Tree TrackId]
children)
        | (BlockId
block_id, [Tree TrackId]
tracks) <- [(BlockId, [Tree TrackId])]
blocks
        , Tree.Node TrackId
track_id [Tree TrackId]
children <- [Tree TrackId]
tracks
        ]
    -- Get all child TrackIds, but stop as soon as I hit another tempo track.
    child_tracks :: [Tree TrackId] -> [TrackId]
child_tracks = (Tree TrackId -> [TrackId]) -> [Tree TrackId] -> [TrackId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Tree TrackId -> [TrackId]) -> [Tree TrackId] -> [TrackId])
-> (Tree TrackId -> [TrackId]) -> [Tree TrackId] -> [TrackId]
forall a b. (a -> b) -> a -> b
$ \(Tree.Node TrackId
track_id [Tree TrackId]
children) ->
        if TrackId
track_id TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
tempo_tracks then []
            else TrackId
track_id TrackId -> [TrackId] -> [TrackId]
forall a. a -> [a] -> [a]
: [Tree TrackId] -> [TrackId]
child_tracks [Tree TrackId]
children
    tempo_tracks :: Set TrackId
tempo_tracks = [TrackId] -> Set TrackId
forall a. Ord a => [a] -> Set a
Set.fromList ([TrackId] -> Set TrackId) -> [TrackId] -> Set TrackId
forall a b. (a -> b) -> a -> b
$
        (Stack -> Maybe TrackId) -> [Stack] -> [TrackId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe TrackId
-> ((BlockId, Maybe TrackId) -> Maybe TrackId)
-> Maybe (BlockId, Maybe TrackId)
-> Maybe TrackId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe TrackId
forall a. Maybe a
Nothing (BlockId, Maybe TrackId) -> Maybe TrackId
forall a b. (a, b) -> b
snd (Maybe (BlockId, Maybe TrackId) -> Maybe TrackId)
-> (Stack -> Maybe (BlockId, Maybe TrackId))
-> Stack
-> Maybe TrackId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack -> Maybe (BlockId, Maybe TrackId)
get_block_track) ([Stack] -> [TrackId]) -> [Stack] -> [TrackId]
forall a b. (a -> b) -> a -> b
$ WarpMap -> [Stack]
forall k a. Map k a -> [k]
Map.keys WarpMap
wmap

-- * functions on TrackWarp

tempo_func :: [TrackWarp] -> Transport.TempoFunction
tempo_func :: [TrackWarp] -> TempoFunction
tempo_func [TrackWarp]
track_warps BlockId
block_id TrackId
track_id TrackTime
pos = (Warp -> RealTime) -> [Warp] -> [RealTime]
forall a b. (a -> b) -> [a] -> [b]
map ((Warp -> TrackTime -> RealTime) -> TrackTime -> Warp -> RealTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip Warp -> TrackTime -> RealTime
Warp.warp TrackTime
pos) [Warp]
warps
    where
    warps :: [Warp]
warps = [TrackWarp -> Warp
tw_warp TrackWarp
tw | TrackWarp
tw <- [TrackWarp]
track_warps, TrackWarp -> BlockId
tw_block TrackWarp
tw BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
block_id,
        TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TrackId
track_id (TrackWarp -> Set TrackId
tw_tracks TrackWarp
tw)]

-- | If a block is called in multiple places, a score time on it may occur at
-- multiple real times.  Find the Warp which is closest to a given RealTime, or
-- the ID warp if there are none.
--
-- Pick the real time from the given selection which is
-- closest to the real time of the selection on the root block.
--
-- Return the first real time if there's no root or it doesn't have
-- a selection.
--
-- This can't use Transport.TempoFunction because I need to pick the
-- appropriate Warp and then look up multiple ScoreTimes in it.
closest_warp :: [TrackWarp] -> Transport.ClosestWarpFunction
closest_warp :: [TrackWarp] -> ClosestWarpFunction
closest_warp [TrackWarp]
track_warps BlockId
block_id TrackId
track_id RealTime
pos =
    Warp
-> ((RealTime, TrackWarp) -> Warp)
-> Maybe (RealTime, TrackWarp)
-> Warp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Warp
Warp.identity (TrackWarp -> Warp
tw_warp (TrackWarp -> Warp)
-> ((RealTime, TrackWarp) -> TrackWarp)
-> (RealTime, TrackWarp)
-> Warp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, TrackWarp) -> TrackWarp
forall a b. (a, b) -> b
snd) (Maybe (RealTime, TrackWarp) -> Warp)
-> Maybe (RealTime, TrackWarp) -> Warp
forall a b. (a -> b) -> a -> b
$
        ((RealTime, TrackWarp) -> RealTime)
-> [(RealTime, TrackWarp)] -> Maybe (RealTime, TrackWarp)
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.minimum_on (RealTime -> RealTime
forall a. Num a => a -> a
abs (RealTime -> RealTime)
-> ((RealTime, TrackWarp) -> RealTime)
-> (RealTime, TrackWarp)
-> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
subtract RealTime
pos (RealTime -> RealTime)
-> ((RealTime, TrackWarp) -> RealTime)
-> (RealTime, TrackWarp)
-> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, TrackWarp) -> RealTime
forall a b. (a, b) -> a
fst) [(RealTime, TrackWarp)]
annotated
    where
    annotated :: [(RealTime, TrackWarp)]
annotated = [RealTime] -> [TrackWarp] -> [(RealTime, TrackWarp)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TrackWarp -> RealTime) -> [TrackWarp] -> [RealTime]
forall a b. (a -> b) -> [a] -> [b]
map TrackWarp -> RealTime
tw_start [TrackWarp]
warps) [TrackWarp]
warps
    warps :: [TrackWarp]
warps = [TrackWarp
tw | TrackWarp
tw <- [TrackWarp]
track_warps, TrackWarp -> BlockId
tw_block TrackWarp
tw BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
block_id,
        TrackId -> Set TrackId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TrackId
track_id (TrackWarp -> Set TrackId
tw_tracks TrackWarp
tw)]

-- | Take RealTime back to the TrackTimes on the various blocks that it
-- corresponds to.
inverse_tempo_func :: [TrackWarp] -> Transport.InverseTempoFunction
inverse_tempo_func :: [TrackWarp] -> InverseTempoFunction
inverse_tempo_func [TrackWarp]
track_warps Stop
stop RealTime
realtime = do
    (BlockId
block_id, Set TrackId
track_ids, TrackTime
pos) <- [(BlockId, Set TrackId, TrackTime)]
track_pos
    (BlockId, [(TrackId, TrackTime)])
-> [(BlockId, [(TrackId, TrackTime)])]
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
block_id, [(TrackId
track_id, TrackTime
pos) | TrackId
track_id <- Set TrackId -> [TrackId]
forall a. Set a -> [a]
Set.toList Set TrackId
track_ids])
    where
    -- Ornaments and leading keyswitches can result in starting at a negative
    -- time.  But if this function returns [] the play monitor thread will take
    -- that to mean the performance is over.
    ts :: RealTime
ts = RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
0 RealTime
realtime
    -- ts <= tw_end means that you can get the ScoreTime for the end of
    -- a block.  This is useful because then "Cmd.StepPlay" can step to the
    -- very end.
    track_pos :: [(BlockId, Set TrackId, TrackTime)]
track_pos =
        [ (TrackWarp -> BlockId
tw_block TrackWarp
tw, TrackWarp -> Set TrackId
tw_tracks TrackWarp
tw, Warp -> RealTime -> TrackTime
Warp.unwarp (TrackWarp -> Warp
tw_warp TrackWarp
tw) RealTime
ts)
        | TrackWarp
tw <- [TrackWarp]
track_warps
        , TrackWarp -> RealTime
tw_start TrackWarp
tw RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= RealTime
ts Bool -> Bool -> Bool
&& (Stop
stop Stop -> Stop -> Bool
forall a. Eq a => a -> a -> Bool
== Stop
Transport.NoStop Bool -> Bool -> Bool
|| RealTime
ts RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= TrackWarp -> RealTime
tw_end TrackWarp
tw)
        ]