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

-- | Postprocs that change note start and duration.
module Derive.C.Post.Postproc (
    library
    , Key
    , make_cancel
    , adjust_offset
    , cancel_strong_weak
    , group_and_cancel
    , infer_duration_merged
) where
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe

import qualified Util.Lists as Lists
import qualified Util.Test.ApproxEq as ApproxEq
import qualified Derive.C.Prelude.ControlFunction as ControlFunction
import qualified Derive.C.Prelude.Equal as Equal
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.StaticMacro as StaticMacro
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Flags as Flags
import qualified Derive.LEvent as LEvent
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream

import qualified Perform.RealTime as RealTime

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
    [ (Symbol
"apply-start-offset", Transformer Note
c_apply_start_offset)
    , (Symbol
"cancel", Transformer Note
c_cancel)
    , (Symbol
"infer-negative", Transformer Note
c_infer_negative)
    , (Symbol
"randomize-start", Transformer Note
c_randomize_start)
    , (Symbol
"strong", Module -> CallName -> Doc -> Flags -> Transformer Note
Make.add_flag Module
module_ CallName
"strong"
        Doc
"Add the 'Derive.Flags.strong' flag, which will cancel coincident\
            \ non-strong notes."
        Flags
Flags.strong)
    , (Symbol
"weak", Module -> CallName -> Doc -> Flags -> Transformer Note
Make.add_flag Module
module_ CallName
"weak"
        Doc
"Add the 'Derive.Flags.weak' flag, which will cause this to be\
            \ cancelled by coincident non-weak notes."
        Flags
Flags.weak)
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
Module.prelude

-- * infer-negative

c_infer_negative :: Derive.Transformer Derive.Note
c_infer_negative :: Transformer Note
c_infer_negative = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"infer-negative" Tags
Tags.postproc
    Doc
"Infer durations for negative events, by instrument."
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"heuristic" (Text
"note" :: Text) Doc
"doc"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RealTime
final_duration_arg
    ) forall a b. (a -> b) -> a -> b
$ \(Text
heuristic, RealTime
final_dur) PassedArgs Note
_args Deriver (Stream Note)
deriver -> do
        RealTime -> Stream Note -> Stream Note
process <- forall a. Stack => Text -> Maybe a -> Deriver a
Derive.require (Text
"invalid heuristic: " forall a. Semigroup a => a -> a -> a
<> Text
heuristic) forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text
heuristic :: Text) Map Text (RealTime -> Stream Note -> Stream Note)
infer_heuristics
        RealTime -> Stream Note -> Stream Note
process RealTime
final_dur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver
    where
    infer_heuristics :: Map Text (RealTime -> Stream Note -> Stream Note)
infer_heuristics = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"hand", RealTime -> Stream Note -> Stream Note
next_hand)
        , (Text
"note", RealTime -> Stream Note -> Stream Note
next_note)
        ]

-- | Until the next note with the same hand.  Suitable for gender barung.
-- If the next event doesn't touch this one, stop at its (negative) start time.
-- This is a bit weird conceptually but in practice seems to be useful for
-- controlling duration.
next_hand :: RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event
next_hand :: RealTime -> Stream Note -> Stream Note
next_hand = forall key.
Eq key =>
Key key
-> (RealTime -> [Note] -> Maybe RealTime)
-> RealTime
-> Stream Note
-> Stream Note
infer_duration Note -> (Instrument, Maybe Text)
Post.hand_key forall a b. (a -> b) -> a -> b
$ \RealTime
here [Note]
nexts ->
    forall a. Num a => a -> a -> a
subtract RealTime
here forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Note -> RealTime
until RealTime
here forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
Lists.head [Note]
nexts
    where
    until :: RealTime -> Note -> RealTime
until RealTime
here Note
next
        | Note -> RealTime
Score.event_min Note
next forall a. Ord a => a -> a -> Bool
>= RealTime
here forall a. Num a => a -> a -> a
+ RealTime
threshold = Note -> RealTime
Score.event_min Note
next
        | Bool
otherwise = Note -> RealTime
Score.event_max Note
next
    threshold :: RealTime
threshold = RealTime
0.05

