diff --git a/HarmTrace.cabal b/HarmTrace.cabal --- a/HarmTrace.cabal +++ b/HarmTrace.cabal @@ -1,5 +1,5 @@ name: HarmTrace -version: 0.6 +version: 0.7 synopsis: Harmony Analysis and Retrieval of Music description: HarmTrace: Harmony Analysis and Retrieval of Music with Type-level Representations of Abstract @@ -27,6 +27,7 @@ cabal-version: >= 1.6 tested-with: GHC == 7.0.3 + executable harmtrace hs-source-dirs: src other-modules: HarmTrace.HarmTrace @@ -35,10 +36,10 @@ HarmTrace.Base.Parsing HarmTrace.Base.TypeLevel - HarmTrace.HAnTree.Augment HarmTrace.HAnTree.Binary HarmTrace.HAnTree.HAn HarmTrace.HAnTree.HAnParser + HarmTrace.HAnTree.PostProcess HarmTrace.HAnTree.ToHAnTree HarmTrace.HAnTree.Tree @@ -46,22 +47,38 @@ HarmTrace.IO.Main HarmTrace.IO.PrintTree + HarmTrace.Matching.Alignment + HarmTrace.Matching.AlignmentFaster HarmTrace.Matching.FlatMatch + HarmTrace.Matching.GuptaNishimura HarmTrace.Matching.GuptaNishimuraEditMatch + HarmTrace.Matching.HChord HarmTrace.Matching.Matching HarmTrace.Matching.Sim + HarmTrace.Matching.SimpleChord HarmTrace.Matching.Standard + HarmTrace.Matching.Testing - HarmTrace.Model.Instances - HarmTrace.Model.Main - HarmTrace.Model.Model - HarmTrace.Model.Parser + HarmTrace.Models.Models + HarmTrace.Models.Parser + HarmTrace.Models.Jazz.Instances + HarmTrace.Models.Jazz.Main + HarmTrace.Models.Jazz.Model + + HarmTrace.Models.Pop.Instances + HarmTrace.Models.Pop.Main + HarmTrace.Models.Pop.Model + + HarmTrace.Models.Test.Instances + HarmTrace.Models.Test.Main + HarmTrace.Models.Test.Model + HarmTrace.Tokenizer.Tokenizer HarmTrace.Tokenizer.Tokens main-is: Main.hs - build-depends: base >= 4.3 && < 4.4, template-haskell >=2.5 && <2.6, + build-depends: base >= 4.2 && < 4.4, template-haskell >=2.4 && <2.6, mtl, directory, filepath, array, parallel >= 3, Diff == 0.1.*, parseargs >= 0.1.3.2, regex-tdfa == 1.1.*, process >= 1.0, diff --git a/src/HarmTrace/Base/MusicRep.hs b/src/HarmTrace/Base/MusicRep.hs --- a/src/HarmTrace/Base/MusicRep.hs +++ b/src/HarmTrace/Base/MusicRep.hs @@ -138,22 +138,25 @@ | sh `elem` [Min,Min7,Min6,Min9,HDim7] = MinClass | sh `elem` [Sev,Nin,Aug] = DomClass | sh `elem` [Dim,Dim7] = DimClass - | otherwise = error "toClassType: unknow shorthand" -- cannot happen - - + | otherwise = error ("toClassType: unknow shorthand: " ++ show sh) +-------------------------------------------------------------------------------- -- Value Level Scale Degree Transposition -------------------------------------------------------------------------------- -relativize :: Key -> [ChordLabel] -> [ChordDegree] -relativize k = map (toChordDegree k) - --- Chord root shorthand degrees original repetitions +isNoneChord :: ChordLabel -> Bool +isNoneChord (Chord (Note _ N) _ _ _ _) = True +isNoneChord (Chord _ None _ _ _) = True +isNoneChord _ = False + +-- Chord root shorthand degrees location duration toChordDegree :: Key -> ChordLabel -> ChordDegree toChordDegree k (Chord r sh degs loc d) = - Chord (toScaleDegree k r) sh degs loc d + Chord (toScaleDegree k r) sh degs loc d toScaleDegree :: Key -> Root -> ScaleDegree -toScaleDegree (Key kr _) cr = -- Note Nothing I +toScaleDegree _ n@(Note _ N) = + error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose" ++ show n) +toScaleDegree (Key kr _) cr = -- Note Nothing I scaleDegrees!!(((diaNatToSemi cr) - (diaNatToSemi kr)) `mod` 12) -- transposes a degree with sem semitones up diff --git a/src/HarmTrace/HAnTree/Augment.hs b/src/HarmTrace/HAnTree/Augment.hs deleted file mode 100644 --- a/src/HarmTrace/HAnTree/Augment.hs +++ /dev/null @@ -1,63 +0,0 @@ -module HarmTrace.HAnTree.Augment where - -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.HAnTree.HAn -import HarmTrace.HAnTree.Tree - -import Data.List(partition, find) -import Data.Maybe (isJust, fromJust) - --- Parser stuff -import Text.ParserCombinators.UU.BasicInstances as PC - --------------------------------------------------------------------------------- --- Augmenting a Tree HAn with the chords deleted by the parser --------------------------------------------------------------------------------- - --- merges the deleted chords back into the parsed Tree HAn -mergeDelChords :: Key -> [[ChordLabel]] -> [Tree HAn] -> [Tree HAn] -mergeDelChords _key [] trees = trees -mergeDelChords _key _ [] = [] -mergeDelChords key d (i@(Node (HAnChord c) _ _):ts) - | status c == CT.Inserted = i : mergeDelChords key d ts - | isJust m = i : (toDelHAn key $ fromJust m) ++ mergeDelChords key d ts - | otherwise = i : mergeDelChords key d ts - where m = find (\x -> (getLoc . last $ chords c) + 1 == (getLoc $ head x)) d -mergeDelChords key chrds (Node han cs pn : ts) = - Node han (mergeDelChords key chrds cs) pn : mergeDelChords key chrds ts - --- transforms a (deleted) chord into a Tree HAn data type -toDelHAn :: Key -> [ChordLabel] -> [Tree HAn] -toDelHAn key m = map f m where - f c@(Chord r sh _add _loc d) = (Node (HAnChord - (ChordToken (toScaleDegree key r) (toClassType sh) [c] CT.Deleted 1 d)) - [] Nothing) - --- returns the deleted chords, given a list of errors and the input tokes -filterErrorPos :: [Error Int] -> [Chord a] -> [Chord a] -filterErrorPos e c = filter (\x -> getLoc x `elem` dels) chrds ++ cDelsAtEnd - where - (delsAtEnd, dels) = partition (== (-1)) . map gPos $ filter f e - (chrds,cDelsAtEnd) = splitAt (length c - length delsAtEnd) c - gPos (PC.Inserted _ p _) = p - gPos (PC.Deleted _ p _) = p - gPos (DeletedAtEnd _) = (-1) - gPos (Replaced _ _ p _) = p - f (PC.Inserted _ _ _) = False - f (PC.Deleted _ _ _) = True - f (DeletedAtEnd _) = True - f (Replaced _ _ _ _) = False - --- groups the deleted chord tokens that are neighbours, if we were not --- grouping chords but Integers, a result could look like: --- groupNeighbours [1,2,7,8,9,11,13,16,17] = [[1,2],[7,8,9],[11],[13],[16,17]] -groupNeighbours :: [Chord a] -> [[Chord a]] -groupNeighbours [] = [] -groupNeighbours (x:xs) = let (grp,tl) = get x xs in grp : groupNeighbours tl --- splits a list into a list with neighbours and a tail -get :: Chord a -> [Chord a] -> ([Chord a],[Chord a]) -get a l@[] = ([a],l) -get a l@(b:cs) - | (getLoc a) + 1 == getLoc b = (a:bs,cs') - | otherwise = ([a],l) where (bs,cs') = get b cs diff --git a/src/HarmTrace/HAnTree/HAn.hs b/src/HarmTrace/HAnTree/HAn.hs --- a/src/HarmTrace/HAnTree/HAn.hs +++ b/src/HarmTrace/HAnTree/HAn.hs @@ -20,8 +20,10 @@ -- H_armonic An_alysis wrapper datatype, the Int represents the duration data HAn = HAn !Int !String | HAnFunc !HFunc + | HAnPrep !Prep | HAnTrans !Trans | HAnChord !ChordToken + -- duration Mode constructor_ix specials data HFunc = Ton !Int !Mode !Int !(Maybe Spec) | Dom !Int !Mode !Int !(Maybe Spec) @@ -32,21 +34,24 @@ data Spec = Blues | MinBorrow | Parallel deriving Eq - -data Trans = SecDom !Int !ScaleDegree -- "V/X" - | SecMin !Int !ScaleDegree -- "v/X" - | SecDim !Int !ScaleDegree -- "v/X" - | Trit !Int !ScaleDegree -- "bII/X" + +-- Preparations, like secondary dominants etc. that cause a "split" in the tree +data Prep = SecDom !Int !ScaleDegree -- "V/X" + | SecMin !Int !ScaleDegree -- "v/X" + | DiatDom !Int !ScaleDegree -- "Vd" + | NoPrep + +-- Scalde degree transformations, e.g. tritone substitutions etc. +data Trans = Trit !Int !ScaleDegree -- "bII/X" | DimTrit !Int !ScaleDegree -- "bIIb9/X" | DimTrans !Int !ScaleDegree -- "VII0" - | DiatDom !Int !ScaleDegree -- "Vd" | NoTrans -------------------------------------------------------------------------------- -- Binary instances -------------------------------------------------------------------------------- -deriveAllL [ ''HAn, ''Trans, ''HFunc, ''Spec] +deriveAllL [ ''HAn, ''Trans, ''Prep, ''HFunc, ''Spec] instance Binary HAn where put = putDefault @@ -54,6 +59,9 @@ instance Binary Trans where put = putDefault get = getDefault +instance Binary Prep where + put = putDefault + get = getDefault instance Binary HFunc where put = putDefault get = getDefault @@ -69,6 +77,7 @@ rnf (HAn d s ) = rnf d `seq` rnf s rnf (HAnFunc a) = rnf a rnf (HAnTrans a) = rnf a + rnf (HAnPrep a) = rnf a rnf (HAnChord a) = seq a () instance NFData HFunc where @@ -79,14 +88,16 @@ rnf PD = () rnf PT = () -instance NFData Trans where +instance NFData Prep where rnf (SecDom i d) = rnf i `seq` d `seq` () rnf (SecMin i d) = rnf i `seq` d `seq` () - rnf (SecDim i d) = rnf i `seq` d `seq` () + rnf (DiatDom i d) = rnf i `seq` d `seq` () + rnf NoPrep = () + +instance NFData Trans where rnf (Trit i d) = rnf i `seq` d `seq` () rnf (DimTrit i d) = rnf i `seq` d `seq` () rnf (DimTrans i d) = rnf i `seq` d `seq` () - rnf (DiatDom i d) = rnf i `seq` d `seq` () rnf NoTrans = () instance NFData Spec where @@ -95,7 +106,7 @@ rnf Parallel = () -------------------------------------------------------------------------------- --- Instances for Harmony Analyses +-- Durations set and get instances -------------------------------------------------------------------------------- -- Yes, I know these can be generic functions, but with my current generic @@ -103,10 +114,10 @@ class GetDur a where getDur :: a -> Int - instance GetDur HAn where getDur (HAn d _s) = d getDur (HAnFunc a) = getDur a + getDur (HAnPrep a) = getDur a getDur (HAnTrans a) = getDur a getDur (HAnChord a) = dur a @@ -114,47 +125,26 @@ getDur (Ton i _ _ _) = i getDur (Dom i _ _ _) = i getDur (Sub i _ _ _) = i - getDur _ = 1 + getDur _ = 0 -instance GetDur Trans where +instance GetDur Prep where getDur (SecDom i _) = i getDur (SecMin i _) = i - getDur (SecDim i _) = i + getDur (DiatDom i _) = i + getDur NoPrep = 0 + +instance GetDur Trans where getDur (Trit i _) = i getDur (DimTrit i _) = i getDur (DimTrans i _) = i - getDur (DiatDom i _) = i - getDur (NoTrans) = 0 + getDur NoTrans = 0 +instance GetDur (Chord a) where + getDur = duration + class SetDur a where setDur :: a -> Int -> a - -instance Eq HAn where - (HAn _ s) == (HAn _ s2) = s == s2 - (HAnChord chord) == (HAnChord chord2) = chord == chord2 - (HAnFunc hfunk) == (HAnFunc hfunk2) = hfunk == hfunk2 - (HAnTrans trans) == (HAnTrans trans2) = trans == trans2 - _ == _ = False - -instance Eq HFunc where - (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2 - (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2 - (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2 - P == P = True - PD == PD = True - PT == PT = True - _ == _ = False -instance Eq Trans where - (SecDom _ sd) == (SecDom _ sd2) = sd == sd2 - (SecMin _ sd) == (SecMin _ sd2) = sd == sd2 - (SecDim _ sd) == (SecMin _ sd2) = sd == sd2 - (Trit _ sd) == (Trit _ sd2) = sd == sd2 - (DimTrit _ sd) == (DimTrit _ sd2) = sd == sd2 - (DimTrans _ sd) == (DimTrans _ sd2) = sd == sd2 - (DiatDom _ sd) == (DiatDom _ sd2) = sd == sd2 - _ == _ = False - instance SetDur HAn where setDur (HAn _ s) i = (HAn i s) setDur (HAnFunc a) i = (HAnFunc (setDur a i)) @@ -167,42 +157,87 @@ setDur (Sub _d m i s) d = (Sub d m i s) setDur a _ = a -instance SetDur Trans where +instance SetDur Prep where setDur (SecDom _d sd) d = (SecDom d sd) setDur (SecMin _d sd) d = (SecMin d sd) - setDur (SecDim _d sd) d = (SecMin d sd) + setDur (DiatDom _d sd) d = (DiatDom d sd) + setDur NoPrep _ = NoPrep + +instance SetDur Trans where setDur (Trit _d sd) d = (Trit d sd) setDur (DimTrit _d sd) d = (DimTrit d sd) setDur (DimTrans _d sd) d = (DimTrans d sd) - setDur (DiatDom _d sd) d = (DiatDom d sd) setDur NoTrans _ = NoTrans + +-------------------------------------------------------------------------------- +-- Eq instances +-------------------------------------------------------------------------------- + +instance Eq HAn where + (HAn _ s) == (HAn _ s2) = s == s2 + (HAnChord chord) == (HAnChord chord2) = chord == chord2 + (HAnFunc hfunk) == (HAnFunc hfunk2) = hfunk == hfunk2 + (HAnTrans trans) == (HAnTrans trans2) = trans == trans2 + _ == _ = False + +instance Eq HFunc where + -- ignore duration for now + (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2 + (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2 + (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2 + P == P = True + PD == PD = True + PT == PT = True + _ == _ = False +instance Eq Prep where + (SecDom _dur sd) == (SecDom _dur2 sd2) = sd == sd2 + (SecMin _dur sd) == (SecMin _dur2 sd2) = sd == sd2 + (DiatDom _dur sd) == (DiatDom _dur2 sd2) = sd == sd2 + NoPrep == NoPrep = True + _ == _ = False -instance Show Trans where - show (SecDom _l d) = "V/" ++ show d - show (SecMin _l d) = "v/" ++ show d - show (SecDim _l d) = "VII/" ++ show d - show (Trit _l d) = "IIb/" ++ show d - show (DimTrit _l d) = "IIb9b/" ++ show d - show (DimTrans _l d) = show d ++ "0" - show (NoTrans) = "_" - show (DiatDom _l d) = "Vd/"++ show d +instance Eq Trans where + (Trit _dur sd) == (Trit _dur2 sd2) = sd == sd2 + (DimTrit _dur sd) == (DimTrit _dur2 sd2) = sd == sd2 + (DimTrans _dur sd) == (DimTrans _dur2 sd2) = sd == sd2 + NoTrans == NoTrans = True + _ == _ = False + +-------------------------------------------------------------------------------- +-- Eq and Show instances +-------------------------------------------------------------------------------- +instance Show Prep where + show (SecDom l d) = "V/" ++ show d ++ '_' : show l + show (SecMin l d) = "v/" ++ show d ++ '_' : show l + show (DiatDom l d) = "Vd/"++ show d ++ '_' : show l + show NoPrep = "np" + +instance Show Trans where + show (Trit l d) = "IIb/" ++ show d ++ '_' : show l + show (DimTrit l d) = "IIb9b/" ++ show d ++ '_' : show l + show (DimTrans l d) = show d ++ "0" ++ '_' : show l + show (NoTrans) = "nt" + instance Show HAn where - show (HAn _l con) = con -- ++ "_s" ++ '_' : show l + show (HAn l con) = con ++ "_s" ++ '_' : show l show (HAnChord chord) = show chord show (HAnFunc hfunk) = show hfunk show (HAnTrans trans) = show trans + show (HAnPrep prep ) = show prep instance Show HFunc where - show (Ton _l mode i s) = "T" ++ show mode ++ '_' : show i ++ maybe "" show s - show (Dom _l mode i s) = "D" ++ show mode ++ '_' : show i ++ maybe "" show s - show (Sub _l mode i s) = "S" ++ show mode ++ '_' : show i ++ maybe "" show s + show (Ton l mode i s) = "T" ++ show mode ++ '_' : show i + ++ maybe "" show s ++ '_' : show l + show (Dom l mode i s) = "D" ++ show mode ++ '_' : show i + ++ maybe "" show s ++ '_' : show l + show (Sub l mode i s) = "S" ++ show mode ++ '_' : show i + ++ maybe "" show s ++ '_' : show l show (P ) = "Piece" show (PT) = "PT" show (PD) = "PD" - instance Show Spec where show Blues = "bls" show MinBorrow = "bor" diff --git a/src/HarmTrace/HAnTree/PostProcess.hs b/src/HarmTrace/HAnTree/PostProcess.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/HAnTree/PostProcess.hs @@ -0,0 +1,109 @@ +module HarmTrace.HAnTree.PostProcess ( PPOption(..) + , expandChordDurations + , removePDPT, removeInsertions + , mergeDelChords ) where + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens as CT +import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.Tree + +import Data.List(partition, find) +import Data.Maybe (isJust, fromJust) +-- import Debug.Trace + +-- Parser stuff +import Text.ParserCombinators.UU.BasicInstances as PC + + +-- Optional post-processing operations +data PPOption = RemoveInsertions | RemovePDPT + | MergeDelChords | ExpandChordDurations -- | ... ? + deriving (Eq) + +-- propagates the durations of the chords up into the tree +expandChordDurations :: Tree HAn -> Tree HAn +expandChordDurations (Node h [] a) = (Node h [] a) where +expandChordDurations (Node h cs a) = (Node (setDur h d) cs' a) where + cs' = map expandChordDurations cs + d = sum $ map (getDur . getLabel) cs' + +-- removes some nodes from the tree structure that are not important for +-- similarity estimation +removePDPT :: Tree HAn -> Tree HAn +removePDPT = removeBy (\l -> l `elem` [(HAnFunc PD), (HAnFunc PT)]) + +-- Removes the HAn Nodes that were inserted by the parsing process +removeInsertions :: Tree HAn -> Tree HAn +removeInsertions = head . fst . remIns + +remIns :: Tree HAn -> ([Tree HAn], Bool) +remIns l@(Node han [ ] _ ) = if isInserted han then ([],True) else ([l],False) +remIns (Node han cn pn) = ([Node han (concat trees) pn], False) where + (trees,_ ) = unzip . filter (not . snd) $ map remIns cn + +-- returns True if a HAn is Inserted +isInserted :: HAn -> Bool +isInserted (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) = True +isInserted _ = False + +-------------------------------------------------------------------------------- +-- PostProcessing a Tree HAn with the chords deleted by the parser +-------------------------------------------------------------------------------- + +-- top level function for merging deleted chords +-- TODO: could be made to work on [ChordToken] instead of [ChordLabel] +mergeDelChords :: Key -> [Error Int] -> [ChordLabel] -> Tree HAn -> Tree HAn +mergeDelChords key pErr tok tree = + head $ mergeDelChords' key (groupNeighbours (filterErrorPos pErr tok)) [tree] + +-- N.B. there is a bug in this function: if the first chords is deleted +-- it is not placed back because there is no chord in the tree before +-- the deleted chord. + +-- merges the deleted chords back into the parsed Tree HAn +mergeDelChords' :: Key -> [[ChordLabel]] -> [Tree HAn] -> [Tree HAn] +mergeDelChords' _key [] tree = tree +mergeDelChords' _key _ [] = [] +mergeDelChords' key d (i@(Node (HAnChord c) _ _):ts) + | status c == CT.Inserted = i : mergeDelChords' key d ts + | isJust m = i : (toDelHAn key $ fromJust m) ++ mergeDelChords' key d ts + | otherwise = i : mergeDelChords' key d ts + where m = find (\x -> (getLoc . last $ chords c) + 1 == (getLoc $ head x)) d +mergeDelChords' key chrds (Node han cs pn : ts) = + Node han (mergeDelChords' key chrds cs) pn : mergeDelChords' key chrds ts + +-- transforms a (deleted) chord into a Tree HAn data type +toDelHAn :: Key -> [ChordLabel] -> [Tree HAn] +toDelHAn key m = map f m where + f c@(Chord r sh _add _loc d) = (Node (HAnChord + (ChordToken (toScaleDegree key r) (toClassType sh) [c] CT.Deleted 1 d)) + [] Nothing) + +-- returns the deleted chords, given a list of errors and the input tokes +filterErrorPos :: [Error Int] -> [Chord a] -> [Chord a] +filterErrorPos e c = filter (\x -> getLoc x `elem` dels) chrds ++ cDelsAtEnd + where + (delsAtEnd, dels) = partition (== (-1)) . map gPos $ filter f e + (chrds,cDelsAtEnd) = splitAt (length c - length delsAtEnd) c + gPos (PC.Inserted _ p _) = p + gPos (PC.Deleted _ p _) = p + gPos (DeletedAtEnd _) = (-1) + gPos (Replaced _ _ p _) = p + f (PC.Inserted _ _ _) = False + f (PC.Deleted _ _ _) = True + f (DeletedAtEnd _) = True + f (Replaced _ _ _ _) = False + +-- groups the deleted chord tokens that are neighbours, if we were not +-- grouping chords but Integers, a result could look like: +-- groupNeighbours [1,2,7,8,9,11,13,16,17] = [[1,2],[7,8,9],[11],[13],[16,17]] +groupNeighbours :: [Chord a] -> [[Chord a]] +groupNeighbours [] = [] +groupNeighbours (x:xs) = let (grp,tl) = get x xs in grp : groupNeighbours tl +-- splits a list into a list with neighbours and a tail +get :: Chord a -> [Chord a] -> ([Chord a],[Chord a]) +get a l@[] = ([a],l) +get a l@(b:cs) + | (getLoc a) + 1 == getLoc b = (a:bs,cs') + | otherwise = ([a],l) where (bs,cs') = get b cs diff --git a/src/HarmTrace/HAnTree/ToHAnTree.hs b/src/HarmTrace/HAnTree/ToHAnTree.hs --- a/src/HarmTrace/HAnTree/ToHAnTree.hs +++ b/src/HarmTrace/HAnTree/ToHAnTree.hs @@ -3,7 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -module HarmTrace.HAnTree.ToHAnTree ( GTree(..), gTreeDefault, HAn(..)) where +module HarmTrace.HAnTree.ToHAnTree ( GTree(..) , HAn(..) , gTreeDefault + , gTreeHead , emptyHAnTree ) where import Generics.Instant.Base import HarmTrace.HAnTree.Tree (Tree(..)) @@ -26,9 +27,6 @@ instance (GTree a, GTree b) => GTree (a :*: b) where gTree (a :*: b) = gTree a ++ gTree b -instance GTree a => GTree [a] where - gTree x = concatMap gTree x - instance GTree a => GTree (Rec a) where gTree (Rec x) = gTree x @@ -36,6 +34,15 @@ gTree (Var x) = gTree x +instance GTree a => GTree [a] where + gTree x = concatMap gTree x + -- Dispatcher gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn] gTreeDefault = gTree . from + +gTreeHead :: (GTree a) => a -> Tree HAn +gTreeHead = head . gTree + +emptyHAnTree :: Tree HAn +emptyHAnTree = Node (HAn 0 "empty") [] Nothing diff --git a/src/HarmTrace/HAnTree/Tree.hs b/src/HarmTrace/HAnTree/Tree.hs --- a/src/HarmTrace/HAnTree/Tree.hs +++ b/src/HarmTrace/HAnTree/Tree.hs @@ -110,14 +110,16 @@ depth' x (Node _ c _ ) = x : concatMap (depth' (x+1)) c -- recursively removes the nodes with label 'x' from a tree -remove :: (Eq t) => t -> Tree t -> [Tree t] +remove :: (Eq t) => t -> Tree t -> Tree t remove x = removeBy (== x) -- more general version of remove -removeBy :: (t -> Bool) -> Tree t -> [Tree t] -removeBy f (Node l c pn) - | f l = concatMap (removeBy f) c - | otherwise = [(Node l (concatMap (removeBy f) c) pn)] +removeBy :: (t -> Bool) -> Tree t -> Tree t +removeBy f t = head (removeBy' f t) +removeBy' :: (t -> Bool) -> Tree t -> [Tree t] +removeBy' f (Node l c pn) + | f l = concatMap (removeBy' f) c + | otherwise = [(Node l (concatMap (removeBy' f) c) pn)] -- collects all the subtrees of tree in a list in post order. pot, pot', pret, pret',potPret :: Tree t -> [Tree t] diff --git a/src/HarmTrace/HarmTrace.hs b/src/HarmTrace/HarmTrace.hs --- a/src/HarmTrace/HarmTrace.hs +++ b/src/HarmTrace/HarmTrace.hs @@ -1,15 +1,34 @@ -module HarmTrace.HarmTrace where +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} -import HarmTrace.Model.Model hiding (PD, PT) -import HarmTrace.Model.Main +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.HAn import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.Augment +import HarmTrace.HAnTree.HAn (HFunc (P)) +import HarmTrace.HAnTree.PostProcess import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens +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 @@ -18,56 +37,75 @@ -- Plugging everything together -------------------------------------------------------------------------------- --- instance Show (Piece key) where show x = showChord x "" - +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 -string2PieceCPostProc :: String - -> ( [ChordLabel], [Piece key], [Tree HAn] - , [Error Int], [Error Int]) -string2PieceCPostProc s = case string2PieceC s of - (key, tok, trees, err, err2) -> (tok, trees, output, err, err2) where - output = map postProc trees - postProc tree = treeOperations (mergeDelChords key - (groupNeighbours (filterErrorPos err2 tok)) - (gTree $ 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 -{-expandChordDurations :: Tree HAn -> Tree HAn -expandChordDurations (Node h cs a) = (Node (setDur h d) cs' a) where - cs' = map expandChordDurations cs - d = if null cs' then 0 else maximum $ map (getDur . getLabel) cs' - -} --- removes some nodes from the tree structure that are not important for --- similarity estimation -treeOperations :: [Tree HAn] -> Tree HAn -treeOperations = {-expandChordDurations . head . removeInserstions . -} - head . removeBy (\l -> l `elem` remv) . head - where remv = [(HAnFunc PD), (HAnFunc PT)] +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" -{- --- do not yet remove this function, allthough it is currently not used (and --- extremely ugly) we might need it for matching -removeInserstions :: Tree HAn -> [Tree HAn] -removeInserstions n@(Node l c pn) - | isInsertion n = concatMap removeInserstions c - | otherwise = [(Node l (concatMap removeInserstions c) pn)] where - isInsertion :: Tree HAn -> Bool - isInsertion (Node _ [Node _ [Node _ - [Node (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) _ _] _] _] _) = True - isInsertion (Node _ [Node _ - [Node (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) _ _] _] _) = True - isInsertion (Node _ - [Node (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) _ _ ] _) = True - isInsertion - (Node (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) _ _) = True - isInsertion _ = False --} - +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). -string2PieceC ::String -> (Key,[ChordLabel],[Piece key],[Error Int],[Error Int]) -string2PieceC s = let - (PieceToken key tok,err)=parse ((,) <$> parseSongAbs <*> pEnd) (createStr 0 s) - (trees,err2) = parse_h ((,) <$> pMajOrMin key <*> pEnd ) - (createStr 0 (mergeDups key tok)) - in (key, tok, trees, err, err2) +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 diff --git a/src/HarmTrace/IO/Errors.hs b/src/HarmTrace/IO/Errors.hs --- a/src/HarmTrace/IO/Errors.hs +++ b/src/HarmTrace/IO/Errors.hs @@ -1,10 +1,10 @@ +{-# OPTIONS_GHC -Wall #-} module HarmTrace.IO.Errors where -- Parser stuff -import Text.ParserCombinators.UU.BasicInstances as PC +import Text.ParserCombinators.UU.BasicInstances as PC (Error (..)) import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokenizer import Data.List (genericLength) @@ -21,14 +21,14 @@ ++ show e ++ " unconsumed tokens" -- More concise showing errors, and in IO -showErrors :: String -> [Error Int] -> IO () +showErrors :: Show a => String -> [Error a] -> IO () showErrors label l = case countErrors l of ErrorNrs i d e r -> putStrLn (label ++ show i ++ " insertions, " ++ show d ++ " deletions, " ++ show r ++ " replacements, " ++ show e ++ " deletions at the end") -- Counts the number of insertions and deletions -countErrors :: [Error Int] -> ErrorNrs +countErrors :: Show a => [Error a] -> ErrorNrs countErrors [] = ErrorNrs 0 0 0 0 countErrors ((PC.Inserted _ _ _) :t) = inc1 (countErrors t) countErrors ((PC.Deleted _ _ _) :t) = inc2 (countErrors t) @@ -38,10 +38,11 @@ simpleErrorMeasure :: ErrorNrs -> Float simpleErrorMeasure (ErrorNrs i d e r) = fromIntegral (i + d + e + r) -errorRatio :: [Error Int] -> [ChordLabel] -> Float +errorRatio :: Show a => [Error a] -> [ChordLabel] -> Float errorRatio errs toks = simpleErrorMeasure (countErrors errs) / -- probably we should not divide here by "mergeDups" ... - genericLength (mergeDups (Key (Note Nothing C) MajMode) toks) + -- genericLength (mergeDups (Key (Note Nothing C) MajMode) toks) + genericLength toks inc1, inc2, inc3, inc4 :: ErrorNrs -> ErrorNrs inc1 e = e { ins = ins e + 1 } diff --git a/src/HarmTrace/IO/Main.hs b/src/HarmTrace/IO/Main.hs --- a/src/HarmTrace/IO/Main.hs +++ b/src/HarmTrace/IO/Main.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -- Testing @@ -10,23 +11,43 @@ -- Music stuff import HarmTrace.HarmTrace import HarmTrace.Base.MusicRep -import HarmTrace.Model.Instances () +import HarmTrace.Models.Jazz.Instances () import HarmTrace.HAnTree.Tree (Tree) import HarmTrace.HAnTree.ToHAnTree import HarmTrace.IO.Errors +-- import HarmTrace.Matching.GuptaNishimuraEditMatch +import HarmTrace.Matching.Standard +-- import HarmTrace.Matching.Matching (getMatch) +-- import HarmTrace.Matching.AlignmentFaster (getAlignDist) +import HarmTrace.Matching.Alignment (getAlignDist, getHAnDist) +#ifdef AUDIO +-- Audio stuff +import HarmTrace.Base.Parsing +import HarmTrace.Audio.Parser +import HarmTrace.Audio.BeatChroma +import HarmTrace.Audio.Annotations +import HarmTrace.Audio.Harmonize +import HarmTrace.Audio.Evaluation +import HarmTrace.Audio.ChordTypes (ChordAnnotation) +import Data.List (genericLength) +#endif + -- Library modules import System.Console.ParseArgs hiding (args) -- cabal install parseargs import Data.List (sort, groupBy, intersperse) -import Data.Binary (encodeFile) import Control.Arrow ((***)) import System.FilePath import System.Directory import System.IO -import Text.Regex.TDFA +import Text.Regex.TDFA hiding (match) import Text.Printf (printf) import System.CPUTime +import Data.Maybe (isJust, fromJust) +import Data.Binary +-- Parallelism +import Control.Parallel.Strategies -------------------------------------------------------------------------------- -- Data set Info @@ -55,42 +76,50 @@ getClassSizes = map ((head *** id) . unzip) . groupBy gf . createGroundTruth where gf (name1, _key1) (name2, _key2) = name1 == name2 -writeGroundTruth :: [FilePath] -> FilePath -> IO () -writeGroundTruth files outfp = - writeFile outfp . Prelude.tail $ concatMap merge (createGroundTruth files) - where merge :: (String, String) -> String - merge (x,y) = '\n' : y ++ "\t" ++ x +writeGroundTruth :: FilePath -> FilePath -> IO () +writeGroundTruth infp outfp = + do files <- readDataDir infp + writeFile outfp . Prelude.tail $ concatMap merge (createGroundTruth files) + where merge :: (String, String) -> String + merge (x,y) = '\n' : y ++ "\t" ++ x -------------------------------------------------------------------------------- --- Symbolic IO +-- Symbolic Parsing IO -------------------------------------------------------------------------------- --- parses a string of chords s and returns a parse tree with the harmony structure -parseTree, parseTreeVerb :: String -> IO [Tree HAn] -parseTree s = do let (toks, _, ts, te, pe) = string2PieceCPostProc s - putStrLn ("parsed " ++ show (length toks) ++ " chords") - if not $ null te then showErrors "tokenizer: " te - else putStr "" - if not $ null pe then showErrors "parser: " pe - else putStr "" - return ts +-- parses a string of chords and returns a parse tree with the harmony structure +parseTree, parseTreeVerb :: (GTree g) => Grammar g -> [PPOption] -> String + -> IO (ParseResult g) +parseTree g opts s = + do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s + putStrLn ("parsed " ++ show (length tks) ++ " chords into " + ++ show n ++ " ambiguous trees") + if not $ null te then showErrors "tokenizer: " te + else putStr "" + if not $ null pe then showErrors "parser: " pe + else putStr "" + return pr -parseTreeVerb s = - do let (toks, _, ts, te, pe) = string2PieceCPostProc s - putStrLn ("parsed " ++ show (length toks) ++ " chords") - if not (null te) then mapM_ print te +parseTreeVerb g opts s = + do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s + putStrLn ("parsed " ++ show (length tks) ++ " chords into " + ++ show n ++ " ambiguous trees") + if not $ null te then mapM_ print te else putStr "" - if not (null pe) then mapM_ print pe + if not $ null pe then mapM_ print pe else putStr "" - return ts + return pr -- Batch analyzing a directory with chord sequence files with reduced output. -parseDir :: FilePath -> Maybe FilePath -> IO () -parseDir filepath bOut = getDirectoryContents filepath - >>= parseDir' bOut filepath . sort +parseDir :: (GTree g) + => Grammar g -> [PPOption] -> FilePath -> Maybe FilePath -> IO () +parseDir g opts filepath bOut = getDirectoryContents filepath + >>= parseDir' g opts bOut filepath . sort -parseDir' :: Maybe FilePath -> String -> [String] -> IO () -parseDir' bOut fp fs = +parseDir' :: (GTree g) + => Grammar g -> [PPOption] -> Maybe FilePath + -> String -> [String] -> IO () +parseDir' g opts bOut fp fs = do putStr "Filename\tNumber of trees\t" putStr "Insertions\tDeletions\tReplacements\tDeletions at the end\t" putStr "Tot_Correction\tNr_of_chords\t" @@ -98,8 +127,14 @@ let process :: FilePath -> FilePath -> IO ([ChordLabel],Tree HAn) process path x = do content <- readFile (path x) - let (tks, ps, ts, e1, e2) = string2PieceCPostProc content - t = seq (length ts) (return ()) + let (ParseResult _ tks ps ts nr e1 e2 _) + = postProc opts $ string2Piece g content + -- @Pedro: I think that the (length ts) only is here to + -- evaluate all trees right? Since the tree selection is now + -- incorporated in the postprocessing I replaced it with + -- length ps + -- t = seq (length ts) (return ()) + t = seq (length ps) (return ()) ErrorNrs i d e r = countErrors e2 errRat = errorRatio e2 tks nrOfChords = length tks -- (mergeDups toks) @@ -107,20 +142,196 @@ t t2 <- getCPUTime let diff = fromIntegral (t2 - t1) / (1000000000 :: Float) - when (not (null e1)) $ - putErrLn (show x ++ ": " ++ show e1) - printLn . concat $ intersperse "\t" [ x, show (length ps) + when (not $ null e1) $ putErrLn (show x ++ ": " ++ show e1) + printLn . concat $ intersperse "\t" [ x, show nr , show i, show d, show r, show e , show (i+d+e+r) , show nrOfChords, showFloat errRat , showFloat diff] - return (tks, head ts) + return (tks, ts) res <- mapM (process fp) (filter ((== ".txt") . takeExtension) fs) case bOut of Nothing -> return () Just bf -> encodeFile bf (unzip res :: ([[ChordLabel]],[Tree HAn])) - + -------------------------------------------------------------------------------- +-- Symbolic Matching IO +-------------------------------------------------------------------------------- + +data MatchMode = STDiff | LCES | HAnAlign | Align + deriving (Eq, Ord, Show) + +-- should return True if sim a b == sim b a and False otherwise +isSymmetrical :: MatchMode -> Bool +-- @pedro: I guess it is symmetrical, but I'm not 100% sure +isSymmetrical STDiff = False +isSymmetrical LCES = True +isSymmetrical HAnAlign = True +isSymmetrical Align = True + +-- matches a directory of chord description files +dirMatch :: (GTree g) + => Grammar g -> [PPOption] -> Maybe FilePath + -> MatchMode -> Maybe Float -> FilePath -> IO () +dirMatch g o bIn m me fp = + do fs <- readDataDir fp + let process s = let (ParseResult _ tks _ ts _nrts _ ePar _) + = postProc o $ string2Piece g s + in (tks, ts, errorRatio ePar tks) + filterError = if isJust me + then filter (\(_,_,e) -> e <= fromJust me) else id + pss <- mapM (\f -> readFile' (fp f)) fs + (tks, ps) <- case bIn of + Just bp -> decodeFile bp :: IO ([[ChordLabel]],[Tree HAn]) + Nothing -> let (toks, ps', _) = unzip3 (filterError + (map process pss)) + in return (toks, ps' `using` parList rdeepseq) + let fsQLab = labelQuery fs + -- print the ireval format ... + putStr "true\n" + if (m == LCES || m == HAnAlign || m == Align) + then putStr "false\n" else putStr "true\n" + mapM_ (putStr . (++ "\t"). getId) (fst . unzip $ filter snd fsQLab) + putChar '\n' + mapM_ (putStr . (++ "\t"). getId) fs + putChar '\n' + -- do the actual matching ... + let match :: (a -> a -> Float) -> [a] -> [([Float],Bool)] + match sim l = [ ([ calcSim sim x y i j + | (j,y) <- zip [0..] l], xIsQ) -- :: ([Float],Bool) + | (i,x,xIsQ) <- zip3 [0..] l (snd . unzip $ fsQLab)] + -- calculate the similarity sim a b, or, if calculated, look up sim b a + calcSim :: (a -> a -> Float) -> a -> a -> Int -> Int -> Float + calcSim sim x y i j = if isSymmetrical m && j < i + then (fst (simMat !! j)) !! i else sim x y + simMat, querySimMat :: [([Float],Bool)] + simMat = (case m of -- full n x n similarity matrix + STDiff -> match diffChordsLen tks + LCES -> error "disabled: fix me" + HAnAlign -> match getHAnDist ps + Align -> match (getAlignDist tempKeyC tempKeyC) tks + ) where tempKeyC = (Key (Note Nothing C) MajMode) + -- filter all non-queries, lazy evaluation should ensure the + -- non-queries will not be evaluated + querySimMat = (filter snd simMat) `using` parList rdeepseq + sequence_ [ printLine x | (x,_) <- querySimMat] + +printLine :: [Float] -> IO () +printLine l = printLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) + +-- labels (True/False) the songs that have multiple versions and are queries +labelQuery :: [FilePath] -> [(FilePath, Bool)] +labelQuery l = let cs = getClassSizes l in + map (\x -> (x,(>1) . length . fromJust $ lookup (getTitle x) cs)) l + + +#ifdef AUDIO +-------------------------------------------------------------------------------- +-- Audio Data IO +-------------------------------------------------------------------------------- + +-- the strings that build up a data file +vampStr, keyStr, chromaStr, beatStr :: String +chromaStr = "nnls-chroma_nnls-chroma_bothchroma" +keyStr = "qm-vamp-plugins_qm-keydetector_keystrength" +beatStr = "qm-vamp-plugins_qm-tempotracker_beats" +vampStr ="(^.+)_vamp_("++ chromaStr ++ '|' : keyStr ++ '|' : beatStr + ++ ").csv$" + +parseAnnotation :: GTree g => Grammar g -> FilePath -> FilePath + -> IO (ParseResult g) +parseAnnotation g fpkey fpann + = do key <- readFile fpkey + ann <- readFile fpann + return $ gt2Piece g key ann + +-- reads an annotation +readAnnotation :: FilePath -> IO ChordAnnotation +readAnnotation fp = do f <- readFile fp + return (parseData parseAnnotationData f) + +-- maps readAudioFeat over a directory +readAudioFeatureDir :: FilePath -> IO [Maybe AudioFeat] +readAudioFeatureDir fp = + do fs <- getDirectoryContents fp + mapM (readAudioFeat fp) + (group . sort $ filter (\x -> takeExtension x == ".csv") fs) + where + group :: [FilePath] -> [(FilePath, FilePath, FilePath)] + group (c:k:b:fs) = (c,b,k) : group fs + group [] =[] + group _ = error ("the number of files in the filepath " + ++ "cannot be divided by 3") + +-- given a base file path and a triple of three filenames describing +-- a chroma, beat and key file, parses all data and returns an audioFeat +-- if everything went well. +readAudioFeat :: FilePath -> (FilePath, FilePath, FilePath) + -> IO (Maybe AudioFeat) +readAudioFeat baseURI (chroma, beat, key) = + -- get the part of the filenames before _vamp_ and use it as ID + let (idStr:ids) = map ((maybe "" head) . regexMatchGroups vampStr) + [chroma,beat,key] in + if all (idStr ==) ids then do -- if the IDs are the same then proceed + dChroma <- readFile (baseURI chroma) + dBeat <- readFile (baseURI beat) + dKey <- readFile (baseURI key) + return . Just $ AudioFeat idStr + (parseData parseChordinoData dChroma) + (parseData parseBeatData dBeat) + (parseData parseKeyStrengthData dKey) + else do putStrLn ("found non-matching set of audiofeatures with ids " + ++ show ids) + return Nothing + +{- | evaluluates a single labeling of a piece with a ground truth annotation +visually: +time match GT MPTREE +0.0 True NNone NNone +0.2 True EMaj EMaj +... etc. +The argurments need some explanation: the first argurment should be +the filepath to one of the data files (there must be three, a chroma, a +beat and a key file, to create an AudioFeat), but without all text after +"_vamp_" e.g. for reading file1_vamp_nnls-chroma_nnls-chroma_bothchroma.csv +only file1 should be presented. The function below will now read all +three data files in by adding chromaStr, beatStr and keyStr, respectively +the second file path should just point at the ground truth annotation +-} +evaluateLabeling :: FilePath -> FilePath -> IO Double +evaluateLabeling gtfp audiofp = do + let (path, file) = splitFileName audiofp + files = ((file ++ chromaStr <.> "csv"),(file ++ beatStr <.> "csv"), (file ++ keyStr <.> "csv")) + gt <- readAnnotation gtfp + (Just af) <- readAudioFeat path files + -- mapM print gt + -- let test = (processAudioFeat simpleAnnotator af) + -- mapM print test + putStrLn "time\tmatch\tGT\tMPTREE" + printRelCorrectOverlap simpleAnnotator af gt + +-- given a ground truth directory and an data directory (containing exactly +-- 3 times as much files as the gt directory) all files will be labeled and +-- the relative correct overlap wil be corrected an presented to the user +batchLabeling :: FilePath -> FilePath -> IO () -- [Double] +batchLabeling gtfp audiofp = do + gt <- getDirectoryContents gtfp + af <- readAudioFeatureDir audiofp + rco <- zipWithM printEval (sort $ filter ((== ".lab") . takeExtension ) gt) af + putStrLn ("average: " ++ show (sum rco / genericLength rco)) + where + printEval :: FilePath -> Maybe AudioFeat -> IO Double + printEval _ Nothing = error "printEval: Nothing" + printEval fp (Just af) = do + gt <- readAnnotation (gtfp fp) + -- let test = processAudioFeat (harmonyAnnotator (getKey af)) af + let test = processAudioFeat simpleAnnotator af + result = relCorrectOverlap gt test + putStrLn (fp ++ ':' : show af ++ ' ' : show result) + return result +#endif + +-------------------------------------------------------------------------------- -- Utils -------------------------------------------------------------------------------- putErrLn :: String -> IO() @@ -156,8 +367,4 @@ -- | Shows a Float with 5 decimal places showFloat :: Float -> String -showFloat = printf "%.6f" ---showFloat = show . (/ (1000 :: Float)) . fromIntegral - -- . (round :: Float -> Int) . (* 1000) - - +showFloat = printf "%.6f" diff --git a/src/HarmTrace/IO/PrintTree.hs b/src/HarmTrace/IO/PrintTree.hs --- a/src/HarmTrace/IO/PrintTree.hs +++ b/src/HarmTrace/IO/PrintTree.hs @@ -12,7 +12,7 @@ -- or http://gnuwin32.sourceforge.net/packages/wget.htm printTreeHAn :: Tree HAn -> FilePath -> IO ExitCode -printTreeHAn t o = printTree (show t) o +printTreeHAn t o = printTree (show t) (o ++ ".png") printTreeHAnF :: [Tree HAn] -> String -> IO ExitCode printTreeHAnF ts o = printTreeF (map show ts) o diff --git a/src/HarmTrace/Matching/Alignment.hs b/src/HarmTrace/Matching/Alignment.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Matching/Alignment.hs @@ -0,0 +1,179 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +-- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $ +module HarmTrace.Matching.Alignment ( alignChordLab, pPrintV, getAlignDist + , getHAnDist, alignHAnChord + -- , getDownRight, wbMatchF, align, Sim(..) + -- , collectMatch + ) where + +import HarmTrace.Base.MusicRep +import HarmTrace.Matching.SimpleChord +import HarmTrace.Matching.HChord +import HarmTrace.Matching.Sim +import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.Tree + +import Prelude hiding (map, length, head, last, mapM_, max) + +import Data.Vector hiding ((!), (++)) +import qualified Data.List as L + +-- import Debug.Trace +{- + +Matching notes: +=============== +** Normalisation ( sim * sim ) / (maxsim a * maxsim b) helps in practically + all cases. +** The sampling in general has a large effect on matching speed, and a small + effect on retrieval performance. In all observed cases using no sampling + performs (slightly) better than not using sampling. The sample rate herein + also has an effect: using normal integer division (`div`) deletes chords + with a beat length of 1, which decreases retrieval performance. It is + better to use a `div1` that also includes the chords with a duration of + beat (see SimpleChord.myDiv) +** The mis-match penalty should be -2 > -1 < 0: -1 seems to be optimal + (= insertion/deletion) +** Use very "conservative" similarity measures (not many things are similar) +** Using a ChordType instead of just major/minor improves results +** Using the HAnTrans information improves the similarity estimation +** using only the information of the model (HAnTrans and HAnFunc) performs + worse than using the root and chord type +** Separating transformations (HAnTrans), i.e. Tritone substitutions, dimchord + transformations etc., from preparations (HAnPrep), i.e. secondary dominants, + diatonic chains etc., improves results. This is probably due to that + previously a transformation could "override" a preparations because only + one HAnTrans node was stored (the lowest one in the tree). +** adding similarity between various different preparations DiatV == SecDom + improves similarity. This makes sense because both involve fifth jumps + +-} + +-------------------------------------------------------------------------------- +-- Baseline chord label alignment (no model) +-------------------------------------------------------------------------------- + +-- returns a similarity/distance value +getAlignDist :: Key -> Key -> [ChordLabel] -> [ChordLabel] -> Float +getAlignDist ka kb ta tb = let (_match, dist, _tab) = alignChordLab ka kb ta tb + in dist + + +alignChordLab :: Key -> Key -> [ChordLabel] -> [ChordLabel] + -> ([SimChord], Float, Vector (Vector Int)) +alignChordLab ka kb ta tb = (fst $ matchToSeq match ta' tb', dis, tab) where + (match, weight, tab) = --trace ("ta: " ++ show ta'++ "\ntb: "++ show tb') + align (-2) ta' tb' + dis = fromIntegral (weight * weight) + / fromIntegral (maxSim ta' * maxSim tb') + ta' = L.concatMap (toSimChords . toChordDegree ka) ta + tb' = L.concatMap (toSimChords . toChordDegree kb) tb + +-------------------------------------------------------------------------------- +-- HAn Chord alignment +-------------------------------------------------------------------------------- + +-- returns a similarity/distance value +getHAnDist :: Tree HAn -> Tree HAn -> Float +getHAnDist ta tb = let (_match, dist, _tab) = alignHAnChord ta tb in dist + +alignHAnChord :: Tree HAn -> Tree HAn -> ([HChord], Float, Vector (Vector Int)) +alignHAnChord ta tb = + -- trace ("ta: " ++ show ta'++ "\ntb: "++ show tb' ++ "\nsim: "++ show dis) + (fst $ matchToSeq match ta' tb', dis, tab) where + (match, weight, tab) = align (-2) ta' tb' + dis = fromIntegral (weight * weight) + / fromIntegral (maxSim ta' * maxSim tb') + ta' = toHChords ta + tb' = toHChords tb + +-- creates an alignment and returns the list of matches, the distance, and +-- the alignment table. The first argument is the insertion/deletion +-- penalty (should be a negative value). +align :: Sim a => Int -> [a] -> [a] -> ([(Int,Int)], Int, Vector (Vector Int)) +align _ _ [] = ([],0,empty) +align _ [] _ = ([],0,empty) +align inDel a b = (cm, getDownRight t,t) where + t = wbMatchF inDel a b + cm = toList (collectMatch t) + +wbMatchF :: Sim a => Int -> [a] -> [a] -> Vector (Vector Int) +wbMatchF _ _ [] = empty +wbMatchF _ [] _ = empty +wbMatchF inDel a' b' = m where + a = fromList a' + b = fromList b' + match, fill :: Int -> Int -> Int + {-# INLINE fill #-} + match i j = sim (a ! i) (b ! j) + -- this is the actual core recursive definintion of the algorithm + fill 0 0 = max (match 0 0) 0 + fill 0 j = max0 (((m ! 0 ) !(j-1)) + inDel) (match 0 j) + fill i 0 = max0 (((m !(i-1)) ! 0 ) + inDel) (match i 0) + fill i j = max3 (((m !(i-1)) ! j ) + inDel) + (((m !(i-1)) !(j-1)) + match i j) + (((m ! i) !(j-1)) + inDel) + m = generate (length a) (generate (length b) . fill) + + +-------------------------------------------------------------------------------- +-- Getting the alignment out of the table +-------------------------------------------------------------------------------- + +collectMatch :: Vector (Vector Int) -> Vector (Int,Int) +collectMatch a = fromList $ collect a (length a -1, length (head a) -1) [] +collect :: (Ord b, Num b) => Vector (Vector b) -> (Int, Int) -> [(Int, Int)] + -> [(Int, Int)] +collect a c@(0,0) m = if (a!0)!0 > 0 then c : m else m +collect a c@(i,0) m = if (a!i)!0 > (a!(i-1))! 0 + then c : m else collect a (i-1,0) m +collect a c@(0,j) m = if (a!0)!j > (a!0 )!(j-1) + then c : m else collect a (0,j-1) m +collect a c@(i,j) m + | (a ! i) ! j > snd o = collect a (fst o) (c : m) + | otherwise = collect a (fst o) m where + o = realMax3 ((i-1,j) , (a !(i-1)) ! j ) + ((i-1,j-1), (a !(i-1)) !(j-1)) + ((i,j-1) , (a ! i ) !(j-1)) + +realMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) +realMax3 w nw n = maxByWeight nw (maxByWeight w n) where + maxByWeight :: Ord a => (t,a) -> (t,a) -> (t,a) + maxByWeight a@(_,wa) b@(_,wb) = if wa > wb then a else b + +-------------------------------------------------------------------------------- +-- Some LCES helper functions +-------------------------------------------------------------------------------- + +matchToSeq :: [(Int,Int)] -> [a] -> [a] -> ([a],[a]) +matchToSeq mat aOrg bOrg = (f aMat aOrg, f bMat bOrg) where + f m o = fst . L.unzip $ L.filter (\(_,x) -> x `L.elem` m) (L.zip o [0..]) + (aMat, bMat) = L.unzip mat + +(!) :: Vector a -> Int -> a +{-# INLINE (!) #-} +(!) = unsafeIndex + +max3 :: (Ord a, Num a) => a -> a -> a -> a +{-# INLINE max3 #-} +max3 a b c = max a (max0 b c) + +max0 :: (Ord a, Num a) => a -> a -> a +{-# INLINE max0 #-} +max0 a b = max a (max b 0) +-- max3' w nw n = if n > nw then n else max nw w -- not correct yet + +max :: (Ord a, Num a) => a -> a -> a +{-# INLINE max #-} +max x y = if x <= y then y else x + +getDownRight :: Vector (Vector a) -> a +getDownRight n = last (last n) + +-- pretty prints a 2 dimensional vector in a readable format +pPrintV :: Show a => Vector (Vector a) -> IO () +pPrintV = mapM_ printLn where + printLn :: Show a => Vector a -> IO() + printLn v = do mapM_ (\x -> putStr (show x ++ " ")) v ; putChar '\n' + diff --git a/src/HarmTrace/Matching/AlignmentFaster.hs b/src/HarmTrace/Matching/AlignmentFaster.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Matching/AlignmentFaster.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} + +-- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $ +module HarmTrace.Matching.AlignmentFaster ( getAlignDist + -- , wbMatchF, align, SimInt (..) + ) where + +import HarmTrace.Base.MusicRep +import HarmTrace.Matching.SimpleChord + +import Prelude hiding (map, length, head, last, (!!), max) + +import Data.Vector hiding ((!)) +-- import qualified Data.Vector.Unboxed as U +import qualified Data.List as L + +-- import Debug.Trace +-------------------------------------------------------------------------------- +-- Parameters +-------------------------------------------------------------------------------- + +inDel :: Int +inDel = -1 + +-------------------------------------------------------------------------------- +-- Matching +-------------------------------------------------------------------------------- + +-- returns a similarity value +getAlignDist :: Key -> Key -> [ChordLabel] -> [ChordLabel] -> Float +getAlignDist ka kb ta tb = fromIntegral weight where + (_match,weight) = align ta' tb' + ta' = L.concatMap (toSimChords . toChordDegree ka) ta + tb' = L.concatMap (toSimChords . toChordDegree kb) tb + +align :: SimInt a=> [a] -> [a] -> ([a], Int) +align _ [] = ([],0) +align [] _ = ([],0) +align a b = ([], last t) where + t = wbMatchF a b + +wbMatchF :: SimInt a => [a] -> [a] -> Vector Int +wbMatchF _ [] = empty +wbMatchF [] _ = empty +wbMatchF a' b' = m where + a = fromList a' + b = fromList b' + cols = length b + toij :: Int -> (Int,Int) + {-# INLINE toij #-} + toij x = let i = x `div` cols in (i, x - (i*cols)) + (!!) :: Vector Int -> (Int,Int) -> Int + {-# INLINE (!!) #-} + (!!) v (i,j) = v `unsafeIndex` ((i * cols) + j) + match :: Int -> Int -> Int + {-# INLINE match #-} + match i j = simInt (a ! i) (b ! j) + -- fil c = let f = fill c in trace ("c: " L.++ show c L.++ " val: " L.++ show f) f + -- this is the actual core recursive definintion of the algorithm + fill :: (Int,Int) -> Int + {-# INLINE fill #-} + fill (0,0) = max (match 0 0) 0 + fill (0,j) = max0 ((m !!(0 ,j-1)) + inDel) (match 0 j) + fill (i,0) = max0 ((m !!(i-1,0 )) + inDel) (match i 0) + fill (i,j) = max3 ((m !!(i-1,j )) + inDel) + ((m !!(i-1,j-1)) + match i j) + ((m !!(i ,j-1)) + inDel) + m = generate ((length a) * (length b)) (fill . toij) + +(!) :: Vector a -> Int -> a +{-# INLINE (!) #-} +(!) = unsafeIndex + +max3 :: (Ord a, Num a) => a -> a -> a -> a +{-# INLINE max3 #-} +max3 a b c = max a (max0 b c) + +max0 :: (Ord a, Num a) => a -> a -> a +{-# INLINE max0 #-} +max0 a b = max a (max b 0) + +max :: (Ord a, Num a) => a -> a -> a +{-# INLINE max #-} +max x y = if x <= y then y else x + + diff --git a/src/HarmTrace/Matching/GuptaNishimura.hs b/src/HarmTrace/Matching/GuptaNishimura.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Matching/GuptaNishimura.hs @@ -0,0 +1,146 @@ +{-# OPTIONS_GHC -Wall #-} +-- $Id: GuptaNishimura.hs 1260 2011-06-14 15:18:21Z bash $ +module HarmTrace.Matching.GuptaNishimura where + +-------------------------------------------------------------------------------- +-- Finding the Largest Common Embedable Subtrees (LCES) +-- Based on: Gupta, A. and Nishimura, N. (1998) Finding largest subtrees and +-- smallest supertrees, Algorithmica, 21(2), p. 183--210 +-- author: Bas de Haas +-------------------------------------------------------------------------------- + +import Data.Ord +import Data.Maybe +import Data.Array +import Data.List + +import HarmTrace.Matching.Tree + +-------------------------------------------------------------------------------- +-- Top Level LCES function +-------------------------------------------------------------------------------- + +-- Top level function that returns the largest common embedable subtree +-- of two trees +getLCES :: (Eq t) => Tree t -> Tree t -> [Tree t] +getLCES ta tb = matchToTree ta (map fst (reverse m)) where + n = lces ta tb + (m,_) = n!b + (_,b) = bounds n + +-- calculates the largest labeled common embeddable subtree +lces :: (Eq t) => Tree t -> Tree t -> Array (Int, Int) ([(Int,Int)], Int) +lces ta tb = n where + la = size ta-1 + lb = size tb-1 + a = listArray (0,la) (pot ta) + b = listArray (0,lb) (pot tb) + maxi :: Int -> [Int] -> ([(Int,Int)],Int) + maxi _ [] = ([],0) + maxi i cb = {-# SCC "maxi_lces" #-}n!(i,maximumBy (comparing (\j -> getWeight $ n!(i,j))) cb ) + maxj :: [Int] -> Int -> ([(Int,Int)],Int) + maxj [] _ = ([],0) + maxj ca j = {-# SCC "maxi_lces" #-}n!( maximumBy (comparing (\i -> getWeight $ n!(i,j))) ca,j) + recur i j = findBestMatch (getLabel (a!i) == getLabel (b!j))i j mc mi mj where + mi = maxi i (getChildPns (b!j)) + mj = maxj (getChildPns (a!i)) j + mc = wbMatch (getChild (a!i)) (getChild $ b!j) n + n = array ((0,0), (la, lb)) + (((0,0), if getLabel (a!0)==getLabel (b!0) then ([(0,0)],1) else ([],0)) : + [((0,j), recur 0 j) | j <- [1..lb]] ++ + [((i,0), recur i 0) | i <- [1..la]] ++ + [((i,j), recur i j) | i <- [1..la], j <- [1..lb]]) + +-- returns the best matching candidate, given the previous candidates, the +-- bipartite matching. The function depends on wheter the currend nodes +-- match and wether, in that case, on of the current nodes is not allready +-- matched +findBestMatch :: Bool -> Int -> Int -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) + -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) +findBestMatch match i j a b c + | not match = first + | otherwise = if isFree first i j then ((i,j):mf,wf+1) --add match + else if wf /= ws then first + else if isFree second i j then ((i,j):ms,ws+1) + else if wf /= wt then first + else if isFree second i j then ((i,j):mt,wt+1) + else first where + (first@(mf,wf) : second@(ms,ws) : (mt,wt) : []) = + {- SCC sorting -} reverse $ sortBy (comparing getWeight) [a,b,c] + + +-------------------------------------------------------------------------------- +-- Weighted Plannar Matching of a Bipartite Graph +-------------------------------------------------------------------------------- + +-- selects the most lower right cell in the wbMatch' matrix +wbMatch :: (Eq t) => [Tree t] -> [Tree t] + -> Array (Int, Int) ([(Int, Int)], Int) -> ([(Int, Int)], Int) +wbMatch _ [] _ = ([],0) +wbMatch [] _ _ = ([],0) +wbMatch a b n = getDownRight $ wbMatch' a b n + + +-- returns the actual planar weighted bipartite matchings. n should contain +-- the weights of the edge between a[i] and b[j] +wbMatch' :: (Eq t) => [Tree t] -> [Tree t] + -> Array (Int, Int) ([(Int,Int)], Int) + -> Array (Int, Int) ([(Int,Int)], Int) +wbMatch' _ [] _ = {-# SCC "listArrayA" #-} listArray ((0,0),(0,0)) [] +wbMatch' [] _ _ = {-# SCC "listArrayB" #-} listArray ((0,0),(0,0)) [] +wbMatch' a b n = m where + la = length a-1 + lb = length b-1 + -- returns a previously matched subtree + subTree :: Int -> Int -> ([(Int,Int)], Int) + subTree i j = n ! (fromJust . getPn $ a!!i, fromJust . getPn $ b!!j) + -- this is the actual core recursive definintion of the algorithm + match :: Int -> Int -> ([(Int,Int)], Int) + match i j = maximumBy (comparing getWeight) [maxPrv, minPrv, diagM] where + s@(_mat,w) = subTree i j + hasMatch = w > 0 + maxPrv = if not hasMatch then m!(i-1,j) + else if isFree (m!(i-1,j)) i j then merge s (m!(i-1,j)) + else m!(i-1,j) + minPrv = if not hasMatch then m!(i,j-1) + else if isFree (m!(i,j-1)) i j then merge s (m!(i,j-1)) + else m!(i,j-1) + diagM = merge s (m!(i-1,j-1)) + m = array ((0,0),(la,lb)) + (((0,0), subTree 0 0) : + [((0,j), if getWeight (subTree 0 j) > getWeight (m!(0,j-1)) + then subTree 0 j else m!(0,j-1)) | j <- [1..lb]] ++ + [((i,0), if getWeight (subTree i 0) > getWeight (m!(i-1,0)) + then subTree i 0 else m!(i-1,0)) | i <- [1..la]] ++ + [((i,j), match i j) | i <- [1..la], j <- [1..lb]]) + + +-------------------------------------------------------------------------------- +-- Some LCES helper functions +-------------------------------------------------------------------------------- +getDownRight :: (Ix i) => Array i e -> e +getDownRight n = n ! snd (bounds n) + +-- returns the weight of a match and is synonymous to snd +getWeight :: (a, b) -> b +getWeight (_,w) = w + +-- returns the list with matches and is synonymous to fst +getMatch :: ([a], b) -> [a] +getMatch (m,_) = m + +-- checks if the previously calculated optimal solution does not +-- contain the indices i and j in a and b, resepectivly +isFree :: ([(Int,Int)], Int) -> Int -> Int -> Bool +isFree ([],_) _ _ = True +isFree ((previ, prevj):_,_) i j = ( i > previ && j > prevj) + +-- mergest two lists with matches +merge :: ([a], Int) -> ([a], Int) -> ([a], Int) +merge (a, wa) (b, wb) = (a ++ b, wa + wb) + +-- adds a match to a list of matches +-- addMatch :: (Int, Int) -> ([(Int, Int)], Int) -> ([(Int, Int)], Int) +-- addMatch (i,j) (a, w)= ((i,j):a, w+1) + + diff --git a/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs b/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs --- a/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs +++ b/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs @@ -29,7 +29,7 @@ getLCES ta tb = fst (getWeightLCES ta tb) getSimLCES :: (Sim t, Eq t) => Tree t -> Tree t -> Float -getSimLCES ta tb = (weight * weight) / (selfSim ta * selfSim tb) where +getSimLCES ta tb = (weight * weight) / (maxSim ta * maxSim tb) where (_lces, weight) = getWeightLCES ta tb diff --git a/src/HarmTrace/Matching/HChord.hs b/src/HarmTrace/Matching/HChord.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Matching/HChord.hs @@ -0,0 +1,51 @@ +module HarmTrace.Matching.HChord (HChord, Sim, toHChords) where + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens +import HarmTrace.Matching.Sim +import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.Tree + +-- represents a very simple chord, only major and minor and a root scaledegree +data HChord = HChord { deg :: !Int -- I = 0, IIb = 1 ... VII = 11 + , clss :: !ClassType -- MajClass | MinClass | DomClass | .. + , func :: !HFunc + , prep :: !Prep + , trns :: !Trans} + +instance Sim HChord where + {-# INLINE sim #-} + sim (HChord r ct _fc pr tr) (HChord r2 ct2 _fc2 pr2 tr2) + | r == r2 && ct == ct2 = 2 + sim pr pr2 + sim tr tr2 + | otherwise = -1 + +instance Show HChord where + show (HChord r ct fc pr tr) = show fc ++ ':' : show pr ++ ':' : show tr + ++ ':' : show (scaleDegrees !! r) ++ show ct + +toHChords :: Tree HAn -> [HChord] +toHChords t = getHAn undefinedHChord t + +-- getHAn also samples/replicates the chords based on their duration in beats +getHAn :: HChord -> Tree HAn -> [HChord] +getHAn c (Node h@(HAnChord ct) [] _) -- there might be inserted chords + | null (chords ct) = [] -- ignore them in the matching process + | otherwise = let c' = update c h + -- ignore func when the chord is deleted + c'' = if status ct == Deleted + then c' { trns = NoTrans } else c' + in replicate (dur ct) c'' + -- in replicate ((dur ct) `div1` 2) c'' +getHAn c (Node h cs _) = let c' = update c h in concatMap (getHAn c') cs + +update :: HChord -> HAn -> HChord +update hc (HAn _ _) = hc +update hc (HAnFunc f) = hc { func = f } +update hc (HAnTrans t) = hc { trns = t } +update hc (HAnPrep p) = hc { prep = p } +update hc (HAnChord c) = hc { deg = diaDegToSemi $ root c + , clss = classType c } + +undefinedHChord :: HChord +undefinedHChord = HChord (-1 :: Int) (MajClass :: ClassType) + (P :: HFunc) NoPrep NoTrans diff --git a/src/HarmTrace/Matching/Matching.hs b/src/HarmTrace/Matching/Matching.hs --- a/src/HarmTrace/Matching/Matching.hs +++ b/src/HarmTrace/Matching/Matching.hs @@ -1,145 +1,130 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $ -module HarmTrace.Matching.Matching (getSimMatch, getMatch, filterTrans - , collectMChord, printBPM, MatchChord (..)) where +module HarmTrace.Matching.Matching (getMatch, printBPM + , getDownRight, wbMatch, wbMatchF + , collectMatch, align, getWeightMatch + ) where import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens -import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.HAn import HarmTrace.Matching.Sim +import HarmTrace.HAnTree.HAn -import Data.Maybe import Data.Array -import Data.Ord -import Data.List (maximumBy) +import Debug.Trace -------------------------------------------------------------------------------- +-- Parameters +-------------------------------------------------------------------------------- + +inDel, matchW :: Float +inDel = -1 +matchW = 4 + +max3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) +max3 = lazyMax3 +-------------------------------------------------------------------------------- -- Matching -------------------------------------------------------------------------------- --- Top level functions: - -- prints a match -printBPM :: Int -> Tree HAn -> Tree HAn -> IO() -printBPM sampRate t1' t2' = putStrLn ("score: " ++ show simVal ++ '\n' : +printBPM :: [ChordLabel] -> [ChordLabel] -> IO() +printBPM t1' t2' = putStrLn ("score: " ++ show simVal ++ '\n' : "self sim 1: "++ show (maxSim t1) ++ '\n' : "self sim 2: "++ show (maxSim t2) ++ '\n' : - align t1 t2 (reverse match)) where - t1 = collectMChord sampRate t1' - t2 = collectMChord sampRate t2' - (match, simVal) = getDownRight $ wbMatch t1 t2 - align :: [MatchChord] -> [MatchChord] -> [(Int, Int)] -> [Char] - align a@(ha:ta) b@(hb:tb) m@((ma,mb):ms) + algn t1 t2 (reverse match)) where + -- hardcode C major for now ... + t1 = map (toChordDegree (Key (Note Nothing C) MajMode)) t1' + t2 = map (toChordDegree (Key (Note Nothing C) MajMode)) t2' + -- (match, simVal) = getDownRight $ wbMatch t1 t2 + tab = trace (show t1 ++"\n" ++ show t2) (wbMatchF t1 t2) + simVal = getDownRight $ tab + match = collectMatch tab + -- algn :: Sim a => [a] -> [a] -> [(Int, Int)] -> [Char] + algn a@(ha:ta) b@(hb:tb) m@((ma,mb):ms) | matcha && matchb = show ha ++ "\t** " ++ (show $ sim ha hb) ++ - " **\t" ++ show hb ++ '\n':(align ta tb ms) - | matcha = " \t\t" ++ show hb ++ '\n':(align a tb m) - | matchb = show ha ++ '\n' :(align ta b m) - | otherwise = show ha ++ "\t\t" ++ show hb ++ '\n' :(align ta tb m) - where matcha = (mgetLoc ha) == ma - matchb = (mgetLoc hb) == mb - align _ _ _ = "" + " **\t" ++ show hb ++ '\n':(algn ta tb ms) + | matcha = " \t\t" ++ show hb ++ '\n':(algn a tb m) + | matchb = show ha ++ '\n' :(algn ta b m) + | otherwise = show ha ++ "\t\t" ++ show hb ++ '\n' :(algn ta tb m) + where matcha = (getLoc ha) == ma + matchb = (getLoc hb) == mb + algn _ _ _ = "" --- returns a list of matched chords -getSimMatch :: Int -> Tree HAn -> Tree HAn -> [MatchChord] -getSimMatch sr ta tb = fst $ getWeightMatch - (collectMChord sr ta) (collectMChord sr tb) -- returns a similarity value -getMatch :: Int -> Tree HAn -> Tree HAn -> Float -getMatch sampleRate ta' tb' = (weight * weight) / (maxSim ta * maxSim tb) where - (_match,weight) = getWeightMatch ta tb - ta = (collectMChord sampleRate ta') - tb = (collectMChord sampleRate tb') - --- first argument is the sample rate, second argument is the parse tree -collectMChord :: Int -> Tree HAn -> [MatchChord] -collectMChord sr ts = number $ collectMChord' - (undefined :: HFunc) NoTrans ts where - collectMChord' :: HFunc -> Trans -> Tree HAn -> [MatchChord] - collectMChord' f t (Node (HAnChord ct) _ _) = - convChord sr f (filterTrans t) ct -- sample rate s - collectMChord' _f t (Node (HAnFunc hf) cs _) = - concatMap (collectMChord' hf t) cs - collectMChord' f t (Node (HAnTrans ht) (c:cs) _) = - collectMChord' f ht c ++ concatMap (collectMChord' f t) cs - collectMChord' f t (Node _ cs _) = - concatMap (collectMChord' f t) cs - -- the first argument r (Int) is the sample rate in beats. If it is set to one - -- every beat is expanded to a chord. - convChord :: Int -> HFunc -> Trans -> ChordToken -> [MatchChord] - convChord r f t (ChordToken rt ct chds s _loc _dur) = - concatMap convert chds where - convert :: ChordLabel -> [MatchChord] - convert (Chord _ sh ad l d) - |d == 1 = [MChord rt sh ct ad s l 1 f t] - |otherwise = replicate (round (fromIntegral d / fromIntegral r :: Float)) - (MChord rt sh ct ad s l r f t) - - number :: [MatchChord] -> [MatchChord] - number t = number' t 0 - number' :: [MatchChord] -> Int -> [MatchChord] - number' [] _ = [] - number' (MChord rt sh ct ad s _loc d f t: ns) ix = - (MChord rt sh ct ad s ix d f t) : number' ns (ix+1) - -filterTrans :: Trans -> Trans -filterTrans s@(SecDom _ _) = s -filterTrans s@(SecMin _ _) = s -filterTrans s@(DiatDom _ _) = s -filterTrans s@(DimTrit _ _) = s -filterTrans _ = NoTrans - -data MatchChord = MChord { _mchordRoot :: ScaleDegree - , _mchordShorthand :: Shorthand - , _mclassType :: ClassType - , _mchordAdditions :: [Addition] - , _mstatus :: ParseStatus - , mgetLoc :: Int -- the index of the chord - , mduration :: Int -- in the list of tokens - , _hfunc :: HFunc - , _trans :: Trans - } - -instance Show MatchChord where - show (MChord rt sh _clss _add _stat lc dr f t ) = - show f ++ ':' : show t ++ ':' : show rt ++ ':' : show sh - ++ '-' : show lc ++ ':' : show dr - -instance Sim MatchChord where - sim (MChord rt _sh clss _add _stat _loc dur1 _fnc _trns ) - (MChord rt2 _sh2 clss2 _add2 _stat2 _loc2 dur2 _fnc2 _trns2) - = (mChord) * (fromIntegral $ min dur1 dur2) where - {- mFnc = if fnc == fnc2 then 0.15 else 0.0 - mTrns = if stat /= Deleted && stat2 /= Deleted - && trns == trns2 && trns /= NoTrans then 0.25 else 0.0 -} - mChord = if rt == rt2 && clss == clss2 then 1.0 else 0.0 - -- mDel = if isNotDel && mChord > 0 then 0.1 else 0.0 - -- mSh = if mChord > 0 && sh == sh2 then 0.1 else 0.0 - --mStat = if stat == stat2 && then 0.05 else 0.0 - --isNotDel = stat /= Deleted && stat2 /= Deleted - -- d = fromIntegral $ min dur1 dur2 - -maxSim :: [MatchChord] -> Float -maxSim = foldr (\a b -> sim a a + b) 0 - - - +getMatch :: Key -> [ChordLabel] -> [ChordLabel] -> Float +getMatch key ta tb = (weight * weight) / + (maxSim ta' * maxSim tb' * matchW * matchW) where + -- (_match,weight) = getWeightMatch ta' tb' + (_match,weight) = align ta' tb' + ta' = map (toChordDegree key) ta + tb' = map (toChordDegree key) tb + -- selects the most lower right cell in the wbMatch' matrix -getWeightMatch :: [MatchChord] -> [MatchChord] -> ([MatchChord], Float) +getWeightMatch :: (Sim a, GetDur a) => [a] -> [a] -> ([a], Float) getWeightMatch _ [] = ([],0) getWeightMatch [] _ = ([],0) getWeightMatch a b = (result,simVal) where (match, simVal) = getDownRight $ wbMatch a b + result = snd . unzip $ filter (\x -> fst x `elem` mfst) (zip [0..] a) mfst = reverse $ map fst match - result = catMaybes $ map f a - f x - | (mgetLoc x) `elem` mfst = Just x - | otherwise = Nothing +align :: (Sim a, GetDur a) => [a] -> [a] -> ([a], Float) +align _ [] = ([],0.0) +align [] _ = ([],0.0) +align a b = (m, getDownRight t) where + t = wbMatchF a b + cm = (map fst $ collectMatch t) + m = fst . unzip $ filter (\(_,x) -> x `elem` cm) (zip a [0..]) + +wbMatchF :: (Sim a, GetDur a) => [a] -> [a] -> Array (Int, Int) (Float) +wbMatchF _ [] = listArray ((0,0),(0,0)) (repeat 0.0) +wbMatchF [] _ = listArray ((0,0),(0,0)) (repeat 0.0) +wbMatchF a' b' = m where + la = length a'-1 + lb = length b'-1 + a = listArray (0,la) a' -- we need random access and therefore + b = listArray (0,lb) b' -- convert the lists to arrays + dura = listArray (0,la) (map (fromIntegral . getDur) a') + durb = listArray (0,lb) (map (fromIntegral . getDur) b') + match :: Int -> Int -> Float + match i j = let s' = 2 * matchW * sim (a!i) (b!j) in + if s' > 0 then s' else inDel * (min (dura!i) (durb!j)) -- durWeight + -- inDelj = inDel * (fromIntegral $ getDur (b!j)) + -- this is the actual core recursive definintion of the algorithm + recur i j = max3'(m!(i-1,j) + inDel * (dura!i)) + (m!(i-1,j-1) + match i j) + (m!(i,j-1) + inDel * (durb!j)) + m = array ((0,0),(la,lb)) + (((0,0), max (match 0 0) 0) : + [((0,j), max0 (m!(0,j-1) + inDel * (durb!j)) (match 0 j)) | j <- [1..lb]] ++ + [((i,0), max0 (m!(i-1,0) + inDel * (dura!i)) (match i 0)) | i <- [1..la]] ++ + [((i,j), recur i j) | i <- [1..la], j <- [1..lb]]) -wbMatch :: Sim a => [a] -> [a] -> Array (Int, Int) ([(Int, Int)], Float) +max3' :: (Ord a, Num a) => a -> a -> a -> a +max3' a b c = max a (max0 b c) +-- max3' w nw n = if n > nw then n else max0 nw w -- not correct yet + +max0 :: (Ord a, Num a) => a -> a -> a +max0 a b = max a (max b 0) + + +collectMatch :: Array (Int, Int) Float -> [(Int,Int)] +collectMatch a = collect a (snd $ bounds a) [] +collect :: Array (Int, Int) Float -> (Int,Int) -> [(Int,Int)] -> [(Int,Int)] +collect a c@(0,0) m = if a!c > 0 then c : m else m +collect a c@(i,0) m = if a!(i,0) > a!(i-1,0) then c : m else collect a (i-1,0) m +collect a c@(0,j) m = if a!(0,j) > a!(0,j-1) then c : m else collect a (0,j-1) m +collect a c@(i,j) m + | a!c > snd o = collect a (fst o) (c : m) + | otherwise = collect a (fst o) m where + o = realMax3 ((i-1,j) , a!(i-1,j)) + ((i-1,j-1), a!(i-1,j-1)) + ((i,j-1) , a!(i,j-1)) + +wbMatch :: (Sim a, GetDur a) => [a] -> [a] + -> Array (Int, Int) ([(Int, Int)], Float) wbMatch _ [] = listArray ((0,0),(0,0)) (repeat ([],0.0)) wbMatch [] _ = listArray ((0,0),(0,0)) (repeat ([],0.0)) wbMatch a' b' = m where @@ -150,26 +135,36 @@ match :: Int -> Int -> ([(Int,Int)],Float) match i j = if s > 0 then ([(i,j)],s) else ([],0) where s = sim (a!i) (b!j) -- this is the actual core recursive definintion of the algorithm - concatMatch i j = maximumBy (comparing getWeight) l where - l = if s > 0 -- put the diagonal at the back to prefer symmetry - then [ merge2 i j s (m!(i-1,j)) - , merge2 i j s (m!(i,j-1)) - , merge2 i j s (m!(i-1,j-1))] - else [m!(i-1,j), m!(i,j-1), m!(i-1,j-1)] - s = sim (a!i) (b!j) - m = array ((0,0),(la,lb)) + concatMatch i j = l where + l = if s > 0 + then max3 (merge i j di (m!(i-1,j))) + (merge i j s (m!(i-1,j-1))) + (merge i j dj (m!(i,j-1))) + else max3 (m!(i-1,j)) (m!(i,j-1)) (m!(i-1,j-1)) + s = sim (a!i) (b!j) + di = inDel * getDurWeight (a!(i-1)) (b!j) + dj = inDel * getDurWeight (a!i) (b!(j-1)) + m = array ((0,0),(la,lb)) (((0,0), match 0 0) : - [((0,j), maxWeight (m!(0,j-1)) (match 0 j)) | j <- [1..lb]] ++ - [((i,0), maxWeight (m!(i-1,0)) (match i 0)) | i <- [1..la]] ++ + [((0,j), maxByWeight (m!(0,j-1)) (match 0 j)) | j <- [1..lb]] ++ + [((i,0), maxByWeight (m!(i-1,0)) (match i 0)) | i <- [1..la]] ++ [((i,j), concatMatch i j) | i <- [1..la], j <- [1..lb]]) - -maxWeight :: (a, Float) -> (a, Float) -> (a, Float) -maxWeight a@(_,wa) b@(_,wb) = if wa >= wb then a else b - + +lazyMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) +lazyMax3 w@(_,w') nw@(_,nw') n@(_,n') = if n' > nw' then n else + (if w' > nw' then w else nw) + +realMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) +realMax3 w nw n = maxByWeight nw (maxByWeight w n) where + +maxByWeight :: Ord a => (t,a) -> (t,a) -> (t,a) +maxByWeight a@(_,wa) b@(_,wb) = if wa > wb then a else b + + -- merges two tuples contianing the matchings, weight and cumulative depth of both -- matched trees. -merge2 :: Int -> Int -> Float -> ([(Int,Int)], Float) -> ([(Int,Int)], Float) -merge2 i j s p@(prv, w) +merge :: Int -> Int -> Float -> ([(Int,Int)], Float) -> ([(Int,Int)], Float) +merge i j s p@(prv, w) | isFree prv i fst && isFree prv j snd = ((i,j) : prv, w + s) | otherwise = p where isFree :: [a] -> Int -> (a -> Int) -> Bool @@ -182,5 +177,6 @@ getDownRight n = n ! snd (bounds n) -- returns the weight of a match and is synonymous to snd -getWeight :: (a, b) -> b -getWeight (_,w) = w +-- getWeight :: (a, b) -> b +-- getWeight (_,w) = w + diff --git a/src/HarmTrace/Matching/Sim.hs b/src/HarmTrace/Matching/Sim.hs --- a/src/HarmTrace/Matching/Sim.hs +++ b/src/HarmTrace/Matching/Sim.hs @@ -1,86 +1,78 @@ {-# OPTIONS_GHC -Wall #-} module HarmTrace.Matching.Sim where -import HarmTrace.Tokenizer.Tokens import HarmTrace.HAnTree.HAn import HarmTrace.HAnTree.Tree +import HarmTrace.Base.MusicRep -------------------------------------------------------------------------------- -- A class for representing numerical similarity between datatypes -------------------------------------------------------------------------------- --- parameters - -funkWeight, secdomWeight, transWeight, chordVSan :: Float -funkWeight = 0.5 -secdomWeight = 1.0 -transWeight = 1.0 -chordVSan = 0.2 - class Sim a where - sim :: a -> a -> Float + sim :: a -> a -> Int instance Sim a => Sim (Tree a) where sim (Node l _ _) (Node l' _ _) = sim l l' - instance Sim a => Sim [a] where sim [ha] [hb] = sim ha hb sim (ha:ta) (hb:tb) = sim ha hb + sim ta tb - sim _ _ = 0.0 + sim _ _ = 0 -instance Sim HAn where - sim (HAnChord chord) (HAnChord chord2) = sim chord chord2 - sim (HAnFunc hfunk) (HAnFunc hfunk2) = sim hfunk hfunk2 - sim (HAnTrans trans) (HAnTrans trans2) = sim trans trans2 - sim a b - | a == b = funkWeight * chordVSan * durWeight (getDur a) (getDur b) - | otherwise = 0.0 - -instance Sim HFunc where - sim a b - | a == b = funkWeight * chordVSan * durWeight (getDur a) (getDur b) - | otherwise = 0.0 - -instance Sim Trans where - sim (SecDom d sd) (SecDom d2 sd2) - | sd == sd2 = secdomWeight * chordVSan * (durWeight d d2) - | otherwise = 0.0 - sim (SecMin d sd) (SecMin d2 sd2) - | sd == sd2 = secdomWeight * chordVSan * (durWeight d d2) - | otherwise = 0.0 - sim (Trit d sd) (Trit d2 sd2) - | sd == sd2 = secdomWeight * chordVSan * (durWeight d d2) - | otherwise = 0.0 - sim (DimTrit d _) (DimTrit d2 _) = - transWeight * chordVSan * durWeight d d2 - sim (DimTrans d _) (DimTrans d2 _) = - transWeight * chordVSan * durWeight d d2 - sim (DiatDom d sd) (DiatDom d2 sd2) - | sd == sd2 = secdomWeight * chordVSan * (durWeight d d2) - | otherwise = 0.0 - sim _ _ = 0.0 - -instance Sim ChordToken where - sim (ChordToken sd clss _cs _stat _n d ) - (ChordToken sd2 clss2 _cs2 _stat2 _n2 d2) - -- | sameDeg && sameClss && sameStat = 1.0 * weight - -- | sameDeg && sameClss && sameCs = 0.9 * weight - | sameDeg && sameClss = 1.0 * weight - | otherwise = 0.0 where - sameDeg = sd == sd2 - sameClss = clss == clss2 - -- sameCs = cs == cs2 - -- sameStat = stat == stat2 - weight = durWeight d d2 +instance Sim Int where + {-# INLINE sim #-} + sim i j = if i == j then 1 else 0 -durWeight :: Int -> Int -> Float -durWeight durA durB = fromIntegral (min durA durB) +instance Sim HFunc where + {-# INLINE sim #-} + sim (Ton _ _m c _) (Ton _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2 + sim (Dom _ _m c _) (Dom _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2 + sim (Sub _ _m c _) (Sub _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2 + sim P P = 1 + sim PD PD = 1 + sim PT PT = 1 + sim _ _ = 0 + +instance Sim Mode where + {-# INLINE sim #-} + sim MajMode MajMode = 1 + sim MinMode MinMode = 1 + sim _ _ = 0 --- calculates the self similarity value (used for normalisation) -selfSim :: (Sim a) => Tree a -> Float -selfSim (Node l [] _) = sim l l -selfSim (Node l cs _) = sim l l + (sum $ map selfSim cs) +instance Sim Trans where + {-# INLINE sim #-} + sim (Trit _v sd) (Trit _v2 sd2) = if sd == sd2 then 1 else 0 + sim (DimTrit _v sd) (DimTrit _v2 sd2) = if sd == sd2 then 1 else 0 + sim (DimTrans _v sd) (DimTrans _v2 sd2) = if sd == sd2 then 1 else 0 + sim _ _ =0 -selfSiml :: (Sim a) => [Tree a] -> Float -selfSiml trees = sum $ map selfSim trees +instance Sim Prep where + {-# INLINE sim #-} + sim (DiatDom _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 3 else 2 + sim (SecDom _v sd) (SecDom _v2 sd2) = if sd == sd2 then 3 else 2 + sim (SecMin _v sd) (SecMin _v2 sd2) = if sd == sd2 then 3 else 2 + + sim (SecMin _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 2 else 1 + sim (DiatDom _v sd) (SecMin _v2 sd2) = if sd == sd2 then 2 else 1 + + sim (SecMin _v sd) (SecDom _v2 sd2) = if sd == sd2 then 2 else 1 + sim (SecDom _v sd) (SecMin _v2 sd2) = if sd == sd2 then 2 else 1 + + sim (DiatDom _v sd) (SecDom _v2 sd2) = if sd == sd2 then 2 else 1 + sim (SecDom _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 2 else 1 + -- sim NoTrans NoTrans = + sim _ _ = 0 + +-------------------------------------------------------------------------------- +-- Some utility functions +-------------------------------------------------------------------------------- + +-- calculates the self similarity value (used for normalisation) i.e. the +-- maximum similarity score +maxSim :: Sim a => [a] -> Int +maxSim = foldr (\a b -> sim a a + b) 0 + +div1 :: Int -> Int -> Int +div1 n c = if n == 1 then 1 else n `div` c + diff --git a/src/HarmTrace/Matching/SimpleChord.hs b/src/HarmTrace/Matching/SimpleChord.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Matching/SimpleChord.hs @@ -0,0 +1,41 @@ +module HarmTrace.Matching.SimpleChord (SimChord, Sim, toSimChords) where + +import HarmTrace.Base.MusicRep +import HarmTrace.Matching.Sim + +-- represents a very simple chord, only major and minor and a root scaledegree +data SimChord = SimChord !Int -- I = 0, IIb = 1 ... VII = 11 + !Bool -- maj = True, min = False + +instance Sim SimChord where + {-# INLINE sim #-} + sim (SimChord r sh) (SimChord r2 sh2) -- = simInt r r2 + simInt sh sh2 + | r == r2 && sh == sh2 = 4 + | otherwise = -1 + +instance Show SimChord where + show (SimChord r sh) = show (scaleDegrees !! r) ++ if sh then "" else "m" + +toSimChords :: ChordDegree -> [SimChord] +toSimChords (Chord r sh _add _loc d) = + -- replicate (d `div1` 2) (SimChord (diaDegToSemi r) (toMode sh)) + replicate d (SimChord (diaDegToSemi r) (toMode sh)) + +toMode :: Shorthand -> Bool +toMode Maj = True +toMode Min = False +toMode Dim = False +toMode Aug = True +toMode Maj7 = True +toMode Min7 = False +toMode Sev = True +toMode Dim7 = False +toMode HDim7 = False +toMode MinMaj7= False +toMode Maj6 = True +toMode Min6 = False +toMode Nin = True +toMode Maj9 = True +toMode Min9 = False +toMode Sus4 = False -- for now +toMode _ = False -- should not happen diff --git a/src/HarmTrace/Matching/Testing.hs b/src/HarmTrace/Matching/Testing.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Matching/Testing.hs @@ -0,0 +1,82 @@ +module HarmTrace.Matching.Testing where + +import HarmTrace.Matching.Matching hiding (align, wbMatchF, getDownRight, getMatch, collectMatch) +import HarmTrace.Matching.AlignmentFaster +import HarmTrace.Matching.Sim +import HarmTrace.HAnTree.HAn + +import Data.Array + +-- testing +import Test.QuickCheck +import Data.List.Split +import qualified Data.Vector as V + +-------------------------------------------------------------------------------- +-- Testing +-------------------------------------------------------------------------------- + +instance SimInt Char where + {- sim 'a' 'b' = 0.5 + sim 'a' 'c' = 0.1 + sim 'a' 'd' = 1.1 + sim 'a' 'e' = -1.1 + sim 'a' 'f' = -3.1 + sim 'c' 'd' = -1.5 + sim 'e' 'f' = 0.5 + sim 'g' 'h' = -3.2 + sim 'k' 'l' = 4.9 + sim 'i' 'j' = 0.95-} + simInt a b = if a == b then 5 else 0 + +instance GetDur Char where getDur _ = 1 + +data Test = Test Char Int deriving (Eq, Show) + +instance GetDur Test where + getDur (Test _ d) = d + +instance Arbitrary (Test) where + arbitrary = do e <- elements ['a' .. 'm'] + d <- elements [1 .. 12] + return (Test e d) + +instance Sim (Test) where +{- sim (Test 'a' d) (Test 'b' d2) = 0.5 * durWeight d d2 + sim (Test 'b' d) (Test 'a' d2) = 1.5 * durWeight d d2 + sim (Test 'a' d) (Test 'c' d2) = -0.5 * durWeight d d2 + sim (Test 'a' d) (Test 'd' d2) = 5.5 * durWeight d d2 + sim (Test 'd' d) (Test 'b' d2) = -0.5 * durWeight d d2 + sim (Test 'e' d) (Test 'f' d2) = 0.5 * durWeight d d2-} + sim a b = if a == b then 1.0 else 0.0 + +-- propRef :: [Char] -> [Char] -> Bool +-- -- propRef :: [Test] -> [Test] -> Bool +-- propRef a b = (length . fst $ align a b) == (length . fst $ getWeightMatch a b) + +-- -- propSym :: [Char] -> [Char] -> Bool +-- propSym :: [Test] -> [Test] -> Bool +-- propSym a b = snd (align a b) == snd (align b a) + +-- traverse a 2 dimentional array row by row and appies f to every element +-- should return a String that is printed to the console +pPrintf :: (e -> String) -> Array (Int, Int) e -> IO () +pPrintf f n = putStr $ unlines $ map (concatMap (\x -> f x ++ " ")) list + where list = splitEvery (fromIntegral (snd $ snd $ bounds n)+1) (elems n) + +-- pretty prints a 2 diminentional array in a readable format +pPrint :: (Show e) => Array (Int, Int) e -> IO () +pPrint n = pPrintf show n + +pPrintV :: Show a => V.Vector (V.Vector a) -> IO () +pPrintV = V.mapM_ printLn where + printLn :: Show a => V.Vector a -> IO() + printLn v = do V.mapM_ (\x -> putStr (show x ++ " ")) v ; putChar '\n' + +bigTest :: Args +bigTest = stdArgs -- Args + { replay = Nothing + , maxSuccess = 1250 + , maxDiscard = 250 + , maxSize = 100 + } diff --git a/src/HarmTrace/Model/Instances.hs b/src/HarmTrace/Model/Instances.hs deleted file mode 100644 --- a/src/HarmTrace/Model/Instances.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Model.Instances where - --- Generics stuff -import Generics.Instant.TH - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances - --- Music stuff -import HarmTrace.Model.Parser -import HarmTrace.Model.Model -import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.ToHAnTree -import HarmTrace.HAnTree.HAn -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Base.TypeLevel -import HarmTrace.Base.MusicRep - --- Library modules -import Control.Arrow - - --------------------------------------------------------------------------------- --- The non-generic part of the parser --------------------------------------------------------------------------------- - -instance ParseG (Base_SD key deg clss Ze) where parseG = empty - -instance ( ToDegree (DiatV deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Min5 key deg MinClass n) - , ParseG (Base_SD key (DiatV deg) MinClass n) - , ParseG (Base_SD key (DiatVM deg) MajClass n) - , ParseG (Base_SD key deg MinClass n) - ) => ParseG (Base_SD key deg MinClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Diat <$> parseG <*> parseG - <|> Cons_DiatM' <$> parseG <*> parseG - -instance ( ToDegree (DiatVM deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Min5 key deg MajClass n) - , ParseG (Base_SD key (DiatVM deg) MajClass n) - , ParseG (Base_SD key deg MajClass n) - ) => ParseG (Base_SD key deg MajClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_DiatM <$> parseG <*> parseG - -instance ( ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key deg clss n) - , ParseG (Min5 key deg clss n) - ) => ParseG (Base_SD key deg clss (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - --- Ad-hoc cases for Base_Vmin -instance ParseG (Base_Vmin key deg clss Ze) where parseG = empty - -instance ( ParseG (Base_SD key (VMin deg) MinClass n) - , ParseG (TritMinVSub key deg DomClass) - ) => ParseG (Base_Vmin key deg DomClass (Su n)) where - parseG = Base_Vmin <$> parseG - <|> Cons_Vmin <$> parseG <*> parseG - -instance ( ParseG (TritMinVSub key deg clss) - ) => ParseG (Base_Vmin key deg clss (Su n)) where - parseG = Base_Vmin <$> parseG - - --- Ad-hoc cases for Base_Final -instance ParseG (Base_Final key deg clss Ze) where parseG = empty - -instance ( ParseG (FinalDimTrans key deg clss) - ) => ParseG (Base_Final key deg clss (Su n)) where - parseG = Base_Final <$> parseG - -instance ( ParseG (FinalDimTrans key deg DomClass) - , ParseG (FinalDimTrans key deg MinClass) - , ParseG (Base_Final key (Tritone deg) DomClass n) - , ParseG (Base_Final key (IIbDim deg) DimClass n) - ) => ParseG (Base_Final key deg DomClass (Su n)) where - parseG = Base_Final <$> parseG - <|> Final_Tritone <$> parseG - <|> Final_Dim_V <$> parseG - --- Ad-hoc cases for Surface_Chord -instance ParseG (Surface_Chord key deg clss Ze) where parseG = empty - -instance ( ToDegree deg - , ParseG (Surface_Chord key (MinThird deg) DimClass n) - ) => ParseG (Surface_Chord key deg DimClass (Su n)) where - parseG = Dim_Chord_Trns <$> parseG - <|> pChord deg DimClass - where deg = toDegree (undefined :: deg) - --- all chords -instance ( ToDegree deg, ToClass clss - ) => ParseG (Surface_Chord key deg clss (Su n)) where - parseG = pChord deg clss - where deg = toDegree (undefined :: deg) - clss = toClass (undefined :: clss) - - -pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord key deg clss (Su n)) --- Do not parse Imp degrees -pChord (Note _ Imp) _clss = empty --- General case -pChord deg clss = setStatus <$> pSatisfy recognize insertion where - recognize (ChordToken deg' clss' _cs _stat _n _d) = deg == deg' && clss == clss' - setStatus (ChordToken r t l NotParsed n d) = Surface_Chord (ChordToken r t l Parsed n d) - setStatus c = Surface_Chord c - insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 - --------------------------------------------------------------------------------- --- The non-generic part of the GTree wrapper --------------------------------------------------------------------------------- -toGTree :: (GetDegree a, GTree a) => - (Int -> ScaleDegree -> Trans) -> a -> Int -> [Tree HAn] -toGTree con deg trans = [Node (HAnTrans (con 1 (getScaleDegree deg trans))) - (gTree deg) Nothing] - --- create a branching Tree HAn -toGTreeSplit :: (GetDegree a, GTree a, GTree b) => - (Int -> ScaleDegree -> Trans) -> b -> a -> Int -> [Tree HAn] -toGTreeSplit con sd deg trans - = (Node (HAnTrans . con 1 $ getScaleDegree deg trans) (gTree sd) Nothing - : gTree deg) - -getScaleDegree :: (GetDegree a) => a -> Int -> ScaleDegree -getScaleDegree deg addTrans = case getDeg deg of - (deg', trans) -> transposeSem deg' (trans + addTrans) - --- Ad-Hoc case for Piece -instance GTree (Piece key) where -- we take the children to skip a "list node" - gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] - --- Ad-hoc cases for Base_SD -instance GTree (Base_SD key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GTree (Min5 key deg clss n) - , GTree (Base_SD key (VDom deg) DomClass n) - , GTree (Base_SD key (DiatV deg) MinClass n) - , GTree (Base_SD key (DiatVM deg) MajClass n) - , GTree (Base_SD key deg clss n) - ) => GTree (Base_SD key deg clss (Su n)) where - gTree (Base_SD d) = gTree d - gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d 0 - gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d 0 - gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d 0 - gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d 0 - --- Ad-hoc cases for Base_Vmin key -instance GTree (Base_Vmin key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GTree (Base_SD key (VMin deg) MinClass n) - , GTree (TritMinVSub key deg DomClass ) - , GTree (Final key deg MinClass ) - ) => GTree (Base_Vmin key deg clss (Su n)) where - gTree (Base_Vmin d) = gTree d - -- pattern match into the SD to see if we are our target degree - -- is tritone substituted, if so, we "tritone-unsubstitute" - gTree (Cons_Vmin s d@(Final_Tritone _)) = toGTreeSplit SecMin s d 1 - gTree (Cons_Vmin s d ) = toGTreeSplit SecMin s d 0 - --- Ad-hoc cases for Base_Final -instance GTree (Base_Final key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GetDegree (Base_Final key (Tritone deg) DomClass n) - , GetDegree (Base_Final key (IIbDim deg) DimClass n) - , GTree (FinalDimTrans key deg clss) - , GTree (Base_Final key (Tritone deg) DomClass n) - , GTree (Base_Final key (IIbDim deg) DimClass n) - ) => GTree (Base_Final key deg clss (Su n)) where - gTree (Base_Final d) = gTree d - -- The tritone substitution of a relative V is as alsway one semitone above - -- the chord it is preceding - gTree (Final_Tritone d) = toGTree Trit d 11 - gTree (Final_Dim_V d) = toGTree DimTrit d 11 - --- Ad-hoc cases for Surface_Chord -instance GTree (Surface_Chord key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) - , GTree (Surface_Chord key (MinThird deg) DimClass n) - ) => GTree (Surface_Chord key deg clss (Su n)) where - gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] - gTree (Dim_Chord_Trns c) = toGTree DimTrans c 9 - --------------------------------------------------------------------------------- --- Ad hoc getDegree instaces --------------------------------------------------------------------------------- - --- This function retuns a value level description of a degree using getDegree. --- Certain visualizations demand an addiional scale degree tranposition. The --- addTrans integer value can be used for that (use 0 for no transposition) -toDegVal :: (GetDegree a) => a -> Int -> ShowS -toDegVal deg addTrans = case getDeg deg of - (deg', trans) -> shows $ transposeSem deg' (trans + addTrans) - -showDegree :: GetDegree a => a -> String -showDegree deg = (toDegVal deg 0) "" - --- Given a degree getDegee ensures that all information about the internal --- structure of a scale degree,i.e. the degree and the an int value representing --- the transposition of that degree at the current level, is available. -class GetDegree a where - getDeg :: a -> (ScaleDegree, Int) - --- TODO there is a bug in get degree it works correct if the tree is binary, --- but if there are multiple repetitions of the same progression grouped under --- one functional node, as in the b part of "there is no greater love" in --- the Vd/X the X is wrongy printed. -instance GetDegree (Base_SD key deg clss n) where - getDeg (Base_SD d) = getDeg d - getDeg (Cons_Vdom _ d) = second (+5) (getDeg d) - getDeg (Cons_Diat _ d) = second (+5) (getDeg d) - getDeg (Cons_DiatM _ d) = second (+5) (getDeg d) - getDeg (Cons_DiatM' _ d) = second (+5) (getDeg d) - -instance GetDegree (Base_Vmin key deg clss n) where - getDeg (Base_Vmin d) = getDeg d - getDeg (Cons_Vmin _ d) = second (+5) (getDeg d) - -instance ( GetDegree (Base_Final key deg clss Ze)) where - getDeg = error "getDegree: impossible?" -instance ( GetDegree (Final key deg clss) - , GetDegree (Base_Final key deg DimClass n) - , GetDegree (Base_Final key (Tritone deg) DomClass n) - , GetDegree (Base_Final key (IIbDim deg) DimClass n) - ) => GetDegree (Base_Final key deg clss (Su n)) where - getDeg (Base_Final d) = getDeg d - -- The tritone substitution of a relative V is as always one semitone above - -- the chord it is preceding - getDeg (Final_Tritone d) = second (+6) (getDeg d) - getDeg (Final_Dim_V d) = second (+1) (getDeg d) - -instance ( GetDegree (Surface_Chord key deg clss Ze)) where - getDeg = error "getDegree: impossible?" - -instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) - ) => GetDegree (Surface_Chord key deg clss (Su n)) where - getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) - getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) - --------------------------------------------------------------------------------- --- Instances of Representable for music datatypes --------------------------------------------------------------------------------- - -deriveAllL allTypes - -$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) - allTypes) - -$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) - allTypes) - --------------------------------------------------------------------------------- --- ChordToken as tokens --------------------------------------------------------------------------------- - -instance IsLocationUpdatedBy Int ChordToken where - advance p c = p + chordNumReps c diff --git a/src/HarmTrace/Model/Main.hs b/src/HarmTrace/Model/Main.hs deleted file mode 100644 --- a/src/HarmTrace/Model/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HarmTrace.Model.Main where - --- Parser stuff -import Text.ParserCombinators.UU - --- Music stuff -import HarmTrace.Base.MusicRep -import HarmTrace.Model.Parser -import HarmTrace.Model.Model hiding (PD,PT) - -import HarmTrace.Model.Instances () - - --------------------------------------------------------------------------------- --- From tokens to structured music pieces --------------------------------------------------------------------------------- - -pPieceMaj, pPieceMin :: forall key. PMusic [Piece key] -pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase key MajMode]) -pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase key MinMode]) - -pMajOrMin :: forall key. Key -> PMusic [Piece key] -pMajOrMin (Key _ MajMode) = pPieceMaj -pMajOrMin (Key _ MinMode) = pPieceMin - diff --git a/src/HarmTrace/Model/Model.hs b/src/HarmTrace/Model/Model.hs deleted file mode 100644 --- a/src/HarmTrace/Model/Model.hs +++ /dev/null @@ -1,412 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Model.Model where - -import HarmTrace.Base.TypeLevel - -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens -import Language.Haskell.TH.Syntax (Name) - --------------------------------------------------------------------------------- --- Musical structure as a datatype --------------------------------------------------------------------------------- - --- perhaps this module should be named differently, like Model or HarmonyModel - -data MajMode -data MinMode - --- High level structure --- 'key' is not used yet -data Piece key = forall mode. Piece [Phrase key mode] - --- The Phrase level -data Phrase key mode where - PT :: Ton key mode -> Phrase key mode - PD :: Dom key mode -> Phrase key mode - --- Harmonic categories --- Tonic -data Ton key mode where - -- major mode - T_1 :: Final key I MajClass -> Ton key MajMode - T_2 :: Final key I MajClass -> Final key IV MajClass - -> Final key I MajClass -> Ton key MajMode - - -- blues - -- T_4_bls :: Final key I DomClass -> Ton key mode - - T_3_par :: Final key III MinClass -> Ton key MajMode - T_6_bor :: TMinBorrow key -> Ton key MajMode - - -- minor mode - Tm_1 :: SD key MinMode I MinClass -> Ton key MinMode - Tm_2 :: Final key I MinClass -> Final key IV MinClass - -> Final key I MinClass -> Ton key MinMode - - Tm_3_par :: Final key IIIb MajClass -> Ton key MinMode - Tm_6_bor :: TMajBorrow key -> Ton key MinMode -- picardy third etc. - --- Dominant -data Dom key mode where - -- major mode - D_1 :: SDom key mode -> Dom key mode -> Dom key mode - D_2 :: SD key mode V DomClass -> Dom key mode - D_3 :: SD key mode V MajClass -> Dom key mode - - D_4 :: SD key MajMode VII MinClass -> Dom key MajMode - - -- moll-dur: minor mode borrowings in major - -- This would be an elegant way of defining major minor borrowing, - -- but it causes a lot of unwanted abmiguities since all the mode - -- rules can be explained with and without borrowing - -- D_9_bor :: Dom key MinMode -> Dom key MajMode - D_8_bor :: DMinBorrow key -> Dom key MajMode - - -- minor mode (there must be at least one rule with "MinMode" otherwise - -- no you get a "No instance for (ParseG (Dom key MinMode))" error - Dm_1 :: SD key MinMode VIIb MajClass -> Dom key MinMode - Dm_2_bor :: DMajBorrow key -> Dom key MinMode - --- Subdominant -data SDom key mode where - S_1_par :: SD key mode II MinClass -> SDom key mode -- sub dom parallel - - -- Pretty printing? this rule compensates for the V/I Imp - -- to be able to parse D:7 D:min G:7 C:maj (not in cmj) - S_3_par :: SD key mode II DomClass -> Final key II MinClass - -> SDom key mode - S_4 :: SD key MajMode IV MajClass -> SDom key MajMode - S_5 :: SD key MajMode III MinClass -> Final key IV MajClass - -> SDom key MajMode - -- S_6_par :: SD key MajMode VI MinClass -> SDom key MajMode - - -- blues - -- S_2_bls :: SD key mode IV DomClass -> SD key mode I DomClass - -- -> SDom key mode - - -- Borrowing from minor in a major mode - -- S_7_bor :: SDom key MajMode -> SDom key MinMode - S_7_bor :: SMinBorrow key -> SDom key MajMode - - -- minor mode - Sm_1 :: SD key MinMode IV MinClass -> SDom key MinMode - Sm_2 :: SD key MinMode IIIb MajClass -> Final key IV MinClass - -> SDom key MinMode - -- Sm_3_par :: SD key MinMode VIb MajClass -> SDom key MinMode - - -- perhaps add a functional node for Neapolitan chords? - Sm_4 :: SD key MinMode IIb MajClass -> SDom key MinMode -- Neapolitan - - Sm_5_bor :: SMajBorrow key -> SDom key MinMode - --- Borrowings from minor in a major key -data TMinBorrow key = Tm_21_bor (SD key MinMode I MinClass) - | Tm_23_bor (SD key MinMode IIIb MajClass) - -data DMinBorrow key = Dm_24_bor (SD key MinMode VIIb MajClass) - -- | Dm_21_bor (Final key VIIb DomClass) - -data SMinBorrow key = Sm_20_bor (SD key MinMode IV MinClass) - -- | Sm_21_bor (SD key MinMode VIb MajClass) - | Sm_22_bor (SD key MinMode IIb MajClass) -- Neapolitan - - --- Borrowings from major in a minor key -data TMajBorrow key = T_21_bor (SD key MajMode I MajClass) - | T_23_bor (SD key MajMode III MinClass) - -data DMajBorrow key = D_24_bor (SD key MajMode VII MinClass) - -- | D_21_bor (Final key VII DimClass) - -data SMajBorrow key = S_20_bor (SD key MajMode IV MajClass) - - --- Limit secondary dominants to a few levels -type SD key mode deg clss = Base_SD key deg clss T7 - --- a type that can be substituted by its tritone sub and diminished 7b9 -type TritMinVSub key deg clss = Base_Final key deg clss T2 - --- A Scale degree that can only translate to a surface chord --- and allows for the transformation into enharmonic equivalent --- diminshed surface chords -type FinalDimTrans key deg clss = Surface_Chord key deg clss T4 - --- A Scale degree that translates into a (non-tranformable) surface chord -type Final key deg clss = Surface_Chord key deg clss T1 - - --- Datatypes for clustering harmonic degrees -data Base_SD key deg clss n where - Base_SD :: Min5 key deg clss n - -> Base_SD key deg clss (Su n) - -- Rule for explaining perfect secondary dominants - Cons_Vdom :: Base_SD key (VDom deg) DomClass n -> Min5 key deg clss n - -> Base_SD key deg clss (Su n) - Cons_Diat :: Base_SD key (DiatV deg) MinClass n -> Base_SD key deg MinClass n - -> Base_SD key deg MinClass (Su n) - Cons_DiatM :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MajClass n - -> Base_SD key deg MajClass (Su n) - Cons_DiatM' :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MinClass n - -> Base_SD key deg MinClass (Su n) - --- One case only allowed (Tritone or Cons_Vmin) -type Min5 key deg clss n = Base_Vmin key deg clss n - -data Base_Vmin key deg clss n where - -- No minor fifth - Base_Vmin :: TritMinVSub key deg clss - -> Base_Vmin key deg clss (Su n) - -- Minor fifth insertion - Cons_Vmin :: Base_SD key (VMin deg) MinClass n -> TritMinVSub key deg DomClass - -> Base_Vmin key deg DomClass (Su n) - - -data Base_Final key deg clss n where - -- Just a "normal", final degree. The Strings are the original input. - Base_Final :: FinalDimTrans key deg clss -> Base_Final key deg clss (Su n) - -- Tritone substitution - Final_Tritone :: Base_Final key (Tritone deg) DomClass n - -> Base_Final key deg DomClass (Su n) - Final_Dim_V :: Base_Final key (IIbDim deg) DimClass n - -> Base_Final key deg DomClass (Su n) - --- Dimished tritone substitution accounting for dimished chord transistions -data Surface_Chord key deg clss n where - Surface_Chord :: ChordToken - -> Surface_Chord key deg clss (Su n) - Dim_Chord_Trns :: Surface_Chord key (MinThird deg) DimClass n - -> Surface_Chord key deg DimClass (Su n) - --------------------------------------------------------------------------------- --- Type Level Scale Degrees --------------------------------------------------------------------------------- - --- typelevel chord classes -data MajClass -data MinClass -data DomClass -data DimClass - --- Degrees (at the type level) -data I -data Ib -data Is -data II -data IIb -data IIs -data III -data IIIb -data IIIs -data IV -data IVb -data IVs -data V -data Vb -data Vs -data VI -data VIb -data VIs -data VII -data VIIb -data VIIs - --- Used when we don't want to consider certain possibilities -data Imp - --- Degrees at the value level are in Tokenizer --- Type to value conversions -class ToClass clss where - toClass :: clss -> ClassType - -instance ToClass MajClass where toClass _ = MajClass -instance ToClass MinClass where toClass _ = MinClass -instance ToClass DomClass where toClass _ = DomClass -instance ToClass DimClass where toClass _ = DimClass - --- The class doesn't really matter, since the degree will be impossible to parse -instance ToClass Imp where toClass _ = DimClass - -class ToDegree deg where - toDegree :: deg -> ScaleDegree - -instance ToDegree I where toDegree _ = Note Nothing I -instance ToDegree II where toDegree _ = Note Nothing II -instance ToDegree III where toDegree _ = Note Nothing III -instance ToDegree IV where toDegree _ = Note Nothing IV -instance ToDegree V where toDegree _ = Note Nothing V -instance ToDegree VI where toDegree _ = Note Nothing VI -instance ToDegree VII where toDegree _ = Note Nothing VII -instance ToDegree Ib where toDegree _ = Note (Just Fl) I -instance ToDegree IIb where toDegree _ = Note (Just Fl) II -instance ToDegree IIIb where toDegree _ = Note (Just Fl) III -instance ToDegree IVb where toDegree _ = Note (Just Fl) IV -instance ToDegree Vb where toDegree _ = Note (Just Fl) V -instance ToDegree VIb where toDegree _ = Note (Just Fl) VI -instance ToDegree VIIb where toDegree _ = Note (Just Fl) VII -instance ToDegree IIs where toDegree _ = Note (Just Sh) II -instance ToDegree IIIs where toDegree _ = Note (Just Sh) III -instance ToDegree IVs where toDegree _ = Note (Just Sh) IV -instance ToDegree Vs where toDegree _ = Note (Just Sh) V -instance ToDegree VIs where toDegree _ = Note (Just Sh) VI -instance ToDegree VIIs where toDegree _ = Note (Just Sh) VII - --- Can't ever parse these -instance ToDegree Imp where toDegree _ = Note Nothing Imp - - --------------------------------------------------------------------------------- --- Type Families for Relative Scale Degrees --------------------------------------------------------------------------------- - - --- Diatonic fifths, and their class (comments with the CMaj scale) --- See http://en.wikipedia.org/wiki/Circle_progression -type family DiatV deg :: * -type instance DiatV I = Imp -- V -- G7 should be Dom -type instance DiatV V = Imp -- II -- Dm7 should be SDom -type instance DiatV II = VI -- Am7 -type instance DiatV VI = III -- Em7 -type instance DiatV III = VII -- Bhdim7 can be explained by Dim rule -type instance DiatV VII = Imp -- IV -- FMaj7 should be SDom -type instance DiatV IV = Imp -- I -- CMaj7 - -type instance DiatV IIb = Imp -type instance DiatV IIIb = Imp -type instance DiatV IVs = Imp -type instance DiatV VIb = Imp -type instance DiatV VIIb = Imp -type instance DiatV Imp = Imp - -type family DiatVM deg :: * -type instance DiatVM I = Imp -- V -- G7 should be Dom -type instance DiatVM V = Imp -- Dm7 should be SDom -type instance DiatVM II = VIb -- Ab -type instance DiatVM VI = Imp -- Em7 -type instance DiatVM III = Imp -- Bhdim7 can be explained by Dim rule -type instance DiatVM VII = Imp -- IV -- FMaj7 should be SDom -type instance DiatVM IV = Imp -- I -- CMaj7 - -type instance DiatVM IIb = Imp -type instance DiatVM IIIb = VIIb -type instance DiatVM IVs = Imp -type instance DiatVM VIb = IIIb -type instance DiatVM VIIb = Imp -type instance DiatVM Imp = Imp - --------------------------------------------------------------------------------- --- Type families for secondary dominants --------------------------------------------------------------------------------- - --- Perfect fifths (class is always Dom) --- See http://en.wikipedia.org/wiki/Circle_of_fifths -type family VDom deg :: * - -type instance VDom I = Imp -- interferes with dom -type instance VDom IIb = VIb -type instance VDom II = VI -type instance VDom IIIb = VIIb -- interferes with Dm_3 -type instance VDom III = VII -type instance VDom IV = I -type instance VDom IVs = IIb -type instance VDom V = II -- interferes with Sm_1 -type instance VDom VIb = IIIb -type instance VDom VI = III -type instance VDom VIIb = IV -type instance VDom VII = IVs -type instance VDom Imp = Imp - --- Perfect fifths for the minor case (this is an additional --- type family to controll the reduction of ambiguities --- specifically in the minor case) -type family VMin deg :: * -type instance VMin I = V -type instance VMin IIb = VIb -type instance VMin II = VI -- interferes with sub -type instance VMin IIIb = VIIb -type instance VMin III = VII -type instance VMin IV = I -type instance VMin IVs = IIb -type instance VMin V = Imp -- II interferes with sub -type instance VMin VIb = IIIb -type instance VMin VI = III -type instance VMin VIIb = Imp --IV -- inteferes with sub IV:min -type instance VMin VII = IVs -type instance VMin Imp = Imp - --- The tritone substitution --- See http://en.wikipedia.org/wiki/Tritone_substitution -type family Tritone deg :: * -type instance Tritone I = IVs -type instance Tritone IVs = I - -type instance Tritone IIb = V -- gives undesired (ambiguous results) as -type instance Tritone V = IIb -- Dom = IIb/I = IIbdim - -type instance Tritone II = VIb -- interferes IIbDim V -type instance Tritone VIb = II - -type instance Tritone IIIb = VI -type instance Tritone VI = IIIb - -type instance Tritone III = VIIb -- Interferes with VIIb from minor -type instance Tritone VIIb = III - -type instance Tritone IV = VII -type instance Tritone VII = IV - -type instance Tritone Imp = Imp - - --------------------------------------------------------------------------------- --- Type families for diminished chord transformations --------------------------------------------------------------------------------- - --- in combination with the secondary dominants and enharmonic equivalency --- these type families account for ascending dim chord progressions -type family IIbDim deg :: * -type instance IIbDim I = IIb -type instance IIbDim IIb = II -type instance IIbDim II = IIIb -type instance IIbDim IIIb = III -type instance IIbDim III = IV -type instance IIbDim IV = IVs -type instance IIbDim IVs = V -type instance IIbDim V = VIb -- interferes with dim tritone V/V -type instance IIbDim VIb = VI -type instance IIbDim VI = VIIb -type instance IIbDim VIIb = VII -type instance IIbDim VII = I -type instance IIbDim Imp = Imp - --- Dimchords can be transposed a minor third without changing their role, --- they are enharmonically equivalent. -type family MinThird deg :: * -type instance MinThird I = IIIb -type instance MinThird IIb = III -type instance MinThird II = IV -type instance MinThird IIIb = IVs -type instance MinThird III = V -type instance MinThird IV = VIb -type instance MinThird IVs = VI -type instance MinThird V = VIIb -type instance MinThird VIb = VII -type instance MinThird VI = I -type instance MinThird VIIb = IIb -type instance MinThird VII = II -type instance MinThird Imp = Imp - --- Belongs in Instances, but needs to be here due to staging restrictions -allTypes :: [Name] -allTypes = [ ''Phrase, ''Ton, ''Dom, ''SDom - , ''TMinBorrow, ''DMinBorrow, ''SMinBorrow - , ''TMajBorrow, ''DMajBorrow, ''SMajBorrow ] diff --git a/src/HarmTrace/Model/Parser.hs b/src/HarmTrace/Model/Parser.hs deleted file mode 100644 --- a/src/HarmTrace/Model/Parser.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- Semi-generic parser for chords -module HarmTrace.Model.Parser where - - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances - --- Generics stuff -import Generics.Instant.Base as G - --- Music stuff -import HarmTrace.Tokenizer.Tokens - - --------------------------------------------------------------------------------- --- The generic part of the parser --------------------------------------------------------------------------------- - -type PMusic a = P (Str ChordToken [ChordToken] Int) a - -class Parse' f where - parse' :: PMusic f - -instance Parse' U where - parse' = pure U - -instance (ParseG a) => Parse' (Rec a) where - parse' = Rec <$> parseG - --- Not really necessary because TH is not generating any Var, but anyway -instance (ParseG a) => Parse' (Var a) where - parse' = Var <$> parseG - -instance (Constructor c, Parse' f) => Parse' (G.CEq c p p f) where - parse' = G.C <$> parse' "Constructor " ++ conName (undefined :: C c f) - -instance Parse' (G.CEq c p q f) where - parse' = empty - -instance (Parse' f, Parse' g) => Parse' (f :+: g) where - parse' = L <$> parse' <|> R <$> parse' - -instance (Parse' f, Parse' g) => Parse' (f :*: g) where - parse' = (:*:) <$> parse' <*> parse' - - -class ParseG a where - parseG :: PMusic a - -instance (ParseG a) => ParseG [a] where - parseG = pList1 parseG - -- We should use non-greedy parsing here, else the final Dom is never parsed - -- as such. - -- parseG = pList1_ng parseG - -instance (ParseG a) => ParseG (Maybe a) where - parseG = pMaybe parseG - -parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a --- parseGdefault = fmap (to . head) (amb parse') --- Previously we used: -parseGdefault = fmap to parse' --- This gave rise to many ambiguities. Now we allow parse' to be ambiguous --- (note that the sum case uses <|>) but then pick only the very first tree --- from all the possible results. It remains to be seen if the first tree is --- the best... diff --git a/src/HarmTrace/Models/Jazz/Instances.hs b/src/HarmTrace/Models/Jazz/Instances.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Jazz/Instances.hs @@ -0,0 +1,250 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Models.Jazz.Instances where + +-- Generics stuff +import Generics.Instant.TH + +-- Parser stuff +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances + +-- Music stuff +import HarmTrace.Models.Parser +import HarmTrace.Models.Jazz.Model +import HarmTrace.HAnTree.Tree +import HarmTrace.HAnTree.ToHAnTree +import HarmTrace.HAnTree.HAn +import HarmTrace.Tokenizer.Tokens as CT +import HarmTrace.Base.TypeLevel +import HarmTrace.Base.MusicRep + +-- Library modules +import Control.Arrow + +-------------------------------------------------------------------------------- +-- The non-generic part of the parser +-------------------------------------------------------------------------------- + +instance ParseG (Base_SD key deg clss Ze) where parseG = empty + +instance ( ToDegree (DiatV deg) + , ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key (DiatV deg) MinClass n) + , ParseG (Base_SD key (DiatVM deg) MajClass n) + , ParseG (Base_SD key deg MinClass n) + , ParseG (TritMinVSub key deg MinClass ) + ) => ParseG (Base_SD key deg MinClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + <|> Cons_Diat <$> parseG <*> parseG + <|> Cons_DiatM' <$> parseG <*> parseG + +instance ( ToDegree (DiatVM deg) + , ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key (DiatVM deg) MajClass n) + , ParseG (Base_SD key deg MajClass n) + , ParseG (TritMinVSub key deg MajClass ) + ) => ParseG (Base_SD key deg MajClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + <|> Cons_DiatM <$> parseG <*> parseG + +instance ( ToDegree (VMin deg) + , ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key (VMin deg) MinClass n) + , ParseG (Base_SD key deg DomClass n) + , ParseG (TritMinVSub key deg DomClass ) + ) => ParseG (Base_SD key deg DomClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + <|> Cons_Vmin <$> parseG <*> parseG + +instance ( ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key deg DimClass n) + , ParseG (TritMinVSub key deg DimClass ) + ) => ParseG (Base_SD key deg DimClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + +-- Ad-hoc cases for Base_Final +instance ParseG (Base_Final key deg clss Ze) where parseG = empty + +instance ( ParseG (FinalDimTrans key deg clss) + ) => ParseG (Base_Final key deg clss (Su n)) where + parseG = Base_Final <$> parseG + +instance ( ParseG (FinalDimTrans key deg DomClass) + , ParseG (FinalDimTrans key deg MinClass) + , ParseG (Base_Final key (Tritone deg) DomClass n) + , ParseG (Base_Final key (IIbDim deg) DimClass n) + ) => ParseG (Base_Final key deg DomClass (Su n)) where + parseG = Base_Final <$> parseG + <|> Final_Tritone <$> parseG + <|> Final_Dim_V <$> parseG + +-- Ad-hoc cases for Surface_Chord +instance ParseG (Surface_Chord key deg clss Ze) where parseG = empty + +instance ( ToDegree deg + , ParseG (Surface_Chord key (MinThird deg) DimClass n) + ) => ParseG (Surface_Chord key deg DimClass (Su n)) where + parseG = Dim_Chord_Trns <$> parseG + <|> pChord deg DimClass + where deg = toDegree (undefined :: deg) + +-- all chords +instance ( ToDegree deg, ToClass clss + ) => ParseG (Surface_Chord key deg clss (Su n)) where + parseG = pChord deg clss + where deg = toDegree (undefined :: deg) + clss = toClass (undefined :: clss) + + +pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord key deg clss (Su n)) +-- Do not parse Imp degrees +pChord (Note _ Imp) _clss = empty +-- General case +pChord deg clss = setStatus <$> pSatisfy recognize insertion where + recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss' + setStatus (ChordToken r t l NotParsed n d) + = Surface_Chord (ChordToken r t l Parsed n d) + setStatus c = Surface_Chord c + insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 + +-------------------------------------------------------------------------------- +-- The non-generic part of the GTree wrapper +-------------------------------------------------------------------------------- +toGTree :: (GetDegree a, GTree a) => + (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn] +toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) + (gTree deg) Nothing] + +-- create a branching Tree HAn +toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) => + (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn] +toGTreeSplit con vof deg + = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg + +-- Ad-Hoc case for Piece +instance GTree (Piece key) where -- we take the children to skip a "list node" + gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] + +-- Ad-hoc cases for Base_SD +instance GTree (Base_SD key deg clss Ze) where + gTree _ = error "gTree: impossible?" + +instance ( GTree (Base_SD key (VDom deg) DomClass n) + , GTree (Base_SD key (DiatV deg) MinClass n) + , GTree (Base_SD key (DiatVM deg) MajClass n) + , GTree (Base_SD key (VMin deg) MinClass n) + , GTree (Base_SD key deg clss n) + , GTree (Base_Final key deg clss n) + ) => GTree (Base_SD key deg clss (Su n)) where + gTree (Base_SD d) = gTree d + gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d + gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d + gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d + +-- Ad-hoc cases for Base_Final +instance GTree (Base_Final key deg clss Ze) where + gTree _ = error "gTree: impossible?" + +instance ( GetDegree (Base_Final key (Tritone deg) DomClass n) + , GetDegree (Base_Final key (IIbDim deg) DimClass n) + , GTree (FinalDimTrans key deg clss) + , GTree (Base_Final key (Tritone deg) DomClass n) + , GTree (Base_Final key (IIbDim deg) DimClass n) + ) => GTree (Base_Final key deg clss (Su n)) where + gTree (Base_Final d) = gTree d + -- The tritone substitution of a relative V is as alsway one semitone above + -- the chord it is preceding + gTree (Final_Tritone d) = toGTree Trit 6 d + gTree (Final_Dim_V d) = toGTree DimTrit 11 d + +-- Ad-hoc cases for Surface_Chord +instance GTree (Surface_Chord key deg clss Ze) where + gTree _ = error "gTree: impossible?" + +instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) + , GTree (Surface_Chord key (MinThird deg) DimClass n) + ) => GTree (Surface_Chord key deg clss (Su n)) where + gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] + gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print? + +-------------------------------------------------------------------------------- +-- Ad hoc getDegree instaces +-------------------------------------------------------------------------------- +toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree +toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t) + +toSDVal :: (GetDegree a) => a -> ScaleDegree +toSDVal d = let (a,i) = getDeg d in transposeSem a i + +-- Given a degree getDegee ensures that all information about the internal +-- structure of a scale degree,i.e. the degree and the an int value representing +-- the transposition of that degree at the current level, is available. +class GetDegree a where + getDeg :: a -> (ScaleDegree, Int) + +instance GetDegree (Base_SD key deg clss n) where + getDeg (Base_SD d) = getDeg d + getDeg (Cons_Vdom _ d) = getDeg d + getDeg (Cons_Diat _ d) = getDeg d + getDeg (Cons_DiatM _ d) = getDeg d + getDeg (Cons_DiatM' _ d) = getDeg d + getDeg (Cons_Vmin _ d) = getDeg d + +instance ( GetDegree (Base_Final key deg clss Ze)) where + getDeg = error "getDegree: impossible?" +instance GetDegree (Base_Final key deg clss n) where + getDeg (Base_Final d) = getDeg d + -- The tritone substitution of a relative V is as always one semitone above + -- the chord it is preceding + getDeg (Final_Tritone d) = second (+6) (getDeg d) + getDeg (Final_Dim_V d) = second (+1) (getDeg d) + +instance ( GetDegree (Surface_Chord key deg clss Ze)) where + getDeg = error "getDegree: impossible?" + +instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) + ) => GetDegree (Surface_Chord key deg clss (Su n)) where + getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) + getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) + +-------------------------------------------------------------------------------- +-- Instances of Representable for music datatypes +-------------------------------------------------------------------------------- + +deriveAllL allTypes + +$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) + allTypes) + +$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) + allTypes) + +-------------------------------------------------------------------------------- +-- ChordToken as tokens +-------------------------------------------------------------------------------- + +instance IsLocationUpdatedBy Int ChordToken where + advance p c = p + chordNumReps c diff --git a/src/HarmTrace/Models/Jazz/Main.hs b/src/HarmTrace/Models/Jazz/Main.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Jazz/Main.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HarmTrace.Models.Jazz.Main ( + pJazz + , module HarmTrace.Models.Jazz.Model + ) where + +-- Parser stuff +import Text.ParserCombinators.UU + +-- Music stuff +import HarmTrace.Base.MusicRep +import HarmTrace.Models.Parser +import HarmTrace.Models.Jazz.Model hiding (PD,PT) + +import HarmTrace.Models.Jazz.Instances () + + +-------------------------------------------------------------------------------- +-- From tokens to structured music pieces +-------------------------------------------------------------------------------- + +pPieceMaj, pPieceMin :: forall key. PMusic [Piece key] +pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase key MajMode]) +pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase key MinMode]) + +pJazz :: forall key. Key -> PMusic [Piece key] +pJazz (Key _ MajMode) = pPieceMaj +pJazz (Key _ MinMode) = pPieceMin + diff --git a/src/HarmTrace/Models/Jazz/Model.hs b/src/HarmTrace/Models/Jazz/Model.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Jazz/Model.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Models.Jazz.Model where + +import HarmTrace.Base.TypeLevel + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens +import Language.Haskell.TH.Syntax (Name) + +-------------------------------------------------------------------------------- +-- Musical structure as a datatype +-------------------------------------------------------------------------------- + +#ifndef NUMLEVELS +#define NUMLEVELS T5 +#endif + +-- perhaps this module should be named differently, like Model or HarmonyModel + +data MajMode +data MinMode + +-- High level structure +-- 'key' is not used yet +data Piece key = forall mode. Piece [Phrase key mode] + +-- The Phrase level +data Phrase key mode where + PT :: Ton key mode -> Phrase key mode + PD :: Dom key mode -> Phrase key mode + +-- Harmonic categories +-- Tonic +data Ton key mode where + -- major mode + T_1 :: Final key I MajClass -> Ton key MajMode + T_2 :: Final key I MajClass -> Final key IV MajClass + -> Final key I MajClass -> Ton key MajMode + + -- blues + -- T_4_bls :: Final key I DomClass -> Ton key mode + + T_3_par :: Final key III MinClass -> Ton key MajMode + T_6_bor :: TMinBorrow key -> Ton key MajMode + + -- minor mode + Tm_1 :: SD key MinMode I MinClass -> Ton key MinMode + Tm_2 :: Final key I MinClass -> Final key IV MinClass + -> Final key I MinClass -> Ton key MinMode + + Tm_3_par :: Final key IIIb MajClass -> Ton key MinMode + Tm_6_bor :: TMajBorrow key -> Ton key MinMode -- picardy third etc. + +-- Dominant +data Dom key mode where + -- major mode + D_1 :: SDom key mode -> Dom key mode -> Dom key mode + D_2 :: SD key mode V DomClass -> Dom key mode + D_3 :: SD key mode V MajClass -> Dom key mode + + D_4 :: SD key MajMode VII MinClass -> Dom key MajMode + + -- moll-dur: minor mode borrowings in major + -- This would be an elegant way of defining major minor borrowing, + -- but it causes a lot of unwanted abmiguities since all the mode + -- rules can be explained with and without borrowing + -- D_9_bor :: Dom key MinMode -> Dom key MajMode + D_8_bor :: DMinBorrow key -> Dom key MajMode + + -- minor mode (there must be at least one rule with "MinMode" otherwise + -- no you get a "No instance for (ParseG (Dom key MinMode))" error + Dm_4 :: SD key MinMode VIIb MajClass -> Dom key MinMode + Dm_8_bor :: DMajBorrow key -> Dom key MinMode + +-- Subdominant +data SDom key mode where + S_1_par :: SD key mode II MinClass -> SDom key mode -- sub dom parallel + + -- Pretty printing? this rule compensates for the V/I Imp + -- to be able to parse D:7 D:min G:7 C:maj (not in cmj) + S_2_par :: SD key mode II DomClass -> Final key II MinClass + -> SDom key mode + S_3 :: SD key MajMode IV MajClass -> SDom key MajMode + S_4 :: SD key MajMode III MinClass -> Final key IV MajClass + -> SDom key MajMode + -- S_6_par :: SD key MajMode VI MinClass -> SDom key MajMode + + -- blues + -- S_2_bls :: SD key mode IV DomClass -> SD key mode I DomClass + -- -> SDom key mode + + -- Borrowing from minor in a major mode + -- S_7_bor :: SDom key MajMode -> SDom key MinMode + S_5_bor :: SMinBorrow key -> SDom key MajMode + + -- minor mode + Sm_3 :: SD key MinMode IV MinClass -> SDom key MinMode + Sm_4 :: SD key MinMode IIIb MajClass -> Final key IV MinClass + -> SDom key MinMode + -- Sm_3_par :: SD key MinMode VIb MajClass -> SDom key MinMode + + Sm_5_bor :: SMajBorrow key -> SDom key MinMode + + -- perhaps add a functional node for Neapolitan chords? + Sm_6 :: SD key MinMode IIb MajClass -> SDom key MinMode -- Neapolitan + +-- Borrowings from minor in a major key +data TMinBorrow key = Tm_21_bor (SD key MinMode I MinClass) + | Tm_23_bor (SD key MinMode IIIb MajClass) + +data DMinBorrow key = Dm_24_bor (SD key MinMode VIIb MajClass) + -- | Dm_21_bor (Final key VIIb DomClass) + +data SMinBorrow key = Sm_20_bor (SD key MinMode IV MinClass) + -- | Sm_21_bor (SD key MinMode VIb MajClass) + | Sm_22_bor (SD key MinMode IIb MajClass) -- Neapolitan + +-- Borrowings from major in a minor key +data TMajBorrow key = T_21_bor (SD key MajMode I MajClass) + | T_23_bor (SD key MajMode III MinClass) + +data DMajBorrow key = D_24_bor (SD key MajMode VII MinClass) + -- | D_21_bor (Final key VII DimClass) + +data SMajBorrow key = S_20_bor (SD key MajMode IV MajClass) + + +-- Limit secondary dominants to a few levels +type SD key mode deg clss = Base_SD key deg clss NUMLEVELS + +-- a type that can be substituted by its tritone sub and diminished 7b9 +type TritMinVSub key deg clss = Base_Final key deg clss T2 + +-- A Scale degree that can only translate to a surface chord +-- and allows for the transformation into enharmonic equivalent +-- diminshed surface chords +type FinalDimTrans key deg clss = Surface_Chord key deg clss T4 + +-- A Scale degree that translates into a (non-tranformable) surface chord +type Final key deg clss = Surface_Chord key deg clss T1 + + +-- Datatypes for clustering harmonic degrees +-- type Base_SD key deg clss n = List (Base_SD' key deg clss n) T4 + +data Base_SD key deg clss n where + Base_SD :: TritMinVSub key deg clss -- Min5 key deg clss n + -> Base_SD key deg clss (Su n) + -- Rule for explaining perfect secondary dominants + Cons_Vdom :: Base_SD key (VDom deg) DomClass n -> Base_SD key deg clss n + -> Base_SD key deg clss (Su n) + Cons_Diat :: Base_SD key (DiatV deg) MinClass n -> Base_SD key deg MinClass n + -> Base_SD key deg MinClass (Su n) + Cons_DiatM :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MajClass n + -> Base_SD key deg MajClass (Su n) + Cons_DiatM' :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MinClass n + -> Base_SD key deg MinClass (Su n) + -- Minor fifth insertion + Cons_Vmin :: Base_SD key (VMin deg) MinClass n -> Base_SD key deg DomClass n + -> Base_SD key deg DomClass (Su n) + + +data Base_Final key deg clss n where + -- Just a "normal", final degree. The Strings are the original input. + Base_Final :: FinalDimTrans key deg clss -> Base_Final key deg clss (Su n) + -- Tritone substitution + Final_Tritone :: Base_Final key (Tritone deg) DomClass n + -> Base_Final key deg DomClass (Su n) + Final_Dim_V :: Base_Final key (IIbDim deg) DimClass n + -> Base_Final key deg DomClass (Su n) + +-- Dimished tritone substitution accounting for dimished chord transistions +data Surface_Chord key deg clss n where + Surface_Chord :: ChordToken + -> Surface_Chord key deg clss (Su n) + Dim_Chord_Trns :: Surface_Chord key (MinThird deg) DimClass n + -> Surface_Chord key deg DimClass (Su n) + +-------------------------------------------------------------------------------- +-- Type Level Scale Degrees +-------------------------------------------------------------------------------- + +-- typelevel chord classes +data MajClass +data MinClass +data DomClass +data DimClass + +-- Degrees (at the type level) +data I +data Ib +data Is +data II +data IIb +data IIs +data III +data IIIb +data IIIs +data IV +data IVb +data IVs +data V +data Vb +data Vs +data VI +data VIb +data VIs +data VII +data VIIb +data VIIs + +-- Used when we don't want to consider certain possibilities +data Imp + +-- Degrees at the value level are in Tokenizer +-- Type to value conversions +class ToClass clss where + toClass :: clss -> ClassType + +instance ToClass MajClass where toClass _ = MajClass +instance ToClass MinClass where toClass _ = MinClass +instance ToClass DomClass where toClass _ = DomClass +instance ToClass DimClass where toClass _ = DimClass + +-- The class doesn't really matter, since the degree will be impossible to parse +instance ToClass Imp where toClass _ = DimClass + +class ToDegree deg where + toDegree :: deg -> ScaleDegree + +instance ToDegree I where toDegree _ = Note Nothing I +instance ToDegree II where toDegree _ = Note Nothing II +instance ToDegree III where toDegree _ = Note Nothing III +instance ToDegree IV where toDegree _ = Note Nothing IV +instance ToDegree V where toDegree _ = Note Nothing V +instance ToDegree VI where toDegree _ = Note Nothing VI +instance ToDegree VII where toDegree _ = Note Nothing VII +instance ToDegree Ib where toDegree _ = Note (Just Fl) I +instance ToDegree IIb where toDegree _ = Note (Just Fl) II +instance ToDegree IIIb where toDegree _ = Note (Just Fl) III +instance ToDegree IVb where toDegree _ = Note (Just Fl) IV +instance ToDegree Vb where toDegree _ = Note (Just Fl) V +instance ToDegree VIb where toDegree _ = Note (Just Fl) VI +instance ToDegree VIIb where toDegree _ = Note (Just Fl) VII +instance ToDegree IIs where toDegree _ = Note (Just Sh) II +instance ToDegree IIIs where toDegree _ = Note (Just Sh) III +instance ToDegree IVs where toDegree _ = Note (Just Sh) IV +instance ToDegree Vs where toDegree _ = Note (Just Sh) V +instance ToDegree VIs where toDegree _ = Note (Just Sh) VI +instance ToDegree VIIs where toDegree _ = Note (Just Sh) VII + +-- Can't ever parse these +instance ToDegree Imp where toDegree _ = Note Nothing Imp + + +-------------------------------------------------------------------------------- +-- Type Families for Relative Scale Degrees +-------------------------------------------------------------------------------- + + +-- Diatonic fifths, and their class (comments with the CMaj scale) +-- See http://en.wikipedia.org/wiki/Circle_progression +type family DiatV deg :: * +type instance DiatV I = Imp -- V -- G7 should be Dom +type instance DiatV V = Imp -- II -- Dm7 should be SDom +type instance DiatV II = VI -- Am7 +type instance DiatV VI = III -- Em7 +type instance DiatV III = VII -- Bhdim7 can be explained by Dim rule +type instance DiatV VII = Imp -- IV -- FMaj7 should be SDom +type instance DiatV IV = Imp -- I -- CMaj7 + +type instance DiatV IIb = Imp +type instance DiatV IIIb = Imp +type instance DiatV IVs = Imp +type instance DiatV VIb = Imp +type instance DiatV VIIb = Imp +type instance DiatV Imp = Imp + +type family DiatVM deg :: * +type instance DiatVM I = Imp -- V -- G7 should be Dom +type instance DiatVM V = Imp -- Dm7 should be SDom +type instance DiatVM II = VIb -- Ab +type instance DiatVM VI = Imp -- Em7 +type instance DiatVM III = Imp -- Bhdim7 can be explained by Dim rule +type instance DiatVM VII = Imp -- IV -- FMaj7 should be SDom +type instance DiatVM IV = Imp -- I -- CMaj7 + +type instance DiatVM IIb = Imp +type instance DiatVM IIIb = VIIb +type instance DiatVM IVs = Imp +type instance DiatVM VIb = IIIb +type instance DiatVM VIIb = Imp +type instance DiatVM Imp = Imp + +-------------------------------------------------------------------------------- +-- Type families for secondary dominants +-------------------------------------------------------------------------------- + +-- Perfect fifths (class is always Dom) +-- See http://en.wikipedia.org/wiki/Circle_of_fifths +type family VDom deg :: * + +type instance VDom I = Imp -- interferes with dom +type instance VDom IIb = VIb +type instance VDom II = VI +type instance VDom IIIb = VIIb -- interferes with Dm_3 +type instance VDom III = VII +type instance VDom IV = I +type instance VDom IVs = IIb +type instance VDom V = II -- interferes with Sm_1 +type instance VDom VIb = IIIb +type instance VDom VI = III +type instance VDom VIIb = IV +type instance VDom VII = IVs +type instance VDom Imp = Imp + +-- Perfect fifths for the minor case (this is an additional +-- type family to controll the reduction of ambiguities +-- specifically in the minor case) +type family VMin deg :: * +type instance VMin I = V +type instance VMin IIb = VIb +type instance VMin II = VI -- interferes with sub +type instance VMin IIIb = VIIb +type instance VMin III = VII +type instance VMin IV = I +type instance VMin IVs = IIb +type instance VMin V = Imp -- II interferes with sub +type instance VMin VIb = IIIb +type instance VMin VI = III +type instance VMin VIIb = Imp --IV -- inteferes with sub IV:min +type instance VMin VII = IVs +type instance VMin Imp = Imp + +-- The tritone substitution +-- See http://en.wikipedia.org/wiki/Tritone_substitution +type family Tritone deg :: * +type instance Tritone I = IVs +type instance Tritone IVs = I + +type instance Tritone IIb = V -- gives undesired (ambiguous results) as +type instance Tritone V = IIb -- Dom = IIb/I = IIbdim + +type instance Tritone II = VIb -- interferes IIbDim V +type instance Tritone VIb = II + +type instance Tritone IIIb = VI +type instance Tritone VI = IIIb + +type instance Tritone III = VIIb -- Interferes with VIIb from minor +type instance Tritone VIIb = III + +type instance Tritone IV = VII +type instance Tritone VII = IV + +type instance Tritone Imp = Imp + + +-------------------------------------------------------------------------------- +-- Type families for diminished chord transformations +-------------------------------------------------------------------------------- + +-- in combination with the secondary dominants and enharmonic equivalency +-- these type families account for ascending dim chord progressions +type family IIbDim deg :: * +type instance IIbDim I = IIb +type instance IIbDim IIb = II +type instance IIbDim II = IIIb +type instance IIbDim IIIb = III +type instance IIbDim III = IV +type instance IIbDim IV = IVs +type instance IIbDim IVs = V +type instance IIbDim V = VIb -- interferes with dim tritone V/V +type instance IIbDim VIb = VI +type instance IIbDim VI = VIIb +type instance IIbDim VIIb = VII +type instance IIbDim VII = I +type instance IIbDim Imp = Imp + +-- Dimchords can be transposed a minor third without changing their role, +-- they are enharmonically equivalent. +type family MinThird deg :: * +type instance MinThird I = IIIb +type instance MinThird IIb = III +type instance MinThird II = IV +type instance MinThird IIIb = IVs +type instance MinThird III = V +type instance MinThird IV = VIb +type instance MinThird IVs = VI +type instance MinThird V = VIIb +type instance MinThird VIb = VII +type instance MinThird VI = I +type instance MinThird VIIb = IIb +type instance MinThird VII = II +type instance MinThird Imp = Imp + +-- Belongs in Instances, but needs to be here due to staging restrictions +allTypes :: [Name] +allTypes = [ ''Phrase, ''Ton, ''Dom, ''SDom + , ''TMinBorrow, ''DMinBorrow, ''SMinBorrow + , ''TMajBorrow, ''DMajBorrow, ''SMajBorrow ] diff --git a/src/HarmTrace/Models/Models.hs b/src/HarmTrace/Models/Models.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Models.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module HarmTrace.Models.Models where + +import HarmTrace.Models.Jazz.Model as J hiding (PD, PT) +import HarmTrace.Models.Pop.Model as P hiding (PD, PT) +import HarmTrace.Models.Test.Main + +import HarmTrace.HAnTree.ToHAnTree + + +data Grammar :: * -> * where + Jazz :: Grammar (J.Piece key) + Pop :: Grammar (P.Piece key) + Test :: Grammar PieceTest + +data GrammarEx where + GrammarEx :: (GTree g) => Grammar g -> GrammarEx diff --git a/src/HarmTrace/Models/Parser.hs b/src/HarmTrace/Models/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Parser.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Semi-generic parser for chords +module HarmTrace.Models.Parser where + + +-- Parser stuff +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances + +-- Generics stuff +import Generics.Instant.Base as G + +-- Music stuff +import HarmTrace.Tokenizer.Tokens + + +-------------------------------------------------------------------------------- +-- The generic part of the parser +-------------------------------------------------------------------------------- + +type PMusic a = P (Str ChordToken [ChordToken] Int) a + +class Parse' f where + parse' :: PMusic f + +instance Parse' U where + parse' = pure U + +instance (ParseG a) => Parse' (Rec a) where + parse' = Rec <$> parseG + +-- Not really necessary because TH is not generating any Var, but anyway +instance (ParseG a) => Parse' (Var a) where + parse' = Var <$> parseG + +instance (Constructor c, Parse' f) => Parse' (G.CEq c p p f) where + parse' = G.C <$> parse' "Constructor " ++ conName (undefined :: C c f) + +instance Parse' (G.CEq c p q f) where + parse' = empty + +instance (Parse' f, Parse' g) => Parse' (f :+: g) where + parse' = L <$> parse' <|> R <$> parse' + +instance (Parse' f, Parse' g) => Parse' (f :*: g) where + parse' = (:*:) <$> parse' <*> parse' + + +class ParseG a where + parseG :: PMusic a + +instance (ParseG a) => ParseG [a] where + parseG = pList1 parseG + -- We should use non-greedy parsing here, else the final Dom is never parsed + -- as such. + -- parseG = pList1_ng parseG + +instance (ParseG a) => ParseG (Maybe a) where + parseG = pMaybe parseG + +parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a +-- parseGdefault = fmap (to . head) (amb parse') +-- Previously we used: +parseGdefault = fmap to parse' +-- This gave rise to many ambiguities. Now we allow parse' to be ambiguous +-- (note that the sum case uses <|>) but then pick only the very first tree +-- from all the possible results. It remains to be seen if the first tree is +-- the best... diff --git a/src/HarmTrace/Models/Pop/Instances.hs b/src/HarmTrace/Models/Pop/Instances.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Pop/Instances.hs @@ -0,0 +1,250 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Models.Pop.Instances where + +-- Generics stuff +import Generics.Instant.TH + +-- Parser stuff +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances + +-- Music stuff +import HarmTrace.Models.Parser +import HarmTrace.Models.Pop.Model +import HarmTrace.HAnTree.Tree +import HarmTrace.HAnTree.ToHAnTree +import HarmTrace.HAnTree.HAn +import HarmTrace.Tokenizer.Tokens as CT +import HarmTrace.Base.TypeLevel +import HarmTrace.Base.MusicRep + +-- Library modules +import Control.Arrow + +-------------------------------------------------------------------------------- +-- The non-generic part of the parser +-------------------------------------------------------------------------------- + +instance ParseG (Base_SD key deg clss Ze) where parseG = empty + +instance ( ToDegree (DiatV deg) + , ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key (DiatV deg) MinClass n) + , ParseG (Base_SD key (DiatVM deg) MajClass n) + , ParseG (Base_SD key deg MinClass n) + , ParseG (TritMinVSub key deg MinClass ) + ) => ParseG (Base_SD key deg MinClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + <|> Cons_Diat <$> parseG <*> parseG + <|> Cons_DiatM' <$> parseG <*> parseG + +instance ( ToDegree (DiatVM deg) + , ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key (DiatVM deg) MajClass n) + , ParseG (Base_SD key deg MajClass n) + , ParseG (TritMinVSub key deg MajClass ) + ) => ParseG (Base_SD key deg MajClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + <|> Cons_DiatM <$> parseG <*> parseG + +instance ( ToDegree (VMin deg) + , ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key (VMin deg) MinClass n) + , ParseG (Base_SD key deg DomClass n) + , ParseG (TritMinVSub key deg DomClass ) + ) => ParseG (Base_SD key deg DomClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + <|> Cons_Vmin <$> parseG <*> parseG + +instance ( ToDegree (VDom deg) + , ParseG (Base_SD key (VDom deg) DomClass n) + , ParseG (Base_SD key deg DimClass n) + , ParseG (TritMinVSub key deg DimClass ) + ) => ParseG (Base_SD key deg DimClass (Su n)) where + parseG = Base_SD <$> parseG + <|> Cons_Vdom <$> parseG <*> parseG + +-- Ad-hoc cases for Base_Final +instance ParseG (Base_Final key deg clss Ze) where parseG = empty + +instance ( ParseG (FinalDimTrans key deg clss) + ) => ParseG (Base_Final key deg clss (Su n)) where + parseG = Base_Final <$> parseG + +instance ( ParseG (FinalDimTrans key deg DomClass) + , ParseG (FinalDimTrans key deg MinClass) + , ParseG (Base_Final key (Tritone deg) DomClass n) + , ParseG (Base_Final key (IIbDim deg) DimClass n) + ) => ParseG (Base_Final key deg DomClass (Su n)) where + parseG = Base_Final <$> parseG + <|> Final_Tritone <$> parseG + <|> Final_Dim_V <$> parseG + +-- Ad-hoc cases for Surface_Chord +instance ParseG (Surface_Chord key deg clss Ze) where parseG = empty + +instance ( ToDegree deg + , ParseG (Surface_Chord key (MinThird deg) DimClass n) + ) => ParseG (Surface_Chord key deg DimClass (Su n)) where + parseG = Dim_Chord_Trns <$> parseG + <|> pChord deg DimClass + where deg = toDegree (undefined :: deg) + +-- all chords +instance ( ToDegree deg, ToClass clss + ) => ParseG (Surface_Chord key deg clss (Su n)) where + parseG = pChord deg clss + where deg = toDegree (undefined :: deg) + clss = toClass (undefined :: clss) + + +pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord key deg clss (Su n)) +-- Do not parse Imp degrees +pChord (Note _ Imp) _clss = empty +-- General case +pChord deg clss = setStatus <$> pSatisfy recognize insertion where + recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss' + setStatus (ChordToken r t l NotParsed n d) + = Surface_Chord (ChordToken r t l Parsed n d) + setStatus c = Surface_Chord c + insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 + +-------------------------------------------------------------------------------- +-- The non-generic part of the GTree wrapper +-------------------------------------------------------------------------------- +toGTree :: (GetDegree a, GTree a) => + (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn] +toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) + (gTree deg) Nothing] + +-- create a branching Tree HAn +toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) => + (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn] +toGTreeSplit con vof deg + = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg + +-- Ad-Hoc case for Piece +instance GTree (Piece key) where -- we take the children to skip a "list node" + gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] + +-- Ad-hoc cases for Base_SD +instance GTree (Base_SD key deg clss Ze) where + gTree _ = error "gTree: impossible?" + +instance ( GTree (Base_SD key (VDom deg) DomClass n) + , GTree (Base_SD key (DiatV deg) MinClass n) + , GTree (Base_SD key (DiatVM deg) MajClass n) + , GTree (Base_SD key (VMin deg) MinClass n) + , GTree (Base_SD key deg clss n) + , GTree (Base_Final key deg clss n) + ) => GTree (Base_SD key deg clss (Su n)) where + gTree (Base_SD d) = gTree d + gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d + gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d + gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d + +-- Ad-hoc cases for Base_Final +instance GTree (Base_Final key deg clss Ze) where + gTree _ = error "gTree: impossible?" + +instance ( GetDegree (Base_Final key (Tritone deg) DomClass n) + , GetDegree (Base_Final key (IIbDim deg) DimClass n) + , GTree (FinalDimTrans key deg clss) + , GTree (Base_Final key (Tritone deg) DomClass n) + , GTree (Base_Final key (IIbDim deg) DimClass n) + ) => GTree (Base_Final key deg clss (Su n)) where + gTree (Base_Final d) = gTree d + -- The tritone substitution of a relative V is as alsway one semitone above + -- the chord it is preceding + gTree (Final_Tritone d) = toGTree Trit 6 d + gTree (Final_Dim_V d) = toGTree DimTrit 11 d + +-- Ad-hoc cases for Surface_Chord +instance GTree (Surface_Chord key deg clss Ze) where + gTree _ = error "gTree: impossible?" + +instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) + , GTree (Surface_Chord key (MinThird deg) DimClass n) + ) => GTree (Surface_Chord key deg clss (Su n)) where + gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] + gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print? + +-------------------------------------------------------------------------------- +-- Ad hoc getDegree instaces +-------------------------------------------------------------------------------- +toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree +toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t) + +toSDVal :: (GetDegree a) => a -> ScaleDegree +toSDVal d = let (a,i) = getDeg d in transposeSem a i + +-- Given a degree getDegee ensures that all information about the internal +-- structure of a scale degree,i.e. the degree and the an int value representing +-- the transposition of that degree at the current level, is available. +class GetDegree a where + getDeg :: a -> (ScaleDegree, Int) + +instance GetDegree (Base_SD key deg clss n) where + getDeg (Base_SD d) = getDeg d + getDeg (Cons_Vdom _ d) = getDeg d + getDeg (Cons_Diat _ d) = getDeg d + getDeg (Cons_DiatM _ d) = getDeg d + getDeg (Cons_DiatM' _ d) = getDeg d + getDeg (Cons_Vmin _ d) = getDeg d + +instance ( GetDegree (Base_Final key deg clss Ze)) where + getDeg = error "getDegree: impossible?" +instance GetDegree (Base_Final key deg clss n) where + getDeg (Base_Final d) = getDeg d + -- The tritone substitution of a relative V is as always one semitone above + -- the chord it is preceding + getDeg (Final_Tritone d) = second (+6) (getDeg d) + getDeg (Final_Dim_V d) = second (+1) (getDeg d) + +instance ( GetDegree (Surface_Chord key deg clss Ze)) where + getDeg = error "getDegree: impossible?" + +instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) + ) => GetDegree (Surface_Chord key deg clss (Su n)) where + getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) + getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) + +-------------------------------------------------------------------------------- +-- Instances of Representable for music datatypes +-------------------------------------------------------------------------------- + +deriveAllL allTypes + +$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) + allTypes) + +$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) + allTypes) + +-------------------------------------------------------------------------------- +-- ChordToken as tokens +-------------------------------------------------------------------------------- + +instance IsLocationUpdatedBy Int ChordToken where + advance p c = p + chordNumReps c diff --git a/src/HarmTrace/Models/Pop/Main.hs b/src/HarmTrace/Models/Pop/Main.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Pop/Main.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HarmTrace.Models.Pop.Main ( + pPop + , module HarmTrace.Models.Pop.Model + ) where + +-- Parser stuff +import Text.ParserCombinators.UU + +-- Music stuff +import HarmTrace.Base.MusicRep +import HarmTrace.Models.Parser +import HarmTrace.Models.Pop.Model hiding (PD,PT) + +import HarmTrace.Models.Pop.Instances () + + +-------------------------------------------------------------------------------- +-- From tokens to structured music pieces +-------------------------------------------------------------------------------- + +pPieceMaj, pPieceMin :: forall key. PMusic [Piece key] +pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase key MajMode]) +pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase key MinMode]) + +pPop :: forall key. Key -> PMusic [Piece key] +pPop (Key _ MajMode) = pPieceMaj +pPop (Key _ MinMode) = pPieceMin + diff --git a/src/HarmTrace/Models/Pop/Model.hs b/src/HarmTrace/Models/Pop/Model.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Pop/Model.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Models.Pop.Model where + +import HarmTrace.Base.TypeLevel + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens +import Language.Haskell.TH.Syntax (Name) + +-------------------------------------------------------------------------------- +-- Musical structure as a datatype +-------------------------------------------------------------------------------- + +-- perhaps this module should be named differently, like Model or HarmonyModel + +data MajMode +data MinMode + +-- High level structure +-- 'key' is not used yet +data Piece key = forall mode. Piece [Phrase key mode] + +-- The Phrase level +data Phrase key mode where + PT :: Ton key mode -> Phrase key mode + PD :: Dom key mode -> Phrase key mode + +-- Harmonic categories +-- Tonic +data Ton key mode where + -- major mode + T_1 :: Final key I MajClass -> Ton key MajMode + T_2 :: Final key I MajClass -> Final key IV MajClass + -> Final key I MajClass -> Ton key MajMode + -- T_3 :: Final key I MajClass -> Final key I DimClass + -- -> Final key I MajClass -> Ton key MajMode + -- blues + -- T_4_bls :: Final key I DomClass -> Ton key mode + + -- T_5_par :: Final key III MinClass -> Ton key MajMode + T_6_bor :: TMinBorrow key -> Ton key MajMode + + -- minor mode + Tm_1 :: SD key MinMode I MinClass -> Ton key MinMode + Tm_2 :: Final key I MinClass -> Final key IV MinClass + -> Final key I MinClass -> Ton key MinMode + Tm_3 :: Final key I MinClass -> Final key IV MinClass + -> Final key I MinClass -> Ton key MinMode + -- Tm_4_par :: Final key IIIb MajClass -> Ton key MinMode + Tm_6_bor :: TMajBorrow key -> Ton key MinMode -- picardy third etc. + +-- Dominant +data Dom key mode where + -- major mode + D_1 :: SDom key mode -> Dom key mode -> Dom key mode + D_2 :: SD key mode V DomClass -> Dom key mode + -- I would like to model this with a SD VIs dimClass, but somehow, + -- this causes a ToDegree loop + -- D_3 :: SD key mode IIIb DimClass -> + -- Final key V DomClass -> Dom key mode -- not in CMJ + D_4 :: SD key mode V MajClass -> Dom key mode + -- D_5 :: Final key V DomClass -> Final key V DimClass + -- -> Final key V DomClass -> Dom key mode + -- D_6 :: Final key VII DimClass -> Dom key MajMode + D_7 :: SD key MajMode VII MinClass -> Dom key MajMode + -- moll-dur: minor mode borrowings in major + -- This would be an elegant way of defining major minor borrowing, + -- but it causes a lot of unwanted abmiguities since all the mode + -- rules can be explained with and without borrowing + -- D_9_bor :: Dom key MinMode -> Dom key MajMode + D_8_bor :: DMinBorrow key -> Dom key MajMode + + -- minor mode (there must be at least one rule with "MinMode" otherwise + -- no you get a "No instance for (ParseG (Dom key MinMode))" error + Dm_1 :: SD key MinMode VIIb MajClass -> Dom key MinMode + Dm_2_bor :: DMajBorrow key -> Dom key MinMode + +-- Subdominant +data SDom key mode where + S_1_par :: SD key mode II MinClass -> SDom key mode -- sub dom parallel + -- S_2_bls :: SD key mode IV DomClass -> SD key mode I DomClass + -- -> SDom key mode + -- Pretty printing? this rule compensates for the V/I Imp + -- to be able to parse D:7 D:min G:7 C:maj (not in cmj) + S_3_par :: SD key mode II DomClass -> Final key II MinClass + -> SDom key mode + S_4 :: SD key MajMode IV MajClass -> SDom key MajMode + S_5 :: SD key MajMode III MinClass -> Final key IV MajClass + -> SDom key MajMode + -- S_6_par :: SD key MajMode VI MinClass -> SDom key MajMode + + -- Borrowing from minor in a major mode + -- S_7_bor :: SDom key MajMode -> SDom key MinMode + S_7_bor :: SMinBorrow key -> SDom key MajMode + + -- minor mode + Sm_1 :: SD key MinMode IV MinClass -> SDom key MinMode + Sm_2 :: SD key MinMode IIIb MajClass -> Final key IV MinClass + -> SDom key MinMode + -- Sm_3_par :: SD key MinMode VIb MajClass -> SDom key MinMode + -- perhaps add a functional node for Neapolitan chords? + Sm_4 :: SD key MinMode IIb MajClass -> SDom key MinMode -- Neapolitan + Sm_5_bor :: SMajBorrow key -> SDom key MinMode + +-- Borrowings from minor in a major key +data TMinBorrow key = Tm_20_bor (SD key MinMode IIIb MajClass) + +data DMinBorrow key = Dm_20_bor (SD key MinMode VIIb MajClass) + -- | Dm_21_bor (Final key VIIb DomClass) + +data SMinBorrow key = Sm_20_bor (SD key MinMode IV MinClass) + -- | Sm_21_bor (SD key MinMode VIb MajClass) + | Sm_22_bor (SD key MinMode IIb MajClass) -- Neapolitan + + +-- Borrowings from major in a minor key +data TMajBorrow key = T_20_bor (SD key MajMode I MajClass) + | T_21_bor (SD key MajMode III MinClass) + +data DMajBorrow key = D_20_bor (SD key MajMode VII MinClass) + -- | D_21_bor (Final key VII DimClass) + +data SMajBorrow key = S_20_bor (SD key MajMode IV MajClass) + + +-- Limit secondary dominants to a few levels +type SD key mode deg clss = Base_SD key deg clss T5 + +-- a type that can be substituted by its tritone sub and diminished 7b9 +type TritMinVSub key deg clss = Base_Final key deg clss T2 + +-- A Scale degree that can only translate to a surface chord +-- and allows for the transformation into enharmonic equivalent +-- diminshed surface chords +type FinalDimTrans key deg clss = Surface_Chord key deg clss T4 + +-- A Scale degree that translates into a (non-tranformable) surface chord +type Final key deg clss = Surface_Chord key deg clss T1 + + +-- Datatypes for clustering harmonic degrees +-- type Base_SD key deg clss n = List (Base_SD' key deg clss n) T4 + +data Base_SD key deg clss n where + Base_SD :: TritMinVSub key deg clss -- Min5 key deg clss n + -> Base_SD key deg clss (Su n) + -- Rule for explaining perfect secondary dominants + Cons_Vdom :: Base_SD key (VDom deg) DomClass n -> Base_SD key deg clss n + -> Base_SD key deg clss (Su n) + Cons_Diat :: Base_SD key (DiatV deg) MinClass n -> Base_SD key deg MinClass n + -> Base_SD key deg MinClass (Su n) + Cons_DiatM :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MajClass n + -> Base_SD key deg MajClass (Su n) + Cons_DiatM' :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MinClass n + -> Base_SD key deg MinClass (Su n) + -- Minor fifth insertion + Cons_Vmin :: Base_SD key (VMin deg) MinClass n -> Base_SD key deg DomClass n + -> Base_SD key deg DomClass (Su n) + + +data Base_Final key deg clss n where + -- Just a "normal", final degree. The Strings are the original input. + Base_Final :: FinalDimTrans key deg clss -> Base_Final key deg clss (Su n) + -- Tritone substitution + Final_Tritone :: Base_Final key (Tritone deg) DomClass n + -> Base_Final key deg DomClass (Su n) + Final_Dim_V :: Base_Final key (IIbDim deg) DimClass n + -> Base_Final key deg DomClass (Su n) + +-- Dimished tritone substitution accounting for dimished chord transistions +data Surface_Chord key deg clss n where + Surface_Chord :: ChordToken + -> Surface_Chord key deg clss (Su n) + Dim_Chord_Trns :: Surface_Chord key (MinThird deg) DimClass n + -> Surface_Chord key deg DimClass (Su n) + +-------------------------------------------------------------------------------- +-- Type Level Scale Degrees +-------------------------------------------------------------------------------- + +-- typelevel chord classes +data MajClass +data MinClass +data DomClass +data DimClass + +-- Degrees (at the type level) +data I +data Ib +data Is +data II +data IIb +data IIs +data III +data IIIb +data IIIs +data IV +data IVb +data IVs +data V +data Vb +data Vs +data VI +data VIb +data VIs +data VII +data VIIb +data VIIs + +-- Used when we don't want to consider certain possibilities +data Imp + +-- Degrees at the value level are in Tokenizer +-- Type to value conversions +class ToClass clss where + toClass :: clss -> ClassType + +instance ToClass MajClass where toClass _ = MajClass +instance ToClass MinClass where toClass _ = MinClass +instance ToClass DomClass where toClass _ = DomClass +instance ToClass DimClass where toClass _ = DimClass + +-- The class doesn't really matter, since the degree will be impossible to parse +instance ToClass Imp where toClass _ = DimClass + +class ToDegree deg where + toDegree :: deg -> ScaleDegree + +instance ToDegree I where toDegree _ = Note Nothing I +instance ToDegree II where toDegree _ = Note Nothing II +instance ToDegree III where toDegree _ = Note Nothing III +instance ToDegree IV where toDegree _ = Note Nothing IV +instance ToDegree V where toDegree _ = Note Nothing V +instance ToDegree VI where toDegree _ = Note Nothing VI +instance ToDegree VII where toDegree _ = Note Nothing VII +instance ToDegree Ib where toDegree _ = Note (Just Fl) I +instance ToDegree IIb where toDegree _ = Note (Just Fl) II +instance ToDegree IIIb where toDegree _ = Note (Just Fl) III +instance ToDegree IVb where toDegree _ = Note (Just Fl) IV +instance ToDegree Vb where toDegree _ = Note (Just Fl) V +instance ToDegree VIb where toDegree _ = Note (Just Fl) VI +instance ToDegree VIIb where toDegree _ = Note (Just Fl) VII +instance ToDegree IIs where toDegree _ = Note (Just Sh) II +instance ToDegree IIIs where toDegree _ = Note (Just Sh) III +instance ToDegree IVs where toDegree _ = Note (Just Sh) IV +instance ToDegree Vs where toDegree _ = Note (Just Sh) V +instance ToDegree VIs where toDegree _ = Note (Just Sh) VI +instance ToDegree VIIs where toDegree _ = Note (Just Sh) VII + +-- Can't ever parse these +instance ToDegree Imp where toDegree _ = Note Nothing Imp + + +-------------------------------------------------------------------------------- +-- Type Families for Relative Scale Degrees +-------------------------------------------------------------------------------- + + +-- Diatonic fifths, and their class (comments with the CMaj scale) +-- See http://en.wikipedia.org/wiki/Circle_progression +type family DiatV deg :: * +type instance DiatV I = Imp -- V -- G7 should be Dom +type instance DiatV V = Imp -- II -- Dm7 should be SDom +type instance DiatV II = VI -- Am7 +type instance DiatV VI = III -- Em7 +type instance DiatV III = VII -- Bhdim7 can be explained by Dim rule +type instance DiatV VII = Imp -- IV -- FMaj7 should be SDom +type instance DiatV IV = Imp -- I -- CMaj7 + +type instance DiatV IIb = Imp +type instance DiatV IIIb = Imp +type instance DiatV IVs = Imp +type instance DiatV VIb = Imp +type instance DiatV VIIb = Imp +type instance DiatV Imp = Imp + +type family DiatVM deg :: * +type instance DiatVM I = Imp -- V -- G7 should be Dom +type instance DiatVM V = Imp -- Dm7 should be SDom +type instance DiatVM II = VIb -- Ab +type instance DiatVM VI = Imp -- Em7 +type instance DiatVM III = Imp -- Bhdim7 can be explained by Dim rule +type instance DiatVM VII = Imp -- IV -- FMaj7 should be SDom +type instance DiatVM IV = Imp -- I -- CMaj7 + +type instance DiatVM IIb = Imp +type instance DiatVM IIIb = VIIb +type instance DiatVM IVs = Imp +type instance DiatVM VIb = IIIb +type instance DiatVM VIIb = Imp +type instance DiatVM Imp = Imp + +-------------------------------------------------------------------------------- +-- Type families for secondary dominants +-------------------------------------------------------------------------------- + +-- Perfect fifths (class is always Dom) +-- See http://en.wikipedia.org/wiki/Circle_of_fifths +type family VDom deg :: * + +type instance VDom I = Imp -- interferes with dom +type instance VDom IIb = VIb +type instance VDom II = VI +type instance VDom IIIb = VIIb -- interferes with Dm_3 +type instance VDom III = VII +type instance VDom IV = I +type instance VDom IVs = IIb +type instance VDom V = II -- interferes with Sm_1 +type instance VDom VIb = IIIb +type instance VDom VI = III +type instance VDom VIIb = IV +type instance VDom VII = IVs +type instance VDom Imp = Imp + +-- Perfect fifths for the minor case (this is an additional +-- type family to controll the reduction of ambiguities +-- specifically in the minor case) +type family VMin deg :: * +type instance VMin I = V +type instance VMin IIb = VIb +type instance VMin II = VI -- interferes with sub +type instance VMin IIIb = VIIb +type instance VMin III = VII +type instance VMin IV = I +type instance VMin IVs = IIb +type instance VMin V = Imp -- II interferes with sub +type instance VMin VIb = IIIb +type instance VMin VI = III +type instance VMin VIIb = Imp --IV -- inteferes with sub IV:min +type instance VMin VII = IVs +type instance VMin Imp = Imp + +-- The tritone substitution +-- See http://en.wikipedia.org/wiki/Tritone_substitution +type family Tritone deg :: * +type instance Tritone I = IVs +type instance Tritone IVs = I + +type instance Tritone IIb = V -- gives undesired (ambiguous results) as +type instance Tritone V = IIb -- Dom = IIb/I = IIbdim + +type instance Tritone II = VIb -- interferes IIbDim V +type instance Tritone VIb = II + +type instance Tritone IIIb = VI +type instance Tritone VI = IIIb + +type instance Tritone III = VIIb -- Interferes with VIIb from minor +type instance Tritone VIIb = III + +type instance Tritone IV = VII +type instance Tritone VII = IV + +type instance Tritone Imp = Imp + + +-------------------------------------------------------------------------------- +-- Type families for diminished chord transformations +-------------------------------------------------------------------------------- + +-- in combination with the secondary dominants and enharmonic equivalency +-- these type families account for ascending dim chord progressions +type family IIbDim deg :: * +type instance IIbDim I = IIb +type instance IIbDim IIb = II +type instance IIbDim II = IIIb +type instance IIbDim IIIb = III +type instance IIbDim III = IV +type instance IIbDim IV = IVs +type instance IIbDim IVs = V +type instance IIbDim V = VIb -- interferes with dim tritone V/V +type instance IIbDim VIb = VI +type instance IIbDim VI = VIIb +type instance IIbDim VIIb = VII +type instance IIbDim VII = I +type instance IIbDim Imp = Imp + +-- Dimchords can be transposed a minor third without changing their role, +-- they are enharmonically equivalent. +type family MinThird deg :: * +type instance MinThird I = IIIb +type instance MinThird IIb = III +type instance MinThird II = IV +type instance MinThird IIIb = IVs +type instance MinThird III = V +type instance MinThird IV = VIb +type instance MinThird IVs = VI +type instance MinThird V = VIIb +type instance MinThird VIb = VII +type instance MinThird VI = I +type instance MinThird VIIb = IIb +type instance MinThird VII = II +type instance MinThird Imp = Imp + +-- Belongs in Instances, but needs to be here due to staging restrictions +allTypes :: [Name] +allTypes = [ ''Phrase, ''Ton, ''Dom, ''SDom + , ''TMinBorrow, ''DMinBorrow, ''SMinBorrow + , ''TMajBorrow, ''DMajBorrow, ''SMajBorrow ] diff --git a/src/HarmTrace/Models/Test/Instances.hs b/src/HarmTrace/Models/Test/Instances.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Test/Instances.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Models.Test.Instances where + +-- Generics stuff +import Generics.Instant.TH + +-- Parser stuff +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances hiding (Inserted) + +-- GTree stuff +import HarmTrace.HAnTree.Tree +import HarmTrace.HAnTree.ToHAnTree + +-- Music stuff +import HarmTrace.Base.MusicRep +import HarmTrace.Models.Parser +import HarmTrace.Models.Test.Model +import HarmTrace.Tokenizer.Tokens + + +-- A very, very permissive model. +instance ParseG NoteTest where + parseG = NoteTest <$> pSatisfy recognize insertion where + recognize = const True + insertion = Insertion "ChordToken" + (ChordToken (Note Nothing I) MajClass [] Inserted 1 0) 5 + + +instance GTree PieceTest where + gTree (PieceTest ns) = [Node (HAn 0 "Pie") (gTree ns) Nothing] + +instance GTree NoteTest where + gTree (NoteTest c) = [Node (HAnChord c) [] Nothing] + +-------------------------------------------------------------------------------- +-- Instances of Representable for music datatypes +-------------------------------------------------------------------------------- + +deriveAllL allTypes + +$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) + allTypes) +{- +$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) + allTypes) +-} +-------------------------------------------------------------------------------- +-- ChordToken as tokens +-------------------------------------------------------------------------------- + +instance IsLocationUpdatedBy Int ChordToken where + advance p c = p + chordNumReps c diff --git a/src/HarmTrace/Models/Test/Main.hs b/src/HarmTrace/Models/Test/Main.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Test/Main.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HarmTrace.Models.Test.Main ( + pPieceTest + , module HarmTrace.Models.Test.Model + ) where + +-- Music stuff +import HarmTrace.Models.Parser +import HarmTrace.Models.Test.Model + +import HarmTrace.Models.Test.Instances () + + +-------------------------------------------------------------------------------- +-- From tokens to structured music pieces +-------------------------------------------------------------------------------- + +pPieceTest :: PMusic [PieceTest] +pPieceTest = parseG diff --git a/src/HarmTrace/Models/Test/Model.hs b/src/HarmTrace/Models/Test/Model.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Models/Test/Model.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Models.Test.Model where + +import Language.Haskell.TH.Syntax (Name) +import HarmTrace.Tokenizer.Tokens + + +data PieceTest = PieceTest [NoteTest] + +data NoteTest = NoteTest ChordToken + +-- Belongs in Instances, but needs to be here due to staging restrictions +allTypes :: [Name] +allTypes = [ ''PieceTest ] diff --git a/src/HarmTrace/Tokenizer/Tokenizer.hs b/src/HarmTrace/Tokenizer/Tokenizer.hs --- a/src/HarmTrace/Tokenizer/Tokenizer.hs +++ b/src/HarmTrace/Tokenizer/Tokenizer.hs @@ -3,7 +3,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} -module HarmTrace.Tokenizer.Tokenizer (parseSongAbs, pString, mergeDups) where +module HarmTrace.Tokenizer.Tokenizer ( parseChordTokens {-not used yet-} + , parseSongAbs, toKeyRelTok) where import HarmTrace.Base.Parsing import HarmTrace.Base.MusicRep @@ -15,26 +16,32 @@ -- Tokenizing: parsing strings into tokens -------------------------------------------------------------------------------- --- TODO: mergeDups is now exported, perhaps integrade into parseSongAbs? --- Merges duplicate chords -mergeDups :: Key -> [ChordLabel] -> [ChordToken] -mergeDups k (c@(Chord r sh _add _loc d):cs) = - mergeDups' k (ChordToken (toScaleDegree k r) (toClassType sh) [c] NotParsed 1 d) cs -mergeDups _k [] = [] -mergeDups' :: Key -> ChordToken -> [ChordLabel] -> [ChordToken] -mergeDups' _k p [] = [p] -mergeDups' k p@(ChordToken deg clss cs' _stat n d1) (c@(Chord r sh _a _loc d2):cs) +-- toplevel parser: parses a string of chord labels into a key relative +-- representation +parseChordTokens :: ListLike s Char => s -> (PieceLabel ,[Error LineColPos]) +parseChordTokens inp = parseDataWithErrors parseSongAbs inp + +-- Merges duplicate chords and transforms absolute chord labels into key +-- relative tokens that can be parsed by the HarmTrace model +-- (previously called mergeDups) +toKeyRelTok :: Key -> [ChordLabel] -> [ChordToken] +toKeyRelTok k (c@(Chord r sh _add _loc d):cs) = toKeyRelTok' k + (ChordToken (toScaleDegree k r) (toClassType sh) [c] NotParsed 1 d) cs +toKeyRelTok _key [] = [] +toKeyRelTok' :: Key -> ChordToken -> [ChordLabel] -> [ChordToken] +toKeyRelTok' _k p [] = [p] +toKeyRelTok' k p@(ChordToken deg clss cs' _stat n d1) (c@(Chord r sh _a _l d2):cs) | deg == deg2 && clss == clss2 = - mergeDups' k (ChordToken deg clss (cs' ++ [c]) NotParsed (n+1) (d1+d2)) cs - | otherwise = p : mergeDups' k (ChordToken deg2 clss2 [c] NotParsed 1 d2) cs + toKeyRelTok' k (ChordToken deg clss (cs' ++ [c]) NotParsed (n+1) (d1+d2)) cs + | otherwise = p : toKeyRelTok' k (ChordToken deg2 clss2 [c] NotParsed 1 d2) cs where clss2 = toClassType sh deg2 = toScaleDegree k r -- Input is a string of whitespace-separated chords, e.g. -- Bb:9(s11) E:min7 Eb:min7 Ab:7 D:min7 G:7(13) C:maj6(9) -- First token is the key of the piece -parseSongAbs :: Parser PieceAbsToken -- PieceRelToken -- -parseSongAbs = PieceToken <$> parseKey <* pLineEnd +parseSongAbs :: Parser PieceLabel -- PieceRelToken -- +parseSongAbs = PieceLabel <$> parseKey <* pLineEnd <*> (setLoc 0 <$> pListSep_ng pLineEnd parseChord ) <* pList pLineEnd where setLoc :: Int -> [Chord a] -> [Chord a] diff --git a/src/HarmTrace/Tokenizer/Tokens.hs b/src/HarmTrace/Tokenizer/Tokens.hs --- a/src/HarmTrace/Tokenizer/Tokens.hs +++ b/src/HarmTrace/Tokenizer/Tokens.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceAbsToken +module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceLabel (..) , PieceToken (..), ParseStatus (..) ) where @@ -17,8 +17,8 @@ -------------------------------------------------------------------------------- -- merged Chords that will be presented to the parser -data ChordToken = ChordToken { _root :: ScaleDegree - , _classType :: ClassType +data ChordToken = ChordToken { root :: ScaleDegree + , classType :: ClassType , chords :: [ChordLabel] , status :: ParseStatus , chordNumReps :: Int @@ -30,8 +30,9 @@ -- a datatype to store a tokenized chords -- type PieceRelToken = PieceToken ChordDegree -type PieceAbsToken = PieceToken ChordLabel -data PieceToken a = PieceToken { pieceKey :: Key, labels :: [a] } +-- type PieceAbsToken = PieceToken ChordLabel +data PieceToken = PieceToken Key [ChordToken] +data PieceLabel = PieceLabel Key [ChordLabel] -------------------------------------------------------------------------------- -- Instances for Chord Tokens diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,29 +1,24 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleInstances #-} module Main where -- Libs -import System.Console.ParseArgs hiding (args) -- cabal install parseargs -import System.FilePath -import System.IO -import Data.Maybe (isJust, fromJust) -import Data.Binary +import System.Console.ParseArgs hiding (args) -- Music stuff import HarmTrace.HarmTrace -import HarmTrace.Base.MusicRep import HarmTrace.IO.Main import HarmTrace.IO.Errors -import HarmTrace.Matching.GuptaNishimuraEditMatch -import HarmTrace.Matching.Standard -import HarmTrace.Matching.Matching import HarmTrace.IO.PrintTree -import HarmTrace.HAnTree.Tree (Tree) -import HarmTrace.HAnTree.HAn -import HarmTrace.Matching.Sim (selfSim) +import HarmTrace.HAnTree.ToHAnTree (gTreeHead) +--import HarmTrace.Matching.GuptaNishimuraEditMatch +import HarmTrace.Matching.Standard +-- import HarmTrace.Matching.Matching (printBPM) +import HarmTrace.Matching.Alignment (getAlignDist, alignChordLab, pPrintV, alignHAnChord) +-- import HarmTrace.Matching.Sim (maxSim) +import Data.List (delete) --- Parallelism -import Control.Parallel.Strategies -------------------------------------------------------------------------------- -- Command-line arguments @@ -31,6 +26,7 @@ data MyArgs = SourceInputString | SourceInputFile | TargetInputFile | InputDir | OpMode | Print | MaxErrorRate | BinaryOut | BinaryIn + | PrintIns | Grammar deriving (Eq, Ord, Show) myArgs :: [Arg MyArgs] @@ -63,22 +59,32 @@ argAbbr = Just 'd', argName = Just "dir", argData = argDataOptional "directory" ArgtypeString, - argDesc = "Input directory (to process all files within)" + argDesc = "Input directory (process all files within)" }, Arg { argIndex = OpMode, argAbbr = Just 'm', argName = Just "mode", - argData = argDataRequired "parse|stdiff|lces|bpm" - ArgtypeString, - argDesc = "One of \"parse\", \"lces\", \"stdiff\", "++ - "or \"bpm\"" + argData = argDataRequired "string" ArgtypeString, + argDesc = "Matching mode (parse|stdiff|lces|hanlign|align)" }, + Arg { argIndex = Grammar, + argAbbr = Just 'g', + argName = Just "grammar", + argData = argDataRequired "string" ArgtypeString, + argDesc = "Grammar to use (jazz|test|pop)" + }, Arg { argIndex = Print, argAbbr = Just 'p', argName = Just "print", argData = Nothing, - argDesc = "Set this flag to generate a .png for an input file" + argDesc = "Set this flag to print a .png of the parse" }, + Arg { argIndex = PrintIns, + argAbbr = Just 's', + argName = Just "print-insertions", + argData = Nothing, + argDesc = "Set this flag to show inserted nodes" + }, Arg { argIndex = BinaryOut, argAbbr = Just 'o', argName = Just "out", @@ -90,17 +96,18 @@ argName = Just "in", argData = argDataOptional "filepath" ArgtypeString, argDesc = "Input binary file for matching" - } + } ] -------------------------------------------------------------------------------- -- Main -------------------------------------------------------------------------------- - -data MatchMode = STDiff | LCES | BPMatch - deriving (Eq, Ord, Show) - +-- by default all post processing operations are executed +defaultOpts :: [PPOption] +defaultOpts = [ RemovePDPT , RemoveInsertions + , MergeDelChords, ExpandChordDurations ] + err1, err2, err3 :: String err1 = "Use a source file, or a directory." err2 = "Use a source file and a target file, or a directory." @@ -108,49 +115,65 @@ main :: IO () main = do args <- parseArgsIO ArgsComplete myArgs - let mode = getRequiredArg args OpMode - prnt = gotArg args Print + let mode = getRequiredArg args OpMode + grmS = getRequiredArg args Grammar + prnt = gotArg args Print + opts = if gotArg args PrintIns + then delete RemoveInsertions defaultOpts else defaultOpts + gram = case grmS of + "jazz" -> GrammarEx Jazz + "pop" -> GrammarEx Pop + "test" -> GrammarEx Test + s -> usageError args ("Unknown grammar: " ++ s) case mode of - "parse" -> mainParse prnt - "stdiff" -> mainMatch False STDiff - "bpm" -> mainMatch prnt BPMatch - "lces" -> mainMatch prnt LCES + "parse" -> mainParse args opts prnt gram + "stdiff" -> mainMatch args opts False STDiff gram + "hanlign"-> mainMatch args opts prnt HAnAlign gram + "lces" -> mainMatch args opts prnt LCES gram + "align" -> mainMatch args opts prnt Align gram s -> usageError args ("Unknown mode: " ++ s) -mainParse :: Bool -> IO () -mainParse p = do args <- parseArgsIO ArgsComplete myArgs - let cStr = getArgString args SourceInputString - mf1 = getArgString args SourceInputFile - mf2 = getArgString args TargetInputFile - bOut = getArgString args BinaryOut - mdir = getArgString args InputDir - case (cStr, mf1,mf2,mdir, p) of - -- parse a string of chords - (Just c, Nothing, Nothing, Nothing , False) -> - parseTree c >> return () - (Just c, Nothing, Nothing, Nothing , True) -> - do ts <- parseTree c - printTreeHAnF ts (trimFilename c) >> return () - -- Parse one file, show full output - (Nothing, Just f1, Nothing, Nothing , False) -> - do ts <- readFile f1 >>= parseTreeVerb - mapM_ print ts - (Nothing, Just f1, Nothing, Nothing , True ) -> - --with post processing - do ts <- readFile f1 >>= parseTree - printTreeHAnF ts f1 >> return () - -- Parse all files in one dir, show condensed output - (Nothing, Nothing, Nothing, Just dir, False) -> - parseDir dir bOut - _ -> usageError args err1 + +mainParse :: Args MyArgs -> [PPOption] -> Bool -> GrammarEx -> IO () +mainParse args o p (GrammarEx g) = + do let cStr = getArgString args SourceInputString + mf1 = getArgString args SourceInputFile + mf2 = getArgString args TargetInputFile + bOut = getArgString args BinaryOut + mdir = getArgString args InputDir + case (cStr, mf1,mf2,mdir, p) of + -- parse a string of chords + (Just c, Nothing, Nothing, Nothing , False) -> + do pr <- parseTreeVerb g o c + mapM_ (print . gTreeHead) (parsedPiece pr) + -- and print a parsetree + (Just c, Nothing, Nothing, Nothing , True) -> + do pr <- parseTree g o c + let ts = map gTreeHead (parsedPiece pr) + _ <- printTreeHAn (pieceTreeHAn pr) (trimFilename ("pp" ++ c)) + printTreeHAnF ts (trimFilename c) >> return () + -- Parse one file, show full output + (Nothing, Just f1, Nothing, Nothing , False) -> + do pr <- readFile f1 >>= parseTreeVerb g o + print (pieceTreeHAn pr) + mapM_ (print . gTreeHead) (parsedPiece pr) + (Nothing, Just f1, Nothing, Nothing , True ) -> + --with post processing + do pr <- readFile f1 >>= parseTree g o + let ts = map gTreeHead (parsedPiece pr) + printTreeHAn (pieceTreeHAn pr) (f1 ++ ".postProc") >> return () + printTreeHAnF ts f1 >> return () + -- Parse all files in one dir, show condensed output + (Nothing, Nothing, Nothing, Just dir, False) -> + parseDir g o dir bOut + _ -> usageError args err1 trimFilename :: String -> String trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 -mainMatch :: Bool -> MatchMode -> IO () -mainMatch p m = - do args <- parseArgsIO ArgsComplete myArgs - let cStr = getArgString args SourceInputString +mainMatch :: Args MyArgs -> [PPOption] -> Bool -> MatchMode -> GrammarEx -> IO () +mainMatch args o p m (GrammarEx g) = + do let cStr = getArgString args SourceInputString mf1 = getArg args SourceInputFile mf2 = getArg args TargetInputFile mdir = getArg args InputDir @@ -161,87 +184,34 @@ (_,Just f1, Just f2, Nothing, prnt) -> do c1 <- readFile' f1 c2 <- readFile' f2 - matchFiles m prnt c1 c2 f1 f2 + matchFiles o m prnt c1 c2 f1 f2 (Just c, Just f1, Nothing, Nothing, True) -> - matchFiles m True c f1 (trimFilename c) (trimFilename f1) + matchFiles o m True c f1 (trimFilename c) (trimFilename f1) -- match all files in one dir, show condensed output - (_,Nothing, Nothing, Just dir, False) -> testDirMatch bIn m me dir + (_,Nothing, Nothing, Just dir, False) -> dirMatch g o bIn m me dir _ -> usageError args err2 -printSelfSims :: Tree HAn -> Tree HAn -> IO() -printSelfSims a b = putStrLn (str a ++ str b) where - str x = "self similarity" ++ (show $ selfSim x) - -matchFiles :: MatchMode -> Bool -> String -> String -> String -> String -> IO () -matchFiles m prnt f1 f2 _n1 _n2 = - let (toks1, _, ts1, te1, pe1) = string2PieceCPostProc f1 - (toks2, _, ts2, te2, pe2) = string2PieceCPostProc f2 +matchFiles :: [PPOption] -> MatchMode -> Bool -> String -> String + -> String -> String -> IO () +matchFiles o m prnt f1 f2 _n1 _n2 = + -- should move to HarmTrace.IO.Main + let (ParseResult key1 toks1 _ ts1 _nr1 te1 pe1 _) + = postProc o $ string2Piece Jazz f1 + (ParseResult key2 toks2 _ ts2 _nr2 te2 pe2 _) + = postProc o $ string2Piece Jazz f2 in do if not $ null te1 then showErrors "tokenizer 1: " te1 else putStr "" if not $ null te2 then showErrors "tokenizer 2: " te2 else putStr "" if not $ null pe1 then showErrors "parser 1: " pe1 else putStr "" if not $ null pe2 then showErrors "parser 2: " pe2 else putStr "" case (m,prnt) of - (STDiff,_) -> print (diffChordsLen toks1 toks2) - (BPMatch,True) -> printBPM 2 (head ts1) (head ts2) - (BPMatch,False) -> error "Unimplemented." -- putStrLn ( "score: " ++ show (getMatch 2 ts1 ts2)) - (LCES,False) -> do - printSelfSims (head ts1) (head ts2) - putStrLn ("1vs2\n" ++show lcesab ++ "\nscore: " ++ show scoreab) - putStrLn ("2vs1\n" ++show lcesba ++ "\nscore: " ++ show scoreba) - putStrLn ("self Simlarity 1: " ++ (show . selfSim $ head ts1)) - putStrLn ("self Simlarity 2: " ++ (show . selfSim $ head ts2)) where - (lcesab,lcesba,scoreab,scoreba) = matchTwo (head ts1) (head ts2) - (LCES,True) -> do - {- printTreeHAnF (show ts1) ( n1 <.> "png") >> return () - printTreeHAnF (show ts2) ( n2 <.> "png") >> return () - printTreeHAn (show lcesab) ("match1vs2" <.> "png") - >> return () - printTreeHAn (show lcesba) ("match2vs1" <.> "png") - >> return () - printSelfSims ts1 ts2 -} - putStrLn ("refactor me"); - -matchTwo :: Tree HAn -> Tree HAn -> ([Tree HAn], [Tree HAn], Float, Float) -matchTwo ta tb = (lcesab,lcesba,scoreab,scoreba) where - (lcesab, scoreab) = getWeightLCES ta tb - (lcesba, scoreba) = getWeightLCES tb ta - --- filters the songs that have multiple versions and can be used as query -filterNonQuery :: [FilePath] -> [FilePath] -filterNonQuery = concatMap snd . filter ((>1) . length . snd) . getClassSizes - --- matches a directory of chord description files -testDirMatch :: Maybe FilePath -> MatchMode -> Maybe Float -> FilePath -> IO () -testDirMatch bIn m me fp = - do fs <- readDataDir fp - let process s = let (tks, _, ts, _, e2) = string2PieceCPostProc s - in (tks, head ts, errorRatio e2 tks) - filterError = if isJust me - then filter (\(_,_,e) -> e <= fromJust me) else id - pss <- mapM (\f -> readFile' (fp f)) fs - (tks, ps) <- case bIn of - Just bp -> decodeFile bp :: IO ([[ChordLabel]],[Tree HAn]) - Nothing -> let (toks, ps', _) = unzip3 (filterError - (map process pss)) - in return (toks, ps' `using` parList rdeepseq) - let fsq = filterNonQuery fs - putStr "true\n" - if (m == LCES || m == BPMatch) then putStr "false\n" else putStr "true\n" - mapM_ (putStr . (++ "\t")) fsq - putChar '\n' - mapM_ (putStr . (++ "\t"). getId) fs - putStrLn "" - let match sim l = [ [ sim x y | y <- l ] - | (x,i) <- zip l (map getId fs), i `elem` fsq ] - printLine l = putStrLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) - >> hFlush stdout - let r = (case m of - STDiff -> match diffChordsLen tks - LCES -> match getSimLCES ps - BPMatch -> match (getMatch 2) ps) - -- we could use nr-of-cores threads to pars nr-of-cores chunks... - -- `using` parListChunk numCapabilities rdeepseq - -- ... but this is just faster - `using` parList rdeepseq - sequence_ [ printLine x | x <- r] + (STDiff,_) -> print (diffChordsLen toks1 toks2) + (Align ,False) -> print (getAlignDist key1 key2 toks1 toks2) + (Align ,True ) -> do let (mat,v,t) = alignChordLab key1 key2 toks1 toks2 + pPrintV t; print mat ; print v + + (HAnAlign,True ) -> do let (mat,v,t) = alignHAnChord ts1 ts2 + pPrintV t; print mat ; print v + (HAnAlign,False) -> error "Unimplemented." + (LCES,False) -> error "Unimplemented." + (LCES,True) -> do putStrLn ("refactor me");