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

-- | Utilities for the mridangam-specific DSL.  Sister to
-- "Solkattu.Dsl.Notation", this is like "Solkattu.Dsl.Mridangam", but with
-- more complicated implementations, and without the annoying overidden (.).
module Solkattu.Dsl.MridangamNotation (
    merge
    , makeNote1, makeNote
) where
import qualified Util.CallStack as CallStack
import qualified Util.Lists as Lists
import qualified Solkattu.Dsl.Notation as Notation
import qualified Solkattu.Instrument.Mridangam as Mridangam
import qualified Solkattu.Realize as Realize
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu

import Global


type NoteT sollu = S.Note Solkattu.Group (Solkattu.Note sollu)
type Stroke = Realize.Stroke Mridangam.Stroke

-- | This is the implementation for the (&) operator.
merge :: CallStack.Stack => [NoteT Stroke] -> [NoteT Stroke] -> [NoteT Stroke]
merge :: Stack => [NoteT Stroke] -> [NoteT Stroke] -> [NoteT Stroke]
merge [NoteT Stroke]
as [NoteT Stroke]
bs = case ([NoteT Stroke]
as, [NoteT Stroke]
bs) of
    ([S.Note (Solkattu.Note NoteT Stroke
a)], [NoteT Stroke]
bs) -> Stroke -> [NoteT Stroke] -> [NoteT Stroke]
single (forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT Stroke
a) [NoteT Stroke]
bs
    ([NoteT Stroke]
as, [S.Note (Solkattu.Note NoteT Stroke
b)]) -> Stroke -> [NoteT Stroke] -> [NoteT Stroke]
single (forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT Stroke
b) [NoteT Stroke]
as
    ([NoteT Stroke], [NoteT Stroke])
_ -> forall g a. Sequence g a -> [Note g a]
S.toList forall a b. (a -> b) -> a -> b
$ forall g sollu. Speed -> Sequence g sollu -> Sequence g sollu
Notation.speed Speed
maxSpeed forall a b. (a -> b) -> a -> b
$ forall g a. [Note g a] -> Sequence g a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {g}.
Pretty g =>
Paired (Note g (Note Stroke)) (Note g (Note Stroke))
-> Note g (Note Stroke)
merge1 [Paired (NoteT Stroke) (NoteT Stroke)]
pairs
    where
    -- As a special case, if I'm merging a single stroke with a sequence,
    -- retain the structure of the sequence.  This way it won't destroy a
    -- group to modify the first stroke.
    single :: Stroke -> [NoteT Stroke] -> [NoteT Stroke]
    single :: Stroke -> [NoteT Stroke] -> [NoteT Stroke]
single Stroke
stroke [] = [forall stroke g. stroke -> Note g (Note stroke)
makeNote1 Stroke
stroke]
    single Stroke
stroke (NoteT Stroke
a:[NoteT Stroke]
as) = (forall a. a -> [a] -> [a]
:[NoteT Stroke]
as) forall a b. (a -> b) -> a -> b
$ case NoteT Stroke
a of
        S.Note (Solkattu.Note NoteT Stroke
n) ->
            forall stroke g. stroke -> Note g (Note stroke)
makeNote1 forall a b. (a -> b) -> a -> b
$ Stack => Stroke -> Stroke -> Stroke
Mridangam.bothRStrokes Stroke
stroke (forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT Stroke
n)
        S.Note (Solkattu.Space Space
_) -> forall stroke g. stroke -> Note g (Note stroke)
makeNote1 Stroke
stroke
        S.Note Note Stroke
n -> forall a. Stack => Text -> a
Solkattu.throw forall a b. (a -> b) -> a -> b
$ Text
"can't merge with " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note Stroke
n
        S.TempoChange TempoChange
change [NoteT Stroke]
subs -> forall g a. TempoChange -> [Note g a] -> Note g a
S.TempoChange TempoChange
change (Stroke -> [NoteT Stroke] -> [NoteT Stroke]
single Stroke
stroke [NoteT Stroke]
subs)
        S.Group Group
g [NoteT Stroke]
subs -> forall g a. g -> [Note g a] -> Note g a
S.Group Group
g (Stroke -> [NoteT Stroke] -> [NoteT Stroke]
single Stroke
stroke [NoteT Stroke]
subs)

    -- At this point TempoChanges and Groups should have been flattened away.
    merge1 :: Paired (Note g (Note Stroke)) (Note g (Note Stroke))
-> Note g (Note Stroke)
merge1 (Lists.First Note g (Note Stroke)
a) = Note g (Note Stroke)
a
    merge1 (Lists.Second Note g (Note Stroke)
b) = Note g (Note Stroke)
b
    merge1 (Lists.Both Note g (Note Stroke)
a Note g (Note Stroke)
b)
        | forall {g} {sollu}. Note g (Note sollu) -> Bool
isRest Note g (Note Stroke)
a = Note g (Note Stroke)
b
        | forall {g} {sollu}. Note g (Note sollu) -> Bool
isRest Note g (Note Stroke)
b = Note g (Note Stroke)
a
        | Bool
