module HarmTrace.Audio.Annotate ( mptreeAnnotator, groupAnnotator
, simpleAnnotator, mptreeAnnotatorSTG
, putSegStats, preProcessData
) where
import Constants ( maxSegmentSize, maxLProductSize)
import HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync
, mergeByOneAndThree )
import HarmTrace.Audio.Key (getBeatSyncKeyFromChroma)
import HarmTrace.Base.MusicTime
import HarmTrace.Base.MusicRep
import HarmTrace.Models.Models
import HarmTrace.Models.Jazz.Main
import HarmTrace.Models.Pop.Main
import HarmTrace.Models.ChordTokens
import HarmTrace.IO.Errors
import HarmTrace.HAnTree.HAn (HAn)
import HarmTrace.HAnTree.Tree (Tree, size, depth)
import HarmTrace.HAnTree.ToHAnTree (GTree)
import HarmTrace.HarmTrace
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances
import System.IO (stdout,hFlush)
import Data.List (sortBy, groupBy, intersperse)
import Control.Arrow (first)
import Text.Printf (printf)
mptreeAnnotatorSTG :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat
-> ChordAnnotation
mptreeAnnotatorSTG gex k = snapToGrid . mptreeAnnotator gex k
mptreeAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat
-> ChordAnnotation
mptreeAnnotator (GrammarEx g) k f = concatMap (harmonize g) (preProcessData k f)
preProcessData :: Maybe [TimedData Key] -> AudioFeat -> [ProbChordSeg]
preProcessData gtk af@(AudioFeat chrm beats _afk _id) =
segmentByTonic $ segmentByKey key . mergeByOneAndThree
. createChordRanks $ beatSync beats chrm
where key = maybe (getBeatSyncKeyFromChroma af) id gtk
harmonize :: forall g. (GTree g) => Grammar g -> ProbChordSeg
-> ChordAnnotation
harmonize g (Segment k cands) =
let isExpandable :: Bool
isExpandable = length (filter ((>1) . length) (map getData cands)) > 0
myParse :: [ProbChord] -> (Tree HAn,[ProbChord],Float)
myParse cs =
let x = map probChord cs
res :: ([g],[Error Int])
res = case g of
Jazz -> parse_h ((,) <$> pJazz k <*> pEnd) (createStr 0 x)
Pop -> parse_h ((,) <$> pPop k <*> pEnd) (createStr 0 x)
pr = ParseResult u (concatMap chords x) (fst res) u u u (snd res) []
t = pieceTreeHAn (postProc [ RemovePDPT, MergeDelChords ] pr)
u :: forall a. a
u = error "harmonize: undefined placeholder evaluated"
in (t, cs, errorRatio (snd res) x )
parseResults :: [(Tree HAn,[ProbChord],Float)]
parseResults = [ myParse l
| l <- lProduct (map getData cands) ]
select :: [(Tree HAn,[ProbChord],Float)] -> [ProbChord]
select = select1 . head
. groupBy (\(_,_,a) (_,_,b) -> a `compare` b == EQ)
. sortBy (\(_,_,a) (_,_,b) -> a `compare` b)
select1 :: [(Tree HAn,[ProbChord],Float)] -> [ProbChord]
select1 = snd3 . head . sortBy cmp where
cmp (a,_,_) (b,_,_) = (size a, depth a) `compare` (size b, depth b)
snd3 (_,s,_) = s
probChord :: ProbChord -> ChordToken
probChord (ProbChord lab@(Chord r _sh _add _on _dur) _p) =
(ChordToken r' sh' [lab] NotParsed 1 0) where
r' = if isNone r then Note Nothing Imp else toScaleDegree k r
sh' = toClassType lab
setBestChords :: [ProbChord] -> [TimedData ProbChord]
setBestChords = zipWith setData cands
in if isExpandable then setBestChords $ select parseResults
else map pickHead cands
pickHead :: TimedData [ProbChord] -> TimedData ProbChord
pickHead = fmap head
snapToGrid :: [TimedData ProbChord] -> [TimedData ProbChord]
snapToGrid = foldr snap [] . reduceTimedPChords where
snap :: TimedData a -> [TimedData a] -> [TimedData a]
snap td [] = [td]
snap a (h : tl) = case ( odd (beatLen a) && odd (beatLen h) , getBeat h ) of
(True, Two ) -> shiftFwd a h ++ tl
(True, Four) -> shiftBwd a h ++ tl
_ -> a : h : tl
beatLen :: TimedData a -> Int
beatLen = pred . length . getTimeStamps
shiftBwd :: TimedData a -> TimedData a -> [TimedData a]
shiftBwd (TimedData a ta) tdb = case getTimeStamps tdb of
[_on, off] -> [TimedData a (ta ++ [off]) ]
(_hb : hhb : tb) -> [TimedData a (ta ++ [hhb]), tdb{getTimeStamps = (hhb:tb)}]
[_] -> error "HarmTrace.Audio.Annotate.shiftBwd: 1 timestamp, onset == offset"
[ ] -> error "HarmTrace.Audio.Annotate.shiftBwd: No timestamps to shift"
shiftFwd :: TimedData a -> TimedData a -> [TimedData a]
shiftFwd tda (TimedData b tb) = case getTimeStamps tda of
[ ] -> error "HarmTrace.Audio.Annotate.shiftFwd: No timestamps to shift"
[_] -> error "HarmTrace.Audio.Annotate.shiftFwd: 1 timestamp, onset == offset"
[on, _off] -> [TimedData b (on : tb) ]
ta -> [tda {getTimeStamps = initTa}, TimedData b (oneButLastTa : tb)]
where
(initTa,oneButLastTa) = snocsnoc ta
snocsnoc :: [a] -> ([a],a)
snocsnoc [] = error "snocsnoc: empty list"
snocsnoc [_] = error "snocsnoc: singleton list"
snocsnoc [x,_lst] = ([x], x)
snocsnoc (x:xs) = first (x :) (snocsnoc xs)
reduceTimedPChords :: [TimedData ProbChord] -> [TimedData ProbChord]
reduceTimedPChords = foldr group [] where
group :: TimedData ProbChord -> [TimedData ProbChord] -> [TimedData ProbChord]
group c [] = [c]
group tc@(TimedData c tsc ) (th@(TimedData h tsh ) : t)
| c `pChordEq` h = concatTimedData c {prob = avgProb} tc th : t
| otherwise = tc : th : t where
avgProb :: NumData
avgProb = let ltsc = fromIntegral $ length tsc
ltsh = fromIntegral $ length tsh
tot = ltsc + ltsh
in (prob c * ltsc) + (prob h * ltsh) / tot
pChordEq :: ProbChord -> ProbChord -> Bool
pChordEq (ProbChord cA _pA) (ProbChord cB _pB) =
chordRoot cA == chordRoot cB &&
chordShorthand cA == chordShorthand cB
segmentByKey :: [TimedData Key] -> [TimedData [ProbChord]] -> [ProbChordSeg]
segmentByKey [] _ = error "segmentByKey: empty key list"
segmentByKey [k] chds = [Segment (getData k) chds]
segmentByKey (k : ks) chds = let (seg,cs) = span ((<= offset k) . offset) chds
in Segment (getData k) seg : segmentByKey ks cs
segmentByTonic :: [ProbChordSeg] -> [ProbChordSeg]
segmentByTonic segs = concatMap emergencySplit $ concatMap split segs where
split :: ProbChordSeg -> [ProbChordSeg]
split (Segment key cs) = zipWith Segment (repeat key) (segmentTonic key cs)
emergencySplit :: ProbChordSeg -> [ProbChordSeg]
emergencySplit (Segment k cs) = map (Segment k) (recSplit cs) where
recSplit [] = []
recSplit b
| blen <= maxSegmentSize
&& snd (lProdStats b) <= maxLProductSize = [b]
| otherwise = recSplit l ++ recSplit r
where blen = length b
(l,r) = splitAt (blen `div` 2) b
segmentTonic :: Key -> [TimedData [ProbChord]] -> [[TimedData [ProbChord]]]
segmentTonic k cands = segment cands [] where
segment [] [] = []
segment [] acc = [reverse acc]
segment (c:cs) acc
| c' `isTonic` k || c' `isDom` k = reverse (c:acc) : segmentTonic k cs
| otherwise = segment cs (c:acc) where
c' = getFstChord c
getFstChord :: TimedData [ProbChord] -> ChordLabel
getFstChord c = case getData c of
[] -> error "getFstChord: empty list"
(h:_) -> chordLab h
isTonic :: ChordLabel -> Key -> Bool
isTonic (Chord (Note Nothing N) _ _ _ _) _ = False
isTonic c (Key r m) = r == chordRoot c && m == toMode (toTriad c)
isDom :: ChordLabel -> Key -> Bool
isDom (Chord (Note Nothing N) _ _ _ _) _ = False
isDom c key = toScaleDegree key (chordRoot c) == Note Nothing V
&& toTriad c == MajTriad
lProduct :: [[a]] -> [[a]]
lProduct [] = []
lProduct [l] = [ [x] | x <- l ]
lProduct (h:t) = concat [ map (x:) (lProduct t) | x <- h ]
putSegStats :: Maybe [TimedData Key] -> AudioFeat -> IO()
putSegStats k af = mapM_ segmentStat $ preProcessData k af
segmentStat :: ProbChordSeg -> IO ()
segmentStat (Segment k bs) =
do putStr ("\nstart: " ++ (printf "%.3f" . onset $ head bs))
putStr (", end: " ++ (printf "%.3f" . offset $ last bs))
putStr (", key: " ++ show k)
putStr (", probChords: " ++ show (length bs))
let (l, lpr) = lProdStats bs
putStr (", lists > 1: " ++ show l)
putStrLn (" lProduct: " ++ show lpr)
(putStrLn . concat . intersperse "\n" . map showTimedData $ bs)
>> hFlush stdout where
showTimedData :: TimedData [ProbChord] -> String
showTimedData td =
(concat . intersperse ", " . map showProbChord . getData $ td)
++ ": " ++ ( show . getTimeStamps $ td )
showProbChord :: ProbChord -> String
showProbChord (ProbChord lab p) = show lab ++ '@' : printf "%.3f" p
lProdStats :: [TimedData [a]] -> (Int, Int)
lProdStats bs = (length l, lpr) where
l = filter ((>1) . length ) (map getData bs)
lpr = foldr (\a b -> length a * b) 1 l
groupAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation
groupAnnotator _g _keyAnn (AudioFeat chrm beats _key _id) =
let endTime = BarTime (time $ last chrm) Four
beats' = takeWhile (< endTime) beats ++ [endTime]
in map pickHead . mergeByOneAndThree
. createChordRanks $ beatSync beats' chrm
simpleAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation
simpleAnnotator _g _keyAnn (AudioFeat crm bts _key _id) =
map pickHead . createChordRanks $ beatSync bts crm