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

{- | Cmd-level support for integration.  These cmds interpret the output of
    the calls in "Derive.Call.Integrate" to create score from deriver output
    and merge it back into the current score.

    An example of track integration:

    - Add \" | <\" to a note track title, which causes damage and a rederive.

    - The integrate call @<@ collects events and puts them into derive results,
    which go into DeriveComplete, which winds up at 'integrate_tracks'.

    - 'integrate_tracks' finds no existing derived tracks, so it merges into
    [], which creates new tracks, and damages the whole block.

    - Then it sets 'Cmd.derive_immediately' on the block, which removes the
    usual derive wait.

    - Derive once again emits integrate results, which winds up at
    'integrate_tracks' again, but since there are no changes this time, there
    is no further damage, and derivation stops.  This additional integration
    just to find out there were no changes is inefficient, but not a big deal
    since it only happens the first time.

    Modify source track:

    - Track damage causes a rederive, which causes the @<@ call to collect
    integrated events.

    - 'integrate_tracks' merges the changes into the destination track (or
    tracks), which damages them.

    - This time when the derive happens, since there was no damage on the
    source track, it gets cached.  The cache intentionally doesn't retain
    integrated events, so @<@ is skipped and I don't get a second derivation.

    Block integration is similar, except that I don't get a double derivation
    when the first new block is created, since the damage is separated to
    a different block.

    It might be a little more orthogonal to omit the thing where
    I automatically create an integrated block or track if there are none, but
    it's convenient in practice.  It does, however, make it tricky to undo
    past the integrate, since if you undo the block\/track creation, the
    integrate call is still there and just creates another.  Be quick!

    This also implements score integration, which is a higher level form of
    integration that simply copies score events directly, without the
    intervening derive step.
-}
module Cmd.Integrate (cmd_integrate, score_integrate, manual_integrate) where
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.Log as Log

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Create as Create
import qualified Cmd.Integrate.Convert as Convert
import qualified Cmd.Integrate.Merge as Merge
import qualified Cmd.Msg as Msg

import qualified Derive.Derive as Derive
import qualified Ui.Block as Block
import qualified Ui.Ui as Ui
import qualified Ui.Update as Update

import           Global
import           Types


-- | Derive integrate takes the result of a derivation and merges it into
-- blocks or tracks which are marked as integrate destinations.  A special
-- derive call captures events and saves them in 'Cmd.perf_integrated'.
cmd_integrate :: Cmd.M m => Msg.Msg -> m Cmd.Status
cmd_integrate :: forall (m :: * -> *). M m => Msg -> m Status
cmd_integrate (Msg.DeriveStatus BlockId
block_id (Msg.DeriveComplete Performance
perf ImStarted
_)) = do
    -- If a block or track wants to integrate twice with different events,
    -- I don't know which ones to give to the destinations, and wind up
    -- creating a new track every time.
    let ([Integrated]
dups, [Integrated]
integrates) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. NonEmpty a -> Either a a
is_dup forall a b. (a -> b) -> a -> b
$
            forall key a. Eq key => (a -> key) -> [a] -> [NonEmpty a]
Lists.groupStable Integrated -> Either BlockId TrackId
Derive.integrated_source
                (Performance -> [Integrated]
Cmd.perf_integrated Performance
perf)
        is_dup :: NonEmpty a -> Either a a
is_dup (a
x :| [a]
xs) = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs then forall a b. b -> Either a b
Right a
x else forall a b. a -> Either a b
Left a
x
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Integrated]
dups) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"these blocks or tracks want to integrate twice: "
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
                (forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> Text
pretty forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integrated -> Either BlockId TrackId
Derive.integrated_source) [Integrated]
dups)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => BlockId -> Integrated -> m ()
integrate BlockId
block_id) [Integrated]
integrates
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
cmd_integrate Msg
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue

-- | Integrate the track information into the current state.
integrate :: Cmd.M m => BlockId -> Derive.Integrated -> m ()
integrate :: forall (m :: * -> *). M m => BlockId -> Integrated -> m ()
integrate BlockId
derived_block_id Integrated
integrated = do
    Tracks
tracks <- forall (m :: * -> *). M m => BlockId -> Stream Event -> m Tracks
Convert.convert BlockId
derived_block_id
        (Integrated -> Stream Event
Derive.integrated_events Integrated
integrated)
    case Integrated -> Either BlockId TrackId
