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

-- | Transformers on @Derive.Generator Derive.Note@.
module Derive.C.Prelude.NoteTransformer (library) where
import qualified Data.List.NonEmpty as NonEmpty

import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Lists as Lists

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Eval as Eval
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 Derive.Typecheck as Typecheck

import qualified Perform.RealTime as RealTime

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"sequence", Generator Note
c_sequence)
        , (Symbol
"sequence-rt", Generator Note
c_sequence_realtime)
        , (Symbol
"parallel", Generator Note
c_parallel)
        ]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"clip", Transformer Note
c_clip)
        , (Symbol
"Clip", Transformer Note
c_clip_start)
        , (Symbol
"debug", Transformer Note
c_debug)
        , (Symbol
"loop", Transformer Note
c_loop)
        , (Symbol
"multiple", Transformer Note
c_multiple)
        , (Symbol
"tile", Transformer Note
c_tile)
        , (Symbol
"repeat", Transformer Note
c_repeat)
        ]
    ]

-- * generators

-- This isn't a NoteTransformer, but it seems like it belongs here.  What is
-- a better name for the module?
c_sequence :: Derive.Generator Derive.Note
c_sequence :: Generator Note
c_sequence = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall {d}.
(Taggable d, Callable (Transformer d), Callable (Generator d),
 Callable (TrackCall d)) =>
PassedArgs d -> Deriver (CallDuration ScoreTime)
score_duration forall a b. (a -> b) -> a -> b
$
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"sequence" forall a. Monoid a => a
mempty
    Doc
"Run the given calls in sequence. If they each have have an intrinsic\
    \ CallDuration (usually this means block calls), they will get that amount\
    \ of time, at least proportial to the duration of the event. Otherwise,\
    \ if none of them do, they are given equal duration. If some do and some\
    \ don't, you probably get confusing results."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser (NonEmpty Quoted)
calls_arg forall a b. (a -> b) -> a -> b
$ \NonEmpty Quoted
calls PassedArgs Note
args -> do
        let derivers :: [(Quoted, NoteDeriver)]
derivers = forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs Note
args NonEmpty Quoted
calls
        [ScoreTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Quoted, Deriver a) -> Deriver ScoreTime
get_score_duration [(Quoted, NoteDeriver)]
derivers
        ScoreTime
-> ScoreTime -> [NoteDeriver] -> [ScoreTime] -> NoteDeriver
sequence_derivers (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args)
            (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Quoted, NoteDeriver)]
derivers) [ScoreTime]
durs
    where
    calls_arg :: Parser (NonEmpty Quoted)
calls_arg = forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"call" Doc
"Generator calls."
    score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
score_duration PassedArgs d
args = do
        NonEmpty Quoted
calls <- forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
Sig.parse_or_throw Parser (NonEmpty Quoted)
calls_arg PassedArgs d
args
        [ScoreTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Quoted, Deriver a) -> Deriver ScoreTime
get_score_duration (forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs d
args NonEmpty Quoted
calls)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CallDuration a
Derive.CallDuration (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [ScoreTime]
durs)

sequence_derivers :: ScoreTime -> ScoreTime -> [Derive.NoteDeriver]
    -> [ScoreTime] -> Derive.NoteDeriver
sequence_derivers :: ScoreTime
-> ScoreTime -> [NoteDeriver] -> [ScoreTime] -> NoteDeriver
sequence_derivers ScoreTime
start ScoreTime
event_dur [NoteDeriver]
derivers [ScoreTime]
unstretched_durs = forall a. Monoid a => [a] -> a
mconcat
    [ forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur NoteDeriver
d
    | (ScoreTime
start, ScoreTime
dur, NoteDeriver
d) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) ScoreTime
start [ScoreTime]
durs) [ScoreTime]
durs [NoteDeriver]
derivers
    ]
    where
    durs :: [ScoreTime]
durs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
*ScoreTime
stretch) [ScoreTime]
unstretched_durs
    stretch :: ScoreTime
stretch = if ScoreTime
total_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 then ScoreTime
1 else ScoreTime
event_dur forall a. Fractional a => a -> a -> a
/ ScoreTime
total_dur
        where total_dur :: ScoreTime
total_dur = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [ScoreTime]
unstretched_durs

c_sequence_realtime :: Derive.Generator Derive.Note
c_sequence_realtime :: Generator Note
c_sequence_realtime = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall {d}.
(Taggable d, Callable (Transformer d), Callable (Generator d),
 Callable (TrackCall d)) =>
