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

{-# LANGUAGE DeriveFunctor #-}
-- | Pattern based derivation.
module Derive.C.Bali.Sekar where
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Num as Num

import qualified Derive.Args as Args
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.SubT as SubT
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.Sig as Sig

import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
    [ (Symbol
"sekar", Generator Note
c_sekar_direct)
    , (Symbol
"sekar-e", Generator Note
c_sekar_even)
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"bali" forall a. Semigroup a => a -> a -> a
<> Module
"sekar"

c_sekar_direct :: Derive.Generator Derive.Note
c_sekar_direct :: Generator Note
c_sekar_direct = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"sekar" (Tags
Tags.inst forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs)
    Doc
"Arrange sub-notes according to a pattern.\
    \\nIn the direct substitution style, each note retains its relative\
    \ duration as it is rearranged by the pattern. A rest is considered a\
    \ note, but just one note, so you can't have two rests in a row."
    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. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"pattern" (Doc
"If there is a list of patterns, they are for\
        \ different numbers of notes, starting with 1. A single pattern is\
        \ applied to all numbers though. " forall a. Semigroup a => a -> a -> a
<> Doc
pattern_doc)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
arrive_env
    ) forall a b. (a -> b) -> a -> b
$ \([Text]
pattern_text, Bool
arrive) PassedArgs Note
args -> do
        [Pattern]
patterns <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Deriver Pattern
make_pattern [Text]
pattern_text
        NonEmpty Pattern
patterns <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            [(Pattern, Text)] -> Either Text (NonEmpty Pattern)
check_patterns (forall a b. [a] -> [b] -> [(a, b)]
zip [Pattern]
patterns [Text]
pattern_text)
        let range :: (TrackTime, TrackTime)
range = forall a. PassedArgs a -> (TrackTime, TrackTime)
Args.range PassedArgs Note
args
        let derive :: [RestEvent] -> Deriver State Error (Stream Note)
derive
                | Bool
arrive = (TrackTime, TrackTime)
-> NonEmpty Pattern
-> [RestEvent]
-> Deriver State Error (Stream Note)
sekar_direct_arrive (TrackTime, TrackTime)
range NonEmpty Pattern
patterns
                | Bool
otherwise = (TrackTime, TrackTime)
-> NonEmpty Pattern
-> [RestEvent]
-> Deriver State Error (Stream Note)
sekar_direct (TrackTime, TrackTime)
range NonEmpty Pattern
patterns
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [RestEvent] -> Deriver State Error (Stream Note)
derive forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. Bool -> Bool -> PassedArgs d -> Deriver [[RestEvent]]
Sub.sub_rest_events Bool
arrive Bool
True PassedArgs Note
args

c_sekar_even :: Derive.Generator Derive.Note
c_sekar_even :: Generator Note
c_sekar_even = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"sekar" (Tags
Tags.inst forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs)
    Doc
"Arrange sub-notes according to a pattern.\
    \\nIn the even subdivision style, the range is divided evenly based\
    \ on the highest index of the pattern (so `abcac` would divide into 3\
    \ parts). The melody is sampled at those points for note attacks,\
    \ sustains, and rests, which are then rearranged by the pattern.\
    \ Thus, the output is always notes in a regular tempo determined by the\
    \ length of the pattern."
    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. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"pattern" Doc
pattern_doc
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
arrive_env
    ) forall a b. (a -> b) -> a -> b
$ \(Text
pattern, Bool
arrive) PassedArgs Note
args -> do
        Pattern
pattern <- Text -> Deriver Pattern
make_pattern Text
pattern
        let derive :: [RestEvent] -> Deriver State Error (Stream Note)
derive = Bool
-> (TrackTime, TrackTime)
-> Pattern
-> [RestEvent]
-> Deriver State Error (Stream Note)
sekar_even Bool
arrive (forall a. PassedArgs a -> (TrackTime, TrackTime)
Args.range PassedArgs Note
args) Pattern
pattern
        forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [RestEvent] -> Deriver State Error (Stream Note)
derive forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. Bool -> Bool -> PassedArgs d -> Deriver [[RestEvent]]
Sub.sub_rest_events Bool
arrive Bool
True PassedArgs Note
args

arrive_env :: Sig.Parser Bool
arrive_env :: Parser Bool
arrive_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"arrive" EnvironDefault
Sig.Prefixed Bool
True forall a b. (a -> b) -> a -> b
$
    Doc
