packages feed

HarmTrace 1.0 → 2.0

raw patch · 56 files changed

+7561/−6340 lines, 56 filesdep +cmdargsdep +soxdep −regex-tdfadep ~basedep ~template-haskelldep ~uu-parsinglibbuild-type:Customsetup-changed

Dependencies added: cmdargs, sox

Dependencies removed: regex-tdfa

Dependency ranges changed: base, template-haskell, uu-parsinglib

Files

HarmTrace.cabal view
@@ -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.-                        <http://dreixel.net/research/pdf/fmmh.pdf>--copyright:              (c) 2010--2011 Universiteit Utrecht-license:                GPL-3-license-file:           LICENSE-author:                 W. Bas de Haas and Jose Pedro Magalhaes-stability:              experimental-maintainer:             bash@cs.uu.nl, jpm@cs.uu.nl-homepage:               http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace-category:               Music-build-type:             Simple-cabal-version:          >= 1.6-tested-with:            GHC == 7.0.3, GHC == 7.2.1--extra-source-files:     README--executable harmtrace-  hs-source-dirs:       src-  other-modules:        HarmTrace.HarmTrace--                        HarmTrace.Audio.Annotations-                        HarmTrace.Audio.BeatChroma-                        HarmTrace.Audio.ChordTypes-                        HarmTrace.Audio.Evaluation-                        HarmTrace.Audio.Harmonize-                        HarmTrace.Audio.Key-                        HarmTrace.Audio.Parser-                        HarmTrace.Audio.Utils--                        HarmTrace.Base.MusicRep-                        HarmTrace.Base.Parsing-                        HarmTrace.Base.TypeLevel--                        HarmTrace.HAnTree.Binary-                        HarmTrace.HAnTree.HAn-                        HarmTrace.HAnTree.HAnParser-                        HarmTrace.HAnTree.PostProcess-                        HarmTrace.HAnTree.ToHAnTree-                        HarmTrace.HAnTree.Tree--                        HarmTrace.IO.Errors-                        HarmTrace.IO.Main-                        HarmTrace.IO.PrintTree--                        HarmTrace.Matching.Alignment-                        HarmTrace.Matching.HChord-                        HarmTrace.Matching.Sim-                        HarmTrace.Matching.SimpleChord-                        HarmTrace.Matching.Standard-                        HarmTrace.Matching.GuptaNishimura--                        HarmTrace.Models.Models-                        HarmTrace.Models.Parser--                        HarmTrace.Models.Jazz.Instances-                        HarmTrace.Models.Jazz.Main-                        HarmTrace.Models.Jazz.Model--                        HarmTrace.Models.Pop.Instances-                        HarmTrace.Models.Pop.Main-                        HarmTrace.Models.Pop.Model--                        HarmTrace.Tokenizer.Tokenizer-                        HarmTrace.Tokenizer.Tokens--  main-is:              Main.hs-  build-depends:        base >= 4.2 && < 4.5, template-haskell >=2.4 && <2.7,-                        mtl, directory, filepath, array, parallel >= 3,-                        Diff == 0.1.*, parseargs >= 0.1.3.2, -                        regex-tdfa == 1.1.*, process >= 1.0,-                        uu-parsinglib >= 2.7.1, ListLike >= 3.0.1,-                        vector >= 0.7, deepseq,-                        instant-generics >= 0.3.1 && < 0.4, binary == 0.5.*,-                        hmatrix >= 0.11.0.3, hmatrix-gsl-stats >= 0.1.2.9--  cpp-options:          -DAUDIO--  ghc-options:          -Wall-                        -O2 -fno-spec-constr-count -funbox-strict-fields-                        -fcontext-stack=50-                        -threaded -feager-blackholing -rtsopts--  ghc-prof-options:     -auto-all+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.
+                        <http://dreixel.net/research/pdf/fmmh.pdf>
+
+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
LICENSE view
@@ -1,674 +1,674 @@-                    GNU GENERAL PUBLIC LICENSE-                       Version 3, 29 June 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.--                            Preamble--  The GNU General Public License is a free, copyleft license for-software and other kinds of works.--  The licenses for most software and other practical works are designed-to take away your freedom to share and change the works.  By contrast,-the GNU General Public License is intended to guarantee your freedom to-share and change all versions of a program--to make sure it remains free-software for all its users.  We, the Free Software Foundation, use the-GNU General Public License for most of our software; it applies also to-any other work released this way by its authors.  You can apply it to-your programs, too.--  When we speak of free software, we are referring to freedom, not-price.  Our General Public Licenses are designed to make sure that you-have the freedom to distribute copies of free software (and charge for-them if you wish), that you receive source code or can get it if you-want it, that you can change the software or use pieces of it in new-free programs, and that you know you can do these things.--  To protect your rights, we need to prevent others from denying you-these rights or asking you to surrender the rights.  Therefore, you have-certain responsibilities if you distribute copies of the software, or if-you modify it: responsibilities to respect the freedom of others.--  For example, if you distribute copies of such a program, whether-gratis or for a fee, you must pass on to the recipients the same-freedoms that you received.  You must make sure that they, too, receive-or can get the source code.  And you must show them these terms so they-know their rights.--  Developers that use the GNU GPL protect your rights with two steps:-(1) assert copyright on the software, and (2) offer you this License-giving you legal permission to copy, distribute and/or modify it.--  For the developers' and authors' protection, the GPL clearly explains-that there is no warranty for this free software.  For both users' and-authors' sake, the GPL requires that modified versions be marked as-changed, so that their problems will not be attributed erroneously to-authors of previous versions.--  Some devices are designed to deny users access to install or run-modified versions of the software inside them, although the manufacturer-can do so.  This is fundamentally incompatible with the aim of-protecting users' freedom to change the software.  The systematic-pattern of such abuse occurs in the area of products for individuals to-use, which is precisely where it is most unacceptable.  Therefore, we-have designed this version of the GPL to prohibit the practice for those-products.  If such problems arise substantially in other domains, we-stand ready to extend this provision to those domains in future versions-of the GPL, as needed to protect the freedom of users.--  Finally, every program is threatened constantly by software patents.-States should not allow patents to restrict development and use of-software on general-purpose computers, but in those that do, we wish to-avoid the special danger that patents applied to a free program could-make it effectively proprietary.  To prevent this, the GPL assures that-patents cannot be used to render the program non-free.--  The precise terms and conditions for copying, distribution and-modification follow.--                       TERMS AND CONDITIONS--  0. Definitions.--  "This License" refers to version 3 of the GNU General Public License.--  "Copyright" also means copyright-like laws that apply to other kinds of-works, such as semiconductor masks.--  "The Program" refers to any copyrightable work licensed under this-License.  Each licensee is addressed as "you".  "Licensees" and-"recipients" may be individuals or organizations.--  To "modify" a work means to copy from or adapt all or part of the work-in a fashion requiring copyright permission, other than the making of an-exact copy.  The resulting work is called a "modified version" of the-earlier work or a work "based on" the earlier work.--  A "covered work" means either the unmodified Program or a work based-on the Program.--  To "propagate" a work means to do anything with it that, without-permission, would make you directly or secondarily liable for-infringement under applicable copyright law, except executing it on a-computer or modifying a private copy.  Propagation includes copying,-distribution (with or without modification), making available to the-public, and in some countries other activities as well.--  To "convey" a work means any kind of propagation that enables other-parties to make or receive copies.  Mere interaction with a user through-a computer network, with no transfer of a copy, is not conveying.--  An interactive user interface displays "Appropriate Legal Notices"-to the extent that it includes a convenient and prominently visible-feature that (1) displays an appropriate copyright notice, and (2)-tells the user that there is no warranty for the work (except to the-extent that warranties are provided), that licensees may convey the-work under this License, and how to view a copy of this License.  If-the interface presents a list of user commands or options, such as a-menu, a prominent item in the list meets this criterion.--  1. Source Code.--  The "source code" for a work means the preferred form of the work-for making modifications to it.  "Object code" means any non-source-form of a work.--  A "Standard Interface" means an interface that either is an official-standard defined by a recognized standards body, or, in the case of-interfaces specified for a particular programming language, one that-is widely used among developers working in that language.--  The "System Libraries" of an executable work include anything, other-than the work as a whole, that (a) is included in the normal form of-packaging a Major Component, but which is not part of that Major-Component, and (b) serves only to enable use of the work with that-Major Component, or to implement a Standard Interface for which an-implementation is available to the public in source code form.  A-"Major Component", in this context, means a major essential component-(kernel, window system, and so on) of the specific operating system-(if any) on which the executable work runs, or a compiler used to-produce the work, or an object code interpreter used to run it.--  The "Corresponding Source" for a work in object code form means all-the source code needed to generate, install, and (for an executable-work) run the object code and to modify the work, including scripts to-control those activities.  However, it does not include the work's-System Libraries, or general-purpose tools or generally available free-programs which are used unmodified in performing those activities but-which are not part of the work.  For example, Corresponding Source-includes interface definition files associated with source files for-the work, and the source code for shared libraries and dynamically-linked subprograms that the work is specifically designed to require,-such as by intimate data communication or control flow between those-subprograms and other parts of the work.--  The Corresponding Source need not include anything that users-can regenerate automatically from other parts of the Corresponding-Source.--  The Corresponding Source for a work in source code form is that-same work.--  2. Basic Permissions.--  All rights granted under this License are granted for the term of-copyright on the Program, and are irrevocable provided the stated-conditions are met.  This License explicitly affirms your unlimited-permission to run the unmodified Program.  The output from running a-covered work is covered by this License only if the output, given its-content, constitutes a covered work.  This License acknowledges your-rights of fair use or other equivalent, as provided by copyright law.--  You may make, run and propagate covered works that you do not-convey, without conditions so long as your license otherwise remains-in force.  You may convey covered works to others for the sole purpose-of having them make modifications exclusively for you, or provide you-with facilities for running those works, provided that you comply with-the terms of this License in conveying all material for which you do-not control copyright.  Those thus making or running the covered works-for you must do so exclusively on your behalf, under your direction-and control, on terms that prohibit them from making any copies of-your copyrighted material outside their relationship with you.--  Conveying under any other circumstances is permitted solely under-the conditions stated below.  Sublicensing is not allowed; section 10-makes it unnecessary.--  3. Protecting Users' Legal Rights From Anti-Circumvention Law.--  No covered work shall be deemed part of an effective technological-measure under any applicable law fulfilling obligations under article-11 of the WIPO copyright treaty adopted on 20 December 1996, or-similar laws prohibiting or restricting circumvention of such-measures.--  When you convey a covered work, you waive any legal power to forbid-circumvention of technological measures to the extent such circumvention-is effected by exercising rights under this License with respect to-the covered work, and you disclaim any intention to limit operation or-modification of the work as a means of enforcing, against the work's-users, your or third parties' legal rights to forbid circumvention of-technological measures.--  4. Conveying Verbatim Copies.--  You may convey verbatim copies of the Program's source code as you-receive it, in any medium, provided that you conspicuously and-appropriately publish on each copy an appropriate copyright notice;-keep intact all notices stating that this License and any-non-permissive terms added in accord with section 7 apply to the code;-keep intact all notices of the absence of any warranty; and give all-recipients a copy of this License along with the Program.--  You may charge any price or no price for each copy that you convey,-and you may offer support or warranty protection for a fee.--  5. Conveying Modified Source Versions.--  You may convey a work based on the Program, or the modifications to-produce it from the Program, in the form of source code under the-terms of section 4, provided that you also meet all of these conditions:--    a) The work must carry prominent notices stating that you modified-    it, and giving a relevant date.--    b) The work must carry prominent notices stating that it is-    released under this License and any conditions added under section-    7.  This requirement modifies the requirement in section 4 to-    "keep intact all notices".--    c) You must license the entire work, as a whole, under this-    License to anyone who comes into possession of a copy.  This-    License will therefore apply, along with any applicable section 7-    additional terms, to the whole of the work, and all its parts,-    regardless of how they are packaged.  This License gives no-    permission to license the work in any other way, but it does not-    invalidate such permission if you have separately received it.--    d) If the work has interactive user interfaces, each must display-    Appropriate Legal Notices; however, if the Program has interactive-    interfaces that do not display Appropriate Legal Notices, your-    work need not make them do so.--  A compilation of a covered work with other separate and independent-works, which are not by their nature extensions of the covered work,-and which are not combined with it such as to form a larger program,-in or on a volume of a storage or distribution medium, is called an-"aggregate" if the compilation and its resulting copyright are not-used to limit the access or legal rights of the compilation's users-beyond what the individual works permit.  Inclusion of a covered work-in an aggregate does not cause this License to apply to the other-parts of the aggregate.--  6. Conveying Non-Source Forms.--  You may convey a covered work in object code form under the terms-of sections 4 and 5, provided that you also convey the-machine-readable Corresponding Source under the terms of this License,-in one of these ways:--    a) Convey the object code in, or embodied in, a physical product-    (including a physical distribution medium), accompanied by the-    Corresponding Source fixed on a durable physical medium-    customarily used for software interchange.--    b) Convey the object code in, or embodied in, a physical product-    (including a physical distribution medium), accompanied by a-    written offer, valid for at least three years and valid for as-    long as you offer spare parts or customer support for that product-    model, to give anyone who possesses the object code either (1) a-    copy of the Corresponding Source for all the software in the-    product that is covered by this License, on a durable physical-    medium customarily used for software interchange, for a price no-    more than your reasonable cost of physically performing this-    conveying of source, or (2) access to copy the-    Corresponding Source from a network server at no charge.--    c) Convey individual copies of the object code with a copy of the-    written offer to provide the Corresponding Source.  This-    alternative is allowed only occasionally and noncommercially, and-    only if you received the object code with such an offer, in accord-    with subsection 6b.--    d) Convey the object code by offering access from a designated-    place (gratis or for a charge), and offer equivalent access to the-    Corresponding Source in the same way through the same place at no-    further charge.  You need not require recipients to copy the-    Corresponding Source along with the object code.  If the place to-    copy the object code is a network server, the Corresponding Source-    may be on a different server (operated by you or a third party)-    that supports equivalent copying facilities, provided you maintain-    clear directions next to the object code saying where to find the-    Corresponding Source.  Regardless of what server hosts the-    Corresponding Source, you remain obligated to ensure that it is-    available for as long as needed to satisfy these requirements.--    e) Convey the object code using peer-to-peer transmission, provided-    you inform other peers where the object code and Corresponding-    Source of the work are being offered to the general public at no-    charge under subsection 6d.--  A separable portion of the object code, whose source code is excluded-from the Corresponding Source as a System Library, need not be-included in conveying the object code work.--  A "User Product" is either (1) a "consumer product", which means any-tangible personal property which is normally used for personal, family,-or household purposes, or (2) anything designed or sold for incorporation-into a dwelling.  In determining whether a product is a consumer product,-doubtful cases shall be resolved in favor of coverage.  For a particular-product received by a particular user, "normally used" refers to a-typical or common use of that class of product, regardless of the status-of the particular user or of the way in which the particular user-actually uses, or expects or is expected to use, the product.  A product-is a consumer product regardless of whether the product has substantial-commercial, industrial or non-consumer uses, unless such uses represent-the only significant mode of use of the product.--  "Installation Information" for a User Product means any methods,-procedures, authorization keys, or other information required to install-and execute modified versions of a covered work in that User Product from-a modified version of its Corresponding Source.  The information must-suffice to ensure that the continued functioning of the modified object-code is in no case prevented or interfered with solely because-modification has been made.--  If you convey an object code work under this section in, or with, or-specifically for use in, a User Product, and the conveying occurs as-part of a transaction in which the right of possession and use of the-User Product is transferred to the recipient in perpetuity or for a-fixed term (regardless of how the transaction is characterized), the-Corresponding Source conveyed under this section must be accompanied-by the Installation Information.  But this requirement does not apply-if neither you nor any third party retains the ability to install-modified object code on the User Product (for example, the work has-been installed in ROM).--  The requirement to provide Installation Information does not include a-requirement to continue to provide support service, warranty, or updates-for a work that has been modified or installed by the recipient, or for-the User Product in which it has been modified or installed.  Access to a-network may be denied when the modification itself materially and-adversely affects the operation of the network or violates the rules and-protocols for communication across the network.--  Corresponding Source conveyed, and Installation Information provided,-in accord with this section must be in a format that is publicly-documented (and with an implementation available to the public in-source code form), and must require no special password or key for-unpacking, reading or copying.--  7. Additional Terms.--  "Additional permissions" are terms that supplement the terms of this-License by making exceptions from one or more of its conditions.-Additional permissions that are applicable to the entire Program shall-be treated as though they were included in this License, to the extent-that they are valid under applicable law.  If additional permissions-apply only to part of the Program, that part may be used separately-under those permissions, but the entire Program remains governed by-this License without regard to the additional permissions.--  When you convey a copy of a covered work, you may at your option-remove any additional permissions from that copy, or from any part of-it.  (Additional permissions may be written to require their own-removal in certain cases when you modify the work.)  You may place-additional permissions on material, added by you to a covered work,-for which you have or can give appropriate copyright permission.--  Notwithstanding any other provision of this License, for material you-add to a covered work, you may (if authorized by the copyright holders of-that material) supplement the terms of this License with terms:--    a) Disclaiming warranty or limiting liability differently from the-    terms of sections 15 and 16 of this License; or--    b) Requiring preservation of specified reasonable legal notices or-    author attributions in that material or in the Appropriate Legal-    Notices displayed by works containing it; or--    c) Prohibiting misrepresentation of the origin of that material, or-    requiring that modified versions of such material be marked in-    reasonable ways as different from the original version; or--    d) Limiting the use for publicity purposes of names of licensors or-    authors of the material; or--    e) Declining to grant rights under trademark law for use of some-    trade names, trademarks, or service marks; or--    f) Requiring indemnification of licensors and authors of that-    material by anyone who conveys the material (or modified versions of-    it) with contractual assumptions of liability to the recipient, for-    any liability that these contractual assumptions directly impose on-    those licensors and authors.--  All other non-permissive additional terms are considered "further-restrictions" within the meaning of section 10.  If the Program as you-received it, or any part of it, contains a notice stating that it is-governed by this License along with a term that is a further-restriction, you may remove that term.  If a license document contains-a further restriction but permits relicensing or conveying under this-License, you may add to a covered work material governed by the terms-of that license document, provided that the further restriction does-not survive such relicensing or conveying.--  If you add terms to a covered work in accord with this section, you-must place, in the relevant source files, a statement of the-additional terms that apply to those files, or a notice indicating-where to find the applicable terms.--  Additional terms, permissive or non-permissive, may be stated in the-form of a separately written license, or stated as exceptions;-the above requirements apply either way.--  8. Termination.--  You may not propagate or modify a covered work except as expressly-provided under this License.  Any attempt otherwise to propagate or-modify it is void, and will automatically terminate your rights under-this License (including any patent licenses granted under the third-paragraph of section 11).--  However, if you cease all violation of this License, then your-license from a particular copyright holder is reinstated (a)-provisionally, unless and until the copyright holder explicitly and-finally terminates your license, and (b) permanently, if the copyright-holder fails to notify you of the violation by some reasonable means-prior to 60 days after the cessation.--  Moreover, your license from a particular copyright holder is-reinstated permanently if the copyright holder notifies you of the-violation by some reasonable means, this is the first time you have-received notice of violation of this License (for any work) from that-copyright holder, and you cure the violation prior to 30 days after-your receipt of the notice.--  Termination of your rights under this section does not terminate the-licenses of parties who have received copies or rights from you under-this License.  If your rights have been terminated and not permanently-reinstated, you do not qualify to receive new licenses for the same-material under section 10.--  9. Acceptance Not Required for Having Copies.--  You are not required to accept this License in order to receive or-run a copy of the Program.  Ancillary propagation of a covered work-occurring solely as a consequence of using peer-to-peer transmission-to receive a copy likewise does not require acceptance.  However,-nothing other than this License grants you permission to propagate or-modify any covered work.  These actions infringe copyright if you do-not accept this License.  Therefore, by modifying or propagating a-covered work, you indicate your acceptance of this License to do so.--  10. Automatic Licensing of Downstream Recipients.--  Each time you convey a covered work, the recipient automatically-receives a license from the original licensors, to run, modify and-propagate that work, subject to this License.  You are not responsible-for enforcing compliance by third parties with this License.--  An "entity transaction" is a transaction transferring control of an-organization, or substantially all assets of one, or subdividing an-organization, or merging organizations.  If propagation of a covered-work results from an entity transaction, each party to that-transaction who receives a copy of the work also receives whatever-licenses to the work the party's predecessor in interest had or could-give under the previous paragraph, plus a right to possession of the-Corresponding Source of the work from the predecessor in interest, if-the predecessor has it or can get it with reasonable efforts.--  You may not impose any further restrictions on the exercise of the-rights granted or affirmed under this License.  For example, you may-not impose a license fee, royalty, or other charge for exercise of-rights granted under this License, and you may not initiate litigation-(including a cross-claim or counterclaim in a lawsuit) alleging that-any patent claim is infringed by making, using, selling, offering for-sale, or importing the Program or any portion of it.--  11. Patents.--  A "contributor" is a copyright holder who authorizes use under this-License of the Program or a work on which the Program is based.  The-work thus licensed is called the contributor's "contributor version".--  A contributor's "essential patent claims" are all patent claims-owned or controlled by the contributor, whether already acquired or-hereafter acquired, that would be infringed by some manner, permitted-by this License, of making, using, or selling its contributor version,-but do not include claims that would be infringed only as a-consequence of further modification of the contributor version.  For-purposes of this definition, "control" includes the right to grant-patent sublicenses in a manner consistent with the requirements of-this License.--  Each contributor grants you a non-exclusive, worldwide, royalty-free-patent license under the contributor's essential patent claims, to-make, use, sell, offer for sale, import and otherwise run, modify and-propagate the contents of its contributor version.--  In the following three paragraphs, a "patent license" is any express-agreement or commitment, however denominated, not to enforce a patent-(such as an express permission to practice a patent or covenant not to-sue for patent infringement).  To "grant" such a patent license to a-party means to make such an agreement or commitment not to enforce a-patent against the party.--  If you convey a covered work, knowingly relying on a patent license,-and the Corresponding Source of the work is not available for anyone-to copy, free of charge and under the terms of this License, through a-publicly available network server or other readily accessible means,-then you must either (1) cause the Corresponding Source to be so-available, or (2) arrange to deprive yourself of the benefit of the-patent license for this particular work, or (3) arrange, in a manner-consistent with the requirements of this License, to extend the patent-license to downstream recipients.  "Knowingly relying" means you have-actual knowledge that, but for the patent license, your conveying the-covered work in a country, or your recipient's use of the covered work-in a country, would infringe one or more identifiable patents in that-country that you have reason to believe are valid.--  If, pursuant to or in connection with a single transaction or-arrangement, you convey, or propagate by procuring conveyance of, a-covered work, and grant a patent license to some of the parties-receiving the covered work authorizing them to use, propagate, modify-or convey a specific copy of the covered work, then the patent license-you grant is automatically extended to all recipients of the covered-work and works based on it.--  A patent license is "discriminatory" if it does not include within-the scope of its coverage, prohibits the exercise of, or is-conditioned on the non-exercise of one or more of the rights that are-specifically granted under this License.  You may not convey a covered-work if you are a party to an arrangement with a third party that is-in the business of distributing software, under which you make payment-to the third party based on the extent of your activity of conveying-the work, and under which the third party grants, to any of the-parties who would receive the covered work from you, a discriminatory-patent license (a) in connection with copies of the covered work-conveyed by you (or copies made from those copies), or (b) primarily-for and in connection with specific products or compilations that-contain the covered work, unless you entered into that arrangement,-or that patent license was granted, prior to 28 March 2007.--  Nothing in this License shall be construed as excluding or limiting-any implied license or other defenses to infringement that may-otherwise be available to you under applicable patent law.--  12. No Surrender of Others' Freedom.--  If conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License.  If you cannot convey a-covered work so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you may-not convey it at all.  For example, if you agree to terms that obligate you-to collect a royalty for further conveying from those to whom you convey-the Program, the only way you could satisfy both those terms and this-License would be to refrain entirely from conveying the Program.--  13. Use with the GNU Affero General Public License.--  Notwithstanding any other provision of this License, you have-permission to link or combine any covered work with a work licensed-under version 3 of the GNU Affero General Public License into a single-combined work, and to convey the resulting work.  The terms of this-License will continue to apply to the part which is the covered work,-but the special requirements of the GNU Affero General Public License,-section 13, concerning interaction through a network will apply to the-combination as such.--  14. Revised Versions of this License.--  The Free Software Foundation may publish revised and/or new versions of-the GNU General Public License from time to time.  Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.--  Each version is given a distinguishing version number.  If the-Program specifies that a certain numbered version of the GNU General-Public License "or any later version" applies to it, you have the-option of following the terms and conditions either of that numbered-version or of any later version published by the Free Software-Foundation.  If the Program does not specify a version number of the-GNU General Public License, you may choose any version ever published-by the Free Software Foundation.--  If the Program specifies that a proxy can decide which future-versions of the GNU General Public License can be used, that proxy's-public statement of acceptance of a version permanently authorizes you-to choose that version for the Program.--  Later license versions may give you additional or different-permissions.  However, no additional obligations are imposed on any-author or copyright holder as a result of your choosing to follow a-later version.--  15. Disclaimer of Warranty.--  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY-APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM-IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.--  16. Limitation of Liability.--  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF-SUCH DAMAGES.--  17. Interpretation of Sections 15 and 16.--  If the disclaimer of warranty and limitation of liability provided-above cannot be given local legal effect according to their terms,-reviewing courts shall apply local law that most closely approximates-an absolute waiver of all civil liability in connection with the-Program, unless a warranty or assumption of liability accompanies a-copy of the Program in return for a fee.--                     END OF TERMS AND CONDITIONS--            How to Apply These Terms to Your New Programs--  If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these terms.--  To do so, attach the following notices to the program.  It is safest-to attach them to the start of each source file to most effectively-state the exclusion of warranty; and each file should have at least-the "copyright" line and a pointer to where the full notice is found.--    <one line to give the program's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    This program is free software: you can redistribute it and/or modify-    it under the terms of the GNU General Public License as published by-    the Free Software Foundation, either version 3 of the License, or-    (at your option) any later version.--    This program is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-    GNU General Public License for more details.--    You should have received a copy of the GNU General Public License-    along with this program.  If not, see <http://www.gnu.org/licenses/>.--Also add information on how to contact you by electronic and paper mail.--  If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:--    <program>  Copyright (C) <year>  <name of author>-    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.-    This is free software, and you are welcome to redistribute it-    under certain conditions; type `show c' for details.--The hypothetical commands `show w' and `show c' should show the appropriate-parts of the General Public License.  Of course, your program's commands-might be different; for a GUI interface, you would use an "about box".--  You should also get your employer (if you work as a programmer) or school,-if any, to sign a "copyright disclaimer" for the program, if necessary.-For more information on this, and how to apply and follow the GNU GPL, see-<http://www.gnu.org/licenses/>.--  The GNU General Public License does not permit incorporating your program-into proprietary programs.  If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications with-the library.  If this is what you want to do, use the GNU Lesser General-Public License instead of this License.  But first, please read+                    GNU GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+  The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works.  By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users.  We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors.  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+  To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights.  Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received.  You must make sure that they, too, receive
+or can get the source code.  And you must show them these terms so they
+know their rights.
+
+  Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+  For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software.  For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+  Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so.  This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software.  The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable.  Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products.  If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+  Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary.  To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                       TERMS AND CONDITIONS
+
+  0. Definitions.
+
+  "This License" refers to version 3 of the GNU General Public License.
+
+  "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+  "The Program" refers to any copyrightable work licensed under this
+License.  Each licensee is addressed as "you".  "Licensees" and
+"recipients" may be individuals or organizations.
+
+  To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy.  The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+  A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+  To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy.  Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+  To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies.  Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+  An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License.  If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+  1. Source Code.
+
+  The "source code" for a work means the preferred form of the work
+for making modifications to it.  "Object code" means any non-source
+form of a work.
+
+  A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+  The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form.  A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+  The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities.  However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work.  For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+  The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+  The Corresponding Source for a work in source code form is that
+same work.
+
+  2. Basic Permissions.
+
+  All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met.  This License explicitly affirms your unlimited
+permission to run the unmodified Program.  The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work.  This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+  You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force.  You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright.  Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+  Conveying under any other circumstances is permitted solely under
+the conditions stated below.  Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+  No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+  When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+  4. Conveying Verbatim Copies.
+
+  You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+  You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+  5. Conveying Modified Source Versions.
+
+  You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+    a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+
+    b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under section
+    7.  This requirement modifies the requirement in section 4 to
+    "keep intact all notices".
+
+    c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy.  This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged.  This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+
+    d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+  A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit.  Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+  6. Conveying Non-Source Forms.
+
+  You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+    a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+
+    b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the
+    Corresponding Source from a network server at no charge.
+
+    c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source.  This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+
+    d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge.  You need not require recipients to copy the
+    Corresponding Source along with the object code.  If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source.  Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+
+    e) Convey the object code using peer-to-peer transmission, provided
+    you inform other peers where the object code and Corresponding
+    Source of the work are being offered to the general public at no
+    charge under subsection 6d.
+
+  A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+  A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling.  In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage.  For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product.  A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+  "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source.  The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+  If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information.  But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+  The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed.  Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+  Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+  7. Additional Terms.
+
+  "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law.  If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+  When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it.  (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.)  You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+  Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+    a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+
+    b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+
+    c) Prohibiting misrepresentation of the origin of that material, or
+    requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+
+    d) Limiting the use for publicity purposes of names of licensors or
+    authors of the material; or
+
+    e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+
+    f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions of
+    it) with contractual assumptions of liability to the recipient, for
+    any liability that these contractual assumptions directly impose on
+    those licensors and authors.
+
+  All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10.  If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term.  If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+  If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+  Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+  8. Termination.
+
+  You may not propagate or modify a covered work except as expressly
+provided under this License.  Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+  However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+  Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+  Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License.  If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+  9. Acceptance Not Required for Having Copies.
+
+  You are not required to accept this License in order to receive or
+run a copy of the Program.  Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance.  However,
+nothing other than this License grants you permission to propagate or
+modify any covered work.  These actions infringe copyright if you do
+not accept this License.  Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+  10. Automatic Licensing of Downstream Recipients.
+
+  Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License.  You are not responsible
+for enforcing compliance by third parties with this License.
+
+  An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations.  If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+  You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License.  For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+  11. Patents.
+
+  A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based.  The
+work thus licensed is called the contributor's "contributor version".
+
+  A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version.  For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+  Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+  In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement).  To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+  If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients.  "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+  If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+  A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License.  You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+  Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+  12. No Surrender of Others' Freedom.
+
+  If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all.  For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+  13. Use with the GNU Affero General Public License.
+
+  Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work.  The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+  14. Revised Versions of this License.
+
+  The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+  Each version is given a distinguishing version number.  If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation.  If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+  If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+  Later license versions may give you additional or different
+permissions.  However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation, either version 3 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+  If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+    <program>  Copyright (C) <year>  <name of author>
+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+  You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+  The GNU General Public License does not permit incorporating your program
+into proprietary programs.  If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.  But first, please read
 <http://www.gnu.org/philosophy/why-not-lgpl.html>.