PassedArgs d -> Deriver (CallDuration ScoreTime)
score_duration forall a b. (a -> b) -> a -> b
$
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"sequence-rt" forall a. Monoid a => a
mempty
    Doc
"Run the given block calls in sequence. Each call gets its natural\
    \ real time duration. Unlike `sequence`, each block gets its natural\
    \ RealTime duration, rather than being normalized to 1 and then expanded\
    \ to its ScoreTime duration. TODO I can't get the RealTime duration without\
    \ deriving, at which point it's too late to stretch, so the event duration\
    \ has no effect." -- TODO that last sentence is now out of date since
    -- I have Derive.get_real_duration, right?
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser (NonEmpty Quoted)
calls_arg forall a b. (a -> b) -> a -> b
$ \NonEmpty Quoted
calls PassedArgs Note
args -> do
        let derivers :: [(Quoted, NoteDeriver)]
derivers = forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs Note
args NonEmpty Quoted
calls
        [RealTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Quoted, Deriver a) -> Deriver RealTime
get_real_duration [(Quoted, NoteDeriver)]
derivers
        ScoreTime
-> ScoreTime -> [NoteDeriver] -> [RealTime] -> NoteDeriver
sequence_derivers_realtime (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args)
            (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Quoted, NoteDeriver)]
derivers) [RealTime]
durs
    where
    calls_arg :: Parser (NonEmpty Quoted)
calls_arg = forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"call" Doc
"Generator calls."
    score_duration :: PassedArgs a -> Deriver (CallDuration ScoreTime)
score_duration PassedArgs a
args = do
        NonEmpty Quoted
calls <- forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
Sig.parse_or_throw Parser (NonEmpty Quoted)
calls_arg PassedArgs a
args
        [RealTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Quoted, Deriver a) -> Deriver RealTime
get_real_duration (forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs a
args NonEmpty Quoted
calls)
        ScoreTime
end <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [RealTime]
durs)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CallDuration a
Derive.CallDuration forall a b. (a -> b) -> a -> b
$ ScoreTime
end forall a. Num a => a -> a -> a
- forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args

sequence_derivers_realtime :: ScoreTime -> ScoreTime -> [Derive.NoteDeriver]
    -> [RealTime] -> Derive.NoteDeriver
sequence_derivers_realtime :: ScoreTime
-> ScoreTime -> [NoteDeriver] -> [RealTime] -> NoteDeriver
sequence_derivers_realtime ScoreTime
start ScoreTime
event_dur [NoteDeriver]
derivers [RealTime]
r_durs = do
    RealTime
r_start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    [ScoreTime]
starts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Time a => a -> Deriver ScoreTime
Derive.score forall a b. (a -> b) -> a -> b
$ forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) RealTime
r_start [RealTime]
r_durs
    let unstretched_durs :: [ScoreTime]
unstretched_durs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) (forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts) [ScoreTime]
starts
    let total_dur :: ScoreTime
total_dur = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [ScoreTime]
unstretched_durs
        stretch :: ScoreTime
stretch = if ScoreTime
total_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 then ScoreTime
1 else ScoreTime
event_dur forall a. Fractional a => a -> a -> a
/ ScoreTime
total_dur
    let durs :: [ScoreTime]
durs = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
*ScoreTime
stretch) [ScoreTime]
unstretched_durs
    forall a. Monoid a => [a] -> a
mconcat
        [ forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur NoteDeriver
d
        | (ScoreTime
start, ScoreTime
dur, NoteDeriver
d) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) ScoreTime
start [ScoreTime]
durs) [ScoreTime]
durs [NoteDeriver]
derivers
        ]

c_parallel :: Derive.Generator Derive.Note
c_parallel :: Generator Note
c_parallel = forall d.
(PassedArgs d -> Deriver (CallDuration ScoreTime))
-> Generator d -> Generator d
Derive.with_score_duration forall {d}.
(Taggable d, Callable (Transformer d), Callable (Generator d),
 Callable (TrackCall d)) =>
PassedArgs d -> Deriver (CallDuration ScoreTime)
score_duration forall a b. (a -> b) -> a -> b
$ forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator
    Module
Module.prelude CallName
"parallel" forall a. Monoid a => a
mempty Doc
"Run the given calls in parallel."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser (NonEmpty Quoted)
calls_arg forall a b. (a -> b) -> a -> b
$ \NonEmpty Quoted
calls PassedArgs Note
args -> do
        let derivers :: [(Quoted, NoteDeriver)]
