-- 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 #-}
-- | Carnatic ragas.
module Derive.Scale.Raga where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Vector as Vector

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Pretty as Pretty

import qualified Derive.Scale as Scale
import qualified Derive.Scale.JustScales as JustScales
import qualified Derive.Scale.TheoryFormat as TheoryFormat

import qualified Perform.Pitch as Pitch

import           Global


scales :: [Scale.Definition]
scales :: [Definition]
scales = forall a b. (a -> b) -> [a] -> [b]
map Scale -> Definition
Scale.Simple
    [ ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
JustScales.make_scale ScaleId
"raga"
        (Format -> ScaleMap
scale_map (forall key. RelativeFormat key -> Format
TheoryFormat.sargam RelativeFormat Int
relative_fmt)) Doc
doc [(Doc, Doc)]
doc_fields
    ]

doc :: Doc.Doc
doc :: Doc
doc = Doc
"Carnatic ragas, from the melakarta system.\
    \\nThe \"key\" is actually the raga, e.g.\
    \ `key=shankarabharanam`. Arohana and avarohana are not represented in the\
    \ scale, so janya ragams look the same as their parent. The information\
    \ is present, though, so it can be interpreted by various gamakam ornaments\
    \ (not yet implemented though).  TODO There is also currently no way to\
    \ represent pitches which differ in arohana and avarohana.\
    \\nSince latin orthography is inconsistent, they might be spelled slightly\
    \ differently from how you expect."

doc_fields :: [(Doc.Doc, Doc.Doc)]
doc_fields :: [(Doc, Doc)]
doc_fields = [(Key, Key)] -> [(Doc, Doc)]
JustScales.group_relative_keys [(Key, Key)]
melakarta_keys

scale_map :: TheoryFormat.Format -> JustScales.ScaleMap
scale_map :: Format -> ScaleMap
scale_map = Keys -> Key -> Maybe Name -> Format -> ScaleMap
JustScales.scale_map Keys
keys Key
default_key forall a. Maybe a
Nothing

relative_fmt :: TheoryFormat.RelativeFormat TheoryFormat.Tonic
relative_fmt :: RelativeFormat Int
relative_fmt = Keys -> Key -> RelativeFormat Int
JustScales.make_relative_fmt Keys
keys Key
default_key

default_key :: JustScales.Key
Just Key
default_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name -> Key
Pitch.Key Name
"shankarabharanam") Keys
keys

keys :: Map Pitch.Key JustScales.Key
keys :: Keys
keys = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Key, Key)]
melakarta_keys


-- * implementation

melakarta_keys :: [(Pitch.Key, JustScales.Key)]
melakarta_keys :: [(Key, Key)]
melakarta_keys =
    [ (Name -> Key
Pitch.Key Name
alias, Int -> Map Name Ratios -> Key
JustScales.Key Int
0 (forall k a. k -> a -> Map k a
Map.singleton Name
"" Ratios
ratios))
    | (Name
name, Ragam
ragam) <- [(Name, Ragam)]
ragams
    , let ratios :: Ratios
ratios = Ragam -> Ratios
ragam_ratios Ragam
ragam
    , Name
alias <- Name
name forall a. a -> [a] -> [a]
: Name -> [Name]
aliases_of Name
name
    ]
    where
    aliases_of :: Name -> [Name]
aliases_of Name
name = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Name
name Map Name [Name]
aliases

melakarta_ragams :: [(Name, Ragam)]
melakarta_ragams :: [(Name, Ragam)]
melakarta_ragams = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
melakarta_names forall a b. (a -> b) -> a -> b
$ do
    SwaramP
ma <- [SwaramP
Ma1, SwaramP
Ma2]
    SwaramP
ri <- [SwaramP
Ri1, SwaramP
Ri2, SwaramP
Ri3]
    SwaramP
ga <- [SwaramP
Ga1, SwaramP
Ga2, SwaramP
Ga3]
    SwaramP
da <- [SwaramP
Da1, SwaramP
Da2, SwaramP
Da3]
    SwaramP
ni <- [SwaramP
Ni1, SwaramP
Ni2, SwaramP
Ni3]
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ SwaramP
da forall a. Eq a => a -> a -> Bool
== SwaramP
Da2 Bool -> Bool -> Bool
|- SwaramP
ni forall a. Eq a => a -> a -> Bool
/= SwaramP
Ni1
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ SwaramP
da forall a. Eq a => a -> a -> Bool
== SwaramP
Da3 Bool -> Bool -> Bool
|- SwaramP
ni forall a. Eq a => a -> a -> Bool
== SwaramP
Ni3
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ SwaramP
ri forall a. Eq a => a -> a -> Bool
== SwaramP
Ri2 Bool -> Bool -> Bool
|- SwaramP
ga forall a. Eq a => a -> a -> Bool
/= SwaramP
Ga1
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ SwaramP
ri forall a. Eq a => a -> a -> Bool
== SwaramP
Ri3 Bool -> Bool -> Bool
|- SwaramP
ga forall a. Eq a => a -> a -> Bool
== SwaramP
Ga3
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> RagamT a
Same [SwaramP
ri, SwaramP
ga, SwaramP
ma, SwaramP
Pa, SwaramP
da, SwaramP
ni]
    where
    infixr 3 |-
    Bool
