module Music.Theory.Pitch.Chord where

import Data.List {- base -}
import Data.Maybe {- base -}

import qualified Text.Parsec as P {- parsec -}

import qualified Music.Theory.Key as T {- hmt -}
import qualified Music.Theory.List as T {- hmt -}
import qualified Music.Theory.Parse as T {- hmt -}
import qualified Music.Theory.Pitch.Note as T {- hmt -}

type Pc = (T.Note,T.Alteration)

pc_pp :: Pc -> [Char]
pc_pp :: Pc -> [Char]
pc_pp (Note
n,Alteration
a) = Note -> Char
T.note_pp Note
n forall a. a -> [a] -> [a]
: Alteration -> [Char]
T.alteration_iso Alteration
a

-- | D = dominant, M = major
data Extension = D7 | M7 deriving (Extension -> Extension -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Extension -> Extension -> Bool
$c/= :: Extension -> Extension -> Bool
== :: Extension -> Extension -> Bool
$c== :: Extension -> Extension -> Bool
Eq,Int -> Extension -> ShowS
[Extension] -> ShowS
Extension -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Extension] -> ShowS
$cshowList :: [Extension] -> ShowS
show :: Extension -> [Char]
$cshow :: Extension -> [Char]
showsPrec :: Int -> Extension -> ShowS
$cshowsPrec :: Int -> Extension -> ShowS
Show)

extension_tbl :: Num n => [(Extension, (String,n))]
extension_tbl :: forall n. Num n => [(Extension, ([Char], n))]
extension_tbl = [(Extension
D7,([Char]
"7",n
10)),(Extension
M7,([Char]
"M7",n
11))]

extension_dat :: Num n => Extension -> (String,n)
extension_dat :: forall n. Num n => Extension -> ([Char], n)
extension_dat = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. Eq k => k -> [(k, v)] -> v
T.lookup_err forall n. Num n => [(Extension, ([Char], n))]
extension_tbl

extension_pp :: Extension -> String
extension_pp :: Extension -> [Char]
extension_pp = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall n. Num n => Extension -> ([Char], n)
extension_dat :: Extension -> (String,Int))

extension_to_pc :: Num n => Extension -> n
extension_to_pc :: forall n. Num n => Extension -> n
extension_to_pc = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Num n => Extension -> ([Char], n)
extension_dat

data Chord_Type = Major | Minor
                | Augmented | Diminished
                | Diminished_7 | Half_Diminished
                | Suspended_2 | Suspended_4
                  deriving (Chord_Type -> Chord_Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Chord_Type -> Chord_Type -> Bool
$c/= :: Chord_Type -> Chord_Type -> Bool
== :: Chord_Type -> Chord_Type -> Bool
$c== :: Chord_Type -> Chord_Type -> Bool
Eq,Int -> Chord_Type -> ShowS
[Chord_Type] -> ShowS
Chord_Type -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Chord_Type] -> ShowS
$cshowList :: [Chord_Type] -> ShowS
show :: Chord_Type -> [Char]
$cshow :: Chord_Type -> [Char]
showsPrec :: Int -> Chord_Type -> ShowS
$cshowsPrec :: Int -> Chord_Type -> ShowS
Show)

is_suspended :: Chord_Type -> Bool
is_suspended :: Chord_Type -> Bool
is_suspended Chord_Type
ty = Chord_Type
ty forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Chord_Type
Suspended_2,Chord_Type
Suspended_4]

-- | Names and pc-sets for chord types.
-- The name used here is in the first position, alternates follow.
chord_type_tbl :: Num n => [(Chord_Type,([String],[n]))]
chord_type_tbl :: forall n. Num n => [(Chord_Type, ([[Char]], [n]))]
chord_type_tbl =
    [(Chord_Type
Major,([[Char]
"",[Char]
"M",[Char]
"maj"],[n
0,n
4,n
7]))
    ,(Chord_Type
Minor,([[Char]
"m",[Char]
"min"],[n
0,n
3,n
7]))
    ,(Chord_Type
Augmented,([[Char]
"+",[Char]
"aug"],[n
0,n
4,n
8]))
    ,(Chord_Type
Diminished,([[Char]
"o",[Char]
"dim"],[n
0,n
3,n
6]))
    ,(Chord_Type
Diminished_7,([[Char]
"o7",[Char]
"dim7"],[n
0,n
3,n
6,n
9]))
    ,(Chord_Type
Half_Diminished,([[Char]
"Ø",[Char]
"halfdim",[Char]
"m7(b5)"],[n
0,n
3,n
6,n
10]))
    ,(Chord_Type
Suspended_2,([[Char]
"sus2"],[n
0,n
2,n
7]))
    ,(Chord_Type
Suspended_4,([[Char]
"sus4"],[n
0,n
5,n
7]))]