derivers = forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs Note
args NonEmpty Quoted
calls
        [ScoreTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Quoted, Deriver a) -> Deriver ScoreTime
get_score_duration [(Quoted, NoteDeriver)]
derivers
        ScoreTime
-> ScoreTime -> [NoteDeriver] -> [ScoreTime] -> NoteDeriver
parallel_derivers (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args)
            (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Quoted, NoteDeriver)]
derivers) [ScoreTime]
durs
    where
    calls_arg :: Parser (NonEmpty Quoted)
calls_arg = forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"call" Doc
"Generator calls."
    score_duration :: PassedArgs d -> Deriver (CallDuration ScoreTime)
score_duration PassedArgs d
args = do
        NonEmpty Quoted
calls <- forall d a. Taggable d => Parser a -> PassedArgs d -> Deriver a
Sig.parse_or_throw Parser (NonEmpty Quoted)
calls_arg PassedArgs d
args
        [ScoreTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Quoted, Deriver a) -> Deriver ScoreTime
get_score_duration (forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs d
args NonEmpty Quoted
calls)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> CallDuration a
Derive.CallDuration forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ScoreTime
0 (forall a. Ord a => [a] -> Maybe a
Lists.maximum [ScoreTime]
durs)

parallel_derivers :: ScoreTime -> ScoreTime -> [Derive.NoteDeriver]
    -> [ScoreTime] -> Derive.NoteDeriver
parallel_derivers :: ScoreTime
-> ScoreTime -> [NoteDeriver] -> [ScoreTime] -> NoteDeriver
parallel_derivers ScoreTime
start ScoreTime
event_dur [NoteDeriver]
derivers [ScoreTime]
durs =
    forall a. ScoreTime -> Deriver a -> Deriver a
Derive.stretch ScoreTime
stretch forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur NoteDeriver
d
        | (ScoreTime
dur, NoteDeriver
d) <- forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
durs [NoteDeriver]
derivers
        ]
    where
    stretch :: ScoreTime
stretch = if ScoreTime
call_dur forall a. Eq a => a -> a -> Bool
== ScoreTime
0 then ScoreTime
1 else ScoreTime
event_dur forall a. Fractional a => a -> a -> a
/ ScoreTime
call_dur
    call_dur :: ScoreTime
call_dur = forall a. a -> Maybe a -> a
fromMaybe ScoreTime
0 (forall a. Ord a => [a] -> Maybe a
Lists.maximum [ScoreTime]
durs)

calls_to_derivers :: Derive.CallableExpr d => Derive.PassedArgs d
    -> NonEmpty DeriveT.Quoted
    -> [(DeriveT.Quoted, Derive.Deriver (Stream.Stream d))]
calls_to_derivers :: forall d.
CallableExpr d =>
PassedArgs d -> NonEmpty Quoted -> [(Quoted, Deriver (Stream d))]
calls_to_derivers PassedArgs d
args NonEmpty Quoted
calls = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Quoted
calls)
    (forall a b. (a -> b) -> [a] -> [b]
map (forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted_normalized (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args))
        (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Quoted
calls))

get_score_duration :: (DeriveT.Quoted, Derive.Deriver a)
    -> Derive.Deriver ScoreTime
get_score_duration :: forall a. (Quoted, Deriver a) -> Deriver ScoreTime
get_score_duration (Quoted
quoted, Deriver a
d) = forall a.
Deriver a -> Deriver (Either Error (CallDuration ScoreTime))
Derive.get_score_duration Deriver a
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Error
err -> forall a. Stack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"get score dur: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Error
err
    Right CallDuration ScoreTime
Derive.Unknown -> forall a. Stack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"unknown score duration for "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
quoted
    Right (Derive.CallDuration ScoreTime
dur) -> forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
dur

get_real_duration :: (DeriveT.Quoted, Derive.Deriver a)
    -> Derive.Deriver RealTime
get_real_duration :: forall a. (Quoted, Deriver a) -> Deriver RealTime
get_real_duration (Quoted
quoted, Deriver a
d) = forall a.
Deriver a -> Deriver (Either Error (CallDuration RealTime))
Derive.get_real_duration Deriver a
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Error
err -> forall a. Stack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"get real dur: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Error
err
    Right CallDuration RealTime
Derive.Unknown -> forall a. Stack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"unknown real duration for "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
quoted
    Right (Derive.CallDuration RealTime
dur) -> forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
dur


