HarmTrace-0.4: MIR/HarmGram/Tokenizer.hs
{-# 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)