-- | Until the next note with the same instrument.  Suitable for gender
-- panerus.
next_note :: RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event
next_note :: RealTime -> Stream Note -> Stream Note
next_note = forall key.
Eq key =>
Key key
-> (RealTime -> [Note] -> Maybe RealTime)
-> RealTime
-> Stream Note
-> Stream Note
infer_duration Note -> Instrument
Score.event_instrument forall a b. (a -> b) -> a -> b
$ \RealTime
here [Note]
nexts ->
    forall a. Num a => a -> a -> a
subtract RealTime
here forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. [a] -> Maybe a
Lists.head (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\Note
n -> Note -> RealTime
start Note
n forall a. Num a => a -> a -> a
- RealTime
here forall a. Ord a => a -> a -> Bool
< RealTime
threshold) [Note]
nexts)
    where
    threshold :: RealTime
threshold = RealTime
0.15
    start :: Note -> RealTime
start = Note -> RealTime
Score.event_start

infer_duration :: Eq key => Key key
    -> (RealTime -> [Score.Event] -> Maybe RealTime)
    -> RealTime
    -> Stream.Stream Score.Event
    -> Stream.Stream Score.Event
infer_duration :: forall key.
Eq key =>
Key key
-> (RealTime -> [Note] -> Maybe RealTime)
-> RealTime
-> Stream Note
-> Stream Note
infer_duration Key key
next_key RealTime -> [Note] -> Maybe RealTime
infer RealTime
final_dur =
    forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Note, [Note]) -> Note
infer1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, [a])
Post.nexts_by Key key
next_key
    where
    infer1 :: (Note, [Note]) -> Note
infer1 (Note
event, [Note]
nexts)
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
nexts = RealTime -> Note -> Note
Score.set_duration RealTime
final_dur Note
event
        | Note -> RealTime
Score.event_duration Note
event forall a. Ord a => a -> a -> Bool
>= RealTime
0 = Note
event
        | Bool
otherwise = case RealTime -> [Note] -> Maybe RealTime
infer (Note -> RealTime
Score.event_start Note
event) [Note]
nexts of
            Maybe RealTime
Nothing -> RealTime -> Note -> Note
Score.set_duration RealTime
final_dur Note
event
            Just RealTime
dur -> RealTime -> Note -> Note
Score.set_duration RealTime
dur Note
event

-- * cancel

c_cancel :: Derive.Transformer Derive.Note
c_cancel :: Transformer Note
c_cancel = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"cancel" Tags
Tags.postproc
    Doc
"Process the 'Derive.Flags.strong' and 'Derive.Flags.weak' flags.\
    \ This will cause notes to be dropped."
    forall a b. (a -> b) -> a -> b
$ forall key.
Ord key =>
Cancel -> Key key -> WithArgDoc (Transformer Note (Stream Note))
make_cancel ((Note -> [Note] -> Note) -> Cancel
cancel_strong_weak Note -> [Note] -> Note
infer_duration_merged) Note -> (Instrument, Maybe Text)
Post.hand_key

-- | Given a set of coincident notes, return either an error, or merge them
-- into a set of output notes.
type Cancel = [Score.Event] -> Either Text [Score.Event]

-- | The key identifies another event which is in the same voice.  This could
-- be 'Post.hand_key', but it could also match polos to sangsih, since they
-- form a composite part.
type Key key = Score.Event -> key

make_cancel :: Ord key => Cancel -> Key key
    -> Derive.WithArgDoc (Derive.TransformerF Derive.Note)
make_cancel :: forall key.
Ord key =>
Cancel -> Key key -> WithArgDoc (Transformer Note (Stream Note))
make_cancel Cancel
cancel Key key
key =
    forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser RealTime
final_duration_arg forall a b. (a -> b) -> a -> b
$ \RealTime
final_dur PassedArgs Note
_args Deriver (Stream Note)
deriver ->
        forall err a. Stack => (err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key.
Ord key =>
Cancel
-> Key key -> RealTime -> Stream Note -> Either Text (Stream Note)
group_and_cancel Cancel
cancel Key key
key RealTime
final_dur
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Stream Note)
deriver

