module Mezzo.Model.Harmony.Functional
(
Quality (..)
, DegreeC (..)
, TimeSignature
, TimeSig (..)
, KeyToQual
, KeyToOtherQual
, IsMajor
, IsMinor
, ProgType (..)
, Phrase (..)
, Cadence (..)
, Tonic (..)
, Dominant (..)
, Subdominant (..)
, ChordsToPartiture
, ProgTypeToChords
, FromProg
, Prog (..)
, Ton (..)
, Dom (..)
, Sub (..)
, Cad (..)
, Phr (..)
)
where
import Mezzo.Model.Reify
import Mezzo.Model.Types hiding (IntervalClass (..))
import Mezzo.Model.Prim
import Mezzo.Model.Harmony.Chords
import GHC.TypeLits
import Data.Kind (Type)
infix 5 :=
data Quality = MajQ | MinQ | DomQ | DimQ
data DegreeC (d :: ScaleDegree) (q :: Quality) (k :: KeyType) (i :: Inversion) (o :: OctaveNum) where
DegChord :: DegreeC d q k i o
type TimeSignature = Nat
data TimeSig (t :: TimeSignature) = TimeSig
type family KeyToQual (k :: KeyType) where
KeyToQual (Key _ _ MajorMode) = MajQ
KeyToQual (Key _ _ MinorMode) = MinQ
type family KeyToOtherQual (k :: KeyType) where
KeyToOtherQual (Key _ _ MajorMode) = MinQ
KeyToOtherQual (Key _ _ MinorMode) = MajQ
type family QualToType (q :: Quality) :: TetradType where
QualToType MajQ = DoubledT MajTriad
QualToType MinQ = DoubledT MinTriad
QualToType DomQ = MajMinSeventh
QualToType DimQ = DimSeventh
class IsMajor (k :: KeyType) (s :: Symbol)
instance IsMajor (Key pc acc MajorMode) s
instance TypeError (Text "Can't have a " :<>: Text s :<>: Text " in minor mode.")
=> IsMajor (Key pc acc MinorMode) s
class IsMinor (k :: KeyType) (s :: Symbol)
instance IsMinor (Key pc acc MinorMode) s
instance TypeError (Text "Can't have a " :<>: Text s :<>: Text " in minor mode.")
=> IsMinor (Key pc acc MajorMode) s
data ProgType (k :: KeyType) (l :: Nat) where
CadPhrase :: Cadence k l -> ProgType k l
(:=) :: Phrase k l -> ProgType k (n l) -> ProgType 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
PhraseI :: Tonic k l -> Phrase k l
data Cadence (k :: KeyType) (l :: Nat) where
AuthCad :: DegreeC V MajQ k Inv1 (OctPred o) -> DegreeC I q k Inv0 o -> Cadence k 2
AuthCad7 :: DegreeC V DomQ k Inv2 (OctPred o) -> DegreeC I q k Inv0 o -> Cadence k 2
AuthCadVii :: DegreeC VII DimQ k Inv1 (OctPred o) -> DegreeC I q k Inv0 o -> Cadence k 2
AuthCad64 :: DegreeC I q k Inv2 o -> DegreeC V DomQ k Inv3 (OctPred o) -> DegreeC I q k Inv1 o -> Cadence k 3
DeceptCad :: DegreeC V DomQ k Inv2 o -> DegreeC VI q k Inv1 o -> Cadence k 2
FullCad :: Subdominant k l1 -> Cadence k (l l1) -> Cadence k l
NoCad :: Cadence k 0
data Tonic (k :: KeyType) (l :: Nat) where
TonT :: DegreeC I (KeyToQual k) k Inv0 o -> Tonic k 1
TonTT :: Tonic k l1 -> Tonic k (l l1) -> Tonic k l
data Dominant (k :: KeyType) (l :: Nat) where
DomVM :: DegreeC V MajQ k Inv2 o -> Dominant k 1
DomV7 :: DegreeC V DomQ k Inv2 o -> Dominant k 1
DomVii0 :: DegreeC VII DimQ k i o -> Dominant k 1
DomSecD :: DegreeC II DomQ k Inv0 o -> DegreeC V DomQ k Inv2 (OctPred o) -> Dominant k 2
DomSD :: Subdominant k l1 -> Dominant k (l l1) -> Dominant k l
DomDD :: Dominant k l1 -> Dominant k (l l1) -> Dominant k l
data Subdominant (k :: KeyType) (l :: Nat) where
SubIV :: DegreeC IV (KeyToQual k) k i o -> Subdominant k 1
SubIIm :: DegreeC II MinQ k i o -> Subdominant k 1
SubIIImIVM :: DegreeC III MinQ k i1 o -> DegreeC IV MajQ k i2 (OctPred o) -> Subdominant k 2
SubSS :: Subdominant k l1 -> Subdominant k (l l1) -> Subdominant k l
type DegToChord (dc :: DegreeC d q k i o) = Tetrad (DegreeRoot k (Degree d Natural o)) (QualToType q) i
type family CadToChords (l :: Nat) (c :: Cadence k l) :: Vector (ChordType 4) l where
CadToChords 2 (AuthCad d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords 2 (AuthCad7 d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords 2 (AuthCadVii d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords 2 (DeceptCad d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
CadToChords 3 (AuthCad64 d1 d2 d3) = DegToChord d1 :-- DegToChord d2 :-- DegToChord d3 :-- None
CadToChords l (FullCad (s :: Subdominant k l1) c) = SubdomToChords l1 s ++. CadToChords (l l1) c
CadToChords 0 NoCad = None
type family TonToChords (l :: Nat) (t :: Tonic k l) :: Vector (ChordType 4) l where
TonToChords 1 (TonT d) = DegToChord d :-- None
TonToChords l (TonTT (t1 :: Tonic k l1) t2) = TonToChords l1 t1 ++. TonToChords (l l1) t2
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 2 (DomSecD d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
DomToChords l (DomSD (s :: Subdominant k l1) d) =
SubdomToChords l1 s ++. DomToChords (l l1) d
DomToChords l (DomDD (d1 :: Dominant k l1) d2) =
DomToChords l1 d1 ++. DomToChords (l l1) d2
type family SubdomToChords (l :: Nat) (t :: Subdominant k l) :: Vector (ChordType 4) l where
SubdomToChords 1 (SubIIm d) = DegToChord d :-- None
SubdomToChords 1 (SubIV d) = DegToChord d :-- None
SubdomToChords 2 (SubIIImIVM d1 d2) = DegToChord d1 :-- DegToChord d2 :-- None
SubdomToChords l (SubSS (s1 :: Subdominant k l1) s2) =
SubdomToChords l1 s1 ++. SubdomToChords (l l1) s2
type family PhraseToChords (l :: Nat) (p :: Phrase k l) :: Vector (ChordType 4) l where
PhraseToChords l (PhraseIVI (t1 :: Tonic k (l2 dl)) (d :: Dominant k dl)
(t2 :: Tonic k (l l2))) =
TonToChords (l2 dl) t1 ++. DomToChords dl d ++. TonToChords (l l2) t2
PhraseToChords l (PhraseVI (d :: Dominant k dl) t) =
DomToChords dl d ++. TonToChords (l dl) t
PhraseToChords l (PhraseI t) =
TonToChords l t
type family ProgTypeToChords (l :: Nat) (p :: ProgType k l) :: Vector (ChordType 4) l where
ProgTypeToChords l (CadPhrase (c :: Cadence k l)) = CadToChords l c
ProgTypeToChords l ((p :: Phrase k l1) := ps) =
PhraseToChords l1 p ++. ProgTypeToChords (l l1) ps
type family ChordsToPartiture (v :: Vector (ChordType n) l) (t :: TimeSignature) :: Partiture n (l * t * 8) where
ChordsToPartiture None _ = (End :-- End :-- End :-- End :-- None)
ChordsToPartiture (c :-- cs) l = FromChord c (l * 8) +|+ ChordsToPartiture cs l
type family FromProg (p :: ProgType k l) (t :: TimeSignature) :: Partiture 4 (l * t * 8) where
FromProg (p :: ProgType k l) t = ChordsToPartiture (ProgTypeToChords l p) t
data Ton (t :: Tonic k d) = Ton
data Dom (d :: Dominant k d) = Dom
data Sub (s :: Subdominant k d) = Sub
data Cad (c :: Cadence k d) = Cad
data Phr (p :: Phrase k d) = Phr
data Prog (p :: ProgType k l) = Prog
instance (ch ~ DegToChord d, IntListRep ch) => Primitive (TonT d) where
type Rep (TonT d) = [[Int]]
prim _ = [prim (Cho @4 @ch)]
pretty _ = "Ton"
instance (IntLListRep t1, IntLListRep t2) => Primitive (TonTT (t1 :: Tonic k dur1) (t2 :: Tonic k (l dur1)) :: Tonic k l) where
type Rep (TonTT t1 t2) = [[Int]]
prim _ = prim (Ton @k @dur1 @t1) ++ prim (Ton @k @(l dur1) @t2)
pretty _ = pretty (Ton @k @dur1 @t1) ++ " | " ++ pretty (Ton @k @(l dur1) @t2)
instance (ch ~ DegToChord d, IntListRep ch) => Primitive (DomVM d) where
type Rep (DomVM d) = [[Int]]
prim _ = [prim (Cho @4 @ch)]
pretty _ = "Dom Maj"
instance (ch ~ DegToChord d, IntListRep ch) => Primitive (DomV7 d) where
type Rep (DomV7 d) = [[Int]]
prim _ = [prim (Cho @4 @ch)]
pretty _ = "Dom Maj7"
instance (ch ~ DegToChord d, IntListRep ch) => Primitive (DomVii0 d) where
type Rep (DomVii0 d) = [[Int]]
prim _ = [prim (Cho @4 @ch)]
pretty _ = "Dom VII0"
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2) => Primitive (DomSecD d1 d2) where
type Rep (DomSecD d1 d2) = [[Int]]
prim _ = [prim (Cho @4 @ch1)] ++ [prim (Cho @4 @ch2)]
pretty _ = "Dom SecD"
instance (IntLListRep sd, IntLListRep d) => Primitive (DomSD (sd :: Subdominant k sdur) (d :: Dominant k (l sdur)) :: Dominant k l) where
type Rep (DomSD sd d) = [[Int]]
prim _ = prim (Sub @k @sdur @sd) ++ prim (Dom @k @(l sdur) @d)
pretty _ = pretty (Sub @k @sdur @sd) ++ " | " ++ pretty (Dom @k @(l sdur) @d)
instance (IntLListRep d1, IntLListRep d2) => Primitive (DomDD (d1 :: Dominant k dur1) (d2 :: Dominant k (l dur1)) :: Dominant k l) where
type Rep (DomDD d1 d2) = [[Int]]
prim _ = prim (Dom @k @dur1 @d1) ++ prim (Dom @k @(l dur1) @d2)
pretty _ = pretty (Dom @k @dur1 @d1) ++ " | " ++ pretty (Dom @k @(l dur1) @d2)
instance (ch ~ DegToChord d, IntListRep ch) => Primitive (SubIIm d) where
type Rep (SubIIm d) = [[Int]]
prim _ = [prim (Cho @4 @ch)]
pretty _ = "Sub ii"
instance (ch ~ DegToChord d, IntListRep ch) => Primitive (SubIV d) where
type Rep (SubIV d) = [[Int]]
prim _ = [prim (Cho @4 @ch)]
pretty _ = "Sub IV"
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2) => Primitive (SubIIImIVM d1 d2) where
type Rep (SubIIImIVM d1 d2) = [[Int]]
prim _ = [prim (Cho @4 @ch1), prim (Cho @4 @ch2)]
pretty _ = "Sub iii IV"
instance (IntLListRep s1, IntLListRep s2) => Primitive (SubSS (s1 :: Subdominant k dur1) (s2 :: Subdominant k (l dur1)) :: Subdominant k l) where
type Rep (SubSS s1 s2) = [[Int]]
prim _ = prim (Sub @k @dur1 @s1) ++ prim (Sub @k @(l dur1) @s2)
pretty _ = pretty (Sub @k @dur1 @s1) ++ " | " ++ pretty (Sub @k @(l dur1) @s2)
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2) => Primitive (AuthCad d1 d2) where
type Rep (AuthCad d1 d2) = [[Int]]
prim _ = [prim (Cho @4 @ch1), prim (Cho @4 @ch2)]
pretty _ = "AuthCad V"
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2) => Primitive (AuthCad7 d1 d2) where
type Rep (AuthCad7 d1 d2) = [[Int]]
prim _ = [prim (Cho @4 @ch1), prim (Cho @4 @ch2)]
pretty _ = "AuthCad V7"
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2) => Primitive (AuthCadVii d1 d2) where
type Rep (AuthCadVii d1 d2) = [[Int]]
prim _ = [prim (Cho @4 @ch1), prim (Cho @4 @ch2)]
pretty _ = "AuthCad vii"
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2, ch3 ~ DegToChord d3, IntListRep ch3) => Primitive (AuthCad64 d1 d2 d3) where
type Rep (AuthCad64 d1 d2 d3) = [[Int]]
prim _ = [prim (Cho @4 @ch1), prim (Cho @4 @ch2), prim (Cho @4 @ch3)]
pretty _ = "AuthCad 6-4"
instance (ch1 ~ DegToChord d1, IntListRep ch1, ch2 ~ DegToChord d2, IntListRep ch2) => Primitive (DeceptCad d1 d2) where
type Rep (DeceptCad d1 d2) = [[Int]]
prim _ = [prim (Cho @4 @ch1), prim (Cho @4 @ch2)]
pretty _ = "DeceptCad"
instance (IntLListRep sd, IntLListRep c) => Primitive (FullCad (sd :: Subdominant k sdur) (c :: Cadence k (l sdur)) :: Cadence k l) where
type Rep (FullCad sd c) = [[Int]]
prim _ = prim (Sub @k @sdur @sd) ++ prim (Cad @k @(l sdur) @c)
pretty _ = pretty (Sub @k @sdur @sd) ++ " | " ++ pretty (Cad @k @(l sdur) @c)
instance Primitive NoCad where
type Rep NoCad = [[Int]]
prim _ = []
pretty _ = "NoCad"
instance (IntLListRep t1, IntLListRep d, IntLListRep t2) => Primitive (PhraseIVI (t1 :: Tonic k (l2 l1)) (d :: Dominant k l1) (t2 :: Tonic k (l l2)) :: Phrase k l) where
type Rep (PhraseIVI t1 d t2) = [[Int]]
prim _ = prim (Ton @k @(l2 l1) @t1) ++ prim (Dom @k @l1 @d) ++ prim (Ton @k @(l l2) @t2)
pretty _ = pretty (Ton @k @(l2 l1) @t1) ++ " | " ++ pretty (Dom @k @l1 @d) ++ " | " ++ pretty (Ton @k @(l l2) @t2)
instance (IntLListRep d, IntLListRep t) => Primitive (PhraseVI (d :: Dominant k l1) (t :: Tonic k (l l1)) :: Phrase k l) where
type Rep (PhraseVI d t) = [[Int]]
prim _ = prim (Dom @k @l1 @d) ++ prim (Ton @k @(l l1) @t)
pretty _ = pretty (Dom @k @l1 @d) ++ " | " ++ pretty (Ton @k @(l l1) @t)
instance (IntLListRep t) => Primitive (PhraseI (t :: Tonic k l) :: Phrase k l) where
type Rep (PhraseI t) = [[Int]]
prim _ = prim (Ton @k @l @t)
pretty _ = pretty (Ton @k @l @t)
instance (IntLListRep c) => Primitive (CadPhrase c :: ProgType k l) where
type Rep (CadPhrase c) = [[Int]]
prim _ = prim (Cad @k @l @c)
pretty _ = pretty (Cad @k @l @c)
instance (IntLListRep ph, IntLListRep pr) => Primitive ((ph :: Phrase k l) := (pr :: ProgType k (n l)) :: ProgType k n) where
type Rep (ph := pr) = [[Int]]
prim _ = prim (Phr @k @l @ph) ++ prim (Prog @k @(n l) @pr)
pretty _ = pretty (Phr @k @l @ph) ++ " || " ++ pretty (Prog @k @(n l) @pr)