README view
@@ -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
Setup.hs view
@@ -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
+ src/Constants.hs view
@@ -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
+ src/HarmTrace/Audio/Annotate.hs view
@@ -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
+
+ src/HarmTrace/Audio/AnnotationParser.hs view
@@ -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: <http://isophonics.net/content/reference-annotations>
+--------------------------------------------------------------------------------
+
+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'
− src/HarmTrace/Audio/Annotations.hs 
@@ -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
− src/HarmTrace/Audio/BeatChroma.hs 
@@ -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
src/HarmTrace/Audio/ChordTypes.hs view
@@ -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:
+--
+-- * <http://www.vamp-plugins.org>
+--
+-- * <http://isophonics.net/nnls-chroma>
+--
+-- * <http://omras2.org/SonicAnnotator>
+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
+ src/HarmTrace/Audio/ChromaChord.hs view
@@ -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
+
+ src/HarmTrace/Audio/ChromaKey.hs view
@@ -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
+          ]
+ src/HarmTrace/Audio/DataParser.hs view
@@ -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
src/HarmTrace/Audio/Evaluation.hs view
@@ -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         
+
+
− src/HarmTrace/Audio/Harmonize.hs 
@@ -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-
src/HarmTrace/Audio/Key.hs view
@@ -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
+
− src/HarmTrace/Audio/Parser.hs 
@@ -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
+ src/HarmTrace/Audio/Statistical.hs view
@@ -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 <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 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..] 
+
+
− src/HarmTrace/Audio/Utils.hs 
@@ -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
src/HarmTrace/Base/MusicRep.hs view
@@ -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
src/HarmTrace/Base/Parsing.hs view
@@ -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
+
src/HarmTrace/Base/TypeLevel.hs view
@@ -1,81 +1,81 @@-{-# LANGUAGE EmptyDataDecls           #-}-{-# LANGUAGE KindSignatures           #-}-{-# LANGUAGE TypeFamilies             #-}-{-# LANGUAGE UndecidableInstances     #-}-{-# LANGUAGE ScopedTypeVariables      #-}-{-# LANGUAGE DeriveDataTypeable       #-}--module HarmTrace.Base.TypeLevel (-      Su, Ze -    , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10-    , T11, T12, T13, T14, T15, T16, T17, T18, T19, T20-    , ToNat(..)-  ) where--import Data.Typeable----- Type level peano naturals-data Su :: * -> *  deriving Typeable-data Ze :: *       deriving Typeable---- Some shorthands-type T0 = Ze-type T1 = Su T0-type T2 = Su T1-type T3 = Su T2-type T4 = Su T3-type T5 = Su T4-type T6 = Su T5-type T7 = Su T6-type T8 = Su T7-type T9 = Su T8-type T10 = Su T9-type T11 = Su T10-type T12 = Su T11-type T13 = Su T12-type T14 = Su T13-type T15 = Su T14-type T16 = Su T15-type T17 = Su T16-type T18 = Su T17-type T19 = Su T18-type T20 = Su T19--class ToNat n where-  toNat :: n -> Int--instance ToNat Ze where toNat _ = 0-instance (ToNat n) => ToNat (Su n) where toNat _ = 1 + toNat (undefined :: n)-{---- Below is some experimentation...---- A degree has a distance to root in semi-tones (n in T0..T11) and a --- class (major or minor)-data Degree n cls---- Transposing is a bit like addition...-type family Transpose m n--- ... but we normalize at the end to stay within T0..T11-type instance Transpose m T0 = Norm m-type instance Transpose m (Su n) = Transpose (Su m) n---- Normalizing is the same as subtracting T12, but only if we can. Else we keep--- the type unchanged.-type Norm m = Sub m T12 m---- Subtraction with an extra type for failure-type family Sub m n fail--- Inductive case-type instance Sub (Su m) (Su n) fail = Sub m n fail--- Base case, subtraction succeeded-type instance Sub m T0 fail = m--- Base case, subtraction failed-type instance Sub T0 (Su n) fail = fail---- A secondary dominant is a transposition by 7 semi-tones-type SD deg = Transpose deg T7---- A tritone substitution is a transposition by 6 semi-tones-type TS deg = Transpose deg T6--}+{-# LANGUAGE EmptyDataDecls           #-}
+{-# LANGUAGE KindSignatures           #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE DeriveDataTypeable       #-}
+
+module HarmTrace.Base.TypeLevel (
+      Su, Ze 
+    , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10
+    , T11, T12, T13, T14, T15, T16, T17, T18, T19, T20
+    , ToNat(..)
+  ) where
+
+import Data.Typeable
+
+
+-- Type level peano naturals
+data Su :: * -> *  deriving Typeable
+data Ze :: *       deriving Typeable
+
+-- Some shorthands
+type T0 = Ze
+type T1 = Su T0
+type T2 = Su T1
+type T3 = Su T2
+type T4 = Su T3
+type T5 = Su T4
+type T6 = Su T5
+type T7 = Su T6
+type T8 = Su T7
+type T9 = Su T8
+type T10 = Su T9
+type T11 = Su T10
+type T12 = Su T11
+type T13 = Su T12
+type T14 = Su T13
+type T15 = Su T14
+type T16 = Su T15
+type T17 = Su T16
+type T18 = Su T17
+type T19 = Su T18
+type T20 = Su T19
+
+class ToNat n where
+  toNat :: n -> Int
+
+instance ToNat Ze where toNat _ = 0
+instance (ToNat n) => ToNat (Su n) where toNat _ = 1 + toNat (undefined :: n)
+{-
+-- Below is some experimentation...
+
+-- A degree has a distance to root in semi-tones (n in T0..T11) and a 
+-- class (major or minor)
+data Degree n cls
+
+-- Transposing is a bit like addition...
+type family Transpose m n
+-- ... but we normalize at the end to stay within T0..T11
+type instance Transpose m T0 = Norm m
+type instance Transpose m (Su n) = Transpose (Su m) n
+
+-- Normalizing is the same as subtracting T12, but only if we can. Else we keep
+-- the type unchanged.
+type Norm m = Sub m T12 m
+
+-- Subtraction with an extra type for failure
+type family Sub m n fail
+-- Inductive case
+type instance Sub (Su m) (Su n) fail = Sub m n fail
+-- Base case, subtraction succeeded
+type instance Sub m T0 fail = m
+-- Base case, subtraction failed
+type instance Sub T0 (Su n) fail = fail
+
+-- A secondary dominant is a transposition by 7 semi-tones
+type SD deg = Transpose deg T7
+
+-- A tritone substitution is a transposition by 6 semi-tones
+type TS deg = Transpose deg T6
+-}
src/HarmTrace/HAnTree/Binary.hs view
@@ -1,59 +1,59 @@-{-# LANGUAGE GADTs                    #-}-{-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE TypeOperators            #-}---- Generic Binary--module HarmTrace.HAnTree.Binary where--import Control.Monad (liftM, liftM2)-import Data.Binary-import Generics.Instant---class GBinary a where-  gput :: a -> Put-  gget :: Get a---instance GBinary U where-  gput _ = return ()-  gget = return U--instance (GBinary a) => GBinary (CEq c p p a) where-  gput (C a) = gput a-  gget = liftM C gget-{--instance (GBinary a) => GBinary (CEq c p q a) where-  gput _ = return ()-  gget = error "gget: CEq impossible"--}-instance (GBinary a, GBinary b) => GBinary (a :+: b) where-  gput (L a) = put (0 :: Word8) >> gput a-  gput (R a) = put (1 :: Word8) >> gput a-  gget = do t <- get :: Get Word8-            case t of-              0 -> liftM L gget-              1 -> liftM R gget-              _ -> error "gget: :+: impossible"--instance (GBinary a, GBinary b) => GBinary (a :*: b) where-  gput (a :*: b) = gput a >> gput b-  gget = liftM2 (:*:) gget gget--instance (Binary a) => GBinary (Rec a) where-  gput (Rec a) = put a-  gget = liftM Rec get--instance (Binary a) => GBinary (Var a) where-  gput (Var a) = put a-  gget = liftM Var get----- Default implementations-getDefault :: (Representable a, GBinary (Rep a)) => Get a-getDefault = fmap to gget--putDefault :: (Representable a, GBinary (Rep a)) => a -> Put-putDefault = gput . from+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE TypeOperators            #-}
+
+-- Generic Binary
+
+module HarmTrace.HAnTree.Binary where
+
+import Control.Monad (liftM, liftM2)
+import Data.Binary
+import Generics.Instant
+
+
+class GBinary a where
+  gput :: a -> Put
+  gget :: Get a
+
+
+instance GBinary U where
+  gput _ = return ()
+  gget = return U
+
+instance (GBinary a) => GBinary (CEq c p p a) where
+  gput (C a) = gput a
+  gget = liftM C gget
+{-
+instance (GBinary a) => GBinary (CEq c p q a) where
+  gput _ = return ()
+  gget = error "gget: CEq impossible"
+-}
+instance (GBinary a, GBinary b) => GBinary (a :+: b) where
+  gput (L a) = put (0 :: Word8) >> gput a
+  gput (R a) = put (1 :: Word8) >> gput a
+  gget = do t <- get :: Get Word8
+            case t of
+              0 -> liftM L gget
+              1 -> liftM R gget
+              _ -> error "gget: :+: impossible"
+
+instance (GBinary a, GBinary b) => GBinary (a :*: b) where
+  gput (a :*: b) = gput a >> gput b
+  gget = liftM2 (:*:) gget gget
+
+instance (Binary a) => GBinary (Rec a) where
+  gput (Rec a) = put a
+  gget = liftM Rec get
+
+instance (Binary a) => GBinary (Var a) where
+  gput (Var a) = put a
+  gget = liftM Var get
+
+
+-- Default implementations
+getDefault :: (Representable a, GBinary (Rep a)) => Get a
+getDefault = fmap to gget
+
+putDefault :: (Representable a, GBinary (Rep a)) => a -> Put
+putDefault = gput . from
src/HarmTrace/HAnTree/HAn.hs view
@@ -1,244 +1,244 @@-{-# LANGUAGE TemplateHaskell                #-}-{-# LANGUAGE EmptyDataDecls                 #-}-{-# LANGUAGE TypeFamilies                   #-}-{-# LANGUAGE GADTs                          #-}--module HarmTrace.HAnTree.HAn where --import HarmTrace.Base.MusicRep-import HarmTrace.Tokenizer.Tokens-import HarmTrace.HAnTree.Binary--import Generics.Instant.TH-import Control.DeepSeq-import Data.Binary------------------------------------------------------------------------------------- Datatypes for representing Harmonic Analyses (at the value level)------------------------------------------------------------------------------------- H_armonic An_alysis wrapper datatype, the Int represents the duration-data HAn   = HAn      !Int !String -           | HAnFunc  !HFunc-           | HAnPrep  !Prep-           | HAnTrans !Trans -           | HAnChord !ChordToken -           -            -- duration Mode constructor_ix specials-data HFunc = Ton !Int !Mode !Int !(Maybe Spec)-           | Dom !Int !Mode !Int !(Maybe Spec) -           | Sub !Int !Mode !Int !(Maybe Spec) -           | P -           | PD-           | PT       -  -data Spec  = Blues | MinBorrow | Parallel          -  deriving Eq       ---- Preparations, like secondary dominants etc. that cause a "split" in the tree  -data Prep  = SecDom   !Int !ScaleDegree -- "V/X"-           | SecMin   !Int !ScaleDegree -- "v/X"           -           | DiatDom  !Int !ScaleDegree -- "Vd"-           | NoPrep---- Scalde degree transformations, e.g. tritone substitutions etc.-data Trans = Trit     !Int !ScaleDegree -- "bII/X"    -           | DimTrit  !Int !ScaleDegree -- "bIIb9/X"    -           | DimTrans !Int !ScaleDegree -- "VII0"      -           | NoTrans------------------------------------------------------------------------------------- Binary instances-----------------------------------------------------------------------------------deriveAllL [ ''HAn, ''Trans, ''Prep, ''HFunc, ''Spec]--instance Binary HAn where-  put = putDefault-  get = getDefault-instance Binary Trans where-  put = putDefault-  get = getDefault-instance Binary Prep where-  put = putDefault-  get = getDefault-instance Binary HFunc where-  put = putDefault-  get = getDefault-instance Binary Spec where-  put = putDefault-  get = getDefault------------------------------------------------------------------------------------- NFData instances-----------------------------------------------------------------------------------instance NFData HAn where-  rnf (HAn d s   ) = rnf d `seq` rnf s-  rnf (HAnFunc  a) = rnf a-  rnf (HAnTrans a) = rnf a-  rnf (HAnPrep  a) = rnf a-  rnf (HAnChord a) = seq a ()--instance NFData HFunc where-  rnf (Ton a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d-  rnf (Dom a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d-  rnf (Sub a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d-  rnf P             = ()-  rnf PD            = ()-  rnf PT            = ()-  -instance NFData Prep where-  rnf (SecDom i d) = rnf i `seq` d `seq` ()-  rnf (SecMin i d) = rnf i `seq` d `seq` ()-  rnf (DiatDom i d) = rnf i `seq` d `seq` ()-  rnf NoPrep = ()-  -instance NFData Trans where  -  rnf (Trit   i d) = rnf i `seq` d `seq` ()-  rnf (DimTrit  i d) = rnf i `seq` d `seq` ()-  rnf (DimTrans i d) = rnf i `seq` d `seq` ()-  rnf NoTrans = ()-  -instance NFData Spec where-  rnf Blues     = ()-  rnf MinBorrow = ()-  rnf Parallel  = ()-  ------------------------------------------------------------------------------------ Durations set and get instances---------------------------------------------------------------------------------  ---- Yes, I know these can be generic functions, but with my current generic --- programming skils it is faster two write them by hand.-class GetDur a where  -  getDur :: a -> Int-  -instance GetDur HAn where-  getDur (HAn  d  _s) = d-  getDur (HAnFunc  a) = getDur a  -  getDur (HAnPrep  a) = getDur a  -  getDur (HAnTrans a) = getDur a  -  getDur (HAnChord a) = dur a-  -instance GetDur HFunc where-  getDur (Ton i _ _ _) = i-  getDur (Dom i _ _ _) = i-  getDur (Sub i _ _ _) = i-  getDur _             = 0-  -instance GetDur Prep where-  getDur (SecDom i _) = i-  getDur (SecMin i _) = i-  getDur (DiatDom  i _) = i-  getDur NoPrep      = 0--instance GetDur Trans where  -  getDur (Trit   i _) = i-  getDur (DimTrit  i _) = i-  getDur (DimTrans i _) = i-  getDur NoTrans = 0--instance GetDur (Chord a) where-  getDur = duration- -class SetDur a where  -  setDur :: a -> Int -> a-  -instance SetDur HAn where-  setDur (HAn  _ s)   i = (HAn  i s) -  setDur (HAnFunc  a) i = (HAnFunc (setDur a i)) -  setDur (HAnTrans a) i = (HAnTrans (setDur a i)) -  setDur a           _i = a-  -instance SetDur HFunc where-  setDur (Ton _d m i s) d = (Ton d m i s)-  setDur (Dom _d m i s) d = (Dom d m i s)-  setDur (Sub _d m i s) d = (Sub d m i s)-  setDur a _  = a-  -instance SetDur Prep where-  setDur (SecDom   _d sd) d = (SecDom   d sd)-  setDur (SecMin   _d sd) d = (SecMin   d sd)-  setDur (DiatDom  _d sd) d = (DiatDom  d sd)-  setDur NoPrep _ = NoPrep-  -instance SetDur Trans where  -  setDur (Trit     _d sd) d = (Trit     d sd)-  setDur (DimTrit  _d sd) d = (DimTrit  d sd)-  setDur (DimTrans _d sd) d = (DimTrans d sd)-  setDur NoTrans _ = NoTrans- ------------------------------------------------------------------------------------ Eq instances---------------------------------------------------------------------------------  - -instance Eq HAn where -  (HAn _ s)        == (HAn _ s2)        = s     == s2-  (HAnChord chord) == (HAnChord chord2) = chord == chord2-  (HAnFunc  hfunk) == (HAnFunc  hfunk2) = hfunk == hfunk2-  (HAnTrans trans) == (HAnTrans trans2) = trans == trans2-  _ == _ = False-   -instance Eq HFunc where-  -- ignore duration for now-  (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2 -  (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2-  (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2-  P             == P   = True         -  PD            == PD  = True         -  PT            == PT  = True    -  _             == _   = False   -  -instance Eq Prep where-  (SecDom   _dur sd) == (SecDom   _dur2 sd2) = sd == sd2 -  (SecMin   _dur sd) == (SecMin   _dur2 sd2) = sd == sd2 -  (DiatDom  _dur sd) == (DiatDom  _dur2 sd2) = sd == sd2 -  NoPrep             == NoPrep = True-  _                  == _      = False-  -instance Eq Trans where  -  (Trit     _dur sd) == (Trit     _dur2 sd2) = sd == sd2 -  (DimTrit  _dur sd) == (DimTrit  _dur2 sd2) = sd == sd2 -  (DimTrans _dur sd) == (DimTrans _dur2 sd2) = sd == sd2 -  NoTrans           == NoTrans = True-  _                 == _       = False    ------------------------------------------------------------------------------------- Eq and Show instances----------------------------------------------------------------------------------  -instance Show Prep where-  show (SecDom   l d) = "V/"     ++ show d ++ '_' : show l-  show (SecMin   l d) = "v/"     ++ show d ++ '_' : show l-  show (DiatDom  l d) = "Vd/"++ show d ++ '_' : show l -  show NoPrep = "np"--instance Show Trans where  -  show (Trit     l d) = "IIb/"   ++ show d ++ '_' : show l-  show (DimTrit  l d) = "IIb9b/" ++ show d ++ '_' : show l-  show (DimTrans l d) = show d   ++ "0"    ++ '_' : show l-  show (NoTrans)      = "nt"--instance Show HAn where -  show (HAn l con)     = con ++ "_s"  ++ '_' : show l-  show (HAnChord chord) = show chord -  show (HAnFunc  hfunk) = show hfunk -  show (HAnTrans trans) = show trans -  show (HAnPrep  prep ) = show prep-  -instance Show HFunc where-  show (Ton l mode i s) = "T" ++ show mode       ++ '_' : show i -                              ++ maybe "" show s ++ '_' : show l-  show (Dom l mode i s) = "D" ++ show mode       ++ '_' : show i -                              ++ maybe "" show s ++ '_' : show l-  show (Sub l mode i s) = "S" ++ show mode       ++ '_' : show i -                              ++ maybe "" show s ++ '_' : show l-  show (P )             = "Piece"-  show (PT)             = "PT"-  show (PD)             = "PD" --instance Show Spec where-  show Blues     = "bls" -  show MinBorrow = "bor"+{-# LANGUAGE TemplateHaskell                #-}
+{-# LANGUAGE EmptyDataDecls                 #-}
+{-# LANGUAGE TypeFamilies                   #-}
+{-# LANGUAGE GADTs                          #-}
+
+module HarmTrace.HAnTree.HAn where 
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Tokenizer.Tokens
+import HarmTrace.HAnTree.Binary
+
+import Generics.Instant.TH
+import Control.DeepSeq
+import Data.Binary
+
+--------------------------------------------------------------------------------
+-- Datatypes for representing Harmonic Analyses (at the value level)
+--------------------------------------------------------------------------------
+
+-- H_armonic An_alysis wrapper datatype, the Int represents the duration
+data HAn   = HAn      !Int !String 
+           | HAnFunc  !HFunc
+           | HAnPrep  !Prep
+           | HAnTrans !Trans 
+           | HAnChord !ChordToken 
+           
+            -- duration Mode constructor_ix specials
+data HFunc = Ton !Int !Mode !Int !(Maybe Spec)
+           | Dom !Int !Mode !Int !(Maybe Spec) 
+           | Sub !Int !Mode !Int !(Maybe Spec) 
+           | P 
+           | PD
+           | PT       
+  
+data Spec  = Blues | MinBorrow | Parallel          
+  deriving Eq       
+
+-- Preparations, like secondary dominants etc. that cause a "split" in the tree  
+data Prep  = SecDom   !Int !ScaleDegree -- "V/X"
+           | SecMin   !Int !ScaleDegree -- "v/X"           
+           | DiatDom  !Int !ScaleDegree -- "Vd"
+           | NoPrep
+
+-- Scalde degree transformations, e.g. tritone substitutions etc.
+data Trans = Trit     !Int !ScaleDegree -- "bII/X"    
+           | DimTrit  !Int !ScaleDegree -- "bIIb9/X"    
+           | DimTrans !Int !ScaleDegree -- "VII0"      
+           | NoTrans
+
+--------------------------------------------------------------------------------
+-- Binary instances
+--------------------------------------------------------------------------------
+
+deriveAllL [ ''HAn, ''Trans, ''Prep, ''HFunc, ''Spec]
+
+instance Binary HAn where
+  put = putDefault
+  get = getDefault
+instance Binary Trans where
+  put = putDefault
+  get = getDefault
+instance Binary Prep where
+  put = putDefault
+  get = getDefault
+instance Binary HFunc where
+  put = putDefault
+  get = getDefault
+instance Binary Spec where
+  put = putDefault
+  get = getDefault
+
+--------------------------------------------------------------------------------
+-- NFData instances
+--------------------------------------------------------------------------------
+
+instance NFData HAn where
+  rnf (HAn d s   ) = rnf d `seq` rnf s
+  rnf (HAnFunc  a) = rnf a
+  rnf (HAnTrans a) = rnf a
+  rnf (HAnPrep  a) = rnf a
+  rnf (HAnChord a) = seq a ()
+
+instance NFData HFunc where
+  rnf (Ton a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+  rnf (Dom a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+  rnf (Sub a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+  rnf P             = ()
+  rnf PD            = ()
+  rnf PT            = ()
+  
+instance NFData Prep where
+  rnf (SecDom i d) = rnf i `seq` d `seq` ()
+  rnf (SecMin i d) = rnf i `seq` d `seq` ()
+  rnf (DiatDom i d) = rnf i `seq` d `seq` ()
+  rnf NoPrep = ()
+  
+instance NFData Trans where  
+  rnf (Trit   i d) = rnf i `seq` d `seq` ()
+  rnf (DimTrit  i d) = rnf i `seq` d `seq` ()
+  rnf (DimTrans i d) = rnf i `seq` d `seq` ()
+  rnf NoTrans = ()
+  
+instance NFData Spec where
+  rnf Blues     = ()
+  rnf MinBorrow = ()
+  rnf Parallel  = ()
+  
+--------------------------------------------------------------------------------
+-- Durations set and get instances
+--------------------------------------------------------------------------------  
+
+-- Yes, I know these can be generic functions, but with my current generic 
+-- programming skils it is faster two write them by hand.
+class GetDur a where  
+  getDur :: a -> Int
+  
+instance GetDur HAn where
+  getDur (HAn  d  _s) = d
+  getDur (HAnFunc  a) = getDur a  
+  getDur (HAnPrep  a) = getDur a  
+  getDur (HAnTrans a) = getDur a  
+  getDur (HAnChord a) = dur a
+  
+instance GetDur HFunc where
+  getDur (Ton i _ _ _) = i
+  getDur (Dom i _ _ _) = i
+  getDur (Sub i _ _ _) = i
+  getDur _             = 0
+  
+instance GetDur Prep where
+  getDur (SecDom i _) = i
+  getDur (SecMin i _) = i
+  getDur (DiatDom  i _) = i
+  getDur NoPrep      = 0
+
+instance GetDur Trans where  
+  getDur (Trit   i _) = i
+  getDur (DimTrit  i _) = i
+  getDur (DimTrans i _) = i
+  getDur NoTrans = 0
+
+instance GetDur (Chord a) where
+  getDur = duration
+ 
+class SetDur a where  
+  setDur :: a -> Int -> a
+  
+instance SetDur HAn where
+  setDur (HAn  _ s)   i = (HAn  i s) 
+  setDur (HAnFunc  a) i = (HAnFunc (setDur a i)) 
+  setDur (HAnTrans a) i = (HAnTrans (setDur a i)) 
+  setDur a           _i = a
+  
+instance SetDur HFunc where
+  setDur (Ton _d m i s) d = (Ton d m i s)
+  setDur (Dom _d m i s) d = (Dom d m i s)
+  setDur (Sub _d m i s) d = (Sub d m i s)
+  setDur a _  = a
+  
+instance SetDur Prep where
+  setDur (SecDom   _d sd) d = (SecDom   d sd)
+  setDur (SecMin   _d sd) d = (SecMin   d sd)
+  setDur (DiatDom  _d sd) d = (DiatDom  d sd)
+  setDur NoPrep _ = NoPrep
+  
+instance SetDur Trans where  
+  setDur (Trit     _d sd) d = (Trit     d sd)
+  setDur (DimTrit  _d sd) d = (DimTrit  d sd)
+  setDur (DimTrans _d sd) d = (DimTrans d sd)
+  setDur NoTrans _ = NoTrans
+ 
+--------------------------------------------------------------------------------
+-- Eq instances
+--------------------------------------------------------------------------------  
+ 
+instance Eq HAn where 
+  (HAn _ s)        == (HAn _ s2)        = s     == s2
+  (HAnChord chord) == (HAnChord chord2) = chord == chord2
+  (HAnFunc  hfunk) == (HAnFunc  hfunk2) = hfunk == hfunk2
+  (HAnTrans trans) == (HAnTrans trans2) = trans == trans2
+  _ == _ = False
+   
+instance Eq HFunc where
+  -- ignore duration for now
+  (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2 
+  (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2
+  (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2
+  P             == P   = True         
+  PD            == PD  = True         
+  PT            == PT  = True    
+  _             == _   = False   
+  
+instance Eq Prep where
+  (SecDom   _dur sd) == (SecDom   _dur2 sd2) = sd == sd2 
+  (SecMin   _dur sd) == (SecMin   _dur2 sd2) = sd == sd2 
+  (DiatDom  _dur sd) == (DiatDom  _dur2 sd2) = sd == sd2 
+  NoPrep             == NoPrep = True
+  _                  == _      = False
+  
+instance Eq Trans where  
+  (Trit     _dur sd) == (Trit     _dur2 sd2) = sd == sd2 
+  (DimTrit  _dur sd) == (DimTrit  _dur2 sd2) = sd == sd2 
+  (DimTrans _dur sd) == (DimTrans _dur2 sd2) = sd == sd2 
+  NoTrans           == NoTrans = True
+  _                 == _       = False    
+
+--------------------------------------------------------------------------------
+-- Eq and Show instances
+--------------------------------------------------------------------------------
+  
+instance Show Prep where
+  show (SecDom   l d) = "V/"     ++ show d ++ '_' : show l
+  show (SecMin   l d) = "v/"     ++ show d ++ '_' : show l
+  show (DiatDom  l d) = "Vd/"++ show d ++ '_' : show l 
+  show NoPrep = "np"
+
+instance Show Trans where  
+  show (Trit     l d) = "IIb/"   ++ show d ++ '_' : show l
+  show (DimTrit  l d) = "IIb9b/" ++ show d ++ '_' : show l
+  show (DimTrans l d) = show d   ++ "0"    ++ '_' : show l
+  show (NoTrans)      = "nt"
+
+instance Show HAn where 
+  show (HAn l con)     = con ++ "_s"  ++ '_' : show l
+  show (HAnChord chord) = show chord 
+  show (HAnFunc  hfunk) = show hfunk 
+  show (HAnTrans trans) = show trans 
+  show (HAnPrep  prep ) = show prep
+  
+instance Show HFunc where
+  show (Ton l mode i s) = "T" ++ show mode       ++ '_' : show i 
+                              ++ maybe "" show s ++ '_' : show l
+  show (Dom l mode i s) = "D" ++ show mode       ++ '_' : show i 
+                              ++ maybe "" show s ++ '_' : show l
+  show (Sub l mode i s) = "S" ++ show mode       ++ '_' : show i 
+                              ++ maybe "" show s ++ '_' : show l
+  show (P )             = "Piece"
+  show (PT)             = "PT"
+  show (PD)             = "PD" 
+
+instance Show Spec where
+  show Blues     = "bls" 
+  show MinBorrow = "bor"
   show Parallel  = "par"
src/HarmTrace/HAnTree/HAnParser.hs view
@@ -1,43 +1,43 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}--module HarmTrace.HAnTree.HAnParser where--import HarmTrace.Base.Parsing-import HarmTrace.Base.MusicRep (Mode(..))-import HarmTrace.HAnTree.HAn--import Data.Maybe (isJust, fromJust)------------------------------------------------------------------------------------ A Small Parser for Parsing MIR constructors---------------------------------------------------------------------------------     ---- this top-level function parses a constructor name and returns the --- corresponding HAn data type. N.B. we can implement the catch all--- case as a parser, because it accepts everything and one will get an --- "ambiguous parser?" error.s-parseHAn :: ListLike state Char => state -> HAn                          -parseHAn inp -  | isJust a  = fromJust a-  | otherwise = parseData (HAn 1 <$> pAnyStr) inp where -- catch all case-      a = parseData (pMaybe $ HAnFunc  <$> pHFunc) inp--        -pHFunc :: Parser HFunc-pHFunc =    Ton 1 <$ pSym 'T' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec-        <|> Dom 1 <$ pSym 'D' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec-        <|> Sub 1 <$ pSym 'S' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec-        <|> PD    <$ pString "PD" -        <|> PT    <$ pString "PT" --pMode :: Parser Mode-pMode =     MinMode <$ pSym 'm'-        <|> MajMode <$ pString "" --pSpec :: Parser Spec       -pSpec =     MinBorrow <$ pString "_bor" -        <|> Blues     <$ pString "_bls" -        <|> Parallel  <$ pString "_par" -     -pAnyStr :: Parser String        +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module HarmTrace.HAnTree.HAnParser where
+
+import HarmTrace.Base.Parsing
+import HarmTrace.Base.MusicRep (Mode(..))
+import HarmTrace.HAnTree.HAn
+
+import Data.Maybe (isJust, fromJust)
+--------------------------------------------------------------------------------
+-- A Small Parser for Parsing MIR constructors
+--------------------------------------------------------------------------------     
+
+-- this top-level function parses a constructor name and returns the 
+-- corresponding HAn data type. N.B. we can implement the catch all
+-- case as a parser, because it accepts everything and one will get an 
+-- "ambiguous parser?" error.s
+parseHAn :: ListLike state Char => state -> HAn                          
+parseHAn inp 
+  | isJust a  = fromJust a
+  | otherwise = parseData (HAn 1 <$> pAnyStr) inp where -- catch all case
+      a = parseData (pMaybe $ HAnFunc  <$> pHFunc) inp
+
+        
+pHFunc :: Parser HFunc
+pHFunc =    Ton 1 <$ pSym 'T' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec
+        <|> Dom 1 <$ pSym 'D' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec
+        <|> Sub 1 <$ pSym 'S' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec
+        <|> PD    <$ pString "PD" 
+        <|> PT    <$ pString "PT" 
+
+pMode :: Parser Mode
+pMode =     MinMode <$ pSym 'm'
+        <|> MajMode <$ pString "" 
+
+pSpec :: Parser Spec       
+pSpec =     MinBorrow <$ pString "_bor" 
+        <|> Blues     <$ pString "_bls" 
+        <|> Parallel  <$ pString "_par" 
+     
+pAnyStr :: Parser String        
 pAnyStr =  pAtMost 15 pAscii
src/HarmTrace/HAnTree/PostProcess.hs view
@@ -1,109 +1,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
src/HarmTrace/HAnTree/ToHAnTree.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE TypeOperators            #-}-{-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE GADTs                    #-}--module HarmTrace.HAnTree.ToHAnTree ( GTree(..) , HAn(..) , gTreeDefault-                                   , gTreeHead , emptyHAnTree ) where--import Generics.Instant.Base-import HarmTrace.HAnTree.Tree (Tree(..))-import HarmTrace.HAnTree.HAn-import HarmTrace.HAnTree.HAnParser--class GTree a where-  gTree :: a -> [Tree HAn] --instance GTree U where-  gTree U = [Node (HAn 0 "U") [] Nothing]-  -instance (GTree a, GTree b) => GTree (a :+: b) where-  gTree (L x) = gTree x-  gTree (R x) = gTree x-  -instance (GTree a, Constructor c) => GTree (CEq c p q a) where-  gTree c@(C a) = [Node (parseHAn (conName c)) (gTree a) Nothing]-    -instance (GTree a, GTree b) => GTree (a :*: b) where-  gTree (a :*: b) = gTree a ++ gTree b--instance GTree a => GTree (Rec a) where-  gTree (Rec x) = gTree x-  -instance GTree a => GTree (Var a) where-  gTree (Var x) = gTree x---instance GTree a => GTree [a] where-  gTree x = concatMap gTree x---- Dispatcher-gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn]-gTreeDefault = gTree . from--gTreeHead :: (GTree a) => a -> Tree HAn-gTreeHead = head . gTree--emptyHAnTree :: Tree HAn+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE GADTs                    #-}
+
+module HarmTrace.HAnTree.ToHAnTree ( GTree(..) , HAn(..) , gTreeDefault
+                                   , gTreeHead , emptyHAnTree ) where
+
+import Generics.Instant.Base
+import HarmTrace.HAnTree.Tree (Tree(..))
+import HarmTrace.HAnTree.HAn
+import HarmTrace.HAnTree.HAnParser
+
+class GTree a where
+  gTree :: a -> [Tree HAn] 
+
+instance GTree U where
+  gTree U = [Node (HAn 0 "U") [] Nothing]
+  
+instance (GTree a, GTree b) => GTree (a :+: b) where
+  gTree (L x) = gTree x
+  gTree (R x) = gTree x
+  
+instance (GTree a, Constructor c) => GTree (CEq c p q a) where
+  gTree c@(C a) = [Node (parseHAn (conName c)) (gTree a) Nothing]
+    
+instance (GTree a, GTree b) => GTree (a :*: b) where
+  gTree (a :*: b) = gTree a ++ gTree b
+
+instance GTree a => GTree (Rec a) where
+  gTree (Rec x) = gTree x
+  
+instance GTree a => GTree (Var a) where
+  gTree (Var x) = gTree x
+
+
+instance GTree a => GTree [a] where
+  gTree x = concatMap gTree x
+
+-- Dispatcher
+gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn]
+gTreeDefault = gTree . from
+
+gTreeHead :: (GTree a) => a -> Tree HAn
+gTreeHead = head . gTree
+
+emptyHAnTree :: Tree HAn
 emptyHAnTree = Node (HAn 0 "empty") [] Nothing
src/HarmTrace/HAnTree/Tree.hs view
@@ -1,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
src/HarmTrace/HarmTrace.hs view
@@ -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 []
+ src/HarmTrace/IO/BasePaths.hs view
@@ -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)
+ src/HarmTrace/IO/Common.hs view
@@ -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
+
+ src/HarmTrace/IO/Downsample.hs view
@@ -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'
src/HarmTrace/IO/Errors.hs view
@@ -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 }
+ src/HarmTrace/IO/FeatExtract.hs view
@@ -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 
+-- (<http://omras2.org/SonicAnnotator>), 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:
+--
+-- * <http://www.vamp-plugins.org>
+--
+-- * <http://omras2.org/SonicAnnotator>
+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)
src/HarmTrace/IO/Main.hs view
@@ -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
+
+ src/HarmTrace/IO/Match.hs view
@@ -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
+ src/HarmTrace/IO/Parse.hs view
@@ -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)
src/HarmTrace/IO/PrintTree.hs view
@@ -1,80 +1,80 @@-{-# OPTIONS_GHC -Wall #-}-module HarmTrace.IO.PrintTree ( printTreeF   , printTree-                              , printTreeHAnF, printTreeHAn) where--import System.Exit (ExitCode)-import System.Process (runProcess, waitForProcess, ProcessHandle)-import HarmTrace.HAnTree.Tree (Tree)-import HarmTrace.HAnTree.HAn (HAn)----- needs gnu wget http://www.gnu.org/software/wget/ --- or             http://gnuwin32.sourceforge.net/packages/wget.htm--printTreeHAn :: Tree HAn -> FilePath -> IO ExitCode-printTreeHAn t o = printTree (show t) (o ++ ".png")--printTreeHAnF :: [Tree HAn] -> String -> IO ExitCode-printTreeHAnF ts o = printTreeF (map show ts) o----- |gets a .png from http://ironcreek.net/phpsyntaxtree/ that prints--- the parse tree of the chord sequence that was entered as parsed by our --- HarmGram model. wget is used under the hood. If any, the first ten --- ambiguous parse trees are printed.                -printTreeF :: [String] -> -- ^ the tree description to be printed   -              String   -> -- ^ a string for generating the filenames            -              IO ExitCode      -printTreeF trees  outStr   =    printMoreTrees (take 15 trees) outStr 0 where-  printMoreTrees :: [String] -> String -> Int -> IO ExitCode-  printMoreTrees []     _   _ = error "empty list of trees, nothing to print"-  printMoreTrees [t]    out i = printTree t (nrFile out i) -  printMoreTrees (t:ts) out i = do _ <- printTree t (nrFile out i) -                                   printMoreTrees ts out  (i+1)-  nrFile :: String -> Int -> String                                      -  nrFile str i = str ++ show i ++ ".png"    -  --- |gets a .png from http://ironcreek.net/phpsyntaxtree/ that prints--- the parse tree of the chord sequence that was entered as parsed by our --- HarmGram model. wget is used under the hood. If any, the first ten --- ambiguous parse trees are printed.                           -printTree :: String ->   -- ^ the tree description to be printed-             FilePath -> -- ^ a filepath to the output file-             IO ExitCode  -printTree tree outfile  = do submit <- submitTree tree -                             _ <- waitForProcess submit -                             png <- getpng outfile -                             waitForProcess png---- wget --save-cookies cookies.txt -        --keep-session-cookies -        --post-data "data=[tree]&drawbtn=&opencount=3&closedcount=3&font=vera_sans&fontsize=8&color=on&antialias=on&autosub=on&triangles=on" -        --http://ironcreek.net/phpsyntaxtree/ -submitTree :: String -> IO ProcessHandle-submitTree tree = wget "http://ironcreek.net/phpsyntaxtree/" opt  where-  opt = [ "--save-cookies"-        , "phpsyntax_cookies.txt"-        , "--keep-session-cookies"-        , "--quiet"-        , "--delete-after"-        , "--post-data"-        , "data=" ++ tree ++ "&drawbtn=&opencount=3&closedcount=3&" ++-          "font=vera_sans&fontsize=8&color=on&antialias=on&triangles=on"-        ]-        ---        ---wget  cookies.txt --output-document %2.png http://ironcreek.net/phpsyntaxtree/dnlgraph.php -getpng :: String -> IO ProcessHandle-getpng name = wget "http://ironcreek.net/phpsyntaxtree/dnlgraph.php" opt  where-  opt = [ "--load-cookies"-        , "phpsyntax_cookies.txt"-        , "--quiet"-        , "--output-document"-        , name-        ]-        -wget :: String -> [String] -> IO ProcessHandle-wget url opt = -  do let par = url : opt-     runProcess "wget" par Nothing Nothing Nothing Nothing Nothing-+{-# OPTIONS_GHC -Wall #-}
+module HarmTrace.IO.PrintTree ( printTreeF   , printTree
+                              , printTreeHAnF, printTreeHAn) where
+
+import System.Exit (ExitCode)
+import System.Process (runProcess, waitForProcess, ProcessHandle)
+import HarmTrace.HAnTree.Tree (Tree)
+import HarmTrace.HAnTree.HAn (HAn)
+
+
+-- needs gnu wget http://www.gnu.org/software/wget/ 
+-- or             http://gnuwin32.sourceforge.net/packages/wget.htm
+
+printTreeHAn :: Tree HAn -> FilePath -> IO ExitCode
+printTreeHAn t o = printTree (show t) (o ++ ".png")
+
+printTreeHAnF :: [Tree HAn] -> String -> IO ExitCode
+printTreeHAnF ts o = printTreeF (map show ts) o
+
+
+-- |gets a .png from http://ironcreek.net/phpsyntaxtree/ that prints
+-- the parse tree of the chord sequence that was entered as parsed by our 
+-- HarmGram model. wget is used under the hood. If any, the first ten 
+-- ambiguous parse trees are printed.                
+printTreeF :: [String] -> -- ^ the tree description to be printed   
+              String   -> -- ^ a string for generating the filenames            
+              IO ExitCode      
+printTreeF trees  outStr   =    printMoreTrees (take 15 trees) outStr 0 where
+  printMoreTrees :: [String] -> String -> Int -> IO ExitCode
+  printMoreTrees []     _   _ = error "empty list of trees, nothing to print"
+  printMoreTrees [t]    out i = printTree t (nrFile out i) 
+  printMoreTrees (t:ts) out i = do _ <- printTree t (nrFile out i) 
+                                   printMoreTrees ts out  (i+1)
+  nrFile :: String -> Int -> String                                      
+  nrFile str i = str ++ show i ++ ".png"    
+  
+-- |gets a .png from http://ironcreek.net/phpsyntaxtree/ that prints
+-- the parse tree of the chord sequence that was entered as parsed by our 
+-- HarmGram model. wget is used under the hood. If any, the first ten 
+-- ambiguous parse trees are printed.                           
+printTree :: String ->   -- ^ the tree description to be printed
+             FilePath -> -- ^ a filepath to the output file
+             IO ExitCode  
+printTree tree outfile  = do submit <- submitTree tree 
+                             _ <- waitForProcess submit 
+                             png <- getpng outfile 
+                             waitForProcess png
+
+-- wget --save-cookies cookies.txt 
+        --keep-session-cookies 
+        --post-data "data=[tree]&drawbtn=&opencount=3&closedcount=3&font=vera_sans&fontsize=8&color=on&antialias=on&autosub=on&triangles=on" 
+        --http://ironcreek.net/phpsyntaxtree/ 
+submitTree :: String -> IO ProcessHandle
+submitTree tree = wget "http://ironcreek.net/phpsyntaxtree/" opt  where
+  opt = [ "--save-cookies"
+        , "phpsyntax_cookies.txt"
+        , "--keep-session-cookies"
+        , "--quiet"
+        , "--delete-after"
+        , "--post-data"
+        , "data=" ++ tree ++ "&drawbtn=&opencount=3&closedcount=3&" ++
+          "font=vera_sans&fontsize=8&color=on&antialias=on&triangles=on"
+        ]
+        
+--        
+--wget  cookies.txt --output-document %2.png http://ironcreek.net/phpsyntaxtree/dnlgraph.php 
+getpng :: String -> IO ProcessHandle
+getpng name = wget "http://ironcreek.net/phpsyntaxtree/dnlgraph.php" opt  where
+  opt = [ "--load-cookies"
+        , "phpsyntax_cookies.txt"
+        , "--quiet"
+        , "--output-document"
+        , name
+        ]
+        
+wget :: String -> [String] -> IO ProcessHandle
+wget url opt = 
+  do let par = url : opt
+     runProcess "wget" par Nothing Nothing Nothing Nothing Nothing
+
+ src/HarmTrace/IO/Recognise.hs view
@@ -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 )
+
src/HarmTrace/Matching/Alignment.hs view
@@ -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'
+
src/HarmTrace/Matching/GuptaNishimura.hs view
@@ -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"
src/HarmTrace/Matching/HChord.hs view
@@ -1,51 +1,51 @@-module HarmTrace.Matching.HChord (HChord, Sim, toHChords) where--import HarmTrace.Base.MusicRep-import HarmTrace.Tokenizer.Tokens-import HarmTrace.Matching.Sim -import HarmTrace.HAnTree.HAn-import HarmTrace.HAnTree.Tree---- represents a  very simple chord, only major and minor and a root scaledegree-data HChord = HChord { deg  :: !Int       -- I = 0, IIb = 1 ... VII = 11-                     , clss :: !ClassType -- MajClass | MinClass | DomClass | ..-                     , func :: !HFunc-                     , prep :: !Prep-                     , trns :: !Trans}--instance Sim HChord where-  {-# INLINE sim #-}-  sim (HChord r ct _fc pr tr) (HChord r2 ct2 _fc2 pr2 tr2) -    | r == r2 && ct == ct2 = 2 + sim pr pr2 + sim tr tr2-    | otherwise = -1-    -instance Show HChord where-  show (HChord r ct fc pr tr) =        show fc ++ ':' : show pr ++ ':' : show tr-                              ++ ':' : show (scaleDegrees !! r) ++ show ct--toHChords :: Tree HAn -> [HChord]-toHChords t = getHAn undefinedHChord t---- getHAn also samples/replicates the chords based on their duration in beats-getHAn :: HChord -> Tree HAn -> [HChord]-getHAn c (Node h@(HAnChord ct) [] _) -- there might be inserted chords-  | null (chords ct)   = []          -- ignore them in the matching process-  | otherwise          = let c'  = update c h -                                     -- ignore func when the chord is deleted-                             c'' = if status ct == Deleted -                                   then c' { trns = NoTrans } else c'-                         in  replicate (dur ct)    c''-                         -- in replicate ((dur ct) `div1` 2) c''-getHAn c (Node h cs _) = let c' = update c h in concatMap (getHAn c') cs--update :: HChord -> HAn -> HChord-update hc (HAn    _ _) = hc-update hc (HAnFunc  f) = hc { func = f }-update hc (HAnTrans t) = hc { trns = t }-update hc (HAnPrep  p) = hc { prep = p }-update hc (HAnChord c) = hc { deg  = diaDegToSemi $ root c-                            , clss = classType c }--undefinedHChord :: HChord-undefinedHChord =  HChord (-1 :: Int)  (MajClass :: ClassType)-                          (P :: HFunc) NoPrep NoTrans+module HarmTrace.Matching.HChord (HChord, Sim, toHChords) where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Tokenizer.Tokens
+import HarmTrace.Matching.Sim 
+import HarmTrace.HAnTree.HAn
+import HarmTrace.HAnTree.Tree
+
+-- represents a  very simple chord, only major and minor and a root scaledegree
+data HChord = HChord { deg  :: !Int       -- I = 0, IIb = 1 ... VII = 11
+                     , clss :: !ClassType -- MajClass | MinClass | DomClass | ..
+                     , func :: !HFunc
+                     , prep :: !Prep
+                     , trns :: !Trans}
+
+instance Sim HChord where
+  {-# INLINE sim #-}
+  sim (HChord r ct _fc pr tr) (HChord r2 ct2 _fc2 pr2 tr2) 
+    | r == r2 && ct == ct2 = 2 + sim pr pr2 + sim tr tr2
+    | otherwise = -1
+    
+instance Show HChord where
+  show (HChord r ct fc pr tr) =        show fc ++ ':' : show pr ++ ':' : show tr
+                              ++ ':' : show (scaleDegrees !! r) ++ show ct
+
+toHChords :: Tree HAn -> [HChord]
+toHChords t = getHAn undefinedHChord t
+
+-- getHAn also samples/replicates the chords based on their duration in beats
+getHAn :: HChord -> Tree HAn -> [HChord]
+getHAn c (Node h@(HAnChord ct) [] _) -- there might be inserted chords
+  | null (chords ct)   = []          -- ignore them in the matching process
+  | otherwise          = let c'  = update c h 
+                                     -- ignore func when the chord is deleted
+                             c'' = if status ct == Deleted 
+                                   then c' { trns = NoTrans } else c'
+                         in  replicate (dur ct)    c''
+                         -- in replicate ((dur ct) `div1` 2) c''
+getHAn c (Node h cs _) = let c' = update c h in concatMap (getHAn c') cs
+
+update :: HChord -> HAn -> HChord
+update hc (HAn    _ _) = hc
+update hc (HAnFunc  f) = hc { func = f }
+update hc (HAnTrans t) = hc { trns = t }
+update hc (HAnPrep  p) = hc { prep = p }
+update hc (HAnChord c) = hc { deg  = toSemitone $ root c
+                            , clss = classType c }
+
+undefinedHChord :: HChord
+undefinedHChord =  HChord (-1 :: Int)  (MajClass :: ClassType)
+                          (P :: HFunc) NoPrep NoTrans
src/HarmTrace/Matching/Sim.hs view
@@ -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
src/HarmTrace/Matching/SimpleChord.hs view
@@ -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))
src/HarmTrace/Matching/Standard.hs view
@@ -1,25 +1,25 @@--module HarmTrace.Matching.Standard (diffChords, diffChordsLen) where--import Data.Algorithm.Diff -- cabal install Diff--diff :: (Eq a) => [a] -> [a] -> [(DI,a)]-diff = getDiff--diffLen :: (Eq a) => [a] -> [a] -> Float-diffLen x y = fromIntegral (len (diff x y)) / fromIntegral (length x)--len :: [(DI,a)] -> Int-len []        = 0-len ((B,_):t) = len t-len ((_,_):t) = 1 + len t------------------------------------------------------------------------------------- Matching-----------------------------------------------------------------------------------diffChordsLen :: (Eq a) => [a] -> [a] -> Float-diffChordsLen = diffLen--diffChords :: (Show a, Eq a) => [a] -> [a] -> String-diffChords x y = show (diff x y)+
+module HarmTrace.Matching.Standard (diffChords, diffChordsLen) where
+
+import Data.Algorithm.Diff -- cabal install Diff
+
+diff :: (Eq a) => [a] -> [a] -> [(DI,a)]
+diff = getDiff
+
+diffLen :: (Eq a) => [a] -> [a] -> Float
+diffLen x y = fromIntegral (len (diff x y)) / fromIntegral (length x)
+
+len :: [(DI,a)] -> Int
+len []        = 0
+len ((B,_):t) = len t
+len ((_,_):t) = 1 + len t
+
+--------------------------------------------------------------------------------
+-- Matching
+--------------------------------------------------------------------------------
+
+diffChordsLen :: (Eq a) => [a] -> [a] -> Float
+diffChordsLen = diffLen
+
+diffChords :: (Show a, Eq a) => [a] -> [a] -> String
+diffChords x y = show (diff x y)
src/HarmTrace/Models/Jazz/Instances.hs view
@@ -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
src/HarmTrace/Models/Jazz/Main.hs view
@@ -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
src/HarmTrace/Models/Jazz/Model.hs view
@@ -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 ]
src/HarmTrace/Models/Models.hs view
@@ -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
src/HarmTrace/Models/Parser.hs view
@@ -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...
src/HarmTrace/Models/Pop/Instances.hs view
@@ -1,250 +1,250 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-{-# LANGUAGE TemplateHaskell        #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE EmptyDataDecls         #-}-{-# LANGUAGE TypeSynonymInstances   #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE UndecidableInstances   #-}-{-# LANGUAGE OverlappingInstances   #-}-{-# LANGUAGE GADTs                  #-}--module HarmTrace.Models.Pop.Instances where---- Generics stuff-import Generics.Instant.TH---- Parser stuff-import Text.ParserCombinators.UU-import Text.ParserCombinators.UU.BasicInstances---- Music stuff-import HarmTrace.Models.Parser-import HarmTrace.Models.Pop.Model-import HarmTrace.HAnTree.Tree-import HarmTrace.HAnTree.ToHAnTree-import HarmTrace.HAnTree.HAn-import HarmTrace.Tokenizer.Tokens as CT-import HarmTrace.Base.TypeLevel-import HarmTrace.Base.MusicRep---- Library modules-import Control.Arrow------------------------------------------------------------------------------------- The non-generic part of the parser-----------------------------------------------------------------------------------instance ParseG (Base_SD   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
src/HarmTrace/Models/Pop/Main.hs view
@@ -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
+
src/HarmTrace/Models/Pop/Model.hs view
@@ -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 ]
src/HarmTrace/Tokenizer/Tokenizer.hs view
@@ -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"
src/HarmTrace/Tokenizer/Tokens.hs view
@@ -1,65 +1,65 @@-{-# LANGUAGE TemplateHaskell                #-}-{-# LANGUAGE EmptyDataDecls                 #-}-{-# LANGUAGE TypeFamilies                   #-}-{-# LANGUAGE GADTs                          #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceLabel  (..)-                                  , PieceToken (..), ParseStatus (..)-                                  ) where--import HarmTrace.Base.MusicRep-import HarmTrace.HAnTree.Binary-import Generics.Instant.TH-import Data.Binary-  ------------------------------------------------------------------------------------ Tokens for parsing chords------------------------------------------------------------------------------------- merged Chords that will be presented to the parser-data ChordToken = ChordToken { root          :: ScaleDegree-                             , classType     :: ClassType-                             , chords        :: [ChordLabel]-                             , status        :: ParseStatus-                             , chordNumReps  :: Int-                             , dur           :: Int -- duration-                             } -                             -data ParseStatus = NotParsed | Parsed | Deleted | Inserted-  deriving (Eq, Show)-                             --- a datatype to store a tokenized chords                              --- type PieceRelToken = PieceToken ChordDegree--- type PieceAbsToken = PieceToken ChordLabel-data PieceToken = PieceToken Key [ChordToken]-data PieceLabel = PieceLabel Key [ChordLabel]------------------------------------------------------------------------------------- Instances for Chord Tokens----------------------------------------------------------------------------------instance Eq ChordToken where-  (ChordToken sd clss _cs stat _n _d) == (ChordToken sd2 clss2 _cs2 stat2 _n2 _d2) -    = sd == sd2 && clss == clss2 && stat == stat2--instance Show ChordToken where-  show (ChordToken sd clss _cs Inserted _n _d) = show sd ++ show clss++"[Inserted]"-  show (ChordToken sd clss  cs Deleted  _n _d) = -    show sd ++ show clss ++ "[Deleted" ++ showChords cs ++ "]"-  show (ChordToken sd clss  cs _ _n d) = show sd ++ show clss ++ '_' : show d -                                                 ++ showChords cs    -showChords :: Show a => [Chord a] -> String  -showChords = concatMap (\x -> '[' : show x ++ "]") -------------------------------------------------------------------------------------- Binary instances-----------------------------------------------------------------------------------deriveAllL [''ChordToken, ''ParseStatus]--instance Binary ChordToken where-  put = putDefault-  get = getDefault-instance Binary ParseStatus where-  put = putDefault+{-# LANGUAGE TemplateHaskell                #-}
+{-# LANGUAGE EmptyDataDecls                 #-}
+{-# LANGUAGE TypeFamilies                   #-}
+{-# LANGUAGE GADTs                          #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+module HarmTrace.Tokenizer.Tokens ( ChordToken (..), PieceLabel  (..)
+                                  , PieceToken (..), ParseStatus (..)
+                                  ) where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.HAnTree.Binary
+import Generics.Instant.TH
+import Data.Binary
+  
+--------------------------------------------------------------------------------
+-- Tokens for parsing chords
+--------------------------------------------------------------------------------
+
+-- merged Chords that will be presented to the parser
+data ChordToken = ChordToken { root          :: ScaleDegree
+                             , classType     :: ClassType
+                             , chords        :: [ChordLabel]
+                             , status        :: ParseStatus
+                             , chordNumReps  :: Int
+                             , dur           :: Int -- duration
+                             } 
+                             
+data ParseStatus = NotParsed | Parsed | Deleted | Inserted
+  deriving (Eq, Show)
+                             
+-- a datatype to store a tokenized chords                              
+-- type PieceRelToken = PieceToken ChordDegree
+-- type PieceAbsToken = PieceToken ChordLabel
+data PieceToken = PieceToken Key [ChordToken]
+data PieceLabel = PieceLabel Key [ChordLabel]
+
+--------------------------------------------------------------------------------
+-- Instances for Chord Tokens
+--------------------------------------------------------------------------------
+instance Eq ChordToken where
+  (ChordToken sd clss _cs stat _n _d) == (ChordToken sd2 clss2 _cs2 stat2 _n2 _d2) 
+    = sd == sd2 && clss == clss2 && stat == stat2
+
+instance Show ChordToken where
+  show (ChordToken sd clss _cs Inserted _n _d) = show sd ++ show clss++"[Inserted]"
+  show (ChordToken sd clss  cs Deleted  _n _d) = 
+    show sd ++ show clss ++ "[Deleted" ++ showChords cs ++ "]"
+  show (ChordToken sd clss  cs _ _n d) = show sd ++ show clss ++ '_' : show d 
+                                                 ++ showChords cs    
+showChords :: Show a => [Chord a] -> String  
+showChords = concatMap (\x -> '[' : show x ++ "]") 
+
+
+--------------------------------------------------------------------------------
+-- Binary instances
+--------------------------------------------------------------------------------
+
+deriveAllL [''ChordToken, ''ParseStatus]
+
+instance Binary ChordToken where
+  put = putDefault
+  get = getDefault
+instance Binary ParseStatus where
+  put = putDefault
   get = getDefault
src/Main.hs view
@@ -1,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 ]