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

-- | Post-proc calls that impose a new kind of articulation.
module Derive.C.Post.Rearticulate (library) where
import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.LEvent as LEvent
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
    [ (Symbol
"slur-n", Transformer Note
c_slur_n)
    , (Symbol
"slur-dur", Transformer Note
c_slur_dur)
    ]

c_slur_n :: Derive.Transformer Derive.Note
c_slur_n :: Transformer Note
c_slur_n = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"slur-n" Tags
Tags.postproc
    Doc
"Merge groups of notes into one note, where the pitch is taken from each\
    \ merged note. The groups are of a fixed size."
    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. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"group" Doc
"How many notes in a group.")
    forall a b. (a -> b) -> a -> b
$ \Int
group PassedArgs Note
_args Deriver (Stream Note)
deriver -> Int -> Stream Note -> Stream Note
slur_n Int
group forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

slur_n :: Int -> Stream.Stream Score.Event -> Stream.Stream Score.Event
slur_n :: Int -> Stream Note -> Stream Note
slur_n Int
group = forall a. [LEvent a] -> Stream a
Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEvent Note] -> [LEvent 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] -> [LEvent Note]
go [LEvent Note]
events = case 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. Int -> [LEvent a] -> ([LEvent a], [LEvent a])
split_events Int
group [LEvent Note]
events of
        (([], [Msg]
logs), [LEvent Note]
_) -> forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs
        ((Note
e : [Note]
es, [Msg]
logs), [LEvent Note]
post) -> forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs
            forall a. [a] -> [a] -> [a]
++ forall a. a -> LEvent a
LEvent.Event (Note -> [Note] -> Note
slur Note
e [Note]
es) forall a. a -> [a] -> [a]
: [LEvent Note] -> [LEvent Note]
go [LEvent Note]
post

-- | Merge pitch and controls from the given events.
--
-- Previously I used a curve and time to merge more gradually.  I can add it
-- back if it's useful.
slur :: Score.Event -> [Score.Event] -> Score.Event
slur :: Note -> [Note] -> Note
slur Note
event [Note]
events = Note
event
    { event_duration :: RealTime
Score.event_duration = RealTime
dur
    , event_pitch :: PSignal
Score.event_pitch = PSignal -> [(RealTime, PSignal)] -> PSignal
merge_pitch (Note -> PSignal
Score.event_pitch Note
event)
        [(Note -> RealTime
Score.event_start Note
e, Note -> PSignal
Score.event_pitch Note
e) | Note
e <- [Note]
events]
    , event_environ :: Environ
Score.event_environ = ControlMap -> Environ
Env.from_controls (Note -> [Note] -> ControlMap
merge_controls Note
event [Note]
events)
        forall a. Semigroup a => a -> a -> a
<> Note -> Environ
Score.event_environ Note
event
    }
    where
    dur :: RealTime
dur = Note -> RealTime
Score.event_end (forall a. a -> Maybe a -> a
fromMaybe Note
event (forall a. [a] -> Maybe a
Lists.last [Note]
events))
        forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
event

merge_pitch :: PSignal.PSignal -> [(RealTime, PSignal.PSignal)]
    -> PSignal.PSignal
merge_pitch :: PSignal -> [(RealTime, PSignal)] -> PSignal
merge_pitch PSignal
sig [(RealTime, PSignal)]
sigs =
    forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ PSignal
sig forall a. a -> [a] -> [a]
: [RealTime -> PSignal -> PSignal
PSignal.clip_before RealTime
start PSignal
sig | (RealTime
start, PSignal
sig) <- [(RealTime, PSignal)]
sigs]

merge_controls :: Score.Event -> [Score.Event] -> ScoreT.ControlMap
merge_controls :: Note -> [Note] -> ControlMap
merge_controls Note
event [Note]
events = forall k a. (Ord k, Monoid a) => [Map k a] -> Map k a
Maps.mconcat forall a b. (a -> b) -> a -> b
$ Note -> ControlMap
clip Note
event forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Note -> ControlMap
clip [Note]
events
    where
    clip :: Note -> ControlMap
clip Note
event = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_before (Note -> RealTime
Score.event_start Note
event)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Note -> ControlMap
Score.event_controls Note
event

-- | 'splitAt' for LEvents.
split_events :: Int -> [LEvent.LEvent a]
    -> ([LEvent.LEvent a], [LEvent.LEvent a])
split_events :: forall a. Int -> [LEvent a] -> ([LEvent a], [LEvent a])
split_events Int
_ [] = ([], [])
split_events Int
n (LEvent a
e:[LEvent a]
es)
    | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = ([], LEvent a
e forall a. a -> [a] -> [a]
: [LEvent a]
es)
    | Bool
otherwise = (LEvent a
e forall a. a -> [a] -> [a]
: [LEvent a]
pre, [LEvent a]
post)
    where ([LEvent a]
pre, [LEvent a]
post) = forall a. Int -> [LEvent a] -> ([LEvent a], [LEvent a])
split_events (if forall a. LEvent a -> Bool
LEvent.is_event LEvent a
e then Int
n forall a. Num a => a -> a -> a
- Int
1 else Int
n) [LEvent a]
es

c_slur_dur :: Derive.Transformer Derive.Note
c_slur_dur :: Transformer Note
c_slur_dur = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"slur-dur" Tags
Tags.postproc
    Doc
"Merge groups of notes into one note, where the pitch is taken from each\
    \ merged note. The groups are by duration."
    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
<$> (DefaultScore -> Duration
Typecheck._score forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"dur" Doc
"How long each group is.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DefaultScore -> Duration
Typecheck._score 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
"offset" (ScoreTime -> DefaultScore
Typecheck.score ScoreTime
0)
        Doc
"Groups start at this time.")
    ) forall a b. (a -> b) -> a -> b
$ \(Duration
dur, Duration
offset) PassedArgs Note
args Deriver (Stream Note)
deriver -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        RealTime
dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start Duration
dur
        RealTime
offset <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start Duration
offset
        RealTime -> RealTime -> Stream Note -> Stream Note
slur_dur RealTime
dur RealTime
offset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

slur_dur :: RealTime -> RealTime -> Stream.Stream Score.Event
    -> Stream.Stream Score.Event
slur_dur :: RealTime -> RealTime -> Stream Note -> Stream Note
slur_dur RealTime
dur RealTime
offset Stream Note
stream =
    forall e. [Msg] -> Stream e -> Stream e
Stream.merge_logs [Msg]
logs forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Stream a
Stream.from_sorted_events forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Note -> Note
apply (RealTime -> RealTime -> [Note] -> [NonEmpty Note]
group_dur RealTime
dur RealTime
offset [Note]
events)
    where
    apply :: NonEmpty Note -> Note
apply (Note
e :| [Note]
es) = Note -> [Note] -> Note
slur Note
e [Note]
es
    ([Note]
events, [Msg]
logs) = forall a. Stream a -> ([a], [Msg])
Stream.partition Stream Note
stream

group_dur :: RealTime -> RealTime -> [Score.Event] -> [NonEmpty Score.Event]
group_dur :: RealTime -> RealTime -> [Note] -> [NonEmpty Note]
group_dur RealTime
dur RealTime
offset = forall key a. Eq key => (a -> key) -> [a] -> [NonEmpty a]
Lists.groupStable Note -> Integer
group_of
    where
    group_of :: Note -> Integer
group_of = forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Double
RealTime.to_seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/RealTime
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
offset
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
Score.event_start