HarmTrace.hs

{-# LANGUAGE GADTs    #-}
{-# LANGUAGE CPP      #-}
{-# OPTIONS_GHC -Wall #-}

module HarmTrace.HarmTrace ( PPOption(..), Grammar(..), GrammarEx(..)
                           , ParseResult(..)
                           , string2Piece, postProc ) where

import HarmTrace.Models.Models
import HarmTrace.Models.Jazz.Main
import HarmTrace.Models.Pop.Main
import HarmTrace.Models.Test.Main
import HarmTrace.HAnTree.ToHAnTree
import HarmTrace.HAnTree.Tree
import HarmTrace.HAnTree.HAn (HFunc (P))
import HarmTrace.HAnTree.PostProcess
import HarmTrace.Base.MusicRep
import HarmTrace.Tokenizer.Tokens as CT
import HarmTrace.Tokenizer.Tokenizer

import Data.Ord (comparing)
import Data.List (minimumBy)

#ifdef AUDIO
-- Audio/Annotation Stuff
import HarmTrace.Audio.Annotations
import HarmTrace.Audio.ChordTypes

import HarmTrace.Base.Parsing (parseDataWithErrors)
#endif

-- Parser stuff
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances as PC

--------------------------------------------------------------------------------
-- Plugging everything together
--------------------------------------------------------------------------------

data ParseResult a = ParseResult { parsedKey          :: Key
                                 , parsedChordLabels  :: [ChordLabel]
                                 , parsedPiece        :: [a]
                                 , pieceTreeHAn       :: Tree HAn
                                 , nrAmbTrees         :: Int
                                 , tokenizerErrors    :: [Error LineColPos ]
                                 , pieceErrors        :: [Error Int] 
                                 , postProcessing     :: [PPOption]}
  
-- parses s with string2PieceC and merges the deleted chords with the tree
-- (Representable a, GTree (Rep a))
postProc :: (GTree g) => [PPOption] -> ParseResult g -> ParseResult g
postProc opts beforePostProc = beforePostProc { pieceTreeHAn = t } 
  where
  t = selectTree $ map (postProcess fs . gTreeHead) (parsedPiece beforePostProc)
  fs = map opt2Func opts
  opt2Func :: PPOption -> (Tree HAn -> Tree HAn)
  opt2Func RemoveInsertions = removeInsertions 
  opt2Func RemovePDPT       = removePDPT
  opt2Func MergeDelChords   = mergeDelChords (parsedKey beforePostProc)
                                             (pieceErrors beforePostProc)
                                             (parsedChordLabels beforePostProc)
  opt2Func ExpandChordDurations = expandChordDurations

selectTree :: [Tree HAn] -> Tree HAn
selectTree [] = emptyHAnTree
selectTree ts = minimumBy (comparing getNrFuncNodes) ts

getNrFuncNodes :: Tree HAn -> Int
getNrFuncNodes (Node (HAnFunc P) nodes _) = length nodes
getNrFuncNodes _ = error "HarmTrace.hs: not a correctly formed HAn Tree" 
  
postProcess :: [Tree HAn -> Tree HAn] -> Tree HAn -> Tree HAn
postProcess []     tree = tree
postProcess (f:fs) tree = f (postProcess fs tree)

-- Takes a string with line-separated chords of a song and
-- returns all possible parsed pieces, together with error-correction steps
-- taken (on tokenizing and on musical recognition).
string2Piece :: Grammar g -> String -> ParseResult g
string2Piece g s = let
  (PieceLabel key tok, err) = parse ((,) <$> parseSongAbs <*> pEnd)
                                    (createStr (LineColPos 0 0 0) s)
  (trees, err2) = case g of 
                    Jazz -> parse_h ((,) <$> pJazz key <*> pEnd)
                              (createStr 0 (toKeyRelTok key tok))  
                    Pop  -> parse_h ((,) <$> pPop  key <*> pEnd)
                              (createStr 0 (toKeyRelTok key tok))
                    Test -> parse_h ((,) <$> pPieceTest <*> pEnd)
                              (createStr 0 (toKeyRelTok key tok))
  in ParseResult key tok trees emptyHAnTree (length trees) err err2 []


#ifdef AUDIO
--------------------------------------------------------------------------------
-- Parsing audio file ground-truth annotations
--------------------------------------------------------------------------------  

gt2Piece :: (GTree g) => Grammar g -> String -> String -> ParseResult g
gt2Piece g ks cs = let
  (TimedData key _ _:_cs, errK) = parseDataWithErrors parseKeyAnnotationData ks
  (tok, errT) = parseDataWithErrors parseAnnotationData cs
  ppTok       = preProcess tok
  (ts, errP)  = case g of 
                  Jazz -> parse_h ((,) <$> pJazz key <*> pEnd)
                            (createStr 0 (toKeyRelTok key ppTok))  
                  Pop  -> parse_h ((,) <$> pPop  key <*> pEnd)
                            (createStr 0 (toKeyRelTok key ppTok))
                  Test -> parse_h ((,) <$> pPieceTest <*> pEnd)
                            (createStr 0 (toKeyRelTok key ppTok))
  in ParseResult key ppTok ts emptyHAnTree (length ts) (errK ++ errT) errP [] 
#endif