x |- :: Bool -> Bool -> Bool
|- Bool
y = Bool -> Bool
not Bool
x Bool -> Bool -> Bool
|| Bool
y

-- | This is the same as 'melakarta_ragams', but with intervals.  I should
-- probably derive melakarta_ragams from this.
melakarta_intervals :: [(Name, [Pitch.Semi])]
melakarta_intervals :: [(Name, [Int])]
melakarta_intervals = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
melakarta_names forall a b. (a -> b) -> a -> b
$ do
    Int
ma <- [Int
ma1, Int
ma2]
    Int
ri <- [Int
ri1, Int
ri2, Int
ri3]
    Int
ga <- [Int
ga1, Int
ga2, Int
ga3]
    Int
da <- [Int
da1, Int
da2, Int
da3]
    Int
ni <- [Int
ni1, Int
ni2, Int
ni3]
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
da forall a. Eq a => a -> a -> Bool
== Int
da2 Bool -> Bool -> Bool
|- Int
ni forall a. Eq a => a -> a -> Bool
/= Int
ni1
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
da forall a. Eq a => a -> a -> Bool
== Int
da3 Bool -> Bool -> Bool
|- Int
ni forall a. Eq a => a -> a -> Bool
== Int
ni3
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
ri forall a. Eq a => a -> a -> Bool
== Int
ri2 Bool -> Bool -> Bool
|- Int
ga forall a. Eq a => a -> a -> Bool
/= Int
ga1
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
ri forall a. Eq a => a -> a -> Bool
== Int
ri3 Bool -> Bool -> Bool
|- Int
ga forall a. Eq a => a -> a -> Bool
== Int
ga3
    let indices :: [Int]
indices = [Int
sa, Int
ri, Int
ga, Int
ma, Int
pa, Int
da, Int
ni, Int
12]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) (forall a. [a] -> [a]
tail [Int]
indices) [Int]
indices
    where
    [Int
sa, Int
ri1, Int
ri2, Int
ri3, Int
ga3, Int
ma1, Int
ma2, Int
pa, Int
da1, Int
da2, Int
da3, Int
ni3]
        = forall a. Int -> [a] -> [a]
take Int
12 [Int
0..]
    ga1 :: Int
ga1 = Int
ri2
    ga2 :: Int
ga2 = Int
ri3
    ni1 :: Int
ni1 = Int
da2
    ni2 :: Int
ni2 = Int
da3
    infixr 3 |-
    Bool
x |- :: Bool -> Bool -> Bool
|- Bool
y = Bool -> Bool
not Bool
x Bool -> Bool -> Bool
|| Bool
y

type Ratio = Ratio.Ratio Int

data SwaramP = Sa | Ri1 | Ri2 | Ri3 | Ga1 | Ga2 | Ga3 | Ma1 | Ma2 | Pa
    | Da1 | Da2 | Da3 | Ni1 | Ni2 | Ni3
    deriving (SwaramP -> SwaramP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SwaramP -> SwaramP -> Bool
$c/= :: SwaramP -> SwaramP -> Bool
== :: SwaramP -> SwaramP -> Bool
$c== :: SwaramP -> SwaramP -> Bool
Eq, Eq SwaramP
SwaramP -> SwaramP -> Bool
SwaramP -> SwaramP -> Ordering
SwaramP -> SwaramP -> SwaramP
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 :: SwaramP -> SwaramP -> SwaramP
$cmin :: SwaramP -> SwaramP -> SwaramP
max :: SwaramP -> SwaramP -> SwaramP
$cmax :: SwaramP -> SwaramP -> SwaramP
>= :: SwaramP -> SwaramP -> Bool
$c>= :: SwaramP -> SwaramP -> Bool
> :: SwaramP -> SwaramP -> Bool
$c> :: SwaramP -> SwaramP -> Bool
<= :: SwaramP -> SwaramP -> Bool
$c<= :: SwaramP -> SwaramP -> Bool
< :: SwaramP -> SwaramP -> Bool
$c< :: SwaramP -> SwaramP -> Bool
compare :: SwaramP -> SwaramP -> Ordering
$ccompare :: SwaramP -> SwaramP -> Ordering
Ord, Int -> SwaramP
SwaramP -> Int
SwaramP -> [SwaramP]
SwaramP -> SwaramP
SwaramP -> SwaramP -> [SwaramP]
SwaramP -> SwaramP -> SwaramP -> [SwaramP]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SwaramP -> SwaramP -> SwaramP -> [SwaramP]
$cenumFromThenTo :: SwaramP -> SwaramP -> SwaramP -> [SwaramP]
enumFromTo :: SwaramP -> SwaramP -> [SwaramP]
$cenumFromTo :: SwaramP -> SwaramP -> [SwaramP]
enumFromThen :: SwaramP -> SwaramP -> [SwaramP]
$cenumFromThen :: SwaramP -> SwaramP -> [SwaramP]
enumFrom :: SwaramP -> [SwaramP]
$cenumFrom :: SwaramP -> [SwaramP]
fromEnum :: SwaramP -> Int
$cfromEnum :: SwaramP -> Int
toEnum :: Int -> SwaramP
$ctoEnum :: Int -> SwaramP
pred :: SwaramP -> SwaramP
$cpred :: SwaramP -> SwaramP
succ :: SwaramP -> SwaramP
$csucc :: SwaramP -> SwaramP
Enum, Int -> SwaramP -> ShowS
[SwaramP] -> ShowS
SwaramP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SwaramP] -> ShowS
$cshowList :: [SwaramP] -> ShowS
show :: SwaramP -> [Char]
$cshow :: SwaramP -> [Char]
showsPrec :: Int -> SwaramP -> ShowS
$cshowsPrec :: Int -> SwaramP -> ShowS
Show)

