HarmTrace 0.5 → 0.6
raw patch · 25 files changed
+2914/−3 lines, 25 files
Files
- HarmTrace.cabal +34/−3
- src/HarmTrace/Base/MusicRep.hs +231/−0
- src/HarmTrace/Base/Parsing.hs +41/−0
- src/HarmTrace/Base/TypeLevel.hs +81/−0
- src/HarmTrace/HAnTree/Augment.hs +63/−0
- src/HarmTrace/HAnTree/Binary.hs +59/−0
- src/HarmTrace/HAnTree/HAn.hs +209/−0
- src/HarmTrace/HAnTree/HAnParser.hs +43/−0
- src/HarmTrace/HAnTree/ToHAnTree.hs +41/−0
- src/HarmTrace/HAnTree/Tree.hs +163/−0
- src/HarmTrace/HarmTrace.hs +73/−0
- src/HarmTrace/IO/Errors.hs +50/−0
- src/HarmTrace/IO/Main.hs +163/−0
- src/HarmTrace/IO/PrintTree.hs +80/−0
- src/HarmTrace/Matching/FlatMatch.hs +121/−0
- src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs +150/−0
- src/HarmTrace/Matching/Matching.hs +186/−0
- src/HarmTrace/Matching/Sim.hs +86/−0
- src/HarmTrace/Matching/Standard.hs +25/−0
- src/HarmTrace/Model/Instances.hs +286/−0
- src/HarmTrace/Model/Main.hs +28/−0
- src/HarmTrace/Model/Model.hs +412/−0
- src/HarmTrace/Model/Parser.hs +76/−0
- src/HarmTrace/Tokenizer/Tokenizer.hs +149/−0
- src/HarmTrace/Tokenizer/Tokens.hs +64/−0
HarmTrace.cabal view
@@ -1,5 +1,5 @@ name: HarmTrace -version: 0.5 +version: 0.6 synopsis: Harmony Analysis and Retrieval of Music description: HarmTrace: Harmony Analysis and Retrieval of Music with Type-level Representations of Abstract @@ -9,7 +9,7 @@ for automatically analysing the harmony of music sequences. HarmTrace is described in the paper: . - * José Pedro Magalhães and W. Bas de Haas. + * Jose Pedro Magalhaes and W. Bas de Haas. /Experience Report: Functional Modelling of Musical Harmony./ International Conference on Functional Programming, 2011. @@ -18,7 +18,7 @@ copyright: (c) 2010--2011 Universiteit Utrecht license: OtherLicense license-file: LICENSE -author: W. Bas de Haas and José Pedro Magalhães +author: W. Bas de Haas and Jose Pedro Magalhaes stability: experimental maintainer: bash@cs.uu.nl, jpm@cs.uu.nl homepage: http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace @@ -29,6 +29,37 @@ executable harmtrace hs-source-dirs: src + other-modules: HarmTrace.HarmTrace + + HarmTrace.Base.MusicRep + HarmTrace.Base.Parsing + HarmTrace.Base.TypeLevel + + HarmTrace.HAnTree.Augment + HarmTrace.HAnTree.Binary + HarmTrace.HAnTree.HAn + HarmTrace.HAnTree.HAnParser + HarmTrace.HAnTree.ToHAnTree + HarmTrace.HAnTree.Tree + + HarmTrace.IO.Errors + HarmTrace.IO.Main + HarmTrace.IO.PrintTree + + HarmTrace.Matching.FlatMatch + HarmTrace.Matching.GuptaNishimuraEditMatch + HarmTrace.Matching.Matching + HarmTrace.Matching.Sim + HarmTrace.Matching.Standard + + HarmTrace.Model.Instances + HarmTrace.Model.Main + HarmTrace.Model.Model + HarmTrace.Model.Parser + + HarmTrace.Tokenizer.Tokenizer + HarmTrace.Tokenizer.Tokens + main-is: Main.hs build-depends: base >= 4.3 && < 4.4, template-haskell >=2.5 && <2.6, mtl, directory, filepath, array, parallel >= 3,
+ src/HarmTrace/Base/MusicRep.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.Base.MusicRep where + +import Data.Maybe +import Data.List (elemIndex, intersperse, intercalate) +import Control.DeepSeq +import HarmTrace.HAnTree.Binary +import Generics.Instant.TH +import Data.Binary + +-------------------------------------------------------------------------------- +-- Representing musical information at the value level +-------------------------------------------------------------------------------- + +-- Keys (at the value level) +data Key = Key Root Mode deriving (Show, Eq) +data Mode = MinMode | MajMode deriving Eq + +instance NFData Mode where + rnf MinMode = () + rnf MajMode = () + +type ChordLabel = Chord Root +type ChordDegree = Chord ScaleDegree + +-- the representation for a single tokenized chord +data Chord a = Chord { chordRoot :: a + , chordShorthand :: Shorthand + , chordAdditions :: [Addition] + , getLoc :: Int -- the index of the chord + , duration :: Int -- in the list of tokens + } + +data Class = Class ClassType Shorthand + +data ClassType = MajClass | MinClass | DomClass | DimClass deriving (Eq) + +data Shorthand = -- Triad chords + Maj | Min | Dim | Aug + -- Seventh chords + | Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7 + -- Sixth chords + | Maj6 | Min6 + -- Extended chords + | Nin | Maj9 | Min9 + -- Suspended chords + | Sus4 + -- In some cases there is no chord a certain position + -- This is especially important for the chroma processing + | None + deriving (Show, Eq, Enum, Bounded) + + +-- Key relative scale degrees to abstract from the absolute Root notes +type ScaleDegree = Note DiatonicDegree + +data DiatonicDegree = I | II | III | IV | V | VI | VII | Imp + deriving (Show, Eq, Enum, Ord, Bounded) + +-- Representing absolute root notes +type Root = Note DiatonicNatural + +data DiatonicNatural = C | D | E | F | G | A | B | N -- N is for no root + deriving (Show, Eq, Enum, Ord, Bounded) + +-- Intervals for additonal chord notes +type Addition = Note Interval + +data Interval = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10 + | I11 | I12 | I13 + deriving (Eq, Enum, Ord, Bounded) + +data Note a = Note (Maybe Modifier) a deriving (Eq) + +data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat + deriving (Eq) + +-------------------------------------------------------------------------------- +-- Instances for the general music datatypes +-------------------------------------------------------------------------------- + + +instance Show Mode where + show MajMode = "" + show MinMode = "m" + +instance Eq a => Eq (Chord a) where + (Chord ra sha dega _loc _d) == (Chord rb shb degb _locb _db) + = ra == rb && sha == shb && dega == degb + +instance (Show a) => Show (Chord a) where + show (Chord r sh deg loc d) = show r ++ ':' : show sh + ++ (if not (null deg) then showAdds deg else "") + ++ '_' : show loc ++ ':' : show d + +showAdds :: Show a => [a] -> String +showAdds x = '(' : intercalate "," (map show x) ++ ")" + +instance Show Class where show (Class ct _) = show ct + +instance Show ClassType where + show (MajClass) = "" + show (MinClass) = "m" + show (DomClass) = "7" + show (DimClass) = "0" + +instance (Show a) => Show (Note a) where + show (Note m interval) = show interval ++ maybe "" show m + +instance Show Interval where + show a = show . ((!!) ([1..13]::[Integer])) + . fromJust $ elemIndex a [minBound..] + + +instance Show Modifier where + show Sh = "#" + show Fl = "b" + show SS = "##" + show FF = "bb" + +-- for showing additional additions +showAdditions :: [Addition] -> String +showAdditions a + | null a = "" + | otherwise = "(" ++ concat (intersperse "," (map show a)) ++ ")" + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- + +toClassType :: Shorthand -> ClassType +toClassType sh + | sh `elem` [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4] = MajClass + | 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 + + +-- Value Level Scale Degree Transposition +-------------------------------------------------------------------------------- + +relativize :: Key -> [ChordLabel] -> [ChordDegree] +relativize k = map (toChordDegree k) + +-- Chord root shorthand degrees original repetitions +toChordDegree :: Key -> ChordLabel -> ChordDegree +toChordDegree k (Chord r sh degs loc d) = + Chord (toScaleDegree k r) sh degs loc d + +toScaleDegree :: Key -> Root -> ScaleDegree +toScaleDegree (Key kr _) cr = -- Note Nothing I + scaleDegrees!!(((diaNatToSemi cr) - (diaNatToSemi kr)) `mod` 12) + +-- transposes a degree with sem semitones up +transposeSem :: ScaleDegree -> Int -> ScaleDegree +transposeSem deg sem = scaleDegrees!!((sem + (diaDegToSemi deg)) `mod` 12) where + +-- gives the semitone value [0,11] of a Degree, e.g. F# = 6 +diaDegToSemi :: ScaleDegree -> Int +diaDegToSemi (Note m deg) = + ([0,2,4,5,7,9,11] !! (fromJust $ elemIndex deg [minBound..])) + (modToSemi m) + +diaNatToSemi :: Root -> Int +diaNatToSemi (Note m nat) = + ([0,2,4,5,7,9,11] !! (fromJust $ elemIndex nat [minBound..])) + (modToSemi m) + + +-- transforms type-level modifiers to semitones (Int values) +modToSemi :: Maybe Modifier -> Int +modToSemi Nothing = 0 +modToSemi (Just Sh) = 1 +modToSemi (Just Fl) = -1 +modToSemi (Just SS) = 2 +modToSemi (Just FF) = -2 + +scaleDegrees ::[ScaleDegree] +scaleDegrees = [ Note Nothing I + , Note (Just Fl) II + , Note Nothing II + , Note (Just Fl) III + , Note Nothing III + , Note Nothing IV + , Note (Just Sh) IV + , Note Nothing V + , Note (Just Fl) VI + , Note Nothing VI + , Note (Just Fl) VII + , Note Nothing VII + ] + + +-------------------------------------------------------------------------------- +-- Binary instances +-------------------------------------------------------------------------------- + +deriveAllL [''Note, ''DiatonicDegree + , ''Mode, ''Chord, ''DiatonicNatural, ''ClassType + , ''Modifier, ''Shorthand, ''Interval] + +instance (Binary a) => Binary (Note a) where + put = putDefault + get = getDefault +instance Binary DiatonicDegree where + put = putDefault + get = getDefault +instance Binary Mode where + put = putDefault + get = getDefault +instance (Binary a) => Binary (Chord a) where + put = putDefault + get = getDefault +instance Binary DiatonicNatural where + put = putDefault + get = getDefault +instance Binary ClassType where + put = putDefault + get = getDefault +instance Binary Modifier where + put = putDefault + get = getDefault +instance Binary Shorthand where + put = putDefault + get = getDefault +instance Binary Interval where + put = putDefault + get = getDefault
+ src/HarmTrace/Base/Parsing.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +module HarmTrace.Base.Parsing ( parseData, parseDataWithErrors + , pString, pLineEnd + , module Data.ListLike.Base + , module Text.ParserCombinators.UU + , module Text.ParserCombinators.UU.Utils + , module Text.ParserCombinators.UU.BasicInstances + ) where + +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.Utils hiding (pSpaces) +import Text.ParserCombinators.UU.BasicInstances hiding (IsLocationUpdatedBy) +import Data.ListLike.Base (ListLike) + +-------------------------------------------------------------------------------- +-- A collection of parsing functions used by parsers throughout the project +-------------------------------------------------------------------------------- + +-- toplevel parsers +parseData :: (ListLike s a, Show a) => P (Str a s LineColPos) b -> s -> b +parseData p inp = fst ( parseDataWithErrors p inp ) + +parseDataWithErrors :: (ListLike s a, Show a) + => P (Str a s LineColPos) b -> s -> (b, [Error LineColPos]) +parseDataWithErrors p inp = (parse ( (,) <$> p <*> pEnd) + (createStr (LineColPos 0 0 0) inp)) + +-- parses specific string +pString :: (ListLike state a, IsLocationUpdatedBy loc a, Show a, Eq a) + => [a] -> P (Str a state loc) [a] +pString s = foldr (\a b -> (:) <$> a <*> b) (pure []) (map pSym s) + +-- parses whitespace (@pedro: should probably not contain '\n') +-- pSpaces :: Parser Char +-- pSpaces = pAnySym [' ','\n','\t'] + +-- parses UNIX and DOS/WINDOWS line endings +pLineEnd :: Parser String +pLineEnd = pString "\n" <|> pString "\r\n" <|> pString " " <|> pString "\t"
+ src/HarmTrace/Base/TypeLevel.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module HarmTrace.Base.TypeLevel ( + Su, Ze + , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10 + , T11, T12, T13, T14, T15, T16, T17, T18, T19, T20 + , ToNat(..) + ) where + +import Data.Typeable + + +-- Type level peano naturals +data Su :: * -> * deriving Typeable +data Ze :: * deriving Typeable + +-- Some shorthands +type T0 = Ze +type T1 = Su T0 +type T2 = Su T1 +type T3 = Su T2 +type T4 = Su T3 +type T5 = Su T4 +type T6 = Su T5 +type T7 = Su T6 +type T8 = Su T7 +type T9 = Su T8 +type T10 = Su T9 +type T11 = Su T10 +type T12 = Su T11 +type T13 = Su T12 +type T14 = Su T13 +type T15 = Su T14 +type T16 = Su T15 +type T17 = Su T16 +type T18 = Su T17 +type T19 = Su T18 +type T20 = Su T19 + +class ToNat n where + toNat :: n -> Int + +instance ToNat Ze where toNat _ = 0 +instance (ToNat n) => ToNat (Su n) where toNat _ = 1 + toNat (undefined :: n) +{- +-- Below is some experimentation... + +-- A degree has a distance to root in semi-tones (n in T0..T11) and a +-- class (major or minor) +data Degree n cls + +-- Transposing is a bit like addition... +type family Transpose m n +-- ... but we normalize at the end to stay within T0..T11 +type instance Transpose m T0 = Norm m +type instance Transpose m (Su n) = Transpose (Su m) n + +-- Normalizing is the same as subtracting T12, but only if we can. Else we keep +-- the type unchanged. +type Norm m = Sub m T12 m + +-- Subtraction with an extra type for failure +type family Sub m n fail +-- Inductive case +type instance Sub (Su m) (Su n) fail = Sub m n fail +-- Base case, subtraction succeeded +type instance Sub m T0 fail = m +-- Base case, subtraction failed +type instance Sub T0 (Su n) fail = fail + +-- A secondary dominant is a transposition by 7 semi-tones +type SD deg = Transpose deg T7 + +-- A tritone substitution is a transposition by 6 semi-tones +type TS deg = Transpose deg T6 +-}
+ src/HarmTrace/HAnTree/Augment.hs view
@@ -0,0 +1,63 @@+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
+ src/HarmTrace/HAnTree/Binary.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +-- Generic Binary + +module HarmTrace.HAnTree.Binary where + +import Control.Monad (liftM, liftM2) +import Data.Binary +import Generics.Instant + + +class GBinary a where + gput :: a -> Put + gget :: Get a + + +instance GBinary U where + gput _ = return () + gget = return U + +instance (GBinary a) => GBinary (CEq c p p a) where + gput (C a) = gput a + gget = liftM C gget +{- +instance (GBinary a) => GBinary (CEq c p q a) where + gput _ = return () + gget = error "gget: CEq impossible" +-} +instance (GBinary a, GBinary b) => GBinary (a :+: b) where + gput (L a) = put (0 :: Word8) >> gput a + gput (R a) = put (1 :: Word8) >> gput a + gget = do t <- get :: Get Word8 + case t of + 0 -> liftM L gget + 1 -> liftM R gget + _ -> error "gget: :+: impossible" + +instance (GBinary a, GBinary b) => GBinary (a :*: b) where + gput (a :*: b) = gput a >> gput b + gget = liftM2 (:*:) gget gget + +instance (Binary a) => GBinary (Rec a) where + gput (Rec a) = put a + gget = liftM Rec get + +instance (Binary a) => GBinary (Var a) where + gput (Var a) = put a + gget = liftM Var get + + +-- Default implementations +getDefault :: (Representable a, GBinary (Rep a)) => Get a +getDefault = fmap to gget + +putDefault :: (Representable a, GBinary (Rep a)) => a -> Put +putDefault = gput . from
+ src/HarmTrace/HAnTree/HAn.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.HAnTree.HAn where + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens +import HarmTrace.HAnTree.Binary + +import Generics.Instant.TH +import Control.DeepSeq +import Data.Binary + +-------------------------------------------------------------------------------- +-- Datatypes for representing Harmonic Analyses (at the value level) +-------------------------------------------------------------------------------- + +-- H_armonic An_alysis wrapper datatype, the Int represents the duration +data HAn = HAn !Int !String + | HAnFunc !HFunc + | HAnTrans !Trans + | HAnChord !ChordToken + -- duration Mode constructor_ix specials +data HFunc = Ton !Int !Mode !Int !(Maybe Spec) + | Dom !Int !Mode !Int !(Maybe Spec) + | Sub !Int !Mode !Int !(Maybe Spec) + | P + | PD + | PT + +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" + | DimTrit !Int !ScaleDegree -- "bIIb9/X" + | DimTrans !Int !ScaleDegree -- "VII0" + | DiatDom !Int !ScaleDegree -- "Vd" + | NoTrans + +-------------------------------------------------------------------------------- +-- Binary instances +-------------------------------------------------------------------------------- + +deriveAllL [ ''HAn, ''Trans, ''HFunc, ''Spec] + +instance Binary HAn where + put = putDefault + get = getDefault +instance Binary Trans where + put = putDefault + get = getDefault +instance Binary HFunc where + put = putDefault + get = getDefault +instance Binary Spec where + put = putDefault + get = getDefault + +-------------------------------------------------------------------------------- +-- NFData instances +-------------------------------------------------------------------------------- + +instance NFData HAn where + rnf (HAn d s ) = rnf d `seq` rnf s + rnf (HAnFunc a) = rnf a + rnf (HAnTrans a) = rnf a + rnf (HAnChord a) = seq a () + +instance NFData HFunc where + rnf (Ton a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + rnf (Dom a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + rnf (Sub a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + rnf P = () + rnf PD = () + rnf PT = () + +instance NFData Trans 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 (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 + rnf Blues = () + rnf MinBorrow = () + rnf Parallel = () + +-------------------------------------------------------------------------------- +-- Instances for Harmony Analyses +-------------------------------------------------------------------------------- + +-- Yes, I know these can be generic functions, but with my current generic +-- programming skils it is faster two write them by hand. +class GetDur a where + getDur :: a -> Int + + +instance GetDur HAn where + getDur (HAn d _s) = d + getDur (HAnFunc a) = getDur a + getDur (HAnTrans a) = getDur a + getDur (HAnChord a) = dur a + +instance GetDur HFunc where + getDur (Ton i _ _ _) = i + getDur (Dom i _ _ _) = i + getDur (Sub i _ _ _) = i + getDur _ = 1 + +instance GetDur Trans where + getDur (SecDom i _) = i + getDur (SecMin i _) = i + getDur (SecDim i _) = i + getDur (Trit i _) = i + getDur (DimTrit i _) = i + getDur (DimTrans i _) = i + getDur (DiatDom i _) = i + getDur (NoTrans) = 0 + +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)) + setDur (HAnTrans a) i = (HAnTrans (setDur a i)) + setDur a _i = a + +instance SetDur HFunc where + setDur (Ton _d m i s) d = (Ton d m i s) + setDur (Dom _d m i s) d = (Dom d m i s) + setDur (Sub _d m i s) d = (Sub d m i s) + setDur a _ = a + +instance SetDur Trans 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 (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 + + +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 Show HAn where + show (HAn _l con) = con -- ++ "_s" ++ '_' : show l + show (HAnChord chord) = show chord + show (HAnFunc hfunk) = show hfunk + show (HAnTrans trans) = show trans + +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 (P ) = "Piece" + show (PT) = "PT" + show (PD) = "PD" + + +instance Show Spec where + show Blues = "bls" + show MinBorrow = "bor" + show Parallel = "par"
+ src/HarmTrace/HAnTree/HAnParser.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} + +module HarmTrace.HAnTree.HAnParser where + +import HarmTrace.Base.Parsing +import HarmTrace.Base.MusicRep (Mode(..)) +import HarmTrace.HAnTree.HAn + +import Data.Maybe (isJust, fromJust) +-------------------------------------------------------------------------------- +-- A Small Parser for Parsing MIR constructors +-------------------------------------------------------------------------------- + +-- this top-level function parses a constructor name and returns the +-- corresponding HAn data type. N.B. we can implement the catch all +-- case as a parser, because it accepts everything and one will get an +-- "ambiguous parser?" error.s +parseHAn :: ListLike state Char => state -> HAn +parseHAn inp + | isJust a = fromJust a + | otherwise = parseData (HAn 1 <$> pAnyStr) inp where -- catch all case + a = parseData (pMaybe $ HAnFunc <$> pHFunc) inp + + +pHFunc :: Parser HFunc +pHFunc = Ton 1 <$ pSym 'T' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec + <|> Dom 1 <$ pSym 'D' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec + <|> Sub 1 <$ pSym 'S' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec + <|> PD <$ pString "PD" + <|> PT <$ pString "PT" + +pMode :: Parser Mode +pMode = MinMode <$ pSym 'm' + <|> MajMode <$ pString "" + +pSpec :: Parser Spec +pSpec = MinBorrow <$ pString "_bor" + <|> Blues <$ pString "_bls" + <|> Parallel <$ pString "_par" + +pAnyStr :: Parser String +pAnyStr = pAtMost 15 pAscii
+ src/HarmTrace/HAnTree/ToHAnTree.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module HarmTrace.HAnTree.ToHAnTree ( GTree(..), gTreeDefault, HAn(..)) where + +import Generics.Instant.Base +import HarmTrace.HAnTree.Tree (Tree(..)) +import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.HAnParser + +class GTree a where + gTree :: a -> [Tree HAn] + +instance GTree U where + gTree U = [Node (HAn 0 "U") [] Nothing] + +instance (GTree a, GTree b) => GTree (a :+: b) where + gTree (L x) = gTree x + gTree (R x) = gTree x + +instance (GTree a, Constructor c) => GTree (CEq c p q a) where + gTree c@(C a) = [Node (parseHAn (conName c)) (gTree a) Nothing] + +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 + +instance GTree a => GTree (Var a) where + gTree (Var x) = gTree x + + +-- Dispatcher +gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn] +gTreeDefault = gTree . from
+ src/HarmTrace/HAnTree/Tree.hs view
@@ -0,0 +1,163 @@+ +module HarmTrace.HAnTree.Tree where + +import Data.Maybe +import qualified Data.Binary as B +import Control.Monad.State +import Data.List (maximumBy) +import Control.DeepSeq + +-------------------------------------------------------------------------------- +-- Tree datastructure +-------------------------------------------------------------------------------- + +-- our (temporary) tree data structure, a leaf is simply represented +-- as Node a [] or NodePn a [] pn +data Tree a = Node { getLabel :: !a, getChild :: ![Tree a], getPn :: !(Maybe Int) } + deriving Eq + +-- specific show instance for pretty printing +instance (Show a) => Show (Tree a) where + show (Node a children _) = --filter (\x -> '\"' /= x && '\'' /= x) + desc where + desc = ('[' : show a) ++ concatMap show children ++ "]" + +instance (NFData a) => NFData (Tree a) where + rnf (Node l c p) = rnf l `seq` rnf c `seq` rnf p + +instance (B.Binary a) => B.Binary (Tree a) where + put (Node l c p) = B.put l >> B.put c >> B.put p + get = liftM3 Node B.get B.get B.get + +-------------------------------------------------------------------------------- +-- Creating Trees +-------------------------------------------------------------------------------- + +-- returns a Tree data structure, given a string representation of a tree. +strTree :: String -> Tree String +strTree = head . strTree' where + strTree' [] = [] + strTree' (c:cs) + | c == '[' = Node lab (strTree' a) Nothing : strTree' b + | c == ']' = strTree' cs + | otherwise = error ("cannot parse, not well formed tree description: " + ++ [c]) where + (x ,b) = splitAt (findClose cs) cs + (lab,a) = span (\y -> (y /= '[') && (y /= ']')) x + +-- given a string representation of a tree, e.g. "[b][c]]" findClose +-- returns the index of the closing bracket, e.g. 6. +findClose :: String -> Int +findClose s = findClose' s 1 0 +findClose' :: String -> Int -> Int -> Int +findClose' [] b ix + | b == 0 = ix-1 + | otherwise = error + "not well formed tree description: cannot find closing bracket" +findClose' (c : cs) b ix + | b == 0 = ix-1 + | c == '[' = findClose' cs (b+1) (ix+1) + | c == ']' = findClose' cs (b-1) (ix+1) + | otherwise = findClose' cs b (ix+1) + +-------------------------------------------------------------------------------- +-- Basic operations on the Tree data structure +-------------------------------------------------------------------------------- + +-- given a list with tree getPn +getPns :: [Tree t] -> [Int] +getPns = map (fromJust . getPn) + +-- returns the list of po nrs of the children of t +getChildPns :: Tree a -> [Int] +-- getChildPns t = map (fromJust . getPn) (getChild t) +getChildPns (Node _lab children _pn) = map (fromJust . getPn) children + +-- returns the subtree of t given its post order number pn +getSubTree :: Tree t -> Int -> Tree t +getSubTree t pn = pot t!!pn + +-- returns True if t is a leaf and False otherwise +isLf :: (Eq t) => Tree t -> Bool +isLf t = getChild t == [] + +collectLeafs :: Tree t -> [Tree t] +collectLeafs t@(Node _ [] _) = [t] +collectLeafs (Node _ cn _) = concatMap collectLeafs cn + +-- returns the size of the tree +size, depth :: Tree t -> Int +size (Node _ [] _) = 1 +size (Node _ children _ ) = foldr ((+) . size ) 1 children + +-- returns the size of a forrest of trees +sizeF, depthF :: [Tree t] -> Int +sizeF treeList = foldr ((+) . size ) 0 treeList + +avgDepth :: Tree t -> Float +avgDepth t = fromIntegral (sum dep) / fromIntegral (length dep) where + dep = depth' 1 t + +-- returns the maximum depth of a tree +depth t = maximumBy compare (depth' 1 t) + +-- returns the maximum depth of a forrest of trees +depthF treeList = maximumBy compare (concatMap (depth' 1) treeList) + +-- depth helper +depth' :: Int -> Tree t -> [Int] +depth' x (Node _ [] _ ) = [x] +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 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)] + +-- collects all the subtrees of tree in a list in post order. +pot, pot', pret, pret',potPret :: Tree t -> [Tree t] +potPret t = pot' (setPre t) +pot t = pot' (setPost t) +pot' t@(Node _ [] _) = [t] +pot' t@(Node _ children _) = concatMap pot' children ++ [t] +-- collects all the subtrees of tree in a list in pre order. +pret t = pret' (setPre t) +pret' t@(Node _ [] _) = [t] +pret' t@(Node _ children _) = t : concatMap pret' children + +-- very inefficient way of converting a pre order number to a post order number +-- just for testing.... +preToPost :: Tree t -> Int -> Int +preToPost t pn = fromJust . getPn $ pret' (setPost t) !! pn + + +-- Converts Node's to NodePn's and sets the post order numbers +-- JPM: setPost is a typical tree labelling problem. +-- Looks nicer with the state monad, I think: +setPost, setPre :: Tree t -> Tree t +setPost t = evalState (stm t) 0 where + stm :: Tree t -> State Int (Tree t) + stm (Node a cs _) = do cs' <- mapM stm cs + pn <- get + modify (+1) + return (Node a cs' (Just pn)) + +-- Sets pre order numbers +setPre t = evalState (stm t) 0 where + stm :: Tree t -> State Int (Tree t) + stm (Node a cs _) = do pn <- get + modify (+1) + cs' <- mapM stm cs + return (Node a cs' (Just pn)) + +--not very efficient, but nevertheless very effective, todo optimize elem operation +matchToTree :: Tree t -> [Int] -> [Tree t] +matchToTree t@(Node _ _ Nothing ) k = matchToTree (setPost t) k +matchToTree (Node a cn (Just pn)) k = + let cs = concatMap (`matchToTree` k) cn + in if pn `elem` k then [Node a cs (Just pn)] else cs
+ src/HarmTrace/HarmTrace.hs view
@@ -0,0 +1,73 @@+module HarmTrace.HarmTrace where + +import HarmTrace.Model.Model hiding (PD, PT) +import HarmTrace.Model.Main +import HarmTrace.HAnTree.ToHAnTree +import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.Tree +import HarmTrace.HAnTree.Augment +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens +import HarmTrace.Tokenizer.Tokenizer + +-- Parser stuff +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances as PC + +-------------------------------------------------------------------------------- +-- Plugging everything together +-------------------------------------------------------------------------------- + +-- instance Show (Piece key) where show x = showChord x "" + +-- 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)) + +{-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)] + +{- +-- 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 +-} + +-- 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)
+ src/HarmTrace/IO/Errors.hs view
@@ -0,0 +1,50 @@+module HarmTrace.IO.Errors where + +-- Parser stuff +import Text.ParserCombinators.UU.BasicInstances as PC + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokenizer + +import Data.List (genericLength) + +-------------------------------------------------------------------------------- +-- Error Reporting +-------------------------------------------------------------------------------- + +data ErrorNrs = ErrorNrs { ins :: Int, del :: Int, delEnd :: Int, rep :: Int } + +-- datatype for storing the number of different error types +instance Show ErrorNrs where + show (ErrorNrs i d e r) = show i ++ " insertions, " ++ show d + ++ " deletions, " ++ show r ++ "replacements, and " + ++ show e ++ " unconsumed tokens" + +-- More concise showing errors, and in IO +showErrors :: String -> [Error Int] -> 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 [] = ErrorNrs 0 0 0 0 +countErrors ((PC.Inserted _ _ _) :t) = inc1 (countErrors t) +countErrors ((PC.Deleted _ _ _) :t) = inc2 (countErrors t) +countErrors ((DeletedAtEnd _) :t) = inc3 (countErrors t) +countErrors ((Replaced _ _ _ _):t) = inc4 (countErrors t) + +simpleErrorMeasure :: ErrorNrs -> Float +simpleErrorMeasure (ErrorNrs i d e r) = fromIntegral (i + d + e + r) + +errorRatio :: [Error Int] -> [ChordLabel] -> Float +errorRatio errs toks = simpleErrorMeasure (countErrors errs) / + -- probably we should not divide here by "mergeDups" ... + genericLength (mergeDups (Key (Note Nothing C) MajMode) toks) + +inc1, inc2, inc3, inc4 :: ErrorNrs -> ErrorNrs +inc1 e = e { ins = ins e + 1 } +inc2 e = e { del = del e + 1 } +inc3 e = e { delEnd = delEnd e + 1 } +inc4 e = e { rep = rep e + 1 }
+ src/HarmTrace/IO/Main.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Testing +module HarmTrace.IO.Main where + +-- Parser stuff +import Text.ParserCombinators.UU + +-- Music stuff +import HarmTrace.HarmTrace +import HarmTrace.Base.MusicRep +import HarmTrace.Model.Instances () +import HarmTrace.HAnTree.Tree (Tree) +import HarmTrace.HAnTree.ToHAnTree +import HarmTrace.IO.Errors + +-- 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.Printf (printf) +import System.CPUTime + + +-------------------------------------------------------------------------------- +-- Data set Info +-------------------------------------------------------------------------------- +biabPat :: String +biabPat = "^(.*)_id_([0-9]{5})_(allanah|wdick|community|midicons|realbook).(M|S|m|s)(G|g)[0-9A-Za-z]{1}.txt$" + +getInfo :: String -> Maybe [String] +getInfo fileName = + do let + (_,_,_,groups) <- fileName =~~ biabPat :: Maybe (String,String,String,[String]) + return groups + +getTitle, getId, getDb :: String -> String +getTitle fn = getInfo' 0 fn +getId fn = getInfo' 1 fn +getDb fn = getInfo' 2 fn + +getInfo' :: Int -> String -> String +getInfo' i fn = maybe "no_info" (!!i) (getInfo fn) + +createGroundTruth :: [String] -> [(String, String)] +createGroundTruth files = [ (getTitle x, getId x) | x <- files ] + +getClassSizes :: [String] -> [(String,[String])] +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 + +-------------------------------------------------------------------------------- +-- Symbolic 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 + +parseTreeVerb s = + do let (toks, _, ts, te, pe) = string2PieceCPostProc s + putStrLn ("parsed " ++ show (length toks) ++ " chords") + if not (null te) then mapM_ print te + else putStr "" + if not (null pe) then mapM_ print pe + else putStr "" + return ts + +-- 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' :: Maybe FilePath -> String -> [String] -> IO () +parseDir' 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" + putStrLn "Error ratio\tTime taken" + 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 ()) + ErrorNrs i d e r = countErrors e2 + errRat = errorRatio e2 tks + nrOfChords = length tks -- (mergeDups toks) + t1 <- getCPUTime + 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) + , show i, show d, show r, show e + , show (i+d+e+r) + , show nrOfChords, showFloat errRat + , showFloat diff] + return (tks, head ts) + res <- mapM (process fp) (filter ((== ".txt") . takeExtension) fs) + case bOut of + Nothing -> return () + Just bf -> encodeFile bf (unzip res :: ([[ChordLabel]],[Tree HAn])) + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- +putErrLn :: String -> IO() +putErrLn = hPutStrLn stderr + +printLn :: String ->IO () +printLn s = putStrLn s >> hFlush stdout + + +regexMatchGroups :: String -> String -> Maybe [String] +regexMatchGroups pat str = do + (_,_,_,groups) <- str =~~ pat :: Maybe (String,String,String,[String]) + return groups + +-- Stricter readFile +hGetContents' :: Handle -> IO [Char] +hGetContents' hdl = do e <- hIsEOF hdl + if e then return [] + else do c <- hGetChar hdl + cs <- hGetContents' hdl + return (c:cs) + +readFile' :: FilePath -> IO [Char] +readFile' fn = do hdl <- openFile fn ReadMode + xs <- hGetContents' hdl + hClose hdl + return xs + +readDataDir :: FilePath -> IO [FilePath] +readDataDir fp = + do fs <- getDirectoryContents fp + return . sort $ filter (\str -> str =~ biabPat) fs + +-- | Shows a Float with 5 decimal places +showFloat :: Float -> String +showFloat = printf "%.6f" +--showFloat = show . (/ (1000 :: Float)) . fromIntegral + -- . (round :: Float -> Int) . (* 1000) + +
+ src/HarmTrace/IO/PrintTree.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -Wall #-} +module HarmTrace.IO.PrintTree ( printTreeF , printTree + , printTreeHAnF, printTreeHAn) where + +import System.Exit (ExitCode) +import System.Process (runProcess, waitForProcess, ProcessHandle) +import HarmTrace.HAnTree.Tree (Tree) +import HarmTrace.HAnTree.HAn (HAn) + + +-- needs gnu wget http://www.gnu.org/software/wget/ +-- or http://gnuwin32.sourceforge.net/packages/wget.htm + +printTreeHAn :: Tree HAn -> FilePath -> IO ExitCode +printTreeHAn t o = printTree (show t) o + +printTreeHAnF :: [Tree HAn] -> String -> IO ExitCode +printTreeHAnF ts o = printTreeF (map show ts) o + + +-- |gets a .png from http://ironcreek.net/phpsyntaxtree/ that prints +-- the parse tree of the chord sequence that was entered as parsed by our +-- HarmGram model. wget is used under the hood. If any, the first ten +-- ambiguous parse trees are printed. +printTreeF :: [String] -> -- ^ the tree description to be printed + String -> -- ^ a string for generating the filenames + IO ExitCode +printTreeF trees outStr = printMoreTrees (take 15 trees) outStr 0 where + printMoreTrees :: [String] -> String -> Int -> IO ExitCode + printMoreTrees [] _ _ = error "empty list of trees, nothing to print" + printMoreTrees [t] out i = printTree t (nrFile out i) + printMoreTrees (t:ts) out i = do _ <- printTree t (nrFile out i) + printMoreTrees ts out (i+1) + nrFile :: String -> Int -> String + nrFile str i = str ++ show i ++ ".png" + +-- |gets a .png from http://ironcreek.net/phpsyntaxtree/ that prints +-- the parse tree of the chord sequence that was entered as parsed by our +-- HarmGram model. wget is used under the hood. If any, the first ten +-- ambiguous parse trees are printed. +printTree :: String -> -- ^ the tree description to be printed + FilePath -> -- ^ a filepath to the output file + IO ExitCode +printTree tree outfile = do submit <- submitTree tree + _ <- waitForProcess submit + png <- getpng outfile + waitForProcess png + +-- wget --save-cookies cookies.txt + --keep-session-cookies + --post-data "data=[tree]&drawbtn=&opencount=3&closedcount=3&font=vera_sans&fontsize=8&color=on&antialias=on&autosub=on&triangles=on" + --http://ironcreek.net/phpsyntaxtree/ +submitTree :: String -> IO ProcessHandle +submitTree tree = wget "http://ironcreek.net/phpsyntaxtree/" opt where + opt = [ "--save-cookies" + , "phpsyntax_cookies.txt" + , "--keep-session-cookies" + , "--quiet" + , "--delete-after" + , "--post-data" + , "data=" ++ tree ++ "&drawbtn=&opencount=3&closedcount=3&" ++ + "font=vera_sans&fontsize=8&color=on&antialias=on&triangles=on" + ] + +-- +--wget cookies.txt --output-document %2.png http://ironcreek.net/phpsyntaxtree/dnlgraph.php +getpng :: String -> IO ProcessHandle +getpng name = wget "http://ironcreek.net/phpsyntaxtree/dnlgraph.php" opt where + opt = [ "--load-cookies" + , "phpsyntax_cookies.txt" + , "--quiet" + , "--output-document" + , name + ] + +wget :: String -> [String] -> IO ProcessHandle +wget url opt = + do let par = url : opt + runProcess "wget" par Nothing Nothing Nothing Nothing Nothing +
+ src/HarmTrace/Matching/FlatMatch.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -Wall #-} + +module HarmTrace.Matching.FlatMatch where + +import Data.Array +import Data.List + +-- import HarmTrace.Base.MusicRep +import HarmTrace.HAnTree.Tree +import HarmTrace.Matching.GuptaNishimura (getDownRight) + +-- Toplevel: +-- Returns a Maximum Included Subtree (MIS). This is the three that maximizes +-- the number of matching nodes in a tree respecting the order and +-- ancestorship relations. The size of a MIS is always greater then or equal +-- to the size of the LCES of Gupta and Nishimura. +getFlatMatch :: (Eq t) => Tree t -> Tree t -> [Tree t] +getFlatMatch ta tb = buildLCES (matchToTree ta ma) (matchToTree tb mb) where + (ma,mb) = getFlatMatch' ta tb +getFlatMatch' :: (Eq a) => Tree a -> Tree a -> ([Int], [Int]) +getFlatMatch' ta tb = unzip $ reverse $ fst3 $ getDownRight $ wbMatch (potPret ta) (potPret tb) simLab + + +buildLCES :: [Tree t] -> [Tree t] -> [Tree t] +buildLCES [] [] = [] +buildLCES [] _ = error "buildLCES error" +buildLCES _ [] = error "buildLCES error" +buildLCES a@(ta:tas) b@(tb:tbs) + | size ta > size tb = buildLCES (flatten a) b + | size ta < size tb = buildLCES a (flatten b) + | otherwise + = Node (getLabel ta) (buildLCES (getChild ta) (getChild tb)) Nothing + : buildLCES tas tbs + +flatten :: [Tree t] -> [Tree t] +flatten [] = [] +flatten (t:[]) = flatRight t +flatten (t:ts) = flatLeft t ++ ts + +flatRight :: Tree t -> [Tree t] +flatRight t@(Node _ [] _ ) = [t] +flatRight (Node a (c:cn) pn) = [lf, Node a (c' ++ cn) pn] where + (lf, c') = getFirstLeaf c + +getFirstLeaf :: Tree t -> (Tree t, [Tree t]) +getFirstLeaf ta@(Node _ [] _ ) = (ta, []) +getFirstLeaf (Node a (c:cs) pn ) = (lf, [Node a (cn' ++ cs) pn]) where + (lf, cn') = getFirstLeaf c + +flatLeft :: Tree t -> [Tree t] +flatLeft t@(Node _ [] _ ) = [t] +flatLeft (Node l c pn ) = c ++ [Node l [] pn] + +-- returns the actual matching +-- TODO ensure potPret? +wbMatch :: [Tree a] -> [Tree a] -> (Tree a -> Tree a -> Bool) -> + Array (Int, Int) ([(Int, Int)], Int, Int) +wbMatch _ [] _ = listArray ((0,0),(0,0)) (repeat ([],0,0)) +wbMatch [] _ _ = listArray ((0,0),(0,0)) (repeat ([],0,0)) +wbMatch a' b' simf = 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 + match i j = if simf (a!i) (b!j) then ([(i,j)],1,1) else ([],0,0) + -- this is the actual core recursive definintion of the algorithm + concatMatch i j = maximumBy depthWeight l where + l = if simf (a!i) (b!j) -- put the diagonal at the back to prefer symmetry + then [merge (i,j) (m!(i-1,j)) a b, merge (i,j) (m!(i,j-1)) a b, merge (i,j) (m!(i-1,j-1)) a b] + else [m!(i-1,j), m!(i,j-1), m!(i-1,j-1)] + m = array ((0,0),(la,lb)) + (((0,0), match 0 0) : + [((0,j), maximumBy depthWeight [m!(0,j-1), match 0 j]) | j <- [1..lb]] ++ + [((i,0), maximumBy depthWeight [m!(i-1,0), match i 0]) | i <- [1..la]] ++ + [((i,j), concatMatch i j) | i <- [1..la], j <- [1..lb]]) + +-- returns the weight of a matching +getWeight :: ([(Int,Int)], Int, Int) -> Int +getWeight (_,w,_) = w + +-- compares two matching on the basis of their weight +-- and in case of equal weight on the basis of the cummulative +-- depth of both compared trees +depthWeight :: (a, Int, Int) -> (a, Int, Int) -> Ordering +depthWeight (_,w,d) (_,w',d') + | w < w' = LT + | w > w' = GT + | (d - d') < 0 = LT + | (d - d') > 0 = GT + | otherwise = EQ + +-- merges two tuples contianing the matchings, weight and cumulative depth of both +-- matched trees. +merge :: (Int,Int) -> ([(Int,Int)], Int, Int) -> Array Int (Tree b) -> Array Int (Tree b) -> + ([(Int,Int)], Int, Int) +merge e@(i,j) p@(prv, w, d) a b -- trace ((show e) ++ ":"++show prv++" d: " ++ show d ++ " update: " ++ show (d + (levelUp prv i fst a) + (levelUp prv j snd b))) + | isFree prv i fst && isFree prv j snd = (e : prv, w + 1, d + depthInc) + | otherwise = p where + depthInc = if levelUp prv i fst a && levelUp prv j snd b then 1 else 0 + +isFree :: [a] -> Int -> (a -> Int) -> Bool +isFree prv i f = null prv || i > f (head prv) + +-- returns True if given a previous matching prv the the node i of tree a +-- moves up a level and False otherwise +-- N.B. this should retrieve the preorder number, i.e. use potPret +-- If the preorder number of the previous match (in postorder!) is larger than +-- the current preorder number we move up in the three and increase the depth +levelUp :: [a] -> Int -> (a -> Int) -> Array Int (Tree b) -> Bool +levelUp prv i f a = null prv || getPn (a!f (head prv)) > getPn (a!i) + +-- similarity measure for comparing tree labels +simLab :: (Eq a) => Tree a -> Tree a -> Bool +simLab ta tb = getLabel ta == getLabel tb + +-- similarity measure for comparing anything +simEq :: (Eq a) => a -> a -> Bool +simEq a b = a == b + +fst3 :: (a, Int, Int) -> a +fst3 (f, _,_) = f
+ src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -Wall #-} +module HarmTrace.Matching.GuptaNishimuraEditMatch ( getSimLCES, getLCES + , getWeightLCES + )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 qualified Data.Vector as V + +import Data.Ord +import Data.Maybe +import Data.Array +import Data.List + +import HarmTrace.HAnTree.Tree +import HarmTrace.Matching.Sim + +-------------------------------------------------------------------------------- +-- Top Level LCES function +-------------------------------------------------------------------------------- + +getLCES :: (Eq t, Sim t) => Tree t -> Tree t -> [Tree t] +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 + (_lces, weight) = getWeightLCES ta tb + + +-- Top level function that returns the largest common embedable subtree +-- of two trees +getWeightLCES :: (Eq t, Sim t) => Tree t -> Tree t -> ([Tree t],Float) +getWeightLCES ta tb = (matchToTree ta (map fst (reverse m)),s) where + n = lces ta tb + (m,s) = n!(snd $ bounds n) + + +-- calculates the largest labeled common embeddable subtree +lces :: (Eq t, Sim t) => Tree t -> Tree t + -> Array (Int, Int) ([(Int,Int)], Float) +lces ta tb = n where + la = size ta-1 + lb = size tb-1 + a = V.fromList (pot ta) + b = V.fromList (pot tb) + maxi :: Int -> [Int] -> ([(Int,Int)],Float) + maxi _ [] = ([],0) + maxi i cb = {-# SCC "maxi_lces" #-}n!(i,maximumBy (comparing (\j -> getWeight $ n!(i,j))) cb ) + maxj :: [Int] -> Int -> ([(Int,Int)],Float) + maxj [] _ = ([],0) + maxj ca j = {-# SCC "maxi_lces" #-}n!( maximumBy (comparing (\i -> getWeight $ n!(i,j))) ca,j) + recur i j = findBestMatch (sim (getLabel $ a V.! i) (getLabel $ b V.! j))i j mc mi mj where + mi = maxi i (getChildPns (b V.! j)) + mj = maxj (getChildPns (a V.! i)) j + mc = wbMatch (getChild (a V.! i)) (getChild $ b V.! j) n + n = array ((0,0), (la, lb)) + (((0,0), ([],sim (getLabel $ a V.! 0) (getLabel (b V.! 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 :: Float -> Int -> Int -> ([(Int,Int)], Float) + -> ([(Int,Int)], Float) -> ([(Int,Int)], Float) -> ([(Int,Int)], Float) +findBestMatch simv i j a b c + | simv == 0 = first + | otherwise = if isFree first i j then ((i,j):mf,wf+simv) --add match + else if wf /= ws then first + else if isFree second i j then ((i,j):ms,ws+simv) + else if wf /= wt then first + else if isFree second i j then ((i,j):mt,wt+simv) + 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)], Float) -> ([(Int, Int)], Float) +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)], Float) + -> Array (Int, Int) ([(Int,Int)], Float) +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)], Float) + 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)], Float) + 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 + +-- checks if the previously calculated optimal solution does not +-- contain the indices i and j in a and b, resepectivly +isFree :: ([(Int,Int)], Float) -> Int -> Int -> Bool +isFree ([],_) _ _ = True +isFree ((previ, prevj):_,_) i j = ( i > previ && j > prevj) + +-- mergest two lists with matches +merge :: ([a], Float) -> ([a], Float) -> ([a], Float) +merge (a, wa) (b, wb) = (a ++ b, wa + wb)
+ src/HarmTrace/Matching/Matching.hs view
@@ -0,0 +1,186 @@+{-# 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 + +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens +import HarmTrace.HAnTree.Tree +import HarmTrace.HAnTree.HAn +import HarmTrace.Matching.Sim + +import Data.Maybe +import Data.Array +import Data.Ord +import Data.List (maximumBy) + +-------------------------------------------------------------------------------- +-- Matching +-------------------------------------------------------------------------------- + +-- Top level functions: + +-- prints a match +printBPM :: Int -> Tree HAn -> Tree HAn -> IO() +printBPM sampRate 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) + | 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 _ _ _ = "" + +-- 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 + + + +-- selects the most lower right cell in the wbMatch' matrix +getWeightMatch :: [MatchChord] -> [MatchChord] -> ([MatchChord], Float) +getWeightMatch _ [] = ([],0) +getWeightMatch [] _ = ([],0) +getWeightMatch a b = (result,simVal) where + (match, simVal) = getDownRight $ wbMatch a b + mfst = reverse $ map fst match + result = catMaybes $ map f a + f x + | (mgetLoc x) `elem` mfst = Just x + | otherwise = Nothing + + +wbMatch :: Sim 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 + 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 + 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)) + (((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]] ++ + [((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 + +-- 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) + | isFree prv i fst && isFree prv j snd = ((i,j) : prv, w + s) + | otherwise = p where + isFree :: [a] -> Int -> (a -> Int) -> Bool + isFree prv' a f = null prv' || a > f (head prv') + +-------------------------------------------------------------------------------- +-- 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
+ src/HarmTrace/Matching/Sim.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_GHC -Wall #-} +module HarmTrace.Matching.Sim where + +import HarmTrace.Tokenizer.Tokens +import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.Tree + +-------------------------------------------------------------------------------- +-- 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 + +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 + +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 + +durWeight :: Int -> Int -> Float +durWeight durA durB = fromIntegral (min durA durB) + +-- 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) + +selfSiml :: (Sim a) => [Tree a] -> Float +selfSiml trees = sum $ map selfSim trees
+ src/HarmTrace/Matching/Standard.hs view
@@ -0,0 +1,25 @@+ +module HarmTrace.Matching.Standard (diffChords, diffChordsLen) where + +import Data.Algorithm.Diff -- cabal install Diff + +diff :: (Eq a) => [a] -> [a] -> [(DI,a)] +diff = getDiff + +diffLen :: (Eq a) => [a] -> [a] -> Float +diffLen x y = fromIntegral (len (diff x y)) / fromIntegral (length x) + +len :: [(DI,a)] -> Int +len [] = 0 +len ((B,_):t) = len t +len ((_,_):t) = 1 + len t + +-------------------------------------------------------------------------------- +-- Matching +-------------------------------------------------------------------------------- + +diffChordsLen :: (Eq a) => [a] -> [a] -> Float +diffChordsLen = diffLen + +diffChords :: (Show a, Eq a) => [a] -> [a] -> String +diffChords x y = show (diff x y)
+ src/HarmTrace/Model/Instances.hs view
@@ -0,0 +1,286 @@+{-# 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
+ src/HarmTrace/Model/Main.hs view
@@ -0,0 +1,28 @@+{-# 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 +
+ src/HarmTrace/Model/Model.hs view
@@ -0,0 +1,412 @@+{-# 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 ]
+ src/HarmTrace/Model/Parser.hs view
@@ -0,0 +1,76 @@+{-# 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...
+ src/HarmTrace/Tokenizer/Tokenizer.hs view
@@ -0,0 +1,149 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +module HarmTrace.Tokenizer.Tokenizer (parseSongAbs, pString, mergeDups) where + +import HarmTrace.Base.Parsing +import HarmTrace.Base.MusicRep +import HarmTrace.Tokenizer.Tokens + +import Data.Maybe + +-------------------------------------------------------------------------------- +-- 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) + | 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 + 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 + <*> (setLoc 0 <$> pListSep_ng pLineEnd parseChord ) + <* pList pLineEnd where + setLoc :: Int -> [Chord a] -> [Chord a] + setLoc _ [] = [] + setLoc ix (Chord r c d _ l :cs) = (Chord r c d ix l) : setLoc (ix+1) cs + +-- For now, I assume there is always a shorthand, and sometimes extra +-- degrees. I guess it might be the case that sometimes there is no shorthand, +-- but then there certainly are degrees. +parseChord :: Parser ChordLabel +parseChord = f <$> parseRoot <* pSym ':' <*> pMaybe parseShorthand + <*> (parseDegrees `opt` []) <* pSym ';' <*> pNaturalRaw + where f r (Just s) [] l = Chord r s [] 0 l + -- if there are no degrees and no shorthand (should not occur) + -- we make it a minor chord + f r Nothing [] l = Chord r Maj [] 0 l + -- in case of there is no short hand we analyse the degree list + f r Nothing d l = Chord r (analyseDegs d) d 0 l + -- in case of a sus4/maj we also analyse the degree list + f r (Just Sus4) d l = Chord r (analyseDegs d) d 0 l + f r (Just Maj) d l = Chord r (analyseDegs d) d 0 l + -- if we have another short hand we ignore the degrees list + f r (Just s) d l = Chord r s d 0 l + + +parseKey :: Parser Key +parseKey = f <$> parseRoot <* pSym ':' <*> parseShorthand + where f r m | m == Maj = Key r MajMode + | m == Min = Key r MinMode + | otherwise = error ("Tokenizer: key must be Major or Minor, " + ++ "found: " ++ show m) + + +-- analyses a list of Degrees and assigns a shortHand i.e. Chord Class +analyseDegs :: [Addition] -> Shorthand +analyseDegs d + | (Note (Just Fl) I3) `elem` d = Min + | (Note (Just Sh) I5) `elem` d = Sev + | (Note (Just Fl) I7) `elem` d = Sev + | (Note Nothing I7) `elem` d = Maj7 + | (Note (Just Fl) I9) `elem` d = Sev + | (Note (Just Sh) I9) `elem` d = Sev + | (Note Nothing I11) `elem` d = Sev + | (Note (Just Sh) I11) `elem` d = Sev + | (Note (Just Fl) I13) `elem` d = Sev + | (Note Nothing I13) `elem` d = Sev + | (Note Nothing I3) `elem` d = Maj + | otherwise = Maj + + + +parseShorthand :: Parser Shorthand +parseShorthand = Maj <$ pString "maj" + <|> Min <$ pString "min" + <|> Dim <$ pString "dim" + <|> Aug <$ pString "aug" + <|> Maj7 <$ pString "maj7" + <|> Min7 <$ pString "min7" + <|> Sev <$ pString "7" + <|> Dim7 <$ pString "dim7" + <|> HDim7 <$ pString "hdim" <* opt (pSym '7') '7' + <|> MinMaj7 <$ pString "minmaj7" + <|> Maj6 <$ pString "maj6" + <|> Maj6 <$ pString "6" + <|> Min6 <$ pString "min6" + <|> Nin <$ pString "9" + <|> Maj9 <$ pString "maj9" + <|> Min9 <$ pString "min9" + <|> Sus4 <$ pString "sus4" <?> "Shorthand" + +-- We don't produce intervals for a shorthand. This could easily be added, +-- though. +parseDegrees :: Parser [Addition] +parseDegrees = pPacked (pSym '(') (pSym ')') + (catMaybes <$> (pList1Sep (pSym ',') parseDegree)) + +parseDegree :: Parser (Maybe Addition) +parseDegree = (Just <$> (Note <$> pMaybe parseModifier <*> parseInterval)) + <|> Nothing <$ pSym '*' <* pMaybe parseModifier <* parseInterval + +parseModifier :: Parser Modifier +parseModifier = Sh <$ pSym 's' + <|> Sh <$ pSym '#' + <|> Fl <$ pSym 'b' + <|> SS <$ pString "ss" + <|> FF <$ pString "bb" <?> "Modifier" + +parseInterval :: Parser Interval +parseInterval = ((!!) [minBound..] ) . pred <$> pNaturalRaw + +parseRoot :: Parser Root +parseRoot = Note Nothing A <$ pSym 'A' + <|> Note Nothing B <$ pSym 'B' + <|> Note Nothing C <$ pSym 'C' + <|> Note Nothing D <$ pSym 'D' + <|> Note Nothing E <$ pSym 'E' + <|> Note Nothing F <$ pSym 'F' + <|> Note Nothing G <$ pSym 'G' + <|> Note (Just Fl) A <$ pString "Ab" + <|> Note (Just Fl) B <$ pString "Bb" + <|> Note (Just Fl) C <$ pString "Cb" + <|> Note (Just Fl) D <$ pString "Db" + <|> Note (Just Fl) E <$ pString "Eb" + <|> Note (Just Fl) F <$ pString "Fb" + <|> Note (Just Fl) G <$ pString "Gb" + <|> Note (Just Sh) A <$ pString "A#" + <|> Note (Just Sh) B <$ pString "B#" + <|> Note (Just Sh) C <$ pString "C#" + <|> Note (Just Sh) D <$ pString "D#" + <|> Note (Just Sh) E <$ pString "E#" + <|> Note (Just Sh) F <$ pString "F#" + <|> Note (Just Sh) G <$ pString "G#" <?> "Chord root"
+ src/HarmTrace/Tokenizer/Tokens.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceAbsToken + , PieceToken (..), ParseStatus (..) + ) where + +import HarmTrace.Base.MusicRep +import HarmTrace.HAnTree.Binary +import Generics.Instant.TH +import Data.Binary + +-------------------------------------------------------------------------------- +-- Tokens for parsing chords +-------------------------------------------------------------------------------- + +-- merged Chords that will be presented to the parser +data ChordToken = ChordToken { _root :: ScaleDegree + , _classType :: ClassType + , chords :: [ChordLabel] + , status :: ParseStatus + , chordNumReps :: Int + , dur :: Int -- duration + } + +data ParseStatus = NotParsed | Parsed | Deleted | Inserted + deriving (Eq, Show) + +-- a datatype to store a tokenized chords +-- type PieceRelToken = PieceToken ChordDegree +type PieceAbsToken = PieceToken ChordLabel +data PieceToken a = PieceToken { pieceKey :: Key, labels :: [a] } + +-------------------------------------------------------------------------------- +-- Instances for Chord Tokens +-------------------------------------------------------------------------------- +instance Eq ChordToken where + (ChordToken sd clss _cs stat _n _d) == (ChordToken sd2 clss2 _cs2 stat2 _n2 _d2) + = sd == sd2 && clss == clss2 && stat == stat2 + +instance Show ChordToken where + show (ChordToken sd clss _cs Inserted _n _d) = show sd ++ show clss++"[Inserted]" + show (ChordToken sd clss cs Deleted _n _d) = + show sd ++ show clss ++ "[Deleted" ++ showChords cs ++ "]" + show (ChordToken sd clss cs _ _n d) = show sd ++ show clss ++ '_' : show d + ++ showChords cs +showChords :: Show a => [Chord a] -> String +showChords = concatMap (\x -> '[' : show x ++ "]") + + +-------------------------------------------------------------------------------- +-- Binary instances +-------------------------------------------------------------------------------- + +deriveAllL [''ChordToken, ''ParseStatus] + +instance Binary ChordToken where + put = putDefault + get = getDefault +instance Binary ParseStatus where + put = putDefault + get = getDefault