-- | Common music keys.
module Music.Theory.Key where

import Control.Monad {- base -}
import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Music.Theory.List as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Pitch.Name as T
import qualified Music.Theory.Pitch.Note as T
import qualified Music.Theory.Interval as T

-- | Enumeration of common music notation modes.
data Mode = Minor_Mode | Major_Mode
              deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq,Eq Mode
Mode -> Mode -> Bool
Mode -> Mode -> Ordering
Mode -> Mode -> Mode
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 :: Mode -> Mode -> Mode
$cmin :: Mode -> Mode -> Mode
max :: Mode -> Mode -> Mode
$cmax :: Mode -> Mode -> Mode
>= :: Mode -> Mode -> Bool
$c>= :: Mode -> Mode -> Bool
> :: Mode -> Mode -> Bool
$c> :: Mode -> Mode -> Bool
<= :: Mode -> Mode -> Bool
$c<= :: Mode -> Mode -> Bool
< :: Mode -> Mode -> Bool
$c< :: Mode -> Mode -> Bool
compare :: Mode -> Mode -> Ordering
$ccompare :: Mode -> Mode -> Ordering
Ord,Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

-- | Pretty printer for 'Mode'.
mode_pp :: Mode -> String
mode_pp :: Mode -> String
mode_pp Mode
m =
    case Mode
m of
      Mode
Minor_Mode -> String
"Minor"
      Mode
Major_Mode -> String
"Major"

-- | Lower-cased 'mode_pp'.
mode_identifier_pp :: Mode -> String
mode_identifier_pp :: Mode -> String
mode_identifier_pp = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode -> String
mode_pp

-- | There are two modes, given one return the other.
mode_parallel :: Mode -> Mode
mode_parallel :: Mode -> Mode
mode_parallel Mode
m = if Mode
m forall a. Eq a => a -> a -> Bool
== Mode
Minor_Mode then Mode
Major_Mode else Mode
Minor_Mode

mode_pc_seq :: Num t => Mode -> [t]
mode_pc_seq :: forall t. Num t => Mode -> [t]
mode_pc_seq Mode
md =
    case Mode
md of
      Mode
Major_Mode -> [t
0,t
2,t
4,t
5,t
7,t
9,t
11]
      Mode
Minor_Mode -> [t
0,t
2,t
3,t
5,t
7,t
8,t
10]

-- | A common music notation key is a 'Note', 'Alteration', 'Mode' triple.
type Key = (T.Note,T.Alteration,Mode)

-- | 'Mode' of 'Key'.
key_mode :: Key -> Mode
key_mode :: Key -> Mode
key_mode (Note
_,Alteration
_,Mode
m) = Mode
m

-- | Enumeration of 42 CMN keys.
--
-- > length key_sequence_42 == 7 * 3 * 2
key_sequence_42 :: [Key]
key_sequence_42 :: [Key]
key_sequence_42 =
    let a_seq :: [Alteration]
a_seq = [Alteration
T.Flat,Alteration
T.Natural,Alteration
T.Sharp]
        m_seq :: [Mode]
m_seq = [Mode
Major_Mode,Mode
Minor_Mode]
    in [(Note
n,Alteration
a,Mode
m) | Note
n <- [Note]
T.note_seq,Alteration
a <- [Alteration]
a_seq,Mode
m <- [Mode]
m_seq]

-- | Subset of 'key_sequence' not including very eccentric keys (where
-- there are more than 7 alterations).
--
-- > length key_sequence_30 == 30
key_sequence_30 :: [Key]
key_sequence_30 :: [Key]
key_sequence_30 = forall a. (a -> Bool) -> [a] -> [a]
filter (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Ord a => a -> a -> Bool
< Int
8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe Int
key_fifths) [Key]
key_sequence_42

-- | Parallel key, ie. 'mode_parallel' of 'Key'.
key_parallel :: Key -> Key
key_parallel :: Key -> Key
key_parallel (Note
n,Alteration
a,Mode
m) = (Note
n,Alteration
a,Mode -> Mode
mode_parallel Mode
m)