final_duration_arg :: Sig.Parser RealTime
final_duration_arg :: Parser RealTime
final_duration_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"final-duration" EnvironDefault
Sig.Unprefixed
    (RealTime
1 :: RealTime) Doc
"If there is no following note, infer this duration."

group_and_cancel :: Ord key => Cancel -> Key key -> RealTime
    -> Events -> Either Text Events
group_and_cancel :: forall key.
Ord key =>
Cancel
-> Key key -> RealTime -> Stream Note -> Either Text (Stream Note)
group_and_cancel Cancel
cancel Key key
key RealTime
final_dur =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall key.
Eq key =>
Key key -> RealTime -> Stream Note -> Stream Note
infer_duration_single Key key
key RealTime
final_dur forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Note -> Stream Note
suppress_notes)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
([a] -> Either Text [a])
-> [Either [LEvent a] [a]] -> Either Text (Stream a)
merge_groups Cancel
cancel forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key.
Ord key =>
(Note -> key) -> Stream Note -> [Either [LEvent Note] [Note]]
group_coincident Key key
key

-- | Merge notes with 'Flags.strong' and 'Flags.weak'.  The rules are that
-- strong notes merge with weaker ones, in the order strong, normal, weak.
--
-- Previously I considered multiple weaks or strongs ambiguous, but it turns
-- out I get multiple strongs with two hand strokes at the end of a block,
-- and I might as well allow the rest too, for simplicity.
cancel_strong_weak :: (Score.Event -> [Score.Event] -> Score.Event)
    -> [Score.Event] -> Either Text [Score.Event]
cancel_strong_weak :: (Note -> [Note] -> Note) -> Cancel
cancel_strong_weak Note -> [Note] -> Note
merge [Note]
events = case [Note] -> ([Note], [Note], [Note])
partition [Note]
events of
    (strongs :: [Note]
strongs@(Note
_:[Note]
_), [Note]
weaks, [Note]
normals) ->
        forall a b. b -> Either a b
Right [Note -> [Note] -> Note
merge Note
strong ([Note]
normals forall a. [a] -> [a] -> [a]
++ [Note]
weaks) | Note
strong <- [Note]
strongs]
    ([], [Note]
weaks, normals :: [Note]
normals@(Note
_:[Note]
_)) -> forall a b. b -> Either a b
Right [Note -> [Note] -> Note
merge Note
normal [Note]
weaks | Note
normal <- [Note]
normals]
    ([], [Note]
weaks, []) -> forall a b. b -> Either a b
Right [Note]
weaks
    where
    partition :: [Note] -> ([Note], [Note], [Note])
partition = forall a. (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a])
Lists.partition2 (Flags -> Note -> Bool
Score.has_flags Flags
Flags.strong)
        (Flags -> Note -> Bool
Score.has_flags Flags
Flags.weak)

-- | Handle 'Flags.infer_duration' for notes merged together.  This is the case
-- where a final note replaces a coincident initial note.  The strong note gets
-- the duration of the longest weak notes, if there are any.  If there are no
-- weaks, then there are no coincedent notes to merge, so return the event
-- unchanged so 'infer_duration_single' can handle it.
infer_duration_merged :: Score.Event -> [Score.Event] -> Score.Event
infer_duration_merged :: Note -> [Note] -> Note
infer_duration_merged Note
strong [Note]
weaks =
    case forall a. Ord a => [a] -> Maybe a
Lists.maximum (forall a b. (a -> b) -> [a] -> [b]
map Note -> RealTime
Score.event_end [Note]
weaks) of
        Just RealTime
end | Flags -> Note -> Bool
Score.has_flags Flags
Flags.infer_duration Note
strong ->
            Stack => Text -> Note -> Note
Score.add_log (Text
"set duration to max of weak notes: "
                forall a. Semigroup a => a -> a -> a
<> [Note] -> Text
Score.short_events [Note]
weaks) forall a b. (a -> b) -> a -> b
$
            Flags -> Note -> Note
Score.remove_flags Flags
Flags.infer_duration forall a b. (a -> b) -> a -> b
$
            RealTime -> Note -> Note
Score.set_duration (RealTime
end forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
strong) Note
strong
        Maybe RealTime
_ -> Note
strong

