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

-- | Repl cmds to deal with events.
module Cmd.Repl.LEvent where
import qualified Data.List as List
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.Regex as Regex
import qualified Util.Texts as Texts

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Edit as Edit
import qualified Cmd.Instrument.Mridangam as Mridangam
import qualified Cmd.ModifyEvents as ModifyEvents
import qualified Cmd.Selection as Selection
import qualified Cmd.TimeStep as TimeStep

import qualified Derive.Expr as Expr
import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Sel as Sel
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui

import           Global
import           Types


get :: Ui.M m => TrackId -> m Events.Events
get :: forall (m :: * -> *). M m => TrackId -> m Events
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Track -> Events
Track.track_events forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Track
Ui.get_track

events :: Ui.M m => TrackId -> m [Event.Event]
events :: forall (m :: * -> *). M m => TrackId -> m [Event]
events = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Events -> [Event]
Events.ascending forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Events
get

stretch :: ScoreTime -> Cmd.CmdL ()
stretch :: TrackTime -> CmdL ()
stretch TrackTime
factor = do
    TrackTime
start <- forall (m :: * -> *). M m => m TrackTime
Selection.start
    forall (m :: * -> *). M m => Track m -> m ()
ModifyEvents.selection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => (Event -> Event) -> Track m
ModifyEvents.event forall a b. (a -> b) -> a -> b
$ TrackTime -> TrackTime -> Event -> Event
stretch_event TrackTime
start TrackTime
factor

stretch_event :: ScoreTime -> ScoreTime -> Event.Event -> Event.Event
stretch_event :: TrackTime -> TrackTime -> Event -> Event
stretch_event TrackTime
start TrackTime
factor Event
event
    | Event -> TrackTime
Event.start Event
event forall a. Ord a => a -> a -> Bool
< TrackTime
start = Event
event
    | Bool
otherwise = Lens Event TrackTime
Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f
%= (\TrackTime
p -> (TrackTime
p forall a. Num a => a -> a -> a
- TrackTime
start) forall a. Num a => a -> a -> a
* TrackTime
factor forall a. Num a => a -> a -> a
+ TrackTime
start) forall a b. (a -> b) -> a -> b
$
        Lens Event TrackTime
Event.duration_ forall f a. Lens f a -> (a -> a) -> f -> f
%= (forall a. Num a => a -> a -> a
*TrackTime
factor) forall a b. (a -> b) -> a -> b
$ Event
event

-- | Stretch events to fit in the given duration.
stretch_to :: TrackTime -> Cmd.CmdL ()
stretch_to :: TrackTime -> CmdL ()
stretch_to TrackTime
dur = do
    SelectedEvents
selected <- forall (m :: * -> *). M m => m SelectedEvents
Selection.events
    TrackTime
start <- forall (m :: * -> *). M m => m TrackTime
Selection.start
    let maybe_end :: Maybe TrackTime
maybe_end = forall a. Ord a => [a] -> Maybe a
Lists.maximum forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> TrackTime
Event.end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) SelectedEvents
selected
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TrackTime
maybe_end forall a b. (a -> b) -> a -> b
$ \TrackTime
end ->
        forall (m :: * -> *). M m => Track m -> m ()
ModifyEvents.selection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => (Event -> Event) -> Track m
ModifyEvents.event forall a b. (a -> b) -> a -> b
$
            TrackTime -> TrackTime -> Event -> Event
stretch_event TrackTime
start (TrackTime
dur forall a. Fractional a => a -> a -> a
/ (TrackTime
end forall a. Num a => a -> a -> a
- TrackTime
start))

-- | Duration of the current selection, e.g. @stretch_to =<< sel_dur@.
sel_dur :: Cmd.M m => m TrackTime
sel_dur :: forall (m :: * -> *). M m => m TrackTime
sel_dur = do
    Selection
sel <- forall (m :: * -> *). M m => m Selection
Selection.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Selection -> TrackTime
Sel.duration Selection
sel

modify_dur :: Cmd.M m => (ScoreTime -> ScoreTime) -> m ()
modify_dur :: forall (m :: * -> *). M m => (TrackTime -> TrackTime) -> m ()
modify_dur = forall (m :: * -> *). M m => (TrackTime -> TrackTime) -> m ()
Edit.modify_dur

-- | Find all events containing the given substring.  Call with 'pp' to get
-- copy-pastable 's' codes.
find :: Text -> Cmd.CmdL [(Ui.Range, Text)]
find :: Text -> CmdL [(Range, Text)]
find Text
substr = (Text -> Bool) -> CmdL [(Range, Text)]
find_f (Text
substr `Text.isInfixOf`)