-- | Transposition of 'Key'.
key_transpose :: Key -> Int -> Key
key_transpose :: Key -> Int -> Key
key_transpose (Note
n,Alteration
a,Mode
m) Int
x =
    let pc :: Int
pc = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"key_transpose?") ((Note, Alteration) -> Maybe Int
T.note_alteration_to_pc (Note
n,Alteration
a))
        (Note
n',Alteration
a') = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"key_transpose?") (forall i. Integral i => i -> Maybe (Note, Alteration)
T.pc_to_note_alteration_ks ((Int
pc forall a. Num a => a -> a -> a
+ Int
x) forall a. Integral a => a -> a -> a
`mod` Int
12))
    in (Note
n',Alteration
a',Mode
m)

-- | Relative key (ie. 'mode_parallel' with the same number of and type of alterations.
--
-- > let k = [(T.C,T.Natural,Major_Mode),(T.E,T.Natural,Minor_Mode)]
-- > in map (key_lc_uc_pp . key_relative) k == ["a♮","G♮"]
key_relative :: Key -> Key
key_relative :: Key -> Key
key_relative Key
k =
    case Key -> Mode
key_mode Key
k of
      Mode
Major_Mode -> Key -> Key
key_parallel (Key -> Int -> Key
key_transpose Key
k Int
9)
      Mode
Minor_Mode -> Key -> Key
key_parallel (Key -> Int -> Key
key_transpose Key
k Int
3)

-- | Mediant minor of major key.
--
-- > key_mediant (T.C,T.Natural,Major_Mode) == Just (T.E,T.Natural,Minor_Mode)
key_mediant :: Key -> Maybe Key
key_mediant :: Key -> Maybe Key
key_mediant Key
k =
    case Key -> Mode
key_mode Key
k of
      Mode
Major_Mode -> forall a. a -> Maybe a
Just (Key -> Key
key_parallel (Key -> Int -> Key
key_transpose Key
k Int
4))
      Mode
_ -> forall a. Maybe a
Nothing

-- > fmap key_pc_set (key_lc_uc_parse "E")
key_pc_set :: Integral i => Key -> [i]
key_pc_set :: forall i. Integral i => Key -> [i]
key_pc_set (Note
n,Alteration
a,Mode
md) =
    let pc0 :: i
pc0 = forall i. Num i => Note -> i
T.note_to_pc Note
n forall a. Num a => a -> a -> a
+ forall i. Integral i => Alteration -> i
T.alteration_to_diff_err Alteration
a
    in forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Integral a => a -> a -> a
`mod` i
12) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ i
pc0)) (forall t. Num t => Mode -> [t]
mode_pc_seq Mode
md))

-- | Pretty-printer where 'Minor_Mode' is written in lower case (lc) and
-- alteration symbol is shown using indicated function.
key_lc_pp :: (T.Alteration -> String) -> Key -> String
key_lc_pp :: (Alteration -> String) -> Key -> String
key_lc_pp Alteration -> String
a_pp (Note
n,Alteration
a,Mode
m) =
    let c :: Char
c = Note -> Char
T.note_pp Note
n
        c' :: Char
c' = if Mode
m forall a. Eq a => a -> a -> Bool
== Mode
Minor_Mode then Char -> Char
toLower Char
c else Char
c
    in Char
c' forall a. a -> [a] -> [a]
: Alteration -> String
a_pp Alteration
a

-- | 'key_lc_pp' with unicode (uc) alteration.
--
-- > map key_lc_uc_pp [(C,Sharp,Minor_Mode),(E,Flat,Major_Mode)] == ["c♯","E♭"]
key_lc_uc_pp :: Key -> String
key_lc_uc_pp :: Key -> String
key_lc_uc_pp = (Alteration -> String) -> Key -> String
key_lc_pp (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alteration -> Char
T.alteration_symbol)

-- | 'key_lc_pp' with ISO alteration.
key_lc_iso_pp :: Key -> String
key_lc_iso_pp :: Key -> String
key_lc_iso_pp = (Alteration -> String) -> Key -> String
key_lc_pp Alteration -> String
T.alteration_iso

