MIR.hs

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

module MIR.HarmGram.MIR where

import MIR.HarmGram.TypeLevel

import MIR.HarmGram.Tokenizer hiding (D)
import Language.Haskell.TH.Syntax (Name)

import Data.Typeable

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

-- High level structure
data Piece = Piece     [Phrase] 
           | Piece_min [PhraseMin] 
  deriving Typeable

-- The Prase level           
data Phrase     = PT Ton
                | PD Dom
  deriving Typeable
data PhraseMin  = PT_m TMin
                | PD_m DMin
  deriving Typeable
                
-- Harmonic categories for pieces in major keys
-- Tonic in major
data Ton  = T_2 (SD I MajClass)
          | Tbls_0 (Final I DomClass)
          | T_3 (Final I MajClass) (Final IV  MajClass) (Final I MajClass)
          | T_4 (Final I MajClass) (Final I   DimClass) (Final I MajClass)
  deriving Typeable

-- Dominant in major    
data Dom  = D_1 SDom Dom 
          | Dm_0 DMinBorrow 
          | D_2 (SD V DomClass)
          | D_3 (SD V MajClass)
          | D_4 (SD VII DimClass)
          | D_5 (Final V DomClass) (Final V DimClass) (Final V DomClass)   
  deriving Typeable

-- Subdominant in major          
data SDom = S_1  DiatV
          | Sbls_0 (SD IV DomClass) (SD I DomClass)
          | Sm_0 SMinBorrow
          | S_2 (SD II MinClass)
          | S_3 (SD IV MajClass)
          | S_4 (SD VI MinClass) -- maybe substitute by sec dom??
          | S_5 (SD III MinClass) (Final IV MajClass) 
          | S_6 (SD II DomClass) (Final II MinClass) -- pretty printing???
  deriving Typeable

-- account for diatonic succession          
data DiatV  = Vd_1 (SD III MinClass) (Final VI  MinClass)
            | Vd_2 (SD IV  MajClass) (Final VII MinClass)  
  deriving Typeable

-- Harmonic categories for pieces in minor keys
data TMin = Tm_2 (SD I MinClass)
          | Tm_3 (Final I MinClass) (Final IV  MinClass) (Final I MinClass)
          | T_0 TMajBorrow
  deriving Typeable

data TMajBorrow = 
            Tpar (SD IIIb MajClass)
  deriving Typeable
          
data DMin = Dm_1 SMin DMin
          | Dm_2 (SD V DomClass)
          | Dm_3 (SD V MajClass)      
          -- | Dm_4 (Final VIIb DomClass)   
          | Dm_5 (SD IIb  MajClass)   -- Neapolitan 
  deriving Typeable

-- Borrowings from minor in a major key
data DMinBorrow =      
            Dm_4' (Final VIIb DomClass)   
          | Dm_5' (SD IIb  MajClass)   -- Neapolitan 
  deriving Typeable
 
data SMin = Sm_1 DiatVm
          | Sm_2 (SD II MinClass)
          | Sm_3 (SD IV MinClass)
          | Sm_4 (SD VIb MajClass)
          | Sm_5 (SD II DomClass) (Final II MinClass) -- pretty printing???
  deriving Typeable
 
 -- Borrowings from minor in a major key
data SMinBorrow = 
            Sm_3' (SD IV MinClass)
  deriving Typeable

data DiatVm  = Vdm_1  (SD IIIb MajClass) (Final VIb MajClass)
             | Vdm_2  (SD IV  MinClass)  (Final VII DomClass)  
             -- | Vd_m2 (SD VI MajClass)  (Final II MinClass)
  deriving Typeable

         
-- Limit secondary dominants to a few levels
type SD deg clss = Base_SD deg clss T5