find_f :: (Text -> Bool) -> Cmd.CmdL [(Ui.Range, Text)]
find_f :: (Text -> Bool) -> CmdL [(Range, Text)]
find_f Text -> Bool
matches = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM forall {t :: * -> *} {m :: * -> *}.
(Traversable t, M m) =>
(BlockId, t TrackId) -> m (t [(Range, Text)])
search forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [(BlockId, [TrackId])]
Ui.all_block_track_ids
    where
    search :: (BlockId, t TrackId) -> m (t [(Range, Text)])
search (BlockId
block_id, t TrackId
track_ids) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t TrackId
track_ids forall a b. (a -> b) -> a -> b
$ \TrackId
track_id -> do
        [Event]
events <- Events -> [Event]
Events.ascending forall b c a. (b -> c) -> (a -> b) -> a -> c
. Track -> Events
Track.track_events
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => TrackId -> m Track
Ui.get_track TrackId
track_id
        let range :: Event -> Range
range Event
e = Maybe BlockId -> TrackId -> TrackTime -> TrackTime -> Range
Ui.Range (forall a. a -> Maybe a
Just BlockId
block_id) TrackId
track_id
                (Event -> TrackTime
Event.start Event
e) (Event -> TrackTime
Event.end Event
e)
        forall (m :: * -> *) a. Monad m => a -> m a
return [(Event -> Range
range Event
event, Event -> Text
Event.text Event
event) |
            Event
event <- [Event]
events, Text -> Bool
matches (Event -> Text
Event.text Event
event)]

-- | Replace text on events.  Call with 'ModifyEvents.all_blocks' to replace it
-- everywhere, or 'ModifyEvents.note_tracks' for just note tracks.
replace :: Monad m => Text -> Text -> ModifyEvents.Track m
replace :: forall (m :: * -> *). Monad m => Text -> Text -> Track m
replace Text
from Text
to = forall (m :: * -> *). Monad m => (Text -> Text) -> Track m
ModifyEvents.text (HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
from Text
to)

replace_exact :: Monad m => Text -> Text -> ModifyEvents.Track m
replace_exact :: forall (m :: * -> *). Monad m => Text -> Text -> Track m
replace_exact Text
from Text
to = forall (m :: * -> *). Monad m => (Text -> Text) -> Track m
ModifyEvents.text forall a b. (a -> b) -> a -> b
$ \Text
t -> if Text
t forall a. Eq a => a -> a -> Bool
== Text
from then Text
to else Text
t

-- | Multiple replacements.  This is simultaneous replacement, so
-- [(a, b), (b, a)] will swap @a@ and @b@ as expected.
replace_many :: Monad m => [(Text, Text)] -> ModifyEvents.Track m
replace_many :: forall (m :: * -> *). Monad m => [(Text, Text)] -> Track m
replace_many = forall (m :: * -> *). Monad m => (Text -> Text) -> Track m
ModifyEvents.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> Text -> Text
Texts.replaceMany

replace_many_exact :: Monad m => [(Text, Text)] -> ModifyEvents.Track m
replace_many_exact :: forall (m :: * -> *). Monad m => [(Text, Text)] -> Track m
replace_many_exact [(Text, Text)]
repl = forall (m :: * -> *). Monad m => (Text -> Text) -> Track m
ModifyEvents.text forall a b. (a -> b) -> a -> b
$ \Text
t -> forall a. a -> Maybe a -> a
fromMaybe Text
t (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Text)]
repl)

-- | Upgrade thoppi on the right to thoppi on the left.  Delete when I don't
-- have any more scores like that.
upgrade_mridangam :: Cmd.M m => m ()
upgrade_mridangam :: forall (m :: * -> *). M m => m ()
upgrade_mridangam = forall (m :: * -> *). M m => Track m -> m ()
ModifyEvents.note_tracks forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => [(Text, Text)] -> Track m
replace_many_exact forall a b. (a -> b) -> a -> b
$
    forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn (String -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
List.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
untxt) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map forall {b} {c}. (Symbol, b, c) -> Text
call_of forall a b. (a -> b) -> a -> b
$
        [Stroke]
-> [Stroke]
-> [(Symbol, [Symbol])]
-> [(Symbol, Char)]
-> [(Symbol, [Symbol], Maybe Char)]
Mridangam.make_both [Stroke]
Mridangam.left_notes [Stroke]
Mridangam.right_notes [] []
    where
    call_of :: (Symbol, b, c) -> Text
call_of (Symbol
c, b
_, c
_) = Symbol -> Text
Expr.unsym Symbol
c