swaram_ratio :: SwaramP -> Ratio
swaram_ratio :: SwaramP -> Ratio Int
swaram_ratio = \case
    SwaramP
Sa -> Ratio Int
sa
    SwaramP
Ri1 -> Ratio Int
ri1
    SwaramP
Ri2 -> Ratio Int
ri2
    SwaramP
Ri3 -> Ratio Int
ri3
    SwaramP
Ga1 -> Ratio Int
ga1
    SwaramP
Ga2 -> Ratio Int
ga2
    SwaramP
Ga3 -> Ratio Int
ga3
    SwaramP
Ma1 -> Ratio Int
ma1
    SwaramP
Ma2 -> Ratio Int
ma2
    SwaramP
Pa -> Ratio Int
pa
    SwaramP
Da1 -> Ratio Int
da1
    SwaramP
Da2 -> Ratio Int
da2
    SwaramP
Da3 -> Ratio Int
da3
    SwaramP
Ni1 -> Ratio Int
ni1
    SwaramP
Ni2 -> Ratio Int
ni2
    SwaramP
Ni3 -> Ratio Int
ni3
    where

    {- I don't think there is any official definition, but listeners agree 8/7
        is too high for ri, so I use a 5-limit scale.  Except prati madhyama is
        7/5, because I like it.  There is some theoretical material deriving 22
        srutis via 5-limit, but I'm not sure what bearing it has on real
        practice.

        > 1     2m    2M    3m    3M    4P    4A    5P    6m    6M    7m    7M
        > s     r1    r2    r3                      p     d1    d2    d3
        >             g1    g2    g3    m1    m2                n1    n2    n3
    -}
    sa, ri1, ri2, ri3, ga3, ma1, ma2, pa, da1, da2, da3, ni3 :: Ratio
    (Ratio Int
sa, Ratio Int
ri1, Ratio Int
ri2, Ratio Int
ri3, Ratio Int
ga3, Ratio Int
ma1, Ratio Int
ma2, Ratio Int
pa, Ratio Int
da1, Ratio Int
da2, Ratio Int
da3, Ratio Int
ni3) =
        (Ratio Int
1, Ratio Int
16forall a. Fractional a => a -> a -> a
/Ratio Int
15, Ratio Int
9forall a. Fractional a => a -> a -> a
/Ratio Int
8, Ratio Int
6forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
5forall a. Fractional a => a -> a -> a
/Ratio Int
4, Ratio Int
4forall a. Fractional a => a -> a -> a
/Ratio Int
3, Ratio Int
7forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
3forall a. Fractional a => a -> a -> a
/Ratio Int
2, Ratio Int
8forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
5forall a. Fractional a => a -> a -> a
/Ratio Int
3, Ratio Int
9forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
15forall a. Fractional a => a -> a -> a
/Ratio Int
8)
    ga1, ga2, ni1, ni2 :: Ratio
    ga1 :: Ratio Int
ga1 = Ratio Int
ri2
    ga2 :: Ratio Int
ga2 = Ratio Int
ri3
    ni1 :: Ratio Int
ni1 = Ratio Int
da2
    ni2 :: Ratio Int
ni2 = Ratio Int
da3

all_swarams :: [SwaramP]
all_swarams :: [SwaramP]
all_swarams = [SwaramP
Sa, SwaramP
Ri1, SwaramP
Ri2, SwaramP
Ga2, SwaramP
Ga3, SwaramP
Ma1, SwaramP
Ma2, SwaramP
Pa, SwaramP
Da1, SwaramP
Da2, SwaramP
Ni2, SwaramP
Ni3]