"If true, the last note of the pattern is aligned to the end of the event,\
    \ and given " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty Flags
Flags.infer_duration forall a. Semigroup a => a -> a -> a
<> Doc
"."

pattern_doc :: Doc.Doc
pattern_doc :: Doc
pattern_doc =
    Doc
"The pattern is letters from a-z, where `a` is the first note and `z` is\
    \ the 26th. Capital letters replace that note with a rest. Gaps in the\
    \ input notes count as rest notes."

check_patterns :: [(Pattern, Text)] -> Either Text (NonEmpty Pattern)
check_patterns :: [(Pattern, Text)] -> Either Text (NonEmpty Pattern)
check_patterns [(Pattern
pattern, Text
_)] = forall a b. b -> Either a b
Right (Pattern
pattern forall a. a -> [a] -> NonEmpty a
:| [])
check_patterns [(Pattern, Text)]
patterns = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. Show a => (Index, (Pattern, a)) -> Either Text ()
check (forall a b. [a] -> [b] -> [(a, b)]
zip [Index
1..] [(Pattern, Text)]
patterns)
    case forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Pattern, Text)]
patterns) of
        Maybe (NonEmpty Pattern)
Nothing -> forall a b. a -> Either a b
Left Text
"require at least one pattern"
        Just NonEmpty Pattern
ps -> forall a b. b -> Either a b
Right NonEmpty Pattern
ps
    where
    check :: (Index, (Pattern, a)) -> Either Text ()
check (Index
n, (Pattern
pattern, a
ptext))
        | Pattern -> Index
pattern_length Pattern
pattern forall a. Eq a => a -> a -> Bool
/= Index
n = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            Text
"expected pattern of length " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Index
n forall a. Semigroup a => a -> a -> a
<> Text
" but got "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
ptext
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ** even subdivision

data DivNote a = DivNote !a | DivRest | DivContinue
    deriving (DivNote a -> DivNote a -> Bool
forall a. Eq a => DivNote a -> DivNote a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DivNote a -> DivNote a -> Bool
$c/= :: forall a. Eq a => DivNote a -> DivNote a -> Bool
== :: DivNote a -> DivNote a -> Bool
$c== :: forall a. Eq a => DivNote a -> DivNote a -> Bool
Eq, Index -> DivNote a -> ShowS
forall a. Show a => Index -> DivNote a -> ShowS
forall a. Show a => [DivNote a] -> ShowS
forall a. Show a => DivNote a -> String
forall a.
(Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DivNote a] -> ShowS
$cshowList :: forall a. Show a => [DivNote a] -> ShowS
show :: DivNote a -> String
$cshow :: forall a. Show a => DivNote a -> String
showsPrec :: Index -> DivNote a -> ShowS
$cshowsPrec :: forall a. Show a => Index -> DivNote a -> ShowS
Show, forall a b. a -> DivNote b -> DivNote a
forall a b. (a -> b) -> DivNote a -> DivNote b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DivNote b -> DivNote a
$c<$ :: forall a b. a -> DivNote b -> DivNote a
fmap :: forall a b. (a -> b) -> DivNote a -> DivNote b
$cfmap :: forall a b. (a -> b) -> DivNote a -> DivNote b
Functor)

sekar_even :: Bool -> (ScoreTime, ScoreTime) -> Pattern -> [Sub.RestEvent]
    -> Derive.NoteDeriver
sekar_even :: Bool
-> (TrackTime, TrackTime)
-> Pattern
-> [RestEvent]
-> Deriver State Error (Stream Note)
sekar_even Bool
arrive (TrackTime
start, TrackTime
end) Pattern
pattern [RestEvent]
events =
    [Event] -> Deriver State Error (Stream Note)
Sub.derive forall a b. (a -> b) -> a -> b
$ (if Bool
arrive then [Event] -> [Event]
nudge else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. TrackTime -> EventT a -> EventT a
SubT.at TrackTime
start) forall a b. (a -> b) -> a -> b
$
        forall a. TrackTime -> [DivNote a] -> Pattern -> [EventT a]
div_realize TrackTime
dur [DivNote (Deriver State Error (Stream Note))]
notes Pattern
pattern
    where
    notes :: [DivNote (Deriver State Error (Stream Note))]
notes = forall a. [EventT (Maybe a)] -> [TrackTime] -> [DivNote a]
div_extract [RestEvent]
events [TrackTime]
samples
    samples :: [TrackTime]
