-- Copyright 2017 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 RecordWildCards, DeriveFunctor #-}
-- | Realize abstract solkattu Notes to sa-relative notes.
module Solkattu.Instrument.Sargam where
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Derive.Expr as Expr
import qualified Derive.ShowVal as ShowVal
import qualified Solkattu.Instrument.ToScore as ToScore
import qualified Solkattu.Realize as Realize
import qualified Solkattu.S as S
import qualified Solkattu.Solkattu as Solkattu

import qualified Perform.Pitch as Pitch
import Global


type SequenceM g = S.Sequence g (Solkattu.Note (Realize.Stroke Stroke))

newtype Attributes = Attributes (Map Text (Maybe Text))
    deriving (PitchClass -> Attributes -> ShowS
[Attributes] -> ShowS
Attributes -> String
(PitchClass -> Attributes -> ShowS)
-> (Attributes -> String)
-> ([Attributes] -> ShowS)
-> Show Attributes
forall a.
(PitchClass -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attributes] -> ShowS
$cshowList :: [Attributes] -> ShowS
show :: Attributes -> String
$cshow :: Attributes -> String
showsPrec :: PitchClass -> Attributes -> ShowS
$cshowsPrec :: PitchClass -> Attributes -> ShowS
Show, Attributes -> Attributes -> Bool
(Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Bool) -> Eq Attributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attributes -> Attributes -> Bool
$c/= :: Attributes -> Attributes -> Bool
== :: Attributes -> Attributes -> Bool
$c== :: Attributes -> Attributes -> Bool
Eq)

data Stroke = Stroke {
    Stroke -> Pitch
_pitch :: !Pitch.Pitch
    -- | These turn into transformers for the note.
    , Stroke -> Set Text
_attributes :: !(Set Text)
    } deriving (PitchClass -> Stroke -> ShowS
[Stroke] -> ShowS
Stroke -> String
(PitchClass -> Stroke -> ShowS)
-> (Stroke -> String) -> ([Stroke] -> ShowS) -> Show Stroke
forall a.
(PitchClass -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stroke] -> ShowS
$cshowList :: [Stroke] -> ShowS
show :: Stroke -> String
$cshow :: Stroke -> String
showsPrec :: PitchClass -> Stroke -> ShowS
$cshowsPrec :: PitchClass -> Stroke -> ShowS
Show, Stroke -> Stroke -> Bool
(Stroke -> Stroke -> Bool)
-> (Stroke -> Stroke -> Bool) -> Eq Stroke
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stroke -> Stroke -> Bool
$c/= :: Stroke -> Stroke -> Bool
== :: Stroke -> Stroke -> Bool
$c== :: Stroke -> Stroke -> Bool
Eq, Eq Stroke
Eq Stroke
-> (Stroke -> Stroke -> Ordering)
-> (Stroke -> Stroke -> Bool)
-> (Stroke -> Stroke -> Bool)
-> (Stroke -> Stroke -> Bool)
-> (Stroke -> Stroke -> Bool)
-> (Stroke -> Stroke -> Stroke)
-> (Stroke -> Stroke -> Stroke)
-> Ord Stroke
Stroke -> Stroke -> Bool
Stroke -> Stroke -> Ordering
Stroke -> Stroke -> Stroke
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Stroke -> Stroke -> Stroke
$cmin :: Stroke -> Stroke -> Stroke
max :: Stroke -> Stroke -> Stroke
$cmax :: Stroke -> Stroke -> Stroke
>= :: Stroke -> Stroke -> Bool
$c>= :: Stroke -> Stroke -> Bool
> :: Stroke -> Stroke -> Bool
$c> :: Stroke -> Stroke -> Bool
<= :: Stroke -> Stroke -> Bool
$c<= :: Stroke -> Stroke -> Bool
< :: Stroke -> Stroke -> Bool
$c< :: Stroke -> Stroke -> Bool
compare :: Stroke -> Stroke -> Ordering
$ccompare :: Stroke -> Stroke -> Ordering
Ord)

instance Solkattu.Notation Stroke where
    notation :: Stroke -> (Style, Text)
notation (Stroke Pitch
pitch Set Text
attrs) =
        Text -> (Style, Text)