-- | Modify event text with 'ModifyEvents.substitute'.
--
-- For example, to turn \"si .5 .3\" into \".3 | i .5\":
--
-- > ModifyEvents.control_tracks $
-- >    LEvent.replace_pattern ("si"<>w<>w) [F 1, "| i", F 0]
--
-- 'w' is a word, 'ws' is >=0 words, 'ws1' is >=1 words, and a string matches
-- literal text.
replace_pattern :: Cmd.M m => ModifyEvents.Parser
    -> [ModifyEvents.Replacement] -> ModifyEvents.Track m
replace_pattern :: forall (m :: * -> *). M m => Parser -> [Replacement] -> Track m
replace_pattern Parser
from [Replacement]
to =
    forall (m :: * -> *). M m => (Text -> Either Text Text) -> Track m
ModifyEvents.failable_text (Parser -> [Replacement] -> Text -> Either Text Text
ModifyEvents.substitute Parser
from [Replacement]
to)

-- | Modify event text with 'Regex.substituteGroups'.
--
-- For example, to turn \"si .5 .3\" into \".3 | i .5\":
--
-- > ModifyEvents.control_tracks $ LEvent.replace_regex
-- >    "si (\\W+) (\\W+)" (\[f0 f1] -> f1 <> " | i " <> f0)
replace_regex :: Monad m => String -> ([Text] -> Text) -> ModifyEvents.Track m
replace_regex :: forall (m :: * -> *).
Monad m =>
String -> ([Text] -> Text) -> Track m
replace_regex String
regex [Text] -> Text
modify =
    forall (m :: * -> *). Monad m => (Text -> Text) -> Track m
ModifyEvents.text (Regex -> (Text -> [Text] -> Text) -> Text -> Text
Regex.substituteGroups Regex
reg (forall a b. a -> b -> a
const [Text] -> Text
modify))
    where reg :: Regex
reg = HasCallStack => String -> Regex
Regex.compileUnsafe String
regex

-- * quantize

-- | Which end of the event to quantize.
data Mode = Start | End | Both

quantize_sel :: Cmd.M m => Text -> m ()
quantize_sel :: forall (m :: * -> *). M m => Text -> m ()
quantize_sel = forall (m :: * -> *). M m => Track m -> m ()
ModifyEvents.selection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => Mode -> Text -> Track m
quantize_timestep Mode
Both

-- | Quantize to a TimeStep's duration.  What this does is snap the edges of
-- the event to the nearest timestep.
quantize_timestep :: Ui.M m => Mode -> Text -> ModifyEvents.Track m
quantize_timestep :: forall (m :: * -> *). M m => Mode -> Text -> Track m
quantize_timestep Mode
mode Text
step BlockId
block_id TrackId
track_id [Event]
events = do
    TimeStep
step <- forall (m :: * -> *) err a.
(HasCallStack, M m) =>
(err -> Text) -> Either err a -> m a
Ui.require_right (Text
"parsing timestep: "<>) forall a b. (a -> b) -> a -> b
$
        Text -> Either Text TimeStep
TimeStep.parse_time_step Text
step
    TrackNum
tracknum <- forall (m :: * -> *). M m => BlockId -> TrackId -> m TrackNum
Ui.get_tracknum_of BlockId
block_id TrackId
track_id
    [TrackTime]
points <- forall (m :: * -> *).
M m =>
Direction
-> BlockId -> TrackNum -> TrackTime -> TimeStep -> m [TrackTime]
TimeStep.get_points_from Direction
TimeStep.Advance BlockId
block_id TrackNum
tracknum TrackTime
0 TimeStep
step
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [TrackTime] -> [Event] -> [Event]
resolve_conflicts [TrackTime]
points forall a b. (a -> b) -> a -> b
$
        forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL (Mode -> [TrackTime] -> Event -> ([TrackTime], Event)
quantize_event Mode
mode) [TrackTime]
points [Event]
events

-- | Quantize can put two events in the same spot.  Resolve the conflicts by
-- bumping events back until they don't conflict.  If I run out of timesteps,
-- bump by 1.
resolve_conflicts :: [TrackTime] -> [Event.Event] -> [Event.Event]
resolve_conflicts :: [TrackTime] -> [Event] -> [Event]
resolve_conflicts [TrackTime]
_ [] = []
resolve_conflicts [TrackTime]
points (Event
event : [Event]
events) =
    Event
event forall a. a -> [a] -> [a]
: [TrackTime] -> [Event] -> [Event]
resolve_conflicts [TrackTime]
points_after
        (forall a b. (a -> b) -> [a] -> [b]
map (Lens Event TrackTime
Event.start_ forall f a. Lens f a -> a -> f -> f
#= TrackTime
bump) [Event]
group forall a. [a] -> [a] -> [a]
++ [Event]
rest)
    where
    ([Event]
group, [Event]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Eq a => a -> a -> Bool
== Event -> TrackTime
Event.start Event
event) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> TrackTime
Event.start) [Event]
events
    bump :: TrackTime
