-- 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 Derive.C.Prelude.Integrate ( library, unwarp ) where import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Util.Lists as Lists import qualified Derive.Call as Call import qualified Derive.Call.BlockUtil as BlockUtil import qualified Derive.Call.Module as Module import qualified Derive.Controls as Controls import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Deriver.Internal as Internal import qualified Derive.Env as Env import qualified Derive.Library as Library import qualified Derive.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Derive.Sig as Sig import qualified Derive.Stack as Stack import qualified Derive.Stream as Stream import qualified Derive.Warp as Warp import qualified Perform.RealTime as RealTime import qualified Ui.TrackTree as TrackTree import qualified Ui.Ui as Ui import qualified Ui.UiConfig as UiConfig import Global import Types library :: Library.Library library :: Library library = forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [ (Symbol "<<", Transformer Note c_block_integrate) , (Symbol "<", Transformer Note c_track_integrate) ] -- * block integrate c_block_integrate :: Derive.Transformer Derive.Note c_block_integrate :: Transformer Note c_block_integrate = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module Module.prelude CallName "block-integrate" forall a. Monoid a => a mempty (Doc "Integrate the output into a new block. The events are returned as-is\ \ so the block can still be played normally." ) forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d) Sig.callt ( forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "keep-controls" (forall a. Ord a => [a] -> Set a Set.fromList [Control Controls.dynamic]) Doc "Keep only these controls. Transposers are always kept." ) forall a b. (a -> b) -> a -> b $ \Set Control keep_controls PassedArgs Note _ Deriver (Stream Note) deriver -> do Stream Note events <- Deriver (Stream Note) deriver Set Control -> Stream Note -> Deriver () block_integrate Set Control keep_controls Stream Note events forall (m :: * -> *) a. Monad m => a -> m a return Stream Note events block_integrate :: Set ScoreT.Control -> Stream.Stream Score.Event -> Derive.Deriver () block_integrate :: Set Control -> Stream Note -> Deriver () block_integrate Set Control keep_controls Stream Note events = do -- Only collect an integration if this is the top level block. Otherwise -- I can get integrating blocks called from many places and who knows which -- one is supposed to be integrated. forall (m :: * -> *) a. Monad m => m (Maybe a) -> (a -> m ()) -> m () whenJustM (Stack -> Maybe (BlockId, Maybe TrackId) toplevel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver Stack Internal.get_stack) forall a b. (a -> b) -> a -> b $ \(BlockId block_id, Maybe TrackId mb_track_id) -> do forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust Maybe TrackId mb_track_id forall a b. (a -> b) -> a -> b $ \TrackId track_id -> forall a. Stack => Key -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Key "block integrate seems to be in a track title: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Key pretty TrackId track_id Stream Note events <- forall a. Stack => StateId a -> Deriver a Derive.eval_ui forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). M m => BlockId -> Stream Note -> m (Stream Note) unwarp BlockId block_id Stream Note events let keep :: Set Control keep = Set Control keep_controls forall a. Semigroup a => a -> a -> a <> Set Control Controls.integrate_keep let integrated :: Integrated integrated = Either BlockId TrackId -> Stream Note -> Integrated Derive.Integrated (forall a b. a -> Either a b Left BlockId block_id) forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Set Control -> Note -> Note strip_controls Set Control keep) Stream Note events Collect -> Deriver () Internal.merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_integrated :: [Integrated] Derive.collect_integrated = [Integrated integrated] } -- | If the block uses a default tempo, it will get applied once during -- integration, and again when it's played. I should avoid applying the -- default tempo at all for integration, but that's too much bother. Instead, -- unwarp the events if the default tempo was applied. -- -- TODO Getting rid of the default tempo entirely is also an option. unwarp :: Ui.M m => BlockId -> Stream.Stream Score.Event -> m (Stream.Stream Score.Event) unwarp :: forall (m :: * -> *). M m => BlockId -> Stream Note -> m (Stream Note) unwarp BlockId block_id Stream Note events = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a ifM (forall (m :: * -> *). M m => BlockId -> m Bool uses_default_tempo BlockId block_id) (do Y tempo <- forall (m :: * -> *) a. M m => (Default -> a) -> m a Ui.get_default Default -> Y UiConfig.default_tempo forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall {f :: * -> *}. Functor f => RealTime -> f Note -> f Note move (Y -> RealTime RealTime.seconds Y tempo) Stream Note events) (forall (m :: * -> *) a. Monad m => a -> m a return Stream Note events) where move :: RealTime -> f Note -> f Note move RealTime tempo = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a -> b) -> a -> b $ (RealTime -> RealTime) -> Note -> Note Score.move (forall a. Num a => a -> a -> a *RealTime tempo) forall b c a. (b -> c) -> (a -> b) -> a -> c . (RealTime -> RealTime) -> Note -> Note Score.duration (forall a. Num a => a -> a -> a *RealTime tempo) uses_default_tempo :: Ui.M m => BlockId -> m Bool uses_default_tempo :: forall (m :: * -> *). M m => BlockId -> m Bool uses_default_tempo BlockId block_id = forall a. Maybe a -> Bool Maybe.isJust forall b c a. (b -> c) -> (a -> b) -> a -> c . [Tree Track] -> Maybe (Tree Track) BlockUtil.has_top_tempo_track forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => BlockId -> m [Tree Track] TrackTree.events_tree_of BlockId block_id -- * track integrate c_track_integrate :: Derive.Transformer Derive.Note c_track_integrate :: Transformer Note c_track_integrate = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module Module.prelude CallName "track-integrate" forall a. Monoid a => a mempty (Doc "Integrate the output into new tracks. Events will be split into tracks\ \ based on source track, instrument, and scale, as documented in\ \ 'Cmd.Integrate.Convert'.\ \\nUnlike block integrate, this doesn't return the events.\ \ While an integrated block's output is likely to be playable, and\ \ you can chose whether or not to play it, an integrated track\ \ is part of a block, so it plays whether you want it or not." ) forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d) Sig.callt ( forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "keep-controls" (forall a. Ord a => [a] -> Set a Set.fromList [Control Controls.dynamic]) Doc "Keep only these controls. Transposers are always kept." ) forall a b. (a -> b) -> a -> b $ \Set Control keep_controls PassedArgs Note _args Deriver (Stream Note) deriver -> do -- Similar to block_integrate, only collect an integration if this is -- at the toplevel. Stack -> Maybe (BlockId, Maybe TrackId) toplevel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver Stack Internal.get_stack forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just (BlockId block_id, Maybe TrackId Nothing) -> forall a. Stack => Key -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Key "track integrate seems to be in a block title: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Key pretty BlockId block_id Just (BlockId block_id, Just TrackId track_id) -> do -- The derive is intentionally outside of the -- 'only_destinations_damaged' check. This is because I need -- the collect from it, specifically 'collect_track_dynamic'. -- I could avoid derivation by retaining the track dynamics -- from the previous performance, but it seems like this would -- lead to it hanging on to lots of garbage, especially since -- it would never drop track dynamics entries for deleted -- tracks. Stream Note events <- Stream Note -> Deriver (Stream Note) unwarp_events forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall a. Deriver a -> Deriver a integrate_derive Deriver (Stream Note) deriver -- Always include transposers because they affect the pitches. -- TODO: technically they should be from pscale_transposers, -- but that's so much work to collect, let's just assume the -- standards. let keep :: Set Control keep = Set Control keep_controls forall a. Semigroup a => a -> a -> a <> Set Control Controls.integrate_keep -- I originally guarded this with a hack that would not emit -- track integrates if only the destinations had received -- damage. But the track cache now serves this purpose, since -- it intentionally doesn't retain 'Derive.collect_integrated'. BlockId -> TrackId -> Stream Note -> Deriver () track_integrate BlockId block_id TrackId track_id forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Set Control -> Note -> Note strip_controls Set Control keep) Stream Note events Maybe (BlockId, Maybe TrackId) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return () forall (m :: * -> *) a. Monad m => a -> m a return forall a. Stream a Stream.empty integrate_derive :: Derive.Deriver a -> Derive.Deriver a integrate_derive :: forall a. Deriver a -> Deriver a integrate_derive Deriver a deriver = do -- See comment in "Cmd.Integrate.Convert" for why. Y dyn <- RealTime -> Deriver Y Call.dynamic RealTime 0 forall a. Control -> Y -> Deriver a -> Deriver a Derive.with_constant_control Control Controls.dynamic_integrate Y dyn Deriver a deriver -- | Unwarp integrated events, otherwise the tempo would be applied twice, once -- during integration and again during derivation of the integrated output. -- -- Previously I used 'Internal.in_real_time', but it turns out that yields -- different results for calls that use RealTime. To get the same results as a -- play would, I have to do the derive normally and then unwrap after the fact. -- This doesn't unwarp the control signals, but Integrate.Convert only looks -- at values on note starts, so the complete signals don't matter. unwarp_events :: Stream.Stream Score.Event -> Derive.Deriver (Stream.Stream Score.Event) unwarp_events :: Stream Note -> Deriver (Stream Note) unwarp_events Stream Note events = do Warp warp <- forall a. (Dynamic -> a) -> Deriver a Internal.get_dynamic Dynamic -> Warp Derive.state_warp forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((RealTime -> ScoreTime) -> Note -> Note unwarp_event (Warp -> RealTime -> ScoreTime Warp.unwarp Warp warp)) Stream Note events unwarp_event :: (RealTime -> ScoreTime) -> Score.Event -> Score.Event unwarp_event :: (RealTime -> ScoreTime) -> Note -> Note unwarp_event RealTime -> ScoreTime to_score Note event = RealTime -> RealTime -> Note -> Note Score.place RealTime start (RealTime end forall a. Num a => a -> a -> a - RealTime start) Note event where start :: RealTime start = RealTime -> RealTime convert (Note -> RealTime Score.event_start Note event) end :: RealTime end = RealTime -> RealTime convert (Note -> RealTime Score.event_end Note event) convert :: RealTime -> RealTime convert = ScoreTime -> RealTime RealTime.from_score forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> ScoreTime to_score strip_controls :: Set ScoreT.Control -> Score.Event -> Score.Event strip_controls :: Set Control -> Note -> Note strip_controls Set Control keep Note event = Note event { event_environ :: Environ Score.event_environ = Map Key Val -> Environ Env.from_map forall a b. (a -> b) -> a -> b $ forall k a. Eq k => [(k, a)] -> Map k a Map.fromAscList forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter (Key, Val) -> Bool wanted forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toAscList forall a b. (a -> b) -> a -> b $ Environ -> Map Key Val Env.to_map forall a b. (a -> b) -> a -> b $ Note -> Environ Score.event_environ Note event } where wanted :: (Key, Val) -> Bool wanted (Key key, (DeriveT.VSignal Typed Control _)) = forall a. Ord a => a -> Set a -> Bool Set.member (Key -> Control ScoreT.Control Key key) Set Control keep wanted (Key, Val) _ = Bool True track_integrate :: BlockId -> TrackId -> Stream.Stream Score.Event -> Derive.Deriver () track_integrate :: BlockId -> TrackId -> Stream Note -> Deriver () track_integrate BlockId block_id TrackId track_id Stream Note events = do Stream Note events <- forall a. Stack => StateId a -> Deriver a Derive.eval_ui forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). M m => BlockId -> Stream Note -> m (Stream Note) unwarp BlockId block_id Stream Note events let integrated :: Integrated integrated = Either BlockId TrackId -> Stream Note -> Integrated Derive.Integrated (forall a b. b -> Either a b Right TrackId track_id) Stream Note events Collect -> Deriver () Internal.merge_collect forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { collect_integrated :: [Integrated] Derive.collect_integrated = [Integrated integrated] } toplevel :: Stack.Stack -> Maybe (BlockId, Maybe TrackId) toplevel :: Stack -> Maybe (BlockId, Maybe TrackId) toplevel Stack stack = case Stack -> [(BlockId, [TrackId])] Stack.block_tracks_of Stack stack of [(BlockId block_id, [TrackId] track_ids)] -> forall a. a -> Maybe a Just (BlockId block_id, forall a. [a] -> Maybe a Lists.last [TrackId] track_ids) [(BlockId, [TrackId])] _ -> forall a. Maybe a Nothing