-- | Handle 'Flags.infer_duration' for a note by itself.  When there is no
-- coincident note to replace, the duration extends to the start of the next
-- matching event, according to the 'Key'.
--
-- This actually finds the next matching event which starts later than this
-- one.  Normally notes of the same key are not expected to occur
-- simultaneously, but may still do so, for example pasang parts which are
-- normally considered a single voice but may still contain unison or kempyung.
infer_duration_single :: Eq key => Key key -> RealTime
    -> Stream.Stream Score.Event -> Stream.Stream Score.Event
infer_duration_single :: forall key.
Eq key =>
Key key -> RealTime -> Stream Note -> Stream Note
infer_duration_single Key key
key RealTime
final_dur = forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ forall {t :: * -> *}. Foldable t => (Note, t Note) -> Note
infer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, [a])
Post.nexts_by Key key
key
    where
    infer :: (Note, t Note) -> Note
infer (Note
event, t Note
_) | Bool -> Bool
not (Flags -> Note -> Bool
Score.has_flags Flags
Flags.infer_duration Note
event) = Note
event
    infer (Note
event, t Note
nexts) =
        Flags -> Note -> Note
Score.remove_flags Flags
Flags.infer_duration forall a b. (a -> b) -> a -> b
$ case Maybe Note
next of
            Just Note
next -> Stack => Text -> Note -> Note
Score.add_log Text
"set duration to next start" forall a b. (a -> b) -> a -> b
$
                RealTime -> Note -> Note
set_end (Note -> RealTime
Score.event_start Note
next) Note
event
            Maybe Note
Nothing -> Stack => Text -> Note -> Note
Score.add_log Text
"set duration to final dur" forall a b. (a -> b) -> a -> b
$
                RealTime -> Note -> Note
Score.set_duration RealTime
final_dur Note
event
        where
        next :: Maybe Note
next = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Ord a => a -> a -> Bool
> Note -> RealTime
Score.event_start Note
event) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
Score.event_start) t Note
nexts
    set_end :: RealTime -> Note -> Note
set_end RealTime
end Note
event = RealTime -> Note -> Note
Score.set_duration (RealTime
end forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
event) Note
event

merge_groups :: ([a] -> Either Text [a]) -> [Either [LEvent.LEvent a] [a]]
    -> Either Text (Stream.Stream a)
merge_groups :: forall a.
([a] -> Either Text [a])
-> [Either [LEvent a] [a]] -> Either Text (Stream a)
merge_groups [a] -> Either Text [a]
merge = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [LEvent a] -> Stream a
Stream.from_sorted_list 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 Either [LEvent a] [a] -> Either Text [LEvent a]
go
    where
    go :: Either [LEvent a] [a] -> Either Text [LEvent a]
go (Left [LEvent a]
ungrouped) = forall a b. b -> Either a b
Right [LEvent a]
ungrouped
    go (Right []) = forall a b. b -> Either a b
Right []
    go (Right [a
e]) = forall a b. b -> Either a b
Right [forall a. a -> LEvent a
LEvent.Event a
e]
    go (Right [a]
es) = forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Either Text [a]
merge [a]
es

type Events = Stream.Stream Score.Event

-- | Group events with the same start time.  Events in Left are not grouped.
group_coincident :: Ord key => (Score.Event -> key) -> Events
    -> [Either [LEvent.LEvent Score.Event] [Score.Event]]
group_coincident :: forall key.
Ord key =>
(Note -> key) -> Stream Note -> [Either [LEvent Note] [Note]]
group_coincident Note -> key
key = [LEvent Note] -> [Either [LEvent Note] [Note]]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Stream a -> [LEvent a]
Stream.to_list
    where
    go :: [LEvent Note] -> [Either [LEvent Note] [Note]]
go [] = []
    go (log :: LEvent Note
log@(LEvent.Log {}) : [LEvent Note]
es) = forall a b. a -> Either a b
Left [LEvent Note
log] forall a. a -> [a] -> [a]
: [LEvent Note] -> [Either [LEvent Note] [Note]]
go [LEvent Note]
es
    go (LEvent.Event Note
e : [LEvent Note]
es) =
        (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Msg]