-- 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 trnaslate to a surface chord
-- (or a dim chord transformation of a diminshed surface chord
type Final deg clss = Surface_Chord deg clss T4


-- Datatypes for clustering harmonic degrees
data Base_SD deg clss :: * -> * where
  Base_SD      :: Min5    deg clss  n           
               -> Base_SD deg clss (Su n)
  -- Rule for explaining perfect secondary dominants
  Cons_Vdom :: Base_SD (VDom deg) DomClass n -> Min5 deg clss n
               -> Base_SD deg clss (Su n)             
  deriving Typeable

-- One case only allowed (Tritone or Cons_Vmin)
type Min5 deg clss n = Base_Vmin deg clss n

data Base_Vmin deg clss :: * -> * where
  -- No minor fifth
  Base_Vmin :: TritMinVSub deg clss             
            -> Base_Vmin   deg clss (Su n)
  -- Minor fifth insertion
  Cons_Vmin :: Base_SD  (VMin deg) MinClass     n  -> TritMinVSub deg DomClass 
            -> Base_Vmin      deg  DomClass (Su n)
  deriving Typeable
            
            
data Base_Final deg :: * -> * -> * where
  -- Just a "normal", final degree. The Strings are the original input.
  Base_Final     :: Final deg clss -> Base_Final deg clss (Su n)
  -- Tritone substitution
  Final_Tritone  :: Base_Final (Tritone deg) DomClass n
                 -> Base_Final deg DomClass (Su n)   
  Final_Dim_Trit :: Base_Final (Tritone deg) DimClass n
                 -> Base_Final deg DomClass (Su n)     
  deriving Typeable         

-- Diminished tritone substitution accounting for diminished chord transistions
data Surface_Chord deg :: * -> * -> * where
  Surface_Chord  :: Degree -> [(Class, String)] 
                 -> Surface_Chord deg clss    (Su n)            
  Dim_Chord_Trns :: Surface_Chord (MinThird deg) DimClass n
                 -> Surface_Chord deg DimClass (Su n)  
  deriving Typeable    

--------------------------------------------------------------------------------
-- Type Level Scale Degrees
--------------------------------------------------------------------------------

-- Classes (at the type level)
data MajClass deriving Typeable
data MinClass deriving Typeable
data DomClass deriving Typeable
data DimClass deriving Typeable

-- Classes (at the value level)
data Class = Class ClassType Shorthand deriving Typeable

instance Show Class where show (Class ct sh) = show ct

data ClassType = MajClass | MinClass | DomClass | DimClass

instance Show ClassType where
  show (MajClass) = ""
  show (MinClass) = "m"
  show (DomClass) = "7"
  show (DimClass) = "0"

-- Degrees (at the type level)
data I deriving Typeable
data Ib deriving Typeable
data Is deriving Typeable
data II deriving Typeable
data IIb deriving Typeable
data IIs deriving Typeable
data III deriving Typeable
data IIIb deriving Typeable
data IIIs deriving Typeable
data IV deriving Typeable
data IVb deriving Typeable
data IVs deriving Typeable
data V deriving Typeable
data Vb deriving Typeable
data Vs deriving Typeable
data VI deriving Typeable
data VIb deriving Typeable
data VIs deriving Typeable
data VII deriving Typeable
data VIIb deriving Typeable
data VIIs deriving Typeable

-- Used when we don't want to consider certain possibilities
data Imp deriving Typeable

-- 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 -> Degree

instance ToDegree I     where toDegree _ = Degree Nothing 1
instance ToDegree II    where toDegree _ = Degree Nothing 2
instance ToDegree III   where toDegree _ = Degree Nothing 3
instance ToDegree IV    where toDegree _ = Degree Nothing 4
instance ToDegree V     where toDegree _ = Degree Nothing 5
instance ToDegree VI    where toDegree _ = Degree Nothing 6
instance ToDegree VII   where toDegree _ = Degree Nothing 7
instance ToDegree Ib    where toDegree _ = Degree (Just Fl) 1
instance ToDegree IIb   where toDegree _ = Degree (Just Fl) 2
instance ToDegree IIIb  where toDegree _ = Degree (Just Fl) 3
instance ToDegree IVb   where toDegree _ = Degree (Just Fl) 4
instance ToDegree Vb    where toDegree _ = Degree (Just Fl) 5
instance ToDegree VIb   where toDegree _ = Degree (Just Fl) 6
instance ToDegree VIIb  where toDegree _ = Degree (Just Fl) 7
instance ToDegree IIs   where toDegree _ = Degree (Just Sh) 2
instance ToDegree IIIs  where toDegree _ = Degree (Just Sh) 3
instance ToDegree IVs   where toDegree _ = Degree (Just Sh) 4
instance ToDegree Vs    where toDegree _ = Degree (Just Sh) 5
instance ToDegree VIs   where toDegree _ = Degree (Just Sh) 6
instance ToDegree VIIs  where toDegree _ = Degree (Just Sh) 7

-- Can't ever parse degree 42 (TODO: what about error correction?...)
instance ToDegree Imp where toDegree _ = Degree Nothing 42


--------------------------------------------------------------------------------
-- Type Families for Relative Scale Degrees
--------------------------------------------------------------------------------
-- 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 --Imp -- 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  = IV
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 Is    = V
type instance Tritone IIb   = V
type instance Tritone V     = IIb 

type instance Tritone II    = VIb
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 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, ''PhraseMin, ''TMin, ''Ton 
           , ''Dom, ''DMinBorrow, ''SDom, ''DMin, ''DiatV, ''SMin, ''DiatVm 
           , ''SMinBorrow, ''TMajBorrow
           ]