billboard-parser (empty) → 1.0.0.0
raw patch · 9 files changed
+1666/−0 lines, 9 filesdep +HUnitdep +HarmTrace-Basedep +ListLikesetup-changed
Dependencies added: HUnit, HarmTrace-Base, ListLike, base, directory, filepath, mtl, parseargs, uu-parsinglib
Files
- Billboard/Annotation.hs +142/−0
- Billboard/BeatBar.hs +91/−0
- Billboard/BillboardData.hs +345/−0
- Billboard/BillboardParser.hs +586/−0
- Billboard/IOUtils.hs +54/−0
- LICENSE +165/−0
- Setup.hs +2/−0
- billboard-parser.cabal +58/−0
- main.hs +223/−0
+ Billboard/Annotation.hs view
@@ -0,0 +1,142 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Billboard.BillboardParser +-- Copyright : (c) 2012--2013 Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <bash@cs.uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Billboard files can contain a variety of annoatations. This module +-- aims at representing these as Haskell types +-------------------------------------------------------------------------------- + +module Billboard.Annotation ( -- * Types for storing annotations encountered in the Billboard dataset + Annotation (..) + , Label (..) + , Instrument (..) + , Description (..) + -- * Utilities + -- ** Tests + , isStruct + , isStart + , isUnknown + , isRepeat + , isEndAnno + , isFirstChord + , isLastChord + -- ** Data access + , getRepeats + , getLabel + ) where + +import HarmTrace.Base.MusicRep (Root) + +-- | an 'Annotation' occurs either at the start or at the end of a chord +-- sequence line. +data Annotation = Start Label | End Label deriving Eq + +instance Show Annotation where + show (Start l) = '<' : show l + show (End l) = show l ++ ">" + +-- | All annotations contain information we term 'Label' +data Label = Struct Char Int -- ^ denoting A .. Z and the nr of primes (') + | Instr Instrument + | Anno Description + | Modulation Root + deriving Eq + +instance Show Label where + show (Instr lab) = show lab + show (Anno lab) = show lab + show (Modulation lab) = show lab + show (Struct c i) = c : replicate i '\'' + +-- | Representing musical instruments +data Instrument = Guitar | Voice | Violin | Banjo | Synthesizer | Saxophone + | Flute | Drums | Trumpet | Piano | Harmonica | Organ + | Keyboard | Trombone | Electricsitar | Pennywhistle + | Tenorsaxophone | Whistle | Oboe | Tambura | Horns | Clarinet + | Electricguitar | Tenorhorn | Percussion | Rhythmguitar + | Hammondorgan | Harpsichord | Cello | Acousticguitar + | Bassguitar | Strings | SteelDrum | Vibraphone | Bongos + | Steelguitar | Horn | Sitar | Barisaxophone | Accordion + | Tambourine | Kazoo + | UnknownInstr String -- ^ a catch all description for + -- unrecognised instruments + deriving (Show, Eq) + +-- | Representing typical structural segementation labels +data Description = Chorus | Intro | Outro | Bridge | Interlude | Solo + | Fadeout | Fadein | Prechorus | Maintheme | Keychange + | Secondarytheme | Ending | PhraseTrans | Instrumental + | Coda | Transition | PreVerse | Vocal | Talking + | TalkingEnd | Silence | Applause | Noise | SongEnd + | ModulationSeg | PreIntro | Chords + | Repeat Int + | Verse (Maybe Int) + -- | a chord inserted by the posprocessing interpolation + | InterpolationInsert + -- | a catch all description for unrecognised descriptions + | UnknownAnno String + + deriving (Show, Eq) + + +-------------------------------------------------------------------------------- +-- Boundary Utilities +-------------------------------------------------------------------------------- + +-- | Returns the 'Label' of an 'Annotation' +getLabel :: Annotation -> Label +getLabel (Start l) = l +getLabel (End l) = l + +-- | Returns True if the 'Annotation' occurs at the start of a line +isStart :: Annotation -> Bool +isStart (Start _) = True +isStart (End _) = False + +-- | Returns True if the 'Annotation' annotates a structural segmentation label +isStruct :: Label -> Bool +isStruct (Struct _ _) = True +isStruct _ = False + +-- | Returns True if the 'Annotation' +isUnknown :: Annotation -> Bool +isUnknown s = case (getLabel s) of + (Instr (UnknownInstr _ )) -> True + (Anno (UnknownAnno _ )) -> True + _ -> False + +-- | Returns True if the 'Annotation' represents the end of a piece. +isEndAnno :: Annotation -> Bool +isEndAnno (End (Anno SongEnd)) = True +isEndAnno _ = False + +-- | Returns True if the 'Annotation' represents a repeat. +isRepeat :: Annotation -> Bool +isRepeat (End (Anno (Repeat _))) = True +isRepeat _ = False + +-- | Returns True if the 'Annotation' marks the start of a chord sequence +isFirstChord :: Annotation -> Bool +isFirstChord (Start (Anno Chords)) = True +isFirstChord _ = False + +-- | Returns True if the 'Annotation' marks the end of a chord sequence +isLastChord :: Annotation -> Bool +isLastChord (End (Anno Chords)) = True +isLastChord _ = False + +-- | Returns the number of repeats represented by this 'Annotation'. If the +-- 'Annotation' describes something completely different (say 'Electricsitar') +-- it will return 1. +getRepeats :: Annotation -> Int +getRepeats (End (Anno (Repeat r))) = r +getRepeats _ = 1 + +
+ Billboard/BeatBar.hs view
@@ -0,0 +1,91 @@+-------------------------------------------------------------------------------- +-- | +-- Module : Billboard.BillboardParser +-- Copyright : (c) 2012--2013 Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <bash@cs.uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Modelling musical time (in a minimalistic way) with beats, bars +-- and time signatures. +-------------------------------------------------------------------------------- + +module Billboard.BeatBar ( TimeSig (..) + , BeatWeight (..) + , beatWeight + , tatumsPerBar + , chordsPerDot ) where + +-------------------------------------------------------------------------------- +-- Modelling Beat and Bar structures (for chord sequences) +-------------------------------------------------------------------------------- + +-- TODO explain Change: perhaps this should be separated +-- | Barlines can have different weights. Among other applications, this is used +-- in the printing of chord sequences. +data BeatWeight = UnAligned | Beat | Change | Bar | Bar4 | Bar8 + | Bar16 | LineStart + deriving (Eq, Ord, Enum) + +instance Show BeatWeight where + show UnAligned = "" + show Change = "" + show Beat = "." + show Bar = "|" + show Bar4 = "|\n|" + show Bar8 = "|\n|" + show Bar16 = "|\n|" + show LineStart = "|\n|" + +-- | Model a time signature as a fraction +newtype TimeSig = TimeSig {timeSig :: (Int, Int)} deriving (Eq) + +instance Show TimeSig where + show (TimeSig (num, denom)) = show num ++ '/' : show denom + +-- | Defines the "metrical weight of a bar". A regular beat has strength 0, +-- a bar has strength 1, a bar after 4 bars 2, a bar after 8 bars 3, and a bar +-- after 16 bars 4. +beatWeight :: TimeSig -> Int -> BeatWeight +beatWeight ts pos = let tatum = tatumsPerBar ts in + case (mod pos tatum, mod pos (4*tatum), mod pos (8*tatum), mod pos (16*tatum)) of + (0,0,0,0) -> Bar16 -- a bar @ sixteen measures, weight 4 + (0,0,0,_) -> Bar8 -- a bar @ eight measures + (0,0,_,_) -> Bar4 -- a bar @ four measures + (0,_,_,_) -> Bar -- a bar position + _ -> Beat -- a regular beat position, weight 0 + + + +-- | Returns the number of 'tatums' in a bar which is different for time +-- signatures. For example: +-- +-- >>> tatumsPerBar (TimeSig (3 ,4)) +-- 6 +-- +-- >>> tatumsPerBar (TimeSig (6 ,8)) +-- 6 +-- +-- >>> tatumsPerBar (TimeSig (12,8)) +-- 12 +-- +-- N.B. This function is not strictly correct music-theoretically, but +-- it reflects how Billboard annotators used time signatures. +tatumsPerBar :: TimeSig -> Int +tatumsPerBar (TimeSig (beats , 4)) = 2 * beats +tatumsPerBar (TimeSig (beats , 8)) = beats +tatumsPerBar ts = irregularMeterError ts "illegal denominator" + +-- | Returns the number of 'BBChord' that are inserted for one ".", based on +-- a 'TimeSig'nature. +chordsPerDot :: TimeSig -> Int +chordsPerDot (TimeSig (_ , 4)) = 2 +chordsPerDot (TimeSig (_ , 8)) = 3 +chordsPerDot ts = irregularMeterError ts "illegal denominator" + +irregularMeterError :: TimeSig -> String -> a +irregularMeterError ts msg = error ("Irregular meter: " ++ show ts ++ ' ' : msg) + +
+ Billboard/BillboardData.hs view
@@ -0,0 +1,345 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Billboard.BillboardData +-- Copyright : (c) 2012--2013 Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <bash@cs.uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A set of datatypes for representing Billboard chord sequence data +-- See: John Ashley Burgoyne, Jonathan Wild, Ichiro Fujinaga, +-- /An Expert Ground-Truth Set for Audio Chord Recognition and Music Analysis/, +-- In: Proceedings of International Conference on Music Information Retrieval, +-- 2011. (<http://ismir2011.ismir.net/papers/OS8-1.pdf>) +-------------------------------------------------------------------------------- + +module Billboard.BillboardData ( -- * The BillBoard data representation + BillboardData (..) + , Meta (..) + , BBChord (..) + , Artist + , Title + , noneBBChord + -- * Billboard data utilities + -- ** Data access + , getBBChords + , getBBChordsNoSilence + , addStart + , addEnd + , addLabel + , addStartEnd + , getDuration + , getStructAnn + , setChordIxsT + -- ** Tests + , isStructSegStart + , isNoneBBChord + , isChange + , hasAnnotations + , isEnd + -- ** Chord reduction + , reduceBBChords + , expandBBChords + , reduceTimedBBChords + , expandTimedBBChords + -- * Showing + , showInMIREXFormat + , showFullChord + ) where + +-- HarmTrace stuff +import HarmTrace.Base.MusicRep hiding (isNone) +import HarmTrace.Base.MusicTime (TimedData (..), timedDataBT, getData + , onset, offset, concatTimedData) + +import Billboard.BeatBar +import Billboard.Annotation ( Annotation (..), isStart, isStruct + , getLabel, Label, isEndAnno + , isFirstChord, isLastChord) + +import Data.List (partition) + +-- | The 'BillboardData' datatype stores all information that has been extracted +-- from a Billboard chord annotation +data BillboardData = BillboardData { getTitle :: Title + , getArtist :: Artist + , getTimeSig :: TimeSig + , getKeyRoot :: Root + , getSong :: [TimedData BBChord] + } deriving Show + +-- | Represents the artists of the piece +type Artist = String +-- | Represents the title of the piece +type Title = String +-- | Represents other metadata of the piece, i.e. the time signature +-- and key root +data Meta = Metre TimeSig + | KeyRoot Root deriving Show + + +-- | We wrap the 'HarmTrace.Base.MusicRep.Chord' datatype into a 'BBChord' type, +-- so that we can augment it with 'Annotation's and 'BeatWeight's. +data BBChord = BBChord { annotations :: [Annotation] + , weight :: BeatWeight + , chord :: Chord Root + } + +instance Show BBChord where + show (BBChord [] Beat _c) = show Beat + show (BBChord bd Beat _c) = show Beat ++ show bd + show (BBChord [] w c) = show w ++ ' ' : show c -- ++ (show $ duration c) + show (BBChord bd w c) = + let (srt, end) = partition isStart bd + in show w ++ concatMap show srt ++ ' ' : show c ++ ' ' : concatMap show end + +instance Ord BBChord where + compare (BBChord _ _ a) (BBChord _ _ b) + | rt == EQ = compare (toTriad a) (toTriad b) -- N.B.toTriad can be expensive + | otherwise = rt where + rt = compare (chordRoot a) (chordRoot b) + +-- TODO replace by derived EQ, use a specific EQ where needed. +instance Eq BBChord where + (BBChord _ _ a) == (BBChord _ _ b) = chordRoot a == chordRoot b && + toTriad a == toTriad b + + +-------------------------------------------------------------------------------- +-- Some BBChord Utilities +-------------------------------------------------------------------------------- +-- | A chord label with no root, shorthand or other information to represent +-- a none harmonic sections +noneBBChord :: BBChord +noneBBChord = BBChord [] Change noneLabel {duration =1} + +-- | Returns True if the 'BBChord' represents a starting point of a structural +-- segment +isStructSegStart :: BBChord -> Bool-- look for segTypes that are Start and Struct +isStructSegStart = not . null . filter isStruct . map getLabel + . filter isStart . annotations + +-- | Returns True if the 'BBChord' represents a chord Change (must be set +-- beforehand, only the 'BeatWeight' stored in the 'BBChord' is examined) +isChange :: BBChord -> Bool +isChange c = case weight c of + Change -> True + UnAligned -> error "BBChord.isChange: the BBChord is not beat aligned" + _ -> False + +-- | Returns True if the 'BBChord' is a 'noneBBChord', i.e. has not root note +-- and no shorthand +isNoneBBChord :: BBChord -> Bool +isNoneBBChord = isNoneChord . chord + +-- | Returns True if this 'BBChord' is the last (N) chord of the song +isEnd :: BBChord -> Bool +isEnd c = isNoneBBChord c && hasAnnotation isEndAnno c + +-- | Returns True if the 'BBChord' has any 'Annotations's and False otherwise +hasAnnotations :: BBChord -> Bool +hasAnnotations = not . null . annotations + +-- | Takes an 'Annotation' predicate and checks if it holds for a 'BBChord' +hasAnnotation :: (Annotation -> Bool) -> BBChord -> Bool +hasAnnotation f c = case annotations c of + [] -> False + a -> or . map f $ a + +-- | Adds a starting point of an 'Annotation' 'Label' to a 'BBChord' +addStart :: Label -> BBChord -> BBChord +addStart lab chrd = chrd { annotations = Start lab : annotations chrd } + +-- | Adds an end point of an 'Annotation' 'Label' to a 'BBChord' +addEnd :: Label -> BBChord -> BBChord +addEnd lab chrd = chrd { annotations = End lab : annotations chrd } + +-- | Adds both a start and an end 'Annotation' 'Label' to a 'BBChord' +addStartEnd :: Label -> BBChord -> BBChord +addStartEnd lab c = c { annotations = Start lab : End lab : annotations c } + +-- | Annotates a sequence of 'BBChord's by adding a Start 'Label' 'Annotation' +-- at the first chord and an End 'Label' 'Annotation' at the last chord. The +-- remainder of the list remains untouched +addLabel :: Label -> [BBChord] -> [BBChord] +addLabel _ [ ] = [ ] +addLabel lab [c] = [addStart lab . addEnd lab $ c] +addLabel lab (c:cs) = addStart lab c : foldr step [] cs where + step :: BBChord -> [BBChord] -> [BBChord] + step x [] = [addEnd lab x] -- add a label to the last element of the list + step x xs = x : xs + +-- | Sets the indexes of a list of 'TimedData' 'BBChord's (starting at 0) +setChordIxsT :: [TimedData BBChord] -> [TimedData BBChord] +setChordIxsT cs = zipWith (fmap . flip setChordIx) [0..] cs + +-- | Sets the indexes of a list of 'BBChords' (starting at 0) +setChordIxs :: [BBChord] -> [BBChord] +setChordIxs cs = zipWith setChordIx cs [0..] + +-- sets the index of a 'BBChord' (should not be exported) +setChordIx :: BBChord -> Int -> BBChord +setChordIx rc i = let x = chord rc in rc {chord = x {getLoc = i} } + +-- | Returns the duration of the chord (the unit of the duration can be +-- application dependent, but will generally be measured in eighth notes) +-- If the data comes directly from the parser the duration will be 1 for +-- all 'BBChord's. However, if it has been \reduced\ with 'reduceBBChords' +-- the duration will be the number of consecutive tatum units. +getDuration :: BBChord -> Int +getDuration = duration . chord + +-- sets the duration of an 'BBChord' +setDuration :: BBChord -> Int -> BBChord +setDuration c i = let x = chord c in c { chord = x { duration = i } } + +-- | Strips the time stamps from BillBoardData and concatenates all 'BBChords' +getBBChords :: BillboardData -> [BBChord] +getBBChords = map getData . getSong + +-- | Strips the time stamps from BillBoardData and concatenates all 'BBChords' +-- and removes the silence at the beginning and end of the song. +getBBChordsNoSilence :: BillboardData -> [BBChord] +getBBChordsNoSilence = removeSilence . getBBChords where + + -- Removes the Silence, Applause, and other non-harmonic None chords at the + -- beginning and end of a piece + removeSilence :: [BBChord] -> [BBChord] + removeSilence = takeIncl (not . hasAnnotation isLastChord ) . + dropWhile (not . hasAnnotation isFirstChord) + + -- Does exactly the same as 'takeWhile' but includes the element for which + -- the predicate holds. For example takeIncl (< 3) [1..5] = [1, 2, 3] + takeIncl :: (a -> Bool) -> [a] -> [a] + takeIncl _ [] = [ ] + takeIncl p (x:xs) + | p x = x : takeIncl p xs + | otherwise = [x] + +-- | Returns the structural segmentation 'Annotation's, +-- given a 'BBChord' +getStructAnn :: BBChord -> [Annotation] +getStructAnn = filter ( isStruct . getLabel ) . annotations + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Given a list of 'BBChord's that have a certain duration (i.e. the number of +-- beats that the chord should sound), every 'BBChord' is replaced by /x/ +-- 'BBChord's with the same properties, but whit a duration of 1 beat, where /x/ +-- is the duration of the original 'BBChord' +expandBBChords :: [BBChord] -> [BBChord] +expandBBChords = setChordIxs . concatMap replic where + replic c = let x = setDuration c 1 + in x : replicate (pred . duration $ chord c) + x { weight = Beat, annotations = []} + +-- | The inverse function of 'expandChordDur': given a list of 'BBChords' that +-- all have a duration of 1 beat, all subsequent /x/ 'BBChords' with the same +-- label are grouped into one 'BBChord' with durations /x/. N.B. +-- +-- >>> expandBBChords (reduceBBChords cs) = cs +-- +-- also, +-- +-- >>> (expandBBChords cs) = cs +-- +-- and, +-- +-- >>> reduceBBChords (reduceBBChords cs) = (reduceBBChords cs) +-- +-- hold. This has been tested on the first tranch of 649 Billboard songs +reduceBBChords :: [BBChord] -> [BBChord] +reduceBBChords = setChordIxs . foldr group [] where + + group :: BBChord -> [BBChord] -> [BBChord] + group c [] = [c] + group c (h:t) + | c `bbChordEq` h = setDuration c (succ . duration $ chord h): t + | otherwise = c : h : t + + +-- | Returns the reduced chord sequences, where repeated chords are merged +-- into one 'BBChord', similar to 'reduceBBChords', but then wrapped in a +-- 'TimedData' type. +reduceTimedBBChords :: [TimedData BBChord] -> [TimedData BBChord] +reduceTimedBBChords = setChordIxsT . foldr groupT [] where + + groupT :: TimedData BBChord -> [TimedData BBChord] -> [TimedData BBChord] + groupT c [] = [c] + groupT tc@(TimedData c _ ) (th@(TimedData h _ ) : t) + | c `bbChordEq` h = concatTimedData + (setDuration c (succ . duration $ chord h)) tc th : t + | otherwise = tc : th : t + +-- | Similar to 'expandBBChords' the inverse of 'reduceTimedBBChords' +expandTimedBBChords :: [TimedData BBChord] -> [TimedData BBChord] +expandTimedBBChords = setChordIxsT . concatMap replic where + + replic :: TimedData BBChord -> [TimedData BBChord] + replic (TimedData c ts) = + let x = setDuration c 1 + in zipWith3 timedDataBT + (x : repeat x { weight = Beat, annotations = []}) ts (tail ts) + + +-- keep groupBBChord and expandChordDur "inverseable" we use a more strict +-- 'BBChord' equallity +bbChordEq :: BBChord -> BBChord -> Bool +bbChordEq (BBChord anA btA cA) (BBChord anB btB cB) = + chordRoot cA == chordRoot cB && + chordShorthand cA == chordShorthand cB && + chordAdditions cA == chordAdditions cB && + anA `annEq` anB && + btA `beatEq` btB where + + annEq :: [Annotation] -> [Annotation] -> Bool + annEq [] [] = True + annEq _ [] = True + annEq a b = a == b + + beatEq :: BeatWeight -> BeatWeight -> Bool + beatEq LineStart Beat = True + beatEq Bar Beat = True + beatEq Change Beat = True + beatEq Bar Bar = False + beatEq Change Change = False + beatEq LineStart LineStart = False + beatEq a b = a == b + +-------------------------------------------------------------------------------- +-- Printing chord sequences +-------------------------------------------------------------------------------- + +-- | Shows the chord sequence in the 'BillboardData' +showFullChord :: ([TimedData BBChord] -> [TimedData BBChord]) + -> BillboardData -> String +showFullChord redf = concatMap (showLine (show . chord)) . redf . getSong + +-- | Shows the 'BillboardData' in MIREX format, using only :maj, :min, :aug, +-- :dim, sus2, sus4, and ignoring all chord additions +showInMIREXFormat :: ([TimedData BBChord] -> [TimedData BBChord]) + -> BillboardData -> String +showInMIREXFormat redf = concatMap (showLine mirexBBChord) . redf . getSong + +-- | Shows a 'TimedData' 'BBChord' in MIREX triadic format, using only :maj, +-- :min, :aug, :dim, sus2, sus4, and ignoring all chord additions +showLine :: (BBChord -> String) -> TimedData BBChord -> String +showLine shwf c = show (onset c) ++ '\t' : show (offset c) + ++ '\t' : (shwf . getData $ c) ++ "\n" + +-- Categorises a chord as Major or Minor and shows it in Harte et al. syntax +mirexBBChord :: BBChord -> String +mirexBBChord bbc = let x = chord bbc + in case (chordRoot x, chordShorthand x) of + ((Note _ N), None ) -> "N" + ((Note _ X), _ ) -> "X" + (r , Sus2 ) -> show r ++ ":sus2" + (r , Sus4 ) -> show r ++ ":sus4" + (r , _ ) -> case toTriad x of + NoTriad -> "X" + t -> show r ++':' : show t
+ Billboard/BillboardParser.hs view
@@ -0,0 +1,586 @@+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Billboard.BillboardParser +-- Copyright : (c) 2012--2013 Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <bash@cs.uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A set of combinator parsers that parse Billboard data. See: +-- John Ashley Burgoyne, Jonathan Wild, Ichiro Fujinaga, +-- /An Expert Ground-Truth Set for Audio Chord Recognition and Music Analysis/, +-- In: Proceedings of International Conference on Music Information Retrieval, +-- 2011. (<http://ismir2011.ismir.net/papers/OS8-1.pdf>) +-------------------------------------------------------------------------------- + +module Billboard.BillboardParser ( pBillboard + , parseBillboard + , acceptableBeatDeviationMultiplier ) where + +import Data.List (genericLength, partition) +import Control.Arrow (first) +-- import Control.Monad.State +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) + +-------------------------------------------------------------------------------- +-- Constants +-------------------------------------------------------------------------------- + +-- | A parameter that sets the acceptable beat deviation multiplier, which +-- controls when exceptionally long beat lengths will be interpolated. +acceptableBeatDeviationMultiplier :: Double +acceptableBeatDeviationMultiplier = 0.075 + +-------------------------------------------------------------------------------- +-- Top level Billboard parsers +-------------------------------------------------------------------------------- + +-- | Toplevel function for parsing Billboard data files. The function returns +-- a tuple containing the result of the parsing in a 'BillboardData' type and +-- a (possibly empty) list of parsing errors. +parseBillboard :: String -> (BillboardData, [Error LineColPos]) +parseBillboard = parseDataWithErrors pBillboard + +-- | The top-level parser for parsing the billboard data (see 'parseBillboard'). +pBillboard :: Parser BillboardData +pBillboard = do (a, t, ts, r) <- pHeader + c <- pChordLinesPost ts + -- before we return the chords we store the index of the + -- chord in the 'BBChord' type (setChordIxsT) + return (BillboardData a t ts r (setChordIxsT c)) where + + +-------------------------------------------------------------------------------- +-- parsing meta data in the headers +-------------------------------------------------------------------------------- + +-- parsing meta data on the title, artist, metre and the tonic of the piece +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 ) + +-- parses a time signature +pTimeSig :: Parser TimeSig +pTimeSig = TimeSig <$> (tuple <$> pIntegerRaw <*> (pSym '/' *> pIntegerRaw)) + +-------------------------------------------------------------------------------- +-- parsing the additional annotations +-------------------------------------------------------------------------------- + +pStructStart :: Parser [Annotation] +pStructStart = pList (pStrucLab <|> pStrucDescStart) + +-- structural annotations, e.g. A, B, C, etc.. +pStrucLab :: Parser Annotation +pStrucLab = Start <$> (Struct <$> pUpper <*> pPrimes) <* pString ", " + +-- recognises an arbitrary number of primes +pPrimes :: Parser Int +pPrimes = length <$> pMany (pSym '\'') + +-- parses structural descriptions (strings before a ',' ) before the +-- chord sequences +pStrucDescStart :: Parser Annotation +pStrucDescStart = (Start . Anno) <$> pAnno <* pString ", " + +-- parses a known or an unknown annotation +pAnno :: Parser Description +pAnno = pAnnotation <<|> pUnknownAnno + +-- the annotations known to this parser +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 + +-- parses after the chords sequence description +pEndAnnotations :: Parser [Annotation] +pEndAnnotations = (++) <$> pRepeat <*> ((++) <$> pPhrase <*> pEndAnno) + +pEndAnno :: Parser [Annotation] +pEndAnno = concat <$> pList (pString ", " *> + (pPhrase <|> pLeadInstr <|> pStrucDescEnd)) +-- parses phrase annotations +pPhrase :: Parser [Annotation] +pPhrase = (list . End . Anno $ PhraseTrans) <$ pString " ->" `opt` [] + +-- parses a repeating phrase +pRepeat :: Parser [Annotation] +pRepeat = (list . End . Anno . Repeat) <$> (pString " x" *> pIntegerRaw) `opt` [] + +-- parses structural descriptions (strings after a ',' ) after a chord sequences +pStrucDescEnd :: Parser [Annotation] +pStrucDescEnd = (list . End . Anno) <$> pAnno + +-- parses a three different kind of lead insturment descriptions: +-- a start, an end, and a start and ending boundary +pLeadInstr :: Parser [Annotation] +pLeadInstr = pLeadInstrStart <|> pLeadInstrEnd <|> pLeadInstrStartEnd + +-- start of a lead instrument description +pLeadInstrStart :: Parser [Annotation] +pLeadInstrStart = (list . Start . Instr) <$> (pSym '(' *> pInstr) + +-- end of a lead instrument description +pLeadInstrEnd :: Parser [Annotation] +pLeadInstrEnd = (list . End . Instr) <$> pInstr <* pSym ')' + +-- start and end of a lead instrument description +pLeadInstrStartEnd :: Parser [Annotation] +pLeadInstrStartEnd = f <$> (pSym '(' *> pInstr <* pSym ')') + where f a = [Start $ Instr a, End $ Instr a] + +pInstr :: Parser Instrument +pInstr = pInstrument <<|> pUnknownInstr + +-- parses the different kind of lead instruments +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 + +-- a parser that recognises either a metre change or a modulation +pMetaChange :: Parser (Either (Double, [BBChord]) Meta) +pMetaChange = pModulation <|> pMetreChange + +-- recongises a modulation and returns the new tonic +pModulation :: Parser (Either (Double, [BBChord]) Meta) +pModulation = Right <$> (pMetaPrefix *> pKeyRoot) + +-- recongises a metre change and returns the new time signature +pMetreChange :: Parser (Either (Double, [BBChord]) Meta) +pMetreChange = Right <$> (pMetaPrefix *> pMetre) + +-------------------------------------------------------------------------------- +-- Post-processing the chord sequence data +-------------------------------------------------------------------------------- + +-- Top-level parser for parsing chords sequence lines an annotations +pChordLinesPost :: TimeSig -> Parser [TimedData BBChord] +pChordLinesPost ts = (interp . setTiming) <$> pChordLines ts + +-- labels every line with the corresponding starting and ending times (where +-- the end time is actually the start time of the next chord line) +setTiming :: [(Double, a)] -> [TimedData a] +setTiming [ ] = [] +setTiming [_] = [] -- remove the end +setTiming (a : b : cs) = TimedData (snd a) [Time (fst a), Time (fst b)] + : setTiming (b:cs) + +-- interpolates the on- and offset for every 'BBChord' in a timestamped list +-- of 'BBChord's +interp :: [TimedData [BBChord]] -> [TimedData BBChord] +interp = concatMap interpolate . fixBothBeatDev where + + -- splits a 'TimedData [BBChord]' into multiple instances interpolating + -- the off an onsets by evenly dividing the time for every beat. + 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) ..] + +-- The beat deviation occurs both at the beginning and at the end of piece, +-- but the principle of correction is exactly the same (but mirrored). Hence +-- 'fixForward' and 'fixBackward' both rely on 'fixOddLongBeats' +fixForward, fixBackward, fixBothBeatDev :: [TimedData [BBChord]] + -> [TimedData [BBChord]] +fixBothBeatDev = fixBackward . fixForward +fixForward = fixOddLongBeats Forward + acceptableBeatDeviationMultiplier +fixBackward = reverse . fixOddLongBeats Backward -- = reversed fix Forward + acceptableBeatDeviationMultiplier . reverse + +data Direction = Forward | Backward + +-- We discovered that the 'Billboard.Tests.oddBeatLengthTest' failed at quite +-- some songs. The reason of failure is often caused by the /silence/ +-- timestamps at the beginning and end of a song. Probably, the annotators +-- marked /silence/ when there was really not much to hear any more. +-- This, however, is a problem: apparently there is a discrepancy between the +-- last musical beat of a song and the actual silence that clearly distorts +-- the 'interp'olation of the last line of annotated chords. Hence, we +-- use a different kind of interpolation for this last line of chords. We use +-- the average beat length of the previous line to predict the beat durations +-- of the chords and fill the /gap/ between the last chord and the /silence/ +-- annotation with additional 'N' chords. +fixOddLongBeats :: Direction -> Double -> [TimedData [BBChord]] + -> [TimedData [BBChord]] +fixOddLongBeats dir beatDev song = sil ++ (fixOddLongLine . markStartEnd dir $ cs) where + + -- separate the lines containing silence N chords at the beginning + -- from the lines that contain musical chords + (sil,cs) = break (not . and . map (isNoneBBChord) . getData) song + -- precalculate the average beat length, filtering lines that contain + -- none harmonic data (in the from of N chords) + avgBt = avgBeatLens . filter (and . map (not . isNoneBBChord) . getData ) $ cs + + -- Marks the start and beginning of the chords sequence + markStartEnd :: Direction -> [TimedData [BBChord]] -> [TimedData [BBChord]] + markStartEnd _ [] = [] + markStartEnd Forward (fc : rst) = fmap markStart fc : rst + markStartEnd Backward (fc : rst) = fmap markEnd fc : rst + + -- does the actual marking + 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) + + -- Fixes the distorted interpolation + 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 + + -- fills the "gap" with none chords + replicateNone :: Double -> TimedData [BBChord] -> [BBChord] + replicateNone prvBeat d = + -- calculate the number of beats expected, minus the chords in the list + let nrN = (round ((offset d - onset d) / prvBeat)) - (length . getData $ d) + repN = noneBBChord {weight = Beat} + -- annotate that this is an interpolated N list + in addLabel (Anno InterpolationInsert) + (noneBBChord : replicate (pred nrN) repN) + + -- Calculates the average length of a beat in a list of Timed BBChords + avgBeatLens :: [TimedData [BBChord]] -> Double + avgBeatLens l = (sum . map avgBeatLen $ l) / genericLength l + + -- Calculates the average length of a beat + avgBeatLen :: TimedData [BBChord] -> Double + avgBeatLen td = (offset td - onset td) / genericLength (getData td) + +-------------------------------------------------------------------------------- +-- Chord sequence data parsers +-------------------------------------------------------------------------------- + +-- Parses the /musical part/ of the Billboard data file by recursively parsing +-- the lines of chords, silence, metre changes or modulations +pChordLines :: TimeSig -> Parser [(Double, [BBChord])] +pChordLines ts = do p <- pLine ts -- parse one line + r <- case p of + -- if we parse chords, continue + (Left t ) -> concatLines t + -- if we encounter a new global metre we use this + -- metre for the parsing the following chords + (Right (Metre newTs)) -> pChordLines newTs + -- we ignore modulations for now + (Right _ ) -> pChordLines ts + return r where + + -- concatenates the parsed lines of chords recursively + concatLines :: (Double, [BBChord]) -> Parser [(Double, [BBChord])] + concatLines t = case isEnd . head . snd $ t of + True -> (t :) <$> pure [] -- stop condition + False -> (t :) <$> pChordLines ts -- continue + +-- Parses one line which can be chords, meta information, or end/silence +pLine :: TimeSig -> Parser (Either (Double, [BBChord]) Meta) +pLine ts = (pChordLine ts <|> pSilenceLine <|> pMetaChange) <* pLineEnd + +-- parses a line annotated with "silence" +pSilenceLine :: Parser (Either (Double, [BBChord]) Meta) +pSilenceLine = f <$> pDoubleRaw <* pSym '\t' <*> (pZSilence <|> pSongEnd) + where f a b = Left (a,[b]) + +-- parses a line with annotated chord sequence data +pChordLine :: TimeSig -> Parser (Either (Double, [BBChord]) Meta) +pChordLine ts = Left <$> (setAnnotations <$> pDoubleRaw <* pSym '\t' + <*> pStructStart + <*> pChordSeq ts + <*> pEndAnnotations) + +-- merges the different forms information (annotations, beats, chords, time- +-- stamps) into a timestamped list of 'BBChord's +setAnnotations :: Double -> [Annotation] -> [BBChord] -> [Annotation] + -> (Double, [BBChord]) +setAnnotations d _ [ ] _ = (d, []) -- no chords, just a timestamp +setAnnotations d srt chords end = + (d, updateLast (addAnnotation end'') (addAnnotation srt' c : cs)) + + where -- put the 'starting annotations' at the beginning + (srt', end') = first (++ srt) (partition isStart end) + -- if there exists annotated repeats the chords sequence in 'chords' + -- is repeated, if not 'chords' is returned. + (c : cs, end'') = case partition isRepeat end' of + -- in the case that we find a repetition we return an updated + -- list of annotations (rep'') that does not contain the repetition + -- Afterall, it has been expanded and could only confuse users + ([r], nr) -> (concat $ replicate (getRepeats r) chords, nr) + ([ ], _ ) -> (chords, end') + _ -> error "Billboard.Billboardparser: multiple repeats found!" + + -- replaces the list of annotations in a BBChord + addAnnotation :: [Annotation] -> BBChord -> BBChord + addAnnotation ans crd = crd {annotations = ans} + + -- applies a function to the last element of a list + updateLast :: (a -> a) -> [a] -> [a] + updateLast _ [ ] = [] + updateLast f [x] = [f x] + updateLast f (x:xs) = x : updateLast f xs + +-- Recognises the "Z" character, and several silence annotations. If silence +-- (see pSilence) is explicitly annotated the annotation is also stored in the +-- outputed N chord label. +pZSilence :: Parser BBChord +pZSilence = endChord <$> + ((pString "Z" <* pPrimes) *> pMaybe (pString ", " *> pSilence) + <|> Just <$> pSilence) where + -- if there are silence annotations add them to a N chord + endChord :: Maybe Label -> BBChord + endChord = maybe noneC ((flip addStartEnd) noneC) + + noneC = addStart (Struct 'Z' 0) noneBBChord + + -- recognises a "silence" annotation, no chords are sounding + 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") + +-- parses the end of a song +pSongEnd :: Parser BBChord +pSongEnd = (flip addEnd) noneBBChord <$> ((Anno SongEnd) <$ pString "end") + +-- recognises a chord sequence like: +-- "| Db:maj Gb:maj/5 | Ab:maj Db:maj/5 | Bb:min Bb:min/b7 Gb:maj . | Ab:maj |\" +pChordSeq :: TimeSig -> Parser [BBChord] +pChordSeq ts = setWeight . concat <$> (pSym '|' + *> pList1Sep_ng (pString "|") (pBar ts) + <* pSym '|') where + -- Log the start of a line (which generally marks the start of a phrase) as + -- a "metrical weight", which is used in printing the sequence to the user. + setWeight :: [BBChord] -> [BBChord] + setWeight [] = [] + setWeight (h:t) = h {weight = LineStart} : t + +-- In a bar we can encounter chords and optionally we can also encounter an +-- additional time signature description +pBar :: TimeSig -> Parser [BBChord] +pBar ts = markBarStart <$> (updateRep <$> (pSym ' ' + *> (pParens pTimeSig `opt` ts)) + <*> pBarChords) + +-- parses the chords within one bar +pBarChords :: Parser [BBChord] +pBarChords = pList1Sep_ng (pSym ' ') (pBBChord <|> pRepChord) <* pSym ' ' + +-- marks the start of a bar by setting the beat weight field to 'Bar' +markBarStart :: [BBChord] -> [BBChord] +markBarStart [] = [] +markBarStart (h:t) = h {weight = Bar} : t + +-- within a bar there can be one chord, two chords (representing the sounding +-- chord in the first and second halve of the bar), multiple chords, and +-- repetitions marked with a '.' +updateRep :: TimeSig -> [BBChord] -> [BBChord] +updateRep _ [ ] = error "updateRep: no chords to update" +updateRep ts [c] = replChord (tatumsPerBar ts) c -- one chord +updateRep ts [c1, c2] = let t = (tatumsPerBar ts) `div` 2 -- two chords + in replChord t c1 ++ replChord t c2 +updateRep ts cs = update cs -- multiple chords + -- updates the repetited chords ('.') + where update :: [BBChord] -> [BBChord] + update [ ] = [ ] + update [x] = replChord (chordsPerDot ts) x + update (x:y:xs) = case weight y of + -- Because at parsing time we do not know which chord is repeated + -- by a '.' we replace the chord in the 'BBChord' by the previous + -- chord (at parsing time a None chord is stored in the BBchord) + Beat -> replChord (chordsPerDot ts) x ++ update (y {chord = chord x}: xs) + Change -> replChord (chordsPerDot ts) x ++ update (y : xs) + _ -> error "update: unexpected beat weight" -- cannot happen + +-- replicates an 'BBChord' the first chord will have a 'Change' +-- weigth and the remaining chords will have a 'Beat' weight +replChord :: Int -> BBChord -> [BBChord] +replChord d c = c : replicate (pred d) c {weight = Beat} + +-- parses a chord a repetition symbol '.' +pRepChord :: Parser BBChord +pRepChord = noneBBChord {weight = Beat} <$ pSym '.' + +-- parses a single chord into an 'BBChord' +pBBChord :: Parser BBChord +pBBChord = BBChord [] Change <$> pChord + + +-------------------------------------------------------------------------------- +-- general parsers combinators +-------------------------------------------------------------------------------- + +-- optionally parsers a space ' ' +pMabSpc:: Parser (Maybe Char) +pMabSpc = pMaybe (pSym ' ') + +-- optionally parsers a space ' ' or a dash '-' +pMabSpcDsh :: Parser (Maybe Char) +pMabSpcDsh = pMaybe (pSym ' ' <|> pSym '-') + +pOptWrapPar :: String -> Parser String +pOptWrapPar s = pSym '(' *> pString s <* pSym ')' <|> pString s + +-- accepts any string +pReadableStr :: Parser String +pReadableStr = pList1 pReadableSym + +-- accepts a 'Char' in the range of: +-- !\"#$%&'() +-- ,-./0123456789:; +-- ?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz +pReadableSym :: Parser Char +pReadableSym = pRange (' ', ')') <|> pRange(',',';') <|> pRange ('?', 'z') + +-- parses a line ending +pLineEnd :: Parser Char +pLineEnd = pMany (pSym ' ') *> (pSym '\n' <|> pSym '\r') + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +tuple :: a -> b -> (a,b) +tuple a b = (a,b) + +list :: a -> [a] +list a = [a] +
+ Billboard/IOUtils.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Billboard.IOUtils +-- Copyright : (c) 2012--2013 Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <bash@cs.uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A set Billboard specific file and directory utilities +-------------------------------------------------------------------------------- + +module Billboard.IOUtils (bbdir, getBBFiles, getBBFile) where + +import System.Directory +import System.FilePath +import Text.Printf (printf) +import Control.Monad (filterM) + +-- | Applies a function to all files in a directory +bbdir :: (FilePath -> IO a) -> FilePath -> IO [a] +bbdir f fp = getDirectoryContents fp >>= filterM isBillboardDir + >>= mapM (\d -> f (fp </> d </> "salami_chords.txt")) + +-- | Given the path to the Billboard collection, returns a list with the +-- filepaths and id's of the salami_chords.txt files. (The id is the parent +-- folder name.) +getBBFiles :: FilePath -> IO [(FilePath, Int)] +getBBFiles p = getDirectoryContents p >>= filterM isBillboardDir + >>= mapM (\d -> return (p </> d </> "salami_chords.txt", read d)) + +-- Returns true if the folder name is 4 characters long and a number between +-- 0 and 1000 +isBillboardDir :: String -> IO Bool +isBillboardDir x = case length x of + 4 -> do let n = read x :: Int -- x should be a folder 0 - 1000 + return (n >= 0 && n <= 1000) + _ -> return False + +-- | Given a base directory pointing to the billboard location and a billboard +-- id, this function returns the path to that particular billboard file. If +-- the file does not exist, an error is thrown. +getBBFile :: FilePath -> Int -> IO (FilePath) +getBBFile billboardLoc nr = + do let fp = billboardLoc </> printf "%04d" nr </> "salami_chords.txt" + fpExist <- doesFileExist fp + case fpExist of + True -> return fp + False -> error ("Error: " ++ printf "%04d" nr + ++ " is not a valid billboard id, or the directory " + ++ billboardLoc ++"does not point to the billboard collection" + ++ " Regardless, the file " ++ fp ++ " does not exist" )
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ billboard-parser.cabal view
@@ -0,0 +1,58 @@+name: billboard-parser +version: 1.0.0.0 +synopsis: A parser for the Billboard chord dataset +description: We present a parser for the world famous Billboard dataset + containing the chord transcriptions of over 1000 + professional chord transcriptions of popular music randomly + selected from /Billboard/ magazine's ``Hot 100'' chart + between 1958 and 1991, all time-aligned with audio. + . + See: W. Bas de Haas and John Ashley Burgoyne, + /Parsing the Billboard Chord Transcriptions/, Technical Report + UU-CS-2012-018, Department of Information and Computing + Sciences, Utrecht University, 2012. + (<http://www.cs.uu.nl/research/techreps/repo/CS-2012/2012-018.pdf>) + . + And: John Ashley Burgoyne, Jonathan Wild, Ichiro Fujinaga, + /An Expert Ground-Truth Set for Audio Chord Recognition and Music Analysis/, + In: Proceedings of International + Conference on Music Information Retrieval, 2011. + (<http://ismir2011.ismir.net/papers/OS8-1.pdf>) +homepage: http://ddmal.music.mcgill.ca/billboard +license: LGPL-3 +license-file: LICENSE +author: W. Bas de Haas +maintainer: W. Bas de Haas <bash@cs.uu.nl> +copyright: (c) 2012--2013 Utrecht University +category: Music +build-type: Simple +tested-with: GHC == 7.4.1, GHC == 7.6.1 + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + +library + build-depends: base >=4.5, + directory >=1.1, filepath >=1.3, + uu-parsinglib ==2.7.*, ListLike ==3.1.*, + HUnit ==1.2.*, mtl ==2.1.*, HarmTrace-Base >= 0.9 + + exposed-modules: Billboard.Annotation + Billboard.BeatBar + Billboard.BillboardData + Billboard.BillboardParser + Billboard.IOUtils + + ghc-options: -Wall + -O2 + +executable billboard-parser + main-is: main.hs + + build-depends: base >=4.5 && < 4.7, parseargs ==0.1.*, + directory >=1.1, filepath >=1.3, + uu-parsinglib ==2.7.*, ListLike ==3.1.*, + HUnit ==1.2.*, mtl ==2.1.*, HarmTrace-Base >= 0.9 + + ghc-options: -Wall + -O2
+ main.hs view
@@ -0,0 +1,223 @@+{-# OPTIONS_GHC -Wall #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) 2012 Universiteit Utrecht +-- License : GPL3 +-- +-- Maintainer : W. Bas de Haas <bash@cs.uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: The Commandline interface for parsing Billboard data. See: +-- John Ashley Burgoyne, Jonathan Wild, Ichiro Fujinaga, +-- /An Expert Ground-Truth Set for Audio Chord Recognition and Music Analysis/, +-- In: Proceedings of International Conference on Music Information Retrieval, +-- 2011. (<http://ismir2011.ismir.net/papers/OS8-1.pdf>) +-------------------------------------------------------------------------------- + +module Main (main) where + +import Billboard.BillboardData ( BBChord (..) + , reduceTimedBBChords, BillboardData(..) + , showFullChord, showInMIREXFormat, getTitle) +import Billboard.BillboardParser ( parseBillboard ) +import Billboard.Tests ( mainTestFile, mainTestDir, rangeTest + , oddBeatLengthTest, getOffBeats) +import Billboard.IOUtils + +-- harmtrace imports +import HarmTrace.Base.MusicTime (TimedData (..), dropTimed) + +-- other libraries +import System.Console.ParseArgs +import System.FilePath +import Control.Monad (when, void) +import Text.Printf (printf) +import Data.List (genericLength, intercalate) + +-------------------------------------------------------------------------------- +-- Contants +-------------------------------------------------------------------------------- + +outputFileName :: FilePath +outputFileName = "mirex_chords" <.> "txt" + +-------------------------------------------------------------------------------- +-- Commandline argument parsing +-------------------------------------------------------------------------------- +data ReppatArgs = InputFilepath | InputDirFilepath | InputID | ModeArg | OutDir + | Compression deriving (Eq, Ord, Show) + +myArgs :: [Arg ReppatArgs] +myArgs = [ + Arg { argIndex = ModeArg, + argAbbr = Just 'm', + argName = Just "mode", + argData = argDataRequired "mode" ArgtypeString, + argDesc = "The operation mode (parse|mirex|test|full)" + } + , Arg { argIndex = OutDir, + argAbbr = Just 'o', + argName = Just "out", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Output directory for the mirex files" + } + , Arg { argIndex = InputFilepath, + argAbbr = Just 'f', + argName = Just "file", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Input file containing chord information" + } + , Arg { argIndex = InputDirFilepath, + argAbbr = Just 'd', + argName = Just "dir", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Base directory path to the billboard dataset" + } + , Arg { argIndex = InputID, + argAbbr = Just 'i', + argName = Just "id", + argData = argDataOptional "integer" ArgtypeInt, + argDesc = ( "Input identifier (0-1000). Can only be used\n" + ++ " in combination with " + ++ "a base directory" ) + } + , Arg { argIndex = Compression, + argAbbr = Just 'c', + argName = Just "comp", + argData = argDataOptional "string" ArgtypeString, + argDesc = ( "Use \"exp(and)\" to use eighth note grid output" + ++ "\n and \"red(uce)\" " + ++ "for compressed output" ) + } + ] + +-- representing the mode of operation +data Mode = Mirex | Parse | Test | Full | Result deriving (Eq) + +-- Run from CL +main :: IO () +main = do arg <- parseArgsIO ArgsComplete myArgs + -- check whether we have a usable mode + let mode = case (getRequiredArg arg ModeArg) of + "full" -> Full + "mirex" -> Mirex + "parse" -> Parse + "test" -> Test + "result" -> Result + m -> usageError arg ("unrecognised mode: " ++ m) + -- get filepaths + inFile = getArg arg InputFilepath + inDir = getArg arg InputDirFilepath + bbid = getArg arg InputID + mout = getArg arg OutDir + compf = case getArg arg Compression of + (Just "exp") -> id + (Just "expand") -> id + (Just "red") -> reduceTimedBBChords + (Just "reduce") -> reduceTimedBBChords + _ -> reduceTimedBBChords + + -- the input is either a file (Left) or a directory (Right) + input <- case (inFile, inDir, bbid) of + -- we have two ways of identifying a file: by filename + (Just f , Nothing, Nothing) -> return (Left f) + -- or by basepath and id + (Nothing, Just d , Just i ) -> getBBFile d i + >>= return . Left + (Nothing, Just d , Nothing) -> return (Right d) + _ -> usageError arg "Invalid filepaths" + + -- do the parsing magic + case (mode, input) of + (Full, Left f) -> showFile (showFullChord compf) f + (Full, Right d) -> void $ writeDir (showFullChord compf) mout d + (Mirex, Left f) -> showFile (showInMIREXFormat compf) f + (Mirex, Right d) -> void $ writeDir (showInMIREXFormat compf) mout d + (Parse, Left f) -> parseFile compf f + (Parse, Right d) -> parseDir d + (Test , Left f) -> mainTestFile rangeTest f + (Test , Right d) -> mainTestDir oddBeatLengthTest d + (Result, Left _) -> error "can only run results on a full dataset" + (Result, Right d) -> runResults d + + +-------------------------------------------------------------------------------- +-- Parsing Billboard data verbosely +-------------------------------------------------------------------------------- + +parseFile :: ([TimedData BBChord] -> [TimedData BBChord]) -> FilePath -> IO () +parseFile cf fp = do inp <- readFile fp + let (bbd, err) = parseBillboard inp + printBillboard bbd + mapM_ print err where + + + printBillboard :: BillboardData -> IO() + printBillboard bd = + do putStrLn (getArtist bd ++ ": " ++ getTitle bd) + putStr . concatMap (\x -> ' ' : show x) . dropTimed . cf . getSong $ bd + putStr " |\n\n" + +-- parses a directory of Billboard songs +parseDir :: FilePath -> IO () +parseDir d = void . bbdir oneSliceSalami $ d where + -- parses a billboard file and presents the user with condenced output + -- If parsing errors are encountered, they are printed + oneSliceSalami :: FilePath -> IO ([TimedData BBChord]) + oneSliceSalami f = + do inp <- readFile f + let (bbd, err) = parseBillboard inp + s = getSong bbd + putStrLn (getArtist bbd ++ ": " ++ getTitle bbd) + putStrLn (d </> "salami_chords.txt, beats: " ++ show (length s) + ++ ", errors: " ++ show (length err)) + when (not $ null err) (mapM_ print err) + return s + +-------------------------------------------------------------------------------- +-- Converting the Billboard format to MIREX format +-------------------------------------------------------------------------------- + +-- Reads a file and prints the chords in mirex format +showFile :: (BillboardData -> String) -> FilePath -> IO () +showFile shwf f = readFile f >>= putStrLn . shwf . fst . parseBillboard + +-- Reads a directory an writes a file with the chords, in a format defined +-- by a specific show function, in the folder containing also the original file +writeDir :: (BillboardData -> String) -> Maybe FilePath -> FilePath + -> IO [String] +writeDir shwf mfp d = getBBFiles d >>= mapM toMirex where + + -- read, parses, and writes one mirex chord file + toMirex :: (FilePath, Int) -> IO (String) + toMirex (f,i) = -- (filename, id) + do inp <- readFile f + let (bbd, err) = parseBillboard inp + s = shwf bbd + out = case mfp of + -- place the file next to the input file (but rename) + Nothing -> dropFileName f </> outputFileName + -- place the output file in a specific folder (if set) + Just fp -> fp </> printf "%.4d" i ++ "_audio.lab" + when (not $ null err) (error ("there were errors in file: " ++ f)) + writeFile out s + putStrLn ("written file: " ++ out) + return s + +runResults :: FilePath -> IO () +runResults d = do let ths = [0.05, 0.075, 0.1, 0.15, 0.25] + putStrLn $ intercalate "\t" ("File" : map show ths) + getBBFiles d >>= mapM_ (getResult ths) + where + getResult :: [Double] -> (FilePath, Int) -> IO [Double] + getResult ths (fp, _) = do inp <- readFile fp + >>= return . getSong . fst . parseBillboard + let r = map (offRatio inp) ths + putStrLn $ intercalate "\t" (fp : map show r) + return r + + offRatio :: [TimedData BBChord] -> Double -> Double + offRatio td th = genericLength (getOffBeats th td) / genericLength td +