{-# LANGUAGE TemplateHaskell                #-}
{-# LANGUAGE EmptyDataDecls                 #-}
{-# LANGUAGE TypeFamilies                   #-}
{-# LANGUAGE GADTs                          #-}

module HarmTrace.Base.MusicRep where
  
import Data.Maybe
import Data.List (elemIndex, intersperse, intercalate)  
import Control.DeepSeq
import HarmTrace.HAnTree.Binary
import Generics.Instant.TH
import Data.Binary
  
--------------------------------------------------------------------------------
-- Representing musical information at the value level
--------------------------------------------------------------------------------

-- Keys (at the value level)
data Key  = Key Root Mode       deriving (Show, Eq)
data Mode = MinMode | MajMode   deriving Eq

instance NFData Mode where
  rnf MinMode = ()
  rnf MajMode = ()
  
type ChordLabel   = Chord Root
type ChordDegree  = Chord ScaleDegree

-- the representation for a single tokenized chord 
data Chord a = Chord { chordRoot        :: a
                     , chordShorthand   :: Shorthand
                     , chordAdditions   :: [Addition]
                     , getLoc           :: Int -- the index of the chord  
                     , duration         :: Int -- in the list of tokens
                     }                        

data Class = Class ClassType Shorthand

data ClassType = MajClass | MinClass | DomClass | DimClass  deriving (Eq)               
                   
data Shorthand = -- Triad chords
                 Maj | Min | Dim | Aug
                 -- Seventh chords
               | Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7
                 -- Sixth chords
               | Maj6 | Min6
                 -- Extended chords
               | Nin | Maj9 | Min9
                 -- Suspended chords
               | Sus4
                 -- In some cases there is no chord a certain position
                 -- This is especially important for the chroma processing
               | None
  deriving (Show, Eq, Enum, Bounded) 


-- Key relative scale degrees to abstract from the absolute Root notes
type ScaleDegree = Note DiatonicDegree

data DiatonicDegree = I | II | III | IV | V | VI | VII | Imp
  deriving (Show, Eq, Enum, Ord, Bounded)

-- Representing absolute root notes  
type Root = Note DiatonicNatural
  
data DiatonicNatural =  C | D | E | F | G | A | B | N -- N is for no root 
  deriving (Show, Eq, Enum, Ord, Bounded)
  
-- Intervals for additonal chord notes    
type Addition = Note Interval
  
data Interval = I1  | I2  | I3  | I4 | I5 | I6 | I7 | I8 | I9 | I10 
              | I11 | I12 | I13 
  deriving (Eq, Enum, Ord, Bounded)     
  
data Note a = Note (Maybe Modifier) a   deriving (Eq) 
  
data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat
  deriving (Eq)  

--------------------------------------------------------------------------------
-- Instances for the general music datatypes
--------------------------------------------------------------------------------   

    
instance Show Mode where
  show MajMode = ""
  show MinMode = "m"  
  
instance Eq a => Eq (Chord a) where
  (Chord ra sha dega _loc _d) == (Chord rb shb degb _locb _db) 
     = ra == rb && sha == shb && dega == degb 
  
instance (Show a) => Show (Chord a) where
  show (Chord r sh deg loc d) =  show r ++ ':' : show sh 
                            ++ (if not (null deg) then showAdds deg else "")
                            ++ '_' : show loc ++ ':' : show d
    
showAdds :: Show a => [a] -> String                                
showAdds x = '(' : intercalate "," (map show x) ++ ")"
     
instance Show Class where show (Class ct _) = show ct
                            
instance Show ClassType where
  show (MajClass) = ""
  show (MinClass) = "m"
  show (DomClass) = "7"
  show (DimClass) = "0"                             
                            
instance (Show a) => Show (Note a) where
  show (Note m interval) = show interval ++ maybe "" show m

instance Show Interval where
  show a = show . ((!!) ([1..13]::[Integer])) 
                . fromJust $ elemIndex a [minBound..]
   
  
instance Show Modifier where 
  show Sh = "#"
  show Fl = "b"
  show SS = "##"
  show FF = "bb"     

-- for showing additional additions
showAdditions :: [Addition] -> String
showAdditions a 
  | null a    = ""
  | otherwise = "(" ++ concat (intersperse ","  (map show a)) ++ ")"           
  
--------------------------------------------------------------------------------
-- Utils      
--------------------------------------------------------------------------------

toClassType :: Shorthand -> ClassType
toClassType sh 
  | sh `elem` [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4] = MajClass
  | sh `elem` [Min,Min7,Min6,Min9,HDim7] = MinClass
  | sh `elem` [Sev,Nin,Aug] = DomClass
  | sh `elem` [Dim,Dim7] = DimClass 
  | otherwise = error ("toClassType: unknow shorthand: " ++ show sh)     
--------------------------------------------------------------------------------
-- Value Level Scale Degree Transposition
-------------------------------------------------------------------------------- 

isNoneChord :: ChordLabel -> Bool
isNoneChord (Chord (Note _ N) _ _ _ _) = True
isNoneChord (Chord _ None _ _ _)       = True
isNoneChord _                          = False
    
-- Chord root shorthand degrees location duration
toChordDegree :: Key -> ChordLabel -> ChordDegree
toChordDegree k (Chord r sh degs loc d) = 
                 Chord (toScaleDegree k r) sh degs loc d    
    
toScaleDegree :: Key -> Root -> ScaleDegree
toScaleDegree _ n@(Note _ N) = 
  error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose" ++ show n)
toScaleDegree (Key kr _) cr  = -- Note Nothing I
  scaleDegrees!!(((diaNatToSemi cr) - (diaNatToSemi kr)) `mod` 12)

-- transposes a degree with sem semitones up
transposeSem :: ScaleDegree -> Int -> ScaleDegree
transposeSem deg sem = scaleDegrees!!((sem + (diaDegToSemi deg)) `mod` 12) where

-- gives the semitone value [0,11] of a Degree, e.g. F# = 6
diaDegToSemi :: ScaleDegree -> Int
diaDegToSemi (Note m deg) = 
  ([0,2,4,5,7,9,11] !! (fromJust $ elemIndex deg [minBound..])) + (modToSemi m) 
  
diaNatToSemi :: Root -> Int
diaNatToSemi (Note m nat) = 
  ([0,2,4,5,7,9,11] !! (fromJust $ elemIndex nat [minBound..])) + (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
           
scaleDegrees ::[ScaleDegree]  
scaleDegrees = [ Note  Nothing   I
               , Note  (Just Fl) II
               , Note  Nothing   II
               , Note  (Just Fl) III
               , Note  Nothing   III
               , Note  Nothing   IV
               , Note  (Just Sh) IV
               , Note  Nothing   V
               , Note  (Just Fl) VI
               , Note  Nothing   VI
               , Note  (Just Fl) VII
               , Note  Nothing   VII
               ]


--------------------------------------------------------------------------------
-- Binary instances
--------------------------------------------------------------------------------

deriveAllL [''Note, ''DiatonicDegree
           , ''Mode, ''Chord, ''DiatonicNatural, ''ClassType
           , ''Modifier, ''Shorthand, ''Interval]

instance (Binary a) => Binary (Note a) where
  put = putDefault
  get = getDefault
instance Binary DiatonicDegree where
  put = putDefault
  get = getDefault
instance Binary Mode where
  put = putDefault
  get = getDefault
instance (Binary a) => Binary (Chord a) where
  put = putDefault
  get = getDefault
instance Binary DiatonicNatural where
  put = putDefault
  get = getDefault
instance Binary ClassType where
  put = putDefault
  get = getDefault
instance Binary Modifier where
  put = putDefault
  get = getDefault
instance Binary Shorthand where
  put = putDefault
  get = getDefault
instance Binary Interval where
  put = putDefault
  get = getDefault