logs then forall a. a -> a
id else (forall a b. a -> Either a b
Left (forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs) :)) forall a b. (a -> b) -> a -> b
$
            forall {a}. [Either a [Note]]
groups forall a. [a] -> [a] -> [a]
++ [LEvent Note] -> [Either [LEvent Note] [Note]]
go [LEvent Note]
after
        where
        (([Note]
during, [Msg]
logs), [LEvent Note]
after) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or forall a b. (a -> b) -> a -> b
$ Note -> Note -> Bool
same_start Note
e) [LEvent Note]
es
        -- [e] is going to be a common case, since most notes don't group.
        groups :: [Either a [Note]]
groups = forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right (forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Lists.groupSort Note -> key
key (Note
e forall a. a -> [a] -> [a]
: [Note]
during))
    same_start :: Note -> Note -> Bool
same_start Note
e1 Note
e2 = Note -> RealTime
Score.event_start Note
e1 RealTime -> RealTime -> Bool
RealTime.== Note -> RealTime
Score.event_start Note
e2

-- | Filter out events that fall at and before the 'EnvKey.suppress_until'
-- range of an event with the same (instrument, hand).  Only events that don't
-- have a suppress_until are suppressed.
--
-- This is complicated by the fact that an event should suppress coincident
-- events even if the supressor follows the suppressee in the list, so I have
-- to look into the future for the greatest suppress_until.
suppress_notes :: Stream.Stream Score.Event -> Stream.Stream Score.Event
suppress_notes :: Stream Note -> Stream Note
suppress_notes =
    forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state a.
(state -> a -> (state, [Note]))
-> state -> Stream a -> (state, Stream Note)
Post.emap forall {a}.
Ord a =>
Map a RealTime
-> ([(a, Maybe RealTime, Note)], (a, Maybe RealTime, Note))
-> (Map a RealTime, [Note])
go forall k a. Map k a
Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a)
Stream.zip_on forall a. [a] -> [[a]]
Post.nexts
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c.
([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a)
Stream.zip3_on (forall a b. (a -> b) -> [a] -> [b]
map Note -> (Instrument, Maybe Text)
Post.hand_key) (forall a b. (a -> b) -> [a] -> [b]
map Note -> Maybe RealTime
get_suppress)
    where
    go :: Map a RealTime
-> ([(a, Maybe RealTime, Note)], (a, Maybe RealTime, Note))
-> (Map a RealTime, [Note])
go Map a RealTime
suppressed ([(a, Maybe RealTime, Note)]
nexts, (a
key, Maybe RealTime
suppress, Note
event)) = case Maybe RealTime
suppress of
        Maybe RealTime
Nothing -> (,) Map a RealTime
suppressed forall a b. (a -> b) -> a -> b
$ case Maybe RealTime
suppress_until of
            Just RealTime
until | RealTime
until forall a. Ord a => a -> a -> Bool
>= Note -> RealTime
Score.event_start Note
event forall a. Num a => a -> a -> a
- RealTime
RealTime.eta -> []
            Maybe RealTime
_ -> [Note
event]
        Just RealTime
until -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
key RealTime
until Map a RealTime
suppressed, [Note
event])
        where
        suppress_until :: Maybe RealTime
suppress_until = forall a. Ord a => [a] -> Maybe a
Lists.maximum forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$
            (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
key Map a RealTime
suppressed :) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> b
suppress_of forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Note -> Bool
coincident forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> c
event_of) forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==a
key) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
key_of) [(a, Maybe RealTime, Note)]
nexts
        coincident :: Note -> Bool
coincident Note
e = Note -> RealTime
Score.event_start Note
e
            forall a. Ord a => a -> a -> Bool
<= Note -> RealTime
Score.event_start Note
event forall a. Num a => a -> a -> a
+ RealTime
RealTime.eta
    get_suppress :: Score.Event -> Maybe RealTime
    get_suppress :: Note -> Maybe RealTime
get_suppress = forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.suppress_until forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Environ
Score.event_environ
    key_of :: (a, b, c) -> a
key_of (a
k, b
_, c
_) = a
k
    suppress_of :: (a, b, c) -> b
