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