Solkattu.textNotation (Text -> (Style, Text)) -> Text -> (Style, Text)
forall a b. (a -> b) -> a -> b
$ Pitch -> Text
forall a. Notation a => a -> Text
Solkattu.notationText Pitch
pitch
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
attrs then Text
""
                else Text -> [Text] -> Text
Text.intercalate Text
"+" (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
attrs)

instance Pretty Stroke where pretty :: Stroke -> Text
pretty = Stroke -> Text
forall a. Notation a => a -> Text
Solkattu.notationText

instance Expr.ToExpr Stroke where
    to_expr :: Stroke -> Expr MiniVal
to_expr (Stroke Pitch
_ Set Text
attrs) =
        (Symbol -> Expr MiniVal -> Expr MiniVal)
-> Expr MiniVal -> [Symbol] -> Expr MiniVal
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Symbol -> Expr MiniVal -> Expr MiniVal
forall a. Symbol -> Expr a -> Expr a
Expr.transform0 (Symbol -> Expr MiniVal
forall val. Symbol -> Expr val
Expr.generator0 Symbol
"")
            ((Text -> Symbol) -> [Text] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Symbol
Expr.Symbol (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
attrs))

instance Expr.ToExpr (Realize.Stroke Stroke) where to_expr :: Stroke Stroke -> Expr MiniVal
to_expr = Stroke Stroke -> Expr MiniVal
forall a. ToExpr a => Stroke a -> Expr MiniVal
Realize.toExpr

instance Solkattu.Notation Pitch.Pitch where
    notation :: Pitch -> (Style, Text)
notation (Pitch.Pitch PitchClass
oct Degree
degree) = Text -> (Style, Text)
Solkattu.textNotation (Text -> (Style, Text)) -> Text -> (Style, Text)
forall a b. (a -> b) -> a -> b
$
        Degree -> Text
forall a. Notation a => a -> Text
Solkattu.notationText Degree
degree Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case PitchClass
oct of
            PitchClass
3 -> Text
dotBelow
            PitchClass
4 -> Text
""
            PitchClass
5 -> Text
dotAbove
            PitchClass
_ -> PitchClass -> Text
forall a. Show a => a -> Text
showt PitchClass
oct

-- | Show pitch as parsed by the raga scales.
scorePitch :: Pitch.Pitch -> Text
scorePitch :: Pitch -> Text
scorePitch (Pitch.Pitch PitchClass
oct Degree
degree) = PitchClass -> Text
forall a. Show a => a -> Text
showt PitchClass
oct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Degree -> Text
forall a. Notation a => a -> Text
Solkattu.notationText Degree
degree

instance Solkattu.Notation Pitch.Degree where
    notation :: Degree -> (Style, Text)
notation (Pitch.Degree PitchClass
pc PitchClass
_accs) = Text -> (Style, Text)
Solkattu.textNotation (Text -> (Style, Text)) -> Text -> (Style, Text)
forall a b. (a -> b) -> a -> b
$
        Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (PitchClass -> Text
forall a. Show a => a -> Text
showt PitchClass
pc) (Vector Text
degrees Vector Text -> PitchClass -> Maybe Text
forall a. Vector a -> PitchClass -> Maybe a
Vector.!? PitchClass
pc)
        where degrees :: Vector Text
degrees = [Text] -> Vector Text
forall a. [a] -> Vector a
Vector.fromList ([Text] -> Vector Text) -> [Text] -> Vector Text
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton String
"srgmpdn"

-- COMBINING DOT ABOVE
dotAbove :: Text
dotAbove :: Text
dotAbove = Text
"\x0307"

-- COMBINING DOT BELOW
dotBelow :: Text
dotBelow :: Text
dotBelow = Text
"\x0323"

pitchCall :: Pitch.Pitch -> Expr.Call Text
pitchCall :: Pitch -> Call Text
pitchCall (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
acc)) = Symbol -> [Text] -> Call Text
forall val. Symbol -> [val] -> Call val
Expr.call Symbol
"pitch" ([Text] -> Call Text) -> [Text] -> Call Text
forall a b. (a -> b) -> a -> b
$
    [PitchClass -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val PitchClass
oct, PitchClass -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val PitchClass
pc]
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ if PitchClass
acc PitchClass -> PitchClass -> Bool
forall a. Eq a => a -> a -> Bool
== PitchClass
0 then [] else [PitchClass -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val PitchClass
acc]