samples = (if Bool
arrive then forall a. Index -> [a] -> [a]
drop Index
1 else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range TrackTime
start TrackTime
end TrackTime
ndur
    ndur :: TrackTime
ndur = (TrackTime
end forall a. Num a => a -> a -> a
- TrackTime
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pattern -> Index
pattern_length Pattern
pattern)
    dur :: TrackTime
dur = (TrackTime
end forall a. Num a => a -> a -> a
- TrackTime
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Index
length Pattern
pattern)
    nudge :: [Event] -> [Event]
nudge = forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
add_last_note_flags) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. TrackTime -> EventT a -> EventT a
SubT.at TrackTime
dur)

div_realize :: ScoreTime -> [DivNote a] -> Pattern -> [SubT.EventT a]
div_realize :: forall a. TrackTime -> [DivNote a] -> Pattern -> [EventT a]
div_realize TrackTime
dur [DivNote a]
notes = forall {a}. [(TrackTime, DivNote a)] -> [EventT a]
combine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ TrackTime
0 TrackTime
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Index, Element) -> DivNote a
resolve
    where
    resolve :: (Index, Element) -> DivNote a
resolve (Index
i, Element
element) = case Element
element of
        Element
Rest -> forall a. DivNote a
DivRest
        Element
Note -> forall a. a -> Maybe a -> a
fromMaybe forall a. DivNote a
DivRest forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Index -> Maybe a
Lists.at [DivNote a]
notes Index
i
    combine :: [(TrackTime, DivNote a)] -> [EventT a]
combine ((TrackTime
start, DivNote a
note) : [(TrackTime, DivNote a)]
notes) = case DivNote a
note of
        DivNote a
DivRest -> [EventT a]
continue
        DivNote a
DivContinue -> [EventT a]
continue
        DivNote a
d -> forall a. TrackTime -> TrackTime -> a -> EventT a
SubT.EventT TrackTime
start (TrackTime
dur forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Index
cs) a
d forall a. a -> [a] -> [a]
: [EventT a]
continue
            where cs :: Index
cs = forall (t :: * -> *) a. Foldable t => t a -> Index
length (forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall {a} {a}. (a, DivNote a) -> Bool
is_continue [(TrackTime, DivNote a)]
notes) forall a. Num a => a -> a -> a
+ Index
1
        where continue :: [EventT a]
continue = [(TrackTime, DivNote a)] -> [EventT a]
combine [(TrackTime, DivNote a)]
notes
    combine [] = []
    is_continue :: (a, DivNote a) -> Bool
is_continue (a
_, DivNote a
DivContinue) = Bool
True
    is_continue (a, DivNote a)
_ = Bool
False

-- | Convert 'SubT.EventT's to DivNotes at the given times.
div_extract :: [SubT.EventT (Maybe a)] -> [ScoreTime] -> [DivNote a]
div_extract :: forall a. [EventT (Maybe a)] -> [TrackTime] -> [DivNote a]
div_extract [EventT (Maybe a)]
events = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a}.
[EventT (Maybe a)] -> TrackTime -> ([EventT (Maybe a)], DivNote a)
go [EventT (Maybe a)]
events
    where
    go :: [EventT (Maybe a)] -> TrackTime -> ([EventT (Maybe a)], DivNote a)
go [EventT (Maybe a)]
events TrackTime
t = case forall a. (a -> Bool) -> [a] -> [a]
drop_until_next (forall {a}. TrackTime -> EventT a -> Bool
past TrackTime
t) [EventT (Maybe a)]
events of
        events :: [EventT (Maybe a)]
events@(EventT (Maybe a)
event : [EventT (Maybe a)]
_) -> ([EventT (Maybe a)]
events,) forall a b. (a -> b) -> a -> b
$ case forall a. EventT a -> a
SubT._note EventT (Maybe a)
event of
            Maybe a
Nothing -> forall a. DivNote a
DivRest
            Just a
d
                | TrackTime
t TrackTime -> TrackTime -> Bool
ScoreTime.== forall a. EventT a -> TrackTime
SubT._start EventT (Maybe a)
event -> forall a. a -> DivNote a
DivNote a
d
                | TrackTime
t TrackTime -> TrackTime -> Bool
ScoreTime.> forall a. EventT a -> TrackTime
SubT.end EventT (Maybe a)
event -> forall a. DivNote a
DivRest
                | Bool
