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

-- | Calls for randomized scores.
module Derive.C.Prelude.Random where
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Log as Log

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream

import qualified Ui.Meter.Meter as Meter

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ (forall d. CallableExpr d => [(Symbol, Generator d)]) -> Library
Library.poly_generators
        [ (Symbol
"alt", forall d. CallableExpr d => Generator d
c_alternate)
        , (Symbol
"alt-w", forall d. CallableExpr d => Generator d
c_alternate_weighted)
        ]
    , (forall d. CallableExpr d => [(Symbol, Transformer d)]) -> Library
Library.poly_transformers
        [ (Symbol
"omit", forall d. CallableExpr d => Transformer d
c_omit)
        , (Symbol
"log-seed", forall d. CallableExpr d => Transformer d
c_log_seed)
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"alt-t", Generator Event
c_alternate_tracks)
        , (Symbol
"t-alt", Generator Event
c_tempo_alternate)
        , (Symbol
"t-alt-c", Generator Event
c_tempo_alternate_continuous)
        ]
    , [(Symbol, ValCall)] -> Library
Library.vals
        [ (Symbol
"alt", ValCall
c_val_alternate) -- or ?
        , (Symbol
"alt-w", ValCall
c_val_alternate_weighted)
        , (Symbol
"range", ValCall
c_range) -- or -?
        ]
    ]

c_omit :: Derive.CallableExpr d => Derive.Transformer d
c_omit :: forall d. CallableExpr d => Transformer d
c_omit = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"omit" Tags
Tags.random
    Doc
"Omit the derived call a certain percentage of the time."
    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
"chance" (Double
0.5 :: Double)
        Doc
"Chance, from 0 to 1, that the transformed note will be omitted."
    ) forall a b. (a -> b) -> a -> b
$ \Double
omit PassedArgs d
_args Deriver (Stream d)
deriver ->
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Double -> Deriver Bool
Call.chance Double
omit) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty) Deriver (Stream d)
deriver

c_log_seed :: Derive.CallableExpr d => Derive.Transformer d
c_log_seed :: forall d. CallableExpr d => Transformer d
c_log_seed = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"log-seed" forall a. Monoid a => a
mempty
    Doc
"Emit a log message with the seed at this point. If you like how a\
    \ generator realized, and want to freeze it, then you can use this to\
    \ get the seed, and then hardcode it with `seed=xyz`."
    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 d
_args Deriver (Stream d)
deriver -> do
        Int
seed <- forall a. a -> Maybe a -> a
fromMaybe Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.seed
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"log-seed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Int
seed :: Int)
        Deriver (Stream d)
deriver

c_alternate :: Derive.CallableExpr d => Derive.Generator d
c_alternate :: forall d. CallableExpr d => Generator d
c_alternate = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"alternate" Tags
Tags.random
    Doc
"Pick one of several expressions and evaluate it."
    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 (forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"expr" Doc
"Expression to evaluate.") forall a b. (a -> b) -> a -> b
$
    \NonEmpty Quoted
exprs PassedArgs d
args -> do
        Quoted
quoted <- forall a. NonEmpty a -> Double -> a
Call.pick NonEmpty Quoted
exprs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => Deriver a
Call.random
        forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) Quoted
quoted

c_alternate_weighted :: Derive.CallableExpr d => Derive.Generator d
c_alternate_weighted :: forall d. CallableExpr d => Generator d
c_alternate_weighted =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"alternate-weighted" Tags
Tags.random
    Doc
"Pick one of several expressions and evaluate it."
    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 (forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser (NonEmpty (a, b))
Sig.many1_pairs ArgName
"expr" Doc
"(weight, expr) pairs.") forall a b. (a -> b) -> a -> b
$
    \NonEmpty (Double, Quoted)
pairs PassedArgs d
args ->
        forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs d
args) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty (Double, a) -> Double -> a
Call.pick_weighted NonEmpty (Double, Quoted)
pairs
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Random a => Deriver a
Call.random

