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

-- | Utilities that use "Cmd.ModifyNotes" to do higher-level transformations.
module Cmd.Repl.LNote where
import qualified Data.List as List
import qualified Data.Map as Map

import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Cmd.Cmd as Cmd
import qualified Cmd.ModifyNotes as ModifyNotes
import qualified Cmd.Selection as Selection

import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Perform.Pitch as Pitch

import           Global
import           Types


-- * query

notes :: Cmd.CmdL [(ModifyNotes.Note, TrackId)]
notes :: CmdL [(Note, TrackId)]
notes = forall (m :: * -> *). M m => m [(Note, TrackId)]
ModifyNotes.selected_notes

note_controls :: Cmd.CmdL
    [(ModifyNotes.Note, (Maybe PSignal.Transposed, ScoreT.ControlValMap))]
note_controls :: CmdL [(Note, (Maybe Transposed, ControlValMap))]
note_controls = do
    BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
    Vector Event
events <- Performance -> Vector Event
Cmd.perf_events forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> m Performance
Cmd.get_performance BlockId
block_id
    [(Note, TrackId)]
note_track_ids <- CmdL [(Note, TrackId)]
notes
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Note, TrackId)]
-> Vector Event -> [(Note, (Maybe Transposed, ControlValMap))]
ModifyNotes.find_controls [(Note, TrackId)]
note_track_ids Vector Event
events

-- * modify

-- | Merge the selected note tracks into one.
merge :: Cmd.CmdL ()
merge :: CmdL ()
merge = forall (m :: * -> *). M m => ModifyNotes m -> m ()
ModifyNotes.selection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => (Note -> Note) -> ModifyNotes m
ModifyNotes.note forall a b. (a -> b) -> a -> b
$ Note :-> Int
ModifyNotes.index forall f a. Lens f a -> a -> f -> f
#= Int
0

-- | Distribute the notes among the given number of tracks, round-robin.  Since
-- only each note only carries over the controls in its extent, if there are
-- notes that rely on control values carried forward, the values will be
-- different in the new tracks.
distribute_n :: Int -> Cmd.CmdL ()
distribute_n :: Int -> CmdL ()
distribute_n Int
tracks = forall (m :: * -> *). M m => ModifyNotes m -> m ()
ModifyNotes.selection forall a b. (a -> b) -> a -> b
$ \BlockId
_ [(Note, TrackId)]
notes -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> Note -> Note
modify Int
tracks) [Int
0..] (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Note, TrackId)]
notes)
    where
    modify :: Int -> Int -> Note -> Note
modify Int
tracks Int
n = Note :-> Int
ModifyNotes.index forall f a. Lens f a -> a -> f -> f
#= Int
n forall a. Integral a => a -> a -> a
`mod` Int
tracks

-- | Like 'distribute_n', but use only the selected tracks.
distribute :: Cmd.CmdL ()
distribute :: CmdL ()
distribute = do
    (BlockId
block_id, [Int]
_, [TrackId]
track_ids, Range
_) <- forall (m :: * -> *). M m => m (BlockId, [Int], [TrackId], Range)
Selection.tracks
    Int
tracks <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => BlockId -> [TrackId] -> m TrackTree
ModifyNotes.extract_note_trees BlockId
block_id [TrackId]
track_ids
    Int -> CmdL ()
distribute_n Int
tracks

-- | Try to compact non-overlapping notes to use the least number of tracks
-- possible.
compact :: Cmd.CmdL ()
compact :: CmdL ()
compact =
    forall (m :: * -> *). M m => ModifyNotes m -> m ()
