module Music.Theory.Key where
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
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
data Mode_T = Minor_Mode | Major_Mode
deriving (Eq,Ord,Show)
mode_pp :: Mode_T -> String
mode_pp m =
case m of
Minor_Mode -> "Minor"
Major_Mode -> "Major"
mode_identifier_pp :: Mode_T -> String
mode_identifier_pp = map toLower . mode_pp
mode_parallel :: Mode_T -> Mode_T
mode_parallel m = if m == Minor_Mode then Major_Mode else Minor_Mode
mode_pc_seq :: Num t => Mode_T -> [t]
mode_pc_seq md =
case md of
Major_Mode -> [0,2,4,5,7,9,11]
Minor_Mode -> [0,2,3,5,7,8,10]
type Key = (T.Note_T,T.Alteration_T,Mode_T)
key_mode :: Key -> Mode_T
key_mode (_,_,m) = m
key_sequence_42 :: [Key]
key_sequence_42 =
let a_seq = [T.Flat,T.Natural,T.Sharp]
m_seq = [Major_Mode,Minor_Mode]
in [(n,a,m) | n <- T.note_seq,a <- a_seq,m <- m_seq]
key_sequence_30 :: [Key]
key_sequence_30 = filter (\k -> maybe False ((< 8) . abs) (key_fifths k)) key_sequence_42
key_parallel :: Key -> Key
key_parallel (n,a,m) = (n,a,mode_parallel m)
key_transpose :: Key -> Int -> Key
key_transpose (n,a,m) x =
let Just pc = T.note_alteration_to_pc (n,a)
Just (n',a') = T.pc_to_note_alteration_ks ((pc + x) `mod` 12)
in (n',a',m)
key_relative :: Key -> Key
key_relative k =
case key_mode k of
Major_Mode -> key_parallel (key_transpose k 9)
Minor_Mode -> key_parallel (key_transpose k 3)
key_mediant :: Key -> Maybe Key
key_mediant k =
case key_mode k of
Major_Mode -> Just (key_parallel (key_transpose k 4))
_ -> Nothing
key_pc_set :: Integral i => Key -> [i]
key_pc_set (n,a,md) =
let pc0 = T.note_to_pc n + T.alteration_to_diff_err a
in sort (map ((`mod` 12) . (+ pc0)) (mode_pc_seq md))
key_lc_pp :: (T.Alteration_T -> String) -> Key -> String
key_lc_pp a_pp (n,a,m) =
let c = T.note_pp n
c' = if m == Minor_Mode then toLower c else c
in c' : a_pp a
key_lc_uc_pp :: Key -> String
key_lc_uc_pp = key_lc_pp (return . T.alteration_symbol)
key_lc_iso_pp :: Key -> String
key_lc_iso_pp = key_lc_pp T.alteration_iso
key_lc_tonh_pp :: Key -> String
key_lc_tonh_pp = key_lc_pp T.alteration_tonh
key_identifier_pp :: (Show a, Show a1) => (a, a1, Mode_T) -> [Char]
key_identifier_pp (n,a,m) = map toLower (intercalate "_" [show n,show a,mode_pp m])
note_char_to_key :: Char -> Maybe Key
note_char_to_key c =
let m = if isUpper c then Major_Mode else Minor_Mode
in fmap (\n -> (n,T.Natural,m)) (T.parse_note_t True c)
key_lc_uc_parse :: String -> Maybe Key
key_lc_uc_parse k =
let with_k a (n,_,m) = (n,a,m)
with_a n a = fmap (with_k a) (note_char_to_key n)
in case k of
[c] -> note_char_to_key c
[n,a] -> join (fmap (with_a n) (T.symbol_to_alteration_iso a))
_ -> Nothing
key_fifths :: Key -> Maybe Int
key_fifths (n,a,m) =
let cf x = let (p,q) = T.circle_of_fifths x in p ++ q
eq (T.Pitch n' a' _) = n == n' && a == a'
ix = case m of
Major_Mode -> findIndex eq (cf T.c4)
Minor_Mode -> findIndex eq (cf T.a4)
in fmap (\i -> if i < 13 then negate i else i 12) ix
key_fifths_tbl :: [(Key,Int)]
key_fifths_tbl =
let f (k,n) = maybe Nothing (\n' -> Just (k,n')) n
in mapMaybe f (zip key_sequence_42 (map key_fifths key_sequence_42))
fifths_to_key :: Mode_T -> Int -> Maybe Key
fifths_to_key md n =
let eq_f = (\((_,_,md'),n') -> md == md' && n == n')
in fmap fst (find eq_f key_fifths_tbl)
implied_key :: Integral i => Mode_T -> [i] -> Maybe Key
implied_key md pc_set =
let a_seq = [0,1,1,2,2,3,3,4,4,5,5,6,6]
key_seq = mapMaybe (fifths_to_key md) a_seq
in find (\k -> pc_set `T.is_subset` key_pc_set k) key_seq
implied_fifths :: Integral i => Mode_T -> [i] -> Maybe Int
implied_fifths md = join . fmap key_fifths . implied_key md
implied_key_err :: Integral i => Mode_T -> [i] -> Key
implied_key_err md = fromMaybe (error "implied_key") . implied_key md
implied_fifths_err :: Integral i => Mode_T -> [i] -> Int
implied_fifths_err md = fromMaybe (error "implied_fifths") . key_fifths . implied_key_err md