event-list-0.1.0.2/0000755000000000000000000000000011777327303012142 5ustar0000000000000000event-list-0.1.0.2/Setup.lhs0000644000000000000000000000011511777327303013747 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain event-list-0.1.0.2/event-list.cabal0000644000000000000000000000600611777327303015222 0ustar0000000000000000Name: event-list Version: 0.1.0.2 License: GPL License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann Homepage: http://code.haskell.org/~thielema/event-list/ Category: Data 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. Tested-With: GHC==6.4.1, GHC==6.6.1, GHC==6.8.2 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository head type: darcs location: http://code.haskell.org/~thielema/event-list/ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/event-list/ tag: 0.1.0.2 Flag splitBase description: Choose the new smaller, split-up base package. Flag buildTests description: Build test executables default: False Library Build-Depends: non-negative >=0.1 && <0.2, transformers >=0.1 && <0.4, utility-ht >=0.0.3 && <0.1, QuickCheck >=1.1 && <3 If flag(splitBase) Build-Depends: base >= 2 && <6 Else Build-Depends: special-functors >= 1.0 && <1.1, base >= 1.0 && < 2 GHC-Options: -Wall 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 If flag(buildTests) -- QuickCheck 1.1 has Maybe instance which we need Build-Depends: QuickCheck >=1.1 && <3 If flag(splitBase) Build-Depends: random >=1.0 && <2.0 Else Buildable: False GHC-Options: -Wall Hs-Source-Dirs: src 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 event-list-0.1.0.2/LICENSE0000644000000000000000000010451311777327303013153 0ustar0000000000000000 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 . event-list-0.1.0.2/src/0000755000000000000000000000000011777327303012731 5ustar0000000000000000event-list-0.1.0.2/src/Test/0000755000000000000000000000000011777327303013650 5ustar0000000000000000event-list-0.1.0.2/src/Test/Main.hs0000644000000000000000000000144311777327303015072 0ustar0000000000000000module 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 import qualified System.IO as IO prefix :: String -> [(String, IO ())] -> [(String, IO ())] prefix msg = map (\(str,test) -> (msg ++ "." ++ str, test)) main :: IO () main = IO.hSetBuffering IO.stdout IO.NoBuffering >> (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 : []) event-list-0.1.0.2/src/Test/Utility.hs0000644000000000000000000000160311777327303015647 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Utility where import qualified Numeric.NonNegative.Wrapper as NonNeg import Test.QuickCheck (Arbitrary(arbitrary)) import qualified Data.Char as Char import System.Random (Random, ) import Control.Monad (liftM, ) newtype ArbChar = ArbChar Char deriving (Eq, Ord, Enum, Random) instance Show ArbChar where showsPrec n (ArbChar c) = showsPrec n c instance Arbitrary ArbChar where arbitrary = liftM (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary toLower :: ArbChar -> ArbChar toLower (ArbChar c) = ArbChar (Char.toLower c) toUpper :: ArbChar -> ArbChar toUpper (ArbChar c) = ArbChar (Char.toUpper c) type TimeDiff = NonNeg.Integer timeToDouble :: TimeDiff -> NonNeg.Double timeToDouble = fromIntegral makeFracTime :: (TimeDiff, TimeDiff) -> NonNeg.Double makeFracTime (n,d) = timeToDouble n / (timeToDouble d + 1) event-list-0.1.0.2/src/Test/Data/0000755000000000000000000000000011777327303014521 5ustar0000000000000000event-list-0.1.0.2/src/Test/Data/EventList/0000755000000000000000000000000011777327303016436 5ustar0000000000000000event-list-0.1.0.2/src/Test/Data/EventList/Relative/0000755000000000000000000000000011777327303020211 5ustar0000000000000000event-list-0.1.0.2/src/Test/Data/EventList/Relative/TimeEnd.hs0000644000000000000000000014611411777327303022101 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2008-2010 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 -} module Test.Data.EventList.Relative.TimeEnd (tests) where import Test.Utility import Test.QuickCheck (quickCheck) 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 qualified Data.EventList.Relative.TimeTimePrivate as TimeTimePriv import qualified Data.EventList.Absolute.TimeTime as AbsTimeTimeList import Data.EventList.Relative.MixedTime ((/.), (./), empty, ) import Data.EventList.Relative.TimeTimePrivate (($~~), lift, ) import qualified Numeric.NonNegative.Chunky as NonNegChunky import qualified Numeric.NonNegative.Class as NonNeg import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.EventList.Relative.TimeTime (isNormalized, ) import System.Random (Random, randomR, mkStdGen, ) import Control.Monad.Trans.State (state, evalState, gets, modify, ) import Control.Monad (liftM2, ) import Data.Maybe.HT (toMaybe, ) import Data.Tuple.HT (mapFst, mapPair, ) import qualified Data.List as List 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 switchLConsTime :: (Eq body, Eq time) => TimeTimeList.T time body -> Bool switchLConsTime xs = xs == MixedTimeList.switchTimeL MixedTimeList.consTime xs switchLConsBody :: (Eq body, Eq time) => BodyTimeList.T time body -> Bool switchLConsBody xs = xs == MixedTimeList.switchBodyL BodyTimeList.empty MixedTimeList.consBody xs switchRSnocTime :: (Eq body, Eq time) => TimeTimeList.T time body -> Bool switchRSnocTime xs = xs == TimeMixedList.switchTimeR TimeMixedList.snocTime xs switchRSnocBody :: (Eq body, Eq time) => TimeBodyList.T time body -> Bool switchRSnocBody xs = xs == TimeMixedList.switchBodyR TimeBodyList.empty TimeMixedList.snocBody xs switchLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool switchLInfinite = checkInfinite . MixedTimeList.switchBodyL (error "switchBodyL: empty list") (flip const) . MixedTimeList.switchTimeL (flip const) . makeInfiniteEventList switchRInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool switchRInfinite = checkInfinite . TimeMixedList.switchBodyR (error "switchBodyR: empty list") const . TimeMixedList.switchTimeR const . 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 ./ (add t0b t1a) /. b1 ./ t1b /. empty) iterate' :: (a -> a) -> a -> [a] iterate' f = let recourse x = ((:) $! x) $ recourse (f x) in recourse chunkyShow :: Int -> Bool chunkyShow = (\t -> t==t) . take 1000000 . show . const (NonNegChunky.fromChunks $ iterate' (2-) (1::TimeDiff)) _chunkyCheck :: Int -> Bool _chunkyCheck = (\t -> t==t) . take 1000000 . -- (!!1000000) . {- NonNegChunky.toChunks . NonNegChunky.fromChunks . -} iterate' (1+) {- With an early implementation of mapTimeTail this resulted in heap exhaustion. -} mapTimeTailChunkyInfinite :: (NonNeg.C time, Num time, Eq body, Show body) => (body -> body) -> BodyTimeList.T (NonNegChunky.T time) body -> Bool mapTimeTailChunkyInfinite _f = (\t -> t==t) . take 1000000 . NonNegChunky.toChunks . MixedTimeList.switchTimeL const . {- MixedTimeList.switchTimeL MixedTimeList.consTime . -} MixedTimeList.consTime (NonNegChunky.fromChunks $ iterate' (2-) 1) {- mapTimeTailChunkyInfinite :: (NonNeg.C time, Num time, Eq body, Show body) => (body -> body) -> BodyTimeList.T (NonNegChunky.T time) body -> Bool mapTimeTailChunkyInfinite f = (\t -> t==t) . take 1000000 . show . MixedTimeList.mapTimeTail (fmap f) . MixedTimeList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) -} {- mapTimeTailChunkyInfinite :: (NonNeg.C time, Eq body) => (body -> body) -> BodyTimeList.T (NonNegChunky.T time) body -> Bool mapTimeTailChunkyInfinite f = -- not . NonNegChunky.isNull . -- not . null . NonNegChunky.toChunks . (\t -> t==t) . take 1000000 . NonNegChunky.toChunks . MixedTimeList.switchTimeL const . -- TimeTimeList.dropTime 1000000 . MixedTimeList.mapTimeTail (fmap f) . MixedTimeList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) mapTimeTailChunkyInfinite :: (NonNeg.C time, Eq body) => (body -> body) -> NonNegChunky.T time -> TimeTimeList.T (NonNegChunky.T time) body -> Bool mapTimeTailChunkyInfinite f time = MixedTimeList.mapTimeTail (fmap f) . TimeTimeList.delay (let infTime = mappend time infTime in infTime) -} 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 zero) xs == xs appendRightIdentity :: (NonNeg.C time, Eq body) => TimeTimeList.T time body -> Bool appendRightIdentity xs = TimeTimeList.append xs (TimeTimeList.pause zero) == 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 zero)) 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 (add dif0 dif1) xs == TimeTimeList.delay dif0 (TimeTimeList.delay dif1 xs) delayPause :: (NonNeg.C time) => time -> time -> Bool delayPause dif0 dif1 = let pause = TimeTimeList.pause (add 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 == zero || t >= TimeTimeList.duration xs || zero < 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, Num 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, Num time, Ord body) => time -> NonEmptyList time body -> Bool takeTimeInfinite t = (t == ) . TimeTimeList.duration . TimeTimeList.takeTime t . makeUncollapsedInfiniteEventList dropTimeInfinite :: (NonNeg.C time, Num time, Ord body) => time -> NonEmptyList time body -> Bool dropTimeInfinite t = checkInfinite . TimeTimeList.dropTime t . makeUncollapsedInfiniteEventList dropTimeLargeInfinite :: (NonNeg.C time, Num time, Ord body) => NonEmptyList time body -> Bool dropTimeLargeInfinite = checkInfinite . TimeTimeList.dropTime 10000 . makeUncollapsedInfiniteEventList splitAtTimeLazyInfinite :: (NonNeg.C time, Num time, Ord body, Show time, Show body) => BodyTimeList.T (NonNegChunky.T time) body -> Bool splitAtTimeLazyInfinite = not . null . show . snd . TimeTimeList.splitAtTime 1000000 . MixedTimeList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) dropTimeLazyInfinite :: (NonNeg.C time, Num time, Ord body, Show time, Show body) => BodyTimeList.T (NonNegChunky.T time) body -> Bool dropTimeLazyInfinite = not . null . show . TimeTimeList.dropTime 1000000 . MixedTimeList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) {- dropTimeLazyInfinite :: (NonNeg.C time, Num time, Ord body) => BodyTimeList.T (NonNegChunky.T time) body -> Bool dropTimeLazyInfinite = (\t -> t==t) . take 100 . NonNegChunky.toChunks . MixedTimeList.switchTimeL const . TimeTimeList.dropTime 1000000 . MixedTimeList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) -} 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 `add` 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 :: (NonNeg.C time) => (body -> Bool) -> TimeTimeList.T time body -> Bool filterSatisfy p = all p . TimeTimeList.getBodies . TimeTimeList.filter p filterProjection :: (NonNeg.C 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 :: (NonNeg.C 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 :: (NonNeg.C 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) catMaybesRInfinite :: (NonNeg.C time, Num time, Eq body) => NonEmptyList time (Maybe body) -> Bool catMaybesRInfinite xs = {- @(add 1) is needed in order to assert that the accumulated time is infinite and can be clipped by @min 100@. -} let t = min 100 $ List.foldr add zero $ TimeTimeList.getTimes $ TimeTimeList.catMaybesR $ TimeTimeList.mapTime (NonNegChunky.fromNumber . (add 1)) $ makeInfiniteEventList xs in t == t catMaybesRInitInfinite :: (NonNeg.C time, Num time, Eq body) => NonEmptyList time body -> Bool catMaybesRInitInfinite xs = let t = min 100 $ MixedTimeList.switchTimeL const $ TimeTimeList.catMaybesR $ TimeTimeList.mapBody (const (Nothing::Maybe())) $ TimeTimeList.mapTime (NonNegChunky.fromNumber . (add 1)) $ makeInfiniteEventList xs in t == t partitionMaybe :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeTimeList.T time body -> Bool partitionMaybe p xs = TimeTimeList.partitionMaybe (\x -> toMaybe (p x) x) xs == TimeTimeList.partition p xs partitionMaybeR :: (NonNeg.C time, Eq body0, Eq body1) => (body0 -> Maybe body1) -> TimeTimeList.T time body0 -> Bool partitionMaybeR f xs = TimeTimeList.partitionMaybe f xs == TimeTimeList.partitionMaybeR f xs partitionMaybeRInfinite :: (NonNeg.C time, Num time, Eq body0, Eq body1) => (body0 -> Maybe body1) -> NonEmptyList time body0 -> Bool partitionMaybeRInfinite f xs = {- @(add 1) is needed in order to assert that the accumulated time is infinite and can be clipped by @min 100@. -} let timeSum = min 100 . List.foldr add zero . TimeTimeList.getTimes t = mapPair (timeSum, timeSum) $ TimeTimeList.partitionMaybeR f $ TimeTimeList.mapTime (NonNegChunky.fromNumber . add 1) $ makeInfiniteEventList xs in t == t partitionMaybeRInitInfinite :: (NonNeg.C time, Num time, Eq body0, Eq body1) => (body0 -> Maybe body1) -> NonEmptyList time body0 -> Bool partitionMaybeRInitInfinite f xs = let initTime = min 100 . MixedTimeList.switchTimeL const t = mapPair (initTime, initTime) $ TimeTimeList.partitionMaybeR f $ TimeTimeList.mapTime (NonNegChunky.fromNumber . add 1) $ makeInfiniteEventList xs in t == t {- | '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 zero) xs == xs mergeRightIdentity :: (NonNeg.C time, Ord body) => TimeTimeList.T time body -> Bool mergeRightIdentity xs = TimeTimeList.merge xs (TimeTimeList.pause zero) == 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.pad dur xs longYs = TimeTimeList.pad 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) {- Normalization is important, otherwise we have the counterexample: Relative.TimeEnd.insertMerge: Falsifiable, after 6 tests: 2 '~' 0 /. '"' ./ 2 /. '~' ./ 0 /. '#' ./ 1 /. empty -} insertMerge :: (NonNeg.C time, Ord body) => time -> body -> TimeTimeList.T time body -> Bool insertMerge time body evs0 = let evs = TimeTimeList.normalize evs0 in TimeTimeList.insert time body evs == TimeTimeList.merge (TimeTimeList.cons time body $ TimeTimeList.pause zero) 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 zero 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 moveForwardIdentity :: (NonNeg.C time, Num time, Ord body) => TimeTimeList.T time body -> Bool moveForwardIdentity evs = evs == TimeTimeList.moveForward (TimeTimeList.mapBody ((,) zero) evs) moveForwardAdditive :: (NonNeg.C time, Num time, Ord body) => TimeTimeList.T time ((time,time),body) -> Bool moveForwardAdditive evs = TimeTimeList.normalize (moveForwardLimited (moveForwardLimited (TimeTimeList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) == TimeTimeList.normalize (moveForwardLimited (TimeTimeList.mapBody (mapFst (uncurry add)) evs)) moveForwardCommutative :: (NonNeg.C time, Num time, Ord body) => TimeTimeList.T time ((time,time),body) -> Bool moveForwardCommutative evs = TimeTimeList.normalize (moveForwardLimited (moveForwardLimited (TimeTimeList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) == TimeTimeList.normalize (moveForwardLimited (moveForwardLimited (TimeTimeList.mapBody (\((t0,t1),b) -> (t1,(t0,b))) evs))) moveForwardRestricted :: (NonNeg.C time, Num time, Ord body) => time -> TimeTimeList.T time (time,body) -> Bool moveForwardRestricted maxTime evs0 = let evs = TimeTimeList.mapBody (mapFst (min maxTime)) $ restrictMoveTimes (TimeTimeList.normalize evs0) mevs = TimeTimeList.moveForward evs in mevs == TimeTimeList.moveForwardRestrictedBy (\_ _ -> True) maxTime evs && mevs == TimeTimeList.moveForwardRestrictedByStrict (\_ _ -> True) maxTime evs && mevs == TimeTimeList.moveForwardRestrictedByQueue (\_ _ -> False) maxTime evs moveForwardRestrictedInfinity :: (NonNeg.C time, Num time, Ord body) => time -> NonEmptyList time (time,body) -> Bool moveForwardRestrictedInfinity maxTime = checkInfinite . TimeTimeList.moveForwardRestricted maxTime . TimeTimeList.mapBody (mapFst (min maxTime)) . restrictMoveTimes . makeUncollapsedInfiniteEventList moveForwardLimited :: (NonNeg.C time, Num time) => TimeTimeList.T time (time,body) -> TimeTimeList.T time body moveForwardLimited = TimeTimeList.moveForward . restrictMoveTimes restrictMoveTimes :: (NonNeg.C time) => TimeTimeList.T time (time,body) -> TimeTimeList.T time (time,body) restrictMoveTimes = flip evalState zero . TimeTimeList.mapM (\t -> modify (add t) >> return t) (\(t,b) -> gets (\tm -> (min t tm, b))) arrangeSingletons :: (NonNeg.C time, Ord body) => TimeTimeList.T time body -> Bool arrangeSingletons evs = evs == TimeTimeList.arrange (TimeTimeList.mapBody (\x -> TimeTimeList.cons zero x (TimeTimeList.pause zero)) evs) arrangeDelay :: (NonNeg.C time, Ord body) => time -> NonEmptyList time body -> Bool arrangeDelay delay evs0 = let evs = makeNonEmptyEventList evs0 in TimeTimeList.delay delay evs == TimeTimeList.arrange (TimeTimeList.mapBody (\x -> TimeTimeList.cons delay x (TimeTimeList.pause zero)) $ TimeTimePriv.mapTimeLast (add delay) evs) arrangeSimple :: (NonNeg.C time, Ord body) => TimeTimeList.T time (TimeTimeList.T time body) -> Bool arrangeSimple evs = TimeTimeList.normalize (TimeTimeList.arrange evs) == -- implementation not lazy enough for regular use TimeTimeList.foldr (TimeTimeList.delay) (TimeTimeList.merge) (TimeTimeList.pause zero) (TimeTimeList.mapBody TimeTimeList.normalize evs) arrangeAbsolute :: (NonNeg.C time, Num time, Ord body) => TimeTimeList.T time (TimeTimeList.T time body) -> Bool arrangeAbsolute evs = TimeTimeList.normalize (TimeTimeList.arrange evs) == AbsTimeTimeList.foldr (\t (xs,ys) -> TimeTimeList.merge (TimeTimeList.delay t (TimeTimeList.normalize xs)) ys) (,) (TimeTimeList.pause zero, TimeTimeList.pause zero) (TimeTimeList.toAbsoluteEventList zero evs) arrangeInfinity :: (NonNeg.C time, Num time, Ord body) => NonEmptyList time (NonEmptyList time body) -> Bool arrangeInfinity = checkInfinite . TimeTimeList.arrange . TimeTimeList.mapBody makeUncollapsedInfiniteEventList . makeUncollapsedInfiniteEventList 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 (zero<) (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, Num 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) reverseAppend :: (NonNeg.C time, Eq body) => TimeTimeList.T time body -> TimeTimeList.T time body -> Bool reverseAppend xs ys = TimeTimeList.reverse (TimeTimeList.append xs ys) == TimeTimeList.append (TimeTimeList.reverse ys) (TimeTimeList.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) zero 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 add 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, Num time) => NonEmptyList time body -> TimeTimeList.T time body makeUncollapsedInfiniteEventList = makeInfiniteEventList . (\(time,body,xs) -> (add 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 = MixedTimeList.switchBodyL (error "checkInfinite: finite list") const xs in x == x && y == y tests :: [(String, IO ())] tests = ("viewTimeL consTime", quickCheck (viewLConsTime :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("viewBodyL consBody", quickCheck (viewLConsBody :: BodyTimeList.T TimeDiff ArbChar -> Bool)) : ("viewTimeR snocTime", quickCheck (viewRSnocTime :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("viewBodyR snocBody", quickCheck (viewRSnocBody :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("viewLInfinite", quickCheck (viewLInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("viewRInfinite", quickCheck (viewRInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("switchTimeL consTime", quickCheck (switchLConsTime :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("switchBodyL consBody", quickCheck (switchLConsBody :: BodyTimeList.T TimeDiff ArbChar -> Bool)) : ("switchTimeR snocTime", quickCheck (switchRSnocTime :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("switchBodyR snocBody", quickCheck (switchRSnocBody :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("switchLInfinite", quickCheck (switchLInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("switchRInfinite", quickCheck (switchRInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("consInfinite", quickCheck (consInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("consTimeBodyInfinite", quickCheck (consTimeBodyInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("snocInfinite", quickCheck (snocInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("snocTimeBodyInfinite", quickCheck (snocTimeBodyInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("consInfix", quickCheck (consInfix :: TimeDiff -> ArbChar -> TimeDiff -> TimeDiff -> ArbChar -> TimeDiff -> Bool)) : ("chunkyShow", quickCheck chunkyShow) : {- ("chunkyCheck", quickCheck chunkyCheck) : -} ("mapTimeTailChunkyInfinite", quickCheck (mapTimeTailChunkyInfinite succ :: BodyTimeList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) : ("map body composition", quickCheck (mapBodyComposition toUpper toLower :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("map time composition", quickCheck ((\dt0 dt1 -> mapTimeComposition (add dt0) (add dt1)) :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("map time body commutative", quickCheck ((\dt -> mapTimeBodyCommutative (add dt) toUpper) :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mapBodyInfinite", quickCheck (mapBodyInfinite toUpper :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("mapTimeInfinite", quickCheck (\dt -> mapTimeInfinite (add dt) :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("mapNormalize", quickCheck (mapNormalize succ :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("append left identity", quickCheck (appendLeftIdentity :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("append right identity", quickCheck (appendRightIdentity :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("append associative", quickCheck (appendAssociative :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("appendCons", quickCheck (appendCons :: TimeDiff -> ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mapBodyAppend", quickCheck (mapBodyAppend toUpper :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("appendSplitAtTime", quickCheck (appendSplitAtTime :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("appendFirstInfinite", quickCheck (appendFirstInfinite :: NonEmptyList TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("appendSecondInfinite", quickCheck (appendSecondInfinite :: TimeTimeList.T TimeDiff ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("concatNaive", quickCheck (concatNaive :: [TimeTimeList.T TimeDiff ArbChar] -> Bool)) : ("cycleNaive", quickCheck (cycleNaive :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("cycleInfinite", quickCheck (cycleInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("decreaseStart delay", quickCheck (decreaseStartDelay :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("decreaseStartInfinite", quickCheck (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("delay additive", quickCheck (delayAdditive :: TimeDiff -> TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("delay pause", quickCheck (delayPause :: TimeDiff -> TimeDiff -> Bool)) : ("delay append pause", quickCheck (delayAppendPause :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("delayInfinite", quickCheck (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("splitAtTakeDropTime", quickCheck (splitAtTakeDropTime :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("takeTimeEndPause", quickCheck (takeTimeEndPause :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("takeTimeAppendFirst", quickCheck (takeTimeAppendFirst :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("takeTimeAppendSecond", quickCheck (takeTimeAppendSecond :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("takeTimeNormalize", quickCheck (takeTimeNormalize :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("dropTimeNormalize", quickCheck (dropTimeNormalize :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("takeTimeInfinite", quickCheck (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("dropTimeInfinite", quickCheck (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("dropTimeLargeInfinite", quickCheck (dropTimeLargeInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("splitAtTimeLazyInfinite", quickCheck (splitAtTimeLazyInfinite :: BodyTimeList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) : ("dropTimeLazyInfinite", quickCheck (dropTimeLazyInfinite :: BodyTimeList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) : ("duration pause", quickCheck (durationPause :: TimeDiff -> Bool)) : ("duration append", quickCheck (durationAppend :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("duration merge", quickCheck (durationMerge :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("durationTakeTime", quickCheck (durationTakeTime :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("durationDropTime", quickCheck (durationDropTime :: TimeDiff -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterSatisfy", quickCheck (\c -> filterSatisfy (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterProjection", quickCheck (\c -> filterProjection (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterCommutative", quickCheck (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterComposition", quickCheck (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterNormalize", quickCheck (\c -> filterNormalize (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterAppend", quickCheck (\c -> filterAppend (c<) :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterDuration", quickCheck (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterPartition", quickCheck (\c -> filterPartition (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterInfinite", quickCheck (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("catMaybesAppend", quickCheck (catMaybesAppend :: TimeTimeList.T TimeDiff (Maybe ArbChar) -> TimeTimeList.T TimeDiff (Maybe ArbChar) -> Bool)) : ("catMaybesRInfinite", quickCheck (catMaybesRInfinite :: NonEmptyList TimeDiff (Maybe ArbChar) -> Bool)) : ("catMaybesRInitInfinite", quickCheck (catMaybesRInitInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("partitionMaybe", quickCheck (\c -> partitionMaybe (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("partitionMaybeR", quickCheck (\c -> partitionMaybeR (\x -> toMaybe (c Bool)) : ("partitionMaybeRInfinite", quickCheck (\c -> partitionMaybeRInfinite (\x -> toMaybe (c Bool)) : ("partitionMaybeRInitInfinite", quickCheck (\c -> partitionMaybeRInitInfinite (\x -> toMaybe (c Bool)) : ("mergeNormalize", quickCheck (mergeNormalize :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("merge left identity", quickCheck (mergeLeftIdentity :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("merge right identity", quickCheck (mergeRightIdentity :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("merge commutative", quickCheck (mergeCommutative :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("merge associative", quickCheck (mergeAssociative :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("merge append", quickCheck (mergeAppend :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("appendByMerge", quickCheck (appendByMerge :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mergeMap", quickCheck (mergeMap succ :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mergeFilter", quickCheck (\c -> mergeFilter (c>) :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mergePartition", quickCheck (\c -> mergePartition (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mergeEitherMapMaybe", quickCheck (mergeEitherMapMaybe :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mergeInfinite", quickCheck (mergeInfinite :: NonEmptyList TimeDiff ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("insertCommutative", quickCheck (insertCommutative :: (TimeDiff, ArbChar) -> (TimeDiff, ArbChar) -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("insertMerge", quickCheck (insertMerge :: TimeDiff -> ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("insertNormalize", quickCheck (insertNormalize :: TimeDiff -> ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("insertSplitAtTime", quickCheck (insertSplitAtTime :: TimeDiff -> ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("insertInfinite", quickCheck (insertInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("moveForwardIdentity", quickCheck (moveForwardIdentity :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("moveForwardAdditive", quickCheck (moveForwardAdditive :: TimeTimeList.T TimeDiff ((TimeDiff,TimeDiff),ArbChar) -> Bool)) : ("moveForwardCommutative", quickCheck (moveForwardCommutative :: TimeTimeList.T TimeDiff ((TimeDiff,TimeDiff),ArbChar) -> Bool)) : ("moveForwardRestricted", quickCheck (moveForwardRestricted :: TimeDiff -> TimeTimeList.T TimeDiff (TimeDiff,ArbChar) -> Bool)) : ("moveForwardRestrictedInfinity", quickCheck (moveForwardRestrictedInfinity :: TimeDiff -> NonEmptyList TimeDiff (TimeDiff,ArbChar) -> Bool)) : ("arrangeSingletons", quickCheck (arrangeSingletons :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("arrangeDelay", quickCheck (arrangeDelay :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("arrangeSimple", quickCheck (arrangeSimple :: TimeTimeList.T TimeDiff (TimeTimeList.T TimeDiff ArbChar) -> Bool)) : ("arrangeAbsolute", quickCheck (arrangeAbsolute :: TimeTimeList.T TimeDiff (TimeTimeList.T TimeDiff ArbChar) -> Bool)) : ("arrangeInfinity", quickCheck (arrangeInfinity :: NonEmptyList TimeDiff (NonEmptyList TimeDiff ArbChar) -> Bool)) : ("coincidentFlatten", quickCheck (coincidentFlatten :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentGaps", quickCheck (collectCoincidentGaps :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentNonEmpty", quickCheck (collectCoincidentNonEmpty :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentInfinite", quickCheck (collectCoincidentInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("mapCoincidentMap", quickCheck (mapCoincidentMap toUpper :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mapCoincidentComposition", quickCheck (mapCoincidentComposition reverse reverse :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mapCoincidentReverse", quickCheck (mapCoincidentReverse :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("reverseAppend", quickCheck (reverseAppend :: TimeTimeList.T TimeDiff ArbChar -> TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("mapBodyMAppendRandom", quickCheck (mapBodyMAppendRandom :: Int -> TimeTimeList.T TimeDiff (ArbChar,ArbChar) -> TimeTimeList.T TimeDiff (ArbChar,ArbChar) -> Bool)) : ("mapBodyMInfinite", quickCheck (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (ArbChar,ArbChar) -> Bool)) : [] event-list-0.1.0.2/src/Test/Data/EventList/Relative/BodyEnd.hs0000644000000000000000000011441211777327303022074 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2008 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 -} module Test.Data.EventList.Relative.BodyEnd (tests) where import Test.Utility import Test.QuickCheck (quickCheck) 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.Chunky as NonNegChunky import qualified Numeric.NonNegative.Class as NonNeg import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.EventList.Relative.TimeBody (isNormalized) import Data.Tuple.HT (mapFst, mapPair, ) import System.Random (Random, randomR, mkStdGen, ) import Control.Monad.Trans.State (state, evalState, gets, modify, ) import Control.Monad (liftM2) import Data.Maybe (isJust) 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 switchLConsTime :: (Eq body, Eq time) => TimeBodyList.T time body -> Bool switchLConsTime xs = xs == MixedBodyList.switchTimeL TimeBodyList.empty MixedBodyList.consTime xs switchLConsBody :: (Eq body, Eq time) => BodyBodyList.T time body -> Bool switchLConsBody xs = xs == MixedBodyList.switchBodyL MixedBodyList.consBody xs switchLInfinite :: (NonNeg.C time, Eq body) => NonEmptyList time body -> Bool switchLInfinite = checkInfinite . TimeBodyList.switchL (error "switchBodyL: empty list") (flip const) . 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 (add 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 == zero || t >= TimeBodyList.duration xs || zero < 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, Num 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 = add 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, Num time, Ord body) => time -> NonEmptyList time body -> Bool takeTimeInfinite t = (t == ) . TimeTimeList.duration . TimeMixedList.takeTime t . makeUncollapsedInfiniteEventList dropTimeInfinite :: (NonNeg.C time, Num time, Ord body) => time -> NonEmptyList time body -> Bool dropTimeInfinite t = checkInfinite . TimeMixedList.dropTime t . makeUncollapsedInfiniteEventList _splitAtTimeLazyInfinite :: (NonNeg.C time, Num time, Ord body, Show time, Show body) => BodyBodyList.T (NonNegChunky.T time) body -> Bool _splitAtTimeLazyInfinite = not . null . show . snd . TimeMixedList.splitAtTime 1000000 . MixedBodyList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) _dropTimeLazyInfinite :: (NonNeg.C time, Num time, Ord body, Show time, Show body) => BodyBodyList.T (NonNegChunky.T time) body -> Bool _dropTimeLazyInfinite = not . null . show . TimeMixedList.dropTime 1000000 . MixedBodyList.consTime (NonNegChunky.fromChunks $ iterate (2-) 1) 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, Num 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 :: (NonNeg.C time) => (body -> Bool) -> TimeBodyList.T time body -> Bool filterSatisfy p = all p . TimeBodyList.getBodies . TimeBodyList.filter p filterProjection :: (NonNeg.C 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 :: (NonNeg.C 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 :: (NonNeg.C 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) {- Relative.BodyEnd.insert merge: Falsifiable, after 12 tests: 2 '}' 1 /. '%' ./ 1 /. '}' ./ 0 /. ' ' ./ 5 /. 'z' ./ 5 /. '\'' ./ 2 /. '\DEL' ./ 2 /. 'x' ./ 3 /. '\DEL' ./ empty -} 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 zero (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 moveForwardIdentity :: (NonNeg.C time, Num time, Ord body) => TimeBodyList.T time body -> Bool moveForwardIdentity evs = evs == TimeBodyList.moveForward (TimeBodyList.mapBody ((,) zero) evs) moveForwardAdditive :: (NonNeg.C time, Num time, Ord body) => TimeBodyList.T time ((time,time),body) -> Bool moveForwardAdditive evs = TimeBodyList.normalize (moveForwardLimited (moveForwardLimited (TimeBodyList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) == TimeBodyList.normalize (moveForwardLimited (TimeBodyList.mapBody (mapFst (uncurry add)) evs)) moveForwardCommutative :: (NonNeg.C time, Num time, Ord body) => TimeBodyList.T time ((time,time),body) -> Bool moveForwardCommutative evs = TimeBodyList.normalize (moveForwardLimited (moveForwardLimited (TimeBodyList.mapBody (\((t0,t1),b) -> (t0,(t1,b))) evs))) == TimeBodyList.normalize (moveForwardLimited (moveForwardLimited (TimeBodyList.mapBody (\((t0,t1),b) -> (t1,(t0,b))) evs))) {- moveForwardRestricted :: (NonNeg.C time, Ord body) => time -> TimeBodyList.T time (time,body) -> Bool moveForwardRestricted maxTime evs0 = let evs = TimeBodyList.mapBody (mapFst (min maxTime)) $ restrictMoveTimes (TimeBodyList.normalize evs0) in TimeBodyList.moveForward evs == TimeBodyList.moveForwardRestricted maxTime evs moveForwardRestrictedInfinity :: (NonNeg.C time, Eq body) => time -> NonEmptyList time (time,body) -> Bool moveForwardRestrictedInfinity maxTime = checkInfinite . TimeBodyList.moveForwardRestricted maxTime . TimeBodyList.mapBody (mapFst (min maxTime)) . restrictMoveTimes . makeUncollapsedInfiniteEventList -} moveForwardLimited :: (NonNeg.C time, Num time) => TimeBodyList.T time (time,body) -> TimeBodyList.T time body moveForwardLimited = TimeBodyList.moveForward . restrictMoveTimes restrictMoveTimes :: (NonNeg.C time) => TimeBodyList.T time (time,body) -> TimeBodyList.T time (time,body) restrictMoveTimes = flip evalState zero . TimeBodyList.mapM (\t -> modify (add t) >> return t) (\(t,b) -> gets (\tm -> (min t tm, b))) spanSatisfy :: (NonNeg.C time, Eq body) => (body -> Bool) -> TimeBodyList.T time body -> Bool spanSatisfy p = uncurry (&&) . mapPair (all p . TimeBodyList.getBodies, TimeBodyList.switchL True (const . not . p . snd)) . 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 (zero<) (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, Num 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 :: -- (NonNeg.C 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) zero 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 add 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, Num time) => NonEmptyList time body -> TimeBodyList.T time body makeUncollapsedInfiniteEventList = makeInfiniteEventList . (\(time,body,xs) -> (add 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 = TimeBodyList.switchL (error "BodyEnd.checkInfinite: empty list") const $ TimeBodyPriv.lift (Disp.drop 100) xs0 in x == x tests :: [(String, IO ())] tests = ("viewTimeL consTime", quickCheck (viewLConsTime :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("viewBodyL consBody", quickCheck (viewLConsBody :: BodyBodyList.T TimeDiff ArbChar -> Bool)) : ("switchTimeL consTime", quickCheck (switchLConsTime :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("switchBodyL consBody", quickCheck (switchLConsBody :: BodyBodyList.T TimeDiff ArbChar -> Bool)) : ("viewLInfinite", quickCheck (viewLInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("switchLInfinite", quickCheck (switchLInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("consInfinite", quickCheck (consInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("consTimeBodyInfinite", quickCheck (consTimeBodyInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("snocInfinite", quickCheck (snocInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("consInfix", quickCheck (consInfix :: TimeDiff -> ArbChar -> TimeDiff -> ArbChar -> Bool)) : ("map body composition", quickCheck (mapBodyComposition toUpper toLower :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("map time composition", quickCheck ((\dt0 dt1 -> mapTimeComposition (add dt0) (add dt1)) :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("map time body commutative", quickCheck ((\dt -> mapTimeBodyCommutative (add dt) toUpper) :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mapBodyInfinite", quickCheck (mapBodyInfinite toUpper :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("mapTimeInfinite", quickCheck (\dt -> mapTimeInfinite (add dt) :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("mapNormalize", quickCheck (mapNormalize succ :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("append left identity", quickCheck (appendLeftIdentity :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("append right identity", quickCheck (appendRightIdentity :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("append associative", quickCheck (appendAssociative :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("appendCons", quickCheck (appendCons :: TimeDiff -> ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mapBodyAppend", quickCheck (mapBodyAppend toUpper :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("appendSplitAtTime", quickCheck (appendSplitAtTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("appendFirstInfinite", quickCheck (appendFirstInfinite :: NonEmptyList TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("appendSecondInfinite", quickCheck (appendSecondInfinite :: TimeBodyList.T TimeDiff ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("cycleInfinite", quickCheck (cycleInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("decreaseStart delay", quickCheck (decreaseStartDelay :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("decreaseStartInfinite", quickCheck (decreaseStartInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("delay additive", quickCheck (delayAdditive :: TimeDiff -> TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("delay append pause", quickCheck (delayAppendPause :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("delayInfinite", quickCheck (delayInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("splitAtTakeDropTime", quickCheck (splitAtTakeDropTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("takeTimeEndPause", quickCheck (takeTimeEndPause :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("takeTimeAppendFirst", quickCheck (takeTimeAppendFirst :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("takeTimeAppendSecond", quickCheck (takeTimeAppendSecond :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("takeTimeNormalize", quickCheck (takeTimeNormalize :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("dropTimeNormalize", quickCheck (dropTimeNormalize :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("takeTimeInfinite", quickCheck (takeTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("dropTimeInfinite", quickCheck (dropTimeInfinite :: TimeDiff -> NonEmptyList TimeDiff ArbChar -> Bool)) : {- ("splitAtTimeLazyInfinite", quickCheck (splitAtTimeLazyInfinite :: BodyBodyList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) : ("dropTimeLazyInfinite", quickCheck (dropTimeLazyInfinite :: BodyBodyList.T (NonNegChunky.T TimeDiff) ArbChar -> Bool)) : -} ("duration pause", quickCheck (durationPause :: TimeDiff -> Bool)) : ("duration append", quickCheck (durationAppend :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("duration merge", quickCheck (durationMerge :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("durationTakeTime", quickCheck (durationTakeTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("durationDropTime", quickCheck (durationDropTime :: TimeDiff -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterSatisfy", quickCheck (\c -> filterSatisfy (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterProjection", quickCheck (\c -> filterProjection (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterCommutative", quickCheck (\c0 c1 -> filterCommutative (c0<) (c1>) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterComposition", quickCheck (\c0 c1 -> filterComposition (c0<) (c1>) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterNormalize", quickCheck (\c -> filterNormalize (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterAppend", quickCheck (\c -> filterAppend (c<) :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterDuration", quickCheck (\c -> filterDuration (c<) :: TimeTimeList.T TimeDiff ArbChar -> Bool)) : ("filterPartition", quickCheck (\c -> filterPartition (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("filterInfinite", quickCheck (\c -> filterInfinite (c<) :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("catMaybesAppend", quickCheck (catMaybesAppend :: TimeBodyList.T TimeDiff (Maybe ArbChar) -> TimeBodyList.T TimeDiff (Maybe ArbChar) -> Bool)) : ("mergeNormalize", quickCheck (mergeNormalize :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("merge left identity", quickCheck (mergeLeftIdentity :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("merge right identity", quickCheck (mergeRightIdentity :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("merge commutative", quickCheck (mergeCommutative :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("merge associative", quickCheck (mergeAssociative :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("merge append", quickCheck (mergeAppend :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mergeMap", quickCheck (mergeMap succ :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mergeFilter", quickCheck (\c -> mergeFilter (c>) :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mergePartition", quickCheck (\c -> mergePartition (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mergeEitherMapMaybe", quickCheck (mergeEitherMapMaybe :: TimeBodyList.T TimeDiff ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mergeInfinite", quickCheck (mergeInfinite :: NonEmptyList TimeDiff ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("insert commutative", quickCheck (insertCommutative :: (TimeDiff, ArbChar) -> (TimeDiff, ArbChar) -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("insert merge", quickCheck (insertMerge :: TimeDiff -> ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("insertNormalize", quickCheck (insertNormalize :: TimeDiff -> ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("insertSplitAtTime", quickCheck (insertSplitAtTime :: TimeDiff -> ArbChar -> TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("insertInfinite", quickCheck (insertInfinite :: TimeDiff -> ArbChar -> NonEmptyList TimeDiff ArbChar -> Bool)) : ("moveForwardIdentity", quickCheck (moveForwardIdentity :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("moveForwardAdditive", quickCheck (moveForwardAdditive :: TimeBodyList.T TimeDiff ((TimeDiff,TimeDiff),ArbChar) -> Bool)) : ("moveForwardCommutative", quickCheck (moveForwardCommutative :: TimeBodyList.T TimeDiff ((TimeDiff,TimeDiff),ArbChar) -> Bool)) : {- ("moveForwardRestricted", quickCheck (moveForwardRestricted :: TimeDiff -> TimeBodyList.T TimeDiff (TimeDiff,ArbChar) -> Bool)) : ("moveForwardRestrictedInfinity", quickCheck (moveForwardRestrictedInfinity :: TimeDiff -> NonEmptyList TimeDiff (TimeDiff,ArbChar) -> Bool)) : -} ("spanSatisfy", quickCheck (\c -> spanSatisfy (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("spanAppend", quickCheck (\c -> spanAppend (c<) :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("spanInfinite", quickCheck (\c -> spanInfinite (c<) :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("coincidentFlatten", quickCheck (coincidentFlatten :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentGaps", quickCheck (collectCoincidentGaps :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentNonEmpty", quickCheck (collectCoincidentNonEmpty :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentInfinite", quickCheck (collectCoincidentInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("mapCoincidentMap", quickCheck (mapCoincidentMap toUpper :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mapCoincidentComposition", quickCheck (mapCoincidentComposition reverse reverse :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mapCoincidentReverse", quickCheck (mapCoincidentReverse :: TimeBodyList.T TimeDiff ArbChar -> Bool)) : ("mapBodyMAppendRandom", quickCheck (mapBodyMAppendRandom :: Int -> TimeBodyList.T TimeDiff (ArbChar,ArbChar) -> TimeBodyList.T TimeDiff (ArbChar,ArbChar) -> Bool)) : ("mapBodyMInfinite", quickCheck (mapBodyMInfinite :: Int -> NonEmptyList TimeDiff (ArbChar,ArbChar) -> Bool)) : [] event-list-0.1.0.2/src/Test/Data/EventList/Absolute/0000755000000000000000000000000011777327303020214 5ustar0000000000000000event-list-0.1.0.2/src/Test/Data/EventList/Absolute/TimeEnd.hs0000644000000000000000000002221511777327303022077 0ustar0000000000000000{- | 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 (quickCheck) 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 System.Random (Random, randomR, mkStdGen) import Control.Monad (liftM) import qualified Numeric.NonNegative.Class as NonNeg import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Control.Monad.Trans.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, Eq time, Num time) => AbsTime.T time body -> RelTime.T time body -> Bool (==~) xs ys = xs == RelTime.toAbsoluteEventList 0 ys duration :: (NonNeg.C time, Num time) => RelTime.T time body -> Bool duration xs = AbsTime.duration $~ xs == RelTime.duration xs mapBody :: (Eq body1, NonNeg.C time, 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, Num 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, Num time, Random body, Eq body) => Int -> RelTime.T time (body, body) -> Bool mapBodyMRandom seed = mapBodyM (flip evalState (mkStdGen seed)) (state . randomR) filter :: (Eq body, NonNeg.C time, Num time) => (body -> Bool) -> RelTime.T time body -> Bool filter p xs = AbsTime.filter p $~ xs ==~ RelTime.filter p xs {- mapMaybe :: (NonNeg.C time, Num time) => (body0 -> Maybe body1) -> RelTime.T time body0 -> RelTime.T time body1 mapMaybe f = catMaybes . mapBody f -} catMaybes :: (Eq body, NonNeg.C time, 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, NonNeg.C time, 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, NonNeg.C time, 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, Num time, Eq body) => RelTime.T time body -> Bool collectCoincident xs = AbsTime.collectCoincident $~ xs ==~ RelTime.collectCoincident xs collectCoincidentInfinite :: (NonNeg.C time, Num time, Eq body) => NonEmptyList time body -> Bool collectCoincidentInfinite = checkInfinite . AbsTime.collectCoincident . makeUncollapsedInfiniteEventList flatten :: (NonNeg.C time, Num time, Eq body) => RelTime.T time [body] -> Bool flatten xs = AbsTime.flatten $~ xs ==~ RelTime.flatten xs normalize :: (NonNeg.C time, Num time, Ord body) => RelTime.T time body -> Bool normalize xs = AbsTime.normalize $~ xs ==~ RelTime.normalize xs {- test fails 1 /. '\DEL' ./ 0 /. '"' ./ 1 /. '}' ./ 0 /. empty 0 /. '\DEL' ./ 1 /. '}' ./ 0 /. '\DEL' ./ 1 /. empty 4 /. '|' ./ 0 /. '!' ./ 3 /. '"' ./ 1 /. '!' ./ 3 /. empty 1 /. '$' ./ 2 /. '~' ./ 1 /. '|' ./ 1 /. '|' ./ 1 /. empty -} merge :: (NonNeg.C time, Num 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, Num 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, Num 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, Num 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, Num 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, Num 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, Num time) => NonEmptyList time body -> AbsTime.T time body makeUncollapsedInfiniteEventList = makeInfiniteEventList . mapFst (mapFst (1+)) makeInfiniteEventList :: (NonNeg.C time, Num time) => NonEmptyList time body -> AbsTime.T time body makeInfiniteEventList = RelTime.toAbsoluteEventList 0 . RelTime.cycle . makeNonEmptyEventList makeNonEmptyEventList :: (NonNeg.C time, Num 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", quickCheck (duration :: RelTime.T TimeDiff ArbChar -> Bool)) : ("mapBody", quickCheck (mapBody toUpper :: RelTime.T TimeDiff ArbChar -> Bool)) : ("mapBodyM", quickCheck (mapBodyMRandom :: Int -> RelTime.T TimeDiff (ArbChar, ArbChar) -> Bool)) : ("filter", quickCheck (\c -> filter (c<) :: RelTime.T TimeDiff ArbChar -> Bool)) : ("catMaybes", quickCheck (catMaybes :: RelTime.T TimeDiff (Maybe ArbChar) -> Bool)) : ("partition", quickCheck (\c -> partition (c<) :: RelTime.T TimeDiff ArbChar -> Bool)) : ("slice", quickCheck (slice fst :: RelTime.T TimeDiff (ArbChar,ArbChar) -> Bool)) : ("collectCoincident", quickCheck (collectCoincident :: RelTime.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentInfinite", quickCheck (collectCoincidentInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("flatten", quickCheck (flatten :: RelTime.T TimeDiff [ArbChar] -> Bool)) : ("normalize", quickCheck (normalize :: RelTime.T TimeDiff ArbChar -> Bool)) : ("merge", quickCheck (merge :: RelTime.T TimeDiff ArbChar -> RelTime.T TimeDiff ArbChar -> Bool)) : ("insert", quickCheck (insert :: TimeDiff -> ArbChar -> RelTime.T TimeDiff ArbChar -> Bool)) : ("append", quickCheck (append :: RelTime.T TimeDiff ArbChar -> RelTime.T TimeDiff ArbChar -> Bool)) : ("concat", quickCheck (concat :: [RelTime.T TimeDiff ArbChar] -> Bool)) : ("decreaseStart", quickCheck (decreaseStart :: TimeDiff -> TimeDiff -> RelTime.T TimeDiff ArbChar -> Bool)) : ("delay", quickCheck (delay :: TimeDiff -> RelTime.T TimeDiff ArbChar -> Bool)) : ("resample", quickCheck (resample :: TimeDiff -> RelTime.T (TimeDiff, TimeDiff) ArbChar -> Bool)) : ("resampleInfinite", quickCheck (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) ArbChar -> Bool)) : [] event-list-0.1.0.2/src/Test/Data/EventList/Absolute/BodyEnd.hs0000644000000000000000000002353111777327303022100 0ustar0000000000000000{- | 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 (quickCheck) 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 System.Random (Random, randomR, mkStdGen) import Control.Monad (liftM) import qualified Numeric.NonNegative.Class as NonNeg import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Control.Monad.Trans.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, NonNeg.C time, Num time) => AbsBody.T time body -> RelBody.T time body -> Bool (==~) xs ys = xs == RelBody.toAbsoluteEventList 0 ys duration :: (NonNeg.C time, Num time) => RelBody.T time body -> Bool duration xs = AbsBody.duration $~ xs == RelBody.duration xs mapBody :: (Eq body1, NonNeg.C time, 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, Num 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, Num time, Random body, Eq body) => Int -> RelBody.T time (body, body) -> Bool mapBodyMRandom seed = mapBodyM (flip evalState (mkStdGen seed)) (state . randomR) filter :: (Eq body, NonNeg.C time, 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, NonNeg.C time, 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, NonNeg.C time, 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, NonNeg.C time, 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 :: (Eq body, NonNeg.C time, Num time) => RelBody.T time body -> Bool collectCoincident xs = AbsBody.collectCoincident $~ xs ==~ RelBody.collectCoincident xs collectCoincidentFoldr :: (Eq body, NonNeg.C time, Num time) => RelBody.T time body -> Bool collectCoincidentFoldr xs = AbsBody.collectCoincident $~ xs == AbsBody.collectCoincidentFoldr $~ xs collectCoincidentNonLazy :: (Eq body, NonNeg.C time, Num time) => RelBody.T time body -> Bool collectCoincidentNonLazy xs = AbsBody.collectCoincident $~ xs == AbsBody.collectCoincidentNonLazy $~ xs collectCoincidentInfinite :: (Eq body, NonNeg.C time, Num time) => NonEmptyList time body -> Bool collectCoincidentInfinite = checkInfinite . AbsBody.collectCoincident . makeUncollapsedInfiniteEventList flatten :: (Eq body, NonNeg.C time, Num time) => RelBody.T time [body] -> Bool flatten xs = AbsBody.flatten $~ xs ==~ RelBody.flatten xs normalize :: (Ord body, NonNeg.C time, Num time) => RelBody.T time body -> Bool normalize xs = AbsBody.normalize $~ xs ==~ RelBody.normalize xs merge :: (Ord body, NonNeg.C time, Num time) => RelBody.T time body -> RelBody.T time body -> Bool merge xs ys = AbsBody.merge $~ xs $~ ys ==~ RelBody.merge xs ys insert :: (Ord body, NonNeg.C time, Num time) => time -> body -> RelBody.T time body -> Bool insert t b xs = AbsBody.insert t b $~ xs ==~ RelBody.insert t b xs append :: (Eq body, NonNeg.C time, Num time) => RelBody.T time body -> RelBody.T time body -> Bool append xs ys = AbsBody.append $~ xs $~ ys ==~ RelBody.append xs ys concat :: (Eq body, NonNeg.C time, Num time) => [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 :: (Eq body, NonNeg.C time, Num time) => 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 :: (Eq body, NonNeg.C time, Num time) => 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, Num time) => NonEmptyList time body -> AbsBody.T time body makeUncollapsedInfiniteEventList = makeInfiniteEventList . mapFst (mapFst (1+)) makeInfiniteEventList :: (NonNeg.C time, Num 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 = AbsBody.switchL (error "BodyEnd.checkInfinite: empty list") const $ AbsBodyPriv.lift (Disp.drop 100) xs0 in x == x tests :: [(String, IO ())] tests = ("duration", quickCheck (duration :: RelBody.T TimeDiff ArbChar -> Bool)) : ("mapBody", quickCheck (mapBody toUpper :: RelBody.T TimeDiff ArbChar -> Bool)) : ("mapBodyM", quickCheck (mapBodyMRandom :: Int -> RelBody.T TimeDiff (ArbChar, ArbChar) -> Bool)) : ("filter", quickCheck (\c -> filter (c<) :: RelBody.T TimeDiff ArbChar -> Bool)) : ("catMaybes", quickCheck (catMaybes :: RelBody.T TimeDiff (Maybe ArbChar) -> Bool)) : ("partition", quickCheck (\c -> partition (c<) :: RelBody.T TimeDiff ArbChar -> Bool)) : ("slice", quickCheck (slice fst :: RelBody.T TimeDiff (ArbChar,ArbChar) -> Bool)) : ("collectCoincident", quickCheck (collectCoincident :: RelBody.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentFoldr", quickCheck (collectCoincidentFoldr :: RelBody.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentNonLazy", quickCheck (collectCoincidentNonLazy :: RelBody.T TimeDiff ArbChar -> Bool)) : ("collectCoincidentInfinite", quickCheck (collectCoincidentInfinite :: NonEmptyList TimeDiff ArbChar -> Bool)) : ("flatten", quickCheck (flatten :: RelBody.T TimeDiff [ArbChar] -> Bool)) : ("normalize", quickCheck (normalize :: RelBody.T TimeDiff ArbChar -> Bool)) : ("merge", quickCheck (merge :: RelBody.T TimeDiff ArbChar -> RelBody.T TimeDiff ArbChar -> Bool)) : ("insert", quickCheck (insert :: TimeDiff -> ArbChar -> RelBody.T TimeDiff ArbChar -> Bool)) : ("append", quickCheck (append :: RelBody.T TimeDiff ArbChar -> RelBody.T TimeDiff ArbChar -> Bool)) : ("concat", quickCheck (concat :: [RelBody.T TimeDiff ArbChar] -> Bool)) : ("decreaseStart", quickCheck (decreaseStart :: TimeDiff -> TimeDiff -> RelBody.T TimeDiff ArbChar -> Bool)) : ("delay", quickCheck (delay :: TimeDiff -> RelBody.T TimeDiff ArbChar -> Bool)) : ("resample", quickCheck (resample :: TimeDiff -> RelBody.T (TimeDiff, TimeDiff) ArbChar -> Bool)) : ("resampleInfinite", quickCheck (resampleInfinite :: TimeDiff -> NonEmptyList (TimeDiff, TimeDiff) ArbChar -> Bool)) : [] event-list-0.1.0.2/src/Data/0000755000000000000000000000000011777327303013602 5ustar0000000000000000event-list-0.1.0.2/src/Data/AlternatingList/0000755000000000000000000000000011777327303016706 5ustar0000000000000000event-list-0.1.0.2/src/Data/AlternatingList/Custom.hs0000644000000000000000000000274711777327303020526 0ustar0000000000000000{- | 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) event-list-0.1.0.2/src/Data/AlternatingList/List/0000755000000000000000000000000011777327303017621 5ustar0000000000000000event-list-0.1.0.2/src/Data/AlternatingList/List/Uniform.hs0000644000000000000000000001731011777327303021576 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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, zipWithFirst, zipWithSecond, concatMonoid, concatMapMonoid, sequence, sequence_, traverse, traverse_, traverseFirst, traverseSecond, getFirsts, getSeconds, length, genericLength, fromFirstList, fromSecondList, fromEitherList, singleton, isSingleton, cons, snoc, reverse, mapSecondHead, forceSecondHead, foldr, foldl, 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 Control.Applicative as Applicative import qualified Data.List as List import Control.Applicative (Applicative, pure, ) import Data.Monoid (Monoid, mempty, mappend, ) import Test.QuickCheck (Arbitrary, arbitrary, ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) {- 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, foldl, map, concat, length, reverse, sequence, sequence_, ) {- | 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 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) zipWithFirst :: (a0 -> a1 -> a2) -> [a0] -> T a1 b -> T a2 b zipWithFirst f xs (Cons a bs) = Cons a $ Disp.zipWithFirst f xs bs zipWithSecond :: (b0 -> b1 -> b2) -> (b0,[b0]) -> T a b1 -> T a b2 zipWithSecond f (x,xs) (Cons a bs) = Cons (f x a) $ Disp.zipWithSecond f xs bs concatMonoid :: Monoid m => T m m -> m concatMonoid = foldr mappend mappend mempty concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = concatMonoid . map f g sequence :: Applicative m => T (m a) (m b) -> m (T a b) sequence (Cons b xs) = Applicative.liftA2 Cons b (Disp.sequence xs) sequence_ :: (Applicative m, Monoid d) => T (m d) (m d) -> m d sequence_ (Cons b xs) = Applicative.liftA2 mappend b $ Disp.sequence_ xs traverse :: Applicative m => (a0 -> m a1) -> (b0 -> m b1) -> T a0 b0 -> m (T a1 b1) traverse aAction bAction = sequence . map aAction bAction traverse_ :: (Applicative m, Monoid d) => (a -> m d) -> (b -> m d) -> T a b -> m d traverse_ aAction bAction = sequence_ . map aAction bAction traverseFirst :: Applicative m => (a0 -> m a1) -> T a0 b -> m (T a1 b) traverseFirst aAction = traverse aAction pure traverseSecond :: Applicative m => (b0 -> m b1) -> T a b0 -> m (T a b1) traverseSecond bAction = traverse pure 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 forceSecondHead :: T a b -> T a b forceSecondHead = mapSecondHead id 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 {- The lazy pattern match leads to a space leak in synthesizer-alsa:testArrangeSpaceLeak I would like to reproduce this in a small test, but I did not achieve this so far. -} -- foldr f g d ~(Cons b xs) = g b $ Disp.foldr f g d xs foldl :: (c -> a -> d) -> (d -> b -> c) -> d -> T a b -> c foldl f g d0 xs = foldr (\a go c -> go (f c a)) (\b go d -> go (g d b)) id xs d0 -- for a nicer implementation see Mixed reverse :: T a b -> T a b reverse = foldl (\ ~(Cons a xs) b -> Disp.cons b a xs) (flip Cons) Disp.empty 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 []) event-list-0.1.0.2/src/Data/AlternatingList/List/Mixed.hs0000644000000000000000000002145211777327303021227 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2009 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, viewFirstL, viewSecondL, viewR, viewFirstR, viewSecondR, switchL, switchFirstL, switchSecondL, switchR, switchFirstR, switchSecondR, mapFirstL, mapFirstHead, mapFirstTail, mapSecondL, mapSecondHead, mapSecondTail, mapFirstR, mapFirstLast, mapFirstInit, mapSecondR, mapSecondLast, mapSecondInit, appendUniformUniform, appendDisparateUniform, appendUniformDisparate, concatUniform, concatDisparate, reverseUniform, reverseDisparate, 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.Tuple.HT (mapFst, mapSnd, mapPair, ) import Prelude hiding (null, foldr, map, concat, sequence, sequence_, ) 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) = Disp.switchR (Nothing, b0) (\ xs a b -> (Just (consSecond b0 xs, a), b)) xs0 viewFirstR :: Disp.T b a -> Maybe (Uniform.T a b, a) viewFirstR = Monad.liftM (\ (xs, ~(a,b)) -> (snocSecond xs a, b)) . Disp.viewR {- TODO: Must be more lazy in case of @viewSecondR (2 /. 'a' ./ 3 /. 'b' ./ 4 /. undefined)@. It must also return the @'b'@ but it does not. -} viewSecondR :: Uniform.T a b -> (Disp.T b a, b) viewSecondR (Uniform.Cons b0 xs0) = Disp.switchR (Disp.empty, b0) (\ xs a b -> (consFirst b0 (snocSecond xs a), b)) xs0 {-# INLINE switchL #-} switchL :: (b -> c) -> (b -> a -> Uniform.T a b -> c) -> Uniform.T a b -> c switchL f g = switchSecondL (\x -> switchFirstL (f x) (g x)) {-# INLINE switchFirstL #-} switchFirstL :: c -> (a -> Uniform.T a b -> c) -> Disp.T a b -> c switchFirstL f g = Disp.switchL f (\ a b xs -> g a (consSecond b xs)) {-# INLINE switchSecondL #-} switchSecondL :: (b -> Disp.T a b -> c) -> Uniform.T a b -> c switchSecondL f (Uniform.Cons b xs) = f b xs {- The lazy pattern match leads to a space leak in synthesizer-alsa:testArrangeSpaceLeak I would like to reproduce this in a small test, but I did not achieve this so far. -} -- switchSecondL f ~(Uniform.Cons b xs) = f b xs {-# INLINE switchR #-} switchR :: (b -> c) -> (Uniform.T a b -> a -> b -> c) -> Uniform.T a b -> c switchR f g = switchSecondR (\xs b -> switchFirstR (f b) (\ys a -> g ys a b) xs) {-# INLINE switchFirstR #-} switchFirstR :: c -> (Uniform.T a b -> a -> c) -> Disp.T b a -> c switchFirstR f g = maybe f (uncurry g) . viewFirstR {-# INLINE switchSecondR #-} switchSecondR :: (Disp.T b a -> b -> c) -> Uniform.T a b -> c switchSecondR f = uncurry f . viewSecondR -- 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) reverseUniform :: Uniform.T a b -> Uniform.T a b reverseUniform = Uniform.foldl (flip consFirst) (flip consSecond) Disp.empty reverseDisparate :: Disp.T a b -> Disp.T b a reverseDisparate = Disp.foldl (flip consSecond) (flip consFirst) Disp.empty 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 = switchSecondL (\ b xs -> appendUniformDisparate b (concatDisparate xs)) 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 = switchFirstL (error "dropUniform: empty list") (flip const) . 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 recourse xs0 = (\(b,xs) -> if p b then (empty, xs0) else maybe (\(a,ys) ->) let (as,) = recourse 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 -} event-list-0.1.0.2/src/Data/AlternatingList/List/Disparate.hs0000644000000000000000000001755511777327303022106 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2009 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, zipWithFirst, zipWithSecond, concatMonoid, concatMapMonoid, sequence, sequence_, traverse, traverse_, traverseFirst, traverseSecond, getFirsts, getSeconds, length, genericLength, empty, singleton, null, cons, snoc, viewL, viewR, switchL, switchR, mapHead, mapLast, foldr, foldrPair, foldl, reverse, format, append, concat, cycle, splitAt, take, drop, genericSplitAt, genericTake, genericDrop, spanFirst, spanSecond, ) where import Data.Tuple.HT (mapSnd, mapPair, ) import qualified Data.List as List import qualified Data.List.HT as ListHT import qualified Control.Monad as Monad import qualified Control.Applicative as Applicative import qualified Data.Traversable as Trav import Control.Applicative (Applicative, pure, ) import Data.Monoid (Monoid, mempty, mappend, ) import Test.QuickCheck (Arbitrary, arbitrary, ) import Prelude hiding (null, foldr, foldl, map, concat, cycle, length, take, drop, splitAt, reverse, sequence, sequence_, ) 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 instance (Arbitrary a, Arbitrary b) => Arbitrary (T a b) where arbitrary = Monad.liftM Cons arbitrary 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 {-# INLINE mapPairFirst #-} mapPairFirst :: (a0 -> a1) -> Pair a0 b -> Pair a1 b mapPairFirst f e = e{pairFirst = f (pairFirst e)} {-# INLINE mapPairSecond #-} mapPairSecond :: (b0 -> b1) -> Pair a b0 -> Pair a b1 mapPairSecond f e = e{pairSecond = f (pairSecond e)} {-# INLINE map #-} map :: (a0 -> a1) -> (b0 -> b1) -> T a0 b0 -> T a1 b1 map f g = lift (List.map (mapPairFirst f . mapPairSecond g)) {-# INLINE mapFirst #-} mapFirst :: (a0 -> a1) -> T a0 b -> T a1 b mapFirst f = lift (List.map (mapPairFirst f)) {-# INLINE mapSecond #-} mapSecond :: (b0 -> b1) -> T a b0 -> T a b1 mapSecond g = lift (List.map (mapPairSecond g)) zipWithFirst :: (a0 -> a1 -> a2) -> [a0] -> T a1 b -> T a2 b zipWithFirst f xs = lift $ zipWith (\x (Pair a b) -> Pair (f x a) b) xs zipWithSecond :: (b0 -> b1 -> b2) -> [b0] -> T a b1 -> T a b2 zipWithSecond f xs = lift $ zipWith (\x (Pair a b) -> Pair a (f x b)) xs concatMonoid :: Monoid m => T m m -> m concatMonoid = foldr mappend mappend mempty concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = concatMonoid . map f g sequence :: Applicative m => T (m a) (m b) -> m (T a b) sequence = Applicative.liftA Cons . Trav.traverse (\(Pair a b) -> Applicative.liftA2 Pair a b) . decons sequence_ :: (Applicative m, Monoid d) => T (m d) (m d) -> m d sequence_ = foldr (Applicative.liftA2 mappend) (Applicative.liftA2 mappend) $ pure mempty -- Trav.traverse_ (\(Pair a b) -> Applicative.liftA2 mappend a b) . decons traverse :: Applicative m => (a0 -> m a1) -> (b0 -> m b1) -> T a0 b0 -> m (T a1 b1) traverse aAction bAction = sequence . map aAction bAction traverse_ :: (Applicative m, Monoid d) => (a -> m d) -> (b -> m d) -> T a b -> m d traverse_ aAction bAction = sequence_ . map aAction bAction traverseFirst :: Applicative m => (a0 -> m a1) -> T a0 b -> m (T a1 b) traverseFirst aAction = traverse aAction pure traverseSecond :: Applicative m => (b0 -> m b1) -> T a b0 -> m (T a b1) traverseSecond bAction = traverse pure 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 = switchL Nothing (\a b xs -> Just ((a, b), xs)) {-# INLINE switchL #-} switchL :: c -> (a -> b -> T a b -> c) -> T a b -> c switchL f g (Cons ys) = case ys of (Pair a b : xs) -> g a b (Cons xs) [] -> f {-# INLINE mapHead #-} mapHead :: ((a,b) -> (a,b)) -> T a b -> T a b mapHead f = switchL empty (curry (uncurry cons . 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))) . ListHT.viewR . decons {-# INLINE switchR #-} switchR :: c -> (T a b -> a -> b -> c) -> T a b -> c switchR f g = maybe f (\ ~(xs, ~(Pair a b)) -> g (Cons xs) a b) . ListHT.viewR . decons {-# INLINE mapLast #-} 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 foldl :: (c -> a -> d) -> (d -> b -> c) -> c -> T a b -> c foldl f g c0 xs = foldr (\a go c -> go (f c a)) (\b go d -> go (g d b)) id xs c0 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 -- for a nicer implementation see Mixed reverse :: T a b -> T b a reverse = foldl (flip (,)) (\ ~(a,xs) b -> cons b a xs) empty {- | 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 -} event-list-0.1.0.2/src/Data/EventList/0000755000000000000000000000000011777327303015517 5ustar0000000000000000event-list-0.1.0.2/src/Data/EventList/Utility.hs0000644000000000000000000000305011777327303017514 0ustar0000000000000000module Data.EventList.Utility where -- State monad could be avoided by mapAccumL import Control.Monad.Trans.State (State, state, modify, gets, ) import qualified Data.List as List import Data.Tuple.HT (mapPair, ) {- | 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 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 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)) event-list-0.1.0.2/src/Data/EventList/Relative/0000755000000000000000000000000011777327303017272 5ustar0000000000000000event-list-0.1.0.2/src/Data/EventList/Relative/BodyBody.hs0000644000000000000000000000214411777327303021342 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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, concatMapMonoid, traverse, mapM, ) where import Data.EventList.Relative.BodyBodyPrivate -- import qualified Data.AlternatingList.List.Disparate as Disp import qualified Data.AlternatingList.List.Uniform as Uniform import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), liftA, ) import Data.Monoid (Monoid, ) import Prelude hiding (mapM) concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Uniform.concatMapMonoid f g . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse f g = liftA Cons . Uniform.traverse f g . decons mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = unwrapMonad . traverse (WrapMonad . f) (WrapMonad . g) event-list-0.1.0.2/src/Data/EventList/Relative/BodyTimePrivate.hs0000644000000000000000000000451411777327303022701 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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 qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Control.Applicative as App import Data.Monoid (Monoid, mempty, mappend, ) import Test.QuickCheck (Arbitrary(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 instance Monoid (T time body) where mempty = Cons Disp.empty mappend (Cons x) (Cons y) = Cons (Disp.append x y) instance Functor (T time) where fmap f (Cons x) = Cons (Disp.mapFirst f x) instance Fold.Foldable (T time) where foldMap = Trav.foldMapDefault instance Trav.Traversable (T time) where traverse f = App.liftA Cons . Disp.traverse f App.pure . decons 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 liftA :: App.Applicative m => (Disp.T body0 time0 -> m (Disp.T body1 time1)) -> (T time0 body0 -> m (T time1 body1)) liftA f = App.liftA 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 -- mconcat concat :: -- (NonNeg.C time) => [T time body] -> T time body concat = Cons . Disp.concat . map decons -- mcycle - if it would be a standard function 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 event-list-0.1.0.2/src/Data/EventList/Relative/BodyTime.hs0000644000000000000000000001043611777327303021346 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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, empty, singleton, null, fromPairList, toPairList, getTimes, getBodies, duration, durationR, mapBody, mapTime, concatMapMonoid, traverse, traverse_, traverseBody, traverseTime, mapM, mapM_, mapBodyM, mapTimeM, foldr, foldrPair, cons, snoc, viewL, viewR, switchL, switchR, span, ) where import Data.EventList.Relative.BodyTimePrivate import qualified Data.AlternatingList.List.Disparate as Disp -- import qualified Data.AlternatingList.List.Uniform as Uniform import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Data.Monoid (Monoid, mempty, ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import qualified Data.List as List import Prelude hiding (mapM, mapM_, foldr, span, null, ) fromPairList :: [(body, time)] -> T time body fromPairList = Cons . Disp.fromPairList toPairList :: T time body -> [(body, time)] toPairList = Disp.toPairList . decons getBodies :: T time body -> [body] getBodies = Disp.getFirsts . decons getTimes :: T time body -> [time] getTimes = Disp.getSeconds . decons duration :: Num time => T time body -> time duration = sum . getTimes durationR :: Num time => T time body -> time durationR = List.foldr (+) 0 . getTimes mapBody :: (body0 -> body1) -> T time body0 -> T time body1 mapBody f = lift (Disp.mapFirst f) mapTime :: (time0 -> time1) -> T time0 body -> T time1 body mapTime f = lift (Disp.mapSecond f) concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Disp.concatMapMonoid g f . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse timeAction bodyAction = liftA (Disp.traverse bodyAction timeAction) traverse_ :: Applicative m => (time -> m ()) -> (body -> m ()) -> T time body -> m () traverse_ f g = Disp.traverse_ g f . decons traverseBody :: Applicative m => (body0 -> m body1) -> T time body0 -> m (T time body1) traverseBody f = liftA (Disp.traverseFirst f) traverseTime :: Applicative m => (time0 -> m time1) -> T time0 body -> m (T time1 body) traverseTime f = liftA (Disp.traverseSecond f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM timeAction bodyAction = unwrapMonad . traverse (WrapMonad . timeAction) (WrapMonad . bodyAction) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = unwrapMonad . traverse_ (WrapMonad . f) (WrapMonad . g) mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = unwrapMonad . traverseBody (WrapMonad . f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = unwrapMonad . traverseTime (WrapMonad . f) foldr :: (body -> a -> b) -> (time -> b -> a) -> b -> T time body -> b foldr f g x = Disp.foldr f g x . decons foldrPair :: (body -> time -> a -> a) -> a -> T time body -> a foldrPair f x = Disp.foldrPair f x . decons empty :: T time body empty = mempty null :: T time body -> Bool null = Disp.null . decons singleton :: body -> time -> T time body singleton body time = Cons $ Disp.singleton body time cons :: body -> time -> T time body -> T time body cons body time = lift (Disp.cons body time) snoc :: T time body -> body -> time -> T time body snoc xs body time = Cons $ (Disp.snoc $*~ xs) body time viewL :: T time body -> Maybe ((body, time), T time body) viewL = fmap (mapSnd Cons) . Disp.viewL . decons viewR :: T time body -> Maybe (T time body, (body, time)) viewR = fmap (mapFst Cons) . Disp.viewR . decons {-# INLINE switchL #-} switchL :: c -> (body -> time -> T time body -> c) -> T time body -> c switchL f g = Disp.switchL f (\ b t -> g b t . Cons) . decons {-# INLINE switchR #-} switchR :: c -> (T time body -> body -> time -> c) -> T time body -> c switchR f g = Disp.switchR f (\xs b t -> g (Cons xs) b t) . decons span :: (body -> Bool) -> T time body -> (T time body, T time body) span p = mapPair (Cons, Cons) . Disp.spanFirst p . decons event-list-0.1.0.2/src/Data/EventList/Relative/TimeTimePrivate.hs0000644000000000000000000001510511777327303022700 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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 Data.EventList.Relative.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 Numeric.NonNegative.Class as NonNeg import Numeric.NonNegative.Class (zero, add, ) import Data.Tuple.HT (mapFst, mapSnd, ) import qualified Control.Monad as Monad import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Control.Applicative as App import Control.Applicative (Applicative, ) import Data.Monoid (Monoid, mempty, mappend, mconcat, ) import Test.QuickCheck (Arbitrary(arbitrary)) import Prelude hiding (foldr, ) 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 instance (NonNeg.C time) => Monoid (T time body) where mempty = Cons (Uniform.singleton zero) mappend = append mconcat = flatten . consTime zero . mconcat . map (consBody [] . fmap (:[])) append, appendAlt, appendSwitch :: (NonNeg.C time) => T time body -> T time body -> T time body append xs ys = forceTimeHead $ foldr delay (\b -> consTime NonNeg.zero . consBody b) ys xs appendAlt xs ys = foldr (\t -> delay t . either id (consTime NonNeg.zero)) (\b -> Right . consBody b) (Left ys) xs {- not lazy enough for @append (2 /. 'a' ./ 4 /. 'b' ./ 2 /. undefined) undefined@ -} appendSwitch = switchTimeR (\ xs t -> lift (Mixed.appendDisparateUniform $~* xs) . delay t) instance Functor (T time) where fmap f (Cons x) = Cons (Uniform.mapFirst f x) instance Fold.Foldable (T time) where foldMap = Trav.foldMapDefault instance Trav.Traversable (T time) where traverse f = App.liftA Cons . Uniform.traverse f App.pure . decons 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 liftA :: Applicative m => (Uniform.T body0 time0 -> m (Uniform.T body1 time1)) -> (T time0 body0 -> m (T time1 body1)) liftA f = App.liftA 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 {-# INLINE switchTimeL #-} switchTimeL :: (time -> BodyTimeList.T time body -> a) -> T time body -> a switchTimeL f = Mixed.switchSecondL (\b -> f b . BodyTimePriv.Cons) . decons {-# INLINE switchBodyL #-} switchBodyL :: a -> (body -> T time body -> a) -> BodyTimeList.T time body -> a switchBodyL f g = Mixed.switchFirstL f (\t -> g t . Cons) . BodyTimePriv.decons {-# INLINE switchTimeR #-} switchTimeR :: (TimeBodyList.T time body -> time -> a) -> T time body -> a switchTimeR f = Mixed.switchSecondR (f . TimeBodyPriv.Cons) . decons {-# INLINE switchBodyR #-} switchBodyR :: a -> (T time body -> body -> a) -> TimeBodyList.T time body -> a switchBodyR f g = Mixed.switchFirstR f (g . Cons) . 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 f = switchTimeL (\time -> consTime time . f) {- This causes a memory leak when used with chunky time values. I have found this problem in synthesizer-alsa:EventList.MIDI.matchNote, but I could not reliably reproduce that in smaller setups. 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 foldr :: (time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b foldr f g x = Uniform.foldr g f x . decons forceTimeHead :: (NonNeg.C time) => T time body -> T time body forceTimeHead = mapTimeHead id delay :: (NonNeg.C time) => time -> T time body -> T time body delay dif = mapTimeHead (add dif) flatten :: (NonNeg.C time) => T time [body] -> T time body flatten = Cons . Uniform.foldr (Mixed.appendUniformUniform . Uniform.fromSecondList zero) Mixed.consSecond -- consTime Disp.empty . -- (\(b:bs) xs -> consBody b (List.foldr (cons 0) xs bs)) empty . Uniform.mapSecond NonNeg.sum . Uniform.filterFirst (not . null) . decons event-list-0.1.0.2/src/Data/EventList/Relative/TimeBodyPrivate.hs0000644000000000000000000000522011777327303022674 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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 qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Control.Applicative as App import Control.Applicative (Applicative, ) import Data.Monoid (Monoid, mempty, mappend, ) import Data.Tuple.HT (mapSnd, ) import Test.QuickCheck (Arbitrary(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 instance Monoid (T time body) where mempty = Cons Disp.empty mappend (Cons x) (Cons y) = Cons (Disp.append x y) instance Functor (T time) where fmap f (Cons x) = Cons (Disp.mapSecond f x) instance Fold.Foldable (T time) where foldMap = Trav.foldMapDefault instance Trav.Traversable (T time) where traverse f = App.liftA Cons . Disp.traverse App.pure f . decons 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 liftA :: Applicative m => (Disp.T time0 body0 -> m (Disp.T time1 body1)) -> (T time0 body0 -> m (T time1 body1)) liftA f = App.liftA 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 event-list-0.1.0.2/src/Data/EventList/Relative/MixedBody.hs0000644000000000000000000000424311777327303021515 0ustar0000000000000000{- | 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, switchTimeL, switchBodyL, 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.Tuple.HT (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 {-# INLINE switchTimeL #-} switchTimeL :: a -> (time -> BodyBodyList.T time body -> a) -> TimeBodyList.T time body -> a switchTimeL f g = Mixed.switchFirstL f (\t -> g t . BodyBodyPriv.Cons) . TimeBodyPriv.decons {-# INLINE switchBodyL #-} switchBodyL :: (body -> TimeBodyList.T time body -> a) -> BodyBodyList.T time body -> a switchBodyL f = Mixed.switchSecondL (\b -> f b . TimeBodyPriv.Cons) . BodyBodyPriv.decons event-list-0.1.0.2/src/Data/EventList/Relative/TimeMixed.hs0000644000000000000000000000774111777327303021524 0ustar0000000000000000{- | 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, switchTimeR, switchBodyR, 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, switchTimeR, switchBodyR, 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.Tuple.HT (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 = switchTimeR (\ xs t -> TimeBodyList.append xs . TimeBodyList.delay t) {- | 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 = mapFst Uniform.forceSecondHead . Mixed.switchFirstL (Mixed.consSecond NonNeg.zero Disp.empty, Disp.empty) (\t1 xs -> let (mt,~(before,dt)) = NonNeg.split t0 t1 in mapFst (Mixed.consSecond mt) $ if before then (Disp.empty, Mixed.consFirst dt xs) else Mixed.switchSecondL (\b ys -> mapFst (Mixed.consFirst b) $ splitAtTimeAux dt ys) xs) splitAtTime :: (NonNeg.C time) => time -> TimeBodyList.T time body -> (TimeTimeList.T time body, TimeBodyList.T time body) splitAtTime t = mapPair (TimeTimePriv.Cons, TimeBodyPriv.Cons) . splitAtTimeAux t . 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 event-list-0.1.0.2/src/Data/EventList/Relative/BodyBodyPrivate.hs0000644000000000000000000000350411777327303022676 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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 qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Control.Applicative as App import Test.QuickCheck (Arbitrary(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 {- instance Monoid (T time body) where mempty cannot be defined mappend could be defined by inserting a time difference of zero -} instance Functor (T time) where fmap f (Cons x) = Cons (Uniform.mapSecond f x) instance Fold.Foldable (T time) where foldMap = Trav.foldMapDefault instance Trav.Traversable (T time) where traverse f = App.liftA Cons . Uniform.traverse App.pure f . decons 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 event-list-0.1.0.2/src/Data/EventList/Relative/MixedTime.hs0000644000000000000000000000361311777327303021516 0ustar0000000000000000{- | 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, switchTimeL, switchBodyL, 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.Tuple.HT (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 event-list-0.1.0.2/src/Data/EventList/Relative/TimeTime.hs0000644000000000000000000004525211777327303021353 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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, zipWithBody, zipWithTime, unzip, concatMapMonoid, traverse, traverse_, traverseBody, traverseTime, mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration, merge, mergeBy, insert, {- insertBy, -} pad, moveForward, moveForwardRestricted, moveBackward, arrange, arrangeBy, moveForwardRestrictedBy, moveForwardRestrictedByQueue, moveForwardRestrictedByStrict, decreaseStart, delay, filter, partition, partitionMaybe, partitionMaybeR, slice, foldr, foldl, pause, isPause, cons, snoc, viewL, viewR, switchL, switchR, mapMaybe, catMaybes, catMaybesR, append, concat, concatNaive, cycle, cycleNaive, reverse, splitAtTime, takeTime, dropTime, forceTimeHead, discretize, resample, collectCoincident, flatten, mapCoincident, normalize, isNormalized, toAbsoluteEventList, fromAbsoluteEventList, ) where import Data.EventList.Relative.TimeTimePrivate as TimeTimePriv 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 Data.Monoid (Monoid, mempty, mconcat, ) import qualified Numeric.NonNegative.Class as NonNeg import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, ) import Data.EventList.Utility (floorDiff, ) import Control.Monad.Trans.State (evalState, modify, get, gets, put, ) import Control.Monad (liftM2, ) import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Prelude hiding (null, foldr, foldl, map, filter, concat, cycle, reverse, sequence, sequence_, mapM, mapM_, unzip, ) 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 :: NonNeg.C time => T time body -> time duration = NonNeg.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 {-# INLINE switchL #-} switchL :: (time -> a) -> ((time, body) -> T time body -> a) -> T time body -> a switchL f g = Mixed.switchL f (\t b -> g (t,b) . Cons) . decons viewR :: T time body -> (Maybe (T time body, body), time) viewR = mapFst (fmap (mapFst Cons)) . Mixed.viewR . decons {-# INLINE switchR #-} switchR :: (time -> a) -> (T time body -> body -> time -> a) -> T time body -> a switchR f g = Mixed.switchR f (g . Cons) . 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 zipWithBody :: (body0 -> body1 -> body2) -> [body0] -> T time body1 -> T time body2 zipWithBody f = lift . Uniform.zipWithFirst f zipWithTime :: (time0 -> time1 -> time2) -> (time0, [time0]) -> T time1 body -> T time2 body zipWithTime f = lift . Uniform.zipWithSecond f unzip :: T time (body0, body1) -> (T time body0, T time body1) unzip = foldr (\time -> mapPair (consTime time, consTime time)) (\(body0, body1) -> mapPair (consBody body0, consBody body1)) (mempty, mempty) concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Uniform.concatMapMonoid g f . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse f g = liftA (Uniform.traverse g f) traverse_ :: Applicative m => (time -> m ()) -> (body -> m ()) -> T time body -> m () traverse_ f g = Uniform.traverse_ g f . decons traverseBody :: Applicative m => (body0 -> m body1) -> T time body0 -> m (T time body1) traverseBody f = liftA (Uniform.traverseFirst f) traverseTime :: Applicative m => (time0 -> m time1) -> T time0 body -> m (T time1 body) traverseTime f = liftA (Uniform.traverseSecond f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = unwrapMonad . traverse (WrapMonad . f) (WrapMonad . g) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = unwrapMonad . traverse_ (WrapMonad . f) (WrapMonad . g) mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = unwrapMonad . traverseBody (WrapMonad . f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = unwrapMonad . traverseTime (WrapMonad . f) {- | 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 isAscending . 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 'splitAt' and 'insert'. -} mergeBy :: (NonNeg.C time) => (body -> body -> Bool) -> T time body -> T time body -> T time body mergeBy before = let recourse xs0 ys0 = let (xt,xs) = viewTimeL xs0 (yt,ys) = viewTimeL ys0 (mt,~(bef,dt)) = NonNeg.split xt yt in delay mt $ if dt == zero then case (viewBodyL xs, viewBodyL ys) of (Nothing, _) -> consTime zero ys (_, Nothing) -> consTime zero 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 recourse with 'mergeBy' on xs or ys -} if before b0 b1 then cons zero b0 $ recourse xs1 (consTime zero ys) else cons zero b1 $ recourse (consTime zero xs) ys1 else if bef then let ys1 = consTime dt ys in flip (switchBodyL ys1) xs $ \ b xs1 -> cons zero b $ recourse xs1 ys1 else let xs1 = consTime dt xs in flip (switchBodyL xs1) ys $ \ b ys1 -> cons zero b $ recourse xs1 ys1 in recourse {- | 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 Haskore/section equivalence. It is also necessary to assert a unique representation of the event list independent of the structure of the event type. The same function for inserting into a time ordered list with a trailing pause. -} 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 = switchTimeL $ \ t1 xs0 -> let (mt,~(b,dt)) = NonNeg.split t1 t in delay mt $ if not b then cons zero me0 $ consTime dt xs0 else switchBodyL (cons dt me0 $ pause zero) (\ me1 xs -> consTime zero $ if dt==zero && before me0 me1 then consBody me0 (cons zero me1 xs) else consBody me1 (recurseTime dt xs)) xs0 in recurseTime t0 {- Ensure that the list has a minimum length by extending the last pause accordingly. -} pad :: (NonNeg.C time) => time -> T time body -> T time body pad time = mergeBy (\ _ _ -> False) (pause time) {- | Move events towards the front of the event list. You must make sure, that no event is moved before time zero. This works only for finite lists. -} moveForward :: (Ord time, Num time) => T time (time, body) -> T time body moveForward = fromAbsoluteEventList . AbsoluteEventList.moveForward . toAbsoluteEventList 0 moveBackward :: (NonNeg.C time) => T time (time, body) -> T time body moveBackward = catMaybes . foldr (\t -> cons t Nothing) (\(t,b) -> insertBy (ltMaybe (\_ _ -> True)) t (Just b)) (pause zero) {- | Like 'moveForward' but restricts the look-ahead time. For @moveForwardRestricted maxTimeDiff xs@ all time differences (aka the moveForward offsets) in @xs@ must be at most @maxTimeDiff@. With this restriction the function is lazy enough for handling infinite event lists. However the larger @maxTimeDiff@ the more memory and time is consumed. -} {- Implementation notes: We keep a (non-optimized) priority queue as the state of a state monad. In a pause we emit all events that occur in this duration. -} moveForwardRestricted :: (Ord body, NonNeg.C time) => time -> T time (time, body) -> T time body moveForwardRestricted maxTime = decreaseStart maxTime . moveBackward . mapBody (mapFst (maxTime-|)) . pad maxTime {- moveForwardRestrictedBy (\_ _ -> True) -- (<) -} ltMaybe :: (body -> body -> Bool) -> (Maybe body -> Maybe body -> Bool) ltMaybe cmp mx my = case (mx,my) of (Nothing, _) -> True (_, Nothing) -> False (Just x, Just y) -> cmp x y -- | currently only for testing moveForwardRestrictedBy :: (NonNeg.C time) => (body -> body -> Bool) -> time -> T time (time, body) -> T time body moveForwardRestrictedBy cmp maxTime = decreaseStart maxTime . catMaybes . foldr (\t -> cons t Nothing) (\(t,b) -> insertBy (ltMaybe cmp) (maxTime-|t) (Just b)) (pause maxTime) -- | currently only for testing moveForwardRestrictedByStrict :: (NonNeg.C time) => (body -> body -> Bool) -> time -> T time (time, body) -> T time body moveForwardRestrictedByStrict cmp maxTime = decreaseStart maxTime . foldr delay (\(t,b) -> insertBy cmp (maxTime-|t) b) (pause maxTime) -- | currently only for testing moveForwardRestrictedByQueue :: (NonNeg.C time, Num time) => (body -> body -> Bool) -> time -> T time (time, body) -> T time body moveForwardRestrictedByQueue cmp maxTime xs = let (prefix,suffix) = splitAtTime maxTime xs prefixDur = duration prefix {- maxTime would work in most cases, too -} getChunk t = do (toEmit,toKeep) <- gets (splitAtTime t) put toKeep return (pad t toEmit) insertEvent (t,b) = insertBy cmp (maxTime - t) b in evalState (foldr (\t m -> liftM2 append (getChunk t) m) (\b m -> modify (insertEvent b) >> m) (gets (pad prefixDur)) suffix) (moveForward (seq prefixDur prefix)) {- this way 'prefixDur' will be computed early and 'prefix' need not to be stored until the end of the list -} {- | Merge several event lists respecting the start time of the outer event list. -} arrange :: (Ord body, NonNeg.C time) => T time (T time body) -> T time body arrange = arrangeBy (\_ _ -> True) arrangeBy :: (NonNeg.C time) => (body -> body -> Bool) -> T time (T time body) -> T time body arrangeBy cmp = catMaybes . foldr (\t -> cons t Nothing) (\xs -> mergeBy (ltMaybe cmp) (mapBody Just xs)) (pause zero) concat :: (NonNeg.C time) => [T time body] -> T time body concat = mconcat {- | '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 zero) {- | Uses sharing. -} cycle :: (NonNeg.C time) => T time body -> T time body cycle = switchTimeL (\t0 xs -> consTime t0 $ BodyTimePriv.cycle $ BodyTimePriv.mapTimeLast (add t0) xs) 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 = switchTimeL (\t1 xs -> let (mt,~(bef,dt)) = NonNeg.split t0 t1 in {- The handling of the second pair member looks a bit cumbersome, but it is necessary to prepend the time once in order to prevent a memory leak. -} mapPair (consTime mt, forceTimeHead) $ if bef then (mempty, consTime dt xs) else switchBodyL (mempty, pause zero) (\ b -> mapFst (consBody b) . splitAtTime dt) xs) 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 dropTime t0 = switchTimeL (\t1 xs -> let (bef,dt) = snd $ NonNeg.split t0 t1 in forceTimeHead $ if bef then consTime dt xs else switchBodyL (pause zero) (\ _b -> dropTime dt) xs) {- Surprisingly this has a space leak, see test dropTimeLazyInfinite. dropTime :: (NonNeg.C time) => time -> T time body -> T time body dropTime t0 = switchTimeL (\t1 xs -> let (bef,dt) = snd $ NonNeg.split t0 t1 in if bef then consTime dt xs else switchBodyL (pause zero) (\ _b -> dropTime dt) xs) -} decreaseStart :: (NonNeg.C time) => time -> T time body -> T time body decreaseStart dif = mapTimeHead (-| dif) collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident = mapTimeInit TimeBodyList.collectCoincident 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 :: (NonNeg.C time) => (body -> Bool) -> T time body -> T time body filter p = mapMaybe (\b -> toMaybe (p b) b) mapMaybe :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> T time body1 mapMaybe f = catMaybes . mapBody f {- | Adds times in a left-associative fashion. Use this if the time is a strict data type. -} catMaybes :: (NonNeg.C time) => T time (Maybe body) -> T time body catMaybes = mapTime NonNeg.sum . lift Uniform.catMaybesFirst {- | Adds times in a right-associative fashion. Use this if the time is a data type like lazy Peano numbers or "Numeric.NonNegative.Chunky". -} catMaybesR :: (NonNeg.C time) => T time (Maybe body) -> T time body catMaybesR = foldr (mapTimeHead . add) (maybe id (cons zero)) (pause zero) partition :: (NonNeg.C time) => (body -> Bool) -> T time body -> (T time body, T time body) partition p = mapPair (mapTime NonNeg.sum, mapTime NonNeg.sum) . mapPair (Cons, Cons) . Uniform.partitionFirst p . decons partitionMaybe :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> (T time body1, T time body0) partitionMaybe f = mapPair (mapTime NonNeg.sum . Cons, mapTime NonNeg.sum . Cons) . Uniform.partitionMaybeFirst f . decons {- | Cf. 'catMaybesR' -} partitionMaybeR :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> (T time body1, T time body0) partitionMaybeR f = mapPair (mapTime (List.foldr add zero), mapTime (List.foldr add zero)) . mapPair (Cons, Cons) . Uniform.partitionMaybeFirst f . decons {- | Since we need it later for MIDI generation, we will also define a slicing into equivalence classes of events. -} slice :: (Eq a, NonNeg.C time) => (body -> a) -> T time body -> [(a, T time body)] slice = Utility.slice (fmap fst . viewBodyL . snd . viewTimeL) partition foldl :: (a -> time -> b) -> (b -> body -> a) -> a -> T time body -> b foldl f g x = Uniform.foldl g f x . decons reverse :: T time body -> T time body reverse = lift Uniform.reverse 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 event-list-0.1.0.2/src/Data/EventList/Relative/TimeBody.hs0000644000000000000000000004026511777327303021351 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 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, switchL, switchR, cons, snoc, fromPairList, toPairList, getTimes, getBodies, duration, mapBody, mapTime, zipWithBody, zipWithTime, unzip, concatMapMonoid, traverse, traverse_, traverseBody, traverseTime, mapM, mapM_, mapBodyM, mapTimeM, foldr, foldrPair, merge, mergeBy, insert, insertBy, moveForward, decreaseStart, delay, filter, partition, partitionMaybe, 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 Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Data.Monoid (Monoid, ) import qualified Numeric.NonNegative.Class as NonNeg import Numeric.NonNegative.Class ((-|), zero, add, ) import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, ) import Control.Monad.Trans.State (evalState, modify, get, put, ) import Prelude hiding (mapM, mapM_, unzip, 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 {-# INLINE switchL #-} switchL :: c -> ((time, body) -> T time body -> c) -> T time body -> c switchL f g = Disp.switchL f (\ t b -> g (t,b) . Cons) . decons {-# INLINE switchR #-} switchR :: c -> (T time body -> (time, body) -> c) -> T time body -> c switchR f g = Disp.switchR f (\xs t b -> g (Cons xs) (t,b)) . 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 :: NonNeg.C time => T time body -> time duration = NonNeg.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) zipWithBody :: (body0 -> body1 -> body2) -> [body0] -> T time body1 -> T time body2 zipWithBody f = lift . Disp.zipWithSecond f zipWithTime :: (time0 -> time1 -> time2) -> [time0] -> T time1 body -> T time2 body zipWithTime f = lift . Disp.zipWithFirst f unzip :: T time (body0, body1) -> (T time body0, T time body1) unzip = foldrPair (\time (body0, body1) -> mapPair (cons time body0, cons time body1)) (empty, empty) concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Disp.concatMapMonoid f g . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse f g = liftA (Disp.traverse f g) traverse_ :: Applicative m => (time -> m ()) -> (body -> m ()) -> T time body -> m () traverse_ f g = Disp.traverse_ f g . decons traverseBody :: Applicative m => (body0 -> m body1) -> T time body0 -> m (T time body1) traverseBody f = liftA (Disp.traverseSecond f) traverseTime :: Applicative m => (time0 -> m time1) -> T time0 body -> m (T time1 body) traverseTime f = liftA (Disp.traverseFirst f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = unwrapMonad . traverse (WrapMonad . f) (WrapMonad . g) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = unwrapMonad . traverse_ (WrapMonad . f) (WrapMonad . g) mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = unwrapMonad . traverseBody (WrapMonad . f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = unwrapMonad . traverseTime (WrapMonad . 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 {- | Keep only events that match a predicate while preserving absolute times. -} filter :: (NonNeg.C time) => (body -> Bool) -> T time body -> T time body filter p = mapMaybe (\b -> toMaybe (p b) b) -- filter p = fst . partition p mapMaybe :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> T time body1 mapMaybe f = catMaybes . mapBody f {- | Adds times in a left-associative fashion. Use this if the time is a strict data type. -} catMaybes :: (NonNeg.C time) => T time (Maybe body) -> T time body catMaybes = Cons . fst . Mixed.viewSecondR . Uniform.mapSecond NonNeg.sum . Uniform.catMaybesFirst . flip Mixed.snocSecond (error "catMaybes: no trailing time") . 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. -} {- Could be implemented more easily in terms of Uniform.partition -} partition :: (NonNeg.C time) => (body -> Bool) -> T time body -> (T time body, T time body) partition p = partitionRec p zero zero partitionRec :: (NonNeg.C time) => (body -> Bool) -> time -> time -> T time body -> (T time body, T time body) partitionRec p = let recourse t0 t1 = switchL (empty, empty) (\ (t, b) es -> let t0' = add t0 t t1' = add t1 t in if p b then mapFst (cons t0' b) (recourse zero t1' es) else mapSnd (cons t1' b) (recourse t0' zero es)) in recourse partitionMaybe :: (NonNeg.C time) => (body0 -> Maybe body1) -> T time body0 -> (T time body1, T time body0) partitionMaybe f = mapPair (catMaybes, catMaybes) . foldrPair (\t a -> let mb = f a a1 = maybe (Just a) (const Nothing) mb in mapPair (cons t mb, cons t a1)) (empty, empty) {- | Using a classification function we splice the event list into lists, each containing the same class. Absolute time stamps are preserved. -} slice :: (Eq a, NonNeg.C 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 = mapPair (Cons, Cons) . Disp.spanSecond p . decons {- | Group events that have equal start times (that is zero time differences). -} collectCoincident :: (NonNeg.C time) => T time body -> T time [body] collectCoincident = mapTimeTail $ BodyBodyPriv.lift $ Uniform.filterFirst (zero <) {- | Reverse to collectCoincident: Turn each @body@ into a separate event. > xs == flatten (collectCoincident xs) -} flatten :: (NonNeg.C time) => T time [body] -> T time body flatten = Cons . Mixed.switchFirstL Disp.empty (\time -> unlift (delay time) . fst . Mixed.viewSecondR . Uniform.foldr (Mixed.appendUniformUniform . Uniform.fromSecondList zero) Mixed.consSecond Disp.empty . Uniform.mapSecond NonNeg.sum . Uniform.filterSecond (not . List.null)) . 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 isAscending . getBodies . collectCoincident {- | This function merges the events of two lists into a new event list. Note that 'merge' compares entire events rather than just start times. This is to ensure that it is commutative, one of the properties we test for. -} merge :: (NonNeg.C time, Ord body) => T time body -> T time body -> T time body merge = mergeBy (<) {- | 'mergeBy' is like 'merge' but does not simply use the methods of the 'Ord' class but allows a custom comparison function. If in event lists @xs@ and @ys@ there are coinciding elements @x@ and @y@, and @cmp x y@ is 'True', then @x@ comes before @y@ in @mergeBy cmp xs ys@. > EventList> EventList.mergeBy (\_ _ -> True) (0 /. 'a' ./ empty) (0 /. 'b' ./ empty) > 0 /. 'a' ./ 0 /. 'b' ./ empty > > EventList> EventList.mergeBy (\_ _ -> False) (0 /. 'a' ./ empty) (0 /. 'b' ./ empty) > 0 /. 'b' ./ 0 /. 'a' ./ empty -} {- Could be implemented using 'splitAt' and 'insert'. -} mergeBy :: (NonNeg.C time) => (body -> body -> Bool) -> T time body -> T time body -> T time body mergeBy before = let recourse xs0 ys0 = case (viewL xs0, viewL ys0) of (Nothing, _) -> ys0 (_, Nothing) -> xs0 (Just ((xt,xb),xs), Just ((yt,yb),ys)) -> let (mt,~(b,dt)) = NonNeg.split xt yt in uncurry (cons mt) $ if b && (dt/=zero || before xb yb) then (xb, recourse xs $ cons dt yb ys) else (yb, recourse ys $ cons dt xb xs) in recourse {- | 'insert' inserts an event into an event list at the given time. -} insert :: (NonNeg.C time, Ord body) => time -> body -> T time body -> T time body insert = insertBy (<) insertBy :: (NonNeg.C time) => (body -> body -> Bool) -> time -> body -> T time body -> T time body insertBy before = let recourse t0 me0 = (\ ~((t,me), rest) -> cons t me rest) . switchL ((t0,me0), empty) (\(t1, me1) mevs -> let (mt,~(b,dt)) = NonNeg.split t0 t1 in mapFst ((,) mt) $ if b && (dt/=zero || before me0 me1) then (me0, cons dt me1 mevs) else (me1, recourse dt me0 mevs)) in recourse {- | Move events towards the front of the event list. You must make sure, that no event is moved before time zero. This works only for finite lists. -} moveForward :: (Ord time, Num time) => T time (time, body) -> T time body moveForward = fromAbsoluteEventList . AbsoluteEventList.moveForward . toAbsoluteEventList 0 {- Like 'moveForward' but restricts the look-ahead time. For @moveForwardRestricted maxTimeDiff xs@ all time differences (aka the moveForward offsets) in @xs@ must be at most @maxTimeDiff@. With this restriction the function is lazy enough for handling infinite event lists. However the larger @maxTimeDiff@ the more memory and time is consumed. -} {- for implementation notes see TimeTime This implementation requires TimeTime.duration, TimeMixed.appendBodyEnd, TimeMixed.splitAtTime and thus we would need a lot of movement of functions between modules moveForwardRestricted :: (NonNeg.C time) => time -> T time (time, body) -> T time body moveForwardRestricted maxTime xs = let (prefix,suffix) = splitAtTime maxTime xs prefixDur = duration prefix getChunk t = do (toEmit,toKeep) <- gets (splitAtTime t) put toKeep return (pad t toEmit) insertEvent (t,b) = insertBy (\ _ _ -> False) (maxTime - t) b in evalState (foldr (\t m -> liftM2 append (getChunk t) m) (\b m -> modify (insertEvent b) >> m) (gets (pad prefixDur)) suffix) (moveForward (seq prefixDur prefix)) -} 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 (-| dif) delay :: (NonNeg.C time) => time -> T time body -> T time body delay dif = mapTimeHead (add 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 Utility.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 event-list-0.1.0.2/src/Data/EventList/Absolute/0000755000000000000000000000000011777327303017275 5ustar0000000000000000event-list-0.1.0.2/src/Data/EventList/Absolute/TimeTimePrivate.hs0000644000000000000000000000447311777327303022711 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2009 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.Tuple.HT (mapFst, ) import qualified Control.Monad as Monad import qualified Control.Applicative as Applicative import Control.Applicative (Applicative, ) 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 liftA :: Applicative m => (Uniform.T body0 time0 -> m (Uniform.T body1 time1)) -> (T time0 body0 -> m (T time1 body1)) liftA f = Applicative.liftA 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 {-# INLINE switchTimeR #-} switchTimeR :: (TimeBodyList.T time body -> time -> a) -> T time body -> a switchTimeR f = Mixed.switchSecondR (f . TimeBodyList.Cons) . decons {-# INLINE switchBodyR #-} switchBodyR :: a -> (T time body -> body -> a) -> TimeBodyList.T time body -> a switchBodyR f g = Mixed.switchFirstR f (g . Cons) . TimeBodyList.decons mapTimeInit :: (TimeBodyList.T time body0 -> TimeBodyList.T time body1) -> T time body0 -> T time body1 mapTimeInit f = uncurry snocTime . mapFst f . viewTimeR event-list-0.1.0.2/src/Data/EventList/Absolute/TimeBodyPrivate.hs0000644000000000000000000000651211777327303022704 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2009 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 import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Control.Applicative as App import Control.Applicative (Applicative, ) import Data.Monoid (Monoid, mempty, mappend, mconcat, ) import Test.QuickCheck (Arbitrary(arbitrary)) import Prelude hiding (concat, cycle) newtype T time body = Cons {decons :: Disp.T time body} deriving (Eq, Ord, Show) instance (Arbitrary time, Arbitrary body) => Arbitrary (T time body) where arbitrary = Monad.liftM Cons arbitrary instance (Num time, Ord time) => Monoid (T time body) where mempty = Cons Disp.empty mappend = append mconcat = concat instance Functor (T time) where fmap f (Cons x) = Cons (Disp.mapSecond f x) instance Fold.Foldable (T time) where foldMap = Trav.foldMapDefault instance Trav.Traversable (T time) where traverse f = App.liftA Cons . Disp.traverse App.pure f . decons 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 liftA :: Applicative m => (Disp.T time0 body0 -> m (Disp.T time1 body1)) -> (T time0 body0 -> m (T time1 body1)) liftA f = App.liftA 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 {-# INLINE switchL #-} switchL :: c -> ((time, body) -> T time body -> c) -> T time body -> c switchL f g = Disp.switchL f (\ t b -> g (t,b) . Cons) . decons {-# INLINE switchR #-} switchR :: c -> (T time body -> (time, body) -> c) -> T time body -> c switchR f g = Disp.switchR f (\xs t b -> g (Cons xs) (t,b)) . decons 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) {- | 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 = switchR 0 (const fst) {- Is it necessary to exclude negative delays? Even negative time stamps should not hurt absolutely timestamped lists. -} 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" 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 {- Unfortunately in absolute lists we cannot use sharing as in List.cycle since the start times of the later lists are greater. -} cycle :: (Ord time, Num time) => T time body -> T time body cycle = concat . repeat event-list-0.1.0.2/src/Data/EventList/Absolute/TimeMixed.hs0000644000000000000000000000055011777327303021516 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 -} module Data.EventList.Absolute.TimeMixed (snocBody, snocTime, -- (/.), (./), viewTimeR, viewBodyR, switchTimeR, switchBodyR, mapTimeInit, ) where import Data.EventList.Absolute.TimeTimePrivate event-list-0.1.0.2/src/Data/EventList/Absolute/TimeTime.hs0000644000000000000000000002145711777327303021357 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2009 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, switchL, cons, snoc, mapBody, mapTime, concatMapMonoid, traverse, traverse_, traverseBody, traverseTime, mapM, mapM_, mapBodyM, mapTimeM, getTimes, getBodies, duration, merge, mergeBy, insert, insertBy, moveForward, 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.List.HT as ListHT import qualified Data.EventList.Utility as Utility import Data.Tuple.HT (mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, ) import qualified Control.Monad as Monad import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Control.Monad.Trans.State (state, evalState) import Data.Monoid (Monoid, ) 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 {-# INLINE switchL #-} switchL :: (time -> a) -> ((time, body) -> T time body -> a) -> T time body -> a switchL f g = Mixed.switchL f (\t b -> g (t,b) . Cons) . 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 concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Uniform.concatMapMonoid g f . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse f g = liftA (Uniform.traverse g f) traverse_ :: Applicative m => (time -> m ()) -> (body -> m ()) -> T time body -> m () traverse_ f g = Uniform.traverse_ g f . decons traverseBody :: Applicative m => (body0 -> m body1) -> T time body0 -> m (T time body1) traverseBody f = liftA (Uniform.traverseFirst f) traverseTime :: Applicative m => (time0 -> m time1) -> T time0 body -> m (T time1 body) traverseTime f = liftA (Uniform.traverseSecond f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = unwrapMonad . traverse (WrapMonad . f) (WrapMonad . g) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = unwrapMonad . traverse_ (WrapMonad . f) (WrapMonad . g) mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = unwrapMonad . traverseBody (WrapMonad . f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = unwrapMonad . traverseTime (WrapMonad . f) 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 = switchTimeR (\ xs t -> mapPair (flip snocTime t, flip snocTime t) (TimeBodyList.partition p xs)) 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 . Mixed.switchSecondL (\ t0 -> Mixed.consSecond t0 . Mixed.mapFirstInit (Uniform.catMaybesFirst . flip evalState (Just t0) . Uniform.traverseFirst (\time -> state $ \ oldTime -> (Monad.guard (time /= oldTime) >> time, time)) . Uniform.mapFirst Just)) . 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 isAscending . 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) in switchL (\t1 -> uncurry cons mev0 $ pause (max t0 t1)) (\mev1 mevs -> if Utility.beforeBy before mev0 mev1 then uncurry cons mev0 $ mevs1 else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) mevs1 {- | Move events towards the front of the event list. You must make sure, that no event is moved before time zero. This works only for finite lists. -} moveForward :: (Ord time, Num time) => T time (time, body) -> T time body moveForward = mapTimeInit TimeBodyList.moveForward append :: (Ord time, Num time) => T time body -> T time body -> T time body append = switchTimeR (\xs t -> lift (Mixed.appendDisparateUniform $~ xs) . delay t) 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") (ListHT.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 . Mixed.switchSecondL (\ t xs -> Mixed.consSecond (if t>=dif then t-dif else error "decreaseStart: difference too big") (Disp.mapSecond (subtract dif) xs)) . 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*) event-list-0.1.0.2/src/Data/EventList/Absolute/TimeBody.hs0000644000000000000000000003035011777327303021346 0ustar0000000000000000{- | Copyright : (c) Henning Thielemann 2007-2010 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 -} module Data.EventList.Absolute.TimeBody (T, empty, singleton, null, viewL, viewR, switchL, switchR, cons, snoc, fromPairList, toPairList, getTimes, getBodies, duration, mapBody, mapTime, concatMapMonoid, traverse, traverse_, traverseBody, traverseTime, mapM, mapM_, mapBodyM, mapTimeM, merge, mergeBy, insert, insertBy, moveForward, decreaseStart, delay, filter, partition, partitionMaybe, 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.Monoid (Monoid, ) import Data.Tuple.HT (mapFst, mapSnd, ) import Data.Maybe.HT (toMaybe, ) import Data.List.HT (isAscending, isAscendingLazy, ) import Data.Function.HT (compose2, ) import Data.EventList.Utility (beforeBy, ) import qualified Control.Monad as Monad import Control.Applicative (Applicative, WrappedMonad(WrapMonad, unwrapMonad), ) import Control.Monad.Trans.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 concatMapMonoid :: Monoid m => (time -> m) -> (body -> m) -> T time body -> m concatMapMonoid f g = Disp.concatMapMonoid f g . decons traverse :: Applicative m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) traverse f g = liftA (Disp.traverse f g) traverse_ :: Applicative m => (time -> m ()) -> (body -> m ()) -> T time body -> m () traverse_ f g = Disp.traverse_ f g . decons traverseBody :: Applicative m => (body0 -> m body1) -> T time body0 -> m (T time body1) traverseBody f = liftA (Disp.traverseSecond f) traverseTime :: Applicative m => (time0 -> m time1) -> T time0 body -> m (T time1 body) traverseTime f = liftA (Disp.traverseFirst f) mapM :: Monad m => (time0 -> m time1) -> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1) mapM f g = unwrapMonad . traverse (WrapMonad . f) (WrapMonad . g) mapM_ :: Monad m => (time -> m ()) -> (body -> m ()) -> T time body -> m () mapM_ f g = unwrapMonad . traverse_ (WrapMonad . f) (WrapMonad . g) mapBodyM :: Monad m => (body0 -> m body1) -> T time body0 -> m (T time body1) mapBodyM f = unwrapMonad . traverseBody (WrapMonad . f) mapTimeM :: Monad m => (time0 -> m time1) -> T time0 body -> m (T time1 body) mapTimeM f = unwrapMonad . traverseTime (WrapMonad . 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") (isAscendingLazy (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) partitionMaybe :: (body0 -> Maybe body1) -> T time body0 -> (T time body1, T time body0) partitionMaybe p = foldrPair (\ t b -> maybe (mapSnd (cons t b)) (mapFst . cons t) (p 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 . Mixed.switchFirstL Disp.empty (\ t0 -> Mixed.consFirst t0 . Uniform.catMaybesFirst . flip evalState (Just t0) . Uniform.traverseFirst (\time -> state $ \ oldTime -> (Monad.guard (time /= oldTime) >> time, time)) . Uniform.mapFirst Just) . decons collectCoincidentFoldr :: Eq time => T time body -> T time [body] collectCoincidentFoldr = Cons . foldrPair (\t0 b0 xs -> Mixed.consFirst t0 $ Disp.switchL (Uniform.singleton [b0]) (\t1 bs ys -> if t0 == t1 then Mixed.consSecond (b0:bs) ys else Mixed.consSecond [b0] xs) xs) Disp.empty {- | Will fail on infinite lists. -} collectCoincidentNonLazy :: Eq time => T time body -> T time [body] collectCoincidentNonLazy = Cons . foldrPair (\t0 b0 xs -> Disp.switchL (Disp.singleton t0 [b0]) (\t1 bs ys -> if t0 == t1 then Disp.cons t0 (b0:bs) ys else Disp.cons t0 [b0] xs) 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 isAscending . 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 recourse 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 recourse {- | 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 switchL (uncurry singleton mev0) (\mev1 mevs -> if beforeBy before mev0 mev1 then uncurry cons mev0 $ mevs1 else uncurry cons mev1 $ uncurry (insertBy before) mev0 mevs) mevs1 {- | Move events towards the front of the event list. You must make sure, that no event is moved before time zero. This works only for finite lists. -} moveForward :: (Ord time, Num time) => T time (time, body) -> T time body moveForward = fromPairList . List.sortBy (compose2 compare fst) . List.map (\ ~(time,(timeDiff,body)) -> (time - timeDiff, body)) . toPairList {- 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 = switchL empty (\(t, b) xs -> cons (if t>=dif then t-dif else error "decreaseStart: difference too big") b (mapTime (subtract dif) xs)) {- | 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*)