Derive.integrated_source Integrated
integrated of
        Left BlockId
block_id -> forall (m :: * -> *). M m => BlockId -> Tracks -> m ()
integrate_block BlockId
block_id Tracks
tracks
        Right TrackId
track_id -> forall (m :: * -> *). M m => BlockId -> TrackId -> Tracks -> m ()
integrate_tracks BlockId
derived_block_id TrackId
track_id Tracks
tracks

-- | Update and replace the DeriveDestinations for the given TrackId.
-- A source track can have multiple destinations, and each of those is actually
-- a list of DeriveDestinations.
integrate_tracks :: Cmd.M m => BlockId -> TrackId -> Convert.Tracks -> m ()
integrate_tracks :: forall (m :: * -> *). M m => BlockId -> TrackId -> Tracks -> m ()
integrate_tracks BlockId
block_id TrackId
track_id Tracks
tracks = do
    Block
block <- forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    -- This means the < call on a non-top block emitted Cmd.perf_integrated.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Block -> [TrackId]
Block.block_track_ids Block
block) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"derivation of " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
" wanted to derive "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackId
track_id forall a. Semigroup a => a -> a -> a
<> Text
", which is not in that block"
    [(TrackId, TrackDestinations)]
itracks <- Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    let dests :: [[NoteDestination]]
dests =
            [ [NoteDestination]
dests
            | (TrackId
source_id, Block.DeriveDestinations [NoteDestination]
dests) <- [(TrackId, TrackDestinations)]
itracks
            , TrackId
source_id forall a. Eq a => a -> a -> Bool
== TrackId
track_id
            ]
    [[NoteDestination]]
new_dests <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[NoteDestination]]
dests
        then (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
MergeTitles
-> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination]
Merge.merge_tracks MergeTitles
Merge.KeepTitles BlockId
block_id Tracks
tracks []
        else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
M m =>
MergeTitles
-> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination]
Merge.merge_tracks MergeTitles
Merge.KeepTitles BlockId
block_id Tracks
tracks) [[NoteDestination]]
dests
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[NoteDestination]]
new_dests) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"derive track integrate " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
" "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty TrackId
track_id forall a. Semigroup a => a -> a -> a
<> Text
" to "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDestination -> (TrackId, EventIndex)
Block.dest_note)) [[NoteDestination]]
new_dests)
    forall (m :: * -> *).
M m =>
BlockId
-> ([(TrackId, TrackDestinations)]
    -> [(TrackId, TrackDestinations)])
-> m ()
Ui.modify_integrated_tracks BlockId
block_id forall a b. (a -> b) -> a -> b
$ forall key a.
Eq key =>
key -> [(key, a)] -> [(key, a)] -> [(key, a)]
replace TrackId
track_id
        [(TrackId
track_id, [NoteDestination] -> TrackDestinations
Block.DeriveDestinations [NoteDestination]
dests) | [NoteDestination]
dests <- [[NoteDestination]]
new_dests]
    forall (m :: * -> *). M m => [BlockId] -> m ()
Cmd.derive_immediately [BlockId
block_id]

-- | Look for blocks derived from this one and replace their contents, or
-- create a new block if there are no blocks derived from this one.
integrate_block :: Cmd.M m => BlockId -> Convert.Tracks -> m ()
integrate_block :: forall (m :: * -> *). M m => BlockId -> Tracks -> m ()
integrate_block BlockId
source_id Tracks
tracks = do
    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    [(BlockId, [NoteDestination])]
dest_blocks <- case forall {a}. Map a Block -> [(a, [NoteDestination])]
integrated_from Map BlockId Block
blocks of
        [] -> do
            (BlockId
block_id, [NoteDestination]
dests) <- forall (m :: * -> *).
M m =>
BlockId -> Tracks -> m (BlockId, [NoteDestination])
Merge.create_block BlockId
source_id Tracks
tracks
            forall (m :: * -> *). M m => BlockId -> m ViewId
Create.view BlockId
block_id
            forall (m :: * -> *) a. Monad m => a -> m a
return [(BlockId
block_id, [NoteDestination]
dests)]
        [(BlockId, [NoteDestination])]