c_alternate_tracks :: Derive.Generator Derive.Note
c_alternate_tracks :: Generator Event
c_alternate_tracks = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"alternate-tracks"
    (Tags
Tags.random forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs) Doc
"Evaluate notes from one of the sub-tracks."
    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
    (forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"weight" Doc
"Likelihood to choose each child track. Each number is\
        \ a relative weight, and tracks without a number default to 1. It's\
        \ an error to have more numbers than tracks.") forall a b. (a -> b) -> a -> b
$
    \[Double]
weights PassedArgs Event
args -> do
        [[Event]]
subs <- forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Event
args
        let err :: Text
err =  Text
"more weights than tracks: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
weights)
                forall a. Semigroup a => a -> a -> a
<> Text
" > " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Event]]
subs) forall a. Semigroup a => a -> a -> a
<> Text
" tracks"
        [(Double, [Event])]
sub_weights <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a} {b}.
Num a =>
Text -> Paired a b -> Deriver State Error (a, b)
pair Text
err) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [Paired a b]
Lists.zipPadded [Double]
weights [[Event]]
subs
        case forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [(Double, [Event])]
sub_weights of
            Maybe (NonEmpty (Double, [Event]))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
            Just NonEmpty (Double, [Event])
sub_weights ->
                [Event] -> Deriver (Stream Event)
Sub.derive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty (Double, a) -> Double -> a
Call.pick_weighted NonEmpty (Double, [Event])
sub_weights forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Random a => Deriver a
Call.random
    where
    pair :: Text -> Paired a b -> Deriver State Error (a, b)
pair Text
_ (Lists.Both a
weight b
sub) = forall (m :: * -> *) a. Monad m => a -> m a
return (a
weight, b
sub)
    pair Text
err (Lists.First a
_) = forall a. Stack => Text -> Deriver a
Derive.throw Text
err
    pair Text
_ (Lists.Second b
sub) = forall (m :: * -> *) a. Monad m => a -> m a
return (a
1, b
sub)

-- TODO This doesn't really belong in here since it's not random.  Also not in
-- NoteTransformer since it's not a transformer.  Maybe all this stuff should
-- move to an Alternate module?
c_tempo_alternate :: Derive.Generator Derive.Note
c_tempo_alternate :: Generator Event
c_tempo_alternate = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"tempo-alternate"
    forall a. Monoid a => a
mempty Doc
tempo_alternate_doc 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 ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Quoted, [(RealTime, Quoted)])
breakpoints_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"timestep" EnvironDefault
Sig.Prefixed Rank
Meter.E
        Doc
"Use the duration of this timestep, in seconds."
    ) forall a b. (a -> b) -> a -> b
$ \((Quoted
bottom, [(RealTime, Quoted)]
pairs), Rank
timestep) PassedArgs Event
args -> do
        RealTime
dur <- forall a. Time a => a -> Deriver State Error RealTime
Derive.real forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Rank -> Int -> Deriver ScoreTime
Call.meter_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Event
args) Rank
timestep Int
1
        forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs Event
args) forall a b. (a -> b) -> a -> b
$ forall key val. Ord key => val -> [(key, val)] -> key -> val
under_threshold Quoted
bottom [(RealTime, Quoted)]
pairs RealTime
dur

under_threshold :: Ord key => val -> [(key, val)] -> key -> val
under_threshold :: forall key val. Ord key => val -> [(key, val)] -> key -> val
under_threshold val
bottom ((key
threshold, val
expr) : [(key, val)]
rest) key
dur
    | key
dur forall a. Ord a => a -> a -> Bool
< key
threshold = val
bottom
    | Bool
otherwise = forall key val. Ord key => val -> [(key, val)] -> key -> val
under_threshold val
expr [(key, val)]
rest key
dur
under_threshold val
bottom [] key
_ = val
bottom

tempo_alternate_doc :: Doc.Doc
tempo_alternate_doc :: Doc
tempo_alternate_doc =
    Doc