-- * transformers

c_multiple :: Derive.Transformer Derive.Note
c_multiple :: Transformer Note
c_multiple = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"multiple" forall a. Monoid a => a
mempty
    Doc
"Derive the transformed score under different transformers."
    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 (NonEmpty a)
Sig.many1 ArgName
"transformer" Doc
"Derive under each transformer.")
    forall a b. (a -> b) -> a -> b
$ \NonEmpty Quoted
transformers PassedArgs Note
args NoteDeriver
deriver ->
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall {d}.
(Callable (Transformer d), Taggable d) =>
Context d -> Deriver (Stream d) -> Quoted -> Deriver (Stream d)
apply (forall a. PassedArgs a -> Context a
Args.context PassedArgs Note
args) NoteDeriver
deriver)
            (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Quoted
transformers)
    where
    apply :: Context d -> Deriver (Stream d) -> Quoted -> Deriver (Stream d)
apply Context d
ctx Deriver (Stream d)
deriver Quoted
trans = forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> Quoted -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_quoted_transformers Context d
ctx Quoted
trans Deriver (Stream d)
deriver

c_debug :: Derive.Transformer Derive.Note
c_debug :: Transformer Note
c_debug = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"debug" forall a. Monoid a => a
mempty
    Doc
"Save the events at this point in a special log msg. This is useful to\
    \ inspect events at a certain point in a pipeline. You can extract them\
    \ later by looking at the `Log.msg_data` of a log msg with the given tag."
    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
"tag" Doc
"Log msg has this text.")
    forall a b. (a -> b) -> a -> b
$ \Text
tag PassedArgs Note
_ NoteDeriver
deriver -> do
        Stream Note
events <- NoteDeriver
deriver
        forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => Text -> a -> Msg -> Msg
Log.with_dyn Text
tag (forall a. Stream a -> [a]
Stream.events_of Stream Note
events) forall a b. (a -> b) -> a -> b
$
            Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Debug forall a. Maybe a
Nothing Text
"debug call"
        forall (m :: * -> *) a. Monad m => a -> m a
return Stream Note
events

-- ** clip

c_clip :: Derive.Transformer Derive.Note
c_clip :: Transformer Note
c_clip = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"clip" forall a. Monoid a => a
mempty
    Doc
"Unstretch the deriver to its natural duration, and clip events that lie\
    \ beyond the end of the event. Notes that overlap the end of the event will\
    \ be cut short.\
    \\nThis is only useful with calls that have a natural duration apart from\
    \ whatever their calling event's duration, e.g. block calls."
    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 -> forall x a.
PassedArgs x
-> (ScoreTime -> Deriver a -> Deriver a) -> Deriver a -> Deriver a
unstretch_args PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ \ScoreTime
_dur NoteDeriver
deriver -> do
        RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args)
        Maybe RealTime -> Maybe RealTime -> NoteDeriver -> NoteDeriver
trim_events forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just RealTime
end) forall a b. (a -> b) -> a -> b
$
            forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) NoteDeriver
deriver

c_clip_start :: Derive.Transformer Derive.Note
c_clip_start :: Transformer Note
c_clip_start = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"Clip" forall a. Monoid a => a
mempty
    Doc
"Like `clip`, but align the named block to the end of the event instead\
    \ of the beginning. Events that then lie before the start are clipped."
    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 -> forall x a.
PassedArgs x
-> (ScoreTime -> Deriver a -> Deriver a) -> Deriver a -> Deriver a
unstretch_args PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ \ScoreTime
dur NoteDeriver
deriver -> do
        RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args)
        Maybe RealTime -> Maybe RealTime -> NoteDeriver -> NoteDeriver
trim_events (forall a. a -> Maybe a
Just RealTime
start) forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
            forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at (forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs Note
args forall a. Num a => a -> a -> a
- ScoreTime
dur) NoteDeriver
deriver

-- ** loop

c_loop :: Derive.Transformer Derive.Note
c_loop :: Transformer Note
c_loop = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"loop" forall a. Monoid a => a
mempty
    Doc
"This is similar to `clip`, but when the called note runs out, it is\
    \ repeated."
    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 -> forall x a.
PassedArgs x
-> (ScoreTime -> Deriver a -> Deriver a) -> Deriver a -> Deriver a
unstretch_args PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ \ScoreTime
dur NoteDeriver
deriver -> do
        let (ScoreTime
start, ScoreTime
end) = forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args
        let repeats :: Int
