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

-- | Idiomatic things for various instruments.
module Derive.C.Post.Idiom where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call.Ly as Ly
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.LEvent as LEvent
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
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
"pizz-arp", Transformer Note
c_pizz_arp)
    , (Symbol
"avoid-overlap", Transformer Note
c_avoid_overlap)
    , (Symbol
"zero-duration-mute", Transformer Note
c_zero_duration_mute)
    , (Symbol
"extend-duration", Transformer Note
c_extend_duration)
    , (Symbol
"apply-attributes", Transformer Note
c_apply_attributes)
    ]

-- * pizz arp

c_pizz_arp :: Derive.Transformer Derive.Note
c_pizz_arp :: Transformer Note
c_pizz_arp = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"pizz-arp"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    Doc
"Arpeggiate simultaneous notes with `+pizz`. The order is arbitrary but\
    \ probably in track order.  TODO sort by pitch?" 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
"time" (RealTime
0.02 :: RealTime)
        Doc
"Insert this much time between each note."
    ) forall a b. (a -> b) -> a -> b
$
    \RealTime
time PassedArgs Note
_args Deriver (Stream Note)
deriver -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver (Stream Note)
deriver forall a b. (a -> b) -> a -> b
$
        RealTime -> Stream Note -> Deriver (Stream Note)
pizz_arp RealTime
time forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (Stream Note)
deriver

pizz_arp :: RealTime -> Stream.Stream Score.Event -> Derive.NoteDeriver
pizz_arp :: RealTime -> Stream Note -> Deriver (Stream Note)
pizz_arp RealTime
time = RealTime
-> (Note -> Bool)
-> (NonEmpty Note -> Deriver [Note])
-> Stream Note
-> Deriver (Stream Note)
map_simultaneous RealTime
0.025 (Attributes -> Note -> Bool
Score.has_attribute Attributes
Attrs.pizz) forall a b. (a -> b) -> a -> b
$
    \(Note
event :| [Note]
chord) -> forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (RealTime -> RealTime) -> Note -> Note
Score.move (forall a. Num a => a -> a -> a
+RealTime
t) Note
event
        | (RealTime
t, Note
event) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
0 RealTime
time) (Note
event forall a. a -> [a] -> [a]
: [Note]
chord)
        ]

map_simultaneous :: RealTime
    -- ^ events starting closer than this amount are considered simultaneous
    -> (Score.Event -> Bool)
    -- ^ only process events that pass this predicate
    -> (NonEmpty Score.Event -> Derive.Deriver [Score.Event])
    -- ^ process simultaneous events
    -> Stream.Stream Score.Event -> Derive.NoteDeriver
map_simultaneous :: RealTime
-> (Note -> Bool)
-> (NonEmpty Note -> Deriver [Note])
-> Stream Note
-> Deriver (Stream Note)
map_simultaneous RealTime
eta Note -> Bool
accept NonEmpty Note -> Deriver [Note]
f =
    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
. [LEvent Note] -> Deriver State Error [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] -> Deriver State Error [LEvent Note]
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (LEvent.Log Msg
log : [LEvent Note]
events) = (forall a. Msg -> LEvent a
LEvent.Log Msg
log :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LEvent Note] -> Deriver State Error [LEvent Note]
go [LEvent Note]
events
    go (LEvent.Event Note
event : [LEvent Note]
events)
        | Note -> Bool
accept Note
event = Note -> [LEvent Note] -> Deriver State Error [LEvent Note]
collect Note
event [LEvent Note]
events
        | Bool
otherwise = (forall a. a -> LEvent a
LEvent.Event Note
event :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LEvent Note] -> Deriver State Error [LEvent Note]
go [LEvent Note]
events
    collect :: Note -> [LEvent Note] -> Deriver State Error [LEvent Note]
collect Note
event [LEvent Note]
events = do
        [Note]
out <- NonEmpty Note -> Deriver [Note]
f (Note
event forall a. a -> [a] -> NonEmpty a
:| [Note]
wanted)
        [LEvent Note]
out_rest <- [LEvent Note] -> Deriver State Error [LEvent Note]
go [LEvent Note]
rest
        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. a -> LEvent a
LEvent.Event ([Note]
out forall a. [a] -> [a] -> [a]
++ [Note]
unwanted) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs
            forall a. [a] -> [a] -> [a]
++ [LEvent Note]
out_rest
        where
        start :: RealTime