otherwise -> forall a. DivNote a
DivContinue
        [] -> ([], forall a. DivNote a
DivRest)
    past :: TrackTime -> EventT a -> Bool
past TrackTime
t = (TrackTime -> TrackTime -> Bool
ScoreTime.> TrackTime
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EventT a -> TrackTime
SubT._start

-- | Drop until the predicate is true for the next event.  This is like
-- @dropWhile (not . f)@, but you get the element before the predicate becomes
-- false.
drop_until_next :: (a -> Bool) -> [a] -> [a]
drop_until_next :: forall a. (a -> Bool) -> [a] -> [a]
drop_until_next a -> Bool
f [a]
xs = case [a]
xs of
    xs :: [a]
xs@(a
_ : a
x2 : [a]
_) | a -> Bool
f a
x2 -> [a]
xs
    [a
x] -> [a
x]
    a
_ : [a]
xs -> forall a. (a -> Bool) -> [a] -> [a]
drop_until_next a -> Bool
f [a]
xs
    [] -> []

-- ** direct substitution

-- | Like 'sekar_direct', but expect sub-events excluding the start and
-- including the end, and align the last note to the end of the call.
sekar_direct_arrive :: (ScoreTime, ScoreTime) -> NonEmpty Pattern
    -> [Sub.RestEvent] -> Derive.NoteDeriver
sekar_direct_arrive :: (TrackTime, TrackTime)
-> NonEmpty Pattern
-> [RestEvent]
-> Deriver State Error (Stream Note)
sekar_direct_arrive (TrackTime, TrackTime)
range NonEmpty Pattern
patterns [RestEvent]
events_ =
    [Event] -> Deriver State Error (Stream Note)
Sub.derive forall a b. (a -> b) -> a -> b
$ [Event] -> [Event]
add_flags forall a b. (a -> b) -> a -> b
$ forall {a}. [EventT a] -> [EventT a]
align forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. TrackTime -> EventT a -> EventT a
SubT.stretch TrackTime
factor) forall a b. (a -> b) -> a -> b
$
        [RestEvent] -> [Event]
Sub.strip_rests [RestEvent]
realized
    where
    -- The first event should be a rest, since I passed end_bias=True to
    -- Sub.sub_rest_events.  The stretch factor assumes the event durations add
    -- up to 'range'.  For that to be true, I have to give the initial rest
    -- duration to the destination note.
    events :: [RestEvent]
events = case [RestEvent]
events_ of
        [] -> []
        RestEvent
rest : [RestEvent]
events -> case forall a. [a] -> Maybe ([a], a)
Lists.unsnoc [RestEvent]
events of
            Maybe ([RestEvent], RestEvent)
Nothing -> [RestEvent]
events
            Just ([RestEvent]
initial, RestEvent
final)
                | forall a. EventT a -> TrackTime
SubT._start RestEvent
final forall a. Ord a => a -> a -> Bool
>= forall a b. (a, b) -> b
snd (TrackTime, TrackTime)
range ->
                    [RestEvent]
initial forall a. [a] -> [a] -> [a]
++ [RestEvent
final { _duration :: TrackTime
SubT._duration = TrackTime
dur }]
                | Bool
otherwise -> [RestEvent]
events forall a. [a] -> [a] -> [a]
++ [forall a. TrackTime -> TrackTime -> a -> EventT a
SubT.EventT (forall a b. (a, b) -> b
snd (TrackTime, TrackTime)
range) TrackTime
dur forall a. Maybe a
Nothing]
                where dur :: TrackTime
dur = forall a. EventT a -> TrackTime
SubT._duration RestEvent
rest

    realized :: [RestEvent]
realized = NonEmpty Pattern -> [RestEvent] -> [RestEvent]
realize_groups NonEmpty Pattern
patterns [RestEvent]
events
    factor :: TrackTime
factor = forall a. [EventT a] -> TrackTime
sum_duration [RestEvent]
events forall a. Fractional a => a -> a -> a
/ forall a. [EventT a] -> TrackTime
sum_duration [RestEvent]
realized
    -- Align notes to the end of the range.
    align :: [EventT a] -> [EventT a]
align [EventT a]
es = case forall a. [a] -> Maybe a
Lists.last [EventT a]
es of
        Maybe (EventT a)
Nothing -> []
        Just EventT a