all_ratios :: [Ratio]
all_ratios :: [Ratio Int]
all_ratios = forall a b. (a -> b) -> [a] -> [b]
map SwaramP -> Ratio Int
swaram_ratio [SwaramP]
all_swarams

unswaram :: SwaramP -> Swaram
unswaram :: SwaramP -> Swaram
unswaram = \case
    SwaramP
Sa -> Swaram
S
    SwaramP
Ri1 -> Swaram
R
    SwaramP
Ri2 -> Swaram
R
    SwaramP
Ri3 -> Swaram
R
    SwaramP
Ga1 -> Swaram
G
    SwaramP
Ga2 -> Swaram
G
    SwaramP
Ga3 -> Swaram
G
    SwaramP
Ma1 -> Swaram
M
    SwaramP
Ma2 -> Swaram
M
    SwaramP
Pa -> Swaram
P
    SwaramP
Da1 -> Swaram
D
    SwaramP
Da2 -> Swaram
D
    SwaramP
Da3 -> Swaram
D
    SwaramP
Ni1 -> Swaram
N
    SwaramP
Ni2 -> Swaram
N
    SwaramP
Ni3 -> Swaram
N

swaramps :: Swaram -> [SwaramP]
swaramps :: Swaram -> [SwaramP]
swaramps = \case
    Swaram
S -> [SwaramP
Sa]
    Swaram
R -> [SwaramP
Ri1, SwaramP
Ri2, SwaramP
Ri3]
    Swaram
G -> [SwaramP
Ga1, SwaramP
Ga2, SwaramP
Ga3]
    Swaram
M -> [SwaramP
Ma1, SwaramP
Ma2]
    Swaram
P -> [SwaramP
Pa]
    Swaram
D -> [SwaramP
Da1, SwaramP
Da2, SwaramP
Da3]
    Swaram
N -> [SwaramP
Ni1, SwaramP
Ni2, SwaramP
Ni3]

data Swaram = S | R | G | M | P | D | N
    deriving (Swaram -> Swaram -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Swaram -> Swaram -> Bool
$c/= :: Swaram -> Swaram -> Bool
== :: Swaram -> Swaram -> Bool
$c== :: Swaram -> Swaram -> Bool
Eq, Eq Swaram
Swaram -> Swaram -> Bool
Swaram -> Swaram -> Ordering
Swaram -> Swaram -> Swaram
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 :: Swaram -> Swaram -> Swaram
$cmin :: Swaram -> Swaram -> Swaram
max :: Swaram -> Swaram -> Swaram
$cmax :: Swaram -> Swaram -> Swaram
>= :: Swaram -> Swaram -> Bool
$c>= :: Swaram -> Swaram -> Bool
> :: Swaram -> Swaram -> Bool
$c> :: Swaram -> Swaram -> Bool
<= :: Swaram -> Swaram -> Bool
$c<= :: Swaram -> Swaram -> Bool
< :: Swaram -> Swaram -> Bool
$c< :: Swaram -> Swaram -> Bool
compare :: Swaram -> Swaram -> Ordering
$ccompare :: Swaram -> Swaram -> Ordering
Ord, Int -> Swaram
Swaram -> Int
Swaram -> [Swaram]
Swaram -> Swaram
Swaram -> Swaram -> [Swaram]
Swaram -> Swaram -> Swaram -> [Swaram]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Swaram -> Swaram -> Swaram -> [Swaram]
$cenumFromThenTo :: Swaram -> Swaram -> Swaram -> [Swaram]
enumFromTo :: Swaram -> Swaram -> [Swaram]
$cenumFromTo :: Swaram -> Swaram -> [Swaram]
enumFromThen :: Swaram -> Swaram -> [Swaram]
$cenumFromThen :: Swaram -> Swaram -> [Swaram]
enumFrom :: Swaram -> [Swaram]
$cenumFrom :: Swaram -> [Swaram]
fromEnum :: Swaram -> Int
$cfromEnum :: Swaram -> Int
toEnum :: Int -> Swaram
$ctoEnum :: Int -> Swaram
pred :: Swaram -> Swaram
$cpred :: Swaram -> Swaram
succ :: Swaram -> Swaram
$csucc :: Swaram -> Swaram
Enum, Int -> Swaram -> ShowS
[Swaram] -> ShowS
Swaram -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Swaram] -> ShowS
$cshowList :: [Swaram] -> ShowS
show :: Swaram -> [Char]
$cshow :: Swaram -> [Char]
showsPrec :: Int -> Swaram -> ShowS
$cshowsPrec :: Int -> Swaram -> ShowS
Show)
type Name = Text

type Ragam = RagamT SwaramP

