HarmTrace 0.7 → 1.0
raw patch · 50 files changed
+6339/−4890 lines, 50 filesdep +hmatrixdep +hmatrix-gsl-statsdep ~basedep ~template-haskelldep ~uu-parsinglibsetup-changed
Dependencies added: hmatrix, hmatrix-gsl-stats
Dependency ranges changed: base, template-haskell, uu-parsinglib, vector
Files
- HarmTrace.cabal +98/−94
- LICENSE +674/−1
- README +23/−0
- Setup.hs +6/−6
- src/HarmTrace/Audio/Annotations.hs +143/−0
- src/HarmTrace/Audio/BeatChroma.hs +292/−0
- src/HarmTrace/Audio/ChordTypes.hs +102/−0
- src/HarmTrace/Audio/Evaluation.hs +98/−0
- src/HarmTrace/Audio/Harmonize.hs +256/−0
- src/HarmTrace/Audio/Key.hs +95/−0
- src/HarmTrace/Audio/Parser.hs +79/−0
- src/HarmTrace/Audio/Utils.hs +121/−0
- src/HarmTrace/Base/MusicRep.hs +267/−233
- src/HarmTrace/Base/Parsing.hs +40/−40
- src/HarmTrace/Base/TypeLevel.hs +81/−81
- src/HarmTrace/HAnTree/Binary.hs +59/−59
- src/HarmTrace/HAnTree/HAn.hs +243/−243
- src/HarmTrace/HAnTree/HAnParser.hs +42/−42
- src/HarmTrace/HAnTree/PostProcess.hs +108/−108
- src/HarmTrace/HAnTree/ToHAnTree.hs +47/−47
- src/HarmTrace/HAnTree/Tree.hs +168/−165
- src/HarmTrace/HarmTrace.hs +107/−111
- src/HarmTrace/IO/Errors.hs +49/−51
- src/HarmTrace/IO/Main.hs +494/−370
- src/HarmTrace/IO/PrintTree.hs +80/−80
- src/HarmTrace/Matching/Alignment.hs +179/−179
- src/HarmTrace/Matching/AlignmentFaster.hs +0/−86
- src/HarmTrace/Matching/FlatMatch.hs +0/−121
- src/HarmTrace/Matching/GuptaNishimura.hs +190/−146
- src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs +0/−150
- src/HarmTrace/Matching/HChord.hs +51/−51
- src/HarmTrace/Matching/Matching.hs +0/−182
- src/HarmTrace/Matching/Sim.hs +89/−77
- src/HarmTrace/Matching/SimpleChord.hs +23/−41
- src/HarmTrace/Matching/Standard.hs +25/−25
- src/HarmTrace/Matching/Testing.hs +0/−82
- src/HarmTrace/Models/Jazz/Instances.hs +250/−250
- src/HarmTrace/Models/Jazz/Main.hs +28/−31
- src/HarmTrace/Models/Jazz/Model.hs +409/−410
- src/HarmTrace/Models/Models.hs +17/−19
- src/HarmTrace/Models/Parser.hs +75/−75
- src/HarmTrace/Models/Pop/Instances.hs +250/−250
- src/HarmTrace/Models/Pop/Main.hs +29/−31
- src/HarmTrace/Models/Pop/Model.hs +412/−407
- src/HarmTrace/Models/Test/Instances.hs +0/−66
- src/HarmTrace/Models/Test/Main.hs +0/−21
- src/HarmTrace/Models/Test/Model.hs +0/−22
- src/HarmTrace/Tokenizer/Tokenizer.hs +157/−156
- src/HarmTrace/Tokenizer/Tokens.hs +64/−64
- src/Main.hs +319/−217
HarmTrace.cabal view
@@ -1,94 +1,98 @@-name: HarmTrace -version: 0.7 -synopsis: Harmony Analysis and Retrieval of Music -description: HarmTrace: Harmony Analysis and Retrieval of Music - with Type-level Representations of Abstract - Chords Entities - . - We present HarmTrace, a system - for automatically analysing the harmony of music - sequences. HarmTrace is described in the paper: - . - * Jose Pedro Magalhaes and W. Bas de Haas. - /Experience Report: Functional Modelling of Musical Harmony./ - International Conference on Functional Programming, - 2011. - <http://dreixel.net/research/pdf/fmmh.pdf> - -copyright: (c) 2010--2011 Universiteit Utrecht -license: OtherLicense -license-file: LICENSE -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 -category: Music -build-type: Simple -cabal-version: >= 1.6 -tested-with: GHC == 7.0.3 - - -executable harmtrace - hs-source-dirs: src - other-modules: HarmTrace.HarmTrace - - HarmTrace.Base.MusicRep - HarmTrace.Base.Parsing - HarmTrace.Base.TypeLevel - - HarmTrace.HAnTree.Binary - HarmTrace.HAnTree.HAn - HarmTrace.HAnTree.HAnParser - HarmTrace.HAnTree.PostProcess - HarmTrace.HAnTree.ToHAnTree - HarmTrace.HAnTree.Tree - - HarmTrace.IO.Errors - HarmTrace.IO.Main - HarmTrace.IO.PrintTree - - HarmTrace.Matching.Alignment - HarmTrace.Matching.AlignmentFaster - HarmTrace.Matching.FlatMatch - HarmTrace.Matching.GuptaNishimura - HarmTrace.Matching.GuptaNishimuraEditMatch - HarmTrace.Matching.HChord - HarmTrace.Matching.Matching - HarmTrace.Matching.Sim - HarmTrace.Matching.SimpleChord - HarmTrace.Matching.Standard - HarmTrace.Matching.Testing - - HarmTrace.Models.Models - HarmTrace.Models.Parser - - HarmTrace.Models.Jazz.Instances - HarmTrace.Models.Jazz.Main - HarmTrace.Models.Jazz.Model - - HarmTrace.Models.Pop.Instances - HarmTrace.Models.Pop.Main - HarmTrace.Models.Pop.Model - - HarmTrace.Models.Test.Instances - HarmTrace.Models.Test.Main - HarmTrace.Models.Test.Model - - HarmTrace.Tokenizer.Tokenizer - HarmTrace.Tokenizer.Tokens - - main-is: Main.hs - build-depends: base >= 4.2 && < 4.4, template-haskell >=2.4 && <2.6, - mtl, directory, filepath, array, parallel >= 3, - Diff == 0.1.*, parseargs >= 0.1.3.2, - regex-tdfa == 1.1.*, process >= 1.0, - uu-parsinglib == 2.7.1, ListLike >= 3.0.1, - vector == 0.7.*, deepseq, - instant-generics >= 0.3.1 && < 0.4, binary == 0.5.* - - ghc-options: -Wall - -O2 -fno-spec-constr-count -funbox-strict-fields - -fcontext-stack=50 - -threaded -feager-blackholing -rtsopts - - ghc-prof-options: -auto-all +name: HarmTrace+version: 1.0+synopsis: Harmony Analysis and Retrieval of Music+description: HarmTrace: Harmony Analysis and Retrieval of Music + with Type-level Representations of Abstract+ Chords Entities+ .+ We present HarmTrace, a system+ for automatically analysing the harmony of music+ sequences. HarmTrace is described in the paper:+ .+ * Jose Pedro Magalhaes and W. Bas de Haas.+ /Experience Report: Functional Modelling of Musical Harmony./+ International Conference on Functional Programming,+ 2011.+ <http://dreixel.net/research/pdf/fmmh.pdf>++copyright: (c) 2010--2011 Universiteit Utrecht+license: GPL-3+license-file: LICENSE+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+category: Music+build-type: Simple+cabal-version: >= 1.6+tested-with: GHC == 7.0.3, GHC == 7.2.1++extra-source-files: README++executable harmtrace+ hs-source-dirs: src+ other-modules: HarmTrace.HarmTrace++ HarmTrace.Audio.Annotations+ HarmTrace.Audio.BeatChroma+ HarmTrace.Audio.ChordTypes+ HarmTrace.Audio.Evaluation+ HarmTrace.Audio.Harmonize+ HarmTrace.Audio.Key+ HarmTrace.Audio.Parser+ HarmTrace.Audio.Utils++ HarmTrace.Base.MusicRep+ HarmTrace.Base.Parsing+ HarmTrace.Base.TypeLevel++ HarmTrace.HAnTree.Binary+ HarmTrace.HAnTree.HAn+ HarmTrace.HAnTree.HAnParser+ HarmTrace.HAnTree.PostProcess+ HarmTrace.HAnTree.ToHAnTree+ HarmTrace.HAnTree.Tree++ HarmTrace.IO.Errors+ HarmTrace.IO.Main+ HarmTrace.IO.PrintTree++ HarmTrace.Matching.Alignment+ HarmTrace.Matching.HChord+ HarmTrace.Matching.Sim+ HarmTrace.Matching.SimpleChord+ HarmTrace.Matching.Standard+ HarmTrace.Matching.GuptaNishimura++ HarmTrace.Models.Models+ HarmTrace.Models.Parser++ HarmTrace.Models.Jazz.Instances+ HarmTrace.Models.Jazz.Main+ HarmTrace.Models.Jazz.Model++ HarmTrace.Models.Pop.Instances+ HarmTrace.Models.Pop.Main+ HarmTrace.Models.Pop.Model++ HarmTrace.Tokenizer.Tokenizer+ HarmTrace.Tokenizer.Tokens++ main-is: Main.hs+ build-depends: base >= 4.2 && < 4.5, template-haskell >=2.4 && <2.7,+ mtl, directory, filepath, array, parallel >= 3,+ Diff == 0.1.*, parseargs >= 0.1.3.2, + regex-tdfa == 1.1.*, process >= 1.0,+ uu-parsinglib >= 2.7.1, ListLike >= 3.0.1,+ vector >= 0.7, deepseq,+ instant-generics >= 0.3.1 && < 0.4, binary == 0.5.*,+ hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9++ cpp-options: -DAUDIO++ ghc-options: -Wall+ -O2 -fno-spec-constr-count -funbox-strict-fields+ -fcontext-stack=50+ -threaded -feager-blackholing -rtsopts++ ghc-prof-options: -auto-all
LICENSE view
@@ -1,1 +1,674 @@-This work is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/3.0/ or send a letter to Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA. + GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ README view
@@ -0,0 +1,23 @@+HarmTrace (Harmony Analysis and Retrieval of Music with Type-level +Representations of Abstract Chords Entities) is a system for automatic harmony +analysis of music. It takes a sequence of chords as input and produces a harmony +analysis, which can be visualised as a tree. ++Music theory has been essential in composing and performing music for centuries. +Within Western tonal music, from the early Baroque on to modern-day jazz and pop +music, the function of chords within a chord sequence can be explained by +harmony theory. Although Western tonal harmony theory is a thoroughly studied +area, formalising this theory is a hard problem. ++With HarmTrace we have developed a formalisation of the rules of tonal harmony +as a Haskell (generalized) algebraic datatype. Given a sequence of chord labels, +the harmonic function of a chord in its tonal context is automatically derived. +For this, we use several advanced functional programming techniques, such as +type-level computations, datatype-generic programming, and error-correcting +parsers. Our functional model of harmony offers various benefits: it can be used +to define harmonic similarity measures and facilitate music retrieval, or it can +help musicologists in batch-analysing large corpora of digitised scores, for +instance. ++More information about HarmTrace, including how to use and example output, is+available on its webpage: http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace
Setup.hs view
@@ -1,6 +1,6 @@-module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMainWithHooks simpleUserHooks +module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMainWithHooks simpleUserHooks
+ src/HarmTrace/Audio/Annotations.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +module HarmTrace.Audio.Annotations where + +-- import Text.ParserCombinators.UU hiding (join) +-- import Text.ParserCombinators.UU.BasicInstances +-- import Data.ListLike.Base (ListLike) + +import Data.Maybe (isJust,fromJust) + +import HarmTrace.Audio.Parser +import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicRep +import HarmTrace.Base.Parsing +import HarmTrace.Tokenizer.Tokenizer (parseDegrees, parseDegree) + +-- perhaps this file should be moved to the tokeniser module, because it is +-- is very related to tokenising + +-------------------------------------------------------------------------------- +-- Harmonically analysing Chord Annotations +-------------------------------------------------------------------------------- + +preProcess :: [ChordSegment] -> [ChordLabel] +preProcess = preProcess' 0 +preProcess' :: Int -> [ChordSegment] -> [ChordLabel] +preProcess' _ [] = [] +preProcess' ix ((TimedData c@(Chord r sh ad _loc dur) _on _off):ns) + | isNoneChord c = preProcess' (ix) ns + | otherwise = (Chord r sh ad ix dur) : preProcess' (ix+1) ns + +-------------------------------------------------------------------------------- +-- Chords +-------------------------------------------------------------------------------- + +parseAnnotationData :: Parser ChordAnnotation +parseAnnotationData = pListSep_ng pLineEnd pChordSegment <* pLineEnd + +pChordSegment :: Parser ChordSegment +pChordSegment = timedData' <$> pNumData <* pSpaceTab + <*> pNumData <* pSpaceTab <*> pChord + + +pChord :: Parser ChordLabel +pChord = f <$> parseRoot <*> pMaybe (pSym ':' *> parseShorthand) + <*> (parseDegrees `opt` []) + -- there might be a basenote inversion annotation + -- which we currently ignore + <*> pMaybe (pSym '/' *> parseDegree) where + -- if there is no root note, there is no chord type + -- Chord root shorthand additions start duration + f r sh _ _ | r == (Note Nothing N) = Chord r None [] 0 1 + | isJust sh = Chord r (fromJust sh) [] 0 1 + | otherwise = Chord r Maj [] 0 1 + +-------------------------------------------------------------------------------- +-- Keys +-------------------------------------------------------------------------------- + +parseKeyAnnotationData :: Parser KeyAnnotation +parseKeyAnnotationData = pListSep_ng pLineEnd pKeySegment <* pLineEnd + +pKeySegment :: Parser KeySegment +pKeySegment = timedData' <$> pNumData <* pSpaceTab + <*> pNumData <* pSpaceTab + <*> (pKey <|> pKeyNone) + +pKey :: Parser Key +pKey = Key <$ pString "Key" <* pSpaceTab <*> parseRoot <*> pMode + +pKeyNone :: Parser Key +pKeyNone = (Key (Note Nothing N) MajMode) <$ pString "Silence" + +pMode :: Parser Mode +pMode = MajMode <$ pString "" + <|> MinMode <$ pString ":minor" + <|> MinMode <$ pString ":aeolian" + <|> MajMode <$ pString ":major" + <|> MinMode <$ pString ":dorian" + <|> MajMode <$ pString ":mixolydian" -- this must be solved differently + <|> MajMode <$ pString ":modal" -- and this too.... + + +-------------------------------------------------------------------------------- +-- General Parsers and Utils +-------------------------------------------------------------------------------- + +timedData' :: NumData -> NumData -> a -> TimedData a +timedData' on off chrd = TimedData chrd on off + +pSpaceTab :: Parser Char +pSpaceTab = pSym ' ' <|> pSym '\t' + +-- begin stealing from Tokenizer.hs (added/changed some ad hoc instances) + +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" + <|> Maj <$ pString ""-- this is not really nice, but works + <|> Sus4 <$ pString "sus4" + <|> Sus2 <$ pString "sus2" + <?> "Shorthand" + +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 Nothing N <$ pSym 'N' -- for no chord + <|> 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" + +-- end stealing from Tokenizer.hs
+ src/HarmTrace/Audio/BeatChroma.hs view
@@ -0,0 +1,292 @@+{-# OPTIONS_GHC -Wall #-}+module HarmTrace.Audio.BeatChroma where++import HarmTrace.Audio.Parser+import HarmTrace.Audio.ChordTypes+import HarmTrace.Audio.Utils+import HarmTrace.Base.MusicRep++-- import Text.Printf (printf)+import Data.List (sortBy, groupBy)+import Data.Ord (comparing)++import Numeric.LinearAlgebra -- http://hackage.haskell.org/package/hmatrix +import qualified Numeric.GSL.Statistics as GSL hiding (mean)++--------------------------------------------------------------------------------+-- Local Parameters+--------------------------------------------------------------------------------++-- The cutOffProbability is the value that determines the length of the +-- probChord list (a sorted list with normalised distances to the chroma vector)+cutOffProbability :: NumData+cutOffProbability = 0.92++-- The maximum number of probabilities+maxProbChordListLength :: Int+maxProbChordListLength = 6++--------------------------------------------------------------------------------+-- Matching chords and chroma+-------------------------------------------------------------------------------- ++segmentByKey :: [TimedData Key] -> [TimedData [ProbChord]] -> [ProbChordSeg]+segmentByKey [] _ = error "segmentByKey: empty key list"+segmentByKey [k] chds = [Segment (getData k) chds]+segmentByKey (k : ks) chds = let (seg,cs) = span ((<= (offset k)) . offset) chds+ in Segment (getData k) seg : segmentByKey ks cs+ +groupPChord :: [[ProbChord]] -> [[[ProbChord]]]+groupPChord = groupBy probChordEqPerm++-- a function for comparing list of probchords, two list are considered equal+-- if the chords and their order match, the probabilities are ignored+probChordEq :: [ProbChord] -> [ProbChord] -> Bool+probChordEq [] [] = True+probChordEq (p:pc) (q:qs) = chordLab p == chordLab q && probChordEq pc qs+probChordEq _ _ = False++-- a function for comparing list of probchords, two list are considered equal+-- if the chords and their order match, the probabilities are ignored+probChordEqPerm :: [ProbChord] -> [ProbChord] -> Bool+probChordEqPerm p q = eqPerm (map chordLab p) (map chordLab q)+eqPerm :: [ChordLabel] -> [ChordLabel] -> Bool+eqPerm [] _ = True+eqPerm (p:pc) qs = p `elem` qs && eqPerm pc qs+-- eqPerm (p:pc) qs = ( qs == [noneLabel] || p `elem` qs ) && eqPerm pc qs++-- syncronises the last beat and key frame to match the last chord frame+syncEndings :: [ChordinoLine] -> [NumData] -> [ChordinoLine]+ -> ([ChordinoLine], [NumData], [ChordinoLine])+syncEndings chrm beat key = + let endTime = time $ last chrm+ key' = takeWhile ((< endTime).time) key + (l,[lst]) = splitAt ((length key') - 1) key'+ in (chrm, takeWhile (< endTime) beat ++ [endTime]+ , l ++ [lst{time = endTime}])++-- creates "timed" blocks, given beat and beat aligned data +-- (used by simpleannotator)+addTimeInfo :: BeatTrackerData -> [a] -> [TimedData a]+addTimeInfo offs blcks = zipWith3 TimedData blcks ons offs where+ ons = 0 : offs ++--------------------------------------------------------------------------------+-- Matrix Functions for matching chords+-------------------------------------------------------------------------------- ++createChordRanks :: BeatChroma -> [[ProbChord]]+createChordRanks = + map (selectTop . normalize .sortTake . matchCDictionary) + . meanBeatSyncVectors where+ sortTake, normalize :: [ProbChord] -> [ProbChord]+ sortTake = take maxProbChordListLength . sortBy (comparing prob)+ normalize l@(h:_) = map (\(ProbChord c p) -> (ProbChord c (prob h / p))) l + normalize [] = []+ selectTop l -- selects the everything with a propability > x+ | null s = none + -- so far, this had not possitive effect+ -- | length s > maxProbChordListLength = none + | otherwise = s + where s = takeWhile ((> cutOffProbability) . prob) l + none = [ProbChord noneLabel 0.0]++-- takes the mean of every "beat block" and these Vectors as one Matrix+-- Each row of this matrix corresponds to the chroma within one beat+meanBeatSyncVectors :: BeatChroma -> [Vector NumData] -- [[ChordinoLine]]+meanBeatSyncVectors = map mean . beatSyncMatrix++-- takes the median of every "beat block" and these Vectors as one Matrix+-- Each row of this matrix corresponds to the chroma within one beat+-- N.B. does not perform as well as meanBeatSyncVectors+-- medianBeatSyncVectors :: BeatChroma -> [Vector NumData]+-- medianBeatSyncVectors = + -- map (fromList . map GSL.median . toColumns) . beatSyncMatrix+ +-- creates a list of matrices, in which each matrix corresponds to the+-- collection of chroma vectors within one beat (drop the time stamp)+beatSyncMatrix :: BeatChroma -> [Matrix NumData]+beatSyncMatrix dat = map (dropColumns 1 . toChromaMatrix) dat++-- converst a ChordinoData into a Matrix+toChromaMatrix :: ChordinoData -> Matrix NumData+toChromaMatrix = fromLists . map mergeLine where+ mergeLine :: ChordinoLine -> [NumData]+ mergeLine (ChordinoLine tm bs tb) = tm : bs ++ tb + +-- matches all 12 tranposisition of a chord structure with a chorma vector +matchCDictionary :: Vector NumData -> [ProbChord]+matchCDictionary v = map (matchStruct v) chordDictionary++-- calculate an Euclidean (PNorm2) norm+matchStruct :: Vector NumData -> ChordCand -> ProbChord+matchStruct chroma cc@(ChordCand r sh _cs) = + -- Chord root shorthand degrees description_str repetitions+ ProbChord (Chord r sh [] 0 1) (pnorm PNorm2 (chroma - bassTrebStruct cc))+ -- (correlation chroma (bassTrebStruct cc))++-- creates a "matchable" 24D vector given a ChordStruct+bassTrebStruct :: ChordCand -> Vector NumData+bassTrebStruct (ChordCand _r _sh cs) = fromList (cs ++ cs)+-- does not seem to improve performance+{- | sh == None = fromList (cs ++ cs)+ | otherwise = fromList (bass ++ cs) where+ bass = (f before) ++ 1 : (f $ tail after)+ (before,after)= splitAt (diaNatToSemi r) cs+ f = map (* 0.5)+-} +--------------------------------------------------------------------------------+-- The Chord Dictionary+--------------------------------------------------------------------------------++-- the chord dictionary of all chords that are matched+chordDictionary :: [ChordCand]+chordDictionary = concatMap transpose12 [minBound..] -- all shorthands :-)+ +-- takes a ChordStruct and returns a list containing the 12+-- tranposed verions (including the original) of the ChordStruct +transpose12 :: Shorthand -> [ChordCand]+transpose12 shand + | null cstruct = []+ | shand == None = [ChordCand (Note Nothing N) None cstruct]+ | otherwise = transpose12' 11 shand cstruct where+ cstruct = (shortHandToChordStruct shand)+ transpose12' :: Int -> Shorthand -> ChordStruct -> [ChordCand]+ transpose12' 0 sh cs = [ChordCand (head chromaPC) sh cs]+ transpose12' n sh cs = ChordCand (chromaPC!!(12-n)) sh (shift n cs) + : transpose12' (n-1) sh cs++shortHandToChordStruct :: Shorthand -> ChordStruct+shortHandToChordStruct sh = case sh of + -- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11+ -- C, Db, D, Eb, E, F, F#, G, Ab, A, Bb, B+ Maj -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0 ] + Min -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0 ]+ -- HDim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0 ] + -- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ] + -- Maj6 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0 ] + Sev -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0 ] + Dim7 -> [1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0 ] + -- Maj7 -> [1, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1 ] + -- Min7 -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 ]+ -- Min6 -> [1, 0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0 ]+ -- Sus4 -> [1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0 ] + + None -> [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] + -- None -> [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ] + _ -> []+ -- none+ -- all+ -- ....+ +--------------------------------------------------------------------------------+-- Chroma key estimation+--------------------------------------------------------------------------------+ +beatSyncKeyStrenth :: BeatTrackerData -> ChordinoData -> [[NumData]]+beatSyncKeyStrenth bts key = + map matchKeyProfiles . meanBeatSyncVectors {- . mergeBeats 8 -} $ beatSync bts key++nanToZero :: RealFloat a => a -> a+nanToZero n = if isNaN n then 0 else n++-- printKeyStrength :: BeatTrackerData -> ChordinoData -> IO ()+-- printKeyStrength bts chrm = + -- let showLn :: [NumData] -> IO ()+ -- showLn x = do mapM_ (putStr . printf "%.2f ") x ; putStr "\n"+ -- in mapM_ showLn $ beatSyncKeyStrenth bts chrm+ +matchKeyProfiles :: Vector NumData -> [NumData]+-- matchKeyProfiles chroma = map (\x -> pnorm PNorm2 (chroma - x)) allKeyProfiles+matchKeyProfiles crm = map (nanToZero . GSL.correlation crm) allKeyProfiles++allKeyProfiles :: [Vector NumData]+allKeyProfiles = map (fromList . keyToProfile) keyMap + +keyToProfile :: Key -> [NumData] +keyToProfile (Key root m) = reverseShift (diaNatToSemi root) (selectProfile m) ++selectProfile :: Mode -> [NumData]+selectProfile MajMode = krumhanslProfCMaj+selectProfile MinMode = krumhanslProfCMin + +krumhanslProfCMaj, krumhanslProfCMin :: [NumData]+krumhanslProfCMaj = + [6.35, 2.23, 3.48, 2.33, 4.38, 4.09, 2.52, 5.19, 2.39, 3.66, 2.29, 2.88]+krumhanslProfCMin = + [6.33, 2.68, 3.52, 5.38, 2.60, 3.53, 2.54, 4.75, 3.98, 2.69, 3.34, 3.17]+ +--------------------------------------------------------------------------------+-- key strength Matrix Computations+--------------------------------------------------------------------------------+ +toBeatSyncKey :: BeatTrackerData -> KeyStrengthData -> [Key]+toBeatSyncKey bts key = + medianFilter 4 . map ((!!) keyMap . maxIndex) . meanBeatSyncVectors + $ beatSync bts key++-- returns a (median based) key label given a Nx24 key strength matrix+findKeyIndex :: Matrix NumData -> Key+findKeyIndex = (!!) keyMap . median . map maxIndex . toRows++toKeyMatrix :: KeyStrengthData -> Matrix NumData+toKeyMatrix = fromLists . map mergeKeyData where+ mergeKeyData :: ChordinoLine -> [NumData]+ mergeKeyData (ChordinoLine _ ma mi) = ma ++ mi++-- findKeyLab :: Matrix NumData -> Key+-- findKeyLab m = keyMap !! (findKeyIndex m)++-- the chroma map uses a circle of fifths based ordering+keyMap :: [Key]+keyMap = [ Key (Note (Just Sh) F) MajMode -- "F#" 6+ , Key (Note Nothing B) MajMode -- "B" 11+ , Key (Note Nothing E) MajMode -- "E" 4+ , Key (Note Nothing A) MajMode -- "A" 9+ , Key (Note Nothing D) MajMode -- "D" 2+ , Key (Note Nothing G) MajMode -- "G" 7+ , Key (Note Nothing C) MajMode -- "C" 0+ , Key (Note Nothing F) MajMode -- "F" 5+ , Key (Note (Just Fl) B) MajMode -- "Bb" 10+ , Key (Note (Just Fl) E) MajMode -- "Eb" 3+ , Key (Note (Just Fl) A) MajMode -- "Ab" 8+ , Key (Note (Just Fl) D) MajMode -- "Db" 1+ , Key (Note (Just Fl) E) MinMode -- "Ebm" 3+ , Key (Note (Just Sh) G) MinMode -- "G#m" 8+ , Key (Note (Just Sh) C) MinMode -- "C#m" 1+ , Key (Note (Just Sh) F) MinMode -- "F#m" 6+ , Key (Note Nothing B) MinMode -- "Bm" 11+ , Key (Note Nothing E) MinMode -- "Em" 4+ , Key (Note Nothing A) MinMode -- "Am" 9+ , Key (Note Nothing D) MinMode -- "Dm" 2+ , Key (Note Nothing G) MinMode -- "Gm" 7+ , Key (Note Nothing C) MinMode -- "Cm" 0+ , Key (Note Nothing F) MinMode -- "Fm" 5+ , Key (Note (Just Fl) B) MinMode -- "Bbm" 10+ ]++--------------------------------------------------------------------------------+-- key annotation preparation+--------------------------------------------------------------------------------++-- syncronises the last beat and key frame to match the last chord frame+syncWithAnnKey :: [ChordinoLine] -> [NumData] -> [TimedData Key] + -> ([NumData], [TimedData Key])+syncWithAnnKey chrm beat key = + let endTime = time $ last chrm + beat' = takeWhile (< endTime) beat ++ [endTime]+ none (Key r _) = r /= Note Nothing N -- filter the None keys+ noNoneKey = (filter (none . getData) key)+ -- reset key start timestamp to 0.0 and end timestampt to chorma end+ resetHead = (head noNoneKey) {onset = 0.0} : tail noNoneKey+ (l,[lst]) = splitAt ((length resetHead) - 1) resetHead+ -- key' = sampleAt beat' (l ++[lst{offset = endTime}])+ in (beat',l ++[lst{offset = endTime}])+ +--------------------------------------------------------------------------------+-- general Matrix stuff+--------------------------------------------------------------------------------++-- given a matrix, calculates the mean vector +mean :: (Product t, Fractional t) => Matrix t -> Vector t+mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a
+ src/HarmTrace/Audio/ChordTypes.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module HarmTrace.Audio.ChordTypes where+ +import HarmTrace.Base.MusicRep+import Text.Printf (printf)+import Control.DeepSeq++--------------------------------------------------------------------------------+-- High-level structure+--------------------------------------------------------------------------------++-- the standard evaluation format of a chord annotation consists of a+-- list with chords and segment boundaries+type ChordAnnotation = [ChordSegment]++type ChordSegment = TimedData ChordLabel++type KeyAnnotation = [KeySegment]+ +type KeySegment = TimedData Key++type Block = TimedData [ProbChord]++data TimedData a = TimedData {getData :: a, onset :: NumData, offset :: NumData}++-- clusering propchords in a collection of chords that share a key+data ProbChordSeg = Segment { segKey :: Key + , segChords :: [TimedData [ProbChord]] }+ +-- combining a chord with a probability+data ProbChord = ProbChord {chordLab :: ChordLabel, prob :: NumData}++-- a chord candidate: an intermediate datatype that matches shorthand, +-- chord structure and root note+data ChordCand = ChordCand Root Shorthand ChordStruct + +type ChordStruct = [NumData] ++-- an iterable list of Roots+chromaPC ::[Root] +chromaPC = [ Note Nothing C+ , Note (Just Fl) D+ , Note Nothing D+ , Note (Just Fl) E+ , Note Nothing E+ , Note Nothing F+ , Note (Just Sh) F+ , Note Nothing G+ , Note (Just Fl) A+ , Note Nothing A+ , Note (Just Fl) B+ , Note Nothing B+ ]++--------------------------------------------------------------------------------+-- NFData instances+-------------------------------------------------------------------------------- ++-- Simplified+instance NFData ChordSegment where+ rnf (TimedData a b c) = a `seq` rnf b `seq` rnf c++--------------------------------------------------------------------------------+-- Instances of high-level datastructure+-------------------------------------------------------------------------------- ++instance Show (ProbChord) where + show (ProbChord (Chord r sh _ _ _) p) = + show r ++ ':' : show sh ++ ':' : printf "%.2f" p ++instance Show a => Show (TimedData a) where + show (TimedData bk s l) = show bk ++ " (" ++ show s ++ ':' : show l ++ ")\n"++instance Show ProbChordSeg where+ show pc = concatMap (\x -> (show $ segKey pc) ++ ' ' : show x) (segChords pc)+ +--------------------------------------------------------------------------------+-- numerical data representation+--------------------------------------------------------------------------------++data AudioFeat = AudioFeat String ChordinoData BeatTrackerData KeyStrengthData +instance Show AudioFeat where + show (AudioFeat idStr _ _ _) = idStr++type ChordinoData = [ChordinoLine] +data ChordinoLine = ChordinoLine + { time :: NumData + , bass :: [NumData] -- each of the lists has always 12 elements + , treb :: [NumData] -- A, Bb, B, C, Db, D, Eb, E, F, F#, G, Ab + } deriving (Eq, Show) -- and is shifted 3 positions to match C, Db, .., B+ +type KeyStrengthData = ChordinoData ++type BeatTrackerData = [NumData] -- deriving (Eq, Show) ++type NumData = Double++type BeatChroma = [[ChordinoLine]] -- one list per beat++-- data TimeChroma = TimeChroma {stamp :: NumData, croma :: [NumData]}
+ src/HarmTrace/Audio/Evaluation.hs view
@@ -0,0 +1,98 @@+module HarmTrace.Audio.Evaluation where++import HarmTrace.Audio.ChordTypes+import HarmTrace.Audio.Utils +import HarmTrace.Audio.Key(getBeatSyncKeyFromChroma)+import HarmTrace.Audio.BeatChroma ( createChordRanks, groupPChord, syncEndings)+import HarmTrace.Base.MusicRep ++import Data.List (genericLength, zipWith5)+import Text.Printf(printf)+import System.IO (stdout,hFlush)++--------------------------------------------------------------------------------+-- Evaluation Parameters+--------------------------------------------------------------------------------++-- this functions determines when two chords are considered the same+eqFunc :: ChordLabel -> ChordLabel -> Bool+eqFunc = chordTriadEq++sampleRate, displaySampleRate :: NumData+-- the sample rate used in a normal (non-visual) comparison (in seconds)+sampleRate = 0.01+-- the sample rate used when visually comparing a chord annotation with a +-- ground-truth annotation. Often a higher sample rate is prefered. Although+-- one uses precision, the visual result is easier to read+displaySampleRate = 0.3++--------------------------------------------------------------------------------+-- Evaluation function+--------------------------------------------------------------------------------++chordClassEq :: ChordLabel -> ChordLabel -> Bool+chordClassEq (Chord (Note Nothing N) None _ _ _)+ (Chord (Note Nothing N) None _ _ _) = True+chordClassEq (Chord (Note Nothing N) None _ _ _) _ = False+chordClassEq _ (Chord (Note Nothing N) None _ _ _) = False+chordClassEq (Chord r1 sh1 _ _ _) (Chord r2 sh2 _ _ _) =+ (diaNatToSemi r1) == (diaNatToSemi r2) && (toClassType sh1 == toClassType sh2)++chordTriadEq :: ChordLabel -> ChordLabel -> Bool+chordTriadEq (Chord (Note Nothing N) None _ _ _)+ (Chord (Note Nothing N) None _ _ _) = True+chordTriadEq (Chord (Note Nothing N) None _ _ _) _ = False+chordTriadEq _ (Chord (Note Nothing N) None _ _ _) = False+chordTriadEq (Chord r1 sh1 _ _ _) (Chord r2 sh2 _ _ _) =+ (diaNatToSemi r1) == (diaNatToSemi r2) && (toMode sh1 == toMode sh2)++-- calculates the relative correct overlap, which is the recall+-- of matching frames, and defined as the nr of matching frames (sampled at+-- an 10 milisecond interval) divided by all frames+relCorrectOverlap :: ChordAnnotation -> ChordAnnotation -> Double+relCorrectOverlap a b =+ (foldl countMatch 0 (zipWith eqFunc sama samb)) / tot where+ sama = sample a+ samb = sample b+ tot = max (genericLength sama) (genericLength samb)++-- does the same thing as relCorrectOverlap, but it also prints the+-- chords and uses a lower sample rate+printRelCorrectOverlap :: (AudioFeat -> ChordAnnotation) -> AudioFeat+ -> ChordAnnotation -> IO Double+printRelCorrectOverlap annotator af@(AudioFeat _idStr chrm' beat' key') gt = do+ let (chrm, beat, key) = syncEndings chrm' beat' key'+ keys = mergeAndTimeStamp head beat $ getBeatSyncKeyFromChroma beat key + blks = mergeAndTimeStamp avgPC beat . groupPChord+ . createChordRanks $ beatSync beat chrm+ -- sample the info for printing and evaluation+ samaf = sampleWith displaySampleRate (annotator af)+ samgt = sampleWith displaySampleRate gt+ sambk = sampleWith displaySampleRate blks+ samk = sampleWith displaySampleRate keys++ tot = max (genericLength samaf) (genericLength samgt)+ showEq m = if m then "==" else "/=" + printEval :: NumData -> ChordLabel -> ChordLabel -> Key -> [ProbChord] + -> IO Bool+ printEval t g a b c = + do putStrLn (printf "%.2f" t ++ '\t' : showEq equal ++ '\t' : show g+ ++ '\t' : show a ++ '\t' : show b ++ '\t' : show c)+ >> hFlush stdout+ return equal where equal = g `eqFunc` a+ putStrLn "time\tmatch\tGT\t\tMPTREE\tkey\toptional chords"+ m <- sequence (zipWith5 printEval [0.0,displaySampleRate ..] + samgt samaf samk sambk)+ return ((foldl countMatch 0 m) / tot)++countMatch :: Double -> Bool -> Double +countMatch x y | y = succ x -- count the number of matching frames+ | otherwise = x++-- given a chord annotation sample the chord label at every 10 ms+sample :: [TimedData a] -> [a]+sample = sampleWith sampleRate++-- like sample, but takes a sample rate (seconds :: Float) as argument+sampleWith :: NumData -> [TimedData a] -> [a]+sampleWith rate = sampleAt [0.00, rate .. ]
+ src/HarmTrace/Audio/Harmonize.hs view
@@ -0,0 +1,256 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module HarmTrace.Audio.Harmonize ( harmonyAnnotator, headAnnotator+ , simpleAnnotator , putSegStats) where++import HarmTrace.Audio.BeatChroma( createChordRanks, syncWithAnnKey, addTimeInfo+ , groupPChord, segmentByKey , syncEndings)+import HarmTrace.Audio.Key (getBeatSyncKeyFromChroma)+import HarmTrace.Audio.Utils +import HarmTrace.Audio.ChordTypes+import HarmTrace.Base.MusicRep++import HarmTrace.Models.Models+import HarmTrace.Models.Jazz.Main+import HarmTrace.Models.Pop.Main+import HarmTrace.Tokenizer.Tokens+import HarmTrace.IO.Errors++import HarmTrace.HAnTree.HAn (HAn)+import HarmTrace.HAnTree.Tree (Tree, size, depth)+import HarmTrace.HAnTree.ToHAnTree (GTree)+-- import HarmTrace.HAnTree.PostProcess (PPOption (..))+import HarmTrace.HarmTrace++import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances++import System.IO (stdout,hFlush)+import Data.List (sortBy, groupBy)+import Text.Printf (printf)++--------------------------------------------------------------------------------+-- Local Parameters+--------------------------------------------------------------------------------++maxSegmentSize, maxLProductSize :: Int+maxSegmentSize = 8+maxLProductSize = 20++--------------------------------------------------------------------------------+-- From chords with probabilities to a single chord, using harmony+--------------------------------------------------------------------------------+ +harmonyAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat + -> ChordAnnotation+harmonyAnnotator (GrammarEx g) mk af = case mk of + Nothing -> concatMap (harmonize g) (preProcessData af)+ (Just k) -> concatMap (harmonize g) (preProcessDataWithKey k af)++preProcessDataWithKey :: [TimedData Key] -> AudioFeat -> [ProbChordSeg]+preProcessDataWithKey key' (AudioFeat _idStr chrm beat' _keystrength) = + let (beat,key) = syncWithAnnKey chrm beat' key'+ chdgrp = mergeAndTimeStamp avgPC beat . groupPChord+ . createChordRanks $ beatSync beat chrm+ in segmentByTonic $ segmentByKey key chdgrp+ +preProcessData :: AudioFeat -> [ProbChordSeg]+preProcessData (AudioFeat _idStr chrm' beat' key') = + let (chrm, beat, key) = syncEndings chrm' beat' key'+ keygrp = mergeAndTimeStamp head beat $ getBeatSyncKeyFromChroma beat key + chdgrp = mergeAndTimeStamp avgPC beat . groupPChord+ . createChordRanks $ beatSync beat chrm+ in segmentByTonic $ segmentByKey keygrp chdgrp++harmonize :: forall g. (GTree g) => Grammar g -> ProbChordSeg -> ChordAnnotation+harmonize g (Segment k bs) =+ let isExpandable :: Bool+ isExpandable = (length $ filter ((>1) . length) (map getData bs)) > 0+ + pickHead :: Block -> ChordSegment+ pickHead tpc = tpc {getData = chordLab . head $ getData tpc}+ + myParse :: [ChordToken] -> (Tree HAn,[ChordToken],[Error Int])+ myParse x =+ let -- First, parse the tokens+ res :: ([g],[Error Int])+ res = case g of + Jazz -> parse_h ((,) <$> pJazz k <*> pEnd) (createStr 0 x)+ Pop -> parse_h ((,) <$> pPop k <*> pEnd) (createStr 0 x)+ -- Build a ParseResult from that+ pr = ParseResult u (concatMap chords x) (fst res) u u u (snd res) []+ -- So that we can post-process it. Then extract the Tree HAn+ t = pieceTreeHAn (postProc [ RemovePDPT, MergeDelChords ] pr)+ u :: forall a. a+ u = error "harmonize: undefined placeholder evaluated"+ -- Return the Tree HAn, the input tokens, and the errors+ in (t, x, snd res)++ -- To be improved+ evaluateParse :: (Tree HAn,[ChordToken],[Error Int])+ -> (Tree HAn,[ChordToken],Float)+ evaluateParse (ts,tokens,errors) = (ts,tokens,errorRatio errors tokens)++ -- Generate, parse, and evaluate all possible sequences of chords+ parseResults :: [(Tree HAn,[ChordToken],Float)]+ parseResults = [ evaluateParse (myParse l)+ | l <- lProduct (map (map probChord . getData) bs) ]++ -- From all possible parse trees, take the best one+ select :: [(Tree HAn,[ChordToken],Float)] -> [ChordToken]+ select = select1 . head+ . groupBy (\(_,_,a) (_,_,b) -> a `compare` b == EQ)+ . sortBy (\(_,_,a) (_,_,b) -> a `compare` b)++ -- These all have the same error ratio, so we sort them first by tree+ -- size, then depth, and pick the first+ select1 :: [(Tree HAn,[ChordToken],Float)] -> [ChordToken]+ select1 = snd3 . head . sortBy cmp where+ cmp (a,_,_) (b,_,_) = (size a, depth a) `compare` (size b, depth b)+ snd3 (_,a,_) = a++ probChord :: ProbChord -> ChordToken+ probChord (ProbChord lab@(Chord r sh _add _on _dur) _p) = + (ChordToken r' sh' [lab] NotParsed 1 0) where+ r' = if isNone r then Note Nothing Imp else toScaleDegree k r+ sh' = if sh == None then NoClass else toClassType sh+ + -- store on and offsets for merging after parsing+ ons, offs :: [NumData]+ ons = map onset bs+ offs = map offset bs++ mergeTimeStamp :: [ChordToken] -> [ChordSegment]+ mergeTimeStamp cs = zipWith3 TimedData (map (head . chords) cs) ons offs++ -- if there is nothing to expand, do not parse+ in if isExpandable then mergeTimeStamp $ select parseResults + else map pickHead bs++--------------------------------------------------------------------------------+-- Segmentation functions+--------------------------------------------------------------------------------+-- Temporary test values+{-+test = segmentTonic testKey testSeq+testKey = Key (Note Nothing C) MajMode+testSeq = testChordG ++ testChordC ++ testChordC ++ testChordG ++ testChordG+testChordC = [TimedData [ProbChord labC 1, ProbChord labG 0.5] 0 0]+testChordG = [TimedData [ProbChord labG 1, ProbChord labC 0.5] 0 0]+labC = Chord (Note Nothing C) Maj [] 0 0+labG = Chord (Note Nothing G) Maj [] 0 0+-}++-- Reminder: TimedData [ProbChord] == Block+segmentByTonic :: [ProbChordSeg] -> [ProbChordSeg]+segmentByTonic segs = concatMap emergencySplit $ concatMap split segs where+ split :: ProbChordSeg -> [ProbChordSeg]+ split (Segment key cs) = zipWith Segment (repeat key) (segmentTonic key cs)++-- In case segments are just to big, even after segmenting on Tonic and Dominant+-- split these segments into smaller segements recursively.+emergencySplit :: ProbChordSeg -> [ProbChordSeg]+emergencySplit (Segment k cs) = map (Segment k) (recSplit cs)+recSplit :: [TimedData [a]] -> [[TimedData [a]]]+recSplit [] = []+recSplit b+ | blen <= maxSegmentSize + && (snd $ lProdStats b) <= maxLProductSize = [b]+ | otherwise = recSplit l ++ recSplit r+ where blen = length b+ (l,r) = splitAt (blen `div` 2) b + +-- Break into segments according to the key+segmentTonic :: Key -> [Block] -> [[Block]]+segmentTonic k' cs' = segmentTonic' k' cs' [] where + segmentTonic' _ [] [] = []+ segmentTonic' _ [] acc = [reverse acc]+ segmentTonic' k (c:cs) acc+ | c' `isTonic` k || c' `isDom` k = reverse (c:acc) : segmentTonic k cs+ | otherwise = segmentTonic' k cs (c:acc) where + c' = getFstChord c++-- Take the first chord (which is the one with the highest probability, since+-- the list is sorted)+getFstChord :: TimedData [ProbChord] -> ChordLabel+getFstChord c = case getData c of+ [] -> error "getFstChord: empty list"+ (h:_) -> chordLab h -- only split on chords we are certain of+ -- _ -> Chord (Note Nothing N) None [] 0 0 -- else return None++-- Check if this chord label is the tonic+isTonic :: ChordLabel -> Key -> Bool+isTonic c (Key r m) = r == chordRoot c && m `eqMode` (chordShorthand c)++-- Check if this chord label is the dominant+-- JPM: I don't understand why this function looks so different from `isTonic`+isDom :: ChordLabel -> Key -> Bool+isDom (Chord (Note Nothing N) _ _ _ _) _ = False+isDom c key = toScaleDegree key (chordRoot c) == Note Nothing V+ && MajMode `eqMode` (chordShorthand c)++-- It is debatable how to implement this function, musically speaking. This+-- is what I came up with, without thinking too much.+eqMode :: Mode -> Shorthand -> Bool+eqMode _ Sus4 = False+eqMode _ Sus2 = False+eqMode m sh = m == toMode sh++lProduct :: [[a]] -> [[a]]+lProduct [] = []+lProduct [l] = [ [x] | x <- l ]+lProduct (h:t) = concat [ map (x:) (lProduct t) | x <- h ]++--------------------------------------------------------------------------------+-- Some printing and statistics functions+--------------------------------------------------------------------------------++-- prints Segmetation statistics+putSegStats :: Maybe [TimedData Key] -> AudioFeat -> IO()+putSegStats mk af = case mk of+ Nothing -> mapM_ segmentStat $ preProcessData af+ (Just k) -> mapM_ segmentStat $ preProcessDataWithKey k af ++segmentStat :: ProbChordSeg -> IO ()+segmentStat s@(Segment k bs) = + do putStr ("start: " ++ (printf "%.3f" . onset $ head bs))+ putStr (", end: " ++ (printf "%.3f" . offset $ last bs))+ putStr (", key: " ++ show k)+ putStr (", probChords: " ++ show (length bs))+ let (l, lpr) = lProdStats bs+ putStr (", lists > 1: " ++ (show l) )+ putStrLn (" lProduct: " ++ show lpr)+ print s >> hFlush stdout++-- Given a Block list this function returns the number of probChords with a +-- list > 1 (fst) and the lProduct size (snd)+lProdStats :: [TimedData [a]] -> (Int, Int)+lProdStats bs = (length l, lpr) where+ l = filter ((>1) . length ) (map getData bs)+ lpr = foldr (\a b -> (length a) * b) 1 l++--------------------------------------------------------------------------------+-- A baseline chord label annotator+--------------------------------------------------------------------------------++-- Creates an annotation out of a block list, by just picking the first chord+-- This annotator does smart grouping+headAnnotator :: Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation+headAnnotator _keyAnn (AudioFeat _idStr chrm beat _key ) = -- ignore key info+ let endTime = time $ last chrm+ bts = takeWhile (< endTime) beat ++ [endTime]+ in map headChrd . mergeAndTimeStamp avgPC bts . groupPChord . createChordRanks + $ beatSync bts chrm where + headChrd :: TimedData [ProbChord] -> TimedData ChordLabel+ headChrd td = td {getData = chordLab . head $ getData td}++-- The most simple annotator, no grouping, no matching, +-- just pick the best matching chord+simpleAnnotator :: Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation+simpleAnnotator _keyAnn (AudioFeat _idStr chrm beat _key ) = -- ignore key+ addTimeInfo beat . map (chordLab . head) . createChordRanks+ $ beatSync beat chrm+
+ src/HarmTrace/Audio/Key.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}++module HarmTrace.Audio.Key where++import HarmTrace.Audio.ChordTypes+import HarmTrace.Audio.Utils+import HarmTrace.Audio.BeatChroma ( beatSyncKeyStrenth, keyMap)+import HarmTrace.Base.MusicRep++import Prelude as P hiding ( map, length, head, last, mapM, mapM_, max+ , maximum, reverse, tail, null, concatMap )++-- N.B. Vector inside this module refers to a different type than Vector+-- in the HarmTrace.Audio.BeatChroma module+import Data.Vector as V +import qualified Data.List as L++import Data.Ord (comparing)+import Text.Printf (printf)++--------------------------------------------------------------------------------+-- Chroma key estimation+--------------------------------------------------------------------------------+modulPenalty :: NumData+modulPenalty = 1.0++getBeatSyncKeyFromChroma :: [NumData] -> [ChordinoLine] -> [[Key]]+getBeatSyncKeyFromChroma bts key = + groupKeys . getKeyFromTable $ selectKey bts key++selectKey :: [NumData] -> [ChordinoLine] -> Vector (Vector (Int, NumData))+selectKey _bts [] = empty +selectKey [] _key = empty+selectKey bts key = k where+ -- start by calculating the beat synchronised key strenght for all + -- 24 keys (ordered by HarmTrace.Audio.BeatChroma.keyMap)+ m :: Vector (Vector NumData)+ m = fromList . L.map fromList $ beatSyncKeyStrenth bts key+ + -- calculate for every beat the maximum key (the index) and the + -- profile correlation (snd)+ maxima :: Vector (Int, NumData)+ {-# INLINE maxima #-}+ maxima = map (\x -> (maxIndex x, maximum x)) m+ + -- we fill a beat x 24 table and store the cumulative key strength.+ -- we can chose to stay in the current key or we can modulate which is+ -- penalised by modulPenalty, we also store the index so we can follow+ -- the path back to the first beat+ fill :: Int -> Int -> (Int, NumData)+ {-# INLINE fill #-}+ fill 0 j = (j, (m!0)!j)+ fill i j = let (mj, mv) = maxima!i -- current max+ noModul = (j , (snd ((k!(i-1))!j)) + ((m!i)!j))+ modul = (mj, (snd ((k!(i-1))!j)) + mv - modulPenalty)+ in max2 modul noModul ++ k = generate (length m) (generate 24 . fill)++max2 :: (Int, NumData) -> (Int, NumData) -> (Int, NumData)+{-# INLINE max2 #-}+max2 t1@(_, s1) t2@(_, s2) = if s1 > s2 then t1 else t2++getKeyFromTable :: Vector (Vector (Int, NumData)) -> [Key]+getKeyFromTable k = L.map ((!!) keyMap) (L.reverse yek) where+ yek = collectMax (fst $ maximumBy (comparing snd) (last k)) (reverse k)+ -- given the table calulated with selectKey, this function calculates + -- the actual key assignment for every beat+ collectMax :: Int -> Vector (Vector (Int, NumData)) -> [Int]+ collectMax startj l + | null l = []+ | otherwise = fst ((head l) ! startj) : collectMax m (tail l) where+ m = fst $ maximumBy (comparing snd) (head l)++printKeyTable :: [NumData] -> [ChordinoLine] -> IO ()+printKeyTable bts chrm = + let showLn :: Vector (Int, NumData) -> IO ()+ showLn x = do mapM_ (\(i,f) -> putStr (printf "(%d, %.2f)" i f)) x+ putStr "\n"+ in mapM_ showLn $ selectKey bts chrm ++naiveBeatSyncKey :: BeatTrackerData -> [ChordinoLine] -> [Key]+naiveBeatSyncKey bts key = + L.map (((!!) keyMap) . maxListIndex) $ beatSyncKeyStrenth bts key++--------------------------------------------------------------------------------+-- key strengthpParsing+--------------------------------------------------------------------------------++groupKeys :: [Key] -> [[Key]]+groupKeys ks = L.group . L.concat $ groupMinSize 16 (getGlobalKey ks) ks ++getGlobalKey :: [Key] -> Key+getGlobalKey = mode
+ src/HarmTrace/Audio/Parser.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}++module HarmTrace.Audio.Parser where++import HarmTrace.Audio.ChordTypes+import HarmTrace.Base.Parsing hiding (pComma,pQuotedString,pParentheticalString)++--------------------------------------------------------------------------------+-- data parsers+--------------------------------------------------------------------------------++-- Beat Parsing +parseBeatData :: Parser BeatTrackerData+parseBeatData = pListSep_ng pLineEnd pLine <* pLineEnd where+ pLine = opt pLabel "" *> pNumData <* opt (pComma *> pQuotedString) ""++-- Chroma parsing +parseChordinoData :: Parser ChordinoData+parseChordinoData = pListSep_ng pLineEnd pChordinoLine <* pLineEnd where+ pChordinoLine = const convert <$> opt pLabel ""+ <*> pList1Sep (pSym ',') pNumData + convert :: [NumData] -> ChordinoLine -- shift the chorma to match C .. B+ convert l | length l == 25 = ChordinoLine h (shift 3 a) (shift 3 b)+ | otherwise = error ("Wrong list length of " ++ show (length l))+ where (h:t) = l+ (a,b) = splitAt 12 t++-- rotates the elements in the list with n positions+shift :: Int -> [a] -> [a]+shift p l = b ++ a where (a,b) = splitAt p l ++reverseShift :: Int -> [a] -> [a]+reverseShift p l = b ++ a where (a,b) = splitAt ((length l) - p) l ++-- key parsing+parseKeyStrengthData :: Parser KeyStrengthData +parseKeyStrengthData = pListSep_ng pLineEnd pKeyLine <* pLineEnd where+ pKeyLine = convert <$> pList1Sep (pSym ',') pNumData + convert :: [NumData] -> ChordinoLine+ convert l | length l == 26 = ChordinoLine h a (tail b)+ | otherwise = error ("Wrong list length of " ++ show (length l))+ where (h:t) = l+ (a,b) = splitAt 12 t ++-- key 12 dim vector chroms+parseChromaData :: Parser [ChordinoLine]+parseChromaData = pListSep_ng pLineEnd pCrmLine <* pLineEnd where+ pCrmLine = convert <$> pList1Sep (pSym ',') pNumData + -- This is a bit of a hack, but I do not want to rewrite all the functions + -- again for a very similar data type that only has one 12-dim chroma vector+ convert :: [NumData] -> ChordinoLine + convert l | length t == 12 = ChordinoLine h (shift 3 t) [] -- hence we make this []+ | otherwise = error ("Wrong list length of " ++ show (length l))+ where (h:t) = l+ + +--------------------------------------------------------------------------------+-- Basic parsers+--------------------------------------------------------------------------------+ +pNumData :: Parser NumData+pNumData = pDoubleRaw++pComma :: Parser Char+pComma = pSym ','++pParentheticalString :: Char -> Parser String+pParentheticalString d = pSym d *> pList pNonQuoteVChar <* pSym d where+ pNonQuoteVChar = pSatisfy (\c -> visibleChar c && c /= d) + (Insertion ("Character in a string set off from main text" +++ "by delimiter, e.g. double-quotes or comment token") 'y' 5)+ visibleChar c = '\032' <= c && c <= '\126'++pQuotedString :: Parser String+pQuotedString = pParentheticalString '"'++pLabel :: Parser String+pLabel = (pQuotedString `opt` "") <* pComma
+ src/HarmTrace/Audio/Utils.hs view
@@ -0,0 +1,121 @@+module HarmTrace.Audio.Utils where++import HarmTrace.Audio.ChordTypes++import Data.List (genericLength, transpose, tails, inits,maximumBy, sort, group)+import Data.Ord (comparing)++--------------------------------------------------------------------------------+-- Some utility functions used by other functions throughout the Audio module+--------------------------------------------------------------------------------++-- returns the last timestamp+-- getLastFrameTimeStamp :: [ChordinoLine] -> NumData+-- getLastFrameTimeStamp = time . last++-- given a list of beats, a list of grouped data items, and a merging function+-- mergeAndTimeStamp returns a list of TimedData items of which these+-- data items are grouped with the provided merging function+mergeAndTimeStamp ::([a] -> a)-> [NumData] -> [[a]] -> [TimedData a]+mergeAndTimeStamp f = mergeAndTimeStamp' f 0+mergeAndTimeStamp' ::([a] -> a)-> NumData -> [NumData] -> [[a]] -> [TimedData a]+mergeAndTimeStamp' _ _ [] [] = []+mergeAndTimeStamp' mergef ons beats (x : xs) = + let (offs : rest) = drop ((length x) -1) beats+ in TimedData (mergef x) ons offs : mergeAndTimeStamp' mergef offs rest xs+mergeAndTimeStamp' _ _ _ _ = + error "mergeAndTimeStamp: asynchronous beats and data"+ +-- a function for merging identical lists of ProbChords. Equallity of the chords+-- in the lists is assumed and the probabilities are averaged+avgPC :: [[ProbChord]] -> [ProbChord]+avgPC [[a]] = [a]+avgPC pcs = let cs = map chordLab $ head pcs + ps = map listMean . transpose $ map (map prob) pcs+ in zipWith ProbChord cs ps ++-- similarly to group, but in case a group is smaller than s the group is filled+-- with the same number of a's+-- ?> groupMinSize 3 0 [1,2,2,3,3,3,4,4,4,4,5,5,5,5,5]+-- [[0],[0,0],[0,0,0],[4,4,4,4],[5,5,5,5,5]]+groupMinSize :: Eq a => Int -> a -> [a] -> [[a]]+groupMinSize _ _ [] = []+groupMinSize s a (x:xs) = grp : groupMinSize s a zs+ where (ys,zs) = span (== x) xs+ lys = length ys+ grp = if length ys >= s then x:ys else replicate (lys + 1) a+ +-- samples at specific points in time, specified in a list+sampleAt :: [NumData] -> [TimedData a] -> [a]+sampleAt _ [] = []+sampleAt [] a = map getData a -- will never occur, return without sampling+sampleAt (t:ts) (c:cs)+ | t <= offset c = getData c : sampleAt ts (c:cs)+ | otherwise = sampleAt (t:ts) cs ++--------------------------------------------------------------------------------+-- Statistical functions+--------------------------------------------------------------------------------+ +listMean :: [NumData] -> NumData+listMean a = sum a / genericLength a+ +-- a median filter: see http://en.wikipedia.org/wiki/Median_filter+medianFilter :: Ord a => Int -> [a] -> [a]+medianFilter wsize l = map mode $ getWindows wsize l+ +-- returns a list with all "sliding windows" of size wsize +-- the left and right edge of the list are with the first and last (size /2)+-- items, respectively and the remainder is filled with the mode/median of+-- the complete list+getWindows :: Ord a => Int -> [a] -> [[a]]+getWindows size l = lbor ++ mid ++ rbor+ where mid = takeWhile (hasSize size) . map (take size) $ tails l+ gmed = mode l+ ls = size `div` 2+ rs = size - ls - 1+ lbor = reverse $ map (fillWith size gmed) + (reverse . dropWhile (null) . inits $ take ls l)+ rbor = map (reverse . fillWith size gmed) + (takeWhile (not . null) . tails . take rs $ reverse l)+ -- in general (length l) < x, but this is guaranteed within this let+ fillWith :: Int -> a -> [a] -> [a]+ fillWith x a lt = replicate (x - (length l)) a ++ lt++hasSize :: Int -> [a] -> Bool+hasSize s l = length l >= s+ +-- the mode: the element that occurs most often in the collection +mode :: Ord a => [a] -> a+mode [] = error "Key.hs: mode called on []"+mode l = head . maximumBy (comparing length) . group $ sort l + +-- the median: not good for keys... +median :: Ord a => [a] -> a+median [] = error "Key.hs: median called on []"+median l = sort l !! (length l `div` 2) ++maxListIndex :: Ord a => [a] -> Int+maxListIndex = fst . maxPair where+ maxPair :: Ord a => [a] -> (Int,a)+ maxPair = maximumBy (comparing snd) . zip [0..] ++--------------------------------------------------------------------------------+-- Making beat synchronized chroma+--------------------------------------------------------------------------------+mergeBeats :: Int -> [[a]] -> [[a]]+mergeBeats _ [] = []+mergeBeats n l = let (a,b) = splitAt n l in concat a : mergeBeats n b++-- synchronizes the ChordinoData to the list of beats in the BeatTrackerData+-- by grouping the ChordinoLines of the ChordinoData in separate lists+beatSync :: BeatTrackerData -> ChordinoData -> BeatChroma+beatSync _ [] = []+beatSync bt (cd:cs) = beatSync' bt [cd] (cd:cs) where+ beatSync' :: [NumData] -> [ChordinoLine] -> [ChordinoLine] -> [[ChordinoLine]]+ beatSync' _ _ [] = []+ beatSync' [] _ c = [c]+ beatSync' (b:bs) prv c -- we also store the previous group in case beat < time+ | null x = prv : beatSync' bs prv xs + | otherwise = x : beatSync' bs x xs + where (x, xs) = span ((>=) b . time) c
src/HarmTrace/Base/MusicRep.hs view
@@ -1,234 +1,268 @@-{-# 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: " ++ show sh) --------------------------------------------------------------------------------- --- Value Level Scale Degree Transposition --------------------------------------------------------------------------------- - -isNoneChord :: ChordLabel -> Bool -isNoneChord (Chord (Note _ N) _ _ _ _) = True -isNoneChord (Chord _ None _ _ _) = True -isNoneChord _ = False - --- Chord root shorthand degrees location duration -toChordDegree :: Key -> ChordLabel -> ChordDegree -toChordDegree k (Chord r sh degs loc d) = - Chord (toScaleDegree k r) sh degs loc d - -toScaleDegree :: Key -> Root -> ScaleDegree -toScaleDegree _ n@(Note _ N) = - error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose" ++ show n) -toScaleDegree (Key kr _) cr = -- Note Nothing I - scaleDegrees!!(((diaNatToSemi cr) - (diaNatToSemi kr)) `mod` 12) - --- transposes a degree with sem semitones up -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 +{-# 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 { keyRoot :: Root, keyMode :: Mode } deriving (Eq, Ord)+data Mode = MajMode | MinMode deriving (Eq, Ord)++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 | NoClass+ 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 | Sus2+ -- 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, Ord) + +data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat+ deriving (Eq, Ord)++--------------------------------------------------------------------------------+-- Instances for the general music datatypes+-------------------------------------------------------------------------------- ++instance Show Key where+ show (Key r m) = show r ++ show m+ +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"+ show NoClass = "N"++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 +--------------------------------------------------------------------------------++isNone :: Root -> Bool+isNone (Note _ N) = True+isNone _ = False++noneLabel :: ChordLabel+noneLabel = (Chord (Note Nothing N) None [] 0 0)++isNoneChord :: ChordLabel -> Bool+isNoneChord (Chord (Note _ N) _ _ _ _) = True+isNoneChord (Chord _ None _ _ _) = True+isNoneChord _ = False++toClassType :: Shorthand -> ClassType+toClassType sh + | sh `elem` [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4,Sus2] = MajClass+ | sh `elem` [Min,Min7,Min6,Min9,HDim7] = MinClass+ | sh `elem` [Sev,Nin,Aug] = DomClass+ | sh `elem` [Dim,Dim7] = DimClass + | otherwise = error ("toClassType: unknown shorthand: " ++ show sh) ++toMode :: Shorthand -> Mode +toMode Maj = MajMode+toMode Min = MinMode+toMode Dim = MinMode+toMode Aug = MajMode+toMode Maj7 = MajMode+toMode Min7 = MinMode+toMode Sev = MajMode+toMode Dim7 = MinMode+toMode HDim7 = MinMode+toMode MinMaj7 = MinMode+toMode Maj6 = MajMode +toMode Min6 = MinMode+toMode Nin = MajMode+toMode Maj9 = MajMode+toMode Min9 = MinMode+toMode Sus4 = MinMode -- for now+toMode _ = MinMode -- should not happen+ +--------------------------------------------------------------------------------+-- Value Level Scale Degree Transposition+-------------------------------------------------------------------------------- + +-- Chord root shorthand degrees location duration+toChordDegree :: Key -> ChordLabel -> ChordDegree+toChordDegree k (Chord r sh degs loc d) = + Chord (toScaleDegree k r) sh degs loc d + +toScaleDegree :: Key -> Root -> ScaleDegree+toScaleDegree _ n@(Note _ N) = + error ("HarmTrace.Base.MusicRep.toScaleDegree: cannot transpose" ++ show n)+toScaleDegree (Key kr _) cr = -- Note Nothing I+ scaleDegrees!!(((diaNatToSemi cr) - (diaNatToSemi kr)) `mod` 12)++-- transposes a degree with sem semitones up+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 n@(Note _ Imp) = + error ("HarmTrace.Base.MusicRep.diaDegToSemi: no semitone for" ++ show n)+diaDegToSemi (Note m deg) = + ([0,2,4,5,7,9,11] !! (fromJust $ elemIndex deg [minBound..])) + (modToSemi m) + +diaNatToSemi :: Root -> Int+diaNatToSemi n@(Note _ N ) = + error ("HarmTrace.Base.MusicRep.diaDegToSemi: no semitone for" ++ show n)+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
@@ -1,41 +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 +{-# 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
@@ -1,81 +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 --} +{-# 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/Binary.hs view
@@ -1,59 +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 +{-# 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
@@ -1,244 +1,244 @@-{-# 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 - | HAnPrep !Prep - | HAnTrans !Trans - | HAnChord !ChordToken - - -- duration Mode constructor_ix specials -data HFunc = Ton !Int !Mode !Int !(Maybe Spec) - | Dom !Int !Mode !Int !(Maybe Spec) - | Sub !Int !Mode !Int !(Maybe Spec) - | P - | PD - | PT - -data Spec = Blues | MinBorrow | Parallel - deriving Eq - --- Preparations, like secondary dominants etc. that cause a "split" in the tree -data Prep = SecDom !Int !ScaleDegree -- "V/X" - | SecMin !Int !ScaleDegree -- "v/X" - | DiatDom !Int !ScaleDegree -- "Vd" - | NoPrep - --- Scalde degree transformations, e.g. tritone substitutions etc. -data Trans = Trit !Int !ScaleDegree -- "bII/X" - | DimTrit !Int !ScaleDegree -- "bIIb9/X" - | DimTrans !Int !ScaleDegree -- "VII0" - | NoTrans - --------------------------------------------------------------------------------- --- Binary instances --------------------------------------------------------------------------------- - -deriveAllL [ ''HAn, ''Trans, ''Prep, ''HFunc, ''Spec] - -instance Binary HAn where - put = putDefault - get = getDefault -instance Binary Trans where - put = putDefault - get = getDefault -instance Binary Prep 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 (HAnPrep 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 Prep where - rnf (SecDom i d) = rnf i `seq` d `seq` () - rnf (SecMin i d) = rnf i `seq` d `seq` () - rnf (DiatDom i d) = rnf i `seq` d `seq` () - rnf NoPrep = () - -instance NFData Trans where - rnf (Trit i d) = rnf i `seq` d `seq` () - rnf (DimTrit i d) = rnf i `seq` d `seq` () - rnf (DimTrans i d) = rnf i `seq` d `seq` () - rnf NoTrans = () - -instance NFData Spec where - rnf Blues = () - rnf MinBorrow = () - rnf Parallel = () - --------------------------------------------------------------------------------- --- Durations set and get instances --------------------------------------------------------------------------------- - --- 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 (HAnPrep 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 _ = 0 - -instance GetDur Prep where - getDur (SecDom i _) = i - getDur (SecMin i _) = i - getDur (DiatDom i _) = i - getDur NoPrep = 0 - -instance GetDur Trans where - getDur (Trit i _) = i - getDur (DimTrit i _) = i - getDur (DimTrans i _) = i - getDur NoTrans = 0 - -instance GetDur (Chord a) where - getDur = duration - -class SetDur a where - setDur :: a -> Int -> a - -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 Prep where - setDur (SecDom _d sd) d = (SecDom d sd) - setDur (SecMin _d sd) d = (SecMin d sd) - setDur (DiatDom _d sd) d = (DiatDom d sd) - setDur NoPrep _ = NoPrep - -instance SetDur Trans where - setDur (Trit _d sd) d = (Trit d sd) - setDur (DimTrit _d sd) d = (DimTrit d sd) - setDur (DimTrans _d sd) d = (DimTrans d sd) - setDur NoTrans _ = NoTrans - --------------------------------------------------------------------------------- --- Eq instances --------------------------------------------------------------------------------- - -instance Eq HAn where - (HAn _ s) == (HAn _ s2) = s == s2 - (HAnChord chord) == (HAnChord chord2) = chord == chord2 - (HAnFunc hfunk) == (HAnFunc hfunk2) = hfunk == hfunk2 - (HAnTrans trans) == (HAnTrans trans2) = trans == trans2 - _ == _ = False - -instance Eq HFunc where - -- ignore duration for now - (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2 - (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2 - (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2 - P == P = True - PD == PD = True - PT == PT = True - _ == _ = False - -instance Eq Prep where - (SecDom _dur sd) == (SecDom _dur2 sd2) = sd == sd2 - (SecMin _dur sd) == (SecMin _dur2 sd2) = sd == sd2 - (DiatDom _dur sd) == (DiatDom _dur2 sd2) = sd == sd2 - NoPrep == NoPrep = True - _ == _ = False - -instance Eq Trans where - (Trit _dur sd) == (Trit _dur2 sd2) = sd == sd2 - (DimTrit _dur sd) == (DimTrit _dur2 sd2) = sd == sd2 - (DimTrans _dur sd) == (DimTrans _dur2 sd2) = sd == sd2 - NoTrans == NoTrans = True - _ == _ = False - --------------------------------------------------------------------------------- --- Eq and Show instances --------------------------------------------------------------------------------- - -instance Show Prep where - show (SecDom l d) = "V/" ++ show d ++ '_' : show l - show (SecMin l d) = "v/" ++ show d ++ '_' : show l - show (DiatDom l d) = "Vd/"++ show d ++ '_' : show l - show NoPrep = "np" - -instance Show Trans where - show (Trit l d) = "IIb/" ++ show d ++ '_' : show l - show (DimTrit l d) = "IIb9b/" ++ show d ++ '_' : show l - show (DimTrans l d) = show d ++ "0" ++ '_' : show l - show (NoTrans) = "nt" - -instance Show HAn where - show (HAn l con) = con ++ "_s" ++ '_' : show l - show (HAnChord chord) = show chord - show (HAnFunc hfunk) = show hfunk - show (HAnTrans trans) = show trans - show (HAnPrep prep ) = show prep - -instance Show HFunc where - show (Ton l mode i s) = "T" ++ show mode ++ '_' : show i - ++ maybe "" show s ++ '_' : show l - show (Dom l mode i s) = "D" ++ show mode ++ '_' : show i - ++ maybe "" show s ++ '_' : show l - show (Sub l mode i s) = "S" ++ show mode ++ '_' : show i - ++ maybe "" show s ++ '_' : show l - show (P ) = "Piece" - show (PT) = "PT" - show (PD) = "PD" - -instance Show Spec where - show Blues = "bls" - show MinBorrow = "bor" +{-# 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+ | HAnPrep !Prep+ | HAnTrans !Trans + | HAnChord !ChordToken + + -- duration Mode constructor_ix specials+data HFunc = Ton !Int !Mode !Int !(Maybe Spec)+ | Dom !Int !Mode !Int !(Maybe Spec) + | Sub !Int !Mode !Int !(Maybe Spec) + | P + | PD+ | PT + +data Spec = Blues | MinBorrow | Parallel + deriving Eq ++-- Preparations, like secondary dominants etc. that cause a "split" in the tree +data Prep = SecDom !Int !ScaleDegree -- "V/X"+ | SecMin !Int !ScaleDegree -- "v/X" + | DiatDom !Int !ScaleDegree -- "Vd"+ | NoPrep++-- Scalde degree transformations, e.g. tritone substitutions etc.+data Trans = Trit !Int !ScaleDegree -- "bII/X" + | DimTrit !Int !ScaleDegree -- "bIIb9/X" + | DimTrans !Int !ScaleDegree -- "VII0" + | NoTrans++--------------------------------------------------------------------------------+-- Binary instances+--------------------------------------------------------------------------------++deriveAllL [ ''HAn, ''Trans, ''Prep, ''HFunc, ''Spec]++instance Binary HAn where+ put = putDefault+ get = getDefault+instance Binary Trans where+ put = putDefault+ get = getDefault+instance Binary Prep 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 (HAnPrep 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 Prep where+ rnf (SecDom i d) = rnf i `seq` d `seq` ()+ rnf (SecMin i d) = rnf i `seq` d `seq` ()+ rnf (DiatDom i d) = rnf i `seq` d `seq` ()+ rnf NoPrep = ()+ +instance NFData Trans where + rnf (Trit i d) = rnf i `seq` d `seq` ()+ rnf (DimTrit i d) = rnf i `seq` d `seq` ()+ rnf (DimTrans i d) = rnf i `seq` d `seq` ()+ rnf NoTrans = ()+ +instance NFData Spec where+ rnf Blues = ()+ rnf MinBorrow = ()+ rnf Parallel = ()+ +--------------------------------------------------------------------------------+-- Durations set and get instances+-------------------------------------------------------------------------------- ++-- 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 (HAnPrep 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 _ = 0+ +instance GetDur Prep where+ getDur (SecDom i _) = i+ getDur (SecMin i _) = i+ getDur (DiatDom i _) = i+ getDur NoPrep = 0++instance GetDur Trans where + getDur (Trit i _) = i+ getDur (DimTrit i _) = i+ getDur (DimTrans i _) = i+ getDur NoTrans = 0++instance GetDur (Chord a) where+ getDur = duration+ +class SetDur a where + setDur :: a -> Int -> a+ +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 Prep where+ setDur (SecDom _d sd) d = (SecDom d sd)+ setDur (SecMin _d sd) d = (SecMin d sd)+ setDur (DiatDom _d sd) d = (DiatDom d sd)+ setDur NoPrep _ = NoPrep+ +instance SetDur Trans where + setDur (Trit _d sd) d = (Trit d sd)+ setDur (DimTrit _d sd) d = (DimTrit d sd)+ setDur (DimTrans _d sd) d = (DimTrans d sd)+ setDur NoTrans _ = NoTrans+ +--------------------------------------------------------------------------------+-- Eq instances+-------------------------------------------------------------------------------- + +instance Eq HAn where + (HAn _ s) == (HAn _ s2) = s == s2+ (HAnChord chord) == (HAnChord chord2) = chord == chord2+ (HAnFunc hfunk) == (HAnFunc hfunk2) = hfunk == hfunk2+ (HAnTrans trans) == (HAnTrans trans2) = trans == trans2+ _ == _ = False+ +instance Eq HFunc where+ -- ignore duration for now+ (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2 + (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2+ (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2+ P == P = True + PD == PD = True + PT == PT = True + _ == _ = False + +instance Eq Prep where+ (SecDom _dur sd) == (SecDom _dur2 sd2) = sd == sd2 + (SecMin _dur sd) == (SecMin _dur2 sd2) = sd == sd2 + (DiatDom _dur sd) == (DiatDom _dur2 sd2) = sd == sd2 + NoPrep == NoPrep = True+ _ == _ = False+ +instance Eq Trans where + (Trit _dur sd) == (Trit _dur2 sd2) = sd == sd2 + (DimTrit _dur sd) == (DimTrit _dur2 sd2) = sd == sd2 + (DimTrans _dur sd) == (DimTrans _dur2 sd2) = sd == sd2 + NoTrans == NoTrans = True+ _ == _ = False ++--------------------------------------------------------------------------------+-- Eq and Show instances+--------------------------------------------------------------------------------+ +instance Show Prep where+ show (SecDom l d) = "V/" ++ show d ++ '_' : show l+ show (SecMin l d) = "v/" ++ show d ++ '_' : show l+ show (DiatDom l d) = "Vd/"++ show d ++ '_' : show l + show NoPrep = "np"++instance Show Trans where + show (Trit l d) = "IIb/" ++ show d ++ '_' : show l+ show (DimTrit l d) = "IIb9b/" ++ show d ++ '_' : show l+ show (DimTrans l d) = show d ++ "0" ++ '_' : show l+ show (NoTrans) = "nt"++instance Show HAn where + show (HAn l con) = con ++ "_s" ++ '_' : show l+ show (HAnChord chord) = show chord + show (HAnFunc hfunk) = show hfunk + show (HAnTrans trans) = show trans + show (HAnPrep prep ) = show prep+ +instance Show HFunc where+ show (Ton l mode i s) = "T" ++ show mode ++ '_' : show i + ++ maybe "" show s ++ '_' : show l+ show (Dom l mode i s) = "D" ++ show mode ++ '_' : show i + ++ maybe "" show s ++ '_' : show l+ show (Sub l mode i s) = "S" ++ show mode ++ '_' : show i + ++ maybe "" show s ++ '_' : show l+ show (P ) = "Piece"+ show (PT) = "PT"+ show (PD) = "PD" ++instance Show Spec where+ show Blues = "bls" + show MinBorrow = "bor" show Parallel = "par"
src/HarmTrace/HAnTree/HAnParser.hs view
@@ -1,43 +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 +{-# 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/PostProcess.hs view
@@ -1,109 +1,109 @@-module HarmTrace.HAnTree.PostProcess ( PPOption(..) - , expandChordDurations - , removePDPT, removeInsertions - , mergeDelChords ) where - -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.HAnTree.HAn -import HarmTrace.HAnTree.Tree - -import Data.List(partition, find) -import Data.Maybe (isJust, fromJust) --- import Debug.Trace - --- Parser stuff -import Text.ParserCombinators.UU.BasicInstances as PC - - --- Optional post-processing operations -data PPOption = RemoveInsertions | RemovePDPT - | MergeDelChords | ExpandChordDurations -- | ... ? - deriving (Eq) - --- propagates the durations of the chords up into the tree -expandChordDurations :: Tree HAn -> Tree HAn -expandChordDurations (Node h [] a) = (Node h [] a) where -expandChordDurations (Node h cs a) = (Node (setDur h d) cs' a) where - cs' = map expandChordDurations cs - d = sum $ map (getDur . getLabel) cs' - --- removes some nodes from the tree structure that are not important for --- similarity estimation -removePDPT :: Tree HAn -> Tree HAn -removePDPT = removeBy (\l -> l `elem` [(HAnFunc PD), (HAnFunc PT)]) - --- Removes the HAn Nodes that were inserted by the parsing process -removeInsertions :: Tree HAn -> Tree HAn -removeInsertions = head . fst . remIns - -remIns :: Tree HAn -> ([Tree HAn], Bool) -remIns l@(Node han [ ] _ ) = if isInserted han then ([],True) else ([l],False) -remIns (Node han cn pn) = ([Node han (concat trees) pn], False) where - (trees,_ ) = unzip . filter (not . snd) $ map remIns cn - --- returns True if a HAn is Inserted -isInserted :: HAn -> Bool -isInserted (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) = True -isInserted _ = False - --------------------------------------------------------------------------------- --- PostProcessing a Tree HAn with the chords deleted by the parser --------------------------------------------------------------------------------- - --- top level function for merging deleted chords --- TODO: could be made to work on [ChordToken] instead of [ChordLabel] -mergeDelChords :: Key -> [Error Int] -> [ChordLabel] -> Tree HAn -> Tree HAn -mergeDelChords key pErr tok tree = - head $ mergeDelChords' key (groupNeighbours (filterErrorPos pErr tok)) [tree] - --- N.B. there is a bug in this function: if the first chords is deleted --- it is not placed back because there is no chord in the tree before --- the deleted chord. - --- merges the deleted chords back into the parsed Tree HAn -mergeDelChords' :: Key -> [[ChordLabel]] -> [Tree HAn] -> [Tree HAn] -mergeDelChords' _key [] tree = tree -mergeDelChords' _key _ [] = [] -mergeDelChords' key d (i@(Node (HAnChord c) _ _):ts) - | status c == CT.Inserted = i : mergeDelChords' key d ts - | isJust m = i : (toDelHAn key $ fromJust m) ++ mergeDelChords' key d ts - | otherwise = i : mergeDelChords' key d ts - where m = find (\x -> (getLoc . last $ chords c) + 1 == (getLoc $ head x)) d -mergeDelChords' key chrds (Node han cs pn : ts) = - Node han (mergeDelChords' key chrds cs) pn : mergeDelChords' key chrds ts - --- transforms a (deleted) chord into a Tree HAn data type -toDelHAn :: Key -> [ChordLabel] -> [Tree HAn] -toDelHAn key m = map f m where - f c@(Chord r sh _add _loc d) = (Node (HAnChord - (ChordToken (toScaleDegree key r) (toClassType sh) [c] CT.Deleted 1 d)) - [] Nothing) - --- returns the deleted chords, given a list of errors and the input tokes -filterErrorPos :: [Error Int] -> [Chord a] -> [Chord a] -filterErrorPos e c = filter (\x -> getLoc x `elem` dels) chrds ++ cDelsAtEnd - where - (delsAtEnd, dels) = partition (== (-1)) . map gPos $ filter f e - (chrds,cDelsAtEnd) = splitAt (length c - length delsAtEnd) c - gPos (PC.Inserted _ p _) = p - gPos (PC.Deleted _ p _) = p - gPos (DeletedAtEnd _) = (-1) - gPos (Replaced _ _ p _) = p - f (PC.Inserted _ _ _) = False - f (PC.Deleted _ _ _) = True - f (DeletedAtEnd _) = True - f (Replaced _ _ _ _) = False - --- groups the deleted chord tokens that are neighbours, if we were not --- grouping chords but Integers, a result could look like: --- groupNeighbours [1,2,7,8,9,11,13,16,17] = [[1,2],[7,8,9],[11],[13],[16,17]] -groupNeighbours :: [Chord a] -> [[Chord a]] -groupNeighbours [] = [] -groupNeighbours (x:xs) = let (grp,tl) = get x xs in grp : groupNeighbours tl --- splits a list into a list with neighbours and a tail -get :: Chord a -> [Chord a] -> ([Chord a],[Chord a]) -get a l@[] = ([a],l) -get a l@(b:cs) - | (getLoc a) + 1 == getLoc b = (a:bs,cs') +module HarmTrace.HAnTree.PostProcess ( PPOption(..)+ , expandChordDurations+ , removePDPT, removeInsertions+ , mergeDelChords ) where++import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens as CT+import HarmTrace.HAnTree.HAn+import HarmTrace.HAnTree.Tree++import Data.List(partition, find)+import Data.Maybe (isJust, fromJust)+-- import Debug.Trace++-- Parser stuff+import Text.ParserCombinators.UU.BasicInstances as PC+++-- Optional post-processing operations +data PPOption = RemoveInsertions | RemovePDPT + | MergeDelChords | ExpandChordDurations -- | ... ?+ deriving (Eq)++-- propagates the durations of the chords up into the tree+expandChordDurations :: Tree HAn -> Tree HAn+expandChordDurations (Node h [] a) = (Node h [] a) where+expandChordDurations (Node h cs a) = (Node (setDur h d) cs' a) where+ cs' = map expandChordDurations cs+ d = sum $ map (getDur . getLabel) cs'++-- removes some nodes from the tree structure that are not important for+-- similarity estimation+removePDPT :: Tree HAn -> Tree HAn+removePDPT = removeBy (\l -> l `elem` [(HAnFunc PD), (HAnFunc PT)])++-- Removes the HAn Nodes that were inserted by the parsing process+removeInsertions :: Tree HAn -> Tree HAn+removeInsertions = head . fst . remIns++remIns :: Tree HAn -> ([Tree HAn], Bool)+remIns l@(Node han [ ] _ ) = if isInserted han then ([],True) else ([l],False)+remIns (Node han cn pn) = ([Node han (concat trees) pn], False) where+ (trees,_ ) = unzip . filter (not . snd) $ map remIns cn+ +-- returns True if a HAn is Inserted+isInserted :: HAn -> Bool+isInserted (HAnChord (ChordToken _ _ _ CT.Inserted _ _)) = True+isInserted _ = False++--------------------------------------------------------------------------------+-- PostProcessing a Tree HAn with the chords deleted by the parser+--------------------------------------------------------------------------------++-- top level function for merging deleted chords+-- TODO: could be made to work on [ChordToken] instead of [ChordLabel]+mergeDelChords :: Key -> [Error Int] -> [ChordLabel] -> Tree HAn -> Tree HAn+mergeDelChords key pErr tok tree = + head $ mergeDelChords' key (groupNeighbours (filterErrorPos pErr tok)) [tree] + +-- N.B. there is a bug in this function: if the first chords is deleted +-- it is not placed back because there is no chord in the tree before+-- the deleted chord.++-- merges the deleted chords back into the parsed Tree HAn+mergeDelChords' :: Key -> [[ChordLabel]] -> [Tree HAn] -> [Tree HAn]+mergeDelChords' _key [] tree = tree+mergeDelChords' _key _ [] = []+mergeDelChords' key d (i@(Node (HAnChord c) _ _):ts)+ | status c == CT.Inserted = i : mergeDelChords' key d ts+ | isJust m = i : (toDelHAn key $ fromJust m) ++ mergeDelChords' key d ts+ | otherwise = i : mergeDelChords' key d ts+ where m = find (\x -> (getLoc . last $ chords c) + 1 == (getLoc $ head x)) d+mergeDelChords' key chrds (Node han cs pn : ts) =+ Node han (mergeDelChords' key chrds cs) pn : mergeDelChords' key chrds ts++-- transforms a (deleted) chord into a Tree HAn data type+toDelHAn :: Key -> [ChordLabel] -> [Tree HAn]+toDelHAn key m = map f m where+ f c@(Chord r sh _add _loc d) = (Node (HAnChord+ (ChordToken (toScaleDegree key r) (toClassType sh) [c] CT.Deleted 1 d))+ [] Nothing)++-- returns the deleted chords, given a list of errors and the input tokes+filterErrorPos :: [Error Int] -> [Chord a] -> [Chord a]+filterErrorPos e c = filter (\x -> getLoc x `elem` dels) chrds ++ cDelsAtEnd+ where+ (delsAtEnd, dels) = partition (== (-1)) . map gPos $ filter f e+ (chrds,cDelsAtEnd) = splitAt (length c - length delsAtEnd) c+ gPos (PC.Inserted _ p _) = p+ gPos (PC.Deleted _ p _) = p+ gPos (DeletedAtEnd _) = (-1)+ gPos (Replaced _ _ p _) = p+ f (PC.Inserted _ _ _) = False+ f (PC.Deleted _ _ _) = True+ f (DeletedAtEnd _) = True+ f (Replaced _ _ _ _) = False++-- groups the deleted chord tokens that are neighbours, if we were not+-- grouping chords but Integers, a result could look like:+-- groupNeighbours [1,2,7,8,9,11,13,16,17] = [[1,2],[7,8,9],[11],[13],[16,17]]+groupNeighbours :: [Chord a] -> [[Chord a]]+groupNeighbours [] = []+groupNeighbours (x:xs) = let (grp,tl) = get x xs in grp : groupNeighbours tl+-- splits a list into a list with neighbours and a tail+get :: Chord a -> [Chord a] -> ([Chord a],[Chord a])+get a l@[] = ([a],l)+get a l@(b:cs)+ | (getLoc a) + 1 == getLoc b = (a:bs,cs') | otherwise = ([a],l) where (bs,cs') = get b cs
src/HarmTrace/HAnTree/ToHAnTree.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.HAnTree.ToHAnTree ( GTree(..) , HAn(..) , gTreeDefault - , gTreeHead , emptyHAnTree ) 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 (Rec a) where - gTree (Rec x) = gTree x - -instance GTree a => GTree (Var a) where - gTree (Var x) = gTree x - - -instance GTree a => GTree [a] where - gTree x = concatMap gTree x - --- Dispatcher -gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn] -gTreeDefault = gTree . from - -gTreeHead :: (GTree a) => a -> Tree HAn -gTreeHead = head . gTree - -emptyHAnTree :: Tree HAn +{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}++module HarmTrace.HAnTree.ToHAnTree ( GTree(..) , HAn(..) , gTreeDefault+ , gTreeHead , emptyHAnTree ) 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 (Rec a) where+ gTree (Rec x) = gTree x+ +instance GTree a => GTree (Var a) where+ gTree (Var x) = gTree x+++instance GTree a => GTree [a] where+ gTree x = concatMap gTree x++-- Dispatcher+gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn]+gTreeDefault = gTree . from++gTreeHead :: (GTree a) => a -> Tree HAn+gTreeHead = head . gTree++emptyHAnTree :: Tree HAn emptyHAnTree = Node (HAn 0 "empty") [] Nothing
src/HarmTrace/HAnTree/Tree.hs view
@@ -1,165 +1,168 @@- -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 t = head (removeBy' f t) -removeBy' :: (t -> Bool) -> Tree t -> [Tree t] -removeBy' f (Node l c pn) - | f l = concatMap (removeBy' f) c - | otherwise = [(Node l (concatMap (removeBy' f) c) pn)] - --- collects all the subtrees of tree in a list in post order. -pot, pot', pret, pret',potPret :: Tree t -> [Tree t] -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 ++module HarmTrace.HAnTree.Tree where++import Data.Maybe+import qualified Data.Binary as B+import Control.Monad.State+import Data.List (maximumBy, genericLength)+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]+{-# INLINE getChildPns #-} +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) / (genericLength dep) where + dep = depth' 1 t++avgDepthF :: [Tree t] -> Float+avgDepthF t = let l = map avgDepth t in sum l / genericLength l ++-- 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 t = head (removeBy' f t)+removeBy' :: (t -> Bool) -> Tree t -> [Tree t]+removeBy' f (Node l c pn) + | f l = concatMap (removeBy' f) c + | otherwise = [(Node l (concatMap (removeBy' f) c) pn)]++-- collects all the subtrees of tree in a list in post order.+pot, pot', pret, pret',potPret :: Tree t -> [Tree t]+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
@@ -1,111 +1,107 @@-{-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} - -module HarmTrace.HarmTrace ( PPOption(..), Grammar(..), GrammarEx(..) - , ParseResult(..) - , string2Piece, postProc ) where - -import HarmTrace.Models.Models -import HarmTrace.Models.Jazz.Main -import HarmTrace.Models.Pop.Main -import HarmTrace.Models.Test.Main -import HarmTrace.HAnTree.ToHAnTree -import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.HAn (HFunc (P)) -import HarmTrace.HAnTree.PostProcess -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Tokenizer.Tokenizer - -import Data.Ord (comparing) -import Data.List (minimumBy) - -#ifdef AUDIO --- Audio/Annotation Stuff -import HarmTrace.Audio.Annotations -import HarmTrace.Audio.ChordTypes - -import HarmTrace.Base.Parsing (parseDataWithErrors) -#endif - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances as PC - --------------------------------------------------------------------------------- --- Plugging everything together --------------------------------------------------------------------------------- - -data ParseResult a = ParseResult { parsedKey :: Key - , parsedChordLabels :: [ChordLabel] - , parsedPiece :: [a] - , pieceTreeHAn :: Tree HAn - , nrAmbTrees :: Int - , tokenizerErrors :: [Error LineColPos ] - , pieceErrors :: [Error Int] - , postProcessing :: [PPOption]} - --- parses s with string2PieceC and merges the deleted chords with the tree --- (Representable a, GTree (Rep a)) -postProc :: (GTree g) => [PPOption] -> ParseResult g -> ParseResult g -postProc opts beforePostProc = beforePostProc { pieceTreeHAn = t } - where - t = selectTree $ map (postProcess fs . gTreeHead) (parsedPiece beforePostProc) - fs = map opt2Func opts - opt2Func :: PPOption -> (Tree HAn -> Tree HAn) - opt2Func RemoveInsertions = removeInsertions - opt2Func RemovePDPT = removePDPT - opt2Func MergeDelChords = mergeDelChords (parsedKey beforePostProc) - (pieceErrors beforePostProc) - (parsedChordLabels beforePostProc) - opt2Func ExpandChordDurations = expandChordDurations - -selectTree :: [Tree HAn] -> Tree HAn -selectTree [] = emptyHAnTree -selectTree ts = minimumBy (comparing getNrFuncNodes) ts - -getNrFuncNodes :: Tree HAn -> Int -getNrFuncNodes (Node (HAnFunc P) nodes _) = length nodes -getNrFuncNodes _ = error "HarmTrace.hs: not a correctly formed HAn Tree" - -postProcess :: [Tree HAn -> Tree HAn] -> Tree HAn -> Tree HAn -postProcess [] tree = tree -postProcess (f:fs) tree = f (postProcess fs tree) - --- Takes a string with line-separated chords of a song and --- returns all possible parsed pieces, together with error-correction steps --- taken (on tokenizing and on musical recognition). -string2Piece :: Grammar g -> String -> ParseResult g -string2Piece g s = let - (PieceLabel key tok, err) = parse ((,) <$> parseSongAbs <*> pEnd) - (createStr (LineColPos 0 0 0) s) - (trees, err2) = case g of - Jazz -> parse_h ((,) <$> pJazz key <*> pEnd) - (createStr 0 (toKeyRelTok key tok)) - Pop -> parse_h ((,) <$> pPop key <*> pEnd) - (createStr 0 (toKeyRelTok key tok)) - Test -> parse_h ((,) <$> pPieceTest <*> pEnd) - (createStr 0 (toKeyRelTok key tok)) - in ParseResult key tok trees emptyHAnTree (length trees) err err2 [] - - -#ifdef AUDIO --------------------------------------------------------------------------------- --- Parsing audio file ground-truth annotations --------------------------------------------------------------------------------- - -gt2Piece :: (GTree g) => Grammar g -> String -> String -> ParseResult g -gt2Piece g ks cs = let - (TimedData key _ _:_cs, errK) = parseDataWithErrors parseKeyAnnotationData ks - (tok, errT) = parseDataWithErrors parseAnnotationData cs - ppTok = preProcess tok - (ts, errP) = case g of - Jazz -> parse_h ((,) <$> pJazz key <*> pEnd) - (createStr 0 (toKeyRelTok key ppTok)) - Pop -> parse_h ((,) <$> pPop key <*> pEnd) - (createStr 0 (toKeyRelTok key ppTok)) - Test -> parse_h ((,) <$> pPieceTest <*> pEnd) - (createStr 0 (toKeyRelTok key ppTok)) - in ParseResult key ppTok ts emptyHAnTree (length ts) (errK ++ errT) errP [] -#endif +{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}++module HarmTrace.HarmTrace ( PPOption(..), Grammar(..), GrammarEx(..)+ , ParseResult(..), gt2Piece+ , string2Piece, postProc ) where++import HarmTrace.Models.Models+import HarmTrace.Models.Jazz.Main+import HarmTrace.Models.Pop.Main+import HarmTrace.HAnTree.ToHAnTree+import HarmTrace.HAnTree.Tree+import HarmTrace.HAnTree.HAn (HFunc (P))+import HarmTrace.HAnTree.PostProcess+import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens as CT+import HarmTrace.Tokenizer.Tokenizer++import Data.Ord (comparing)+import Data.List (minimumBy)++#ifdef AUDIO+-- Audio/Annotation Stuff+import HarmTrace.Audio.Annotations+import HarmTrace.Audio.ChordTypes++import HarmTrace.Base.Parsing (parseDataWithErrors)+#endif++-- Parser stuff+import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances as PC++--------------------------------------------------------------------------------+-- Plugging everything together+--------------------------------------------------------------------------------++data ParseResult a = ParseResult { parsedKey :: Key+ , parsedChordLabels :: [ChordLabel]+ , parsedPiece :: [a]+ , pieceTreeHAn :: Tree HAn+ , nrAmbTrees :: Int+ , tokenizerErrors :: [Error LineColPos ]+ , pieceErrors :: [Error Int] + , postProcessing :: [PPOption]}+ +-- parses s with string2Piece and merges the deleted chords with the tree+-- (Representable a, GTree (Rep a))+postProc :: (GTree g) => [PPOption] -> ParseResult g -> ParseResult g+postProc opts beforePostProc = beforePostProc { pieceTreeHAn = t } + where+ t = selectTree $ map (postProcess fs . gTreeHead) (parsedPiece beforePostProc)+ fs = map opt2Func opts+ opt2Func :: PPOption -> (Tree HAn -> Tree HAn)+ opt2Func RemoveInsertions = removeInsertions + opt2Func RemovePDPT = removePDPT+ opt2Func MergeDelChords = mergeDelChords (parsedKey beforePostProc)+ (pieceErrors beforePostProc)+ (parsedChordLabels beforePostProc)+ opt2Func ExpandChordDurations = expandChordDurations++selectTree :: [Tree HAn] -> Tree HAn+selectTree [] = emptyHAnTree+selectTree ts = minimumBy (comparing getNrFuncNodes) ts++getNrFuncNodes :: Tree HAn -> Int+getNrFuncNodes (Node (HAnFunc P) nodes _) = length nodes+getNrFuncNodes _ = error "HarmTrace.hs: not a correctly formed HAn Tree" + +postProcess :: [Tree HAn -> Tree HAn] -> Tree HAn -> Tree HAn+postProcess [] tree = tree+postProcess (f:fs) tree = f (postProcess fs tree)++-- Takes a string with line-separated chords of a song and+-- returns all possible parsed pieces, together with error-correction steps+-- taken (on tokenizing and on musical recognition).+string2Piece :: Grammar g -> String -> ParseResult g+string2Piece g s = let+ (PieceLabel key tok, err) = parse ((,) <$> parseSongAbs <*> pEnd)+ (createStr (LineColPos 0 0 0) s)+ (trees, err2) = case g of + Jazz -> parse_h ((,) <$> pJazz key <*> pEnd)+ (createStr 0 (toKeyRelTok key tok)) + Pop -> parse_h ((,) <$> pPop key <*> pEnd)+ (createStr 0 (toKeyRelTok key tok))+ in ParseResult key tok trees emptyHAnTree (length trees) err err2 []+++#ifdef AUDIO+--------------------------------------------------------------------------------+-- Parsing audio file ground-truth annotations+-------------------------------------------------------------------------------- ++gt2Piece :: (GTree g) => Grammar g -> String -> String -> ParseResult g+gt2Piece g kstr cstr = let+ (ks , errK) = parseDataWithErrors parseKeyAnnotationData kstr+ key = getData . head $ filter (not . isNone . keyRoot . getData) ks+ (tok, errT) = parseDataWithErrors parseAnnotationData cstr+ ppTok = preProcess tok+ (ts, errP) = case g of + Jazz -> parse_h ((,) <$> pJazz key <*> pEnd)+ (createStr 0 (toKeyRelTok key ppTok)) + Pop -> parse_h ((,) <$> pPop key <*> pEnd)+ (createStr 0 (toKeyRelTok key ppTok))+ in ParseResult key ppTok ts emptyHAnTree (length ts) (errK ++ errT) errP [] +#endif
src/HarmTrace/IO/Errors.hs view
@@ -1,51 +1,49 @@-{-# OPTIONS_GHC -Wall #-} -module HarmTrace.IO.Errors where - --- Parser stuff -import Text.ParserCombinators.UU.BasicInstances as PC (Error (..)) - -import HarmTrace.Base.MusicRep - -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 :: Show a => String -> [Error a] -> IO () -showErrors label l = case countErrors l of - ErrorNrs i d e r -> putStrLn (label ++ show i ++ " insertions, " - ++ show d ++ " deletions, " - ++ show r ++ " replacements, " - ++ show e ++ " deletions at the end") --- Counts the number of insertions and deletions -countErrors :: Show a => [Error a] -> ErrorNrs -countErrors [] = ErrorNrs 0 0 0 0 -countErrors ((PC.Inserted _ _ _) :t) = inc1 (countErrors t) -countErrors ((PC.Deleted _ _ _) :t) = inc2 (countErrors t) -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 :: Show a => [Error a] -> [ChordLabel] -> Float -errorRatio errs toks = simpleErrorMeasure (countErrors errs) / - -- probably we should not divide here by "mergeDups" ... - -- genericLength (mergeDups (Key (Note Nothing C) MajMode) toks) - genericLength 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 } +{-# OPTIONS_GHC -Wall #-}+module HarmTrace.IO.Errors where++-- Parser stuff+import Text.ParserCombinators.UU.BasicInstances as PC (Error (..))++import Data.List (genericLength)+import System.IO (stderr, hPutStrLn)+--------------------------------------------------------------------------------+-- 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 :: Show a => String -> [Error a] -> IO ()+showErrors label l = case countErrors l of+ ErrorNrs i d e r -> hPutStrLn stderr (label ++ show i ++ " insertions, " + ++ show d ++ " deletions, "+ ++ show r ++ " replacements, "+ ++ show e ++ " deletions at the end")+-- Counts the number of insertions and deletions+countErrors :: Show a => [Error a] -> ErrorNrs+countErrors [] = ErrorNrs 0 0 0 0+countErrors ((PC.Inserted _ _ _) :t) = inc1 (countErrors t)+countErrors ((PC.Deleted _ _ _) :t) = inc2 (countErrors t)+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 :: Show a => [Error a] -> [b] -> Float+errorRatio errs toks = simpleErrorMeasure (countErrors errs) /+ -- probably we should not divide here by "mergeDups" ...+ -- genericLength (mergeDups (Key (Note Nothing C) MajMode) toks)+ genericLength 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
@@ -1,370 +1,494 @@-{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE CPP #-} -{-# 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.Models.Jazz.Instances () -import HarmTrace.HAnTree.Tree (Tree) -import HarmTrace.HAnTree.ToHAnTree -import HarmTrace.IO.Errors --- import HarmTrace.Matching.GuptaNishimuraEditMatch -import HarmTrace.Matching.Standard --- import HarmTrace.Matching.Matching (getMatch) --- import HarmTrace.Matching.AlignmentFaster (getAlignDist) -import HarmTrace.Matching.Alignment (getAlignDist, getHAnDist) - -#ifdef AUDIO --- Audio stuff -import HarmTrace.Base.Parsing -import HarmTrace.Audio.Parser -import HarmTrace.Audio.BeatChroma -import HarmTrace.Audio.Annotations -import HarmTrace.Audio.Harmonize -import HarmTrace.Audio.Evaluation -import HarmTrace.Audio.ChordTypes (ChordAnnotation) -import Data.List (genericLength) -#endif - --- Library modules -import System.Console.ParseArgs hiding (args) -- cabal install parseargs -import Data.List (sort, groupBy, intersperse) -import Control.Arrow ((***)) -import System.FilePath -import System.Directory -import System.IO -import Text.Regex.TDFA hiding (match) -import Text.Printf (printf) -import System.CPUTime -import Data.Maybe (isJust, fromJust) -import Data.Binary - --- Parallelism -import Control.Parallel.Strategies - --------------------------------------------------------------------------------- --- Data set Info --------------------------------------------------------------------------------- -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 infp outfp = - do files <- readDataDir infp - writeFile outfp . Prelude.tail $ concatMap merge (createGroundTruth files) - where merge :: (String, String) -> String - merge (x,y) = '\n' : y ++ "\t" ++ x - --------------------------------------------------------------------------------- --- Symbolic Parsing IO --------------------------------------------------------------------------------- - --- parses a string of chords and returns a parse tree with the harmony structure -parseTree, parseTreeVerb :: (GTree g) => Grammar g -> [PPOption] -> String - -> IO (ParseResult g) -parseTree g opts s = - do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s - putStrLn ("parsed " ++ show (length tks) ++ " chords into " - ++ show n ++ " ambiguous trees") - if not $ null te then showErrors "tokenizer: " te - else putStr "" - if not $ null pe then showErrors "parser: " pe - else putStr "" - return pr - -parseTreeVerb g opts s = - do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s - putStrLn ("parsed " ++ show (length tks) ++ " chords into " - ++ show n ++ " ambiguous trees") - if not $ null te then mapM_ print te - else putStr "" - if not $ null pe then mapM_ print pe - else putStr "" - return pr - --- Batch analyzing a directory with chord sequence files with reduced output. -parseDir :: (GTree g) - => Grammar g -> [PPOption] -> FilePath -> Maybe FilePath -> IO () -parseDir g opts filepath bOut = getDirectoryContents filepath - >>= parseDir' g opts bOut filepath . sort - -parseDir' :: (GTree g) - => Grammar g -> [PPOption] -> Maybe FilePath - -> String -> [String] -> IO () -parseDir' g opts bOut fp fs = - do putStr "Filename\tNumber of trees\t" - putStr "Insertions\tDeletions\tReplacements\tDeletions at the end\t" - putStr "Tot_Correction\tNr_of_chords\t" - putStrLn "Error ratio\tTime taken" - let process :: FilePath -> FilePath -> IO ([ChordLabel],Tree HAn) - process path x = - do content <- readFile (path </> x) - let (ParseResult _ tks ps ts nr e1 e2 _) - = postProc opts $ string2Piece g content - -- @Pedro: I think that the (length ts) only is here to - -- evaluate all trees right? Since the tree selection is now - -- incorporated in the postprocessing I replaced it with - -- length ps - -- t = seq (length ts) (return ()) - t = seq (length ps) (return ()) - ErrorNrs i d e r = countErrors e2 - errRat = errorRatio e2 tks - nrOfChords = length tks -- (mergeDups toks) - 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 nr - , show i, show d, show r, show e - , show (i+d+e+r) - , show nrOfChords, showFloat errRat - , showFloat diff] - return (tks, ts) - res <- mapM (process fp) (filter ((== ".txt") . takeExtension) fs) - case bOut of - Nothing -> return () - Just bf -> encodeFile bf (unzip res :: ([[ChordLabel]],[Tree HAn])) - --------------------------------------------------------------------------------- --- Symbolic Matching IO --------------------------------------------------------------------------------- - -data MatchMode = STDiff | LCES | HAnAlign | Align - deriving (Eq, Ord, Show) - --- should return True if sim a b == sim b a and False otherwise -isSymmetrical :: MatchMode -> Bool --- @pedro: I guess it is symmetrical, but I'm not 100% sure -isSymmetrical STDiff = False -isSymmetrical LCES = True -isSymmetrical HAnAlign = True -isSymmetrical Align = True - --- matches a directory of chord description files -dirMatch :: (GTree g) - => Grammar g -> [PPOption] -> Maybe FilePath - -> MatchMode -> Maybe Float -> FilePath -> IO () -dirMatch g o bIn m me fp = - do fs <- readDataDir fp - let process s = let (ParseResult _ tks _ ts _nrts _ ePar _) - = postProc o $ string2Piece g s - in (tks, ts, errorRatio ePar tks) - filterError = if isJust me - then filter (\(_,_,e) -> e <= fromJust me) else id - pss <- mapM (\f -> readFile' (fp </> f)) fs - (tks, ps) <- case bIn of - Just bp -> decodeFile bp :: IO ([[ChordLabel]],[Tree HAn]) - Nothing -> let (toks, ps', _) = unzip3 (filterError - (map process pss)) - in return (toks, ps' `using` parList rdeepseq) - let fsQLab = labelQuery fs - -- print the ireval format ... - putStr "true\n" - if (m == LCES || m == HAnAlign || m == Align) - then putStr "false\n" else putStr "true\n" - mapM_ (putStr . (++ "\t"). getId) (fst . unzip $ filter snd fsQLab) - putChar '\n' - mapM_ (putStr . (++ "\t"). getId) fs - putChar '\n' - -- do the actual matching ... - let match :: (a -> a -> Float) -> [a] -> [([Float],Bool)] - match sim l = [ ([ calcSim sim x y i j - | (j,y) <- zip [0..] l], xIsQ) -- :: ([Float],Bool) - | (i,x,xIsQ) <- zip3 [0..] l (snd . unzip $ fsQLab)] - -- calculate the similarity sim a b, or, if calculated, look up sim b a - calcSim :: (a -> a -> Float) -> a -> a -> Int -> Int -> Float - calcSim sim x y i j = if isSymmetrical m && j < i - then (fst (simMat !! j)) !! i else sim x y - simMat, querySimMat :: [([Float],Bool)] - simMat = (case m of -- full n x n similarity matrix - STDiff -> match diffChordsLen tks - LCES -> error "disabled: fix me" - HAnAlign -> match getHAnDist ps - Align -> match (getAlignDist tempKeyC tempKeyC) tks - ) where tempKeyC = (Key (Note Nothing C) MajMode) - -- filter all non-queries, lazy evaluation should ensure the - -- non-queries will not be evaluated - querySimMat = (filter snd simMat) `using` parList rdeepseq - sequence_ [ printLine x | (x,_) <- querySimMat] - -printLine :: [Float] -> IO () -printLine l = printLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) - --- labels (True/False) the songs that have multiple versions and are queries -labelQuery :: [FilePath] -> [(FilePath, Bool)] -labelQuery l = let cs = getClassSizes l in - map (\x -> (x,(>1) . length . fromJust $ lookup (getTitle x) cs)) l - - -#ifdef AUDIO --------------------------------------------------------------------------------- --- Audio Data IO --------------------------------------------------------------------------------- - --- the strings that build up a data file -vampStr, keyStr, chromaStr, beatStr :: String -chromaStr = "nnls-chroma_nnls-chroma_bothchroma" -keyStr = "qm-vamp-plugins_qm-keydetector_keystrength" -beatStr = "qm-vamp-plugins_qm-tempotracker_beats" -vampStr ="(^.+)_vamp_("++ chromaStr ++ '|' : keyStr ++ '|' : beatStr - ++ ").csv$" - -parseAnnotation :: GTree g => Grammar g -> FilePath -> FilePath - -> IO (ParseResult g) -parseAnnotation g fpkey fpann - = do key <- readFile fpkey - ann <- readFile fpann - return $ gt2Piece g key ann - --- reads an annotation -readAnnotation :: FilePath -> IO ChordAnnotation -readAnnotation fp = do f <- readFile fp - return (parseData parseAnnotationData f) - --- maps readAudioFeat over a directory -readAudioFeatureDir :: FilePath -> IO [Maybe AudioFeat] -readAudioFeatureDir fp = - do fs <- getDirectoryContents fp - mapM (readAudioFeat fp) - (group . sort $ filter (\x -> takeExtension x == ".csv") fs) - where - group :: [FilePath] -> [(FilePath, FilePath, FilePath)] - group (c:k:b:fs) = (c,b,k) : group fs - group [] =[] - group _ = error ("the number of files in the filepath " - ++ "cannot be divided by 3") - --- given a base file path and a triple of three filenames describing --- a chroma, beat and key file, parses all data and returns an audioFeat --- if everything went well. -readAudioFeat :: FilePath -> (FilePath, FilePath, FilePath) - -> IO (Maybe AudioFeat) -readAudioFeat baseURI (chroma, beat, key) = - -- get the part of the filenames before _vamp_ and use it as ID - let (idStr:ids) = map ((maybe "" head) . regexMatchGroups vampStr) - [chroma,beat,key] in - if all (idStr ==) ids then do -- if the IDs are the same then proceed - dChroma <- readFile (baseURI </> chroma) - dBeat <- readFile (baseURI </> beat) - dKey <- readFile (baseURI </> key) - return . Just $ AudioFeat idStr - (parseData parseChordinoData dChroma) - (parseData parseBeatData dBeat) - (parseData parseKeyStrengthData dKey) - else do putStrLn ("found non-matching set of audiofeatures with ids " - ++ show ids) - return Nothing - -{- | evaluluates a single labeling of a piece with a ground truth annotation -visually: -time match GT MPTREE -0.0 True NNone NNone -0.2 True EMaj EMaj -... etc. -The argurments need some explanation: the first argurment should be -the filepath to one of the data files (there must be three, a chroma, a -beat and a key file, to create an AudioFeat), but without all text after -"_vamp_" e.g. for reading file1_vamp_nnls-chroma_nnls-chroma_bothchroma.csv -only file1 should be presented. The function below will now read all -three data files in by adding chromaStr, beatStr and keyStr, respectively -the second file path should just point at the ground truth annotation --} -evaluateLabeling :: FilePath -> FilePath -> IO Double -evaluateLabeling gtfp audiofp = do - let (path, file) = splitFileName audiofp - files = ((file ++ chromaStr <.> "csv"),(file ++ beatStr <.> "csv"), (file ++ keyStr <.> "csv")) - gt <- readAnnotation gtfp - (Just af) <- readAudioFeat path files - -- mapM print gt - -- let test = (processAudioFeat simpleAnnotator af) - -- mapM print test - putStrLn "time\tmatch\tGT\tMPTREE" - printRelCorrectOverlap simpleAnnotator af gt - --- given a ground truth directory and an data directory (containing exactly --- 3 times as much files as the gt directory) all files will be labeled and --- the relative correct overlap wil be corrected an presented to the user -batchLabeling :: FilePath -> FilePath -> IO () -- [Double] -batchLabeling gtfp audiofp = do - gt <- getDirectoryContents gtfp - af <- readAudioFeatureDir audiofp - rco <- zipWithM printEval (sort $ filter ((== ".lab") . takeExtension ) gt) af - putStrLn ("average: " ++ show (sum rco / genericLength rco)) - where - printEval :: FilePath -> Maybe AudioFeat -> IO Double - printEval _ Nothing = error "printEval: Nothing" - printEval fp (Just af) = do - gt <- readAnnotation (gtfp </> fp) - -- let test = processAudioFeat (harmonyAnnotator (getKey af)) af - let test = processAudioFeat simpleAnnotator af - result = relCorrectOverlap gt test - putStrLn (fp ++ ':' : show af ++ ' ' : show result) - return result -#endif - --------------------------------------------------------------------------------- --- Utils --------------------------------------------------------------------------------- -putErrLn :: String -> IO() -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" +{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE CPP #-}+{-# 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.Models.Jazz.Instances ()+import HarmTrace.HAnTree.Tree (Tree)+import HarmTrace.HAnTree.ToHAnTree+import HarmTrace.IO.Errors+import HarmTrace.Matching.Standard+import HarmTrace.Matching.GuptaNishimura+import HarmTrace.Matching.Alignment (getAlignDist, getHAnDist)++#ifdef AUDIO+-- Audio stuff+import HarmTrace.Base.Parsing+import HarmTrace.Audio.Parser+import HarmTrace.Audio.Annotations+import HarmTrace.Audio.Harmonize (putSegStats)+import HarmTrace.Audio.Evaluation+import HarmTrace.Audio.ChordTypes (ChordAnnotation, AudioFeat (..), TimedData)+import Data.List (genericLength)+#endif++-- Library modules+import System.Console.ParseArgs hiding (args) -- cabal install parseargs+import Data.List (sort, groupBy, intersperse)+import Control.Arrow ((***))+import System.FilePath+import System.Directory+import System.IO+import Text.Regex.TDFA hiding (match)+import Text.Printf (printf)+import System.CPUTime+import Data.Maybe (isJust, fromJust)+import Data.Binary++-- Parallelism+import Control.Parallel.Strategies++--------------------------------------------------------------------------------+-- Data set Info+--------------------------------------------------------------------------------+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 infp outfp =+ do files <- readDataDir infp+ writeFile outfp . Prelude.tail $ concatMap merge (createGroundTruth files) + where merge :: (String, String) -> String+ merge (x,y) = '\n' : y ++ "\t" ++ x++--------------------------------------------------------------------------------+-- Symbolic Parsing IO +--------------------------------------------------------------------------------++-- parses a string of chords and returns a parse tree with the harmony structure+parseTree, parseTreeVerb :: (GTree g) => Grammar g -> [PPOption] -> String + -> IO (ParseResult g)+parseTree g opts s =+ do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s+ putStrLn ("parsed " ++ show (length tks) ++ " chords into " + ++ show n ++ " ambiguous trees")+ if not $ null te then showErrors "tokenizer: " te + else putStr ""+ if not $ null pe then showErrors "parser: " pe + else putStr ""+ return pr++parseTreeVerb g opts s = + do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ string2Piece g s+ putStrLn ("parsed " ++ show (length tks) ++ " chords into " + ++ show n ++ " ambiguous trees")+ if not $ null te then mapM_ print te+ else putStr ""+ if not $ null pe then mapM_ print pe+ else putStr ""+ return pr + +-- Batch analyzing a directory with chord sequence files with reduced output.+parseDir :: (GTree g)+ => Grammar g -> [PPOption] -> FilePath -> Maybe FilePath -> IO ()+parseDir g opts filepath bOut = getDirectoryContents filepath + >>= parseDir' g opts bOut filepath . sort++parseDir' :: (GTree g)+ => Grammar g -> [PPOption] -> Maybe FilePath+ -> String -> [String] -> IO ()+parseDir' g opts bOut fp fs = + do putStr "Filename\tNumber of trees\t"+ putStr "Insertions\tDeletions\tReplacements\tDeletions at the end\t"+ putStr "Tot_Correction\tNr_of_chords\t"+ putStrLn "Error ratio\tTime taken"+ let process :: FilePath -> FilePath -> IO ([ChordLabel],Tree HAn)+ process path x =+ do content <- readFile (path </> x)+ let (ParseResult _ tks ps ts nr e1 e2 _) + = postProc opts $ string2Piece g content+ -- @Pedro: I think that the (length ts) only is here to + -- evaluate all trees right? Since the tree selection is now+ -- incorporated in the postprocessing I replaced it with + -- length ps+ -- t = seq (length ts) (return ())+ t = seq (length ps) (return ())+ ErrorNrs i d e r = countErrors e2+ errRat = errorRatio e2 tks+ nrOfChords = length tks -- (mergeDups toks)+ 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 nr+ , show i, show d, show r, show e+ , show (i+d+e+r)+ , show nrOfChords, showFloat errRat+ , showFloat diff] + return (tks, ts)+ res <- mapM (process fp) (filter ((== ".txt") . takeExtension) fs)+ case bOut of+ Nothing -> return ()+ Just bf -> encodeFile bf (unzip res :: ([[ChordLabel]],[Tree HAn]))++--------------------------------------------------------------------------------+-- Symbolic Matching IO+--------------------------------------------------------------------------------++data MatchMode = STDiff | LCESsize | LCESsim | HAnAlign | Align+ deriving (Eq, Ord, Show) ++-- should return True if sim a b == sim b a and False otherwise +isSymmetrical :: MatchMode -> Bool+-- @pedro: I guess it is symmetrical, but I'm not 100% sure+isSymmetrical STDiff = False +isSymmetrical LCESsize = True+isSymmetrical LCESsim = True+isSymmetrical HAnAlign = True +isSymmetrical Align = True + +-- matches a directory of chord description files+dirMatch :: (GTree g)+ => Grammar g -> [PPOption] -> Maybe FilePath+ -> MatchMode -> Maybe Float -> FilePath -> IO ()+dirMatch g o bIn m me fp = + do fs <- readDataDir fp+ let process s = let (ParseResult _ tks _ ts _nrts _ ePar _) + = postProc o $ string2Piece g s+ in (tks, ts, errorRatio ePar tks)+ filterError = if isJust me + then filter (\(_,_,e) -> e <= fromJust me) else id+ pss <- mapM (\f -> readFile' (fp </> f)) fs+ (tks, ps) <- case bIn of+ Just bp -> decodeFile bp :: IO ([[ChordLabel]],[Tree HAn])+ Nothing -> let (toks, ps', _) = unzip3 (filterError + (map process pss))+ in return (toks, ps' `using` parList rdeepseq)+ let fsQLab = labelQuery fs+ -- print the ireval format ...+ putStr "true\n"+ if (m == LCESsize || m == LCESsim || m == HAnAlign || m == Align) + then putStr "false\n" else putStr "true\n"+ mapM_ (putStr . (++ "\t"). getId) (fst . unzip $ filter snd fsQLab) + putChar '\n'+ mapM_ (putStr . (++ "\t"). getId) fs + putChar '\n'+ -- do the actual matching ... + let match :: (a -> a -> Float) -> [a] -> [([Float],Bool)]+ match sim l = [ ([ calcSim sim x y i j + | (j,y) <- zip [0..] l], xIsQ) -- :: ([Float],Bool)+ | (i,x,xIsQ) <- zip3 [0..] l (snd . unzip $ fsQLab)]+ -- calculate the similarity sim a b, or, if calculated, look up sim b a + calcSim :: (a -> a -> Float) -> a -> a -> Int -> Int -> Float+ calcSim sim x y i j = if isSymmetrical m && j < i + then (fst (simMat !! j)) !! i else sim x y+ simMat, querySimMat :: [([Float],Bool)]+ simMat = (case m of -- full n x n similarity matrix+ STDiff -> match diffChordsLen tks+ LCESsize -> match getLCESsize ps+ LCESsim -> match getLCESsim ps+ HAnAlign -> match getHAnDist ps+ Align -> match (getAlignDist tempKeyC tempKeyC) tks + ) where tempKeyC = (Key (Note Nothing C) MajMode)+ -- filter all non-queries, lazy evaluation should ensure the + -- non-queries will not be evaluated+ querySimMat = (filter snd simMat) `using` parList rdeepseq+ sequence_ [ printLine x | (x,_) <- querySimMat]+ +printLine :: [Float] -> IO () +printLine l = printLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) + +-- labels (True/False) the songs that have multiple versions and are queries+labelQuery :: [FilePath] -> [(FilePath, Bool)]+labelQuery l = let cs = getClassSizes l in + map (\x -> (x,(>1) . length . fromJust $ lookup (getTitle x) cs)) l +++#ifdef AUDIO+--------------------------------------------------------------------------------+-- Audio Ground-truth annotations IO+-------------------------------------------------------------------------------- ++parseAnnotation, parseAnnotationVerb :: (GTree g) => Grammar g -> [PPOption] + -> String -> String -> IO (ParseResult g)+parseAnnotation g opts k ann =+ do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ gt2Piece g k ann + putStrLn ("key: " ++ k)+ putStrLn ("parsed " ++ show (length tks)++ " audio chord annotations into " + ++ show n ++ " ambiguous trees")+ if not $ null te then showErrors "tokenizer: " te+ else putStr ""+ if not $ null pe then showErrors "parser: " pe+ else putStr ""+ return pr++parseAnnotationVerb g opts k ann =+ do let pr@(ParseResult _ tks _ _ n te pe _) = postProc opts $ gt2Piece g k ann + putStrLn ("key: " ++ k)+ if not $ null te then do putStrLn "tokenizer errors:" ; mapM_ print te+ else putStr ""+ if not $ null pe then do putStrLn "parser errors:" ; mapM_ print pe+ else putStr ""+ putStrLn ("parsed " ++ show (length tks)++ " audio chord annotations into " + ++ show n ++ " ambiguous trees")+ return pr ++-- parses a directory of annotation files and key description files+-- and prints condenced parsing information to std out+parseAnnotationDir :: GTree a => Grammar a -> [PPOption] -> FilePath -> FilePath+ -> IO () +parseAnnotationDir g opts kdir andir =+ do ks <- getDirectoryContents kdir+ ans <- getDirectoryContents andir+ -- prints parse results in one line+ let prntParse :: (FilePath,FilePath) -> IO ()+ prntParse (kfp,anfp) = + do k <- readFile kfp+ a <- readFile anfp+ printLn . concat $ intersperse "\t" (takeFileName kfp + : (showParseResult . postProc opts $ gt2Piece g k a))+ -- filters .lab files and adds the path+ fileFilter :: FilePath -> [FilePath] -> [FilePath]+ fileFilter pf = map (combine pf) . filter ((== ".lab") . takeExtension) ++ case matchKeyAnn (fileFilter kdir $ reverse ks) + (fileFilter andir $ reverse ans) of+ Just x -> do printLn ("Filename\tkey\tnrOfTrees\tInsertions\tDeletions"+ ++ "\tDelsAtEnd\tTotalErr\tnrOfChords\tTokenizerErr")+ mapM_ prntParse x+ Nothing -> putStrLn ("the filenames in " ++ kdir + ++ " do not exactly match the ones in " ++ andir)++-- Checks if the key and the annotation files all match, if this is the+-- case it will return a paired list of these files+matchKeyAnn :: [FilePath] -> [FilePath] -> Maybe [(FilePath,FilePath)] +matchKeyAnn ks ans = + let match = and $ zipWith eqFileName ks ans+ eqFileName :: FilePath -> FilePath -> Bool+ eqFileName a b = takeFileName a == takeFileName b+ in if match then Just $ zip ks ans else Nothing++-- shows some elements of a ParseResult +showParseResult :: ParseResult a -> [String]+showParseResult (ParseResult k tk _p _han n te pe _pp) =+ let pErr = countErrors pe + insert = ins pErr+ delete = del pErr+ endDel = delEnd pErr+ total = insert + delete + endDel+ -- key nrOfTrees Insertions Deletions DelsAtEnd TotalErr tokenizerErr+ in show k : (map show (n : insert : delete : endDel : total + : length tk : length te :[]))+++--------------------------------------------------------------------------------+-- Audio Data IO+-------------------------------------------------------------------------------- ++-- the strings that build up a data file +vampStr, keyStr, chromaStr, beatStr :: String+chromaStr = "nnls-chroma_nnls-chroma_bothchroma"+-- keyStr = "qm-vamp-plugins_qm-keydetector_keystrength"+keyStr = "nnls-chroma_nnls-chroma_chroma"+beatStr = "qm-vamp-plugins_qm-tempotracker_beats"+vampStr ="(^.+)_vamp_("++ chromaStr ++ '|' : keyStr ++ '|' : beatStr + ++ ").csv$" ++ +-- maps readAudioFeat over a directory+readAudioFeatureDir :: FilePath -> IO [Maybe AudioFeat]+readAudioFeatureDir fp = + do fs <- getDirectoryContents fp+ mapM (readAudioFeat fp) + (group . sort $ filter (\x -> x =~ vampStr) fs) + where+ group :: [FilePath] -> [(FilePath, FilePath, FilePath)]+ group (c:k:b:fs) = (c,b,k) : group fs+ group [] =[]+ group _ = error ("the number of files in the filepath " + ++ "cannot be divided by 3")++-- given a base file path and a triple of three filenames describing +-- a chroma, beat and key file, parses all data and returns an audioFeat+-- if everything went well. +readAudioFeat :: FilePath -> (FilePath, FilePath, FilePath) + -> IO (Maybe AudioFeat)+readAudioFeat baseURI (chroma, beat, key) = + -- get the part of the filenames before _vamp_ and use it as ID+ let (idStr:ids) = map ((maybe "" head) . regexMatchGroups vampStr) + [chroma,beat,key] in+ if all (idStr ==) ids then do -- if the IDs are the same then proceed+ dChroma <- readFile (baseURI </> chroma)+ dBeat <- readFile (baseURI </> beat)+ dKey <- readFile (baseURI </> key)+ -- mapM_ (\x -> putStrLn ("reading: " ++ show x)) + -- ((baseURI </> chroma):(baseURI </> beat):[baseURI </> key])+ let chrm = parseData parseChordinoData dChroma+ beats= parseData parseBeatData dBeat+ -- keys = parseData parseKeyStrengthData dKey+ keys = parseData parseChromaData dKey+ -- N.B. the lines below caused a memory leak!+ -- let (chrm, cerr) = parseDataWithErrors parseChordinoData dChroma+ -- (beats, berr) = parseDataWithErrors parseBeatData dBeat+ -- (keys, kerr) = parseDataWithErrors parseKeyStrengthData dKey+ -- if not (null cerr) then showErrors "both-chroma: " cerr else putStr ""+ -- if not (null berr) then showErrors "beat-detection: " berr else putStr ""+ -- if not (null kerr) then showErrors "key-strength: " kerr else putStr ""+ return . Just $ AudioFeat idStr chrm beats keys+ else do putStrLn ("found non-matching set of audiofeatures with ids " + ++ show ids)+ return Nothing++{- | evaluluates a single labeling of a piece with a ground truth annotation +visually: +time match GT MPTREE+0.0 True NNone NNone+0.2 True EMaj EMaj+... etc.+The arguments need some explanation: the first filepath should be +the filepath to one of the data files (there must be three, a chroma, a+beat and a key file, to create an AudioFeat), but without all text after+"_vamp_" e.g. for reading file1_vamp_nnls-chroma_nnls-chroma_bothchroma.csv+only file1 should be presented. The function below will now read all +three data files in by adding chromaStr, beatStr and keyStr, respectively+the second file path should just point at the ground truth annotation+-}+evaluateLabeling :: (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) + -> Bool -> FilePath -> FilePath -> Maybe FilePath -> IO Double+evaluateLabeling annotator prnt gtfp audiofp keyfp = do+ let (path, file) = splitFileName audiofp+ files = ( file ++ chromaStr <.> "csv"+ , file ++ beatStr <.> "csv"+ , file ++ keyStr <.> "csv" )+ gt <- readAnnotation gtfp+ (Just af) <- readAudioFeat path files++ case (keyfp,prnt) of+ (Nothing,True) -> do printLn ("using key finding")+ putSegStats Nothing af+ printRelCorrectOverlap (annotator Nothing) af gt+ (Nothing,False) -> do return (relCorrectOverlap gt (annotator Nothing af))+ (Just k ,True) -> + do key <- readAndParseKeyAnn k+ printLn ("using groundTruth a key annotation: " ++ show key)+ putSegStats (Just key) af+ printRelCorrectOverlap (annotator (Just key)) af gt+ (Just k ,False) -> + do key <- readAndParseKeyAnn k+ return (relCorrectOverlap gt (annotator (Just key) af))+ +-- given a ground truth directory and an data directory (containing exactly+-- 3 times as much files as the gt directory) all files will be labeled and+-- the relative correct overlap wil be corrected an presented to the user+batchLabeling :: (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) + -> FilePath -> FilePath -> Maybe FilePath -> IO ()+batchLabeling annotator gtfp audiofp keyfp = do+ gt <- getDirectoryContents gtfp+ af <- readAudioFeatureDir audiofp+ + -- parse the key annotations [Maybe [TimedData Key]]+ mKeys <- case keyfp of+ Nothing -> + do printLn "using key finding"+ return $ repeat Nothing + (Just fp) -> + do printLn "using key ground-truth annotations"+ kfs <- getDirectoryContents fp+ -- better to move also the reading etc. to evalR+ ks <- mapM (\x ->readAndParseKeyAnn (fp </> x))+ (sort $ filter ((== ".lab") . takeExtension ) kfs) + return $ map Just ks++ -- this is really hacky, but there is no zipWith3M+ let files = zip (sort $ filter ((== ".lab") . takeExtension ) gt) mKeys+ + printLn "file\trun time (seconds)\trelative correct overlap" + res <- zipWithM evalR files af+ -- _ <- zipWithM printRes files res+ printLn ("average: " ++ show (sum (fmap fst res) / genericLength res))+ where+ evalR :: (FilePath, Maybe [TimedData Key]) -> Maybe AudioFeat+ -> IO (Double, Float)+ evalR _ Nothing = error "evalR: Nothing"+ evalR (fp, maybeKey) (Just af) = do+ gt <- readAnnotation (gtfp </> fp)+ let result = relCorrectOverlap gt (annotator maybeKey af {- `using` parList rdeepseq -})+ exec = seq result (return ())+ t1 <- getCPUTime+ exec+ t2 <- getCPUTime+ let time = fromIntegral (t2 - t1) / (1000000000000 :: Float)+ printRes fp (result, time)+ return (result, time)++ printRes :: FilePath -> (Double, Float) -> IO ()+ printRes fp (r,t) = printLn (fp ++ ":\t" ++ showFloat t ++ '\t' : show r)+ >> hFlush stdout+#endif++-- reads an annotation+readAnnotation :: FilePath -> IO ChordAnnotation+readAnnotation fp = do f <- readFile fp+ return (parseData parseAnnotationData f)+ +readAndParseKeyAnn :: FilePath -> IO [TimedData Key]+readAndParseKeyAnn keyfp = do key <- readFile keyfp + return $ parseData parseKeyAnnotationData key+ +--------------------------------------------------------------------------------+-- 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"
src/HarmTrace/IO/PrintTree.hs view
@@ -1,80 +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 ++ ".png") - -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 - +{-# 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 ++ ".png")++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/Alignment.hs view
@@ -1,179 +1,179 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} - --- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $ -module HarmTrace.Matching.Alignment ( alignChordLab, pPrintV, getAlignDist - , getHAnDist, alignHAnChord - -- , getDownRight, wbMatchF, align, Sim(..) - -- , collectMatch - ) where - -import HarmTrace.Base.MusicRep -import HarmTrace.Matching.SimpleChord -import HarmTrace.Matching.HChord -import HarmTrace.Matching.Sim -import HarmTrace.HAnTree.HAn -import HarmTrace.HAnTree.Tree - -import Prelude hiding (map, length, head, last, mapM_, max) - -import Data.Vector hiding ((!), (++)) -import qualified Data.List as L - --- import Debug.Trace -{- - -Matching notes: -=============== -** Normalisation ( sim * sim ) / (maxsim a * maxsim b) helps in practically - all cases. -** The sampling in general has a large effect on matching speed, and a small - effect on retrieval performance. In all observed cases using no sampling - performs (slightly) better than not using sampling. The sample rate herein - also has an effect: using normal integer division (`div`) deletes chords - with a beat length of 1, which decreases retrieval performance. It is - better to use a `div1` that also includes the chords with a duration of - beat (see SimpleChord.myDiv) -** The mis-match penalty should be -2 > -1 < 0: -1 seems to be optimal - (= insertion/deletion) -** Use very "conservative" similarity measures (not many things are similar) -** Using a ChordType instead of just major/minor improves results -** Using the HAnTrans information improves the similarity estimation -** using only the information of the model (HAnTrans and HAnFunc) performs - worse than using the root and chord type -** Separating transformations (HAnTrans), i.e. Tritone substitutions, dimchord - transformations etc., from preparations (HAnPrep), i.e. secondary dominants, - diatonic chains etc., improves results. This is probably due to that - previously a transformation could "override" a preparations because only - one HAnTrans node was stored (the lowest one in the tree). -** adding similarity between various different preparations DiatV == SecDom - improves similarity. This makes sense because both involve fifth jumps - --} - --------------------------------------------------------------------------------- --- Baseline chord label alignment (no model) --------------------------------------------------------------------------------- - --- returns a similarity/distance value -getAlignDist :: Key -> Key -> [ChordLabel] -> [ChordLabel] -> Float -getAlignDist ka kb ta tb = let (_match, dist, _tab) = alignChordLab ka kb ta tb - in dist - - -alignChordLab :: Key -> Key -> [ChordLabel] -> [ChordLabel] - -> ([SimChord], Float, Vector (Vector Int)) -alignChordLab ka kb ta tb = (fst $ matchToSeq match ta' tb', dis, tab) where - (match, weight, tab) = --trace ("ta: " ++ show ta'++ "\ntb: "++ show tb') - align (-2) ta' tb' - dis = fromIntegral (weight * weight) - / fromIntegral (maxSim ta' * maxSim tb') - ta' = L.concatMap (toSimChords . toChordDegree ka) ta - tb' = L.concatMap (toSimChords . toChordDegree kb) tb - --------------------------------------------------------------------------------- --- HAn Chord alignment --------------------------------------------------------------------------------- - --- returns a similarity/distance value -getHAnDist :: Tree HAn -> Tree HAn -> Float -getHAnDist ta tb = let (_match, dist, _tab) = alignHAnChord ta tb in dist - -alignHAnChord :: Tree HAn -> Tree HAn -> ([HChord], Float, Vector (Vector Int)) -alignHAnChord ta tb = - -- trace ("ta: " ++ show ta'++ "\ntb: "++ show tb' ++ "\nsim: "++ show dis) - (fst $ matchToSeq match ta' tb', dis, tab) where - (match, weight, tab) = align (-2) ta' tb' - dis = fromIntegral (weight * weight) - / fromIntegral (maxSim ta' * maxSim tb') - ta' = toHChords ta - tb' = toHChords tb - --- creates an alignment and returns the list of matches, the distance, and --- the alignment table. The first argument is the insertion/deletion --- penalty (should be a negative value). -align :: Sim a => Int -> [a] -> [a] -> ([(Int,Int)], Int, Vector (Vector Int)) -align _ _ [] = ([],0,empty) -align _ [] _ = ([],0,empty) -align inDel a b = (cm, getDownRight t,t) where - t = wbMatchF inDel a b - cm = toList (collectMatch t) - -wbMatchF :: Sim a => Int -> [a] -> [a] -> Vector (Vector Int) -wbMatchF _ _ [] = empty -wbMatchF _ [] _ = empty -wbMatchF inDel a' b' = m where - a = fromList a' - b = fromList b' - match, fill :: Int -> Int -> Int - {-# INLINE fill #-} - match i j = sim (a ! i) (b ! j) - -- this is the actual core recursive definintion of the algorithm - fill 0 0 = max (match 0 0) 0 - fill 0 j = max0 (((m ! 0 ) !(j-1)) + inDel) (match 0 j) - fill i 0 = max0 (((m !(i-1)) ! 0 ) + inDel) (match i 0) - fill i j = max3 (((m !(i-1)) ! j ) + inDel) - (((m !(i-1)) !(j-1)) + match i j) - (((m ! i) !(j-1)) + inDel) - m = generate (length a) (generate (length b) . fill) - - --------------------------------------------------------------------------------- --- Getting the alignment out of the table --------------------------------------------------------------------------------- - -collectMatch :: Vector (Vector Int) -> Vector (Int,Int) -collectMatch a = fromList $ collect a (length a -1, length (head a) -1) [] -collect :: (Ord b, Num b) => Vector (Vector b) -> (Int, Int) -> [(Int, Int)] - -> [(Int, Int)] -collect a c@(0,0) m = if (a!0)!0 > 0 then c : m else m -collect a c@(i,0) m = if (a!i)!0 > (a!(i-1))! 0 - then c : m else collect a (i-1,0) m -collect a c@(0,j) m = if (a!0)!j > (a!0 )!(j-1) - then c : m else collect a (0,j-1) m -collect a c@(i,j) m - | (a ! i) ! j > snd o = collect a (fst o) (c : m) - | otherwise = collect a (fst o) m where - o = realMax3 ((i-1,j) , (a !(i-1)) ! j ) - ((i-1,j-1), (a !(i-1)) !(j-1)) - ((i,j-1) , (a ! i ) !(j-1)) - -realMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) -realMax3 w nw n = maxByWeight nw (maxByWeight w n) where - maxByWeight :: Ord a => (t,a) -> (t,a) -> (t,a) - maxByWeight a@(_,wa) b@(_,wb) = if wa > wb then a else b - --------------------------------------------------------------------------------- --- Some LCES helper functions --------------------------------------------------------------------------------- - -matchToSeq :: [(Int,Int)] -> [a] -> [a] -> ([a],[a]) -matchToSeq mat aOrg bOrg = (f aMat aOrg, f bMat bOrg) where - f m o = fst . L.unzip $ L.filter (\(_,x) -> x `L.elem` m) (L.zip o [0..]) - (aMat, bMat) = L.unzip mat - -(!) :: Vector a -> Int -> a -{-# INLINE (!) #-} -(!) = unsafeIndex - -max3 :: (Ord a, Num a) => a -> a -> a -> a -{-# INLINE max3 #-} -max3 a b c = max a (max0 b c) - -max0 :: (Ord a, Num a) => a -> a -> a -{-# INLINE max0 #-} -max0 a b = max a (max b 0) --- max3' w nw n = if n > nw then n else max nw w -- not correct yet - -max :: (Ord a, Num a) => a -> a -> a -{-# INLINE max #-} -max x y = if x <= y then y else x - -getDownRight :: Vector (Vector a) -> a -getDownRight n = last (last n) - --- pretty prints a 2 dimensional vector in a readable format -pPrintV :: Show a => Vector (Vector a) -> IO () -pPrintV = mapM_ printLn where - printLn :: Show a => Vector a -> IO() - printLn v = do mapM_ (\x -> putStr (show x ++ " ")) v ; putChar '\n' - +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++-- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $+module HarmTrace.Matching.Alignment ( alignChordLab, pPrintV, getAlignDist+ , getHAnDist, alignHAnChord+ -- , getDownRight, wbMatchF, align, Sim(..)+ -- , collectMatch+ ) where++import HarmTrace.Base.MusicRep+import HarmTrace.Matching.SimpleChord+import HarmTrace.Matching.HChord+import HarmTrace.Matching.Sim+import HarmTrace.HAnTree.HAn +import HarmTrace.HAnTree.Tree++import Prelude hiding (map, length, head, last, mapM_, max)++import Data.Vector hiding ((!), (++))+import qualified Data.List as L++-- import Debug.Trace+{-++Matching notes:+===============+** Normalisation ( sim * sim ) / (maxsim a * maxsim b) helps in practically + all cases.+** The sampling in general has a large effect on matching speed, and a small + effect on retrieval performance. In all observed cases using no sampling + performs (slightly) better than not using sampling. The sample rate herein + also has an effect: using normal integer division (`div`) deletes chords + with a beat length of 1, which decreases retrieval performance. It is+ better to use a `div1` that also includes the chords with a duration of+ beat (see SimpleChord.myDiv)+** The mis-match penalty should be -2 > -1 < 0: -1 seems to be optimal + (= insertion/deletion)+** Use very "conservative" similarity measures (not many things are similar) +** Using a ChordType instead of just major/minor improves results+** Using the HAnTrans information improves the similarity estimation+** using only the information of the model (HAnTrans and HAnFunc) performs+ worse than using the root and chord type+** Separating transformations (HAnTrans), i.e. Tritone substitutions, dimchord+ transformations etc., from preparations (HAnPrep), i.e. secondary dominants,+ diatonic chains etc., improves results. This is probably due to that + previously a transformation could "override" a preparations because only+ one HAnTrans node was stored (the lowest one in the tree). +** adding similarity between various different preparations DiatV == SecDom+ improves similarity. This makes sense because both involve fifth jumps ++-}++--------------------------------------------------------------------------------+-- Baseline chord label alignment (no model)+-------------------------------------------------------------------------------- ++-- returns a similarity/distance value +getAlignDist :: Key -> Key -> [ChordLabel] -> [ChordLabel] -> Float+getAlignDist ka kb ta tb = let (_match, dist, _tab) = alignChordLab ka kb ta tb+ in dist ++ +alignChordLab :: Key -> Key -> [ChordLabel] -> [ChordLabel] + -> ([SimChord], Float, Vector (Vector Int))+alignChordLab ka kb ta tb = (fst $ matchToSeq match ta' tb', dis, tab) where+ (match, weight, tab) = --trace ("ta: " ++ show ta'++ "\ntb: "++ show tb') + align (-2) ta' tb' + dis = fromIntegral (weight * weight) + / fromIntegral (maxSim ta' * maxSim tb')+ ta' = L.concatMap (toSimChords . toChordDegree ka) ta+ tb' = L.concatMap (toSimChords . toChordDegree kb) tb++--------------------------------------------------------------------------------+-- HAn Chord alignment+-------------------------------------------------------------------------------- ++-- returns a similarity/distance value +getHAnDist :: Tree HAn -> Tree HAn -> Float+getHAnDist ta tb = let (_match, dist, _tab) = alignHAnChord ta tb in dist + +alignHAnChord :: Tree HAn -> Tree HAn -> ([HChord], Float, Vector (Vector Int))+alignHAnChord ta tb = + -- trace ("ta: " ++ show ta'++ "\ntb: "++ show tb' ++ "\nsim: "++ show dis)+ (fst $ matchToSeq match ta' tb', dis, tab) where+ (match, weight, tab) = align (-2) ta' tb' + dis = fromIntegral (weight * weight) + / fromIntegral (maxSim ta' * maxSim tb')+ ta' = toHChords ta + tb' = toHChords tb + +-- creates an alignment and returns the list of matches, the distance, and+-- the alignment table. The first argument is the insertion/deletion+-- penalty (should be a negative value).+align :: Sim a => Int -> [a] -> [a] -> ([(Int,Int)], Int, Vector (Vector Int))+align _ _ [] = ([],0,empty)+align _ [] _ = ([],0,empty)+align inDel a b = (cm, getDownRight t,t) where+ t = wbMatchF inDel a b+ cm = toList (collectMatch t)+ +wbMatchF :: Sim a => Int -> [a] -> [a] -> Vector (Vector Int)+wbMatchF _ _ [] = empty +wbMatchF _ [] _ = empty+wbMatchF inDel a' b' = m where+ a = fromList a' + b = fromList b' + match, fill :: Int -> Int -> Int+ {-# INLINE fill #-}+ match i j = sim (a ! i) (b ! j) + -- this is the actual core recursive definintion of the algorithm+ fill 0 0 = max (match 0 0) 0+ fill 0 j = max0 (((m ! 0 ) !(j-1)) + inDel) (match 0 j) + fill i 0 = max0 (((m !(i-1)) ! 0 ) + inDel) (match i 0) + fill i j = max3 (((m !(i-1)) ! j ) + inDel) + (((m !(i-1)) !(j-1)) + match i j) + (((m ! i) !(j-1)) + inDel)+ m = generate (length a) (generate (length b) . fill)+++--------------------------------------------------------------------------------+-- Getting the alignment out of the table+-------------------------------------------------------------------------------- ++collectMatch :: Vector (Vector Int) -> Vector (Int,Int)+collectMatch a = fromList $ collect a (length a -1, length (head a) -1) []+collect :: (Ord b, Num b) => Vector (Vector b) -> (Int, Int) -> [(Int, Int)] + -> [(Int, Int)]+collect a c@(0,0) m = if (a!0)!0 > 0 then c : m else m+collect a c@(i,0) m = if (a!i)!0 > (a!(i-1))! 0 + then c : m else collect a (i-1,0) m+collect a c@(0,j) m = if (a!0)!j > (a!0 )!(j-1) + then c : m else collect a (0,j-1) m+collect a c@(i,j) m + | (a ! i) ! j > snd o = collect a (fst o) (c : m)+ | otherwise = collect a (fst o) m where + o = realMax3 ((i-1,j) , (a !(i-1)) ! j )+ ((i-1,j-1), (a !(i-1)) !(j-1))+ ((i,j-1) , (a ! i ) !(j-1))++realMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) +realMax3 w nw n = maxByWeight nw (maxByWeight w n) where+ maxByWeight :: Ord a => (t,a) -> (t,a) -> (t,a) + maxByWeight a@(_,wa) b@(_,wb) = if wa > wb then a else b ++--------------------------------------------------------------------------------+-- Some LCES helper functions+-------------------------------------------------------------------------------- ++matchToSeq :: [(Int,Int)] -> [a] -> [a] -> ([a],[a])+matchToSeq mat aOrg bOrg = (f aMat aOrg, f bMat bOrg) where+ f m o = fst . L.unzip $ L.filter (\(_,x) -> x `L.elem` m) (L.zip o [0..]) + (aMat, bMat) = L.unzip mat++(!) :: Vector a -> Int -> a+{-# INLINE (!) #-}+(!) = unsafeIndex++max3 :: (Ord a, Num a) => a -> a -> a -> a+{-# INLINE max3 #-}+max3 a b c = max a (max0 b c)++max0 :: (Ord a, Num a) => a -> a -> a +{-# INLINE max0 #-}+max0 a b = max a (max b 0)+-- max3' w nw n = if n > nw then n else max nw w -- not correct yet++max :: (Ord a, Num a) => a -> a -> a +{-# INLINE max #-}+max x y = if x <= y then y else x++getDownRight :: Vector (Vector a) -> a+getDownRight n = last (last n) ++-- pretty prints a 2 dimensional vector in a readable format+pPrintV :: Show a => Vector (Vector a) -> IO ()+pPrintV = mapM_ printLn where+ printLn :: Show a => Vector a -> IO()+ printLn v = do mapM_ (\x -> putStr (show x ++ " ")) v ; putChar '\n'+
− src/HarmTrace/Matching/AlignmentFaster.hs
@@ -1,86 +0,0 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} - --- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $ -module HarmTrace.Matching.AlignmentFaster ( getAlignDist - -- , wbMatchF, align, SimInt (..) - ) where - -import HarmTrace.Base.MusicRep -import HarmTrace.Matching.SimpleChord - -import Prelude hiding (map, length, head, last, (!!), max) - -import Data.Vector hiding ((!)) --- import qualified Data.Vector.Unboxed as U -import qualified Data.List as L - --- import Debug.Trace --------------------------------------------------------------------------------- --- Parameters --------------------------------------------------------------------------------- - -inDel :: Int -inDel = -1 - --------------------------------------------------------------------------------- --- Matching --------------------------------------------------------------------------------- - --- returns a similarity value -getAlignDist :: Key -> Key -> [ChordLabel] -> [ChordLabel] -> Float -getAlignDist ka kb ta tb = fromIntegral weight where - (_match,weight) = align ta' tb' - ta' = L.concatMap (toSimChords . toChordDegree ka) ta - tb' = L.concatMap (toSimChords . toChordDegree kb) tb - -align :: SimInt a=> [a] -> [a] -> ([a], Int) -align _ [] = ([],0) -align [] _ = ([],0) -align a b = ([], last t) where - t = wbMatchF a b - -wbMatchF :: SimInt a => [a] -> [a] -> Vector Int -wbMatchF _ [] = empty -wbMatchF [] _ = empty -wbMatchF a' b' = m where - a = fromList a' - b = fromList b' - cols = length b - toij :: Int -> (Int,Int) - {-# INLINE toij #-} - toij x = let i = x `div` cols in (i, x - (i*cols)) - (!!) :: Vector Int -> (Int,Int) -> Int - {-# INLINE (!!) #-} - (!!) v (i,j) = v `unsafeIndex` ((i * cols) + j) - match :: Int -> Int -> Int - {-# INLINE match #-} - match i j = simInt (a ! i) (b ! j) - -- fil c = let f = fill c in trace ("c: " L.++ show c L.++ " val: " L.++ show f) f - -- this is the actual core recursive definintion of the algorithm - fill :: (Int,Int) -> Int - {-# INLINE fill #-} - fill (0,0) = max (match 0 0) 0 - fill (0,j) = max0 ((m !!(0 ,j-1)) + inDel) (match 0 j) - fill (i,0) = max0 ((m !!(i-1,0 )) + inDel) (match i 0) - fill (i,j) = max3 ((m !!(i-1,j )) + inDel) - ((m !!(i-1,j-1)) + match i j) - ((m !!(i ,j-1)) + inDel) - m = generate ((length a) * (length b)) (fill . toij) - -(!) :: Vector a -> Int -> a -{-# INLINE (!) #-} -(!) = unsafeIndex - -max3 :: (Ord a, Num a) => a -> a -> a -> a -{-# INLINE max3 #-} -max3 a b c = max a (max0 b c) - -max0 :: (Ord a, Num a) => a -> a -> a -{-# INLINE max0 #-} -max0 a b = max a (max b 0) - -max :: (Ord a, Num a) => a -> a -> a -{-# INLINE max #-} -max x y = if x <= y then y else x - -
− src/HarmTrace/Matching/FlatMatch.hs
@@ -1,121 +0,0 @@-{-# 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/GuptaNishimura.hs view
@@ -1,146 +1,190 @@-{-# OPTIONS_GHC -Wall #-} --- $Id: GuptaNishimura.hs 1260 2011-06-14 15:18:21Z bash $ -module HarmTrace.Matching.GuptaNishimura where - --------------------------------------------------------------------------------- --- Finding the Largest Common Embedable Subtrees (LCES) --- Based on: Gupta, A. and Nishimura, N. (1998) Finding largest subtrees and --- smallest supertrees, Algorithmica, 21(2), p. 183--210 --- author: Bas de Haas --------------------------------------------------------------------------------- - -import Data.Ord -import Data.Maybe -import Data.Array -import Data.List - -import HarmTrace.Matching.Tree - --------------------------------------------------------------------------------- --- Top Level LCES function --------------------------------------------------------------------------------- - --- Top level function that returns the largest common embedable subtree --- of two trees -getLCES :: (Eq t) => Tree t -> Tree t -> [Tree t] -getLCES ta tb = matchToTree ta (map fst (reverse m)) where - n = lces ta tb - (m,_) = n!b - (_,b) = bounds n - --- calculates the largest labeled common embeddable subtree -lces :: (Eq t) => Tree t -> Tree t -> Array (Int, Int) ([(Int,Int)], Int) -lces ta tb = n where - la = size ta-1 - lb = size tb-1 - a = listArray (0,la) (pot ta) - b = listArray (0,lb) (pot tb) - maxi :: Int -> [Int] -> ([(Int,Int)],Int) - maxi _ [] = ([],0) - maxi i cb = {-# SCC "maxi_lces" #-}n!(i,maximumBy (comparing (\j -> getWeight $ n!(i,j))) cb ) - maxj :: [Int] -> Int -> ([(Int,Int)],Int) - maxj [] _ = ([],0) - maxj ca j = {-# SCC "maxi_lces" #-}n!( maximumBy (comparing (\i -> getWeight $ n!(i,j))) ca,j) - recur i j = findBestMatch (getLabel (a!i) == getLabel (b!j))i j mc mi mj where - mi = maxi i (getChildPns (b!j)) - mj = maxj (getChildPns (a!i)) j - mc = wbMatch (getChild (a!i)) (getChild $ b!j) n - n = array ((0,0), (la, lb)) - (((0,0), if getLabel (a!0)==getLabel (b!0) then ([(0,0)],1) else ([],0)) : - [((0,j), recur 0 j) | j <- [1..lb]] ++ - [((i,0), recur i 0) | i <- [1..la]] ++ - [((i,j), recur i j) | i <- [1..la], j <- [1..lb]]) - --- returns the best matching candidate, given the previous candidates, the --- bipartite matching. The function depends on wheter the currend nodes --- match and wether, in that case, on of the current nodes is not allready --- matched -findBestMatch :: Bool -> Int -> Int -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) - -> ([(Int,Int)], Int) -> ([(Int,Int)], Int) -findBestMatch match i j a b c - | not match = first - | otherwise = if isFree first i j then ((i,j):mf,wf+1) --add match - else if wf /= ws then first - else if isFree second i j then ((i,j):ms,ws+1) - else if wf /= wt then first - else if isFree second i j then ((i,j):mt,wt+1) - else first where - (first@(mf,wf) : second@(ms,ws) : (mt,wt) : []) = - {- SCC sorting -} reverse $ sortBy (comparing getWeight) [a,b,c] - - --------------------------------------------------------------------------------- --- Weighted Plannar Matching of a Bipartite Graph --------------------------------------------------------------------------------- - --- selects the most lower right cell in the wbMatch' matrix -wbMatch :: (Eq t) => [Tree t] -> [Tree t] - -> Array (Int, Int) ([(Int, Int)], Int) -> ([(Int, Int)], Int) -wbMatch _ [] _ = ([],0) -wbMatch [] _ _ = ([],0) -wbMatch a b n = getDownRight $ wbMatch' a b n - - --- returns the actual planar weighted bipartite matchings. n should contain --- the weights of the edge between a[i] and b[j] -wbMatch' :: (Eq t) => [Tree t] -> [Tree t] - -> Array (Int, Int) ([(Int,Int)], Int) - -> Array (Int, Int) ([(Int,Int)], Int) -wbMatch' _ [] _ = {-# SCC "listArrayA" #-} listArray ((0,0),(0,0)) [] -wbMatch' [] _ _ = {-# SCC "listArrayB" #-} listArray ((0,0),(0,0)) [] -wbMatch' a b n = m where - la = length a-1 - lb = length b-1 - -- returns a previously matched subtree - subTree :: Int -> Int -> ([(Int,Int)], Int) - subTree i j = n ! (fromJust . getPn $ a!!i, fromJust . getPn $ b!!j) - -- this is the actual core recursive definintion of the algorithm - match :: Int -> Int -> ([(Int,Int)], Int) - match i j = maximumBy (comparing getWeight) [maxPrv, minPrv, diagM] where - s@(_mat,w) = subTree i j - hasMatch = w > 0 - maxPrv = if not hasMatch then m!(i-1,j) - else if isFree (m!(i-1,j)) i j then merge s (m!(i-1,j)) - else m!(i-1,j) - minPrv = if not hasMatch then m!(i,j-1) - else if isFree (m!(i,j-1)) i j then merge s (m!(i,j-1)) - else m!(i,j-1) - diagM = merge s (m!(i-1,j-1)) - m = array ((0,0),(la,lb)) - (((0,0), subTree 0 0) : - [((0,j), if getWeight (subTree 0 j) > getWeight (m!(0,j-1)) - then subTree 0 j else m!(0,j-1)) | j <- [1..lb]] ++ - [((i,0), if getWeight (subTree i 0) > getWeight (m!(i-1,0)) - then subTree i 0 else m!(i-1,0)) | i <- [1..la]] ++ - [((i,j), match i j) | i <- [1..la], j <- [1..lb]]) - - --------------------------------------------------------------------------------- --- Some LCES helper functions --------------------------------------------------------------------------------- -getDownRight :: (Ix i) => Array i e -> e -getDownRight n = n ! snd (bounds n) - --- returns the weight of a match and is synonymous to snd -getWeight :: (a, b) -> b -getWeight (_,w) = w - --- returns the list with matches and is synonymous to fst -getMatch :: ([a], b) -> [a] -getMatch (m,_) = m - --- checks if the previously calculated optimal solution does not --- contain the indices i and j in a and b, resepectivly -isFree :: ([(Int,Int)], Int) -> Int -> Int -> Bool -isFree ([],_) _ _ = True -isFree ((previ, prevj):_,_) i j = ( i > previ && j > prevj) - --- mergest two lists with matches -merge :: ([a], Int) -> ([a], Int) -> ([a], Int) -merge (a, wa) (b, wb) = (a ++ b, wa + wb) - --- adds a match to a list of matches --- addMatch :: (Int, Int) -> ([(Int, Int)], Int) -> ([(Int, Int)], Int) --- addMatch (i,j) (a, w)= ((i,j):a, w+1) - - +{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+module HarmTrace.Matching.GuptaNishimura ( getLCES , getLCESsize+ , getLCESdepth, getLCESsim) +where++--------------------------------------------------------------------------------+-- Finding the Largest Common Embedable Subtrees (LCES)+-- Based on: Gupta, A. and Nishimura, N. (1998) Finding largest subtrees and +-- smallest supertrees, Algorithmica, 21(2), p. 183--210+-- author: Bas de Haas+-------------------------------------------------------------------------------- ++import Data.Ord+import Data.Maybe+import Prelude hiding (length, last)+import Data.Vector hiding ((!), last)+import qualified Data.List as L++import HarmTrace.HAnTree.Tree+import HarmTrace.HAnTree.HAn+import HarmTrace.Matching.Sim++-------------------------------------------------------------------------------- +-- Top Level LCES function+-------------------------------------------------------------------------------- ++getLCESsim :: Tree HAn -> Tree HAn -> Float+getLCESsim ta tb = let match = fromIntegral . snd $ getLCES ta tb+ selfSimA = sim ta ta * cumDur ta+ selfSimB = sim tb tb * cumDur tb+ in (match * match) / fromIntegral (selfSimA * selfSimB)++getLCESsize :: Tree HAn -> Tree HAn -> Float+getLCESsize ta tb = let match = fromIntegral . sizeF . fst $ getLCES ta tb+ in (match * match) / fromIntegral (size ta * size tb)++-- Check ismir09 implementation+getLCESdepth :: Tree HAn -> Tree HAn -> Float+getLCESdepth ta tb = let match = avgDepthF . fst $ getLCES ta tb+ in (match * match) / (avgDepth ta * avgDepth tb) ++-- Top level function that returns the largest common embedable subtree+-- of two trees+getLCES :: Tree HAn -> Tree HAn -> ([Tree HAn], Int)+getLCES ta tb = (matchToTree ta (L.map fst (L.reverse m)),w) where + (LCES m w) = last . last $ lces ta tb++nonMatchPenal :: Int+nonMatchPenal = 2 + +-------------------------------------------------------------------------------- +-- LCES calculation+-------------------------------------------------------------------------------- + +-- calculates the largest labeled common embeddable subtree+lces :: (Sim t, GetDur t) => Tree t -> Tree t -> Vector (Vector LCES)+lces ta tb = n where+ a = fromList (pot ta)+ b = fromList (pot tb)+ maxi :: Int -> [Int] -> LCES+ {-# INLINE maxi #-} + maxi _ [] = emptyLCES + maxi i cb = (n!i) ! (L.maximumBy (comparing (\j -> getWeight $ ((n!i)!j))) cb)+ maxj :: [Int] -> Int -> LCES+ {-# INLINE maxj #-} + maxj [] _ = emptyLCES + maxj ca j = (n ! (L.maximumBy (comparing (\i -> getWeight $ ((n!i)!j))) ca))!j+ recur 0 0 = if sim (getLabel (a ! 0)) (getLabel (b ! 0)) > 0+ then LCES [(0,0)] (durSim (getLabel (a ! 0)) (getLabel (b ! 0)))+ else emptyLCES+ recur i j = findBestMatch (sim labi labj) + (min (getDur labi) (getDur labj)) i j mc mi mj where + mi = maxi i (getChildPns (b ! j))+ mj = maxj (getChildPns (a ! i)) j+ mc = wbMatch (getChild (a ! i)) (getChild $ b ! j) n+ !labi = getLabel (a!i) + !labj = getLabel (b!j)+ n = generate (length a) (generate (length b) . recur) + +-- returns the best matching candidate, given the previous candidates, the+-- bipartite matching. The function depends on wheter the currend nodes +-- match and whether, in that case, one of the current nodes is not allready +-- matched+findBestMatch :: Int -> Int -> Int -> Int -> LCES -> LCES -> LCES -> LCES +{-# INLINE findBestMatch #-} +findBestMatch simv dur i j a b c+ | simv <= 0 = (LCES mf (max (wf - (nonMatchPenal * dur)) 0 ))+ | otherwise = if isFree first i j then (LCES ((i,j):mf) (wf+(dur*simv))) + else if wf /= ws then first + else if isFree second i j then (LCES ((i,j):ms) (ws+(dur*simv)))+ else if wf /= wt then first+ else if isFree second i j then (LCES ((i,j):mt) (wt+(dur*simv)))+ else first where+ (first@(LCES mf wf) :second@(LCES ms ws) :(LCES mt wt) :[]) = mySort [a,b,c]+ +--------------------------------------------------------------------------------+-- Weighted Plannar Matching of a Bipartite Graph+-------------------------------------------------------------------------------- + +-- returns the actual planar weighted bipartite matchings. n should contain +-- the weights of the edge between a[i] and b[j] +wbMatch :: [Tree t] -> [Tree t] -> Vector (Vector LCES) -> LCES+{-# INLINE wbMatch #-} +wbMatch _ [] _ = emptyLCES+wbMatch [] _ _ = emptyLCES+wbMatch a b n = last $ last m where + -- returns a previously matched subtree + subTree :: Int -> Int -> LCES + {-# INLINE subTree #-} + subTree i j = (n ! (fromJust . getPn $ a!!i)) ! (fromJust . getPn $ b!!j)+ -- this is the actual core recursive definintion of the algorithm+ match, fill :: Int -> Int -> LCES + match i j = L.maximumBy (comparing getWeight) [maxPrv, minPrv, diagM] where+ s = subTree i j+ !hasMatch = getWeight s > 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)) + fill 0 0 = subTree 0 0+ fill 0 j = if getWeight (subTree 0 j) > getWeight ((m ! 0) ! (j-1)) + then subTree 0 j else (m ! 0) ! (j-1)+ fill i 0 = if getWeight (subTree i 0) > getWeight ((m ! (i-1)) ! 0) + then subTree i 0 else ((m ! (i-1)) ! 0)+ fill i j = match i j + m = generate (L.length a) (generate (L.length b) . fill) + +--------------------------------------------------------------------------------+-- Some LCES helper functions+-------------------------------------------------------------------------------- ++data LCES = LCES ![(Int, Int)] !Int ++getWeight :: LCES -> Int+{-# INLINE getWeight #-}+getWeight (LCES _ w) = w++-- getMatch :: LCES -> [(Int, Int)]+-- getMatch (LCES m _) = m++durSim :: (Sim a, GetDur a) => a -> a -> Int+durSim a b = (sim a b) * (min (getDur a) (getDur b))++emptyLCES :: LCES+{-# INLINE emptyLCES #-}+emptyLCES = LCES [] 0 ++(!) :: Vector a -> Int -> a+{-# INLINE (!) #-}+(!) = unsafeIndex++last :: Vector a -> a+{-# INLINE last #-}+last = unsafeLast++cumDur :: (GetDur a) => Tree a -> Int+cumDur a = (getDur $ getLabel a) + (L.sum $ L.map cumDur (getChild a))++-- checks if the previously calculated optimal solution does not +-- contain the indices i and j in a and b, resepectivly+isFree :: LCES -> Int -> Int -> Bool+{-# INLINE isFree #-}+isFree (LCES [] _) _ _ = True+isFree (LCES ((previ, prevj):_) _) i j = ( i > previ && j > prevj)++-- mergest two lists with matches+merge :: LCES -> LCES -> LCES+{-# INLINE merge #-}+merge (LCES a wa) (LCES b wb) = LCES (a L.++ b) (wa + wb)++-- this sorting routine makes quite a large difference in runtime performance!+mySort :: [LCES] -> [LCES]+{-# INLINE mySort #-}+mySort [a,b,c] = case (x >= y, y >= z, x >= z) of+ (True , True , True ) -> [a,b,c]+ (True , False, True ) -> [a,c,b]+ (True , False, False) -> [c,a,b]+ (False, True , True ) -> [b,a,c]+ (False, True , False) -> [b,c,a]+ (False, False, False) -> [c,b,a]+ _ -> error "mySort: impossible"+ where !x = getWeight a+ !y = getWeight b+ !z = getWeight c+mySort _ = error "mySort: unexpected argument"
− src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs
@@ -1,150 +0,0 @@-{-# 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) / (maxSim ta * maxSim 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/HChord.hs view
@@ -1,51 +1,51 @@-module HarmTrace.Matching.HChord (HChord, Sim, toHChords) where - -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens -import HarmTrace.Matching.Sim -import HarmTrace.HAnTree.HAn -import HarmTrace.HAnTree.Tree - --- represents a very simple chord, only major and minor and a root scaledegree -data HChord = HChord { deg :: !Int -- I = 0, IIb = 1 ... VII = 11 - , clss :: !ClassType -- MajClass | MinClass | DomClass | .. - , func :: !HFunc - , prep :: !Prep - , trns :: !Trans} - -instance Sim HChord where - {-# INLINE sim #-} - sim (HChord r ct _fc pr tr) (HChord r2 ct2 _fc2 pr2 tr2) - | r == r2 && ct == ct2 = 2 + sim pr pr2 + sim tr tr2 - | otherwise = -1 - -instance Show HChord where - show (HChord r ct fc pr tr) = show fc ++ ':' : show pr ++ ':' : show tr - ++ ':' : show (scaleDegrees !! r) ++ show ct - -toHChords :: Tree HAn -> [HChord] -toHChords t = getHAn undefinedHChord t - --- getHAn also samples/replicates the chords based on their duration in beats -getHAn :: HChord -> Tree HAn -> [HChord] -getHAn c (Node h@(HAnChord ct) [] _) -- there might be inserted chords - | null (chords ct) = [] -- ignore them in the matching process - | otherwise = let c' = update c h - -- ignore func when the chord is deleted - c'' = if status ct == Deleted - then c' { trns = NoTrans } else c' - in replicate (dur ct) c'' - -- in replicate ((dur ct) `div1` 2) c'' -getHAn c (Node h cs _) = let c' = update c h in concatMap (getHAn c') cs - -update :: HChord -> HAn -> HChord -update hc (HAn _ _) = hc -update hc (HAnFunc f) = hc { func = f } -update hc (HAnTrans t) = hc { trns = t } -update hc (HAnPrep p) = hc { prep = p } -update hc (HAnChord c) = hc { deg = diaDegToSemi $ root c - , clss = classType c } - -undefinedHChord :: HChord -undefinedHChord = HChord (-1 :: Int) (MajClass :: ClassType) - (P :: HFunc) NoPrep NoTrans +module HarmTrace.Matching.HChord (HChord, Sim, toHChords) where++import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens+import HarmTrace.Matching.Sim +import HarmTrace.HAnTree.HAn+import HarmTrace.HAnTree.Tree++-- represents a very simple chord, only major and minor and a root scaledegree+data HChord = HChord { deg :: !Int -- I = 0, IIb = 1 ... VII = 11+ , clss :: !ClassType -- MajClass | MinClass | DomClass | ..+ , func :: !HFunc+ , prep :: !Prep+ , trns :: !Trans}++instance Sim HChord where+ {-# INLINE sim #-}+ sim (HChord r ct _fc pr tr) (HChord r2 ct2 _fc2 pr2 tr2) + | r == r2 && ct == ct2 = 2 + sim pr pr2 + sim tr tr2+ | otherwise = -1+ +instance Show HChord where+ show (HChord r ct fc pr tr) = show fc ++ ':' : show pr ++ ':' : show tr+ ++ ':' : show (scaleDegrees !! r) ++ show ct++toHChords :: Tree HAn -> [HChord]+toHChords t = getHAn undefinedHChord t++-- getHAn also samples/replicates the chords based on their duration in beats+getHAn :: HChord -> Tree HAn -> [HChord]+getHAn c (Node h@(HAnChord ct) [] _) -- there might be inserted chords+ | null (chords ct) = [] -- ignore them in the matching process+ | otherwise = let c' = update c h + -- ignore func when the chord is deleted+ c'' = if status ct == Deleted + then c' { trns = NoTrans } else c'+ in replicate (dur ct) c''+ -- in replicate ((dur ct) `div1` 2) c''+getHAn c (Node h cs _) = let c' = update c h in concatMap (getHAn c') cs++update :: HChord -> HAn -> HChord+update hc (HAn _ _) = hc+update hc (HAnFunc f) = hc { func = f }+update hc (HAnTrans t) = hc { trns = t }+update hc (HAnPrep p) = hc { prep = p }+update hc (HAnChord c) = hc { deg = diaDegToSemi $ root c+ , clss = classType c }++undefinedHChord :: HChord+undefinedHChord = HChord (-1 :: Int) (MajClass :: ClassType)+ (P :: HFunc) NoPrep NoTrans
− src/HarmTrace/Matching/Matching.hs
@@ -1,182 +0,0 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} - --- $Id: Matching.hs 1260 2011-06-14 15:18:21Z bash $ -module HarmTrace.Matching.Matching (getMatch, printBPM - , getDownRight, wbMatch, wbMatchF - , collectMatch, align, getWeightMatch - ) where - -import HarmTrace.Base.MusicRep -import HarmTrace.Matching.Sim -import HarmTrace.HAnTree.HAn - -import Data.Array -import Debug.Trace - --------------------------------------------------------------------------------- --- Parameters --------------------------------------------------------------------------------- - -inDel, matchW :: Float -inDel = -1 -matchW = 4 - -max3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) -max3 = lazyMax3 --------------------------------------------------------------------------------- --- Matching --------------------------------------------------------------------------------- - --- prints a match -printBPM :: [ChordLabel] -> [ChordLabel] -> IO() -printBPM t1' t2' = putStrLn ("score: " ++ show simVal ++ '\n' : - "self sim 1: "++ show (maxSim t1) ++ '\n' : - "self sim 2: "++ show (maxSim t2) ++ '\n' : - algn t1 t2 (reverse match)) where - -- hardcode C major for now ... - t1 = map (toChordDegree (Key (Note Nothing C) MajMode)) t1' - t2 = map (toChordDegree (Key (Note Nothing C) MajMode)) t2' - -- (match, simVal) = getDownRight $ wbMatch t1 t2 - tab = trace (show t1 ++"\n" ++ show t2) (wbMatchF t1 t2) - simVal = getDownRight $ tab - match = collectMatch tab - -- algn :: Sim a => [a] -> [a] -> [(Int, Int)] -> [Char] - algn a@(ha:ta) b@(hb:tb) m@((ma,mb):ms) - | matcha && matchb = show ha ++ "\t** " ++ (show $ sim ha hb) ++ - " **\t" ++ show hb ++ '\n':(algn ta tb ms) - | matcha = " \t\t" ++ show hb ++ '\n':(algn a tb m) - | matchb = show ha ++ '\n' :(algn ta b m) - | otherwise = show ha ++ "\t\t" ++ show hb ++ '\n' :(algn ta tb m) - where matcha = (getLoc ha) == ma - matchb = (getLoc hb) == mb - algn _ _ _ = "" - - --- returns a similarity value -getMatch :: Key -> [ChordLabel] -> [ChordLabel] -> Float -getMatch key ta tb = (weight * weight) / - (maxSim ta' * maxSim tb' * matchW * matchW) where - -- (_match,weight) = getWeightMatch ta' tb' - (_match,weight) = align ta' tb' - ta' = map (toChordDegree key) ta - tb' = map (toChordDegree key) tb - --- selects the most lower right cell in the wbMatch' matrix -getWeightMatch :: (Sim a, GetDur a) => [a] -> [a] -> ([a], Float) -getWeightMatch _ [] = ([],0) -getWeightMatch [] _ = ([],0) -getWeightMatch a b = (result,simVal) where - (match, simVal) = getDownRight $ wbMatch a b - result = snd . unzip $ filter (\x -> fst x `elem` mfst) (zip [0..] a) - mfst = reverse $ map fst match - -align :: (Sim a, GetDur a) => [a] -> [a] -> ([a], Float) -align _ [] = ([],0.0) -align [] _ = ([],0.0) -align a b = (m, getDownRight t) where - t = wbMatchF a b - cm = (map fst $ collectMatch t) - m = fst . unzip $ filter (\(_,x) -> x `elem` cm) (zip a [0..]) - -wbMatchF :: (Sim a, GetDur a) => [a] -> [a] -> Array (Int, Int) (Float) -wbMatchF _ [] = listArray ((0,0),(0,0)) (repeat 0.0) -wbMatchF [] _ = listArray ((0,0),(0,0)) (repeat 0.0) -wbMatchF a' b' = m where - la = length a'-1 - lb = length b'-1 - a = listArray (0,la) a' -- we need random access and therefore - b = listArray (0,lb) b' -- convert the lists to arrays - dura = listArray (0,la) (map (fromIntegral . getDur) a') - durb = listArray (0,lb) (map (fromIntegral . getDur) b') - match :: Int -> Int -> Float - match i j = let s' = 2 * matchW * sim (a!i) (b!j) in - if s' > 0 then s' else inDel * (min (dura!i) (durb!j)) -- durWeight - -- inDelj = inDel * (fromIntegral $ getDur (b!j)) - -- this is the actual core recursive definintion of the algorithm - recur i j = max3'(m!(i-1,j) + inDel * (dura!i)) - (m!(i-1,j-1) + match i j) - (m!(i,j-1) + inDel * (durb!j)) - m = array ((0,0),(la,lb)) - (((0,0), max (match 0 0) 0) : - [((0,j), max0 (m!(0,j-1) + inDel * (durb!j)) (match 0 j)) | j <- [1..lb]] ++ - [((i,0), max0 (m!(i-1,0) + inDel * (dura!i)) (match i 0)) | i <- [1..la]] ++ - [((i,j), recur i j) | i <- [1..la], j <- [1..lb]]) - -max3' :: (Ord a, Num a) => a -> a -> a -> a -max3' a b c = max a (max0 b c) --- max3' w nw n = if n > nw then n else max0 nw w -- not correct yet - -max0 :: (Ord a, Num a) => a -> a -> a -max0 a b = max a (max b 0) - - -collectMatch :: Array (Int, Int) Float -> [(Int,Int)] -collectMatch a = collect a (snd $ bounds a) [] -collect :: Array (Int, Int) Float -> (Int,Int) -> [(Int,Int)] -> [(Int,Int)] -collect a c@(0,0) m = if a!c > 0 then c : m else m -collect a c@(i,0) m = if a!(i,0) > a!(i-1,0) then c : m else collect a (i-1,0) m -collect a c@(0,j) m = if a!(0,j) > a!(0,j-1) then c : m else collect a (0,j-1) m -collect a c@(i,j) m - | a!c > snd o = collect a (fst o) (c : m) - | otherwise = collect a (fst o) m where - o = realMax3 ((i-1,j) , a!(i-1,j)) - ((i-1,j-1), a!(i-1,j-1)) - ((i,j-1) , a!(i,j-1)) - -wbMatch :: (Sim a, GetDur a) => [a] -> [a] - -> Array (Int, Int) ([(Int, Int)], Float) -wbMatch _ [] = listArray ((0,0),(0,0)) (repeat ([],0.0)) -wbMatch [] _ = listArray ((0,0),(0,0)) (repeat ([],0.0)) -wbMatch a' b' = m where - 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 = l where - l = if s > 0 - then max3 (merge i j di (m!(i-1,j))) - (merge i j s (m!(i-1,j-1))) - (merge i j dj (m!(i,j-1))) - else max3 (m!(i-1,j)) (m!(i,j-1)) (m!(i-1,j-1)) - s = sim (a!i) (b!j) - di = inDel * getDurWeight (a!(i-1)) (b!j) - dj = inDel * getDurWeight (a!i) (b!(j-1)) - m = array ((0,0),(la,lb)) - (((0,0), match 0 0) : - [((0,j), maxByWeight (m!(0,j-1)) (match 0 j)) | j <- [1..lb]] ++ - [((i,0), maxByWeight (m!(i-1,0)) (match i 0)) | i <- [1..la]] ++ - [((i,j), concatMatch i j) | i <- [1..la], j <- [1..lb]]) - -lazyMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) -lazyMax3 w@(_,w') nw@(_,nw') n@(_,n') = if n' > nw' then n else - (if w' > nw' then w else nw) - -realMax3 :: (Ord a) => (t, a) -> (t, a) -> (t, a) -> (t, a) -realMax3 w nw n = maxByWeight nw (maxByWeight w n) where - -maxByWeight :: Ord a => (t,a) -> (t,a) -> (t,a) -maxByWeight a@(_,wa) b@(_,wb) = if wa > wb then a else b - - --- merges two tuples contianing the matchings, weight and cumulative depth of both --- matched trees. -merge :: Int -> Int -> Float -> ([(Int,Int)], Float) -> ([(Int,Int)], Float) -merge i j s p@(prv, w) - | isFree prv i fst && isFree prv j snd = ((i,j) : prv, w + s) - | otherwise = p where - isFree :: [a] -> Int -> (a -> Int) -> Bool - 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
@@ -1,78 +1,90 @@-{-# OPTIONS_GHC -Wall #-} -module HarmTrace.Matching.Sim where - -import HarmTrace.HAnTree.HAn -import HarmTrace.HAnTree.Tree -import HarmTrace.Base.MusicRep - --------------------------------------------------------------------------------- --- A class for representing numerical similarity between datatypes --------------------------------------------------------------------------------- - -class Sim a where - sim :: a -> a -> Int - -instance Sim a => Sim (Tree a) where - sim (Node l _ _) (Node l' _ _) = sim l l' - -instance Sim a => Sim [a] where - sim [ha] [hb] = sim ha hb - sim (ha:ta) (hb:tb) = sim ha hb + sim ta tb - sim _ _ = 0 - -instance Sim Int where - {-# INLINE sim #-} - sim i j = if i == j then 1 else 0 - -instance Sim HFunc where - {-# INLINE sim #-} - sim (Ton _ _m c _) (Ton _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2 - sim (Dom _ _m c _) (Dom _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2 - sim (Sub _ _m c _) (Sub _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2 - sim P P = 1 - sim PD PD = 1 - sim PT PT = 1 - sim _ _ = 0 - -instance Sim Mode where - {-# INLINE sim #-} - sim MajMode MajMode = 1 - sim MinMode MinMode = 1 - sim _ _ = 0 - -instance Sim Trans where - {-# INLINE sim #-} - sim (Trit _v sd) (Trit _v2 sd2) = if sd == sd2 then 1 else 0 - sim (DimTrit _v sd) (DimTrit _v2 sd2) = if sd == sd2 then 1 else 0 - sim (DimTrans _v sd) (DimTrans _v2 sd2) = if sd == sd2 then 1 else 0 - sim _ _ =0 - -instance Sim Prep where - {-# INLINE sim #-} - sim (DiatDom _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 3 else 2 - sim (SecDom _v sd) (SecDom _v2 sd2) = if sd == sd2 then 3 else 2 - sim (SecMin _v sd) (SecMin _v2 sd2) = if sd == sd2 then 3 else 2 - - sim (SecMin _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 2 else 1 - sim (DiatDom _v sd) (SecMin _v2 sd2) = if sd == sd2 then 2 else 1 - - sim (SecMin _v sd) (SecDom _v2 sd2) = if sd == sd2 then 2 else 1 - sim (SecDom _v sd) (SecMin _v2 sd2) = if sd == sd2 then 2 else 1 - - sim (DiatDom _v sd) (SecDom _v2 sd2) = if sd == sd2 then 2 else 1 - sim (SecDom _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 2 else 1 - -- sim NoTrans NoTrans = - sim _ _ = 0 - --------------------------------------------------------------------------------- --- Some utility functions --------------------------------------------------------------------------------- - --- calculates the self similarity value (used for normalisation) i.e. the --- maximum similarity score -maxSim :: Sim a => [a] -> Int -maxSim = foldr (\a b -> sim a a + b) 0 - -div1 :: Int -> Int -> Int -div1 n c = if n == 1 then 1 else n `div` c +{-# OPTIONS_GHC -Wall #-}+module HarmTrace.Matching.Sim where++import HarmTrace.HAnTree.HAn+import HarmTrace.HAnTree.Tree+import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens (ChordToken)++-------------------------------------------------------------------------------- +-- A class for representing numerical similarity between datatypes+-------------------------------------------------------------------------------- ++class Sim a where+ sim :: a -> a -> Int+ +instance Sim a => Sim (Tree a) where+ sim (Node l _ _) (Node l' _ _) = sim l l'++instance Sim a => Sim [a] where+ sim [ha] [hb] = sim ha hb + sim (ha:ta) (hb:tb) = sim ha hb + sim ta tb+ sim _ _ = 0++instance Sim HAn where+ sim (HAn _ a) (HAn _ b) = if a == b then 1 else 0+ sim (HAnFunc a) (HAnFunc b) = sim a b+ sim (HAnPrep a) (HAnPrep b) = sim a b+ sim (HAnTrans a) (HAnTrans b) = sim a b+ sim (HAnChord a) (HAnChord b) = sim a b+ sim _ _ = 0+ +instance Sim Int where+ {-# INLINE sim #-}+ sim i j = if i == j then 1 else 0++instance Sim HFunc where+ {-# INLINE sim #-}+ sim (Ton _ _m c _) (Ton _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2+ sim (Dom _ _m c _) (Dom _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2+ sim (Sub _ _m c _) (Sub _ _m2 c2 _) = if c == c2 then 1 else 0 -- 1 + sim m m2+ sim P P = 1 + sim PD PD = 1 + sim PT PT = 1 + sim _ _ = 0+ +instance Sim Mode where+ {-# INLINE sim #-}+ sim MajMode MajMode = 1 + sim MinMode MinMode = 1 + sim _ _ = 0++instance Sim Trans where + {-# INLINE sim #-}+ sim (Trit _v sd) (Trit _v2 sd2) = if sd == sd2 then 1 else 0+ sim (DimTrit _v sd) (DimTrit _v2 sd2) = if sd == sd2 then 1 else 0+ sim (DimTrans _v sd) (DimTrans _v2 sd2) = if sd == sd2 then 1 else 0+ sim _ _ =0++instance Sim Prep where + {-# INLINE sim #-} + sim (DiatDom _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 3 else 2+ sim (SecDom _v sd) (SecDom _v2 sd2) = if sd == sd2 then 3 else 2+ sim (SecMin _v sd) (SecMin _v2 sd2) = if sd == sd2 then 3 else 2+ + sim (SecMin _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 2 else 1+ sim (DiatDom _v sd) (SecMin _v2 sd2) = if sd == sd2 then 2 else 1+ + sim (SecMin _v sd) (SecDom _v2 sd2) = if sd == sd2 then 2 else 1+ sim (SecDom _v sd) (SecMin _v2 sd2) = if sd == sd2 then 2 else 1+ + sim (DiatDom _v sd) (SecDom _v2 sd2) = if sd == sd2 then 2 else 1+ sim (SecDom _v sd) (DiatDom _v2 sd2) = if sd == sd2 then 2 else 1+ -- sim NoTrans NoTrans = + sim _ _ = 0 + +instance Sim ChordToken where+ sim c1 c2 = if c1 == c2 then 2 else 0+ +-------------------------------------------------------------------------------- +-- Some utility functions+-------------------------------------------------------------------------------- + +-- calculates the self similarity value (used for normalisation) i.e. the+-- maximum similarity score+maxSim :: Sim a => [a] -> Int+maxSim = foldr (\a b -> sim a a + b) 0 + +div1 :: Int -> Int -> Int +div1 n c = if n == 1 then 1 else n `div` c
src/HarmTrace/Matching/SimpleChord.hs view
@@ -1,41 +1,23 @@-module HarmTrace.Matching.SimpleChord (SimChord, Sim, toSimChords) where - -import HarmTrace.Base.MusicRep -import HarmTrace.Matching.Sim - --- represents a very simple chord, only major and minor and a root scaledegree -data SimChord = SimChord !Int -- I = 0, IIb = 1 ... VII = 11 - !Bool -- maj = True, min = False - -instance Sim SimChord where - {-# INLINE sim #-} - sim (SimChord r sh) (SimChord r2 sh2) -- = simInt r r2 + simInt sh sh2 - | r == r2 && sh == sh2 = 4 - | otherwise = -1 - -instance Show SimChord where - show (SimChord r sh) = show (scaleDegrees !! r) ++ if sh then "" else "m" - -toSimChords :: ChordDegree -> [SimChord] -toSimChords (Chord r sh _add _loc d) = - -- replicate (d `div1` 2) (SimChord (diaDegToSemi r) (toMode sh)) - replicate d (SimChord (diaDegToSemi r) (toMode sh)) - -toMode :: Shorthand -> Bool -toMode Maj = True -toMode Min = False -toMode Dim = False -toMode Aug = True -toMode Maj7 = True -toMode Min7 = False -toMode Sev = True -toMode Dim7 = False -toMode HDim7 = False -toMode MinMaj7= False -toMode Maj6 = True -toMode Min6 = False -toMode Nin = True -toMode Maj9 = True -toMode Min9 = False -toMode Sus4 = False -- for now -toMode _ = False -- should not happen+module HarmTrace.Matching.SimpleChord (SimChord, Sim, toSimChords) where++import HarmTrace.Base.MusicRep+import HarmTrace.Matching.Sim++-- represents a very simple chord, only major and minor and a root scaledegree+data SimChord = SimChord !Int -- I = 0, IIb = 1 ... VII = 11+ !Mode -- maj = True, min = False+ +instance Sim SimChord where+ {-# INLINE sim #-}+ sim (SimChord r sh) (SimChord r2 sh2) -- = simInt r r2 + simInt sh sh2+ | r == r2 && sh == sh2 = 4+ | otherwise = -1+ +instance Show SimChord where+ show (SimChord r sh) = show (scaleDegrees !! r) + ++ if sh == MajMode then "" else "m"+ +toSimChords :: ChordDegree -> [SimChord]+toSimChords (Chord r sh _add _loc d) = + -- replicate (d `div1` 2) (SimChord (diaDegToSemi r) (toMode sh))+ replicate d (SimChord (diaDegToSemi r) (toMode sh))
src/HarmTrace/Matching/Standard.hs view
@@ -1,25 +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) ++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/Matching/Testing.hs
@@ -1,82 +0,0 @@-module HarmTrace.Matching.Testing where - -import HarmTrace.Matching.Matching hiding (align, wbMatchF, getDownRight, getMatch, collectMatch) -import HarmTrace.Matching.AlignmentFaster -import HarmTrace.Matching.Sim -import HarmTrace.HAnTree.HAn - -import Data.Array - --- testing -import Test.QuickCheck -import Data.List.Split -import qualified Data.Vector as V - --------------------------------------------------------------------------------- --- Testing --------------------------------------------------------------------------------- - -instance SimInt Char where - {- sim 'a' 'b' = 0.5 - sim 'a' 'c' = 0.1 - sim 'a' 'd' = 1.1 - sim 'a' 'e' = -1.1 - sim 'a' 'f' = -3.1 - sim 'c' 'd' = -1.5 - sim 'e' 'f' = 0.5 - sim 'g' 'h' = -3.2 - sim 'k' 'l' = 4.9 - sim 'i' 'j' = 0.95-} - simInt a b = if a == b then 5 else 0 - -instance GetDur Char where getDur _ = 1 - -data Test = Test Char Int deriving (Eq, Show) - -instance GetDur Test where - getDur (Test _ d) = d - -instance Arbitrary (Test) where - arbitrary = do e <- elements ['a' .. 'm'] - d <- elements [1 .. 12] - return (Test e d) - -instance Sim (Test) where -{- sim (Test 'a' d) (Test 'b' d2) = 0.5 * durWeight d d2 - sim (Test 'b' d) (Test 'a' d2) = 1.5 * durWeight d d2 - sim (Test 'a' d) (Test 'c' d2) = -0.5 * durWeight d d2 - sim (Test 'a' d) (Test 'd' d2) = 5.5 * durWeight d d2 - sim (Test 'd' d) (Test 'b' d2) = -0.5 * durWeight d d2 - sim (Test 'e' d) (Test 'f' d2) = 0.5 * durWeight d d2-} - sim a b = if a == b then 1.0 else 0.0 - --- propRef :: [Char] -> [Char] -> Bool --- -- propRef :: [Test] -> [Test] -> Bool --- propRef a b = (length . fst $ align a b) == (length . fst $ getWeightMatch a b) - --- -- propSym :: [Char] -> [Char] -> Bool --- propSym :: [Test] -> [Test] -> Bool --- propSym a b = snd (align a b) == snd (align b a) - --- traverse a 2 dimentional array row by row and appies f to every element --- should return a String that is printed to the console -pPrintf :: (e -> String) -> Array (Int, Int) e -> IO () -pPrintf f n = putStr $ unlines $ map (concatMap (\x -> f x ++ " ")) list - where list = splitEvery (fromIntegral (snd $ snd $ bounds n)+1) (elems n) - --- pretty prints a 2 diminentional array in a readable format -pPrint :: (Show e) => Array (Int, Int) e -> IO () -pPrint n = pPrintf show n - -pPrintV :: Show a => V.Vector (V.Vector a) -> IO () -pPrintV = V.mapM_ printLn where - printLn :: Show a => V.Vector a -> IO() - printLn v = do V.mapM_ (\x -> putStr (show x ++ " ")) v ; putChar '\n' - -bigTest :: Args -bigTest = stdArgs -- Args - { replay = Nothing - , maxSuccess = 1250 - , maxDiscard = 250 - , maxSize = 100 - }
src/HarmTrace/Models/Jazz/Instances.hs view
@@ -1,250 +1,250 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Models.Jazz.Instances where - --- Generics stuff -import Generics.Instant.TH - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances - --- Music stuff -import HarmTrace.Models.Parser -import HarmTrace.Models.Jazz.Model -import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.ToHAnTree -import HarmTrace.HAnTree.HAn -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Base.TypeLevel -import HarmTrace.Base.MusicRep - --- Library modules -import Control.Arrow - --------------------------------------------------------------------------------- --- The non-generic part of the parser --------------------------------------------------------------------------------- - -instance ParseG (Base_SD key deg clss Ze) where parseG = empty - -instance ( ToDegree (DiatV deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key (DiatV deg) MinClass n) - , ParseG (Base_SD key (DiatVM deg) MajClass n) - , ParseG (Base_SD key deg MinClass n) - , ParseG (TritMinVSub key deg MinClass ) - ) => ParseG (Base_SD key deg MinClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Diat <$> parseG <*> parseG - <|> Cons_DiatM' <$> parseG <*> parseG - -instance ( ToDegree (DiatVM deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key (DiatVM deg) MajClass n) - , ParseG (Base_SD key deg MajClass n) - , ParseG (TritMinVSub key deg MajClass ) - ) => ParseG (Base_SD key deg MajClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_DiatM <$> parseG <*> parseG - -instance ( ToDegree (VMin deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key (VMin deg) MinClass n) - , ParseG (Base_SD key deg DomClass n) - , ParseG (TritMinVSub key deg DomClass ) - ) => ParseG (Base_SD key deg DomClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Vmin <$> parseG <*> parseG - -instance ( ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key deg DimClass n) - , ParseG (TritMinVSub key deg DimClass ) - ) => ParseG (Base_SD key deg DimClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - --- Ad-hoc cases for Base_Final -instance ParseG (Base_Final key deg clss Ze) where parseG = empty - -instance ( ParseG (FinalDimTrans key deg clss) - ) => ParseG (Base_Final key deg clss (Su n)) where - parseG = Base_Final <$> parseG - -instance ( ParseG (FinalDimTrans key deg DomClass) - , ParseG (FinalDimTrans key deg MinClass) - , ParseG (Base_Final key (Tritone deg) DomClass n) - , ParseG (Base_Final key (IIbDim deg) DimClass n) - ) => ParseG (Base_Final key deg DomClass (Su n)) where - parseG = Base_Final <$> parseG - <|> Final_Tritone <$> parseG - <|> Final_Dim_V <$> parseG - --- Ad-hoc cases for Surface_Chord -instance ParseG (Surface_Chord key deg clss Ze) where parseG = empty - -instance ( ToDegree deg - , ParseG (Surface_Chord key (MinThird deg) DimClass n) - ) => ParseG (Surface_Chord key deg DimClass (Su n)) where - parseG = Dim_Chord_Trns <$> parseG - <|> pChord deg DimClass - where deg = toDegree (undefined :: deg) - --- all chords -instance ( ToDegree deg, ToClass clss - ) => ParseG (Surface_Chord key deg clss (Su n)) where - parseG = pChord deg clss - where deg = toDegree (undefined :: deg) - clss = toClass (undefined :: clss) - - -pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord key deg clss (Su n)) --- Do not parse Imp degrees -pChord (Note _ Imp) _clss = empty --- General case -pChord deg clss = setStatus <$> pSatisfy recognize insertion where - recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss' - setStatus (ChordToken r t l NotParsed n d) - = Surface_Chord (ChordToken r t l Parsed n d) - setStatus c = Surface_Chord c - insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 - --------------------------------------------------------------------------------- --- The non-generic part of the GTree wrapper --------------------------------------------------------------------------------- -toGTree :: (GetDegree a, GTree a) => - (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn] -toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) - (gTree deg) Nothing] - --- create a branching Tree HAn -toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) => - (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn] -toGTreeSplit con vof deg - = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg - --- Ad-Hoc case for Piece -instance GTree (Piece key) where -- we take the children to skip a "list node" - gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] - --- Ad-hoc cases for Base_SD -instance GTree (Base_SD key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GTree (Base_SD key (VDom deg) DomClass n) - , GTree (Base_SD key (DiatV deg) MinClass n) - , GTree (Base_SD key (DiatVM deg) MajClass n) - , GTree (Base_SD key (VMin deg) MinClass n) - , GTree (Base_SD key deg clss n) - , GTree (Base_Final key deg clss n) - ) => GTree (Base_SD key deg clss (Su n)) where - gTree (Base_SD d) = gTree d - gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d - gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d - gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d - --- Ad-hoc cases for Base_Final -instance GTree (Base_Final key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GetDegree (Base_Final key (Tritone deg) DomClass n) - , GetDegree (Base_Final key (IIbDim deg) DimClass n) - , GTree (FinalDimTrans key deg clss) - , GTree (Base_Final key (Tritone deg) DomClass n) - , GTree (Base_Final key (IIbDim deg) DimClass n) - ) => GTree (Base_Final key deg clss (Su n)) where - gTree (Base_Final d) = gTree d - -- The tritone substitution of a relative V is as alsway one semitone above - -- the chord it is preceding - gTree (Final_Tritone d) = toGTree Trit 6 d - gTree (Final_Dim_V d) = toGTree DimTrit 11 d - --- Ad-hoc cases for Surface_Chord -instance GTree (Surface_Chord key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) - , GTree (Surface_Chord key (MinThird deg) DimClass n) - ) => GTree (Surface_Chord key deg clss (Su n)) where - gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] - gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print? - --------------------------------------------------------------------------------- --- Ad hoc getDegree instaces --------------------------------------------------------------------------------- -toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree -toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t) - -toSDVal :: (GetDegree a) => a -> ScaleDegree -toSDVal d = let (a,i) = getDeg d in transposeSem a i - --- Given a degree getDegee ensures that all information about the internal --- structure of a scale degree,i.e. the degree and the an int value representing --- the transposition of that degree at the current level, is available. -class GetDegree a where - getDeg :: a -> (ScaleDegree, Int) - -instance GetDegree (Base_SD key deg clss n) where - getDeg (Base_SD d) = getDeg d - getDeg (Cons_Vdom _ d) = getDeg d - getDeg (Cons_Diat _ d) = getDeg d - getDeg (Cons_DiatM _ d) = getDeg d - getDeg (Cons_DiatM' _ d) = getDeg d - getDeg (Cons_Vmin _ d) = getDeg d - -instance ( GetDegree (Base_Final key deg clss Ze)) where - getDeg = error "getDegree: impossible?" -instance GetDegree (Base_Final key deg clss n) where - getDeg (Base_Final d) = getDeg d - -- The tritone substitution of a relative V is as always one semitone above - -- the chord it is preceding - getDeg (Final_Tritone d) = second (+6) (getDeg d) - getDeg (Final_Dim_V d) = second (+1) (getDeg d) - -instance ( GetDegree (Surface_Chord key deg clss Ze)) where - getDeg = error "getDegree: impossible?" - -instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) - ) => GetDegree (Surface_Chord key deg clss (Su n)) where - getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) - getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) - --------------------------------------------------------------------------------- --- Instances of Representable for music datatypes --------------------------------------------------------------------------------- - -deriveAllL allTypes - -$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) - allTypes) - -$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) - allTypes) - --------------------------------------------------------------------------------- --- ChordToken as tokens --------------------------------------------------------------------------------- - -instance IsLocationUpdatedBy Int ChordToken where - advance p c = p + chordNumReps c +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE GADTs #-}++module HarmTrace.Models.Jazz.Instances where++-- Generics stuff+import Generics.Instant.TH++-- Parser stuff+import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances++-- Music stuff+import HarmTrace.Models.Parser+import HarmTrace.Models.Jazz.Model+import HarmTrace.HAnTree.Tree+import HarmTrace.HAnTree.ToHAnTree+import HarmTrace.HAnTree.HAn+import HarmTrace.Tokenizer.Tokens as CT+import HarmTrace.Base.TypeLevel+import HarmTrace.Base.MusicRep++-- Library modules+import Control.Arrow++--------------------------------------------------------------------------------+-- The non-generic part of the parser+--------------------------------------------------------------------------------++instance ParseG (Base_SD deg clss Ze) where parseG = empty+ +instance ( ToDegree (DiatV deg)+ , ToDegree (VDom deg)+ , ParseG (Base_SD (VDom deg) DomClass n)+ , ParseG (Base_SD (DiatV deg) MinClass n)+ , ParseG (Base_SD (DiatVM deg) MajClass n)+ , ParseG (Base_SD deg MinClass n)+ , ParseG (TritMinVSub deg MinClass ) + ) => ParseG (Base_SD 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 (VDom deg) DomClass n)+ , ParseG (Base_SD (DiatVM deg) MajClass n)+ , ParseG (Base_SD deg MajClass n)+ , ParseG (TritMinVSub deg MajClass )+ ) => ParseG (Base_SD deg MajClass (Su n)) where+ parseG = Base_SD <$> parseG+ <|> Cons_Vdom <$> parseG <*> parseG+ <|> Cons_DiatM <$> parseG <*> parseG + +instance ( ToDegree (VMin deg)+ , ToDegree (VDom deg)+ , ParseG (Base_SD (VDom deg) DomClass n)+ , ParseG (Base_SD (VMin deg) MinClass n)+ , ParseG (Base_SD deg DomClass n)+ , ParseG (TritMinVSub deg DomClass ) + ) => ParseG (Base_SD deg DomClass (Su n)) where+ parseG = Base_SD <$> parseG+ <|> Cons_Vdom <$> parseG <*> parseG+ <|> Cons_Vmin <$> parseG <*> parseG + +instance ( ToDegree (VDom deg)+ , ParseG (Base_SD (VDom deg) DomClass n)+ , ParseG (Base_SD deg DimClass n)+ , ParseG (TritMinVSub deg DimClass )+ ) => ParseG (Base_SD deg DimClass (Su n)) where+ parseG = Base_SD <$> parseG+ <|> Cons_Vdom <$> parseG <*> parseG++-- Ad-hoc cases for Base_Final+instance ParseG (Base_Final deg clss Ze) where parseG = empty++instance ( ParseG (FinalDimTrans deg clss)+ ) => ParseG (Base_Final deg clss (Su n)) where+ parseG = Base_Final <$> parseG+ +instance ( ParseG (FinalDimTrans deg DomClass)+ , ParseG (FinalDimTrans deg MinClass)+ , ParseG (Base_Final (Tritone deg) DomClass n)+ , ParseG (Base_Final (IIbDim deg) DimClass n)+ ) => ParseG (Base_Final 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 deg clss Ze) where parseG = empty++instance ( ToDegree deg + , ParseG (Surface_Chord (MinThird deg) DimClass n)+ ) => ParseG (Surface_Chord 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 deg clss (Su n)) where+ parseG = pChord deg clss+ where deg = toDegree (undefined :: deg)+ clss = toClass (undefined :: clss)+++pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n))+-- Do not parse Imp degrees+pChord (Note _ Imp) _clss = empty+-- General case+pChord deg clss = setStatus <$> pSatisfy recognize insertion where+ recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss'+ setStatus (ChordToken r t l NotParsed n d) + = Surface_Chord (ChordToken r t l Parsed n d)+ setStatus c = Surface_Chord c+ insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5++--------------------------------------------------------------------------------+-- The non-generic part of the GTree wrapper+--------------------------------------------------------------------------------+toGTree :: (GetDegree a, GTree a) =>+ (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn]+toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) + (gTree deg) Nothing]++-- create a branching Tree HAn+toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) =>+ (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn]+toGTreeSplit con vof deg + = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg+ +-- Ad-Hoc case for Piece +instance GTree Piece 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 deg clss Ze) where+ gTree _ = error "gTree: impossible?"+ +instance ( GTree (Base_SD (VDom deg) DomClass n)+ , GTree (Base_SD (DiatV deg) MinClass n)+ , GTree (Base_SD (DiatVM deg) MajClass n)+ , GTree (Base_SD (VMin deg) MinClass n)+ , GTree (Base_SD deg clss n)+ , GTree (Base_Final deg clss n)+ ) => GTree (Base_SD deg clss (Su n)) where+ gTree (Base_SD d) = gTree d+ gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d + gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d + gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d ++-- Ad-hoc cases for Base_Final+instance GTree (Base_Final deg clss Ze) where+ gTree _ = error "gTree: impossible?"++instance ( GetDegree (Base_Final (Tritone deg) DomClass n)+ , GetDegree (Base_Final (IIbDim deg) DimClass n)+ , GTree (FinalDimTrans deg clss)+ , GTree (Base_Final (Tritone deg) DomClass n)+ , GTree (Base_Final (IIbDim deg) DimClass n)+ ) => GTree (Base_Final deg clss (Su n)) where+ gTree (Base_Final d) = gTree d+ -- The tritone substitution of a relative V is as alsway one semitone above+ -- the chord it is preceding+ gTree (Final_Tritone d) = toGTree Trit 6 d + gTree (Final_Dim_V d) = toGTree DimTrit 11 d ++-- Ad-hoc cases for Surface_Chord+instance GTree (Surface_Chord deg clss Ze) where+ gTree _ = error "gTree: impossible?"+ +instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n)+ , GTree (Surface_Chord (MinThird deg) DimClass n)+ ) => GTree (Surface_Chord deg clss (Su n)) where+ gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing]+ gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print?+ +--------------------------------------------------------------------------------+-- Ad hoc getDegree instaces+-------------------------------------------------------------------------------- +toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree+toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t)++toSDVal :: (GetDegree a) => a -> ScaleDegree+toSDVal d = let (a,i) = getDeg d in transposeSem a i++-- Given a degree getDegee ensures that all information about the internal+-- structure of a scale degree,i.e. the degree and the an int value representing+-- the transposition of that degree at the current level, is available.+class GetDegree a where+ getDeg :: a -> (ScaleDegree, Int) ++instance GetDegree (Base_SD deg clss n) where+ getDeg (Base_SD d) = getDeg d+ getDeg (Cons_Vdom _ d) = getDeg d + getDeg (Cons_Diat _ d) = getDeg d + getDeg (Cons_DiatM _ d) = getDeg d + getDeg (Cons_DiatM' _ d) = getDeg d + getDeg (Cons_Vmin _ d) = getDeg d ++instance ( GetDegree (Base_Final deg clss Ze)) where + getDeg = error "getDegree: impossible?"+instance GetDegree (Base_Final deg clss n) where+ getDeg (Base_Final d) = getDeg d+ -- The tritone substitution of a relative V is as always one semitone above+ -- the chord it is preceding+ getDeg (Final_Tritone d) = second (+6) (getDeg d)+ getDeg (Final_Dim_V d) = second (+1) (getDeg d)++instance ( GetDegree (Surface_Chord deg clss Ze)) where + getDeg = error "getDegree: impossible?"+ +instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n)+ ) => GetDegree (Surface_Chord 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/Models/Jazz/Main.hs view
@@ -1,31 +1,28 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HarmTrace.Models.Jazz.Main ( - pJazz - , module HarmTrace.Models.Jazz.Model - ) where - --- Parser stuff -import Text.ParserCombinators.UU - --- Music stuff -import HarmTrace.Base.MusicRep -import HarmTrace.Models.Parser -import HarmTrace.Models.Jazz.Model hiding (PD,PT) - -import HarmTrace.Models.Jazz.Instances () - - --------------------------------------------------------------------------------- --- From tokens to structured music pieces --------------------------------------------------------------------------------- - -pPieceMaj, pPieceMin :: forall key. PMusic [Piece key] -pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase key MajMode]) -pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase key MinMode]) - -pJazz :: forall key. Key -> PMusic [Piece key] -pJazz (Key _ MajMode) = pPieceMaj -pJazz (Key _ MinMode) = pPieceMin - ++module HarmTrace.Models.Jazz.Main ( + pJazz + , module HarmTrace.Models.Jazz.Model+ ) where++-- Parser stuff+import Text.ParserCombinators.UU++-- Music stuff+import HarmTrace.Base.MusicRep+import HarmTrace.Models.Parser+import HarmTrace.Models.Jazz.Model hiding (PD,PT)++import HarmTrace.Models.Jazz.Instances ()+++--------------------------------------------------------------------------------+-- From tokens to structured music pieces+--------------------------------------------------------------------------------++pPieceMaj, pPieceMin :: PMusic [Piece]+pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase MajMode])+pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase MinMode])++pJazz :: Key -> PMusic [Piece]+pJazz (Key _ MajMode) = pPieceMaj+pJazz (Key _ MinMode) = pPieceMin
src/HarmTrace/Models/Jazz/Model.hs view
@@ -1,410 +1,409 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Models.Jazz.Model where - -import HarmTrace.Base.TypeLevel - -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens -import Language.Haskell.TH.Syntax (Name) - --------------------------------------------------------------------------------- --- Musical structure as a datatype --------------------------------------------------------------------------------- - -#ifndef NUMLEVELS -#define NUMLEVELS T5 -#endif - --- perhaps this module should be named differently, like Model or HarmonyModel - -data MajMode -data MinMode - --- High level structure --- 'key' is not used yet -data Piece key = forall mode. Piece [Phrase key mode] - --- The Phrase level -data Phrase key mode where - PT :: Ton key mode -> Phrase key mode - PD :: Dom key mode -> Phrase key mode - --- Harmonic categories --- Tonic -data Ton key mode where - -- major mode - T_1 :: Final key I MajClass -> Ton key MajMode - T_2 :: Final key I MajClass -> Final key IV MajClass - -> Final key I MajClass -> Ton key MajMode - - -- blues - -- T_4_bls :: Final key I DomClass -> Ton key mode - - T_3_par :: Final key III MinClass -> Ton key MajMode - T_6_bor :: TMinBorrow key -> Ton key MajMode - - -- minor mode - Tm_1 :: SD key MinMode I MinClass -> Ton key MinMode - Tm_2 :: Final key I MinClass -> Final key IV MinClass - -> Final key I MinClass -> Ton key MinMode - - Tm_3_par :: Final key IIIb MajClass -> Ton key MinMode - Tm_6_bor :: TMajBorrow key -> Ton key MinMode -- picardy third etc. - --- Dominant -data Dom key mode where - -- major mode - D_1 :: SDom key mode -> Dom key mode -> Dom key mode - D_2 :: SD key mode V DomClass -> Dom key mode - D_3 :: SD key mode V MajClass -> Dom key mode - - D_4 :: SD key MajMode VII MinClass -> Dom key MajMode - - -- moll-dur: minor mode borrowings in major - -- This would be an elegant way of defining major minor borrowing, - -- but it causes a lot of unwanted abmiguities since all the mode - -- rules can be explained with and without borrowing - -- D_9_bor :: Dom key MinMode -> Dom key MajMode - D_8_bor :: DMinBorrow key -> Dom key MajMode - - -- minor mode (there must be at least one rule with "MinMode" otherwise - -- no you get a "No instance for (ParseG (Dom key MinMode))" error - Dm_4 :: SD key MinMode VIIb MajClass -> Dom key MinMode - Dm_8_bor :: DMajBorrow key -> Dom key MinMode - --- Subdominant -data SDom key mode where - S_1_par :: SD key mode II MinClass -> SDom key mode -- sub dom parallel - - -- Pretty printing? this rule compensates for the V/I Imp - -- to be able to parse D:7 D:min G:7 C:maj (not in cmj) - S_2_par :: SD key mode II DomClass -> Final key II MinClass - -> SDom key mode - S_3 :: SD key MajMode IV MajClass -> SDom key MajMode - S_4 :: SD key MajMode III MinClass -> Final key IV MajClass - -> SDom key MajMode - -- S_6_par :: SD key MajMode VI MinClass -> SDom key MajMode - - -- blues - -- S_2_bls :: SD key mode IV DomClass -> SD key mode I DomClass - -- -> SDom key mode - - -- Borrowing from minor in a major mode - -- S_7_bor :: SDom key MajMode -> SDom key MinMode - S_5_bor :: SMinBorrow key -> SDom key MajMode - - -- minor mode - Sm_3 :: SD key MinMode IV MinClass -> SDom key MinMode - Sm_4 :: SD key MinMode IIIb MajClass -> Final key IV MinClass - -> SDom key MinMode - -- Sm_3_par :: SD key MinMode VIb MajClass -> SDom key MinMode - - Sm_5_bor :: SMajBorrow key -> SDom key MinMode - - -- perhaps add a functional node for Neapolitan chords? - Sm_6 :: SD key MinMode IIb MajClass -> SDom key MinMode -- Neapolitan - --- Borrowings from minor in a major key -data TMinBorrow key = Tm_21_bor (SD key MinMode I MinClass) - | Tm_23_bor (SD key MinMode IIIb MajClass) - -data DMinBorrow key = Dm_24_bor (SD key MinMode VIIb MajClass) - -- | Dm_21_bor (Final key VIIb DomClass) - -data SMinBorrow key = Sm_20_bor (SD key MinMode IV MinClass) - -- | Sm_21_bor (SD key MinMode VIb MajClass) - | Sm_22_bor (SD key MinMode IIb MajClass) -- Neapolitan - --- Borrowings from major in a minor key -data TMajBorrow key = T_21_bor (SD key MajMode I MajClass) - | T_23_bor (SD key MajMode III MinClass) - -data DMajBorrow key = D_24_bor (SD key MajMode VII MinClass) - -- | D_21_bor (Final key VII DimClass) - -data SMajBorrow key = S_20_bor (SD key MajMode IV MajClass) - - --- Limit secondary dominants to a few levels -type SD key mode deg clss = Base_SD key deg clss NUMLEVELS - --- a type that can be substituted by its tritone sub and diminished 7b9 -type TritMinVSub key deg clss = Base_Final key deg clss T2 - --- A Scale degree that can only translate to a surface chord --- and allows for the transformation into enharmonic equivalent --- diminshed surface chords -type FinalDimTrans key deg clss = Surface_Chord key deg clss T4 - --- A Scale degree that translates into a (non-tranformable) surface chord -type Final key deg clss = Surface_Chord key deg clss T1 - - --- Datatypes for clustering harmonic degrees --- type Base_SD key deg clss n = List (Base_SD' key deg clss n) T4 - -data Base_SD key deg clss n where - Base_SD :: TritMinVSub key deg clss -- Min5 key deg clss n - -> Base_SD key deg clss (Su n) - -- Rule for explaining perfect secondary dominants - Cons_Vdom :: Base_SD key (VDom deg) DomClass n -> Base_SD key deg clss n - -> Base_SD key deg clss (Su n) - Cons_Diat :: Base_SD key (DiatV deg) MinClass n -> Base_SD key deg MinClass n - -> Base_SD key deg MinClass (Su n) - Cons_DiatM :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MajClass n - -> Base_SD key deg MajClass (Su n) - Cons_DiatM' :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MinClass n - -> Base_SD key deg MinClass (Su n) - -- Minor fifth insertion - Cons_Vmin :: Base_SD key (VMin deg) MinClass n -> Base_SD key deg DomClass n - -> Base_SD key deg DomClass (Su n) - - -data Base_Final key deg clss n where - -- Just a "normal", final degree. The Strings are the original input. - Base_Final :: FinalDimTrans key deg clss -> Base_Final key deg clss (Su n) - -- Tritone substitution - Final_Tritone :: Base_Final key (Tritone deg) DomClass n - -> Base_Final key deg DomClass (Su n) - Final_Dim_V :: Base_Final key (IIbDim deg) DimClass n - -> Base_Final key deg DomClass (Su n) - --- Dimished tritone substitution accounting for dimished chord transistions -data Surface_Chord key deg clss n where - Surface_Chord :: ChordToken - -> Surface_Chord key deg clss (Su n) - Dim_Chord_Trns :: Surface_Chord key (MinThird deg) DimClass n - -> Surface_Chord key deg DimClass (Su n) - --------------------------------------------------------------------------------- --- Type Level Scale Degrees --------------------------------------------------------------------------------- - --- typelevel chord classes -data MajClass -data MinClass -data DomClass -data DimClass - --- Degrees (at the type level) -data I -data Ib -data Is -data II -data IIb -data IIs -data III -data IIIb -data IIIs -data IV -data IVb -data IVs -data V -data Vb -data Vs -data VI -data VIb -data VIs -data VII -data VIIb -data VIIs - --- Used when we don't want to consider certain possibilities -data Imp - --- Degrees at the value level are in Tokenizer --- Type to value conversions -class ToClass clss where - toClass :: clss -> ClassType - -instance ToClass MajClass where toClass _ = MajClass -instance ToClass MinClass where toClass _ = MinClass -instance ToClass DomClass where toClass _ = DomClass -instance ToClass DimClass where toClass _ = DimClass - --- The class doesn't really matter, since the degree will be impossible to parse -instance ToClass Imp where toClass _ = DimClass - -class ToDegree deg where - toDegree :: deg -> ScaleDegree - -instance ToDegree I where toDegree _ = Note Nothing I -instance ToDegree II where toDegree _ = Note Nothing II -instance ToDegree III where toDegree _ = Note Nothing III -instance ToDegree IV where toDegree _ = Note Nothing IV -instance ToDegree V where toDegree _ = Note Nothing V -instance ToDegree VI where toDegree _ = Note Nothing VI -instance ToDegree VII where toDegree _ = Note Nothing VII -instance ToDegree Ib where toDegree _ = Note (Just Fl) I -instance ToDegree IIb where toDegree _ = Note (Just Fl) II -instance ToDegree IIIb where toDegree _ = Note (Just Fl) III -instance ToDegree IVb where toDegree _ = Note (Just Fl) IV -instance ToDegree Vb where toDegree _ = Note (Just Fl) V -instance ToDegree VIb where toDegree _ = Note (Just Fl) VI -instance ToDegree VIIb where toDegree _ = Note (Just Fl) VII -instance ToDegree IIs where toDegree _ = Note (Just Sh) II -instance ToDegree IIIs where toDegree _ = Note (Just Sh) III -instance ToDegree IVs where toDegree _ = Note (Just Sh) IV -instance ToDegree Vs where toDegree _ = Note (Just Sh) V -instance ToDegree VIs where toDegree _ = Note (Just Sh) VI -instance ToDegree VIIs where toDegree _ = Note (Just Sh) VII - --- Can't ever parse these -instance ToDegree Imp where toDegree _ = Note Nothing Imp - - --------------------------------------------------------------------------------- --- Type Families for Relative Scale Degrees --------------------------------------------------------------------------------- - - --- Diatonic fifths, and their class (comments with the CMaj scale) --- See http://en.wikipedia.org/wiki/Circle_progression -type family DiatV deg :: * -type instance DiatV I = Imp -- V -- G7 should be Dom -type instance DiatV V = Imp -- II -- Dm7 should be SDom -type instance DiatV II = VI -- Am7 -type instance DiatV VI = III -- Em7 -type instance DiatV III = VII -- Bhdim7 can be explained by Dim rule -type instance DiatV VII = Imp -- IV -- FMaj7 should be SDom -type instance DiatV IV = Imp -- I -- CMaj7 - -type instance DiatV IIb = Imp -type instance DiatV IIIb = Imp -type instance DiatV IVs = Imp -type instance DiatV VIb = Imp -type instance DiatV VIIb = Imp -type instance DiatV Imp = Imp - -type family DiatVM deg :: * -type instance DiatVM I = Imp -- V -- G7 should be Dom -type instance DiatVM V = Imp -- Dm7 should be SDom -type instance DiatVM II = VIb -- Ab -type instance DiatVM VI = Imp -- Em7 -type instance DiatVM III = Imp -- Bhdim7 can be explained by Dim rule -type instance DiatVM VII = Imp -- IV -- FMaj7 should be SDom -type instance DiatVM IV = Imp -- I -- CMaj7 - -type instance DiatVM IIb = Imp -type instance DiatVM IIIb = VIIb -type instance DiatVM IVs = Imp -type instance DiatVM VIb = IIIb -type instance DiatVM VIIb = Imp -type instance DiatVM Imp = Imp - --------------------------------------------------------------------------------- --- Type families for secondary dominants --------------------------------------------------------------------------------- - --- Perfect fifths (class is always Dom) --- See http://en.wikipedia.org/wiki/Circle_of_fifths -type family VDom deg :: * - -type instance VDom I = Imp -- interferes with dom -type instance VDom IIb = VIb -type instance VDom II = VI -type instance VDom IIIb = VIIb -- interferes with Dm_3 -type instance VDom III = VII -type instance VDom IV = I -type instance VDom IVs = IIb -type instance VDom V = II -- interferes with Sm_1 -type instance VDom VIb = IIIb -type instance VDom VI = III -type instance VDom VIIb = IV -type instance VDom VII = IVs -type instance VDom Imp = Imp - --- Perfect fifths for the minor case (this is an additional --- type family to controll the reduction of ambiguities --- specifically in the minor case) -type family VMin deg :: * -type instance VMin I = V -type instance VMin IIb = VIb -type instance VMin II = VI -- interferes with sub -type instance VMin IIIb = VIIb -type instance VMin III = VII -type instance VMin IV = I -type instance VMin IVs = IIb -type instance VMin V = Imp -- II interferes with sub -type instance VMin VIb = IIIb -type instance VMin VI = III -type instance VMin VIIb = Imp --IV -- inteferes with sub IV:min -type instance VMin VII = IVs -type instance VMin Imp = Imp - --- The tritone substitution --- See http://en.wikipedia.org/wiki/Tritone_substitution -type family Tritone deg :: * -type instance Tritone I = IVs -type instance Tritone IVs = I - -type instance Tritone IIb = V -- gives undesired (ambiguous results) as -type instance Tritone V = IIb -- Dom = IIb/I = IIbdim - -type instance Tritone II = VIb -- interferes IIbDim V -type instance Tritone VIb = II - -type instance Tritone IIIb = VI -type instance Tritone VI = IIIb - -type instance Tritone III = VIIb -- Interferes with VIIb from minor -type instance Tritone VIIb = III - -type instance Tritone IV = VII -type instance Tritone VII = IV - -type instance Tritone Imp = Imp - - --------------------------------------------------------------------------------- --- Type families for diminished chord transformations --------------------------------------------------------------------------------- - --- in combination with the secondary dominants and enharmonic equivalency --- these type families account for ascending dim chord progressions -type family IIbDim deg :: * -type instance IIbDim I = IIb -type instance IIbDim IIb = II -type instance IIbDim II = IIIb -type instance IIbDim IIIb = III -type instance IIbDim III = IV -type instance IIbDim IV = IVs -type instance IIbDim IVs = V -type instance IIbDim V = VIb -- interferes with dim tritone V/V -type instance IIbDim VIb = VI -type instance IIbDim VI = VIIb -type instance IIbDim VIIb = VII -type instance IIbDim VII = I -type instance IIbDim Imp = Imp - --- Dimchords can be transposed a minor third without changing their role, --- they are enharmonically equivalent. -type family MinThird deg :: * -type instance MinThird I = IIIb -type instance MinThird IIb = III -type instance MinThird II = IV -type instance MinThird IIIb = IVs -type instance MinThird III = V -type instance MinThird IV = VIb -type instance MinThird IVs = VI -type instance MinThird V = VIIb -type instance MinThird VIb = VII -type instance MinThird VI = I -type instance MinThird VIIb = IIb -type instance MinThird VII = II -type instance MinThird Imp = Imp - --- Belongs in Instances, but needs to be here due to staging restrictions -allTypes :: [Name] -allTypes = [ ''Phrase, ''Ton, ''Dom, ''SDom - , ''TMinBorrow, ''DMinBorrow, ''SMinBorrow - , ''TMajBorrow, ''DMajBorrow, ''SMajBorrow ] +{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}++module HarmTrace.Models.Jazz.Model where++import HarmTrace.Base.TypeLevel++import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens+import Language.Haskell.TH.Syntax (Name)++--------------------------------------------------------------------------------+-- Musical structure as a datatype+--------------------------------------------------------------------------------++#ifndef NUMLEVELS+#define NUMLEVELS T5+#endif++-- perhaps this module should be named differently, like Model or HarmonyModel++data MajMode+data MinMode++-- High level structure+data Piece = forall mode. Piece [Phrase mode]++-- The Phrase level+data Phrase mode where+ PT :: Ton mode -> Phrase mode+ PD :: Dom mode -> Phrase mode++-- Harmonic categories+-- Tonic+data Ton mode where+ -- major mode+ T_1 :: Final I MajClass -> Ton MajMode+ T_2 :: Final I MajClass -> Final IV MajClass + -> Final I MajClass -> Ton MajMode+ + -- blues + -- T_4_bls :: Final I DomClass -> Ton mode ++ T_3_par :: Final III MinClass -> Ton MajMode + T_6_bor :: TMinBorrow -> Ton MajMode++ -- minor mode + Tm_1 :: SD MinMode I MinClass -> Ton MinMode+ Tm_2 :: Final I MinClass -> Final IV MinClass+ -> Final I MinClass -> Ton MinMode ++ Tm_3_par :: Final IIIb MajClass -> Ton MinMode + Tm_6_bor :: TMajBorrow -> Ton MinMode -- picardy third etc. ++-- Dominant+data Dom mode where+ -- major mode+ D_1 :: SDom mode -> Dom mode -> Dom mode+ D_2 :: SD mode V DomClass -> Dom mode+ D_3 :: SD mode V MajClass -> Dom mode++ D_4 :: SD MajMode VII MinClass -> Dom 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 MinMode -> Dom MajMode+ D_8_bor :: DMinBorrow -> Dom MajMode+ + -- minor mode (there must be at least one rule with "MinMode" otherwise+ -- no you get a "No instance for (ParseG (Dom MinMode))" error+ Dm_4 :: SD MinMode VIIb MajClass -> Dom MinMode+ Dm_8_bor :: DMajBorrow -> Dom MinMode++-- Subdominant+data SDom mode where+ S_1_par :: SD mode II MinClass -> SDom mode -- sub dom parallel++ -- Pretty printing? this rule compensates for the V/I Imp+ -- to be able to parse D:7 D:min G:7 C:maj (not in cmj)+ S_2_par :: SD mode II DomClass -> Final II MinClass+ -> SDom mode + S_3 :: SD MajMode IV MajClass -> SDom MajMode+ S_4 :: SD MajMode III MinClass -> Final IV MajClass + -> SDom MajMode+ -- S_6_par :: SD MajMode VI MinClass -> SDom MajMode+ + -- blues+ -- S_2_bls :: SD mode IV DomClass -> SD mode I DomClass + -- -> SDom mode + + -- Borrowing from minor in a major mode+ -- S_7_bor :: SDom MajMode -> SDom MinMode+ S_5_bor :: SMinBorrow -> SDom MajMode + + -- minor mode+ Sm_3 :: SD MinMode IV MinClass -> SDom MinMode+ Sm_4 :: SD MinMode IIIb MajClass -> Final IV MinClass + -> SDom MinMode+ -- Sm_3_par :: SD MinMode VIb MajClass -> SDom MinMode+ + Sm_5_bor :: SMajBorrow -> SDom MinMode ++ -- perhaps add a functional node for Neapolitan chords?+ Sm_6 :: SD MinMode IIb MajClass -> SDom MinMode -- Neapolitan+ +-- Borrowings from minor in a major key+data TMinBorrow = Tm_21_bor (SD MinMode I MinClass) + | Tm_23_bor (SD MinMode IIIb MajClass) ++data DMinBorrow = Dm_24_bor (SD MinMode VIIb MajClass) + -- | Dm_21_bor (Final VIIb DomClass) + +data SMinBorrow = Sm_20_bor (SD MinMode IV MinClass) + -- | Sm_21_bor (SD MinMode VIb MajClass)+ | Sm_22_bor (SD MinMode IIb MajClass) -- Neapolitan ++-- Borrowings from major in a minor key+data TMajBorrow = T_21_bor (SD MajMode I MajClass)+ | T_23_bor (SD MajMode III MinClass)++data DMajBorrow = D_24_bor (SD MajMode VII MinClass) + -- | D_21_bor (Final VII DimClass)+ +data SMajBorrow = S_20_bor (SD MajMode IV MajClass) + + +-- Limit secondary dominants to a few levels+type SD mode deg clss = Base_SD deg clss NUMLEVELS++-- a type that can be substituted by its tritone sub and diminished 7b9+type TritMinVSub deg clss = Base_Final 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 deg clss = Surface_Chord deg clss T4++-- A Scale degree that translates into a (non-tranformable) surface chord+type Final deg clss = Surface_Chord deg clss T1+++-- Datatypes for clustering harmonic degrees+-- type Base_SD deg clss n = List (Base_SD' deg clss n) T4++data Base_SD deg clss n where+ Base_SD :: TritMinVSub deg clss -- Min5 deg clss n+ -> Base_SD deg clss (Su n) + -- Rule for explaining perfect secondary dominants+ Cons_Vdom :: Base_SD (VDom deg) DomClass n -> Base_SD deg clss n+ -> Base_SD deg clss (Su n)+ Cons_Diat :: Base_SD (DiatV deg) MinClass n -> Base_SD deg MinClass n+ -> Base_SD deg MinClass (Su n)+ Cons_DiatM :: Base_SD (DiatVM deg) MajClass n -> Base_SD deg MajClass n+ -> Base_SD deg MajClass (Su n)+ Cons_DiatM' :: Base_SD (DiatVM deg) MajClass n -> Base_SD deg MinClass n+ -> Base_SD deg MinClass (Su n)+ -- Minor fifth insertion+ Cons_Vmin :: Base_SD (VMin deg) MinClass n -> Base_SD deg DomClass n+ -> Base_SD deg DomClass (Su n)++ +data Base_Final deg clss n where+ -- Just a "normal", final degree. The Strings are the original input.+ Base_Final :: FinalDimTrans deg clss -> Base_Final deg clss (Su n)+ -- Tritone substitution+ Final_Tritone :: Base_Final (Tritone deg) DomClass n+ -> Base_Final deg DomClass (Su n)+ Final_Dim_V :: Base_Final (IIbDim deg) DimClass n+ -> Base_Final deg DomClass (Su n) ++-- Dimished tritone substitution accounting for dimished chord transistions+data Surface_Chord deg clss n where+ Surface_Chord :: ChordToken + -> Surface_Chord deg clss (Su n)+ Dim_Chord_Trns :: Surface_Chord (MinThird deg) DimClass n+ -> Surface_Chord 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/Models/Models.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} - -module HarmTrace.Models.Models where - -import HarmTrace.Models.Jazz.Model as J hiding (PD, PT) -import HarmTrace.Models.Pop.Model as P hiding (PD, PT) -import HarmTrace.Models.Test.Main - -import HarmTrace.HAnTree.ToHAnTree - - -data Grammar :: * -> * where - Jazz :: Grammar (J.Piece key) - Pop :: Grammar (P.Piece key) - Test :: Grammar PieceTest - -data GrammarEx where - GrammarEx :: (GTree g) => Grammar g -> GrammarEx +{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module HarmTrace.Models.Models where++import HarmTrace.Models.Jazz.Model as J hiding (PD, PT) +import HarmTrace.Models.Pop.Model as P hiding (PD, PT)++import HarmTrace.HAnTree.ToHAnTree+++data Grammar :: * -> * where+ Jazz :: Grammar J.Piece+ Pop :: Grammar P.Piece++data GrammarEx where+ GrammarEx :: (GTree g) => Grammar g -> GrammarEx
src/HarmTrace/Models/Parser.hs view
@@ -1,75 +1,75 @@-{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- Semi-generic parser for chords -module HarmTrace.Models.Parser where - - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances - --- Generics stuff -import Generics.Instant.Base as G - --- Music stuff -import HarmTrace.Tokenizer.Tokens - - --------------------------------------------------------------------------------- --- The generic part of the parser --------------------------------------------------------------------------------- - -type PMusic a = P (Str ChordToken [ChordToken] Int) a - -class Parse' f where - parse' :: PMusic f - -instance Parse' U where - parse' = pure U - -instance (ParseG a) => Parse' (Rec a) where - parse' = Rec <$> parseG - --- Not really necessary because TH is not generating any Var, but anyway -instance (ParseG a) => Parse' (Var a) where - parse' = Var <$> parseG - -instance (Constructor c, Parse' f) => Parse' (G.CEq c p p f) where - parse' = G.C <$> parse' <?> "Constructor " ++ conName (undefined :: C c f) - -instance Parse' (G.CEq c p q f) where - parse' = empty - -instance (Parse' f, Parse' g) => Parse' (f :+: g) where - parse' = L <$> parse' <|> R <$> parse' - -instance (Parse' f, Parse' g) => Parse' (f :*: g) where - parse' = (:*:) <$> parse' <*> parse' - - -class ParseG a where - parseG :: PMusic a - -instance (ParseG a) => ParseG [a] where - parseG = pList1 parseG - -- We should use non-greedy parsing here, else the final Dom is never parsed - -- as such. - -- parseG = pList1_ng parseG - -instance (ParseG a) => ParseG (Maybe a) where - parseG = pMaybe parseG - -parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a --- parseGdefault = fmap (to . head) (amb parse') --- Previously we used: -parseGdefault = fmap to parse' --- This gave rise to many ambiguities. Now we allow parse' to be ambiguous --- (note that the sum case uses <|>) but then pick only the very first tree --- from all the possible results. It remains to be seen if the first tree is --- the best... +{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- Semi-generic parser for chords+module HarmTrace.Models.Parser where+++-- Parser stuff+import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances++-- Generics stuff+import Generics.Instant.Base as G++-- Music stuff+import HarmTrace.Tokenizer.Tokens+++--------------------------------------------------------------------------------+-- The generic part of the parser+--------------------------------------------------------------------------------++type PMusic a = P (Str ChordToken [ChordToken] Int) a++class Parse' f where+ parse' :: PMusic f++instance Parse' U where+ parse' = pure U++instance (ParseG a) => Parse' (Rec a) where+ parse' = Rec <$> parseG++-- Not really necessary because TH is not generating any Var, but anyway+instance (ParseG a) => Parse' (Var a) where+ parse' = Var <$> parseG++instance (Constructor c, Parse' f) => Parse' (G.CEq c p p f) where+ parse' = G.C <$> parse' <?> "Constructor " ++ conName (undefined :: C c f)++instance Parse' (G.CEq c p q f) where + parse' = empty++instance (Parse' f, Parse' g) => Parse' (f :+: g) where+ parse' = L <$> parse' <|> R <$> parse'++instance (Parse' f, Parse' g) => Parse' (f :*: g) where+ parse' = (:*:) <$> parse' <*> parse'+++class ParseG a where+ parseG :: PMusic a++instance (ParseG a) => ParseG [a] where+ parseG = pList1 parseG+ -- We should use non-greedy parsing here, else the final Dom is never parsed+ -- as such.+ -- parseG = pList1_ng parseG++instance (ParseG a) => ParseG (Maybe a) where+ parseG = pMaybe parseG++parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a+-- parseGdefault = fmap (to . head) (amb parse')+-- Previously we used:+parseGdefault = fmap to parse'+-- This gave rise to many ambiguities. Now we allow parse' to be ambiguous+-- (note that the sum case uses <|>) but then pick only the very first tree+-- from all the possible results. It remains to be seen if the first tree is+-- the best...
src/HarmTrace/Models/Pop/Instances.hs view
@@ -1,250 +1,250 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Models.Pop.Instances where - --- Generics stuff -import Generics.Instant.TH - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances - --- Music stuff -import HarmTrace.Models.Parser -import HarmTrace.Models.Pop.Model -import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.ToHAnTree -import HarmTrace.HAnTree.HAn -import HarmTrace.Tokenizer.Tokens as CT -import HarmTrace.Base.TypeLevel -import HarmTrace.Base.MusicRep - --- Library modules -import Control.Arrow - --------------------------------------------------------------------------------- --- The non-generic part of the parser --------------------------------------------------------------------------------- - -instance ParseG (Base_SD key deg clss Ze) where parseG = empty - -instance ( ToDegree (DiatV deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key (DiatV deg) MinClass n) - , ParseG (Base_SD key (DiatVM deg) MajClass n) - , ParseG (Base_SD key deg MinClass n) - , ParseG (TritMinVSub key deg MinClass ) - ) => ParseG (Base_SD key deg MinClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Diat <$> parseG <*> parseG - <|> Cons_DiatM' <$> parseG <*> parseG - -instance ( ToDegree (DiatVM deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key (DiatVM deg) MajClass n) - , ParseG (Base_SD key deg MajClass n) - , ParseG (TritMinVSub key deg MajClass ) - ) => ParseG (Base_SD key deg MajClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_DiatM <$> parseG <*> parseG - -instance ( ToDegree (VMin deg) - , ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key (VMin deg) MinClass n) - , ParseG (Base_SD key deg DomClass n) - , ParseG (TritMinVSub key deg DomClass ) - ) => ParseG (Base_SD key deg DomClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - <|> Cons_Vmin <$> parseG <*> parseG - -instance ( ToDegree (VDom deg) - , ParseG (Base_SD key (VDom deg) DomClass n) - , ParseG (Base_SD key deg DimClass n) - , ParseG (TritMinVSub key deg DimClass ) - ) => ParseG (Base_SD key deg DimClass (Su n)) where - parseG = Base_SD <$> parseG - <|> Cons_Vdom <$> parseG <*> parseG - --- Ad-hoc cases for Base_Final -instance ParseG (Base_Final key deg clss Ze) where parseG = empty - -instance ( ParseG (FinalDimTrans key deg clss) - ) => ParseG (Base_Final key deg clss (Su n)) where - parseG = Base_Final <$> parseG - -instance ( ParseG (FinalDimTrans key deg DomClass) - , ParseG (FinalDimTrans key deg MinClass) - , ParseG (Base_Final key (Tritone deg) DomClass n) - , ParseG (Base_Final key (IIbDim deg) DimClass n) - ) => ParseG (Base_Final key deg DomClass (Su n)) where - parseG = Base_Final <$> parseG - <|> Final_Tritone <$> parseG - <|> Final_Dim_V <$> parseG - --- Ad-hoc cases for Surface_Chord -instance ParseG (Surface_Chord key deg clss Ze) where parseG = empty - -instance ( ToDegree deg - , ParseG (Surface_Chord key (MinThird deg) DimClass n) - ) => ParseG (Surface_Chord key deg DimClass (Su n)) where - parseG = Dim_Chord_Trns <$> parseG - <|> pChord deg DimClass - where deg = toDegree (undefined :: deg) - --- all chords -instance ( ToDegree deg, ToClass clss - ) => ParseG (Surface_Chord key deg clss (Su n)) where - parseG = pChord deg clss - where deg = toDegree (undefined :: deg) - clss = toClass (undefined :: clss) - - -pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord key deg clss (Su n)) --- Do not parse Imp degrees -pChord (Note _ Imp) _clss = empty --- General case -pChord deg clss = setStatus <$> pSatisfy recognize insertion where - recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss' - setStatus (ChordToken r t l NotParsed n d) - = Surface_Chord (ChordToken r t l Parsed n d) - setStatus c = Surface_Chord c - insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5 - --------------------------------------------------------------------------------- --- The non-generic part of the GTree wrapper --------------------------------------------------------------------------------- -toGTree :: (GetDegree a, GTree a) => - (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn] -toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) - (gTree deg) Nothing] - --- create a branching Tree HAn -toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) => - (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn] -toGTreeSplit con vof deg - = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg - --- Ad-Hoc case for Piece -instance GTree (Piece key) where -- we take the children to skip a "list node" - gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing] - --- Ad-hoc cases for Base_SD -instance GTree (Base_SD key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GTree (Base_SD key (VDom deg) DomClass n) - , GTree (Base_SD key (DiatV deg) MinClass n) - , GTree (Base_SD key (DiatVM deg) MajClass n) - , GTree (Base_SD key (VMin deg) MinClass n) - , GTree (Base_SD key deg clss n) - , GTree (Base_Final key deg clss n) - ) => GTree (Base_SD key deg clss (Su n)) where - gTree (Base_SD d) = gTree d - gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d - gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d - gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d - gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d - --- Ad-hoc cases for Base_Final -instance GTree (Base_Final key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GetDegree (Base_Final key (Tritone deg) DomClass n) - , GetDegree (Base_Final key (IIbDim deg) DimClass n) - , GTree (FinalDimTrans key deg clss) - , GTree (Base_Final key (Tritone deg) DomClass n) - , GTree (Base_Final key (IIbDim deg) DimClass n) - ) => GTree (Base_Final key deg clss (Su n)) where - gTree (Base_Final d) = gTree d - -- The tritone substitution of a relative V is as alsway one semitone above - -- the chord it is preceding - gTree (Final_Tritone d) = toGTree Trit 6 d - gTree (Final_Dim_V d) = toGTree DimTrit 11 d - --- Ad-hoc cases for Surface_Chord -instance GTree (Surface_Chord key deg clss Ze) where - gTree _ = error "gTree: impossible?" - -instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) - , GTree (Surface_Chord key (MinThird deg) DimClass n) - ) => GTree (Surface_Chord key deg clss (Su n)) where - gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing] - gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print? - --------------------------------------------------------------------------------- --- Ad hoc getDegree instaces --------------------------------------------------------------------------------- -toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree -toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t) - -toSDVal :: (GetDegree a) => a -> ScaleDegree -toSDVal d = let (a,i) = getDeg d in transposeSem a i - --- Given a degree getDegee ensures that all information about the internal --- structure of a scale degree,i.e. the degree and the an int value representing --- the transposition of that degree at the current level, is available. -class GetDegree a where - getDeg :: a -> (ScaleDegree, Int) - -instance GetDegree (Base_SD key deg clss n) where - getDeg (Base_SD d) = getDeg d - getDeg (Cons_Vdom _ d) = getDeg d - getDeg (Cons_Diat _ d) = getDeg d - getDeg (Cons_DiatM _ d) = getDeg d - getDeg (Cons_DiatM' _ d) = getDeg d - getDeg (Cons_Vmin _ d) = getDeg d - -instance ( GetDegree (Base_Final key deg clss Ze)) where - getDeg = error "getDegree: impossible?" -instance GetDegree (Base_Final key deg clss n) where - getDeg (Base_Final d) = getDeg d - -- The tritone substitution of a relative V is as always one semitone above - -- the chord it is preceding - getDeg (Final_Tritone d) = second (+6) (getDeg d) - getDeg (Final_Dim_V d) = second (+1) (getDeg d) - -instance ( GetDegree (Surface_Chord key deg clss Ze)) where - getDeg = error "getDegree: impossible?" - -instance ( GetDegree (Surface_Chord key (MinThird deg) DimClass n) - ) => GetDegree (Surface_Chord key deg clss (Su n)) where - getDeg (Surface_Chord (ChordToken d _cls _cs _stat _n _dur)) = (d,0) - getDeg (Dim_Chord_Trns d) = second (+9) (getDeg d) - --------------------------------------------------------------------------------- --- Instances of Representable for music datatypes --------------------------------------------------------------------------------- - -deriveAllL allTypes - -$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) - allTypes) - -$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) - allTypes) - --------------------------------------------------------------------------------- --- ChordToken as tokens --------------------------------------------------------------------------------- - -instance IsLocationUpdatedBy Int ChordToken where - advance p c = p + chordNumReps c +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE GADTs #-}++module HarmTrace.Models.Pop.Instances where++-- Generics stuff+import Generics.Instant.TH++-- Parser stuff+import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances++-- Music stuff+import HarmTrace.Models.Parser+import HarmTrace.Models.Pop.Model+import HarmTrace.HAnTree.Tree+import HarmTrace.HAnTree.ToHAnTree+import HarmTrace.HAnTree.HAn+import HarmTrace.Tokenizer.Tokens as CT+import HarmTrace.Base.TypeLevel+import HarmTrace.Base.MusicRep++-- Library modules+import Control.Arrow++--------------------------------------------------------------------------------+-- The non-generic part of the parser+--------------------------------------------------------------------------------++instance ParseG (Base_SD deg clss Ze) where parseG = empty+ +instance ( ToDegree (DiatV deg)+ , ToDegree (VDom deg)+ , ParseG (Base_SD (VDom deg) DomClass n)+ , ParseG (Base_SD (DiatV deg) MinClass n)+ , ParseG (Base_SD (DiatVM deg) MajClass n)+ , ParseG (Base_SD deg MinClass n)+ , ParseG (TritMinVSub deg MinClass ) + ) => ParseG (Base_SD 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 (VDom deg) DomClass n)+ , ParseG (Base_SD (DiatVM deg) MajClass n)+ , ParseG (Base_SD deg MajClass n)+ , ParseG (TritMinVSub deg MajClass )+ ) => ParseG (Base_SD deg MajClass (Su n)) where+ parseG = Base_SD <$> parseG+ <|> Cons_Vdom <$> parseG <*> parseG+ <|> Cons_DiatM <$> parseG <*> parseG + +instance ( ToDegree (VMin deg)+ , ToDegree (VDom deg)+ , ParseG (Base_SD (VDom deg) DomClass n)+ , ParseG (Base_SD (VMin deg) MinClass n)+ , ParseG (Base_SD deg DomClass n)+ , ParseG (TritMinVSub deg DomClass ) + ) => ParseG (Base_SD deg DomClass (Su n)) where+ parseG = Base_SD <$> parseG+ <|> Cons_Vdom <$> parseG <*> parseG+ <|> Cons_Vmin <$> parseG <*> parseG + +instance ( ToDegree (VDom deg)+ , ParseG (Base_SD (VDom deg) DomClass n)+ , ParseG (Base_SD deg DimClass n)+ , ParseG (TritMinVSub deg DimClass )+ ) => ParseG (Base_SD deg DimClass (Su n)) where+ parseG = Base_SD <$> parseG+ <|> Cons_Vdom <$> parseG <*> parseG++-- Ad-hoc cases for Base_Final+instance ParseG (Base_Final deg clss Ze) where parseG = empty++instance ( ParseG (FinalDimTrans deg clss)+ ) => ParseG (Base_Final deg clss (Su n)) where+ parseG = Base_Final <$> parseG+ +instance ( ParseG (FinalDimTrans deg DomClass)+ , ParseG (FinalDimTrans deg MinClass)+ , ParseG (Base_Final (Tritone deg) DomClass n)+ , ParseG (Base_Final (IIbDim deg) DimClass n)+ ) => ParseG (Base_Final 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 deg clss Ze) where parseG = empty++-- instance ( ToDegree deg + -- , ParseG (Surface_Chord (MinThird deg) DimClass n)+ -- ) => ParseG (Surface_Chord 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 deg clss (Su n)) where+ parseG = pChord deg clss+ where deg = toDegree (undefined :: deg)+ clss = toClass (undefined :: clss)+++pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss (Su n))+-- Do not parse Imp degrees+pChord (Note _ Imp) _clss = empty+-- General case+pChord deg clss = setStatus <$> pSatisfy recognize insertion where+ recognize (ChordToken deg' clss' _cs _st _n _d) = deg == deg' && clss == clss'+ setStatus (ChordToken r t l NotParsed n d) + = Surface_Chord (ChordToken r t l Parsed n d)+ setStatus c = Surface_Chord c+ insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5++--------------------------------------------------------------------------------+-- The non-generic part of the GTree wrapper+--------------------------------------------------------------------------------+toGTree :: (GetDegree a, GTree a) =>+ (Int -> ScaleDegree -> Trans) -> Int -> a -> [Tree HAn]+toGTree con transp deg = [Node (HAnTrans . con 1 $ toTransSDVal transp deg) + (gTree deg) Nothing]++-- create a branching Tree HAn+toGTreeSplit :: (GetDegree a, GetDegree b, GTree a, GTree b) =>+ (Int -> ScaleDegree -> Prep) -> b -> a -> [Tree HAn]+toGTreeSplit con vof deg + = Node (HAnPrep . con 1 $ toSDVal deg) (gTree vof) Nothing : gTree deg+ +-- Ad-Hoc case for Piece +instance GTree Piece 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 deg clss Ze) where+ gTree _ = error "gTree: impossible?"+ +instance ( GTree (Base_SD (VDom deg) DomClass n)+ , GTree (Base_SD (DiatV deg) MinClass n)+ , GTree (Base_SD (DiatVM deg) MajClass n)+ , GTree (Base_SD (VMin deg) MinClass n)+ , GTree (Base_SD deg clss n)+ , GTree (Base_Final deg clss n)+ ) => GTree (Base_SD deg clss (Su n)) where+ gTree (Base_SD d) = gTree d+ gTree (Cons_Vdom s d) = toGTreeSplit SecDom s d + gTree (Cons_Diat s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM s d) = toGTreeSplit DiatDom s d + gTree (Cons_DiatM' s d) = toGTreeSplit DiatDom s d + gTree (Cons_Vmin s d) = toGTreeSplit SecMin s d ++-- Ad-hoc cases for Base_Final+instance GTree (Base_Final deg clss Ze) where+ gTree _ = error "gTree: impossible?"++instance ( GetDegree (Base_Final (Tritone deg) DomClass n)+ , GetDegree (Base_Final (IIbDim deg) DimClass n)+ , GTree (FinalDimTrans deg clss)+ , GTree (Base_Final (Tritone deg) DomClass n)+ , GTree (Base_Final (IIbDim deg) DimClass n)+ ) => GTree (Base_Final deg clss (Su n)) where+ gTree (Base_Final d) = gTree d+ -- The tritone substitution of a relative V is as alsway one semitone above+ -- the chord it is preceding+ gTree (Final_Tritone d) = toGTree Trit 6 d + gTree (Final_Dim_V d) = toGTree DimTrit 11 d ++-- Ad-hoc cases for Surface_Chord+instance GTree (Surface_Chord deg clss Ze) where+ gTree _ = error "gTree: impossible?"+ +instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n)+ , GTree (Surface_Chord (MinThird deg) DimClass n)+ ) => GTree (Surface_Chord deg clss (Su n)) where+ gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing]+ -- gTree (Dim_Chord_Trns c) = toGTree DimTrans 9 c -- pretty print?+ +--------------------------------------------------------------------------------+-- Ad hoc getDegree instaces+-------------------------------------------------------------------------------- +toTransSDVal :: (GetDegree a) => Int -> a -> ScaleDegree+toTransSDVal t d = let (a,i) = getDeg d in transposeSem a (i+t)++toSDVal :: (GetDegree a) => a -> ScaleDegree+toSDVal d = let (a,i) = getDeg d in transposeSem a i++-- Given a degree getDegee ensures that all information about the internal+-- structure of a scale degree,i.e. the degree and the an int value representing+-- the transposition of that degree at the current level, is available.+class GetDegree a where+ getDeg :: a -> (ScaleDegree, Int) ++instance GetDegree (Base_SD deg clss n) where+ getDeg (Base_SD d) = getDeg d+ getDeg (Cons_Vdom _ d) = getDeg d + getDeg (Cons_Diat _ d) = getDeg d + getDeg (Cons_DiatM _ d) = getDeg d + getDeg (Cons_DiatM' _ d) = getDeg d + getDeg (Cons_Vmin _ d) = getDeg d ++instance ( GetDegree (Base_Final deg clss Ze)) where + getDeg = error "getDegree: impossible?"+instance GetDegree (Base_Final deg clss n) where+ getDeg (Base_Final d) = getDeg d+ -- The tritone substitution of a relative V is as always one semitone above+ -- the chord it is preceding+ getDeg (Final_Tritone d) = second (+6) (getDeg d)+ getDeg (Final_Dim_V d) = second (+1) (getDeg d)++instance ( GetDegree (Surface_Chord deg clss Ze)) where + getDeg = error "getDegree: impossible?"+ +instance ( GetDegree (Surface_Chord (MinThird deg) DimClass n)+ ) => GetDegree (Surface_Chord 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/Models/Pop/Main.hs view
@@ -1,31 +1,29 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HarmTrace.Models.Pop.Main ( - pPop - , module HarmTrace.Models.Pop.Model - ) where - --- Parser stuff -import Text.ParserCombinators.UU - --- Music stuff -import HarmTrace.Base.MusicRep -import HarmTrace.Models.Parser -import HarmTrace.Models.Pop.Model hiding (PD,PT) - -import HarmTrace.Models.Pop.Instances () - - --------------------------------------------------------------------------------- --- From tokens to structured music pieces --------------------------------------------------------------------------------- - -pPieceMaj, pPieceMin :: forall key. PMusic [Piece key] -pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase key MajMode]) -pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase key MinMode]) - -pPop :: forall key. Key -> PMusic [Piece key] -pPop (Key _ MajMode) = pPieceMaj -pPop (Key _ MinMode) = pPieceMin - ++module HarmTrace.Models.Pop.Main ( + pPop+ , module HarmTrace.Models.Pop.Model+ ) where++-- Parser stuff+import Text.ParserCombinators.UU++-- Music stuff+import HarmTrace.Base.MusicRep+import HarmTrace.Models.Parser+import HarmTrace.Models.Pop.Model hiding (PD,PT)++import HarmTrace.Models.Pop.Instances ()+++--------------------------------------------------------------------------------+-- From tokens to structured music pieces+--------------------------------------------------------------------------------++pPieceMaj, pPieceMin :: PMusic [Piece]+pPieceMaj = map Piece <$> amb (parseG :: PMusic [Phrase MajMode])+pPieceMin = map Piece <$> amb (parseG :: PMusic [Phrase MinMode])++pPop :: Key -> PMusic [Piece]+pPop (Key _ MajMode) = pPieceMaj+pPop (Key _ MinMode) = pPieceMin+
src/HarmTrace/Models/Pop/Model.hs view
@@ -1,407 +1,412 @@-{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Models.Pop.Model where - -import HarmTrace.Base.TypeLevel - -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens -import Language.Haskell.TH.Syntax (Name) - --------------------------------------------------------------------------------- --- Musical structure as a datatype --------------------------------------------------------------------------------- - --- perhaps this module should be named differently, like Model or HarmonyModel - -data MajMode -data MinMode - --- High level structure --- 'key' is not used yet -data Piece key = forall mode. Piece [Phrase key mode] - --- The Phrase level -data Phrase key mode where - PT :: Ton key mode -> Phrase key mode - PD :: Dom key mode -> Phrase key mode - --- Harmonic categories --- Tonic -data Ton key mode where - -- major mode - T_1 :: Final key I MajClass -> Ton key MajMode - T_2 :: Final key I MajClass -> Final key IV MajClass - -> Final key I MajClass -> Ton key MajMode - -- T_3 :: Final key I MajClass -> Final key I DimClass - -- -> Final key I MajClass -> Ton key MajMode - -- blues - -- T_4_bls :: Final key I DomClass -> Ton key mode - - -- T_5_par :: Final key III MinClass -> Ton key MajMode - T_6_bor :: TMinBorrow key -> Ton key MajMode - - -- minor mode - Tm_1 :: SD key MinMode I MinClass -> Ton key MinMode - Tm_2 :: Final key I MinClass -> Final key IV MinClass - -> Final key I MinClass -> Ton key MinMode - Tm_3 :: Final key I MinClass -> Final key IV MinClass - -> Final key I MinClass -> Ton key MinMode - -- Tm_4_par :: Final key IIIb MajClass -> Ton key MinMode - Tm_6_bor :: TMajBorrow key -> Ton key MinMode -- picardy third etc. - --- Dominant -data Dom key mode where - -- major mode - D_1 :: SDom key mode -> Dom key mode -> Dom key mode - D_2 :: SD key mode V DomClass -> Dom key mode - -- I would like to model this with a SD VIs dimClass, but somehow, - -- this causes a ToDegree loop - -- D_3 :: SD key mode IIIb DimClass -> - -- Final key V DomClass -> Dom key mode -- not in CMJ - D_4 :: SD key mode V MajClass -> Dom key mode - -- D_5 :: Final key V DomClass -> Final key V DimClass - -- -> Final key V DomClass -> Dom key mode - -- D_6 :: Final key VII DimClass -> Dom key MajMode - D_7 :: SD key MajMode VII MinClass -> Dom key MajMode - -- moll-dur: minor mode borrowings in major - -- This would be an elegant way of defining major minor borrowing, - -- but it causes a lot of unwanted abmiguities since all the mode - -- rules can be explained with and without borrowing - -- D_9_bor :: Dom key MinMode -> Dom key MajMode - D_8_bor :: DMinBorrow key -> Dom key MajMode - - -- minor mode (there must be at least one rule with "MinMode" otherwise - -- no you get a "No instance for (ParseG (Dom key MinMode))" error - Dm_1 :: SD key MinMode VIIb MajClass -> Dom key MinMode - Dm_2_bor :: DMajBorrow key -> Dom key MinMode - --- Subdominant -data SDom key mode where - S_1_par :: SD key mode II MinClass -> SDom key mode -- sub dom parallel - -- S_2_bls :: SD key mode IV DomClass -> SD key mode I DomClass - -- -> SDom key mode - -- Pretty printing? this rule compensates for the V/I Imp - -- to be able to parse D:7 D:min G:7 C:maj (not in cmj) - S_3_par :: SD key mode II DomClass -> Final key II MinClass - -> SDom key mode - S_4 :: SD key MajMode IV MajClass -> SDom key MajMode - S_5 :: SD key MajMode III MinClass -> Final key IV MajClass - -> SDom key MajMode - -- S_6_par :: SD key MajMode VI MinClass -> SDom key MajMode - - -- Borrowing from minor in a major mode - -- S_7_bor :: SDom key MajMode -> SDom key MinMode - S_7_bor :: SMinBorrow key -> SDom key MajMode - - -- minor mode - Sm_1 :: SD key MinMode IV MinClass -> SDom key MinMode - Sm_2 :: SD key MinMode IIIb MajClass -> Final key IV MinClass - -> SDom key MinMode - -- Sm_3_par :: SD key MinMode VIb MajClass -> SDom key MinMode - -- perhaps add a functional node for Neapolitan chords? - Sm_4 :: SD key MinMode IIb MajClass -> SDom key MinMode -- Neapolitan - Sm_5_bor :: SMajBorrow key -> SDom key MinMode - --- Borrowings from minor in a major key -data TMinBorrow key = Tm_20_bor (SD key MinMode IIIb MajClass) - -data DMinBorrow key = Dm_20_bor (SD key MinMode VIIb MajClass) - -- | Dm_21_bor (Final key VIIb DomClass) - -data SMinBorrow key = Sm_20_bor (SD key MinMode IV MinClass) - -- | Sm_21_bor (SD key MinMode VIb MajClass) - | Sm_22_bor (SD key MinMode IIb MajClass) -- Neapolitan - - --- Borrowings from major in a minor key -data TMajBorrow key = T_20_bor (SD key MajMode I MajClass) - | T_21_bor (SD key MajMode III MinClass) - -data DMajBorrow key = D_20_bor (SD key MajMode VII MinClass) - -- | D_21_bor (Final key VII DimClass) - -data SMajBorrow key = S_20_bor (SD key MajMode IV MajClass) - - --- Limit secondary dominants to a few levels -type SD key mode deg clss = Base_SD key deg clss T5 - --- a type that can be substituted by its tritone sub and diminished 7b9 -type TritMinVSub key deg clss = Base_Final key deg clss T2 - --- A Scale degree that can only translate to a surface chord --- and allows for the transformation into enharmonic equivalent --- diminshed surface chords -type FinalDimTrans key deg clss = Surface_Chord key deg clss T4 - --- A Scale degree that translates into a (non-tranformable) surface chord -type Final key deg clss = Surface_Chord key deg clss T1 - - --- Datatypes for clustering harmonic degrees --- type Base_SD key deg clss n = List (Base_SD' key deg clss n) T4 - -data Base_SD key deg clss n where - Base_SD :: TritMinVSub key deg clss -- Min5 key deg clss n - -> Base_SD key deg clss (Su n) - -- Rule for explaining perfect secondary dominants - Cons_Vdom :: Base_SD key (VDom deg) DomClass n -> Base_SD key deg clss n - -> Base_SD key deg clss (Su n) - Cons_Diat :: Base_SD key (DiatV deg) MinClass n -> Base_SD key deg MinClass n - -> Base_SD key deg MinClass (Su n) - Cons_DiatM :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MajClass n - -> Base_SD key deg MajClass (Su n) - Cons_DiatM' :: Base_SD key (DiatVM deg) MajClass n -> Base_SD key deg MinClass n - -> Base_SD key deg MinClass (Su n) - -- Minor fifth insertion - Cons_Vmin :: Base_SD key (VMin deg) MinClass n -> Base_SD key deg DomClass n - -> Base_SD key deg DomClass (Su n) - - -data Base_Final key deg clss n where - -- Just a "normal", final degree. The Strings are the original input. - Base_Final :: FinalDimTrans key deg clss -> Base_Final key deg clss (Su n) - -- Tritone substitution - Final_Tritone :: Base_Final key (Tritone deg) DomClass n - -> Base_Final key deg DomClass (Su n) - Final_Dim_V :: Base_Final key (IIbDim deg) DimClass n - -> Base_Final key deg DomClass (Su n) - --- Dimished tritone substitution accounting for dimished chord transistions -data Surface_Chord key deg clss n where - Surface_Chord :: ChordToken - -> Surface_Chord key deg clss (Su n) - Dim_Chord_Trns :: Surface_Chord key (MinThird deg) DimClass n - -> Surface_Chord key deg DimClass (Su n) - --------------------------------------------------------------------------------- --- Type Level Scale Degrees --------------------------------------------------------------------------------- - --- typelevel chord classes -data MajClass -data MinClass -data DomClass -data DimClass - --- Degrees (at the type level) -data I -data Ib -data Is -data II -data IIb -data IIs -data III -data IIIb -data IIIs -data IV -data IVb -data IVs -data V -data Vb -data Vs -data VI -data VIb -data VIs -data VII -data VIIb -data VIIs - --- Used when we don't want to consider certain possibilities -data Imp - --- Degrees at the value level are in Tokenizer --- Type to value conversions -class ToClass clss where - toClass :: clss -> ClassType - -instance ToClass MajClass where toClass _ = MajClass -instance ToClass MinClass where toClass _ = MinClass -instance ToClass DomClass where toClass _ = DomClass -instance ToClass DimClass where toClass _ = DimClass - --- The class doesn't really matter, since the degree will be impossible to parse -instance ToClass Imp where toClass _ = DimClass - -class ToDegree deg where - toDegree :: deg -> ScaleDegree - -instance ToDegree I where toDegree _ = Note Nothing I -instance ToDegree II where toDegree _ = Note Nothing II -instance ToDegree III where toDegree _ = Note Nothing III -instance ToDegree IV where toDegree _ = Note Nothing IV -instance ToDegree V where toDegree _ = Note Nothing V -instance ToDegree VI where toDegree _ = Note Nothing VI -instance ToDegree VII where toDegree _ = Note Nothing VII -instance ToDegree Ib where toDegree _ = Note (Just Fl) I -instance ToDegree IIb where toDegree _ = Note (Just Fl) II -instance ToDegree IIIb where toDegree _ = Note (Just Fl) III -instance ToDegree IVb where toDegree _ = Note (Just Fl) IV -instance ToDegree Vb where toDegree _ = Note (Just Fl) V -instance ToDegree VIb where toDegree _ = Note (Just Fl) VI -instance ToDegree VIIb where toDegree _ = Note (Just Fl) VII -instance ToDegree IIs where toDegree _ = Note (Just Sh) II -instance ToDegree IIIs where toDegree _ = Note (Just Sh) III -instance ToDegree IVs where toDegree _ = Note (Just Sh) IV -instance ToDegree Vs where toDegree _ = Note (Just Sh) V -instance ToDegree VIs where toDegree _ = Note (Just Sh) VI -instance ToDegree VIIs where toDegree _ = Note (Just Sh) VII - --- Can't ever parse these -instance ToDegree Imp where toDegree _ = Note Nothing Imp - - --------------------------------------------------------------------------------- --- Type Families for Relative Scale Degrees --------------------------------------------------------------------------------- - - --- Diatonic fifths, and their class (comments with the CMaj scale) --- See http://en.wikipedia.org/wiki/Circle_progression -type family DiatV deg :: * -type instance DiatV I = Imp -- V -- G7 should be Dom -type instance DiatV V = Imp -- II -- Dm7 should be SDom -type instance DiatV II = VI -- Am7 -type instance DiatV VI = III -- Em7 -type instance DiatV III = VII -- Bhdim7 can be explained by Dim rule -type instance DiatV VII = Imp -- IV -- FMaj7 should be SDom -type instance DiatV IV = Imp -- I -- CMaj7 - -type instance DiatV IIb = Imp -type instance DiatV IIIb = Imp -type instance DiatV IVs = Imp -type instance DiatV VIb = Imp -type instance DiatV VIIb = Imp -type instance DiatV Imp = Imp - -type family DiatVM deg :: * -type instance DiatVM I = Imp -- V -- G7 should be Dom -type instance DiatVM V = Imp -- Dm7 should be SDom -type instance DiatVM II = VIb -- Ab -type instance DiatVM VI = Imp -- Em7 -type instance DiatVM III = Imp -- Bhdim7 can be explained by Dim rule -type instance DiatVM VII = Imp -- IV -- FMaj7 should be SDom -type instance DiatVM IV = Imp -- I -- CMaj7 - -type instance DiatVM IIb = Imp -type instance DiatVM IIIb = VIIb -type instance DiatVM IVs = Imp -type instance DiatVM VIb = IIIb -type instance DiatVM VIIb = Imp -type instance DiatVM Imp = Imp - --------------------------------------------------------------------------------- --- Type families for secondary dominants --------------------------------------------------------------------------------- - --- Perfect fifths (class is always Dom) --- See http://en.wikipedia.org/wiki/Circle_of_fifths -type family VDom deg :: * - -type instance VDom I = Imp -- interferes with dom -type instance VDom IIb = VIb -type instance VDom II = VI -type instance VDom IIIb = VIIb -- interferes with Dm_3 -type instance VDom III = VII -type instance VDom IV = I -type instance VDom IVs = IIb -type instance VDom V = II -- interferes with Sm_1 -type instance VDom VIb = IIIb -type instance VDom VI = III -type instance VDom VIIb = IV -type instance VDom VII = IVs -type instance VDom Imp = Imp - --- Perfect fifths for the minor case (this is an additional --- type family to controll the reduction of ambiguities --- specifically in the minor case) -type family VMin deg :: * -type instance VMin I = V -type instance VMin IIb = VIb -type instance VMin II = VI -- interferes with sub -type instance VMin IIIb = VIIb -type instance VMin III = VII -type instance VMin IV = I -type instance VMin IVs = IIb -type instance VMin V = Imp -- II interferes with sub -type instance VMin VIb = IIIb -type instance VMin VI = III -type instance VMin VIIb = Imp --IV -- inteferes with sub IV:min -type instance VMin VII = IVs -type instance VMin Imp = Imp - --- The tritone substitution --- See http://en.wikipedia.org/wiki/Tritone_substitution -type family Tritone deg :: * -type instance Tritone I = IVs -type instance Tritone IVs = I - -type instance Tritone IIb = V -- gives undesired (ambiguous results) as -type instance Tritone V = IIb -- Dom = IIb/I = IIbdim - -type instance Tritone II = VIb -- interferes IIbDim V -type instance Tritone VIb = II - -type instance Tritone IIIb = VI -type instance Tritone VI = IIIb - -type instance Tritone III = VIIb -- Interferes with VIIb from minor -type instance Tritone VIIb = III - -type instance Tritone IV = VII -type instance Tritone VII = IV - -type instance Tritone Imp = Imp - - --------------------------------------------------------------------------------- --- Type families for diminished chord transformations --------------------------------------------------------------------------------- - --- in combination with the secondary dominants and enharmonic equivalency --- these type families account for ascending dim chord progressions -type family IIbDim deg :: * -type instance IIbDim I = IIb -type instance IIbDim IIb = II -type instance IIbDim II = IIIb -type instance IIbDim IIIb = III -type instance IIbDim III = IV -type instance IIbDim IV = IVs -type instance IIbDim IVs = V -type instance IIbDim V = VIb -- interferes with dim tritone V/V -type instance IIbDim VIb = VI -type instance IIbDim VI = VIIb -type instance IIbDim VIIb = VII -type instance IIbDim VII = I -type instance IIbDim Imp = Imp - --- Dimchords can be transposed a minor third without changing their role, --- they are enharmonically equivalent. -type family MinThird deg :: * -type instance MinThird I = IIIb -type instance MinThird IIb = III -type instance MinThird II = IV -type instance MinThird IIIb = IVs -type instance MinThird III = V -type instance MinThird IV = VIb -type instance MinThird IVs = VI -type instance MinThird V = VIIb -type instance MinThird VIb = VII -type instance MinThird VI = I -type instance MinThird VIIb = IIb -type instance MinThird VII = II -type instance MinThird Imp = Imp - --- Belongs in Instances, but needs to be here due to staging restrictions -allTypes :: [Name] -allTypes = [ ''Phrase, ''Ton, ''Dom, ''SDom - , ''TMinBorrow, ''DMinBorrow, ''SMinBorrow - , ''TMajBorrow, ''DMajBorrow, ''SMajBorrow ] +{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}++module HarmTrace.Models.Pop.Model where++import HarmTrace.Base.TypeLevel++import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens+import Language.Haskell.TH.Syntax (Name)++--------------------------------------------------------------------------------+-- Musical structure as a datatype+--------------------------------------------------------------------------------++#ifndef NUMLEVELS+#define NUMLEVELS T5+#endif++-- perhaps this module should be named differently, like Model or HarmonyModel++data MajMode+data MinMode++-- High level structure+data Piece = forall mode. Piece [Phrase mode]++-- The Phrase level+data Phrase mode where+ PT :: Ton mode -> Phrase mode+ PD :: Dom mode -> Phrase mode++-- Harmonic categories+-- Tonic+data Ton mode where+ T_0 :: SDom mode -> Ton mode -> Ton mode+ -- major mode+ T_1 :: Final I MajClass -> Ton MajMode+ -- T_2 :: Final I MajClass -> Final IV MajClass + -- -> Final I MajClass -> Ton MajMode+ + -- blues + T_4_bls :: Final I DomClass -> Ton mode ++ T_3_par :: Final III MinClass -> Ton MajMode + T_6_bor :: TMinBorrow -> Ton MajMode++ -- minor mode + Tm_1 :: SD MinMode I MinClass -> Ton MinMode+ -- Tm_2 :: Final I MinClass -> Final IV MinClass+ -- -> Final I MinClass -> Ton MinMode ++ Tm_3_par :: Final IIIb MajClass -> Ton MinMode + Tm_6_bor :: TMajBorrow -> Ton MinMode -- picardy third etc. ++-- Dominant+data Dom mode where+ -- major mode+ D_1 :: SDom mode -> Dom mode -> Dom mode+ D_2 :: SD mode V DomClass -> Dom mode+ D_3 :: SD mode V MajClass -> Dom mode++ D_4 :: SD MajMode VII MinClass -> Dom 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 MinMode -> Dom MajMode+ D_8_bor :: DMinBorrow -> Dom MajMode+ + -- minor mode (there must be at least one rule with "MinMode" otherwise+ -- no you get a "No instance for (ParseG (Dom MinMode))" error+ Dm_4 :: SD MinMode VIIb MajClass -> Dom MinMode+ Dm_8_bor :: DMajBorrow -> Dom MinMode++-- Subdominant+data SDom mode where+ S_1_par :: SD mode II MinClass -> SDom mode -- sub dom parallel++ -- Pretty printing? this rule compensates for the V/I Imp+ -- to be able to parse D:7 D:min G:7 C:maj (not in cmj)+ S_2_par :: SD mode II DomClass -> Final II MinClass+ -> SDom mode + S_3 :: SD MajMode IV MajClass -> SDom MajMode+ -- blues+ S_3_bls :: Final IV DomClass -> SDom mode+ S_4 :: SD MajMode III MinClass -> Final IV MajClass+ -> SDom MajMode+ S_7 :: SD MajMode III MinClass -> Final II MinClass+ -> SDom MajMode+ S_5_par :: SD MajMode VI MinClass -> SDom MajMode++ -- Borrowing from minor in a major mode+ -- S_7_bor :: SDom MajMode -> SDom MinMode+ S_9_bor :: SMinBorrow -> SDom MajMode + + -- minor mode+ Sm_3 :: SD MinMode IV MinClass -> SDom MinMode+ Sm_4 :: SD MinMode IIIb MajClass -> Final IV MinClass + -> SDom MinMode+ Sm_7 :: SD MinMode IIIb MajClass -> Final II MinClass+ -> SDom MinMode + Sm_5_par :: SD MinMode VIb MajClass -> SDom MinMode+ + Sm_9_bor :: SMajBorrow -> SDom MinMode ++ -- perhaps add a functional node for Neapolitan chords?+ Sm_6 :: SD MinMode IIb MajClass -> SDom MinMode -- Neapolitan+ +-- Borrowings from minor in a major key+data TMinBorrow = Tm_21_bor (SD MinMode I MinClass) + | Tm_23_bor (SD MinMode IIIb MajClass) ++data DMinBorrow = Dm_24_bor (SD MinMode VIIb MajClass) + -- | Dm_21_bor (Final VIIb DomClass) + +data SMinBorrow = Sm_20_bor (SD MinMode IV MinClass) + -- | Sm_21_bor (SD MinMode VIb MajClass)+ | Sm_22_bor (SD MinMode IIb MajClass) -- Neapolitan ++-- Borrowings from major in a minor key+data TMajBorrow = T_21_bor (SD MajMode I MajClass)+ | T_23_bor (SD MajMode III MinClass)++data DMajBorrow = D_24_bor (SD MajMode VII MinClass) + -- | D_21_bor (Final VII DimClass)+ +data SMajBorrow = S_20_bor (SD MajMode IV MajClass) + + +-- Limit secondary dominants to a few levels+type SD mode deg clss = Base_SD deg clss NUMLEVELS++-- a type that can be substituted by its tritone sub and diminished 7b9+type TritMinVSub deg clss = Base_Final 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 deg clss = Surface_Chord deg clss T4++-- A Scale degree that translates into a (non-tranformable) surface chord+type Final deg clss = Surface_Chord deg clss T1+++-- Datatypes for clustering harmonic degrees+-- type Base_SD deg clss n = List (Base_SD' deg clss n) T4++data Base_SD deg clss n where+ Base_SD :: TritMinVSub deg clss -- Min5 deg clss n+ -> Base_SD deg clss (Su n) + -- Rule for explaining perfect secondary dominants+ Cons_Vdom :: Base_SD (VDom deg) DomClass n -> Base_SD deg clss n+ -> Base_SD deg clss (Su n)+ Cons_Diat :: Base_SD (DiatV deg) MinClass n -> Base_SD deg MinClass n+ -> Base_SD deg MinClass (Su n)+ Cons_DiatM :: Base_SD (DiatVM deg) MajClass n -> Base_SD deg MajClass n+ -> Base_SD deg MajClass (Su n)+ Cons_DiatM' :: Base_SD (DiatVM deg) MajClass n -> Base_SD deg MinClass n+ -> Base_SD deg MinClass (Su n)+ -- Minor fifth insertion+ Cons_Vmin :: Base_SD (VMin deg) MinClass n -> Base_SD deg DomClass n+ -> Base_SD deg DomClass (Su n)++ +data Base_Final deg clss n where+ -- Just a "normal", final degree. The Strings are the original input.+ Base_Final :: FinalDimTrans deg clss -> Base_Final deg clss (Su n)+ -- Tritone substitution+ Final_Tritone :: Base_Final (Tritone deg) DomClass n+ -> Base_Final deg DomClass (Su n)+ Final_Dim_V :: Base_Final (IIbDim deg) DimClass n+ -> Base_Final deg DomClass (Su n) ++-- Dimished tritone substitution accounting for dimished chord transistions+data Surface_Chord deg clss n where+ Surface_Chord :: ChordToken + -> Surface_Chord deg clss (Su n)+ -- Dim_Chord_Trns :: Surface_Chord (MinThird deg) DimClass n+ -- -> Surface_Chord 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 = Imp -- 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 = Imp -- 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 -- Imp -- interferes with S_bls VI7 -> I7+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/Models/Test/Instances.hs
@@ -1,66 +0,0 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Models.Test.Instances where - --- Generics stuff -import Generics.Instant.TH - --- Parser stuff -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances hiding (Inserted) - --- GTree stuff -import HarmTrace.HAnTree.Tree -import HarmTrace.HAnTree.ToHAnTree - --- Music stuff -import HarmTrace.Base.MusicRep -import HarmTrace.Models.Parser -import HarmTrace.Models.Test.Model -import HarmTrace.Tokenizer.Tokens - - --- A very, very permissive model. -instance ParseG NoteTest where - parseG = NoteTest <$> pSatisfy recognize insertion where - recognize = const True - insertion = Insertion "ChordToken" - (ChordToken (Note Nothing I) MajClass [] Inserted 1 0) 5 - - -instance GTree PieceTest where - gTree (PieceTest ns) = [Node (HAn 0 "Pie") (gTree ns) Nothing] - -instance GTree NoteTest where - gTree (NoteTest c) = [Node (HAnChord c) [] Nothing] - --------------------------------------------------------------------------------- --- Instances of Representable for music datatypes --------------------------------------------------------------------------------- - -deriveAllL allTypes - -$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault) - allTypes) -{- -$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault) - allTypes) --} --------------------------------------------------------------------------------- --- ChordToken as tokens --------------------------------------------------------------------------------- - -instance IsLocationUpdatedBy Int ChordToken where - advance p c = p + chordNumReps c
− src/HarmTrace/Models/Test/Main.hs
@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HarmTrace.Models.Test.Main ( - pPieceTest - , module HarmTrace.Models.Test.Model - ) where - --- Music stuff -import HarmTrace.Models.Parser -import HarmTrace.Models.Test.Model - -import HarmTrace.Models.Test.Instances () - - --------------------------------------------------------------------------------- --- From tokens to structured music pieces --------------------------------------------------------------------------------- - -pPieceTest :: PMusic [PieceTest] -pPieceTest = parseG
− src/HarmTrace/Models/Test/Model.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - -module HarmTrace.Models.Test.Model where - -import Language.Haskell.TH.Syntax (Name) -import HarmTrace.Tokenizer.Tokens - - -data PieceTest = PieceTest [NoteTest] - -data NoteTest = NoteTest ChordToken - --- Belongs in Instances, but needs to be here due to staging restrictions -allTypes :: [Name] -allTypes = [ ''PieceTest ]
src/HarmTrace/Tokenizer/Tokenizer.hs view
@@ -1,156 +1,157 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -module HarmTrace.Tokenizer.Tokenizer ( parseChordTokens {-not used yet-} - , parseSongAbs, toKeyRelTok) where - -import HarmTrace.Base.Parsing -import HarmTrace.Base.MusicRep -import HarmTrace.Tokenizer.Tokens - -import Data.Maybe - --------------------------------------------------------------------------------- --- Tokenizing: parsing strings into tokens --------------------------------------------------------------------------------- - --- toplevel parser: parses a string of chord labels into a key relative --- representation -parseChordTokens :: ListLike s Char => s -> (PieceLabel ,[Error LineColPos]) -parseChordTokens inp = parseDataWithErrors parseSongAbs inp - --- Merges duplicate chords and transforms absolute chord labels into key --- relative tokens that can be parsed by the HarmTrace model --- (previously called mergeDups) -toKeyRelTok :: Key -> [ChordLabel] -> [ChordToken] -toKeyRelTok k (c@(Chord r sh _add _loc d):cs) = toKeyRelTok' k - (ChordToken (toScaleDegree k r) (toClassType sh) [c] NotParsed 1 d) cs -toKeyRelTok _key [] = [] -toKeyRelTok' :: Key -> ChordToken -> [ChordLabel] -> [ChordToken] -toKeyRelTok' _k p [] = [p] -toKeyRelTok' k p@(ChordToken deg clss cs' _stat n d1) (c@(Chord r sh _a _l d2):cs) - | deg == deg2 && clss == clss2 = - toKeyRelTok' k (ChordToken deg clss (cs' ++ [c]) NotParsed (n+1) (d1+d2)) cs - | otherwise = p : toKeyRelTok' k (ChordToken deg2 clss2 [c] NotParsed 1 d2) cs - where clss2 = toClassType sh - deg2 = toScaleDegree k r - --- Input is a string of whitespace-separated chords, e.g. --- Bb:9(s11) E:min7 Eb:min7 Ab:7 D:min7 G:7(13) C:maj6(9) --- First token is the key of the piece -parseSongAbs :: Parser PieceLabel -- PieceRelToken -- -parseSongAbs = PieceLabel <$> 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" +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++module HarmTrace.Tokenizer.Tokenizer ( parseChordTokens {-not used yet-}+ , parseSongAbs, toKeyRelTok+ , parseDegrees, parseDegree ) where++import HarmTrace.Base.Parsing+import HarmTrace.Base.MusicRep+import HarmTrace.Tokenizer.Tokens++import Data.Maybe++--------------------------------------------------------------------------------+-- Tokenizing: parsing strings into tokens+-------------------------------------------------------------------------------- ++-- toplevel parser: parses a string of chord labels into a key relative +-- representation+parseChordTokens :: ListLike s Char => s -> (PieceLabel ,[Error LineColPos])+parseChordTokens inp = parseDataWithErrors parseSongAbs inp+ +-- Merges duplicate chords and transforms absolute chord labels into key+-- relative tokens that can be parsed by the HarmTrace model +-- (previously called mergeDups)+toKeyRelTok :: Key -> [ChordLabel] -> [ChordToken]+toKeyRelTok k (c@(Chord r sh _add _loc d):cs) = toKeyRelTok' k + (ChordToken (toScaleDegree k r) (toClassType sh) [c] NotParsed 1 d) cs+toKeyRelTok _key [] = []+toKeyRelTok' :: Key -> ChordToken -> [ChordLabel] -> [ChordToken]+toKeyRelTok' _k p [] = [p]+toKeyRelTok' k p@(ChordToken deg clss cs' _stat n d1) (c@(Chord r sh _a _l d2):cs) + | deg == deg2 && clss == clss2 = + toKeyRelTok' k (ChordToken deg clss (cs' ++ [c]) NotParsed (n+1) (d1+d2)) cs+ | otherwise = p : toKeyRelTok' k (ChordToken deg2 clss2 [c] NotParsed 1 d2) cs+ where clss2 = toClassType sh+ deg2 = toScaleDegree k r++-- Input is a string of whitespace-separated chords, e.g.+-- Bb:9(s11) E:min7 Eb:min7 Ab:7 D:min7 G:7(13) C:maj6(9)+-- First token is the key of the piece+parseSongAbs :: Parser PieceLabel -- PieceRelToken -- +parseSongAbs = PieceLabel <$> 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
@@ -1,65 +1,65 @@-{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceLabel (..) - , 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 = PieceToken Key [ChordToken] -data PieceLabel = PieceLabel Key [ChordLabel] - --------------------------------------------------------------------------------- --- 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 +{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceLabel (..)+ , 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 = PieceToken Key [ChordToken]+data PieceLabel = PieceLabel Key [ChordLabel]++--------------------------------------------------------------------------------+-- 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
src/Main.hs view
@@ -1,217 +1,319 @@-{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE FlexibleInstances #-} - -module Main where - --- Libs -import System.Console.ParseArgs hiding (args) - --- Music stuff -import HarmTrace.HarmTrace -import HarmTrace.IO.Main -import HarmTrace.IO.Errors -import HarmTrace.IO.PrintTree -import HarmTrace.HAnTree.ToHAnTree (gTreeHead) ---import HarmTrace.Matching.GuptaNishimuraEditMatch -import HarmTrace.Matching.Standard --- import HarmTrace.Matching.Matching (printBPM) -import HarmTrace.Matching.Alignment (getAlignDist, alignChordLab, pPrintV, alignHAnChord) --- import HarmTrace.Matching.Sim (maxSim) -import Data.List (delete) - - --------------------------------------------------------------------------------- --- Command-line arguments --------------------------------------------------------------------------------- - -data MyArgs = SourceInputString | SourceInputFile | TargetInputFile - | InputDir | OpMode | Print | MaxErrorRate | BinaryOut | BinaryIn - | PrintIns | Grammar - deriving (Eq, Ord, Show) - -myArgs :: [Arg MyArgs] -myArgs = [ - Arg { argIndex = MaxErrorRate, - argAbbr = Just 'e', - argName = Just "max-error", - argData = argDataOptional "float" ArgtypeFloat, - argDesc = "Ignore pieces with higher error rate for diff" - }, - Arg { argIndex = SourceInputString, - argAbbr = Just 'c', - argName = Just "chords", - argData = argDataOptional "string" ArgtypeString, - argDesc = "Input Chord Sequence to parse" - }, - Arg { argIndex = SourceInputFile, - argAbbr = Just '1', - argName = Just "sfile", - argData = argDataOptional "filepath" ArgtypeString, - argDesc = "Input file (source for diff)" - }, - Arg { argIndex = TargetInputFile, - argAbbr = Just '2', - argName = Just "tfile", - argData = argDataOptional "filepath" ArgtypeString, - argDesc = "Input file (target for diff)" - }, - Arg { argIndex = InputDir, - argAbbr = Just 'd', - argName = Just "dir", - argData = argDataOptional "directory" ArgtypeString, - argDesc = "Input directory (process all files within)" - }, - Arg { argIndex = OpMode, - argAbbr = Just 'm', - argName = Just "mode", - argData = argDataRequired "string" ArgtypeString, - argDesc = "Matching mode (parse|stdiff|lces|hanlign|align)" - }, - Arg { argIndex = Grammar, - argAbbr = Just 'g', - argName = Just "grammar", - argData = argDataRequired "string" ArgtypeString, - argDesc = "Grammar to use (jazz|test|pop)" - }, - Arg { argIndex = Print, - argAbbr = Just 'p', - argName = Just "print", - argData = Nothing, - argDesc = "Set this flag to print a .png of the parse" - }, - Arg { argIndex = PrintIns, - argAbbr = Just 's', - argName = Just "print-insertions", - argData = Nothing, - argDesc = "Set this flag to show inserted nodes" - }, - Arg { argIndex = BinaryOut, - argAbbr = Just 'o', - argName = Just "out", - argData = argDataOptional "filepath" ArgtypeString, - argDesc = "Output binary file for parsing results" - }, - Arg { argIndex = BinaryIn, - argAbbr = Just 'i', - argName = Just "in", - argData = argDataOptional "filepath" ArgtypeString, - argDesc = "Input binary file for matching" - } - ] - --------------------------------------------------------------------------------- --- Main --------------------------------------------------------------------------------- - --- by default all post processing operations are executed -defaultOpts :: [PPOption] -defaultOpts = [ RemovePDPT , RemoveInsertions - , MergeDelChords, ExpandChordDurations ] - -err1, err2, err3 :: String -err1 = "Use a source file, or a directory." -err2 = "Use a source file and a target file, or a directory." -err3 = "Use a source file and optionally a target file." - -main :: IO () -main = do args <- parseArgsIO ArgsComplete myArgs - let mode = getRequiredArg args OpMode - grmS = getRequiredArg args Grammar - prnt = gotArg args Print - opts = if gotArg args PrintIns - then delete RemoveInsertions defaultOpts else defaultOpts - gram = case grmS of - "jazz" -> GrammarEx Jazz - "pop" -> GrammarEx Pop - "test" -> GrammarEx Test - s -> usageError args ("Unknown grammar: " ++ s) - case mode of - "parse" -> mainParse args opts prnt gram - "stdiff" -> mainMatch args opts False STDiff gram - "hanlign"-> mainMatch args opts prnt HAnAlign gram - "lces" -> mainMatch args opts prnt LCES gram - "align" -> mainMatch args opts prnt Align gram - s -> usageError args ("Unknown mode: " ++ s) - - -mainParse :: Args MyArgs -> [PPOption] -> Bool -> GrammarEx -> IO () -mainParse args o p (GrammarEx g) = - do let cStr = getArgString args SourceInputString - mf1 = getArgString args SourceInputFile - mf2 = getArgString args TargetInputFile - bOut = getArgString args BinaryOut - mdir = getArgString args InputDir - case (cStr, mf1,mf2,mdir, p) of - -- parse a string of chords - (Just c, Nothing, Nothing, Nothing , False) -> - do pr <- parseTreeVerb g o c - mapM_ (print . gTreeHead) (parsedPiece pr) - -- and print a parsetree - (Just c, Nothing, Nothing, Nothing , True) -> - do pr <- parseTree g o c - let ts = map gTreeHead (parsedPiece pr) - _ <- printTreeHAn (pieceTreeHAn pr) (trimFilename ("pp" ++ c)) - printTreeHAnF ts (trimFilename c) >> return () - -- Parse one file, show full output - (Nothing, Just f1, Nothing, Nothing , False) -> - do pr <- readFile f1 >>= parseTreeVerb g o - print (pieceTreeHAn pr) - mapM_ (print . gTreeHead) (parsedPiece pr) - (Nothing, Just f1, Nothing, Nothing , True ) -> - --with post processing - do pr <- readFile f1 >>= parseTree g o - let ts = map gTreeHead (parsedPiece pr) - printTreeHAn (pieceTreeHAn pr) (f1 ++ ".postProc") >> return () - printTreeHAnF ts f1 >> return () - -- Parse all files in one dir, show condensed output - (Nothing, Nothing, Nothing, Just dir, False) -> - parseDir g o dir bOut - _ -> usageError args err1 - -trimFilename :: String -> String -trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 - -mainMatch :: Args MyArgs -> [PPOption] -> Bool -> MatchMode -> GrammarEx -> IO () -mainMatch args o p m (GrammarEx g) = - do let cStr = getArgString args SourceInputString - mf1 = getArg args SourceInputFile - mf2 = getArg args TargetInputFile - mdir = getArg args InputDir - bIn = getArgString args BinaryIn - me = getArg args MaxErrorRate - case (cStr,mf1,mf2,mdir,p) of - -- Parse source and target file, show full output - (_,Just f1, Just f2, Nothing, prnt) -> - do c1 <- readFile' f1 - c2 <- readFile' f2 - matchFiles o m prnt c1 c2 f1 f2 - (Just c, Just f1, Nothing, Nothing, True) -> - matchFiles o m True c f1 (trimFilename c) (trimFilename f1) - -- match all files in one dir, show condensed output - (_,Nothing, Nothing, Just dir, False) -> dirMatch g o bIn m me dir - _ -> usageError args err2 - -matchFiles :: [PPOption] -> MatchMode -> Bool -> String -> String - -> String -> String -> IO () -matchFiles o m prnt f1 f2 _n1 _n2 = - -- should move to HarmTrace.IO.Main - let (ParseResult key1 toks1 _ ts1 _nr1 te1 pe1 _) - = postProc o $ string2Piece Jazz f1 - (ParseResult key2 toks2 _ ts2 _nr2 te2 pe2 _) - = postProc o $ string2Piece Jazz f2 - in - do if not $ null te1 then showErrors "tokenizer 1: " te1 else putStr "" - if not $ null te2 then showErrors "tokenizer 2: " te2 else putStr "" - if not $ null pe1 then showErrors "parser 1: " pe1 else putStr "" - if not $ null pe2 then showErrors "parser 2: " pe2 else putStr "" - case (m,prnt) of - (STDiff,_) -> print (diffChordsLen toks1 toks2) - (Align ,False) -> print (getAlignDist key1 key2 toks1 toks2) - (Align ,True ) -> do let (mat,v,t) = alignChordLab key1 key2 toks1 toks2 - pPrintV t; print mat ; print v - - (HAnAlign,True ) -> do let (mat,v,t) = alignHAnChord ts1 ts2 - pPrintV t; print mat ; print v - (HAnAlign,False) -> error "Unimplemented." - (LCES,False) -> error "Unimplemented." - (LCES,True) -> do putStrLn ("refactor me"); +{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleInstances #-}++module Main where++-- Libs+import System.Console.ParseArgs hiding (args) ++-- Music stuff+import HarmTrace.HarmTrace+import HarmTrace.IO.Main+import HarmTrace.IO.Errors+import HarmTrace.IO.PrintTree+import HarmTrace.HAnTree.ToHAnTree (gTreeHead)+import HarmTrace.Matching.Standard+import HarmTrace.Matching.GuptaNishimura (getLCES)+import HarmTrace.Matching.Alignment (getAlignDist, alignChordLab+ , pPrintV, alignHAnChord)+import HarmTrace.Audio.Harmonize ( simpleAnnotator, headAnnotator+ , harmonyAnnotator)+import HarmTrace.Audio.ChordTypes (AudioFeat, ChordAnnotation, TimedData)+import HarmTrace.Base.MusicRep (Key)++import Data.List (delete)+import System.FilePath (takeFileName)++--------------------------------------------------------------------------------+-- Command-line arguments+--------------------------------------------------------------------------------++data MyArgs = SourceInputString | SourceInputFile | TargetInputFile + | InputDir | OpMode | Print | MaxErrorRate | BinaryOut | BinaryIn+ | PrintIns | Grammar | TargetKeyInputFile+ | SourceKeyInputFile | AnnotationKeyInputDir| GroundTruthInputFile + | GroundTruthInputDir+ deriving (Eq, Ord, Show)++myArgs :: [Arg MyArgs]+myArgs = [+ Arg { argIndex = MaxErrorRate,+ argAbbr = Just 'e',+ argName = Just "max-err",+ argData = argDataOptional "float" ArgtypeFloat,+ argDesc = "Ignore pieces with higher error rate for diff"+ },+ Arg { argIndex = SourceInputString,+ argAbbr = Just 'c',+ argName = Just "chords",+ argData = argDataOptional "string" ArgtypeString,+ argDesc = "Input Chord Sequence to parse"+ },+ Arg { argIndex = SourceInputFile,+ argAbbr = Just '1',+ argName = Just "sfile",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Input file (source for diff)"+ },+ Arg { argIndex = TargetInputFile,+ argAbbr = Just '2',+ argName = Just "tfile",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Input file (target for diff)"+ },+ Arg { argIndex = SourceKeyInputFile,+ argAbbr = Just '3',+ argName = Just "skey",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Source input ground-truth key annotation file"+ },+ Arg { argIndex = TargetKeyInputFile,+ argAbbr = Just '4',+ argName = Just "tkey",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Target input ground-truth key annotation file"+ },+ Arg { argIndex = GroundTruthInputFile,+ argAbbr = Just '5',+ argName = Just "gt",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Source input ground-truth chord annotation file"+ },+ Arg { argIndex = GroundTruthInputDir,+ argAbbr = Just 'a',+ argName = Just "gt-dir",+ argData = argDataOptional "dir" ArgtypeString,+ argDesc = "Ground-truth Annotation directory"+ },+ Arg { argIndex = InputDir,+ argAbbr = Just 'd',+ argName = Just "dir",+ argData = argDataOptional "dir" ArgtypeString,+ argDesc = "Input directory (process all files within)"+ },+ Arg { argIndex = AnnotationKeyInputDir,+ argAbbr = Just 'k',+ argName = Just "key-dir",+ argData = argDataOptional "dir" ArgtypeString,+ argDesc = "Ground-truth Key annotation directory"+ }, + Arg { argIndex = OpMode,+ argAbbr = Just 'm',+ argName = Just "mode",+ argData = argDataRequired "string" ArgtypeString,+ argDesc = + "Mode: parse|stdiff|lces-s|lcessim|hanlign|\n" ++ + " align|harm-cr|head-cr|simple-cr"+ },+ Arg { argIndex = Grammar,+ argAbbr = Just 'g',+ argName = Just "grammar",+ argData = argDataRequired "string" ArgtypeString,+ argDesc = "Grammar to use (jazz|pop)"+ },+ Arg { argIndex = Print,+ argAbbr = Just 'p',+ argName = Just "print",+ argData = Nothing,+ argDesc = "Set this flag to print a .png of the parse"+ },+ Arg { argIndex = PrintIns,+ argAbbr = Just 's',+ argName = Just "print-insertions",+ argData = Nothing,+ argDesc = "Set this flag to show inserted nodes"+ },+ Arg { argIndex = BinaryOut,+ argAbbr = Just 'o',+ argName = Just "out",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Output binary file for parsing results"+ },+ Arg { argIndex = BinaryIn,+ argAbbr = Just 'i',+ argName = Just "in",+ argData = argDataOptional "filepath" ArgtypeString,+ argDesc = "Input binary file for matching"+ }+ ]++--------------------------------------------------------------------------------+-- Main+--------------------------------------------------------------------------------++data SourceData = Audio | ChordLab | Annotation+ +getDataType :: Args MyArgs -> SourceData+getDataType args+ | gotArg args SourceKeyInputFile = Annotation -- for single files+ | gotArg args AnnotationKeyInputDir = Annotation -- for directory reading+ | otherwise = ChordLab -- add audio support++-- by default all post processing operations are executed +defaultOpts :: [PPOption]+defaultOpts = [ RemovePDPT , RemoveInsertions+ , MergeDelChords, ExpandChordDurations ] + +err1, err2, err3, err4 :: String+err1 = "Use a source file, or a directory."+err2 = "Use a source file and a target file, or a directory."+err3 = "Use a source file and optionally a target file."+err4 = "Use an audio-feature location and a ground-truth file, "+++ "or an audio-feature directory and a ground-truth directory."++main :: IO ()+main = do args <- parseArgsIO ArgsComplete myArgs+ let mode = getRequiredArg args OpMode+ grmS = getRequiredArg args Grammar+ prnt = gotArg args Print+ opts = if gotArg args PrintIns + then delete RemoveInsertions defaultOpts else defaultOpts+ gram = case grmS of+ "jazz" -> GrammarEx Jazz+ "pop" -> GrammarEx Pop+ s -> usageError args ("Unknown grammar: " ++ s)+ case mode of+ "parse" -> mainParse args opts prnt gram+ "stdiff" -> mainMatch args opts False STDiff gram+ "hanlign" -> mainMatch args opts prnt HAnAlign gram+ "lces-s" -> mainMatch args opts prnt LCESsize gram+ "lcessim" -> mainMatch args opts prnt LCESsim gram+ "align" -> mainMatch args opts prnt Align gram+ "head-cr" -> mainChordRec headAnnotator args prnt+ "simple-cr" -> mainChordRec simpleAnnotator args prnt+ "harm-cr" -> mainChordRec (harmonyAnnotator gram) args prnt+ s -> usageError args ("Unknown mode: " ++ s)+++mainParse :: Args MyArgs -> [PPOption] -> Bool -> GrammarEx -> IO ()+mainParse args o p (GrammarEx g) =+ do let cStr = getArgString args SourceInputString+ mf1 = getArgString args SourceInputFile+ ky = getArgString args SourceKeyInputFile+ bOut = getArgString args BinaryOut+ mdir = getArgString args InputDir+ kdir = getArgString args AnnotationKeyInputDir+ sdat = getDataType args+ case (sdat, cStr, mf1,mdir, p, ky, kdir) of+ -- parse a string of chords+ (ChordLab, Just c, Nothing, Nothing , False,Nothing,Nothing) ->+ do pr <- parseTreeVerb g o c + mapM_ (print . gTreeHead) (parsedPiece pr)+ -- and print a parsetree + (ChordLab, Just c, Nothing, Nothing , True,Nothing,Nothing) ->+ do pr <- parseTree g o c + let ts = map gTreeHead (parsedPiece pr)+ _ <- printTreeHAn (pieceTreeHAn pr) (trimFilename ("pp" ++ c))+ printTreeHAnF ts (trimFilename c) >> return ()+ -- Parse one file, show full output+ (ChordLab, Nothing, Just f1, Nothing , False,Nothing,Nothing) -> + do pr <- readFile f1 >>= parseTreeVerb g o+ print (pieceTreeHAn pr)+ mapM_ (print . gTreeHead) (parsedPiece pr)+ (ChordLab, Nothing, Just f1, Nothing , True ,Nothing,Nothing) ->+ --with post processing+ do pr <- readFile f1 >>= parseTree g o+ let ts = map gTreeHead (parsedPiece pr)+ printTreeHAn (pieceTreeHAn pr) (f1 ++ ".postProc") >> return ()+ printTreeHAnF ts f1 >> return () + -- Parse all files in one dir, show condensed output + (ChordLab, Nothing, Nothing, Just dir, False, Nothing, Nothing) ->+ parseDir g o dir bOut+ -- ** audio ground-truth annotation part ** + (Annotation, Nothing, Just f1,Nothing, False, Just kf, Nothing) -> + -- parse a ground-truth annotation and its key and give verbose output + do key <- readFile kf+ pr <- readFile f1 >>= parseAnnotationVerb g o key + print (pieceTreeHAn pr)+ mapM_ (print . gTreeHead) (take 10 $ parsedPiece pr) + (Annotation, Nothing, Just f1, Nothing , True , Just kf,Nothing) ->+ -- parse a ground-truth annotation and its key and print the parse + do key <- readFile kf+ pr <- readFile f1 >>= parseAnnotation g o key + let ts = map gTreeHead (parsedPiece pr)+ printTreeHAn (pieceTreeHAn pr) (f1 ++ ".postProc") >> return ()+ printTreeHAnF ts f1 >> return () + -- Parse all files in one dir, show condensed output + (Annotation, Nothing, Nothing, Just dir,False,Nothing,Just kd) ->+ parseAnnotationDir g o kd dir+ -- Else throw error+ _ -> usageError args err1+ +trimFilename :: String -> String+trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 + +mainMatch :: Args MyArgs -> [PPOption] -> Bool -> MatchMode -> GrammarEx -> IO ()+mainMatch args o p m (GrammarEx g) =+ do let cStr = getArgString args SourceInputString+ mf1 = getArg args SourceInputFile+ mf2 = getArg args TargetInputFile+ mdir = getArg args InputDir+ bIn = getArgString args BinaryIn+ me = getArg args MaxErrorRate+ case (cStr,mf1,mf2,mdir,p) of+ -- Parse source and target file, show full output+ (_,Just f1, Just f2, Nothing, prnt) -> + do c1 <- readFile' f1+ c2 <- readFile' f2+ matchFiles o m prnt c1 c2 f1 f2+ (Just c, Just f1, Nothing, Nothing, True) ->+ matchFiles o m True c f1 (trimFilename c) (trimFilename f1)+ -- match all files in one dir, show condensed output+ (_,Nothing, Nothing, Just dir, False) -> dirMatch g o bIn m me dir + _ -> usageError args err2++matchFiles :: [PPOption] -> MatchMode -> Bool -> String -> String + -> FilePath -> FilePath -> IO ()+matchFiles o m prnt f1 f2 n1 n2 = + -- should move to HarmTrace.IO.Main+ let (ParseResult key1 toks1 _ ts1 _nr1 te1 pe1 _) + = postProc o $ string2Piece Jazz f1+ (ParseResult key2 toks2 _ ts2 _nr2 te2 pe2 _) + = postProc o $ string2Piece Jazz f2+ in+ do if not $ null te1 then showErrors "tokenizer 1: " te1 else putStr ""+ if not $ null te2 then showErrors "tokenizer 2: " te2 else putStr ""+ if not $ null pe1 then showErrors "parser 1: " pe1 else putStr ""+ if not $ null pe2 then showErrors "parser 2: " pe2 else putStr ""+ case (m,prnt) of+ (STDiff,_) -> print (diffChordsLen toks1 toks2)+ (Align ,False) -> print (getAlignDist key1 key2 toks1 toks2)+ (Align ,True ) -> do let (mat,v,t) = alignChordLab key1 key2 toks1 toks2 + pPrintV t; print mat ; print v+ + (HAnAlign,True ) -> do let (mat,v,t) = alignHAnChord ts1 ts2+ pPrintV t; print mat ; print v+ -- quick and dirty LCES plotting (should move to HarmTrace.IO)+ (LCESsize,True) -> + do printTreeHAn ts1 (n1 ++ ".postProc") >> return ()+ printTreeHAn ts2 (n2 ++ ".postProc") >> return ()+ printTreeHAnF (fst $ getLCES ts1 ts2) + ( (take 10 $ takeFileName n1) ++ ".vs." + ++ (take 10 $ takeFileName n2) ++ ".lces") >> return ()+ _ -> error "Unimplemented." ++-- given a audio feature description files and groud-truth annotation, evaluates+-- a model-based chord labelling+mainChordRec :: (Maybe [TimedData Key] -> AudioFeat -> ChordAnnotation) + -> Args MyArgs -> Bool -> IO ()+mainChordRec ann args p = + do let af = getArgString args SourceInputFile+ gt = getArg args GroundTruthInputFile+ key = getArg args SourceKeyInputFile+ afdir = getArg args InputDir+ gtdir = getArg args GroundTruthInputDir+ keydir = getArg args AnnotationKeyInputDir+ case (gt,af,key,gtdir,afdir,keydir,p) of+ -- evaluates a single audio feature set+ (Just g, Just a, Nothing, Nothing, Nothing, Nothing, prnt) -> + evaluateLabeling ann prnt g a Nothing >>= print + -- evaluates a single audio feature set and key annotation+ (Just g, Just a, k, Nothing, Nothing, Nothing, prnt) -> + evaluateLabeling ann prnt g a k >>= print + -- evaluates a directory with audio features+ (Nothing, Nothing, Nothing, Just gd, Just ad, Nothing, _ ) -> + batchLabeling ann gd ad Nothing+ -- evaluates a directory with audio features and key annotations+ (Nothing, Nothing, Nothing, Just gd, Just ad, k, _ ) -> + batchLabeling ann gd ad k+ _ -> usageError args err4