integrated -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(BlockId, [NoteDestination])]
integrated forall a b. (a -> b) -> a -> b
$ \(BlockId
dest_id, [NoteDestination]
track_dests) ->
            (,) BlockId
dest_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination]
Merge.merge_block BlockId
dest_id Tracks
tracks [NoteDestination]
track_dests
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"derive integrated " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
source_id forall a. Semigroup a => a -> a -> a
<> Text
" to "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(BlockId, [NoteDestination])]
dest_blocks)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, [NoteDestination])]
dest_blocks forall a b. (a -> b) -> a -> b
$ \(BlockId
dest_block_id, [NoteDestination]
track_dests) ->
        forall (m :: * -> *).
M m =>
BlockId -> Maybe (BlockId, TrackDestinations) -> m ()
Ui.set_integrated_block BlockId
dest_block_id forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just (BlockId
source_id, [NoteDestination] -> TrackDestinations
Block.DeriveDestinations [NoteDestination]
track_dests)
    forall (m :: * -> *). M m => [BlockId] -> m ()
Cmd.derive_immediately (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(BlockId, [NoteDestination])]
dest_blocks)
    where
    integrated_from :: Map a Block -> [(a, [NoteDestination])]
integrated_from Map a Block
blocks =
        [ (a
block_id, [NoteDestination]
dests)
        | (a
block_id, Just (BlockId
source_block, Block.DeriveDestinations [NoteDestination]
dests))
            <- forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated) (forall k a. Map k a -> [(k, a)]
Map.toList Map a Block
blocks)
        , BlockId
source_block forall a. Eq a => a -> a -> Bool
== BlockId
source_id
        ]


-- * score integrate

-- | For each block with 'Block.ScoreDestinations', figure out if their sources
-- have damage, and if so, re-integrate.
score_integrate :: [Update.UiUpdate] -> Ui.State
    -> Either Ui.Error ([Log.Msg], Ui.State, Update.UiDamage)
score_integrate :: [UiUpdate] -> State -> Either Error ([Msg], State, UiDamage)
score_integrate [UiUpdate]
updates State
state = forall a. State -> StateId a -> Either Error (a, State, UiDamage)
Ui.run_id State
state forall a b. (a -> b) -> a -> b
$ do
    -- These both use the passed state instead of using Ui.get when figuring
    -- out if there are updates that require integration.  This way, a
    -- track integrate can't trigger a block integrate, at least not until the
    -- next call to this function.
    [Text]
track_logs <- forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM forall (m :: * -> *). M m => (BlockId, TrackId) -> m [Text]
score_integrate_tracks forall a b. (a -> b) -> a -> b
$
        [UiUpdate] -> State -> [(BlockId, TrackId)]
needs_track_score_integrate [UiUpdate]
updates State
state
    [Text]
block_logs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). M m => BlockId -> m Text
score_integrate_block forall a b. (a -> b) -> a -> b
$
        [UiUpdate] -> State -> [BlockId]
needs_block_score_integrate [UiUpdate]
updates State
state
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Notice forall a. Maybe a
Nothing) ([Text]
track_logs forall a. [a] -> [a] -> [a]
++ [Text]
block_logs)

score_integrate_block :: Ui.M m => BlockId -> m Text
score_integrate_block :: forall (m :: * -> *). M m => BlockId -> m Text
score_integrate_block BlockId
source_id = do
    Map BlockId Block
blocks <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    let integrated :: [(BlockId, ScoreDestinations)]
integrated = forall {a}. Map a Block -> [(a, ScoreDestinations)]
integrated_from Map BlockId Block
blocks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, ScoreDestinations)]
integrated forall a b. (a -> b) -> a -> b
$ \(BlockId
dest_id, ScoreDestinations
dests) -> do
        ScoreDestinations
dests <- forall (m :: * -> *).
M m =>
BlockId -> BlockId -> ScoreDestinations -> m ScoreDestinations
Merge.score_merge_block BlockId
source_id BlockId
dest_id ScoreDestinations
dests
        forall (m :: * -> *).
M m =>
BlockId -> Maybe (BlockId, TrackDestinations) -> m ()
Ui.set_integrated_block BlockId
dest_id forall a b. (a -> b) -> a -> b
$
            forall a. a -> Maybe a