e -> forall a b. (a -> b) -> [a] -> [b]
map (forall a. TrackTime -> EventT a -> EventT a
SubT.at (forall a b. (a, b) -> b
snd (TrackTime, TrackTime)
range forall a. Num a => a -> a -> a
- forall a. EventT a -> TrackTime
SubT._start EventT a
e)) [EventT a]
es
    add_flags :: [Event] -> [Event]
add_flags = forall a. (a -> a) -> [a] -> [a]
Lists.mapLast forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
add_last_note_flags

add_last_note_flags :: Derive.NoteDeriver -> Derive.NoteDeriver
add_last_note_flags :: Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
add_last_note_flags = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ forall a b. (a -> b) -> a -> b
$ Flags -> Note -> Note
Score.add_flags forall a b. (a -> b) -> a -> b
$
    Flags
Flags.infer_duration forall a. Semigroup a => a -> a -> a
<> Flags
Flags.strong

sum_duration :: [SubT.EventT a] -> ScoreTime
sum_duration :: forall a. [EventT a] -> TrackTime
sum_duration = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. EventT a -> TrackTime
SubT._duration

-- | Sekaran derivation via direct substitution of the sub-events.
sekar_direct :: (ScoreTime, ScoreTime) -> NonEmpty Pattern -> [Sub.RestEvent]
    -> Derive.NoteDeriver
sekar_direct :: (TrackTime, TrackTime)
-> NonEmpty Pattern
-> [RestEvent]
-> Deriver State Error (Stream Note)
sekar_direct (TrackTime, TrackTime)
range NonEmpty Pattern
patterns [RestEvent]
events =
    [Event] -> Deriver State Error (Stream Note)
Sub.derive forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. TrackTime -> TrackTime -> EventT a -> EventT a
SubT.place (forall a b. (a, b) -> a
fst (TrackTime, TrackTime)
range) TrackTime
factor) forall a b. (a -> b) -> a -> b
$ [RestEvent] -> [Event]
Sub.strip_rests [RestEvent]
realized
    where
    realized :: [RestEvent]
realized = NonEmpty Pattern -> [RestEvent] -> [RestEvent]
realize_groups NonEmpty Pattern
patterns [RestEvent]
events
    factor :: TrackTime
factor = forall a. [EventT a] -> TrackTime
sum_duration [RestEvent]
events forall a. Fractional a => a -> a -> a
/ forall a. [EventT a] -> TrackTime
sum_duration [RestEvent]
realized

realize_groups :: NonEmpty Pattern -> [Sub.RestEvent] -> [Sub.RestEvent]
realize_groups :: NonEmpty Pattern -> [RestEvent] -> [RestEvent]
realize_groups NonEmpty Pattern
_ [] = []
realize_groups NonEmpty Pattern
patterns events :: [RestEvent]
events@(RestEvent
event:[RestEvent]
rest) =
    TrackTime -> [[RestEvent]] -> [RestEvent]
go (forall a. EventT a -> TrackTime
SubT._start RestEvent
event) forall a b. (a -> b) -> a -> b
$ forall a. Index -> [a] -> [[a]]
split_groups (Pattern -> Index
pattern_length Pattern
pattern) [RestEvent]
events
    where
    pattern :: Pattern
pattern = forall a b. NonEmpty a -> NonEmpty b -> b
index_with (RestEvent
event forall a. a -> [a] -> NonEmpty a
:| [RestEvent]
rest) NonEmpty Pattern
patterns
    go :: TrackTime -> [[RestEvent]] -> [RestEvent]
go TrackTime
_ [] = []
    go TrackTime
start ([RestEvent]
group : [[RestEvent]]
groups) = [RestEvent]
notes forall a. [a] -> [a] -> [a]
++ TrackTime -> [[RestEvent]] -> [RestEvent]
go (TrackTime
start forall a. Num a => a -> a -> a
+ forall a. [EventT a] -> TrackTime
sum_duration [RestEvent]
notes) [[RestEvent]]
groups
        where notes :: [RestEvent]
notes = TrackTime -> [RestEvent] -> Pattern -> [RestEvent]
realize TrackTime
start [RestEvent]
group Pattern
pattern

index_with :: NonEmpty a -> NonEmpty b -> b
index_with :: forall a b. NonEmpty a -> NonEmpty b -> b
index_with (a
x :| [a]
xs) (b
y :| [b]
ys) = forall {t} {t}. t -> [t] -> t -> [t] -> t
go a
x [a]
xs b
y [b]
ys
    where
    go :: t -> [t] -> t -> [t] -> t