ModifyNotes.selection forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL [ScoreTime] -> Note -> ([ScoreTime], Note)
allocate [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst
    where
    allocate :: [ScoreTime] -> Note -> ([ScoreTime], Note)
allocate [ScoreTime]
state Note
note = ([ScoreTime]
next, Note :-> Int
ModifyNotes.index forall f a. Lens f a -> a -> f -> f
#= Int
i forall a b. (a -> b) -> a -> b
$ Note
note)
        where
        (Int
i, [ScoreTime]
next) = ScoreTime -> ScoreTime -> [ScoreTime] -> (Int, [ScoreTime])
find_index (Note -> ScoreTime
ModifyNotes.note_start Note
note)
            (Note -> ScoreTime
ModifyNotes.note_end Note
note) [ScoreTime]
state

-- | Find the lowest index that a note will fit.  Search the list of end times
-- for one at or before the given start, and return that index and update the
-- list with the new end.
find_index :: ScoreTime -> ScoreTime -> [ScoreTime] -> (Int, [ScoreTime])
find_index :: ScoreTime -> ScoreTime -> [ScoreTime] -> (Int, [ScoreTime])
find_index ScoreTime
start ScoreTime
end = forall {t}. Num t => t -> [ScoreTime] -> (t, [ScoreTime])
go Int
0
    where
    go :: t -> [ScoreTime] -> (t, [ScoreTime])
go t
i [] = (t
i, [ScoreTime
end])
    go t
i (ScoreTime
t:[ScoreTime]
ts)
        | ScoreTime
t forall a. Ord a => a -> a -> Bool
<= ScoreTime
start = (t
i, ScoreTime
end forall a. a -> [a] -> [a]
: [ScoreTime]
ts)
        | Bool
otherwise = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ScoreTime
t:) forall a b. (a -> b) -> a -> b
$ t -> [ScoreTime] -> (t, [ScoreTime])
go (t
iforall a. Num a => a -> a -> a
+t
1) [ScoreTime]
ts

-- | If it's above the nn, compact starting at the high_index, otherwise
-- compact starting at index 0.
--
-- For example, to split on middle C, assuming only dyads in the left hand:
--
-- > LNote.split_on_pitch 2 NN.c4
split_on_pitch :: ModifyNotes.Index -> Pitch.NoteNumber -> Cmd.CmdL ()
split_on_pitch :: Int -> NoteNumber -> CmdL ()
split_on_pitch Int
high_index NoteNumber
break_nn =
    forall (m :: * -> *). M m => ModifyNotes m -> m ()
ModifyNotes.selection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
M m =>
Annotated (Maybe NoteNumber) m -> ModifyNotes m
ModifyNotes.annotate_nns forall a b. (a -> b) -> a -> b
$ \[(Note, Maybe NoteNumber)]
notes ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Note, Maybe NoteNumber)] -> [Note]
split [(Note, Maybe NoteNumber)]
notes
    where
    split :: [(Note, Maybe NoteNumber)] -> [Note]
split = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL ([ScoreTime], [ScoreTime])
-> (Note, Maybe NoteNumber) -> (([ScoreTime], [ScoreTime]), Note)
allocate ([], [])
    allocate :: ([ScoreTime], [ScoreTime])
-> (Note, Maybe NoteNumber) -> (([ScoreTime], [ScoreTime]), Note)
allocate ([ScoreTime]
low_alloc, [ScoreTime]
high_alloc) (Note
note, Maybe NoteNumber
maybe_nn)
        | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
<=NoteNumber
break_nn) Maybe NoteNumber
maybe_nn =
            let (Int
i, [ScoreTime]
next) = [ScoreTime] -> (Int, [ScoreTime])
find [ScoreTime]
low_alloc
            in (([ScoreTime]
next, [ScoreTime]
high_alloc), Note :-> Int
ModifyNotes.index forall f a. Lens f a -> a -> f -> f
#= Int
i forall a b. (a -> b) -> a -> b
$ Note
note)
        | Bool
otherwise =
            let (Int
i, [ScoreTime]
next) = [ScoreTime] -> (Int, [ScoreTime])
find [ScoreTime]
high_alloc
            in (([ScoreTime]
low_alloc, [ScoreTime]
next), Note :-> Int
ModifyNotes.index forall f a. Lens f a -> a -> f -> f
#= (Int
high_index forall a. Num a => a -> a -> a
+ Int
i) forall a b. (a -> b) -> a -> b
$ Note
note)
        where
        find :: [ScoreTime] -> (Int, [ScoreTime])
find = ScoreTime -> ScoreTime -> [ScoreTime] -> (Int, [ScoreTime])
find_index (Note -> ScoreTime
ModifyNotes.note_start Note
note)
            (Note -> ScoreTime
ModifyNotes.note_end Note
note)

-- | Sort by pitch and compact.
sort_on_pitch :: Cmd.M m => Bool -> m ()
sort_on_pitch :: forall (m :: * -> *). M m => Bool -> m ()
sort_on_pitch Bool
high_left = forall (m :: * -> *). M m => ModifyNotes m -> m ()
ModifyNotes.selection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
M m =>
Annotated (Maybe NoteNumber) m -> ModifyNotes m
ModifyNotes.annotate_nns forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. State a -> [Note]
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' State (Maybe NoteNumber)
-> (Note, Maybe NoteNumber) -> State (Maybe NoteNumber)
insert forall a. Monoid a => a
mempty
    where
    insert :: State (Maybe NoteNumber)
