module Billboard.BillboardParser ( pBillboard
, parseBillboard
, acceptableBeatDeviationMultiplier ) where
import Data.List (genericLength, partition)
import Control.Arrow (first)
import Text.ParserCombinators.UU
import HarmTrace.Base.Parsing hiding (pLineEnd)
import HarmTrace.Base.MusicRep hiding (isNone)
import HarmTrace.Base.MusicTime( TimedData (..), timedData
, BarTime (..), onset, offset)
import HarmTrace.Base.ChordTokenizer (pRoot, pChord)
import Billboard.BeatBar ( TimeSig (..), BeatWeight (..), tatumsPerBar
, chordsPerDot )
import Billboard.BillboardData
import Billboard.Annotation ( Annotation (..), Label (..)
, Instrument (..), Description (..), isStart
, isRepeat, getRepeats)
acceptableBeatDeviationMultiplier :: Double
acceptableBeatDeviationMultiplier = 0.075
parseBillboard :: String -> (BillboardData, [Error LineColPos])
parseBillboard = parseDataWithErrors pBillboard
pBillboard :: Parser BillboardData
pBillboard = do (a, t, ts, r) <- pHeader
c <- pChordLinesPost ts
return (BillboardData a t ts r (setChordIxsT c)) where
pHeader :: Parser (Title, Artist, TimeSig, Root)
pHeader = sortMetas <$> (pMetaPrefix *> pTitle ) <* pLineEnd <*>
(pMetaPrefix *> pArtist ) <* pLineEnd <*>
(pMetaPrefix *> pMeta ) <* pLineEnd <*>
(pMetaPrefix *> pMeta ) <* pLineEnd <* pLineEnd where
sortMetas :: Title -> Artist -> Meta -> Meta -> (Title, Artist, TimeSig, Root)
sortMetas t a (Metre ts) (KeyRoot r) = (t, a, ts, r)
sortMetas t a (KeyRoot r) (Metre ts) = (t, a, ts, r)
sortMetas _ _ _ _ =
error "pBillboard (sortMetas): no valid metre and tonic found"
pMetaPrefix :: Parser Char
pMetaPrefix = pSym '#' <* pSym ' '
pTitle :: Parser Title
pTitle = id <$> (pString "title: " *> pReadableStr)
pArtist :: Parser Artist
pArtist = id <$> (pString "artist: " *> pReadableStr)
pMeta :: Parser Meta
pMeta = pMetre <|> pKeyRoot
pMetre :: Parser Meta
pMetre = Metre <$> (pString "metre: " *> pTimeSig )
pKeyRoot :: Parser Meta
pKeyRoot = KeyRoot <$> (pString "tonic: " *> pRoot )
pTimeSig :: Parser TimeSig
pTimeSig = TimeSig <$> (tuple <$> pIntegerRaw <*> (pSym '/' *> pIntegerRaw))
pStructStart :: Parser [Annotation]
pStructStart = pList (pStrucLab <|> pStrucDescStart)
pStrucLab :: Parser Annotation
pStrucLab = Start <$> (Struct <$> pUpper <*> pPrimes) <* pString ", "
pPrimes :: Parser Int
pPrimes = length <$> pMany (pSym '\'')
pStrucDescStart :: Parser Annotation
pStrucDescStart = (Start . Anno) <$> pAnno <* pString ", "
pAnno :: Parser Description
pAnno = pAnnotation <<|> pUnknownAnno
pAnnotation :: Parser Description
pAnnotation = Chorus <$ pString "chorus"<* pMabSpcDsh <* pMaybe pLower
<|> Verse <$> (pString "verse" *> pMabSpc *> pMaybe pTextNr)
<|> PreVerse <$ pString "pre" <* pMabSpcDsh <* pString "verse"
<|> Vocal <$ pString "vocal"
<|> Intro <$ pMaybe (pString "pre") <* pMabSpcDsh
<* pString "intro" <* pMabSpcDsh <* pMaybe pLower
<|> Outro <$ pString "outro"
<|> Bridge <$ pString "bridge"
<|> Interlude <$ pString "interlude"
<|> Transition <$ pString "trans"<* pMaybe (pString "ition" )
<|> Fadeout <$ pString "fade" <* pMabSpc <* pString "out"
<|> Fadein <$ pString "fade" <* pMabSpc <* pString "in"
<|> Solo <$ pString "solo"
<|> Prechorus <$ pString "pre"<* pMabSpcDsh <* pString "chorus"
<|> Maintheme <$ pString "main"<* pMabSpcDsh <* pString "theme"
<|> Keychange <$ pString "key"<* pMabSpcDsh <* pString "change"
<|> Secondarytheme <$ pOptWrapPar "secondary" <* pMabSpcDsh
<* pString "theme"
<|> Instrumental <$ pString "instrumental"
<* pMaybe (pString " break")
<|> Coda <$ pString "coda"
<|> Ending <$ pString "ending"
<|> Talking <$ pString "spoken" <* pMaybe (pString " verse")
<|> ModulationSeg <$ pString "modulation"
pTextNr :: Parser Int
pTextNr = 1 <$ pString "one"
<|> 2 <$ pString "two"
<|> 3 <$ pString "three"
<|> 4 <$ pString "four"
<|> 5 <$ pString "five"
<|> 6 <$ pString "six"
<|> 7 <$ pString "seven"
<|> 8 <$ pString "eight"
<|> 9 <$ pString "nine"
pUnknownAnno :: Parser Description
pUnknownAnno = UnknownAnno <$> pList1 pLower
pEndAnnotations :: Parser [Annotation]
pEndAnnotations = (++) <$> pRepeat <*> ((++) <$> pPhrase <*> pEndAnno)
pEndAnno :: Parser [Annotation]
pEndAnno = concat <$> pList (pString ", " *>
(pPhrase <|> pLeadInstr <|> pStrucDescEnd))
pPhrase :: Parser [Annotation]
pPhrase = (list . End . Anno $ PhraseTrans) <$ pString " ->" `opt` []
pRepeat :: Parser [Annotation]
pRepeat = (list . End . Anno . Repeat) <$> (pString " x" *> pIntegerRaw) `opt` []
pStrucDescEnd :: Parser [Annotation]
pStrucDescEnd = (list . End . Anno) <$> pAnno
pLeadInstr :: Parser [Annotation]
pLeadInstr = pLeadInstrStart <|> pLeadInstrEnd <|> pLeadInstrStartEnd
pLeadInstrStart :: Parser [Annotation]
pLeadInstrStart = (list . Start . Instr) <$> (pSym '(' *> pInstr)
pLeadInstrEnd :: Parser [Annotation]
pLeadInstrEnd = (list . End . Instr) <$> pInstr <* pSym ')'
pLeadInstrStartEnd :: Parser [Annotation]
pLeadInstrStartEnd = f <$> (pSym '(' *> pInstr <* pSym ')')
where f a = [Start $ Instr a, End $ Instr a]
pInstr :: Parser Instrument
pInstr = pInstrument <<|> pUnknownInstr
pInstrument :: Parser Instrument
pInstrument = Guitar <$ pString "guitar"
<|> Voice <$ pString "vo"
<* (pString "ice" <|> pString "cal")
<|> Violin <$ (pString "fiddle" <|>
(pString "violin" <* pMaybe (pSym 's')))
<|> Banjo <$ pString "banjo"
<|> Synthesizer <$ pString "synth" <* pMaybe (pString "esi"
<*(pSym 's' <|> pSym 'z' ) <* pString "er")
<|> Saxophone <$ pString "saxophone"
<|> Flute <$ pString "flute"
<|> Drums <$ pString "drum" <* pMaybe (pString " kit"
<|> pString "s")
<|> SteelDrum <$ pString "steel " <* (pString "drum"
<|> pString "pan") <* pMaybe (pSym 's')
<|> Trumpet <$ pString "trumpet" <* pMaybe (pSym 's')
<|> Vibraphone <$ pString "vibraphone"
<|> Piano <$ pString "piano"
<|> Harmonica <$ pString "harmonica"
<|> Organ <$ pString "organ"
<|> Keyboard <$ pString "keyboard"
<|> Strings <$ pString "strings"
<|> Trombone <$ pString "trombone"
<|> Electricsitar <$ pString "electric"<* pMabSpc <* pString "sitar"
<|> Pennywhistle <$ pString "pennywhistle"
<|> Tenorsaxophone <$ pString "tenor" <* pMabSpc <* pString "saxophone"
<|> Whistle <$ pString "whistle"
<|> Oboe <$ pString "oboe"
<|> Tambura <$ pString "tambura"
<|> Horns <$ (pString "horns" <|> pString "brass")
<|> Clarinet <$ pString "clarinet"
<|> Electricguitar <$ pString "electric"<* pMabSpc <* pString "guitar"
<|> Steelguitar <$ pString "steel" <* pMabSpc <* pString "guitar"
<|> Tenorhorn <$ pString "tenor" <* pMabSpc <* pString "horn"
<|> Percussion <$ pString "percussion"
<|> Rhythmguitar <$ pString "rhythm" <* pMabSpc <* pString "guitar"
<|> Hammondorgan <$ pString "hammond" <* pMabSpc <* pString "organ"
<|> Harpsichord <$ pString "harpsichord"
<|> Cello <$ pString "cello"
<|> Acousticguitar <$ pString "acoustic" <* pMabSpc <* pString "guitar"
<|> Bassguitar <$ pString "bass" <* pMaybe (pString " guitar")
<|> Bongos <$ pString "bongos"
<|> Horn <$ pString "horn"
<|> Sitar <$ pString "sitar"
<|> Barisaxophone <$ pString "baritone" <* pMabSpc <* pString "saxophone"
<|> Accordion <$ pString "accordion"
<|> Tambourine <$ pString "tambourine"
<|> Kazoo <$ pString "kazoo"
pUnknownInstr :: Parser Instrument
pUnknownInstr = UnknownInstr <$> pList1 pLower
pMetaChange :: Parser (Either (Double, [BBChord]) Meta)
pMetaChange = pModulation <|> pMetreChange
pModulation :: Parser (Either (Double, [BBChord]) Meta)
pModulation = Right <$> (pMetaPrefix *> pKeyRoot)
pMetreChange :: Parser (Either (Double, [BBChord]) Meta)
pMetreChange = Right <$> (pMetaPrefix *> pMetre)
pChordLinesPost :: TimeSig -> Parser [TimedData BBChord]
pChordLinesPost ts = (interp . setTiming) <$> pChordLines ts
setTiming :: [(Double, a)] -> [TimedData a]
setTiming [ ] = []
setTiming [_] = []
setTiming (a : b : cs) = TimedData (snd a) [Time (fst a), Time (fst b)]
: setTiming (b:cs)
interp :: [TimedData [BBChord]] -> [TimedData BBChord]
interp = concatMap interpolate . fixBothBeatDev where
interpolate :: TimedData [BBChord] -> [TimedData BBChord]
interpolate td =
let on = onset td
off = offset td
dat = getData td
bt = (off on) / genericLength dat
in zipWith3 timedData dat [on, (on+bt) ..] [(on+bt), (on+bt+bt) ..]
fixForward, fixBackward, fixBothBeatDev :: [TimedData [BBChord]]
-> [TimedData [BBChord]]
fixBothBeatDev = fixBackward . fixForward
fixForward = fixOddLongBeats Forward
acceptableBeatDeviationMultiplier
fixBackward = reverse . fixOddLongBeats Backward
acceptableBeatDeviationMultiplier . reverse
data Direction = Forward | Backward
fixOddLongBeats :: Direction -> Double -> [TimedData [BBChord]]
-> [TimedData [BBChord]]
fixOddLongBeats dir beatDev song = sil ++ (fixOddLongLine . markStartEnd dir $ cs) where
(sil,cs) = break (not . and . map (isNoneBBChord) . getData) song
avgBt = avgBeatLens . filter (and . map (not . isNoneBBChord) . getData ) $ cs
markStartEnd :: Direction -> [TimedData [BBChord]] -> [TimedData [BBChord]]
markStartEnd _ [] = []
markStartEnd Forward (fc : rst) = fmap markStart fc : rst
markStartEnd Backward (fc : rst) = fmap markEnd fc : rst
markStart, markEnd :: [BBChord] -> [BBChord]
markStart [] = []
markStart (h:t) = addStart (Anno Chords) h : t
markEnd [] = []
markEnd l = let (lst : rst) = reverse l
in reverse (addEnd (Anno Chords) lst : rst)
fixOddLongLine :: [TimedData [BBChord]] -> [TimedData [BBChord]]
fixOddLongLine (l : n : ls ) =
case (avgBeatLen l >= ((1 + beatDev) * avgBt), dir) of
(True, Forward ) -> fmap (replicateNone (avgBeatLen n) l ++) l : n : ls
(True, Backward) -> fmap (++ replicateNone (avgBeatLen n) l) l : n : ls
(False, _ ) -> l : n : ls
fixOddLongLine l = l
replicateNone :: Double -> TimedData [BBChord] -> [BBChord]
replicateNone prvBeat d =
let nrN = (round ((offset d onset d) / prvBeat)) (length . getData $ d)
repN = noneBBChord {weight = Beat}
in addLabel (Anno InterpolationInsert)
(noneBBChord : replicate (pred nrN) repN)
avgBeatLens :: [TimedData [BBChord]] -> Double
avgBeatLens l = (sum . map avgBeatLen $ l) / genericLength l
avgBeatLen :: TimedData [BBChord] -> Double
avgBeatLen td = (offset td onset td) / genericLength (getData td)
pChordLines :: TimeSig -> Parser [(Double, [BBChord])]
pChordLines ts = do p <- pLine ts
r <- case p of
(Left t ) -> concatLines t
(Right (Metre newTs)) -> pChordLines newTs
(Right _ ) -> pChordLines ts
return r where
concatLines :: (Double, [BBChord]) -> Parser [(Double, [BBChord])]
concatLines t = case isEnd . head . snd $ t of
True -> (t :) <$> pure []
False -> (t :) <$> pChordLines ts
pLine :: TimeSig -> Parser (Either (Double, [BBChord]) Meta)
pLine ts = (pChordLine ts <|> pSilenceLine <|> pMetaChange) <* pLineEnd
pSilenceLine :: Parser (Either (Double, [BBChord]) Meta)
pSilenceLine = f <$> pDoubleRaw <* pSym '\t' <*> (pZSilence <|> pSongEnd)
where f a b = Left (a,[b])
pChordLine :: TimeSig -> Parser (Either (Double, [BBChord]) Meta)
pChordLine ts = Left <$> (setAnnotations <$> pDoubleRaw <* pSym '\t'
<*> pStructStart
<*> pChordSeq ts
<*> pEndAnnotations)
setAnnotations :: Double -> [Annotation] -> [BBChord] -> [Annotation]
-> (Double, [BBChord])
setAnnotations d _ [ ] _ = (d, [])
setAnnotations d srt chords end =
(d, updateLast (addAnnotation end'') (addAnnotation srt' c : cs))
where
(srt', end') = first (++ srt) (partition isStart end)
(c : cs, end'') = case partition isRepeat end' of
([r], nr) -> (concat $ replicate (getRepeats r) chords, nr)
([ ], _ ) -> (chords, end')
_ -> error "Billboard.Billboardparser: multiple repeats found!"
addAnnotation :: [Annotation] -> BBChord -> BBChord
addAnnotation ans crd = crd {annotations = ans}
updateLast :: (a -> a) -> [a] -> [a]
updateLast _ [ ] = []
updateLast f [x] = [f x]
updateLast f (x:xs) = x : updateLast f xs
pZSilence :: Parser BBChord
pZSilence = endChord <$>
((pString "Z" <* pPrimes) *> pMaybe (pString ", " *> pSilence)
<|> Just <$> pSilence) where
endChord :: Maybe Label -> BBChord
endChord = maybe noneC ((flip addStartEnd) noneC)
noneC = addStart (Struct 'Z' 0) noneBBChord
pSilence :: Parser Label
pSilence = Anno <$> (Silence <$ pString "silence"
<|> Noise <$ pString "noise"
<|> Applause <$ pString "applause"
<|> TalkingEnd <$ pString "talking"
<|> Fadeout <$ pString "fadeout"
<|> PreIntro <$ pString "pre" <* pMabSpcDsh
<* pString "intro")
pSongEnd :: Parser BBChord
pSongEnd = (flip addEnd) noneBBChord <$> ((Anno SongEnd) <$ pString "end")
pChordSeq :: TimeSig -> Parser [BBChord]
pChordSeq ts = setWeight . concat <$> (pSym '|'
*> pList1Sep_ng (pString "|") (pBar ts)
<* pSym '|') where
setWeight :: [BBChord] -> [BBChord]
setWeight [] = []
setWeight (h:t) = h {weight = LineStart} : t
pBar :: TimeSig -> Parser [BBChord]
pBar ts = markBarStart <$> (updateRep <$> (pSym ' '
*> (pParens pTimeSig `opt` ts))
<*> pBarChords)
pBarChords :: Parser [BBChord]
pBarChords = pList1Sep_ng (pSym ' ') (pBBChord <|> pRepChord) <* pSym ' '
markBarStart :: [BBChord] -> [BBChord]
markBarStart [] = []
markBarStart (h:t) = h {weight = Bar} : t
updateRep :: TimeSig -> [BBChord] -> [BBChord]
updateRep _ [ ] = error "updateRep: no chords to update"
updateRep ts [c] = replChord (tatumsPerBar ts) c
updateRep ts [c1, c2] = let t = (tatumsPerBar ts) `div` 2
in replChord t c1 ++ replChord t c2
updateRep ts cs = update cs
where update :: [BBChord] -> [BBChord]
update [ ] = [ ]
update [x] = replChord (chordsPerDot ts) x
update (x:y:xs) = case weight y of
Beat -> replChord (chordsPerDot ts) x ++ update (y {chord = chord x}: xs)
Change -> replChord (chordsPerDot ts) x ++ update (y : xs)
_ -> error "update: unexpected beat weight"
replChord :: Int -> BBChord -> [BBChord]
replChord d c = c : replicate (pred d) c {weight = Beat}
pRepChord :: Parser BBChord
pRepChord = noneBBChord {weight = Beat} <$ pSym '.'
pBBChord :: Parser BBChord
pBBChord = BBChord [] Change <$> pChord
pMabSpc:: Parser (Maybe Char)
pMabSpc = pMaybe (pSym ' ')
pMabSpcDsh :: Parser (Maybe Char)
pMabSpcDsh = pMaybe (pSym ' ' <|> pSym '-')
pOptWrapPar :: String -> Parser String
pOptWrapPar s = pSym '(' *> pString s <* pSym ')' <|> pString s
pReadableStr :: Parser String
pReadableStr = pList1 pReadableSym
pReadableSym :: Parser Char
pReadableSym = pRange (' ', ')') <|> pRange(',',';') <|> pRange ('?', 'z')
pLineEnd :: Parser Char
pLineEnd = pMany (pSym ' ') *> (pSym '\n' <|> pSym '\r')
tuple :: a -> b -> (a,b)
tuple a b = (a,b)
list :: a -> [a]
list a = [a]