start = Note -> RealTime
Score.event_start Note
event
        ([LEvent Note]
with, [LEvent Note]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span
            (forall d. (d -> Bool) -> LEvent d -> Bool
LEvent.log_or ((forall a. Ord a => a -> a -> Bool
<=RealTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
eta forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> RealTime
Score.event_start))
            [LEvent Note]
events
        ([Note]
chord, [Msg]
logs) = forall d. [LEvent d] -> ([d], [Msg])
LEvent.partition [LEvent Note]
with
        ([Note]
wanted, [Note]
unwanted) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition Note -> Bool
accept [Note]
chord

-- * avoid overlap

c_avoid_overlap :: Derive.Transformer Derive.Note
c_avoid_overlap :: Transformer Note
c_avoid_overlap = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"avoid-overlap"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    Doc
"Notes with the same instrument and starting pitch are shortened so they\
    \ don't overlap with each other.  This simulates keyboard instruments, \
    \ where you have to release a key before striking the same key again.\
    \ This also happens to be what MIDI expects, since it's based on keyboards."
    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
"time" (Y
0.1 :: Double)
        Doc
"Ensure at least this much time between two notes of the same pitch.")
    forall a b. (a -> b) -> a -> b
$ \RealTime
time PassedArgs Note
_args Deriver (Stream Note)
deriver -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver (Stream Note)
deriver forall a b. (a -> b) -> a -> b
$
        RealTime -> Stream Note -> Stream Note
avoid_overlap RealTime
time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

avoid_overlap :: RealTime -> Stream.Stream Score.Event
    -> Stream.Stream Score.Event
avoid_overlap :: RealTime -> Stream Note -> Stream Note
avoid_overlap RealTime
time = forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Note, [Note]) -> Note
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Note -> Stream (Note, [Note])
next_same_pitch
    where
    modify :: (Note, [Note]) -> Note
modify (Note
event, []) = Note
event
    modify (Note
event, Note
next : [Note]
_)
        | Note -> Note -> Bool
overlaps Note
event Note
next = RealTime -> Note -> Note
Score.set_duration RealTime
dur Note
event
        | Bool
otherwise = Note
event
        where
        dur :: RealTime
dur = forall a. Ord a => a -> a -> a
max RealTime
Note.min_duration forall a b. (a -> b) -> a -> b
$
            Note -> RealTime
Score.event_start Note
next forall a. Num a => a -> a -> a
- RealTime
time forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
event
    overlaps :: Note -> Note -> Bool
overlaps Note
event Note
next = Note -> RealTime
Score.event_end Note
event forall a. Num a => a -> a -> a
+ RealTime
time forall a. Ord a => a -> a -> Bool
> Note -> RealTime
Score.event_start Note
next

-- | For each event, get the next events with the same instrument and starting
-- pitch.
next_same_pitch :: Stream.Stream Score.Event
    -> Stream.Stream (Score.Event, [Score.Event])
next_same_pitch :: Stream Note -> Stream (Note, [Note])
next_same_pitch = forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ ([Note], Note) -> (Note, [Note])
check 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
    where
    check :: ([Note], Note) -> (Note, [Note])
check ([Note]
nexts, Note
event) = (Note
event, forall a. (a -> Bool) -> [a] -> [a]
filter (Note -> Note -> Bool
same Note
event) [Note]
nexts)
    same :: Note -> Note -> Bool
same Note
event Note
next =
        Note -> Instrument
Score.event_instrument Note
event forall a. Eq a => a -> a -> Bool
== Note -> Instrument
Score.event_instrument Note
next
        Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
Maybe.isJust Maybe NoteNumber
nn Bool -> Bool -> Bool
&& Maybe NoteNumber
nn forall a. Eq a => a -> a -> Bool
== Note -> Maybe NoteNumber
Score.initial_nn Note
next
        where nn :: Maybe NoteNumber
nn = Note -> Maybe NoteNumber
Score.initial_nn Note
event


-- * zero dur mute

-- | See DUtil.zero_duration for a version that can apply any kind of
-- transformation.  This one is limited to attrs because it's a postproc, and
-- it's a postproc because otherwise it's hard to tell if a note is really
-- zero duration and not just an infer-duration note.
c_zero_duration_mute :: Derive.Transformer Derive.Note
c_zero_duration_mute :: Transformer Note
c_zero_duration_mute = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude
    CallName
"zero-duration-mute" (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    Doc
"Add attributes to zero duration events."
    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
"attr" Attributes
Attrs.mute Doc
"Add this attribute."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" (Y
0.75 :: Double) Doc
"Scale dynamic by this amount."
    ) forall a b. (a -> b) -> a -> b
$ \(Attributes
attrs, Y
dyn) PassedArgs Note
_args Deriver (Stream Note)
deriver -> forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Attributes -> Y -> Note -> Note
add Attributes
attrs Y
dyn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver
    where
    add :: Attributes -> Y -> Note -> Note
add Attributes
attrs Y
dyn Note
event
        | Note -> RealTime
Score.event_duration Note
event forall a. Eq a => a -> a -> Bool
== RealTime
0 =
            (Y -> Y) -> Note -> Note
Score.modify_dynamic (forall a. Num a => a -> a -> a
*Y
dyn) forall a b. (a -> b) -> a -> b
$ Attributes -> Note -> Note
Score.add_attributes Attributes
attrs Note
event
        | Bool
otherwise = Note
event


-- * extend duration