suppress_of (a
_, b
s, c
_) = b
s
    event_of :: (a, b, c) -> c
event_of (a
_, b
_, c
e) = c
e

-- * apply start offset

c_randomize_start :: Derive.Transformer Derive.Note
c_randomize_start :: Transformer Note
c_randomize_start = forall a. Stack => Text -> Either Text a -> a
StaticMacro.check Text
"c_randomize_start" forall a b. (a -> b) -> a -> b
$
    forall d.
CallableExpr d =>
Module
-> CallName
-> Tags
-> Doc
-> [Call (Transformer d)]
-> Either Text (Transformer d)
StaticMacro.transformer Module
module_ CallName
"randomize-start" Tags
Tags.postproc Doc
""
        -- apply-start-offset | start-s = (cf-rnd-a+ $)
        [ forall call. call -> [Arg] -> Call call
StaticMacro.Call Transformer Note
c_apply_start_offset []
        , forall call. call -> [Arg] -> Call call
StaticMacro.Call forall d. CallableExpr d => Transformer d
Equal.c_equal
            [ forall a. ToVal a => a -> Arg
StaticMacro.literal (forall a. ShowVal a => a -> Text
ShowVal.show_val Control
Controls.start_s)
            , ValCall -> [Arg] -> Arg
StaticMacro.call ((Y -> Y -> Y) -> ValCall
ControlFunction.c_cf_rnd_around forall a. Num a => a -> a -> a
(+))
                [Arg
StaticMacro.Var]
            ]
        ]

{- | Previously I applied the @%start-s@ and @%start-t@ controls in the note
    generator, but I wound up with notes getting out of sync with their
    controls.  Even if I apply the controls before inversion, it still doesn't
    work other calls, like say block calls, and I can't apply the controls
    before the block call
-}
c_apply_start_offset :: Derive.Transformer Derive.Note
c_apply_start_offset :: Transformer Note
c_apply_start_offset =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"apply-start-offset" Tags
Tags.postproc
    (Doc
"Apply the " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
EnvKey.start_offset_val forall a. Semigroup a => a -> a -> a
<> Doc
" env var.\
     \ This is set by note deriver from the "
     forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.start_s forall a. Semigroup a => a -> a -> a
<> Doc
" and "
     forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.start_t forall a. Semigroup a => a -> a -> a
<> Doc
" controls, so if you want those\
     \ controls to have an effect, you have to use this postproc."
    ) 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
"min-duration" (forall a. Maybe a
Nothing :: Maybe RealTime)
            Doc
"If given, notes on the same hand\
            \ won't be moved closer than this time. Otherwise, hand and\
            \ instrument is ignored."
    ) forall a b. (a -> b) -> a -> b
$ \Maybe RealTime
min_dur PassedArgs Note
_args Deriver (Stream Note)
deriver -> Maybe RealTime -> Stream Note -> Stream Note
apply_start_offset Maybe RealTime
min_dur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

apply_start_offset :: Maybe RealTime -> Stream.Stream Score.Event
    -> Stream.Stream Score.Event
apply_start_offset :: Maybe RealTime -> Stream Note -> Stream Note
apply_start_offset Maybe RealTime
maybe_min_dur =
    Stream (RealTime, Note) -> Stream Note
apply_offset forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream (RealTime, Note) -> Stream (RealTime, Note)
tweak_offset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a)
Stream.zip_on (forall a b. (a -> b) -> [a] -> [b]
map Note -> RealTime
offset_of)
    where
    tweak_offset :: Stream (RealTime, Note) -> Stream (RealTime, Note)
tweak_offset = case Maybe RealTime
maybe_min_dur of
        Maybe RealTime
Nothing -> forall a. a -> a
id
        Just RealTime