Just (BlockId
source_id, ScoreDestinations -> TrackDestinations
Block.ScoreDestinations ScoreDestinations
dests)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"score integrated " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
source_id forall a. Semigroup a => a -> a -> a
<> Text
" to: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(BlockId, ScoreDestinations)]
integrated)
    where
    integrated_from :: Map a Block -> [(a, ScoreDestinations)]
integrated_from Map a Block
blocks =
        [ (a
block_id, ScoreDestinations
dests)
        | (a
block_id, Just (BlockId
source_block, Block.ScoreDestinations ScoreDestinations
dests))
            <- forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated) (forall k a. Map k a -> [(k, a)]
Map.toList Map a Block
blocks)
        , BlockId
source_block forall a. Eq a => a -> a -> Bool
== BlockId
source_id
        ]

score_integrate_tracks :: Ui.M m => (BlockId, TrackId) -> m [Text]
score_integrate_tracks :: forall (m :: * -> *). M m => (BlockId, TrackId) -> m [Text]
score_integrate_tracks (BlockId
block_id, TrackId
track_id) = do
    [(TrackId, TrackDestinations)]
itracks <- Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Block
Ui.get_block BlockId
block_id
    let dests :: [ScoreDestinations]
dests =
            [ ScoreDestinations
dests
            | (TrackId
source_id, Block.ScoreDestinations ScoreDestinations
dests) <- [(TrackId, TrackDestinations)]
itracks
            , TrackId
source_id forall a. Eq a => a -> a -> Bool
== TrackId
track_id
            ]
    [ScoreDestinations]
new_dests <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
M m =>
BlockId -> TrackId -> ScoreDestinations -> m ScoreDestinations
Merge.score_merge_tracks BlockId
block_id TrackId
track_id) [ScoreDestinations]
dests
    forall (m :: * -> *).
M m =>
BlockId
-> ([(TrackId, TrackDestinations)]
    -> [(TrackId, TrackDestinations)])
-> m ()
Ui.modify_integrated_tracks BlockId
block_id forall a b. (a -> b) -> a -> b
$ forall key a.
Eq key =>
key -> [(key, a)] -> [(key, a)] -> [(key, a)]
replace TrackId
track_id
        [(TrackId
track_id, ScoreDestinations -> TrackDestinations
Block.ScoreDestinations ScoreDestinations
dests) | ScoreDestinations
dests <- [ScoreDestinations]
new_dests]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {b}. (Pretty a, Pretty a) => [(a, (a, b))] -> Text
msg [ScoreDestinations]
new_dests
    where
    msg :: [(a, (a, b))] -> Text
msg [(a, (a, b))]
dests = Text
"score integrated " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt TrackId
track_id forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
            [ forall a. Pretty a => a -> Text
pretty a
source_id forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
dest_id
            | (a
source_id, (a
dest_id, b
_)) <- [(a, (a, b))]
dests
            ]

replace :: Eq key => key -> [(key, a)] -> [(key, a)] -> [(key, a)]
replace :: forall key a.
Eq key =>
key -> [(key, a)] -> [(key, a)] -> [(key, a)]
replace key
key [(key, a)]
new [(key, a)]
xs = [(key, a)]
new forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=key
key) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(key, a)]
xs

-- | Blocks which are block score integrate sources and have damage.
needs_block_score_integrate :: [Update.UiUpdate] -> Ui.State -> [BlockId]
needs_block_score_integrate :: [UiUpdate] -> State -> [BlockId]
needs_block_score_integrate [UiUpdate]
updates State
state =
    forall a. (a -> Bool) -> [a] -> [a]
filter BlockId -> Bool
has_integrated forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Set BlockId
damaged_blocks forall a b. (a -> b) -> a -> b
$
        State -> Map BlockId Block
Ui.state_blocks State
state
    where
    -- TODO this is a linear search through all blocks
    has_integrated :: BlockId -> Bool
has_integrated BlockId
block_id = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null
        [ ()
        | Just (BlockId
dest_block_id, Block.ScoreDestinations {}) <-
            forall a b. (a -> b) -> [a] -> [b]
map Block -> Maybe (BlockId, TrackDestinations)
Block.block_integrated forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems (State -> Map BlockId Block
Ui.state_blocks State
state)
        , BlockId
block_id forall a. Eq a => a -> a -> Bool
== BlockId
dest_block_id
        ]
    damaged_blocks :: Set BlockId