data Strokes a = Strokes {
    forall a. Strokes a -> a
s_::a, forall a. Strokes a -> a
r_::a, forall a. Strokes a -> a
g_::a, forall a. Strokes a -> a
m_::a, forall a. Strokes a -> a
p_::a, forall a. Strokes a -> a
d_::a, forall a. Strokes a -> a
n_::a
    , forall a. Strokes a -> a
s::a, forall a. Strokes a -> a
r::a, forall a. Strokes a -> a
g::a, forall a. Strokes a -> a
m::a, forall a. Strokes a -> a
p::a, forall a. Strokes a -> a
d::a, forall a. Strokes a -> a
n::a
    , forall a. Strokes a -> a
s1::a, forall a. Strokes a -> a
r1::a, forall a. Strokes a -> a
g1::a, forall a. Strokes a -> a
m1::a, forall a. Strokes a -> a
p1::a, forall a. Strokes a -> a
d1::a, forall a. Strokes a -> a
n1::a
    } deriving ((forall a b. (a -> b) -> Strokes a -> Strokes b)
-> (forall a b. a -> Strokes b -> Strokes a) -> Functor Strokes
forall a b. a -> Strokes b -> Strokes a
forall a b. (a -> b) -> Strokes a -> Strokes 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 -> Strokes b -> Strokes a
$c<$ :: forall a b. a -> Strokes b -> Strokes a
fmap :: forall a b. (a -> b) -> Strokes a -> Strokes b
$cfmap :: forall a b. (a -> b) -> Strokes a -> Strokes b
Functor, PitchClass -> Strokes a -> ShowS
[Strokes a] -> ShowS
Strokes a -> String
(PitchClass -> Strokes a -> ShowS)
-> (Strokes a -> String)
-> ([Strokes a] -> ShowS)
-> Show (Strokes a)
forall a. Show a => PitchClass -> Strokes a -> ShowS
forall a. Show a => [Strokes a] -> ShowS
forall a. Show a => Strokes a -> String
forall a.
(PitchClass -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Strokes a] -> ShowS
$cshowList :: forall a. Show a => [Strokes a] -> ShowS
show :: Strokes a -> String
$cshow :: forall a. Show a => Strokes a -> String
showsPrec :: PitchClass -> Strokes a -> ShowS
$cshowsPrec :: forall a. Show a => PitchClass -> Strokes a -> ShowS
Show)

strokes :: Strokes Stroke
strokes :: Strokes Stroke
strokes = ((PitchClass -> PitchClass -> Stroke)
-> (PitchClass, PitchClass) -> Stroke
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PitchClass -> PitchClass -> Stroke
stroke) ((PitchClass, PitchClass) -> Stroke)
-> Strokes (PitchClass, PitchClass) -> Strokes Stroke
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Strokes
    { s_ :: (PitchClass, PitchClass)
s_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
0), r_ :: (PitchClass, PitchClass)
r_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
1), g_ :: (PitchClass, PitchClass)
g_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
2), m_ :: (PitchClass, PitchClass)
m_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
3)
    , p_ :: (PitchClass, PitchClass)
p_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
4), d_ :: (PitchClass, PitchClass)
d_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
5), n_ :: (PitchClass, PitchClass)
n_ = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
6)
    , s :: (PitchClass, PitchClass)
s  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
0), r :: (PitchClass, PitchClass)
r  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
1), g :: (PitchClass, PitchClass)
g  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
2), m :: (PitchClass, PitchClass)
m  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
3)
    , p :: (PitchClass, PitchClass)
p  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
4), d :: (PitchClass, PitchClass)
d  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
5), n :: (PitchClass, PitchClass)
n  = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
6)
    , s1 :: (PitchClass, PitchClass)
s1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
0), r1 :: (PitchClass, PitchClass)
r1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
1), g1 :: (PitchClass, PitchClass)
g1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
2), m1 :: (PitchClass, PitchClass)
m1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
3)
    , p1 :: (PitchClass, PitchClass)
p1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
4), d1 :: (PitchClass, PitchClass)
d1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
5), n1 :: (PitchClass, PitchClass)
n1 = (PitchClass
octPitchClass -> PitchClass -> PitchClass
forall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
6)
    }
    where oct :: PitchClass
oct = PitchClass
3