min_dur -> forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (RealTime
-> (Maybe (RealTime, Note), (RealTime, Note),
    Maybe (RealTime, Note))
-> (RealTime, Note)
tweak RealTime
min_dur)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
Post.neighbors_by (Note -> (Instrument, Maybe Text)
Post.hand_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    tweak :: RealTime
-> (Maybe (RealTime, Note), (RealTime, Note),
    Maybe (RealTime, Note))
-> (RealTime, Note)
tweak RealTime
min_dur (Maybe (RealTime, Note)
prev, (RealTime
offset, Note
event), Maybe (RealTime, Note)
next) = (RealTime
new_offset, Note
event)
        where
        new_offset :: RealTime
new_offset = RealTime
-> Maybe (RealTime, RealTime)
-> Maybe (RealTime, RealTime)
-> RealTime
-> RealTime
-> RealTime
adjust_offset RealTime
min_dur (forall {a}. (a, Note) -> (a, RealTime)
extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RealTime, Note)
prev) (forall {a}. (a, Note) -> (a, RealTime)
extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RealTime, Note)
next)
            RealTime
offset (Note -> RealTime
Score.event_start Note
event)
        extract :: (a, Note) -> (a, RealTime)
extract (a
offset, Note
event) = (a
offset, Note -> RealTime
Score.event_start Note
event)

    apply_offset :: Stream (RealTime, Note) -> Stream Note
apply_offset =
        forall a. (a -> Note) -> Stream a -> Stream Note
