diff --git a/FComp.cabal b/FComp.cabal
new file mode 100644
--- /dev/null
+++ b/FComp.cabal
@@ -0,0 +1,112 @@
+name: FComp
+version: 1.0
+synopsis: Compose music
+description: Compose music
+
+copyright: (c) 2014 University of Oxford
+license: GPL-3
+license-file: LICENSE
+author: Jose Pedro Magalhaes
+stability: experimental
+maintainer: jpm@cs.ox.ac.uk
+category: Music
+build-type: Simple
+cabal-version: >= 1.6
+tested-with: GHC == 7.6.1
+
+extra-source-files: README
+
+source-repository head
+ type: git
+ location: https://bitbucket.org/dreixel/fcomp/
+
+flag quickcheck2
+ description: Are we using Quickcheck 2?
+ default: True
+
+executable fcomp
+ hs-source-dirs: src
+ other-modules: HarmTrace.Base.Instances
+
+ HarmTrace.HAnTree.HAn
+ HarmTrace.HAnTree.HAnParser
+ HarmTrace.HAnTree.ToHAnTree
+ HarmTrace.HAnTree.Tree
+
+ HarmTrace.Models.Collect
+ HarmTrace.Models.Parser
+ HarmTrace.Models.Generator
+ HarmTrace.Models.ChordTokens
+
+ HarmTrace.Models.Simple.Instances
+ HarmTrace.Models.Simple.Main
+ HarmTrace.Models.Simple.Model
+
+ HarmTrace.Accompany
+ HarmTrace.Play
+ HarmTrace.Song
+
+ main-is: Main.hs
+
+ build-depends: base >= 4.2 && < 4.7, template-haskell >=2.4 && <2.9,
+ array, deepseq, mtl,
+ ListLike >= 3.0.1, binary >= 0.6.4,
+ uu-parsinglib == 2.7.4.*, HarmTrace-Base == 1.*,
+ instant-generics >= 0.4, ghc-prim >= 0.2,
+ haskore >= 0.2.0.3, midi >= 0.2.1.1, random >= 1.0,
+ time >= 1.4
+
+ if flag(quickcheck2)
+ build-depends: QuickCheck >= 2.1 && < 2.7
+ else
+ build-depends: QuickCheck >= 1.2 && < 1.3
+
+ ghc-options: -Wall
+ -O2 -fno-spec-constr-count -funbox-strict-fields
+
+ 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.7, template-haskell >=2.4 && <2.9,
+ array, deepseq, mtl,
+ ListLike >= 3.0.1, binary >= 0.6.4,
+ uu-parsinglib == 2.7.4.*, HarmTrace-Base == 1.*,
+ instant-generics >= 0.4, ghc-prim >= 0.2,
+ haskore >= 0.2.0.3, midi >= 0.2.1.1, random >= 1.0,
+ time >= 1.4
+
+ if flag(quickcheck2)
+ build-depends: QuickCheck >= 2.1 && < 2.7
+ else
+ build-depends: QuickCheck >= 1.2 && < 1.3
+
+ ghc-options: -Wall
+ -O2 -fno-spec-constr-count -funbox-strict-fields
+
+ ghc-prof-options: -auto-all
+
+ hs-source-dirs: src
+
+ exposed-modules: HarmTrace.Base.Instances
+
+ HarmTrace.HAnTree.HAn
+ HarmTrace.HAnTree.HAnParser
+ HarmTrace.HAnTree.ToHAnTree
+ HarmTrace.HAnTree.Tree
+
+ HarmTrace.Models.Collect
+ HarmTrace.Models.Parser
+ HarmTrace.Models.Generator
+ HarmTrace.Models.ChordTokens
+
+ HarmTrace.Models.Simple.Instances
+ HarmTrace.Models.Simple.Main
+ HarmTrace.Models.Simple.Model
+
+ HarmTrace.Accompany
+ HarmTrace.Play
+ HarmTrace.Song
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ Copyright (C)
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,1 @@
+Composer
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/HarmTrace/Accompany.hs b/src/HarmTrace/Accompany.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Accompany.hs
@@ -0,0 +1,186 @@
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Accompany
+-- 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: Generate a melody (accompaniment) for a given harmony
+--------------------------------------------------------------------------------
+
+module HarmTrace.Accompany where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Song
+import HarmTrace.Models.Simple.Model ( Piece )
+import HarmTrace.Models.Simple.Main ( getChords )
+import HarmTrace.Models.ChordTokens ( ChordToken(..), ctToCL, sdToNote )
+
+import Control.Monad.State
+import System.Random
+
+import Data.List ( intersect )
+
+import Debug.Trace
+
+
+map2 :: (b -> c) -> [(a,b)] -> [(a,c)]
+map2 f = map (\(a,b) -> (a, f b))
+
+data MyState = MyState { genState :: StdGen
+ , keyState :: Key
+ , pieceState :: Piece
+ , chordsState :: [ChordToken] }
+
+accompanyIO :: Key -> Piece -> IO Song
+accompanyIO k p = do gen <- getStdGen
+ let initState = MyState gen k p (getChords p)
+ return (evalState (accompany k) initState)
+
+accompany :: Key -> State MyState Song
+accompany k = allPossible >>= refine >>= pickBest>>= embellish
+ >>= return . Song k
+
+-- 2.1) Generate candidate melody notes from chords
+allPossibleRel :: [ChordToken] -> [(ChordToken,[ScaleDegree])]
+allPossibleRel cs = [ (c, notesRootedOn (root c) (classType c)) | c <- cs ]
+
+allPossible :: State MyState [(ChordLabel,[MelodyNote])]
+allPossible = do k <- get >>= return . keyState
+ p <- get >>= return . pieceState
+ let unRel (c,sds) = ( ctToCL k c
+ , map (flip MelodyNote 3 . sdToNote k) sds)
+ return $ map unRel (allPossibleRel (getChords p))
+
+-- All notes that belong to this chord
+notesRootedOn :: ScaleDegree -> ClassType -> [ScaleDegree]
+notesRootedOn sd cls =
+ let indices = case cls of
+ MajClass -> [0,4,7]
+ MinClass -> [0,3,7]
+ DimClass -> [0,3,6]
+ DomClass -> [0,4,7,10]
+ x -> error $ "notesRootedOn: " ++ show x
+ in [ transposeSem sd i | i <- indices ]
+
+-- 2.2) Trim to remove bad candidates
+refine :: [(ChordLabel, [MelodyNote])] -> State MyState [(ChordLabel, [MelodyNote])]
+refine [] = return []
+refine ((cl,mns):cs) =
+ do k <- get >>= return . keyState
+ -- Make sure the first note is one of I, III, or V
+ let indices = case keyMode k of
+ MajMode -> [0,4,7::Int]
+ MinMode -> [0,3,7]
+ ki = toSemitone (keyRoot k)
+ makeNote i = MelodyNote (toRootM (i + ki)) 3
+ first = map makeNote indices
+ firstNotes = let wanted = first `intersect` mns
+ in if null wanted then mns else wanted
+ -- Handle the final note
+ lastNote ns = let (a,[b]) = splitAt (length ns - 1) ns
+ in a ++ [final b]
+ -- We want the final note to be a I, or, if I is not in the chord, a V
+ final (c,n) = let n' = if makeNote 0 `elem` n
+ then [makeNote 0]
+ else [makeNote 7]
+ in (c,n')
+ return $ ((cl,firstNotes) : lastNote cs)
+
+-- 2.3) Pick one note per chord
+pickBest :: [(ChordLabel, [MelodyNote])] -> State MyState [(ChordLabel, MelodyNote)]
+pickBest cs =
+ do s <- get
+ -- Just randomly pick notes from the list of candidates
+ let g = genState s
+ rs = randoms g
+ f ((cl, mns), r) = (cl, mns !! (r `mod` length mns))
+ result = map f (zip cs rs)
+ -- Make sure VIIs are followed by a I in the right octave
+ k = keyState s
+ ki = toSemitone (keyRoot k)
+ makeNote i = MelodyNote (toRootM (i + ki)) 3
+ resolveCadences :: [(ChordLabel, MelodyNote)] -> [(ChordLabel, MelodyNote)]
+ resolveCadences ((c1,n1):(c2,n2):cns)
+ | n1 == makeNote 0 && n2 == makeNote 11
+ = (c1,n1) : (c2,octaveDown n2) : resolveCadences cns
+ | n1 == makeNote 11 && n2 == makeNote 0
+ = (c1,n1) : (c2,octaveUp n2) : resolveCadences cns
+ | otherwise = (c1,n1) : resolveCadences ((c2,n2):cns)
+ resolveCadences x = x
+ return (resolveCadences result)
+
+-- 2.4) Embellish the melody
+embellish :: [(ChordLabel, MelodyNote)] -> State MyState [(ChordLabel, [MelodyNote])]
+embellish [] = return []
+embellish ((cl,mn):cls) = do g <- get >>= return . genState
+ k <- get >>= return . keyState
+ return $ go k (cl,mn,g) cls
+ where
+ go k (cl1,n1,g1) [] = [(cl1,[n1])]
+ go k (cl1,n1,g1) ((cl2,n2):cls) = let (_,g2) = next g1
+ in (cl1, connectNotes g1 k cl1 n1 n2)
+ : go k (cl2,n2,g2) cls
+
+-- Given two notes, return a melody that begins in the first and ends in
+-- something suitable to be connected to the second.
+connectNotes :: StdGen -> Key -> ChordLabel
+ -> MelodyNote -> MelodyNote -> [MelodyNote]
+connectNotes g k cl n1@(MelodyNote r1 o1) n2@(MelodyNote r2 o2)
+ | n1 == n2
+-- embellish repetitions
+ = let scale = notesInChord cl -- this is debatable...
+ in case fst (randomR (0,3::Int) g) of
+ -- C C -> C C
+ 0 -> [n1]
+ -- C C -> C D E C
+ 1 -> if n1 `elem` scale
+ then take 3 . dropWhile (/= n1) $ scale
+ else [n1]
+ -- C C -> C B C
+ 2 -> if n1 `elem` scale
+ then take 2 . dropWhile (/= n1) $ reverse scale
+ else [n1]
+ -- C C -> C E D C
+ 3 -> let f123_132 [c,d,e] = [c,e,d]
+ in if n1 `elem` scale
+ then f123_132 . take 3 . dropWhile (/= n1) $ scale
+ else [n1]
+ _ -> error "connectNotes: impossible"
+
+-- Connect from a scale in the current key
+connectNotes g k cl n1@(MelodyNote r1 o1) n2@(MelodyNote r2 o2)
+ = let scale = notesInKey k
+ -- scale = notesInChord cl
+ line = if n1 < n2
+ then n1 : takeWhile (< n2) (dropWhile (<= n1) scale)
+ else n1 : takeWhile (n2 <) (dropWhile (n1 <=) (reverse scale))
+ in line
+
+-- Like toRoot, but mod 12
+toRootM :: Int -> Root
+toRootM = toRoot . (`mod` 12)
+
+-- Returns a scale
+notesInKey :: Key -> [MelodyNote]
+notesInKey (Key r m) = let indices = case m of
+ MajMode -> [0,2,4,5,7,9,11]
+ MinMode -> [0,2,3,5,7,8,10] -- tricky
+ base = [ toRootM (toSemitone r + i) | i <- indices ]
+ in filter (\n -> mnRoot n `elem` base) allMelodyNotes
+
+-- Return the scale associated with a chord
+notesInChord :: ChordLabel -> [MelodyNote]
+notesInChord cl = let r = chordRoot cl
+ indices = case chordShorthand cl of
+ Maj -> [0,2,4,5,7,9,11]
+ Sev -> [0,2,4,5,7,9,10]
+ Min -> [0,2,3,5,7,8,10]
+ Dim -> [0,2,3,5,6,8,9]
+ m -> error $ "notesInChord: " ++ show m
+ base = [ toRootM (toSemitone r + i) | i <- indices ]
+ in filter (\n -> mnRoot n `elem` base) allMelodyNotes
diff --git a/src/HarmTrace/Base/Instances.hs b/src/HarmTrace/Base/Instances.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Base/Instances.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+
+module HarmTrace.Base.Instances where
+
+import Control.DeepSeq
+
+import HarmTrace.Base.MusicRep
+
+--------------------------------------------------------------------------------
+-- NFData instances for HarmTrace-Base
+--------------------------------------------------------------------------------
+
+instance NFData Mode where
+ rnf MinMode = ()
+ rnf MajMode = ()
diff --git a/src/HarmTrace/HAnTree/HAn.hs b/src/HarmTrace/HAnTree/HAn.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/HAnTree/HAn.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module HarmTrace.HAnTree.HAn where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Models.ChordTokens
+
+import Control.DeepSeq
+import Data.Binary
+import GHC.Generics (Generic)
+
+--------------------------------------------------------------------------------
+-- 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
+ deriving Generic
+
+ -- 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
+ deriving Generic
+
+data Spec = Blues | MinBorrow | Parallel
+ deriving (Eq, Generic)
+
+-- 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
+ deriving Generic
+
+-- 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
+ deriving Generic
+
+--------------------------------------------------------------------------------
+-- Binary instances
+--------------------------------------------------------------------------------
+
+instance Binary HAn
+instance Binary Trans
+instance Binary Prep
+instance Binary HFunc
+instance Binary Spec
+
+--------------------------------------------------------------------------------
+-- NFData instances
+--------------------------------------------------------------------------------
+
+instance NFData HAn where
+ rnf (HAn d s ) = rnf d `seq` rnf s
+ rnf (HAnFunc a) = rnf a
+ rnf (HAnTrans a) = rnf a
+ rnf (HAnPrep a) = rnf a
+ rnf (HAnChord a) = seq a ()
+
+instance NFData HFunc where
+ rnf (Ton a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+ rnf (Dom a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+ rnf (Sub a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+ rnf P = ()
+ rnf PD = ()
+ rnf PT = ()
+
+instance NFData Prep where
+ rnf (SecDom i d) = rnf i `seq` d `seq` ()
+ rnf (SecMin i d) = rnf i `seq` d `seq` ()
+ rnf (DiatDom i d) = rnf i `seq` d `seq` ()
+ rnf NoPrep = ()
+
+instance NFData Trans where
+ rnf (Trit i d) = rnf i `seq` d `seq` ()
+ rnf (DimTrit i d) = rnf i `seq` d `seq` ()
+ rnf (DimTrans i d) = rnf i `seq` d `seq` ()
+ rnf NoTrans = ()
+
+instance NFData Spec where
+ rnf Blues = ()
+ rnf MinBorrow = ()
+ rnf Parallel = ()
+
+--------------------------------------------------------------------------------
+-- Durations set and get instances
+--------------------------------------------------------------------------------
+
+-- Yes, I know these can be generic functions, but with my current generic
+-- programming skils it is faster two write them by hand.
+class GetDur a where
+ getDur :: a -> Int
+
+instance GetDur HAn where
+ getDur (HAn d _s) = d
+ getDur (HAnFunc a) = getDur a
+ getDur (HAnPrep a) = getDur a
+ getDur (HAnTrans a) = getDur a
+ getDur (HAnChord a) = dur a
+
+instance GetDur HFunc where
+ getDur (Ton i _ _ _) = i
+ getDur (Dom i _ _ _) = i
+ getDur (Sub i _ _ _) = i
+ getDur _ = 0
+
+instance GetDur Prep where
+ getDur (SecDom i _) = i
+ getDur (SecMin i _) = i
+ getDur (DiatDom i _) = i
+ getDur NoPrep = 0
+
+instance GetDur Trans where
+ getDur (Trit i _) = i
+ getDur (DimTrit i _) = i
+ getDur (DimTrans i _) = i
+ getDur NoTrans = 0
+
+instance GetDur (Chord a) where
+ getDur = duration
+
+class SetDur a where
+ setDur :: a -> Int -> a
+
+instance SetDur HAn where
+ setDur (HAn _ s) i = (HAn i s)
+ setDur (HAnFunc a) i = (HAnFunc (setDur a i))
+ setDur (HAnTrans a) i = (HAnTrans (setDur a i))
+ setDur a _i = a
+
+instance SetDur HFunc where
+ setDur (Ton _d m i s) d = (Ton d m i s)
+ setDur (Dom _d m i s) d = (Dom d m i s)
+ setDur (Sub _d m i s) d = (Sub d m i s)
+ setDur a _ = a
+
+instance SetDur Prep where
+ setDur (SecDom _d sd) d = (SecDom d sd)
+ setDur (SecMin _d sd) d = (SecMin d sd)
+ setDur (DiatDom _d sd) d = (DiatDom d sd)
+ setDur NoPrep _ = NoPrep
+
+instance SetDur Trans where
+ setDur (Trit _d sd) d = (Trit d sd)
+ setDur (DimTrit _d sd) d = (DimTrit d sd)
+ setDur (DimTrans _d sd) d = (DimTrans d sd)
+ setDur NoTrans _ = NoTrans
+
+--------------------------------------------------------------------------------
+-- Eq instances
+--------------------------------------------------------------------------------
+
+instance Eq HAn where
+ (HAn _ s) == (HAn _ s2) = s == s2
+ (HAnChord chord) == (HAnChord chord2) = chord == chord2
+ (HAnFunc hfunk) == (HAnFunc hfunk2) = hfunk == hfunk2
+ (HAnTrans trans) == (HAnTrans trans2) = trans == trans2
+ _ == _ = False
+
+instance Eq HFunc where
+ -- ignore duration for now
+ (Ton _ b c d) == (Ton _ b2 c2 d2) = b == b2 && c == c2 && d == d2
+ (Dom _ b c d) == (Dom _ b2 c2 d2) = b == b2 && c == c2 && d == d2
+ (Sub _ b c d) == (Sub _ b2 c2 d2) = b == b2 && c == c2 && d == d2
+ P == P = True
+ PD == PD = True
+ PT == PT = True
+ _ == _ = False
+
+instance Eq Prep where
+ (SecDom _dur sd) == (SecDom _dur2 sd2) = sd == sd2
+ (SecMin _dur sd) == (SecMin _dur2 sd2) = sd == sd2
+ (DiatDom _dur sd) == (DiatDom _dur2 sd2) = sd == sd2
+ NoPrep == NoPrep = True
+ _ == _ = False
+
+instance Eq Trans where
+ (Trit _dur sd) == (Trit _dur2 sd2) = sd == sd2
+ (DimTrit _dur sd) == (DimTrit _dur2 sd2) = sd == sd2
+ (DimTrans _dur sd) == (DimTrans _dur2 sd2) = sd == sd2
+ NoTrans == NoTrans = True
+ _ == _ = False
+
+--------------------------------------------------------------------------------
+-- Eq and Show instances
+--------------------------------------------------------------------------------
+
+instance Show Prep where
+ show (SecDom l d) = "V/" ++ show d ++ '_' : show l
+ show (SecMin l d) = "v/" ++ show d ++ '_' : show l
+ show (DiatDom l d) = "Vd/"++ show d ++ '_' : show l
+ show NoPrep = "np"
+
+instance Show Trans where
+ show (Trit l d) = "IIb/" ++ show d ++ '_' : show l
+ show (DimTrit l d) = "IIb9b/" ++ show d ++ '_' : show l
+ show (DimTrans l d) = show d ++ "0" ++ '_' : show l
+ show (NoTrans) = "nt"
+
+instance Show HAn where
+ show (HAn l con) = con ++ "_s" ++ '_' : show l
+ show (HAnChord chord) = show chord
+ show (HAnFunc hfunk) = show hfunk
+ show (HAnTrans trans) = show trans
+ show (HAnPrep prep ) = show prep
+
+instance Show HFunc where
+ show (Ton l mode i s) = "T" ++ show mode ++ '_' : show i
+ ++ maybe "" show s ++ '_' : show l
+ show (Dom l mode i s) = "D" ++ show mode ++ '_' : show i
+ ++ maybe "" show s ++ '_' : show l
+ show (Sub l mode i s) = "S" ++ show mode ++ '_' : show i
+ ++ maybe "" show s ++ '_' : show l
+ show (P ) = "Piece"
+ show (PT) = "PT"
+ show (PD) = "PD"
+
+instance Show Spec where
+ show Blues = "bls"
+ show MinBorrow = "bor"
+ show Parallel = "par"
diff --git a/src/HarmTrace/HAnTree/HAnParser.hs b/src/HarmTrace/HAnTree/HAnParser.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/HAnTree/HAnParser.hs
@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module HarmTrace.HAnTree.HAnParser where
+
+import HarmTrace.Base.Parsing
+import HarmTrace.Base.MusicRep (Mode(..))
+import HarmTrace.HAnTree.HAn
+
+import Data.Maybe (isJust, fromJust)
+--------------------------------------------------------------------------------
+-- A Small Parser for Parsing MIR constructors
+--------------------------------------------------------------------------------
+
+-- this top-level function parses a constructor name and returns the
+-- corresponding HAn data type. N.B. we can implement the catch all
+-- case as a parser, because it accepts everything and one will get an
+-- "ambiguous parser?" error.s
+parseHAn :: ListLike state Char => state -> HAn
+parseHAn inp
+ | isJust a = fromJust a
+ | otherwise = parseData (HAn 1 <$> pAnyStr) inp where -- catch all case
+ a = parseData (pMaybe $ HAnFunc <$> pHFunc) inp
+
+
+pHFunc :: Parser HFunc
+pHFunc = Ton 1 <$ pSym 'T' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec
+ <|> Dom 1 <$ pSym 'D' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec
+ <|> Sub 1 <$ pSym 'S' <*> pMode <* pSym '_' <*> pInteger <*> pMaybe pSpec
+ <|> PD <$ pString "PD"
+ <|> PT <$ pString "PT"
+
+pMode :: Parser Mode
+pMode = MinMode <$ pSym 'm'
+ <|> MajMode <$ pString ""
+
+pSpec :: Parser Spec
+pSpec = MinBorrow <$ pString "_bor"
+ <|> Blues <$ pString "_bls"
+ <|> Parallel <$ pString "_par"
+
+pAnyStr :: Parser String
+pAnyStr = pAtMost 15 pAscii
diff --git a/src/HarmTrace/HAnTree/ToHAnTree.hs b/src/HarmTrace/HAnTree/ToHAnTree.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/HAnTree/ToHAnTree.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+
+module HarmTrace.HAnTree.ToHAnTree ( GTree(..) , HAn(..) , gTreeDefault
+ , gTreeHead , emptyHAnTree ) where
+
+import Generics.Instant.Base
+import HarmTrace.HAnTree.Tree (Tree(..))
+import HarmTrace.HAnTree.HAn
+import HarmTrace.HAnTree.HAnParser
+
+class GTree a where
+ gTree :: a -> [Tree HAn]
+
+instance GTree U where
+ gTree U = [Node (HAn 0 "U") [] Nothing]
+
+instance (GTree a, GTree b) => GTree (a :+: b) where
+ gTree (L x) = gTree x
+ gTree (R x) = gTree x
+
+instance (GTree a, Constructor c) => GTree (CEq c p q a) where
+ gTree c@(C a) = [Node (parseHAn (conName c)) (gTree a) Nothing]
+
+instance (GTree a, GTree b) => GTree (a :*: b) where
+ gTree (a :*: b) = gTree a ++ gTree b
+
+instance GTree a => GTree (Rec a) where
+ gTree (Rec x) = gTree x
+
+instance GTree a => GTree (Var a) where
+ gTree (Var x) = gTree x
+
+
+instance GTree a => GTree [a] where
+ gTree x = concatMap gTree x
+
+-- Dispatcher
+gTreeDefault :: (Representable a, GTree (Rep a)) => a -> [Tree HAn]
+gTreeDefault = gTree . from
+
+gTreeHead :: (GTree a) => a -> Tree HAn
+gTreeHead = head . gTree
+
+emptyHAnTree :: Tree HAn
+emptyHAnTree = Node (HAn 0 "empty") [] Nothing
diff --git a/src/HarmTrace/HAnTree/Tree.hs b/src/HarmTrace/HAnTree/Tree.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/HAnTree/Tree.hs
@@ -0,0 +1,172 @@
+
+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 all the labels in the tree
+getLabels :: Tree t -> [t]
+getLabels (Node lab ts _) = lab : concatMap getLabels ts
+
+-- returns True if t is a leaf and False otherwise
+isLf :: (Eq t) => Tree t -> Bool
+isLf t = getChild t == []
+
+collectLeafs :: Tree t -> [Tree t]
+collectLeafs t@(Node _ [] _) = [t]
+collectLeafs (Node _ cn _) = concatMap collectLeafs cn
+
+-- returns the size of the tree
+size, depth :: Tree t -> Int
+size (Node _ [] _) = 1
+size (Node _ children _ ) = foldr ((+) . size ) 1 children
+
+-- returns the size of a forrest of trees
+sizeF, depthF :: [Tree t] -> Int
+sizeF treeList = foldr ((+) . size ) 0 treeList
+
+avgDepth :: Tree t -> Float
+avgDepth t = fromIntegral (sum dep) / (genericLength dep) where
+ dep = depth' 1 t
+
+avgDepthF :: [Tree t] -> Float
+avgDepthF t = let l = map avgDepth t in sum l / genericLength l
+
+-- returns the maximum depth of a tree
+depth t = maximumBy compare (depth' 1 t)
+
+-- returns the maximum depth of a forrest of trees
+depthF treeList = maximumBy compare (concatMap (depth' 1) treeList)
+
+-- depth helper
+depth' :: Int -> Tree t -> [Int]
+depth' x (Node _ [] _ ) = [x]
+depth' x (Node _ c _ ) = x : concatMap (depth' (x+1)) c
+
+-- recursively removes the nodes with label 'x' from a tree
+remove :: (Eq t) => t -> Tree t -> Tree t
+remove x = removeBy (== x)
+
+-- more general version of remove
+removeBy :: (t -> Bool) -> Tree t -> Tree t
+removeBy f t = head (removeBy' f t)
+removeBy' :: (t -> Bool) -> Tree t -> [Tree t]
+removeBy' f (Node l c pn)
+ | f l = concatMap (removeBy' f) c
+ | otherwise = [(Node l (concatMap (removeBy' f) c) pn)]
+
+-- collects all the subtrees of tree in a list in post order.
+pot, pot', pret, pret',potPret :: Tree t -> [Tree t]
+potPret t = pot' (setPre t)
+pot t = pot' (setPost t)
+pot' t@(Node _ [] _) = [t]
+pot' t@(Node _ children _) = concatMap pot' children ++ [t]
+-- collects all the subtrees of tree in a list in pre order.
+pret t = pret' (setPre t)
+pret' t@(Node _ [] _) = [t]
+pret' t@(Node _ children _) = t : concatMap pret' children
+
+-- very inefficient way of converting a pre order number to a post order number
+-- just for testing....
+preToPost :: Tree t -> Int -> Int
+preToPost t pn = fromJust . getPn $ pret' (setPost t) !! pn
+
+
+-- Converts Node's to NodePn's and sets the post order numbers
+-- JPM: setPost is a typical tree labelling problem.
+-- Looks nicer with the state monad, I think:
+setPost, setPre :: Tree t -> Tree t
+setPost t = evalState (stm t) 0 where
+ stm :: Tree t -> State Int (Tree t)
+ stm (Node a cs _) = do cs' <- mapM stm cs
+ pn <- get
+ modify (+1)
+ return (Node a cs' (Just pn))
+
+-- Sets pre order numbers
+setPre t = evalState (stm t) 0 where
+ stm :: Tree t -> State Int (Tree t)
+ stm (Node a cs _) = do pn <- get
+ modify (+1)
+ cs' <- mapM stm cs
+ return (Node a cs' (Just pn))
+
+--not very efficient, but nevertheless very effective, todo optimize elem operation
+matchToTree :: Tree t -> [Int] -> [Tree t]
+matchToTree t@(Node _ _ Nothing ) k = matchToTree (setPost t) k
+matchToTree (Node a cn (Just pn)) k =
+ let cs = concatMap (`matchToTree` k) cn
+ in if pn `elem` k then [Node a cs (Just pn)] else cs
diff --git a/src/HarmTrace/Models/ChordTokens.hs b/src/HarmTrace/Models/ChordTokens.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/ChordTokens.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+module HarmTrace.Models.ChordTokens ( ChordToken (..)
+ , sdToNote, ctToCL
+ , PieceToken (..)
+ , ParseStatus (..)
+ ) where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Base.Instances ()
+import Data.Binary
+import GHC.Generics (Generic)
+
+--------------------------------------------------------------------------------
+-- 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
+ } deriving Generic
+
+data ParseStatus = NotParsed | Parsed | Deleted | Inserted
+ deriving (Eq, Show, Generic)
+
+-- a datatype to store a tokenized chords
+data PieceToken = PieceToken Key [ChordToken]
+
+--------------------------------------------------------------------------------
+-- 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 _ _ _ _) = show sd ++ show clss
+
+--------------------------------------------------------------------------------
+-- ChordToken to ChordLabel
+--------------------------------------------------------------------------------
+
+-- This function should be moved to harmtrace-base
+sdToNote :: Key -> ScaleDegree -> Root
+sdToNote (Key r _mode) sd = toRoot . toSemitone . transposeSem sd $ toSemitone r
+
+-- This function should be moved to harmtrace-base
+classTypeToSH :: ClassType -> Shorthand
+classTypeToSH MajClass = Maj
+classTypeToSH MinClass = Min
+classTypeToSH DomClass = Sev
+classTypeToSH DimClass = Dim
+classTypeToSH NoClass = None
+
+ctToCL :: Key -> ChordToken -> ChordLabel
+ctToCL k (ChordToken sd ct _cs _st _reps d) =
+ Chord (sdToNote k sd) (classTypeToSH ct) [] 0 d
+
+--------------------------------------------------------------------------------
+-- Binary instances
+--------------------------------------------------------------------------------
+
+instance Binary ChordToken
+instance Binary ParseStatus
diff --git a/src/HarmTrace/Models/Collect.hs b/src/HarmTrace/Models/Collect.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/Collect.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Models.Collect
+-- 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: Generic collect
+--------------------------------------------------------------------------------
+
+module HarmTrace.Models.Collect ( CollectG (..), collectGdefault ) where
+
+-- Generics stuff
+import Generics.Instant.Base as G
+
+
+--------------------------------------------------------------------------------
+-- The generic part of the parser
+--------------------------------------------------------------------------------
+
+class Collect' a b where
+ collect' :: a -> [b]
+
+instance Collect' U b where
+ collect' _ = []
+
+instance (CollectG a b) => Collect' (Rec a) b where
+ collect' (Rec x) = collectG x
+
+-- Not really necessary because TH is not generating any Var, but anyway
+instance (CollectG a b) => Collect' (Var a) b where
+ collect' (Var x) = collectG x
+
+instance (Collect' a b) => Collect' (G.CEq c p q a) b where
+ collect' (G.C x) = collect' x
+
+instance (Collect' a c, Collect' b c) => Collect' (a :+: b) c where
+ collect' (L x) = collect' x
+ collect' (R x) = collect' x
+
+instance (Collect' a c, Collect' b c) => Collect' (a :*: b) c where
+ collect' (a :*: b) = collect' a ++ collect' b
+
+
+class CollectG a b where
+ collectG :: a -> [b]
+
+instance (CollectG a b) => CollectG [a] b where
+ collectG = concatMap collectG
+
+-- | default generic parser
+collectGdefault :: (Representable a, Collect' (Rep a) b) => a -> [b]
+collectGdefault = collect' . from
diff --git a/src/HarmTrace/Models/Generator.hs b/src/HarmTrace/Models/Generator.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/Generator.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+
+module HarmTrace.Models.Generator (
+ Generate(..), GenerateG(..), genGdefault, arbitrary
+ , Gen, FrequencyTable, frequencies, frequency
+ ) where
+
+import Generics.Instant.Base
+import Generics.Instant.Instances ()
+
+import Test.QuickCheck (Gen, frequency, sized)
+import Data.Maybe (fromJust)
+-- import Debug.Trace (trace)
+
+--------------------------------------------------------------------------------
+-- Utility functions for data generation
+--------------------------------------------------------------------------------
+
+-- | A frequency table detailing how often certain constructors should be
+-- picked. The 'String' corresponds to the constructor name.
+type FrequencyTable = [(String,Int)]
+
+frequencies :: [String] -> FrequencyTable -> Int
+frequencies [] _ = 0
+frequencies (s:ss) ft = let freqs = maybe 1 id (lookup s ft)
+ in freqs + frequencies ss ft
+
+--------------------------------------------------------------------------------
+
+-- Generic empty on Representable (worker)
+class Generate a where
+ gen' :: FrequencyTable -> Int -> Int -> Maybe (Gen a)
+
+instance Generate U where
+ gen' _ _ _ = return . return $ U
+
+instance ( Generate a, ConNames a
+ , Generate b, ConNames b) => Generate (a :+: b) where
+ gen' ft m n =
+ let aConNames = conNames (undefined :: a)
+ bConNames = conNames (undefined :: b)
+ aFrequency = frequencies aConNames ft
+ bFrequency = frequencies bConNames ft
+ rl = maybe [] (\x -> [(aFrequency, fmap L x)]) (gen' ft m n)
+ rr = maybe [] (\x -> [(bFrequency, fmap R x)]) (gen' ft m n)
+ in {- trace ("left " ++ show aConNames ++ ": " ++ show aFrequency ++
+ "\nright " ++ show bConNames ++ ": " ++ show bFrequency) $ -}
+ if null (rl ++ rr) then Nothing else return . frequency $ rl ++ rr
+
+instance (Generate a, Generate b) => Generate (a :*: b) where
+ gen' ft m n = do rl <- gen' ft m n
+ rr <- gen' ft m n
+ return $ do x <- rl
+ y <- rr
+ return (x :*: y)
+
+instance (Generate a) => Generate (CEq c p p a) where
+ gen' ft m n = fmap (fmap C) (gen' ft m n)
+
+instance Generate (CEq c p q a) where
+ gen' _ _ _ = Nothing
+
+instance (GenerateG a) => Generate (Var a) where
+ gen' ft m n = fmap (fmap Var) $ genG ft (n `div` m)
+
+instance (GenerateG a) => Generate (Rec a) where
+ gen' ft m n = fmap (fmap Rec) $ genG ft (n `div` m)
+
+
+-- Dispatcher
+class GenerateG a where
+ genG :: FrequencyTable -> Int -> Maybe (Gen a)
+
+-- | Generic arbitrary function, sized and with custom constructor frequencies.
+-- This function does not require any particular nesting order of the sums of
+-- the generic representation.
+genGdefault :: (Representable a, Generate (Rep a))
+ => FrequencyTable -> Int -> Maybe (Gen a)
+genGdefault ft = fmap (fmap to) . gen' ft 1
+
+-- | Generic arbitrary function with default sizes and constructor frequencies.
+arbitrary :: (Representable a, Generate (Rep a)) => Gen a
+arbitrary = sized (fromJust . genGdefault [])
+
+-- Adhoc instances
+-- none
+
+-- Generic instances
+instance (GenerateG a) => GenerateG (Maybe a) where genG = genGdefault
+instance (GenerateG a) => GenerateG [a] where genG = genGdefault
+instance (GenerateG a, GenerateG b) => GenerateG (a,b) where genG = genGdefault
+
+--------------------------------------------------------------------------------
+
+class ConNames a where
+ conNames :: a -> [String]
+ conNames _ = []
+
+instance (ConNames a, ConNames b) => ConNames (a :+: b) where
+ conNames (_ :: a :+: b) = conNames (undefined :: a) ++
+ conNames (undefined :: b)
+
+instance (ConNames a, Constructor c) => ConNames (CEq c p q a) where
+ conNames (x :: (CEq c p q a)) = [conName x]
+
+instance ConNames U
+instance ConNames (f :*: g)
+instance ConNames (Var a)
+instance ConNames (Rec a)
+
+--------------------------------------------------------------------------------
+{-
+-- | Tree structure to store fixed points as found in the data type.
+data Tree a = Leaf a | Node (Tree a) (Tree a)
+ deriving Show
+
+foldTree :: (a -> b) -> (b -> b -> b) -> Tree a -> b
+foldTree l _ (Leaf x) = l x
+foldTree l n (Node x y) = (foldTree l n x) `n` (foldTree l n y)
+
+sumTree :: Tree Int -> Int
+sumTree = foldTree id (+)
+
+-- | The class to compute fixed points.
+class Fixpoints a where
+ hFixpoints :: a -> Tree Int
+
+instance (Fixpoints a, Fixpoints b) => Fixpoints (a :+: b) where
+ hFixpoints (_ :: a :+: b) = Node (hFixpoints (undefined :: a))
+ (hFixpoints (undefined :: b))
+
+instance (Fixpoints a) => Fixpoints (CEq c p q a) where
+ hFixpoints (_ :: CEq c p q a) = hFixpoints (undefined :: a)
+
+instance (Fixpoints a, Fixpoints b) => Fixpoints (a :*: b) where
+ hFixpoints (_ :: a :*: b) =
+ let Leaf m = hFixpoints (undefined :: a)
+ Leaf n = hFixpoints (undefined :: b)
+ in Leaf (m + n)
+
+instance Fixpoints (Rec a) where hFixpoints _ = Leaf 1
+instance Fixpoints (Var a) where hFixpoints _ = Leaf 0
+instance Fixpoints U where hFixpoints _ = Leaf 0
+
+{-
+-- | Return a tree structure of the fixed points of a datatype
+fixpoints :: (Representable a, Fixpoints (Rep a)) => a -> Tree Int
+fixpoints x = hFixpoints (undefined `asTypeOf` (from x))
+-}
+-}
diff --git a/src/HarmTrace/Models/Parser.hs b/src/HarmTrace/Models/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/Parser.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- 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 (
+ ParseG (..)
+ , parseGdefault
+ , PMusic
+ ) where
+
+
+-- Parser stuff
+import Text.ParserCombinators.UU
+import Text.ParserCombinators.UU.BasicInstances
+
+-- Generics stuff
+import Generics.Instant.Base as G
+
+-- Music stuff
+import HarmTrace.Models.ChordTokens
+
+
+--------------------------------------------------------------------------------
+-- The generic part of the parser
+--------------------------------------------------------------------------------
+
+-- | a type synoniome for a harmonic analysis of a piece of music
+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
+
+-- | default generic parser
+parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a
+-- parseGdefault = fmap (to . head) (amb parse')
+-- Previously we used:
+parseGdefault = fmap to parse'
+-- This gave rise to many ambiguities. Now we allow parse' to be ambiguous
+-- (note that the sum case uses <|>) but then pick only the very first tree
+-- from all the possible results. It remains to be seen if the first tree is
+-- the best...
diff --git a/src/HarmTrace/Models/Simple/Instances.hs b/src/HarmTrace/Models/Simple/Instances.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/Simple/Instances.hs
@@ -0,0 +1,133 @@
+{-# 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 #-}
+{-# LANGUAGE DataKinds #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Models.Simple.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 Simple model
+--------------------------------------------------------------------------------
+
+module HarmTrace.Models.Simple.Instances where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Parser stuff
+import Text.ParserCombinators.UU hiding ((<$$>), (<**>))
+import Text.ParserCombinators.UU.BasicInstances
+
+-- Music stuff
+import HarmTrace.Models.Collect
+import HarmTrace.Models.Parser
+import HarmTrace.Models.Generator
+import HarmTrace.Models.Simple.Model
+import HarmTrace.HAnTree.Tree
+import HarmTrace.HAnTree.ToHAnTree
+import HarmTrace.HAnTree.HAn
+import HarmTrace.Models.ChordTokens as CT
+import HarmTrace.Base.MusicRep
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the parser
+--------------------------------------------------------------------------------
+
+instance ( ToDegree deg, ToClass clss
+ ) => ParseG (Surface_Chord deg clss) where
+ parseG = pChord deg clss
+ where deg = toDegree (Proxy :: Proxy deg)
+ clss = toClass (Proxy :: Proxy clss)
+
+-- generic ad-hoc parser that forms the bridge between the type-level and
+-- value-level representation
+pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss)
+-- Do not parse Imp degrees
+pChord (Note _ Imp) _clss = empty
+-- General case
+pChord deg clss = setStatus <$> pSatisfy recognize insertion where
+ {-# INLINE recognize #-}
+ recognize ct = deg == root ct && clss == classType ct
+
+ {-# INLINE setStatus #-}
+ setStatus c = case status c of
+ NotParsed -> Surface_Chord c {status = Parsed}
+ _ -> Surface_Chord c
+
+ insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the collector
+--------------------------------------------------------------------------------
+
+instance CollectG (Phrase mode) ChordToken where collectG = collectGdefault
+instance CollectG (Ton mode) ChordToken where collectG = collectGdefault
+instance CollectG (SDom mode) ChordToken where collectG = collectGdefault
+instance CollectG (Dom mode) ChordToken where collectG = collectGdefault
+
+instance CollectG (Surface_Chord deg clss) ChordToken where
+ collectG (Surface_Chord x) = [x]
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the generator
+--------------------------------------------------------------------------------
+
+instance ( ToDegree deg, ToClass clss
+ ) => GenerateG (Surface_Chord deg clss) where
+ genG _ _ = genChord deg clss
+ where deg = toDegree (Proxy :: Proxy deg)
+ clss = toClass (Proxy :: Proxy clss)
+
+genChord :: ScaleDegree -> ClassType -> Maybe (Gen (Surface_Chord deg clss))
+genChord (Note _ Imp) _ = Nothing
+genChord deg clss = Just . return . Surface_Chord
+ $ ChordToken deg clss [] CT.Parsed 1 0
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the GTree wrapper
+--------------------------------------------------------------------------------
+
+instance GTree Piece where -- we take the children to skip a "list node"
+ gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing]
+
+instance GTree (Surface_Chord deg clss) where
+ gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing]
+
+--------------------------------------------------------------------------------
+-- Instances of Representable for music datatypes
+--------------------------------------------------------------------------------
+
+deriveAllL allTypes
+
+$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault)
+ allTypes)
+
+$(fmap join $ mapM (\t -> gadtInstance ''GenerateG t 'genG 'genGdefault)
+ allTypes)
+
+$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault)
+ allTypes)
+
+--------------------------------------------------------------------------------
+-- ChordToken as tokens
+--------------------------------------------------------------------------------
+
+instance IsLocationUpdatedBy Int ChordToken where
+ advance p c = p + chordNumReps c
diff --git a/src/HarmTrace/Models/Simple/Main.hs b/src/HarmTrace/Models/Simple/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/Simple/Main.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DataKinds #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Models.Simple.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 Simple parser
+--------------------------------------------------------------------------------
+
+module HarmTrace.Models.Simple.Main (
+ pSimple, genPiece, getChords
+ , module HarmTrace.Models.Simple.Model
+ ) where
+
+-- Parser stuff
+import Text.ParserCombinators.UU
+
+-- Music stuff
+import HarmTrace.Base.MusicRep
+import HarmTrace.Models.Collect
+import HarmTrace.Models.Parser
+import HarmTrace.Models.Generator
+import HarmTrace.Models.Simple.Model
+import HarmTrace.Models.Simple.Instances ()
+import HarmTrace.Models.ChordTokens ( ChordToken )
+
+--------------------------------------------------------------------------------
+-- 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])
+
+pSimple :: Key -> PMusic [Piece]
+pSimple (Key _ MajMode) = pPieceMaj
+pSimple (Key _ MinMode) = pPieceMin
+
+--------------------------------------------------------------------------------
+-- From structured music pieces back to tokens
+--------------------------------------------------------------------------------
+
+getChords :: Piece -> [ChordToken]
+getChords (Piece phrases) = collectG phrases
+
+--------------------------------------------------------------------------------
+-- Generating simple pieces
+--------------------------------------------------------------------------------
+
+genPiece :: Key -> Gen Piece
+genPiece (Key _ MajMode) = fmap Piece (arbitrary :: Gen [Phrase MajMode])
+genPiece (Key _ MinMode) = fmap Piece (arbitrary :: Gen [Phrase MinMode])
diff --git a/src/HarmTrace/Models/Simple/Model.hs b/src/HarmTrace/Models/Simple/Model.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Models/Simple/Model.hs
@@ -0,0 +1,340 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Models.Simple.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 Simple model
+--------------------------------------------------------------------------------
+
+module HarmTrace.Models.Simple.Model where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Models.ChordTokens
+import Language.Haskell.TH.Syntax (Name)
+
+--------------------------------------------------------------------------------
+-- Musical structure as a datatype
+--------------------------------------------------------------------------------
+
+#ifndef NUMLEVELS
+#define NUMLEVELS T5
+#endif
+
+-- data MajMode
+-- data MinMode
+
+data Proxy (t :: k) = Proxy
+
+-- High level structure
+data Piece = forall (mode :: Mode). Piece [Phrase mode]
+
+-- The Phrase level
+data Phrase (mode :: Mode) where
+ P_1451 :: Ton mode -> SDom mode -> Dom mode -> Ton mode -> Phrase mode
+ P_151 :: Ton mode -> Dom mode -> Ton mode -> Phrase mode
+ P_51 :: Dom mode -> Ton mode -> Phrase mode
+ P_15 :: Ton mode -> Dom mode -> Phrase mode
+ P_1 :: Ton mode -> Phrase mode
+
+-- Harmonic categories
+-- Tonic
+data Ton (mode :: Mode) where
+ -- major mode
+ T_1 :: SD MajMode I MajClass -> Ton MajMode
+
+ -- minor mode
+ Tm_1 :: SD MinMode I MinClass -> Ton MinMode
+
+-- Dominant
+data Dom (mode :: Mode) where
+ -- major mode
+ D_2 :: SD mode V DomClass -> Dom mode
+ -- JPM: I don't fully understand why, but D_1 cannot be the first constructor,
+ -- else the generator loops...
+ D_1 :: SDom mode -> Dom mode -> Dom mode
+ D_3 :: SD mode V MajClass -> Dom mode
+ D_4 :: SD MajMode VII DimClass -> Dom MajMode
+ -- hard-coded V/V
+ D_5 :: SD mode II DomClass -> SD mode V DomClass -> Dom mode
+
+ -- 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 VII DimClass -> Dom MinMode
+
+-- Subdominant
+data SDom (mode :: Mode) where
+ S_1 :: SD MajMode IV MajClass -> SDom MajMode
+ S_2 :: SD mode II MinClass -> SDom mode -- dubious for MinMode
+ S_3 :: SD MajMode III MinClass -> SD MajMode IV MajClass -> SDom MajMode
+
+ Sm_1 :: SD MinMode IV MinClass -> SDom MinMode
+
+
+-- Limit secondary dominants to a few levels
+-- type SD mode deg clss = Base_SD deg clss NUMLEVELS
+type SD (mode :: Mode) (deg :: DiatonicDegree) (clss :: ClassType) = Surface_Chord deg clss
+
+data Surface_Chord (deg :: DiatonicDegree) (clss :: ClassType) where
+ Surface_Chord :: ChordToken -> Surface_Chord deg clss
+
+{-
+-- 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
+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 :: ClassType) where
+ toClass :: Proxy 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 NoClass where toClass _ = error "toClass NoClass"
+
+class ToDegree (deg :: DiatonicDegree) where
+ toDegree :: Proxy 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
+
+-- 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 ]
diff --git a/src/HarmTrace/Play.hs b/src/HarmTrace/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Play.hs
@@ -0,0 +1,117 @@
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Play
+-- 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: Play stuff. Interfaces with Haskore.
+--------------------------------------------------------------------------------
+
+module HarmTrace.Play where
+
+import HarmTrace.Base.MusicRep
+import HarmTrace.Song
+
+import qualified Haskore.Composition.Chord as C
+import qualified Haskore.Music as H
+import qualified Haskore.Basic.Pitch as H
+import qualified Haskore.Basic.Duration as H
+import qualified Haskore.Basic.Interval as H
+import Haskore.Melody.Standard as Melody
+import qualified Haskore.Music.GeneralMIDI as MIDI
+import Haskore.Interface.MIDI.Render ( generalMidiDeflt, playTimidityJack )
+
+import Sound.MIDI.File.Save ( toFile )
+
+import Data.List ( genericLength )
+import System.Exit ( ExitCode )
+
+songToChords :: Song -> Melody.T
+songToChords (Song _ l) = H.line $ map clToHChord (map fst l)
+
+clToHChord :: ChordLabel -> Melody.T
+clToHChord cl =
+ let pitch (Note (Just Fl) A) = H.Af
+ pitch (Note Nothing A) = H.A
+ pitch (Note (Just Sh) A) = H.As
+ pitch (Note (Just Fl) B) = H.Bf
+ pitch (Note Nothing B) = H.B
+ pitch (Note (Just Sh) B) = H.Bs
+ pitch (Note (Just Fl) C) = H.Cf
+ pitch (Note Nothing C) = H.C
+ pitch (Note (Just Sh) C) = H.Cs
+ pitch (Note (Just Fl) D) = H.Df
+ pitch (Note Nothing D) = H.D
+ pitch (Note (Just Sh) D) = H.Ds
+ pitch (Note (Just Fl) E) = H.Ef
+ pitch (Note Nothing E) = H.E
+ pitch (Note (Just Sh) E) = H.Es
+ pitch (Note (Just Fl) F) = H.Ff
+ pitch (Note Nothing F) = H.F
+ pitch (Note (Just Sh) F) = H.Fs
+ pitch (Note (Just Fl) G) = H.Gf
+ pitch (Note Nothing G) = H.G
+ pitch (Note (Just Sh) G) = H.Gs
+ pitch x = error $ "pitch: " ++ show x
+
+ clss Maj = C.majorInt
+ clss Min = C.minorInt
+ clss Sev = C.dominantSeventhInt
+ clss Dim = [H.unison, H.minorThird, 6]
+ clss x = error $ "clss: " ++ show x
+
+ dur = H.qn
+ attr = na
+
+ gc = C.generic (pitch (chordRoot cl)) (clss (chordShorthand cl)) dur attr
+ in H.chord $ C.genericToNotes 0 gc
+
+songToMelody :: Song -> Melody.T
+songToMelody (Song _ l) =
+ let mel :: [[MelodyNote]]
+ mel = map snd l
+ in H.line $
+ map (\ns -> H.line $
+ map (H.changeTempo (genericLength ns H.%+ 1) . mnToHNote) ns) mel
+
+mnToHNote :: MelodyNote -> Melody.T
+mnToHNote (MelodyNote (Note (Just Fl) A) o) = Melody.af o H.qn na
+mnToHNote (MelodyNote (Note Nothing A) o) = Melody.a o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) A) o) = Melody.as o H.qn na
+mnToHNote (MelodyNote (Note (Just Fl) B) o) = Melody.bf o H.qn na
+mnToHNote (MelodyNote (Note Nothing B) o) = Melody.b o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) B) o) = Melody.bs o H.qn na
+mnToHNote (MelodyNote (Note (Just Fl) C) o) = Melody.cf o H.qn na
+mnToHNote (MelodyNote (Note Nothing C) o) = Melody.c o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) C) o) = Melody.cs o H.qn na
+mnToHNote (MelodyNote (Note (Just Fl) D) o) = Melody.df o H.qn na
+mnToHNote (MelodyNote (Note Nothing D) o) = Melody.d o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) D) o) = Melody.ds o H.qn na
+mnToHNote (MelodyNote (Note (Just Fl) E) o) = Melody.ef o H.qn na
+mnToHNote (MelodyNote (Note Nothing E) o) = Melody.e o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) E) o) = Melody.es o H.qn na
+mnToHNote (MelodyNote (Note (Just Fl) F) o) = Melody.ff o H.qn na
+mnToHNote (MelodyNote (Note Nothing F) o) = Melody.f o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) F) o) = Melody.fs o H.qn na
+mnToHNote (MelodyNote (Note (Just Fl) G) o) = Melody.gf o H.qn na
+mnToHNote (MelodyNote (Note Nothing G) o) = Melody.g o H.qn na
+mnToHNote (MelodyNote (Note (Just Sh) G) o) = Melody.gs o H.qn na
+mnToHNote x = error $ "mnToHNote: " ++ show x
+
+songToMIDI :: Song -> MIDI.T
+songToMIDI s =
+ let melody = songToMelody s
+ chords = songToChords s
+ in MIDI.fromStdMelody MIDI.Flute melody
+ H.=:= MIDI.fromStdMelody MIDI.AcousticGrandPiano chords
+
+writeMIDI :: FilePath -> MIDI.T -> IO ()
+writeMIDI fp = toFile fp . generalMidiDeflt
+
+playMIDI :: MIDI.T -> IO ExitCode
+playMIDI = playTimidityJack
diff --git a/src/HarmTrace/Song.hs b/src/HarmTrace/Song.hs
new file mode 100644
--- /dev/null
+++ b/src/HarmTrace/Song.hs
@@ -0,0 +1,64 @@
+
+--------------------------------------------------------------------------------
+-- |
+-- Module : HarmTrace.Song
+-- 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 song combines a melody with chords
+--------------------------------------------------------------------------------
+
+module HarmTrace.Song where
+
+import HarmTrace.Base.MusicRep
+import Data.List ( elemIndex )
+
+-- Each chord can have multiple melody notes
+data Song = Song Key [(ChordLabel, [MelodyNote])] deriving Show
+
+data Melody = Melody Key [MelodyNote] deriving Show
+data MelodyNote = MelodyNote { mnRoot :: Root
+ , mnOctave :: Octave } deriving Eq
+type Octave = Int
+
+instance Show MelodyNote where
+ show (MelodyNote r o) = show r ++ show o
+
+octaveDown, octaveUp :: MelodyNote -> MelodyNote
+octaveDown (MelodyNote r n) = MelodyNote r (n - 1)
+octaveUp (MelodyNote r n) = MelodyNote r (n + 1)
+
+instance Ord MelodyNote where
+ compare (MelodyNote r1 o1) (MelodyNote r2 o2)
+ = if compare o1 o2 == EQ
+ then compareRoot r1 r2
+ else compare o1 o2
+
+compareRoot :: Root -> Root -> Ordering
+compareRoot n1 n2
+ = case (elemIndex n1 roots, elemIndex n2 roots) of
+ (Just i1, Just i2) -> compare i1 i2
+ _ -> compare n1 n2 -- probably wrong
+
+allMelodyNotes :: [MelodyNote]
+allMelodyNotes = [ MelodyNote r o | o <- [2..4], r <- roots ]
+
+-- from harmtrace-base
+roots :: [ Root ]
+roots = [ Note Nothing C
+ , Note (Just Sh) C
+ , 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
+ ]
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DataKinds #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- 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: The main module, just for testing
+--------------------------------------------------------------------------------
+
+module Main where
+
+-- Music stuff
+import HarmTrace.Models.Generator
+import HarmTrace.Models.Simple.Main
+import HarmTrace.Accompany
+import HarmTrace.Play
+import HarmTrace.Base.MusicRep
+
+import Test.QuickCheck ( sample' )
+import Data.Maybe ( fromJust )
+import Data.Time.Clock ( getCurrentTime )
+
+--------------------------------------------------------------------------------
+-- Temporary testing code for harmony generation
+--------------------------------------------------------------------------------
+
+{-
+Generating goes as follows:
+1) Generate the harmony
+2) From there, generate the melody:
+ 2.1) Generate candidate melody notes from chords
+ 2.2) Trim these to remove bad candidates
+ 2.3) Pick one
+ 2.4) Embellish it
+3) Combine the two, output
+-}
+
+testGen :: Gen Piece
+testGen = fmap Piece gen
+ where gen = fromJust (genGdefault ft undefined) :: Gen [Phrase MajMode]
+ ft = [("P_1", 0)
+ ,("P_15", 0)
+ ,("P_1451", 2)
+ ,("D_1", 2)
+ ,("D_5", 3)
+ ,(":", 3)
+ ,("S_3", 3)]
+
+main :: IO ()
+main = let k = Key (Note Nothing C) MajMode
+ perform p = do so <- accompanyIO k p
+ t <- getCurrentTime
+ let fn = filter (/= ':') (show t) ++ ".mid"
+ print so
+ writeMIDI fn (songToMIDI so)
+ playMIDI (songToMIDI so)
+ in sample' testGen >>= mapM_ perform