{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE RankNTypes               #-}
{-# LANGUAGE FlexibleContexts         #-}

module MIR.HarmGram.Tokenizer where

-- Parser stuff
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances.String

import Data.Char (digitToInt)
import Data.List (intersperse)
import Data.Maybe
import Data.Typeable

import Control.Arrow (first)


--------------------------------------------------------------------------------
-- Tokens for parsing chords
--------------------------------------------------------------------------------

data PieceToken = PieceToken { key :: ChordName, labels :: [ChordName] }

data Chord a = Chord a (Maybe Shorthand) [Degree] String Int
                -- The String stores the original input
                -- The Int stores the number of repeated chords
  deriving Eq
  
instance (Show a) => Show (Chord a) where
  show (Chord a sh deg _ _) = show a 
                             ++ if isJust sh then show (fromJust sh) else ""
                             ++ if not (null deg) then show deg else ""
  
type ChordName = Chord ChordRoot

data Degree = Degree (Maybe Modifier) Interval
  deriving (Eq, Typeable)

instance Show Degree where
  show (Degree m interval) = intervalToDegree interval ++ maybe "" show m

intervalToDegree :: Int -> String
intervalToDegree i = ["I","II", "III","IV","V","VI","VII"] !! ((i-1) `mod` 7)
  
-- shows Degrees that are used as chord additions (see also showAdditions)   
showAddition :: Degree -> String  
showAddition (Degree m interval) = maybe "" show m ++ show interval
  
data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat
  deriving (Eq)
  
instance Show Modifier where 
  show Sh = "#"
  show Fl = "b"
  show SS = "##"
  show FF = "bb"   

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
  deriving (Show, Eq)

type Interval = Int -- Ranges from 1 to 13

data ChordRoot = A  | B  | C  | D  | E  | F  | G
               | Ab | Bb | Cb | Db | Eb | Fb | Gb
               | As | Bs | Cs | Ds | Es | Fs | Gs
  deriving (Show, Eq)

pString :: (Provides st a b) => [a] -> P st [b]
pString s = foldr (\a b -> (:) <$> a <*> b) (pure []) (map pSym s)

-- Input is a string of whitespace-separated chords, e.g.
-- Bb:9(s11) E:min7 Eb:min7 Ab:7 D:min7 G:7(13) C:maj6(9)
-- First token is the key of the piece
parseSong :: Parser PieceToken
parseSong = PieceToken <$> parseKey <* pSpaces 
                       <*> pListSep_ng pSpaces parseChord 
                           <* pList pSpaces
  where pSpaces = pAnySym [' ','\n','\t']

-- For now, I assume there is always a shorthand, and sometimes extra
-- degrees. I guess it might be the case that sometimes there is no shorthand,
-- but then there certainly are degrees.
parseChord, parseKey :: Parser ChordName
parseChord = f <$> parseRoot <* pSym ':' <*> pMaybe parseShorthand
                                         <*> (parseDegrees `opt` [])
  where -- in case of a sus4 we also analyse the degree list, if there is one.
        f r (Just Sus4) [] = Chord r (Just Sus4) [] (str r Sus4 []) 1
        f r (Just Sus4) d  = Chord r (Just $ analyseDegs d) d 
                                      (str r (analyseDegs d) d) 1
        -- if we have a short hand we use it to determine the class of the chord
        f r (Just s)    d  = Chord r (Just s) d (str r s d) 1
        -- in case of there is no short hand we analyse the degree list
        f r Nothing     d  = Chord r (Just $ analyseDegs d) d 
                                      (str r (analyseDegs d) d) 1
        str r s d          = show r ++ show s ++ showAdditions d

parseKey = f <$> parseRoot <* pSym ':' <*> parseShorthand
  where f k m | k == C && (m == Maj || m == Min) = Chord k (Just m) [] "" 1
              | otherwise = error "Tokenizer: key must be C:Maj or C:min"

-- analyses a list of Degrees and assigns a shortHand i.e. Chord Class        
analyseDegs :: [Degree] -> Shorthand        
analyseDegs d 
  | (Degree (Just Fl) 5)  `elem` d = Min
  | (Degree (Just Sh) 5)  `elem` d = Sev
  | (Degree (Just Fl) 7)  `elem` d = Sev
  | (Degree (Just Fl) 9)  `elem` d = Sev
  | (Degree (Just Sh) 9)  `elem` d = Sev
  | (Degree (Just Sh) 11) `elem` d = Sev
  | (Degree (Just Fl) 13) `elem` d = Sev
  | (Degree (Just Fl) 3)  `elem` d = Min
  | (Degree  Nothing  3)  `elem` d = Maj
  | otherwise                      = Maj
   
       
-- for showing additional additions
showAdditions :: [Degree] -> String
showAdditions a 
  | null a    = ""
  | otherwise = "(" ++ concat (intersperse ","  (map showAddition a)) ++ ")"


parseShorthand :: Parser Shorthand
parseShorthand =     Maj      <$ pString "maj"
                 <|> Min      <$ pString "min"
                 <|> Dim      <$ pString "dim"
                 <|> Aug      <$ pString "aug"
                 <|> Maj7     <$ pString "maj7"
                 <|> Min7     <$ pString "min7"
                 <|> Sev      <$ pString "7"
                 <|> Dim7     <$ pString "dim7"
                 <|> HDim7    <$ pString "hdim" <* opt (pSym '7') '7'
                 <|> MinMaj7  <$ pString "minmaj7"
                 <|> Maj6     <$ pString "maj6"
                 <|> Maj6     <$ pString "6"
                 <|> Min6     <$ pString "min6"
                 <|> Nin      <$ pString "9"
                 <|> Maj9     <$ pString "maj9"
                 <|> Min9     <$ pString "min9"
                 <|> Sus4     <$ pString "sus4" <?> "Shorthand"

-- We don't produce intervals for a shorthand. This could easily be added,
-- though.
parseDegrees :: Parser [Degree]
parseDegrees = pPacked (pSym '(') (pSym ')') 
                       (catMaybes <$> (pList1Sep (pSym ',') parseDegree))
                 
parseDegree :: Parser (Maybe Degree)
parseDegree =     (Just   <$> (Degree <$> pMaybe parseModifier <*> parseInterval))
              <|> Nothing <$  pSym '*' <* pMaybe parseModifier <*  parseInterval
              
parseModifier :: Parser Modifier
parseModifier =     Sh <$ pSym    's'
                <|> Fl <$ pSym    'b'
                <|> SS <$ pString "ss"
                <|> FF <$ pString "bb" <?> "Modifier"

parseInterval :: Parser Interval
parseInterval = pInt

pInt :: Parser Int
pInt = fmap (foldl (\b a -> b * 10 + digitToInt a) 0) 
            (pList (pAnySym ['0'..'9']))

parseRoot :: Parser ChordRoot
parseRoot =     A  <$ pSym 'A'
            <|> B  <$ pSym 'B'
            <|> C  <$ pSym 'C'
            <|> D  <$ pSym 'D'
            <|> E  <$ pSym 'E'
            <|> F  <$ pSym 'F'
            <|> G  <$ pSym 'G'
            <|> Ab <$ pString "Ab"
            <|> Bb <$ pString "Bb"
            <|> Cb <$ pString "Cb"
            <|> Db <$ pString "Db"
            <|> Eb <$ pString "Eb"
            <|> Fb <$ pString "Fb"
            <|> Gb <$ pString "Gb"
            <|> As <$ pString "A#"
            <|> Bs <$ pString "B#"
            <|> Cs <$ pString "C#"
            <|> Ds <$ pString "D#"
            <|> Es <$ pString "E#"
            <|> Fs <$ pString "F#"
            <|> Gs <$ pString "G#" <?> "Chord root"

-- Testing the tokenizer
testTokenizer :: String -> IO ()
testTokenizer s = readFile s >>= print' . map (first labels) . aux where
  aux = parse (amb ((,) <$> parseSong <*> pEnd)) . createStr
  print' l@(h:_:_) =
       putStrLn (show (length l) ++ " possible trees, showing the first:")
    >> print' [h]
  print' [(l,e)]   = mapM_ print l >> show_errors e
  print' []        = print "No parse trees!"

--------------------------------------------------------------------------------
-- From chord names to chord degrees
--------------------------------------------------------------------------------
type ChordDegree = Chord Degree

-- relativizeC chord converts a chord to a degree, on scale C
-- (Obviously, this should be generalized to any scale degree, but for now
-- this will do.)
relativizeC :: ChordName -> ChordDegree
relativizeC (Chord n s i r m) = Chord (rel n) s i r m where
  rel :: ChordRoot -> Degree
  rel C = Degree Nothing 1
  rel D = Degree Nothing 2
  rel E = Degree Nothing 3
  rel F = Degree Nothing 4
  rel G = Degree Nothing 5
  rel A = Degree Nothing 6
  rel B = Degree Nothing 7
  rel Cs = Degree (Just Sh) 1
  rel Ds = Degree (Just Sh) 2
  rel Es = Degree (Just Sh) 3
  rel Fs = Degree (Just Sh) 4
  rel Gs = Degree (Just Sh) 5
  rel As = Degree (Just Sh) 6
  rel Bs = Degree (Just Sh) 7
  rel Cb = Degree (Just Fl) 1
  rel Db = Degree (Just Fl) 2
  rel Eb = Degree (Just Fl) 3
  rel Fb = Degree (Just Fl) 4
  rel Gb = Degree (Just Fl) 5
  rel Ab = Degree (Just Fl) 6
  rel Bb = Degree (Just Fl) 7

-- Merges duplicate chords
mergeDups :: (Eq a) => [Chord a] -> [Chord a]
mergeDups []  = []
mergeDups [x] = [x]
mergeDups (c1@(Chord n s i r m):c2@(Chord n2 s2 i2 r2 _):t)
  | n == n2 && s == s2 = mergeDups ((Chord n s (i++i2) (r ++" "++ r2) (m+1)):t)
  | otherwise          = c1 : mergeDups (c2:t)