repeats = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) forall a. Fractional a => a -> a -> a
/ ScoreTime
dur
            starts :: [ScoreTime]
starts = forall a. Int -> [a] -> [a]
take Int
repeats forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> [a]
Lists.range_ ScoreTime
start ScoreTime
dur
        RealTime
real_end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
        Maybe RealTime -> Maybe RealTime -> NoteDeriver -> NoteDeriver
trim_events forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just RealTime
real_end) forall a b. (a -> b) -> a -> b
$ [ScoreTime] -> ScoreTime -> NoteDeriver -> NoteDeriver
repeat_at [ScoreTime]
starts ScoreTime
1 NoteDeriver
deriver

c_tile :: Derive.Transformer Derive.Note
c_tile :: Transformer Note
c_tile = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"tile" forall a. Monoid a => a
mempty
    Doc
"This is like `loop`, but it can start the looped call in its middle\
    \ instead of starting from 0. The effect is as if the loop is tiled from\
    \ the beginning of the called block, and is only \"let through\" during\
    \ the `tile` call. This is useful for patterns that are tied to the meter,\
    \ but may be interrupted at arbitrary times, e.g. sarvalaghu patterns."
    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 -> forall x a.
PassedArgs x
-> (ScoreTime -> Deriver a -> Deriver a) -> Deriver a -> Deriver a
unstretch_args PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ \ScoreTime
dur NoteDeriver
deriver -> do
        let (ScoreTime
start, ScoreTime
end) = forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args
        let sub_start :: ScoreTime
sub_start = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (RealFrac a, Integral b) => a -> b
floor (ScoreTime
start forall a. Fractional a => a -> a -> a
/ ScoreTime
dur)) forall a. Num a => a -> a -> a
* ScoreTime
dur
        let repeats :: Int
repeats = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
sub_start) forall a. Fractional a => a -> a -> a
/ ScoreTime
dur
            starts :: [ScoreTime]
starts = forall a. Int -> [a] -> [a]
take Int
repeats forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> [a]
Lists.range_ ScoreTime
sub_start ScoreTime
dur
        (RealTime
real_start, RealTime
real_end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Note
args
        Maybe RealTime -> Maybe RealTime -> NoteDeriver -> NoteDeriver
trim_events (forall a. a -> Maybe a
Just RealTime
real_start) (forall a. a -> Maybe a
Just RealTime
real_end) forall a b. (a -> b) -> a -> b
$
            [ScoreTime] -> ScoreTime -> NoteDeriver -> NoteDeriver
repeat_at [ScoreTime]
starts ScoreTime
1 NoteDeriver
deriver

c_repeat :: Derive.Transformer Derive.Note
c_repeat :: Transformer Note
c_repeat = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"repeat" forall a. Monoid a => a
mempty
    Doc
"Repeat the score multiple times, fitted within the note 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 a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"times" Doc
"Repeat this many times.")
    forall a b. (a -> b) -> a -> b
$ \(Typecheck.Positive Int
times) PassedArgs Note
args NoteDeriver
deriver -> do
        let dur :: ScoreTime
dur = forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
times
        let deriver0 :: NoteDeriver
deriver0 = forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at (- forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) NoteDeriver
deriver
        let starts :: [ScoreTime]
starts = forall a. Int -> [a] -> [a]
take Int
times (forall a. Num a => a -> a -> [a]
Lists.range_ (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) ScoreTime
dur)
        [ScoreTime] -> ScoreTime -> NoteDeriver -> NoteDeriver
repeat_at [ScoreTime]
starts (ScoreTime
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
times) NoteDeriver
deriver0

-- | Repeat the deriver at the given start times.
repeat_at :: [ScoreTime] -> ScoreTime -> Derive.NoteDeriver
    -> Derive.NoteDeriver
repeat_at :: [ScoreTime] -> ScoreTime -> NoteDeriver -> NoteDeriver
repeat_at [ScoreTime]
starts ScoreTime
dur NoteDeriver
deriver =
    forall a. Monoid a => [a] -> a
mconcat [forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur NoteDeriver
deriver | ScoreTime
start <- [ScoreTime]
starts]

trim_events :: Maybe RealTime -> Maybe RealTime
    -> Derive.NoteDeriver -> Derive.NoteDeriver
trim_events :: Maybe RealTime -> Maybe RealTime -> NoteDeriver -> NoteDeriver
trim_events Maybe RealTime
start Maybe RealTime
end NoteDeriver
deriver = do
    Stream Note
