module HarmTrace.Audio.Evaluation (
relCorrectOverlap
, achievScore
, chordChangeRatio
, avgDistToOne
, chordTriadEq
, chordClassEq
, majMinEq
, printChordRCO
, printRCO
, sample
) where
import Constants
import HarmTrace.Base.MusicTime
import HarmTrace.Audio.Annotate (preProcessData)
import HarmTrace.Base.MusicRep
import Data.List (genericLength, zipWith5, foldl')
import Text.Printf(printf)
import System.IO (stdout,hFlush)
import Data.Foldable (foldrM)
import Control.Monad.State (State, execState, modify)
eqFunc :: ChordLabel -> ChordLabel -> Bool
eqFunc = chordTriadEq
chordClassEq :: ChordLabel -> ChordLabel -> Bool
chordClassEq a b = chordRoot a `rootEQ` chordRoot b
&& toClassType a == toClassType b
chordTriadEq :: ChordLabel -> ChordLabel -> Bool
chordTriadEq a b = chordRoot a `rootEQ` chordRoot b
&& toMajMin (toTriad a) == toMajMin (toTriad b)
majMinEq :: ChordLabel -> ChordLabel -> Bool
majMinEq a b = chordRoot a `rootEQ` chordRoot b
&& toTriad a `triadEq` toTriad b where
triadEq :: Triad -> Triad -> Bool
triadEq x y = case (toMajMin x, toMajMin y) of
(MajClass, MinClass) -> True
(MinClass, MajClass) -> True
_ -> False
rootEQ :: Root -> Root -> Bool
rootEQ (Note Nothing X) (Note Nothing X) = True
rootEQ (Note Nothing N) (Note Nothing N) = True
rootEQ (Note Nothing X) _ = False
rootEQ _ (Note Nothing X) = False
rootEQ (Note Nothing N) _ = False
rootEQ _ (Note Nothing N) = False
rootEQ a b = toSemitone a == toSemitone b
relCorrectOverlap :: (a -> a -> Bool) -> [TimedData a] -> [TimedData a]
-> Double
relCorrectOverlap eq a b = foldl' countMatch 0 (zipWith eq sama samb) / tot
where sama = sample a
samb = sample b
tot = max (genericLength sama) (genericLength samb)
countMatch :: Double -> Bool -> Double
countMatch x y | y = succ x
| otherwise = x
sample :: [TimedData a]-> [a]
sample = sampleWith evaluationSampleRate
sampleWith :: NumData -> [TimedData a] -> [a]
sampleWith rate = sampleAt [0.00, rate .. ]
sampleAt :: [NumData] -> [TimedData a] -> [a]
sampleAt _ [] = []
sampleAt [] _ = error "Harmtrace.Audio.Evaluation: No sampling grid specified"
sampleAt (t:ts) (c:cs)
| t <= offset c = getData c : sampleAt ts (c:cs)
| otherwise = sampleAt (t:ts) cs
achievScore :: [TimedData ChordLabel] -> [TimedData [ChordLabel]] -> Double
achievScore a b = sum (zipWith eq sama samb) / len
where sama = sample a
samb = sample b
len = min (genericLength sama) (genericLength samb)
eq c cs | foldr (\x -> (chordTriadEq c x ||)) False cs = 1.0
| otherwise = 0.0
chordChangeRatio :: (ChordLabel -> ChordLabel -> Bool)
-> [TimedData ChordLabel] -> [TimedData ChordLabel] -> Double
chordChangeRatio eq gt ma = (fromIntegral . countChordChanges $ gt)
/ (fromIntegral . countChordChanges $ ma) where
countChordChanges :: [TimedData ChordLabel] -> Int
countChordChanges cs = execState (foldrM step [] $ dropTimed cs) 0
step :: ChordLabel -> [ChordLabel] -> State Int [ChordLabel]
step c [] = do modify succ
return [c]
step a ( b : cs )
| a `eq` b = return (a : b : cs)
| otherwise = do modify succ
return (a : b : cs)
avgDistToOne :: [Double] -> Double
avgDistToOne ds = (sum . map absDistToOne $ ds) / genericLength ds where
absDistToOne :: Double -> Double
absDistToOne a = abs (1.0 a)
printChordRCO :: (AudioFeat -> ChordAnnotation) -> [TimedData Key]
-> AudioFeat -> [TimedData ChordLabel] -> IO Double
printChordRCO annotator key af gt = do
let
blks :: [TimedData [ProbChord]]
blks = concatMap segChords $ preProcessData Nothing af
samaf = sampleWith displaySampleRate (dropProb . annotator $ af)
samgt = sampleWith displaySampleRate gt
sambk = sampleWith displaySampleRate blks
samk = sampleWith displaySampleRate key
tot = max (genericLength samaf) (genericLength samgt)
showEq m = if m then "==" else "/="
printEval :: NumData -> ChordLabel -> ChordLabel -> Key -> [ProbChord]
-> IO Bool
printEval t g a b c =
do putStrLn (printf "%.2f" t ++ '\t' : showEq equal ++ '\t' : show g
++ '\t' : show a ++ '\t' : show b ++ '\t' : show c)
>> hFlush stdout
return equal where equal = g `eqFunc` a
putStrLn "time\tmatch\tGT\t\tMPTREE\tkey\toptional chords"
m <- sequence (zipWith5 printEval [0.0,displaySampleRate ..]
samgt
samaf
samk
sambk)
return (foldl countMatch 0 m / tot)
printRCO :: (a -> a -> IO (Bool)) -> [TimedData a] -> [TimedData a]
-> IO (Double)
printRCO ioeq a b = do matches <- sequence (zipWith3 printEq [0,displaySampleRate ..] sama samb)
return (foldl' countMatch 0 matches / tot)
where sama = sampleWith displaySampleRate a
samb = sampleWith displaySampleRate b
tot = max (genericLength sama) (genericLength samb)
printEq ts x y = do putStr (printf "%.2f: " ts)
ioeq x y