diff --git a/HarmTrace.cabal b/HarmTrace.cabal --- a/HarmTrace.cabal +++ b/HarmTrace.cabal @@ -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. - - -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. + + +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. + 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/src/HarmTrace/Audio/Annotations.hs b/src/HarmTrace/Audio/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Annotations.hs @@ -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 diff --git a/src/HarmTrace/Audio/BeatChroma.hs b/src/HarmTrace/Audio/BeatChroma.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/BeatChroma.hs @@ -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 diff --git a/src/HarmTrace/Audio/ChordTypes.hs b/src/HarmTrace/Audio/ChordTypes.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/ChordTypes.hs @@ -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]} diff --git a/src/HarmTrace/Audio/Evaluation.hs b/src/HarmTrace/Audio/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Evaluation.hs @@ -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 .. ] diff --git a/src/HarmTrace/Audio/Harmonize.hs b/src/HarmTrace/Audio/Harmonize.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Harmonize.hs @@ -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 + diff --git a/src/HarmTrace/Audio/Key.hs b/src/HarmTrace/Audio/Key.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Key.hs @@ -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 diff --git a/src/HarmTrace/Audio/Parser.hs b/src/HarmTrace/Audio/Parser.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Parser.hs @@ -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 diff --git a/src/HarmTrace/Audio/Utils.hs b/src/HarmTrace/Audio/Utils.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Utils.hs @@ -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 diff --git a/src/HarmTrace/Base/MusicRep.hs b/src/HarmTrace/Base/MusicRep.hs --- a/src/HarmTrace/Base/MusicRep.hs +++ b/src/HarmTrace/Base/MusicRep.hs @@ -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 diff --git a/src/HarmTrace/Base/Parsing.hs b/src/HarmTrace/Base/Parsing.hs --- a/src/HarmTrace/Base/Parsing.hs +++ b/src/HarmTrace/Base/Parsing.hs @@ -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" diff --git a/src/HarmTrace/Base/TypeLevel.hs b/src/HarmTrace/Base/TypeLevel.hs --- a/src/HarmTrace/Base/TypeLevel.hs +++ b/src/HarmTrace/Base/TypeLevel.hs @@ -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 +-} diff --git a/src/HarmTrace/HAnTree/Binary.hs b/src/HarmTrace/HAnTree/Binary.hs --- a/src/HarmTrace/HAnTree/Binary.hs +++ b/src/HarmTrace/HAnTree/Binary.hs @@ -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 diff --git a/src/HarmTrace/HAnTree/HAn.hs b/src/HarmTrace/HAnTree/HAn.hs --- a/src/HarmTrace/HAnTree/HAn.hs +++ b/src/HarmTrace/HAnTree/HAn.hs @@ -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" diff --git a/src/HarmTrace/HAnTree/HAnParser.hs b/src/HarmTrace/HAnTree/HAnParser.hs --- a/src/HarmTrace/HAnTree/HAnParser.hs +++ b/src/HarmTrace/HAnTree/HAnParser.hs @@ -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 diff --git a/src/HarmTrace/HAnTree/PostProcess.hs b/src/HarmTrace/HAnTree/PostProcess.hs --- a/src/HarmTrace/HAnTree/PostProcess.hs +++ b/src/HarmTrace/HAnTree/PostProcess.hs @@ -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 diff --git a/src/HarmTrace/HAnTree/ToHAnTree.hs b/src/HarmTrace/HAnTree/ToHAnTree.hs --- a/src/HarmTrace/HAnTree/ToHAnTree.hs +++ b/src/HarmTrace/HAnTree/ToHAnTree.hs @@ -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 diff --git a/src/HarmTrace/HAnTree/Tree.hs b/src/HarmTrace/HAnTree/Tree.hs --- a/src/HarmTrace/HAnTree/Tree.hs +++ b/src/HarmTrace/HAnTree/Tree.hs @@ -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 diff --git a/src/HarmTrace/HarmTrace.hs b/src/HarmTrace/HarmTrace.hs --- a/src/HarmTrace/HarmTrace.hs +++ b/src/HarmTrace/HarmTrace.hs @@ -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 diff --git a/src/HarmTrace/IO/Errors.hs b/src/HarmTrace/IO/Errors.hs --- a/src/HarmTrace/IO/Errors.hs +++ b/src/HarmTrace/IO/Errors.hs @@ -1,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 } diff --git a/src/HarmTrace/IO/Main.hs b/src/HarmTrace/IO/Main.hs --- a/src/HarmTrace/IO/Main.hs +++ b/src/HarmTrace/IO/Main.hs @@ -1,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" diff --git a/src/HarmTrace/IO/PrintTree.hs b/src/HarmTrace/IO/PrintTree.hs --- a/src/HarmTrace/IO/PrintTree.hs +++ b/src/HarmTrace/IO/PrintTree.hs @@ -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 + diff --git a/src/HarmTrace/Matching/Alignment.hs b/src/HarmTrace/Matching/Alignment.hs --- a/src/HarmTrace/Matching/Alignment.hs +++ b/src/HarmTrace/Matching/Alignment.hs @@ -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' + diff --git a/src/HarmTrace/Matching/AlignmentFaster.hs b/src/HarmTrace/Matching/AlignmentFaster.hs deleted file mode 100644 --- a/src/HarmTrace/Matching/AlignmentFaster.hs +++ /dev/null @@ -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 - - diff --git a/src/HarmTrace/Matching/FlatMatch.hs b/src/HarmTrace/Matching/FlatMatch.hs deleted file mode 100644 --- a/src/HarmTrace/Matching/FlatMatch.hs +++ /dev/null @@ -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 diff --git a/src/HarmTrace/Matching/GuptaNishimura.hs b/src/HarmTrace/Matching/GuptaNishimura.hs --- a/src/HarmTrace/Matching/GuptaNishimura.hs +++ b/src/HarmTrace/Matching/GuptaNishimura.hs @@ -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" diff --git a/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs b/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs deleted file mode 100644 --- a/src/HarmTrace/Matching/GuptaNishimuraEditMatch.hs +++ /dev/null @@ -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) diff --git a/src/HarmTrace/Matching/HChord.hs b/src/HarmTrace/Matching/HChord.hs --- a/src/HarmTrace/Matching/HChord.hs +++ b/src/HarmTrace/Matching/HChord.hs @@ -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 diff --git a/src/HarmTrace/Matching/Matching.hs b/src/HarmTrace/Matching/Matching.hs deleted file mode 100644 --- a/src/HarmTrace/Matching/Matching.hs +++ /dev/null @@ -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 - diff --git a/src/HarmTrace/Matching/Sim.hs b/src/HarmTrace/Matching/Sim.hs --- a/src/HarmTrace/Matching/Sim.hs +++ b/src/HarmTrace/Matching/Sim.hs @@ -1,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 diff --git a/src/HarmTrace/Matching/SimpleChord.hs b/src/HarmTrace/Matching/SimpleChord.hs --- a/src/HarmTrace/Matching/SimpleChord.hs +++ b/src/HarmTrace/Matching/SimpleChord.hs @@ -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)) diff --git a/src/HarmTrace/Matching/Standard.hs b/src/HarmTrace/Matching/Standard.hs --- a/src/HarmTrace/Matching/Standard.hs +++ b/src/HarmTrace/Matching/Standard.hs @@ -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) diff --git a/src/HarmTrace/Matching/Testing.hs b/src/HarmTrace/Matching/Testing.hs deleted file mode 100644 --- a/src/HarmTrace/Matching/Testing.hs +++ /dev/null @@ -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 - } diff --git a/src/HarmTrace/Models/Jazz/Instances.hs b/src/HarmTrace/Models/Jazz/Instances.hs --- a/src/HarmTrace/Models/Jazz/Instances.hs +++ b/src/HarmTrace/Models/Jazz/Instances.hs @@ -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 diff --git a/src/HarmTrace/Models/Jazz/Main.hs b/src/HarmTrace/Models/Jazz/Main.hs --- a/src/HarmTrace/Models/Jazz/Main.hs +++ b/src/HarmTrace/Models/Jazz/Main.hs @@ -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 diff --git a/src/HarmTrace/Models/Jazz/Model.hs b/src/HarmTrace/Models/Jazz/Model.hs --- a/src/HarmTrace/Models/Jazz/Model.hs +++ b/src/HarmTrace/Models/Jazz/Model.hs @@ -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 ] diff --git a/src/HarmTrace/Models/Models.hs b/src/HarmTrace/Models/Models.hs --- a/src/HarmTrace/Models/Models.hs +++ b/src/HarmTrace/Models/Models.hs @@ -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 diff --git a/src/HarmTrace/Models/Parser.hs b/src/HarmTrace/Models/Parser.hs --- a/src/HarmTrace/Models/Parser.hs +++ b/src/HarmTrace/Models/Parser.hs @@ -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... diff --git a/src/HarmTrace/Models/Pop/Instances.hs b/src/HarmTrace/Models/Pop/Instances.hs --- a/src/HarmTrace/Models/Pop/Instances.hs +++ b/src/HarmTrace/Models/Pop/Instances.hs @@ -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 diff --git a/src/HarmTrace/Models/Pop/Main.hs b/src/HarmTrace/Models/Pop/Main.hs --- a/src/HarmTrace/Models/Pop/Main.hs +++ b/src/HarmTrace/Models/Pop/Main.hs @@ -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 + diff --git a/src/HarmTrace/Models/Pop/Model.hs b/src/HarmTrace/Models/Pop/Model.hs --- a/src/HarmTrace/Models/Pop/Model.hs +++ b/src/HarmTrace/Models/Pop/Model.hs @@ -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 ] diff --git a/src/HarmTrace/Models/Test/Instances.hs b/src/HarmTrace/Models/Test/Instances.hs deleted file mode 100644 --- a/src/HarmTrace/Models/Test/Instances.hs +++ /dev/null @@ -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 diff --git a/src/HarmTrace/Models/Test/Main.hs b/src/HarmTrace/Models/Test/Main.hs deleted file mode 100644 --- a/src/HarmTrace/Models/Test/Main.hs +++ /dev/null @@ -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 diff --git a/src/HarmTrace/Models/Test/Model.hs b/src/HarmTrace/Models/Test/Model.hs deleted file mode 100644 --- a/src/HarmTrace/Models/Test/Model.hs +++ /dev/null @@ -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 ] diff --git a/src/HarmTrace/Tokenizer/Tokenizer.hs b/src/HarmTrace/Tokenizer/Tokenizer.hs --- a/src/HarmTrace/Tokenizer/Tokenizer.hs +++ b/src/HarmTrace/Tokenizer/Tokenizer.hs @@ -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" diff --git a/src/HarmTrace/Tokenizer/Tokens.hs b/src/HarmTrace/Tokenizer/Tokens.hs --- a/src/HarmTrace/Tokenizer/Tokens.hs +++ b/src/HarmTrace/Tokenizer/Tokens.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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