go t
_ (t
x:[t]
xs) t
_ (t
y:[t]
ys) = t -> [t] -> t -> [t] -> t
go t
x [t]
xs t
y [t]
ys
    go t
_ [] t
y [t]
_ = t
y
    go t
_ [t]
_ t
y [] = t
y

split_groups :: Int -> [a] -> [[a]]
split_groups :: forall a. Index -> [a] -> [[a]]
split_groups Index
n [a]
notes = case forall a. Index -> [a] -> ([a], [a])
splitAt Index
n [a]
notes of
    ([], [a]
_) -> []
    ([a]
pre, [a]
post) -> [a]
pre forall a. a -> [a] -> [a]
: forall a. Index -> [a] -> [[a]]
split_groups Index
n [a]
post

type Pattern = [(Index, Element)]
-- | Index into melody notes.
type Index = Int
data Element = Note | Rest deriving (Index -> Element -> ShowS
[Element] -> ShowS
Element -> String
forall a.
(Index -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Element] -> ShowS
$cshowList :: [Element] -> ShowS
show :: Element -> String
$cshow :: Element -> String
showsPrec :: Index -> Element -> ShowS
$cshowsPrec :: Index -> Element -> ShowS
Show)

pattern_length :: Pattern -> Int
pattern_length :: Pattern -> Index
pattern_length = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Index
0:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
+Index
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

make_pattern :: Text -> Derive.Deriver Pattern
make_pattern :: Text -> Deriver Pattern
make_pattern Text
pattern = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
Text.null Text
pattern Bool -> Bool -> Bool
|| (Char -> Bool) -> Text -> Bool
Text.any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
a_to_z forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
Char.toLower) Text
pattern) forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"pattern chars must be a-z: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
pattern
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (forall a. Enum a => a -> Index
fromEnum (Char -> Char
Char.toLower Char
c) forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Index
fromEnum Char
'a',
            if Char -> Bool
Char.isUpper Char
c then Element
Rest else Element
Note)
        | Char
c <- Text -> String
Text.unpack Text
pattern
        ]
    where a_to_z :: Char -> Bool
a_to_z Char
c = Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z'

-- | Apply the pattern to the events.
realize :: ScoreTime -> [Sub.RestEvent] -> Pattern -> [Sub.RestEvent]
realize :: TrackTime -> [RestEvent] -> Pattern -> [RestEvent]
realize TrackTime
start [RestEvent]
events = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (TrackTime, (TrackTime, a)) -> EventT a
place forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. [(TrackTime, b)] -> [(TrackTime, (TrackTime, b))]
add_starts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Index, Element)
-> Maybe (TrackTime, Maybe (Deriver State Error (Stream Note)))
resolve
    where
    resolve :: (Index, Element)
-> Maybe (TrackTime, Maybe (Deriver State Error (Stream Note)))
resolve (Index
i, Element
element) = forall {a}. Element -> EventT (Maybe a) -> (TrackTime, Maybe a)
resolve1 Element
element forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Index -> Maybe a
Lists.at [RestEvent]
events Index
i
    -- Rests have a duration, but no deriver.
    resolve1 :: Element -> EventT (Maybe a) -> (TrackTime, Maybe a)
resolve1 Element
element (SubT.EventT TrackTime
_ TrackTime
dur Maybe a
d) = case Maybe a
d of
        Maybe a
Nothing -> (TrackTime
dur, forall a. Maybe a
Nothing)
        Just a
deriver -> (,) TrackTime
dur forall a b. (a -> b) -> a -> b
$ case Element
element of
            Element
Note -> forall a. a -> Maybe a
Just a
deriver
            Element
Rest -> forall a. Maybe a
Nothing
    add_starts :: [(TrackTime, b)] -> [(TrackTime, (TrackTime, b))]
add_starts [(TrackTime, b)]
events = forall a b. [a] -> [b] -> [(a, b)]
zip (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) TrackTime
start (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TrackTime, b)]
events)) [(TrackTime, b)]
events
    place :: (TrackTime, (TrackTime, a)) -> EventT a
place (TrackTime
start, (TrackTime
dur, a
maybe_deriver)) = forall a. TrackTime -> TrackTime -> a -> EventT a
SubT.EventT TrackTime
start TrackTime
dur a
maybe_deriver