module Mezzo.Model.Harmony.Functional
(
Quality (..)
, Degree (..)
, Piece (..)
, Phrase (..)
, Cadence (..)
, Tonic (..)
, Dominant (..)
, Subdominant (..)
, PieceToChords
)
where
import GHC.TypeLits
import Data.Kind
import Mezzo.Model.Types hiding (IntervalClass (..))
import Mezzo.Model.Prim
import Mezzo.Model.Harmony.Chords
data Quality = MajQ | MinQ | DomQ | DimQ
data Degree (d :: ScaleDegree) (q :: Quality) (k :: KeyType) (i :: Inversion) where
DegChord :: Degree d q k i
class DiatonicDegree (d :: ScaleDegree) (q :: Quality) (k :: KeyType)
instance MajDegQuality d q => DiatonicDegree d q (Key pc acc MajorMode)
instance MinDegQuality d q => DiatonicDegree d q (Key pc acc MinorMode)
class MajDegQuality (d :: ScaleDegree) (q :: Quality)
instance MajDegQuality I MajQ
instance MajDegQuality II MinQ
instance MajDegQuality II DomQ
instance MajDegQuality III MinQ
instance MajDegQuality IV MajQ
instance MajDegQuality V MajQ
instance MajDegQuality V DomQ
instance MajDegQuality VI MinQ
instance MajDegQuality VII DimQ
instance TypeError (Text "Can't have a "
:<>: ShowQual q
:<>: ShowDeg d
:<>: Text " degree chord in major mode.")
=> MajDegQuality d q
class MinDegQuality (d :: ScaleDegree) (q :: Quality)
instance MinDegQuality I MinQ
instance MinDegQuality II DimQ
instance MinDegQuality II DomQ
instance MinDegQuality III MajQ
instance MinDegQuality IV MinQ
instance MinDegQuality V MajQ
instance MinDegQuality V DomQ
instance MinDegQuality VI MajQ
instance MinDegQuality VII MajQ
instance TypeError (Text "Can't have a "
:<>: ShowType q :<>: Text " "
:<>: ShowType d
:<>: Text " degree chord in minor mode.")
=> MinDegQuality d q
data Piece (k :: KeyType) (l :: Nat) where
Cad :: Cadence k l -> Piece k l
(:=) :: Phrase k l -> Piece k (n l) -> Piece k n
data Phrase (k :: KeyType) (l :: Nat) where
PhraseIVI :: Tonic k (l2 l1) -> Dominant k l1 -> Tonic k (l l2) -> Phrase k l
PhraseVI :: Dominant k l1 -> Tonic k (l l1) -> Phrase k l
data Cadence (k :: KeyType) (l :: Nat) where
AuthCad :: Degree V MajQ k Inv1 -> Degree I q k Inv0 -> Cadence k 2
AuthCad7 :: Degree V DomQ k Inv2 -> Degree I q k Inv0 -> Cadence k 2
AuthCadVii :: Degree VII DimQ k Inv0 -> Degree I q k Inv0 -> Cadence k 2
AuthCad64 :: Degree I MajQ k Inv2 -> Degree V DomQ k Inv3 -> Degree I MajQ k Inv1 -> Cadence k 3
HalfCad :: Degree d q k i -> Degree V MajQ k Inv0 -> Cadence k 2
DeceptCad :: Degree V DomQ k Inv0 -> Degree VI q k Inv2 -> Cadence k 2
data Tonic (k :: KeyType) (l :: Nat) where
TonMaj :: Degree I MajQ k Inv0 -> Tonic k 1
TonMin :: Degree I MinQ k Inv0 -> Tonic k 1
class NotInv2 (i :: Inversion)
instance NotInv2 Inv0
instance TypeError (Text "Can't have a tonic in second inversion.") => NotInv2 Inv2
instance NotInv2 Inv1
instance NotInv2 Inv3
data Dominant (k :: KeyType) (l :: Nat) where
DomVM :: Degree V MajQ k i -> Dominant k 1
DomV7 :: Degree V DomQ k i -> Dominant k 1
DomVii0 :: Degree VII DimQ k i -> Dominant k 1
DomSD :: Subdominant k l1 -> Dominant k (l l1) -> Dominant k l
DomSecD :: Degree II DomQ k Inv0 -> Degree V DomQ k Inv2 -> Dominant k 2
data Subdominant (k :: KeyType) (l :: Nat) where
SubIIm :: Degree II MinQ k i -> Subdominant k 1
SubIVM :: Degree IV MajQ k i -> Subdominant k 1
SubIIImIVM :: Degree III MinQ k i1 -> Degree IV MajQ k i2 -> Subdominant k 2
SubIVm :: Degree IV MinQ k i -> Subdominant k 1
type family DegToChord (d :: Degree d q k i) :: ChordType 4 where
DegToChord (DegChord :: Degree d q k i) = SeventhChord (DegreeRoot k d) (QualToType q) i
type family QualToType (q :: Quality) :: SeventhType where
QualToType MajQ = Doubled MajTriad
QualToType MinQ = Doubled MinTriad
QualToType DomQ = MajMinSeventh
QualToType DimQ = DimSeventh
type family CadToChords (c :: Cadence k l) :: Vector (ChordType 4) l where
CadToChords (AuthCad d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords (AuthCad7 d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords (AuthCadVii d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords (AuthCad64 d1 d2 d3) = DegToChord d1 :-- DegToChord d2 :-- DegToChord d3 :-- None
CadToChords (HalfCad d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords (DeceptCad d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
type family TonToChords (t :: Tonic k l) :: Vector (ChordType 4) l where
TonToChords (TonMaj d) = DegToChord d :-- None
TonToChords (TonMin d) = DegToChord d :-- None
type family DomToChords (l :: Nat) (t :: Dominant k l) :: Vector (ChordType 4) l where
DomToChords 1 (DomVM d) = DegToChord d :-- None
DomToChords 1 (DomV7 d) = DegToChord d :-- None
DomToChords 1 (DomVii0 d) = DegToChord d :-- None
DomToChords l (DomSD (s :: Subdominant k l1) d) =
SubdomToChords s ++. DomToChords (l l1) d
DomToChords 2 (DomSecD d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
type family SubdomToChords (t :: Subdominant k l) :: Vector (ChordType 4) l where
SubdomToChords (SubIIm d) = DegToChord d :-- None
SubdomToChords (SubIVM d) = DegToChord d :-- None
SubdomToChords (SubIIImIVM d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
SubdomToChords (SubIVm d) = DegToChord d :-- None
type family PhraseToChords (l :: Nat) (p :: Phrase k l) :: Vector (ChordType 4) l where
PhraseToChords l (PhraseIVI t1 (d :: Dominant k dl) t2) = TonToChords t1 ++. DomToChords dl d ++. TonToChords t2
PhraseToChords l (PhraseVI (d :: Dominant k dl) t) = DomToChords dl d ++. TonToChords t
type family PieceToChords (l :: Nat) (p :: Piece k l) :: Vector (ChordType 4) l where
PieceToChords l (Cad (c :: Cadence k l)) = CadToChords c
PieceToChords l ((p :: Phrase k l1) := ps) = PhraseToChords l1 p ++. PieceToChords (l l1) ps
type family ShowQual (q :: Quality) :: ErrorMessage where
ShowQual MajQ = Text "major "
ShowQual MinQ = Text "minor "
ShowQual DomQ = Text "dominant "
ShowQual DimQ = Text "diminished "
type family ShowDeg (d :: ScaleDegree) :: ErrorMessage where
ShowDeg I = Text "1st"
ShowDeg II = Text "2nd"
ShowDeg III = Text "3rd"
ShowDeg IV = Text "4th"
ShowDeg V = Text "5th"
ShowDeg VI = Text "6th"
ShowDeg VII = Text "7th"