bump = forall a. a -> Maybe a -> a
fromMaybe (Event -> TrackTime
Event.start Event
event forall a. Num a => a -> a -> a
+ TrackTime
1) (forall a. [a] -> Maybe a
Lists.head [TrackTime]
points_after)
    points_after :: [TrackTime]
points_after = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
<= Event -> TrackTime
Event.start Event
event) [TrackTime]
points

-- | Zero-duration events will remain zero duration, and not be affected by
-- End quantization.  Non-zero-duration events will never be quantized to zero
-- duration.
quantize_event :: Mode -> [TrackTime] -> Event.Event
    -> ([TrackTime], Event.Event)
quantize_event :: Mode -> [TrackTime] -> Event -> ([TrackTime], Event)
quantize_event Mode
mode [TrackTime]
points_ Event
event = ([TrackTime]
start_points, Event -> Event
quantize_event Event
event)
    where
    quantize_event :: Event -> Event
quantize_event = case Mode
mode of
        Mode
Start -> Event -> Event
quantize_start
        Mode
End
            | Bool
zero -> forall a. a -> a
id
            | Bool
otherwise -> Event -> Event
quantize_end
        Mode
Both
            | Bool
zero -> Event -> Event
quantize_start
            | Bool
otherwise -> Event -> Event
quantize_end forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Event
quantize_start
    quantize_start :: Event -> Event
quantize_start = Lens Event TrackTime
Event.start_ forall f a. Lens f a -> (a -> a) -> f -> f
%= [TrackTime] -> TrackTime -> TrackTime
quantize [TrackTime]
start_points
    quantize_end :: Event -> Event
quantize_end Event
event = Lens Event TrackTime
Event.end_ forall f a. Lens f a -> (a -> a) -> f -> f
%= [TrackTime] -> TrackTime -> TrackTime
quantize (Event -> [TrackTime]
end_points Event
event) forall a b. (a -> b) -> a -> b
$ Event
event
    zero :: Bool
zero = Event -> TrackTime
Event.duration Event
event forall a. Eq a => a -> a -> Bool
== TrackTime
0
    start_points :: [TrackTime]
start_points = forall key a. Ord key => (a -> key) -> key -> [a] -> [a]
Lists.dropBefore forall a. a -> a
id (Event -> TrackTime
Event.start Event
event) [TrackTime]
points_
    end_points :: Event -> [TrackTime]
end_points Event
e = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
<= Event -> TrackTime
Event.start Event
e) forall a b. (a -> b) -> a -> b
$
        forall key a. Ord key => (a -> key) -> key -> [a] -> [a]
Lists.dropBefore forall a. a -> a
id (Event -> TrackTime
Event.end Event
e) [TrackTime]
start_points

quantize :: [TrackTime] -> TrackTime -> TrackTime
quantize :: [TrackTime] -> TrackTime -> TrackTime
quantize [TrackTime]
points TrackTime
t = case [TrackTime]
points of
    TrackTime
t1 : TrackTime
t2 : [TrackTime]
_
        | forall a. Num a => a -> a
abs (TrackTime
t forall a. Num a => a -> a -> a
- TrackTime
t1) forall a. Ord a => a -> a -> Bool
<= forall a. Num a => a -> a
abs (TrackTime
t2 forall a. Num a => a -> a -> a
- TrackTime
t) -> TrackTime
t1
        | Bool
otherwise -> TrackTime
t2
    [TrackTime
t1] -> TrackTime
t1
    [] -> TrackTime
t

-- * insert

-- | Insert an event directly.
insert :: Cmd.M m => [(ScoreTime, ScoreTime, Text)] -> m ()
insert :: forall (m :: * -> *). M m => [(TrackTime, TrackTime, Text)] -> m ()
insert [(TrackTime, TrackTime, Text)]
events = do
    (BlockId
_, TrackNum
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, TrackNum, TrackId, TrackTime)
Selection.get_insert
    forall (m :: * -> *). M m => TrackId -> [Event] -> m ()
Ui.insert_events TrackId
track_id
        [TrackTime -> TrackTime -> Text -> Event
Event.event (TrackTime
start forall a. Num a => a -> a -> a
+ TrackTime
pos) TrackTime
dur Text
text | (TrackTime
start, TrackTime
dur, Text
text) <- [(TrackTime, TrackTime, Text)]
events]