stroke :: Pitch.Octave -> Pitch.PitchClass -> Stroke
stroke :: PitchClass -> PitchClass -> Stroke
stroke PitchClass
oct PitchClass
pc = Pitch -> Set Text -> Stroke
Stroke (PitchClass -> PitchClass -> Pitch
forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
oct PitchClass
pc) Set Text
forall a. Monoid a => a
mempty

notes :: Strokes (SequenceM g)
notes :: forall g. Strokes (SequenceM g)
notes = Stroke -> Sequence g (Note (Stroke Stroke))
forall stroke g. stroke -> Sequence g (Note (Stroke stroke))
Realize.strokeToSequence (Stroke -> Sequence g (Note (Stroke Stroke)))
-> Strokes Stroke -> Strokes (Sequence g (Note (Stroke Stroke)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Strokes Stroke
strokes

toScore :: ToScore.ToScore Stroke
toScore :: ToScore Stroke
toScore [(Duration, Note Stroke)]
durStrokes = ([(Duration, Duration, Text)]
noteTrack, [(Text
"*", [(Duration, Duration, Text)]
pitchTrack)])
    where
    noteTrack :: [(Duration, Duration, Text)]
noteTrack =
        [ (Duration
start, Duration
dur, Expr MiniVal -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Expr MiniVal
expr)
        | (Duration
start, Duration
dur, Just Expr MiniVal
expr) <-
            [Duration]
-> [Duration]
-> [Maybe (Expr MiniVal)]
-> [(Duration, Duration, Maybe (Expr MiniVal))]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Duration]
starts [Duration]
durs ((Note Stroke -> Maybe (Expr MiniVal))
-> [Note Stroke] -> [Maybe (Expr MiniVal)]
forall a b. (a -> b) -> [a] -> [b]
map Note Stroke -> Maybe (Expr MiniVal)
forall stroke.
ToExpr (Stroke stroke) =>
Note stroke -> Maybe (Expr MiniVal)
ToScore.toExpr [Note Stroke]
strokes)
        ]
    pitchTrack :: [(Duration, Duration, Text)]
pitchTrack =
        [ (Duration
start, Duration
0, Pitch -> Text
scorePitch (Stroke -> Pitch
_pitch (Stroke Stroke -> Stroke
forall stroke. Stroke stroke -> stroke
Realize._stroke Stroke Stroke
note)))
        | (Duration
start, Just Stroke Stroke
note) <- [Duration]
-> [Maybe (Stroke Stroke)] -> [(Duration, Maybe (Stroke Stroke))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Duration]
starts ((Note Stroke -> Maybe (Stroke Stroke))
-> [Note Stroke] -> [Maybe (Stroke Stroke)]
forall a b. (a -> b) -> [a] -> [b]
map Note Stroke -> Maybe (Stroke Stroke)
forall a. Note a -> Maybe (Stroke a)
noteOf [Note Stroke]
strokes)
        ]
    ([Duration]
durs, [Note Stroke]
strokes) = [(Duration, Note Stroke)] -> ([Duration], [Note Stroke])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Duration, Note Stroke)]
durStrokes
    starts :: [Duration]
starts = (Duration -> Duration -> Duration)
-> Duration -> [Duration] -> [Duration]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Duration -> Duration -> Duration
forall a. Num a => a -> a -> a
(+) Duration
0 [Duration]
durs

noteOf :: Realize.Note a -> Maybe (Realize.Stroke a)
noteOf :: forall a. Note a -> Maybe (Stroke a)
noteOf (Realize.Note Stroke a
s) = Stroke a -> Maybe (Stroke a)
forall a. a -> Maybe a
Just Stroke a
s
noteOf Note a
_ = Maybe (Stroke a)
forall a. Maybe a
Nothing

-- ** transposition

octave :: Pitch.Octave -> Stroke -> Stroke
octave :: PitchClass -> Stroke -> Stroke
octave PitchClass
oct Stroke
s = Stroke
s { _pitch :: Pitch
_pitch = PitchClass -> Pitch -> Pitch
Pitch.add_octave PitchClass
oct (Stroke -> Pitch
_pitch Stroke
s) }

add :: Pitch.PitchClass -> Stroke -> Stroke
add :: PitchClass -> Stroke -> Stroke
add PitchClass
steps Stroke
s = Stroke
s { _pitch :: Pitch
_pitch = PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc PitchClass
7 PitchClass
steps (Stroke -> Pitch
_pitch Stroke
s) }