module Mezzo.Model.Harmony.Chords
(
TriadType (..)
, SeventhType (..)
, Inversion (..)
, TriType (..)
, SevType (..)
, Inv (..)
, InvertChord
, ChordType (..)
, Cho (..)
, FromChord
, ChordsToPartiture
) where
import GHC.TypeLits
import Data.Kind (Type)
import Mezzo.Model.Types
import Mezzo.Model.Prim
import Mezzo.Model.Reify
data TriadType = MajTriad | MinTriad | AugTriad | DimTriad
data SeventhType = MajSeventh | MajMinSeventh | MinSeventh | HalfDimSeventh | DimSeventh | Doubled TriadType
data Inversion = Inv0 | Inv1 | Inv2 | Inv3
data TriType (t :: TriadType) = TriType
data SevType (t :: SeventhType) = SevType
data Inv (t :: Inversion) = Inv
data ChordType :: Nat -> Type where
Triad :: RootType -> TriadType -> Inversion -> ChordType 3
SeventhChord :: RootType -> SeventhType -> Inversion -> ChordType 4
data Cho (c :: ChordType n) = Cho
type family TriadTypeToIntervals (t :: TriadType) :: Vector IntervalType 3 where
TriadTypeToIntervals MajTriad =
Interval Perf Unison :-- Interval Maj Third :-- Interval Perf Fifth :-- None
TriadTypeToIntervals MinTriad =
Interval Perf Unison :-- Interval Min Third :-- Interval Perf Fifth :-- None
TriadTypeToIntervals AugTriad =
Interval Perf Unison :-- Interval Maj Third :-- Interval Aug Fifth :-- None
TriadTypeToIntervals DimTriad =
Interval Perf Unison :-- Interval Min Third :-- Interval Dim Fifth :-- None
type family SeventhTypeToIntervals (s :: SeventhType) :: Vector IntervalType 4 where
SeventhTypeToIntervals MajSeventh = TriadTypeToIntervals MajTriad :-| Interval Maj Seventh
SeventhTypeToIntervals MajMinSeventh = TriadTypeToIntervals MajTriad :-| Interval Min Seventh
SeventhTypeToIntervals MinSeventh = TriadTypeToIntervals MinTriad :-| Interval Min Seventh
SeventhTypeToIntervals HalfDimSeventh = TriadTypeToIntervals DimTriad :-| Interval Min Seventh
SeventhTypeToIntervals DimSeventh = TriadTypeToIntervals DimTriad :-| Interval Dim Seventh
SeventhTypeToIntervals (Doubled tt) = TriadTypeToIntervals tt :-| Interval Perf Octave
type family Invert (i :: Inversion) (n :: Nat) (ps :: Vector PitchType n) :: Vector PitchType n where
Invert Inv0 n ps = ps
Invert Inv1 n (p :-- ps) = ps :-| RaiseByOct p
Invert Inv2 n (p :-- ps) = Invert Inv1 (n 1) (p :-- Tail' ps) :-| RaiseByOct (Head' ps)
Invert Inv3 n (p :-- ps) = Invert Inv2 (n 1) (p :-- (Head' (Tail' ps)) :-- (Tail' (Tail' (ps)))) :-| RaiseByOct (Head' ps)
type family InvertDoubled (i :: Inversion) (ps :: Vector PitchType 4) :: Vector PitchType 4 where
InvertDoubled Inv0 ps = ps
InvertDoubled Inv1 ps = Invert Inv1 3 (Init' ps) :-| (RaiseByOct (Head' (Tail' ps)))
InvertDoubled Inv2 ps = Invert Inv2 3 (Init' ps) :-| (RaiseByOct (Head' (Tail' (Tail' ps))))
InvertDoubled Inv3 ps = RaiseAllBy' ps (Interval Perf Octave)
type family InvSucc (i :: Inversion) :: Inversion where
InvSucc Inv0 = Inv1
InvSucc Inv1 = Inv2
InvSucc Inv2 = Inv3
InvSucc Inv3 = Inv0
type family InvertChord (c :: ChordType n) :: ChordType n where
InvertChord (Triad r t Inv2) = Triad r t Inv0
InvertChord (Triad r t i) = Triad r t (InvSucc i)
InvertChord (SeventhChord r t i) = SeventhChord r t (InvSucc i)
type family BuildOnRoot (r :: RootType) (is :: Vector IntervalType n) :: Vector PitchType n where
BuildOnRoot (PitchRoot Silence) _ = TypeError (Text "Can't build a chord on a rest.")
BuildOnRoot r None = None
BuildOnRoot r (i :-- is) = RaiseBy (RootToPitch r) i :-- BuildOnRoot r is
type family ChordToPitchList (c :: ChordType n) :: Vector PitchType n where
ChordToPitchList (Triad r t i) = Invert i 3 (BuildOnRoot r (TriadTypeToIntervals t))
ChordToPitchList (SeventhChord r (Doubled tt) i)
= InvertDoubled i (BuildOnRoot r (SeventhTypeToIntervals (Doubled tt)))
ChordToPitchList (SeventhChord r t i) = Invert i 4 (BuildOnRoot r (SeventhTypeToIntervals t))
type family FromChord (c :: ChordType n) (l :: Nat) :: Partiture n l where
FromChord c l = VectorToColMatrix (ChordToPitchList c) l
type family ChordsToPartiture (v :: Vector (ChordType n) l) (d :: Nat) :: Partiture n (l * d) where
ChordsToPartiture None l = None
ChordsToPartiture (c :-- cs) d = FromChord c d +|+ ChordsToPartiture cs d
instance Primitive MajTriad where
type Rep MajTriad = Int -> [Int]
prim t = \r -> [r, r + 4, r + 7]
pretty t = "Maj"
instance Primitive MinTriad where
type Rep MinTriad = Int -> [Int]
prim t = \r -> [r, r + 3, r + 7]
pretty t = "min"
instance Primitive AugTriad where
type Rep AugTriad = Int -> [Int]
prim t = \r -> [r, r + 4, r + 8]
pretty t = "aug"
instance Primitive DimTriad where
type Rep DimTriad = Int -> [Int]
prim t = \r -> [r, r + 3, r + 6]
pretty t = "dim"
instance Primitive MajSeventh where
type Rep MajSeventh = Int -> [Int]
prim t = \r -> [r, r + 4, r + 7, r + 11]
pretty t = "Maj7"
instance Primitive MajMinSeventh where
type Rep MajMinSeventh = Int -> [Int]
prim t = \r -> [r, r + 4, r + 7, r + 10]
pretty t = "7"
instance Primitive MinSeventh where
type Rep MinSeventh = Int -> [Int]
prim t = \r -> [r, r + 3, r + 7, r + 10]
pretty t = "min7"
instance Primitive HalfDimSeventh where
type Rep HalfDimSeventh = Int -> [Int]
prim t = \r -> [r, r + 3, r + 6, r + 10]
pretty t = "hdim7"
instance Primitive DimSeventh where
type Rep DimSeventh = Int -> [Int]
prim t = \r -> [r, r + 3, r + 6, r + 9]
pretty t = "dim7"
instance FunRep Int [Int] c => Primitive (Doubled c) where
type Rep (Doubled c) = Int -> [Int]
prim t = \r -> prim (TriType @c) r ++ [r + 12]
pretty t = pretty (TriType @c) ++ "D"
invChord :: [Int] -> [Int]
invChord [] = []
invChord (x : xs) = xs ++ [x + 12]
instance Primitive Inv0 where
type Rep Inv0 = [Int] -> [Int]
prim i = id
pretty i = "I0"
instance Primitive Inv1 where
type Rep Inv1 = [Int] -> [Int]
prim i = invChord
pretty i = "I1"
instance Primitive Inv2 where
type Rep Inv2 = [Int] -> [Int]
prim i = invChord . invChord
pretty i = "I2"
instance Primitive Inv3 where
type Rep Inv3 = [Int] -> [Int]
prim i = invChord . invChord . invChord
pretty i = "I3"
instance (IntRep r, FunRep Int [Int] t, FunRep [Int] [Int] i)
=> Primitive (Triad r t i) where
type Rep (Triad r t i) = [Int]
prim c = prim (Inv @i) . prim (TriType @t) $ prim (Root @r)
pretty c = pc ++ " " ++ pretty (TriType @t) ++ " " ++ pretty (Inv @i)
where pc = takeWhile (\c -> c /= ' ' && c /= '\'' && c /= '_') $ pretty (Root @r)
instance (IntRep r, FunRep Int [Int] tt, FunRep [Int] [Int] i)
=> Primitive (SeventhChord r (Doubled tt) i) where
type Rep (SeventhChord r (Doubled tt) i) = [Int]
prim c = inverted ++ [head inverted + 12]
where rootPos = prim (TriType @tt) $ prim (Root @r)
inverted = prim (Inv @i) rootPos
pretty c = pc ++ " " ++ pretty (TriType @tt) ++ "D " ++ pretty (Inv @i)
where pc = takeWhile (\c -> c /= ' ' && c /= '\'' && c /= '_') $ pretty (Root @r)
instance (IntRep r, FunRep Int [Int] t, FunRep [Int] [Int] i)
=> Primitive (SeventhChord r t i) where
type Rep (SeventhChord r t i) = [Int]
prim c = prim (Inv @i) . prim (SevType @t) $ prim (Root @r)
pretty c = pc ++ " " ++ pretty (SevType @t) ++ " " ++ pretty (Inv @i)
where pc = takeWhile (\c -> c /= ' ' && c /= '\'' && c /= '_') $ pretty (Root @r)