otherwise = forall stroke g. stroke -> Note g (Note stroke)
makeNote1 forall a b. (a -> b) -> a -> b
$
            Stack => Stroke -> Stroke -> Stroke
Mridangam.bothRStrokes (forall a g. (Stack, Pretty a, Pretty g) => Note g (Note a) -> a
toStroke1 Note g (Note Stroke)
a) (forall a g. (Stack, Pretty a, Pretty g) => Note g (Note a) -> a
toStroke1 Note g (Note Stroke)
b)
    isRest :: Note g (Note sollu) -> Bool
isRest (S.Note (Solkattu.Space Space
Solkattu.Rest)) = Bool
True
    isRest Note g (Note sollu)
_ = Bool
False
    pairs :: [Paired (NoteT Stroke) (NoteT Stroke)]
pairs = forall a b. [a] -> [b] -> [Paired a b]
Lists.zipPadded (Stack => [NoteT Stroke] -> [NoteT Stroke]
flatten [NoteT Stroke]
as) (Stack => [NoteT Stroke] -> [NoteT Stroke]
flatten [NoteT Stroke]
bs)
    flatten :: CallStack.Stack => [NoteT Stroke] -> [NoteT Stroke]
    flatten :: Stack => [NoteT Stroke] -> [NoteT Stroke]
flatten = forall a. Stack => Either Text a -> a
Solkattu.check
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. Pretty a => Stroke (Note a) -> Either Text (Note a)
unstroke) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a g.
HasMatras a =>
Speed -> [Note g a] -> Either Text [Note g (Stroke a)]
S.flattenSpeed Speed
maxSpeed)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g a x. [Note g a] -> [Note x a]
stripGroups
    maxSpeed :: Speed
maxSpeed = forall a. Ord a => a -> a -> a
max (forall g a. [Flat g a] -> Speed
S.maxSpeed (forall g a. [Note g a] -> [Flat g a]
S.flatten [NoteT Stroke]
as)) (forall g a. [Flat g a] -> Speed
S.maxSpeed (forall g a. [Note g a] -> [Flat g a]
S.flatten [NoteT Stroke]
bs))

-- | 'S.flattenSpeed' gives me 'S.Stroke's, so turn them back into notes and
-- rests.  It's an error to see 'S.Sustain', because that means I'm trying to
-- merge sustained notation, e.g. patterns.
unstroke :: Pretty a => S.Stroke (Solkattu.Note a)
    -> Either Text (Solkattu.Note a)
unstroke :: forall a. Pretty a => Stroke (Note a) -> Either Text (Note a)
unstroke = \case
    S.Attack Note a
a -> forall a b. b -> Either a b
Right Note a
a
    Stroke (Note a)
S.Rest -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall sollu. Space -> Note sollu
Solkattu.Space Space
Solkattu.Rest
    S.Sustain space :: Note a
space@(Solkattu.Space Space
_) -> forall a b. b -> Either a b
Right Note a
space
    S.Sustain Note a
a -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"can't merge with pattern: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note a
a

toStroke1 :: (CallStack.Stack, Pretty a, Pretty g) =>
    S.Note g (Solkattu.Note a) -> a
toStroke1 :: forall a g. (Stack, Pretty a, Pretty g) => Note g (Note a) -> a
toStroke1 (S.Note (Solkattu.Note NoteT a
note)) = forall sollu. NoteT sollu -> sollu
Solkattu._sollu NoteT a
note
toStroke1 Note g (Note a)
note = forall a. Stack => Text -> a
Solkattu.throw forall a b. (a -> b) -> a -> b
$ Text
"expected sollu, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note g (Note a)
note

stripGroups :: [S.Note g a] -> [S.Note x a]
stripGroups :: forall g a x. [Note g a] -> [Note x a]
stripGroups = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {g} {a} {g}. Note g a -> [Note g a]
strip
    where
    strip :: Note g a -> [Note g a]
strip = \case
        S.Note a
a -> [forall g a. a -> Note g a
S.Note a
a]
        S.TempoChange TempoChange
change [Note g a]
subs ->
            [forall g a. TempoChange -> [Note g a] -> Note g a
S.TempoChange TempoChange
change (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Note g a -> [Note g a]
strip [Note g a]
subs)]
        S.Group g
_ [Note g a]
subs -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Note g a -> [Note g a]
strip [Note g a]
subs

-- * util

makeNote1 :: stroke -> S.Note g (Solkattu.Note stroke)
makeNote1 :: forall stroke g. stroke -> Note g (Note stroke)
makeNote1 stroke
stroke = forall g a. a -> Note g a
S.Note forall a b. (a -> b) -> a -> b
$ forall sollu. NoteT sollu -> Note sollu
Solkattu.Note forall a b. (a -> b) -> a -> b
$ forall sollu. sollu -> NoteT sollu
Solkattu.note stroke
stroke

makeNote :: stroke -> [S.Note g (Solkattu.Note stroke)]
makeNote :: forall stroke g. stroke -> [Note g (Note stroke)]
makeNote stroke
stroke = [forall stroke g. stroke -> Note g (Note stroke)
makeNote1 stroke
stroke]