damaged_blocks = 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 {t} {u}. Update t u -> Maybe BlockId
block_changed [UiUpdate]
updates
    block_changed :: Update t u -> Maybe BlockId
block_changed (Update.Block BlockId
bid Block t
_) = forall a. a -> Maybe a
Just BlockId
bid
    block_changed Update t u
_ = forall a. Maybe a
Nothing

-- | Tracks which are track score integrate sources and have damage.
needs_track_score_integrate :: [Update.UiUpdate] -> Ui.State
    -> [(BlockId, TrackId)]
needs_track_score_integrate :: [UiUpdate] -> State -> [(BlockId, TrackId)]
needs_track_score_integrate [UiUpdate]
updates State
state = forall a. Ord a => [a] -> [a]
Lists.unique forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TrackId -> [(BlockId, TrackId)]
integrated_blocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UiUpdate -> Maybe (TrackId, Ranges ScoreTime)
Update.track_changed [UiUpdate]
updates
    where
    integrated_blocks :: TrackId -> [(BlockId, TrackId)]
integrated_blocks TrackId
track_id =
        [ (BlockId
block_id, TrackId
track_id) | (BlockId
block_id, Block
block) <- TrackId -> [(BlockId, Block)]
blocks_with TrackId
track_id
        , Block -> TrackId -> Bool
has_integrated Block
block TrackId
track_id
        ]
    -- TODO this is a linear search through all blocks, as is
    -- Ui.blocks_with_track_id.
    blocks_with :: TrackId -> [(BlockId, Block)]
blocks_with TrackId
track_id = forall a. (a -> Bool) -> [a] -> [a]
filter (TrackId -> Block -> Bool
has_track TrackId
track_id 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. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
        State -> Map BlockId Block
Ui.state_blocks State
state
    has_track :: TrackId -> Block -> Bool
has_track TrackId
track_id Block
block = TrackId
track_id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Block -> [TrackId]
Block.block_track_ids Block
block
    has_integrated :: Block -> TrackId -> Bool
has_integrated Block
block TrackId
track_id = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null
        [ ()
        | (TrackId
source_track_id, Block.ScoreDestinations {})
            <- Block -> [(TrackId, TrackDestinations)]
Block.block_integrated_tracks Block
block
        , TrackId
track_id forall a. Eq a => a -> a -> Bool
== TrackId
source_track_id
        ]

-- * manual integrate

-- | Find blocks with the source key, and merge the given tracks into them.
--
-- If you are creating a new track, you need to have already done that and put
-- an empty destination in it.  Otherwise, this will find no existing
-- destinations and do nothing.
manual_integrate :: Ui.M m => Block.SourceKey -> Convert.Track -- ^ note track
    -> [Convert.Track] -- ^ dependent control tracks
    -> m ()
manual_integrate :: forall (m :: * -> *). M m => Text -> Track -> [Track] -> m ()
manual_integrate Text
key Track
note [Track]
controls = do
    [(BlockId, [NoteDestination])]
block_dests <- forall a. Text -> [(a, Block)] -> [(a, [NoteDestination])]
manual_destinations Text
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map BlockId Block
Ui.state_blocks
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, [NoteDestination])]
block_dests forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, [NoteDestination]
dests) -> do
        [[NoteDestination]]
new_dests <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NoteDestination]
dests forall a b. (a -> b) -> a -> b
$ \NoteDestination
dest ->
            forall (m :: * -> *).
M m =>
MergeTitles
-> BlockId -> Tracks -> [NoteDestination] -> m [NoteDestination]
Merge.merge_tracks MergeTitles
Merge.KeepTitles BlockId
block_id [(Track
note, [Track]
controls)]
                [NoteDestination
dest]
        forall (m :: * -> *).
M m =>
BlockId -> Text -> Maybe [NoteDestination] -> m ()
Ui.set_integrated_manual BlockId
block_id Text
key (forall a. a -> Maybe a
Just (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NoteDestination]]
new_dests))

-- | Find all manual derive destinations with the given key.
manual_destinations :: Block.SourceKey -> [(a, Block.Block)]
    -> [(a, [Block.NoteDestination])]
manual_destinations :: forall a. Text -> [(a, Block)] -> [(a, [NoteDestination])]
manual_destinations Text
key = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Text
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> ManualDestinations
Block.block_integrated_manual))