chord_type_dat :: Num n => Chord_Type -> ([String],[n])
chord_type_dat :: forall n. Num n => Chord_Type -> ([[Char]], [n])
chord_type_dat = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. Eq k => k -> [(k, v)] -> v
T.lookup_err forall n. Num n => [(Chord_Type, ([[Char]], [n]))]
chord_type_tbl

chord_type_pp :: Chord_Type -> String
chord_type_pp :: Chord_Type -> [Char]
chord_type_pp = forall a. [a] -> a
head 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
. (forall n. Num n => Chord_Type -> ([[Char]], [n])
chord_type_dat :: Chord_Type -> ([String],[Int]))

chord_type_pcset :: Num n => Chord_Type -> [n]
chord_type_pcset :: forall n. Num n => Chord_Type -> [n]
chord_type_pcset = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Num n => Chord_Type -> ([[Char]], [n])
chord_type_dat

-- (root,mode,extensions,bass)
data Chord = Chord Pc Chord_Type (Maybe Extension) (Maybe Pc)
             deriving (Int -> Chord -> ShowS
[Chord] -> ShowS
Chord -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Chord] -> ShowS
$cshowList :: [Chord] -> ShowS
show :: Chord -> [Char]
$cshow :: Chord -> [Char]
showsPrec :: Int -> Chord -> ShowS
$cshowsPrec :: Int -> Chord -> ShowS
Show)

chord_pcset :: Chord -> (Maybe Int,[Int])
chord_pcset :: Chord -> (Maybe Int, [Int])
chord_pcset (Chord Pc
pc Chord_Type
ty Maybe Extension
ex Maybe Pc
bs) =
    let get :: Pc -> Int
get = forall a. [Char] -> Maybe a -> a
m_error [Char]
"chord_pcset" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pc -> Maybe Int
T.note_alteration_to_pc
        pc' :: Int
pc' = Pc -> Int
get Pc
pc
        ty' :: [Int]
ty' = forall n. Num n => Chord_Type -> [n]
chord_type_pcset Chord_Type
ty
        ex' :: Maybe Int
ex' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Num n => Extension -> n
extension_to_pc Maybe Extension
ex
        bs' :: Maybe Int
bs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pc -> Int
get Maybe Pc
bs
        ch :: [Int]
ch = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Integral a => a -> a -> a
`mod` Int
12) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
pc')) ([Int]
ty' forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
ex')
        ch' :: [Int]
ch' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Int]
ch (forall a. Eq a => a -> [a] -> [a]
`delete` [Int]
ch) Maybe Int
bs'
    in (Maybe Int
bs',[Int]
ch')

bass_pp :: Pc -> String
bass_pp :: Pc -> [Char]
bass_pp = (Char
'/' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pc -> [Char]
pc_pp

chord_pp :: Chord -> String
chord_pp :: Chord -> [Char]
chord_pp (Chord Pc
pc Chord_Type
ty Maybe Extension
ex Maybe Pc
bs) =
    let (Maybe Chord_Type
pre_ty,Maybe Chord_Type
post_ty) = if Chord_Type -> Bool
is_suspended Chord_Type
ty
                           then (forall a. Maybe a
Nothing,forall a. a -> Maybe a
Just Chord_Type
ty)
                           else (forall a. a -> Maybe a
Just Chord_Type
ty,forall a. Maybe a
Nothing)
    in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Pc -> [Char]
pc_pp Pc
pc
              ,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" Chord_Type -> [Char]
chord_type_pp Maybe Chord_Type
pre_ty
              ,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" Extension -> [Char]
extension_pp Maybe Extension
ex
              ,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" Chord_Type -> [Char]
chord_type_pp Maybe Chord_Type
post_ty
              ,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" Pc -> [Char]
bass_pp Maybe Pc
bs]

m_error :: String -> Maybe a -> a
m_error :: forall a. [Char] -> Maybe a -> a
m_error [Char]
txt = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
txt)