-- | 'key_lc_pp' with tonh alteration.
--
-- > map key_lc_tonh_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)]
key_lc_tonh_pp :: Key -> String
key_lc_tonh_pp :: Key -> String
key_lc_tonh_pp = (Alteration -> String) -> Key -> String
key_lc_pp Alteration -> String
T.alteration_tonh

-- > map key_identifier_pp [(T.C,T.Sharp,Minor_Mode),(T.E,T.Flat,Major_Mode)]
key_identifier_pp :: (Show a, Show a1) => (a, a1, Mode) -> [Char]
key_identifier_pp :: forall a a1. (Show a, Show a1) => (a, a1, Mode) -> String
key_identifier_pp (a
n,a1
a,Mode
m) = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall a. [a] -> [[a]] -> [a]
intercalate String
"_" [forall a. Show a => a -> String
show a
n,forall a. Show a => a -> String
show a1
a,Mode -> String
mode_pp Mode
m])

-- > import Data.Maybe
-- > mapMaybe note_char_to_key "CdEfGaB"
note_char_to_key :: Char -> Maybe Key
note_char_to_key :: Char -> Maybe Key
note_char_to_key Char
c =
    let m :: Mode
m = if Char -> Bool
isUpper Char
c then Mode
Major_Mode else Mode
Minor_Mode
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Note
n -> (Note
n,Alteration
T.Natural,Mode
m)) (Bool -> Char -> Maybe Note
T.parse_note_t Bool
True Char
c)

-- | Parse 'Key' from /lc-uc/ string.
--
-- > let k = mapMaybe key_lc_uc_parse ["c","E","f♯","ab","G#"]
-- > map key_lc_uc_pp k == ["c♮","E♮","f♯","a♭","G♯"]
key_lc_uc_parse :: String -> Maybe Key
key_lc_uc_parse :: String -> Maybe Key
key_lc_uc_parse String
k =
    let with_k :: b -> (a, b, c) -> (a, b, c)
with_k b
a (a
n,b
_,c
m) = (a
n,b
a,c
m)
        with_a :: Char -> b -> Maybe (Note, b, Mode)
with_a Char
n b
a = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {b} {a} {b} {c}. b -> (a, b, c) -> (a, b, c)
with_k b
a) (Char -> Maybe Key
note_char_to_key Char
n)
    in case String
k of
         [Char
c] -> Char -> Maybe Key
note_char_to_key Char
c
         [Char
n,Char
a] -> forall {b}. Char -> b -> Maybe (Note, b, Mode)
with_a Char
n forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Char -> Maybe Alteration
T.symbol_to_alteration_unicode_plus_iso Char
a
         String
_ -> forall a. Maybe a
Nothing

-- | Distance along circle of fifths path of indicated 'Key'.  A
-- positive number indicates the number of sharps, a negative number
-- the number of flats.
--
-- > key_fifths (T.A,T.Natural,Minor_Mode) == Just 0
-- > key_fifths (T.A,T.Natural,Major_Mode) == Just 3
-- > key_fifths (T.C,T.Natural,Minor_Mode) == Just (-3)
-- > key_fifths (T.B,T.Sharp,Minor_Mode) == Just 9
-- > key_fifths (T.E,T.Sharp,Major_Mode) == Just 11
-- > key_fifths (T.B,T.Sharp,Major_Mode) == Nothing
--
-- > zip (map key_lc_iso_pp key_sequence_42) (map key_fifths key_sequence_42)
key_fifths :: Key -> Maybe Int
key_fifths :: Key -> Maybe Int
key_fifths (Note
n,Alteration
a,Mode
m) =
    let cf :: Pitch -> [Pitch]
cf Pitch
x = let ([Pitch]
p,[Pitch]
q) = Pitch -> ([Pitch], [Pitch])
T.circle_of_fifths Pitch
x in [Pitch]
p forall a. [a] -> [a] -> [a]
++ [Pitch]
q
        eq :: Pitch -> Bool
eq (T.Pitch Note
n' Alteration
a' Int
_) = Note
n forall a. Eq a => a -> a -> Bool
== Note
n' Bool -> Bool -> Bool
&& Alteration
a forall a. Eq a => a -> a -> Bool
== Alteration
a'
        ix :: Maybe Int
