-- Copyright 2017 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 Cmd.Ruler.Extract (pull_up, push_down, push_down_recursive) where
import qualified Data.List.NonEmpty as NonEmpty

import qualified Util.Lists as Lists
import qualified Cmd.NoteTrackParse as NoteTrackParse
import qualified Cmd.Ruler.RulerUtil as RulerUtil
import qualified Derive.ParseTitle as ParseTitle
import qualified Ui.Event as Event
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Ui as Ui

import           Global
import           Types


-- * pull_up

-- | Extract the meter marklists from the sub-blocks called on the given
-- track and concatenate them.
pull_up :: Ui.M m => BlockId -> TrackId -> m Meter.Meter
pull_up :: forall (m :: * -> *). M m => BlockId -> TrackId -> m Meter
pull_up BlockId
block_id TrackId
track_id = do
    [(Event, BlockId)]
subs <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m [(Event, BlockId)]
block_calls BlockId
block_id TrackId
track_id
    [Meter]
meters <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). M m => RulerId -> m Meter
RulerUtil.get_meter forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *). M m => BlockId -> m RulerId
Ui.ruler_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Event, BlockId)]
subs
    -- TODO previously I would scale the meters by the size of the event,
    -- but if I assume calls are 1:1 then this isn't necessary
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Meter]
meters

block_calls :: Ui.M m => BlockId -> TrackId -> m [(Event.Event, BlockId)]
block_calls :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m [(Event, BlockId)]
block_calls BlockId
block_id TrackId
track_id = 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 a. NonEmpty a -> a
NonEmpty.head) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackId -> m [(Event, NonEmpty BlockId)]
NoteTrackParse.track_block_calls Bool
False BlockId
block_id TrackId
track_id


-- * push_down

-- | The inverse of 'pull_up': find callee blocks, and copy the ruler from the
-- given block to them.  This sets the 'Ruler.config_start_measure'
-- appropriately, so subsequent modifications should keep the measure numbers.
--
-- If a block is called more than once, it will get the measure number from the
-- first occurrence.
--
-- Since this has to modify multiple blocks, it does the modification itself
-- instead of returning the new meter like 'pull_up'.
push_down :: Ui.M m => Bool
    -- ^ Whether or not it's an error if there are block calls which are not
    -- 1:1.  I can't tell if that's an error or not, but the user should know
    -- if it's supposed to be a \"score\" block.
    --
    -- TODO Optionally I could scale the ruler for non-1:1 callees.
     -> BlockId -> TrackId -> m [BlockId] -- ^ modified children
push_down :: forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackId -> m [BlockId]
push_down Bool
not_1to1_ok BlockId
block_id TrackId
track_id = do
    ([(BlockId, Meter)]
subs, [BlockId]
not_1to1) <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m ([(BlockId, Meter)], [BlockId])
sub_meters BlockId
block_id TrackId
track_id
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
not_1to1_ok Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
not_1to1) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"block calls not 1:1: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [BlockId]
not_1to1
    let sub_blocks :: [(BlockId, Meter)]
sub_blocks = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a b. (a, b) -> a
fst [(BlockId, Meter)]
subs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(BlockId, Meter)]
sub_blocks forall a b. (a -> b) -> a -> b
$ \(BlockId
block_id, Meter
meter) ->
        forall (m :: * -> *).
M m =>
Scope -> BlockId -> (Meter -> Meter) -> m [RulerId]
RulerUtil.local_meter Scope
RulerUtil.Block BlockId
block_id (forall a b. a -> b -> a
const Meter
meter)
    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 b. (a, b) -> a
fst [(BlockId, Meter)]
sub_blocks

push_down_recursive :: Ui.M m => Bool -> BlockId -> TrackId -> m ()
push_down_recursive :: forall (m :: * -> *). M m => Bool -> BlockId -> TrackId -> m ()
push_down_recursive Bool
not_1to1_ok BlockId
block_id TrackId
track_id = do
    [BlockId]
children <- forall (m :: * -> *).
M m =>
Bool -> BlockId -> TrackId -> m [BlockId]
push_down Bool
not_1to1_ok BlockId
block_id TrackId
track_id
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BlockId]
children forall a b. (a -> b) -> a -> b
$ \BlockId
child_block -> do
        [TrackId]
track_ids <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM TrackId -> m Bool
is_note forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m [TrackId]
Ui.track_ids_of BlockId
child_block
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => Bool -> BlockId -> TrackId -> m ()
push_down_recursive Bool
not_1to1_ok BlockId
child_block) [TrackId]
track_ids
    where
    is_note :: TrackId -> m Bool
is_note = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Bool
ParseTitle.is_note_track forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title

sub_meters :: Ui.M m => BlockId -> TrackId
    -> m ([(BlockId, Meter.Meter)], [BlockId])
sub_meters :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m ([(BlockId, Meter)], [BlockId])
sub_meters BlockId
block_id TrackId
track_id = do
    [(Event, BlockId)]
subs <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m [(Event, BlockId)]
block_calls BlockId
block_id TrackId
track_id
    ([(Event, BlockId)]
subs, [(Event, BlockId)]
not_1to1) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM
        (\(Event
event, BlockId
callee) -> forall (m :: * -> *). M m => TrackTime -> BlockId -> m Bool
is_1to1 (Event -> TrackTime
Event.duration Event
event) BlockId
callee)
        [(Event, BlockId)]
subs
    [(BlockId, Meter)]
subs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Event, BlockId)]
subs forall a b. (a -> b) -> a -> b
$ \(Event
event, BlockId
sub_block) -> do
        Meter
meter <- forall (m :: * -> *).
M m =>
BlockId -> TrackTime -> TrackTime -> m Meter
extract_meter BlockId
block_id (Event -> TrackTime
Event.start Event
event) (Event -> TrackTime
Event.end Event
event)
        forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
sub_block, Meter
meter)
    forall (m :: * -> *) a. Monad m => a -> m a
return ([(BlockId, Meter)]
subs, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Event, BlockId)]
not_1to1)

extract_meter :: Ui.M m => BlockId -> TrackTime -> TrackTime -> m Meter.Meter
extract_meter :: forall (m :: * -> *).
M m =>
BlockId -> TrackTime -> TrackTime -> m Meter
extract_meter BlockId
block_id TrackTime
start TrackTime
end = do
    Meter
meter <- forall (m :: * -> *). M m => RulerId -> m Meter
RulerUtil.get_meter forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m RulerId
Ui.ruler_of BlockId
block_id
    -- TODO previously I would set config_start_measure to attempt to make the
    -- sub-meter start at an appropriate count, but now I won't bother unless I
    -- need it.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([MSection] -> [MSection]) -> Meter -> Meter
Meter.modify_sections (TrackTime -> TrackTime -> [MSection] -> [MSection]
RulerUtil.extract TrackTime
start TrackTime
end) Meter
meter

is_1to1 :: Ui.M m => TrackTime -> BlockId -> m Bool
is_1to1 :: forall (m :: * -> *). M m => TrackTime -> BlockId -> m Bool
is_1to1 TrackTime
dur BlockId
block_id = (forall a. Eq a => a -> a -> Bool
==TrackTime
dur) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_end BlockId
block_id