{-# OPTIONS_GHC -fno-warn-orphans   #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE EmptyDataDecls         #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE OverlappingInstances   #-}
-- {-# LANGUAGE IncoherentInstances    #-} -- for ghc-6.12
{-# LANGUAGE GADTs                  #-}

module MIR.Instances where

-- Generics stuff
import Generics.Instant.TH

-- Parser stuff
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances.List ()

-- Diff
import MIR.Matching.GDiff

-- Music stuff
import MIR.HarmGram.ParserChord
import MIR.HarmGram.ShowChord
import MIR.HarmGram.MIR
import MIR.HarmGram.Tokenizer
import MIR.HarmGram.TypeLevel

-- Library modules
import Control.Monad (join)
import Data.List  (intersperse)
import Data.Array
import Control.Arrow
import Data.Typeable 


--------------------------------------------------------------------------------
-- The non-generic part of the parser
--------------------------------------------------------------------------------

-- Ad-hoc cases for Base_SD
instance ParseG (Base_SD   deg clss Ze) where parseG = empty
instance ParseG (Base_Vmin deg clss Ze) where parseG = empty


instance ( ParseG (Base_SD (VDom deg) DomClass n)
         , ParseG (Min5 deg clss n)
         ) => ParseG (Base_SD deg clss (Su n)) where
  parseG =     Base_SD      <$> parseG
           <|> Cons_Vdom <$> parseG <*> parseG
  
-- Ad-hoc cases for Base_Vmin
instance ( ParseG (Base_SD (VMin deg) MinClass n)
         , ParseG (TritMinVSub    deg        DomClass)
         ) => ParseG (Base_Vmin deg DomClass (Su n)) where
  parseG =     Base_Vmin <$> parseG
           <|> Cons_Vmin      <$> parseG <*> parseG

instance ( ParseG (TritMinVSub deg         clss)
         ) => ParseG (Base_Vmin deg clss (Su n)) where
  parseG =     Base_Vmin <$> parseG


-- Ad-hoc cases for Base_Final
instance ParseG (Base_Final deg clss Ze) where parseG = empty

instance ( ParseG (Final deg clss)
         ) => ParseG (Base_Final deg clss (Su n)) where
  parseG =     Base_Final  <$> parseG
  
instance ( ToDegree deg
         , ParseG (Final   deg           DomClass)
         , ParseG (Base_Final (Tritone deg) DomClass n)
         , ParseG (Base_Final (Tritone deg) DimClass n)
         ) => ParseG (Base_Final deg DomClass (Su n)) where
  parseG =     Base_Final     <$> parseG
           <|> Final_Tritone  <$> parseG
           <|> Final_Dim_Trit <$> parseG
    where deg = toDegree (undefined :: deg)  
-- for dim chors    
instance ParseG (Surface_Chord deg clss Ze) where parseG = empty

instance ( ToDegree deg 
         , ParseG (Surface_Chord (MinThird deg) DimClass n)
         ) => ParseG (Surface_Chord deg DimClass (Su n)) where
  parseG =     Dim_Chord_Trns <$> parseG
           <|> pChord deg DimClass
    where deg = toDegree (undefined :: deg)  
  
-- all chords
instance ( ToDegree deg, ToClass clss
         ) => ParseG (Surface_Chord deg clss (Su n)) where
  parseG = pChord deg clss
    where deg = toDegree (undefined :: deg)
          clss = toClass (undefined :: clss)

pChord :: Degree -> ClassType -> PMusic (Surface_Chord deg clss (Su n))
pChord deg clss = transform <$> 
                    pSym (recognize, "ChordDegree", 
                          Chord deg (Just (head classes)) [] "inserted" 1) where
  recognize (Chord deg' (Just shrt) _ _ _) = deg == deg' && shrt `elem` classes
  recognize (Chord deg' Nothing     _ _ _) = False -- deg == deg'
                                             -- It seems that we can't use 
                                             -- deg == deg' above, as we get
                                             -- "ambiguous parser?" for some
                                             -- sequences, e.g.
                                             -- C:6 Bb:9 A:7 D:9 G:maj C: G:7 C:6
  classes = case clss of
              MajClass -> [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4]
              MinClass -> [Min,Min7,Min6,Min9,HDim7]
              DomClass -> [Sev,Nin,Aug]
              DimClass -> [Dim,Dim7]
  transform (Chord d s _ o n) = 
    Surface_Chord d [(Class clss (maybe (head classes) id s),t) | t <- words o ]

--------------------------------------------------------------------------------
-- The non-generic part of the pretty-printer
--------------------------------------------------------------------------------

-- Ad-hoc cases for Base_SD
instance ShowChord (Base_SD deg clss Ze) where
  showChord _ = error "showChord: impossible?"
  
instance ( ShowChord (Min5    deg               clss     n)
         , ShowChord (Base_SD (VDom deg)        DomClass n)
         , ToDegree  (Tritone deg) -- can this go?
         ) => ShowChord (Base_SD deg clss (Su n)) where
  showChord (Base_SD s)        = showChord s
  showChord (Cons_Vdom s d) = relVPrint "V" s d 0
  

-- Ad-hoc cases for Base_Vmin  
instance ShowChord (Base_Vmin deg clss Ze) where
  showChord _ = error "showChord: impossible?"

instance ( ShowChord (Base_SD (VMin deg)  MinClass n)
         , ShowChord (TritMinVSub deg        DomClass)
         ) => ShowChord (Base_Vmin deg clss (Su n)) where
  showChord (Base_Vmin d) = showChord d
  -- pattern match into the SD to see if we are our target degree
  -- is tritone substituted, if so, we "tritone-unsubstitute"
  showChord (Cons_Vmin    s d@(Final_Tritone  _)) = relVPrint "v" s d 1
  showChord (Cons_Vmin    s d@(Final_Dim_Trit _)) = relVPrint "v" s d 1
  showChord (Cons_Vmin    s d                   ) = relVPrint "v" s d 0
  
-- Ad-hoc cases for Base_Final
instance ShowChord (Base_Final deg clss Ze) where
  showChord _ = error "showChord: impossible?"

instance ( GetDegree (Base_Final (Tritone deg) DomClass n)
         , GetDegree (Base_Final (Tritone deg) DimClass n)
         , ShowChord (Final deg clss)
         , ShowChord (Base_Final (Tritone deg)  DomClass n)
         , ShowChord (Base_Final (Tritone deg)  DimClass n)
         ) => ShowChord (Base_Final deg clss (Su n)) where
  showChord (Base_Final d)  = showChord d
  -- The tritone substitution of a relative V is as alsway one semitone above
  -- the chord it is preceding
  showChord (Final_Tritone  d)  = transPrint "IIb7/"   d 11 
  showChord (Final_Dim_Trit d)  = transPrint "IIb7b9/" d 11 

-- dim base case
instance ShowChord (Surface_Chord deg clss Ze) where
  showChord _ = error "showChord: impossible?"

instance ( ShowChord (Surface_Chord deg clss n) 
         , ShowChord (Surface_Chord (MinThird deg) DimClass n) 
         , GetDegree (Surface_Chord (MinThird deg) DimClass n)
         ) => ShowChord (Surface_Chord deg clss (Su n)) where
  showChord (Surface_Chord d rs) = foldr (.) id
     [ paren (shows d . shows r . paren (showString s)) | (r,s) <- rs ]       
  showChord (Dim_Chord_Trns d) = paren $ toDegVal d 9 . showChar '0' . showChord d
  
--------------------------------------------------------------------------------
-- Value level computation for pretty printing
--------------------------------------------------------------------------------   

-- prints a secondary dominance structure, i.e. X/Y where X and Y are scaledegrees
relVPrint :: (GetDegree a, ShowChord b, ShowChord a) =>
             String -> b -> a -> Int -> ShowS
relVPrint prfx s d trans =
  paren (showString prfx . showChar '/' . toDegVal d trans . showChord  s)
  . showChord d 
--  paren (toDegVal d 7 
--  . paren (showString prfx . showChar '/' . toDegVal d trans . showChord  s))
--  . showChord d  

-- prints a single scale degree transformation  
transPrint :: (GetDegree a, ShowChord a) =>
              String -> a -> Int -> ShowS
transPrint prfx d trans =
  paren $ showString prfx. toDegVal d trans . showChord d
  
  
-- This function retuns a value level description of a degree using getDegree. 
-- Certain visualizations demand an addiional scale degree tranposition. The 
-- addTrans integer value can be used for that (use 0 for no transposition)
toDegVal :: (GetDegree a) => a -> Int -> ShowS  
toDegVal deg addTrans = case getDeg deg of 
  (deg, trans) -> shows $ transposeSem deg (trans + addTrans) 


-- Given a degree getDegee ensures that all information about the internal
-- structure of a scale degree, i.e. the degree and the an int value representing
-- the transposition of that degree at the current level, is available.
class GetDegree a where
  getDeg :: a -> (Degree, Int) 
  
instance GetDegree (Base_Vmin deg clss n) where
  getDeg (Base_Vmin d) = getDeg d
  getDeg (Cons_Vmin _ d)    = second (+5) (getDeg d)

instance ( GetDegree (Base_Final deg clss Ze)) where 
  getDeg = error "getDegree: impossible?"
instance ( GetDegree (Final deg clss)
         , GetDegree (Base_Final (Tritone deg)  DomClass n)
         , GetDegree (Base_Final (Tritone deg)  DimClass n)
         ) => GetDegree (Base_Final deg clss (Su n)) where
  getDeg (Base_Final d)  = getDeg d
  -- The tritone substitution of a relative V is as alsway one semitone above
  -- the chord it is preceding
  getDeg (Final_Tritone  d)  = second (+6) (getDeg d)
  getDeg (Final_Dim_Trit d)  = second (+6) (getDeg d)
  
instance ( GetDegree (Surface_Chord deg clss Ze)) where 
  getDeg = error "getDegree: impossible?"
  
instance ( GetDegree (Surface_Chord deg clss n)
         , GetDegree (Surface_Chord (MinThird deg) DimClass n)
         ) => GetDegree (Surface_Chord deg clss (Su n)) where
  getDeg (Surface_Chord d _) = (d,0) 
  getDeg (Dim_Chord_Trns d  ) = second (+9) (getDeg d)

--------------------------------------------------------------------------------
-- Value Level Scale Degree Transposition
-------------------------------------------------------------------------------- 

-- transposes a degree with sem semitones
transposeSem :: Degree -> Int -> Degree
transposeSem deg sem = semiToDia!((sem + (diaToSemi deg)) `mod` 12)

-- gives the semitone value [0,11] of a Degree, e.g. F# = 6
diaToSemi :: Degree -> Int
diaToSemi (Degree m dia) = (diaToSemi'!dia) + (modToSemi m)

-- transforms type-level modifiers to semitones (Int values)
modToSemi :: Maybe Modifier -> Int
modToSemi  Nothing  =  0
modToSemi (Just Sh) =  1
modToSemi (Just Fl) = -1
modToSemi (Just SS) =  2
modToSemi (Just FF) = -2

-- mapping diatonic intervals to semitones 
diaToSemi' :: Array Interval Int
diaToSemi' = listArray (1,7) [0,2,4,5,7,9,11]

-- mapping semitones to diatonic Degrees
-- TODO: what about pitch spelling...?
semiToDia  :: Array Int Degree
semiToDia  = listArray (0,11)
  [ Degree  Nothing  1 -- 0 C
  , Degree (Just Fl) 2 -- 1 Db
  , Degree  Nothing  2 -- 2 D
  , Degree (Just Fl) 3 -- 3 Eb
  , Degree  Nothing  3 -- 4 E
  , Degree  Nothing  4 -- 5 F
  , Degree (Just Sh) 4 -- 6 F#
  , Degree  Nothing  5 -- 7 G
  , Degree (Just Fl) 6 -- 8 Ab
  , Degree  Nothing  6 -- 9 A
  , Degree (Just Fl) 7 -- 10 Bb
  , Degree  Nothing  7 -- 11 B
  ]
  

--------------------------------------------------------------------------------
-- The non-generic part of the diff
--------------------------------------------------------------------------------

instance Children (Base_SD deg clss Ze) where children _ = []

instance ( GDiff (Base_SD (VDom deg) DomClass n)
         , GDiff (Min5 deg clss n)
         ) => Children (Base_SD deg clss (Su n)) where
  children (Base_SD x) = [Ex x]
  children (Cons_Vdom x y) = [Ex x, Ex y]


instance Children (Base_Vmin deg clss Ze) where children _ = []

instance ({- -- for ghc-6.12 
           Typeable (MinThird (MinThird (MinThird (MinThird (Tritone deg))))),
           Typeable (MinThird (MinThird (MinThird (Tritone deg)))),
           Typeable (MinThird (MinThird (Tritone deg))),
           Typeable (MinThird (Tritone deg)),
           Typeable (Tritone (Tritone deg)),
           Typeable (Tritone deg),
           Typeable deg,
         -}
           GDiff (Base_SD (VMin deg)  MinClass n)
         , GDiff (TritMinVSub deg DomClass)
         ) => Children (Base_Vmin deg DomClass (Su n)) where
  children (Base_Vmin x) = [Ex x]
  children (Cons_Vmin x y) = [Ex x, Ex y]

instance ( Typeable deg, Typeable clss, GDiff (TritMinVSub deg clss)
         ) => Children (Base_Vmin deg clss (Su n)) where
  children (Base_Vmin x) = [Ex x]


instance Children (Base_Final deg clss Ze) where children _ = []

instance ( GDiff (Base_Final (Tritone deg) DomClass n)
         , GDiff (Base_Final (Tritone deg) DimClass n)
         , GDiff (Final      deg           DomClass), Typeable deg
         ) => Children (Base_Final deg DomClass (Su n)) where
  children (Base_Final x) = [Ex x]
  children (Final_Tritone x) = [Ex x]
  children (Final_Dim_Trit x) = [Ex x]

instance (Typeable deg, Typeable clss, GDiff (Final deg clss)) 
    => Children (Base_Final deg clss (Su n)) where
  children (Base_Final x) = [Ex x]

instance Children (Surface_Chord deg clss Ze) where children _ = []

instance Children (Surface_Chord deg clss (Su n)) where
  children (Surface_Chord d ((c,_):_)) = [Ex d, Ex c]

instance (GDiff (Surface_Chord (MinThird deg) DimClass n))
    => Children (Surface_Chord deg DimClass (Su n)) where
  children (Surface_Chord d ((c,_):_)) = [Ex d, Ex c]
  children (Dim_Chord_Trns x) = [Ex x]

--------------------------------------------------------------------------------

instance Build (Base_SD deg clss Ze) where build _ _ = Nothing

instance ( Typeable n, Typeable (VDom deg), Typeable deg, Typeable clss
         , GDiff (Base_SD (VDom deg) DomClass n)
         , GDiff (Min5 deg clss n)
         ) => Build (Base_SD deg clss (Su n)) where
  build (Base_SD _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_SD
  build (Cons_Vdom _ _) ((Ex x):(Ex y):r) = do x' <- cast x
                                               y' <- cast y
                                               Just (Cons_Vdom x' y', r)
  build _ _ = Nothing


instance Build (Base_Vmin deg clss Ze) where build _ _ = Nothing

instance ( Typeable n, Typeable (VMin deg), Typeable deg
         , GDiff (Base_SD (VMin deg) MinClass n)
         , GDiff (TritMinVSub    deg        DomClass)
         ) => Build (Base_Vmin deg DomClass (Su n)) where
  build (Base_Vmin _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Vmin
  build (Cons_Vmin _ _) ((Ex x):(Ex y):r) = do x' <- cast x
                                               y' <- cast y
                                               Just (Cons_Vmin x' y', r)

instance ( Typeable deg, Typeable clss, GDiff (TritMinVSub deg clss)
         ) => Build (Base_Vmin deg clss (Su n)) where
  build (Base_Vmin _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Vmin


instance Build (Base_Final deg clss Ze) where build _ _ = Nothing

instance ( Typeable n, Typeable (Tritone deg), Typeable deg
         , GDiff (Base_Final (Tritone deg) DomClass n)
         , GDiff (Base_Final (Tritone deg) DimClass n)
         , GDiff (Final      deg           DomClass)
         ) => Build (Base_Final deg DomClass (Su n)) where
  build (Base_Final _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Final
  build (Final_Tritone _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Final_Tritone
  build (Final_Dim_Trit _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Final_Dim_Trit

instance (Typeable deg, Typeable clss) 
    => Build (Base_Final deg clss (Su n)) where
  build (Base_Final _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Final


instance Build (Surface_Chord den clss Ze) where build _ _ = Nothing

instance Build (Surface_Chord den clss (Su n)) where
  build (Surface_Chord _ ((_,s):r)) ((Ex x):(Ex y):rs) = 
    do x' <- cast x
       y' <- cast y
       Just (Surface_Chord x' ((y',s):r),rs)

instance (Typeable (MinThird den), Typeable n)
    => Build (Surface_Chord den DimClass (Su n)) where
  build (Dim_Chord_Trns _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Dim_Chord_Trns
  build (Surface_Chord _ ((_,s):r)) ((Ex x):(Ex y):rs) = 
    do x' <- cast x
       y' <- cast y
       Just (Surface_Chord x' ((y',s):r),rs)

--------------------------------------------------------------------------------

instance SEq (Base_SD deg clss Ze) where shallowEq _ _ = False -- ?

instance ( GDiff (Base_SD (VDom deg) DomClass n)
         , GDiff (Min5 deg clss n)
         ) => SEq (Base_SD deg clss (Su n)) where
  shallowEq (Base_SD _) (Base_SD _) = True
  shallowEq (Cons_Vdom _ _) (Cons_Vdom _ _) = True
  shallowEq _ _ = False


instance SEq (Base_Vmin deg clss Ze) where shallowEq _ _ = False

instance ( GDiff (Base_SD     (VMin deg) MinClass n)
         , GDiff (TritMinVSub deg        DomClass)
         ) => SEq (Base_Vmin deg DomClass (Su n)) where
  shallowEq (Base_Vmin _) (Base_Vmin _) = True
  shallowEq (Cons_Vmin _ _) (Cons_Vmin _ _) = True
  shallowEq _ _ = False

instance ( GDiff (TritMinVSub deg         clss)
         ) => SEq (Base_Vmin deg clss (Su n)) where
  shallowEq (Base_Vmin _) (Base_Vmin _) = True
  shallowEq _ _ = False


instance SEq (Base_Final deg clss Ze) where shallowEq _ _ = False

instance ( GDiff (Base_Final (Tritone deg) DomClass n)
         , GDiff (Base_Final (Tritone deg) DimClass n)
         , GDiff (Final      deg           DomClass)
         ) => SEq (Base_Final deg DomClass (Su n)) where
  shallowEq (Base_Final _) (Base_Final _) = True
  shallowEq (Final_Tritone _) (Final_Tritone _) = True
  shallowEq (Final_Dim_Trit _) (Final_Dim_Trit _) = True
  shallowEq _ _ = False

instance (SEq (Final deg clss)) => SEq (Base_Final deg clss (Su n)) where
  shallowEq (Base_Final _) (Base_Final _) = True
  shallowEq _ _ = False


instance SEq (Surface_Chord deg clss Ze) where shallowEq _ _ = False

instance SEq (Surface_Chord deg clss (Su n)) where
  shallowEq (Surface_Chord _ _) (Surface_Chord _ _) = True
  shallowEq _ _ = False

instance SEq (Surface_Chord deg DimClass (Su n)) where
  shallowEq (Dim_Chord_Trns _) (Dim_Chord_Trns _) = True
  shallowEq (Surface_Chord _ _) (Surface_Chord _ _) = True
  shallowEq _ _ = False


--------------------------------------------------------------------------------

instance (Typeable deg, Typeable clss) => 
  GDiff (Base_SD deg clss Ze)

instance ( Typeable deg, Typeable clss, Typeable n, Typeable (VDom deg)
         , GDiff (Base_SD (VDom deg) DomClass n)
         , GDiff (Min5 deg clss n)
         ) => GDiff (Base_SD deg clss (Su n))


instance (Typeable deg, Typeable clss)
  => GDiff (Base_Vmin deg clss Ze)

instance ({- -- for ghc-6.12
           Typeable (MinThird (MinThird (MinThird (MinThird (Tritone deg))))),
           Typeable (MinThird (MinThird (MinThird (Tritone deg)))),
           Typeable (MinThird (MinThird (Tritone deg))),
           Typeable (MinThird (Tritone deg)),
           Typeable (Tritone (Tritone deg)),
           Typeable (Tritone deg),
          -}
           Typeable (VMin deg), Typeable deg, Typeable n
         , GDiff (Base_SD (VMin deg) MinClass n)
         , GDiff (TritMinVSub    deg        DomClass)
         ) => GDiff (Base_Vmin deg DomClass (Su n))

instance ( Typeable deg, Typeable clss, Typeable n
         , GDiff (TritMinVSub deg         clss)
         ) => GDiff (Base_Vmin deg clss (Su n))


instance (Typeable deg, Typeable clss)
  => GDiff (Base_Final deg clss Ze)

instance ( Typeable deg, Typeable n, Typeable (Tritone deg)
         , GDiff (Base_Final (Tritone deg) DomClass n)
         , GDiff (Base_Final (Tritone deg) DimClass n)
         , GDiff (Final      deg           DomClass)
         ) => GDiff (Base_Final deg DomClass (Su n))

instance (Typeable deg, Typeable clss, Typeable n, GDiff (Final deg clss)) 
  => GDiff (Base_Final deg clss (Su n))


instance (Typeable deg, Typeable clss)
  => GDiff (Surface_Chord deg clss Ze)

instance (Typeable deg, Typeable clss, Typeable n)
  => GDiff (Surface_Chord deg clss (Su n))

instance ( Typeable deg, Typeable n, Typeable (MinThird deg)
         , GDiff (Surface_Chord (MinThird deg) DimClass n)
         )
  => GDiff (Surface_Chord deg DimClass (Su n))
--------------------------------------------------------------------------------

instance Children Class where children _ = []
instance Build Class where build c r = Just (c,r)
instance SEq Class where shallowEq _ _ = True
instance GDiff Class

instance Children Degree where children _ = []
instance Build Degree where build c r = Just (c,r)
instance SEq Degree where shallowEq _ _ = True
instance GDiff Degree

--------------------------------------------------------------------------------
-- ChordDegree as tokens
--------------------------------------------------------------------------------

instance IsLocationUpdatedBy (Int, Int) ChordDegree where
  advance (line,pos) _ = (line,pos+1)