HarmTrace-0.7: src/HarmTrace/Models/Pop/Model.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
module HarmTrace.Models.Pop.Model where
import HarmTrace.Base.TypeLevel
import HarmTrace.Base.MusicRep
import HarmTrace.Tokenizer.Tokens
import Language.Haskell.TH.Syntax (Name)
--------------------------------------------------------------------------------
-- Musical structure as a datatype
--------------------------------------------------------------------------------
-- perhaps this module should be named differently, like Model or HarmonyModel
data MajMode
data MinMode
-- High level structure
-- 'key' is not used yet
data Piece key = forall mode. Piece [Phrase key mode]
-- The Phrase level
data Phrase key mode where
PT :: Ton key mode -> Phrase key mode
PD :: Dom key mode -> Phrase key mode
-- Harmonic categories
-- Tonic
data Ton key mode where
-- major mode
T_1 :: Final key I MajClass -> Ton key MajMode
T_2 :: Final key I MajClass -> Final key IV MajClass
-> Final key I MajClass -> Ton key MajMode
-- T_3 :: Final key I MajClass -> Final key I DimClass
-- -> Final key I MajClass -> Ton key MajMode
-- blues
-- T_4_bls :: Final key I DomClass -> Ton key mode
-- T_5_par :: Final key III MinClass -> Ton key MajMode
T_6_bor :: TMinBorrow key -> Ton key MajMode
-- minor mode
Tm_1 :: SD key MinMode I MinClass -> Ton key MinMode
Tm_2 :: Final key I MinClass -> Final key IV MinClass
-> Final key I MinClass -> Ton key MinMode
Tm_3 :: Final key I MinClass -> Final key IV MinClass
-> Final key I MinClass -> Ton key MinMode
-- Tm_4_par :: Final key IIIb MajClass -> Ton key MinMode
Tm_6_bor :: TMajBorrow key -> Ton key MinMode -- picardy third etc.
-- Dominant
data Dom key mode where
-- major mode
D_1 :: SDom key mode -> Dom key mode -> Dom key mode
D_2 :: SD key mode V DomClass -> Dom key mode
-- I would like to model this with a SD VIs dimClass, but somehow,
-- this causes a ToDegree loop
-- D_3 :: SD key mode IIIb DimClass ->
-- Final key V DomClass -> Dom key mode -- not in CMJ
D_4 :: SD key mode V MajClass -> Dom key mode
-- D_5 :: Final key V DomClass -> Final key V DimClass
-- -> Final key V DomClass -> Dom key mode
-- D_6 :: Final key VII DimClass -> Dom key MajMode
D_7 :: SD key MajMode VII MinClass -> Dom key MajMode
-- moll-dur: minor mode borrowings in major
-- This would be an elegant way of defining major minor borrowing,
-- but it causes a lot of unwanted abmiguities since all the mode
-- rules can be explained with and without borrowing
-- D_9_bor :: Dom key MinMode -> Dom key MajMode
D_8_bor :: DMinBorrow key -> Dom key MajMode
-- minor mode (there must be at least one rule with "MinMode" otherwise
-- no you get a "No instance for (ParseG (Dom key MinMode))" error
Dm_1 :: SD key MinMode VIIb MajClass -> Dom key MinMode
Dm_2_bor :: DMajBorrow key -> Dom key MinMode
-- Subdominant
data SDom key mode where
S_1_par :: SD key mode II MinClass -> SDom key mode -- sub dom parallel
-- S_2_bls :: SD key mode IV DomClass -> SD key mode I DomClass
-- -> SDom key mode
-- Pretty printing? this rule compensates for the V/I Imp
-- to be able to parse D:7 D:min G:7 C:maj (not in cmj)
S_3_par :: SD key mode II DomClass -> Final key II MinClass
-> SDom key mode
S_4 :: SD key MajMode IV MajClass -> SDom key MajMode
S_5 :: SD key MajMode III MinClass -> Final key IV MajClass
-> SDom key MajMode
-- S_6_par :: SD key MajMode VI MinClass -> SDom key MajMode
-- Borrowing from minor in a major mode
-- S_7_bor :: SDom key MajMode -> SDom key MinMode
S_7_bor :: SMinBorrow key -> SDom key MajMode
-- minor mode
Sm_1 :: SD key MinMode IV MinClass -> SDom key MinMode
Sm_2 :: SD key MinMode IIIb MajClass -> Final key IV MinClass
-> SDom key MinMode
-- Sm_3_par :: SD key MinMode VIb MajClass -> SDom key MinMode
-- perhaps add a functional node for Neapolitan chords?
Sm_4 :: SD key MinMode IIb MajClass -> SDom key MinMode -- Neapolitan
Sm_5_bor :: SMajBorrow key -> SDom key MinMode
-- Borrowings from minor in a major key
data TMinBorrow key = Tm_20_bor (SD key MinMode IIIb MajClass)
data DMinBorrow key = Dm_20_bor (SD key MinMode VIIb MajClass)
-- | Dm_21_bor (Final key VIIb DomClass)
data SMinBorrow key = Sm_20_bor (SD key MinMode IV MinClass)
-- | Sm_21_bor (SD key MinMode VIb MajClass)
| Sm_22_bor (SD key MinMode IIb MajClass) -- Neapolitan
-- Borrowings from major in a minor key
data TMajBorrow key = T_20_bor (SD key MajMode I MajClass)
| T_21_bor (SD key MajMode III MinClass)
data DMajBorrow key = D_20_bor (SD key MajMode VII MinClass)
-- | D_21_bor (Final key VII DimClass)
data SMajBorrow key = S_20_bor (SD key MajMode IV MajClass)
-- Limit secondary dominants to a few levels
type SD key mode deg clss = Base_SD key deg clss T5
-- a type that can be substituted by its tritone sub and diminished 7b9
type TritMinVSub key deg clss = Base_Final key deg clss T2
-- A Scale degree that can only translate to a surface chord
-- and allows for the transformation into enharmonic equivalent
-- diminshed surface chords
type FinalDimTrans key deg clss = Surface_Chord key deg clss T4
-- A Scale degree that translates into a (non-tranformable) surface chord
type Final key deg clss = Surface_Chord key deg clss T1
-- Datatypes for clustering harmonic degrees
-- type Base_SD key deg clss n = List (Base_SD' key deg clss n) T4
data Base_SD key deg clss n where
Base_SD :: TritMinVSub key deg clss -- Min5 key deg clss n
-> Base_SD key deg clss (Su n)
-- Rule for explaining perfect secondary dominants
Cons_Vdom :: Base_SD key (VDom deg) DomClass n -> Base_SD key deg clss n
-> Base_SD key deg clss (Su n)
Cons_Diat :: Base_SD key (DiatV deg) MinClass n -> Base_SD key deg MinClass n
-> Base_SD key deg MinClass (Su n)
Cons_DiatM :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MajClass n
-> Base_SD key deg MajClass (Su n)
Cons_DiatM' :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MinClass n
-> Base_SD key deg MinClass (Su n)
-- Minor fifth insertion
Cons_Vmin :: Base_SD key (VMin deg) MinClass n -> Base_SD key deg DomClass n
-> Base_SD key deg DomClass (Su n)
data Base_Final key deg clss n where
-- Just a "normal", final degree. The Strings are the original input.
Base_Final :: FinalDimTrans key deg clss -> Base_Final key deg clss (Su n)
-- Tritone substitution
Final_Tritone :: Base_Final key (Tritone deg) DomClass n
-> Base_Final key deg DomClass (Su n)
Final_Dim_V :: Base_Final key (IIbDim deg) DimClass n
-> Base_Final key deg DomClass (Su n)
-- Dimished tritone substitution accounting for dimished chord transistions
data Surface_Chord key deg clss n where
Surface_Chord :: ChordToken
-> Surface_Chord key deg clss (Su n)
Dim_Chord_Trns :: Surface_Chord key (MinThird deg) DimClass n
-> Surface_Chord key deg DimClass (Su n)
--------------------------------------------------------------------------------
-- Type Level Scale Degrees
--------------------------------------------------------------------------------
-- typelevel chord classes
data MajClass
data MinClass
data DomClass
data DimClass
-- Degrees (at the type level)
data I
data Ib
data Is
data II
data IIb
data IIs
data III
data IIIb
data IIIs
data IV
data IVb
data IVs
data V
data Vb
data Vs
data VI
data VIb
data VIs
data VII
data VIIb
data VIIs
-- Used when we don't want to consider certain possibilities
data Imp
-- Degrees at the value level are in Tokenizer
-- Type to value conversions
class ToClass clss where
toClass :: clss -> ClassType
instance ToClass MajClass where toClass _ = MajClass
instance ToClass MinClass where toClass _ = MinClass
instance ToClass DomClass where toClass _ = DomClass
instance ToClass DimClass where toClass _ = DimClass
-- The class doesn't really matter, since the degree will be impossible to parse
instance ToClass Imp where toClass _ = DimClass
class ToDegree deg where
toDegree :: deg -> ScaleDegree
instance ToDegree I where toDegree _ = Note Nothing I
instance ToDegree II where toDegree _ = Note Nothing II
instance ToDegree III where toDegree _ = Note Nothing III
instance ToDegree IV where toDegree _ = Note Nothing IV
instance ToDegree V where toDegree _ = Note Nothing V
instance ToDegree VI where toDegree _ = Note Nothing VI
instance ToDegree VII where toDegree _ = Note Nothing VII
instance ToDegree Ib where toDegree _ = Note (Just Fl) I
instance ToDegree IIb where toDegree _ = Note (Just Fl) II
instance ToDegree IIIb where toDegree _ = Note (Just Fl) III
instance ToDegree IVb where toDegree _ = Note (Just Fl) IV
instance ToDegree Vb where toDegree _ = Note (Just Fl) V
instance ToDegree VIb where toDegree _ = Note (Just Fl) VI
instance ToDegree VIIb where toDegree _ = Note (Just Fl) VII
instance ToDegree IIs where toDegree _ = Note (Just Sh) II
instance ToDegree IIIs where toDegree _ = Note (Just Sh) III
instance ToDegree IVs where toDegree _ = Note (Just Sh) IV
instance ToDegree Vs where toDegree _ = Note (Just Sh) V
instance ToDegree VIs where toDegree _ = Note (Just Sh) VI
instance ToDegree VIIs where toDegree _ = Note (Just Sh) VII
-- Can't ever parse these
instance ToDegree Imp where toDegree _ = Note Nothing Imp
--------------------------------------------------------------------------------
-- Type Families for Relative Scale Degrees
--------------------------------------------------------------------------------
-- Diatonic fifths, and their class (comments with the CMaj scale)
-- See http://en.wikipedia.org/wiki/Circle_progression
type family DiatV deg :: *
type instance DiatV I = Imp -- V -- G7 should be Dom
type instance DiatV V = Imp -- II -- Dm7 should be SDom
type instance DiatV II = VI -- Am7
type instance DiatV VI = III -- Em7
type instance DiatV III = VII -- Bhdim7 can be explained by Dim rule
type instance DiatV VII = Imp -- IV -- FMaj7 should be SDom
type instance DiatV IV = Imp -- I -- CMaj7
type instance DiatV IIb = Imp
type instance DiatV IIIb = Imp
type instance DiatV IVs = Imp
type instance DiatV VIb = Imp
type instance DiatV VIIb = Imp
type instance DiatV Imp = Imp
type family DiatVM deg :: *
type instance DiatVM I = Imp -- V -- G7 should be Dom
type instance DiatVM V = Imp -- Dm7 should be SDom
type instance DiatVM II = VIb -- Ab
type instance DiatVM VI = Imp -- Em7
type instance DiatVM III = Imp -- Bhdim7 can be explained by Dim rule
type instance DiatVM VII = Imp -- IV -- FMaj7 should be SDom
type instance DiatVM IV = Imp -- I -- CMaj7
type instance DiatVM IIb = Imp
type instance DiatVM IIIb = VIIb
type instance DiatVM IVs = Imp
type instance DiatVM VIb = IIIb
type instance DiatVM VIIb = Imp
type instance DiatVM Imp = Imp
--------------------------------------------------------------------------------
-- Type families for secondary dominants
--------------------------------------------------------------------------------
-- Perfect fifths (class is always Dom)
-- See http://en.wikipedia.org/wiki/Circle_of_fifths
type family VDom deg :: *
type instance VDom I = Imp -- interferes with dom
type instance VDom IIb = VIb
type instance VDom II = VI
type instance VDom IIIb = VIIb -- interferes with Dm_3
type instance VDom III = VII
type instance VDom IV = I
type instance VDom IVs = IIb
type instance VDom V = II -- interferes with Sm_1
type instance VDom VIb = IIIb
type instance VDom VI = III
type instance VDom VIIb = IV
type instance VDom VII = IVs
type instance VDom Imp = Imp
-- Perfect fifths for the minor case (this is an additional
-- type family to controll the reduction of ambiguities
-- specifically in the minor case)
type family VMin deg :: *
type instance VMin I = V
type instance VMin IIb = VIb
type instance VMin II = VI -- interferes with sub
type instance VMin IIIb = VIIb
type instance VMin III = VII
type instance VMin IV = I
type instance VMin IVs = IIb
type instance VMin V = Imp -- II interferes with sub
type instance VMin VIb = IIIb
type instance VMin VI = III
type instance VMin VIIb = Imp --IV -- inteferes with sub IV:min
type instance VMin VII = IVs
type instance VMin Imp = Imp
-- The tritone substitution
-- See http://en.wikipedia.org/wiki/Tritone_substitution
type family Tritone deg :: *
type instance Tritone I = IVs
type instance Tritone IVs = I
type instance Tritone IIb = V -- gives undesired (ambiguous results) as
type instance Tritone V = IIb -- Dom = IIb/I = IIbdim
type instance Tritone II = VIb -- interferes IIbDim V
type instance Tritone VIb = II
type instance Tritone IIIb = VI
type instance Tritone VI = IIIb
type instance Tritone III = VIIb -- Interferes with VIIb from minor
type instance Tritone VIIb = III
type instance Tritone IV = VII
type instance Tritone VII = IV
type instance Tritone Imp = Imp
--------------------------------------------------------------------------------
-- Type families for diminished chord transformations
--------------------------------------------------------------------------------
-- in combination with the secondary dominants and enharmonic equivalency
-- these type families account for ascending dim chord progressions
type family IIbDim deg :: *
type instance IIbDim I = IIb
type instance IIbDim IIb = II
type instance IIbDim II = IIIb
type instance IIbDim IIIb = III
type instance IIbDim III = IV
type instance IIbDim IV = IVs
type instance IIbDim IVs = V
type instance IIbDim V = VIb -- interferes with dim tritone V/V
type instance IIbDim VIb = VI
type instance IIbDim VI = VIIb
type instance IIbDim VIIb = VII
type instance IIbDim VII = I
type instance IIbDim Imp = Imp
-- Dimchords can be transposed a minor third without changing their role,
-- they are enharmonically equivalent.
type family MinThird deg :: *
type instance MinThird I = IIIb
type instance MinThird IIb = III
type instance MinThird II = IV
type instance MinThird IIIb = IVs
type instance MinThird III = V
type instance MinThird IV = VIb
type instance MinThird IVs = VI
type instance MinThird V = VIIb
type instance MinThird VIb = VII
type instance MinThird VI = I
type instance MinThird VIIb = IIb
type instance MinThird VII = II
type instance MinThird Imp = Imp
-- Belongs in Instances, but needs to be here due to staging restrictions
allTypes :: [Name]
allTypes = [ ''Phrase, ''Ton, ''Dom, ''SDom
, ''TMinBorrow, ''DMinBorrow, ''SMinBorrow
, ''TMajBorrow, ''DMajBorrow, ''SMajBorrow ]