-- | Arohana \/ avarohana structure.  Sa is implicit, so it's omitted.
data RagamT a =
    -- | The arohana is given, the avarohana is the same but reversed.
    Same [a]
    -- | Arohana ascending from low sa, avarohana descending from high sa.
    -- The first and last Sa are omitted, since they are implicit.
    | Different [a] [a]
    deriving (forall a b. a -> RagamT b -> RagamT a
forall a b. (a -> b) -> RagamT a -> RagamT 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 -> RagamT b -> RagamT a
$c<$ :: forall a b. a -> RagamT b -> RagamT a
fmap :: forall a b. (a -> b) -> RagamT a -> RagamT b
$cfmap :: forall a b. (a -> b) -> RagamT a -> RagamT b
Functor, Int -> RagamT a -> ShowS
forall a. Show a => Int -> RagamT a -> ShowS
forall a. Show a => [RagamT a] -> ShowS
forall a. Show a => RagamT a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RagamT a] -> ShowS
$cshowList :: forall a. Show a => [RagamT a] -> ShowS
show :: RagamT a -> [Char]
$cshow :: forall a. Show a => RagamT a -> [Char]
showsPrec :: Int -> RagamT a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RagamT a -> ShowS
Show)

ragam_swarams :: Ragam -> ([SwaramP], Maybe [SwaramP])
ragam_swarams :: Ragam -> ([SwaramP], Maybe [SwaramP])
ragam_swarams = \case
    Same [SwaramP]
swarams -> (SwaramP
Sa forall a. a -> [a] -> [a]
: [SwaramP]
swarams, forall a. Maybe a
Nothing)
    Different [SwaramP]
arohana [SwaramP]
avarohana -> (SwaramP
Sa forall a. a -> [a] -> [a]
: [SwaramP]
arohana, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SwaramP]
avarohana forall a. [a] -> [a] -> [a]
++ [SwaramP
Sa])

ragam_ratios :: Ragam -> JustScales.Ratios
ragam_ratios :: Ragam -> Ratios
ragam_ratios = forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map SwaramP -> Ratio Int
swaram_ratio forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ragam -> ([SwaramP], Maybe [SwaramP])
ragam_swarams
    -- TODO this is just the arohanam, I don't have a way to support multiple
    -- swarams yet.
    -- TODO What's more, I can't even support missing swarams, so this will
    -- be wrong for non-sampurna ragams.

-- | TODO these are integrated into 'ragams', but broken.
janya :: Map Name [(Name, Ragam)]
janya :: Map Name [(Name, Ragam)]
janya = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name, [(Name, RagamT Swaram)]) -> (Name, [(Name, Ragam)])
get
    [ (Name
"kharaharapriya",
        [ (Name
"abheri", forall a. [a] -> [a] -> RagamT a
Different [Swaram
G, Swaram
M, Swaram
P, Swaram
N] [Swaram]
down)
        -- hindustani, similar to abheri
        , (Name
"dhanasri", forall a. [a] -> [a] -> RagamT a
Different [Swaram
G, Swaram
M, Swaram
P, Swaram
N] [Swaram]
down)
        , (Name
"abhogi", forall a. [a] -> RagamT a
Same [Swaram
R, Swaram
G, Swaram
M, Swaram
D])
        , (Name
"sri", forall a. [a] -> [a] -> RagamT a
Different [Swaram
R, Swaram
M, Swaram
P, Swaram
N] [Swaram
N, Swaram
P, Swaram
M, Swaram
R, Swaram
G, Swaram
R])
            -- or avarohana = [N, P, D, N, P, M, R, G, R]
        ])
    , (Name
"harikambhoji",
        [ (Name
"mohanam", forall a. [a] -> RagamT a
Same [Swaram
R, Swaram
G, Swaram
P, Swaram
D])
        , (Name
"natakuranji",
            forall a. [a] -> [a] -> RagamT a
Different [Swaram
M, Swaram
G, Swaram
M, Swaram
N, Swaram
D, Swaram
N, Swaram
P, Swaram
D, Swaram
N] [Swaram
N, Swaram
D, Swaram
M, Swaram
G])
                -- Or [N, D, M, G, M, P, G, R]
        , (Name
"surutti", forall a. [a] -> [a] -> RagamT a
Different [Swaram
R, Swaram
M, Swaram
P, Swaram
N, Swaram
D, Swaram
N] [Swaram
N, Swaram
D, Swaram
P, Swaram
M, Swaram
G, Swaram
P, Swaram
M, Swaram
R])
        ])
    -- , ("mayamalavagoula",
    -- TODO web page says gaulipantu is from mayamalavagoula, but it has m2?
    , (Name
"kamavardhini",
        [ (Name
"goulipantu", forall a. [a] -> [a] -> RagamT a
Different [Swaram
R, Swaram
M, Swaram
P, Swaram
N] [Swaram
N, Swaram
D, Swaram
P, Swaram
M, Swaram
D, Swaram
M, Swaram
G, Swaram
R])
        ])
    ]
    -- TODO ragams with multiple pitches per swaram
    where
    get :: (Name, [(Name, RagamT Swaram)]) -> (Name, [(Name, Ragam)])
get (Name
parent, [(Name, RagamT Swaram)]
janyas) =
        ( Name
parent
        , [(Name
name, Name -> Name -> RagamT Swaram -> Ragam
get_swarams Name
parent Name
name RagamT Swaram
ragam) | (Name
name, RagamT Swaram
ragam) <- [(Name, RagamT Swaram)]
janyas]
        )
    down :: [Swaram]
down = [Swaram
N, Swaram
D .. Swaram
R]

get_swarams :: Name -> Name -> RagamT Swaram -> RagamT SwaramP
get_swarams :: Name -> Name -> RagamT Swaram -> Ragam
get_swarams Name
parent Name
name RagamT Swaram
ragam = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
parent [(Name, Ragam)]
melakarta_ragams of
    Maybe Ragam
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"no parent ragam " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Name
parent forall a. Semigroup a => a -> a -> a
<> [Char]
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Name
name
    Just Ragam
parent -> forall {t :: * -> *}. Foldable t => t SwaramP -> Swaram -> SwaramP
get (forall a b. (a, b) -> a
fst (Ragam -> ([SwaramP], Maybe [SwaramP])
ragam_swarams Ragam
parent)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RagamT Swaram
ragam
    where
    -- Should not error, melakarta ragams are sampurna.
    get :: t SwaramP -> Swaram -> SwaramP
get t SwaramP
present Swaram
swaram =
        forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"melakarta parent doesn't have " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Swaram
swaram) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t SwaramP
present) (Swaram -> [SwaramP]
swaramps Swaram
swaram)