"Derive alternate calls depending on the tempo, for Javanese-style wirama\
    \ transitions. For instance, `a 1/8 b 1/4 c` will play `a` when an 8th\
    \ note is between 0 and 1/8s, `b` when it's between 1/8s and 1/4s, and\
    \ `c` when it's above 1/4s."

c_tempo_alternate_continuous :: Derive.Generator Derive.Note
c_tempo_alternate_continuous :: Generator Event
c_tempo_alternate_continuous =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"tempo-alternate-continuous" forall a. Monoid a => a
mempty
        (Doc
tempo_alternate_doc forall a. Semigroup a => a -> a -> a
<> Doc
"\nThis variant will\
        \ switch between the alternates even in the middle of the call.\
        \ Long notes will be clipped at the transition point.")
    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 ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Quoted, [(RealTime, Quoted)])
breakpoints_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"timestep" EnvironDefault
Sig.Prefixed Rank
Meter.E
        Doc
"Use the duration of this timestep, in seconds."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"interval" EnvironDefault
Sig.Prefixed Rank
Meter.Q
        Doc
"Switch between alternates at this time interval."
    ) forall a b. (a -> b) -> a -> b
$ \((Quoted
bottom, [(RealTime, Quoted)]
pairs), Rank
timestep, Rank
interval) PassedArgs Event
args ->
        Quoted
-> [(RealTime, Quoted)]
-> Rank
-> Rank
-> Generator Event (Stream Event)
tempo_alternate_continuous Quoted
bottom [(RealTime, Quoted)]
pairs Rank
timestep Rank
interval PassedArgs Event
args

breakpoints_arg :: Sig.Parser (DeriveT.Quoted, [(RealTime, DeriveT.Quoted)])
breakpoints_arg :: Parser (Quoted, [(RealTime, Quoted)])
breakpoints_arg = forall a. (a -> Maybe Text) -> Parser a -> Parser a
Sig.check forall {b} {a} {b}.
(Ord b, Pretty b) =>
(a, [(b, b)]) -> Maybe Text
check forall a b. (a -> b) -> a -> b
$ (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"bottom" EnvironDefault
Sig.None Doc
"Default alternate."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser [(a, b)]
Sig.many_pairs ArgName
"threshold,expr"
        Doc
"Evaluate the expr if the tempo is above the threshold.\
        \ The thresholds should be in ascending order, so the fastest alternate\
        \ is at the left."
    where
    check :: (a, [(b, b)]) -> Maybe Text
check (a
_, [(b, b)]
pairs)
        | forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(b, b)]
pairs forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
List.sort (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(b, b)]
pairs) = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"thresholds should be in ascending order: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(b, b)]
pairs)

tempo_alternate_continuous :: DeriveT.Quoted -> [(RealTime, DeriveT.Quoted)]
    -> Meter.Rank -> Meter.Rank -> Derive.NoteArgs -> Derive.NoteDeriver
tempo_alternate_continuous :: Quoted
-> [(RealTime, Quoted)]
-> Rank
-> Rank
-> Generator Event (Stream Event)
tempo_alternate_continuous Quoted
bottom [(RealTime, Quoted)]
pairs Rank
timestep Rank
interval PassedArgs Event
args = do
    ScoreTime
interval <- ScoreTime -> Rank -> Int -> Deriver ScoreTime
Call.meter_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Event
args) Rank
interval Int
1
    let starts :: [ScoreTime]
starts = forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Event
args) (forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs Event
args) ScoreTime
interval
    [Int]
indices <- [ScoreTime] -> Rank -> [RealTime] -> Deriver [Int]
alternate_indices [ScoreTime]
starts Rank
timestep (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(RealTime, Quoted)]
pairs)
    let ([Quoted]
alts, [Int]
alt_indices) = forall a. [a] -> [Int] -> ([a], [Int])
select_indices (Quoted
bottom forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RealTime, Quoted)]
pairs) [Int]
indices
    [Stream Event]
alts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall a. PassedArgs a -> Context a
Args.context PassedArgs Event
args)) [Quoted]
alts
    [RealTime]
real_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 State Error RealTime
Derive.real [ScoreTime]
starts
    let breakpoints :: [(RealTime, Int)]
