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/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#! /usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/Test/Data/EventList/Absolute/BodyEnd.hs b/Test/Data/EventList/Absolute/BodyEnd.hs
new file mode 100644
--- /dev/null
+++ b/Test/Data/EventList/Absolute/BodyEnd.hs
@@ -0,0 +1,325 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Test.Data.EventList.Absolute.BodyEnd (tests) where
+
+import Test.Utility
+import Test.QuickCheck (test)
+
+import qualified Data.EventList.Absolute.TimeBody as AbsBody
+import qualified Data.EventList.Absolute.TimeBodyPrivate as AbsBodyPriv
+import qualified Data.EventList.Relative.TimeBody as RelBody
+import qualified Data.AlternatingList.List.Disparate as Disp
+
+-- for testing in GHCi
+-- import Data.AlternatingList.List.Disparate (empty)
+-- import Data.AlternatingList.List.Uniform ((/.), (./))
+import qualified Data.Char as Char
+
+import System.Random (Random, randomR, mkStdGen)
+import Control.Monad (liftM)
+
+import qualified Data.EventList.Utility as Utility
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Data.EventList.Utility (mapFst, mapSnd, mapPair)
+import qualified Control.Monad as Monad
+import Control.Monad.State (State(State), evalState)
+
+import Prelude hiding (filter, concat)
+
+
+infixl 5 $~
+
+($~) :: Num time =>
+ (AbsBody.T time body -> a) -> (RelBody.T time body -> a)
+($~) f = f . RelBody.toAbsoluteEventList 0
+
+infixl 4 ==~
+
+(==~) :: (Eq body, Num time) =>
+ AbsBody.T time body -> RelBody.T time body -> Bool
+(==~) xs ys =
+ xs == RelBody.toAbsoluteEventList 0 ys
+
+
+
+duration :: Num time => RelBody.T time body -> Bool
+duration xs =
+ AbsBody.duration $~ xs == RelBody.duration xs
+
+
+mapBody :: (Eq body1, Num time) =>
+ (body0 -> body1) -> RelBody.T time body0 -> Bool
+mapBody f xs =
+ AbsBody.mapBody f $~ xs ==~ RelBody.mapBody f xs
+
+
+
+mapBodyM ::
+ (Monad m, Eq body1, NonNeg.C time) =>
+ (m (AbsBody.T time body1) -> AbsBody.T time body1) ->
+ (body0 -> m body1) -> RelBody.T time body0 -> Bool
+mapBodyM run f xs =
+ run (AbsBody.mapBodyM f $~ xs) ==
+ run (liftM (RelBody.toAbsoluteEventList 0) (RelBody.mapBodyM f xs))
+
+mapBodyMRandom ::
+ (NonNeg.C time, Random body, Eq body) =>
+ Int -> RelBody.T time (body, body) -> Bool
+mapBodyMRandom seed =
+ mapBodyM
+ (flip evalState (mkStdGen seed))
+ (State . randomR)
+
+
+filter :: (Eq body, Num time) =>
+ (body -> Bool) -> RelBody.T time body -> Bool
+filter p xs =
+ AbsBody.filter p $~ xs ==~ RelBody.filter p xs
+
+{-
+mapMaybe :: (Num time) =>
+ (body0 -> Maybe body1) ->
+ RelBody.T time body0 -> RelBody.T time body1
+mapMaybe f = catMaybes . mapBody f
+-}
+
+catMaybes :: (Eq body, Num time) =>
+ RelBody.T time (Maybe body) -> Bool
+catMaybes xs =
+ AbsBody.catMaybes $~ xs ==~ RelBody.catMaybes xs
+
+{-
+Could be implemented more easily in terms of Uniform.partition
+-}
+partition :: (Eq body, Num time) =>
+ (body -> Bool) -> RelBody.T time body -> Bool
+partition p xs =
+ AbsBody.partition p $~ xs ==
+-- mapPair (RelBody.toAbsoluteEventList 0, RelBody.toAbsoluteEventList 0)
+ (uncurry $ \ys zs -> (,) $~ ys $~ zs)
+ (RelBody.partition p xs)
+
+{- |
+Since we need it later for MIDI generation,
+we will also define a slicing into equivalence classes of events.
+-}
+slice :: (Eq a, Eq body, Num time) =>
+ (body -> a) -> RelBody.T time body -> Bool
+slice f xs =
+ AbsBody.slice f $~ xs ==
+ map (mapSnd (RelBody.toAbsoluteEventList 0)) (RelBody.slice f xs)
+
+
+collectCoincident :: (NonNeg.C time, Eq body) =>
+ RelBody.T time body -> Bool
+collectCoincident xs =
+ AbsBody.collectCoincident $~ xs ==~
+ RelBody.collectCoincident xs
+
+collectCoincidentFoldr :: (NonNeg.C time, Eq body) =>
+ RelBody.T time body -> Bool
+collectCoincidentFoldr xs =
+ AbsBody.collectCoincident $~ xs ==
+ AbsBody.collectCoincidentFoldr $~ xs
+
+collectCoincidentNonLazy :: (NonNeg.C time, Eq body) =>
+ RelBody.T time body -> Bool
+collectCoincidentNonLazy xs =
+ AbsBody.collectCoincident $~ xs ==
+ AbsBody.collectCoincidentNonLazy $~ xs
+
+collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+collectCoincidentInfinite =
+ checkInfinite .
+ AbsBody.collectCoincident .
+ makeUncollapsedInfiniteEventList
+
+
+flatten :: (NonNeg.C time, Eq body) =>
+ RelBody.T time [body] -> Bool
+flatten xs =
+ AbsBody.flatten $~ xs ==~ RelBody.flatten xs
+
+
+normalize :: (NonNeg.C time, Ord body) =>
+ RelBody.T time body -> Bool
+normalize xs =
+ AbsBody.normalize $~ xs ==~ RelBody.normalize xs
+
+
+merge :: (NonNeg.C time, Ord body) =>
+ RelBody.T time body -> RelBody.T time body -> Bool
+merge xs ys =
+ AbsBody.merge $~ xs $~ ys ==~ RelBody.merge xs ys
+
+
+insert :: (NonNeg.C time, Ord body) =>
+ time -> body -> RelBody.T time body -> Bool
+insert t b xs =
+ AbsBody.insert t b $~ xs ==~ RelBody.insert t b xs
+
+
+
+append :: (NonNeg.C time, Eq body) =>
+ RelBody.T time body -> RelBody.T time body -> Bool
+append xs ys =
+ AbsBody.append $~ xs $~ ys ==~
+ RelBody.append xs ys
+
+concat :: (NonNeg.C time, Eq body) =>
+ [RelBody.T time body] -> Bool
+concat xs =
+ AbsBody.concat (map (RelBody.toAbsoluteEventList 0) xs) ==~
+ RelBody.concat xs
+
+
+{-
+cycle :: (NonNeg.C time) =>
+ RelBody.T time body -> RelBody.T time body
+cycle = concat . List.repeat
+-}
+
+
+decreaseStart :: (NonNeg.C time, Eq body) =>
+ time -> time -> RelBody.T time body -> Bool
+decreaseStart dif0 dif1 xs0 =
+ let difA = min dif0 dif1
+ difB = max dif0 dif1
+ xs = RelBody.delay difB xs0
+ in AbsBody.decreaseStart difA $~ xs ==~
+ RelBody.decreaseStart difA xs
+
+
+delay :: (NonNeg.C time, Eq body) =>
+ time -> RelBody.T time body -> Bool
+delay dif xs =
+ AbsBody.delay dif $~ xs ==~
+ RelBody.delay dif xs
+
+
+
+{-
+resample :: (Integral time, Eq body) =>
+ time -> RelBody.T (time, time) body -> Bool
+resample rateInt xs0 =
+ let xs = RelBody.mapTime (\(n,d) -> n % (d+1)) xs0
+ rate = rateInt % 1
+ in AbsBody.resample rate $~ xs ==~
+ (RelBody.resample rate xs `asTypeOf`
+ AbsBody.singleton (undefined::Int) undefined)
+-}
+
+resample :: (Eq body) =>
+ TimeDiff -> RelBody.T (TimeDiff, TimeDiff) body -> Bool
+resample rateInt xs0 =
+ let {-
+ I add a small amount to the numerator in order
+ to prevent the case of a fraction like 10.5,
+ which can be easily rounded to 10 or 11
+ depending to previous rounding errors.
+ -}
+ xs = RelBody.mapTime ((1e-6 +) . makeFracTime) xs0
+ rate = timeToDouble rateInt + 1
+ in AbsBody.resample rate $~ xs ==~
+ (RelBody.resample rate xs `asTypeOf`
+ RelBody.singleton (undefined::TimeDiff) undefined)
+
+resampleInfinite :: (Eq body) =>
+ TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool
+resampleInfinite rateInt =
+ let rate = timeToDouble rateInt + 1
+ in checkInfinite .
+ (`asTypeOf` AbsBody.singleton (undefined::TimeDiff) undefined) .
+ AbsBody.resample rate .
+ makeInfiniteEventList .
+ mapPair (mapFst makeFracTime, RelBody.mapTime makeFracTime)
+
+
+
+
+type NonEmptyList time body = ((time, body), RelBody.T time body)
+
+makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> AbsBody.T time body
+makeUncollapsedInfiniteEventList =
+ makeInfiniteEventList .
+ mapFst (mapFst (1+))
+
+makeInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> AbsBody.T time body
+makeInfiniteEventList =
+ RelBody.toAbsoluteEventList 0 . RelBody.cycle . makeNonEmptyEventList
+
+makeNonEmptyEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> RelBody.T time body
+makeNonEmptyEventList (p, evs) =
+ uncurry RelBody.cons p evs
+
+{- |
+Pick an arbitrary element from an infinite list
+and check if it can be evaluated.
+-}
+checkInfinite :: (Eq time, Eq body) =>
+ AbsBody.T time body -> Bool
+checkInfinite xs0 =
+ let x = maybe
+ (error "BodyEnd.checkInfinite: empty list") fst $
+ AbsBody.viewL $ AbsBodyPriv.lift (Disp.drop 100) xs0
+ in x == x
+
+
+
+
+
+tests :: [(String, IO ())]
+tests =
+ ("duration",
+ test (duration :: RelBody.T TimeDiff Char -> Bool)) :
+ ("mapBody",
+ test (mapBody Char.toUpper :: RelBody.T TimeDiff Char -> Bool)) :
+ ("mapBodyM",
+ test (mapBodyMRandom :: Int -> RelBody.T TimeDiff (Char, Char) -> Bool)) :
+ ("filter",
+ test (\c -> filter (c<) :: RelBody.T TimeDiff Char -> Bool)) :
+ ("catMaybes",
+ test (catMaybes :: RelBody.T TimeDiff (Maybe Char) -> Bool)) :
+ ("partition",
+ test (\c -> partition (c<) :: RelBody.T TimeDiff Char -> Bool)) :
+ ("slice",
+ test (slice fst :: RelBody.T TimeDiff (Char,Char) -> Bool)) :
+ ("collectCoincident",
+ test (collectCoincident :: RelBody.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentFoldr",
+ test (collectCoincidentFoldr :: RelBody.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentNonLazy",
+ test (collectCoincidentNonLazy :: RelBody.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentInfinite",
+ test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("flatten",
+ test (flatten :: RelBody.T TimeDiff [Char] -> Bool)) :
+ ("normalize",
+ test (normalize :: RelBody.T TimeDiff Char -> Bool)) :
+ ("merge",
+ test (merge :: RelBody.T TimeDiff Char -> RelBody.T TimeDiff Char -> Bool)) :
+ ("insert",
+ test (insert :: TimeDiff -> Char -> RelBody.T TimeDiff Char -> Bool)) :
+ ("append",
+ test (append :: RelBody.T TimeDiff Char -> RelBody.T TimeDiff Char -> Bool)) :
+ ("concat",
+ test (concat :: [RelBody.T TimeDiff Char] -> Bool)) :
+ ("decreaseStart",
+ test (decreaseStart :: TimeDiff -> TimeDiff -> RelBody.T TimeDiff Char -> Bool)) :
+ ("delay",
+ test (delay :: TimeDiff -> RelBody.T TimeDiff Char -> Bool)) :
+ ("resample",
+ test (resample :: TimeDiff -> RelBody.T (TimeDiff, TimeDiff) Char -> Bool)) :
+ ("resampleInfinite",
+ test (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) Char -> Bool)) :
+ []
diff --git a/Test/Data/EventList/Absolute/TimeEnd.hs b/Test/Data/EventList/Absolute/TimeEnd.hs
new file mode 100644
--- /dev/null
+++ b/Test/Data/EventList/Absolute/TimeEnd.hs
@@ -0,0 +1,298 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Test.Data.EventList.Absolute.TimeEnd (tests) where
+
+import Test.Utility
+import Test.QuickCheck (test)
+
+import qualified Data.EventList.Absolute.TimeTime as AbsTime
+import qualified Data.EventList.Absolute.TimeTimePrivate as AbsTimePriv
+import qualified Data.EventList.Relative.TimeTime as RelTime
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+-- for testing in GHCi
+-- import Data.AlternatingList.List.Disparate (empty)
+-- import Data.AlternatingList.List.Uniform ((/.), (./))
+import qualified Data.Char as Char
+
+import System.Random (Random, randomR, mkStdGen)
+import Control.Monad (liftM)
+
+import qualified Data.EventList.Utility as Utility
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Data.EventList.Utility (mapFst, mapSnd, mapPair)
+import qualified Control.Monad as Monad
+import Control.Monad.State (State(State), evalState)
+
+import Prelude hiding (filter, concat)
+
+
+infixl 5 $~
+
+($~) :: Num time =>
+ (AbsTime.T time body -> a) -> (RelTime.T time body -> a)
+($~) f = f . RelTime.toAbsoluteEventList 0
+
+infixl 4 ==~
+
+(==~) :: (Eq body, Num time) =>
+ AbsTime.T time body -> RelTime.T time body -> Bool
+(==~) xs ys =
+ xs == RelTime.toAbsoluteEventList 0 ys
+
+
+
+duration :: Num time => RelTime.T time body -> Bool
+duration xs =
+ AbsTime.duration $~ xs == RelTime.duration xs
+
+
+mapBody :: (Eq body1, Num time) =>
+ (body0 -> body1) -> RelTime.T time body0 -> Bool
+mapBody f xs =
+ AbsTime.mapBody f $~ xs ==~ RelTime.mapBody f xs
+
+
+
+mapBodyM ::
+ (Monad m, Eq body1, NonNeg.C time) =>
+ (m (AbsTime.T time body1) -> AbsTime.T time body1) ->
+ (body0 -> m body1) -> RelTime.T time body0 -> Bool
+mapBodyM run f xs =
+ run (AbsTime.mapBodyM f $~ xs) ==
+ run (liftM (RelTime.toAbsoluteEventList 0) (RelTime.mapBodyM f xs))
+
+mapBodyMRandom ::
+ (NonNeg.C time, Random body, Eq body) =>
+ Int -> RelTime.T time (body, body) -> Bool
+mapBodyMRandom seed =
+ mapBodyM
+ (flip evalState (mkStdGen seed))
+ (State . randomR)
+
+
+filter :: (Eq body, Num time) =>
+ (body -> Bool) -> RelTime.T time body -> Bool
+filter p xs =
+ AbsTime.filter p $~ xs ==~ RelTime.filter p xs
+
+{-
+mapMaybe :: (Num time) =>
+ (body0 -> Maybe body1) ->
+ RelTime.T time body0 -> RelTime.T time body1
+mapMaybe f = catMaybes . mapBody f
+-}
+
+catMaybes :: (Eq body, Num time) =>
+ RelTime.T time (Maybe body) -> Bool
+catMaybes xs =
+ AbsTime.catMaybes $~ xs ==~ RelTime.catMaybes xs
+
+{-
+Could be implemented more easily in terms of Uniform.partition
+-}
+partition :: (Eq body, Num time) =>
+ (body -> Bool) -> RelTime.T time body -> Bool
+partition p xs =
+ AbsTime.partition p $~ xs ==
+-- mapPair (RelTime.toAbsoluteEventList 0, RelTime.toAbsoluteEventList 0)
+ (uncurry $ \ys zs -> (,) $~ ys $~ zs)
+ (RelTime.partition p xs)
+
+{- |
+Since we need it later for MIDI generation,
+we will also define a slicing into equivalence classes of events.
+-}
+slice :: (Eq a, Eq body, Num time) =>
+ (body -> a) -> RelTime.T time body -> Bool
+slice f xs =
+ AbsTime.slice f $~ xs ==
+ map (mapSnd (RelTime.toAbsoluteEventList 0)) (RelTime.slice f xs)
+
+
+collectCoincident :: (NonNeg.C time, Eq body) =>
+ RelTime.T time body -> Bool
+collectCoincident xs =
+ AbsTime.collectCoincident $~ xs ==~
+ RelTime.collectCoincident xs
+
+collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+collectCoincidentInfinite =
+ checkInfinite .
+ AbsTime.collectCoincident .
+ makeUncollapsedInfiniteEventList
+
+
+flatten :: (NonNeg.C time, Eq body) =>
+ RelTime.T time [body] -> Bool
+flatten xs =
+ AbsTime.flatten $~ xs ==~ RelTime.flatten xs
+
+
+normalize :: (NonNeg.C time, Ord body) =>
+ RelTime.T time body -> Bool
+normalize xs =
+ AbsTime.normalize $~ xs ==~ RelTime.normalize xs
+
+
+merge :: (NonNeg.C time, Ord body) =>
+ RelTime.T time body -> RelTime.T time body -> Bool
+merge xs ys =
+ AbsTime.merge $~ xs $~ ys ==~ RelTime.merge xs ys
+
+
+insert :: (NonNeg.C time, Ord body) =>
+ time -> body -> RelTime.T time body -> Bool
+insert t b xs =
+ AbsTime.insert t b $~ xs ==~ RelTime.insert t b xs
+
+
+
+append :: (NonNeg.C time, Eq body) =>
+ RelTime.T time body -> RelTime.T time body -> Bool
+append xs ys =
+ AbsTime.append $~ xs $~ ys ==~
+ RelTime.append xs ys
+
+concat :: (NonNeg.C time, Eq body) =>
+ [RelTime.T time body] -> Bool
+concat xs =
+ AbsTime.concat (map (RelTime.toAbsoluteEventList 0) xs) ==~
+ RelTime.concat xs
+
+
+{-
+cycle :: (NonNeg.C time) =>
+ RelTime.T time body -> RelTime.T time body
+cycle = concat . List.repeat
+-}
+
+
+decreaseStart :: (NonNeg.C time, Eq body) =>
+ time -> time -> RelTime.T time body -> Bool
+decreaseStart dif0 dif1 xs0 =
+ let difA = min dif0 dif1
+ difB = max dif0 dif1
+ xs = RelTime.delay difB xs0
+ in AbsTime.decreaseStart difA $~ xs ==~
+ RelTime.decreaseStart difA xs
+
+
+delay :: (NonNeg.C time, Eq body) =>
+ time -> RelTime.T time body -> Bool
+delay dif xs =
+ AbsTime.delay dif $~ xs ==~
+ RelTime.delay dif xs
+
+
+
+resample :: (Eq body) =>
+ TimeDiff -> RelTime.T (TimeDiff, TimeDiff) body -> Bool
+resample rateInt xs0 =
+ let {-
+ I add a small amount to the numerator in order
+ to prevent the case of a fraction like 10.5,
+ which can be easily rounded to 10 or 11
+ depending to previous rounding errors.
+ -}
+ xs = RelTime.mapTime ((1e-6 +) . makeFracTime) xs0
+ rate = timeToDouble rateInt + 1
+ in AbsTime.resample rate $~ xs ==~
+ (RelTime.resample rate xs `asTypeOf`
+ RelTime.pause (undefined::TimeDiff))
+
+resampleInfinite :: (Eq body) =>
+ TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) body -> Bool
+resampleInfinite rateInt =
+ let rate = timeToDouble rateInt + 1
+ in checkInfinite .
+ (`asTypeOf` AbsTime.pause (undefined::TimeDiff)) .
+ AbsTime.resample rate .
+ makeInfiniteEventList .
+ mapPair (mapFst makeFracTime, RelTime.mapTime makeFracTime)
+
+
+
+type NonEmptyList time body = ((time, body), RelTime.T time body)
+
+makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> AbsTime.T time body
+makeUncollapsedInfiniteEventList =
+ makeInfiniteEventList .
+ mapFst (mapFst (1+))
+
+makeInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> AbsTime.T time body
+makeInfiniteEventList =
+ RelTime.toAbsoluteEventList 0 . RelTime.cycle . makeNonEmptyEventList
+
+makeNonEmptyEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> RelTime.T time body
+makeNonEmptyEventList (p, evs) =
+ uncurry RelTime.cons p evs
+
+{- |
+Pick an arbitrary element from an infinite list
+and check if it can be evaluated.
+-}
+checkInfinite :: (Eq time, Eq body) =>
+ AbsTime.T time body -> Bool
+checkInfinite xs0 =
+ let (x,xs) = AbsTime.viewL (AbsTimePriv.lift (Mixed.dropUniform 100) xs0)
+ y = maybe
+ (error "checkInfinite: finite list")
+ fst
+ xs
+ in x == x && y == y
+
+
+
+
+tests :: [(String, IO ())]
+tests =
+ ("duration",
+ test (duration :: RelTime.T TimeDiff Char -> Bool)) :
+ ("mapBody",
+ test (mapBody Char.toUpper :: RelTime.T TimeDiff Char -> Bool)) :
+ ("mapBodyM",
+ test (mapBodyMRandom :: Int -> RelTime.T TimeDiff (Char, Char) -> Bool)) :
+ ("filter",
+ test (\c -> filter (c<) :: RelTime.T TimeDiff Char -> Bool)) :
+ ("catMaybes",
+ test (catMaybes :: RelTime.T TimeDiff (Maybe Char) -> Bool)) :
+ ("partition",
+ test (\c -> partition (c<) :: RelTime.T TimeDiff Char -> Bool)) :
+ ("slice",
+ test (slice fst :: RelTime.T TimeDiff (Char,Char) -> Bool)) :
+ ("collectCoincident",
+ test (collectCoincident :: RelTime.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentInfinite",
+ test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("flatten",
+ test (flatten :: RelTime.T TimeDiff [Char] -> Bool)) :
+ ("normalize",
+ test (normalize :: RelTime.T TimeDiff Char -> Bool)) :
+ ("merge",
+ test (merge :: RelTime.T TimeDiff Char -> RelTime.T TimeDiff Char -> Bool)) :
+ ("insert",
+ test (insert :: TimeDiff -> Char -> RelTime.T TimeDiff Char -> Bool)) :
+ ("append",
+ test (append :: RelTime.T TimeDiff Char -> RelTime.T TimeDiff Char -> Bool)) :
+ ("concat",
+ test (concat :: [RelTime.T TimeDiff Char] -> Bool)) :
+ ("decreaseStart",
+ test (decreaseStart :: TimeDiff -> TimeDiff -> RelTime.T TimeDiff Char -> Bool)) :
+ ("delay",
+ test (delay :: TimeDiff -> RelTime.T TimeDiff Char -> Bool)) :
+ ("resample",
+ test (resample :: TimeDiff -> RelTime.T (TimeDiff, TimeDiff) Char -> Bool)) :
+ ("resampleInfinite",
+ test (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) Char -> Bool)) :
+ []
diff --git a/Test/Data/EventList/Relative/BodyEnd.hs b/Test/Data/EventList/Relative/BodyEnd.hs
new file mode 100644
--- /dev/null
+++ b/Test/Data/EventList/Relative/BodyEnd.hs
@@ -0,0 +1,907 @@
+module Test.Data.EventList.Relative.BodyEnd (tests) where
+
+import Test.Utility
+import Test.QuickCheck (test)
+
+import qualified Data.EventList.Relative.TimeBody as TimeBodyList
+import qualified Data.EventList.Relative.TimeTime as TimeTimeList
+import qualified Data.EventList.Relative.TimeMixed as TimeMixedList
+import qualified Data.EventList.Relative.MixedBody as MixedBodyList
+import qualified Data.EventList.Relative.BodyBody as BodyBodyList
+import qualified Data.AlternatingList.List.Disparate as Disp
+
+import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyPriv
+
+import Data.EventList.Relative.MixedBody ((/.), (./), empty)
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Numeric.NonNegative.Class ((-|))
+import Data.EventList.Relative.TimeBody (isNormalized)
+
+import Data.EventList.Utility (mapPair)
+import System.Random (Random, randomR, mkStdGen)
+import Control.Monad.State (State(State), evalState)
+import Control.Monad (liftM2)
+import Data.Maybe (isJust)
+import qualified Data.List as List
+import qualified Data.Char as Char
+
+
+
+viewLConsTime :: (Eq body, Eq time) =>
+ TimeBodyList.T time body -> Bool
+viewLConsTime xs =
+ xs == maybe TimeBodyList.empty (uncurry MixedBodyList.consTime) (MixedBodyList.viewTimeL xs)
+
+viewLConsBody :: (Eq body, Eq time) =>
+ BodyBodyList.T time body -> Bool
+viewLConsBody xs =
+ xs == uncurry MixedBodyList.consBody (MixedBodyList.viewBodyL xs)
+
+
+
+viewLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool
+viewLInfinite =
+ checkInfinite .
+ maybe (error "viewBodyL: empty list") snd .
+ TimeBodyList.viewL .
+ makeInfiniteEventList
+
+
+consInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+consInfinite time body =
+ checkInfinite .
+ TimeBodyList.cons time body .
+ makeInfiniteEventList
+
+consTimeBodyInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+consTimeBodyInfinite time body =
+ checkInfinite .
+ MixedBodyList.consTime time .
+ MixedBodyList.consBody body .
+ makeInfiniteEventList
+
+
+snocInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+snocInfinite time body =
+ checkInfinite .
+ flip (flip TimeBodyList.snoc time) body .
+ makeInfiniteEventList
+
+
+consInfix :: (NonNeg.C time, Eq body) =>
+ time -> body -> time -> body -> Bool
+consInfix t0 b0 t1 b1 =
+ TimeBodyList.append (t0 /. b0 ./ empty) (t1 /. b1 ./ empty)
+ == (t0 /. b0 ./ t1 /. b1 ./ empty)
+
+
+mapBodyComposition :: (Eq body2, Eq time) =>
+ (body0 -> body1) -> (body1 -> body2) -> TimeBodyList.T time body0 -> Bool
+mapBodyComposition f g evs =
+ TimeBodyList.mapBody (g . f) evs ==
+ TimeBodyList.mapBody g (TimeBodyList.mapBody f evs)
+
+mapTimeComposition :: (Eq body, Eq time2) =>
+ (time0 -> time1) -> (time1 -> time2) -> TimeBodyList.T time0 body -> Bool
+mapTimeComposition f g evs =
+ TimeBodyList.mapTime (g . f) evs ==
+ TimeBodyList.mapTime g (TimeBodyList.mapTime f evs)
+
+
+mapTimeBodyCommutative :: (Eq body1, Eq time1) =>
+ (time0 -> time1) -> (body0 -> body1) -> TimeBodyList.T time0 body0 -> Bool
+mapTimeBodyCommutative f g evs =
+ TimeBodyList.mapBody g (TimeBodyList.mapTime f evs) ==
+ TimeBodyList.mapTime f (TimeBodyList.mapBody g evs)
+
+
+
+mapBodyInfinite :: (NonNeg.C time, Eq body1) =>
+ (body0 -> body1) -> NonEmptyList time body0 -> Bool
+mapBodyInfinite f =
+ checkInfinite . TimeBodyList.mapBody f . makeInfiniteEventList
+
+mapTimeInfinite :: (NonNeg.C time0, Eq time1, Eq body) =>
+ (time0 -> time1) -> NonEmptyList time0 body -> Bool
+mapTimeInfinite f =
+ checkInfinite . TimeBodyList.mapTime f . makeInfiniteEventList
+
+
+
+{- |
+Does only hold for monotonic functions.
+-}
+mapNormalize :: (NonNeg.C time, Ord body0, Ord body1) =>
+ (body0 -> body1) -> TimeBodyList.T time body0 -> Bool
+mapNormalize f =
+ isNormalized . TimeBodyList.mapBody f . TimeBodyList.normalize
+
+
+
+appendLeftIdentity :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+appendLeftIdentity xs =
+ TimeBodyList.append TimeBodyList.empty xs == xs
+
+appendRightIdentity :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+appendRightIdentity xs =
+ TimeBodyList.append xs TimeBodyList.empty == xs
+
+appendAssociative :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+appendAssociative xs ys zs =
+ TimeBodyList.append xs (TimeBodyList.append ys zs) ==
+ TimeBodyList.append (TimeBodyList.append xs ys) zs
+
+appendCons :: (NonNeg.C time, Eq body) =>
+ time -> body -> TimeBodyList.T time body -> Bool
+appendCons time body xs =
+ TimeBodyList.cons time body xs ==
+ TimeBodyList.append (TimeBodyList.cons time body TimeBodyList.empty) xs
+
+appendSplitAtTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> Bool
+appendSplitAtTime t xs =
+ xs == uncurry TimeMixedList.appendBodyEnd (TimeMixedList.splitAtTime t xs)
+
+mapBodyAppend :: (Eq body1, NonNeg.C time) =>
+ (body0 -> body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool
+mapBodyAppend f xs ys =
+ TimeBodyList.mapBody f (TimeBodyList.append xs ys) ==
+ TimeBodyList.append (TimeBodyList.mapBody f xs) (TimeBodyList.mapBody f ys)
+
+
+appendFirstInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> TimeBodyList.T time body -> Bool
+appendFirstInfinite xs =
+ checkInfinite . TimeBodyList.append (makeInfiniteEventList xs)
+
+appendSecondInfinite :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> NonEmptyList time body -> Bool
+appendSecondInfinite xs =
+ checkInfinite . TimeBodyList.append xs . makeInfiniteEventList
+
+
+decreaseStartDelay :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> Bool
+decreaseStartDelay dif xs =
+ xs == TimeBodyList.decreaseStart dif (TimeBodyList.delay dif xs)
+
+decreaseStartInfinite :: (NonNeg.C time, Eq body) =>
+ time -> NonEmptyList time body -> Bool
+decreaseStartInfinite dif =
+ checkInfinite .
+ TimeBodyList.decreaseStart dif .
+ TimeBodyList.delay dif .
+ makeInfiniteEventList
+
+delayAdditive :: (NonNeg.C time, Eq body) =>
+ time -> time -> TimeBodyList.T time body -> Bool
+delayAdditive dif0 dif1 xs =
+ TimeBodyList.delay (dif0+dif1) xs ==
+ TimeBodyList.delay dif0 (TimeBodyList.delay dif1 xs)
+
+delayAppendPause :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> Bool
+delayAppendPause dif xs =
+ TimeBodyList.delay dif xs == TimeMixedList.appendBodyEnd (TimeTimeList.pause dif) xs
+
+delayInfinite :: (NonNeg.C time, Eq body) =>
+ time -> NonEmptyList time body -> Bool
+delayInfinite dif =
+ checkInfinite .
+ TimeBodyList.delay dif .
+ makeInfiniteEventList
+
+
+
+splitAtTakeDropTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> Bool
+splitAtTakeDropTime t xs =
+ (TimeMixedList.takeTime t xs, TimeMixedList.dropTime t xs) ==
+ TimeMixedList.splitAtTime t xs
+
+takeTimeEndPause :: (NonNeg.C time, Ord body) =>
+ time -> TimeBodyList.T time body -> Bool
+takeTimeEndPause t xs =
+ t == 0 ||
+ t >= TimeBodyList.duration xs ||
+ 0 < snd (TimeMixedList.viewTimeR (TimeMixedList.takeTime t xs))
+
+takeTimeAppendFirst :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+takeTimeAppendFirst t xs ys =
+ TimeMixedList.takeTime t (TimeBodyList.append xs ys) ==
+ TimeTimeList.append
+ (TimeMixedList.takeTime t xs)
+ (TimeMixedList.takeTime (t -| TimeBodyList.duration xs) ys)
+
+takeTimeAppendSecond :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+takeTimeAppendSecond t xs ys0 =
+ -- the second list must not start with a zero pause
+ let ys = TimeBodyList.delay 1 ys0
+ t1 = t+1
+ in TimeMixedList.takeTime (TimeBodyList.duration xs + t1) (TimeBodyList.append xs ys) ==
+ TimeMixedList.prependBodyEnd xs (TimeMixedList.takeTime t1 ys)
+
+takeTimeNormalize :: (NonNeg.C time, Ord body) =>
+ time -> TimeBodyList.T time body -> Bool
+takeTimeNormalize t =
+ TimeTimeList.isNormalized . TimeMixedList.takeTime t . TimeBodyList.normalize
+
+dropTimeNormalize :: (NonNeg.C time, Ord body) =>
+ time -> TimeBodyList.T time body -> Bool
+dropTimeNormalize t =
+ isNormalized . TimeMixedList.dropTime t . TimeBodyList.normalize
+
+takeTimeInfinite :: (NonNeg.C time, Ord body) =>
+ time -> NonEmptyList time body -> Bool
+takeTimeInfinite t =
+ (t == ) . TimeTimeList.duration .
+ TimeMixedList.takeTime t . makeUncollapsedInfiniteEventList
+
+dropTimeInfinite :: (NonNeg.C time, Ord body) =>
+ time -> NonEmptyList time body -> Bool
+dropTimeInfinite t =
+ checkInfinite . TimeMixedList.dropTime t . makeUncollapsedInfiniteEventList
+
+
+
+
+durationPause :: (NonNeg.C time) =>
+ time -> Bool
+durationPause t =
+ t == TimeBodyList.duration (TimeBodyList.singleton t (error "durationPause: no need to access body"))
+
+durationAppend :: (NonNeg.C time) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+durationAppend xs ys =
+ TimeBodyList.duration (TimeBodyList.append xs ys) ==
+ TimeBodyList.duration xs + TimeBodyList.duration ys
+
+durationMerge :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+durationMerge xs ys =
+ TimeBodyList.duration (TimeBodyList.merge xs ys) ==
+ max (TimeBodyList.duration xs) (TimeBodyList.duration ys)
+
+durationTakeTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> Bool
+durationTakeTime t xs =
+ min (TimeBodyList.duration xs) t ==
+ TimeTimeList.duration (TimeMixedList.takeTime t xs)
+
+durationDropTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeBodyList.T time body -> Bool
+durationDropTime t xs =
+ TimeBodyList.duration xs -| t ==
+ TimeBodyList.duration (TimeMixedList.dropTime t xs)
+
+
+
+equalPrefix :: (Eq time, Eq body) =>
+ Int -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+equalPrefix n xs ys =
+ TimeBodyPriv.lift (Disp.take n) xs ==
+ TimeBodyPriv.lift (Disp.take n) ys
+
+cycleInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+cycleInfinite xs0 =
+ let xs = makeInfiniteEventList xs0
+ in equalPrefix 100 xs (TimeBodyList.cycle xs)
+
+
+filterSatisfy :: (Num time) =>
+ (body -> Bool) ->
+ TimeBodyList.T time body -> Bool
+filterSatisfy p =
+ all p . TimeBodyList.getBodies . TimeBodyList.filter p
+
+filterProjection :: (Num time, Eq body) =>
+ (body -> Bool) ->
+ TimeBodyList.T time body -> Bool
+filterProjection p xs =
+ TimeBodyList.filter p xs ==
+ TimeBodyList.filter p (TimeBodyList.filter p xs)
+
+filterCommutative :: (Num time, Eq body) =>
+ (body -> Bool) ->
+ (body -> Bool) ->
+ TimeBodyList.T time body -> Bool
+filterCommutative p q xs =
+ TimeBodyList.filter p (TimeBodyList.filter q xs) ==
+ TimeBodyList.filter q (TimeBodyList.filter p xs)
+
+filterComposition :: (Num time, Eq body) =>
+ (body -> Bool) ->
+ (body -> Bool) ->
+ TimeBodyList.T time body -> Bool
+filterComposition p q xs =
+ TimeBodyList.filter p (TimeBodyList.filter q xs) ==
+ TimeBodyList.filter (\b -> p b && q b) xs
+
+filterNormalize :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) ->
+ TimeBodyList.T time body -> Bool
+filterNormalize p =
+ isNormalized . TimeBodyList.filter p . TimeBodyList.normalize
+
+filterAppend :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) ->
+ TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+filterAppend p xs0 ys =
+ let xs = TimeBodyList.filter p xs0
+ in TimeBodyList.filter p (TimeBodyList.append xs ys) ==
+ TimeBodyList.append xs (TimeBodyList.filter p ys)
+
+filterDuration :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) -> TimeTimeList.T time body -> Bool
+filterDuration p xs =
+ TimeTimeList.duration xs >= TimeTimeList.duration (TimeTimeList.filter p xs)
+
+filterPartition :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> TimeBodyList.T time body -> Bool
+filterPartition p xs =
+ (TimeBodyList.filter p xs, TimeBodyList.filter (not . p) xs) ==
+ TimeBodyList.partition p xs
+
+
+filterInfinite :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) -> NonEmptyList time body -> Bool
+filterInfinite p xs =
+ null (TimeBodyList.getBodies (TimeBodyList.filter p (makeNonEmptyEventList xs)))
+ ||
+ (checkInfinite .
+ TimeBodyList.filter p .
+ makeInfiniteEventList) xs
+
+catMaybesAppend :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time (Maybe body) -> TimeBodyList.T time (Maybe body) -> Bool
+catMaybesAppend xs0 ys =
+ let xs = TimeBodyList.filter isJust xs0
+ in TimeBodyList.catMaybes (TimeBodyList.append xs ys) ==
+ TimeBodyList.append (TimeBodyList.catMaybes xs) (TimeBodyList.catMaybes ys)
+
+
+{- |
+'TimeBodyList.merge' preserves normalization of its operands.
+-}
+mergeNormalize :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+mergeNormalize xs0 ys0 =
+ let xs = TimeBodyList.normalize xs0
+ ys = TimeBodyList.normalize ys0
+ in isNormalized $ TimeBodyList.merge xs ys
+
+mergeLeftIdentity :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> Bool
+mergeLeftIdentity xs =
+ TimeBodyList.merge TimeBodyList.empty xs == xs
+
+mergeRightIdentity :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> Bool
+mergeRightIdentity xs =
+ TimeBodyList.merge xs TimeBodyList.empty == xs
+
+mergeCommutative :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+mergeCommutative xs0 ys0 =
+ let xs = TimeBodyList.normalize xs0
+ ys = TimeBodyList.normalize ys0
+ in TimeBodyList.merge xs ys == TimeBodyList.merge ys xs
+
+mergeAssociative :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+mergeAssociative xs0 ys0 zs0 =
+ let xs = TimeBodyList.normalize xs0
+ ys = TimeBodyList.normalize ys0
+ zs = TimeBodyList.normalize zs0
+ in TimeBodyList.merge xs (TimeBodyList.merge ys zs) ==
+ TimeBodyList.merge (TimeBodyList.merge xs ys) zs
+
+{-
+Prior normalization is not enough,
+because 'append' does not preserve normalization
+if the first list ends with time difference 0
+and the second one starts with time difference 0.
+-}
+mergeAppend :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+mergeAppend xs ys zs =
+ TimeBodyList.normalize (TimeBodyList.append xs (TimeBodyList.merge ys zs)) ==
+ TimeBodyList.normalize
+ (TimeBodyList.merge (TimeBodyList.append xs ys)
+ (TimeBodyList.delay (TimeBodyList.duration xs) zs))
+
+{-
+Normalization is important
+
+does only hold for monotonic functions
+toUpper and toLower are not monotonic
+-}
+
+mergeMap :: (NonNeg.C time, Ord body0 ,Ord body1) =>
+ (body0 -> body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool
+mergeMap f xs0 ys0 =
+ let xs = TimeBodyList.normalize xs0
+ ys = TimeBodyList.normalize ys0
+ in TimeBodyList.mapBody f (TimeBodyList.merge xs ys) ==
+ TimeBodyList.merge (TimeBodyList.mapBody f xs) (TimeBodyList.mapBody f ys)
+
+mergeFilter :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+mergeFilter p xs0 ys0 =
+ let xs = TimeBodyList.normalize xs0
+ ys = TimeBodyList.normalize ys0
+ in TimeBodyList.filter p (TimeBodyList.merge xs ys) ==
+ TimeBodyList.merge (TimeBodyList.filter p xs) (TimeBodyList.filter p ys)
+
+mergePartition :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> TimeBodyList.T time body -> Bool
+mergePartition p xs0 =
+ let xs = TimeBodyList.normalize xs0
+ in xs == uncurry TimeBodyList.merge (TimeBodyList.partition p xs)
+
+mergeEitherMapMaybe :: (NonNeg.C time, Ord body) =>
+ TimeBodyList.T time body -> TimeBodyList.T time body -> Bool
+mergeEitherMapMaybe xs0 ys0 =
+ let xs = TimeBodyList.normalize xs0
+ ys = TimeBodyList.normalize ys0
+ zs = TimeBodyList.merge
+ (TimeBodyList.mapBody Left xs)
+ (TimeBodyList.mapBody Right ys)
+ in xs == TimeBodyList.mapMaybe (either Just (const Nothing)) zs
+ &&
+ ys == TimeBodyList.mapMaybe (either (const Nothing) Just) zs
+
+
+mergeInfinite :: (NonNeg.C time, Ord body) =>
+ NonEmptyList time body ->
+ NonEmptyList time body -> Bool
+mergeInfinite xs0 ys0 =
+ let xs = makeInfiniteEventList xs0
+ ys = makeInfiniteEventList ys0
+ in checkInfinite (TimeBodyList.merge xs ys)
+
+
+
+insertCommutative :: (NonNeg.C time, Ord body) =>
+ (time, body) -> (time, body) -> TimeBodyList.T time body -> Bool
+insertCommutative (time0, body0) (time1, body1) evs =
+ TimeBodyList.insert time0 body0 (TimeBodyList.insert time1 body1 evs) ==
+ TimeBodyList.insert time1 body1 (TimeBodyList.insert time0 body0 evs)
+
+insertMerge :: (NonNeg.C time, Ord body) =>
+ time -> body -> TimeBodyList.T time body -> Bool
+insertMerge time body evs =
+ TimeBodyList.insert time body evs ==
+ TimeBodyList.merge (TimeBodyList.cons time body TimeBodyList.empty) evs
+
+insertNormalize :: (NonNeg.C time, Ord body) =>
+ time -> body -> TimeBodyList.T time body -> Bool
+insertNormalize time body =
+ isNormalized . TimeBodyList.insert time body . TimeBodyList.normalize
+
+insertSplitAtTime :: (NonNeg.C time, Ord body) =>
+ time -> body -> TimeBodyList.T time body -> Bool
+insertSplitAtTime time body evs =
+ TimeBodyList.insert
+ (min time (TimeBodyList.duration evs)) body
+ (TimeBodyList.normalize evs)
+ ==
+ let (prefix,suffix) = TimeMixedList.splitAtTime time evs
+ in TimeBodyList.normalize (TimeMixedList.appendBodyEnd prefix
+ (MixedBodyList.consTime 0 (MixedBodyList.consBody body suffix)))
+
+insertInfinite :: (NonNeg.C time, Ord body) =>
+ time -> body -> NonEmptyList time body -> Bool
+insertInfinite time body =
+ checkInfinite . TimeBodyList.insert time body . makeInfiniteEventList
+
+
+
+spanSatisfy :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) -> TimeBodyList.T time body -> Bool
+spanSatisfy p =
+ uncurry (&&) .
+ mapPair
+ (all p . TimeBodyList.getBodies,
+ maybe True (not . p . snd . fst) . TimeBodyList.viewL) .
+ TimeBodyList.span p
+
+spanAppend :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) -> TimeBodyList.T time body -> Bool
+spanAppend p xs =
+ uncurry TimeBodyList.append (TimeBodyList.span p xs) == xs
+
+spanInfinite :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> NonEmptyList time body -> Bool
+spanInfinite p =
+ checkInfinite . uncurry TimeBodyList.append .
+ TimeBodyList.span p . makeInfiniteEventList
+
+
+coincidentFlatten :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+coincidentFlatten xs =
+ xs == TimeBodyList.flatten (TimeBodyList.collectCoincident xs)
+
+collectCoincidentGaps :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+collectCoincidentGaps xs =
+ let times = TimeBodyList.getTimes (TimeBodyList.collectCoincident xs)
+ in null times || all (0<) (tail times)
+
+collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+collectCoincidentNonEmpty =
+ all (not . null) . TimeBodyList.getBodies . TimeBodyList.collectCoincident
+
+collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+collectCoincidentInfinite =
+ checkInfinite .
+ TimeBodyList.collectCoincident .
+ makeUncollapsedInfiniteEventList
+
+
+mapCoincidentMap :: (NonNeg.C time, Eq body1) =>
+ (body0 -> body1) -> TimeBodyList.T time body0 -> Bool
+mapCoincidentMap f xs =
+ TimeBodyList.mapBody f xs ==
+ TimeBodyList.mapCoincident (map f) xs
+
+mapCoincidentComposition :: (NonNeg.C time, Eq body2) =>
+ ([body0] -> [body1]) -> ([body1] -> [body2]) -> TimeBodyList.T time body0 -> Bool
+mapCoincidentComposition f g xs =
+ TimeBodyList.mapCoincident (g . f) xs ==
+ (TimeBodyList.mapCoincident g . TimeBodyList.mapCoincident f) xs
+
+mapCoincidentReverse :: (NonNeg.C time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+mapCoincidentReverse xs =
+ xs == TimeBodyList.mapCoincident reverse (TimeBodyList.mapCoincident reverse xs)
+
+
+
+mapBodyMAppend ::
+ (Monad m, Eq body1, NonNeg.C time) =>
+ (m (TimeBodyList.T time body1) -> TimeBodyList.T time body1) ->
+ (body0 -> m body1) -> TimeBodyList.T time body0 -> TimeBodyList.T time body0 -> Bool
+mapBodyMAppend run f xs ys =
+ run (TimeBodyList.mapM return f (TimeBodyList.append xs ys)) ==
+ run (liftM2 TimeBodyList.append (TimeBodyList.mapM return f xs) (TimeBodyList.mapM return f ys))
+
+mapBodyMAppendRandom ::
+ (Random body, NonNeg.C time, Eq body) =>
+ Int -> TimeBodyList.T time (body,body) -> TimeBodyList.T time (body,body) -> Bool
+mapBodyMAppendRandom seed =
+ mapBodyMAppend
+ (flip evalState (mkStdGen seed))
+ (State . randomR)
+
+
+mapBodyMInfinite ::
+ (Random body, NonNeg.C time, Eq body) =>
+ Int -> NonEmptyList time (body,body) -> Bool
+mapBodyMInfinite seed =
+ checkInfinite .
+ flip evalState (mkStdGen seed) .
+ TimeBodyList.mapM return (State . randomR) .
+ makeInfiniteEventList
+
+
+{-
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ TimeBodyList.T time0 body0 -> m (TimeBodyList.T time1 body1)
+mapM timeAction bodyAction =
+ Uniform.mapM bodyAction timeAction
+
+mapImmM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ Immediate time0 body0 -> m (Immediate time1 body1)
+mapImmM timeAction bodyAction =
+ Disp.mapM bodyAction timeAction
+
+
+getBodies :: TimeBodyList.T time body -> [body]
+getBodies = Uniform.getFirsts
+
+getTimes :: TimeBodyList.T time body -> [time]
+getTimes = Uniform.getSeconds
+
+
+empty :: Immediate time body
+empty = Disp.empty
+
+
+cons :: time -> body -> TimeBodyList.T time body -> TimeBodyList.T time body
+cons = Uniform.cons
+
+
+snoc :: TimeBodyList.T time body -> body -> time -> TimeBodyList.T time body
+snoc = Uniform.snoc
+
+
+{-
+propInsertPadded :: Event time body -> TimeBodyList.T time body -> Bool
+propInsertPadded (Event time body) evs =
+ EventList.insert time body (fst evs) == fst (insert time body evs)
+-}
+
+appendSingle :: -- (Num time, Ord time, Ord body) =>
+ body -> TimeBodyList.T time body -> EventList.T time body
+appendSingle body xs =
+ Disp.foldr EventList.consTime EventList.consBody EventList.empty $
+ Uniform.snocFirst xs body
+
+fromEventList :: time -> EventList.T time body -> TimeBodyList.T time body
+fromEventList t =
+ EventList.foldr consTime consBody (pause t)
+
+toEventList :: TimeBodyList.T time body -> EventList.T time body
+toEventList xs =
+ zipWith EventList.Event (getTimes xs) (getBodies xs)
+
+{- |
+
+-}
+
+
+discretize :: (RealFrac time, Integral i) =>
+ TimeBodyList.T time body -> TimeBodyList.T i body
+discretize es =
+ evalState (Uniform.mapSecondM roundDiff es) 0
+
+resample :: (RealFrac time, Integral i) =>
+ time -> TimeBodyList.T time body -> TimeBodyList.T i body
+resample rate es =
+ discretize (mapTime (rate*) es)
+
+
+toAbsoluteEventList :: (Num time) =>
+ time -> TimeBodyList.T time body -> AbsoluteEventList.T time body
+toAbsoluteEventList start xs =
+ let ts = Uniform.getSeconds xs
+ bs = Uniform.getFirsts xs
+ ats = List.scanl (+) start ts
+ in maybe
+ (error "padded list always contains one time value")
+ (\ ~(ats0,lt) -> (zip ats0 bs, lt))
+ (viewR ats)
+-}
+
+
+
+
+type NonEmptyList time body = (time, body, TimeBodyList.T time body)
+
+makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> TimeBodyList.T time body
+makeUncollapsedInfiniteEventList =
+ makeInfiniteEventList .
+ (\(time,body,xs) -> (time+1,body,xs))
+
+makeInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> TimeBodyList.T time body
+makeInfiniteEventList =
+ TimeBodyList.cycle . makeNonEmptyEventList
+
+makeNonEmptyEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> TimeBodyList.T time body
+makeNonEmptyEventList (t, b, evs) =
+ TimeBodyList.cons t b evs
+
+{- |
+Pick an arbitrary element from an infinite list
+and check if it can be evaluated.
+-}
+checkInfinite :: (Eq time, Eq body) =>
+ TimeBodyList.T time body -> Bool
+checkInfinite xs0 =
+ let x = maybe
+ (error "BodyEnd.checkInfinite: empty list") fst $
+ TimeBodyList.viewL $ TimeBodyPriv.lift (Disp.drop 100) xs0
+ in x == x
+
+
+
+tests :: [(String, IO ())]
+tests =
+ ("viewTimeL consTime",
+ test (viewLConsTime :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("viewBodyL consBody",
+ test (viewLConsBody :: BodyBodyList.T TimeDiff Char -> Bool)) :
+
+ ("viewLInfinite",
+ test (viewLInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("consInfinite",
+ test (consInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("consTimeBodyInfinite",
+ test (consTimeBodyInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("snocInfinite",
+ test (snocInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("consInfix",
+ test (consInfix :: TimeDiff -> Char -> TimeDiff -> Char -> Bool)) :
+
+
+ ("map body composition",
+ test (mapBodyComposition Char.toUpper Char.toLower
+ :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("map time composition",
+ test ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+))
+ :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("map time body commutative",
+ test ((\dt -> mapTimeBodyCommutative (dt+) Char.toUpper)
+ :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+
+ ("mapBodyInfinite",
+ test (mapBodyInfinite Char.toUpper
+ :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("mapTimeInfinite",
+ test (\dt -> mapTimeInfinite (dt+)
+ :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("mapNormalize",
+ test (mapNormalize succ
+ :: TimeBodyList.T TimeDiff Char -> Bool)) :
+
+ ("append left identity",
+ test (appendLeftIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("append right identity",
+ test (appendRightIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("append associative",
+ test (appendAssociative
+ :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char ->
+ TimeBodyList.T TimeDiff Char -> Bool)) :
+
+ ("appendCons",
+ test (appendCons :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mapBodyAppend",
+ test (mapBodyAppend Char.toUpper
+ :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("appendSplitAtTime",
+ test (appendSplitAtTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("appendFirstInfinite",
+ test (appendFirstInfinite :: NonEmptyList TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("appendSecondInfinite",
+ test (appendSecondInfinite :: TimeBodyList.T TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("cycleInfinite",
+ test (cycleInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("decreaseStart delay",
+ test (decreaseStartDelay :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("decreaseStartInfinite",
+ test (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("delay additive",
+ test (delayAdditive :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("delay append pause",
+ test (delayAppendPause :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("delayInfinite",
+ test (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("splitAtTakeDropTime",
+ test (splitAtTakeDropTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("takeTimeEndPause",
+ test (takeTimeEndPause :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("takeTimeAppendFirst",
+ test (takeTimeAppendFirst :: TimeDiff -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("takeTimeAppendSecond",
+ test (takeTimeAppendSecond :: TimeDiff -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("takeTimeNormalize",
+ test (takeTimeNormalize :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("dropTimeNormalize",
+ test (dropTimeNormalize :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("takeTimeInfinite",
+ test (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("dropTimeInfinite",
+ test (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("duration pause",
+ test (durationPause :: TimeDiff -> Bool)) :
+ ("duration append",
+ test (durationAppend :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("duration merge",
+ test (durationMerge :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("durationTakeTime",
+ test (durationTakeTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("durationDropTime",
+ test (durationDropTime :: TimeDiff -> TimeBodyList.T TimeDiff Char -> Bool)) :
+
+ ("filterSatisfy",
+ test (\c -> filterSatisfy (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterProjection",
+ test (\c -> filterProjection (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterCommutative",
+ test (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterComposition",
+ test (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterNormalize",
+ test (\c -> filterNormalize (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterAppend",
+ test (\c -> filterAppend (c<) :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterDuration",
+ test (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterPartition",
+ test (\c -> filterPartition (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("filterInfinite",
+ test (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("catMaybesAppend",
+ test (catMaybesAppend :: TimeBodyList.T TimeDiff (Maybe Char) -> TimeBodyList.T TimeDiff (Maybe Char) -> Bool)) :
+
+ ("mergeNormalize",
+ test (mergeNormalize :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("merge left identity",
+ test (mergeLeftIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("merge right identity",
+ test (mergeRightIdentity :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("merge commutative",
+ test (mergeCommutative :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("merge associative",
+ test (mergeAssociative :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("merge append",
+ test (mergeAppend :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mergeMap",
+ test (mergeMap succ :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mergeFilter",
+ test (\c -> mergeFilter (c>)
+ :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mergePartition",
+ test (\c -> mergePartition (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mergeEitherMapMaybe",
+ test (mergeEitherMapMaybe
+ :: TimeBodyList.T TimeDiff Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mergeInfinite",
+ test (mergeInfinite
+ :: NonEmptyList TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("insert commutative",
+ test (insertCommutative :: (TimeDiff, Char) -> (TimeDiff, Char) -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("insert merge",
+ test (insertMerge :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("insertNormalize",
+ test (insertNormalize :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("insertSplitAtTime",
+ test (insertSplitAtTime :: TimeDiff -> Char -> TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("insertInfinite",
+ test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("spanSatisfy",
+ test (\c -> spanSatisfy (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("spanAppend",
+ test (\c -> spanAppend (c<) :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("spanInfinite",
+ test (\c -> spanInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("coincidentFlatten",
+ test (coincidentFlatten :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentGaps",
+ test (collectCoincidentGaps :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentNonEmpty",
+ test (collectCoincidentNonEmpty :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentInfinite",
+ test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("mapCoincidentMap",
+ test (mapCoincidentMap Char.toUpper :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mapCoincidentComposition",
+ test (mapCoincidentComposition reverse reverse :: TimeBodyList.T TimeDiff Char -> Bool)) :
+ ("mapCoincidentReverse",
+ test (mapCoincidentReverse :: TimeBodyList.T TimeDiff Char -> Bool)) :
+
+ ("mapBodyMAppendRandom",
+ test (mapBodyMAppendRandom :: Int -> TimeBodyList.T TimeDiff (Char,Char) -> TimeBodyList.T TimeDiff (Char,Char) -> Bool)) :
+ ("mapBodyMInfinite",
+ test (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (Char,Char) -> Bool)) :
+
+ []
diff --git a/Test/Data/EventList/Relative/TimeEnd.hs b/Test/Data/EventList/Relative/TimeEnd.hs
new file mode 100644
--- /dev/null
+++ b/Test/Data/EventList/Relative/TimeEnd.hs
@@ -0,0 +1,978 @@
+module Test.Data.EventList.Relative.TimeEnd (tests) where
+
+import Test.Utility
+import Test.QuickCheck (test)
+
+import qualified Data.EventList.Relative.TimeBody as TimeBodyList
+import qualified Data.EventList.Relative.TimeTime as TimeTimeList
+import qualified Data.EventList.Relative.TimeMixed as TimeMixedList
+import qualified Data.EventList.Relative.MixedTime as MixedTimeList
+import qualified Data.EventList.Relative.BodyTime as BodyTimeList
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import Data.EventList.Relative.MixedTime ((/.), (./), empty)
+
+import Data.EventList.Relative.TimeTimePrivate (($~~), lift)
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Numeric.NonNegative.Class ((-|))
+import Data.EventList.Relative.TimeTime (isNormalized)
+
+import System.Random (Random, randomR, mkStdGen)
+import Control.Monad.State (State(State), evalState)
+import Control.Monad (liftM2)
+import qualified Data.List as List
+import qualified Data.Char as Char
+
+
+
+viewLConsTime :: (Eq body, Eq time) =>
+ TimeTimeList.T time body -> Bool
+viewLConsTime xs =
+ xs == uncurry MixedTimeList.consTime (MixedTimeList.viewTimeL xs)
+
+viewLConsBody :: (Eq body, Eq time) =>
+ BodyTimeList.T time body -> Bool
+viewLConsBody xs =
+ xs == maybe BodyTimeList.empty (uncurry MixedTimeList.consBody) (MixedTimeList.viewBodyL xs)
+
+viewRSnocTime :: (Eq body, Eq time) =>
+ TimeTimeList.T time body -> Bool
+viewRSnocTime xs =
+ xs == uncurry TimeMixedList.snocTime (TimeMixedList.viewTimeR xs)
+
+viewRSnocBody :: (Eq body, Eq time) =>
+ TimeBodyList.T time body -> Bool
+viewRSnocBody xs =
+ xs == maybe TimeBodyList.empty (uncurry TimeMixedList.snocBody) (TimeMixedList.viewBodyR xs)
+
+
+
+
+viewLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool
+viewLInfinite =
+ checkInfinite .
+ maybe (error "viewBodyL: empty list") snd . MixedTimeList.viewBodyL .
+ snd . MixedTimeList.viewTimeL .
+ makeInfiniteEventList
+
+viewRInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool
+viewRInfinite =
+ checkInfinite .
+ maybe (error "viewBodyR: empty list") fst . TimeMixedList.viewBodyR .
+ fst . TimeMixedList.viewTimeR .
+ makeInfiniteEventList
+
+
+consInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+consInfinite time body =
+ checkInfinite .
+ TimeTimeList.cons time body .
+ makeInfiniteEventList
+
+consTimeBodyInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+consTimeBodyInfinite time body =
+ checkInfinite .
+ MixedTimeList.consTime time .
+ MixedTimeList.consBody body .
+ makeInfiniteEventList
+
+
+snocInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+snocInfinite time body =
+ checkInfinite .
+ flip (flip TimeTimeList.snoc body) time .
+ makeInfiniteEventList
+
+snocTimeBodyInfinite :: (NonNeg.C time, Eq body) =>
+ time -> body -> NonEmptyList time body -> Bool
+snocTimeBodyInfinite time body =
+ checkInfinite .
+ flip TimeMixedList.snocTime time .
+ flip TimeMixedList.snocBody body .
+ makeInfiniteEventList
+
+
+consInfix :: (NonNeg.C time, Eq body) =>
+ time -> body -> time -> time -> body -> time -> Bool
+consInfix t0a b0 t0b t1a b1 t1b =
+ TimeTimeList.append (t0a /. b0 ./ t0b /. empty) (t1a /. b1 ./ t1b /. empty)
+ == (t0a /. b0 ./ (t0b+t1a) /. b1 ./ t1b /. empty)
+
+
+
+
+mapBodyComposition :: (Eq body2, Eq time) =>
+ (body0 -> body1) -> (body1 -> body2) -> TimeTimeList.T time body0 -> Bool
+mapBodyComposition f g evs =
+ TimeTimeList.mapBody (g . f) evs ==
+ TimeTimeList.mapBody g (TimeTimeList.mapBody f evs)
+
+mapTimeComposition :: (Eq body, Eq time2) =>
+ (time0 -> time1) -> (time1 -> time2) -> TimeTimeList.T time0 body -> Bool
+mapTimeComposition f g evs =
+ TimeTimeList.mapTime (g . f) evs ==
+ TimeTimeList.mapTime g (TimeTimeList.mapTime f evs)
+
+
+mapTimeBodyCommutative :: (Eq body1, Eq time1) =>
+ (time0 -> time1) -> (body0 -> body1) -> TimeTimeList.T time0 body0 -> Bool
+mapTimeBodyCommutative f g evs =
+ TimeTimeList.mapBody g (TimeTimeList.mapTime f evs) ==
+ TimeTimeList.mapTime f (TimeTimeList.mapBody g evs)
+
+
+
+mapBodyInfinite :: (NonNeg.C time, Eq body1) =>
+ (body0 -> body1) -> NonEmptyList time body0 -> Bool
+mapBodyInfinite f =
+ checkInfinite . TimeTimeList.mapBody f . makeInfiniteEventList
+
+mapTimeInfinite :: (NonNeg.C time0, Eq time1, Eq body) =>
+ (time0 -> time1) -> NonEmptyList time0 body -> Bool
+mapTimeInfinite f =
+ checkInfinite . TimeTimeList.mapTime f . makeInfiniteEventList
+
+
+
+{- |
+Does only hold for monotonic functions.
+-}
+mapNormalize :: (NonNeg.C time, Ord body0, Ord body1) =>
+ (body0 -> body1) -> TimeTimeList.T time body0 -> Bool
+mapNormalize f =
+ isNormalized . TimeTimeList.mapBody f . TimeTimeList.normalize
+
+
+
+appendLeftIdentity :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+appendLeftIdentity xs =
+ TimeTimeList.append (TimeTimeList.pause 0) xs == xs
+
+appendRightIdentity :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+appendRightIdentity xs =
+ TimeTimeList.append xs (TimeTimeList.pause 0) == xs
+
+appendAssociative :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+appendAssociative xs ys zs =
+ TimeTimeList.append xs (TimeTimeList.append ys zs) ==
+ TimeTimeList.append (TimeTimeList.append xs ys) zs
+
+appendCons :: (NonNeg.C time, Eq body) =>
+ time -> body -> TimeTimeList.T time body -> Bool
+appendCons time body xs =
+ TimeTimeList.cons time body xs ==
+ TimeTimeList.append (TimeTimeList.cons time body (TimeTimeList.pause 0)) xs
+
+appendSplitAtTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> Bool
+appendSplitAtTime t xs =
+ xs == uncurry TimeTimeList.append (TimeTimeList.splitAtTime t xs)
+
+mapBodyAppend :: (Eq body1, NonNeg.C time) =>
+ (body0 -> body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool
+mapBodyAppend f xs ys =
+ TimeTimeList.mapBody f (TimeTimeList.append xs ys) ==
+ TimeTimeList.append (TimeTimeList.mapBody f xs) (TimeTimeList.mapBody f ys)
+
+
+appendFirstInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> TimeTimeList.T time body -> Bool
+appendFirstInfinite xs =
+ checkInfinite . TimeTimeList.append (makeInfiniteEventList xs)
+
+appendSecondInfinite :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> NonEmptyList time body -> Bool
+appendSecondInfinite xs =
+ checkInfinite . TimeTimeList.append xs . makeInfiniteEventList
+
+
+decreaseStartDelay :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> Bool
+decreaseStartDelay dif xs =
+ xs == TimeTimeList.decreaseStart dif (TimeTimeList.delay dif xs)
+
+decreaseStartInfinite :: (NonNeg.C time, Eq body) =>
+ time -> NonEmptyList time body -> Bool
+decreaseStartInfinite dif =
+ checkInfinite .
+ TimeTimeList.decreaseStart dif .
+ TimeTimeList.delay dif .
+ makeInfiniteEventList
+
+delayAdditive :: (NonNeg.C time, Eq body) =>
+ time -> time -> TimeTimeList.T time body -> Bool
+delayAdditive dif0 dif1 xs =
+ TimeTimeList.delay (dif0+dif1) xs ==
+ TimeTimeList.delay dif0 (TimeTimeList.delay dif1 xs)
+
+delayPause :: (NonNeg.C time) =>
+ time -> time -> Bool
+delayPause dif0 dif1 =
+ let pause = TimeTimeList.pause (dif0+dif1)
+ in TimeTimeList.delay dif0 (TimeTimeList.pause dif1) ==
+ (asTypeOf pause (TimeTimeList.cons dif0 () pause))
+
+delayAppendPause :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> Bool
+delayAppendPause dif xs =
+ TimeTimeList.delay dif xs == TimeTimeList.append (TimeTimeList.pause dif) xs
+
+delayInfinite :: (NonNeg.C time, Eq body) =>
+ time -> NonEmptyList time body -> Bool
+delayInfinite dif =
+ checkInfinite .
+ TimeTimeList.delay dif .
+ makeInfiniteEventList
+
+
+
+splitAtTakeDropTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> Bool
+splitAtTakeDropTime t xs =
+ (TimeTimeList.takeTime t xs, TimeTimeList.dropTime t xs) ==
+ TimeTimeList.splitAtTime t xs
+
+takeTimeEndPause :: (NonNeg.C time, Ord body) =>
+ time -> TimeTimeList.T time body -> Bool
+takeTimeEndPause t xs =
+ t == 0 ||
+ t >= TimeTimeList.duration xs ||
+ 0 < snd (TimeMixedList.viewTimeR (TimeTimeList.takeTime t xs))
+
+takeTimeAppendFirst :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+takeTimeAppendFirst t xs ys =
+ TimeTimeList.takeTime t (TimeTimeList.append xs ys) ==
+ TimeTimeList.append
+ (TimeTimeList.takeTime t xs)
+ (TimeTimeList.takeTime (t -| TimeTimeList.duration xs) ys)
+
+takeTimeAppendSecond :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+takeTimeAppendSecond t xs0 ys =
+ -- the first list must not end with a zero pause
+ let xs = TimeTimeList.append xs0 (TimeTimeList.pause 1)
+ in TimeTimeList.takeTime (TimeTimeList.duration xs + t) (TimeTimeList.append xs ys) ==
+ TimeTimeList.append xs (TimeTimeList.takeTime t ys)
+
+takeTimeNormalize :: (NonNeg.C time, Ord body) =>
+ time -> TimeTimeList.T time body -> Bool
+takeTimeNormalize t =
+ isNormalized . TimeTimeList.takeTime t . TimeTimeList.normalize
+
+dropTimeNormalize :: (NonNeg.C time, Ord body) =>
+ time -> TimeTimeList.T time body -> Bool
+dropTimeNormalize t =
+ isNormalized . TimeTimeList.dropTime t . TimeTimeList.normalize
+
+takeTimeInfinite :: (NonNeg.C time, Ord body) =>
+ time -> NonEmptyList time body -> Bool
+takeTimeInfinite t =
+ (t == ) . TimeTimeList.duration .
+ TimeTimeList.takeTime t . makeUncollapsedInfiniteEventList
+
+dropTimeInfinite :: (NonNeg.C time, Ord body) =>
+ time -> NonEmptyList time body -> Bool
+dropTimeInfinite t =
+ checkInfinite . TimeTimeList.dropTime t . makeUncollapsedInfiniteEventList
+
+
+
+
+durationPause :: (NonNeg.C time) =>
+ time -> Bool
+durationPause t =
+ t == TimeTimeList.duration (TimeTimeList.pause t)
+
+durationAppend :: (NonNeg.C time) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+durationAppend xs ys =
+ TimeTimeList.duration (TimeTimeList.append xs ys) ==
+ TimeTimeList.duration xs + TimeTimeList.duration ys
+
+durationMerge :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+durationMerge xs ys =
+ TimeTimeList.duration (TimeTimeList.merge xs ys) ==
+ max (TimeTimeList.duration xs) (TimeTimeList.duration ys)
+
+durationTakeTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> Bool
+durationTakeTime t xs =
+ min (TimeTimeList.duration xs) t ==
+ TimeTimeList.duration (TimeTimeList.takeTime t xs)
+
+durationDropTime :: (NonNeg.C time, Eq body) =>
+ time -> TimeTimeList.T time body -> Bool
+durationDropTime t xs =
+ TimeTimeList.duration xs -| t ==
+ TimeTimeList.duration (TimeTimeList.dropTime t xs)
+
+
+
+concatNaive :: (NonNeg.C time, Eq body) =>
+ [TimeTimeList.T time body] -> Bool
+concatNaive xs =
+ TimeTimeList.concat xs == TimeTimeList.concatNaive xs
+
+
+equalPrefix :: (Eq time, Eq body) =>
+ Int -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+equalPrefix n xs ys =
+ Mixed.takeDisparate n $~~ xs ==
+ Mixed.takeDisparate n $~~ ys
+
+cycleNaive :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+cycleNaive xs0 =
+ let xs = makeNonEmptyEventList xs0
+ in equalPrefix 100 (TimeTimeList.cycle xs) (TimeTimeList.cycleNaive xs)
+
+cycleInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+cycleInfinite xs0 =
+ let xs = makeInfiniteEventList xs0
+ in equalPrefix 100 xs (TimeTimeList.cycle xs)
+
+
+filterSatisfy :: (Num time) =>
+ (body -> Bool) ->
+ TimeTimeList.T time body -> Bool
+filterSatisfy p =
+ all p . TimeTimeList.getBodies . TimeTimeList.filter p
+
+filterProjection :: (Num time, Eq body) =>
+ (body -> Bool) ->
+ TimeTimeList.T time body -> Bool
+filterProjection p xs =
+ TimeTimeList.filter p xs ==
+ TimeTimeList.filter p (TimeTimeList.filter p xs)
+
+filterCommutative :: (Num time, Eq body) =>
+ (body -> Bool) ->
+ (body -> Bool) ->
+ TimeTimeList.T time body -> Bool
+filterCommutative p q xs =
+ TimeTimeList.filter p (TimeTimeList.filter q xs) ==
+ TimeTimeList.filter q (TimeTimeList.filter p xs)
+
+filterComposition :: (Num time, Eq body) =>
+ (body -> Bool) ->
+ (body -> Bool) ->
+ TimeTimeList.T time body -> Bool
+filterComposition p q xs =
+ TimeTimeList.filter p (TimeTimeList.filter q xs) ==
+ TimeTimeList.filter (\b -> p b && q b) xs
+
+filterNormalize :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) ->
+ TimeTimeList.T time body -> Bool
+filterNormalize p =
+ isNormalized . TimeTimeList.filter p . TimeTimeList.normalize
+
+filterAppend :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) ->
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+filterAppend p xs ys =
+ TimeTimeList.filter p (TimeTimeList.append xs ys) ==
+ TimeTimeList.append (TimeTimeList.filter p xs) (TimeTimeList.filter p ys)
+
+filterDuration :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) -> TimeTimeList.T time body -> Bool
+filterDuration p xs =
+ TimeTimeList.duration xs == TimeTimeList.duration (TimeTimeList.filter p xs)
+
+filterPartition :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> TimeTimeList.T time body -> Bool
+filterPartition p xs =
+ (TimeTimeList.filter p xs, TimeTimeList.filter (not . p) xs) ==
+ TimeTimeList.partition p xs
+
+
+filterInfinite :: (NonNeg.C time, Eq body) =>
+ (body -> Bool) -> NonEmptyList time body -> Bool
+filterInfinite p xs =
+ null (TimeTimeList.getBodies (TimeTimeList.filter p (makeNonEmptyEventList xs)))
+ ||
+ (checkInfinite .
+ TimeTimeList.filter p .
+ makeInfiniteEventList) xs
+
+catMaybesAppend :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time (Maybe body) -> TimeTimeList.T time (Maybe body) -> Bool
+catMaybesAppend xs ys =
+ TimeTimeList.catMaybes (TimeTimeList.append xs ys) ==
+ TimeTimeList.append (TimeTimeList.catMaybes xs) (TimeTimeList.catMaybes ys)
+
+
+{- |
+'TimeTimeList.merge' preserves normalization of its operands.
+-}
+mergeNormalize :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+mergeNormalize xs0 ys0 =
+ let xs = TimeTimeList.normalize xs0
+ ys = TimeTimeList.normalize ys0
+ in isNormalized $ TimeTimeList.merge xs ys
+
+mergeLeftIdentity :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> Bool
+mergeLeftIdentity xs =
+ TimeTimeList.merge (TimeTimeList.pause 0) xs == xs
+
+mergeRightIdentity :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> Bool
+mergeRightIdentity xs =
+ TimeTimeList.merge xs (TimeTimeList.pause 0) == xs
+
+mergeCommutative :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+mergeCommutative xs0 ys0 =
+ let xs = TimeTimeList.normalize xs0
+ ys = TimeTimeList.normalize ys0
+ in TimeTimeList.merge xs ys == TimeTimeList.merge ys xs
+{-
+merge commutative: Falsifiable, after 8 tests:
+3 ./ '!' /. 0 ./ ' ' /. 1 ./ ' ' /. 2 ./ empty
+3 ./ '!' /. 3 ./ '!' /. 1 ./ empty
+-}
+
+mergeAssociative :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+mergeAssociative xs0 ys0 zs0 =
+ let xs = TimeTimeList.normalize xs0
+ ys = TimeTimeList.normalize ys0
+ zs = TimeTimeList.normalize zs0
+ in TimeTimeList.merge xs (TimeTimeList.merge ys zs) ==
+ TimeTimeList.merge (TimeTimeList.merge xs ys) zs
+
+{-
+Prior normalization is not enough,
+because 'append' does not preserve normalization
+if the first list ends with time difference 0
+and the second one starts with time difference 0.
+
+Without posterior normalization you get
+
+merge append: Falsifiable, after 30 tests:
+1 ./ 'a' /. 0 ./ empty
+1 ./ ' ' /. 1 ./ empty
+0 ./ ' ' /. 1 ./ empty
+
+-}
+mergeAppend :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+mergeAppend xs ys zs =
+ TimeTimeList.normalize (TimeTimeList.append xs (TimeTimeList.merge ys zs)) ==
+ TimeTimeList.normalize
+ (TimeTimeList.merge (TimeTimeList.append xs ys)
+ (TimeTimeList.delay (TimeTimeList.duration xs) zs))
+
+appendByMerge :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+appendByMerge xs ys =
+ TimeTimeList.normalize (TimeTimeList.append xs ys) ==
+ TimeTimeList.normalize (TimeTimeList.merge xs
+ (TimeTimeList.delay (TimeTimeList.duration xs) ys))
+
+{-
+Normalization is important, otherwise the following counter-examples exist:
+
+merge associative: Falsifiable, after 99 tests:
+0 ./ '\DEL' /. 2 ./ '\DEL' /. 2 ./ empty
+0 ./ '\DEL' /. 2 ./ '\DEL' /. 0 ./ '~' /. 3 ./ empty
+2 ./ ' ' /. 2 ./ '\DEL' /. 3 ./ empty
+
+merge associative: Falsifiable, after 99 tests:
+6 ./ '~' /. 2 ./ '%' /. 1 ./ '#' /. 3 ./ '$' /. 2 ./ empty
+6 ./ '~' /. 0 ./ '"' /. 2 ./ '{' /. 0 ./ '"' /. 6 ./ empty
+0 ./ '{' /. 5 ./ '$' /. 3 ./ empty
+
+merge associative: Falsifiable, after 41 tests:
+2 ./ '~' /. 0 ./ empty
+2 ./ '~' /. 0 ./ '$' /. 3 ./ empty
+1 ./ '#' /. 4 ./ '"' /. 4 ./ empty
+-}
+
+-- does only hold for monotonic functions
+-- toUpper and toLower are not monotonic
+mergeMap :: (NonNeg.C time, Ord body0 ,Ord body1) =>
+ (body0 -> body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool
+mergeMap f xs0 ys0 =
+ let xs = TimeTimeList.normalize xs0
+ ys = TimeTimeList.normalize ys0
+ in TimeTimeList.mapBody f (TimeTimeList.merge xs ys) ==
+ TimeTimeList.merge (TimeTimeList.mapBody f xs) (TimeTimeList.mapBody f ys)
+
+mergeFilter :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+mergeFilter p xs0 ys0 =
+ let xs = TimeTimeList.normalize xs0
+ ys = TimeTimeList.normalize ys0
+ in TimeTimeList.filter p (TimeTimeList.merge xs ys) ==
+ TimeTimeList.merge (TimeTimeList.filter p xs) (TimeTimeList.filter p ys)
+
+mergePartition :: (NonNeg.C time, Ord body) =>
+ (body -> Bool) -> TimeTimeList.T time body -> Bool
+mergePartition p xs0 =
+ let xs = TimeTimeList.normalize xs0
+ in xs == uncurry TimeTimeList.merge (TimeTimeList.partition p xs)
+
+mergeEitherMapMaybe :: (NonNeg.C time, Ord body) =>
+ TimeTimeList.T time body -> TimeTimeList.T time body -> Bool
+mergeEitherMapMaybe xs0 ys0 =
+ let xs = TimeTimeList.normalize xs0
+ ys = TimeTimeList.normalize ys0
+ zs = TimeTimeList.merge
+ (TimeTimeList.mapBody Left xs)
+ (TimeTimeList.mapBody Right ys)
+ dur = TimeTimeList.duration zs
+ longXs = TimeTimeList.merge (TimeTimeList.pause dur) xs
+ longYs = TimeTimeList.merge (TimeTimeList.pause dur) ys
+ in longXs == TimeTimeList.mapMaybe (either Just (const Nothing)) zs
+ &&
+ longYs == TimeTimeList.mapMaybe (either (const Nothing) Just) zs
+
+
+mergeInfinite :: (NonNeg.C time, Ord body) =>
+ NonEmptyList time body ->
+ NonEmptyList time body -> Bool
+mergeInfinite xs0 ys0 =
+ let xs = makeInfiniteEventList xs0
+ ys = makeInfiniteEventList ys0
+ in checkInfinite (TimeTimeList.merge xs ys)
+
+
+
+insertCommutative :: (NonNeg.C time, Ord body) =>
+ (time, body) -> (time, body) -> TimeTimeList.T time body -> Bool
+insertCommutative (time0, body0) (time1, body1) evs =
+ TimeTimeList.insert time0 body0 (TimeTimeList.insert time1 body1 evs) ==
+ TimeTimeList.insert time1 body1 (TimeTimeList.insert time0 body0 evs)
+
+insertMerge :: (NonNeg.C time, Ord body) =>
+ time -> body -> TimeTimeList.T time body -> Bool
+insertMerge time body evs =
+ TimeTimeList.insert time body evs ==
+ TimeTimeList.merge (TimeTimeList.cons time body $ TimeTimeList.pause 0) evs
+
+insertNormalize :: (NonNeg.C time, Ord body) =>
+ time -> body -> TimeTimeList.T time body -> Bool
+insertNormalize time body =
+ isNormalized . TimeTimeList.insert time body . TimeTimeList.normalize
+
+insertSplitAtTime :: (NonNeg.C time, Ord body) =>
+ time -> body -> TimeTimeList.T time body -> Bool
+insertSplitAtTime time body evs =
+ TimeTimeList.insert
+ (min time (TimeTimeList.duration evs)) body
+ (TimeTimeList.normalize evs)
+ ==
+ let (prefix,suffix) = TimeTimeList.splitAtTime time evs
+ in TimeTimeList.normalize
+ (TimeTimeList.append prefix (TimeTimeList.cons 0 body suffix))
+ -- append prefix (MixedTimeList.consBody body suffix)
+
+insertInfinite :: (NonNeg.C time, Ord body) =>
+ time -> body -> NonEmptyList time body -> Bool
+insertInfinite time body =
+ checkInfinite . TimeTimeList.insert time body . makeInfiniteEventList
+
+
+
+
+coincidentFlatten :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+coincidentFlatten xs =
+ xs == TimeTimeList.flatten (TimeTimeList.collectCoincident xs)
+
+collectCoincidentGaps :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+collectCoincidentGaps xs =
+ let times = tail (TimeTimeList.getTimes (TimeTimeList.collectCoincident xs))
+ in null times || all (0<) (init times)
+
+collectCoincidentNonEmpty :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+collectCoincidentNonEmpty =
+ all (not . null) . TimeTimeList.getBodies . TimeTimeList.collectCoincident
+
+collectCoincidentInfinite :: (NonNeg.C time, Eq body) =>
+ NonEmptyList time body -> Bool
+collectCoincidentInfinite =
+ checkInfinite .
+ TimeTimeList.collectCoincident .
+ makeUncollapsedInfiniteEventList
+
+
+mapCoincidentMap :: (NonNeg.C time, Eq body1) =>
+ (body0 -> body1) -> TimeTimeList.T time body0 -> Bool
+mapCoincidentMap f xs =
+ TimeTimeList.mapBody f xs ==
+ TimeTimeList.mapCoincident (map f) xs
+
+mapCoincidentComposition :: (NonNeg.C time, Eq body2) =>
+ ([body0] -> [body1]) -> ([body1] -> [body2]) -> TimeTimeList.T time body0 -> Bool
+mapCoincidentComposition f g xs =
+ TimeTimeList.mapCoincident (g . f) xs ==
+ (TimeTimeList.mapCoincident g . TimeTimeList.mapCoincident f) xs
+
+mapCoincidentReverse :: (NonNeg.C time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+mapCoincidentReverse xs =
+ xs == TimeTimeList.mapCoincident reverse (TimeTimeList.mapCoincident reverse xs)
+
+
+
+mapBodyMAppend ::
+ (Monad m, Eq body1, NonNeg.C time) =>
+ (m (TimeTimeList.T time body1) -> TimeTimeList.T time body1) ->
+ (body0 -> m body1) -> TimeTimeList.T time body0 -> TimeTimeList.T time body0 -> Bool
+mapBodyMAppend run f xs ys =
+ run (TimeTimeList.mapM return f (TimeTimeList.append xs ys)) ==
+ run (liftM2 TimeTimeList.append (TimeTimeList.mapM return f xs) (TimeTimeList.mapM return f ys))
+
+mapBodyMAppendRandom ::
+ (Random body, NonNeg.C time, Eq body) =>
+ Int -> TimeTimeList.T time (body,body) -> TimeTimeList.T time (body,body) -> Bool
+mapBodyMAppendRandom seed =
+ mapBodyMAppend
+ (flip evalState (mkStdGen seed))
+ (State . randomR)
+
+
+mapBodyMInfinite ::
+ (Random body, NonNeg.C time, Eq body) =>
+ Int -> NonEmptyList time (body,body) -> Bool
+mapBodyMInfinite seed =
+ checkInfinite .
+ flip evalState (mkStdGen seed) .
+ TimeTimeList.mapM return (State . randomR) .
+ makeInfiniteEventList
+
+
+{-
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ TimeTimeList.T time0 body0 -> m (TimeTimeList.T time1 body1)
+mapM timeAction bodyAction =
+ Uniform.mapM bodyAction timeAction
+
+mapImmM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ Immediate time0 body0 -> m (Immediate time1 body1)
+mapImmM timeAction bodyAction =
+ Disp.mapM bodyAction timeAction
+
+
+getBodies :: TimeTimeList.T time body -> [body]
+getBodies = Uniform.getFirsts
+
+getTimes :: TimeTimeList.T time body -> [time]
+getTimes = Uniform.getSeconds
+
+
+empty :: Immediate time body
+empty = Disp.empty
+
+
+cons :: time -> body -> TimeTimeList.T time body -> TimeTimeList.T time body
+cons = Uniform.cons
+
+
+snoc :: TimeTimeList.T time body -> body -> time -> TimeTimeList.T time body
+snoc = Uniform.snoc
+
+
+{-
+propInsertPadded :: Event time body -> TimeTimeList.T time body -> Bool
+propInsertPadded (Event time body) evs =
+ EventList.insert time body (fst evs) == fst (insert time body evs)
+-}
+
+appendSingle :: -- (Num time, Ord time, Ord body) =>
+ body -> TimeTimeList.T time body -> EventList.T time body
+appendSingle body xs =
+ Disp.foldr EventList.consTime EventList.consBody EventList.empty $
+ Uniform.snocFirst xs body
+
+fromEventList :: time -> EventList.T time body -> TimeTimeList.T time body
+fromEventList t =
+ EventList.foldr consTime consBody (pause t)
+
+toEventList :: TimeTimeList.T time body -> EventList.T time body
+toEventList xs =
+ zipWith EventList.Event (getTimes xs) (getBodies xs)
+
+{- |
+
+-}
+
+
+discretize :: (RealFrac time, Integral i) =>
+ TimeTimeList.T time body -> TimeTimeList.T i body
+discretize es =
+ evalState (Uniform.mapSecondM roundDiff es) 0
+
+resample :: (RealFrac time, Integral i) =>
+ time -> TimeTimeList.T time body -> TimeTimeList.T i body
+resample rate es =
+ discretize (mapTime (rate*) es)
+
+
+toAbsoluteEventList :: (Num time) =>
+ time -> TimeTimeList.T time body -> AbsoluteEventList.T time body
+toAbsoluteEventList start xs =
+ let ts = Uniform.getSeconds xs
+ bs = Uniform.getFirsts xs
+ ats = List.scanl (+) start ts
+ in maybe
+ (error "padded list always contains one time value")
+ (\ ~(ats0,lt) -> (zip ats0 bs, lt))
+ (viewR ats)
+-}
+
+
+
+
+type NonEmptyList time body = (time, body, TimeTimeList.T time body)
+
+makeUncollapsedInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> TimeTimeList.T time body
+makeUncollapsedInfiniteEventList =
+ makeInfiniteEventList .
+ (\(time,body,xs) -> (time+1,body,xs))
+
+makeInfiniteEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> TimeTimeList.T time body
+makeInfiniteEventList =
+ TimeTimeList.cycle . makeNonEmptyEventList
+
+makeNonEmptyEventList :: (NonNeg.C time) =>
+ NonEmptyList time body -> TimeTimeList.T time body
+makeNonEmptyEventList (t, b, evs) =
+ TimeTimeList.cons t b evs
+
+{- |
+Pick an arbitrary element from an infinite list
+and check if it can be evaluated.
+-}
+checkInfinite :: (Eq time, Eq body) =>
+ TimeTimeList.T time body -> Bool
+checkInfinite xs0 =
+ let (x,xs) = MixedTimeList.viewTimeL (lift (Mixed.dropUniform 100) xs0)
+ y = maybe
+ (error "checkInfinite: finite list")
+ fst
+ (MixedTimeList.viewBodyL xs)
+ in x == x && y == y
+
+
+
+tests :: [(String, IO ())]
+tests =
+ ("viewTimeL consTime",
+ test (viewLConsTime :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("viewBodyL consBody",
+ test (viewLConsBody :: BodyTimeList.T TimeDiff Char -> Bool)) :
+ ("viewTimeR snocTime",
+ test (viewRSnocTime :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("viewBodyR snocBody",
+ test (viewRSnocBody :: TimeBodyList.T TimeDiff Char -> Bool)) :
+
+ ("viewLInfinite",
+ test (viewLInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("viewRInfinite",
+ test (viewRInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("consInfinite",
+ test (consInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("consTimeBodyInfinite",
+ test (consTimeBodyInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("snocInfinite",
+ test (snocInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("snocTimeBodyInfinite",
+ test (snocTimeBodyInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("consInfix",
+ test (consInfix :: TimeDiff -> Char -> TimeDiff -> TimeDiff -> Char -> TimeDiff -> Bool)) :
+
+
+ ("map body composition",
+ test (mapBodyComposition Char.toUpper Char.toLower
+ :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("map time composition",
+ test ((\dt0 dt1 -> mapTimeComposition (dt0+) (dt1+))
+ :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("map time body commutative",
+ test ((\dt -> mapTimeBodyCommutative (dt+) Char.toUpper)
+ :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+
+ ("mapBodyInfinite",
+ test (mapBodyInfinite Char.toUpper
+ :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("mapTimeInfinite",
+ test (\dt -> mapTimeInfinite (dt+)
+ :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("mapNormalize",
+ test (mapNormalize succ
+ :: TimeTimeList.T TimeDiff Char -> Bool)) :
+
+ ("append left identity",
+ test (appendLeftIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("append right identity",
+ test (appendRightIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("append associative",
+ test (appendAssociative
+ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char ->
+ TimeTimeList.T TimeDiff Char -> Bool)) :
+
+ ("appendCons",
+ test (appendCons :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mapBodyAppend",
+ test (mapBodyAppend Char.toUpper
+ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("appendSplitAtTime",
+ test (appendSplitAtTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("appendFirstInfinite",
+ test (appendFirstInfinite :: NonEmptyList TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("appendSecondInfinite",
+ test (appendSecondInfinite :: TimeTimeList.T TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("concatNaive",
+ test (concatNaive :: [TimeTimeList.T TimeDiff Char] -> Bool)) :
+ ("cycleNaive",
+ test (cycleNaive :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("cycleInfinite",
+ test (cycleInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("decreaseStart delay",
+ test (decreaseStartDelay :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("decreaseStartInfinite",
+ test (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("delay additive",
+ test (delayAdditive :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("delay pause",
+ test (delayPause :: TimeDiff -> TimeDiff -> Bool)) :
+ ("delay append pause",
+ test (delayAppendPause :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("delayInfinite",
+ test (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("splitAtTakeDropTime",
+ test (splitAtTakeDropTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("takeTimeEndPause",
+ test (takeTimeEndPause :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("takeTimeAppendFirst",
+ test (takeTimeAppendFirst :: TimeDiff -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("takeTimeAppendSecond",
+ test (takeTimeAppendSecond :: TimeDiff -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("takeTimeNormalize",
+ test (takeTimeNormalize :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("dropTimeNormalize",
+ test (dropTimeNormalize :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("takeTimeInfinite",
+ test (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+ ("dropTimeInfinite",
+ test (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("duration pause",
+ test (durationPause :: TimeDiff -> Bool)) :
+ ("duration append",
+ test (durationAppend :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("duration merge",
+ test (durationMerge :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("durationTakeTime",
+ test (durationTakeTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("durationDropTime",
+ test (durationDropTime :: TimeDiff -> TimeTimeList.T TimeDiff Char -> Bool)) :
+
+ ("filterSatisfy",
+ test (\c -> filterSatisfy (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterProjection",
+ test (\c -> filterProjection (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterCommutative",
+ test (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterComposition",
+ test (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterNormalize",
+ test (\c -> filterNormalize (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterAppend",
+ test (\c -> filterAppend (c<) :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterDuration",
+ test (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterPartition",
+ test (\c -> filterPartition (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("filterInfinite",
+ test (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff Char -> Bool)) :
+ ("catMaybesAppend",
+ test (catMaybesAppend :: TimeTimeList.T TimeDiff (Maybe Char) -> TimeTimeList.T TimeDiff (Maybe Char) -> Bool)) :
+
+ ("mergeNormalize",
+ test (mergeNormalize :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("merge left identity",
+ test (mergeLeftIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("merge right identity",
+ test (mergeRightIdentity :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("merge commutative",
+ test (mergeCommutative :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("merge associative",
+ test (mergeAssociative :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("merge append",
+ test (mergeAppend :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("appendByMerge",
+ test (appendByMerge :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mergeMap",
+ test (mergeMap succ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mergeFilter",
+ test (\c -> mergeFilter (c>)
+ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mergePartition",
+ test (\c -> mergePartition (c<) :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mergeEitherMapMaybe",
+ test (mergeEitherMapMaybe
+ :: TimeTimeList.T TimeDiff Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mergeInfinite",
+ test (mergeInfinite
+ :: NonEmptyList TimeDiff Char -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("insert commutative",
+ test (insertCommutative :: (TimeDiff, Char) -> (TimeDiff, Char) -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("insert merge",
+ test (insertMerge :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("insertNormalize",
+ test (insertNormalize :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("insertSplitAtTime",
+ test (insertSplitAtTime :: TimeDiff -> Char -> TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("insertInfinite",
+ test (insertInfinite :: TimeDiff -> Char -> NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("coincidentFlatten",
+ test (coincidentFlatten :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentGaps",
+ test (collectCoincidentGaps :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentNonEmpty",
+ test (collectCoincidentNonEmpty :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("collectCoincidentInfinite",
+ test (collectCoincidentInfinite :: NonEmptyList TimeDiff Char -> Bool)) :
+
+ ("mapCoincidentMap",
+ test (mapCoincidentMap Char.toUpper :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mapCoincidentComposition",
+ test (mapCoincidentComposition reverse reverse :: TimeTimeList.T TimeDiff Char -> Bool)) :
+ ("mapCoincidentReverse",
+ test (mapCoincidentReverse :: TimeTimeList.T TimeDiff Char -> Bool)) :
+
+ ("mapBodyMAppendRandom",
+ test (mapBodyMAppendRandom :: Int -> TimeTimeList.T TimeDiff (Char,Char) -> TimeTimeList.T TimeDiff (Char,Char) -> Bool)) :
+ ("mapBodyMInfinite",
+ test (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (Char,Char) -> Bool)) :
+
+ []
diff --git a/Test/Main.hs b/Test/Main.hs
new file mode 100644
--- /dev/null
+++ b/Test/Main.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import qualified Test.Data.EventList.Absolute.BodyEnd as AbsBodyEnd
+import qualified Test.Data.EventList.Absolute.TimeEnd as AbsTimeEnd
+import qualified Test.Data.EventList.Relative.BodyEnd as RelBodyEnd
+import qualified Test.Data.EventList.Relative.TimeEnd as RelTimeEnd
+
+prefix :: String -> [(String, IO ())] -> [(String, IO ())]
+prefix msg =
+ map (\(str,test) -> (msg ++ "." ++ str, test))
+
+main :: IO ()
+main =
+ mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $
+ concat $
+ prefix "Absolute.BodyEnd" AbsBodyEnd.tests :
+ prefix "Absolute.TimeEnd" AbsTimeEnd.tests :
+ prefix "Relative.BodyEnd" RelBodyEnd.tests :
+ prefix "Relative.TimeEnd" RelTimeEnd.tests :
+ []
diff --git a/Test/Utility.hs b/Test/Utility.hs
new file mode 100644
--- /dev/null
+++ b/Test/Utility.hs
@@ -0,0 +1,28 @@
+module Test.Utility where
+
+import Test.QuickCheck (Arbitrary(..))
+
+import qualified Numeric.NonNegative.Wrapper as NonNeg
+import Control.Monad (liftM)
+import Data.Char (chr)
+
+
+type TimeDiff = NonNeg.Int
+
+timeToDouble :: TimeDiff -> NonNeg.Double
+timeToDouble = fromIntegral
+
+makeFracTime :: (TimeDiff, TimeDiff) -> NonNeg.Double
+makeFracTime (n,d) =
+ timeToDouble n / (timeToDouble d + 1)
+
+
+instance Arbitrary Char where
+ arbitrary = liftM (chr . (32+) . flip mod 96) arbitrary
+ coarbitrary = undefined
+
+instance Arbitrary a => Arbitrary (Maybe a) where
+ arbitrary =
+ arbitrary >>=
+ \b -> if b then fmap Just arbitrary else return Nothing
+ coarbitrary = undefined
diff --git a/event-list.cabal b/event-list.cabal
new file mode 100644
--- /dev/null
+++ b/event-list.cabal
@@ -0,0 +1,60 @@
+Name: event-list
+Version: 0.0.5
+License: GPL
+License-File: LICENSE
+Author: Henning Thielemann
+Maintainer: Henning Thielemann
+Homepage: http://darcs.haskell.org/event-list/
+Category: Data Structures
+Build-Type: Simple
+Build-Depends: non-negative==0.0.1, base>=1.0, mtl, QuickCheck
+-- From the Monad Template Library we only need the State monad.
+-- If your compiler does not support functional dependencies,
+-- it would be easy to replace that by mapAccumL.
+Synopsis: Event lists with relative or absolute time stamps
+Description:
+ These lists manage events that are associated with times.
+ Times may be given as difference between successive events
+ or as absolute time values.
+ Pauses before the first and after the last event are supported.
+ The underlying data structures are lists of elements of alternating types,
+ that is [b,a,b,...,a,b] or [a,b,a,...,a,b].
+ The data structures can be used to represent
+ MIDI files, OpenSoundControl message streams, music performances etc.
+GHC-Options: -Wall
+Tested-With: GHC==6.4.1
+Hs-Source-Dirs: src
+Exposed-Modules:
+ Data.EventList.Absolute.TimeBody
+ Data.EventList.Absolute.TimeTime
+ Data.EventList.Absolute.TimeMixed
+ Data.EventList.Relative.TimeBody
+ Data.EventList.Relative.TimeTime
+ Data.EventList.Relative.TimeMixed
+ Data.EventList.Relative.BodyBody
+ Data.EventList.Relative.BodyTime
+ Data.EventList.Relative.MixedTime
+ Data.EventList.Relative.MixedBody
+Other-Modules:
+ Data.EventList.Utility
+ Data.EventList.Absolute.TimeBodyPrivate
+ Data.EventList.Absolute.TimeTimePrivate
+ Data.EventList.Relative.TimeBodyPrivate
+ Data.EventList.Relative.BodyBodyPrivate
+ Data.EventList.Relative.TimeTimePrivate
+ Data.EventList.Relative.BodyTimePrivate
+ Data.AlternatingList.Custom
+ Data.AlternatingList.List.Disparate
+ Data.AlternatingList.List.Uniform
+ Data.AlternatingList.List.Mixed
+
+Executable: test
+Hs-source-dirs: src, .
+GHC-Options: -Wall
+Main-Is: Test/Main.hs
+Other-Modules:
+ Test.Utility
+ Test.Data.EventList.Absolute.BodyEnd
+ Test.Data.EventList.Absolute.TimeEnd
+ Test.Data.EventList.Relative.BodyEnd
+ Test.Data.EventList.Relative.TimeEnd
diff --git a/src/Data/AlternatingList/Custom.hs b/src/Data/AlternatingList/Custom.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/AlternatingList/Custom.hs
@@ -0,0 +1,68 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+Lists of elements of alternating type.
+This module iuses custom data types which depend mutually.
+This looks nicer but it lacks high level optimizations.
+(They could be added, though.)
+-}
+module Data.AlternatingList.Custom where
+
+infixr 5 :>, :<
+
+{- |
+A list of elements of alternating types,
+where the types of the beginning and the end element are independent,
+namely @a@ at the beginning, @b@ at the end.
+
+Example:
+@1 :> \'a\' :< 2 :> \'b\' :< End@
+-}
+data Disparate a b =
+ a :> Uniform a b
+ | End
+
+{- |
+A list of elements of alternating types,
+where the type of the beginning and the end element is equal,
+namely @b@.
+
+Example:
+@1 :> \'a\' :< 2 :> \'b\' :< 3 :> End@
+-}
+data Uniform a b =
+ b :< Disparate a b
+
+
+
+mapDisparate ::
+ (a0 -> a1) -> (b0 -> b1) ->
+ (Disparate a0 b0 -> Disparate a1 b1)
+mapDisparate f g =
+ foldrDisparate ((:>) . f) ((:<) . g) End
+
+mapUniform ::
+ (a0 -> a1) -> (b0 -> b1) ->
+ (Uniform a0 b0 -> Uniform a1 b1)
+mapUniform f g =
+ foldrUniform ((:>) . f) ((:<) . g) End
+
+
+
+foldrDisparate ::
+ (a -> c -> d) -> (b -> d -> c) ->
+ d -> Disparate a b -> d
+foldrDisparate f g start a0 =
+ case a0 of
+ End -> start
+ a :> bas -> f a (foldrUniform f g start bas)
+
+foldrUniform ::
+ (a -> c -> d) -> (b -> d -> c) ->
+ d -> Uniform a b -> c
+foldrUniform f g start (b :< abas) =
+ g b (foldrDisparate f g start abas)
diff --git a/src/Data/AlternatingList/List/Disparate.hs b/src/Data/AlternatingList/List/Disparate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/AlternatingList/List/Disparate.hs
@@ -0,0 +1,267 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+Lists of elements of alternating type.
+This module is based on the standard list type
+and may benefit from list optimizations.
+-}
+module Data.AlternatingList.List.Disparate
+ (T,
+ fromPairList, toPairList,
+ map, mapFirst, mapSecond,
+ sequence, sequence_,
+ mapM, mapM_, mapFirstM, mapSecondM,
+ getFirsts, getSeconds, length, genericLength,
+ empty, singleton, null,
+ cons, snoc, viewL, viewR, mapHead, mapLast,
+ foldr, foldrPair,
+ format,
+ append, concat, cycle,
+ splitAt, take, drop,
+ genericSplitAt, genericTake, genericDrop,
+ spanFirst, spanSecond,
+ zipWithFirst, zipWithSecond,
+ ) where
+
+import qualified Data.EventList.Utility as Utility
+
+import Data.EventList.Utility (mapPair, mapFst, mapSnd)
+
+import qualified Data.List as List
+import qualified Control.Monad as Monad
+
+import Test.QuickCheck (Arbitrary, arbitrary, coarbitrary)
+
+import Prelude hiding
+ (null, foldr, map, concat, cycle, length, take, drop, splitAt,
+ sequence, sequence_, mapM, mapM_)
+
+
+data Pair a b =
+ Pair {pairFirst :: a,
+ pairSecond :: b}
+ deriving (Eq, Ord, Show)
+
+newtype T a b = Cons {decons :: [Pair a b]}
+ deriving (Eq, Ord)
+
+
+format :: (Show a, Show b) =>
+ String -> String -> Int -> T a b -> ShowS
+format first second p xs =
+ showParen (p>5) $
+ flip (foldr
+ (\a -> showsPrec 5 a . showString first)
+ (\b -> showsPrec 5 b . showString second))
+ xs .
+ showString "empty"
+
+instance (Show a, Show b) => Show (T a b) where
+ showsPrec = format " /. " " ./ "
+
+
+instance (Arbitrary a, Arbitrary b) =>
+ Arbitrary (Pair a b) where
+ arbitrary = Monad.liftM2 Pair arbitrary arbitrary
+ coarbitrary = undefined
+
+instance (Arbitrary a, Arbitrary b) =>
+ Arbitrary (T a b) where
+ arbitrary = Monad.liftM Cons arbitrary
+ coarbitrary = undefined
+
+
+fromPairList :: [(a,b)] -> T a b
+fromPairList = Cons . List.map (uncurry Pair)
+
+toPairList :: T a b -> [(a,b)]
+toPairList = List.map (\ ~(Pair a b) -> (a,b)) . decons
+
+
+lift :: ([Pair a0 b0] -> [Pair a1 b1]) -> (T a0 b0 -> T a1 b1)
+lift f = Cons . f . decons
+
+mapPairFirst :: (a0 -> a1) -> Pair a0 b -> Pair a1 b
+mapPairFirst f e = e{pairFirst = f (pairFirst e)}
+
+mapPairSecond :: (b0 -> b1) -> Pair a b0 -> Pair a b1
+mapPairSecond f e = e{pairSecond = f (pairSecond e)}
+
+map :: (a0 -> a1) -> (b0 -> b1) -> T a0 b0 -> T a1 b1
+map f g = lift (List.map (mapPairFirst f . mapPairSecond g))
+
+mapFirst :: (a0 -> a1) -> T a0 b -> T a1 b
+mapFirst f = lift (List.map (mapPairFirst f))
+
+mapSecond :: (b0 -> b1) -> T a b0 -> T a b1
+mapSecond g = lift (List.map (mapPairSecond g))
+
+
+
+sequence :: Monad m =>
+ T (m a) (m b) -> m (T a b)
+sequence =
+ Monad.liftM Cons .
+ Monad.mapM (\(Pair a b) -> Monad.liftM2 Pair a b) .
+ decons
+
+sequence_ :: Monad m =>
+ T (m ()) (m ()) -> m ()
+sequence_ =
+ Monad.mapM_ (\(Pair a b) -> a >> b) . decons
+
+
+mapM :: Monad m =>
+ (a0 -> m a1) -> (b0 -> m b1) ->
+ T a0 b0 -> m (T a1 b1)
+mapM aAction bAction =
+ sequence . map aAction bAction
+
+mapM_ :: Monad m =>
+ (a -> m ()) -> (b -> m ()) -> T a b -> m ()
+mapM_ aAction bAction =
+ sequence_ . map aAction bAction
+
+
+mapFirstM :: Monad m =>
+ (a0 -> m a1) -> T a0 b -> m (T a1 b)
+mapFirstM aAction =
+ mapM aAction return
+
+mapSecondM :: Monad m =>
+ (b0 -> m b1) -> T a b0 -> m (T a b1)
+mapSecondM bAction =
+ mapM return bAction
+
+
+getFirsts :: T a b -> [a]
+getFirsts = List.map pairFirst . decons
+
+getSeconds :: T a b -> [b]
+getSeconds = List.map pairSecond . decons
+
+length :: T a b -> Int
+length = List.length . getFirsts
+
+genericLength :: Integral i => T a b -> i
+genericLength = List.genericLength . getFirsts
+
+
+
+empty :: T a b
+empty = Cons []
+
+singleton :: a -> b -> T a b
+singleton a b = Cons [Pair a b]
+
+null :: T a b -> Bool
+null = List.null . decons
+
+
+cons :: a -> b -> T a b -> T a b
+cons a b = lift (Pair a b : )
+
+snoc :: T a b -> a -> b -> T a b
+snoc (Cons xs) a b = Cons (xs ++ [Pair a b])
+
+
+viewL :: T a b -> Maybe ((a, b), T a b)
+viewL (Cons ys) =
+ case ys of
+ (Pair a b : xs) -> Just ((a, b), Cons xs)
+ [] -> Nothing
+
+mapHead :: ((a,b) -> (a,b)) -> T a b -> T a b
+mapHead f =
+ maybe empty (uncurry (uncurry cons) . mapFst f) . viewL
+
+
+viewR :: T a b -> Maybe (T a b, (a, b))
+viewR =
+ fmap (mapPair (Cons, \ ~(Pair a b) -> (a, b))) .
+ Utility.viewR . decons
+
+mapLast :: ((a,b) -> (a,b)) -> T a b -> T a b
+mapLast f =
+ maybe empty (uncurry (uncurry . snoc) . mapSnd f) . viewR
+
+
+foldr :: (a -> c -> d) -> (b -> d -> c) -> d -> T a b -> d
+foldr f g =
+ foldrPair (\ a b -> f a . g b)
+
+foldrPair :: (a -> b -> c -> c) -> c -> T a b -> c
+foldrPair f x =
+ List.foldr (\ ~(Pair a b) -> f a b) x . decons
+
+
+append :: T a b -> T a b -> T a b
+append (Cons xs) = lift (xs++)
+
+concat :: [T a b] -> T a b
+concat = Cons . List.concat . List.map decons
+
+cycle :: T a b -> T a b
+cycle = Cons . List.cycle . decons
+
+
+
+{- |
+Currently it is not checked, whether n is too big.
+Don't rely on the current behaviour of @splitAt n x@ for @n > length x@.
+-}
+splitAt :: Int -> T a b -> (T a b, T a b)
+splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons
+
+take :: Int -> T a b -> T a b
+take n = Cons . List.take n . decons
+
+drop :: Int -> T a b -> T a b
+drop n = Cons . List.drop n . decons
+
+
+genericSplitAt :: Integral i => i -> T a b -> (T a b, T a b)
+genericSplitAt n = mapPair (Cons, Cons) . List.genericSplitAt n . decons
+
+genericTake :: Integral i => i -> T a b -> T a b
+genericTake n = Cons . List.genericTake n . decons
+
+genericDrop :: Integral i => i -> T a b -> T a b
+genericDrop n = Cons . List.genericDrop n . decons
+
+
+spanFirst :: (a -> Bool) -> T a b -> (T a b, T a b)
+spanFirst p =
+ mapPair (Cons, Cons) . List.span (p . pairFirst) . decons
+
+spanSecond :: (b -> Bool) -> T a b -> (T a b, T a b)
+spanSecond p =
+ mapPair (Cons, Cons) . List.span (p . pairSecond) . decons
+
+{-
+filterFirst :: (a -> Bool) -> T a b -> T a [b]
+filterFirst =
+ foldr
+ (\time ->
+ if time==0
+ then id
+ else consBody [] . consTime time)
+ (\body ->
+ maybe
+ (consBody [body] $ consTime 0 $ empty)
+ (\(bodys,xs) -> consBody (body:bodys) xs) .
+ viewBodyL)
+ empty
+-}
+
+zipWithFirst :: (a0 -> a1 -> a2) -> [a0] -> T a1 b -> T a2 b
+zipWithFirst f xs =
+ Cons . zipWith (\x (Pair a b) -> Pair (f x a) b) xs . decons
+
+zipWithSecond :: (b0 -> b1 -> b2) -> [b0] -> T a b1 -> T a b2
+zipWithSecond f xs =
+ Cons . zipWith (\x (Pair a b) -> Pair a (f x b)) xs . decons
diff --git a/src/Data/AlternatingList/List/Mixed.hs b/src/Data/AlternatingList/List/Mixed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/AlternatingList/List/Mixed.hs
@@ -0,0 +1,265 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+Functions that combine both data types,
+'Data.AlternatingList.List.Disparate.T' and
+'Data.AlternatingList.List.Uniform.T'
+-}
+module Data.AlternatingList.List.Mixed (
+ consFirst, consSecond, (./), (/.),
+ snocFirst, snocSecond,
+ viewL, viewR, viewFirstL, viewFirstR, viewSecondL, viewSecondR,
+ mapFirstL, mapFirstHead, mapFirstTail,
+ mapSecondL, mapSecondHead, mapSecondTail,
+ mapFirstR, mapFirstLast, mapFirstInit,
+ mapSecondR, mapSecondLast, mapSecondInit,
+ appendUniformUniform, appendDisparateUniform, appendUniformDisparate,
+ concatUniform, concatDisparate,
+ splitAtDisparateUniform, splitAtUniformDisparate, splitAtUniformUniform,
+ takeDisparate, takeUniform, dropDisparate, dropUniform,
+ {- spanFirst, spanSecond, spanDisparate, -}
+
+ ) where
+
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+
+import Data.AlternatingList.List.Uniform (mapSecondHead)
+
+import qualified Control.Monad as Monad
+
+import Data.EventList.Utility (mapPair, mapFst, mapSnd)
+
+import Prelude hiding
+ (null, foldr, map, concat, sequence, sequence_, mapM, mapM_)
+
+
+infixr 5 ./, /.
+
+(/.) :: a -> Uniform.T a b -> Disp.T a b
+(/.) = consFirst
+
+(./) :: b -> Disp.T a b -> Uniform.T a b
+(./) = consSecond
+
+
+consFirst :: a -> Uniform.T a b -> Disp.T a b
+consFirst a ~(Uniform.Cons b xs) = Disp.cons a b xs
+
+consSecond :: b -> Disp.T a b -> Uniform.T a b
+consSecond = Uniform.Cons
+
+
+snocFirst :: Uniform.T a b -> a -> Disp.T b a
+snocFirst xs = appendUniformUniform xs . Uniform.singleton
+-- snocFirst xs a = Uniform.foldr consSecond consFirst (Uniform.singleton a) xs
+
+snocSecond :: Disp.T b a -> b -> Uniform.T a b
+snocSecond xs = appendDisparateUniform xs . Uniform.singleton
+-- snocSecond xs b = Disp.foldr consSecond consFirst (Uniform.singleton b) xs
+
+
+viewL :: Uniform.T a b -> (b, Maybe (a, Uniform.T a b))
+viewL = mapSnd viewFirstL . viewSecondL
+
+viewFirstL :: Disp.T a b -> Maybe (a, Uniform.T a b)
+viewFirstL =
+ Monad.liftM (\((a,b), xs) -> (a, consSecond b xs)) . Disp.viewL
+
+viewSecondL :: Uniform.T a b -> (b, Disp.T a b)
+viewSecondL (Uniform.Cons b xs) = (b,xs)
+
+
+viewR :: Uniform.T a b -> (Maybe (Uniform.T a b, a), b)
+viewR (Uniform.Cons b0 xs0) =
+ maybe
+ (Nothing, b0)
+ (\ (xs, ~(a,b)) -> (Just (consSecond b0 xs, a), b)) $
+ Disp.viewR xs0
+
+viewFirstR :: Disp.T b a -> Maybe (Uniform.T a b, a)
+viewFirstR =
+ Monad.liftM (\ (xs, ~(a,b)) -> (snocSecond xs a, b)) .
+ Disp.viewR
+
+viewSecondR :: Uniform.T a b -> (Disp.T b a, b)
+viewSecondR (Uniform.Cons b0 xs0) =
+ maybe
+ (Disp.empty, b0)
+ (\ (xs, ~(a,b)) -> (consFirst b0 (snocSecond xs a), b))
+ (Disp.viewR xs0)
+
+
+-- could also be in ListDisparate
+mapFirstL ::
+ (a -> a, Uniform.T a b0 -> Uniform.T a b1) ->
+ Disp.T a b0 -> Disp.T a b1
+mapFirstL f =
+ maybe Disp.empty (uncurry consFirst . mapPair f) . viewFirstL
+
+mapFirstHead ::
+ (a -> a) ->
+ Disp.T a b -> Disp.T a b
+mapFirstHead f = mapFirstL (f,id)
+
+mapFirstTail ::
+ (Uniform.T a b0 -> Uniform.T a b1) ->
+ Disp.T a b0 -> Disp.T a b1
+mapFirstTail f = mapFirstL (id,f)
+
+
+mapSecondL ::
+ (b -> b, Disp.T a0 b -> Disp.T a1 b) ->
+ Uniform.T a0 b -> Uniform.T a1 b
+mapSecondL f = uncurry consSecond . mapPair f . viewSecondL
+
+{-
+mapSecondHead ::
+ (b -> b) ->
+ Uniform.T a b -> Uniform.T a b
+mapSecondHead f = mapSecondL (f,id)
+-}
+
+mapSecondTail ::
+ (Disp.T a0 b -> Disp.T a1 b) ->
+ Uniform.T a0 b -> Uniform.T a1 b
+mapSecondTail f = mapSecondL (id,f)
+
+
+mapFirstR ::
+ (Uniform.T a b0 -> Uniform.T a b1, a -> a) ->
+ Disp.T b0 a -> Disp.T b1 a
+mapFirstR f =
+ maybe Disp.empty (uncurry snocFirst . mapPair f) . viewFirstR
+
+-- could also be in ListDisparate
+mapFirstLast ::
+ (a -> a) ->
+ Disp.T b a -> Disp.T b a
+mapFirstLast f = mapFirstR (id,f)
+
+mapFirstInit ::
+ (Uniform.T a b0 -> Uniform.T a b1) ->
+ Disp.T b0 a -> Disp.T b1 a
+mapFirstInit f = mapFirstR (f,id)
+
+
+mapSecondR ::
+ (Disp.T b a0 -> Disp.T b a1, b -> b) ->
+ Uniform.T a0 b -> Uniform.T a1 b
+mapSecondR f = uncurry snocSecond . mapPair f . viewSecondR
+
+mapSecondLast ::
+ (b -> b) ->
+ Uniform.T a b -> Uniform.T a b
+mapSecondLast f = mapSecondR (id,f)
+
+mapSecondInit ::
+ (Disp.T b a0 -> Disp.T b a1) ->
+ Uniform.T a0 b -> Uniform.T a1 b
+mapSecondInit f = mapSecondR (f,id)
+
+
+
+
+appendUniformUniform :: Uniform.T a b -> Uniform.T b a -> Disp.T b a
+appendUniformUniform xs ys =
+ Uniform.foldr consSecond consFirst ys xs
+
+appendDisparateUniform :: Disp.T b a -> Uniform.T a b -> Uniform.T a b
+appendDisparateUniform xs ys =
+ Disp.foldr consSecond consFirst ys xs
+
+appendUniformDisparate :: Uniform.T a b -> Disp.T a b -> Uniform.T a b
+appendUniformDisparate xs ys =
+ mapSecondTail (flip Disp.append ys) xs
+
+
+concatDisparate :: Disp.T (Uniform.T b a) (Uniform.T a b) -> Disp.T a b
+concatDisparate =
+ Disp.foldr appendUniformUniform appendUniformDisparate Disp.empty
+
+concatUniform :: Uniform.T (Uniform.T b a) (Uniform.T a b) -> Uniform.T a b
+concatUniform =
+ (\(b,xs) -> appendUniformDisparate b (concatDisparate xs)) .
+ viewSecondL
+
+
+
+splitAtDisparateUniform :: Int -> Uniform.T a b -> (Disp.T b a, Uniform.T a b)
+splitAtDisparateUniform 0 = (,) Disp.empty
+splitAtDisparateUniform n =
+ (\ ~(prefix,suffix) ->
+ maybe
+ (error "splitAtDisparateUniform: empty list")
+ (mapFst (snocFirst prefix))
+ (viewFirstL suffix)) .
+ splitAtUniformDisparate (pred n)
+
+splitAtUniformDisparate :: Int -> Uniform.T a b -> (Uniform.T a b, Disp.T a b)
+splitAtUniformDisparate n (Uniform.Cons b xs) =
+ mapFst (consSecond b) $ Disp.splitAt n xs
+
+
+splitAtUniformUniform ::
+ Int -> Disp.T b a -> Maybe (Uniform.T a b, Uniform.T b a)
+splitAtUniformUniform n =
+ (\ ~(xs,ys) ->
+ fmap
+ (mapFst (snocSecond xs))
+ (viewFirstL ys)) .
+ Disp.splitAt n
+
+
+takeDisparate :: Int -> Uniform.T a b -> Disp.T b a
+takeDisparate n =
+ fst . viewSecondR . takeUniform n
+
+takeUniform :: Int -> Uniform.T a b -> Uniform.T a b
+takeUniform n (Uniform.Cons b xs) =
+ consSecond b $ Disp.take n xs
+
+dropDisparate :: Int -> Uniform.T a b -> Disp.T a b
+dropDisparate n = Disp.drop n . snd . viewSecondL
+
+dropUniform :: Int -> Uniform.T a b -> Uniform.T a b
+dropUniform 0 = id
+dropUniform n =
+ maybe (error "dropUniform: empty list") snd .
+ viewFirstL . dropDisparate (pred n)
+
+
+{-
+breakDisparateFirst :: (a -> Bool) ->
+ Disp.T a b -> (Disp.T a b, Disp.T a b)
+breakDisparateFirst p = Disp.spanFirst (not . p)
+
+breakUniformFirst :: (a -> Bool) ->
+ Uniform.T a b -> (Uniform.T a b, Disp.T a b)
+breakUniformFirst p =
+ let recurse xs0 =
+ (\(b,xs) ->
+ if p b
+ then (empty, xs0)
+ else
+ maybe
+ (\(a,ys) ->)
+ let (as,) = recurse xs
+ in ) $
+ viewSecondL xs0
+-}
+
+{-
+spanSecond :: (b -> Bool) -> Uniform.T a b -> (Uniform.T a b, Disp.T b a)
+spanSecond p (Uniform.Cons b xs) =
+ mapFst (consSecond b) (Disp.span p xs)
+
+spanDisparate :: (b -> Bool) -> Disp.T a b -> (Uniform.T b a, Uniform.T a b)
+spanDisparate p =
+ mapPair (consSecond, consSecond) . List.span (p . pairFirst) . toPairList
+-}
diff --git a/src/Data/AlternatingList/List/Uniform.hs b/src/Data/AlternatingList/List/Uniform.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/AlternatingList/List/Uniform.hs
@@ -0,0 +1,248 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+Lists of elements of alternating type.
+This module is based on the standard list type
+and may benefit from list optimizations.
+-}
+module Data.AlternatingList.List.Uniform
+ (T(Cons),
+ map, mapFirst, mapSecond,
+ sequence, sequence_, mapM, mapM_, mapFirstM, mapSecondM,
+ getFirsts, getSeconds, length, genericLength,
+ fromFirstList, fromSecondList, fromEitherList,
+ singleton, isSingleton,
+ cons, snoc, mapSecondHead,
+ foldr,
+ format,
+ filterFirst, partitionFirst, partitionMaybeFirst,
+ partitionEitherFirst, unzipEitherFirst,
+ filterSecond, partitionSecond, partitionMaybeSecond,
+ partitionEitherSecond, unzipEitherSecond,
+
+ catMaybesFirst, catMaybesSecond,
+ ) where
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+
+import qualified Control.Monad as Monad
+import qualified Data.List as List
+
+import Control.Monad (Monad, return, (>>))
+
+import Test.QuickCheck (Arbitrary, arbitrary, coarbitrary)
+
+import Data.EventList.Utility (toMaybe, mapPair, mapFst, mapSnd)
+{- this way we cannot access (:) in Hugs
+import Data.Maybe (Maybe, maybe)
+import Text.Show (Show, ShowS, showsPrec, showParen, showString)
+import Prelude
+ (Bool, Int, (.), ($), id, undefined, flip, error,
+ pred, fst, snd,
+ Eq, Ord, Show, (>))
+-}
+import Prelude hiding
+ (null, foldr, map, concat, length, sequence, sequence_, mapM, mapM_)
+
+
+{- |
+The constructor is only exported for use in "Data.AlternatingList.List.Mixed".
+-}
+data T a b = Cons {
+ _lead :: b,
+ disp :: Disp.T a b
+ }
+ deriving (Eq, Ord)
+
+
+format :: (Show a, Show b) =>
+ String -> String -> Int -> T a b -> ShowS
+format first second p xs =
+ showParen (p>5) $
+ flip (foldr
+ (\a -> showsPrec 5 a . showString first)
+ (\b -> showsPrec 5 b . showString second))
+ xs .
+ showString "empty"
+
+instance (Show a, Show b) => Show (T a b) where
+ showsPrec = format " /. " " ./ "
+
+
+instance (Arbitrary a, Arbitrary b) =>
+ Arbitrary (T a b) where
+ arbitrary = Monad.liftM2 Cons arbitrary arbitrary
+ coarbitrary = undefined
+
+
+
+map :: (a0 -> a1) -> (b0 -> b1) -> T a0 b0 -> T a1 b1
+map f g (Cons b xs) = Cons (g b) (Disp.map f g xs)
+
+mapFirst :: (a0 -> a1) -> T a0 b -> T a1 b
+mapFirst f (Cons b xs) = Cons b (Disp.mapFirst f xs)
+
+mapSecond :: (b0 -> b1) -> T a b0 -> T a b1
+mapSecond g (Cons b xs) = Cons (g b) (Disp.mapSecond g xs)
+
+
+
+sequence :: Monad m =>
+ T (m a) (m b) -> m (T a b)
+sequence (Cons b xs) =
+ Monad.liftM2 Cons b (Disp.sequence xs)
+
+sequence_ :: Monad m =>
+ T (m ()) (m ()) -> m ()
+sequence_ (Cons b xs) =
+ b >> Disp.sequence_ xs
+
+
+mapM :: Monad m =>
+ (a0 -> m a1) -> (b0 -> m b1) ->
+ T a0 b0 -> m (T a1 b1)
+mapM aAction bAction =
+ sequence . map aAction bAction
+
+mapM_ :: Monad m =>
+ (a -> m ()) -> (b -> m ()) -> T a b -> m ()
+mapM_ aAction bAction =
+ sequence_ . map aAction bAction
+
+
+mapFirstM :: Monad m =>
+ (a0 -> m a1) -> T a0 b -> m (T a1 b)
+mapFirstM aAction =
+ mapM aAction return
+
+mapSecondM :: Monad m =>
+ (b0 -> m b1) -> T a b0 -> m (T a b1)
+mapSecondM bAction =
+ mapM return bAction
+
+
+getFirsts :: T a b -> [a]
+getFirsts = Disp.getFirsts . disp
+
+getSeconds :: T a b -> [b]
+getSeconds (Cons b xs) = b : Disp.getSeconds xs
+
+length :: T a b -> Int
+length = List.length . getFirsts
+
+genericLength :: Integral i => T a b -> i
+genericLength = List.genericLength . getFirsts
+
+
+fromFirstList :: b -> [a] -> T a b
+fromFirstList b as =
+ Cons b (List.foldr (flip Disp.cons b) Disp.empty as)
+
+fromSecondList :: a -> [b] -> T a b
+fromSecondList a (b:bs) =
+ Cons b (List.foldr (Disp.cons a) Disp.empty bs)
+fromSecondList _ [] = error "fromSecondList: empty list"
+
+fromEitherList :: [Either a b] -> T a [b]
+fromEitherList =
+ List.foldr
+ (either
+ (cons [])
+ (mapSecondHead . (:)))
+ (singleton [])
+
+
+singleton :: b -> T a b
+singleton b = Cons b Disp.empty
+
+isSingleton :: T a b -> Bool
+isSingleton = Disp.null . disp
+
+
+cons :: b -> a -> T a b -> T a b
+cons b0 a ~(Cons b1 xs) = Cons b0 (Disp.cons a b1 xs)
+
+
+snoc :: T a b -> a -> b -> T a b
+snoc (Cons b0 xs) a b1 = Cons b0 (Disp.snoc xs a b1)
+
+
+mapSecondHead :: (b -> b) -> T a b -> T a b
+mapSecondHead f (Cons b xs) = Cons (f b) xs
+
+
+
+foldr :: (a -> c -> d) -> (b -> d -> c) -> d -> T a b -> c
+foldr f g d (Cons b xs) = g b $ Disp.foldr f g d xs
+
+
+
+filterFirst :: (a -> Bool) -> T a b -> T a [b]
+filterFirst p =
+ catMaybesFirst . mapFirst (\a -> toMaybe (p a) a)
+
+filterSecond :: (b -> Bool) -> T a b -> T b [a]
+filterSecond p =
+ catMaybesSecond . mapSecond (\a -> toMaybe (p a) a)
+
+partitionFirst :: (a -> Bool) -> T a b -> (T a [b], T a [b])
+partitionFirst p =
+ unzipEitherFirst .
+ mapFirst (\a -> if p a then Left a else Right a)
+
+partitionSecond :: (b -> Bool) -> T a b -> (T b [a], T b [a])
+partitionSecond p =
+ unzipEitherSecond .
+ mapSecond (\b -> if p b then Left b else Right b)
+
+partitionMaybeFirst :: (a0 -> Maybe a1) -> T a0 b -> (T a1 [b], T a0 [b])
+partitionMaybeFirst f =
+ unzipEitherFirst . mapFirst (\a0 -> maybe (Right a0) Left (f a0))
+
+partitionMaybeSecond :: (b0 -> Maybe b1) -> T a b0 -> (T b1 [a], T b0 [a])
+partitionMaybeSecond f =
+ unzipEitherSecond . mapSecond (\b0 -> maybe (Right b0) Left (f b0))
+
+partitionEitherFirst :: (a -> Either a0 a1) -> T a b -> (T a0 [b], T a1 [b])
+partitionEitherFirst f =
+ unzipEitherFirst . mapFirst f
+
+partitionEitherSecond :: (b -> Either b0 b1) -> T a b -> (T b0 [a], T b1 [a])
+partitionEitherSecond f =
+ unzipEitherSecond . mapSecond f
+
+unzipEitherFirst :: T (Either a0 a1) b -> (T a0 [b], T a1 [b])
+unzipEitherFirst =
+ foldr
+ (either
+ (mapFst . cons [])
+ (mapSnd . cons []))
+ (\b -> mapPair (mapSecondHead (b:), mapSecondHead (b:)))
+ (singleton [], singleton [])
+
+unzipEitherSecond :: T a (Either b0 b1) -> (T b0 [a], T b1 [a])
+unzipEitherSecond =
+ foldr
+ (\a -> mapPair (mapSecondHead (a:), mapSecondHead (a:)))
+ (either
+ (mapFst . cons [])
+ (mapSnd . cons []))
+ (singleton [], singleton [])
+
+catMaybesFirst :: T (Maybe a) b -> T a [b]
+catMaybesFirst =
+ foldr
+ (maybe id (cons []))
+ (mapSecondHead . (:))
+ (singleton [])
+
+catMaybesSecond :: T a (Maybe b) -> T b [a]
+catMaybesSecond =
+ foldr
+ (mapSecondHead . (:))
+ (maybe id (cons []))
+ (singleton [])
diff --git a/src/Data/EventList/Absolute/TimeBody.hs b/src/Data/EventList/Absolute/TimeBody.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Absolute/TimeBody.hs
@@ -0,0 +1,418 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Absolute.TimeBody
+ (T,
+ empty, singleton, null,
+ viewL, viewR, cons, snoc,
+ fromPairList, toPairList,
+ getTimes, getBodies, duration,
+ mapBody, mapTime,
+ mapM, mapM_, mapBodyM, mapTimeM,
+ merge, mergeBy, insert, insertBy,
+ decreaseStart, delay, filter, partition, slice, foldr, foldrPair,
+ mapMaybe, catMaybes,
+ normalize, isNormalized,
+ collectCoincident, flatten, mapCoincident,
+ append, concat, cycle,
+-- splitAtTime, takeTime, dropTime,
+ discretize, resample,
+ checkTimes,
+
+ collectCoincidentFoldr, collectCoincidentNonLazy, -- for testing
+ ) where
+
+import Data.EventList.Absolute.TimeBodyPrivate
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Data.List as List
+import qualified Data.EventList.Utility as Utility
+
+import Data.EventList.Utility
+ (mapFst, mapSnd, toMaybe, isMonotonic, isMonotonicLazy, beforeBy)
+import qualified Control.Monad as Monad
+import Control.Monad.State (State(State), evalState)
+
+import Prelude hiding (mapM, mapM_, null, foldr, filter, concat, cycle)
+
+
+empty :: T time body
+empty = Cons $ Disp.empty
+
+null :: T time body -> Bool
+null = Disp.null . decons
+
+singleton :: time -> body -> T time body
+singleton time body = Cons $ Disp.singleton time body
+
+
+cons :: time -> body -> T time body -> T time body
+cons time body = lift (Disp.cons time body)
+
+snoc :: T time body -> time -> body -> T time body
+snoc xs time body =
+ Cons $ (Disp.snoc $~ xs) time body
+-- lift (\ys -> Disp.snoc ys time body) xs
+
+
+viewL :: T time body -> Maybe ((time, body), T time body)
+viewL = fmap (mapSnd Cons) . Disp.viewL . decons
+
+viewR :: T time body -> Maybe (T time body, (time, body))
+viewR = fmap (mapFst Cons) . Disp.viewR . decons
+
+
+fromPairList :: [(a,b)] -> T a b
+fromPairList = Cons . Disp.fromPairList
+
+toPairList :: T a b -> [(a,b)]
+toPairList = Disp.toPairList . decons
+
+getBodies :: T time body -> [body]
+getBodies = Disp.getSeconds . decons
+
+getTimes :: T time body -> [time]
+getTimes = Disp.getFirsts . decons
+
+{- |
+Duration of an empty event list is considered zero.
+However, I'm not sure if this is sound.
+-}
+duration :: Num time => T time body -> time
+duration = maybe 0 (fst . snd) . viewR
+
+
+
+mapBody :: (body0 -> body1) -> T time body0 -> T time body1
+mapBody f = lift (Disp.mapSecond f)
+
+mapTime :: (time0 -> time1) -> T time0 body -> T time1 body
+mapTime f = lift (Disp.mapFirst f)
+
+
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ T time0 body0 -> m (T time1 body1)
+mapM f g = liftM (Disp.mapM f g)
+
+mapM_ :: Monad m =>
+ (time -> m ()) -> (body -> m ()) ->
+ T time body -> m ()
+mapM_ f g = Disp.mapM_ f g . decons
+
+
+mapBodyM :: Monad m =>
+ (body0 -> m body1) -> T time body0 -> m (T time body1)
+mapBodyM f = liftM (Disp.mapSecondM f)
+
+mapTimeM :: Monad m =>
+ (time0 -> m time1) -> T time0 body -> m (T time1 body)
+mapTimeM f = liftM (Disp.mapFirstM f)
+
+
+{- |
+Check whether time values are in ascending order.
+The list is processed lazily and
+times that are smaller than there predecessors are replaced by 'undefined'.
+If you would remove the 'undefined' times from the resulting list
+the times may still not be ordered.
+E.g. consider the time list @[0,3,1,2]@
+-}
+checkTimes :: (Ord time) => T time body -> T time body
+checkTimes xs =
+ lift
+ (Disp.zipWithFirst
+ (\b t -> if b then t else error "times out of order")
+ (isMonotonicLazy (getTimes xs)))
+ xs
+
+
+foldr :: (time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b
+foldr f g x = Disp.foldr f g x . decons
+
+foldrPair :: (time -> body -> a -> a) -> a -> T time body -> a
+foldrPair f x = Disp.foldrPair f x . decons
+
+
+filter :: (Num time) =>
+ (body -> Bool) -> T time body -> T time body
+filter p = mapMaybe (\b -> toMaybe (p b) b)
+
+mapMaybe :: (Num time) =>
+ (body0 -> Maybe body1) ->
+ T time body0 -> T time body1
+mapMaybe f = catMaybes . mapBody f
+
+catMaybes :: (Num time) =>
+ T time (Maybe body) -> T time body
+catMaybes =
+ foldrPair (maybe id . cons) empty
+
+{-
+Could be implemented more easily in terms of Uniform.partition
+-}
+partition ::
+ (body -> Bool) -> T time body -> (T time body, T time body)
+partition p =
+ foldrPair
+ (\ t b ->
+ (if p b then mapFst else mapSnd) (cons t b))
+ (empty, empty)
+
+{- |
+Since we need it later for MIDI generation,
+we will also define a slicing into equivalence classes of events.
+-}
+slice :: (Eq a) =>
+ (body -> a) -> T time body -> [(a, T time body)]
+slice = Utility.slice (fmap (snd . fst) . viewL) partition
+
+
+{- |
+We will also sometimes need a function which groups events by equal start times.
+This implementation is not so obvious since we work with time differences.
+The criterion is: Two neighbouring events start at the same time
+if the second one has zero time difference.
+-}
+collectCoincident :: Eq time => T time body -> T time [body]
+collectCoincident =
+ Cons .
+ maybe
+ Disp.empty
+ (uncurry $ \ t0 ->
+ Mixed.consFirst t0 .
+ Uniform.catMaybesFirst .
+ flip evalState (Just t0) .
+ Uniform.mapFirstM (\time -> State $ \ oldTime ->
+ (Monad.guard (time /= oldTime) >> time, time)) .
+ Uniform.mapFirst Just) .
+ Mixed.viewFirstL .
+ decons
+
+collectCoincidentFoldr :: Eq time => T time body -> T time [body]
+collectCoincidentFoldr =
+ Cons .
+ foldrPair
+ (\t0 b0 xs ->
+ Mixed.consFirst t0 $
+ maybe
+ (Uniform.singleton [b0])
+ (\((t1,bs),ys) ->
+ if t0 == t1
+ then Mixed.consSecond (b0:bs) ys
+ else Mixed.consSecond [b0] xs) $
+ Disp.viewL xs)
+ Disp.empty
+
+{- |
+Will fail on infinite lists.
+-}
+collectCoincidentNonLazy :: Eq time => T time body -> T time [body]
+collectCoincidentNonLazy =
+ Cons .
+ foldrPair
+ (\t0 b0 xs ->
+ maybe
+ (Disp.singleton t0 [b0])
+ (\((t1,bs),ys) ->
+ if t0 == t1
+ then Disp.cons t0 (b0:bs) ys
+ else Disp.cons t0 [b0] xs) $
+ Disp.viewL xs)
+ Disp.empty
+
+
+flatten :: (Ord time, Num time) => T time [body] -> T time body
+flatten =
+ foldrPair
+ (\t bs xs -> List.foldr (cons t) xs bs)
+ empty
+
+
+{- |
+Apply a function to the lists of coincident events.
+-}
+
+mapCoincident :: (Ord time, Num time) =>
+ ([a] -> [b]) -> T time a -> T time b
+mapCoincident f = flatten . mapBody f . collectCoincident
+
+{- |
+
+'List.sort' sorts a list of coinciding events,
+that is all events but the first one have time difference 0.
+'normalize' sorts all coinciding events in a list
+thus yielding a canonical representation of a time ordered list.
+-}
+
+normalize :: (Ord time, Num time, Ord body) => T time body -> T time body
+normalize = mapCoincident List.sort
+
+isNormalized :: (Ord time, Num time, Ord body) =>
+ T time body -> Bool
+isNormalized =
+ all isMonotonic . getBodies . collectCoincident
+
+
+{- |
+The first important function is 'merge'
+which merges the events of two lists into a new time order list.
+-}
+
+merge :: (Ord time, Ord body) =>
+ T time body -> T time body -> T time body
+merge = mergeBy (<)
+
+{- |
+Note that 'merge' compares entire events rather than just start
+times. This is to ensure that it is commutative, a desirable
+condition for some of the proofs used in \secref{equivalence}.
+It is also necessary to assert a unique representation
+of the performance independent of the structure of the 'Music.T note'.
+The same function for inserting into a time ordered list with a trailing pause.
+The strictness annotation is necessary for working with infinite lists.
+
+Here are two other functions that are already known for non-padded time lists.
+-}
+
+{-
+Could be implemented using as 'splitAt' and 'insert'.
+-}
+mergeBy :: (Ord time) =>
+ (body -> body -> Bool) ->
+ T time body -> T time body -> T time body
+mergeBy before =
+ let recurse xs0 ys0 =
+ case (viewL xs0, viewL ys0) of
+ (Nothing, _) -> ys0
+ (_, Nothing) -> xs0
+ (Just (x,xs), Just (y,ys)) ->
+ if beforeBy before x y
+ then uncurry cons x $ mergeBy before xs ys0
+ else uncurry cons y $ mergeBy before ys xs0
+ in recurse
+
+{- |
+The final critical function is @insert@,
+which inserts an event
+into an already time-ordered sequence of events.
+For instance it is used in MidiFiles to insert a @NoteOff@ event
+into a list of @NoteOn@ and @NoteOff@ events.
+-}
+
+insert :: (Ord time, Ord body) =>
+ time -> body -> T time body -> T time body
+insert = insertBy (<)
+
+
+insertBy :: (Ord time) =>
+ (body -> body -> Bool) ->
+ time -> body -> T time body -> T time body
+insertBy before t0 me0 mevs1 =
+ let mev0 = (t0, me0)
+ in maybe
+ (uncurry singleton mev0)
+ (\(mev1, mevs) ->
+ if beforeBy before mev0 mev1
+ then uncurry cons mev0 $ mevs1
+ else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) $
+ viewL mevs1
+
+
+append :: (Ord time, Num time) =>
+ T time body -> T time body -> T time body
+append xs = lift (Disp.append $~ xs) . delay (duration xs)
+
+concat :: (Ord time, Num time) =>
+ [T time body] -> T time body
+concat xs =
+ let ts = scanl (+) 0 (map duration xs)
+ in Cons $ Disp.concat $ map decons $ zipWith delay ts xs
+
+cycle :: (Ord time, Num time) =>
+ T time body -> T time body
+cycle = concat . List.repeat
+
+
+
+{-
+splitAtTime :: (Ord time, Num time) =>
+ time -> T time body -> (Uniform.T body time, T time body)
+splitAtTime t0 =
+ maybe
+ (Uniform.singleton 0, empty)
+ (\(t1,xs) ->
+ if t0<=t1
+ then (Uniform.singleton t0, consTime (t1-t0) xs)
+ else
+ (\(b,ys) -> mapFst (Uniform.cons t1 b) (splitAtTime (t0-t1) ys))
+ (viewBodyL xs)) .
+ viewTimeL
+
+takeTime :: (Ord time, Num time) =>
+ time -> T time body -> Uniform.T body time
+takeTime t = fst . splitAtTime t
+
+dropTime :: (Ord time, Num time) =>
+ time -> T time body -> T time body
+dropTime t = snd . splitAtTime t
+-}
+
+
+decreaseStart :: (Ord time, Num time) =>
+ time -> T time body -> T time body
+decreaseStart dif =
+ maybe
+ empty
+ (\((t, b), xs) ->
+ cons
+ (if t>=dif
+ then t-dif
+ else error "decreaseStart: difference too big") b
+ (mapTime (subtract dif) xs)) .
+ viewL
+
+delay :: (Ord time, Num time) =>
+ time -> T time body -> T time body
+delay dif =
+ if dif>=0
+ then mapTime (dif+)
+ else error "delay: negative delay"
+
+
+
+{- |
+
+Here are some functions for discretizing the time information.
+When converting the precise relative event times
+to the integer relative event times
+we have to prevent accumulation of rounding errors.
+We avoid this problem with a stateful conversion
+which remembers each rounding error we make.
+This rounding error is used to correct the next rounding.
+Given the relative time and duration of a note
+the function @discretizeEventM@ creates a @State@
+which computes the rounded relative time.
+It is corrected by previous rounding errors.
+
+The resulting event list may have differing time differences
+which were equal before discretization,
+but the overall timing is uniformly close to the original.
+
+-}
+
+discretize :: (RealFrac time, Integral i) =>
+ T time body -> T i body
+discretize = mapTime round
+
+resample :: (RealFrac time, Integral i) =>
+ time -> T time body -> T i body
+resample rate = discretize . mapTime (rate*)
diff --git a/src/Data/EventList/Absolute/TimeBodyPrivate.hs b/src/Data/EventList/Absolute/TimeBodyPrivate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Absolute/TimeBodyPrivate.hs
@@ -0,0 +1,36 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Absolute.TimeBodyPrivate where
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+-- import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Control.Monad as Monad
+
+
+
+newtype T time body = Cons {decons :: Disp.T time body}
+ deriving (Eq, Ord, Show)
+
+
+infixl 5 $~
+
+($~) :: (Disp.T time body -> a) -> (T time body -> a)
+($~) f = f . decons
+
+
+lift ::
+ (Disp.T time0 body0 -> Disp.T time1 body1) ->
+ (T time0 body0 -> T time1 body1)
+lift f = Cons . f . decons
+
+liftM :: Monad m =>
+ (Disp.T time0 body0 -> m (Disp.T time1 body1)) ->
+ (T time0 body0 -> m (T time1 body1))
+liftM f = Monad.liftM Cons . f . decons
diff --git a/src/Data/EventList/Absolute/TimeMixed.hs b/src/Data/EventList/Absolute/TimeMixed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Absolute/TimeMixed.hs
@@ -0,0 +1,22 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Absolute.TimeMixed
+ (snocBody, snocTime, -- (/.), (./),
+ viewTimeR, viewBodyR,
+ mapTimeInit,
+ ) where
+
+import Data.EventList.Absolute.TimeTimePrivate
+-- import qualified Data.EventList.Absolute.TimeBody as TimeBodyList
+-- import qualified Data.EventList.Absolute.TimeTime as TimeTimeList
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+-- import Data.AlternatingList.List.Mixed ((/.), (./))
diff --git a/src/Data/EventList/Absolute/TimeTime.hs b/src/Data/EventList/Absolute/TimeTime.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Absolute/TimeTime.hs
@@ -0,0 +1,284 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+Event list with absolute times starting with a time and ending with a body
+-}
+module Data.EventList.Absolute.TimeTime
+ (T,
+ pause, isPause,
+ viewL, cons, snoc,
+ mapBody, mapTime,
+ mapM, mapM_, mapBodyM, mapTimeM,
+ getTimes, getBodies, duration,
+ merge, mergeBy, insert, insertBy,
+ decreaseStart, delay, filter, partition, slice, foldr,
+ mapMaybe, catMaybes,
+ normalize, isNormalized,
+ collectCoincident, flatten, mapCoincident,
+ append, concat, cycle,
+ discretize, resample,
+ ) where
+
+import Data.EventList.Absolute.TimeTimePrivate
+import Data.EventList.Absolute.TimeBodyPrivate (($~))
+import qualified Data.EventList.Absolute.TimeBodyPrivate as TimeBodyPriv
+import qualified Data.EventList.Absolute.TimeBody as TimeBodyList
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Data.List as List
+import qualified Data.EventList.Utility as Utility
+
+import Data.EventList.Utility (mapPair, mapSnd, toMaybe, isMonotonic)
+import qualified Control.Monad as Monad
+import Control.Monad.State (State(State), evalState)
+
+import Data.Maybe (fromMaybe)
+
+import Prelude hiding
+ (null, foldr, map, filter, concat, cycle, sequence, sequence_, mapM, mapM_)
+
+
+
+pause :: time -> T time body
+pause = Cons . Uniform.singleton
+
+isPause :: T time body -> Bool
+isPause = Uniform.isSingleton . decons
+
+
+
+getBodies :: T time body -> [body]
+getBodies = Uniform.getFirsts . decons
+
+getTimes :: T time body -> [time]
+getTimes = Uniform.getSeconds . decons
+
+duration :: Num time => T time body -> time
+duration = snd . viewTimeR
+-- duration = last . getTimes
+
+
+
+cons :: time -> body -> T time body -> T time body
+cons time body = lift (Uniform.cons time body)
+
+snoc :: T time body -> body -> time -> T time body
+snoc xs body time =
+ Cons $ (Uniform.snoc $* xs) body time
+
+
+viewL :: T time body -> (time, Maybe (body, T time body))
+viewL =
+ mapSnd (fmap (mapSnd Cons) . Mixed.viewFirstL) .
+ Mixed.viewSecondL .
+ decons
+
+
+mapBody :: (body0 -> body1) -> T time body0 -> T time body1
+mapBody = lift . Uniform.mapFirst
+
+mapTime :: (time0 -> time1) -> T time0 body -> T time1 body
+mapTime = lift . Uniform.mapSecond
+
+
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ T time0 body0 -> m (T time1 body1)
+mapM f g = liftM (Uniform.mapM g f)
+
+mapM_ :: Monad m =>
+ (time -> m ()) -> (body -> m ()) ->
+ T time body -> m ()
+mapM_ f g = Uniform.mapM_ g f . decons
+
+
+mapBodyM :: Monad m =>
+ (body0 -> m body1) -> T time body0 -> m (T time body1)
+mapBodyM = liftM . Uniform.mapFirstM
+
+mapTimeM :: Monad m =>
+ (time0 -> m time1) -> T time0 body -> m (T time1 body)
+mapTimeM = liftM . Uniform.mapSecondM
+
+
+
+foldr :: (time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b
+foldr f g x = Uniform.foldr g f x . decons
+
+
+filter :: (Num time) =>
+ (body -> Bool) -> T time body -> T time body
+filter p = mapMaybe (\b -> toMaybe (p b) b)
+
+mapMaybe :: (Num time) =>
+ (body0 -> Maybe body1) ->
+ T time body0 -> T time body1
+mapMaybe f = catMaybes . mapBody f
+
+catMaybes :: (Num time) =>
+ T time (Maybe body) -> T time body
+catMaybes =
+ mapTimeInit TimeBodyList.catMaybes
+
+{-
+Could be implemented more easily in terms of Uniform.partition
+-}
+partition ::
+ (body -> Bool) -> T time body -> (T time body, T time body)
+partition p =
+ (\(xs,t) ->
+ mapPair
+ (flip snocTime t, flip snocTime t)
+ (TimeBodyList.partition p xs)) .
+ viewTimeR
+
+slice :: (Eq a, Num time) =>
+ (body -> a) -> T time body -> [(a, T time body)]
+slice =
+ Utility.slice
+ (fmap fst . snd . viewL)
+ partition
+
+
+collectCoincident :: Eq time => T time body -> T time [body]
+collectCoincident =
+ Cons .
+ (uncurry $ \ t0 ->
+ Mixed.consSecond t0 .
+ Mixed.mapFirstInit
+ (Uniform.catMaybesFirst .
+ flip evalState (Just t0) .
+ Uniform.mapFirstM (\time -> State $ \ oldTime ->
+ (Monad.guard (time /= oldTime) >> time, time)) .
+ Uniform.mapFirst Just)) .
+ Mixed.viewSecondL .
+ decons
+
+
+flatten :: (Ord time, Num time) => T time [body] -> T time body
+flatten = mapTimeInit TimeBodyList.flatten
+
+
+{- |
+Apply a function to the lists of coincident events.
+-}
+
+mapCoincident :: (Ord time, Num time) =>
+ ([a] -> [b]) -> T time a -> T time b
+mapCoincident f = flatten . mapBody f . collectCoincident
+
+{- |
+
+'List.sort' sorts a list of coinciding events,
+that is all events but the first one have time difference 0.
+'normalize' sorts all coinciding events in a list
+thus yielding a canonical representation of a time ordered list.
+-}
+
+normalize :: (Ord time, Num time, Ord body) => T time body -> T time body
+normalize = mapCoincident List.sort
+
+isNormalized :: (Ord time, Num time, Ord body) =>
+ T time body -> Bool
+isNormalized =
+ all isMonotonic . getBodies . collectCoincident
+
+
+
+merge :: (Ord time, Ord body) =>
+ T time body -> T time body -> T time body
+merge = mergeBy (<)
+
+mergeBy :: (Ord time) =>
+ (body -> body -> Bool) ->
+ T time body -> T time body -> T time body
+mergeBy before xs0 ys0 =
+ let (xs,xt) = viewTimeR xs0
+ (ys,yt) = viewTimeR ys0
+ in snocTime
+ (TimeBodyList.mergeBy before xs ys)
+ (max xt yt)
+
+insert :: (Ord time, Ord body) =>
+ time -> body -> T time body -> T time body
+insert = insertBy (<)
+
+insertBy :: (Ord time) =>
+ (body -> body -> Bool) ->
+ time -> body -> T time body -> T time body
+insertBy before t0 me0 mevs1 =
+ let mev0 = (t0, me0)
+ (t1,mxs) = viewL mevs1
+ in maybe
+ (uncurry cons mev0 $ pause (max t0 t1))
+ (\(ev1, mevs) ->
+ let mev1 = (t1,ev1)
+ in if Utility.beforeBy before mev0 mev1
+ then uncurry cons mev0 $ mevs1
+ else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs)
+ mxs
+
+
+
+append :: (Ord time, Num time) =>
+ T time body -> T time body -> T time body
+append =
+ (\(xs, t) -> lift (Mixed.appendDisparateUniform $~ xs) . delay t) .
+ viewTimeR
+
+concat :: (Ord time, Num time) =>
+ [T time body] -> T time body
+concat xs =
+ let ts0 = scanl (+) 0 (List.map duration xs)
+ (ts,dur) =
+ fromMaybe
+ (error "list of accumulated times is always non-empty")
+ (Utility.viewR ts0)
+ in snocTime
+ (TimeBodyPriv.Cons $ Disp.concat $ List.map TimeBodyPriv.decons $
+ zipWith TimeBodyList.delay ts (List.map (fst . viewTimeR) xs))
+ dur
+
+cycle :: (Ord time, Num time) =>
+ T time body -> T time body
+cycle = concat . List.repeat
+
+
+decreaseStart :: (Ord time, Num time) =>
+ time -> T time body -> T time body
+decreaseStart dif =
+ Cons .
+ (\(t, xs) ->
+ Mixed.consSecond
+ (if t>=dif
+ then t-dif
+ else error "decreaseStart: difference too big")
+ (Disp.mapSecond (subtract dif) xs)) .
+ Mixed.viewSecondL .
+ decons
+
+delay :: (Ord time, Num time) =>
+ time -> T time body -> T time body
+delay dif =
+ if dif>=0
+ then mapTime (dif+)
+ else error "delay: negative delay"
+
+
+discretize :: (RealFrac time, Integral i) =>
+ T time body -> T i body
+discretize = mapTime round
+
+resample :: (RealFrac time, Integral i) =>
+ time -> T time body -> T i body
+resample rate =
+ discretize . mapTime (rate*)
+
diff --git a/src/Data/EventList/Absolute/TimeTimePrivate.hs b/src/Data/EventList/Absolute/TimeTimePrivate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Absolute/TimeTimePrivate.hs
@@ -0,0 +1,65 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Absolute.TimeTimePrivate where
+
+import qualified Data.EventList.Absolute.TimeBodyPrivate as TimeBodyList
+
+import Data.EventList.Absolute.TimeBodyPrivate (($~))
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import Data.EventList.Utility (mapFst)
+
+import qualified Control.Monad as Monad
+
+
+newtype T time body = Cons {decons :: Uniform.T body time}
+ deriving (Eq, Ord, Show)
+
+infixl 5 $*
+
+($*) :: (Uniform.T body time -> a) -> (T time body -> a)
+($*) f = f . decons
+
+
+lift ::
+ (Uniform.T body0 time0 -> Uniform.T body1 time1) ->
+ (T time0 body0 -> T time1 body1)
+lift f = Cons . f . decons
+
+liftM :: Monad m =>
+ (Uniform.T body0 time0 -> m (Uniform.T body1 time1)) ->
+ (T time0 body0 -> m (T time1 body1))
+liftM f = Monad.liftM Cons . f . decons
+
+
+snocBody :: T time body -> body -> TimeBodyList.T time body
+snocBody xs =
+ TimeBodyList.Cons . (Mixed.snocFirst $* xs)
+
+snocTime :: TimeBodyList.T time body -> time -> T time body
+snocTime xs =
+ Cons . (Mixed.snocSecond $~ xs)
+
+
+viewTimeR :: T time body -> (TimeBodyList.T time body, time)
+viewTimeR =
+ mapFst TimeBodyList.Cons . Mixed.viewSecondR . decons
+
+viewBodyR :: TimeBodyList.T time body -> Maybe (T time body, body)
+viewBodyR =
+ fmap (mapFst Cons) . Mixed.viewFirstR . TimeBodyList.decons
+
+
+mapTimeInit ::
+ (TimeBodyList.T time body0 -> TimeBodyList.T time body1) ->
+ T time body0 -> T time body1
+mapTimeInit f = uncurry snocTime . mapFst f . viewTimeR
+
diff --git a/src/Data/EventList/Relative/BodyBody.hs b/src/Data/EventList/Relative/BodyBody.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/BodyBody.hs
@@ -0,0 +1,29 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+
+Event lists starting with a body and ending with a body.
+
+-}
+module Data.EventList.Relative.BodyBody
+ (T,
+ mapM,
+ ) where
+
+import Data.EventList.Relative.BodyBodyPrivate
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+
+import Prelude hiding (mapM)
+
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ T time0 body0 -> m (T time1 body1)
+mapM f g = liftM (Uniform.mapM f g)
+
diff --git a/src/Data/EventList/Relative/BodyBodyPrivate.hs b/src/Data/EventList/Relative/BodyBodyPrivate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/BodyBodyPrivate.hs
@@ -0,0 +1,52 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Relative.BodyBodyPrivate where
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+-- import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Control.Monad as Monad
+
+import Test.QuickCheck (Arbitrary(..))
+
+
+
+newtype T time body = Cons {decons :: Uniform.T time body}
+ deriving (Eq, Ord)
+
+instance (Show time, Show body) => Show (T time body) where
+ showsPrec p = Uniform.format " /. " " ./ " p . decons
+
+
+instance (Arbitrary time, Arbitrary body) =>
+ Arbitrary (T time body) where
+ arbitrary = Monad.liftM Cons arbitrary
+ coarbitrary = undefined
+
+
+infixl 5 $**
+
+($**) :: (Uniform.T time body -> a) -> (T time body -> a)
+($**) f = f . decons
+
+
+lift ::
+ (Uniform.T time0 body0 -> Uniform.T time1 body1) ->
+ (T time0 body0 -> T time1 body1)
+lift f = Cons . f . decons
+
+liftM :: Monad m =>
+ (Uniform.T time0 body0 -> m (Uniform.T time1 body1)) ->
+ (T time0 body0 -> m (T time1 body1))
+liftM f = Monad.liftM Cons . f . decons
+
+unlift ::
+ (T time0 body0 -> T time1 body1) ->
+ (Uniform.T time0 body0 -> Uniform.T time1 body1)
+unlift f = decons . f . Cons
diff --git a/src/Data/EventList/Relative/BodyTime.hs b/src/Data/EventList/Relative/BodyTime.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/BodyTime.hs
@@ -0,0 +1,32 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+
+Event lists starting with a body and ending with a time difference.
+
+-}
+module Data.EventList.Relative.BodyTime
+ (T, mapM, empty, ) where
+
+import Data.EventList.Relative.BodyTimePrivate
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+
+import Prelude hiding
+ (mapM)
+
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ T time0 body0 -> m (T time1 body1)
+mapM timeAction bodyAction =
+ liftM (Disp.mapM bodyAction timeAction)
+
+
+empty :: T time body
+empty = Cons Disp.empty
diff --git a/src/Data/EventList/Relative/BodyTimePrivate.hs b/src/Data/EventList/Relative/BodyTimePrivate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/BodyTimePrivate.hs
@@ -0,0 +1,70 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Relative.BodyTimePrivate where
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Control.Monad as Monad
+
+import Test.QuickCheck (Arbitrary(..))
+
+
+
+newtype T time body = Cons {decons :: Disp.T body time}
+ deriving (Eq, Ord)
+
+instance (Show time, Show body) => Show (T time body) where
+ showsPrec p = Disp.format " ./ " " /. " p . decons
+
+
+instance (Arbitrary time, Arbitrary body) =>
+ Arbitrary (T time body) where
+ arbitrary = Monad.liftM Cons arbitrary
+ coarbitrary = undefined
+
+
+infixl 5 $*~
+
+($*~) :: (Disp.T body time -> a) -> (T time body -> a)
+($*~) f = f . decons
+
+
+lift ::
+ (Disp.T body0 time0 -> Disp.T body1 time1) ->
+ (T time0 body0 -> T time1 body1)
+lift f = Cons . f . decons
+
+liftM :: Monad m =>
+ (Disp.T body0 time0 -> m (Disp.T body1 time1)) ->
+ (T time0 body0 -> m (T time1 body1))
+liftM f = Monad.liftM Cons . f . decons
+
+unlift ::
+ (T time0 body0 -> T time1 body1) ->
+ (Disp.T body0 time0 -> Disp.T body1 time1)
+unlift f = decons . f . Cons
+
+
+
+concat :: -- (NonNeg.C time) =>
+ [T time body] -> T time body
+concat =
+ Cons . Disp.concat . map decons
+
+
+cycle :: -- (NonNeg.C time) =>
+ T time body -> T time body
+cycle = lift Disp.cycle
+
+
+mapTimeLast ::
+ (time -> time) ->
+ T time body -> T time body
+mapTimeLast = lift . Mixed.mapFirstLast
diff --git a/src/Data/EventList/Relative/MixedBody.hs b/src/Data/EventList/Relative/MixedBody.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/MixedBody.hs
@@ -0,0 +1,55 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+
+Event lists starting with a body and ending with a time difference.
+
+-}
+module Data.EventList.Relative.MixedBody
+ (consBody, consTime, (/.), (./), empty,
+ viewTimeL, viewBodyL,
+ mapTimeL, mapTimeHead, mapTimeTail,
+ ) where
+
+import Data.EventList.Relative.TimeBody (empty)
+
+import qualified Data.EventList.Relative.TimeBody as TimeBodyList
+import qualified Data.EventList.Relative.BodyBody as BodyBodyList
+
+import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyPriv
+import qualified Data.EventList.Relative.BodyBodyPrivate as BodyBodyPriv
+
+import Data.EventList.Relative.TimeBodyPrivate (mapTimeL, mapTimeHead, mapTimeTail,)
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+-- import Data.AlternatingList.List.Mixed ((/.), (./))
+
+import Data.EventList.Utility (mapSnd)
+
+
+consBody, (./) :: body -> TimeBodyList.T time body -> BodyBodyList.T time body
+consBody b = BodyBodyPriv.Cons . Mixed.consSecond b . TimeBodyPriv.decons
+
+consTime, (/.) :: time -> BodyBodyList.T time body -> TimeBodyList.T time body
+consTime t = TimeBodyPriv.Cons . Mixed.consFirst t . BodyBodyPriv.decons
+
+infixr 5 /. , ./
+
+(./) = consBody
+
+(/.) = consTime
+
+viewTimeL :: TimeBodyList.T time body -> Maybe (time, BodyBodyList.T time body)
+viewTimeL =
+ fmap (mapSnd BodyBodyPriv.Cons) . Mixed.viewFirstL . TimeBodyPriv.decons
+
+viewBodyL :: BodyBodyList.T time body -> (body, TimeBodyList.T time body)
+viewBodyL = mapSnd TimeBodyPriv.Cons . Mixed.viewSecondL . BodyBodyPriv.decons
+
diff --git a/src/Data/EventList/Relative/MixedTime.hs b/src/Data/EventList/Relative/MixedTime.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/MixedTime.hs
@@ -0,0 +1,61 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+
+Event lists starting with a body and ending with a time difference.
+
+-}
+module Data.EventList.Relative.MixedTime
+ (consBody, consTime, (/.), (./), empty,
+ viewTimeL, viewBodyL,
+ mapTimeL, mapTimeHead, mapTimeTail,
+ mapBodyL, mapBodyHead, mapBodyTail,
+ ) where
+
+import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimePriv
+import Data.EventList.Relative.TimeTimePrivate as TimeTimePriv
+
+import qualified Data.EventList.Relative.BodyTime as BodyTimeList
+import qualified Data.EventList.Relative.TimeTime as TimeTimeList
+
+import Data.EventList.Relative.BodyTime (empty)
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+-- import Data.AlternatingList.List.Mixed ((/.), (./))
+
+import Data.EventList.Utility (mapSnd)
+
+import Prelude hiding
+ (null, foldr, map, filter, concat, cycle, sequence, sequence_, mapM, mapM_)
+
+
+infixr 5 /. , ./
+
+(./) :: body -> TimeTimeList.T time body -> BodyTimeList.T time body
+(./) = consBody
+
+(/.) :: time -> BodyTimeList.T time body -> TimeTimeList.T time body
+(/.) = consTime
+
+mapBodyL ::
+ (body -> body, TimeTimeList.T time0 body -> TimeTimeList.T time1 body) ->
+ BodyTimeList.T time0 body -> BodyTimeList.T time1 body
+mapBodyL = BodyTimePriv.lift . Mixed.mapFirstL . mapSnd TimeTimePriv.unlift
+
+mapBodyHead ::
+ (body -> body) ->
+ BodyTimeList.T time body -> BodyTimeList.T time body
+mapBodyHead = BodyTimePriv.lift . Mixed.mapFirstHead
+
+mapBodyTail ::
+ (TimeTimeList.T time0 body -> TimeTimeList.T time1 body) ->
+ BodyTimeList.T time0 body -> BodyTimeList.T time1 body
+mapBodyTail = BodyTimePriv.lift . Mixed.mapFirstTail . TimeTimePriv.unlift
+
diff --git a/src/Data/EventList/Relative/TimeBody.hs b/src/Data/EventList/Relative/TimeBody.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/TimeBody.hs
@@ -0,0 +1,423 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+
+Event lists starting with a time difference and ending with a body.
+
+
+The time is stored in differences between the events.
+Thus there is no increase of time information for long,
+or even infinite, streams of events.
+Further on, the time difference is stored
+in the latter of two neighbouring events.
+This is necessary for real-time computing
+where it is not known whether and when the next event happens.
+
+-}
+module Data.EventList.Relative.TimeBody
+ (T,
+ empty, singleton, null,
+ viewL, viewR, cons, snoc,
+ fromPairList, toPairList,
+ getTimes, getBodies, duration,
+ mapBody, mapTime,
+ mapM, mapM_, mapBodyM, mapTimeM,
+ foldr, foldrPair,
+ merge, mergeBy, insert, insertBy,
+ decreaseStart, delay, filter, partition, slice, span,
+ mapMaybe, catMaybes,
+ normalize, isNormalized,
+ collectCoincident, flatten, mapCoincident,
+ append, concat, cycle,
+ discretize, resample,
+ toAbsoluteEventList, fromAbsoluteEventList,
+ ) where
+
+import Data.EventList.Relative.TimeBodyPrivate
+import qualified Data.EventList.Relative.BodyBodyPrivate as BodyBodyPriv
+
+import qualified Data.EventList.Absolute.TimeBodyPrivate as AbsoluteEventPriv
+import qualified Data.EventList.Absolute.TimeBody as AbsoluteEventList
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Data.List as List
+import qualified Data.EventList.Utility as Utility
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Data.EventList.Utility (floorDiff, mapFst, mapSnd, toMaybe, isMonotonic, beforeBy)
+import Control.Monad.State (evalState, modify, get, put)
+
+import Prelude hiding (mapM, mapM_, null, foldr, filter, concat, cycle, span)
+
+
+
+empty :: T time body
+empty = Cons Disp.empty
+
+null :: T time body -> Bool
+null = Disp.null . decons
+
+singleton :: time -> body -> T time body
+singleton time body = Cons $ Disp.singleton time body
+
+
+cons :: time -> body -> T time body -> T time body
+cons time body = lift (Disp.cons time body)
+
+snoc :: T time body -> time -> body -> T time body
+snoc xs time body = Cons $ (Disp.snoc $~* xs) time body
+
+
+
+viewL :: T time body -> Maybe ((time, body), T time body)
+viewL = fmap (mapSnd Cons) . Disp.viewL . decons
+
+viewR :: T time body -> Maybe (T time body, (time, body))
+viewR = fmap (mapFst Cons) . Disp.viewR . decons
+
+
+
+fromPairList :: [(a,b)] -> T a b
+fromPairList = Cons . Disp.fromPairList
+
+toPairList :: T a b -> [(a,b)]
+toPairList = Disp.toPairList . decons
+
+getBodies :: T time body -> [body]
+getBodies = Disp.getSeconds . decons
+
+getTimes :: T time body -> [time]
+getTimes = Disp.getFirsts . decons
+
+duration :: Num time => T time body -> time
+duration = sum . getTimes
+
+
+
+mapBody :: (body0 -> body1) -> T time body0 -> T time body1
+mapBody f = lift (Disp.mapSecond f)
+
+mapTime :: (time0 -> time1) -> T time0 body -> T time1 body
+mapTime f = lift (Disp.mapFirst f)
+
+
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ T time0 body0 -> m (T time1 body1)
+mapM f g = liftM (Disp.mapM f g)
+
+mapM_ :: Monad m =>
+ (time -> m ()) -> (body -> m ()) ->
+ T time body -> m ()
+mapM_ f g = Disp.mapM_ f g . decons
+
+
+mapBodyM :: Monad m =>
+ (body0 -> m body1) -> T time body0 -> m (T time body1)
+mapBodyM f = liftM (Disp.mapSecondM f)
+
+mapTimeM :: Monad m =>
+ (time0 -> m time1) -> T time0 body -> m (T time1 body)
+mapTimeM f = liftM (Disp.mapFirstM f)
+
+
+
+
+foldr :: (time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b
+foldr f g x = Disp.foldr f g x . decons
+
+foldrPair :: (time -> body -> a -> a) -> a -> T time body -> a
+foldrPair f x = Disp.foldrPair f x . decons
+
+
+{- |
+
+The function 'partition' is somehow the inverse to 'merge'.
+It is similar to 'List.partition'.
+We could use the List function if the event times would be absolute,
+because then the events need not to be altered on splits.
+But absolute time points can't be used for infinite music
+thus we take the burden of adapting the time differences
+when an event is removed from the performance list and
+put to the list of events of a particular instrument.
+@t0@ is the time gone since the last event in the first partition,
+@t1@ is the time gone since the last event in the second partition.
+
+Note, that using 'Data.EventList.Utility.mapPair' we circumvent the following problem:
+Since the recursive call to 'partition'
+may end up with Bottom,
+pattern matching with, say \expression{(es0,es1)},
+will halt the bounding of the variables
+until the most inner call to 'partition' is finished.
+This never happens.
+If the pair constructor is made strict,
+that is we write \expression{~(es0,es1)},
+then everything works.
+Also avoiding pattern matching and
+using 'fst' and 'snd' would help.
+
+-}
+
+filter :: (Num time) =>
+ (body -> Bool) -> T time body -> T time body
+filter p = mapMaybe (\b -> toMaybe (p b) b)
+-- filter p = fst . partition p
+
+mapMaybe :: (Num time) =>
+ (body0 -> Maybe body1) ->
+ T time body0 -> T time body1
+mapMaybe f = catMaybes . mapBody f
+
+catMaybes :: (Num time) =>
+ T time (Maybe body) -> T time body
+catMaybes =
+ Cons .
+ fst . Mixed.viewSecondR .
+ Uniform.mapSecond sum .
+ Uniform.catMaybesFirst .
+ flip Mixed.snocSecond (error "catMaybes: no trailing time") .
+ decons
+
+{-
+Could be implemented more easily in terms of Uniform.partition
+-}
+partition :: (Num time) =>
+ (body -> Bool) -> T time body -> (T time body, T time body)
+partition p = partitionRec p 0 0
+
+partitionRec :: (Num time) =>
+ (body -> Bool) -> time -> time ->
+ T time body -> (T time body, T time body)
+partitionRec p =
+ let recurse t0 t1 =
+ maybe
+ (empty, empty)
+ (\ ((t, b), es) ->
+ let t0' = t0 + t
+ t1' = t1 + t
+ in if p b
+ then mapFst (cons t0' b) (recurse 0 t1' es)
+ else mapSnd (cons t1' b) (recurse t0' 0 es)) .
+ viewL
+ in recurse
+
+{- |
+Since we need it later for MIDI generation,
+we will also define a slicing into equivalence classes of events.
+-}
+slice :: (Eq a, Num time) =>
+ (body -> a) -> T time body -> [(a, T time body)]
+slice = Utility.slice (fmap (snd . fst) . viewL) partition
+
+
+span :: (body -> Bool) -> T time body -> (T time body, T time body)
+span p = Utility.mapPair (Cons, Cons) . Disp.spanSecond p . decons
+
+
+{- |
+We will also sometimes need a function which groups events by equal start times.
+This implementation is not so obvious since we work with time differences.
+The criterion is: Two neighbouring events start at the same time
+if the second one has zero time difference.
+-}
+collectCoincident :: (NonNeg.C time) => T time body -> T time [body]
+collectCoincident =
+ mapTimeTail $ BodyBodyPriv.lift $ Uniform.filterFirst (0<)
+
+flatten :: (NonNeg.C time) => T time [body] -> T time body
+flatten =
+ Cons .
+ maybe
+ Disp.empty
+ (uncurry $ \time ->
+ unlift (delay time) .
+ fst . Mixed.viewSecondR .
+ Uniform.foldr
+ (Mixed.appendUniformUniform . Uniform.fromSecondList 0)
+ Mixed.consSecond Disp.empty .
+ Uniform.mapSecond sum .
+ Uniform.filterSecond (not . List.null)) .
+ Mixed.viewFirstL .
+ decons
+
+
+{- |
+Apply a function to the lists of coincident events.
+-}
+
+mapCoincident :: (NonNeg.C time) =>
+ ([a] -> [b]) -> T time a -> T time b
+mapCoincident f = flatten . mapBody f . collectCoincident
+
+{- |
+
+
+'List.sort' sorts a list of coinciding events,
+that is all events but the first one have time difference 0.
+'normalize' sorts all coinciding events in a list
+thus yielding a canonical representation of a time ordered list.
+-}
+
+normalize :: (NonNeg.C time, Ord body) => T time body -> T time body
+normalize = mapCoincident List.sort
+
+isNormalized :: (NonNeg.C time, Ord body) =>
+ T time body -> Bool
+isNormalized =
+ all isMonotonic . getBodies . collectCoincident
+
+
+
+{- |
+The first important function is 'merge'
+which merges the events of two lists into a new time order list.
+-}
+
+merge :: (NonNeg.C time, Ord body) =>
+ T time body -> T time body -> T time body
+merge = mergeBy (<)
+
+{- |
+Note that 'merge' compares entire events rather than just start
+times. This is to ensure that it is commutative, a desirable
+condition for some of the proofs used in \secref{equivalence}.
+It is also necessary to assert a unique representation
+of the performance independent of the structure of the 'Music.T note'.
+The same function for inserting into a time ordered list with a trailing pause.
+The strictness annotation is necessary for working with infinite lists.
+
+Here are two other functions that are already known for non-padded time lists.
+-}
+
+{-
+Could be implemented using as 'splitAt' and 'insert'.
+-}
+mergeBy :: (NonNeg.C time) =>
+ (body -> body -> Bool) ->
+ T time body -> T time body -> T time body
+mergeBy before xs0 ys0 =
+ case (viewL xs0, viewL ys0) of
+ (Nothing, _) -> ys0
+ (_, Nothing) -> xs0
+ (Just (x@(xt,xb),xs), Just (y@(yt,yb),ys)) ->
+ if beforeBy before x y
+ then uncurry cons x $ mergeBy before xs $ cons (yt-xt) yb ys
+ else uncurry cons y $ mergeBy before ys $ cons (xt-yt) xb xs
+
+
+{- |
+The final critical function is @insert@,
+which inserts an event
+into an already time-ordered sequence of events.
+For instance it is used in MidiFiles to insert a @NoteOff@ event
+into a list of @NoteOn@ and @NoteOff@ events.
+-}
+
+insert :: (NonNeg.C time, Ord body) =>
+ time -> body -> T time body -> T time body
+insert t0 me0 =
+ maybe
+ (singleton t0 me0)
+ (\(mev1@(t1, me1), mevs) ->
+ let mev0 = (t0, me0)
+ in if mev0 < mev1
+ then uncurry cons mev0 $ cons (t1-t0) me1 mevs
+ else uncurry cons mev1 $ insert (t0-t1) me0 mevs)
+ . viewL
+
+
+
+insertBy :: (NonNeg.C time, Ord body) =>
+ (body -> body -> Bool) ->
+ time -> body -> T time body -> T time body
+insertBy before t0 me0 =
+ maybe
+ (singleton t0 me0)
+ (\(mev1@(t1, me1), mevs) ->
+ if beforeBy before (t0, me0) mev1
+ then cons t0 me0 $ cons (t1-t0) me1 mevs
+ else cons t1 me1 $ insert (t0-t1) me0 mevs)
+ . viewL
+
+
+append :: T time body -> T time body -> T time body
+append xs = lift (Disp.append $~* xs)
+
+concat :: [T time body] -> T time body
+concat = Cons . Disp.concat . map decons
+
+cycle :: T time body -> T time body
+cycle = lift Disp.cycle
+
+
+
+decreaseStart :: (NonNeg.C time) =>
+ time -> T time body -> T time body
+decreaseStart dif =
+ mapTimeHead (subtract dif)
+
+delay :: (NonNeg.C time) =>
+ time -> T time body -> T time body
+delay dif =
+ mapTimeHead (dif+)
+
+
+
+{- |
+We provide 'discretize' and 'resample' for discretizing the time information.
+When converting the precise relative event times
+to the integer relative event times
+we have to prevent accumulation of rounding errors.
+We avoid this problem with a stateful conversion
+which remembers each rounding error we make.
+This rounding error is used to correct the next rounding.
+Given the relative time and duration of an event
+the function 'floorDiff' creates a 'Control.Monad.State.State'
+which computes the rounded relative time.
+It is corrected by previous rounding errors.
+
+The resulting event list may have differing time differences
+which were equal before discretization,
+but the overall timing is uniformly close to the original.
+
+We use 'floorDiff' rather than 'Utility.roundDiff'
+in order to compute exclusively with non-negative numbers.
+-}
+
+discretize :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>
+ T time body -> T i body
+discretize =
+ flip evalState 0.5 . mapTimeM floorDiff
+
+resample :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>
+ time -> T time body -> T i body
+resample rate =
+ discretize . mapTime (rate*)
+
+
+{- |
+We tried hard to compute everything with respect to relative times.
+However sometimes we need absolute time values.
+-}
+toAbsoluteEventList :: (Num time) =>
+ time -> T time body -> AbsoluteEventList.T time body
+toAbsoluteEventList start =
+ AbsoluteEventPriv.Cons . decons .
+ flip evalState start .
+ mapTimeM (\dur -> modify (dur+) >> get)
+
+fromAbsoluteEventList :: (Num time) =>
+ AbsoluteEventList.T time body -> T time body
+fromAbsoluteEventList =
+ flip evalState 0 .
+ mapTimeM
+ (\time -> do lastTime <- get; put time; return (time-lastTime)) .
+ Cons . AbsoluteEventPriv.decons
diff --git a/src/Data/EventList/Relative/TimeBodyPrivate.hs b/src/Data/EventList/Relative/TimeBodyPrivate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/TimeBodyPrivate.hs
@@ -0,0 +1,75 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Relative.TimeBodyPrivate where
+
+import qualified Data.EventList.Relative.BodyBodyPrivate as BodyBodyList
+import qualified Data.EventList.Relative.BodyBodyPrivate as BodyBodyPriv
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+-- import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Control.Monad as Monad
+
+import Data.EventList.Utility (mapSnd)
+
+import Test.QuickCheck (Arbitrary(..))
+
+
+
+newtype T time body = Cons {decons :: Disp.T time body}
+ deriving (Eq, Ord)
+
+
+instance (Show time, Show body) => Show (T time body) where
+ showsPrec p = Disp.format " /. " " ./ " p . decons
+
+
+instance (Arbitrary time, Arbitrary body) =>
+ Arbitrary (T time body) where
+ arbitrary = Monad.liftM Cons arbitrary
+ coarbitrary = undefined
+
+
+infixl 5 $~*
+
+($~*) :: (Disp.T time body -> a) -> (T time body -> a)
+($~*) f = f . decons
+
+
+lift ::
+ (Disp.T time0 body0 -> Disp.T time1 body1) ->
+ (T time0 body0 -> T time1 body1)
+lift f = Cons . f . decons
+
+liftM :: Monad m =>
+ (Disp.T time0 body0 -> m (Disp.T time1 body1)) ->
+ (T time0 body0 -> m (T time1 body1))
+liftM f = Monad.liftM Cons . f . decons
+
+unlift ::
+ (T time0 body0 -> T time1 body1) ->
+ (Disp.T time0 body0 -> Disp.T time1 body1)
+unlift f = decons . f . Cons
+
+
+
+mapTimeL ::
+ (time -> time, BodyBodyList.T time body0 -> BodyBodyList.T time body1) ->
+ T time body0 -> T time body1
+mapTimeL = lift . Mixed.mapFirstL . mapSnd BodyBodyPriv.unlift
+
+mapTimeHead ::
+ (time -> time) ->
+ T time body -> T time body
+mapTimeHead = lift . Mixed.mapFirstHead
+
+mapTimeTail ::
+ (BodyBodyList.T time body0 -> BodyBodyList.T time body1) ->
+ T time body0 -> T time body1
+mapTimeTail = lift . Mixed.mapFirstTail . BodyBodyPriv.unlift
diff --git a/src/Data/EventList/Relative/TimeMixed.hs b/src/Data/EventList/Relative/TimeMixed.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/TimeMixed.hs
@@ -0,0 +1,121 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+
+Event lists starting with a body and ending with a time difference.
+
+-}
+module Data.EventList.Relative.TimeMixed
+ (snocBody, snocTime,
+-- (/.), (./),
+ viewTimeR, viewBodyR,
+ mapTimeR, mapTimeLast, mapTimeInit,
+ mapBodyR, mapBodyLast, mapBodyInit,
+ appendBodyEnd, prependBodyEnd,
+ splitAtTime, takeTime, dropTime,
+ ) where
+
+import qualified Data.EventList.Relative.TimeBody as TimeBodyList
+import qualified Data.EventList.Relative.TimeTime as TimeTimeList
+
+import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyPriv
+import qualified Data.EventList.Relative.TimeTimePrivate as TimeTimePriv
+-- import Data.EventList.Relative.TimeBodyPrivate (($~*))
+
+import Data.EventList.Relative.TimeTimePrivate
+ (viewTimeR, viewBodyR, mapTimeR, mapTimeLast, mapTimeInit)
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+-- import Data.AlternatingList.List.Mixed ((/.), (./))
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Data.EventList.Utility (mapFst, mapPair)
+
+
+snocBody :: TimeTimeList.T time body -> body -> TimeBodyList.T time body
+snocBody xs = TimeBodyPriv.Cons . Mixed.snocFirst (TimeTimePriv.decons xs)
+
+snocTime :: TimeBodyList.T time body -> time -> TimeTimeList.T time body
+snocTime xs = TimeTimePriv.Cons . Mixed.snocSecond (TimeBodyPriv.decons xs)
+
+
+
+mapBodyR ::
+ (TimeTimeList.T time0 body -> TimeTimeList.T time1 body, body -> body) ->
+ TimeBodyList.T time0 body -> TimeBodyList.T time1 body
+mapBodyR = TimeBodyPriv.lift . Mixed.mapFirstR . mapFst TimeTimePriv.unlift
+
+mapBodyLast ::
+ (body -> body) ->
+ TimeBodyList.T time body -> TimeBodyList.T time body
+mapBodyLast = TimeBodyPriv.lift . Mixed.mapFirstLast
+
+mapBodyInit ::
+ (TimeTimeList.T time0 body -> TimeTimeList.T time1 body) ->
+ TimeBodyList.T time0 body -> TimeBodyList.T time1 body
+mapBodyInit = TimeBodyPriv.lift . Mixed.mapFirstInit . TimeTimePriv.unlift
+
+
+{-
+propInsertPadded :: Event time body -> T time body -> Bool
+propInsertPadded (Event time body) evs =
+ TimeBodyList.insert time body (fst evs) == fst (insert time body evs)
+-}
+
+{- |
+This is not a good name, expect a change.
+-}
+appendBodyEnd :: (NonNeg.C time) =>
+ TimeTimeList.T time body -> TimeBodyList.T time body -> TimeBodyList.T time body
+appendBodyEnd =
+ (\ ~(xs, t) -> TimeBodyList.append xs . TimeBodyList.delay t) .
+ viewTimeR
+
+{- |
+This is not a good name, expect a change.
+-}
+prependBodyEnd ::
+ TimeBodyList.T time body -> TimeTimeList.T time body -> TimeTimeList.T time body
+prependBodyEnd =
+ TimeTimePriv.lift . Mixed.appendDisparateUniform . TimeBodyPriv.decons
+
+
+
+splitAtTimeAux :: (NonNeg.C time) =>
+ time -> Disp.T time body ->
+ (Uniform.T body time, Disp.T time body)
+splitAtTimeAux t0 =
+ maybe
+ (Uniform.singleton 0, Disp.empty)
+ (\(t1,xs) ->
+ if t0<=t1
+ then (Uniform.singleton t0, Mixed.consFirst (t1-t0) xs)
+ else
+ (\(b,ys) -> mapFst (Uniform.cons t1 b) (splitAtTimeAux (t0-t1) ys))
+ (Mixed.viewSecondL xs)) .
+ Mixed.viewFirstL
+
+splitAtTime :: (NonNeg.C time) =>
+ time -> TimeBodyList.T time body ->
+ (TimeTimeList.T time body, TimeBodyList.T time body)
+splitAtTime t0 =
+ mapPair (TimeTimePriv.Cons, TimeBodyPriv.Cons) .
+ splitAtTimeAux t0 .
+ TimeBodyPriv.decons
+
+takeTime :: (NonNeg.C time) =>
+ time -> TimeBodyList.T time body -> TimeTimeList.T time body
+takeTime t = fst . splitAtTime t
+
+dropTime :: (NonNeg.C time) =>
+ time -> TimeBodyList.T time body -> TimeBodyList.T time body
+dropTime t = snd . splitAtTime t
+
+
diff --git a/src/Data/EventList/Relative/TimeTime.hs b/src/Data/EventList/Relative/TimeTime.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/TimeTime.hs
@@ -0,0 +1,414 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+
+Event lists starting with a time difference and ending with a time difference.
+-}
+module Data.EventList.Relative.TimeTime
+ (T,
+ mapBody, mapTime,
+ mapM, mapM_, mapBodyM, mapTimeM,
+ getTimes, getBodies, duration,
+ merge, mergeBy, insert,
+ decreaseStart, delay, filter, partition, slice, foldr,
+ pause, isPause, cons, snoc, viewL, viewR,
+ mapMaybe, catMaybes,
+ append, concat, concatNaive, cycle, cycleNaive,
+ splitAtTime, takeTime, dropTime,
+ discretize, resample,
+ collectCoincident, flatten, mapCoincident,
+ normalize, isNormalized,
+ toAbsoluteEventList, fromAbsoluteEventList,
+ ) where
+
+import Data.EventList.Relative.TimeTimePrivate as TimeTimePriv
+import Data.EventList.Relative.TimeBodyPrivate (($~*))
+
+import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimePriv
+import qualified Data.EventList.Relative.TimeBody as TimeBodyList
+
+import qualified Data.EventList.Absolute.TimeTimePrivate as AbsoluteEventPriv
+import qualified Data.EventList.Absolute.TimeTime as AbsoluteEventList
+
+import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import qualified Data.List as List
+import qualified Data.EventList.Utility as Utility
+
+import qualified Numeric.NonNegative.Class as NonNeg
+import Data.EventList.Utility (floorDiff, mapPair, mapFst, mapSnd, toMaybe, isMonotonic)
+import qualified Control.Monad.State as Monad
+import Control.Monad.State (evalState, modify, get, put)
+
+import Prelude hiding
+ (null, foldr, map, filter, concat, cycle, sequence, sequence_, mapM, mapM_)
+
+
+
+pause :: time -> T time body
+pause = Cons . Uniform.singleton
+
+isPause :: T time body -> Bool
+isPause = Uniform.isSingleton . decons
+
+
+
+getBodies :: T time body -> [body]
+getBodies = Uniform.getFirsts . decons
+
+getTimes :: T time body -> [time]
+getTimes = Uniform.getSeconds . decons
+
+duration :: Num time => T time body -> time
+duration = sum . getTimes
+
+
+
+cons :: time -> body -> T time body -> T time body
+cons time body = lift (Uniform.cons time body)
+
+snoc :: T time body -> body -> time -> T time body
+snoc xs body time =
+ Cons $ (Uniform.snoc $~~ xs) body time
+
+
+viewL :: T time body -> (time, Maybe (body, T time body))
+viewL =
+ mapSnd (fmap (mapSnd Cons)) .
+ Mixed.viewL .
+ decons
+
+viewR :: T time body -> (Maybe (T time body, body), time)
+viewR =
+ mapFst (fmap (mapFst Cons)) . Mixed.viewR . decons
+
+
+mapBody :: (body0 -> body1) -> T time body0 -> T time body1
+mapBody = lift . Uniform.mapFirst
+
+mapTime :: (time0 -> time1) -> T time0 body -> T time1 body
+mapTime = lift . Uniform.mapSecond
+
+
+
+mapM :: Monad m =>
+ (time0 -> m time1) -> (body0 -> m body1) ->
+ T time0 body0 -> m (T time1 body1)
+mapM f g = liftM (Uniform.mapM g f)
+
+mapM_ :: Monad m =>
+ (time -> m ()) -> (body -> m ()) ->
+ T time body -> m ()
+mapM_ f g = Uniform.mapM_ g f . decons
+
+
+mapBodyM :: Monad m =>
+ (body0 -> m body1) -> T time body0 -> m (T time body1)
+mapBodyM = liftM . Uniform.mapFirstM
+
+mapTimeM :: Monad m =>
+ (time0 -> m time1) -> T time0 body -> m (T time1 body)
+mapTimeM = liftM . Uniform.mapSecondM
+
+
+
+{- |
+Sort coincident elements.
+-}
+normalize :: (Ord body, NonNeg.C time) =>
+ T time body -> T time body
+normalize = mapCoincident List.sort
+
+isNormalized :: (NonNeg.C time, Ord body) =>
+ T time body -> Bool
+isNormalized =
+ all isMonotonic . getBodies . collectCoincident
+
+
+{- |
+The first important function is 'merge'
+which merges the events of two lists into a new time order list.
+-}
+
+merge :: (NonNeg.C time, Ord body) =>
+ T time body -> T time body -> T time body
+merge = mergeBy (<)
+
+{-
+Could be implemented using as 'splitAt' and 'insert'.
+-}
+mergeBy :: (NonNeg.C time) =>
+ (body -> body -> Bool) ->
+ T time body -> T time body -> T time body
+mergeBy before xs0 ys0 =
+ let (xt,xs) = viewTimeL xs0
+ (yt,ys) = viewTimeL ys0
+ in case compare xt yt of
+ LT -> mergeFirstBy before xs0 ys0
+ GT -> mergeFirstBy before ys0 xs0
+ EQ ->
+ consTime xt $
+ case (viewBodyL xs, viewBodyL ys) of
+ (Nothing, _) -> ys
+ (_, Nothing) -> xs
+ (Just (b0,xs1), Just (b1,ys1)) ->
+ {- do not insert both b0 and b1 immediately,
+ because the later one of b0 and b1 may be pushed even further,
+ thus recurse with 'mergeBy' on xs or ys -}
+ if before b0 b1
+ then consBody b0 $ mergeBy before xs1 $ consTime 0 ys
+ else consBody b1 $ mergeBy before ys1 $ consTime 0 xs
+
+{- | merge two time ordered lists provided that e0 is earlier than e1 -}
+mergeFirstBy :: (NonNeg.C time) =>
+ (body -> body -> Bool) ->
+ T time body -> T time body -> T time body
+mergeFirstBy before xs0 ys0 =
+ let (xt,xs) = viewTimeL xs0
+ (yt,ys) = viewTimeL ys0
+ in maybe
+ ys0
+ (\(b,xs1) ->
+ consTime xt $ consBody b $ mergeBy before xs1 $ consTime (yt-xt) ys)
+ (viewBodyL xs)
+
+
+{- |
+Note that 'merge' compares entire events rather than just start
+times. This is to ensure that it is commutative, a desirable
+condition for some of the proofs used in \secref{equivalence}.
+It is also necessary to assert a unique representation
+of the performance independent of the structure of the 'Music.T note'.
+The same function for inserting into a time ordered list with a trailing pause.
+The strictness annotation is necessary for working with infinite lists.
+
+Here are two other functions that are already known for non-padded time lists.
+-}
+
+insert :: (NonNeg.C time, Ord body) =>
+ time -> body -> T time body -> T time body
+insert = insertBy (<)
+
+{-
+Ordering of bodies at the same time
+could be simplified using collectCoincident.
+-}
+insertBy :: (NonNeg.C time) =>
+ (body -> body -> Bool) ->
+ time -> body -> T time body -> T time body
+insertBy before t0 me0 =
+ let recurseTime t =
+ (\ (t1,xs) ->
+ if t
+ consTime t1 $
+ if t==t1 && before me0 me1
+ then consBody me0 (cons 0 me1 xs)
+ else consBody me1 (recurseTime (t-t1) xs))
+ . viewBodyL
+ in recurseTime t0
+
+append :: (NonNeg.C time) =>
+ T time body -> T time body -> T time body
+append =
+ (\(xs, t) -> lift (Mixed.appendDisparateUniform $~* xs) . delay t) .
+ viewTimeR
+
+concat :: (NonNeg.C time) =>
+ [T time body] -> T time body
+concat =
+ flatten . consTime 0 .
+ BodyTimePriv.concat .
+ List.map (consBody [] . mapBody (:[]))
+
+{- |
+'concat' and 'concatNaive' are essentially the same.
+'concat' must use 'foldr' in order to work on infinite lists,
+however if there are many empty lists,
+summing of their durations will be done from right to left,
+which is inefficient.
+Thus we detect subsequent empty lists and merge them from left to right.
+-}
+concatNaive :: (NonNeg.C time) =>
+ [T time body] -> T time body
+concatNaive = List.foldr append (pause 0)
+
+
+{- |
+Uses sharing.
+-}
+cycle :: (NonNeg.C time) =>
+ T time body -> T time body
+cycle =
+ (\(t0,xs) ->
+ consTime t0 $
+ BodyTimePriv.cycle $
+ BodyTimePriv.mapTimeLast (+t0) xs) .
+ viewTimeL
+
+
+cycleNaive :: (NonNeg.C time) =>
+ T time body -> T time body
+cycleNaive = concat . List.repeat
+
+
+
+{- |
+If there is an event at the cutting time,
+this event is returned in the suffix part.
+That is
+@splitAtTime t0 (t0 ./ x /. t1 ./ empty) ==
+ (pause t0, 0 ./ x /. t1 ./ empty)@
+-}
+{-
+It could also be implemented by inserting a marker element
+and then splitting at this element.
+I hope that the current manual recursion routine is the most efficient solution.
+-}
+splitAtTime :: (NonNeg.C time) =>
+ time -> T time body -> (T time body, T time body)
+splitAtTime t0 =
+ (\(t1,xs) ->
+ if t0<=t1
+ then (pause t0, consTime (t1-t0) xs)
+ else
+ maybe
+ (pause t1, pause 0)
+ (\(b,ys) -> mapFst (cons t1 b) (splitAtTime (t0-t1) ys))
+ (viewBodyL xs)) .
+ viewTimeL
+
+takeTime :: (NonNeg.C time) =>
+ time -> T time body -> T time body
+takeTime t = fst . splitAtTime t
+
+dropTime :: (NonNeg.C time) =>
+ time -> T time body -> T time body
+dropTime t = snd . splitAtTime t
+
+
+decreaseStart :: (NonNeg.C time) =>
+ time -> T time body -> T time body
+decreaseStart dif =
+ mapTimeHead (subtract dif)
+
+delay :: (NonNeg.C time) =>
+ time -> T time body -> T time body
+delay dif =
+ mapTimeHead (dif+)
+
+{- |
+
+-}
+
+collectCoincident :: (NonNeg.C time) => T time body -> T time [body]
+collectCoincident =
+ mapTimeInit TimeBodyList.collectCoincident
+
+
+flatten :: (Num time) => T time [body] -> T time body
+flatten =
+ Cons .
+ Uniform.foldr
+ (Mixed.appendUniformUniform . Uniform.fromSecondList 0)
+ Mixed.consSecond -- consTime
+ Disp.empty .
+-- (\(b:bs) xs -> consBody b (List.foldr (cons 0) xs bs)) empty .
+ Uniform.mapSecond sum .
+ Uniform.filterFirst (not . List.null) .
+ decons
+
+
+
+mapCoincident :: (NonNeg.C time) =>
+ ([a] -> [b]) -> T time a -> T time b
+mapCoincident f =
+ flatten . mapBody f . collectCoincident
+
+
+{- |
+Analogously to the 'concat' \/ 'concatNaive' pair
+we have to versions of 'filter',
+where the clever implementation sums up pauses
+from the beginning to the end.
+-}
+
+filter :: (Num time) =>
+ (body -> Bool) ->
+ T time body -> T time body
+filter p = mapMaybe (\b -> toMaybe (p b) b)
+
+mapMaybe :: (Num time) =>
+ (body0 -> Maybe body1) ->
+ T time body0 -> T time body1
+mapMaybe f = catMaybes . mapBody f
+
+catMaybes :: (Num time) =>
+ T time (Maybe body) -> T time body
+catMaybes = mapTime sum . lift Uniform.catMaybesFirst
+
+partition :: (Num time) =>
+ (body -> Bool) ->
+ T time body -> (T time body, T time body)
+partition p =
+ mapPair (mapTime sum, mapTime sum) .
+ mapPair (Cons, Cons) .
+ Uniform.partitionFirst p .
+ decons
+
+{- |
+Since we need it later for MIDI generation,
+we will also define a slicing into equivalence classes of events.
+-}
+slice :: (Eq a, Num time) =>
+ (body -> a) -> T time body -> [(a, T time body)]
+slice = Utility.slice (fmap fst . viewBodyL . snd . viewTimeL) partition
+
+{- |
+
+-}
+
+foldr :: (time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b
+foldr f g x = Uniform.foldr g f x . decons
+
+{- |
+
+-}
+
+
+discretize :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>
+ T time body -> T i body
+discretize =
+ flip evalState 0.5 . mapTimeM floorDiff
+
+resample :: (NonNeg.C time, RealFrac time, NonNeg.C i, Integral i) =>
+ time -> T time body -> T i body
+resample rate =
+ discretize . mapTime (rate*)
+
+
+toAbsoluteEventList :: (Num time) =>
+ time -> T time body -> AbsoluteEventList.T time body
+toAbsoluteEventList start =
+ AbsoluteEventPriv.Cons . decons .
+ flip evalState start .
+ mapTimeM (\dur -> modify (dur+) >> get)
+
+fromAbsoluteEventList :: (Num time) =>
+ AbsoluteEventList.T time body -> T time body
+fromAbsoluteEventList =
+ flip evalState 0 .
+ mapTimeM
+ (\time -> do lastTime <- get; put time; return (time-lastTime)) .
+ Cons . AbsoluteEventPriv.decons
diff --git a/src/Data/EventList/Relative/TimeTimePrivate.hs b/src/Data/EventList/Relative/TimeTimePrivate.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Relative/TimeTimePrivate.hs
@@ -0,0 +1,114 @@
+{- |
+Copyright : (c) Henning Thielemann 2007
+
+Maintainer : haskell@henning-thielemann.de
+Stability : stable
+Portability : Haskell 98
+-}
+module Data.EventList.Relative.TimeTimePrivate where
+
+import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyList
+import qualified Data.EventList.Relative.TimeBodyPrivate as TimeBodyPriv
+
+import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimeList
+import qualified Data.EventList.Relative.BodyTimePrivate as BodyTimePriv
+
+-- import qualified Data.AlternatingList.List.Disparate as Disp
+import qualified Data.AlternatingList.List.Uniform as Uniform
+import qualified Data.AlternatingList.List.Mixed as Mixed
+
+import Data.EventList.Utility (mapFst, mapSnd)
+
+import qualified Control.Monad as Monad
+
+import Test.QuickCheck (Arbitrary(..))
+
+
+
+newtype T time body = Cons {decons :: Uniform.T body time}
+ deriving (Eq, Ord)
+
+
+instance (Show time, Show body) => Show (T time body) where
+ showsPrec p = Uniform.format " ./ " " /. " p . decons
+
+instance (Arbitrary time, Arbitrary body) =>
+ Arbitrary (T time body) where
+ arbitrary = Monad.liftM Cons arbitrary
+ coarbitrary = undefined
+
+
+infixl 5 $~~
+
+($~~) :: (Uniform.T body time -> a) -> (T time body -> a)
+($~~) f = f . decons
+
+
+lift ::
+ (Uniform.T body0 time0 -> Uniform.T body1 time1) ->
+ (T time0 body0 -> T time1 body1)
+lift f = Cons . f . decons
+
+liftM :: Monad m =>
+ (Uniform.T body0 time0 -> m (Uniform.T body1 time1)) ->
+ (T time0 body0 -> m (T time1 body1))
+liftM f = Monad.liftM Cons . f . decons
+
+unlift ::
+ (T time0 body0 -> T time1 body1) ->
+ (Uniform.T body0 time0 -> Uniform.T body1 time1)
+unlift f = decons . f . Cons
+
+
+
+
+consBody :: body -> T time body -> BodyTimeList.T time body
+consBody b = BodyTimePriv.Cons . Mixed.consFirst b . decons
+
+consTime :: time -> BodyTimeList.T time body -> T time body
+consTime t = Cons . Mixed.consSecond t . BodyTimePriv.decons
+
+viewTimeL :: T time body -> (time, BodyTimeList.T time body)
+viewTimeL = mapSnd BodyTimePriv.Cons . Mixed.viewSecondL . decons
+
+viewBodyL :: BodyTimeList.T time body -> Maybe (body, T time body)
+viewBodyL = fmap (mapSnd Cons) . Mixed.viewFirstL . BodyTimePriv.decons
+
+
+viewTimeR :: T time body -> (TimeBodyList.T time body, time)
+viewTimeR = mapFst TimeBodyPriv.Cons . Mixed.viewSecondR . decons
+
+viewBodyR :: TimeBodyList.T time body -> Maybe (T time body, body)
+viewBodyR = fmap (mapFst Cons) . Mixed.viewFirstR . TimeBodyPriv.decons
+
+
+mapTimeL ::
+ (time -> time, BodyTimeList.T time body0 -> BodyTimeList.T time body1) ->
+ T time body0 -> T time body1
+mapTimeL = lift . Mixed.mapSecondL . mapSnd BodyTimePriv.unlift
+
+mapTimeHead ::
+ (time -> time) ->
+ T time body -> T time body
+mapTimeHead = lift . Mixed.mapSecondHead
+
+mapTimeTail ::
+ (BodyTimeList.T time body0 -> BodyTimeList.T time body1) ->
+ T time body0 -> T time body1
+mapTimeTail = lift . Mixed.mapSecondTail . BodyTimePriv.unlift
+
+
+mapTimeR ::
+ (TimeBodyList.T time body0 -> TimeBodyList.T time body1, time -> time) ->
+ T time body0 -> T time body1
+mapTimeR = lift . Mixed.mapSecondR . mapFst TimeBodyPriv.unlift
+
+mapTimeLast ::
+ (time -> time) ->
+ T time body -> T time body
+mapTimeLast = lift . Mixed.mapSecondLast
+
+mapTimeInit ::
+ (TimeBodyList.T time body0 -> TimeBodyList.T time body1) ->
+ T time body0 -> T time body1
+mapTimeInit = lift . Mixed.mapSecondInit . TimeBodyPriv.unlift
diff --git a/src/Data/EventList/Utility.hs b/src/Data/EventList/Utility.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/EventList/Utility.hs
@@ -0,0 +1,139 @@
+module Data.EventList.Utility where
+
+-- State monad could be avoided by mapAccumL
+import Control.Monad.State (State(State), modify, gets)
+import qualified Data.List as List
+
+{- |
+Given the time fraction that remains from the preceding event
+and the current time difference,
+evaluate an integer time difference and
+the remaining fractional part.
+If we would simply map Time to integer values
+with respect to the sampling rate,
+then rounding errors would accumulate.
+-}
+
+roundDiff' :: (RealFrac t, Integral i) => t -> t -> (i, t)
+roundDiff' time frac =
+ let x = time+frac
+ n = round x
+ in (n, x - fromIntegral n)
+
+roundDiff :: (RealFrac t, Integral i) => t -> State t i
+roundDiff = State . roundDiff'
+
+{-
+We could use 'properFraction' but this is inconsistent for negative values.
+-}
+floorDiff :: (RealFrac t, Integral i) => t -> State t i
+floorDiff t =
+ do modify (t+)
+ n <- gets floor
+ modify (subtract (fromIntegral n))
+ return n
+
+-- Control.Arrow.***
+mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)
+mapPair ~(f,g) ~(x,y) = (f x, g y)
+
+-- Control.Arrow.first
+mapFst :: (a -> c) -> (a,b) -> (c,b)
+mapFst f ~(x,y) = (f x, y)
+
+-- Control.Arrow.second
+mapSnd :: (b -> d) -> (a,b) -> (a,d)
+mapSnd g ~(x,y) = (x, g y)
+
+
+toMaybe :: Bool -> a -> Maybe a
+toMaybe False _ = Nothing
+toMaybe True x = Just x
+
+
+{-|
+Given two lists that are ordered
+(i.e. @p x y@ holds for subsequent @x@ and @y@)
+'mergeBy' them into a list that is ordered, again.
+
+This used for merging event lists with absolute time stamps.
+-}
+
+mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+mergeBy p =
+ let recurse xl@(x:xs) yl@(y:ys) =
+ if p x y then x : recurse xs yl
+ else y : recurse xl ys
+ recurse [] yl = yl
+ recurse xl [] = xl
+ in recurse
+
+
+beforeBy :: (Ord time) =>
+ (body -> body -> Bool) ->
+ (time, body) -> (time, body) -> Bool
+beforeBy before (t0, me0) (t1, me1) =
+ case compare t0 t1 of
+ LT -> True
+ EQ -> before me0 me1
+ GT -> False
+
+
+{- |
+This is a combination of 'init' and 'last'
+which avoids memoizing the list
+if the last element is accessed after the initial ones.
+
+> let a = [0..10000000::Int] in (last (init a), last a)
+> let a = [0..10000000::Int]; (bs,b)=splitInit a in (last bs, b)
+-}
+splitInit :: [a] -> ([a], a)
+splitInit (x:xs) =
+ if null xs
+ then ([], x)
+ else mapFst (x:) (splitInit xs)
+splitInit [] = error "splitInit: empty list"
+
+propSplitInit :: Eq a => [a] -> Bool
+propSplitInit xs =
+ splitInit xs == (init xs, last xs)
+
+
+viewR :: [a] -> Maybe ([a], a)
+viewR =
+ foldr (\x mxs -> Just (maybe ([],x) (mapFst (x:)) mxs)) Nothing
+
+propViewR :: Eq a => [a] -> Bool
+propViewR xs =
+ maybe True
+ ((init xs, last xs) == )
+ (viewR xs)
+
+
+composeDouble :: (b -> b -> c) -> (a -> b) -> (a -> a -> c)
+composeDouble g f x y = g (f x) (f y)
+
+equalField :: Eq b => (a -> b) -> a -> a -> Bool
+equalField = composeDouble (==)
+
+
+isMonotonic :: (Ord a) => [a] -> Bool
+isMonotonic = and . isMonotonicLazy
+
+isMonotonicLazy :: (Ord a) => [a] -> [Bool]
+isMonotonicLazy xs = zipWith (<=) xs (tail xs)
+
+
+
+slice :: (Eq a) =>
+ (eventlist -> Maybe body) ->
+ ((body -> Bool) -> eventlist -> (eventlist, eventlist)) ->
+ (body -> a) -> eventlist -> [(a, eventlist)]
+slice hd partition f =
+ List.unfoldr (\ pf ->
+ fmap
+ ((\ i ->
+ mapPair
+ ((,) i, id)
+ (partition ((i==) . f) pf)) . f)
+ (hd pf))