ragams :: [(Name, Ragam)]
ragams :: [(Name, Ragam)]
ragams = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, Ragam) -> [(Name, Ragam)]
get [(Name, Ragam)]
melakarta_ragams
    where
    get :: (Name, Ragam) -> [(Name, Ragam)]
get (Name
name, Ragam
swarams) = (Name
name, Ragam
swarams) forall a. a -> [a] -> [a]
: forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Name
name Map Name [(Name, Ragam)]
janya

melakarta_names :: [Name]
melakarta_names :: [Name]
melakarta_names =
    -- shuddha madhyama
    [ Name
"kanakanki", Name
"ratnangi", Name
"ganamurti" -- r1 g1
    , Name
"vanaspati", Name
"manavati", Name
"tanarupi"

    , Name
"senavati", Name
"hanumatodi", Name
"dhenuka" -- r1 g2
    , Name
"natakapriya", Name
"kokilapriya", Name
"rupavati"

    , Name
"gayakapriya", Name
"vakulabharanam", Name
"mayamalavagoula" -- r1 g3
    , Name
"chakravaham", Name
"suryakantam", Name
"hatakambhari"

    , Name
"jhankaradhwani", Name
"natabhairavi", Name
"kiravani" -- r2 g2
    , Name
"kharaharapriya", Name
"gourimanohari", Name
"varunapriya"

    , Name
"mararanjani", Name
"charukesi", Name
"sarasangi" -- r2 g3
    , Name
"harikambhoji", Name
"dheerashankarabharanam", Name
"naganandini"

    , Name
"yagapriya", Name
"ragavardhini", Name
"gangeyabhusani" -- r3 g3
    , Name
"vagadheeswari", Name
"sulini", Name
"chalanattai"

    -- prati madhyama
    , Name
"salagam", Name
"jalarnavam", Name
"jhalavarali" -- r1 g1
    , Name
"navaneetam", Name
"pavani", Name
"raghupriya"

    , Name
"gavambodhi", Name
"bhavapriya", Name
"subhapantuvarali" -- r1 g2
    , Name
"shadvigamargini", Name
"suvarnangi", Name
"divyamani"

    , Name
"dhavalambari", Name
"namanarayani", Name
"kamavardhini" -- r1 g3
    , Name
"ramapriya", Name
"gamanasrama", Name
"viswambhari"

    , Name
"syamalangi", Name
"shanmukhapriya", Name
"simhendramadhyamam" -- r2 g2
    , Name
"hemavati", Name
"dharamavai", Name
"nitimati"

    , Name
"kantamani", Name
"rishabhapriya", Name
"latangi" -- r2 g3
    , Name
"vachaspati" , Name
"mechakalyani", Name
"chitrambhari"

    , Name
"sucharitra", Name
"jyotiswarupini", Name
"dhatuvardhini" -- r3 g3
    , Name
"nasikabhusani", Name
"kosalam", Name
"rasikapriya"
    ]

