module Billboard.BillboardData (
BillboardData (..)
, Meta (..)
, BBChord (..)
, Artist
, Title
, noneBBChord
, getBBChords
, getBBChordsNoSilence
, addStart
, addEnd
, addLabel
, addStartEnd
, getDuration
, getStructAnn
, setChordIxsT
, isStructSegStart
, isNoneBBChord
, isChange
, hasAnnotations
, isEnd
, reduceBBChords
, expandBBChords
, reduceTimedBBChords
, expandTimedBBChords
, showInMIREXFormat
, showFullChord
) where
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)
data BillboardData = BillboardData { getTitle :: Title
, getArtist :: Artist
, getTimeSig :: TimeSig
, getKeyRoot :: Root
, getSong :: [TimedData BBChord]
} deriving Show
type Artist = String
type Title = String
data Meta = Metre TimeSig
| KeyRoot Root deriving Show
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 (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)
| otherwise = rt where
rt = compare (chordRoot a) (chordRoot b)
instance Eq BBChord where
(BBChord _ _ a) == (BBChord _ _ b) = chordRoot a == chordRoot b &&
toTriad a == toTriad b
noneBBChord :: BBChord
noneBBChord = BBChord [] Change noneLabel {duration =1}
isStructSegStart :: BBChord -> Bool
isStructSegStart = not . null . filter isStruct . map getLabel
. filter isStart . annotations
isChange :: BBChord -> Bool
isChange c = case weight c of
Change -> True
UnAligned -> error "BBChord.isChange: the BBChord is not beat aligned"
_ -> False
isNoneBBChord :: BBChord -> Bool
isNoneBBChord = isNoneChord . chord
isEnd :: BBChord -> Bool
isEnd c = isNoneBBChord c && hasAnnotation isEndAnno c
hasAnnotations :: BBChord -> Bool
hasAnnotations = not . null . annotations
hasAnnotation :: (Annotation -> Bool) -> BBChord -> Bool
hasAnnotation f c = case annotations c of
[] -> False
a -> or . map f $ a
addStart :: Label -> BBChord -> BBChord
addStart lab chrd = chrd { annotations = Start lab : annotations chrd }
addEnd :: Label -> BBChord -> BBChord
addEnd lab chrd = chrd { annotations = End lab : annotations chrd }
addStartEnd :: Label -> BBChord -> BBChord
addStartEnd lab c = c { annotations = Start lab : End lab : annotations c }
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]
step x xs = x : xs
setChordIxsT :: [TimedData BBChord] -> [TimedData BBChord]
setChordIxsT cs = zipWith (fmap . flip setChordIx) [0..] cs
setChordIxs :: [BBChord] -> [BBChord]
setChordIxs cs = zipWith setChordIx cs [0..]
setChordIx :: BBChord -> Int -> BBChord
setChordIx rc i = let x = chord rc in rc {chord = x {getLoc = i} }
getDuration :: BBChord -> Int
getDuration = duration . chord
setDuration :: BBChord -> Int -> BBChord
setDuration c i = let x = chord c in c { chord = x { duration = i } }
getBBChords :: BillboardData -> [BBChord]
getBBChords = map getData . getSong
getBBChordsNoSilence :: BillboardData -> [BBChord]
getBBChordsNoSilence = removeSilence . getBBChords where
removeSilence :: [BBChord] -> [BBChord]
removeSilence = takeIncl (not . hasAnnotation isLastChord ) .
dropWhile (not . hasAnnotation isFirstChord)
takeIncl :: (a -> Bool) -> [a] -> [a]
takeIncl _ [] = [ ]
takeIncl p (x:xs)
| p x = x : takeIncl p xs
| otherwise = [x]
getStructAnn :: BBChord -> [Annotation]
getStructAnn = filter ( isStruct . getLabel ) . annotations
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 = []}
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
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
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)
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
showFullChord :: ([TimedData BBChord] -> [TimedData BBChord])
-> BillboardData -> String
showFullChord redf = concatMap (showLine (show . chord)) . redf . getSong
showInMIREXFormat :: ([TimedData BBChord] -> [TimedData BBChord])
-> BillboardData -> String
showInMIREXFormat redf = concatMap (showLine mirexBBChord) . redf . getSong
showLine :: (BBChord -> String) -> TimedData BBChord -> String
showLine shwf c = show (onset c) ++ '\t' : show (offset c)
++ '\t' : (shwf . getData $ c) ++ "\n"
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