breakpoints = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a b. (a, b) -> b
snd (forall a b. [a] -> [b] -> [(a, b)]
zip [RealTime]
real_starts [Int]
alt_indices)
    -- Debug.tracepM "breakpoints" (starts, zip real_starts alt_indices)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [(RealTime, Int)]
breakpoints of
        -- Optimize a single breakpoint at the start.
        [(RealTime
t, Int
i)] | [RealTime
t] forall a. Eq a => a -> a -> Bool
== forall a. Int -> [a] -> [a]
take Int
1 [RealTime]
real_starts -> [Stream Event]
alts forall a. [a] -> Int -> a
!! Int
i
        [(RealTime, Int)]
_ -> [Stream Event] -> [(RealTime, Int)] -> Stream Event
switch [Stream Event]
alts [(RealTime, Int)]
breakpoints

-- | Switch between note streams when the index changes.  Sounding notes
-- will be clipped, and dropped if they wind up at duration 0.
switch :: [Stream.Stream Score.Event] -> [(RealTime, Int)]
    -> Stream.Stream Score.Event
switch :: [Stream Event] -> [(RealTime, Int)] -> Stream Event
switch [] [(RealTime, Int)]
_ = forall a. Monoid a => a
mempty
switch [Stream Event]
streams [(RealTime, Int)]
bps = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap forall {b}. ((RealTime, Int), Maybe (RealTime, b)) -> Stream Event
select (forall a. [a] -> [(a, Maybe a)]
Lists.zipNext [(RealTime, Int)]
bps)
    where
    -- This is a little bit inefficient because it scans from the beginning of
    -- each stream, but the number of events and streams is likely small.
    select :: ((RealTime, Int), Maybe (RealTime, b)) -> Stream Event
select ((RealTime
t, Int
i), Maybe (RealTime, b)
next) = case Maybe (RealTime, b)
next of
        Maybe (RealTime, b)