alternates :: [([Char], [Char])]
alternates :: [([Char], [Char])]
alternates = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([Char]
a, [Char]
b) -> [([Char]
a, [Char]
b), ([Char]
b, [Char]
a)])
    [ ([Char]
"ou", [Char]
"ow")
    , ([Char]
"dh", [Char]
"d")
    , ([Char]
"bh", [Char]
"b")
    , ([Char]
"kh", [Char]
"k")
    , ([Char]
"v", [Char]
"w")
    , ([Char]
"s", [Char]
"sh")
    ]

alternate :: Eq a => [([a], [a])] -> [a] -> [[a]]
alternate :: forall a. Eq a => [([a], [a])] -> [a] -> [[a]]
alternate [([a], [a])]
alts = (\[[a]]
x -> if [[a]]
x forall a. Eq a => a -> a -> Bool
== [[]] then [] else [[a]]
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
go
    where
    go :: [a] -> [[a]]
go [] = [[]]
    go (a
x : [a]
xs) = forall a b. (a -> b) -> [a] -> [b]
map (a
x:) ([a] -> [[a]]
go [a]
xs) forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {t :: * -> *} {a}. Foldable t => (t a, [a]) -> [[a]]
apply [([a], [a])]
ps
        where
        ps :: [([a], [a])]
ps = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => [a] -> [a] -> Bool
`List.isPrefixOf` (a
xforall a. a -> [a] -> [a]
:[a]
xs)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([a], [a])]
alts
        apply :: (t a, [a]) -> [[a]]
apply (t a
pre, [a]
post) = forall a b. (a -> b) -> [a] -> [b]
map ([a]
post++) forall a b. (a -> b) -> a -> b
$ [a] -> [[a]]
go (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
pre) (a
xforall a. a -> [a] -> [a]
:[a]
xs))


-- | Common aliases for ragam names.
aliases :: Map Name [Name]
aliases :: Map Name [Name]
aliases = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. (Name, a) -> (Name, a)
assert_valid_name
    [ (Name
"dheerashankarabharanam", [Name
"shankarabharanam"])
    , (Name
"mechakalyani", [Name
"kalyani"])
    , (Name
"hanumatodi", [Name
"todi"])
    , (Name
"harikambhoji", [Name
"kambhoji"])
    , (Name
"natabhairavi", [Name
"bhairavi"])
    ]

assert_valid_name :: (Name, a) -> (Name, a)
assert_valid_name :: forall a. (Name, a) -> (Name, a)
assert_valid_name val :: (Name, a)
val@(Name
name, a
_)
    | Name
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
melakarta_names = (Name, a)
val
    | Bool
otherwise = forall a. HasCallStack => Name -> a
errorStack forall a b. (a -> b) -> a -> b
$ Name
"not in melakarta_names: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Name
showt Name
name

-- * query

print_all :: IO ()
print_all :: IO ()
print_all = Name -> IO ()
Text.IO.putStr forall a b. (a -> b) -> a -> b
$ [(Name, Ragam)] -> Name
show_ragams [(Name, Ragam)]
ragams

print_ragams :: Pattern -> IO ()
print_ragams :: [Char] -> IO ()
print_ragams = Name -> IO ()
Text.IO.putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, Ragam)] -> Name
show_ragams forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [(Name, Ragam)]
find_ragams

find_by_swarams :: [SwaramP] -> IO ()
find_by_swarams :: [SwaramP] -> IO ()
find_by_swarams [SwaramP]
swarams_ =
    Name -> IO ()
Text.IO.putStr forall a b. (a -> b) -> a -> b
$ [(Name, Ragam)] -> Name
show_ragams forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Ragam -> Bool
matches forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, Ragam)]
ragams
    where
    matches :: Ragam -> Bool
matches Ragam
ragam = Set SwaramP
swarams forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set SwaramP
rswarams
        where
        ([SwaramP]
aro, Maybe [SwaramP]
avaro) = Ragam -> ([SwaramP], Maybe [SwaramP])
ragam_swarams Ragam
ragam
        rswarams :: Set SwaramP
rswarams = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ SwaramP
Sa forall a. a -> [a] -> [a]
: [SwaramP]
aro forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [SwaramP]
avaro
    swarams :: Set SwaramP
swarams = forall a. Ord a => [a] -> Set a
Set.fromList [SwaramP]
swarams_

-- ** query implementation

type Pattern = String

find_ragams :: Pattern -> [(Name, Ragam)]
find_ragams :: [Char] -> [(Name, Ragam)]
find_ragams [Char]
pattern =
    case forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition forall a b. (a, b) -> a
fst (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}. ([Char], b) -> Maybe (Bool, (Name, b))
match (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Name -> [Char]
untxt) [(Name, Ragam)]
ragams)) of
        (exact :: [(Bool, (Name, Ragam))]
exact@((Bool, (Name, Ragam))
_:[(Bool, (Name, Ragam))]
_), [(Bool, (Name, Ragam))]
_) -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, (Name, Ragam))]
exact
        ([], [(Bool, (Name, Ragam))]
inexact) -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, (Name, Ragam))]
inexact
    where
    match :: ([Char], b) -> Maybe (Bool, (Name, b))
