{-# LANGUAGE CPP                      #-}
{-# LANGUAGE TemplateHaskell          #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE TypeSynonymInstances     #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE GADTs                    #-}

module HarmTrace.Models.Pop.Model where

import HarmTrace.Models.TypeLevel

import HarmTrace.Base.MusicRep
import HarmTrace.Models.ChordTokens
import Language.Haskell.TH.Syntax (Name)

--------------------------------------------------------------------------------
-- Musical structure as a datatype
--------------------------------------------------------------------------------

#ifndef NUMLEVELS
#define NUMLEVELS T4
#endif

-- perhaps this module should be named differently, like Model or HarmonyModel

data MajMode
data MinMode

-- High level structure
data Piece = forall mode. Piece [Phrase mode]

-- The Phrase level
data Phrase mode where
  PT   :: Ton mode -> Phrase mode
  PD   :: Dom mode -> Phrase mode

-- Harmonic categories
-- Tonic
data Ton mode where
  T_0   :: SDom mode -> Ton mode -> Ton mode
  -- major mode
  T_1      :: Final I MajClass         -> Ton MajMode
           
  -- blues           
  T_4_bls  :: Final I DomClass         -> Ton mode  
 
  T_6_bor  :: TMinBorrow -> Ton MajMode

  -- minor mode         
  Tm_1     :: SD MinMode I MinClass    -> Ton MinMode      

  -- Tm_3_par :: Final IIIb MajClass      -> Ton MinMode 
  Tm_6_bor :: TMajBorrow               -> Ton MinMode  -- picardy third etc.     

-- Dominant
data Dom mode where
  -- major mode
  D_1   :: SDom mode -> Dom mode -> Dom mode
  D_2   :: SD mode V DomClass        -> Dom mode
  D_3   :: SD mode V MajClass        -> Dom mode

  D_4   :: SD MajMode VII MinClass   -> Dom 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 MinMode -> Dom MajMode
  D_8_bor :: DMinBorrow              -> Dom MajMode
  
  -- minor mode (there must be at least one rule with "MinMode" otherwise
  -- no you get a "No instance for (ParseG (Dom MinMode))" error
  Dm_4   :: SD MinMode VIIb MajClass -> Dom MinMode
  Dm_8_bor :: DMajBorrow             -> Dom MinMode

-- Subdominant
data SDom mode where
  S_1_par :: SD mode II MinClass     -> SDom mode -- sub dom parallel

  -- 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_2_par :: SD mode II DomClass -> Final II MinClass
                                         -> SDom mode 
  S_3     :: SD MajMode IV MajClass  -> SDom MajMode
  -- blues
  S_3_bls :: Final     IV DomClass  -> SDom mode
  S_4     :: SD MajMode III MinClass -> Final IV MajClass
                                         -> SDom MajMode
  S_7     :: SD MajMode III MinClass -> Final II MinClass
                                         -> SDom MajMode
  S_5_par :: SD MajMode VI MinClass  -> SDom MajMode

  -- Borrowing from minor in a major mode
  S_9_bor :: SMinBorrow -> SDom MajMode 
  
  -- minor mode
  Sm_3    :: SD MinMode IV  MinClass  -> SDom MinMode
  Sm_4    :: SD MinMode IIIb MajClass -> Final IV MinClass 
                                          -> SDom MinMode
  Sm_7    :: SD MinMode IIIb MajClass -> Final II MinClass
                                          -> SDom MinMode                                          
  Sm_5_par :: SD MinMode VIb MajClass -> SDom MinMode
 
  Sm_9_bor :: SMajBorrow              -> SDom MinMode 

  -- perhaps add a functional node for Neapolitan chords?
  Sm_6   :: SD MinMode IIb MajClass   -> SDom MinMode -- Neapolitan
  
-- Borrowings from minor in a major key
data TMinBorrow = Tm_21_bor (SD MinMode I    MinClass)   

data DMinBorrow = Dm_24_bor (SD MinMode VIIb MajClass)   
                      
data SMinBorrow = Sm_20_bor (SD MinMode IV   MinClass) 
                    | Sm_22_bor (SD MinMode IIb  MajClass)   -- Neapolitan 

-- Borrowings from major in a minor key
data TMajBorrow = T_21_bor (SD MajMode I   MajClass)

data DMajBorrow = D_24_bor (SD MajMode VII MinClass)   
                      
data SMajBorrow = S_20_bor (SD MajMode IV   MajClass) 
                    
                    
-- Limit secondary dominants to a few levels
type SD mode deg clss = Base_SD deg clss NUMLEVELS

-- a type that can be substituted by its tritone sub and diminished 7b9
type TritMinVSub deg clss = Base_Final 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 deg clss = Surface_Chord deg clss T4

-- A Scale degree that translates into a (non-tranformable) surface chord
type Final deg clss = Surface_Chord deg clss T1


-- Datatypes for clustering harmonic degrees
-- type Base_SD deg clss n = List (Base_SD' deg clss n) T4

data Base_SD deg clss n where
  Base_SD   :: TritMinVSub deg clss -- Min5    deg clss  n
            -> Base_SD deg clss (Su n)   
  -- Rule for explaining perfect secondary dominants
  Cons_Vdom :: Base_SD (VDom  deg) DomClass n -> Base_SD deg clss n
            -> Base_SD        deg  clss (Su n)
  Cons_Diat :: Base_SD (DiatV deg) MinClass n -> Base_SD deg MinClass n
            -> Base_SD        deg  MinClass (Su n)
  Cons_DiatM :: Base_SD (DiatVM deg) MajClass n -> Base_SD deg MajClass n
            -> Base_SD        deg  MajClass (Su n)
  Cons_DiatM' :: Base_SD (DiatVM deg) MajClass n -> Base_SD deg MinClass n
            -> Base_SD        deg  MinClass (Su n)
  -- Minor fifth insertion
  Cons_Vmin :: Base_SD (VMin deg) MinClass n -> Base_SD deg DomClass n
            -> Base_SD     deg  DomClass (Su n)

            
data Base_Final deg clss n where
  -- Just a "normal", final degree. The Strings are the original input.
  Base_Final     :: FinalDimTrans deg clss -> Base_Final deg clss (Su n)
  -- Tritone substitution

-- Dimished tritone substitution accounting for dimished chord transistions
data Surface_Chord deg clss n where
  Surface_Chord  :: ChordToken  
                 -> Surface_Chord deg clss     (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  = Imp -- 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  = Imp -- 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    = Imp  -- interferes with S_bls VI7 -> I7
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 ]
