diff --git a/HarmTrace.cabal b/HarmTrace.cabal --- a/HarmTrace.cabal +++ b/HarmTrace.cabal @@ -1,98 +1,169 @@ -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 +name: HarmTrace +version: 2.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--2012 Universiteit Utrecht, + 2012 University of Oxford +license: GPL-3 +license-file: LICENSE +author: W. Bas de Haas and Jose Pedro Magalhaes +stability: experimental +maintainer: bash@cs.uu.nl, jpm@cs.ox.ac.uk +homepage: http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace +category: Music +build-type: Custom +cabal-version: >= 1.6 +tested-with: GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1 + +extra-source-files: README + +executable harmtrace + hs-source-dirs: src + other-modules: Constants + + HarmTrace.HarmTrace + + HarmTrace.Audio.ChordTypes + HarmTrace.Audio.Annotate + HarmTrace.Audio.AnnotationParser + HarmTrace.Audio.DataParser + HarmTrace.Audio.ChromaChord + HarmTrace.Audio.ChromaKey + HarmTrace.Audio.Key + HarmTrace.Audio.Evaluation + HarmTrace.Audio.Statistical + + 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.IO.Common + HarmTrace.IO.Match + HarmTrace.IO.Parse + HarmTrace.IO.Recognise + HarmTrace.IO.FeatExtract + HarmTrace.IO.Downsample + HarmTrace.IO.BasePaths + + 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.6, template-haskell >=2.4 && <2.8, + mtl, directory, filepath, array, parallel >= 3, + Diff == 0.1.*, cmdargs >= 0.9 && < 0.10, process >= 1.0, + uu-parsinglib == 2.7.1, ListLike >= 3.0.1, + vector >= 0.7, deepseq, sox >= 0.2.2.1, + instant-generics >= 0.3.1 && < 0.4, binary == 0.5.*, + hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9 + + ghc-options: -Wall + -O2 -fno-spec-constr-count -funbox-strict-fields + -fcontext-stack=50 + -threaded -feager-blackholing -rtsopts + + ghc-prof-options: -auto-all + + +library +-- Note the extreme duplication of information +-- I don't think there's much we can do about that + build-depends: base >= 4.2 && < 4.6, template-haskell >=2.4 && <2.8, + mtl, directory, filepath, array, parallel >= 3, + Diff == 0.1.*, parseargs >= 0.1.3.2, 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 + + ghc-options: -Wall + -O2 -fno-spec-constr-count -funbox-strict-fields + -fcontext-stack=50 + -feager-blackholing -rtsopts + + ghc-prof-options: -auto-all + + hs-source-dirs: src + + exposed-modules: HarmTrace.Audio.ChordTypes + HarmTrace.Audio.Annotate + HarmTrace.Audio.AnnotationParser + HarmTrace.Audio.DataParser + HarmTrace.Audio.ChromaChord + HarmTrace.Audio.ChromaKey + HarmTrace.Audio.Key + HarmTrace.Audio.Evaluation + HarmTrace.Audio.Statistical + + 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.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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,674 +1,674 @@ - 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 + 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 --- a/README +++ b/README @@ -1,23 +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 +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,19 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMainWithHooks simpleUserHooks +module Main (main) where + +import Distribution.Simple +import System.Cmd (system) + +main :: IO () +main = defaultMainWithHooks hooks + where hooks = simpleUserHooks { runTests = runTests' + , preBuild = preBuild' } + +-- Runs the testsuite +runTests' _ _ _ _ = system "shelltest tests -c -d" >> return () + +-- Update the VERSION string before building +--preBuild' :: Args -> BuildFlags -> IO HookedBuildInfo +preBuild' a b = do -- First do our replacement + system "cd src && runghc Replace.hs" + -- Then go on with preBuild as usual + preBuild simpleUserHooks a b diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Constants.hs @@ -0,0 +1,140 @@ +{-# OPTIONS_GHC -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Constants +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Several constants used everywhere +-------------------------------------------------------------------------------- + +module Constants ( vERSION, cutOffProbability, maxProbChordListLength + , maxSegmentSize, maxLProductSize, evaluationSampleRate + , displaySampleRate, outputSampleRate, outputBitsPerSample + , outputNrOfChannels, keyStr, chromaStr, beatStr + , beatVampPath, chromaVampPath, keyVampPath + , deleteDownsampledWav + , defaultVampDir, defaultFeatDir , defaultOutDir + , modulationPenalty, minModulationLength ) where + +import HarmTrace.Audio.ChordTypes (NumData) + +-------------------------------------------------------------------------------- +-- Constants +-------------------------------------------------------------------------------- + +-- | Automatically generated +vERSION :: String +vERSION = gitVersion ++ " (master)" + +gitVersion :: String +gitVersion = "HarmTrace-2.0" + + +-------------------------------------------------------------------------------- +-- Chord Transcription 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.90 + +maxProbChordListLength, maxSegmentSize, maxLProductSize :: Int +-- | The maximum number if chords (the lenght) of a chord candidate list +maxProbChordListLength = 6 + +-- | The maximum size of a list of chord candidate lists (of which all possible +-- combinations will be parsed). If, in the segmentation procedure, this +-- threshold is crossed an 'emergency split' will be made (see +-- Harmtrace.Audio.Annotate.emergencySplit for details) +maxSegmentSize = 12 + +-- | Chord candidate list segments can contain long and short chord candidate +-- lists. This strongly influences the number of considered chord sequence +-- combinations, i.e. the LProductSize. If the number of possible combinations +-- becomes greater than the 'maxLProductSize' also an 'emergency split' will +-- be made, similar to maxSegmentSize. +maxLProductSize = 30 + +-------------------------------------------------------------------------------- +-- Evaluation Parameters +-------------------------------------------------------------------------------- + +evaluationSampleRate, displaySampleRate :: NumData +-- | The sample rate used in a normal (non-visual) comparison (in seconds). +evaluationSampleRate = 0.01 +-- | The sample rate used when visually comparing a chord annotation with a +-- ground-truth annotation. Often a higher sample rate is preferred. Although +-- one uses precision, the visual result is easier to read. +displaySampleRate = 0.3 + + +-------------------------------------------------------------------------------- +-- Feature Extraction and Downsampling Parameters +-------------------------------------------------------------------------------- + +outputSampleRate, outputBitsPerSample, outputNrOfChannels :: Int +-- | Before feature extraction, all audio is downsampled to 'outputSampleRate' +-- Hz. N.B. If the sample rate is changed the VAMP plugin transforms should be +-- updated accordingly (see 'beat', 'chroma', 'key'). +outputSampleRate = 22050 + +-- | Before feature extraction, all audio is converted to contain +-- 'outputBitsPerSample' bits per sample. +outputBitsPerSample = 16 + +-- | Before feature extraction, all audio is converted to contain a fixed number +-- of channels, e.g. 1 for mono or 2 for stereo. +outputNrOfChannels = 1 + +-- | Controls whether the downsampled wav file is deleted after feature +-- extraction. +deleteDownsampledWav :: Bool +deleteDownsampledWav = True + +-- | The strings that build up a audio feature file name +keyStr, chromaStr, beatStr :: String +chromaStr = "_vamp_nnls-chroma_nnls-chroma_bothchroma.csv" +keyStr = "_vamp_nnls-chroma_nnls-chroma_chroma.csv" +-- beatStr = "_vamp_qm-vamp-plugins_qm-tempotracker_beats.csv" +beatStr = "_vamp_qm-vamp-plugins_qm-barbeattracker_beats.csv" + +beatVampPath, chromaVampPath, keyVampPath :: FilePath +-- | specifying the filename of the beat tracker VAMP plugin transform file +beatVampPath = "beat-tracker-one.txt" +-- | specifying the filename of the NNLS chroma VAMP plugin transform file +chromaVampPath = "both-chroma.txt" +-- | specifying the filename of the key-finding chroma VAMP plugin transform file +keyVampPath = "tuned-chroma.txt" + +defaultVampDir, defaultOutDir, defaultFeatDir :: FilePath +-- | The default base directory is the current directory +defaultVampDir = "" +defaultOutDir = "" +defaultFeatDir = "" + +-------------------------------------------------------------------------------- +-- Chroma key estimation +-------------------------------------------------------------------------------- + +-- | The penatly given in the cumulative key strength calculation. For every +-- beat the correlation between a Krumhansl profile and the current beat +-- synchronised chroma feature is calculated for all 24 keys at every beat. +-- An optimal path through this table can be defined as: +-- $M[i,j] = max \{ M[i-1,j] + K[i,j], +-- M[i-1,j] + K[i,k] + p, } +-- where \{k \mid \forall x : K[i,x] \leq K[i,k]\}$ +-- where $p$ is the modulationPenalty, i.e. the penalty for changing the key +-- at that particular beat. +modulationPenalty :: NumData +modulationPenalty = 1.0 + +-- | The minimal length in beats of a key segment +minModulationLength :: Int +minModulationLength = 16 diff --git a/src/HarmTrace/Audio/Annotate.hs b/src/HarmTrace/Audio/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Annotate.hs @@ -0,0 +1,305 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.Annotate +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Combining low-level features (VAMP plug-ins) with high-level +-- knowledge (the HarmTrace harmony model) +-------------------------------------------------------------------------------- +module HarmTrace.Audio.Annotate ( mptreeAnnotator, groupAnnotator + , simpleAnnotator , putSegStats, preProcessData + , preProcessKeyData ) where +-- parameters +import Constants ( maxSegmentSize, maxLProductSize) + +-- Audio Stuff +import HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync + , mergeByBeat, addBeatTimeStamp + , mergeAndTimeStamp) +-- import HarmTrace.Audio.ChromaKey ( syncWithAnnKey) +import HarmTrace.Audio.Key (getBeatSyncKeyFromChroma) +import HarmTrace.Audio.ChordTypes + +-- Harmony Model stuff +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.HarmTrace + +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances + +import System.IO (stdout,hFlush) +import Data.List (sortBy, groupBy, zipWith4) +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- From chords with probabilities to a single chord, using harmony +-------------------------------------------------------------------------------- + +-- | MPTrEE (Model Propelled Transcription of Euphonic Enitities): +-- a sophisticated, harmony and beat informed chord annotator +mptreeAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat + -> ChordBeatAnnotation +mptreeAnnotator (GrammarEx g) k f = concatMap (harmonize g) (preProcessData k f) + +-- | preprocesses the raw audio data before using chord harmony model based +-- chord selection. First, the beats and chroma are synchronised. Second, +-- chord candidate lists are created. Third, a beat time-stamp is added. Fourth, +-- smart, beat informed grouping of the chord candidates is performed. Fifth, +-- the chord candidate lists are grouped in segments based on the key (obtained +-- as provided by the user or as derived from the audio data). Last, the +-- chord candidate lists are further segmented based on the occurrences of +-- I and V chords. +preProcessData :: Maybe [TimedData Key] -> AudioFeat -> [ProbChordSeg] +preProcessData gtk (AudioFeat chrm beats afk) = + segmentByTonic $ segmentByKey key . mergeByBeat . addBeatTimeStamp bt + . createChordRanks $ beatSync bt chrm where + + -- if a ground-truth key annotations are provided, we use these + -- annotations otherwise the key is derived from audio data + (bt, key) = case gtk of + Nothing -> preProcessKeyData chrm beats afk + (Just k) -> syncWithAnnKey k + + -- syncronises the last beat and key frame to match the last chord frame + syncWithAnnKey :: [TimedData Key] -> ([BeatBar], [TimedData Key]) + syncWithAnnKey keys = + let endTime = BeatBar (time $ last chrm, Four) + beats' = takeWhile (< endTime) beats ++ [endTime] + -- filter the None keys + none (Key r _) = r /= Note Nothing N + noNoneKey = (filter (none . getData) keys) + -- reset key start timestamp to 0.0 and end timestampt to chorma end + resetHead = setOnset (head noNoneKey) 0.0 : tail noNoneKey + (l,[lst]) = splitAt (length resetHead - 1) resetHead + in (beats',l ++[setOffset lst (timeStamp endTime)]) + +-- | preprocesses the audio data for automatic key detection. +preProcessKeyData :: [ChordinoLine] -> [BeatBar] -> [ChordinoLine] + -> ([BeatBar], [TimedData Key]) +preProcessKeyData chrm beats afk = + ( b, dumpBeats . mergeAndTimeStamp head b $ getBeatSyncKeyFromChroma b key ) + where -- synchronise the last beat and key to match the last chord + endTime = time $ last chrm + afk' = takeWhile ((< endTime).time) afk + (l,[lst]) = splitAt (length afk' - 1) afk' + end = BeatBar (endTime, Four) + key = l ++ [lst{time = endTime}] + b = takeWhile (< end) beats ++ [end] + +-- reminder: ProbChordSeg = Segment Key [BeatTimedData [ProbChord]] +harmonize :: forall g. (GTree g) => Grammar g -> ProbChordSeg -> ChordBeatAnnotation +harmonize g (Segment k cands) = + let isExpandable :: Bool + isExpandable = length (filter ((>1) . length) (map getData cands)) > 0 + + 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) cands) ] + + -- 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 + + -- replaces the candidate list by the selected chord in a + -- Timed datatype (either TimedData or BeatTimedData) + -- setBestChords :: Timed t => [ChordToken] -> [t ChordLabel] + setBestChords :: [ChordToken] -> [BeatTimedData ChordLabel] + setBestChords = zipWith setData cands . map (head . chords) + + -- if there is nothing to expand, do not parse + in if isExpandable then setBestChords $ select parseResults + else map pickHead cands + +pickHead :: Timed t => t [ProbChord] -> t ChordLabel +pickHead tpc = setData tpc (chordLab . head $ getData tpc) + +-------------------------------------------------------------------------------- +-- 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 +-} + + +-- move to segmentations function in Harmonize? +segmentByKey ::Timed t=>[t Key] -> [BeatTimedData [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 + +-- 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) where + -- 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 :: Timed t => Key -> [t [ProbChord]] -> [[t [ProbChord]]] +segmentTonic :: Key -> [BeatTimedData [ProbChord]] -> [[BeatTimedData [ProbChord]]] +segmentTonic k cands = segment cands [] where + segment [] [] = [] + segment [] acc = [reverse acc] + segment (c:cs) acc + | c' `isTonic` k || c' `isDom` k = reverse (c:acc) : segmentTonic k cs + | otherwise = segment 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 :: Timed t => t [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 k af = mapM_ segmentStat $ preProcessData 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 :: Timed t => [t [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 Chord candidate list by just picking the +-- first chord. This annotator does smart grouping +-- (see 'HarmTrace.Audio.ChromaChord.mergeByBeat'). +groupAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation +groupAnnotator _g _keyAnn (AudioFeat chrm beats _key ) = -- ignore key info + let endTime = BeatBar (time $ last chrm, Four) + beats' = takeWhile (< endTime) beats ++ [endTime] + in map pickHead . mergeByBeat . addBeatTimeStamp beats' . createChordRanks + $ beatSync beats' chrm + + +-- | The most simple annotator, no grouping, no matching, +-- just pick the best matching chord +simpleAnnotator :: GrammarEx -> Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation +simpleAnnotator _g _keyAnn (AudioFeat crm bts _key ) = -- ignore key + addTimeInfo . map (chordLab . head) . createChordRanks $ beatSync bts crm + where -- wraps a data types into 'BeatTimedData' datatype + addTimeInfo :: [a] -> [BeatTimedData a] + addTimeInfo blcks = zipWith4 BeatTimedData blcks bts' (0 : off) off + + (off,bts') = unzip $ map beatBar bts + diff --git a/src/HarmTrace/Audio/AnnotationParser.hs b/src/HarmTrace/Audio/AnnotationParser.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/AnnotationParser.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.AnnotationParser +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Parses textual ground-truth Chord annotations, such as the ones +-- found at: +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.AnnotationParser ( parseAnnotationData + , parseKeyAnnotationData + , preProcess) where + +import Data.Maybe (isJust,fromJust) + +import HarmTrace.Audio.DataParser (pNumData) +import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicRep +import HarmTrace.Base.Parsing +import HarmTrace.Tokenizer.Tokenizer ( parseDegrees, parseDegree + , parseRoot , parseShorthand) + +-- perhaps this file should be moved to the tokeniser module, because it is +-- is very related to tokenising + +-------------------------------------------------------------------------------- +-- Harmonically analysing Chord Annotations +-------------------------------------------------------------------------------- + +-- | Preprocesses a chord annotation for analysing their harmonic structure by +-- removing the time stamps and the None chords. +preProcess :: [TimedData ChordLabel] -> [ChordLabel] +preProcess = preProcess' 0 +preProcess' :: Int -> [TimedData ChordLabel] -> [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 +-------------------------------------------------------------------------------- +-- | Parses a chord annotation. +parseAnnotationData :: Parser ChordAnnotation +parseAnnotationData = pListSep_ng pLineEnd pChordSegment <* pLineEnd + +pChordSegment :: Parser (TimedData ChordLabel) +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 +-------------------------------------------------------------------------------- +-- | Parses a 'Key' annotation. +parseKeyAnnotationData :: Parser [TimedData Key] +parseKeyAnnotationData = pListSep_ng pLineEnd pKeySegment <* pLineEnd + +pKeySegment :: Parser (TimedData Key) +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' diff --git a/src/HarmTrace/Audio/Annotations.hs b/src/HarmTrace/Audio/Annotations.hs deleted file mode 100644 --- a/src/HarmTrace/Audio/Annotations.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/HarmTrace/Audio/BeatChroma.hs +++ /dev/null @@ -1,292 +0,0 @@ -{-# 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 --- a/src/HarmTrace/Audio/ChordTypes.hs +++ b/src/HarmTrace/Audio/ChordTypes.hs @@ -1,102 +1,297 @@ -{-# 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]} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.ChordTypes +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A set of types and classes for representing musical chords +-- recognised from an arbitrary audio source. +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.ChordTypes ( + -- * The 'Timed' class + Timed (..) + + -- * Datatypes + -- ** Types for representing Chords and their probabilities + , ChordBeatAnnotation + , ChordAnnotation + , ProbChordSeg (..) + , ProbChord (..) + , ChordCand (..) + + -- ** Representing musical time + , TimedData (..) + , BeatTimedData (..) + -- , beatTimedData + , Beat (..) + , BeatBar (..) + , BeatBarTrackData + , NumData + + -- ** Representing raw audio data + , AudioFeat (..) + , ChordinoData + , ChordinoLine (..) + , KeyStrengthData + , BeatTrackerData + , BeatChroma + , ChordStruct + + -- * Functions + -- ** Type conversion and other utilities + , getBeatTrack + , getBeat + , setBeat + , nextBeat + , prevBeat + , dumpBeats + , dumpBeat + , timeStamp + , beat + + -- ** miscellaneous + , chromaPC +)where + +import HarmTrace.Base.MusicRep +import Text.Printf (printf) +import Control.DeepSeq + +-------------------------------------------------------------------------------- +-- High-level structure +-------------------------------------------------------------------------------- + +-- | Represents a chord transcription, similar to 'ChordAnnotation', but +-- 'ChordBeatAnnotation' also contains 'Beat' information. +type ChordBeatAnnotation = [BeatTimedData ChordLabel] + +-- | A chord annotation consists of a +-- list with chords and segment boundaries. +type ChordAnnotation = [TimedData ChordLabel] + +data TimedData a = TimedData a NumData NumData + +-- | A datatype that wraps around an arbitrary datatype, adding (in this order) +-- a 'Beat', an onset, and an offset. +data BeatTimedData a = BeatTimedData a Beat NumData NumData + +-- | An alternative constructor for a BeatTimedData using two BeatBar datatypes +-- instead of a 'Beat' and two 'NumData's. +-- beatTimedData :: a -> BeatBar -> BeatBar -> BeatTimedData a +-- beatTimedData a on off = let (onnum,onbt) = beatBar on + -- in BeatTimedData a onbt onnum (fst $ beatBar off) + +-- | Clustering 'ProbChord's in a collection of chords that share a key +data ProbChordSeg = Segment { segKey :: Key + , segChords :: [BeatTimedData [ProbChord]] } + +-- | Combines a 'ChordLabel' with a probability. +data ProbChord = ProbChord {chordLab :: ChordLabel, prob :: NumData} + +-- | A chord candidate: an intermediate datatype that matches shorthand, +-- chord structure and root note (plus inversion) +data ChordCand = ChordCand { originalRootCC :: Root + , inversionRootCC :: Root + , shorthardCC :: Shorthand + , chordStructCC :: ChordStruct } + deriving Show + +type ChordStruct = [NumData] + +-- | For now, we fix the number of available beats to four, because this is also +-- hard-coded into the bar and beat-tracker. +data Beat = One | Two | Three | Four deriving (Eq, Enum) + +-- | 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 + ] + +-- | 'Timed' provides an interface for datatypes that add (musical) time +-- information to other datatypes. Hence, it allows for accessing the fields +-- of 'TimedData' and 'BeatTimedData' via the same interface. +class Timed t where + -- | Returns the contained datatype + getData :: t a -> a + -- | Returns the onset time stamp + onset :: t a -> NumData + -- | Returns the offset time stamp + offset :: t a -> NumData + -- | wraps a datatype in 't' + setData :: t a -> b -> t b + -- | Sets the onset time stamp + setOnset :: t a -> NumData -> t a + -- | Sets the offset time stamp + setOffset :: t a -> NumData -> t a + +instance Timed TimedData where + getData (TimedData d _ _ ) = d + onset (TimedData _ on _ ) = on + offset (TimedData _ _ off) = off + setData (TimedData _ on off) d = TimedData d on off + setOnset (TimedData d _ off) on = TimedData d on off + setOffset (TimedData d on _ ) off = TimedData d on off + +instance Timed BeatTimedData where + getData (BeatTimedData d _ _ _ ) = d + onset (BeatTimedData _ _ on _ ) = on + offset (BeatTimedData _ _ _ off) = off + setData (BeatTimedData _ b on off) d = BeatTimedData d b on off + setOnset (BeatTimedData d b _ off) on = BeatTimedData d b on off + setOffset (BeatTimedData d b on _ ) off = BeatTimedData d b on off + +-------------------------------------------------------------------------------- +-- NFData instances +-------------------------------------------------------------------------------- + +-- Simplified +instance NFData (TimedData ChordLabel) where + rnf (TimedData a b c) = a `seq` rnf b `seq` rnf c + +instance NFData Beat where + rnf One = () + rnf Two = () + rnf Three = () + rnf Four = () + +-------------------------------------------------------------------------------- +-- Instances of high-level data structure +-------------------------------------------------------------------------------- + +instance Eq (ProbChord) where + a == b = chordLab a == chordLab b + +-- TODO remove line-endings from show instances + +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) + +instance Show Beat where + show One = "1" + show Two = "2" + show Three = "3" + show Four = "4" + +instance Show BeatBar where + show = show . beatBar + +instance Show a => Show (BeatTimedData a) where + show (BeatTimedData dat bt on off) = + show bt ++ ';' : show dat ++ ';' : show on ++ ';' : show off ++ "\n" + +-------------------------------------------------------------------------------- +-- numerical data representation +-------------------------------------------------------------------------------- + +-- | Groups the three types of VAMP plug-in data: 'ChordinoData', +-- 'BeatBarTrackData', and 'KeyStrengthData'. See for more information: +-- +-- * +-- +-- * +-- +-- * +data AudioFeat = AudioFeat { getChroma :: ChordinoData + , getBeats :: BeatBarTrackData + , getKeys :: KeyStrengthData } + +type ChordinoData = [ChordinoLine] + +-- | Represents two chroma features and a time stamp. +data ChordinoLine = ChordinoLine + { + -- | Returns the time stamp of the chroma features + time :: NumData + -- | Returns the bass chroma feature + , bass :: [NumData] -- each of the lists has always 12 elements + -- | Returns the treble chroma feature + , 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] + +newtype BeatBar = BeatBar {beatBar :: (NumData, Beat)} deriving Eq + +type BeatBarTrackData = [BeatBar] + +-- | A type synonym is defined for our main numerical representation, this +-- allows us to easily change the precision. +type NumData = Double + +type BeatChroma = [[ChordinoLine]] -- one list per beat + +-- we compare based on the timestamp only +instance Ord BeatBar where + compare (BeatBar (b1,_)) (BeatBar (b2,_)) = compare b1 b2 + +-------------------------------------------------------------------------------- +-- Some type conversion utilities +-------------------------------------------------------------------------------- + +-- | Converts 'BeatBarTrackData' into 'BeatTrackerData' +getBeatTrack :: BeatBarTrackData -> BeatTrackerData +getBeatTrack = map (fst . beatBar) + +-- | Provides access to the 'Beat' field of a 'BeatTimedData'. The other fields +-- should be accessed by the methods of the 'Timed' class. +getBeat :: BeatTimedData a -> Beat +getBeat (BeatTimedData _ b _ _) = b + +-- | Adds 'Beat' information to a 'Timed' datatype +setBeat :: Timed t => t a -> Beat -> BeatTimedData a +setBeat tdat bt = BeatTimedData (getData tdat) bt (onset tdat) (offset tdat) + +nextBeat, prevBeat :: Beat -> Beat +-- | returns the next beat, e.g. @ nextBeat Two = Three @. +-- Following the (current) definition of 'Beat', we still assume 4/4, in the +-- future this function should also have the meter as an argument. +nextBeat Four = One +nextBeat b = succ b + +-- | returns the previous 'Beat', similar to 'prevBeat'. +prevBeat One = Four +prevBeat b = pred b + +-- | Converts a list of 'BeatTimedData's into a list of 'TimedData's +dumpBeats :: [BeatTimedData a] -> [TimedData a] +dumpBeats = map dumpBeat + +-- | Converts a 'BeatTimedData' into a 'TimedData' +dumpBeat :: BeatTimedData a -> TimedData a +dumpBeat (BeatTimedData dat _bt on off) = TimedData dat on off + +-- | Returns the time stamp of a 'BeatBar' +timeStamp :: BeatBar -> NumData +timeStamp = fst . beatBar + +-- | Returns the 'Beat' of a 'BeatBar' +beat :: BeatBar -> Beat +beat = snd . beatBar diff --git a/src/HarmTrace/Audio/ChromaChord.hs b/src/HarmTrace/Audio/ChromaChord.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/ChromaChord.hs @@ -0,0 +1,268 @@ +{-# OPTIONS_GHC -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.ChromaChord +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Recognise audio chroma vectors into textual chord descriptions. +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.ChromaChord ( createChordRanks, beatSync + , mergeByBeat, addBeatTimeStamp + , mergeAndTimeStamp, meanBeatSyncVectors + , module Numeric.LinearAlgebra + , module Numeric.GSL.Statistics + ) where + +import Constants (maxProbChordListLength, cutOffProbability) + +import HarmTrace.Audio.DataParser (shift) +import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicRep + +-- import Text.Printf (printf) +import Data.List (sortBy,find) -- , elemIndices, minimumBy) +import Data.Maybe (isJust, fromJust, mapMaybe) +import Data.Ord (comparing) +-- import Data.Function (on) + +-- http://hackage.haskell.org/package/hmatrix +import Numeric.LinearAlgebra hiding (find) +-- import qualified Numeric.GSL.Statistics as GSL hiding (mean) +import Numeric.GSL.Statistics hiding (mean) + +-------------------------------------------------------------------------------- +-- Matching chords and chroma +-------------------------------------------------------------------------------- + +-- | Wraps Chord candidate lists into a 'BeatTimedData' structure +addBeatTimeStamp :: [BeatBar] -> [[a]] -> [BeatTimedData [a]] +addBeatTimeStamp = beatTime (BeatBar (0,Four)) where + + beatTime :: BeatBar -> [BeatBar] -> [[a]] -> [BeatTimedData [a]] + beatTime _ [] [] = [] + beatTime (BeatBar (on, onbt)) (next@(BeatBar (off, _)) : bs) (x : xs) = + BeatTimedData x onbt on off : beatTime next bs xs + beatTime _ _ _ = error "addBeatTimeStamp:: asynchronous beats and data" + +-- | Given a list of beats, a list of grouped data items, and a merging function +-- 'mergeAndTimeStamp' returns a list of 'BeatTimedData'. Before wrapping the +-- the grouped data items, e.g. chord candidates, the list is reduced by the +-- provided merging function. +mergeAndTimeStamp ::([a] -> a)-> [BeatBar] -> [[a]] -> [BeatTimedData a] +mergeAndTimeStamp f = merge (BeatBar (0,Four)) where + -- merge :: BeatBar -> [BeatBar] -> [[a]] -> [BeatTimedData a] + merge _ [] [] = [] + merge (BeatBar (on, bt)) beats (x : xs) = + let (off : rest) = drop (length x -1) beats + in BeatTimedData (f x) bt on (timeStamp off) : merge off rest xs + merge _ _ _ = error "mergeAndTimeStamp: asynchronous beats and data" + +-- | Merges chord segments, adding a bias toward merging at the first +-- and the third 'Beat' (specified by 'canMerge'). +mergeByBeat :: [BeatTimedData [ProbChord]] -> [BeatTimedData [ProbChord]] +mergeByBeat [] = [] +mergeByBeat [a] = [a] +mergeByBeat (x:y:xs) + | canMerge (getBeat x) (getBeat y) && isJust xy = mergeByBeat (fromJust xy:xs) + | otherwise = x : mergeByBeat (y:xs) where + xy = merge x y + -- merges two Timed 'ProbChord's using intersectPC (currently in Utils.hs) + merge :: BeatTimedData [ProbChord] -> BeatTimedData [ProbChord] + -> Maybe (BeatTimedData [ProbChord]) + merge a b + | not $ null m = Just (BeatTimedData m (getBeat a) (onset a) (offset b)) + | otherwise = Nothing + where m = intersectPC (getData a) (getData b) + -- specifies which combinations of beats are allowed to merge + canMerge :: Beat -> Beat -> Bool + canMerge One _ = True + canMerge Three _ = True + canMerge _ _ = False + + +intersectPC :: [ProbChord] -> [ProbChord] -> [ProbChord] +intersectPC a b = let (a',b') = order a b + in mapMaybe (findAndMergePC a') b' where + -- N.B. the probabilities are not divided by their length so > 1, + -- due to the addition + findAndMergePC :: [ProbChord] -> ProbChord -> Maybe ProbChord + findAndMergePC pcs pc = case find (== pc) pcs of + (Just pc') -> Just (ProbChord (chordLab pc) (prob pc + prob pc')) + Nothing -> Nothing + + -- takes two lists and returns a tuple where the first element is the smallest + -- and the second element is the largest of the two lists + order :: [a] -> [a] -> ([a],[a]) + order x y + | length x <= length y = (x,y) + | otherwise = (y,x) + +-- | Synchronises the 'ChordinoData' with the list of beats +-- by grouping the 'ChordinoLines' of the 'ChordinoData' in separate lists. +beatSync :: BeatBarTrackData -> ChordinoData -> BeatChroma +beatSync _ [] = [] +beatSync bt (cd:cs) = beatSync' (getBeatTrack 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 + +-------------------------------------------------------------------------------- +-- Matrix Functions for matching chords +-------------------------------------------------------------------------------- + +-- | Having a matrix of beat-synchronised bass and treble chromagrams and a +-- chord dictionary, the probability of a chord sounding at a particular beat is +-- estimated by calculating the Euclidean distance between the chord structures +-- and the chroma feature. These distances are calculated for every chord +-- candidate at every beat. Next, we sort the chord candidates by descending +-- Euclidean distance. To obtain a relative measure of the fit +-- between a chord candidate and the chroma vector in the range [0,1], +-- the distances are normalised by dividing them by distance of the best +-- matching chord candidate. +createChordRanks :: BeatChroma -> [[ProbChord]] +createChordRanks = + map (selectTop . normalize . sortTake . matchCDictionary). meanBeatSyncVectors + where + sortTake, normalize :: [ProbChord] -> [ProbChord] + sortTake = take maxProbChordListLength . sortBy (comparing prob) + + normalize l@(h:_) = let ph = prob h in map (\p -> p{prob = ph / prob p }) l + normalize [] = [] + + selectTop l -- selects the everything with a probability > x + | null s = none + -- so far, this had not positive 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 = map (dropColumns 1 . toChromaMatrix) + +-- converts 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 transpositions of a chord structure with a chroma vector +matchCDictionary :: Vector NumData -> [ProbChord] +matchCDictionary v = map (matchStruct v) chordDictionary + +-- calculate an Euclidean (PNorm2) norm +-- I also tried using the maximum norm, but this gave inferior results +matchStruct :: Vector NumData -> ChordCand -> ProbChord +matchStruct chroma (ChordCand r _ir None cs) = + ProbChord (Chord r None [] 0 1) (pnorm PNorm2 (chroma - fromList (cs ++ cs))) +matchStruct chroma (ChordCand r _ir sh cs) = + -- Chord root shorthand degrees description_str repetitions + ProbChord (Chord r sh [] 0 1) (sqrt (bss * bss + treble * treble)) + where treble = pnorm PNorm2 (subVector 12 12 chroma - fromList cs) + -- (_ir,bss) = minimumBy (compare `on` snd) . map matchInv $ rootInvs cs + (_ir,bss) = matchInv r + + -- calculates the euclidean distance between the bass chromagram + -- and all bass note inversions. + matchInv :: Root -> (Root, NumData) + matchInv ir = (ir, pnorm PNorm2 (subVector 0 12 chroma - bcs)) where + bcs = fromList (pre ++ [1] ++ tail post) + (pre, post) = splitAt (toSemitone ir) (shortHandToCS None) + + -- For a given chord structure, compute all possible + -- roots for inversions + -- rootInvs :: ChordStruct -> [Root] + -- rootInvs cs = map iThRoot (elemIndices 1 cs) + +-------------------------------------------------------------------------------- +-- 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 transposed versions +-- (including the original) of the ChordStruct, times the number of possible +-- inversions (3 or 4, depending on the number of notes in the shorthand). +transpose12 :: Shorthand -> [ChordCand] +transpose12 sh + | null cstruct = [] + | sh == None = [ChordCand (Note Nothing N) (Note Nothing N) None cstruct] + | otherwise = concatMap mkChordCands [0..11] + + where + cstruct :: ChordStruct + cstruct = shortHandToCS sh + + mkChordCands :: Int -> [ChordCand] + mkChordCands n = [ ChordCand r r sh shiftedCS] + where shiftedCS = shift (12-n) cstruct + r = iThRoot n + +-- Get the i-th chord root, for 0 <= i < 12 +-- For i >= 12, the result is given modulo 12 +-- JPM: I actually think this is not necessary because we know that +-- 0 <= i < 12, but it makes things safer anyway +iThRoot :: Int -> Root +iThRoot n | n < 0 = error "iThRoot: negative index" + | n >= 0 && n < 12 = chromaPC !! n + | otherwise = iThRoot (n `mod` 12) + +shortHandToCS :: Shorthand -> ChordStruct +shortHandToCS 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 ] + -- Dim -> [1, 0, 0, 1, 0, 0, 1, 0, 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 + -- .... + +-------------------------------------------------------------------------------- +-- 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/ChromaKey.hs b/src/HarmTrace/Audio/ChromaKey.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/ChromaKey.hs @@ -0,0 +1,89 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.ChromaKey +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Low-processing of chroma features for key-finding +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.ChromaKey ( beatSyncKeyStrength, keyMap ) where + +import HarmTrace.Audio.ChromaChord ( Vector, fromList, correlation + , beatSync, meanBeatSyncVectors ) +import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.MusicRep + + +-------------------------------------------------------------------------------- +-- Chroma key estimation +-------------------------------------------------------------------------------- + +-- | Calculates the beat synchronised key strenght for all +-- 24 keys (ordered by 'KeyMap'). +beatSyncKeyStrength :: BeatBarTrackData -> ChordinoData -> [[NumData]] +beatSyncKeyStrength bts key = + map matchKeyProfiles . meanBeatSyncVectors $ beatSync bts key + +nanToZero :: RealFloat a => a -> a +nanToZero n = if isNaN n then 0 else n + +matchKeyProfiles :: Vector NumData -> [NumData] +-- matchKeyProfiles chroma = map (\x -> pnorm PNorm2 (chroma - x)) allKeyProfiles +-- matchKeyProfiles crm = map (nanToZero . GSL.correlation crm) allKeyProfiles +matchKeyProfiles crm = map (nanToZero . correlation crm) allKeyProfiles + +allKeyProfiles :: [Vector NumData] +allKeyProfiles = map (fromList . keyToProfile) keyMap + +keyToProfile :: Key -> [NumData] +keyToProfile (Key root m) = reverseShift (toSemitone root) (selectProfile m) + where reverseShift :: Int -> [a] -> [a] + reverseShift p l = b ++ a where (a,b) = splitAt (length l - p) l + +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 +-------------------------------------------------------------------------------- + +-- | A key chroma map using 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 + ] diff --git a/src/HarmTrace/Audio/DataParser.hs b/src/HarmTrace/Audio/DataParser.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/DataParser.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.DataParser +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Basic parsers for parsing VAMP csv files. +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.DataParser ( + -- * Parsing beat data + parseBeatData + , parseBeatBarData + , pBeat + -- * Parsing chromagram data + , parseChordinoData + , parseChromaData + -- * Basic parsers + , pNumData + , pComma + , pParentheticalString + , pQuotedString + , pLabel + -- * Utilities + , shift +) where + +import HarmTrace.Audio.ChordTypes +import HarmTrace.Base.Parsing hiding (pComma,pQuotedString,pParentheticalString) + +-------------------------------------------------------------------------------- +-- data parsers +-------------------------------------------------------------------------------- + +-- | Parsing beat time stamps. +parseBeatData :: Parser BeatTrackerData +parseBeatData = pListSep_ng pLineEnd pLine <* pLineEnd where + pLine = opt pLabel "" *> pNumData <* opt (pComma *> pQuotedString) "" + +-- | Parses 'BeatBar' data. +parseBeatBarData :: Parser BeatBarTrackData +parseBeatBarData = pListSep_ng pLineEnd pLine <* pLineEnd where + pLine = curry BeatBar <$> (opt pLabel "" *> pNumData ) + <*> (pComma *> pBeat) +-- | Parses a 'Beat'. +pBeat :: Parser Beat +pBeat = toBeat <$> pQuotedString where + + toBeat :: String -> Beat + toBeat "1" = One + toBeat "2" = Two + toBeat "3" = Three + toBeat "4" = Four + toBeat b = error ("HarmTrace.Audio.Parser.toBeat: unknown beat " ++ b) + +-- | 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 ("parseChordinoData: 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 + +-- Parsing 12 dimentional chroma vectors for key-finding. +parseChromaData :: Parser [ChordinoLine] +parseChromaData = pListSep_ng pLineEnd pCrmLine <* pLineEnd where + pCrmLine = convert <$> (opt pLabel "" *> 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 ("parseChromaData: 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/Evaluation.hs b/src/HarmTrace/Audio/Evaluation.hs --- a/src/HarmTrace/Audio/Evaluation.hs +++ b/src/HarmTrace/Audio/Evaluation.hs @@ -1,98 +1,118 @@ -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 .. ] +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.Evaluation +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Basic parsers for parsing VAMP csv files. +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.Evaluation ( + relCorrectOverlap, printRelCorrectOverlap + ) where + +import Constants +import HarmTrace.Audio.ChordTypes +import HarmTrace.Audio.Annotate (preProcessData, preProcessKeyData) +import HarmTrace.Base.MusicRep + +import Data.List (genericLength, zipWith5) +import Text.Printf(printf) +import System.IO (stdout,hFlush) + +-- TODO this is a parameter and should some how be integrated into Constants.hs +-- this functions determines when two chords are considered the same +eqFunc :: ChordLabel -> ChordLabel -> Bool +eqFunc = chordTriadEq + +-------------------------------------------------------------------------------- +-- Evaluation functions +-------------------------------------------------------------------------------- + +-- 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 _ _ _) = + -- (toSemitone r1) == (toSemitone 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 _ _ _) = + toSemitone r1 == toSemitone 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. N.B. the number output by +-- 'printRelCorrectOverlap' might differ from the output of +-- 'relCorrectOverlap', because a different sample rate might be used (see +-- 'Constants'). +printRelCorrectOverlap :: (AudioFeat -> ChordBeatAnnotation) -> AudioFeat + -> ChordAnnotation -> IO Double +printRelCorrectOverlap annotator af@(AudioFeat chrm btbar afk) gt = do + let keys = snd $ preProcessKeyData chrm btbar afk + -- BUG: now alswo when we are evaluating a simple annotator grouping is + -- is displayed, this is wrong. printRelCorrectOverlap should + -- be independend of the kind of annotator. + blks :: [BeatTimedData [ProbChord]] + blks = concatMap segChords $ preProcessData Nothing af + + -- 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 :: Timed t => [t a] -> [a] +sample = sampleWith evaluationSampleRate + +-- like sample, but takes a sample rate (seconds :: Float) as argument +sampleWith :: Timed t => NumData -> [t a] -> [a] +sampleWith rate = sampleAt [0.00, rate .. ] + + +-- samples at specific points in time, specified in a list +sampleAt :: Timed t => [NumData] -> [t a] -> [a] +sampleAt _ [] = [] -- below, will never occur +sampleAt [] _ = error "Harmtrace.Audio.Evaluation: No sampling grid specified" +sampleAt (t:ts) (c:cs) + | t <= offset c = getData c : sampleAt ts (c:cs) + | otherwise = sampleAt (t:ts) cs + + diff --git a/src/HarmTrace/Audio/Harmonize.hs b/src/HarmTrace/Audio/Harmonize.hs deleted file mode 100644 --- a/src/HarmTrace/Audio/Harmonize.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# 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 --- a/src/HarmTrace/Audio/Key.hs +++ b/src/HarmTrace/Audio/Key.hs @@ -1,95 +1,127 @@ -{-# 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 +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.Key +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Key-finding from musical audio. +-------------------------------------------------------------------------------- + +module HarmTrace.Audio.Key (getBeatSyncKeyFromChroma) where + +import HarmTrace.Audio.ChordTypes +import HarmTrace.Audio.Statistical (groupMinSize, mode) +import HarmTrace.Audio.ChromaKey ( beatSyncKeyStrength, keyMap) +import HarmTrace.Base.MusicRep +import Constants (minModulationLength, modulationPenalty) + +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.ChromaChord module +import Data.Vector as V +import qualified Data.List as L +import Control.Arrow ((&&&)) +import Data.Ord (comparing) + +-------------------------------------------------------------------------------- +-- Chroma key estimation +-------------------------------------------------------------------------------- + +-- | Returns a 'Key' key assignment, given 'Beat' and chroma information. +getBeatSyncKeyFromChroma :: [BeatBar] -> [ChordinoLine] -> [[Key]] +getBeatSyncKeyFromChroma bts key = + groupKeys . getKeyFromTable $ selectKey bts key + +selectKey :: [BeatBar] -> [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.ChromaKey.keyMap) + m :: Vector (Vector NumData) + m = fromList . L.map fromList $ beatSyncKeyStrength 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 + maxima = map (maxIndex &&& maximum) 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 modulationPenalty, 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 - modulationPenalty) + -- Reviewer #3 writes that the line above is incorrect. He/She + -- suggests the line below: + -- modul = (mj, (snd ((k!(i-1))!mj)) +mv -modulationPenalty) + -- Reviewer #3 is wrong: k!(i-1))!j represents the cumulative + -- key-strength *up to* the modulation at k!i from k!i on, the + -- new key, represehtned by mj, should be used to calculate + -- the cumulative key strength at the next beat. + -- However, we should evaluate the key finding independently. + 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 + +-- given the cumulative key strength tabel, this function returns the beat-wise +-- key assignments +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) + +-- debugging: +-- printKeyTable :: [BeatBar] -> [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 :: BeatBarTrackData -> [ChordinoLine] -> [Key] +-- naiveBeatSyncKey bts key = + -- L.map (((!!) keyMap) . maxListIndex) $ beatSyncKeyStrenth bts key + +-------------------------------------------------------------------------------- +-- key strengthpParsing +-------------------------------------------------------------------------------- + +-- Smooths and groups the key changes. Given a list of beat-wise key assignments +-- the similar keys are grouped, but a new group, i.e. modulation, has to have +-- the minimum size of 16 beats. If this is not the case, the key assignments +-- will be replaced by the global key. +-- See HarmTrace.Audio.Statistical.groupMinSize +groupKeys :: [Key] -> [[Key]] +groupKeys ks = L.group . L.concat $ + groupMinSize minModulationLength (getGlobalKey ks) ks + +-- Selects the key that is most prominent. +getGlobalKey :: [Key] -> Key +getGlobalKey = mode + diff --git a/src/HarmTrace/Audio/Parser.hs b/src/HarmTrace/Audio/Parser.hs deleted file mode 100644 --- a/src/HarmTrace/Audio/Parser.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# 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/Statistical.hs b/src/HarmTrace/Audio/Statistical.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/Audio/Statistical.hs @@ -0,0 +1,83 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Audio.Statistical +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Some statistical functions used in processing audio. +-------------------------------------------------------------------------------- +module HarmTrace.Audio.Statistical where + +import HarmTrace.Audio.ChordTypes + +import Data.List ( genericLength, tails + , inits,maximumBy, sort, group) +import Data.Ord (comparing) + +-------------------------------------------------------------------------------- +-- Statistical functions +-------------------------------------------------------------------------------- + +-- | Similar 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 + +-- | Returns the mean of list. +listMean :: [NumData] -> NumData +listMean a = sum a / genericLength a + +-- | a median filter: see . +medianFilter :: Ord a => Int -> [a] -> [a] +medianFilter wsize l = map mode $ getWindows wsize l + +-- | Returns a list with all "sliding windows" of a particular size. +-- The left and right edge of the list are filled 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 + +-- | Returns the median of a list. +median :: Ord a => [a] -> a -- the median not good for keys... +median [] = error "Key.hs: median called on []" +median l = sort l !! (length l `div` 2) + +-- | Returns the index of th maximal element of a list. +maxListIndex :: Ord a => [a] -> Int +maxListIndex = fst . maxPair where + maxPair :: Ord a => [a] -> (Int,a) + maxPair = maximumBy (comparing snd) . zip [0..] + + diff --git a/src/HarmTrace/Audio/Utils.hs b/src/HarmTrace/Audio/Utils.hs deleted file mode 100644 --- a/src/HarmTrace/Audio/Utils.hs +++ /dev/null @@ -1,121 +0,0 @@ -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,268 +1,265 @@ -{-# 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 +{-# 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 + ("HarmTrace.Base.MusicRep.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 Sus2 = MinMode -- for now +toMode m = error + ("HarmTrace.Base.MusicRep.toMode: unknown shorthand: " ++ show m) + +-------------------------------------------------------------------------------- +-- 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!!(((toSemitone cr) - (toSemitone kr)) `mod` 12) + +-- transposes a degree with sem semitones up +transposeSem :: ScaleDegree -> Int -> ScaleDegree +transposeSem deg sem = scaleDegrees!!((sem + (toSemitone deg)) `mod` 12) where + +-- gives the semitone value [0,11] of a Degree, e.g. F# = 6 +toSemitone :: (Show a, Enum a) => Note a -> Int +toSemitone (Note m p) + | ix > 6 = error ("HarmTrace.Base.MusicRep.toSemitone: no semitone for" + ++ show (Note m p)) + | otherwise = ([0,2,4,5,7,9,11] !! ix) + modToSemi m where + ix = fromEnum p + +-- 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,47 @@ -{-# 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" +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +module HarmTrace.Base.Parsing ( parseData, parseDataWithErrors + , pString, pLineEnd, pManyTill + , 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" + +pManyTill :: P st a -> P st b -> P st [a] +pManyTill p end = [] <$ end + <<|> + (:) <$> p <*> pManyTill p end + 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,108 @@ -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,168 +1,168 @@ - -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 + +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,107 +1,103 @@ -{-# 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 +{-# 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) + +-- Audio/Annotation Stuff +import HarmTrace.Audio.AnnotationParser +import HarmTrace.Audio.ChordTypes + +import HarmTrace.Base.Parsing (parseDataWithErrors) + +-- 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 [] + + +-------------------------------------------------------------------------------- +-- 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 [] diff --git a/src/HarmTrace/IO/BasePaths.hs b/src/HarmTrace/IO/BasePaths.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/BasePaths.hs @@ -0,0 +1,44 @@ +module HarmTrace.IO.BasePaths ( BasePaths, setPaths + , consBasePaths, basePathsExist + , getVampDir, getFeatDir , getOutDir + , getBeatVampPath, getChromaVampPath + , getKeyVampPath) where + +import System.FilePath (()) +import HarmTrace.IO.Common (fileExists, dirExists) +import Constants ( defaultVampDir, defaultOutDir, defaultFeatDir + , beatVampPath, chromaVampPath, keyVampPath) + +-- | A datatype for storing the base directories of the vamp plugins, feature +-- csv files, and the chord and log Files. +data BasePaths = BasePaths { getVampDir :: FilePath + , getFeatDir :: FilePath + , getOutDir :: FilePath + , getBeatVampPath :: FilePath + , getChromaVampPath :: FilePath + , getKeyVampPath :: FilePath + } + +-- | Similar to 'consBasePaths', but instead excepts 'Maybe FilePath's instead +-- of 'FilePath's +setPaths :: Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> BasePaths +setPaths mv mf mo = + let vamp = maybe defaultVampDir id mv + feat = maybe defaultFeatDir id mf + out = maybe defaultOutDir id mo + in consBasePaths vamp feat out + +-- | contructs a new 'BasePaths' based on a VAMP transform directory, +-- a feature directory (to store the CSV files), and an output directory. +consBasePaths :: FilePath -> FilePath -> FilePath -> BasePaths +consBasePaths vamp feat out = BasePaths vamp feat out + (vamp beatVampPath) (vamp chromaVampPath) (vamp keyVampPath) + +-- | checks (verbosely) if the paths stored in a 'BaseDir' exist. +basePathsExist :: BasePaths -> IO (Bool) +basePathsExist dirs = do v <- fileExists (getBeatVampPath dirs) + c <- fileExists (getChromaVampPath dirs) + k <- fileExists (getKeyVampPath dirs) + f <- dirExists (getFeatDir dirs) + o <- dirExists (getOutDir dirs) + return (v && c && k && f && o) diff --git a/src/HarmTrace/IO/Common.hs b/src/HarmTrace/IO/Common.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/Common.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HarmTrace.IO.Common ( + + showFloat, showIntWithZeros, + getClassSizes, getTitle, getInfo, getId, + readFile', hGetContents', readDataDir, + printLn, putErrLn, printVersion, fileExists, dirExists + + ) where + +-- Parser stuff +import Text.ParserCombinators.UU + +-- Music stuff +import HarmTrace.Models.Jazz.Instances () +import HarmTrace.Base.Parsing +import Constants (vERSION) + +-- Library modules +import System.Console.ParseArgs hiding (args) -- cabal install parseargs +import Data.List (sort, groupBy) +import Control.Arrow ((***)) +import System.FilePath +import System.Directory +import System.IO +import Text.Printf (printf) + + +-------------------------------------------------------------------------------- +-- Data set Info +-------------------------------------------------------------------------------- + +-- parses a database name +pDB :: Parser String +pDB = pString "_" *> ( pString "allanah" + <|> pString "wdick" + <|> pString "community" + <|> pString "midicons" + <|> pString "realbook" ) <* pString "." + +-- parses a biab extension: "(M|S|m|s)(G|g)[0-9A-Za-z]{1}.txt" +pBiabExt :: Parser String +pBiabExt = (:) <$> (pSym 'M' <|> pSym 'S' <|> pSym 'm' <|> pSym 's') <*> + ((:) <$> (pSym 'G' <|> pSym 'g') <*> + ((:) <$> pAscii <*> (pure []))) <* pString ".txt" + +-- parses a title (everything upto "_id_") +pTitle :: Parser String +pTitle = pManyTill pAscii (pString "_id_") + +-- parses the complete Biab filename +pBiab :: Parser BiabInfo +pBiab = BiabInfo <$> pTitle <*> pIntegerRaw <*> pDB <*> pBiabExt + +-- a datatype for storing the band-in-a-box filename information +data BiabInfo = BiabInfo { getTitle :: String + , getId :: Int + , _getDb :: String + , _getExt :: String } + +-- gets the groundtruth information from the filename by parsing it +getInfo :: FilePath -> BiabInfo +getInfo = parseData pBiab + +-- for debugging +-- getInfoErrors :: FilePath -> BiabInfo +-- getInfoErrors fp = let (a, err) = parseDataWithErrors pBiab fp + -- in if not . null $ err then traceShow err a else a + +-- shows an integer always with 5 numbers, e.g. 45 -> 00045 +-- The function can very probably be replaced by "show", but than we have +-- to change the tests, and make sure it realy does not make a difference +showIntWithZeros :: Int -> String +showIntWithZeros i = let i' = show i + in take (5 - (length i')) (repeat '0') ++ i' + +-- creates a (id, title) mapping from a list of files +createGroundTruth :: [String] -> [(String, String)] +createGroundTruth files = [ (getTitle x, showIntWithZeros $ getId x) + | x <- map getInfo 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 + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- +putErrLn :: String -> IO() +putErrLn = hPutStrLn stderr + +printLn :: String ->IO () +printLn s = putStrLn s >> hFlush stdout + +-- 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 -> ".txt" == takeExtension str ) fs + +-- | Shows a Float with 5 decimal places +showFloat :: Float -> String +showFloat = printf "%.6f" + +printVersion :: IO () +printVersion = putStrLn vERSION + +-- | extends the 'System.Directory.doesFileExist' by printing an error message +-- if the file does not exist. +fileExists :: FilePath -> IO (Bool) +fileExists fp = + do e <- doesFileExist fp + when (not e) $ putStrLn ("Error: file does not exists: " ++ show fp) + return e + +-- | extends the 'System.Directory.doesDirectoryExist' by printing an error +-- message if the file does not exist. +dirExists :: FilePath -> IO (Bool) +dirExists fp = + do e <- doesDirectoryExist fp + when (not e) $ putStrLn ("Error: directory does not exists: " ++ show fp) + return e + diff --git a/src/HarmTrace/IO/Downsample.hs b/src/HarmTrace/IO/Downsample.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/Downsample.hs @@ -0,0 +1,40 @@ +module HarmTrace.IO.Downsample (downsample) where + +import Constants (outputSampleRate, outputBitsPerSample, outputNrOfChannels) + +import Sound.Sox.Convert (simple) +import Sound.Sox.Option.Format + +import Data.Monoid +import System.Exit (ExitCode (..)) + +-- import System.Directory +-- import System.FilePath + +-- ** N.B. SoX is required ** +-- http://sox.sourceforge.net/ +-- install on Linux: apt-get install sox libsox-fmt-all (all file formats) +-- install on Windows: you can download the binary from the sox website. +-- However, this binary does not have .mp3 support. This +-- website provides a binary that does: +-- http://www.codeproject.com/Articles/33901/Compiling-SOX-with-Lame-and-Libmad-for-Windows + +downsample :: FilePath -> IO (FilePath) +downsample fp = + do let o = mconcat [ numberOfChannels outputNrOfChannels + , bitsPerSample outputBitsPerSample + , sampleRate outputSampleRate ] + out = fp ++ ".downsampled.wav" + -- out = takeDirectory fp "downsampled" takeFileName fp + conv <- simple none fp o out + if conv /= ExitSuccess + then error "HarmTrace.IO.Downsample: sox did not terminate normally" + else return out + +-- given a path to a directory with wav files (anything other than wav files +-- is ignored will be downsamnpled. +-- batchDownsample :: FilePath -> IO () +-- batchDownsample fp = + -- do fs <- getDirectoryContents fp + -- let fs' = filter ((==".wav") . takeExtension) (map (\x -> fp x) fs) + -- mapM_ downsample fs' 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,49 +1,49 @@ -{-# 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 } +{-# 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/FeatExtract.hs b/src/HarmTrace/IO/FeatExtract.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/FeatExtract.hs @@ -0,0 +1,162 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.IO.FeatExtract +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: A module that wraps arround the sonic annotator +-- (), which is used to extract spectral +-- and pulse features from an audio source. +-------------------------------------------------------------------------------- + +module HarmTrace.IO.FeatExtract (extractFeatures) where + +import System.IO +import System.FilePath +import System.Directory (removeFile) +import System.Process +import Data.List (isPrefixOf) + +import Constants ( keyStr, chromaStr, beatStr, deleteDownsampledWav) +import HarmTrace.Base.Parsing +import HarmTrace.IO.Downsample +import HarmTrace.IO.BasePaths( BasePaths, getBeatVampPath, basePathsExist + , getKeyVampPath, getChromaVampPath + , getFeatDir, getOutDir) + +-- | Extracts the features of an arbitrary audio file, given three VAMP plugin +-- descriptions. Before the feature extraction the audio is preprocessed +-- (downsampled) with the the SoX library (see 'HarmTrace.IO.Downsample') +-- See for more information: +-- +-- * +-- +-- * +extractFeatures :: BasePaths -> FilePath + -> IO (Maybe (FilePath,FilePath,FilePath)) +extractFeatures dirs f = do + -- check if all files and directories exists, if not fail. + exists <- basePathsExist dirs + case exists of + False -> return Nothing + True -> -- create a log file + do let logf = getOutDir dirs takeFileName f <.> "extract.log" + cfp = getFeatDir dirs dropExtension f ++ chromaStr + bfp = getFeatDir dirs dropExtension f ++ beatStr + kfp = getFeatDir dirs dropExtension f ++ keyStr + + -- open a logfile + hdl <- openFile logf AppendMode + hSetBuffering hdl LineBuffering + + -- downsample the audio + hPutStrLn hdl (f ++ ";process audio;0;0") + df <- downsample f + hPutStrLn hdl (f ++ ";process audio;99;19") + + -- extract the features + sonicannotatorProcPipe (LogInfo "" "" 0 20) hdl + (getBeatVampPath dirs) df bfp + sonicannotatorProcPipe (LogInfo "" "" 0 40) hdl + (getChromaVampPath dirs) df cfp + sonicannotatorProcPipe (LogInfo "" "" 0 60) hdl + (getKeyVampPath dirs) df kfp + hClose hdl + + -- remove downsampled wav file? + when deleteDownsampledWav $ void (removeFile df) + -- when (maximum (exitBeat : exitChrm : [exitKey]) > 0) + return (Just (cfp,bfp,kfp)) + +-- executes the sonicannotator and logs all execution info to a log file +-- TODO: perhaps output a Bool for loggin if the annotating is successful +sonicannotatorProcPipe :: LogInfo -> Handle -> FilePath -> FilePath -> FilePath + -> IO () +sonicannotatorProcPipe info logh transformfile inp outp= do + let par = "--transform" : transformfile : "--writer" : "csv" + : "--csv-one-file" : [outp, inp] + (_,_,Just err,p) <- createProcess (proc "sonic-annotator" par) + {std_err = CreatePipe} + x <- hGetContents err + let tlog = transformLog info x + hPutStr logh $ concatMap show tlog + void (waitForProcess p) + -- return () + +-------------------------------------------------------------------------------- +-- parsing sonic annotator logs +-------------------------------------------------------------------------------- + +-- transforms a sonic annotator log file into a file that should be easy to +-- parse, satisfying the following format: file;feature_id;percentage;total_perc +transformLog :: LogInfo -> String -> [LogInfo] -- String +transformLog a = combineLine a . map (parseData pLogLine) . filter f . rLines + where + -- a filter that selects the lines that contain the information we want + f :: String -> Bool + f x = isPrefixOf "Extracting" x || isPrefixOf " id=" x + -- a variant of lines that also splits on a '\r' + rLines :: String -> [String] + rLines s = let (l, s') = break (\x -> ((x == '\n') || (x == '\r'))) s + in l : case s' of + [] -> [] + (_:s'') -> rLines s'' + + -- combines LogLines into LogInfo datatypes that collects the data in the + -- individual lines + combineLine :: LogInfo -> [LogLine] -> [LogInfo] + combineLine i [] = [i] + combineLine i (l:ls) = let i' = comb i l in i' : combineLine i' ls + -- comb does the actual combining + comb :: LogInfo -> LogLine -> LogInfo + comb info (LogFile n) = info {file = n} + comb info (LogFeat d) = info {feature = d} + comb info (LogPerc p) = let t = if p `mod` 5 == 0 then 1 else 0 + in info {perc = p, total = total info + t} + +-- a datatype storing for collecting the information in the log file +data LogInfo = LogInfo {file :: String, + feature :: String, + perc :: Int, + total :: Int} +instance Show LogInfo where + show (LogInfo f d p t) + | null f = "" + | otherwise = f ++ ';' : d ++ ';' : show p ++ ';' : show t ++ "\n" + +-- a datatype for storing the information in one line of the log file +data LogLine = LogFile String + | LogFeat String + | LogPerc Int deriving Show + +-- the actual parsers of the log file +pLogLine :: P (Str Char String LineColPos) LogLine +pLogLine = LogFile <$> pFileName + <|> LogFeat <$> pFeatName + <|> LogPerc <$> pPerc + +-- the percentage of the currently extracted feature +pPerc :: P (Str Char String LineColPos) Int +pPerc = pString "Extracting and writing features... " + *> (pInteger <* pSym '%' <|> f <$> pString "Done") + <* pList pAscii -- if there is anything left + where f x = if x == "Done" then 100 else -1 + +-- the filename +pFileName :: P (Str Char String LineColPos) String +pFileName = pString "Extracting features for: " *> pQuotedString + +-- the feature description +pFeatName :: P (Str Char String LineColPos) String +pFeatName = pString " id=" *> pQuotedString + +-- test :: IO () +-- test = + -- do t <- readFile "D:\\chordify\\harmtrace\\test.txt" + -- mapM_ print (transformLog (LogInfo "" "" 0 20) t) 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,494 +1,13 @@ -{-# 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" +module HarmTrace.IO.Main ( + module HarmTrace.IO.Parse, + module HarmTrace.IO.Match, + module HarmTrace.IO.Recognise, + module HarmTrace.IO.Common + ) where + +-- Simply re-export all the IO stuff +import HarmTrace.IO.Parse +import HarmTrace.IO.Match +import HarmTrace.IO.Recognise +import HarmTrace.IO.Common + diff --git a/src/HarmTrace/IO/Match.hs b/src/HarmTrace/IO/Match.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/Match.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HarmTrace.IO.Match ( + + MatchMode(..), dirMatch + + ) where + + +-- Common IO functions +import HarmTrace.IO.Common + +-- 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) + +-- Library modules +import System.FilePath +import Data.Maybe (isJust, fromJust) +import Data.Binary + +-- Parallelism +import Control.Parallel.Strategies + + +-------------------------------------------------------------------------------- +-- 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)) + -- the line below gives an compile error in ghci + in return (toks, ps' `using` parList rdeepseq) + -- in return (toks, ps') + 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"). showIntWithZeros . getId . getInfo) + (fst . unzip $ filter snd fsQLab) + putChar '\n' + mapM_ (putStr . (++ "\t"). showIntWithZeros . getId . getInfo) 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 $ getInfo x) cs)) l diff --git a/src/HarmTrace/IO/Parse.hs b/src/HarmTrace/IO/Parse.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/Parse.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HarmTrace.IO.Parse ( + + parseTree, parseTreeVerb, parseDir + + ) where + + +-- Common IO functions +import HarmTrace.IO.Common + +-- 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 + +-- Library modules +import Data.List (sort, intersperse, genericLength) +import System.FilePath +import System.Directory +import System.CPUTime +import Data.Binary + + +-------------------------------------------------------------------------------- +-- 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" + --putStrLn "Error ratio\tTime taken" + let process :: FilePath -> FilePath -> IO ([ChordLabel],Tree HAn, Int) + 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 + -- JPM: do not print the time taken so + -- as to allow diffing output in tests + ] -- , showFloat diff] + return (tks, ts, i+d+e+r) + res <- mapM (process fp) (filter ((== ".txt") . takeExtension) fs) + let (cs,ts,err) = (unzip3 res :: ([[ChordLabel]],[Tree HAn], [Int])) + printLn ("average error: " ++ + show ((fromIntegral $ sum err) / (genericLength err) :: Double)) + case bOut of + Nothing -> return () + Just bf -> encodeFile bf (cs, ts) 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/IO/Recognise.hs b/src/HarmTrace/IO/Recognise.hs new file mode 100644 --- /dev/null +++ b/src/HarmTrace/IO/Recognise.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.IO.Recognise +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Handels all the IO of the 'recognise' mode of HarmTrace, which +-- deals with audio chord transcription. +-------------------------------------------------------------------------------- + +module HarmTrace.IO.Recognise ( + + parseAnnotation, parseAnnotationVerb, parseAnnotationDir, + evaluateLabeling, printLabeling, batchLabeling + + ) where + + +-- Common IO functions +import HarmTrace.IO.Common +import HarmTrace.IO.BasePaths (BasePaths, getOutDir, getFeatDir) +import Constants ( keyStr, chromaStr, beatStr ) + +-- Parser stuff +import Text.ParserCombinators.UU + +-- Music stuff +import HarmTrace.HarmTrace +import HarmTrace.Base.MusicRep +import HarmTrace.Models.Jazz.Instances () +import HarmTrace.HAnTree.ToHAnTree +import HarmTrace.IO.Errors +import HarmTrace.Base.Parsing + +-- Audio stuff +import HarmTrace.Audio.DataParser ( parseChordinoData, parseChromaData + , parseBeatBarData) +import HarmTrace.Audio.AnnotationParser +import HarmTrace.Audio.Annotate (putSegStats) +import HarmTrace.Audio.Evaluation +import HarmTrace.Audio.ChordTypes +import HarmTrace.IO.FeatExtract +import Data.List (genericLength, isSuffixOf, stripPrefix) + +-- Library modules +import Data.List (sort, intersperse) +import System.FilePath +import System.Directory +import System.IO +import System.CPUTime +import Data.Maybe (isJust, fromJust, isNothing) +-- import Control.Parallel.Strategies (parList, rdeepseq, using) + +-------------------------------------------------------------------------------- +-- Audio Ground-truth annotations IO +-------------------------------------------------------------------------------- + +-- @pedro: I think the three "parse" functions should go to HarmTrace.IO.Parse +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 printVersion + 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 +-------------------------------------------------------------------------------- + +-- | Returns True when the argument is an audio feature file based on +-- the filename +isAudioFeatureFile :: FilePath -> Bool +isAudioFeatureFile fp + | isSuffixOf chromaStr fp = True + | isSuffixOf keyStr fp = True + | isSuffixOf beatStr fp = True + | otherwise = False + +-- | Retuns the audio feature identifier, which equals the filename without +-- the extension +getAudioFeatureId :: FilePath -> Maybe String +getAudioFeatureId fp + | isJust key = key + | isJust chm = chm + | isJust bt = bt + | otherwise = Nothing + where key = stripSuffix keyStr fp + chm = stripSuffix chromaStr fp + bt = stripSuffix beatStr fp + + -- drops a given suffix from a string. It returns nothing if the suffix + -- is not a suffix of the string + stripSuffix :: String -> String -> Maybe String + stripSuffix suf txt + | isJust stp = Just . reverse $ fromJust stp + | otherwise = Nothing + where stp = stripPrefix (reverse suf) (reverse txt) + +-- maps readAudioFeat over a directory +readAudioFeatureDir :: FilePath -> IO [AudioFeat] +readAudioFeatureDir fp = + do fs <- getDirectoryContents fp + mapM readAudioFeatures (group . sort $ filter isAudioFeatureFile fs) + where + group :: [FilePath] -> [(FilePath, FilePath, FilePath)] + group (c:k:b:fs) = (fp c, fp b, fp k) : group fs + group [] =[] + group _ = error ("HarmTrace.IO.Recognise.readAudioFeatureDir: the " + ++ "number of files in the filepath cannot be divided by 3") + +-- Given triplet of three filenames describing +-- a chroma, beat and key feature file, 'readAudioFeat' parses all data and returns an 'AudioFeat'. +readAudioFeatures :: (FilePath,FilePath,FilePath) -> IO (AudioFeat) +readAudioFeatures (cfp,bfp,kfp) = + do dChroma <- readFile cfp + dBeat <- readFile bfp + dKey <- readFile kfp + + let chrm = parseData parseChordinoData dChroma + beats = parseData parseBeatBarData dBeat + keys = parseData parseChromaData dKey + return (AudioFeat chrm beats keys) + +-- Given one VAMP feature CSV file, HarmTrace will look for the other two +-- feature files needed for chord transcription. If the first argument it True +-- 'findAudioFeatures' outputs the filepaths of the feature files it found. +findAudioFeatures :: Bool -> FilePath -> IO (Maybe (FilePath,FilePath,FilePath)) +findAudioFeatures verbose fp = + case getAudioFeatureId fp of + Nothing -> return Nothing + (Just afid) -> do let cfp = afid ++ chromaStr + bfp = afid ++ beatStr + kfp = afid ++ keyStr + + cfpExists <- doesFileExist cfp + bfpExists <- doesFileExist bfp + kfpExists <- doesFileExist kfp + + when (verbose && cfpExists) (putStrLn ("found: " ++ cfp)) + when (verbose && bfpExists) (putStrLn ("found: " ++ bfp)) + when (verbose && kfpExists) (putStrLn ("found: " ++ kfp)) + + case (cfpExists && bfpExists && kfpExists) of + True -> return (Just (cfp,bfp,kfp)) + False -> return Nothing + +-- | Evaluluates a single labeling of a piece with a ground truth annotation +-- visually. +evaluateLabeling :: (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) + -> Bool -> FilePath -> FilePath -> Maybe FilePath -> IO Double +evaluateLabeling annotator prnt gtfp featfp keyfp = do + + maf <- findAudioFeatures True featfp + af <- readAudioFeatures (fromJust maf) + gt <- readAnnotation gtfp + + case (isJust maf, keyfp, prnt) of + (True, Nothing,True) -> + do printLn ("using key finding") + putSegStats Nothing af + printRelCorrectOverlap (annotator Nothing) af gt + (True, Nothing,False) -> + do return (relCorrectOverlap gt (dumpBeats $ annotator Nothing af)) + (True, Just k ,True) -> + do key <- readAndParseKeyAnn k + printLn ("using groundTruth key annotation: " ++ show key) + putSegStats (Just key) af + printRelCorrectOverlap (annotator (Just key)) af gt + (True, Just k ,False) -> + do key <- readAndParseKeyAnn k + return (relCorrectOverlap gt (dumpBeats $ annotator (Just key) af)) + (False, _, _) -> return (-1) + +-- | 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 -> ChordBeatAnnotation) + -> 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 + + printVersion + printLn "file\trun time (seconds)\trelative correct overlap" + res <- zipWithM evalR files af + -- let res' = res `using` parList rdeepseq + printLn ("average: " ++ show (sum (fmap fst res) / genericLength res)) + where + evalR :: (FilePath, Maybe [TimedData Key]) -> AudioFeat -> IO(Double, Float) + -- evalR _ Nothing = error "evalR: Nothing" + evalR (fp, maybeKey) af = do + gt <- readAnnotation (gtfp fp) + let result = relCorrectOverlap gt (dumpBeats $ annotator maybeKey af) + exec = seq result (return ()) + t1 <- getCPUTime + exec + t2 <- getCPUTime + let runtime = fromIntegral (t2 - t1) / (1000000000000 :: Float) + printRes fp (result, runtime) + return (result, runtime) + + printRes :: FilePath -> (Double, Float) -> IO () + printRes fp (r,t) = printLn (fp ++ ":\t" ++ showFloat t ++ '\t' : show r) + >> hFlush stdout + +-- takes a set of features or an audio file and writes the chords to a file +-- the process is also logged in a logfile to keep track of the process +-- (see HarmTrace.IO.FeatExtract) +printLabeling :: BasePaths + -> (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) + -> FilePath -> IO () +printLabeling dirs annotator fp = do + let -- we use the same logfile for adding harmtrace status + logf = getOutDir dirs takeFileName fp <.> "extract.log" + out = getOutDir dirs takeFileName fp <.> "chords.txt" + ffp = getFeatDir dirs dropExtension (takeFileName fp) ++ chromaStr + + -- check (silently) if features have been extracted earlier + hasFt <- findAudioFeatures True ffp + + case (isAudioFile fp, hasFt) of + -- We found an audio file and no previously extracted features: extract them + (True, Nothing) -> do -- extract features + maf <- extractFeatures dirs fp + if isNothing maf + then appendFile logf (fp ++";ERROR;0;99\n") + else do appendFile logf (fp ++ ";harmtrace;1;80\n") + -- print chords + readAndPrint out maf annotator + appendFile logf (fp++";harmtrace;100;99\n") + appendFile logf (fp++";DONE;100;100\n") + + -- We found an audio file, but also found matching features + (True,Just maf) -> do -- appendFile logf (fp ++ ";Initialize;1;1\n") + writeFile logf (fp ++ ";harmtrace;1;80\n") + readAndPrint out (Just maf) annotator + appendFile logf (fp ++ ";harmtrace;100;99\n") + appendFile logf (fp ++ ";DONE;100;100\n") + + -- No audio, but one feature file: look for all feature files + (False,_ ) -> do maf <- findAudioFeatures True fp + readAndPrint out maf annotator + +-- reads the features and prints the chords +readAndPrint :: FilePath -> Maybe (FilePath, FilePath, FilePath) + -> (Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation) + -> IO () +readAndPrint _ Nothing _ = return () +readAndPrint out (Just af) annotator = + do feat <- readAudioFeatures af + writeAnnotation out . segPerBeat (getBeats feat) $ annotator Nothing feat + +-- returns True if fp is an audio file +isAudioFile :: FilePath -> Bool +isAudioFile fp = elem (tail $ takeExtension fp) -- all sox file formats :-) + [ "8svx", "aif", "aifc", "aiff", "aiffc", "al", "amb", "amr-nb", "amr-wb" + , "anb", "au", "avi", "avr", "awb", "cdda", "cdr", "cvs", "cvsd", "cvu", "dat" + , "dvms", "f32", "f4", "f64", "f8", "ffmpeg", "flac", "fssd", "gsm", "gsrt" + , "hcom", "htk", "ima", "ircam", "la", "lpc", "lpc10", "lu", "m4a", "m4b" + , "maud", "mp2", "mp3", "mp4", "mpg", "nist", "ogg", "prc", "raw", "s1" + , "s16", "s2", "s24", "s3", "s32", "s4", "s8", "sb", "sds", "sf", "sl", "smp" + , "snd", "sndfile", "sndr", "sndt", "sou", "sox", "sph", "sw", "txw", "u1" + , "u16", "u2", "u24", "u3", "u32", "u4", "u8", "ub", "ul", "uw", "vms", "voc" + , "vorbis", "vox", "wav", "wavpcm", "wmv", "wv", "wve", "xa" + ] + + +-- 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 + +-- writes an annotation to a specific file +writeAnnotation :: FilePath -> ChordBeatAnnotation -> IO () +writeAnnotation f ca = do hdl <- openFile f ReadWriteMode + mapM_ (hPutStr hdl . show) ca + hClose hdl + +-- segment a chord annotation per beat +-- ChordAnnotation = [TimedData ChordLabel] and BeatTrackerData = [NumData] +segPerBeat :: BeatBarTrackData -> ChordBeatAnnotation -> ChordBeatAnnotation +segPerBeat bts cds = segment (start : bts) cds where + start = BeatBar (0,prevBeat . snd . beatBar $ head bts) + + -- takes a list of beats and a list of chords (where chords can span multiple + -- beats) and returns a list of beat synchronised list chords (every chord + -- annoation has a one beat duration) + segment :: Show a => [BeatBar] -> [BeatTimedData a] -> [BeatTimedData a] + segment _ [] = [] + segment [b] [c] + | on < offset c = [setOnset c on] + | otherwise = [] -- N.B. includes on == offset b! + where on = fst $ beatBar b + segment (a : b : bs) (c:cs) + | onset c <= on && offset c >= off + = BeatTimedData (getData c) bt on off : segment (b:bs) (c:cs) + | otherwise = segment (a : b : bs) cs + where (on, bt) = beatBar a + off = fst $ beatBar b + -- should not happen + segment [] c = error ("we ran out of beats! Chords left: " ++ show c ) + segment [b] c = error ("Asynchroneous beat (" ++ show b ++ + ") and chords: " ++ show c ) + 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,177 @@ -{-# 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 #-} +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/GuptaNishimura.hs b/src/HarmTrace/Matching/GuptaNishimura.hs --- a/src/HarmTrace/Matching/GuptaNishimura.hs +++ b/src/HarmTrace/Matching/GuptaNishimura.hs @@ -1,190 +1,190 @@ -{-# 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" +{-# 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/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 = toSemitone $ root c + , clss = classType c } + +undefinedHChord :: HChord +undefinedHChord = HChord (-1 :: Int) (MajClass :: ClassType) + (P :: HFunc) NoPrep NoTrans 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,90 +1,90 @@ -{-# 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 +{-# 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,23 +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 - !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)) +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 (toSemitone 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/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,263 @@ -{-# 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 +{-# 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 +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Adhoc instances for the jazz model +-------------------------------------------------------------------------------- + +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,28 +1,41 @@ - -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 + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Models.Jazz.Main +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: The jazz parser +-------------------------------------------------------------------------------- + +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,409 +1,420 @@ -{-# 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 ] +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Models.Jazz.Model +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: The jazz model +-------------------------------------------------------------------------------- + +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 + +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,17 +1,39 @@ -{-# 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 +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Models.Models +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: All the models +-------------------------------------------------------------------------------- + +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 + +instance Show GrammarEx where + show (GrammarEx Jazz) = "JazzGrammar" + show (GrammarEx Pop ) = "PopGrammar" + +instance Eq GrammarEx where + (GrammarEx Jazz) == (GrammarEx Jazz) = True + (GrammarEx Pop ) == (GrammarEx Pop ) = True + _ == _ = False 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,87 @@ -{-# 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 #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : HarmTrace.Models.Parser +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: 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 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 +{-# 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,29 +1,29 @@ - -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 - + +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,412 +1,395 @@ -{-# 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 ] +{-# 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 T4 +#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 + + -- blues + T_4_bls :: Final I DomClass -> Ton mode + + T_6_bor :: TMinBorrow -> Ton MajMode + + -- minor mode + Tm_1 :: SD MinMode 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_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) + +data DMinBorrow = Dm_24_bor (SD MinMode VIIb MajClass) + +data SMinBorrow = Sm_20_bor (SD MinMode IV MinClass) + | Sm_22_bor (SD MinMode IIb MajClass) -- Neapolitan + +-- Borrowings from major in a minor key +data TMajBorrow = T_21_bor (SD MajMode I MajClass) + +data DMajBorrow = D_24_bor (SD MajMode VII MinClass) + +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 + +-- Dimished tritone substitution accounting for dimished chord transistions +data Surface_Chord deg clss n where + Surface_Chord :: ChordToken + -> Surface_Chord deg clss (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 = 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/Tokenizer/Tokenizer.hs b/src/HarmTrace/Tokenizer/Tokenizer.hs --- a/src/HarmTrace/Tokenizer/Tokenizer.hs +++ b/src/HarmTrace/Tokenizer/Tokenizer.hs @@ -1,157 +1,155 @@ -{-# 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" +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +module HarmTrace.Tokenizer.Tokenizer ( parseRoot, parseShorthand + , 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 +-------------------------------------------------------------------------------- + +-- 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" + <|> Sus2 <$ pString "sus2" + "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 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" 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,319 +1,424 @@ -{-# 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 +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford +-- License : GPL3 +-- +-- Maintainer : bash@cs.uu.nl, jpm@cs.ox.ac.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Top-level file +-------------------------------------------------------------------------------- + +module Main where + +import System.Console.CmdArgs.Explicit hiding (Arg) + +import Constants (vERSION) + +import HarmTrace.HarmTrace +import HarmTrace.IO.Main +import HarmTrace.IO.Errors +import HarmTrace.IO.PrintTree +import HarmTrace.IO.BasePaths (setPaths) +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.Annotate ( simpleAnnotator, groupAnnotator + , mptreeAnnotator) +import HarmTrace.Audio.ChordTypes -- (AudioFeat, ChordBeatAnnotation, TimedData) +import HarmTrace.Base.MusicRep (Key) + +import Data.List (delete) +import System.FilePath (takeFileName) +import System.Exit (exitSuccess, exitFailure) +import Control.Monad (when) + + +-------------------------------------------------------------------------------- +-- Top-level main +-------------------------------------------------------------------------------- +harmTrace :: Mode [MyArgs] +harmTrace = (modes "harmtrace" emptyArgs "Harmonic Analysis and Retrieval of Music" + [parseMode, matchMode, recogniseMode]) + { modeGroupFlags = toGroup (inputFlags : helpVerFlags) } + +inputFlags :: Flag [MyArgs] +inputFlags = flagReq ["r", "read-flags"] (upd "ReadFlags") + "file" "File to read flags from" + +main :: IO () +main = do -- Parse the arguments + args <- processArgs harmTrace + + -- Check if we should get flags from a file + -- NOTE: reading flags such as --chords="A B" will not work, because + -- there are spaces inside the string "A B", and `words` isn't clever + -- enough to ignore those. + newArgs <- case (getArg args "ReadFlags") of + -- Nope, use the flags received + Nothing -> return args + -- Yes, read them from the file and overwrite the + -- received flags + Just f -> readFile f >>= + return . processValue harmTrace . words + + -- Check mode and redirect control to appropriate function + case (getArg newArgs "Mode") of + Just "Parse" -> mainParse newArgs + Just "Match" -> mainMatch newArgs + Just "Recognise" -> mainRecognise newArgs + Just m -> putStrLn ("Unknown mode: " ++ m) + Nothing -> do -- Handle help and version, if present + handleHelpVer newArgs harmTrace + putStrLn "Please supply a mode" + +-------------------------------------------------------------------------------- +-- Parse mode +-------------------------------------------------------------------------------- +parseMode :: Mode [MyArgs] +parseMode = mode "parse" [Arg "Mode" "Parse"] "Parse files into harmonic analysis trees" + (flagArg upd0 "") + ([flagReq ["g", "grammar"] updG "string" "Grammar to use (jazz|pop)" + ,flagReq ["c", "chords"] (upd "SourceInputString") "string" "Input chord sequence to parse" + ,flagReq ["i", "file"] (upd "SourceInputFile") "filepath" "Input file to parse" + ,flagReq ["d", "dir"] (upd "InputDir") "filepath" "Input directory to parse all files within" + ,flagReq ["o", "out"] (upd "BinaryOut") "filepath" "Output binary file to write parse results to" + -- We should add a flag for describing that when using -k we are + -- reading files in a different input syntax... + ,flagReq ["k", "key"] (upd "SourceKeyInputFile") "filepath" "Ground-truth key annotation file" + ,flagReq ["x", "key-dir"] (upd "AnnotationKeyInputDir") "filepath" "Ground-truth key annotation directory" + ,flagNone ["p", "print"] ((Switch "Print"):) "Output a .png of the parse tree" + ,flagNone ["s", "print-insertions"] ((Switch "PrintIns"):) "Show inserted nodes" + ] ++ helpVerFlags) + + where -- Flags without input + upd0 "--print" args = Right $ Switch "Print" : args + upd0 "-p" args = Right $ Switch "Print" : args + upd0 "--print-insertions" args = Right $ Switch "PrintIns" : args + upd0 "-s" args = Right $ Switch "PrintIns" : args + upd0 s _ = Left $ "Unknown argument: " ++ s + +mainParse :: [MyArgs] -> IO () +mainParse args = + do let cStr = getArg args "SourceInputString" + sif = getArg args "SourceInputFile" + ky = getArg args "SourceKeyInputFile" + bOut = getArg args "BinaryOut" + mdir = getArg args "InputDir" + kdir = getArg args "AnnotationKeyInputDir" + prnt = gotArg args "Print" + opts = if gotArg args "PrintIns" + then delete RemoveInsertions defaultOpts else defaultOpts + + -- Handle help and version, if present + handleHelpVer args parseMode + + case (getGram args) of + Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure + Just (GrammarEx g) -> + case (cStr, sif,mdir, prnt, ky, kdir) of + -- parse a string of chords + (Just c, Nothing, Nothing, False, Nothing, Nothing) -> + do pr <- parseTreeVerb g opts c + mapM_ (print . gTreeHead) (parsedPiece pr) + -- and print a parsetree + (Just c, Nothing, Nothing, True, Nothing, Nothing) -> + do pr <- parseTree g opts 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, False, Nothing, Nothing) -> + do pr <- readFile f1 >>= parseTreeVerb g opts + print (pieceTreeHAn pr) + mapM_ (print . gTreeHead) (parsedPiece pr) + (Nothing, Just f1, Nothing , True, Nothing, Nothing) -> + --with post processing + do pr <- readFile f1 >>= parseTree g opts + 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, Just dir, False, Nothing, Nothing) -> + parseDir g opts dir bOut + -- ** audio ground-truth annotation part ** + (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 opts key + print (pieceTreeHAn pr) + mapM_ (print . gTreeHead) (take 10 $ parsedPiece pr) + (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 opts 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 + (Nothing, Nothing, Just dir, False, Nothing, Just kd) -> + parseAnnotationDir g opts kd dir + -- Else throw error + _ -> usageError args err1 + +-------------------------------------------------------------------------------- +-- Match mode +-------------------------------------------------------------------------------- +matchMode :: Mode [MyArgs] +matchMode = mode "match" [Arg "Mode" "Match"] "Harmonic similarity matching" + (flagArg upd0 "") + ([flagReq ["m", "mode"] upd1 "string" "Matching mode (stdiff|lces-s|lcessim|hanlign|align)" + ,flagReq ["1", "sfile"] (upd "SourceInputFile") "filepath" "Source file to match" + ,flagReq ["2", "tfile"] (upd "TargetInputFile") "filepath" "Target file to match" + ,flagReq ["d", "dir"] (upd "InputDir") "filepath" "Input directory to parse all files within" + ,flagReq ["i", "in"] (upd "BinaryIn") "filepath" "Input binary file for matching" + ,flagNone ["s", "print-insertions"] ((Switch "PrintIns"):) "Show inserted nodes" + ,flagReq ["g", "grammar"] updG "string" "Grammar to use (jazz|pop)" + ] ++ helpVerFlags) + + where upd0 "--print-insertions" args = Right $ Switch "PrintIns" : args + upd0 "-s" args = Right $ Switch "PrintIns" : args + upd0 s _ = Left $ "Unknown argument: " ++ s + + upd1 "stdiff" args = Right $ (MatchMode STDiff) : args + upd1 "lces-s" args = Right $ (MatchMode LCESsize) : args + upd1 "lcessim" args = Right $ (MatchMode LCESsim) : args + upd1 "hanlign" args = Right $ (MatchMode HAnAlign) : args + upd1 "align" args = Right $ (MatchMode Align) : args + upd1 s _ = Left $ "Unknown match mode: " ++ s + +mainMatch :: [MyArgs] -> IO () +mainMatch args = + do let cStr = getArg args "SourceInputString" + sif = getArg args "SourceInputFile" + mf2 = getArg args "TargetInputFile" + mdir = getArg args "InputDir" + bIn = getArg args "BinaryIn" + me = getArg args "MaxErrorRate" + mode = getMode args + prnt = gotArg args "Print" + opts = if gotArg args "PrintIns" + then delete RemoveInsertions defaultOpts else defaultOpts + + -- Handle help and version, if present + handleHelpVer args matchMode + + case (getGram args) of + Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure + Just (GrammarEx g) -> + case (cStr,sif,mf2,mdir,prnt) of + -- Parse source and target file, show full output + (_, Just f1, Just f2, Nothing, _) -> + do c1 <- readFile' f1 + c2 <- readFile' f2 + matchFiles opts mode prnt c1 c2 f1 f2 + (Just c, Just f1, Nothing, Nothing, True) -> + matchFiles opts mode True c f1 (trimFilename c) (trimFilename f1) + -- match all files in one dir, show condensed output + (_,Nothing, Nothing, Just dir, False) -> dirMatch g opts bIn mode (fmap read 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." + +-------------------------------------------------------------------------------- +-- Recognise mode +-------------------------------------------------------------------------------- + +recogniseMode :: Mode [MyArgs] +recogniseMode = mode "recognise" [Arg "Mode" "Recognise"] "Recognise chords from audio files" + (flagArg upd0 "") + ([flagReq ["m", "mode"] upd1 "string" "Recognition mode (mptree|group|simple)" + ,flagReq ["i", "file"] (upd "SourceInputFile") "filepath" "Input file" + ,flagReq ["c", "gt"] (upd "GroundTruthInputFile") "filepath" "Ground truth chord annotation file (for evaluation)" + ,flagReq ["k", "key"] (upd "SourceKeyInputFile") "filepath" "Ground truth key annotation file" + ,flagReq ["d", "dir"] (upd "InputDir") "filepath" "Input directory" + ,flagReq ["v", "vamp-dir"] (upd "VampBaseDir") "filepath" "Vamp-plugin transform specification base directory" + ,flagReq ["o", "out-dir"] (upd "OutputDir") "filepath" "output directory (for logs and chords)" + ,flagReq ["f", "csv-dir"] (upd "CSVBaseDir") "filepath" "directory for storing the feature csv files" + ,flagReq ["t", "gt-dir"] (upd "GroundTruthInputDir") "filepath" "Ground truth chord annotation input directory (for evaluation)" + ,flagReq ["x", "key-dir"] (upd "AnnotationKeyInputDir") "filepath" "Ground truth chord annotation input directory (for evaluation)" + ,flagReq ["g", "grammar"] updG "string" "Grammar to use (jazz|pop)" + ,flagNone ["p", "print"] ((Switch "Print"):) "Output a .png of the parse tree" + ] ++ helpVerFlags) + + where upd0 "--print" args = Right $ Switch "Print" : args + upd0 "-p" args = Right $ Switch "Print" : args + upd0 s _ = Left $ "Unknown argument: " ++ s + + upd1 "group" args = Right $ (RecognitionMode (RecognitionFun groupAnnotator)) : args + upd1 "simple" args = Right $ (RecognitionMode (RecognitionFun simpleAnnotator)) : args + upd1 "mptree" args = Right $ (RecognitionMode (RecognitionFun mptreeAnnotator)) : args + upd1 s _ = Left $ "Unknown recognition mode: " ++ s + +mainRecognise :: [MyArgs] -> IO () +mainRecognise args = + do let af = getArg args "SourceInputFile" + gt = getArg args "GroundTruthInputFile" + key = getArg args "SourceKeyInputFile" + afdir = getArg args "InputDir" + gtdir = getArg args "GroundTruthInputDir" + keydir = getArg args "AnnotationKeyInputDir" + prnt = gotArg args "Print" + dirs = setPaths (getArg args "VampBaseDir") + (getArg args "CSVBaseDir") + (getArg args "OutputDir") + + + -- Handle help and version, if present + handleHelpVer args recogniseMode + + case (getGram args) of + Nothing -> putStrLn "Please supply a grammar to use" >> exitFailure + Just g -> + let ann :: Maybe [TimedData Key] -> AudioFeat -> ChordBeatAnnotation + ann = (getAnn args) g + in case (gt,af,key,gtdir,afdir,keydir) of + -- evaluates a single audio feature set + (Just g, Just a, Nothing, Nothing, Nothing, Nothing) -> + evaluateLabeling ann prnt g a Nothing >>= print + -- evaluates a single audio feature set and key annotation + (Just g, Just a, maybek, Nothing, Nothing, Nothing) -> + evaluateLabeling ann prnt g a maybek >>= print + -- evaluates a single audio feature set and prints the auto-labelling + -- This is the only option that automatically extracts features + -- from an audio file (if no features, and an audio file are found) + -- TODO enable feature extraction for all options + (Nothing, Just a, Nothing, Nothing, Nothing, Nothing) -> + printLabeling dirs ann a + -- 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, maybek) -> + batchLabeling ann gd ad maybek + _ -> usageError args err4 + +-------------------------------------------------------------------------------- +-- Arguments and utilities +-------------------------------------------------------------------------------- +data MyArgs = Grammar GrammarEx + | MatchMode MatchMode + | RecognitionMode RecognitionFun + | Arg String String + | Switch String + deriving (Eq, Show) + +newtype RecognitionFun = RecognitionFun (GrammarEx -> Maybe [TimedData Key] + -> AudioFeat -> ChordBeatAnnotation) + +instance Show RecognitionFun where + show _ = "RecognitionFun" + +instance Eq RecognitionFun where + _ == _ = error "please do not use this" + +emptyArgs :: [MyArgs] +emptyArgs = [] + +-- Grammar parser +updG :: String -> [MyArgs] -> Either String [MyArgs] +updG "jazz" args = Right $ (Grammar (GrammarEx Jazz)) : args +updG "pop" args = Right $ (Grammar (GrammarEx Pop)) : args +updG s _ = Left $ "Unknown grammar: " ++ s + +-- General update function +upd :: String -> String -> [MyArgs] -> Either String [MyArgs] +upd c s args = Right $ (Arg c s) : args + +getGram :: [MyArgs] -> Maybe GrammarEx +getGram [] = Nothing +getGram ((Grammar g):_) = Just g +getGram (_:t) = getGram t + +getMode :: [MyArgs] -> MatchMode +getMode [] = error "impossible?" +getMode ((MatchMode m):_) = m +getMode (_:t) = getMode t + +getAnn :: [MyArgs] -> (GrammarEx -> Maybe [TimedData Key] -> AudioFeat + -> ChordBeatAnnotation) +getAnn [] = error "impossible?" +getAnn ((RecognitionMode (RecognitionFun f)):_) = f +getAnn (_:t) = getAnn t + +gotArg :: [MyArgs] -> String -> Bool +gotArg [] _ = False +gotArg ((Switch k):_) s | k == s = True +gotArg (_:t) s = gotArg t s + +getArg :: [MyArgs] -> String -> Maybe String +getArg [] _ = Nothing +getArg ((Arg k v):_) s | k == s = Just v +getArg (_:t) s = getArg t s + +-- Help and Version flags, used in all modes +helpVerFlags :: [Flag [MyArgs]] +helpVerFlags = [ flagHelpSimple ((Switch "Help"):) + , flagVersion ((Switch "Version"):)] + +-- Handler for the Help and Version flags +handleHelpVer :: [MyArgs] -> Mode [MyArgs] -> IO () +handleHelpVer args mode = do + let ver = gotArg args "Version" + help = gotArg args "Help" + + -- Output version and exit + when ver $ putStrLn vERSION >> exitSuccess + + -- Output help and exit + when help $ print (helpText [] HelpFormatDefault mode) >> exitSuccess + +-------------------------------------------------------------------------------- +-- Misc +-------------------------------------------------------------------------------- +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." + +usageError :: [MyArgs] -> String -> IO () +usageError _args err = putStrLn err + +trimFilename :: String -> String +trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 + +-- by default all post processing operations are executed +defaultOpts :: [PPOption] +defaultOpts = [ RemovePDPT , RemoveInsertions + , MergeDelChords, ExpandChordDurations ]