match ([Char]
name, b
ragam)
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
==[Char]
name) [[Char]]
infixes = forall a. a -> Maybe a
Just (Bool
True, ([Char] -> Name
txt [Char]
name, b
ragam))
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` [Char]
name) [[Char]]
infixes = forall a. a -> Maybe a
Just (Bool
False, ([Char] -> Name
txt [Char]
name, b
ragam))
        | Bool
otherwise = forall a. Maybe a
Nothing
    infixes :: [[Char]]
infixes = forall a. Eq a => [([a], [a])] -> [a] -> [[a]]
alternate [([Char], [Char])]
alternates [Char]
pattern

show_ragams :: [(Name, Ragam)] -> Text
show_ragams :: [(Name, Ragam)] -> Name
show_ragams [(Name, Ragam)]
ragams = [Name] -> Name
Text.unlines forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map [Name] -> Name
justify [[Name]]
header forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, Ragam) -> [Name]
show_ragam [(Name, Ragam)]
ragams

show_ragam :: (Name, Ragam) -> [Text]
show_ragam :: (Name, Ragam) -> [Name]
show_ragam (Name
name, Ragam
ragam) =
    forall a b. (a -> b) -> [a] -> [b]
map [Name] -> Name
justify (forall a. (a -> a) -> [a] -> [a]
Lists.mapHead (forall a. [a] -> [a] -> [a]
++[Name
name]) (Ragam -> [[Name]]
show_swarams Ragam
ragam))

header :: [[Text]]
header :: [[Name]]
header =
    [ forall a b. (a -> b) -> [a] -> [b]
map forall a. (Eq a, Num a, Pretty a) => Ratio a -> Name
Pretty.improperRatio ([Ratio Int]
all_ratios forall a. [a] -> [a] -> [a]
++ [Ratio Int
2])
    , [Name
"S", Name
"R1", Name
"R2", Name
"R3", Name
"",   Name
"M1", Name
"M2", Name
"P", Name
"D1", Name
"D2", Name
"D3", Name
"", Name
"S"]
    , [Name
"",  Name
"",   Name
"G1", Name
"G2", Name
"G3", Name
"",   Name
"",   Name
"",  Name
"",   Name
"N1", Name
"N2", Name
"N3"]
    ]

data Dir = Down | Up deriving (Dir -> Dir -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dir -> Dir -> Bool
$c/= :: Dir -> Dir -> Bool
== :: Dir -> Dir -> Bool
$c== :: Dir -> Dir -> Bool
Eq)

show_swarams :: Ragam -> [[Text]]
show_swarams :: Ragam -> [[Name]]
show_swarams Ragam
ragam = Dir -> [SwaramP] -> [[Name]]
lines Dir
Up [SwaramP]
aro forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Dir -> [SwaramP] -> [[Name]]
lines Dir
Down) Maybe [SwaramP]
avaro
    where
    ([SwaramP]
aro, Maybe [SwaramP]
avaro) = Ragam -> ([SwaramP], Maybe [SwaramP])
ragam_swarams Ragam
ragam
    lines :: Dir -> [SwaramP] -> [[Name]]
lines Dir
dir = forall a b. (a -> b) -> [a] -> [b]
map [Name] -> [Name]
pad
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((if Dir
dir forall a. Eq a => a -> a -> Bool
== Dir
Up then forall a. (a -> a) -> [a] -> [a]
Lists.mapLast else forall a. (a -> a) -> [a] -> [a]
Lists.mapHead) (forall a. Semigroup a => a -> a -> a
<>[Name
"S"]))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [SwaramP] -> [Name]
line
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
Lists.splitBetween (if Dir
dir forall a. Eq a => a -> a -> Bool
== Dir
Up then forall a. Ord a => a -> a -> Bool
(>) else forall a. Ord a => a -> a -> Bool
(<))
    line :: [SwaramP] -> [Name]
line = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Paired a SwaramP -> Name
cell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a b.
Ord k =>
(a -> k) -> (b -> k) -> [a] -> [b] -> [Paired a b]
Lists.pairSortedOn forall a. a -> a
id SwaramP -> Ratio Int
swaram_ratio [Ratio Int]
all_ratios forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
List.sort
    cell :: Paired a SwaramP -> Name
cell = \case
        Lists.Both a
_ SwaramP
s -> forall a. Show a => a -> Name
showt (SwaramP -> Swaram
unswaram SwaramP
s)
        Paired a SwaramP
_ -> Name
""
    pad :: [Name] -> [Name]
pad = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SwaramP]
all_swarams forall a. Num a => a -> a -> a
+ Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Name
"")

justify :: [Text] -> Text
justify :: [Name] -> Name
justify = [Name] -> Name
Text.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> Name -> Name
Text.justifyLeft Int
5 Char
' ')