ix = case Mode
m of
               Mode
Major_Mode -> forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex Pitch -> Bool
eq (Pitch -> [Pitch]
cf Pitch
T.c4)
               Mode
Minor_Mode -> forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex Pitch -> Bool
eq (Pitch -> [Pitch]
cf Pitch
T.a4)
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> if Int
i forall a. Ord a => a -> a -> Bool
< Int
13 then forall a. Num a => a -> a
negate Int
i else Int
i forall a. Num a => a -> a -> a
- Int
12) Maybe Int
ix

-- | Table mapping 'Key' to 'key_fifths' value.
key_fifths_tbl :: [(Key,Int)]
key_fifths_tbl :: [(Key, Int)]
key_fifths_tbl =
    let f :: (a, f b) -> f (a, b)
f (a
k,f b
n) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
n' -> (a
k,b
n')) f b
n
    in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {f :: * -> *} {a} {b}. Functor f => (a, f b) -> f (a, b)
f (forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
key_sequence_42 (forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe Int
key_fifths [Key]
key_sequence_42))

-- | Lookup 'key_fifths' value in 'key_fifths_tbl'.
--
-- > let a = [0,1,-1,2,-2,3,-3,4,-4,5,-5]
-- > let f md = map key_lc_iso_pp . mapMaybe (fifths_to_key md)
-- > f Minor_Mode a
-- > f Major_Mode a
fifths_to_key :: Mode -> Int -> Maybe Key
fifths_to_key :: Mode -> Int -> Maybe Key
fifths_to_key Mode
md Int
n =
    let eq_f :: ((a, b, Mode), Int) -> Bool
eq_f = (\((a
_,b
_,Mode
md'),Int
n') -> Mode
md forall a. Eq a => a -> a -> Bool
== Mode
md' Bool -> Bool -> Bool
&& Int
n forall a. Eq a => a -> a -> Bool
== Int
n')
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall {a} {b}. ((a, b, Mode), Int) -> Bool
eq_f [(Key, Int)]
key_fifths_tbl)

-- | Given sorted pitch-class set, find simplest implied key in given mode.
--
-- > mapMaybe (implied_key Major_Mode) [[0,2,4],[1,3],[4,10],[3,9],[8,9]]
-- > map (implied_key Major_Mode) [[0,1,2],[0,1,3,4]] == [Nothing,Nothing]
implied_key :: Integral i => Mode -> [i] -> Maybe Key
implied_key :: forall i. Integral i => Mode -> [i] -> Maybe Key
implied_key Mode
md [i]
pc_set =
    let a_seq :: [Int]
a_seq = [Int
0,Int
1,-Int
1,Int
2,-Int
2,Int
3,-Int
3,Int
4,-Int
4,Int
5,-Int
5,Int
6,-Int
6]
        key_seq :: [Key]
key_seq = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Mode -> Int -> Maybe Key
fifths_to_key Mode
md) [Int]
a_seq
    in forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Key
k -> [i]
pc_set forall a. Eq a => [a] -> [a] -> Bool
`T.is_subset` forall i. Integral i => Key -> [i]
key_pc_set Key
k) [Key]
key_seq

-- | 'key_fifths' of 'implied_key'.
implied_fifths :: Integral i => Mode -> [i] -> Maybe Int
implied_fifths :: forall i. Integral i => Mode -> [i] -> Maybe Int
implied_fifths Mode
md = Key -> Maybe Int
key_fifths forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall i. Integral i => Mode -> [i] -> Maybe Key
implied_key Mode
md

implied_key_err :: Integral i => Mode -> [i] -> Key
implied_key_err :: forall i. Integral i => Mode -> [i] -> Key
implied_key_err Mode
md = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"implied_key") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => Mode -> [i] -> Maybe Key
implied_key Mode
md

implied_fifths_err :: Integral i => Mode -> [i] -> Int
implied_fifths_err :: forall i. Integral i => Mode -> [i] -> Int
implied_fifths_err Mode
md = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"implied_fifths") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Maybe Int
key_fifths forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => Mode -> [i] -> Key
implied_key_err Mode
md