-- 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.Lists as Lists 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 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) = 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) = 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 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", forall a. Pretty a => a -> Doc Pretty.format RealTime start) , (Text "end", forall a. Pretty a => a -> Doc Pretty.format RealTime end) , (Text "block", forall a. Pretty a => a -> Doc Pretty.format BlockId block) , (Text "tracks", forall a. Pretty a => a -> Doc Pretty.format Set TrackId tracks) , (Text "warp", forall a. Pretty a => a -> Doc Pretty.format Warp warp) ] instance DeepSeq.NFData TrackWarp where rnf :: TrackWarp -> () rnf TrackWarp tw = forall a. NFData a => a -> () DeepSeq.rnf (TrackWarp -> Set TrackId tw_tracks TrackWarp tw) seq :: forall a b. a -> b -> b `seq` 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 = 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 = forall b a. b -> (a -> b) -> Maybe a -> b maybe [TrackId] tracks (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 = forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Set a -> Bool Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c . TrackWarp -> Set TrackId tw_tracks) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (Track, [TrackId]) -> TrackWarp convert 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 <- forall (m :: * -> *). M m => m [BlockId] Ui.all_block_ids forall a b. [a] -> [b] -> [(a, b)] zip [BlockId] block_ids forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap TrackInfo -> TrackId Ui.track_id)) forall (f :: * -> *) a b. Functor 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 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) <- forall k a. Map k a -> [(k, a)] Map.toList WarpMap wmap] where get_children :: Stack -> [TrackId] get_children Stack stack = forall b a. b -> (a -> b) -> Maybe a -> b maybe [] [Tree TrackId] -> [TrackId] child_tracks 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) -> 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) -> 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 -> 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] _ -> forall a. a -> Maybe a Just (BlockId block_id, Maybe TrackId track_id) [UiFrame] _ -> 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 = 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 = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a b. (a -> b) -> a -> b $ \(Tree.Node TrackId track_id [Tree TrackId] children) -> if TrackId track_id forall a. Ord a => a -> Set a -> Bool `Set.member` Set TrackId tempo_tracks then [] else TrackId track_id forall a. a -> [a] -> [a] : [Tree TrackId] -> [TrackId] child_tracks [Tree TrackId] children tempo_tracks :: Set TrackId tempo_tracks = forall a. Ord a => [a] -> Set a Set.fromList forall a b. (a -> b) -> a -> b $ forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe (forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. Maybe a Nothing forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . Stack -> Maybe (BlockId, Maybe TrackId) get_block_track) forall a b. (a -> b) -> a -> b $ 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 = forall a b. (a -> b) -> [a] -> [b] map (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 forall a. Eq a => a -> a -> Bool == BlockId block_id, 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 = forall b a. b -> (a -> b) -> Maybe a -> b maybe Warp Warp.identity (TrackWarp -> Warp tw_warp forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) forall a b. (a -> b) -> a -> b $ forall k a. Ord k => (a -> k) -> [a] -> Maybe a Lists.minimumOn (forall a. Num a => a -> a abs forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Num a => a -> a -> a subtract RealTime pos forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) [(RealTime, TrackWarp)] annotated where annotated :: [(RealTime, TrackWarp)] annotated = forall a b. [a] -> [b] -> [(a, b)] zip (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 forall a. Eq a => a -> a -> Bool == BlockId block_id, 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 forall (m :: * -> *) a. Monad m => a -> m a return (BlockId block_id, [(TrackId track_id, TrackTime pos) | TrackId track_id <- 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 = 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 forall a. Ord a => a -> a -> Bool <= RealTime ts Bool -> Bool -> Bool && (Stop stop forall a. Eq a => a -> a -> Bool == Stop Transport.NoStop Bool -> Bool -> Bool || RealTime ts forall a. Ord a => a -> a -> Bool <= TrackWarp -> RealTime tw_end TrackWarp tw) ]