Nothing -> forall a. (a -> Bool) -> Stream a -> Stream a
Stream.drop_while ((forall a. Ord a => a -> a -> Bool
<RealTime
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start) ([Stream Event]
streams forall a. [a] -> Int -> a
!! Int
i)
        Just (RealTime
next_t, b
_) -> RealTime -> RealTime -> Stream Event -> Stream Event
extrect RealTime
t RealTime
next_t ([Stream Event]
streams forall a. [a] -> Int -> a
!! Int
i)
    extrect :: RealTime -> RealTime -> Stream Event -> Stream Event
extrect RealTime
start RealTime
end =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> Event -> Event
clip RealTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Stream a -> Stream a
Stream.take_while ((forall a. Ord a => a -> a -> Bool
<RealTime
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Stream a -> Stream a
Stream.drop_while ((forall a. Ord a => a -> a -> Bool
<RealTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
Score.event_start)
    clip :: RealTime -> Event -> Event
clip RealTime
end Event
event
        | Event -> RealTime
Score.event_end Event
event forall a. Ord a => a -> a -> Bool
<= RealTime
end = Event
event
        | Bool
otherwise =
            RealTime -> Event -> Event
Score.set_duration (forall a. Ord a => a -> a -> a
max RealTime
0 (RealTime
end forall a. Num a => a -> a -> a
- Event -> RealTime
Score.event_start Event
event)) Event
event

alternate_indices :: [ScoreTime] -> Meter.Rank -> [RealTime]
    -> Derive.Deriver [Int]
    -- ^ time to switch to which index
alternate_indices :: [ScoreTime] -> Rank -> [RealTime] -> Deriver [Int]
alternate_indices [ScoreTime]
starts Rank
timestep [RealTime]
thresholds = do
    -- reals <- mapM Derive.real starts
    -- Debug.tracepM "reals" (zip starts reals)
    -- Get tempo at each start, in the duration of the timestep at each start.
    [RealTime]
durs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rank -> ScoreTime -> Deriver State Error RealTime
timestep_dur_at Rank
timestep) [ScoreTime]
starts
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ -- Debug.trace_retp "alt_indices" (thresholds, zip starts durs) $
        forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => [a] -> a -> Int
index_under_threshold [RealTime]
thresholds) [RealTime]
durs

timestep_dur_at :: Meter.Rank -> ScoreTime -> Derive.Deriver RealTime
timestep_dur_at :: Rank -> ScoreTime -> Deriver State Error RealTime
timestep_dur_at Rank
timestep ScoreTime
p = do
    forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error RealTime
Call.real_duration ScoreTime
p forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Rank -> Int -> Deriver ScoreTime
Call.meter_duration ScoreTime
p Rank
timestep Int
1

-- | Select the given indices from the list, and return a list with just the
-- indexed elements, and the original indices packed so they index into the
-- dense list.
select_indices :: [a] -> [Int] -> ([a], [Int])
select_indices :: forall a. [a] -> [Int] -> ([a], [Int])
select_indices [a]
xs [Int]
is = (forall a b. (a -> b) -> [a] -> [b]
map ([a]
xs!!) [Int]
unique, forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
pack [Int]
is)
    where
    unique :: [Int]
unique = forall a. Ord a => [a] -> [a]
Lists.uniqueSort [Int]
is
    pack :: Int -> Int
pack Int
i = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Int
i [Int]
unique

index_under_threshold :: Ord a => [a] -> a -> Int
index_under_threshold :: forall a. Ord a => [a] -> a -> Int
index_under_threshold [a]
ts a
val = forall {t}. Num t => t -> [a] -> t
go Int
0 [a]
ts
    where
    go :: t -> [a] -> t
go t
i (a
t:[a]
ts)
        | a
val forall a. Ord a => a -> a -> Bool
<= a
t = t
i
        | Bool
otherwise = t -> [a] -> t
go (t
iforall a. Num a => a -> a -> a
+t
1) [a]
ts
    go t
i [] = t
i

-- * val calls

c_val_alternate :: Derive.ValCall
c_val_alternate :: ValCall
c_val_alternate = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude CallName
"alternate" Tags
Tags.random
    Doc
"Pick one of the arguments randomly."
    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 (forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"val" Doc
"Value of any type.") forall a b. (a -> b) -> a -> b
$ \NonEmpty Val
vals PassedArgs Tagged
_ ->
        forall a. NonEmpty a -> Double -> a
Call.pick (NonEmpty Val
vals :: NonEmpty DeriveT.Val) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => Deriver a
Call.random

c_val_alternate_weighted :: Derive.ValCall
c_val_alternate_weighted :: ValCall
c_val_alternate_weighted = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude CallName
"alternate-weighted"
    Tags
Tags.random Doc
"Pick one of the arguments randomly."
    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 (forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser (NonEmpty (a, b))
Sig.many1_pairs ArgName
"val" Doc
"(weight, val) pairs.") forall a b. (a -> b) -> a -> b
$
    \NonEmpty (Double, Val)
pairs PassedArgs Tagged
_args -> do
        let vals :: NonEmpty DeriveT.Val
            (NonEmpty Double
weights, NonEmpty Val
vals) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NonEmpty.unzip NonEmpty (Double, Val)
pairs
        forall a. NonEmpty (Double, a) -> Double -> a
Call.pick_weighted (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NonEmpty.zip NonEmpty Double
weights NonEmpty Val
vals) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => Deriver a
Call.random

c_range :: Derive.ValCall
c_range :: ValCall
c_range = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude CallName
"range" Tags
Tags.random
    Doc
"Pick a random number within a range." 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 ((,)
    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
"low" (Int
0 :: Int) Doc
"Bottom of range, inclusive."
    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
"high" (Int
1 :: Int) Doc
"Top of range, inclusive."
    ) forall a b. (a -> b) -> a -> b
$ \(Double
low, Double
high) PassedArgs Tagged
_args -> forall a. (Random a, Real a) => a -> a -> Deriver a
Call.random_in Double
low Double
high :: Derive.Deriver Double