p_pc :: T.P Pc
p_pc :: P Pc
p_pc = do
  Note
n <- P Note
T.p_note_t
  Maybe Alteration
a <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe (Bool -> P Alteration
T.p_alteration_t_iso Bool
True)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Note
n,forall a. a -> Maybe a -> a
fromMaybe Alteration
T.Natural Maybe Alteration
a)

p_mode_m :: T.P T.Mode
p_mode_m :: P Mode
p_mode_m = forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Mode
T.Major_Mode (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'm' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Mode
T.Minor_Mode)

p_chord_type :: T.P Chord_Type
p_chord_type :: P Chord_Type
p_chord_type =
    let m :: ParsecT [Char] u Identity Chord_Type
m = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'm' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Minor
        au :: ParsecT [Char] u Identity Chord_Type
au = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'+' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Augmented
        dm :: ParsecT [Char] u Identity Chord_Type
dm = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'o' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Diminished
        dm7 :: ParsecT [Char] u Identity Chord_Type
dm7 = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
P.string [Char]
"o7" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Diminished_7)
        hdm :: ParsecT [Char] u Identity Chord_Type
hdm = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'Ø' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Half_Diminished
        sus2 :: ParsecT [Char] u Identity Chord_Type
sus2 = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
P.string [Char]
"sus2" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Suspended_2)
        sus4 :: ParsecT [Char] u Identity Chord_Type
sus4 = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
P.string [Char]
"sus4" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Chord_Type
Suspended_4)
    in forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Chord_Type
Major (forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice [forall {u}. ParsecT [Char] u Identity Chord_Type
dm7,forall {u}. ParsecT [Char] u Identity Chord_Type
dm,forall {u}. ParsecT [Char] u Identity Chord_Type
hdm,forall {u}. ParsecT [Char] u Identity Chord_Type
au,forall {u}. ParsecT [Char] u Identity Chord_Type
sus2,forall {u}. ParsecT [Char] u Identity Chord_Type
sus4,forall {u}. ParsecT [Char] u Identity Chord_Type
m])

p_extension :: T.P Extension
p_extension :: P Extension
p_extension =
    let d7 :: ParsecT [Char] u Identity Extension
d7 = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'7' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Extension
D7
        m7 :: ParsecT [Char] u Identity Extension
m7 = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
P.string [Char]
"M7" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Extension
M7)
    in forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice [forall {u}. ParsecT [Char] u Identity Extension
d7,forall {u}. ParsecT [Char] u Identity Extension
m7]

p_bass :: T.P (Maybe Pc)
p_bass :: P (Maybe Pc)
p_bass = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'/' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P Pc
p_pc)

p_chord :: T.P Chord
p_chord :: P Chord
p_chord = do
  Pc
pc <- P Pc
p_pc
  Chord_Type
ty <- P Chord_Type
p_chord_type
  Maybe Extension
ex <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
P.optionMaybe P Extension
p_extension
  Maybe Pc
b <- P (Maybe Pc)
p_bass
  Chord_Type
ty' <- P Chord_Type
p_chord_type
  let ty'' :: Chord_Type
ty'' = case (Chord_Type
ty,Chord_Type
ty') of
               (Chord_Type
Major,Chord_Type
Suspended_2) -> Chord_Type
Suspended_2
               (Chord_Type
Major,Chord_Type
Suspended_4) -> Chord_Type
Suspended_4
               (Chord_Type
_,Chord_Type
Major) -> Chord_Type
ty -- ie. nothing
               (Chord_Type, Chord_Type)
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"trailing type not sus2 or sus4: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Chord_Type
ty')
  forall (m :: * -> *) a. Monad m => a -> m a
return (Pc -> Chord_Type -> Maybe Extension -> Maybe Pc -> Chord
Chord Pc
pc Chord_Type
ty'' Maybe Extension
ex Maybe Pc
b)

-- | Parse chord.
--
-- > let ch = words "CmM7 C#o EbM7 Fo7 Gx/D C/E GØ/F Bbsus4/C E7sus2"
-- > let c = map parse_chord ch
-- > map chord_pp c == ch
-- > map chord_pcset c
parse_chord :: String -> Chord
parse_chord :: [Char] -> Chord
parse_chord =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParseError
e -> forall a. HasCallStack => [Char] -> a
error ([Char]
"parse_chord failed\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParseError
e)) forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
P.parse P Chord
p_chord [Char]
""