-- 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
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
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
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
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
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 forall a b. (a -> b) -> a -> b
$ forall a. Notation a => a -> Text
Solkattu.notationText Pitch
pitch
            forall a. Semigroup a => a -> a -> a
<> if forall a. Set a -> Bool
Set.null Set Text
attrs then Text
""
                else Text -> [Text] -> Text
Text.intercalate Text
"+" (forall a. Set a -> [a]
Set.toList Set Text
attrs)

instance Pretty Stroke where pretty :: Stroke -> Text
pretty = 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) =
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Symbol -> Expr a -> Expr a
Expr.transform0 (forall val. Symbol -> Expr val
Expr.generator0 Symbol
"")
            (forall a b. (a -> b) -> [a] -> [b]
map Text -> Symbol
Expr.Symbol (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 = 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 forall a b. (a -> b) -> a -> b
$
        forall a. Notation a => a -> Text
Solkattu.notationText Degree
degree forall a. Semigroup a => a -> a -> a
<> case PitchClass
oct of
            PitchClass
3 -> Text
dotBelow
            PitchClass
4 -> Text
""
            PitchClass
5 -> Text
dotAbove
            PitchClass
_ -> 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) = forall a. Show a => a -> Text
showt PitchClass
oct forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a -> a
fromMaybe (forall a. Show a => a -> Text
showt PitchClass
pc) (Vector Text
degrees forall a. Vector a -> PitchClass -> Maybe a
Vector.!? PitchClass
pc)
        where degrees :: Vector Text
degrees = forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$ 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)) = forall val. Symbol -> [val] -> Call val
Expr.call Symbol
"pitch" forall a b. (a -> b) -> a -> b
$
    [forall a. ShowVal a => a -> Text
ShowVal.show_val PitchClass
oct, forall a. ShowVal a => a -> Text
ShowVal.show_val PitchClass
pc]
        forall a. [a] -> [a] -> [a]
++ if PitchClass
acc forall a. Eq a => a -> a -> Bool
== PitchClass
0 then [] else [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 -> 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
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 = (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PitchClass -> PitchClass -> Stroke
stroke) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Strokes
    { s_ :: (PitchClass, PitchClass)
s_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
0), r_ :: (PitchClass, PitchClass)
r_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
1), g_ :: (PitchClass, PitchClass)
g_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
2), m_ :: (PitchClass, PitchClass)
m_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
3)
    , p_ :: (PitchClass, PitchClass)
p_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
4), d_ :: (PitchClass, PitchClass)
d_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
5), n_ :: (PitchClass, PitchClass)
n_ = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
0, PitchClass
6)
    , s :: (PitchClass, PitchClass)
s  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
0), r :: (PitchClass, PitchClass)
r  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
1), g :: (PitchClass, PitchClass)
g  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
2), m :: (PitchClass, PitchClass)
m  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
3)
    , p :: (PitchClass, PitchClass)
p  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
4), d :: (PitchClass, PitchClass)
d  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
5), n :: (PitchClass, PitchClass)
n  = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
1, PitchClass
6)
    , s1 :: (PitchClass, PitchClass)
s1 = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
0), r1 :: (PitchClass, PitchClass)
r1 = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
1), g1 :: (PitchClass, PitchClass)
g1 = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
2), m1 :: (PitchClass, PitchClass)
m1 = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
3)
    , p1 :: (PitchClass, PitchClass)
p1 = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
4), d1 :: (PitchClass, PitchClass)
d1 = (PitchClass
octforall a. Num a => a -> a -> a
+PitchClass
2, PitchClass
5), n1 :: (PitchClass, PitchClass)
n1 = (PitchClass
octforall 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 (forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
oct PitchClass
pc) forall a. Monoid a => a
mempty

notes :: Strokes (SequenceM g)
notes :: forall g. Strokes (SequenceM g)
notes = forall stroke g. stroke -> Sequence g (Note (Stroke stroke))
Realize.strokeToSequence 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, forall a. ShowVal a => a -> Text
ShowVal.show_val Expr MiniVal
expr)
        | (Duration
start, Duration
dur, Just Expr MiniVal
expr) <-
            forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Duration]
starts [Duration]
durs (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall stroke. Stroke stroke -> stroke
Realize._stroke Stroke Stroke
note)))
        | (Duration
start, Just Stroke Stroke
note) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Duration]
starts (forall a b. (a -> b) -> [a] -> [b]
map forall a. Note a -> Maybe (Stroke a)
noteOf [Note Stroke]
strokes)
        ]
    ([Duration]
durs, [Note Stroke]
strokes) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Duration, Note Stroke)]
durStrokes
    starts :: [Duration]
starts = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl 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) = forall a. a -> Maybe a
Just Stroke a
s
noteOf Note 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) }