c_extend_duration :: Derive.Transformer Derive.Note
c_extend_duration :: Transformer Note
c_extend_duration = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"extend-duration"
    Tags
Tags.postproc (Doc
"Extend the duration of notes with certain attributes.\
    \ This is appropriate for attributes like " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Attributes
Attrs.staccato
    forall a. Semigroup a => a -> a -> a
<> Doc
", which might already have their own built-in duration, and sound\
    \ better when given as much time to ring as possible."
    ) 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. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"attrs" Doc
"Extend durations of notes with these attrs."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (Y -> RealTime
RealTime.seconds Y
2)
        Doc
"Extend to a minimum of this duration."
    ) forall a b. (a -> b) -> a -> b
$ \([Attributes]
attrs, RealTime
dur) PassedArgs Note
_args Deriver (Stream Note)
deriver -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver (Stream Note)
deriver forall a b. (a -> b) -> a -> b
$
        [Attributes] -> RealTime -> Stream Note -> Stream Note
extend_duration [Attributes]
attrs RealTime
dur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

-- | Don't overlap with another note with the same pitch, as in 'avoid_overlap'.
extend_duration :: [Attrs.Attributes] -> RealTime -> Stream.Stream Score.Event
    -> Stream.Stream Score.Event
extend_duration :: [Attributes] -> RealTime -> Stream Note -> Stream Note
extend_duration [Attributes]
attrs RealTime
dur = forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Note, [Note]) -> Note
extend forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream Note -> Stream (Note, [Note])
next_same_pitch
    where
    extend :: (Note, [Note]) -> Note
extend (Note
event, [Note]
nexts)
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Attributes
a -> Attributes -> Note -> Bool
Score.has_attribute Attributes
a Note
event) [Attributes]
attrs =
            (RealTime -> RealTime) -> Note -> Note
Score.duration (forall a. Ord a => a -> a -> a
max forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
dur (forall a. Ord a => a -> a -> a
min RealTime
dur) Maybe RealTime
max_dur) Note
event
        | Bool
otherwise = Note
event
        where max_dur :: Maybe RealTime
max_dur = Note -> Note -> RealTime
diff Note
event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
Lists.head [Note]
nexts
    diff :: Note -> Note -> RealTime
diff Note
e1 Note
e2 = forall a. Ord a => a -> a -> a
max RealTime
0 forall a b. (a -> b) -> a -> b
$ Note -> RealTime
Score.event_start Note
e2 forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
e1 forall a. Num a => a -> a -> a
- RealTime
0.05


-- * apply attributes

c_apply_attributes :: Derive.Transformer Derive.Note
c_apply_attributes :: Transformer Note
c_apply_attributes = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"apply-attributes"
    Tags
Tags.postproc (Doc
"Apply attributes by control signal. This looks for\
        \ controls with a " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
control_prefix forall a. Semigroup a => a -> a -> a
<> Doc
" prefix.\
        \ A control named " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc (Text
control_prefix forall a. Semigroup a => a -> a -> a
<> Text
"a-b")

        forall a. Semigroup a => a -> a -> a
<> Doc
" will, when non-zero, add the `+a+b` attributes to its events."
    ) forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_args Deriver (Stream Note)
deriver -> forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ Note -> Note
apply_attributes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver (Stream Note)
deriver

-- | For all controls that start with 'control_prefix' and are positive during
-- the event start, add those attributes to the event.
--
-- TODO a possible variation would be to take 0<v<1 as a probability of
-- applying the attribute.
apply_attributes :: Score.Event -> Score.Event
apply_attributes :: Note -> Note
apply_attributes Note
event = Attributes -> Note -> Note
Score.add_attributes (forall a. Monoid a => [a] -> a
mconcat [Attributes]
attrs_to_apply) Note
event
    where
    controls :: [(Attrs.Attributes, ScoreT.Control)]
    controls :: [(Attributes, Control)]
controls = forall a k. (a -> Maybe k) -> [a] -> [(k, a)]
Lists.keyOnJust Control -> Maybe Attributes
control_attributes forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$
        Note -> ControlMap
Score.event_controls Note
event
    attrs_to_apply :: [Attributes]
attrs_to_apply = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>Y
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Y
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Attributes, Control)]
controls
    get :: Control -> Y
get Control
c = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Y
0 forall a. Typed a -> a
ScoreT.val_of forall a b. (a -> b) -> a -> b
$
        RealTime -> Control -> Note -> Maybe (Typed Y)
Score.control_at (Note -> RealTime
Score.event_start Note
event) Control
c Note
event

control_attributes :: ScoreT.Control -> Maybe Attrs.Attributes
control_attributes :: Control -> Maybe Attributes
control_attributes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Attributes
Attrs.attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
==Char
'-'))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Maybe Text
Text.stripPrefix Text
control_prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Text
ScoreT.control_name

control_prefix :: Text
control_prefix :: Text
control_prefix = Text
"attr-"