-> (Note, Maybe NoteNumber) -> State (Maybe NoteNumber)
insert State (Maybe NoteNumber)
state (Note, Maybe NoteNumber)
note =
        forall a.
((Note, a) -> (Note, a) -> Bool) -> (Note, a) -> State a -> State a
insert_ordered (\(Note, Maybe NoteNumber)
n1 (Note, Maybe NoteNumber)
n2 -> Maybe NoteNumber -> Maybe NoteNumber -> Bool
cmp (forall a b. (a, b) -> b
snd (Note, Maybe NoteNumber)
n1) (forall a b. (a, b) -> b
snd (Note, Maybe NoteNumber)
n2)) (Note, Maybe NoteNumber)
note State (Maybe NoteNumber)
state
    cmp :: Maybe NoteNumber -> Maybe NoteNumber -> Bool
cmp = if Bool
high_left then forall a. Ord a => a -> a -> Bool
(<) else forall a. Ord a => a -> a -> Bool
(>)

-- | Find the last index with an overlapping note that isn't place_before,
-- and put the note on index+1.  If it it overlaps, make a space by bumping
-- tracks up by one.
insert_ordered :: ((ModifyNotes.Note, a) -> (ModifyNotes.Note, a) -> Bool)
    -> (ModifyNotes.Note, a) -> State a -> State a
insert_ordered :: forall a.
((Note, a) -> (Note, a) -> Bool) -> (Note, a) -> State a -> State a
insert_ordered (Note, a) -> (Note, a) -> Bool
place_before (Note, a)
note State a
state = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
index State a
state of
    Just ((Note, a)
n : [(Note, a)]
_) | forall {b} {b}. (Note, b) -> (Note, b) -> Bool
overlap (Note, a)
note (Note, a)
n ->
        forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
index [(Note, a)
note] forall a b. (a -> b) -> a -> b
$ forall a. Int -> Map Int a -> Map Int a
bump_index Int
index State a
state
    Maybe [(Note, a)]
_ -> forall k a. Ord k => k -> a -> Map k [a] -> Map k [a]
insert_cons Int
index (Note, a)
note State a
state
    where
    index :: Int
index = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ((forall a. Num a => a -> a -> a
+Int
1) 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. [a] -> Maybe a
Lists.last forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Note, a) -> (Note, a) -> Bool
place_before (Note, a)
note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, (Note, a))]
overlapping
    overlapping :: [(Int, (Note, a))]
overlapping = [(Int
i, (Note, a)
n) | (Int
i, (Note, a)
n : [(Note, a)]
_) <- forall k a. Map k a -> [(k, a)]
Map.toAscList State a
state, forall {b} {b}. (Note, b) -> (Note, b) -> Bool
overlap (Note, a)
note (Note, a)
n]
    overlap :: (Note, b) -> (Note, b) -> Bool
overlap (Note, b)
n1 (Note, b)
n2 = Note -> Note -> Bool
ModifyNotes.notes_overlap (forall a b. (a, b) -> a
fst (Note, b)
n1) (forall a b. (a, b) -> a
fst (Note, b)
n2)

bump_index :: Int -> Map Int a -> Map Int a
bump_index :: forall a. Int -> Map Int a -> Map Int a
bump_index Int
index Map Int a
m =
    Map Int a
pre forall a. Semigroup a => a -> a -> a
<> forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Num a => a -> a -> a
+Int
1)) (forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int a
post))
    where (Map Int a
pre, Map Int a
post) = forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Maps.split2 Int
index Map Int a
m

extract :: State a -> [ModifyNotes.Note]
extract :: forall a. State a -> [Note]
extract State a
state = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    [ forall a b. (a -> b) -> [a] -> [b]
map ((Note :-> Int
ModifyNotes.index forall f a. Lens f a -> a -> f -> f
#= Int
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall a. [a] -> [a]
reverse [(Note, a)]
notes)
    | (Int
i, [(Note, a)]
notes) <- forall k a. Map k a -> [(k, a)]
Map.toAscList State a
state
    ]

-- | From track index to notes in reverse order.
type State annot = Map ModifyNotes.Index [(ModifyNotes.Note, annot)]

insert_cons :: Ord k => k -> a -> Map k [a] -> Map k [a]
insert_cons :: forall k a. Ord k => k -> a -> Map k [a] -> Map k [a]
insert_cons k
k a
a = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a
a] (a
a:)) k
k