events <- forall a.
Maybe RealTime -> Maybe RealTime -> Deriver a -> Deriver a
Internal.trim_track_warps Maybe RealTime
start Maybe RealTime
end NoteDeriver
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id RealTime -> Stream Note -> Stream Note
trim_end Maybe RealTime
end forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. (a -> Bool) -> Stream a -> Stream a
Stream.drop_while forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Note -> Bool
event_before) Maybe RealTime
start Stream Note
events
    where
    trim_end :: RealTime -> Stream Note -> Stream Note
trim_end RealTime
e = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Note -> Note
clip RealTime
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Stream a -> Stream a
Stream.take_while (RealTime -> Note -> Bool
event_before RealTime
e)
    clip :: RealTime -> Note -> Note
clip RealTime
end Note
event
        | Note -> RealTime
Score.event_end Note
event forall a. Ord a => a -> a -> Bool
<= RealTime
end = Note
event
        | Bool
otherwise =
            RealTime -> Note -> Note
Score.set_duration (forall a. Ord a => a -> a -> a
max RealTime
0 (RealTime
end forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
event)) Note
event

-- * util

unstretch_args :: Derive.PassedArgs x
    -> (ScoreTime -> Derive.Deriver a -> Derive.Deriver a)
    -> Derive.Deriver a -> Derive.Deriver a
unstretch_args :: forall x a.
PassedArgs x
-> (ScoreTime -> Deriver a -> Deriver a) -> Deriver a -> Deriver a
unstretch_args PassedArgs x
args = forall a.
ScoreTime
-> ScoreTime
-> (ScoreTime -> Deriver a -> Deriver a)
-> Deriver a
-> Deriver a
unstretch (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs x
args) (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs x
args)

-- | Put the deriver at 0t and in its \"natural\" time.  This is only different
-- from its event's time if the deriver has its own duration as per
-- 'Derive.get_score_duration'.
--
-- The generator will do @Derive.place start (event_dur/dur)@, so I have to
-- undo that.
unstretch :: ScoreTime -> ScoreTime
    -> (ScoreTime -> Derive.Deriver a -> Derive.Deriver a)
    -> Derive.Deriver a -> Derive.Deriver a
unstretch :: forall a.
ScoreTime
-> ScoreTime
-> (ScoreTime -> Deriver a -> Deriver a)
-> Deriver a
-> Deriver a
unstretch ScoreTime
start ScoreTime
event_dur ScoreTime -> Deriver a -> Deriver a
process Deriver a
deriver = do
    ScoreTime
dur <- forall a.
Deriver a -> Deriver (Either Error (CallDuration ScoreTime))
Derive.get_score_duration Deriver a
deriver forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Error
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
event_dur
        Right CallDuration ScoreTime
Derive.Unknown -> forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
event_dur
        Right (Derive.CallDuration ScoreTime
dur) -> forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
dur
    ScoreTime -> Deriver a -> Deriver a
process ScoreTime
dur forall a b. (a -> b) -> a -> b
$ forall a. ScoreTime -> Deriver a -> Deriver a
flatten ScoreTime
dur Deriver a
deriver
    where
    flatten :: ScoreTime -> Deriver a -> Deriver a
flatten ScoreTime
dur = forall a. ScoreTime -> Deriver a -> Deriver a
Derive.stretch (ScoreTime
1 forall a. Fractional a => a -> a -> a
/ (ScoreTime
event_durforall a. Fractional a => a -> a -> a
/ScoreTime
dur)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ScoreTime -> Deriver a -> Deriver a
Derive.at (-ScoreTime
start)

-- | Consistent with half-open ranges, block calls try to include events lining
-- up with the start, and exclude ones lining up with the end.  Except negative
-- notes, which is usual, the same thing but backwards.
event_before :: RealTime -> Score.Event -> Bool
event_before :: RealTime -> Note -> Bool
event_before RealTime
t Note
e
    | Note -> RealTime
Score.event_duration Note
e forall a. Ord a => a -> a -> Bool
>= RealTime
0 = Note -> RealTime
Score.event_start Note
e forall a. Ord a => a -> a -> Bool
< RealTime
t forall a. Num a => a -> a -> a
- RealTime
RealTime.eta
    | Bool
otherwise = Note -> RealTime
Score.event_start Note
e forall a. Ord a => a -> a -> Bool
<= RealTime
t forall a. Num a => a -> a -> a
+ RealTime
RealTime.eta