Post.emap1_ord_ forall {a}. (a, (RealTime, Note), Maybe (RealTime, Note)) -> Note
apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a)
Post.neighbors_by (Note -> (Instrument, Maybe Text)
Post.hand_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    apply :: (a, (RealTime, Note), Maybe (RealTime, Note)) -> Note
apply (a
_, (RealTime
offset, Note
event), Maybe (RealTime, Note)
maybe_next) =
        Note -> Note
set_dur forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> Note -> Note
Score.move_start (forall a. a -> Maybe a -> a
fromMaybe RealTime
Note.min_duration Maybe RealTime
maybe_min_dur)
            RealTime
offset Note
event
        where
        set_dur :: Note -> Note
set_dur Note
event = case Maybe (RealTime, Note)
maybe_next of
            Maybe (RealTime, Note)
Nothing -> Note
event
            Just (RealTime
next_offset, Note
next) -> (RealTime -> RealTime) -> Note -> Note
Score.duration (forall a b. a -> b -> a
const RealTime
dur) Note
event
                where
                dur :: RealTime
dur = RealTime -> RealTime -> Note -> RealTime
adjust_duration (Note -> RealTime
Score.event_start Note
next)
                    (Note -> RealTime
Score.event_start Note
next forall a. Num a => a -> a -> a
+ RealTime
next_offset) Note
event

{- | Conceptually, all notes move together until they bump into each
    other.  Or, they move without restriction, and then go to midway of the
    overlap.  But the note's start is a hard lower or upper limit, so one note
    moving can never cause another note to move, it can just cause it to not
    move as much as it wanted.

    TODO actually "half of the overlap" is not the same as "all move together".
    For the latter, the overlap split depends on how far the note moved to get
    there.  So instead of overlap/2 it's 'max 0 (overlap - n) / 2', where 'n'
    is the imbalance between their move offsets.

    TODO this is still broken if an offset causes an note to skip over another.
    But that should be stopped by the next event, right?
-}
adjust_offset :: RealTime -- ^ don't move notes any closer than this
    -> Maybe (RealTime, RealTime) -> Maybe (RealTime, RealTime)
    -> RealTime -> RealTime -> RealTime
adjust_offset :: RealTime
-> Maybe (RealTime, RealTime)
-> Maybe (RealTime, RealTime)
-> RealTime
-> RealTime
-> RealTime
adjust_offset RealTime
min_dur Maybe (RealTime, RealTime)
prev Maybe (RealTime, RealTime)
next RealTime
offset RealTime
start
    | RealTime
offset forall a. Eq a => a -> a -> Bool
== RealTime
0 = RealTime
offset
    | RealTime
offset forall a. Ord a => a -> a -> Bool
> RealTime
0 = case Maybe (RealTime, RealTime)
next of
        Maybe (RealTime, RealTime)
Nothing -> RealTime
offset
            -- 0   1   2   3   4
            -- [----=+=>
            --     <-+-----|
            -- [---====+===)--->
            --     <---+---|
            -- [------->   )
            --     |------->
        Just (RealTime
next_offset, RealTime
next_start)
            | RealTime
overlap forall a. Ord a => a -> a -> Bool
<= RealTime
0 -> forall a. Ord a => a -> a -> a
min (RealTime
next_end forall a. Num a => a -> a -> a
- RealTime
min_dur) RealTime
end forall a. Num a => a -> a -> a
- RealTime
start
            | Bool
otherwise -> (RealTime
end forall a. Num a => a -> a -> a
- RealTime
overlap forall a. Num a => a -> a -> a
+ RealTime
overlap forall a. Fractional a => a -> a -> a
/ RealTime
2 forall a. Num a => a -> a -> a
- RealTime
min_dur) forall a. Num a => a -> a -> a
- RealTime
start
            where
            overlap :: RealTime
overlap = RealTime
end forall a. Num a => a -> a -> a
- RealTime
next_end
            end :: RealTime
end = forall a. Ord a => a -> a -> a
min (forall a. Ord a => a -> a -> a
max RealTime
next_start RealTime
next_end) (RealTime
start forall a. Num a => a -> a -> a
+ RealTime
offset)
            next_end :: RealTime
next_end = forall a. Ord a => a -> a -> a
max RealTime
start (RealTime
next_start forall a. Num a => a -> a -> a
+ RealTime
next_offset)
    | Bool
otherwise = case Maybe (RealTime, RealTime)
prev of
        Maybe (RealTime, RealTime)
Nothing -> RealTime
offset
            -- 0   1   2   3   4
            -- <-------|
            -- (   <-------|
        Just (RealTime
prev_offset, RealTime
prev_start)
            -- If the prev_offset is positive, then it will have already given
            -- the min_dur space.
            | RealTime
overlap forall a. Ord a => a -> a -> Bool
<= RealTime
0 -> if RealTime
prev_offset forall a. Ord a => a -> a -> Bool
> RealTime
0
                then RealTime
offset
                else forall a. Ord a => a -> a -> a
max (RealTime
prev_end forall a. Num a => a -> a -> a
+ RealTime
min_dur) RealTime
end forall a. Num a => a -> a -> a
- RealTime
start
            | Bool
otherwise -> (RealTime
end forall a. Num a => a -> a -> a
+ RealTime
overlap forall a. Num a => a -> a -> a
- RealTime
overlap forall a. Fractional a => a -> a -> a
/ RealTime
2) forall a. Num a => a -> a -> a
- RealTime
start
            where
            overlap :: RealTime
overlap = RealTime
prev_end forall a. Num a => a -> a -> a
- RealTime
end
            end :: RealTime
end = forall a. Ord a => a -> a -> a
max (forall a. Ord a => a -> a -> a
min RealTime
prev_start RealTime
prev_end) (RealTime
start forall a. Num a => a -> a -> a
+ RealTime
offset)
            prev_end :: RealTime
prev_end = forall a. Ord a => a -> a -> a
min RealTime
start (RealTime
prev_start forall a. Num a => a -> a -> a
+ RealTime
prev_offset)

-- | Change the duration based on the movement of the next event.
--
-- If the event end touches the next start, then adjust dur by next_offset.  If
-- it's less, then shorten but don't lengthen.  If it overlaps the next note,
-- then leave it alone.
adjust_duration :: RealTime -> RealTime -> Score.Event -> RealTime
adjust_duration :: RealTime -> RealTime -> Note -> RealTime
adjust_duration RealTime
next RealTime
new_next Note
event =
    forall a. Num a => a -> a -> a
subtract (Note -> RealTime
Score.event_start Note
event) forall a b. (a -> b) -> a -> b
$ case forall a. (ApproxEq a, Ord a) => Y -> a -> a -> Ordering
ApproxEq.compare Y
0.001 RealTime
end RealTime
next of
        Ordering
EQ -> RealTime
new_next
        Ordering
LT -> forall a. Ord a => a -> a -> a
min RealTime
new_next RealTime
end
        Ordering
GT -> RealTime
end
    where end :: RealTime
end = Note -> RealTime
Score.event_end Note
event

offset_of :: Score.Event -> RealTime
offset_of :: Note -> RealTime
offset_of = forall a. a -> Maybe a -> a
fromMaybe RealTime
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.start_offset_val
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Environ
Score.event_environ