packages feed

numeric-prelude 0.1.3.4 → 0.4.4

raw patch · 138 files changed

Files

LICENSE view
@@ -1,674 +1,26 @@-                    GNU GENERAL PUBLIC LICENSE-                       Version 3, 29 June 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.--                            Preamble--  The GNU General Public License is a free, copyleft license for-software and other kinds of works.--  The licenses for most software and other practical works are designed-to take away your freedom to share and change the works.  By contrast,-the GNU General Public License is intended to guarantee your freedom to-share and change all versions of a program--to make sure it remains free-software for all its users.  We, the Free Software Foundation, use the-GNU General Public License for most of our software; it applies also to-any other work released this way by its authors.  You can apply it to-your programs, too.--  When we speak of free software, we are referring to freedom, not-price.  Our General Public Licenses are designed to make sure that you-have the freedom to distribute copies of free software (and charge for-them if you wish), that you receive source code or can get it if you-want it, that you can change the software or use pieces of it in new-free programs, and that you know you can do these things.--  To protect your rights, we need to prevent others from denying you-these rights or asking you to surrender the rights.  Therefore, you have-certain responsibilities if you distribute copies of the software, or if-you modify it: responsibilities to respect the freedom of others.--  For example, if you distribute copies of such a program, whether-gratis or for a fee, you must pass on to the recipients the same-freedoms that you received.  You must make sure that they, too, receive-or can get the source code.  And you must show them these terms so they-know their rights.--  Developers that use the GNU GPL protect your rights with two steps:-(1) assert copyright on the software, and (2) offer you this License-giving you legal permission to copy, distribute and/or modify it.--  For the developers' and authors' protection, the GPL clearly explains-that there is no warranty for this free software.  For both users' and-authors' sake, the GPL requires that modified versions be marked as-changed, so that their problems will not be attributed erroneously to-authors of previous versions.--  Some devices are designed to deny users access to install or run-modified versions of the software inside them, although the manufacturer-can do so.  This is fundamentally incompatible with the aim of-protecting users' freedom to change the software.  The systematic-pattern of such abuse occurs in the area of products for individuals to-use, which is precisely where it is most unacceptable.  Therefore, we-have designed this version of the GPL to prohibit the practice for those-products.  If such problems arise substantially in other domains, we-stand ready to extend this provision to those domains in future versions-of the GPL, as needed to protect the freedom of users.--  Finally, every program is threatened constantly by software patents.-States should not allow patents to restrict development and use of-software on general-purpose computers, but in those that do, we wish to-avoid the special danger that patents applied to a free program could-make it effectively proprietary.  To prevent this, the GPL assures that-patents cannot be used to render the program non-free.--  The precise terms and conditions for copying, distribution and-modification follow.--                       TERMS AND CONDITIONS--  0. Definitions.--  "This License" refers to version 3 of the GNU General Public License.--  "Copyright" also means copyright-like laws that apply to other kinds of-works, such as semiconductor masks.--  "The Program" refers to any copyrightable work licensed under this-License.  Each licensee is addressed as "you".  "Licensees" and-"recipients" may be individuals or organizations.--  To "modify" a work means to copy from or adapt all or part of the work-in a fashion requiring copyright permission, other than the making of an-exact copy.  The resulting work is called a "modified version" of the-earlier work or a work "based on" the earlier work.--  A "covered work" means either the unmodified Program or a work based-on the Program.--  To "propagate" a work means to do anything with it that, without-permission, would make you directly or secondarily liable for-infringement under applicable copyright law, except executing it on a-computer or modifying a private copy.  Propagation includes copying,-distribution (with or without modification), making available to the-public, and in some countries other activities as well.--  To "convey" a work means any kind of propagation that enables other-parties to make or receive copies.  Mere interaction with a user through-a computer network, with no transfer of a copy, is not conveying.--  An interactive user interface displays "Appropriate Legal Notices"-to the extent that it includes a convenient and prominently visible-feature that (1) displays an appropriate copyright notice, and (2)-tells the user that there is no warranty for the work (except to the-extent that warranties are provided), that licensees may convey the-work under this License, and how to view a copy of this License.  If-the interface presents a list of user commands or options, such as a-menu, a prominent item in the list meets this criterion.--  1. Source Code.--  The "source code" for a work means the preferred form of the work-for making modifications to it.  "Object code" means any non-source-form of a work.--  A "Standard Interface" means an interface that either is an official-standard defined by a recognized standards body, or, in the case of-interfaces specified for a particular programming language, one that-is widely used among developers working in that language.--  The "System Libraries" of an executable work include anything, other-than the work as a whole, that (a) is included in the normal form of-packaging a Major Component, but which is not part of that Major-Component, and (b) serves only to enable use of the work with that-Major Component, or to implement a Standard Interface for which an-implementation is available to the public in source code form.  A-"Major Component", in this context, means a major essential component-(kernel, window system, and so on) of the specific operating system-(if any) on which the executable work runs, or a compiler used to-produce the work, or an object code interpreter used to run it.--  The "Corresponding Source" for a work in object code form means all-the source code needed to generate, install, and (for an executable-work) run the object code and to modify the work, including scripts to-control those activities.  However, it does not include the work's-System Libraries, or general-purpose tools or generally available free-programs which are used unmodified in performing those activities but-which are not part of the work.  For example, Corresponding Source-includes interface definition files associated with source files for-the work, and the source code for shared libraries and dynamically-linked subprograms that the work is specifically designed to require,-such as by intimate data communication or control flow between those-subprograms and other parts of the work.--  The Corresponding Source need not include anything that users-can regenerate automatically from other parts of the Corresponding-Source.--  The Corresponding Source for a work in source code form is that-same work.--  2. Basic Permissions.--  All rights granted under this License are granted for the term of-copyright on the Program, and are irrevocable provided the stated-conditions are met.  This License explicitly affirms your unlimited-permission to run the unmodified Program.  The output from running a-covered work is covered by this License only if the output, given its-content, constitutes a covered work.  This License acknowledges your-rights of fair use or other equivalent, as provided by copyright law.--  You may make, run and propagate covered works that you do not-convey, without conditions so long as your license otherwise remains-in force.  You may convey covered works to others for the sole purpose-of having them make modifications exclusively for you, or provide you-with facilities for running those works, provided that you comply with-the terms of this License in conveying all material for which you do-not control copyright.  Those thus making or running the covered works-for you must do so exclusively on your behalf, under your direction-and control, on terms that prohibit them from making any copies of-your copyrighted material outside their relationship with you.--  Conveying under any other circumstances is permitted solely under-the conditions stated below.  Sublicensing is not allowed; section 10-makes it unnecessary.--  3. Protecting Users' Legal Rights From Anti-Circumvention Law.--  No covered work shall be deemed part of an effective technological-measure under any applicable law fulfilling obligations under article-11 of the WIPO copyright treaty adopted on 20 December 1996, or-similar laws prohibiting or restricting circumvention of such-measures.--  When you convey a covered work, you waive any legal power to forbid-circumvention of technological measures to the extent such circumvention-is effected by exercising rights under this License with respect to-the covered work, and you disclaim any intention to limit operation or-modification of the work as a means of enforcing, against the work's-users, your or third parties' legal rights to forbid circumvention of-technological measures.--  4. Conveying Verbatim Copies.--  You may convey verbatim copies of the Program's source code as you-receive it, in any medium, provided that you conspicuously and-appropriately publish on each copy an appropriate copyright notice;-keep intact all notices stating that this License and any-non-permissive terms added in accord with section 7 apply to the code;-keep intact all notices of the absence of any warranty; and give all-recipients a copy of this License along with the Program.--  You may charge any price or no price for each copy that you convey,-and you may offer support or warranty protection for a fee.--  5. Conveying Modified Source Versions.--  You may convey a work based on the Program, or the modifications to-produce it from the Program, in the form of source code under the-terms of section 4, provided that you also meet all of these conditions:--    a) The work must carry prominent notices stating that you modified-    it, and giving a relevant date.--    b) The work must carry prominent notices stating that it is-    released under this License and any conditions added under section-    7.  This requirement modifies the requirement in section 4 to-    "keep intact all notices".--    c) You must license the entire work, as a whole, under this-    License to anyone who comes into possession of a copy.  This-    License will therefore apply, along with any applicable section 7-    additional terms, to the whole of the work, and all its parts,-    regardless of how they are packaged.  This License gives no-    permission to license the work in any other way, but it does not-    invalidate such permission if you have separately received it.--    d) If the work has interactive user interfaces, each must display-    Appropriate Legal Notices; however, if the Program has interactive-    interfaces that do not display Appropriate Legal Notices, your-    work need not make them do so.--  A compilation of a covered work with other separate and independent-works, which are not by their nature extensions of the covered work,-and which are not combined with it such as to form a larger program,-in or on a volume of a storage or distribution medium, is called an-"aggregate" if the compilation and its resulting copyright are not-used to limit the access or legal rights of the compilation's users-beyond what the individual works permit.  Inclusion of a covered work-in an aggregate does not cause this License to apply to the other-parts of the aggregate.--  6. Conveying Non-Source Forms.--  You may convey a covered work in object code form under the terms-of sections 4 and 5, provided that you also convey the-machine-readable Corresponding Source under the terms of this License,-in one of these ways:--    a) Convey the object code in, or embodied in, a physical product-    (including a physical distribution medium), accompanied by the-    Corresponding Source fixed on a durable physical medium-    customarily used for software interchange.--    b) Convey the object code in, or embodied in, a physical product-    (including a physical distribution medium), accompanied by a-    written offer, valid for at least three years and valid for as-    long as you offer spare parts or customer support for that product-    model, to give anyone who possesses the object code either (1) a-    copy of the Corresponding Source for all the software in the-    product that is covered by this License, on a durable physical-    medium customarily used for software interchange, for a price no-    more than your reasonable cost of physically performing this-    conveying of source, or (2) access to copy the-    Corresponding Source from a network server at no charge.--    c) Convey individual copies of the object code with a copy of the-    written offer to provide the Corresponding Source.  This-    alternative is allowed only occasionally and noncommercially, and-    only if you received the object code with such an offer, in accord-    with subsection 6b.--    d) Convey the object code by offering access from a designated-    place (gratis or for a charge), and offer equivalent access to the-    Corresponding Source in the same way through the same place at no-    further charge.  You need not require recipients to copy the-    Corresponding Source along with the object code.  If the place to-    copy the object code is a network server, the Corresponding Source-    may be on a different server (operated by you or a third party)-    that supports equivalent copying facilities, provided you maintain-    clear directions next to the object code saying where to find the-    Corresponding Source.  Regardless of what server hosts the-    Corresponding Source, you remain obligated to ensure that it is-    available for as long as needed to satisfy these requirements.--    e) Convey the object code using peer-to-peer transmission, provided-    you inform other peers where the object code and Corresponding-    Source of the work are being offered to the general public at no-    charge under subsection 6d.--  A separable portion of the object code, whose source code is excluded-from the Corresponding Source as a System Library, need not be-included in conveying the object code work.--  A "User Product" is either (1) a "consumer product", which means any-tangible personal property which is normally used for personal, family,-or household purposes, or (2) anything designed or sold for incorporation-into a dwelling.  In determining whether a product is a consumer product,-doubtful cases shall be resolved in favor of coverage.  For a particular-product received by a particular user, "normally used" refers to a-typical or common use of that class of product, regardless of the status-of the particular user or of the way in which the particular user-actually uses, or expects or is expected to use, the product.  A product-is a consumer product regardless of whether the product has substantial-commercial, industrial or non-consumer uses, unless such uses represent-the only significant mode of use of the product.--  "Installation Information" for a User Product means any methods,-procedures, authorization keys, or other information required to install-and execute modified versions of a covered work in that User Product from-a modified version of its Corresponding Source.  The information must-suffice to ensure that the continued functioning of the modified object-code is in no case prevented or interfered with solely because-modification has been made.--  If you convey an object code work under this section in, or with, or-specifically for use in, a User Product, and the conveying occurs as-part of a transaction in which the right of possession and use of the-User Product is transferred to the recipient in perpetuity or for a-fixed term (regardless of how the transaction is characterized), the-Corresponding Source conveyed under this section must be accompanied-by the Installation Information.  But this requirement does not apply-if neither you nor any third party retains the ability to install-modified object code on the User Product (for example, the work has-been installed in ROM).--  The requirement to provide Installation Information does not include a-requirement to continue to provide support service, warranty, or updates-for a work that has been modified or installed by the recipient, or for-the User Product in which it has been modified or installed.  Access to a-network may be denied when the modification itself materially and-adversely affects the operation of the network or violates the rules and-protocols for communication across the network.--  Corresponding Source conveyed, and Installation Information provided,-in accord with this section must be in a format that is publicly-documented (and with an implementation available to the public in-source code form), and must require no special password or key for-unpacking, reading or copying.--  7. Additional Terms.--  "Additional permissions" are terms that supplement the terms of this-License by making exceptions from one or more of its conditions.-Additional permissions that are applicable to the entire Program shall-be treated as though they were included in this License, to the extent-that they are valid under applicable law.  If additional permissions-apply only to part of the Program, that part may be used separately-under those permissions, but the entire Program remains governed by-this License without regard to the additional permissions.--  When you convey a copy of a covered work, you may at your option-remove any additional permissions from that copy, or from any part of-it.  (Additional permissions may be written to require their own-removal in certain cases when you modify the work.)  You may place-additional permissions on material, added by you to a covered work,-for which you have or can give appropriate copyright permission.--  Notwithstanding any other provision of this License, for material you-add to a covered work, you may (if authorized by the copyright holders of-that material) supplement the terms of this License with terms:--    a) Disclaiming warranty or limiting liability differently from the-    terms of sections 15 and 16 of this License; or--    b) Requiring preservation of specified reasonable legal notices or-    author attributions in that material or in the Appropriate Legal-    Notices displayed by works containing it; or--    c) Prohibiting misrepresentation of the origin of that material, or-    requiring that modified versions of such material be marked in-    reasonable ways as different from the original version; or--    d) Limiting the use for publicity purposes of names of licensors or-    authors of the material; or--    e) Declining to grant rights under trademark law for use of some-    trade names, trademarks, or service marks; or--    f) Requiring indemnification of licensors and authors of that-    material by anyone who conveys the material (or modified versions of-    it) with contractual assumptions of liability to the recipient, for-    any liability that these contractual assumptions directly impose on-    those licensors and authors.--  All other non-permissive additional terms are considered "further-restrictions" within the meaning of section 10.  If the Program as you-received it, or any part of it, contains a notice stating that it is-governed by this License along with a term that is a further-restriction, you may remove that term.  If a license document contains-a further restriction but permits relicensing or conveying under this-License, you may add to a covered work material governed by the terms-of that license document, provided that the further restriction does-not survive such relicensing or conveying.--  If you add terms to a covered work in accord with this section, you-must place, in the relevant source files, a statement of the-additional terms that apply to those files, or a notice indicating-where to find the applicable terms.--  Additional terms, permissive or non-permissive, may be stated in the-form of a separately written license, or stated as exceptions;-the above requirements apply either way.--  8. Termination.--  You may not propagate or modify a covered work except as expressly-provided under this License.  Any attempt otherwise to propagate or-modify it is void, and will automatically terminate your rights under-this License (including any patent licenses granted under the third-paragraph of section 11).--  However, if you cease all violation of this License, then your-license from a particular copyright holder is reinstated (a)-provisionally, unless and until the copyright holder explicitly and-finally terminates your license, and (b) permanently, if the copyright-holder fails to notify you of the violation by some reasonable means-prior to 60 days after the cessation.--  Moreover, your license from a particular copyright holder is-reinstated permanently if the copyright holder notifies you of the-violation by some reasonable means, this is the first time you have-received notice of violation of this License (for any work) from that-copyright holder, and you cure the violation prior to 30 days after-your receipt of the notice.--  Termination of your rights under this section does not terminate the-licenses of parties who have received copies or rights from you under-this License.  If your rights have been terminated and not permanently-reinstated, you do not qualify to receive new licenses for the same-material under section 10.--  9. Acceptance Not Required for Having Copies.--  You are not required to accept this License in order to receive or-run a copy of the Program.  Ancillary propagation of a covered work-occurring solely as a consequence of using peer-to-peer transmission-to receive a copy likewise does not require acceptance.  However,-nothing other than this License grants you permission to propagate or-modify any covered work.  These actions infringe copyright if you do-not accept this License.  Therefore, by modifying or propagating a-covered work, you indicate your acceptance of this License to do so.--  10. Automatic Licensing of Downstream Recipients.--  Each time you convey a covered work, the recipient automatically-receives a license from the original licensors, to run, modify and-propagate that work, subject to this License.  You are not responsible-for enforcing compliance by third parties with this License.--  An "entity transaction" is a transaction transferring control of an-organization, or substantially all assets of one, or subdividing an-organization, or merging organizations.  If propagation of a covered-work results from an entity transaction, each party to that-transaction who receives a copy of the work also receives whatever-licenses to the work the party's predecessor in interest had or could-give under the previous paragraph, plus a right to possession of the-Corresponding Source of the work from the predecessor in interest, if-the predecessor has it or can get it with reasonable efforts.--  You may not impose any further restrictions on the exercise of the-rights granted or affirmed under this License.  For example, you may-not impose a license fee, royalty, or other charge for exercise of-rights granted under this License, and you may not initiate litigation-(including a cross-claim or counterclaim in a lawsuit) alleging that-any patent claim is infringed by making, using, selling, offering for-sale, or importing the Program or any portion of it.--  11. Patents.--  A "contributor" is a copyright holder who authorizes use under this-License of the Program or a work on which the Program is based.  The-work thus licensed is called the contributor's "contributor version".--  A contributor's "essential patent claims" are all patent claims-owned or controlled by the contributor, whether already acquired or-hereafter acquired, that would be infringed by some manner, permitted-by this License, of making, using, or selling its contributor version,-but do not include claims that would be infringed only as a-consequence of further modification of the contributor version.  For-purposes of this definition, "control" includes the right to grant-patent sublicenses in a manner consistent with the requirements of-this License.--  Each contributor grants you a non-exclusive, worldwide, royalty-free-patent license under the contributor's essential patent claims, to-make, use, sell, offer for sale, import and otherwise run, modify and-propagate the contents of its contributor version.--  In the following three paragraphs, a "patent license" is any express-agreement or commitment, however denominated, not to enforce a patent-(such as an express permission to practice a patent or covenant not to-sue for patent infringement).  To "grant" such a patent license to a-party means to make such an agreement or commitment not to enforce a-patent against the party.--  If you convey a covered work, knowingly relying on a patent license,-and the Corresponding Source of the work is not available for anyone-to copy, free of charge and under the terms of this License, through a-publicly available network server or other readily accessible means,-then you must either (1) cause the Corresponding Source to be so-available, or (2) arrange to deprive yourself of the benefit of the-patent license for this particular work, or (3) arrange, in a manner-consistent with the requirements of this License, to extend the patent-license to downstream recipients.  "Knowingly relying" means you have-actual knowledge that, but for the patent license, your conveying the-covered work in a country, or your recipient's use of the covered work-in a country, would infringe one or more identifiable patents in that-country that you have reason to believe are valid.--  If, pursuant to or in connection with a single transaction or-arrangement, you convey, or propagate by procuring conveyance of, a-covered work, and grant a patent license to some of the parties-receiving the covered work authorizing them to use, propagate, modify-or convey a specific copy of the covered work, then the patent license-you grant is automatically extended to all recipients of the covered-work and works based on it.--  A patent license is "discriminatory" if it does not include within-the scope of its coverage, prohibits the exercise of, or is-conditioned on the non-exercise of one or more of the rights that are-specifically granted under this License.  You may not convey a covered-work if you are a party to an arrangement with a third party that is-in the business of distributing software, under which you make payment-to the third party based on the extent of your activity of conveying-the work, and under which the third party grants, to any of the-parties who would receive the covered work from you, a discriminatory-patent license (a) in connection with copies of the covered work-conveyed by you (or copies made from those copies), or (b) primarily-for and in connection with specific products or compilations that-contain the covered work, unless you entered into that arrangement,-or that patent license was granted, prior to 28 March 2007.--  Nothing in this License shall be construed as excluding or limiting-any implied license or other defenses to infringement that may-otherwise be available to you under applicable patent law.--  12. No Surrender of Others' Freedom.--  If conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License.  If you cannot convey a-covered work so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you may-not convey it at all.  For example, if you agree to terms that obligate you-to collect a royalty for further conveying from those to whom you convey-the Program, the only way you could satisfy both those terms and this-License would be to refrain entirely from conveying the Program.--  13. Use with the GNU Affero General Public License.--  Notwithstanding any other provision of this License, you have-permission to link or combine any covered work with a work licensed-under version 3 of the GNU Affero General Public License into a single-combined work, and to convey the resulting work.  The terms of this-License will continue to apply to the part which is the covered work,-but the special requirements of the GNU Affero General Public License,-section 13, concerning interaction through a network will apply to the-combination as such.--  14. Revised Versions of this License.--  The Free Software Foundation may publish revised and/or new versions of-the GNU General Public License from time to time.  Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.--  Each version is given a distinguishing version number.  If the-Program specifies that a certain numbered version of the GNU General-Public License "or any later version" applies to it, you have the-option of following the terms and conditions either of that numbered-version or of any later version published by the Free Software-Foundation.  If the Program does not specify a version number of the-GNU General Public License, you may choose any version ever published-by the Free Software Foundation.--  If the Program specifies that a proxy can decide which future-versions of the GNU General Public License can be used, that proxy's-public statement of acceptance of a version permanently authorizes you-to choose that version for the Program.--  Later license versions may give you additional or different-permissions.  However, no additional obligations are imposed on any-author or copyright holder as a result of your choosing to follow a-later version.--  15. Disclaimer of Warranty.--  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY-APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM-IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.--  16. Limitation of Liability.--  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF-SUCH DAMAGES.--  17. Interpretation of Sections 15 and 16.--  If the disclaimer of warranty and limitation of liability provided-above cannot be given local legal effect according to their terms,-reviewing courts shall apply local law that most closely approximates-an absolute waiver of all civil liability in connection with the-Program, unless a warranty or assumption of liability accompanies a-copy of the Program in return for a fee.--                     END OF TERMS AND CONDITIONS--            How to Apply These Terms to Your New Programs--  If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these terms.--  To do so, attach the following notices to the program.  It is safest-to attach them to the start of each source file to most effectively-state the exclusion of warranty; and each file should have at least-the "copyright" line and a pointer to where the full notice is found.--    <one line to give the program's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    This program is free software: you can redistribute it and/or modify-    it under the terms of the GNU General Public License as published by-    the Free Software Foundation, either version 3 of the License, or-    (at your option) any later version.--    This program is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-    GNU General Public License for more details.--    You should have received a copy of the GNU General Public License-    along with this program.  If not, see <http://www.gnu.org/licenses/>.--Also add information on how to contact you by electronic and paper mail.--  If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:--    <program>  Copyright (C) <year>  <name of author>-    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.-    This is free software, and you are welcome to redistribute it-    under certain conditions; type `show c' for details.--The hypothetical commands `show w' and `show c' should show the appropriate-parts of the General Public License.  Of course, your program's commands-might be different; for a GUI interface, you would use an "about box".+Copyright (c) 2013 Henning Thielemann, Dylan Thurston, Mikael Johansson+All rights reserved. -  You should also get your employer (if you work as a programmer) or school,-if any, to sign a "copyright disclaimer" for the program, if necessary.-For more information on this, and how to apply and follow the GNU GPL, see-<http://www.gnu.org/licenses/>.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the University nor the names of its contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission. -  The GNU General Public License does not permit incorporating your program-into proprietary programs.  If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications with-the library.  If this is what you want to do, use the GNU Lesser General-Public License instead of this License.  But first, please read-<http://www.gnu.org/philosophy/why-not-lgpl.html>.+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
Makefile view
@@ -1,75 +1,32 @@+HCI6 = ghci+HCI7 = ghci -XCPP -DNoImplicitPrelude=RebindableSyntax -OBJECT_DIR    := build/$(shell uname -s)-$(shell uname -m)-INTERFACE_DIR := build/Interface+.PHONY: ghci ghci6 ghci7 ghci-gauss ghci-compile -MODULES = $(wildcard src/*.hs) \-          $(wildcard src/NumericPrelude/*.hs) \-          $(wildcard src/Algebra/*.hs) \-          $(wildcard src/Algebra/NormedSpace/*.hs) \-          $(wildcard src/Number/*.hs) \-          $(wildcard src/Number/Physical/*.hs) \-          $(wildcard src/Number/DimensionTerm/*.hs) \-          $(wildcard src/Number/SI/*.hs) \-          $(wildcard src/Number/ResidueClass/*.hs) \-          $(wildcard src/Number/FixedPoint/*.hs) \-          $(wildcard src/Number/Positional/*.hs) \-          $(wildcard src/MathObj/*hs) \-          $(wildcard src/MathObj/Permutation/*.hs) \-          $(wildcard src/MathObj/Permutation/CycleList/*.hs) \-          $(wildcard src/MathObj/PowerSeries/*.hs)+ghci:	ghci7 -GHC_OPTIONS = -Wall -odir$(OBJECT_DIR) -hidir$(INTERFACE_DIR)+ghci6:+	$(HCI6) -Wall -i:src:test +RTS -M256m -c30 -RTS test/Demo.hs +ghci7:+	$(HCI7) -Wall -i:src:test +RTS -M256m -c30 -RTS test/Demo.hs -# names of literate modules after removing literary information-UNLIT_MODULES = $(patsubst %.lhs, %.hs, $(patsubst %.hs, , $(MODULES)))+ghci-gauss:+	$(HCI7) -Wall -i:src:test:gaussian +RTS -M256m -c30 -RTS test/Test/MathObj/Gaussian/Variance.hs -# names of all modules without literary information-HS_MODULES = $(patsubst %.lhs, %.hs, $(MODULES))+ghci-compile:+	$(HCI7) -Wall -i:src:test +RTS -M256m -c30 -RTS -fobject-code -O -hidir=dist/build -odir=dist/build test/Demo.hs -STDINTERFACES = base/base.haddock parsec/parsec.haddock -HADDOCK_INCL = $(patsubst %, -i /usr/local/share/ghc-6.2/html/libraries/%, \-                    $(STDINTERFACES))--HC = ghc--HCI = ghci+run-test:	update-test+	runhaskell Setup configure --user -fbuildExamples --enable-tests+	runhaskell Setup build+	runhaskell Setup haddock+	./dist/build/numeric-prelude-test/numeric-prelude-test +update-test:+	doctest-extract-0.1 -i src/ -i gaussian/ -i playground/ -o test/ --executable-main=Test/Run.hs $$(cat test-module.list)  -.INTERMEDIATE:	$(UNLIT_MODULES)--.PHONY:	all doc clean build test ghci publish--all:	build--clean:-	-rm `find $(OBJECT_DIR) -name "*.o"`-	-rm `find $(INTERFACE_DIR) -name "*.hi"`--test:	build-#	$(HC) -Wall -i:$(INTERFACE_DIR) -hide-package NumericPrelude -c test/Test.hs-	$(HC) $(GHC_OPTIONS) -i:src:test --make -hide-package numeric-prelude -o testsuite test/Test/Run.hs-	./testsuite--ghci:-	$(HCI) -Wall -i:src:test +RTS -M256m -c30 -RTS test/Test.hs--build:-	-mkdir $(OBJECT_DIR)-	$(HC) $(GHC_OPTIONS) -hide-package numeric-prelude --make -O $(MODULES)--doc:	$(HS_MODULES)-	haddock -o docs/html --dump-interface=docs/numericprelude.haddock $(HADDOCK_INCL) -h $(HS_MODULES)--%.hs:	%.lhs-	unlit $< $@--HASKELLORG_HTMLDIR = /home/darcs/numericprelude/docs/html--publish:-	scp -r dist/doc/html/* cvs.haskell.org:$(HASKELLORG_HTMLDIR)/-	#scp -r docs/html/* cvs.haskell.org:$(HASKELLORG_HTMLDIR)/-	ssh cvs.haskell.org chmod -R o+r $(HASKELLORG_HTMLDIR)-	#ssh cvs.haskell.org chmod o+x `find $(HASKELLORG_HTMLDIR) -type d`+%.html:	%.md+	pandoc $< --output=$@
+ README.md view
@@ -0,0 +1,139 @@+# Revisiting the Numeric Classes++## Introduction++The Prelude for Haskell 98 offers a well-considered set of numeric classes+which covers the standard numeric types+(`Integer`, `Int`, `Rational`, `Float`, `Double`, `Complex`) quite well.+But they offer limited extensibility and have a few other flaws.+In this proposal we will revisit these classes, addressing the following concerns:++1.  The current Prelude defines no semantics for the fundamental operations.+    For instance, presumably addition should be associative+    (or come as close as feasible),+    but this is not mentioned anywhere.++2.  There are some superfluous superclasses.+    For instance, `Eq` and `Show` are superclasses of `Num`.+    Consider the data type+    `   data IntegerFunction a = IF (a -> Integer) `.+    One can reasonably define all the methods of `Algebra.Ring.C` for+    `IntegerFunction a` (satisfying good semantics),+    but it is impossible to define non-bottom instances of `Eq` and `Show`.+    In general, superclass relationship should indicate+    some semantic connection between the two classes.++3.  In a few cases, there is a mix of semantic operations and+    representation-specific operations.+    `toInteger`, `toRational`,+    and the various operations in `RealFloating` (`decodeFloat`, ...)+    are the main examples.++4.  In some cases, the hierarchy is not finely-grained enough:+    Operations that are often defined independently are lumped together.+    For instance, in a financial application one might want a type "Dollar",+    or in a graphics application one might want a type "Vector".+    It is reasonable to add two Vectors or Dollars,+    but not, in general, reasonable to multiply them.+    But the programmer is currently forced to define a method for `(*)`+    when she defines a method for `(+)`.++In specifying the semantics of type classes,+I will state laws as follows:++~~~~+    (a + b) + c === a + (b + c)+~~~~++The intended meaning is extensional equality:+The rest of the program should behave in the same way+if one side is replaced with the other.+Unfortunately, the laws are frequently violated by standard instances;+the law above, for instance, fails for `Float`:++~~~~+    (1e20 + (-1e20)) + 1.0  = 1.0+     1e20 + ((-1e20) + 1.0) = 0.0+~~~~++For inexact number types like floating point types,+thus these laws should be interpreted as guidelines rather than absolute rules.+In particular, the compiler is not allowed to use them for optimization.+Unless stated otherwise, default definitions should also be taken as laws.++Thanks to Brian Boutel, Joe English, William Lee Irwin II, Marcin+Kowalczyk, Ketil Malde, Tom Schrijvers, Ken Shan, and Henning+Thielemann for helpful comments.+++## Usage++Write modules in the following style:++~~~~+    {-# LANGUAGE RebindableSyntax #-}+    module MyModule where++    ... various specific imports ...++    import NumericPrelude+~~~~++Importing `NumericPrelude` is almost the same as++~~~~+    import NumericPrelude.Numeric+    import NumericPrelude.Base   .+~~~~++Instead of the `NoImplicitPrelude` pragma+you could also write `import Prelude ()`+but this will yield problems with numeric literals.++There are two wrapper types that allow types+to be used with both Haskell98 and NumericPrelude type classes+that are initially implemented for only one of them.+++## Scope & Limitations/TODO++* It might be desireable to split `Ord` up into `Poset` and `Ord`+  (a total ordering).+  This is not addressed here.++* In some cases, this hierarchy may not yet be fine-grained enough.+  For instance, time spans ("5 minutes") can be added to times ("12:34"),+  but two times are not addable. ("12:34 + 8:23")+  As it stands,+  users have to use a different operator for adding time spans to times+  than for adding two time spans.+  Similar issues arise for vector space et al.+  This is a consciously-made tradeoff, but might be changed.+  This becomes most serious when dealing with quantities with units+  like `length/distance^2`, for which `(*)` as defined here is useless.+  (One way to see the issue: should+  `  f x y = iterate (x *) y  `+  have principal type+  `  (Ring.C a) => a -> a -> [a]  `+  or something like+  `  (Ring.C a, Module a b) => a -> b -> [b]  `+  ?)++* I stuck with the Haskell 98 names.+  In some cases I find them lacking.+  Neglecting backwards compatibility, we have renamed classes as follows:++    ~~~~+    Num           --> Additive, Ring, Absolute+    Integral      --> ToInteger, IntegralDomain, RealIntegral+    Fractional    --> Field+    Floating      --> Algebraic, Transcendental+    Real          --> ToRational+    RealFrac      --> RealRing, RealField+    RealFloat     --> RealTranscendental+    ~~~~+++Additional standard libraries might include `Enum`, `IEEEFloat`+(including the bulk of the functions in Haskell 98's `RealFloat` class),+`VectorSpace`, `Ratio`, and `Lattice`.
docs/NOTES view
@@ -1,5 +1,137 @@-** -> ^?+* Positional: test suite +Test against 'compensated' package.++* Positional and zero++Represent zero with empty mantissa?+Or better have NonZero type with non-empty mantissa+and a full number type with optional zero?+Or something where we can have negative numbers and zero as option?+Problem is, that we allow negative digits+and thus even a Positive number type can represent zero and negative numbers.++We might at least define a NonEmptyMantissa type for interim computations,+like in 'divide'.++* Positional.Fixed++We could derive the base from digit type, e.g.+   Int32 -> 1000+   Int64 -> 1000000+   newtype Integer -> anything++* Algebra.Module++I think it should be a type family rather than a multi-parameter type class.+My main motivation for multi-paramter type class+was to allow complex numbers to be a vector space over both real and complex numbers.+This does not worked well and even more type inference often fails.+We should just have two different types of complex numbers:+One complex number type being a vector space over reals+and another complex type being a vector space over complex numbers.++* zipWithChecked++We could make the second operand lazy,+and this way we would get a version of 'zipWith'+that can be used for some tying-the-knot applications+(as in unique-logic and BurrowsWheeler).++* Algebra.Complex++conjugate method that works both on real and complex numbers.+This is need in ScalarProduct implementations,+as in Synthesizer.Test.Fourier.++* multiply vs. mul++Make identifiers consistent.+I think Gaussian.multiply can be dropped when (*) is removed from Ring.++* better support for Show instances in NumericPrelude.Text++Appearance of all objects with prefix constructor should be consistent.++* Show for infix operators++Verify Show instances of (%) and (+:).+E.g. Show (Complex Rational)+When a number has negative sign,+the result of 'show' is sometimes no valid Haskell expression.++* infix operator (*:) for Complex.scale++This would be nice to have in Gaussian.Bell and Gaussian.Polynomial.++* explicit export lists++* AdditiveSemiGroup, AdditiveMonoid, AdditiveGroup++Matrices with dynamic dimension have no 'zero' (because of unknown dimension)+   (that is, they have a commutative AdditiveSemiGroup and MultiplicativeSemiGroup)+NonNegative has no (-)++* MultiplicativeSemiGroup, MultiplicativeMonoid, MultiplicativeGroup++Gaussian function, Root, ComplexSquareRoot have no AdditiveGroup operations++* Decision class should be thrown out again++They do not scale well.+They should be divided into 'if' and 'select' parts.++* Eq superclass for Absolute?++If we have Absolute we can always define++  a == b   ===   isZero (a-b)++Maybe this reasoning is no longer valid,+when superclasses of Ring are finer grained.++* Ratios of polynomials++Q(pi) can be represented by Ratio (Polynomial Integer),+however the standard cancelling algorithm+using the GCD and Euclidean algorithm would not work,+because the GCD is a too strict notion here.+Thus currently Q(pi) must be represented by Ratio (Polynomial Rational),+which is redundant.+How can this be overcome?++Are there polynomials p and q over Z+such that p and q are relatively prime,+but for an integer multiple k·p and k·q they have a non-trivial common divisor?++* optimizations++http://www.haskell.org/pipermail/libraries/2010-September/014434.html++ #4101: constant folding for (**)+ #3676: realToFrac conversions+ #3744: comparisons against minBound and maxBound are not optimised away+ #3065: quot is sub-optimal+ #2269: Word type to Double or Float conversions+ #2271: floor, ceiling, round :: Double -> Int are awesomely slow+ #1434: slow conversion Double to Int++All are accessible as http://hackage.haskell.org/trac/ghc/ticket/4101, etc.+All need love.++* sum (and mconcat)++How to provide a 'sum' function that works optimal for the strict and lazy types?+It must sum strict types from the left and lazy types from the right,+and pairs of both kind of types must be added in a mixed manner.+This seems to be impossible to achieve with a Haskell 98 type class or optimizer rules.++http://projects.haskell.org/pipermail/numeric-prelude/2010-July/000016.html++Shall we leave left-biased sum as the default+and provide an advanced type class for unbounded summation?+It could be used to define a generic 'List.length' function.+ * non-negative  NonNegative could require ZeroTestable@@ -63,26 +195,6 @@ but not a locally defined 'fromRational'.  -* people probably interested in NumPrelude:-- Mike Thomas <miketh@brisbane.paradigmgeo.com>-   http://www.haskell.org/pipermail/haskell-cafe/2002-February/002660.html-- jan.skibinski@sympatico.ca-   indexless linear algebra-- blaetterrascheln@web.de- Christian Sievers <sievers@math2.nat.tu-bs.de>- Remi Turk <buran@xs4all.nl>, rturk@science.uva.nl- Ronny Wichers Schreur <R.WichersSchreur@science.ru.nl>-   floorSqrt- - William Lee Irwin III <wli@holomorphy.com>-   ContFrac, continued fractions-- Juergen Bokowski <bokowski@mathematik.tu-darmstadt.de>-   DMV-Nachrichten 2004/3- * RealFloat Defines the properties of a Floating type, thus should be named 'Floating'.@@ -149,7 +261,7 @@ If they can't assert that (I assume that will only rarely be the case), they must do this check by themselve. -* Numeric type classes for DSLs+* Numeric type classes for EDSLs  It is very common to define instances of Numeric type classes for wrapping operations of a foreign programming language.@@ -180,6 +292,21 @@ (For similar values, the rounding errors might be greater than the difference of the values.) +The EDSL classes also have its use for CPU vectors+   EqualityDecision: (==)+   OrderDecision: compare+   Choice: ifThenElse+   Share: Verallgemeinerung von 'let'++And there could be more classes for vector computing:+   Shift+   Access: insert, extract++Using this class we could write synthesizer:Wave functions+or vectorised frequency filters,+such that we can test it with exact arithmetic+and run it with LLVM on CPU vectors.+ * Implicit configuration  Since there are no local type class instances available@@ -308,6 +435,15 @@   +* Function type class++Useful for all function representations like Polynomials, Gaussian functions.+However polynomials can only be applied to Ring types,+and Gaussian functions can only be applied to Transcendental types.+This it would require the usual type tricks+for type constructor class with restricted type arguments.++ * Complex numbers  The module looks horrible because auxiliary type classes are introduced@@ -334,7 +470,7 @@    - Partial Fractions:       - introduce Indexable type class for allowing partial fractions of polynomials       - example decomposition (e.g. implemented in test suite)-          (n-2)*(n+2)/((n-4)*n*(n+4))+          (n-2)·(n+2)/((n-4)·n·(n+4))    - Hypercomplex numbers: Octonions    - matrices, vectors       - conversion of complex and quaternions to real matrices
+ gaussian/Gaussian.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified MathObj.Gaussian.Example as Example++main :: IO ()+main = Example.polyApprox
+ gaussian/MathObj/Gaussian/Bell.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE RebindableSyntax #-}+{-+Complex translated and modulated Gaussian bell curve.++It could be extended to chirps+using a complex valued quadratic term with (real c >= 0).+This allows for a new test:+Express the Fourier transform in terms of a convolution with a chirp.+-}+module MathObj.Gaussian.Bell where++import qualified MathObj.Polynomial as Poly+import qualified Number.Complex as Complex++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+import qualified Algebra.Absolute       as Absolute+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Number.Complex ((+:), )++import Test.QuickCheck (Arbitrary, arbitrary, )+import Control.Monad (liftM4, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (reverse, )+++{- $setup+>>> import qualified MathObj.Gaussian.Bell as G+>>> import qualified Algebra.ZeroTestable as ZeroTestable+>>> import qualified Algebra.Laws as Laws+>>> import qualified Number.Complex as Complex+>>> import Number.Complex ((+:))+>>> import NumericPrelude.Base as P+>>> import NumericPrelude.Numeric as NP+>>> import Prelude ()+>>> import qualified Test.QuickCheck as QC+>>> import Data.Function.HT (Id, nest)+>>>+>>> asRational :: Id (G.T Rational)+>>> asRational = id+>>>+>>> withRational :: Id (G.T Rational -> a)+>>> withRational = id+>>>+>>> isConstant :: ZeroTestable.C a => G.T a -> Bool+>>> isConstant (G.Cons _amp _a b c) = isZero b && isZero c+-}+++data T a = Cons {amp :: a, c0, c1 :: Complex.T a, c2 :: a}+   deriving (Eq, Show)++instance (Absolute.C a, Arbitrary a) => Arbitrary (T a) where+   arbitrary =+      liftM4+         (\k a b c -> Cons (abs k) a b (1 + abs c))+         arbitrary arbitrary arbitrary arbitrary+++constant :: Ring.C a => T a+constant = Cons one zero zero zero++{- |+eigenfunction of 'fourier'+-}+unit :: Ring.C a => T a+unit = Cons one zero zero one++{-# INLINE evaluate #-}+evaluate :: (Trans.C a) =>+   T a -> a -> Complex.T a+evaluate f x =+   Complex.scale+     (sqrt (amp f))+     (Complex.exp $ Complex.scale (-pi) $+      c0 f + Complex.scale x (c1 f) + Complex.fromReal (c2 f * x^2))++evaluateSqRt :: (Trans.C a) =>+   T a -> a -> Complex.T a+evaluateSqRt f x0 =+   Complex.scale+     (sqrt (amp f))+     (let x = sqrt pi * x0+      in  Complex.exp $ negate $+          c0 f + Complex.scale x (c1 f) + Complex.fromReal (c2 f * x^2))++exponentPolynomial :: (Additive.C a) =>+   T a -> Poly.T (Complex.T a)+exponentPolynomial f =+   Poly.fromCoeffs [c0 f, c1 f, Complex.fromReal (c2 f)]+++{-+norm functions depend on interpretation+and would have to return both a rational and transcendental part+expressed as @exp a@.+-}++variance :: (Trans.C a) =>+   T a -> a+variance f =+   recip $ c2 f * 2*pi++{- |+prop> Laws.identity G.multiply G.constant . asRational+prop> Laws.commutative G.multiply . asRational+prop> Laws.associative G.multiply . asRational+-}+multiply :: (Ring.C a) =>+   T a -> T a -> T a+multiply f g =+   Cons+      (amp f * amp g)+      (c0 f + c0 g) (c1 f + c1 g) (c2 f + c2 g)++powerRing :: (Trans.C a) =>+   Integer -> T a -> T a+powerRing p f =+   let pa = fromInteger p+   in  Cons+          (amp f ^ p)+          (pa * c0 f) (pa * c1 f) (fromInteger p * c2 f)++{-+powerField does not makes sense,+since the reciprocal of a Gaussian diverges.+-}++powerAlgebraic :: (Trans.C a) =>+   Rational -> T a -> T a+powerAlgebraic p f =+   let pa = fromRational' p+   in  Cons+          (amp f ^/ p)+          (pa * c0 f) (pa * c1 f) (fromRational' p * c2 f)++powerTranscendental :: (Trans.C a) =>+   a -> T a -> T a+powerTranscendental p f =+   Cons+      (amp f ^? p)+      (Complex.scale p $ c0 f) (Complex.scale p $ c1 f) (p * c2 f)+++{- |+>>> let x=G.Cons 2 (1+:3) (4+:5) (7::Rational); y=G.Cons 7 (1+:4) (3+:2) (5::Rational) in G.convolve x y+Cons {amp = 7 % 6, c0 = 13 % 6 +: 55 % 8, c1 = 41 % 12 +: 13 % 4, c2 = 35 % 12}++prop> Laws.commutative G.convolve . asRational+prop> Laws.associative G.convolve . asRational++Would be nice to have something like:++> Laws.identity G.convolve G.dirac++but we cannot represent @G.dirac@.++prop> isConstant . G.convolve G.constant . asRational++Using a @G.norm1@ we could exactly compute the amplitude+of the resulting constant function.+But that would require transcendent operations.+-}+convolve :: (Field.C a) =>+   T a -> T a -> T a+convolve f g =+   let s = c2 f + c2 g+       {-+       fd = f1/(2*f2)+       gd = g1/(2*g2)+       c = f2*g2/(f2+g2)++       c*(fd+gd) = (f1*g2+f2*g1)/(2*(f2+g2)) = b/2++       c*(fd+gd)^2 - fd^2*f2 - gd^2*g2+         = f2*g2*(fd+gd)^2/(f2 + g2) - (fd^2*f2 + gd^2*g2)+         = (f2*g2*(fd+gd)^2 - (f2+g2)*(fd^2*f2+gd^2*g2)) / (f2 + g2)+         = (2*f2*g2*fd*gd - (fd^2*f2^2+gd^2*g2^2)) / (f2 + g2)+         = (2*f1*g1 - (f1^2+g1^2)) / (4*(f2 + g2))+         = -(f1 - g1)^2/(4*(f2 + g2))+       -}+   in  Cons+          (amp f * amp g / s)+          (c0 f + c0 g+              - Complex.scale (recip (4*s)) ((c1 f - c1 g)^2))+          (Complex.scale (c2 g / s) (c1 f) ++           Complex.scale (c2 f / s) (c1 g))+          (c2 f * c2 g / s)+            -- recip $ recip (c2 f) + recip (c2 g)+{-+   Cons+      (c0 f + c0 g) (c1 f + c1 g)+      (recip $ recip (c2 f) + recip (c2 g))+-}++{- |+prop> withRational $ \x y -> G.convolve x y == G.convolveByTranslation x y+-}+convolveByTranslation :: (Field.C a) =>+   T a -> T a -> T a+convolveByTranslation f0 g0 =+   let fd = Complex.scale (recip (2 * c2 f0)) $ c1 f0+       gd = Complex.scale (recip (2 * c2 g0)) $ c1 g0+       f1 = translateComplex fd f0+       g1 = translateComplex gd g0+       s = c2 f1 + c2 g1+   in  translateComplex (negate $ fd + gd) $+       Cons+          (amp f1 * amp g1 / s)+          (c0 f1 + c0 g1) zero+          (c2 f1 * c2 g1 / s)++{- |+prop> withRational $ \x y -> G.convolve x y == G.convolveByFourier x y+-}+convolveByFourier :: (Field.C a) =>+   T a -> T a -> T a+convolveByFourier f g =+   reverse $ fourier $ multiply (fourier f) (fourier g)++{- |+prop> withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y)+prop> withRational $ \x -> nest 2 G.fourier x == G.reverse x+prop> G.fourier G.unit == (asRational G.unit)+prop> withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x)+prop> withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))+-}+fourier :: (Field.C a) =>+   T a -> T a+fourier f =+   let a = c0 f+       b = c1 f+       rc = recip $ c2 f+   in  Cons+          (amp f * rc)+          (Complex.scale (rc/4) (-b^2) + a)+          (Complex.scale rc $ Complex.quarterRight b)+          rc++{- |+prop> withRational $ \x -> G.fourier x == G.fourierByTranslation x+-}+fourierByTranslation :: (Field.C a) =>+   T a -> T a+fourierByTranslation f =+   translateComplex (Complex.scale (1/2) $ Complex.quarterLeft $ c1 f) $+   Cons (amp f / c2 f) (c0 f) zero (recip $ c2 f)++{-+a + b*x + c*x^2+ = c*(a/c + b/c*x + x^2)+ = c*((x-b/(2*c))^2 + (4*a*c+b^2)/(4*c^2))+ = c*(x-b/(2*c))^2 + (4*a*c+b^2)/(4*c)++fourier ->+   x^2/c - i*b/c*x + (4*a*c+b^2)/(4*c)++fourier (x -> exp(-pi*c*(x-t)^2))+ = fourier $ translate t $ shrink (sqrt c) $ x -> exp(-pi*x^2)+ = modulate t $ dilate (sqrt c) $ fourier $ x -> exp(-pi*x^2)+ = modulate t $ dilate (sqrt c) $ x -> exp(-pi*x^2)+ = modulate t $ x -> exp(-pi*x^2/c)+ = x -> exp(-pi*x^2/c) * exp(-2*pi*i*x*t)+ = x -> exp(-pi*(x^2/c - 2*i*x*t))+-}++{-+b*x + c*x^2+ = c*(b/c*x + x^2)+ = c*((x-br/(2*c))^2 + i*x*bi/c - br^2/(4*c^2))+ = c*(x-br/(2*c))^2 + i*x*bi - br^2/(4*c)++fourier ->+   (x+bi/2)^2/c - i*br/c*(x+bi/2) - br^2/(4*c)+ = (1/c) * ((x+bi/2)^2 - i*br*(x+bi/2) + (br/2)^2)+ = (1/c) * (x^2 - i*b*x + -(br/2)^2 + (bi/2)^2 - i*br*bi/2)+ = (1/c) * (x^2 - i*b*x - (br^2-bi^2+2*br*bi*i)^2 /4)+ = (1/c) * (x^2 - i*b*x - b^2 / 4)+ = (1/c) * (x^2 - i*b*x + (i*b/2)^2)+ = (1/c) * (x - i*b/2)^2++Example:+  (x-b)^2 = b^2 - 2*b*x + x^2+    ->  (- i*2*b*x + x^2)+++fourier (x -> exp(-pi*(c*(x-t)^2 + 2*i*m*x)))+ = fourier $ modulate m $ translate t $ shrink (sqrt c) $ x -> exp(-pi*x^2)+ = translate (-m) $ modulate t $ dilate (sqrt c) $ fourier $ x -> exp(-pi*x^2)+ = translate (-m) $ modulate t $ dilate (sqrt c) $ x -> exp(-pi*x^2)+ = translate (-m) $ modulate t $ x -> exp(-pi*x^2/c)+ = translate (-m) $ x -> exp(-pi*x^2/c) * exp(-2*pi*i*x*t)+ = x -> exp(-pi*(x+m)^2/c) * exp(-2*pi*i*(x+m)*t)+ = x -> exp(-pi*((x+m)^2/c - 2*i*(x+m)*t))+-}++{-+fourier (Cons a 0 0) =+  Cons a 0 infinity++fourier (Cons 0 0 c) =+  Cons 0 0 (recip c)++fourier (Cons 0 b 1) =+  Cons 0 (i*b) 1+-}++{- |+prop> withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x+-}+translate :: Ring.C a => a -> T a -> T a+translate d f =+   let a = c0 f+       b = c1 f+       c = c2 f+   in  Cons+          (amp f)+          (Complex.fromReal (c*d^2) - Complex.scale d b + a)+          (Complex.fromReal (-2*c*d) + b)+          c++{- |+prop> withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x+prop> withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x+-}+translateComplex :: Ring.C a => Complex.T a -> T a -> T a+translateComplex d f =+   let a = c0 f+       b = c1 f+       c = c2 f+   in  Cons+          (amp f)+          (Complex.scale c (d^2) - b*d + a)+          (Complex.scale (-2*c) d + b)+          c++{- |+prop> withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x+prop> withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x))+-}+modulate :: Ring.C a => a -> T a -> T a+modulate d f =+   Cons+      (amp f)+      (c0 f)+      (c1 f + (zero +: 2*d))+      (c2 f)++turn :: Ring.C a => a -> T a -> T a+turn d f =+   Cons+      (amp f)+      (c0 f + (zero +: 2*d))+      (c1 f)+      (c2 f)++{- |+prop> withRational $ \x -> nest 2 G.reverse x == x+-}+reverse :: Additive.C a => T a -> T a+reverse f =+   f{c1 = negate $ c1 f}+++{- |+prop> withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x+prop> withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x+-}+dilate :: Field.C a => a -> T a -> T a+dilate k f =+   Cons+      (amp f)+      (c0 f)+      (Complex.scale (recip k) $ c1 f)+      (c2 f / k^2)++{- |+prop> withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x+prop> withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x+-}+shrink :: Ring.C a => a -> T a -> T a+shrink k f =+   Cons+      (amp f)+      (c0 f)+      (Complex.scale k $ c1 f)+      (c2 f * k^2)++amplify :: (Ring.C a) => a -> T a -> T a+amplify k f =+   Cons+      (k^2 * amp f)+      (c0 f)+      (c1 f)+      (c2 f)
+ gaussian/MathObj/Gaussian/Example.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE RebindableSyntax #-}+{-+Reciprocal of variance of a Gaussian bell curve.+We describe the curve only in terms of its variance+thus we represent a bell curve at the coordinate origin+neglecting its amplitude.++We could also define the amplitude as @root 4 c@,+thus preserving L2 norm being one,+but then @dilate@ and @shrink@ also include an amplification.++We could do some projective geometry in the exponent+in order to also have zero variance,+which corresponds to the dirac impulse.+-}+module MathObj.Gaussian.Example where++import qualified MathObj.Gaussian.Polynomial as PolyBell+import qualified MathObj.Gaussian.Bell as Bell+import qualified MathObj.Gaussian.Variance as Var++import qualified MathObj.Polynomial as Poly++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic      as Algebraic+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring++import qualified Number.Complex as Complex+import qualified Number.Root as Root++import Algebra.Transcendental (pi, )+import Algebra.Algebraic (root, )+import Algebra.Ring ((*), (^), )++import Number.Complex ((+:), )++import qualified Numerics.Function as Func+import qualified Numerics.Fourier as Fourier+import qualified Numerics.Integration as Integ+import qualified Numerics.Differentiation as Diff++import qualified Graphics.Gnuplot.Simple as GP++import Control.Applicative (liftA2, )++import NumericPrelude.Numeric+import NumericPrelude.Base+import qualified Prelude as P+++curve0 :: Var.T Double+curve0 = curve0a++curve0a :: Var.T Double+curve0a = Var.Cons 1.4 3.3++curve0b :: Var.T Double+curve0b = Var.Cons 2.2 1.7++variance0 :: (Double, Double)+variance0 =+   (Var.variance curve0,+    (Integ.rectangular 1000 (-2,2) $ liftA2 (*) (^2) (Var.evaluate curve0)) /+    (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0))++norm10 :: (Double, Double, Double)+norm10 =+   (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0,+    Var.norm1 curve0,+    Root.toNumber (Var.norm1Root curve0))++norm20 :: (Double, Double, Double)+norm20 =+   (sqrt $ Integ.rectangular 1000 (-2,2) $ (^2) . Var.evaluate curve0,+    Var.norm2 curve0,+    Root.toNumber (Var.norm2Root curve0))++norm30 :: (Double, Double, Double)+norm30 =+   (root 3 $ Integ.rectangular 1000 (-2,2) $ (^3) . Var.evaluate curve0,+    Var.normP 3 curve0,+    Root.toNumber (Var.normPRoot 3 curve0))++fourier0 :: IO ()+fourier0 =+   GP.plotFuncs []+      (GP.linearScale 100 (-2,2))+      [Var.evaluate $ Var.fourier curve0,+       Fourier.analysisTransformOneReal 100 (-2,2) $ Var.evaluate curve0]++multiply0 :: IO ()+multiply0 =+   GP.plotFuncs []+      (GP.linearScale 100 (-1,1))+      [Var.evaluate $ Var.multiply curve0a curve0b,+       liftA2 (*) (Var.evaluate curve0a) (Var.evaluate curve0b)]++convolve0 :: IO ()+convolve0 =+   GP.plotFuncs []+      (GP.linearScale 100 (-2,2))+      [Var.evaluate $ Var.convolve curve0a curve0b,+       Integ.convolve 1000 (-3,3) (Var.evaluate curve0a) (Var.evaluate curve0b)]+++curve1 :: Bell.T Double+curve1 = curve1a++curve1a :: Bell.T Double+curve1a = Bell.Cons 1.4 (0.1+:0.3) ((-0.2)+:1.4) 2.3++curve1b :: Bell.T Double+curve1b = Bell.Cons 2.2 ((-0.3)+:2.1) (0.2+:(-0.4)) 1.7++variance1 :: (Double, Double)+variance1 =+   (Bell.variance curve1,+    (Integ.rectangular 1000 (-2,2) $+        liftA2 (*) (^2)+           (Complex.magnitudeSqr .+            Func.translateRight+               (Complex.real (Bell.c1 curve1) / (2 * Bell.c2 curve1))+               (Bell.evaluate curve1))) /+    (Integ.rectangular 1000 (-2,2) $ Complex.magnitude . Bell.evaluate curve1))++{- the norm depends on too much things+norm0vs1 :: (Double, Double)+norm0vs1 =+   ((Integ.rectangular 1000 (-5,5) $ Var.evaluate curve0)+         * exp (- Complex.real (Bell.c0 curve1)),+    Integ.rectangular 1000 (-5,5) $ Complex.magnitude . Bell.evaluate curve1)+-}++fourier1 :: IO ()+fourier1 =+   GP.plotFuncs []+      (GP.linearScale 100 (-5,5))+      [Complex.real . (Bell.evaluate $ Bell.fourier curve1),+       fourierAnalysisReal 100 (-2,2) $ Bell.evaluate curve1]+++curve2 :: PolyBell.T Double+curve2 =+   PolyBell.Cons+--      Bell.unit+--      (Bell.Cons 1.4 (0.1+:0.3) 0 1.2)+--      (Bell.Cons 1.4 (0.1+:0.3) ((-0.2)+:1.4) 1)+      curve1+--      (Poly.fromCoeffs [one])+--      (Poly.fromCoeffs [zero,one])+--      (Poly.fromCoeffs [zero,zero,one])+--      (Poly.fromCoeffs [0,Complex.imaginaryUnit])+      (Poly.fromCoeffs [1.4+:(-0.1),0.8+:(0.1),(-1.1)+:0.3])++differentiate2 :: IO ()+differentiate2 =+   GP.plotFuncs []+      (GP.linearScale 100 (-2,2))+      [Complex.real . (PolyBell.evaluateSqRt $ PolyBell.differentiate curve2),+       ((/ sqrt pi) . ) $ Diff.diff (1e-5) $ Complex.real . PolyBell.evaluateSqRt curve2]++fourier2 :: IO ()+fourier2 =+   GP.plotFuncs []+      (GP.linearScale 100 (-5,5))+      [Complex.real . (PolyBell.evaluateSqRt $ PolyBell.fourier curve2),+       fourierAnalysisReal 100 (-2,2) $ PolyBell.evaluateSqRt curve2]++++fourierAnalysisReal ::+   (P.Floating a) =>+   Integer -> (a, a) -> (a -> Complex.T a) -> a -> a+fourierAnalysisReal n rng f =+   liftA2 (P.-)+      (Fourier.analysisTransformOneReal n rng (Complex.real . f))+      (Fourier.analysisTransformOneImag n rng (Complex.imag . f))+++{- |+Try to approximate @\x -> exp (-x^2) * x@+by a difference of translated Gaussian bells.++exp(-x^2) * x+  ==  exp(-(a+b*x+c*x^2)) - exp(-(a-b*x+c*x^2))+  ==  exp(-(a+c*x^2)) * (exp(-b*x) - exp(b*x))+  ==  exp(-(a+c*x^2)) * 2*sinh (b*x)++It holds+  lim (\b x -> sinh (b*x) / b)  =  id+-}+diffApprox :: IO ()+diffApprox =+   let amp = (2*b)^- (-2)+       a = 0+       {-+       amp = 1+       a = log (2 * abs b)+       -}+       b = -0.1+       c = 1+       ac = Complex.fromReal a+       bc = Complex.fromReal b+   in  GP.plotFuncs []+          (GP.linearScale 100 (-2,2::Double))+          [Complex.real .+           (PolyBell.evaluateSqRt $+              PolyBell.Cons Bell.unit (Poly.fromCoeffs [zero,one])),+           Complex.real .+           liftA2 (-)+             (PolyBell.evaluateSqRt $+                PolyBell.Cons (Bell.Cons amp ac bc c) (Poly.fromCoeffs [one]))+             (PolyBell.evaluateSqRt $+                PolyBell.Cons (Bell.Cons amp ac (-bc) c) (Poly.fromCoeffs [one]))]+++polyApprox :: IO ()+polyApprox =+   GP.plotFuncs []+      (GP.linearScale 100 (-2,2::Double))+      [Complex.real .+         PolyBell.evaluateSqRt curve2,+       Complex.real . sum .+         mapM (\(amp,b) -> \x -> amp * Bell.evaluateSqRt b x)+         (PolyBell.approximateByBells 0.1 curve2)]
+ gaussian/MathObj/Gaussian/ExponentTuple.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE RebindableSyntax #-}+module MathObj.Gaussian.ExponentTuple where++import qualified Test.QuickCheck as QC++import Control.Applicative (liftA2, liftA3)++import Data.Function.HT (compose2)++import NumericPrelude.Base as P+import NumericPrelude.Numeric as NP+++{- $setup+>>> import MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates))+>>> import MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates))+>>> import NumericPrelude.Base as P+>>> import NumericPrelude.Numeric as NP+>>> import Prelude ()+-}+++{- |+For @(HoelderConjugates p q)@ it holds++prop> \(HoelderConjugates p q)  ->  p>=1 && q>=1 && 1/p + 1/q == 1+-}+data HoelderConjugates = HoelderConjugates Rational Rational+   deriving Show++instance QC.Arbitrary HoelderConjugates where+   arbitrary = genHoelderConjugates0++genHoelderConjugates0 :: QC.Gen HoelderConjugates+genHoelderConjugates0 =+   liftA2+      (\(QC.Positive p) (QC.Positive q) ->+         let s = p + q in HoelderConjugates (s % p) (s % q))+      QC.arbitrary QC.arbitrary++genHoelderConjugates1 :: QC.Gen HoelderConjugates+genHoelderConjugates1 =+   liftA2+      (\(QC.Positive p) (QC.Positive q) ->+         let s = 1%p + 1%q+         in HoelderConjugates (fromInteger p * s) (fromInteger q * s))+      QC.arbitrary QC.arbitrary+++{- |+For @(YoungConjugates p q r)@ it holds++prop> \(YoungConjugates p q r)  ->  p>=1 && q>=1 && r>=1 && 1/p + 1/q == 1/r + 1+-}+data YoungConjugates = YoungConjugates Rational Rational Rational+   deriving Show++instance QC.Arbitrary YoungConjugates where+   arbitrary = genYoungConjugates0++{-+Find positive natural numbers @a, b, c, d@ with++> a + b = c + d++and++> d >= a, d >= b, d >= c++then set++> p=d/a, q=d/b, r=d/c+++a+b<=c+b+c<=a+->  2b <= 0+-}+genYoungConjugates0 :: QC.Gen YoungConjugates+genYoungConjugates0 =+   liftA3+      (\(QC.Positive a0) (QC.Positive b0) (QC.Positive c0) ->+         let guardSwap cond (x,y) =+                if cond x y then (x,y) else (y,x)+             {-+             If a+b<=c, then from b>0 it follows a<c and thus c+b>a.+             Swapping a and c is enough and we have not to consider more cases.+             -}+             (a1,c1) = guardSwap (\a c -> a+b0>c) (a0,c0)+             b1 = b0+             d1 = a1+b1-c1+             ((a2,b2),(c2,d2)) =+                guardSwap (compose2 (<=) snd)+                   (guardSwap (<=) (a1,b1),+                    guardSwap (<=) (c1,d1))+         in  YoungConjugates (d2%a2) (d2%b2) (d2%c2))+      QC.arbitrary QC.arbitrary QC.arbitrary++{- |+This one is simpler, but may yield exponents smaller than 1.+-}+genYoungConjugates1 :: QC.Gen YoungConjugates+genYoungConjugates1 =+   liftA3+      (\(QC.Positive a0) (QC.Positive b0) (QC.Positive c0) ->+         let {-+             If a+b<=c, then from b>0 it follows a<c and thus c+b>a.+             Swapping a and c is enough and we have not to consider more cases.+             -}+             (a1,c1) = if a0+b0<=c0 then (c0,a0) else (a0,c0)+             b1 = b0+             d1 = a1+b1-c1+         in  YoungConjugates (d1%a1) (d1%b1) (d1%c1))+      QC.arbitrary QC.arbitrary QC.arbitrary
+ gaussian/MathObj/Gaussian/Polynomial.hs view
@@ -0,0 +1,584 @@+{-# LANGUAGE RebindableSyntax #-}+{-+Complex Gaussian bell multiplied with a polynomial.++In order to make this free of @pi@ factors,+we have to choose @recip (sqrt pi)@+as unit for translations and modulations,+for linear factors and in the differentiation.+-}+{-+ToDo:++* In order to avoid the weird @sqrt pi@ factor,+  use a polynomial expression in @pi@.++* sum of multiple bells using Data.Map from exponent polynomial to coefficient polynomial+  use of Algebra object.++* Discrete Fourier Transform and its eigenvectors++* Use projective geometry in order to support Dirac impulse.+  There are many open questions:+  1. What shall be the product of two Dirac impulses -+     whether they are at the same location or not.+  2. How to organize coefficients+     such that the constant function can be modulated+     and the Dirac impulse can be translated.+-}+module MathObj.Gaussian.Polynomial where++import qualified MathObj.Gaussian.Bell as Bell++import qualified MathObj.LaurentPolynomial as LPoly+import qualified MathObj.Polynomial.Core   as PolyCore+import qualified MathObj.Polynomial        as Poly+import qualified Number.Complex     as Complex++import qualified Algebra.ZeroTestable   as ZeroTestable+import qualified Algebra.Differential   as Differential+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+import qualified Algebra.Absolute       as Absolute+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import qualified Data.Record.HT as Rec+import qualified Data.List as List+import Data.Function.HT (nest, )+import Data.Eq.HT (equating, )+import Data.List.HT (mapAdjacent, )+import Data.Tuple.HT (forcePair, )++import Test.QuickCheck (Arbitrary, arbitrary, )+import Control.Monad (liftM2, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (reverse, )+++{- $setup+>>> :set -XRebindableSyntax+>>>+>>> import qualified MathObj.Gaussian.Polynomial as G+>>> import qualified MathObj.Gaussian.Bell as Bell+>>> import qualified MathObj.Polynomial as Poly+>>> import qualified Algebra.Laws as Laws+>>> import qualified Number.Complex as Complex+>>> import Number.Complex ((+:))+>>> import NumericPrelude.Base as P+>>> import NumericPrelude.Numeric as NP+>>> import qualified Test.QuickCheck as QC+>>> import Data.Function.HT (Id, nest)+>>> import Data.Tuple.HT (mapSnd)+>>>+>>> asRational :: Id (G.T Rational)+>>> asRational = id+>>>+>>> withRational :: Id (G.T Rational -> a)+>>> withRational = id+>>>+>>> mulLinear2i :: Id (G.T Rational)+>>> mulLinear2i x =+>>>    x{G.polynomial = Poly.fromCoeffs [0, 0+:2] * G.polynomial x}+>>>+>>> rotateQuarter :: Int -> Id (G.T Rational)+>>> rotateQuarter n =+>>>    G.scaleComplex (negate Complex.imaginaryUnit ^ fromIntegral n)+-}+++data T a = Cons {bell :: Bell.T a, polynomial :: Poly.T (Complex.T a)}+   deriving (Show)++instance (Absolute.C a, ZeroTestable.C a, Eq a) => Eq (T a) where+   (==) = equal+++{-+Helper data type for 'equal',+that allows to call the (not quite trivial) polynomial equality check.+@RootProduct r a@ represents @sqrt r * a@.+The test using 'signum' works for real numbers,+and I do not know, whether it is correct for other mathematical objects.+However I cannot imagine other mathematical objects,+that make sense at all, here.+Maybe elements of a finite field.+-}+data RootProduct a = RootProduct a a++instance (Absolute.C a, ZeroTestable.C a, Eq a) => Eq (RootProduct a) where+   (RootProduct xr xa) == (RootProduct yr ya)  =+      let xp = xr*xa^2+          yp = yr*ya^2+      in  xp==yp &&+          (isZero xp || signum xa == signum ya)++instance (ZeroTestable.C a) => ZeroTestable.C (RootProduct a) where+   isZero (RootProduct r a) = isZero r || isZero a+++{-+The derived Eq is not correct.+We have to combine the amplitude of the bell with the polynomial,+respecting signs and the square root of the bell amplitude.+-}+equal :: (Absolute.C a, ZeroTestable.C a, Eq a) => T a -> T a -> Bool+equal x y =+   let bx = bell x+       by = bell y+       scaleSqr b =+          (\p ->+              (fmap (RootProduct (Bell.amp b) . Complex.real) p,+               fmap (RootProduct (Bell.amp b) . Complex.imag) p))+           . polynomial+   in  Rec.equal+          (equating Bell.c0 :+           equating Bell.c1 :+           equating Bell.c2 :+           [])+          bx by+       &&+       scaleSqr bx x == scaleSqr by y+++instance (Absolute.C a, ZeroTestable.C a, Arbitrary a) => Arbitrary (T a) where+   arbitrary =+--      liftM2 Cons arbitrary arbitrary+      liftM2 Cons+         arbitrary+         -- we have to restrict the number of polynomial coefficients,+         -- since with the quadratic time algorithms like fourier and convolve,+         -- in connection with Rational slow down tests too much.+         (fmap (Poly.fromCoeffs . take 5 . Poly.coeffs) arbitrary)++++{-# INLINE evaluateSqRt #-}+evaluateSqRt :: (Trans.C a) =>+   T a -> a -> Complex.T a+evaluateSqRt f x =+   Bell.evaluateSqRt (bell f) x *+   Poly.evaluate (polynomial f) (Complex.fromReal $ sqrt pi * x)+{- ToDo: evaluating a complex polynomial for a real argument can be optimized -}+++constant :: (Ring.C a) => T a+constant =+   Cons Bell.constant (Poly.const one)++scale :: (Ring.C a) => a -> T a -> T a+scale x f =+   f{polynomial = fmap (Complex.scale x) $ polynomial f}++scaleComplex :: (Ring.C a) => Complex.T a -> T a -> T a+scaleComplex x f =+   f{polynomial = fmap (x*) $ polynomial f}+++unit :: (Ring.C a) => T a+unit = eigenfunction0++{- |+This one does not hold for larger degrees, although it would be nice:++prop> QC.forAll (QC.choose (0,3)) $ \n -> G.eigenfunctionDifferential n == asRational (G.eigenfunctionIterative n)++Unfortunately, both implementations compute different eigenbases.+-}+eigenfunction :: (Field.C a) => Int -> T a+eigenfunction =+   eigenfunctionDifferential++-- | prop> G.eigenfunction0  ==  asRational (G.eigenfunctionDifferential 0)+eigenfunction0 :: (Ring.C a) => T a+eigenfunction0 =+   Cons Bell.unit (Poly.fromCoeffs [one])++-- | prop> G.eigenfunction1  ==  asRational (G.eigenfunctionDifferential 1)+eigenfunction1 :: (Ring.C a) => T a+eigenfunction1 =+   Cons Bell.unit (Poly.fromCoeffs [zero, one])++-- | prop> G.eigenfunction2  ==  asRational (G.eigenfunctionDifferential 2)+eigenfunction2 :: (Field.C a) => T a+eigenfunction2 =+   Cons Bell.unit (Poly.fromCoeffs [-(1/4), zero, one])++-- | prop> G.eigenfunction3  ==  asRational (G.eigenfunctionDifferential 3)+eigenfunction3 :: (Field.C a) => T a+eigenfunction3 =+   Cons Bell.unit (Poly.fromCoeffs [zero, -(3/4), zero, one])+++{- |+prop> QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionDifferential n in G.fourier x  ==  rotateQuarter n x+-}+eigenfunctionDifferential :: (Field.C a) => Int -> T a+eigenfunctionDifferential n =+   (\f -> f{bell = Bell.unit}) $+   nest n (scale (-1/4) . differentiate) $+   Cons (Bell.Cons one zero zero 2) one++{- |+prop> QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionIterative n in G.fourier x  ==  rotateQuarter n x+-}+eigenfunctionIterative ::+   (Field.C a, Absolute.C a, ZeroTestable.C a, Eq a) => Int -> T a+eigenfunctionIterative n =+   fst . head . dropWhile (uncurry (/=)) . mapAdjacent (,) $+   eigenfunctionIteration $+   Cons+      Bell.unit+      (Poly.fromCoeffs $ replicate n zero ++ [one])++eigenfunctionIteration :: (Field.C a) => T a -> [T a]+eigenfunctionIteration =+   iterate (\x ->+      let y = fourier x+          px = polynomial x+          py = polynomial y+          c = last (Poly.coeffs px) / last (Poly.coeffs py)+      in  y{polynomial = fmap (0.5*) (px + fmap (c*) py)})+++{- |+prop> withRational $ Laws.identity G.multiply G.constant+prop> withRational $ Laws.commutative G.multiply+prop> withRational $ Laws.associative G.multiply+-}+multiply :: (Ring.C a) =>+   T a -> T a -> T a+multiply f g =+   Cons+      (Bell.multiply (bell f) (bell g))+      (polynomial f * polynomial g)++{- |+prop> withRational $ Laws.commutative G.convolve+prop> withRational $ Laws.associative G.convolve+-}+convolve, {- convolveByDifferentiation, -} convolveByFourier :: (Field.C a) =>+   T a -> T a -> T a+convolve = convolveByFourier++{-+f <*> g =+   let (foff,fint) = integrate f+   in  fint <*> differentiate g + makeGaussPoly foff * g++In principle this would work,+but (makeGaussPoly foff * g) contains a lot of+convolutions of Gaussian with Gaussian-polynomial-product,+where the Gaussians have different parameters.++convolveByDifferentiation f g =+   case polynomial f of+      fpoly ->+         if null $ Poly.coeffs fpoly+           then ...+           else ...+-}++convolveByFourier f g =+   reverse $ fourier $ multiply (fourier f) (fourier g)++{-+We use a Horner like scheme+in order to translate multiplications with @id@+to differentations on the Fourier side.+Quadratic runtime.++fourier (Cons bell (Poly.const a + Poly.shift f))+  = fourier (Cons bell (Poly.const a)) + fourier (Cons bell (Poly.shift f))+  = fourier (Cons bell (Poly.const a)) + differentiate (fourier (Cons bell f))++We can certainly speed this up considerably+by decomposing the polynomial into four polynomials,+one for each of the four eigenvalues 1, i, -1, -i.+-}+{- |+prop> withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y)+prop> withRational $ \x -> nest 2 G.fourier x == G.reverse x+prop> withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x)+prop> withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))+prop> withRational $ \x -> G.fourier (G.differentiate x) == mulLinear2i (G.fourier x)+-}+fourier :: (Field.C a) =>+   T a -> T a+fourier f =+   foldr+      (\c p ->+          let q = differentiate p+          in  q{polynomial =+                   Poly.const c ++                   fmap (Complex.scale (1/2) . Complex.quarterLeft) (polynomial q)})+      (Cons (Bell.fourier $ bell f) zero) $+   Poly.coeffs $ polynomial f++{- |+Differentiate and divide by @sqrt pi@ in order to stay in a ring.+This way, we do not need to fiddle with pi factors.++prop> withRational $ \x y -> G.convolve (G.differentiate x) y == G.convolve x (G.differentiate y)+-}+differentiate :: (Ring.C a) => T a -> T a+differentiate f =+   f{polynomial =+        Differential.differentiate (polynomial f)+        - Differential.differentiate (Bell.exponentPolynomial (bell f))+           * polynomial f}++{-+g = (bell f * poly f)'+  = bell f * ((poly f)' - (exppoly (bell f))' * poly f)+poly g = (poly f)' - (exppoly (bell f))' * poly f++Integration means we have g and ask for f.++poly f = ((poly f)' - poly g) / (exppoly (bell f))'++However must start with the highest term of 'poly f',+and thus we need to perform the division on reversed polynomials.+-}+{- |+>>> snd $ G.integrate $ G.differentiate $ G.Cons Bell.unit (Poly.fromCoeffs [7,7,7,7 :: Complex.T Rational])+Cons {bell = Cons {amp = 1 % 1, c0 = 0 % 1 +: 0 % 1, c1 = 0 % 1 +: 0 % 1, c2 = 1 % 1}, polynomial = Polynomial.fromCoeffs [7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1]}++prop> withRational $ \x -> G.integrate (G.differentiate x) == (zero, x)+prop> withRational $ \x@(G.Cons b p) -> let (xoff,xint) = G.integrate x in G.differentiate xint == G.Cons b (p + Poly.const xoff)+-}+integrate ::+   (Field.C a, ZeroTestable.C a) =>+   T a -> (Complex.T a, T a)+integrate f =+   let fs = Poly.coeffs $ polynomial f+       (ys,~[r]) =+          PolyCore.divModRev+             {-+             We need the shortening convention of 'zipWith'+             in order to limit the result list,+             we cannot use list instance for (-).+             -}+             (zipWith (-)+                (0 : 0 : diffRev ys)+                (List.reverse fs))+             (List.reverse $ Poly.coeffs $+              Differential.differentiate $+              Bell.exponentPolynomial $ bell f)+   in  forcePair $+       if null fs+         then (zero, f)+         else (r, f{polynomial = Poly.fromCoeffs $ List.reverse ys})++diffRev :: Ring.C a => [a] -> [a]+diffRev xs =+   zipWith (*) xs+      (drop 1 (iterate (subtract 1) (fromIntegral $ length xs)))++{-+integrateDefinite+   (maybe rename integrate to antiderivative and call this one integrate)++int(x^(2*n)*exp(-x^2),x=-infinity..infinity)+ = 2 * int(x^(2*n)*exp(-x^2),x=0..infinity)+     substitute t=x^2, dt = dx * 2 * sqrt t+ = int(t^(n-1/2)*exp(-t),x=0..infinity)+ = Gamma(n+1/2)+ = (2n-1)!!/2^n * sqrt pi++int(pi^n*x^(2*n)*exp(-pi*x^2),x=-infinity..infinity)+ = (2n-1)!!/2^n+++The remainder value of 'integrate'+is the coefficient of the error function+and this is the only part that does not vanish when approaching the limit.+++In order to stay in a field,+we have to return a rational number+and a transcendental part written es @exp a@.++It would be interesting to see how integral inequalities+translate to scalar inequalities containing exponential functions.+-}+++{- |+prop> withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x+-}+translate :: Ring.C a => a -> T a -> T a+translate d =+   translateComplex (Complex.fromReal d)++{- |+prop> withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x+prop> withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x+-}+translateComplex :: Ring.C a => Complex.T a -> T a -> T a+translateComplex d f =+   Cons+      (Bell.translateComplex d $ bell f)+      (Poly.translate d $ polynomial f)++{- |+prop> withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x+prop> withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x))+-}+modulate :: Ring.C a => a -> T a -> T a+modulate d f =+   Cons+      (Bell.modulate d $ bell f)+      (polynomial f)++turn :: Ring.C a => a -> T a -> T a+turn d f =+   Cons+      (Bell.turn d $ bell f)+      (polynomial f)++{- |+prop> withRational $ \x -> nest 2 G.reverse x == x+-}+reverse :: Additive.C a => T a -> T a+reverse f =+   Cons+      (Bell.reverse $ bell f)+      (Poly.reverse $ polynomial f)++{- |+prop> withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x+prop> withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x+-}+dilate :: Field.C a => a -> T a -> T a+dilate k f =+   Cons+      (Bell.dilate k $ bell f)+      (Poly.dilate (Complex.fromReal k) $ polynomial f)++{- |+prop> withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x+prop> withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x+-}+shrink :: Ring.C a => a -> T a -> T a+shrink k f =+   Cons+      (Bell.shrink k $ bell f)+      (Poly.shrink (Complex.fromReal k) $ polynomial f)++{-+We could also amplify the polynomial coefficients.+-}+amplify :: Ring.C a => a -> T a -> T a+amplify k f =+   Cons+      (Bell.amplify k $ bell f)+      (polynomial f)+++{- |+Approximate a @T a@ using a linear combination of translated @Bell.T a@.+The smaller the unit (e.g. 0.1, 0.01, 0.001)+the better the approximation but the worse the numeric properties.++We cannot put all information into @amp@ of @Bell@,+since @amp@ must be real, but is complex here by construction.+We really need at least signed amplitudes at this place,+since we want to represent differences of Gaussians.++prop> withRational $ \x (QC.NonZero unit) d -> G.approximateByBells unit (G.translateComplex d x) == map (mapSnd (Bell.translateComplex d)) (G.approximateByBells unit x)+prop> withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.dilate d x) == map (mapSnd (Bell.dilate d)) (G.approximateByBells (unit/d) x)+prop> withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.shrink d x) == map (mapSnd (Bell.shrink d)) (G.approximateByBells (unit*d) x)+-}+approximateByBells ::+   Field.C a =>+   a -> T a -> [(Complex.T a, Bell.T a)]+approximateByBells unit_ f =+   let b = bell f+       amps =+          -- approximateByBellsByTranslation+          approximateByBellsAtOnce+             unit_+             (Complex.scale (recip (2 * Bell.c2 b)) (Bell.c1 b))+             (recip (2*unit_*Bell.c2 b))+             (polynomial f)+   in  zip (LPoly.coeffs amps) $+       map+          (\d -> Bell.translate d b)+          (laurentAbscissas (unit_/2) amps)++{- |+prop> \(QC.NonZero unit) d s p0 -> let p = Poly.fromCoeffs $ take 10 p0 in G.approximateByBellsAtOnce unit d s p == G.approximateByBellsByTranslation unit d (s::Rational) p+-}+approximateByBellsAtOnce ::+   Field.C a =>+   a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a)+approximateByBellsAtOnce unit_ d s p =+   foldr+      (\x amps0 ->+         {-+         Decompose (bell t * (t-d)) = bell t * t - bell t * d+         -}+         let y = fmap (Complex.scale s) amps0+         in  -- \t -> bell t * t+             --    ~   (translate unit_ bell - translate (-unit_) bell) / unit_+             LPoly.shift 1 y -+             LPoly.shift (-1) y ++             -- bell t * d+             zipWithAbscissas+                (\t z -> (Complex.fromReal t - d) * z)+                (unit_/2) amps0 ++             LPoly.const x)+      (LPoly.fromCoeffs [])+      (Poly.coeffs p)++approximateByBellsByTranslation ::+   Field.C a =>+   a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a)+approximateByBellsByTranslation unit_ d s p =+   foldr+      (\x amps0 ->+         {-+         Decompose (bell t * (t-d)) = bell t * t - bell t * d+         -}+         let y = fmap (Complex.scale s) amps0+         in  -- \t -> bell t * t+             --    ~   (translate unit_ bell - translate (-unit_) bell) / unit_+             LPoly.shift 1 y -+             LPoly.shift (-1) y ++             -- bell t * d+             zipWithAbscissas Complex.scale (unit_/2) amps0 ++             LPoly.const x)+      (LPoly.fromCoeffs [])+      (Poly.coeffs $ Poly.translate d p)++zipWithAbscissas ::+   (Ring.C a) =>+   (a -> b -> c) -> a -> LPoly.T b -> LPoly.T c+zipWithAbscissas h unit_ y =+   LPoly.fromShiftCoeffs (LPoly.expon y) $+   zipWith h+      (laurentAbscissas unit_ y)+      (LPoly.coeffs y)++laurentAbscissas :: Ring.C a => a -> LPoly.T c -> [a]+laurentAbscissas unit_ =+   map (\d -> fromIntegral d * unit_) .+   iterate (1+) . LPoly.expon+++{- No Ring instance for Gaussians+instance (Ring.C a) => Differential.C (T a) where+   differentiate = differentiate+-}++{- laws+differentiate (f*g) =+   (differentiate f) * g + f * (differentiate g)++inequalities:++Heisenberg's uncertainty relation+   needs integrals and thus needs product of exponential numbers and roots+-}
+ gaussian/MathObj/Gaussian/Variance.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE RebindableSyntax #-}+{-+We represent a Gaussian bell curve in terms of the reciprocal of its variance+and its value at the origin.++We could do some projective geometry in the exponent+in order to also have zero variance,+which corresponds to the dirac impulse.++The Gaussians form a nice multiplicative commutative monoid.+Maybe we should have such a structure.+It would also be useful for the Root data type+and a new Exponential data type.+-}+module MathObj.Gaussian.Variance where++import qualified MathObj.Polynomial as Poly+import qualified Number.Root as Root++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic      as Algebraic+import qualified Algebra.Field          as Field+import qualified Algebra.Absolute       as Absolute+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Test.QuickCheck (Arbitrary, arbitrary, )+import Control.Monad (liftM2, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- $setup+>>> import qualified MathObj.Gaussian.Variance as G+>>> import MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates))+>>> import MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates))+>>> import qualified Algebra.Laws as Laws+>>> import qualified Number.Root as Root+>>> import NumericPrelude.Base as P+>>> import NumericPrelude.Numeric as NP+>>> import Prelude ()+>>> import qualified Test.QuickCheck as QC+>>> import Data.Function.HT (Id, nest)+>>>+>>> asRational :: Id (G.T Rational)+>>> asRational = id+>>>+>>> withRational :: Id (G.T Rational -> a)+>>> withRational = id+-}+++{- |+Since @amp@ is the square of the actual amplitude it must be non-negative.+-}+data T a = Cons {amp, c :: a}+   deriving (Eq, Show)++instance (Absolute.C a, Arbitrary a) => Arbitrary (T a) where+   arbitrary =+      liftM2 Cons+         (fmap abs arbitrary)+         (fmap ((1+) . abs) arbitrary)+++constant :: Ring.C a => T a+constant = Cons one zero++{- |+eigenfunction of 'fourier'+-}+unit :: Ring.C a => T a+unit = Cons one one++{-# INLINE evaluate #-}+evaluate :: (Trans.C a) =>+   T a -> a -> a+evaluate f x =+   sqrt (amp f) * exp (-pi * c f * x^2)++exponentPolynomial :: (Additive.C a) =>+   T a -> Poly.T a+exponentPolynomial f =+   Poly.fromCoeffs [zero, zero, c f]+++integrateRoot :: (Field.C a) => T a -> Root.T a+integrateRoot f =+   Root.sqrt $ Root.fromNumber $ amp f / c f++{- |+Cauchy-Schwarz inequality:++prop> withRational $ \x y -> G.scalarProductRoot x y <= G.norm2Root x `Root.mul` G.norm2Root y++Hoelder inequality:++prop> withRational $ \x y -> G.scalarProductRoot x y <= G.norm1Root x `Root.mul` G.normInfRoot y+prop> withRational $ \x y (HoelderConjugates p q) -> G.scalarProductRoot x y <= G.normPRoot p x `Root.mul` G.normPRoot q y+-}+scalarProductRoot :: (Field.C a) => T a -> T a -> Root.T a+scalarProductRoot f g =+   integrateRoot (multiply f g)+++{- |+prop> withRational $ \x -> G.norm1Root x == G.normPRoot 1 x+-}+norm1Root :: (Field.C a) => T a -> Root.T a+norm1Root = integrateRoot++{- |+prop> withRational $ \x -> G.norm2Root x == G.normPRoot 2 x+-}+norm2Root :: (Field.C a) => T a -> Root.T a+norm2Root f =+   Root.sqrt $+      Root.fromNumber (amp f)+      `Root.div`+      Root.sqrt (Root.fromNumber $ 2 * c f)++normInfRoot :: (Field.C a) => T a -> Root.T a+normInfRoot f =+   Root.sqrt $ Root.fromNumber $ amp f++{-+I would have liked to test for a monotony of norms.+Unfortunately, it does not hold.++Means contain a division by the size of the domain.+Norms do not have this division.+Means are monotonic with respect to the degree.+Norms are not.+We cannot turn the norms into means since the size of the domain+(the complete real axis) is infinitely large.++prop> :{ withRational $ \x p0 q0 ->+   let p = 1 + abs p0+       q = 1 + abs q0+   in  case compare p q of+          EQ -> G.normPRoot p x == G.normPRoot q x+          LT -> G.normPRoot p x <= G.normPRoot q x+          GT -> G.normPRoot p x >= G.normPRoot q x+:}++This should also fail,+but QuickCheck does not seem to try counterexamples.++prop> :{ withRational $ \x p0 ->+   let p = 1 + abs p0+   in  G.normPRoot p x <= G.normInfRoot x+:}+-}+normPRoot :: (Field.C a) => Rational -> T a -> Root.T a+normPRoot p f =+   Root.sqrt (Root.fromNumber (amp f))+   `Root.div`+   Root.rationalPower (recip (2*p)) (Root.fromNumber (fromRational' p * c f))+++-- ToDo: implement NormedSpace.Sum et.al.+norm1 :: (Algebraic.C a) => T a -> a+norm1 f =+   sqrt $ amp f / c f++norm2 :: (Algebraic.C a) => T a -> a+norm2 f =+   sqrt $ amp f / (sqrt $ 2 * c f)++normInf :: (Algebraic.C a) => T a -> a+normInf f =+   sqrt (amp f)++normP :: (Trans.C a) => a -> T a -> a+normP p f =+   sqrt (amp f) * (p * c f) ^? (- recip (2*p))+++variance :: (Trans.C a) =>+   T a -> a+variance f =+   recip $ c f * 2*pi++{- |+prop> withRational $ \x (QC.Positive a) -> G.varianceRational (G.dilate a x) == a^2 * G.varianceRational x+prop> withRational $ \x y -> G.varianceRational (G.convolve x y) == G.varianceRational x + G.varianceRational y+-}+varianceRational :: (Field.C a) => T a -> a+varianceRational f = recip $ c f++{- |+prop> Laws.identity G.multiply G.constant . asRational+prop> Laws.commutative G.multiply . asRational+prop> Laws.associative G.multiply . asRational+-}+multiply :: (Ring.C a) =>+   T a -> T a -> T a+multiply f g =+   Cons (amp f * amp g) (c f + c g)++powerRing :: (Trans.C a) =>+   Integer -> T a -> T a+powerRing p f =+   Cons (amp f ^ p) (fromInteger p * c f)++{-+powerField does not makes sense,+since the reciprocal of a Gaussian diverges.+-}++powerAlgebraic :: (Trans.C a) =>+   Rational -> T a -> T a+powerAlgebraic p f =+   Cons (amp f ^/ p) (fromRational' p * c f)++powerTranscendental :: (Trans.C a) =>+   a -> T a -> T a+powerTranscendental p f =+   Cons (amp f ^? p) (p * c f)++{- |+> convolve x y t =+>    integrate $ \s -> x s * y(t-s)++Convergence only for @c f + c g > 0@.++prop> Laws.commutative G.convolve . asRational+prop> Laws.associative G.convolve . asRational++Young inequality:++prop> withRational $ \x y -> G.normInfRoot (G.convolve x y) <= G.norm1Root x `Root.mul` G.normInfRoot y+prop> withRational $ \x y (HoelderConjugates p q) -> G.normInfRoot (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y+prop> withRational $ \x y (YoungConjugates p q r) -> G.normPRoot r (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y+-}+convolve :: (Field.C a) =>+   T a -> T a -> T a+convolve f g =+   let s = c f + c g+   in  Cons+          (amp f * amp g / s)+          (c f * c g / s)++{- |+> fourier x f =+>    integrate $ \t -> x t * cis (-2*pi*t*f)++Convergence only for @c f > 0@.++prop> withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y)+prop> withRational $ \x -> nest 4 G.fourier x == x+prop> withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))+prop> withRational $ \x y -> G.scalarProductRoot x y == G.scalarProductRoot (G.fourier x) (G.fourier y)+-}+fourier :: (Field.C a) =>+   T a -> T a+fourier f =+   Cons (amp f / c f) (recip $ c f)+{-+fourier (t -> exp(-(a*t)^2))+-}++{- |+prop> withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x+prop> withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x+-}+dilate :: (Field.C a) => a -> T a -> T a+dilate k f =+   Cons (amp f) $ c f / k^2++{- |+prop> withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x+prop> withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x+-}+shrink :: (Ring.C a) => a -> T a -> T a+shrink k f =+   Cons (amp f) $ c f * k^2++{- |+@amplify k@ scales by @abs k@!+-}+amplify :: (Ring.C a) => a -> T a -> T a+amplify k f =+   Cons (k^2 * amp f) $ c f
numeric-prelude.cabal view
@@ -1,168 +1,71 @@+Cabal-Version:  2.2 Name:           numeric-prelude-Version:        0.1.3.4-License:        GPL+Version:        0.4.4+License:        BSD-3-Clause License-File:   LICENSE Author:         Dylan Thurston <dpt@math.harvard.edu>, Henning Thielemann <numericprelude@henning-thielemann.de>, Mikael Johansson Maintainer:     Henning Thielemann <numericprelude@henning-thielemann.de> Homepage:       http://www.haskell.org/haskellwiki/Numeric_Prelude Category:       Math Stability:      Experimental-Tested-With:    GHC==6.4.1, GHC==6.8.2+Tested-With:    GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3+Tested-With:    GHC==8.4.4, GHC==8.6.5, GHC==9.0.1+Build-Type:     Simple Synopsis:       An experimental alternative hierarchy of numeric type classes Description:-  Revisiting the Numeric Classes-  .-  The Prelude for Haskell 98 offers a well-considered set of numeric classes-  which covers the standard numeric types-  ('Integer', 'Int', 'Rational', 'Float', 'Double', 'Complex') quite well.-  But they offer limited extensibility and have a few other flaws.-  In this proposal we will revisit these classes, addressing the following concerns:-  .-  [1] The current Prelude defines no semantics for the fundamental operations.-      For instance, presumably addition should be associative-      (or come as close as feasible),-      but this is not mentioned anywhere.-  .-  [2] There are some superfluous superclasses.-      For instance, 'Eq' and 'Show' are superclasses of 'Num'.-      Consider the data type-      @   data IntegerFunction a = IF (a -> Integer) @-      One can reasonably define all the methods of 'Algebra.Ring.C' for-      @IntegerFunction a@ (satisfying good semantics),-      but it is impossible to define non-bottom instances of 'Eq' and 'Show'.-      In general, superclass relationship should indicate-      some semantic connection between the two classes.-  .-  [3] In a few cases, there is a mix of semantic operations and-      representation-specific operations.-      'toInteger', 'toRational',-      and the various operations in 'RealFloating' ('decodeFloat', ...)-      are the main examples.-  .-  [4] In some cases, the hierarchy is not finely-grained enough:-      Operations that are often defined independently are lumped together.-      For instance, in a financial application one might want a type \"Dollar\",-      or in a graphics application one might want a type \"Vector\".-      It is reasonable to add two Vectors or Dollars,-      but not, in general, reasonable to multiply them.-      But the programmer is currently forced to define a method for '(*)'-      when she defines a method for '(+)'.-  .-  In specifying the semantics of type classes,-  I will state laws as follows:-  .-  >    (a + b) + c === a + (b + c)-  .-  The intended meaning is extensional equality:-  The rest of the program should behave in the same way-  if one side is replaced with the other.-  Unfortunately, the laws are frequently violated by standard instances;-  the law above, for instance, fails for 'Float':-  .-  >    (1e20 + (-1e20)) + 1.0  = 1.0-  >     1e20 + ((-1e20) + 1.0) = 0.0-  .-  For inexact number types like floating point types,-  thus these laws should be interpreted as guidelines rather than absolute rules.-  In particular, the compiler is not allowed to use them for optimization.-  Unless stated otherwise, default definitions should also be taken as laws.-  .-  Thanks to Brian Boutel, Joe English, William Lee Irwin II, Marcin-  Kowalczyk, Ketil Malde, Tom Schrijvers, Ken Shan, and Henning-  Thielemann for helpful comments.-  .-  Scope & Limitations\/TODO:-  * It might be desireable to split Ord up into Poset and Ord-    (a total ordering).-    This is not addressed here.-  .-  * In some cases, this hierarchy may not yet be fine-grained enough.-    For instance, time spans (\"5 minutes\") can be added to times (\"12:34\"),-    but two times are not addable. (\"12:34 + 8:23\")-    As it stands,-    users have to use a different operator for adding time spans to times-    than for adding two time spans.-    Similar issues arise for vector space et al.-    This is a consciously-made tradeoff, but might be changed.-    This becomes most serious when dealing with quantities with units-    like @length\/distance^2@, for which @(*)@ as defined here is useless.-    (One way to see the issue: should-    @  f x y = iterate (x *) y  @-    have principal type-    @  (Ring.C a) => a -> a -> [a]  @-    or something like-    @  (Ring.C a, Module a b) => a -> b -> [b]  @-    ?)-  .-  * I stuck with the Haskell 98 names.-    In some cases I find them lacking.-    Neglecting backwards compatibility, we have renamed classes as follows:-      Num           --> Ring,-      Fractional    --> Field,-      Floating      --> Algebraic + Transcendental,-      RealFloat     --> RealTranscendental,-  .-  * It's slightly unfortunate that 'abs' can no longer be used for complex numbers,-    since it is standard mathematically.-    'magnitude' or more generally 'Algebra.NormedSpace.Euclidean.norm' can be used.-    But it had the wrong type before,-    and I couldn't see how to fit it in without complicating the hierarchy.-  .-  .-  Additional standard libraries might include Enum, IEEEFloat (including-  the bulk of the functions in Haskell 98's RealFloat class),-  VectorSpace, Ratio, and Lattice.-Tested-With:    GHC==6.4.1, GHC==6.8.2-Cabal-Version:  >=1.6-Build-Type:     Simple+  The package provides an experimental alternative hierarchy+  of numeric type classes.+  The type classes are more oriented at mathematical structures+  and their methods come with laws that the instances must fulfill.  Extra-Source-Files:   Makefile+  README.md   docs/NOTES   docs/README   src/Algebra/GenerateRules.hs -Flag splitBase-  description: Choose the new smaller, split-up base package.--Flag buildTests-  description: Build test executables+Flag buildExamples+  description: Build example executables   default:     False  Source-Repository this-  Tag:         0.1.3.4+  Tag:         0.4.4   Type:        darcs-  Location:    http://code.haskell.org/numeric-prelude/+  Location:    https://hub.darcs.net/thielema/numeric-prelude/  Source-Repository head   Type:        darcs-  Location:    http://code.haskell.org/numeric-prelude/+  Location:    https://hub.darcs.net/thielema/numeric-prelude/  Library   Build-Depends:     parsec >=1 && <4,-    QuickCheck >=1 && <3,+    QuickCheck >=2.10 && <3,     storable-record >=0.0.1 && <0.1,-    non-negative >=0.0.2 && <0.1,-    utility-ht >=0.0.4 && <0.1-  If flag(splitBase)-    Build-Depends:-      base >= 2 && <6,-      array >=0.1 && <0.4,-      containers >=0.1 && <0.4,-      random >=1.0 && <1.1-  Else-    Build-Depends: base >= 1.0 && < 2+    non-negative >=0.0.5 && <0.2,+    semigroups >=0.1 && <1.0,+    utility-ht >=0.0.13 && <0.1,+    deepseq >=1.1 && <1.5 +  Build-Depends:+    array >=0.1 && <0.6,+    containers >=0.1 && <0.7,+    random >=1.0 && <1.3,+    base >=4.5 && <5++  Default-Language: Haskell98   GHC-Options:    -Wall   Hs-source-dirs: src   Exposed-modules:+    Algebra.Absolute     Algebra.Additive     Algebra.Algebraic     Algebra.Differential     Algebra.DimensionTerm     Algebra.DivisibleSpace     Algebra.Field+    Algebra.FloatingPoint     Algebra.Indexable     Algebra.IntegralDomain     Algebra.NonNegative@@ -176,9 +79,9 @@     Algebra.NormedSpace.Sum     Algebra.OccasionallyScalar     Algebra.PrincipalIdealDomain-    Algebra.Real     Algebra.RealField     Algebra.RealIntegral+    Algebra.RealRing     Algebra.RealTranscendental     Algebra.RightModule     Algebra.Ring@@ -200,14 +103,19 @@     MathObj.Permutation.CycleList.Check     MathObj.Permutation.Table     MathObj.Polynomial+    MathObj.Polynomial.Core     MathObj.PowerSeries+    MathObj.PowerSeries.Core     MathObj.PowerSeries.DifferentialEquation     MathObj.PowerSeries.Example     MathObj.PowerSeries.Mean     MathObj.PowerSeries2+    MathObj.PowerSeries2.Core     MathObj.PowerSum+    MathObj.RefinementMask2     MathObj.RootSet-    MyPrelude+    MathObj.Wrapper.Haskell98+    MathObj.Wrapper.NumericPrelude     Number.Complex     Number.DimensionTerm     Number.DimensionTerm.SI@@ -227,6 +135,7 @@     Number.ResidueClass.Maybe     Number.ResidueClass.Func     Number.ResidueClass.Reader+    Number.Root     Number.OccasionallyScalarExpression     Number.SI.Unit     Number.SI@@ -235,49 +144,96 @@     Number.Physical     Number.Physical.Read     Number.Physical.Show+    NumericPrelude.List.Checked+    NumericPrelude.List.Generic     NumericPrelude.Elementwise+    NumericPrelude.Numeric+    NumericPrelude.Base     NumericPrelude-    PreludeBase   Other-modules:     NumericPrelude.List     Algebra.AffineSpace-    MathObj.Gaussian.Variance-    MathObj.Gaussian.Bell-    MathObj.Gaussian.Polynomial+    Algebra.RealRing98+    -- I think I won't add them this way.+    -- It is certainly better to split the class into comparison and selection.+    Algebra.EqualityDecision+    Algebra.OrderDecision -Executable test-  Hs-Source-Dirs: src, test-  Main-Is: Test.hs-  If !flag(buildTests)-    Buildable:         False+Executable numeric-prelude-demo+  Hs-Source-Dirs: test+  GHC-Options:    -Wall+  Default-Language: Haskell98+  Main-Is: Demo.hs -Executable testsuite-  Hs-Source-Dirs: src, test+  If flag(buildExamples)+    Build-Depends:+      numeric-prelude,+      base+  Else+    Buildable: False++Test-Suite numeric-prelude-test+  Type: exitcode-stdio-1.0   GHC-Options:    -Wall+  Default-Language: Haskell98+  Hs-Source-Dirs: test   Other-modules:     Test.NumericPrelude.Utility     Test.Number.GaloisField2p32m5+    Test.Number.ComplexSquareRoot+    Test.Algebra.IntegralDomain+    Test.Algebra.PrincipalIdealDomain+    Test.Algebra.RealRing+    Test.Algebra.Additive+    Test.MathObj.RefinementMask2     Test.MathObj.PartialFraction     Test.MathObj.Matrix     Test.MathObj.Polynomial+    Test.MathObj.Polynomial.Core     Test.MathObj.PowerSeries+    Test.MathObj.PowerSeries.Core+    Test.MathObj.PowerSeries.Example+    Test.MathObj.Gaussian.ExponentTuple     Test.MathObj.Gaussian.Variance     Test.MathObj.Gaussian.Bell     Test.MathObj.Gaussian.Polynomial+  Hs-Source-Dirs: playground+  Other-modules:+    Number.ComplexSquareRoot+  Hs-Source-Dirs: gaussian+  Other-Modules:+    MathObj.Gaussian.Bell+    MathObj.Gaussian.Polynomial+    MathObj.Gaussian.Variance+    MathObj.Gaussian.ExponentTuple   Main-Is: Test/Run.hs-  If flag(buildTests)-    Build-Depends: HUnit >=1 && <2-  Else-    Buildable: False -Executable test-gaussian-  Hs-Source-Dirs: src, test+  Build-Depends:+    doctest-exitcode-stdio >=0.0 && <0.1,+    doctest-lib >=0.1 && <0.1.1,+    numeric-prelude,+    QuickCheck,+    utility-ht,+    random,+    base++Executable numeric-prelude-gaussian+  Hs-Source-Dirs: gaussian   Main-Is: Gaussian.hs+  Default-Language: Haskell98   Other-Modules:     MathObj.Gaussian.Example-  If flag(buildTests)+    MathObj.Gaussian.Variance+    MathObj.Gaussian.Bell+    MathObj.Gaussian.Polynomial++  If flag(buildExamples)     Build-Depends:-      gnuplot >=0.3 && <0.4,-      HTam >=0.0.2 && <0.1+      gnuplot >=0.5 && <0.6,+      HTam >=0.0.2 && <0.2,+      numeric-prelude,+      QuickCheck,+      utility-ht,+      base   Else     Buildable: False
+ playground/Number/ComplexSquareRoot.hs view
@@ -0,0 +1,137 @@+module Number.ComplexSquareRoot where++import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing as RealRing+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive+import qualified Algebra.ZeroTestable as ZeroTestable++import qualified Number.Complex as Complex++import Test.QuickCheck (Arbitrary, arbitrary, )++import Control.Monad (liftM2, )++import qualified NumericPrelude.Numeric as NP+import NumericPrelude.Numeric hiding (recip, )+import NumericPrelude.Base+import Prelude ()+++{- $setup+>>> import qualified Number.ComplexSquareRoot as SR+>>> import qualified Number.Complex as Complex+>>> import qualified Algebra.Laws as Laws+>>> import Test.QuickCheck ((==>))+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>> sr :: SR.T Rational -> SR.T Rational+>>> sr = id+-}++{- |+Represent the square root of a complex number+without actually having to compute a square root.+If the Bool is False,+then the square root is represented with positive real part+or zero real part and positive imaginary part.+If the Bool is True the square root is negated.++prop> Laws.identity SR.mul SR.one . sr+prop> Laws.commutative SR.mul . sr+prop> Laws.associative SR.mul . sr+prop> Laws.homomorphism SR.fromNumber (\x y -> x * (y :: Complex.T Rational)) SR.mul+prop> Laws.rightIdentity SR.div SR.one . sr+prop> \x -> not (isZero x) ==> SR.recip (SR.recip x) == sr x+prop> \x -> not (isZero x) ==> Laws.inverse SR.mul SR.recip SR.one (sr x)+-}+data T a = Cons Bool (Complex.T a)+   deriving (Show)++{- |+You must use @fmap@ only for number type conversion.+-}+instance Functor T where+   fmap f (Cons n x) = Cons n (fmap f x)++instance (ZeroTestable.C a) => ZeroTestable.C (T a) where+   isZero (Cons _b s) = isZero s++instance (ZeroTestable.C a, Eq a) => Eq (T a) where+   (Cons xb xs) == (Cons yb ys) =+      isZero xs && isZero ys  ||+      xb==yb && xs==ys++instance (Arbitrary a) => Arbitrary (T a) where+   arbitrary = liftM2 Cons arbitrary arbitrary+++fromNumber :: (RealRing.C a) => Complex.T a -> T a+fromNumber x =+   Cons+      (case compare zero (Complex.real x) of+         LT -> False+         GT -> True+         EQ -> Complex.imag x < zero)+      (x^2)++-- htam:Wavelet.DyadicResultant.parityFlip+toNumber :: (RealRing.C a, Complex.Power a) => T a -> Complex.T a+toNumber (Cons n x) =+   case sqrt x of y -> if n then NP.negate y else y+++one :: (Ring.C a) => T a+one = Cons False NP.one++inUpperHalfplane :: (Additive.C a, Ord a) => Complex.T a -> Bool+inUpperHalfplane x =+   case compare (Complex.imag x) zero of+      GT -> True+      LT -> False+      EQ -> Complex.real x < zero++mul, mulAlt, mulAlt2 :: (RealRing.C a) => T a -> T a -> T a+mul (Cons xb xs) (Cons yb ys) =+   let zs = xs*ys+   in  Cons+          ((xb /= yb) /=+             case (inUpperHalfplane xs,+                   inUpperHalfplane ys,+                   inUpperHalfplane zs) of+                (True,True,False) -> True+                (False,False,True) -> True+                _ -> False)+          zs++mulAlt (Cons xb xs) (Cons yb ys) =+   let zs = xs*ys+   in  Cons+          ((xb /= yb) /=+             let xi = Complex.imag xs+                 yi = Complex.imag ys+                 zi = Complex.imag zs+             in  (xi>=zero) /= (yi>=zero) &&+                 (xi>=zero) /= (zi>=zero))+          zs++mulAlt2 (Cons xb xs) (Cons yb ys) =+   let zs = xs*ys+   in  Cons+          ((xb /= yb) /=+             let xi = Complex.imag xs+                 yi = Complex.imag ys+                 zi = Complex.imag zs+             in  xi*yi<zero && xi*zi<zero)+          zs++div :: (RealField.C a) => T a -> T a -> T a+div x y = mul x (recip y)++recip :: (RealField.C a) => T a -> T a+recip (Cons b s) =+   Cons+      (b /= (Complex.imag s == zero && Complex.real s < zero))+      (NP.recip s)
+ src/Algebra/Absolute.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE RebindableSyntax #-}+module Algebra.Absolute (+   C(abs, signum),+   absOrd, signumOrd,+   ) where++import qualified Algebra.Ring         as Ring+import qualified Algebra.Additive     as Additive++import Algebra.Ring (one, )+import Algebra.Additive (zero, negate,)++import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  )+import Data.Word (Word, Word8, Word16, Word32, Word64, )++import NumericPrelude.Base+import qualified Prelude as P+import Prelude (Integer, Float, Double, )+++{- |+This is the type class of a ring with a notion of an absolute value,+satisfying the laws++>                        a * b === b * a+>   a /= 0  =>  abs (signum a) === 1+>             abs a * signum a === a++Minimal definition: 'abs', 'signum'.++If the type is in the 'Ord' class+we expect 'abs' = 'absOrd' and 'signum' = 'signumOrd'+and we expect the following laws to hold:++>      a + (max b c) === max (a+b) (a+c)+>   negate (max b c) === min (negate b) (negate c)+>      a * (max b c) === max (a*b) (a*c) where a >= 0+>           absOrd a === max a (-a)++If the type is @ZeroTestable@, then it should hold++>  isZero a  ===  signum a == signum (negate a)++We do not require 'Ord' as superclass+since we also want to have "Number.Complex" as instance.+We also do not require @ZeroTestable@ as superclass,+because we like to have expressions of foreign languages+to be instances (cf. embedded domain specific language approach, EDSL),+as well as function types.++'abs' for complex numbers alone may have an inappropriate type,+because it does not reflect that the absolute value is a real number.+You might prefer 'Number.Complex.magnitude'.+This type class is intended for unifying algorithms+that work for both real and complex numbers.+Note the similarity to "Algebra.Units":+'abs' plays the role of @stdAssociate@+and 'signum' plays the role of @stdUnit@.++Actually, since 'abs' can be defined using 'max' and 'negate'+we could relax the superclasses to @Additive@ and 'Ord'+if his class would only contain 'signum'.+-}+class (Ring.C a) => C a where+    abs    :: a -> a+    signum :: a -> a+++absOrd :: (Additive.C a, Ord a) => a -> a+absOrd x = max x (negate x)++signumOrd :: (Ring.C a, Ord a) => a -> a+signumOrd x =+   case compare x zero of+      GT ->        one+      EQ ->        zero+      LT -> negate one+++instance C Integer where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Float   where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Double  where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum+++instance C Int     where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Int8    where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Int16   where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Int32   where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Int64   where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum+++instance C Word    where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Word8   where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Word16  where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Word32  where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum++instance C Word64  where+   {-# INLINE abs #-}+   {-# INLINE signum #-}+   abs = P.abs+   signum = P.signum+
src/Algebra/Additive.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Additive (     -- * Class     C,@@ -8,6 +8,8 @@      -- * Complex functions     sum, sum1,+    sumNestedAssociative,+    sumNestedCommutative,      -- * Instance definition helpers     elementAdd, elementSub, elementNeg,@@ -28,13 +30,21 @@ import qualified NumericPrelude.Elementwise as Elem import Control.Applicative (Applicative(pure, (<*>)), ) import Data.Tuple.HT (fst3, snd3, thd3, )+import qualified Data.List.Match as Match +import qualified Data.Complex as Complex98 import qualified Data.Ratio as Ratio98 import qualified Prelude as P-import Prelude(Int, Integer, Float, Double, fromInteger, )-import PreludeBase+import Prelude (Integer, Float, Double, fromInteger, )+import NumericPrelude.Base  +{- $setup+>>> import qualified Algebra.Additive as A+>>> import qualified Test.QuickCheck as QC+-}++ infixl 6  +, -  {- |@@ -54,6 +64,7 @@ -}  class C a where+    {-# MINIMAL zero, (+), ((-) | negate) #-}     -- | zero element of the vector space     zero     :: a     -- | add and subtract elements@@ -80,6 +91,10 @@ {- | Sum up all elements of a list. An empty list yields zero.++This function is inappropriate for number types like Peano.+Maybe we should make 'sum' a method of Additive.+This would also make 'lengthLeft' and 'lengthRight' superfluous. -} sum :: (C a) => [a] -> a sum = foldl (+) zero@@ -88,13 +103,64 @@ Sum up all elements of a non-empty list. This avoids including a zero which is useful for types where no universal zero is available.+ToDo: Should have NonEmpty type.++prop> \(QC.NonEmpty ns) -> A.sum ns == (A.sum1 ns :: Integer) -} sum1 :: (C a) => [a] -> a sum1 = foldl1 (+)  +{- |+Sum the operands in an order,+such that the dependencies are minimized.+Does this have a measurably effect on speed? +Requires associativity.++prop> \ns -> A.sum ns == (A.sumNestedAssociative ns :: Integer)+-}+sumNestedAssociative :: (C a) => [a] -> a+sumNestedAssociative [] = zero+sumNestedAssociative [x] = x+sumNestedAssociative xs = sumNestedAssociative (sum2 xs)+ {- |+Make sure that the last entries in the list+are equally often part of an addition.+Maybe this can reduce rounding errors.+The list that sum2 computes is a breadth-first-flattened binary tree.++Requires associativity and commutativity.++prop> \ns -> A.sum ns == (A.sumNestedCommutative ns :: Integer)+-}+sumNestedCommutative :: (C a) => [a] -> a+sumNestedCommutative [] = zero+sumNestedCommutative xs@(_:rs) =+   let ys = xs ++ Match.take rs (sum2 ys)+   in  last ys++_sumNestedCommutative :: (C a) => [a] -> a+_sumNestedCommutative [] = zero+_sumNestedCommutative xs@(_:rs) =+   let ys = xs ++ take (length rs) (sum2 ys)+   in  last ys++{-+[a,b,c, a+b,c+(a+b)]+[a,b,c,d, a+b,c+d,(a+b)+(c+d)]+[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)]+[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))]+-}++sum2 :: (C a) => [a] -> [a]+sum2 (x:y:rest) = (x+y) : sum2 rest+sum2 xs = xs++++{- | Instead of baking the add operation into the element function, we could use higher rank types and pass a generic @uncurry (+)@ to the run function.@@ -130,18 +196,21 @@ > addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b) > addPair = Elem.run2 $ Elem.with (,) <*>.+  fst <*>.+  snd -}+{-# INLINE (<*>.+) #-} (<*>.+) ::    (C x) =>    Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a (<*>.+) f acc =    f <*> elementAdd acc +{-# INLINE (<*>.-) #-} (<*>.-) ::    (C x) =>    Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a (<*>.-) f acc =    f <*> elementSub acc +{-# INLINE (<*>.-$) #-} (<*>.-$) ::    (C x) =>    Elem.T v (x -> a) -> (v -> x) -> Elem.T v a@@ -309,6 +378,13 @@    negate = Elem.run  $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3  +{- |+The 'Additive' instantiations treat lists+as prefixes of infinite lists with zero filled tail.+This interpretation is not always appropriate.+The end of a list may just mean: End of available data.+In this case the shortening 'zip' semantics would be more appropriate.+-} instance (C v) => C [v] where    zero   = []    negate = map negate@@ -351,7 +427,17 @@    {-# INLINE negate #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}-   zero                =  0+   zero                =  P.fromInteger 0+   (+)                 =  (P.+)+   (-)                 =  (P.-)+   negate              =  P.negate++instance (P.RealFloat a) => C (Complex98.Complex a) where+   {-# INLINE zero #-}+   {-# INLINE negate #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   zero                =  P.fromInteger 0    (+)                 =  (P.+)    (-)                 =  (P.-)    negate              =  P.negate
src/Algebra/AffineSpace.hs view
@@ -33,8 +33,8 @@  import Control.Applicative (Applicative(pure, (<*>)), ) -import NumericPrelude hiding (zero, )-import PreludeBase+import NumericPrelude.Numeric hiding (zero, )+import NumericPrelude.Base import Prelude ()  {- |
src/Algebra/Algebraic.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Algebraic where  import qualified Algebra.Field as Field--- import qualified Algebra.Units as Units import qualified Algebra.Laws as Laws import qualified Algebra.ToRational as ToRational import qualified Algebra.ToInteger  as ToInteger@@ -12,7 +11,7 @@ import Algebra.Ring ((*), (^), fromInteger) import Algebra.Additive((+)) -import PreludeBase+import NumericPrelude.Base import qualified Prelude as P  @@ -21,6 +20,7 @@ {- | Minimal implementation: 'root' or '(^\/)'. -}  class (Field.C a) => C a where+    {-# MINIMAL root | (^/) #-}     sqrt :: a -> a     sqrt = root 2     -- sqrt x  =  x ** (1/2)
src/Algebra/Differential.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Differential where  import qualified Algebra.Ring as Ring --- import NumericPrelude-import qualified Prelude  {- | 'differentiate' is a general differentation operation
src/Algebra/DimensionTerm.hs view
@@ -1,12 +1,4 @@ {- |-Copyright   :  (c) Henning Thielemann 2008-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable-- We already have the dynamically checked physical units provided by "Number.Physical" and the statically checked ones of the @dimensional@ package of Buckwalter,
src/Algebra/DivisibleSpace.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.DivisibleSpace where-import qualified Prelude+ import qualified Algebra.VectorSpace as VectorSpace  -- Is this right?
+ src/Algebra/EqualityDecision.hs view
@@ -0,0 +1,110 @@+{- |+Combination of @(==)@ and @if then else@+that can be instantiated for more types than @Eq@+or can be instantiated in a way+that allows more defined results (\"more total\" functions):++* Reader like types for representing a context+  like 'Number.ResidueClass.Reader'++* Expressions in an EDSL++* More generally every type based on an applicative functor++* Tuples and Vector types++* Positional and Peano numbers,+  a common prefix of two numbers can be emitted+  before the comparison is done.+  (This could also be done with an overloaded 'if',+   what we also do not have.)+-}+module Algebra.EqualityDecision where++import qualified NumericPrelude.Elementwise as Elem+import Control.Applicative (Applicative(pure, (<*>)), )+import Data.Tuple.HT (fst3, snd3, thd3, )+import Data.List (zipWith4, )+++{- |+For atomic types this could be a superclass of 'Eq'.+However for composed types like tuples, lists, functions+we do elementwise comparison+which is incompatible with the complete comparison performed by '(==)'.+-}+class C a where+   {- |+   It holds++   > (a ==? b) eq noteq  ==  if a==b then eq else noteq++   for atomic types where the right hand side can be defined.+   -}+   (==?) :: a -> a -> a -> a -> a++++{-# INLINE deflt #-}+deflt :: Eq a => a -> a -> a -> a -> a+deflt a b eq noteq =+   if a==b then eq else noteq++++instance C Int where+   {-# INLINE (==?) #-}+   (==?) = deflt++instance C Integer where+   {-# INLINE (==?) #-}+   (==?) = deflt++instance C Float where+   {-# INLINE (==?) #-}+   (==?) = deflt++instance C Double where+   {-# INLINE (==?) #-}+   (==?) = deflt++instance C Bool where+   {-# INLINE (==?) #-}+   (==?) = deflt++instance C Ordering where+   {-# INLINE (==?) #-}+   (==?) = deflt++++{-# INLINE element #-}+element ::+   (C x) =>+   (v -> x) -> Elem.T (v,v,v,v) x+element f =+   Elem.element (\(x,y,eq,noteq) -> (f x ==? f y) (f eq) (f noteq))++{-# INLINE (<*>.==?) #-}+(<*>.==?) ::+   (C x) =>+   Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a+(<*>.==?) f acc =+   f <*> element acc+++instance (C a, C b) => C (a,b) where+   {-# INLINE (==?) #-}+   (==?) = Elem.run4 $ pure (,) <*>.==?  fst <*>.==?  snd++instance (C a, C b, C c) => C (a,b,c) where+   {-# INLINE (==?) #-}+   (==?) = Elem.run4 $ pure (,,) <*>.==?  fst3 <*>.==?  snd3 <*>.==?  thd3++instance C a => C [a] where+   {-# INLINE (==?) #-}+   (==?) = zipWith4 (==?)++instance (C a) => C (b -> a) where+   {-# INLINE (==?) #-}+   (==?) x y eq noteq c  =  (x c ==? y c) (eq c) (noteq c)
src/Algebra/Field.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Field (     {- * Class -}     C,@@ -16,18 +16,18 @@  import Number.Ratio (T((:%)), Rational, (%), numerator, denominator, ) import qualified Number.Ratio as Ratio+import qualified Data.Complex as Complex98 import qualified Data.Ratio as Ratio98 import qualified Algebra.PrincipalIdealDomain as PID  import qualified Algebra.Ring         as Ring-import qualified Algebra.Additive     as Additive import qualified Algebra.ZeroTestable as ZeroTestable  import Algebra.Ring ((*), (^), one, fromInteger) import Algebra.Additive (zero, negate) import Algebra.ZeroTestable (isZero) -import PreludeBase+import NumericPrelude.Base import Prelude (Integer, Float, Double) import qualified Prelude as P import Test.QuickCheck ((==>), Property)@@ -68,6 +68,7 @@ -}  class (Ring.C a) => C a where+    {-# MINIMAL recip | (/) #-}     (/)           :: a -> a -> a     recip         :: a -> a     fromRational' :: Rational -> a@@ -98,8 +99,6 @@ {- * Instances for atomic types -}  {--ToDo:- fromRational must be implemented explicitly for Float and Double! It may be that numerator or denominator cannot be represented as Float due to size constraints, but the fraction can.@@ -110,20 +109,34 @@     {-# INLINE recip #-}     (/)    = (P./)     recip  = (P.recip)+    -- using Ratio98.:% would be more efficient but it is not exported.+    fromRational' x =+       P.fromRational (numerator x Ratio98.% denominator x)  instance C Double where     {-# INLINE (/) #-}     {-# INLINE recip #-}     (/)    = (P./)     recip  = (P.recip)+    fromRational' x =+       P.fromRational (numerator x Ratio98.% denominator x)  instance (PID.C a) => C (Ratio.T a) where     {-# INLINE (/) #-}     {-# INLINE recip #-}     {-# INLINE fromRational' #-} --    (/)                  =  Ratio.liftOrd (%)-    (x:%y) / (x':%y')    =  (x*y') % (y*x')+    x / y                =  x * recip y+{-+This is efficient and almost correct in the sense,+that all admissible cases yield a correct result.+However it will hide division by zero and thus may hide bugs.+Unfortunately 'x' might not be a standard associate,+thus (y:%x) may deviate from the canonical representation.+     recip (x:%y)         =  (y:%x)+-}+    recip = Ratio.recip     fromRational' (x:%y) =  fromInteger x % fromInteger y  @@ -139,6 +152,12 @@ -- legacy  instance (P.Integral a) => C (Ratio98.Ratio a) where+    {-# INLINE (/) #-}+    {-# INLINE recip #-}+    (/)    = (P./)+    recip  = (P.recip)++instance (P.RealFloat a) => C (Complex98.Complex a) where     {-# INLINE (/) #-}     {-# INLINE recip #-}     (/)    = (P./)
+ src/Algebra/FloatingPoint.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RebindableSyntax #-}+module Algebra.FloatingPoint where++import qualified Algebra.RealRing as RealRing+import NumericPrelude.Base++import qualified Prelude as P+import Prelude (Int, Integer, Float, Double, )+++{- |+Counterpart of 'Prelude.RealFloat' but with NumericPrelude superclass.+-}+class RealRing.C a => C a where+   radix :: a -> Integer+   digits :: a -> Int+   range :: a -> (Int, Int)+   decode :: a -> (Integer, Int)+   encode :: Integer -> Int -> a+   exponent :: a -> Int+   significand :: a -> a+   scale :: Int -> a -> a+   isNaN :: a -> Bool+   isInfinite :: a -> Bool+   isDenormalized :: a -> Bool+   isNegativeZero :: a -> Bool+   isIEEE :: a -> Bool++instance C Float where+   radix = P.floatRadix+   digits = P.floatDigits+   range = P.floatRange+   decode = P.decodeFloat+   encode = P.encodeFloat+   exponent = P.exponent+   significand = P.significand+   scale = P.scaleFloat+   isNaN = P.isNaN+   isInfinite = P.isInfinite+   isDenormalized = P.isDenormalized+   isNegativeZero = P.isNegativeZero+   isIEEE = P.isIEEE++instance C Double where+   radix = P.floatRadix+   digits = P.floatDigits+   range = P.floatRange+   decode = P.decodeFloat+   encode = P.encodeFloat+   exponent = P.exponent+   significand = P.significand+   scale = P.scaleFloat+   isNaN = P.isNaN+   isInfinite = P.isInfinite+   isDenormalized = P.isDenormalized+   isNegativeZero = P.isNegativeZero+   isIEEE = P.isIEEE
src/Algebra/GenerateRules.hs view
@@ -45,11 +45,11 @@ realFieldIndirect :: [String] realFieldIndirect =    do targetType <- tail machineIntegerTypes-      method <- "round" : "truncate" : "floor" : "ceiling" : []-      let methodPad = pad 8 method+      method <- "round" : "roundSimple" : "truncate" : "floor" : "ceiling" : []+      let methodPad = pad 11 method       let signature = functionSignature methodPad "a" targetType       return $ "     " ++-         pad 30 ("\"NP." ++ signature ++ "\"") +++         pad 33 ("\"NP." ++ signature ++ "\"") ++          methodPad ++ " = (" ++ functionSignature "P.fromIntegral" "Int" targetType ++ ") . "              ++ method ++ ";" @@ -78,7 +78,7 @@  main :: IO () main =-   putStrLn "module Algebra.RealField" >>+   putStrLn "module Algebra.RealRing" >>    mapM_ putStrLn realFieldIndirect >>    mapM_ putStrLn splitFractionIndirect >>
src/Algebra/IntegralDomain.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.IntegralDomain (     {- * Class -}     C,@@ -8,10 +8,14 @@     divModZero,     divides,     sameResidueClass,-    safeDiv,+    divChecked, safeDiv,     even,     odd, +    divUp,+    roundDown,+    roundUp,+     {- * Algorithms -}     decomposeVarPositional,     decomposeVarPositionalInf,@@ -28,12 +32,11 @@   ) where  import qualified Algebra.Ring         as Ring-import qualified Algebra.Additive     as Additive import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.Ring     ((*), fromInteger)-import Algebra.Additive (zero, (+), (-))-import Algebra.ZeroTestable (isZero)+import Algebra.Ring     ((*), fromInteger, )+import Algebra.Additive (zero, (+), (-), negate, )+import Algebra.ZeroTestable (isZero, )  import Data.Bool.HT (implies, ) import Data.List (mapAccumL, )@@ -43,12 +46,20 @@ import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  ) import Data.Word (Word, Word8, Word16, Word32, Word64, ) -import PreludeBase-import Prelude (Integer, Int)+import NumericPrelude.Base+import Prelude (Integer, ) import qualified Prelude as P  +{- $setup+>>> import Algebra.IntegralDomain (roundDown, roundUp, divUp)+>>> import qualified Test.QuickCheck as QC+>>> import NumericPrelude.Base as P+>>> import NumericPrelude.Numeric as NP+>>> import Prelude ()+-} + infixl 7 `div`, `mod`  @@ -91,7 +102,11 @@ Minimal definition: 'divMod' or ('div' and 'mod') -} class (Ring.C a) => C a where+    {-# MINIMAL divMod | (div, mod) #-}     div, mod :: a -> a -> a+    {- |+    prop> \n (QC.NonZero m) -> let (q,r) = divMod n m in n == (q*m+r :: Integer)+    -}     divMod :: a -> a -> (a,a)      {-# INLINE div #-}@@ -142,17 +157,20 @@ Returns the result of the division, if divisible. Otherwise undefined. -}-{-# INLINE safeDiv #-}-safeDiv :: (ZeroTestable.C a, C a) => a -> a -> a-safeDiv a b =+{-# INLINE divChecked #-}+divChecked, safeDiv :: (ZeroTestable.C a, C a) => a -> a -> a+divChecked a b =    let (q,r) = divMod a b    in  if isZero r          then q          else error "safeDiv: indivisible term" +{-# DEPRECATED safeDiv "use divChecked instead" #-}+safeDiv = divChecked+ {- | Allows division by zero.-If the divisor is zero, then the divident is returned as remainder.+If the divisor is zero, then the dividend is returned as remainder. -} {-# INLINE divModZero #-} divModZero :: (C a, ZeroTestable.C a) => a -> a -> (a,a)@@ -168,6 +186,46 @@ even, odd :: (C a, ZeroTestable.C a) => a -> Bool even n    =  divides 2 n odd       =  not . even+++{- |+@roundDown n m@ rounds @n@ down to the next multiple of @m@.+That is, @roundDown n m@ is the greatest multiple of @m@+that is at most @n@.+The parameter order is consistent with @div@ and friends,+but maybe not useful for partial application.++prop> \n (QC.NonZero m) -> div n m * m == (roundDown n m :: Integer)+-}+roundDown :: C a => a -> a -> a+roundDown n m = n - mod n m++{- |+@roundUp n m@ rounds @n@ up to the next multiple of @m@.+That is, @roundUp n m@ is the greatest multiple of @m@+that is at most @n@.++prop> \n (QC.NonZero m) -> divUp n m * m == (roundUp n m :: Integer)+prop> \n (QC.Positive m) -> let x = roundDown n m in  n-m < x && x <= (n :: Integer)+prop> \n (QC.NonZero m) -> - roundDown n m == (roundUp (-n) m :: Integer)+-}+roundUp :: C a => a -> a -> a+roundUp n m = n + mod (-n) m++{- |+@divUp n m@ is similar to @div@+but it rounds up the quotient,+such that @divUp n m * m = roundUp n m@.+-}+divUp :: C a => a -> a -> a+divUp n m = - div (-n) m++{-+What sign of the remainder is most appropriate?++divModUp :: C a => a -> a -> (a,a)+divModUp n m = mapFst negate $ divMod (-n) m+-}   {- * Instances for atomic types -}
src/Algebra/Lattice.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Lattice (       C(up, dn)     , max, min, abs@@ -13,8 +13,8 @@  import qualified Algebra.Laws as Laws -import NumericPrelude hiding (abs)-import PreludeBase hiding (max, min)+import NumericPrelude.Numeric hiding (abs)+import NumericPrelude.Base hiding (max, min) import qualified Prelude as P  infixl 5 `up`, `dn`
src/Algebra/Module.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |@@ -28,13 +28,16 @@ import qualified NumericPrelude.Elementwise as Elem import Control.Applicative (Applicative(pure, (<*>)), ) +import qualified Data.Complex as Complex98+import Data.Int (Int, Int8, Int16, Int32, Int64, )+ import Data.Function.HT (powerAssociative, ) import Data.List (map, zipWith, ) import Data.Tuple.HT (fst3, snd3, thd3, ) import Data.Tuple (fst, snd, ) -import Prelude((.), Eq, Bool, Int, Integer, Float, Double, ($), )--- import qualified Prelude as P+import qualified Prelude as P+import Prelude((.), Eq, Bool, Integer, Float, Double, ($), )   -- Is this right?@@ -60,6 +63,7 @@     (*>) :: a -> v -> v  +{-# INLINE (<*>.*>) #-} (<*>.*>) ::    (C a x) =>    Elem.T (a,v) (x -> c) -> (v -> x) -> Elem.T (a,v) c@@ -82,6 +86,22 @@    {-# INLINE (*>) #-}    (*>) = (*) +instance C Int8 Int8 where+   {-# INLINE (*>) #-}+   (*>) = (*)++instance C Int16 Int16 where+   {-# INLINE (*>) #-}+   (*>) = (*)++instance C Int32 Int32 where+   {-# INLINE (*>) #-}+   (*>) = (*)++instance C Int64 Int64 where+   {-# INLINE (*>) #-}+   (*>) = (*)+ instance C Integer Integer where    {-# INLINE (*>) #-}    (*>) = (*)@@ -117,13 +137,18 @@    (*>) s f = (*>) s . f  +instance (C a b, P.RealFloat b) => C a (Complex98.Complex b) where+   {-# INLINE (*>) #-}+   s *> (x Complex98.:+ y)  =  (s *> x) Complex98.:+ (s *> y)++ {-* Related functions -}  {-| Compute the linear combination of a list of vectors.  ToDo:-Should it use 'NumericPrelude.List.zipWithMatch' ?+Should it use 'NumericPrelude.List.Checked.zipWith' ? -} linearComb :: C a v => [a] -> [v] -> v linearComb c = sum . zipWith (*>) c
src/Algebra/ModuleBasis.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |@@ -15,14 +15,12 @@  import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.Module   as Module-import qualified Algebra.Additive as Additive import Algebra.Ring     (one, fromInteger) import Algebra.Additive ((+), zero)  import Data.List (map, length, (++))  import Prelude(Eq, (==), Bool, Int, Integer, Float, Double, asTypeOf, )--- import qualified Prelude as P  {- | It must hold:
src/Algebra/Monoid.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-} {- |-Copyright    :   (c) Henning Thielemann 2009, Mikael Johansson 2006+Copyright    :   (c) Henning Thielemann 2009-2010, Mikael Johansson 2006 Maintainer   :   numericprelude@henning-thielemann.de Stability    :   provisional Portability  :@@ -19,6 +18,11 @@  import Data.Monoid as Mn +import Data.Function ((.))+import Data.List (foldr, reverse, map)+import Prelude ()++ {- | We expect a monoid to adher to associativity and the identity behaving decently.@@ -27,36 +31,47 @@ class C a where   idt   :: a   (<*>) :: a -> a -> a+  cumulate :: [a] -> a+  cumulate = foldr (<*>) idt + instance C All where   idt = mempty   (<*>) = mappend+  cumulate = mconcat  instance C Any where   idt = mempty   (<*>) = mappend+  cumulate = mconcat  instance C a => C (Dual a) where   idt = Mn.Dual idt   (Mn.Dual x) <*> (Mn.Dual y) = Mn.Dual (y <*> x)+  cumulate = Mn.Dual . cumulate . reverse . map Mn.getDual  instance C (Endo a) where   idt = mempty   (<*>) = mappend+  cumulate = mconcat  instance C (First a) where   idt = mempty   (<*>) = mappend+  cumulate = mconcat  instance C (Last a) where   idt = mempty   (<*>) = mappend+  cumulate = mconcat   instance Ring.C a => C (Product a) where   idt = Mn.Product Ring.one   (Mn.Product x) <*> (Mn.Product y) = Mn.Product (x Ring.* y)+  cumulate = Mn.Product . Ring.product . map Mn.getProduct  instance Additive.C a => C (Sum a) where   idt = Mn.Sum Additive.zero   (Mn.Sum x) <*> (Mn.Sum y) = Mn.Sum (x Additive.+ y)+  cumulate = Mn.Sum . Additive.sum . map Mn.getSum
src/Algebra/NonNegative.hs view
@@ -1,43 +1,128 @@ {- |-Copyright   :  (c) Henning Thielemann 2007+Copyright   :  (c) Henning Thielemann 2007-2010  Maintainer  :  haskell@henning-thielemann.de Stability   :  stable Portability :  Haskell 98  A type class for non-negative numbers.-Prominent instances are 'Numeric.NonNegative.Wrapper.T' and peano numbers.+Prominent instances are 'Number.NonNegative.T' and 'Number.Peano.T' numbers. This class cannot do any checks, but it let you show to the user what arguments your function expects.+Thus you must define class instances with care. In fact many standard functions ('take', '(!!)', ...) should have this type class constraint.-Thus you must define class instances with care. -}-module Algebra.NonNegative (C(..)) where+module Algebra.NonNegative (+   C(..),+   splitDefault, +   (-|),+--   (-?),+   zero,+   add,+   sum,+   ) where+ import qualified Algebra.Additive as Additive-import qualified Algebra.Real     as Real -infixl 6 -|, -?+import qualified Algebra.Monoid as Monoid +import Algebra.Additive ((-), )++import Prelude hiding (sum, (-), abs, )+++infixl 6 -|  -- , -?++ {- | Instances of this class must ensure non-negative values. We cannot enforce this by types, but the type class constraint @NonNegative.C@ avoids accidental usage of types which allow for negative numbers.++The Monoid superclass contributes a zero and an addition. -}-class (Ord a, Additive.C a) => C a where+class (Ord a, Monoid.C a) => C a where    {- |-   @x -| y == max 0 (x-y)@+   @split x y == (m,(b,d))@ means that+   @b == (x<=y)@,+   @m == min x y@,+   @d == max x y - min x y@, that is @d == abs(x-y)@. -   The default implementation is not efficient,-   because it compares the values and then subtracts, again, if safe.-   @max 0 (x-y)@ is more elegant and efficient-   but not possible in the general case,-   since @x-y@ may already yield a negative number.+   We have chosen this function as base function,+   since it provides comparison and subtraction in one go,+   which is important for replacing common structures like++   > if x<=y+   >   then f(x-y)+   >   else g(y-x)++   that lead to a memory leak for peano numbers.+   We have choosen the simple check @x<=y@+   instead of a full-blown @compare@,+   since we want @Zero <= undefined@ for peano numbers.+   Because of undefined values 'split' is in general+   not commutative in the sense++   > let (m0,(b0,d0)) = split x y+   >     (m1,(b1,d1)) = split y x+   > in  m0==m1 && d0==d1++   The result values are in the order+   in which they are generated for Peano numbers.+   We have chosen the nested pair instead of a triple+   in order to prevent a memory leak+   that occurs if you only use @b@ and @d@ and ignore @m@.+   This is demonstrated by test cases+   Chunky.splitSpaceLeak3 and Chunky.splitSpaceLeak4.    -}-   (-|) :: a -> a -> a-   x -| y  =  if x >= y then x Additive.- y else Additive.zero+   split :: a -> a -> (a, (Bool, a))  -(-?) :: (Real.C a) => a -> a -> (Bool, a)-(-?) x y  =  (x >= y, Real.abs (x Additive.- y))+{- |+Default implementation for wrapped types of 'Ord' and 'Num' class.+-}+{-# INLINE splitDefault #-}+splitDefault ::+   (Ord b, Additive.C b) =>+   (a -> b) -> (b -> a) -> a -> a -> (a, (Bool, a))+splitDefault unpack pack px py =+   let x = unpack px+       y = unpack py+   in  if x<=y+         then (pack x, (True,  pack (y-x)))+         else (pack y, (False, pack (x-y)))+++zero :: C a => a+zero = Monoid.idt++-- like (+)+infixl 6 `add`++add :: C a => a -> a -> a+add = (Monoid.<*>)++sum :: C a => [a] -> a+sum = Monoid.cumulate+++{- |+@x -| y == max 0 (x-y)@++The default implementation is not efficient,+because it compares the values and then subtracts, again, if safe.+@max 0 (x-y)@ is more elegant and efficient+but not possible in the general case,+since @x-y@ may already yield a negative number.+-}+(-|) :: C a => a -> a -> a+x -| y  =+   let (b,d) = snd $ split y x+   in  if b then d else zero++{-+(-?) :: (RealRing.C a) => a -> a -> (Bool, a)+(-?) x y  =  snd $ split y x+-}
src/Algebra/NormedSpace/Euclidean.hs view
@@ -1,45 +1,69 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}  {- |-Copyright   :  (c) Henning Thielemann 2005-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes- Abstraction of normed vector spaces -}  module Algebra.NormedSpace.Euclidean where -import PreludeBase-import NumericPrelude (sqr, abs, (+), sum, Float, Double, Int, Integer, )+import NumericPrelude.Base+import NumericPrelude.Numeric (sqr, abs, zero, (+), sum, Float, Double, Int, Integer, )+import qualified Prelude as P  import qualified Number.Ratio as Ratio  import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.Real      as Real+import qualified Algebra.Absolute      as Absolute import qualified Algebra.Module    as Module +import qualified Data.Complex as Complex98+import qualified Data.Foldable as Fold++ {-|-A vector space equipped with an Euclidean or a Hilbert norm.+Helper class for 'C' that does not need an algebraic type @a@.  Minimal definition: 'normSqr' -}-class (Real.C a, Module.C a v) => Sqr a v where+class (Absolute.C a, Module.C a v) => Sqr a v where   {-| Square of the Euclidean norm of a vector.       This is sometimes easier to implement. -}   normSqr :: v -> a --  normSqr = sqr . norm +{- |+Default definition for 'normSqr' that is based on 'Fold.Foldable' class.+-}+{-# INLINE normSqrFoldable #-}+normSqrFoldable ::+   (Sqr a v, Fold.Foldable f) => f v -> a+normSqrFoldable =+   Fold.foldl (\a v -> a + normSqr v) zero++{- |+Default definition for 'normSqr' that is based on 'Fold.Foldable' class+and the argument vector has at least one component.+-}+{-# INLINE normSqrFoldable1 #-}+normSqrFoldable1 ::+   (Sqr a v, Fold.Foldable f, Functor f) => f v -> a+normSqrFoldable1 =+   Fold.foldl1 (+) . fmap normSqr+++{-|+A vector space equipped with an Euclidean or a Hilbert norm.++Minimal definition:+'norm'+-} class (Sqr a v) => C a v where   {-| Euclidean norm of a vector. -}-  norm    :: v -> a+  norm :: v -> a   defltNorm :: (Algebraic.C a, Sqr a v) => v -> a@@ -75,7 +99,7 @@  {-* Instances for composed types -} -instance (Real.C a, PID.C a) => Sqr (Ratio.T a) (Ratio.T a) where+instance (Absolute.C a, PID.C a) => Sqr (Ratio.T a) (Ratio.T a) where   normSqr = sqr  instance (Sqr a v0, Sqr a v1) => Sqr a (v0, v1) where@@ -94,4 +118,13 @@   normSqr = sum . map normSqr  instance (Algebraic.C a, Sqr a v) => C a [v] where+  norm    = defltNorm+++instance (Sqr a v, P.RealFloat v) => Sqr a (Complex98.Complex v) where+  normSqr (x0 Complex98.:+ x1) = normSqr x0 + normSqr x1++instance+  (Algebraic.C a, Sqr a v, P.RealFloat v) =>+    C a (Complex98.Complex v) where   norm    = defltNorm
src/Algebra/NormedSpace/Maximum.hs view
@@ -1,32 +1,50 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}  {- |-Copyright   :  (c) Henning Thielemann 2005-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes- Abstraction of normed vector spaces -}  module Algebra.NormedSpace.Maximum where -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric+import qualified Prelude as P  import qualified Number.Ratio as Ratio  import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.Real     as Real+import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealRing as RealRing import qualified Algebra.Module   as Module -class (Real.C a, Module.C a v) => C a v where+import qualified Data.Complex as Complex98+import qualified Data.Foldable as Fold+++class (RealRing.C a, Module.C a v) => C a v where   norm :: v -> a +{- |+Default definition for 'norm' that is based on 'Fold.Foldable' class.+-}+{-# INLINE normFoldable #-}+normFoldable ::+   (C a v, Fold.Foldable f) => f v -> a+normFoldable =+   Fold.foldl (\a v -> max a (norm v)) zero++{- |+Default definition for 'norm' that is based on 'Fold.Foldable' class+and the argument vector has at least one component.+-}+{-# INLINE normFoldable1 #-}+normFoldable1 ::+   (C a v, Fold.Foldable f, Functor f) => f v -> a+normFoldable1 =+   Fold.foldl1 max . fmap norm+ {- instance (Ring.C a, Algebra.Module a a) => C a a where   norm = abs@@ -44,7 +62,7 @@   norm = abs  -instance (Real.C a, PID.C a) => C (Ratio.T a) (Ratio.T a) where+instance (RealRing.C a, ToInteger.C a, PID.C a) => C (Ratio.T a) (Ratio.T a) where   norm = abs  instance (Ord a, C a v0, C a v1) => C a (v0, v1) where@@ -55,4 +73,12 @@  instance (Ord a, C a v) => C a [v] where   norm = foldl max zero . map norm---  norm = maximum . map norm+{-+Since the norm is always non-negative,+we can use zero as identity element.+  norm = maximum . map norm+-}+++instance (C a v, P.RealFloat v) => C a (Complex98.Complex v) where+  norm (x0 Complex98.:+ x1) = max (norm x0) (norm x1)
src/Algebra/NormedSpace/Sum.hs view
@@ -1,30 +1,28 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}  {- |-Copyright   :  (c) Henning Thielemann 2005-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes- Abstraction of normed vector spaces -}  module Algebra.NormedSpace.Sum where -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric+import qualified Prelude as P  import qualified Number.Ratio as Ratio  import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.Real     as Real+import qualified Algebra.Absolute     as Absolute import qualified Algebra.Additive as Additive import qualified Algebra.Module   as Module +import qualified Data.Complex as Complex98+import qualified Data.Foldable as Fold++ {-|   The super class is only needed to state the laws   @@@ -33,9 +31,29 @@      norm (u+v)       <=   norm u + norm v   @ -}-class (Real.C a, Module.C a v) => C a v where+class (Absolute.C a, Module.C a v) => C a v where   norm :: v -> a +{- |+Default definition for 'norm' that is based on 'Fold.Foldable' class.+-}+{-# INLINE normFoldable #-}+normFoldable ::+   (C a v, Fold.Foldable f) => f v -> a+normFoldable =+   Fold.foldl (\a v -> a + norm v) zero++{- |+Default definition for 'norm' that is based on 'Fold.Foldable' class+and the argument vector has at least one component.+-}+{-# INLINE normFoldable1 #-}+normFoldable1 ::+   (C a v, Fold.Foldable f, Functor f) => f v -> a+normFoldable1 =+   Fold.foldl1 (+) . fmap norm++ {- instance (Ring.C a, Algebra.Module a a) => C a a where   norm = abs@@ -54,7 +72,7 @@   norm = abs  -instance (Real.C a, PID.C a) => C (Ratio.T a) (Ratio.T a) where+instance (Absolute.C a, PID.C a) => C (Ratio.T a) (Ratio.T a) where   norm = abs  instance (Additive.C a, C a v0, C a v1) => C a (v0, v1) where@@ -65,3 +83,7 @@  instance (Additive.C a, C a v) => C a [v] where   norm = sum . map norm+++instance (C a v, P.RealFloat v) => C a (Complex98.Complex v) where+  norm (x0 Complex98.:+ x1) = norm x0 + norm x1
src/Algebra/OccasionallyScalar.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -27,17 +27,10 @@  module Algebra.OccasionallyScalar where --- import qualified Algebra.RealField    as RealField-import qualified Algebra.ZeroTestable as ZeroTestable-import qualified Algebra.Additive     as Additive-import qualified Number.Complex       as Complex- import Data.Maybe (fromMaybe, ) -import Number.Complex((+:))--import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   -- this is somehow similar to Normalized classes@@ -67,16 +60,8 @@    toMaybeScalar = Just    fromScalar    = id --- this instance should be defined in Number.Complex-instance (Show v, ZeroTestable.C v, Additive.C v, C a v) => C a (Complex.T v) where-   toScalar        = toScalarShow-   toMaybeScalar x = if isZero (Complex.imag x)-                       then toMaybeScalar (Complex.real x)-                       else Nothing-   fromScalar x    = fromScalar x +: zero- {- converting values automatically to integers is a bad idea-instance (Integral b, RealField.C a)+instance (Integral b, RealRing.C a)       => C b a where    toScalar        = toScalarDefault    toMaybeScalar x = mapMaybe round (toMaybeScalar x)
+ src/Algebra/OrderDecision.hs view
@@ -0,0 +1,244 @@+{- |+Combination of @compare@ and @if then else@+that can be instantiated for more types than @Ord@+or can be instantiated in a way+that allows more defined results (\"more total\" functions):++* Reader like types for representing a context+  like 'Number.ResidueClass.Reader'++* Expressions in an EDSL++* More generally every type based on an applicative functor++* Tuples and Vector types++* Positional and Peano numbers,+  a common prefix of two numbers can be emitted+  before the comparison is done.+  (This could also be done with an overloaded 'if',+   what we also do not have.)+-}+module Algebra.OrderDecision where++import qualified Algebra.EqualityDecision as Equality+import Algebra.EqualityDecision ((==?), )++import qualified NumericPrelude.Elementwise as Elem+import Control.Applicative (Applicative(pure, (<*>)), )+import Data.Tuple.HT (fst3, snd3, thd3, )+import Data.List (zipWith4, zipWith5, )++import Prelude hiding (compare, min, max, minimum, maximum, )+import qualified Prelude as P++++{- |+For atomic types this could be a superclass of 'Ord'.+However for composed types like tuples, lists, functions+we do elementwise comparison+which is incompatible with the complete comparison performed by 'P.compare'.+-}+class Equality.C a => C a where+   {- |+   It holds++   > (compare a b) lt eq gt  ==+   >    case Prelude.compare a b of+   >       LT -> lt+   >       EQ -> eq+   >       GT -> gt++   for atomic types where the right hand side can be defined.++   Minimal complete definition:+   'compare' or '(<=?)'.+   -}+   compare :: a -> a -> a -> a -> a -> a+   compare x y lt eq gt =+      (x ==? y) eq ((x <=? y) lt gt)++   {-# INLINE (<=?) #-}+   (<=?) :: a -> a -> a -> a -> a+   (<=?) x y le gt =+      compare x y le le gt++   {-# INLINE (>=?) #-}+   (>=?) :: a -> a -> a -> a -> a+   (>=?) = flip (<=?)++   (<?) :: a -> a -> a -> a -> a+   (<?) x y = flip (x >=? y)++   {-# INLINE (>?) #-}+   (>?) :: a -> a -> a -> a -> a+   (>?) = flip (<?)++{-+   (<?) :: a -> a -> a -> a -> a+   (<?) x y lt ge =+      compare x y lt ge ge++   (>?) :: a -> a -> a -> a -> a+   (>?) x y gt le =+      compare x y le le gt++   (<=?) :: a -> a -> a -> a -> a+   (<=?) x y le gt =+      compare x y le le gt++   (>=?) :: a -> a -> a -> a -> a+   (>=?) x y ge lt =+      compare x y lt ge ge+-}+++max :: C a => a -> a -> a+max x y = (x>?y) x y++min :: C a => a -> a -> a+min x y = (x<?y) x y++maximum :: C a => a -> [a] -> a+maximum x xs = foldl max x xs++minimum :: C a => a -> [a] -> a+minimum x xs = foldl min x xs++++{-# INLINE compareOrd #-}+compareOrd :: Ord a => a -> a -> a -> a -> a -> a+compareOrd a b lt eq gt =+   case P.compare a b of+      LT -> lt+      EQ -> eq+      GT -> gt++instance C Int where+   {-# INLINE compare #-}+   compare = compareOrd++instance C Integer where+   {-# INLINE compare #-}+   compare = compareOrd++instance C Float where+   {-# INLINE compare #-}+   compare = compareOrd++instance C Double where+   {-# INLINE compare #-}+   compare = compareOrd++instance C Bool where+   {-# INLINE compare #-}+   compare = compareOrd++instance C Ordering where+   {-# INLINE compare #-}+   compare = compareOrd++++{-# INLINE elementCompare #-}+elementCompare ::+   (C x) =>+   (v -> x) -> Elem.T (v,v,v,v,v) x+elementCompare f =+   Elem.element (\(x,y,lt,eq,gt) ->+      compare (f x) (f y) (f lt) (f eq) (f gt))++{-# INLINE (<*>.<=>?) #-}+(<*>.<=>?) ::+   (C x) =>+   Elem.T (v,v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v,v) a+(<*>.<=>?) f acc =+   f <*> elementCompare acc+++{-# INLINE element #-}+element ::+   (C x) =>+   (x -> x -> x -> x -> x) ->+   (v -> x) -> Elem.T (v,v,v,v) x+element cmp f =+   Elem.element (\(x,y,true,false) -> cmp (f x) (f y) (f true) (f false))++{-# INLINE (<*>.<=?) #-}+(<*>.<=?) ::+   (C x) =>+   Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a+(<*>.<=?) f acc =+   f <*> element (<=?) acc++{-# INLINE (<*>.>=?) #-}+(<*>.>=?) ::+   (C x) =>+   Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a+(<*>.>=?) f acc =+   f <*> element (>=?) acc++{-# INLINE (<*>.<?) #-}+(<*>.<?) ::+   (C x) =>+   Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a+(<*>.<?) f acc =+   f <*> element (<?) acc++{-# INLINE (<*>.>?) #-}+(<*>.>?) ::+   (C x) =>+   Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a+(<*>.>?) f acc =+   f <*> element (>?) acc+++instance (C a, C b) => C (a,b) where+   {-# INLINE compare #-}+   compare = Elem.run5 $ pure (,) <*>.<=>? fst <*>.<=>? snd+   {-# INLINE (<=?) #-}+   (<=?)   = Elem.run4 $ pure (,) <*>.<=?  fst <*>.<=?  snd+   {-# INLINE (>=?) #-}+   (>=?)   = Elem.run4 $ pure (,) <*>.>=?  fst <*>.>=?  snd+   {-# INLINE (<?) #-}+   (<?)    = Elem.run4 $ pure (,) <*>.<?   fst <*>.<?   snd+   {-# INLINE (>?) #-}+   (>?)    = Elem.run4 $ pure (,) <*>.>?   fst <*>.>?   snd++instance (C a, C b, C c) => C (a,b,c) where+   {-# INLINE compare #-}+   compare = Elem.run5 $ pure (,,) <*>.<=>? fst3 <*>.<=>? snd3 <*>.<=>? thd3+   {-# INLINE (<=?) #-}+   (<=?)   = Elem.run4 $ pure (,,) <*>.<=?  fst3 <*>.<=?  snd3 <*>.<=?  thd3+   {-# INLINE (>=?) #-}+   (>=?)   = Elem.run4 $ pure (,,) <*>.>=?  fst3 <*>.>=?  snd3 <*>.>=?  thd3+   {-# INLINE (<?) #-}+   (<?)    = Elem.run4 $ pure (,,) <*>.<?   fst3 <*>.<?   snd3 <*>.<?   thd3+   {-# INLINE (>?) #-}+   (>?)    = Elem.run4 $ pure (,,) <*>.>?   fst3 <*>.>?   snd3 <*>.>?   thd3++instance C a => C [a] where+   {-# INLINE compare #-}+   compare = zipWith5 compare+   {-# INLINE (<=?) #-}+   (<=?) = zipWith4 (<=?)+   {-# INLINE (>=?) #-}+   (>=?) = zipWith4 (>=?)+   {-# INLINE (<?) #-}+   (<?)  = zipWith4 (<?)+   {-# INLINE (>?) #-}+   (>?)  = zipWith4 (>?)++instance (C a) => C (b -> a) where+   {-# INLINE compare #-}+   compare x y lt eq gt c  =  compare (x c) (y c) (lt c) (eq c) (gt c)+   {-# INLINE (<=?) #-}+   (<=?) x y true false c  =  (x c <=? y c) (true c) (false c)+   {-# INLINE (>=?) #-}+   (>=?) x y true false c  =  (x c >=? y c) (true c) (false c)+   {-# INLINE (<?) #-}+   (<?)  x y true false c  =  (x c <?  y c) (true c) (false c)+   {-# INLINE (>?) #-}+   (>?)  x y true false c  =  (x c >?  y c) (true c) (false c)
src/Algebra/PrincipalIdealDomain.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.PrincipalIdealDomain (     {- * Class -}     C,     extendedGCD,     gcd,     lcm,+    coprime,      {- * Standard implementations for instances -}     euclid,@@ -38,32 +39,41 @@  import qualified Algebra.Units          as Units import qualified Algebra.IntegralDomain as Integral-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable  import qualified Algebra.Laws as Laws  import Algebra.Units          (stdAssociate, stdUnitInv)-import Algebra.IntegralDomain (mod, safeDiv, divMod, divides, divModZero)+import Algebra.IntegralDomain (mod, divChecked, divMod, divides, divModZero) import Algebra.Ring           (one, (*), scalarProduct) import Algebra.Additive       (zero, (+), (-)) import Algebra.ZeroTestable   (isZero) -import Data.Maybe.HT (toMaybe)+import Data.Maybe.HT (toMaybe, )  import Control.Monad (foldM, liftM) import Data.List (mapAccumL, mapAccumR, unfoldr)  import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  ) -import PreludeBase-import Prelude (Integer, Int)-import qualified Prelude as P+import NumericPrelude.Base+import Prelude (Integer, ) import Test.QuickCheck ((==>), Property)  +{- $setup+>>> import qualified Algebra.PrincipalIdealDomain as PID+>>> import Test.NumericPrelude.Utility ((/\))+>>> import qualified Test.QuickCheck as QC+>>>+>>> genResidueClass :: QC.Gen (Integer,Integer)+>>> genResidueClass = do+>>>    m <- fmap QC.getNonZero $ QC.arbitrary+>>>    a <- QC.choose (min 0 $ 1+m, max 0 $ m-1)+>>>    return (m,a)+-} + {- | A principal ideal domain is a ring in which every ideal (the set of multiples of some generating set of elements)@@ -119,11 +129,29 @@     Least common multiple     -}     lcm         :: a -> a -> a-    lcm x y     = safeDiv x (gcd x y) * y  -- avoid big temporary results-    -- lcm x y     = safeDiv (x * y) (gcd x y)+    lcm x y     =+       if isZero x+         then x -- avoid computing undefined (gcd 0 0)+         else divChecked x (gcd x y) * y  -- avoid big temporary results+    -- lcm x y     = divChecked (x * y) (gcd x y)  +{-+These do only work if zero and one are really identity elements. +gcdMulti :: (C a) => [a] -> a+gcdMulti = foldl gcd zero++lcmMulti :: (C a) => [a] -> a+lcmMulti = foldl lcm one+-}++coprime :: (C a) => a -> a -> Bool+coprime x y =+   Units.isUnit (gcd x y)+++ {- We could implement a helper function, which exposes the temporary results.@@ -195,8 +223,8 @@    if isZero g      then (zero,zero)      else-       let xl = safeDiv x g-           yl = safeDiv y g+       let xl = divChecked x g+           yl = divChecked y g            (d,aRed) = divModZero a yl        in  (aRed, b + d*xl) @@ -217,9 +245,9 @@  {- | Not efficient because it requires duplicate computations of GCDs.-However GCDs of neighbouring list elements were not computed before.+However GCDs of adjacent list elements were not computed before. It is also quite arbitrary,-because only neighbouring elements are used for balancing.+because only adjacent elements are used for balancing. There are certainly more sophisticated solutions. -} diophantineMultiMin :: C a => a -> [a] -> Maybe [a]@@ -246,10 +274,6 @@                   (d',cLast') = minimizeFirstOperand (gcd d cLast) d cLast               in  as' ++ [d',cLast']            _ -> as---- cf. MathObj.Permutation.Table-swap :: (a,b) -> (b,a)-swap (x,y) = (y,x) -}  {- |@@ -265,10 +289,21 @@ -}  {- |-For @Just (b,n) = chineseRemainder [(a0,m0), (a1,m1), ..., (an,mn)]@-and all @x@ with @x = b mod n@ the congruences-@x=a0 mod m0, x=a1 mod m1, ..., x=an mod mn@+For @Just (n,b) = chineseRemainderMulti [(m0,a0), (m1,a1), ..., (mk,ak)]@+and all @x@ with @x = b mod n@, the congruences+@x=a0 mod m0, x=a1 mod m1, ..., x=ak mod mk@ are fulfilled.+Also, @n@ is the least common multiplier of all @mi@.++>>> PID.chineseRemainderMulti [(100,21), (10000,2021::Integer)]+Just (10000,2021)+>>> PID.chineseRemainderMulti [(97,90),(99,10),(100,0::Integer)]+Just (960300,100000)+>>> PID.chineseRemainderMulti [(95,30),(97,27),(98,8),(99,1::Integer)]+Just (89403930,1000000)++prop> QC.listOf genResidueClass /\ \xs -> case PID.chineseRemainderMulti xs of Nothing -> True; Just (n,b) -> abs n == abs (foldl lcm 1 (map fst xs)) && map snd xs == map (mod b . fst) xs+prop> \(QC.NonEmpty ms) b -> let xs = map (\(QC.NonZero m) -> (m, mod b m)) ms in case PID.chineseRemainderMulti xs of Nothing -> False; Just (n,c) -> abs n == abs (foldl lcm 1 (map QC.getNonZero ms)) && mod b n == (c::Integer) -} chineseRemainderMulti :: C a => [(a,a)] -> Maybe (a,a) chineseRemainderMulti congs =@@ -282,8 +317,9 @@   {--There exists a GCD variant,-that is specialised for integers and does not need a division.+There is the binary GCD algorithm,+that is specialised for integers in binary representation.+It does not need a division. However, since we have an optimized division, the standard implementation is probably faster.
− src/Algebra/Real.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Algebra.Real (-   C(abs, signum),-   ) where--import qualified Algebra.Ring         as Ring-import qualified Algebra.Additive     as Additive-import qualified Algebra.ZeroTestable as ZeroTestable--import Algebra.Ring (one, ) -- fromInteger-import Algebra.Additive (zero, negate,)--import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  )-import Data.Word (Word, Word8, Word16, Word32, Word64, )--import PreludeBase-import qualified Prelude as P-import Prelude(Int,Integer,Float,Double)---{- |-This is the type class of an ordered ring, satisfying the laws-->              a * b === b * a->      a + (max b c) === max (a+b) (a+c)->   negate (max b c) === min (negate b) (negate c)->      a * (max b c) === max (a*b) (a*c) where a >= 0--Note that abs is in a rather different place than it is in the Haskell-98 Prelude.  In particular,-->   abs :: Complex -> Complex--is not defined.  To me, this seems to have the wrong type anyway;-Complex.magnitude has the correct type.--}-class (Ring.C a, ZeroTestable.C a, Ord a) => C a where-    abs    :: a -> a-    signum :: a -> a--      -- Minimal definition: nothing-    abs x    = max x (negate x)-    signum x = case compare x zero of-                 GT ->        one-                 EQ ->        zero-                 LT -> negate one---instance C Integer where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Float   where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Double  where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum---instance C Int     where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Int8    where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Int16   where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Int32   where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Int64   where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum---instance C Word    where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Word8   where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Word16  where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Word32  where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum--instance C Word64  where-   {-# INLINE abs #-}-   {-# INLINE signum #-}-   abs = P.abs-   signum = P.signum-
src/Algebra/RealField.hs view
@@ -1,459 +1,24 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fglasgow-exts #-}--- -fglasgow-exts for RULES-module Algebra.RealField where+{-# LANGUAGE RebindableSyntax #-}+module Algebra.RealField (+   C,+   ) where -import qualified Algebra.Field              as Field+import qualified Algebra.Field as Field+import qualified Algebra.RealRing as RealRing import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.Real           as Real-import qualified Algebra.Ring           as Ring-import qualified Algebra.ToRational     as ToRational-import qualified Algebra.ToInteger      as ToInteger---import Algebra.Field          ((/), fromRational, )-import Algebra.RealIntegral   (quotRem, )-import Algebra.IntegralDomain (divMod, even, )-import Algebra.Ring           ((*), fromInteger, one, )-import Algebra.Additive       ((+), (-), negate, zero, )-import Algebra.ZeroTestable   (isZero, )-import Algebra.ToInteger      (fromIntegral, )+import qualified Algebra.ToInteger as ToInteger  import qualified Number.Ratio as Ratio-import Number.Ratio (T((:%)), Rational) -import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  )-import Data.Word (Word, Word8, Word16, Word32, Word64, )--import qualified GHC.Float as GHC-import Data.List as List-import Data.Tuple.HT (mapFst, mapPair, )-import Prelude(Int, Integer, Float, Double)-import qualified Prelude as P-import PreludeBase-+import Prelude (Float, Double, )  {- |-Minimal complete definition:-     'splitFraction' or 'floor'--There are probably more laws, but some laws are--> (fromInteger.fst.splitFraction) a + (snd.splitFraction) a === a->    ceiling (toRational x) === ceiling x :: Integer->   truncate (toRational x) === truncate x :: Integer->      floor (toRational x) === floor x :: Integer--If there wouldn't be @Real.C a@ and @ToInteger.C b@ constraints,-we could also use this class for splitting ratios of polynomials.--As an aside, let me note the similarities-between @splitFraction x@ and @x divMod 1@ (if that were defined).-In particular, it might make sense to unify the rounding modes somehow.--IEEEFloat-specific calls are removed here (cf. 'Prelude.RealFloat')-so probably nobody will actually use this default definition.--Henning:-New function 'fraction' doesn't return the integer part of the number.-This also removes a type ambiguity if the integer part is not needed.--The new methods 'fraction' and 'splitFraction'-differ from 'Prelude.properFraction' semantics.-They always round to 'floor'.-This means that the fraction is always non-negative and-is always smaller than 1.-This is more useful in practice and-can be generalised to more than real numbers.-Since every 'Number.Ratio.T' denominator type supports 'Algebra.IntegralDomain.divMod',-every 'Number.Ratio.T' can provide 'fraction' and 'splitFraction',-e.g. fractions of polynomials.-However the ''integral'' part would not be of type class 'ToInteger.C'.--Can there be a separate class for-'fraction', 'splitFraction', 'floor' and 'ceiling'-since they do not need reals and their ordering?--Note:-All of these methods can be defined-exclusively with functions from Ord and Ring.-We could write a power-of-two-algorithm-like the one for finding the number of digits of an Integer-in FixedPoint-fractions module.-This would even be reasonably efficient.-I think the module should be renamed to RealRing,-and the superclass constraint should be lifted from Field to Ring.--We might also add a round method,-that rounds 0.5 always up or always down.-This is much more efficient in inner loops-and is acceptable or even preferable for many applications.--The ToInteger constraint can be lifted to Ring.+This is a convenient class for common types+that both form a field and have a notion of ordering by magnitude. -}--class (Real.C a, Field.C a) => C a where-    splitFraction    :: (ToInteger.C b) => a -> (b,a)-    fraction         ::                    a -> a-    ceiling, floor   :: (ToInteger.C b) => a -> b-    truncate, round  :: (ToInteger.C b) => a -> b---    splitFraction x   =  (floor x, fraction x)--    fraction x   =  x - fromInteger (floor x)--    floor x      =  fromInteger (fst (splitFraction x))--    ceiling x    =  - floor (-x)----    truncate x   =  signum x * floor (abs x)-    truncate x   =  if x>=0-                      then floor x-                      else ceiling x--    round x      =  let (n,r) = splitFraction x-                    in  case compare r (1/2) of-                           LT -> n-                           EQ -> if even n then n else n+1-                           GT -> n+1---instance (ToInteger.C a, PID.C a) => C (Ratio.T a) where-    splitFraction (x:%y) = (fromIntegral q, r:%y)-                               where (q,r) = divMod x y+class (RealRing.C a, Field.C a) => C a where  instance C Float where-    {-# INLINE splitFraction #-}-    {-# INLINE fraction #-}-    {-# INLINE floor #-}-    {-# INLINE ceiling #-}-    {-# INLINE round #-}-    {-# INLINE truncate #-}-    splitFraction = fastSplitFraction GHC.float2Int GHC.int2Float-    fraction      = fastFraction (GHC.int2Float . GHC.float2Int)-    floor         = fromInteger . P.floor-    ceiling       = fromInteger . P.ceiling-    round         = fromInteger . P.round-    truncate      = fromInteger . P.truncate- instance C Double where-    {-# INLINE splitFraction #-}-    {-# INLINE fraction #-}-    {-# INLINE floor #-}-    {-# INLINE ceiling #-}-    {-# INLINE round #-}-    {-# INLINE truncate #-}-    splitFraction = fastSplitFraction GHC.double2Int GHC.int2Double-    fraction      = fastFraction (GHC.int2Double . GHC.double2Int)-    floor         = fromInteger . P.floor-    ceiling       = fromInteger . P.ceiling-    round         = fromInteger . P.round-    truncate      = fromInteger . P.truncate --{-# INLINE fastSplitFraction #-}-fastSplitFraction :: (P.RealFrac a, Real.C a, ToInteger.C b) =>-   (a -> Int) -> (Int -> a) -> a -> (b,a)-fastSplitFraction trunc toFloat x =-   fixSplitFraction $-   if toFloat minBound <= x && x <= toFloat maxBound-     then case trunc x of n -> (fromIntegral n, x - toFloat n)-     else case P.properFraction x of (n,f) -> (fromInteger n, f)--{-# INLINE fixSplitFraction #-}-fixSplitFraction :: (Ring.C a, Ring.C b, Ord a) => (b,a) -> (b,a)-fixSplitFraction (n,f) =-   --  if x>=0 || f==0-   if f>=0-     then (n,   f)-     else (n-1, f+1)--{-# INLINE fastFraction #-}-fastFraction :: (P.RealFrac a, Real.C a) => (a -> a) -> a -> a-fastFraction trunc x =-   fixFraction $-   if fromIntegral (minBound :: Int) <= x && x <= fromIntegral (maxBound :: Int)-     then x - trunc x-     else preludeFraction x--{-# INLINE preludeFraction #-}-preludeFraction :: (P.RealFrac a, Ring.C a) => a -> a-preludeFraction x =-   let second :: (Integer, a) -> a-       second = snd-   in  second (P.properFraction x)--{-# INLINE fixFraction #-}-fixFraction :: (Ring.C a, Ord a) => a -> a-fixFraction y =-   if y>=0 then y else y+1--{--mapM_ (\n -> let x = fromInteger n / 10 in print (x, floorInt GHC.double2Int GHC.int2Double x)) [-20,-19..20]--}--{-# INLINE splitFractionInt #-}-splitFractionInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> (Int, a)-splitFractionInt trunc toFloat x =-   let n = trunc x-   in  fixSplitFraction (n, x - toFloat n)--{-# INLINE floorInt #-}-floorInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int-floorInt trunc toFloat x =-   let n = trunc x-   in  if x >= toFloat n-         then n-         else pred n--{-# INLINE ceilingInt #-}-ceilingInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int-ceilingInt trunc toFloat x =-   let n = trunc x-   in  if x <= toFloat n-         then n-         else succ n--{-# INLINE roundInt #-}-roundInt :: (Field.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int-roundInt trunc toFloat x =-   let half = 0.5 -- P.fromRational-       halfUp = x+half-       n = floorInt trunc toFloat halfUp-   in  if toFloat n == halfUp  &&  P.odd n-         then pred n-         else n---{- RULES maybe used, when Prelude implementations become more efficient-     "NP.round    :: Float -> Int"    round    = P.round    :: Float -> Int;-     "NP.truncate :: Float -> Int"    truncate = P.truncate :: Float -> Int;-     "NP.floor    :: Float -> Int"    floor    = P.floor    :: Float -> Int;-     "NP.ceiling  :: Float -> Int"    ceiling  = P.ceiling  :: Float -> Int;-     "NP.round    :: Double -> Int"   round    = P.round    :: Double -> Int;-     "NP.truncate :: Double -> Int"   truncate = P.truncate :: Double -> Int;-     "NP.floor    :: Double -> Int"   floor    = P.floor    :: Double -> Int;-     "NP.ceiling  :: Double -> Int"   ceiling  = P.ceiling  :: Double -> Int;-  -}---- these rules will also be needed for Int16 et.al.-{-# RULES-     "NP.round    :: Float -> Int"    round    = roundInt    GHC.float2Int  GHC.int2Float;-     "NP.truncate :: Float -> Int"    truncate =             GHC.float2Int               ;-     "NP.floor    :: Float -> Int"    floor    = floorInt    GHC.float2Int  GHC.int2Float;-     "NP.ceiling  :: Float -> Int"    ceiling  = ceilingInt  GHC.float2Int  GHC.int2Float;-     "NP.round    :: Double -> Int"   round    = roundInt    GHC.double2Int GHC.int2Double;-     "NP.truncate :: Double -> Int"   truncate =             GHC.double2Int               ;-     "NP.floor    :: Double -> Int"   floor    = floorInt    GHC.double2Int GHC.int2Double;-     "NP.ceiling  :: Double -> Int"   ceiling  = ceilingInt  GHC.double2Int GHC.int2Double;--     "NP.splitFraction :: Float ->  (Int, Float)"  splitFraction = splitFractionInt GHC.float2Int GHC.int2Float;-     "NP.splitFraction :: Double -> (Int, Double)" splitFraction = splitFractionInt GHC.double2Int GHC.int2Double;-  #-}---- generated by GenerateRules.hs-{-# RULES-     "NP.round    :: a -> Int8"    round    = (P.fromIntegral :: Int -> Int8) . round;-     "NP.truncate :: a -> Int8"    truncate = (P.fromIntegral :: Int -> Int8) . truncate;-     "NP.floor    :: a -> Int8"    floor    = (P.fromIntegral :: Int -> Int8) . floor;-     "NP.ceiling  :: a -> Int8"    ceiling  = (P.fromIntegral :: Int -> Int8) . ceiling;-     "NP.round    :: a -> Int16"   round    = (P.fromIntegral :: Int -> Int16) . round;-     "NP.truncate :: a -> Int16"   truncate = (P.fromIntegral :: Int -> Int16) . truncate;-     "NP.floor    :: a -> Int16"   floor    = (P.fromIntegral :: Int -> Int16) . floor;-     "NP.ceiling  :: a -> Int16"   ceiling  = (P.fromIntegral :: Int -> Int16) . ceiling;-     "NP.round    :: a -> Int32"   round    = (P.fromIntegral :: Int -> Int32) . round;-     "NP.truncate :: a -> Int32"   truncate = (P.fromIntegral :: Int -> Int32) . truncate;-     "NP.floor    :: a -> Int32"   floor    = (P.fromIntegral :: Int -> Int32) . floor;-     "NP.ceiling  :: a -> Int32"   ceiling  = (P.fromIntegral :: Int -> Int32) . ceiling;-     "NP.round    :: a -> Int64"   round    = (P.fromIntegral :: Int -> Int64) . round;-     "NP.truncate :: a -> Int64"   truncate = (P.fromIntegral :: Int -> Int64) . truncate;-     "NP.floor    :: a -> Int64"   floor    = (P.fromIntegral :: Int -> Int64) . floor;-     "NP.ceiling  :: a -> Int64"   ceiling  = (P.fromIntegral :: Int -> Int64) . ceiling;-     "NP.round    :: a -> Word"    round    = (P.fromIntegral :: Int -> Word) . round;-     "NP.truncate :: a -> Word"    truncate = (P.fromIntegral :: Int -> Word) . truncate;-     "NP.floor    :: a -> Word"    floor    = (P.fromIntegral :: Int -> Word) . floor;-     "NP.ceiling  :: a -> Word"    ceiling  = (P.fromIntegral :: Int -> Word) . ceiling;-     "NP.round    :: a -> Word8"   round    = (P.fromIntegral :: Int -> Word8) . round;-     "NP.truncate :: a -> Word8"   truncate = (P.fromIntegral :: Int -> Word8) . truncate;-     "NP.floor    :: a -> Word8"   floor    = (P.fromIntegral :: Int -> Word8) . floor;-     "NP.ceiling  :: a -> Word8"   ceiling  = (P.fromIntegral :: Int -> Word8) . ceiling;-     "NP.round    :: a -> Word16"  round    = (P.fromIntegral :: Int -> Word16) . round;-     "NP.truncate :: a -> Word16"  truncate = (P.fromIntegral :: Int -> Word16) . truncate;-     "NP.floor    :: a -> Word16"  floor    = (P.fromIntegral :: Int -> Word16) . floor;-     "NP.ceiling  :: a -> Word16"  ceiling  = (P.fromIntegral :: Int -> Word16) . ceiling;-     "NP.round    :: a -> Word32"  round    = (P.fromIntegral :: Int -> Word32) . round;-     "NP.truncate :: a -> Word32"  truncate = (P.fromIntegral :: Int -> Word32) . truncate;-     "NP.floor    :: a -> Word32"  floor    = (P.fromIntegral :: Int -> Word32) . floor;-     "NP.ceiling  :: a -> Word32"  ceiling  = (P.fromIntegral :: Int -> Word32) . ceiling;-     "NP.round    :: a -> Word64"  round    = (P.fromIntegral :: Int -> Word64) . round;-     "NP.truncate :: a -> Word64"  truncate = (P.fromIntegral :: Int -> Word64) . truncate;-     "NP.floor    :: a -> Word64"  floor    = (P.fromIntegral :: Int -> Word64) . floor;-     "NP.ceiling  :: a -> Word64"  ceiling  = (P.fromIntegral :: Int -> Word64) . ceiling;--     "NP.splitFraction :: a -> (Int8,a)"     splitFraction = mapFst (P.fromIntegral :: Int -> Int8) . splitFraction;-     "NP.splitFraction :: a -> (Int16,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Int16) . splitFraction;-     "NP.splitFraction :: a -> (Int32,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Int32) . splitFraction;-     "NP.splitFraction :: a -> (Int64,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Int64) . splitFraction;-     "NP.splitFraction :: a -> (Word,a)"     splitFraction = mapFst (P.fromIntegral :: Int -> Word) . splitFraction;-     "NP.splitFraction :: a -> (Word8,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Word8) . splitFraction;-     "NP.splitFraction :: a -> (Word16,a)"   splitFraction = mapFst (P.fromIntegral :: Int -> Word16) . splitFraction;-     "NP.splitFraction :: a -> (Word32,a)"   splitFraction = mapFst (P.fromIntegral :: Int -> Word32) . splitFraction;-     "NP.splitFraction :: a -> (Word64,a)"   splitFraction = mapFst (P.fromIntegral :: Int -> Word64) . splitFraction;-  #-}---{- | TODO: Should be moved to a continued fraction module. -}--approxRational :: (ToRational.C a, C a) => a -> a -> Rational-approxRational rat eps    =  simplest (rat-eps) (rat+eps)-        where simplest x y | y < x      =  simplest y x-                           | x == y     =  xr-                           | x > 0      =  simplest' n d n' d'-                           | y < 0      =  - simplest' (-n') d' (-n) d-                           | otherwise  =  0 :% 1-                                        where xr@(n:%d) = ToRational.toRational x-                                              (n':%d')  = ToRational.toRational y--              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'-                        | isZero r   =  q :% 1-                        | q /= q'    =  (q+1) :% 1-                        | otherwise  =  (q*n''+d'') :% n''-                                     where (q,r)      =  quotRem n d-                                           (q',r')    =  quotRem n' d'-                                           (n'':%d'') =  simplest' d' r' d r----- * generic implementation of round functions--powersOfTwo :: (Ring.C a) => [a]-powersOfTwo = iterate (2*) one--pairsOfPowersOfTwo :: (Ring.C a, Ring.C b) => [(a,b)]-pairsOfPowersOfTwo =-   zip powersOfTwo powersOfTwo--{- |-The generic rounding functions need a number of operations-proportional to the number of binary digits of the integer portion.-If operations like multiplication with two and comparison-need time proportional to the number of binary digits,-then the overall rounding requires quadratic time.--}-genericFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericFloor a =-   if a>=zero-     then genericPosFloor a-     else negate $ genericPosCeiling $ negate a--genericCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericCeiling a =-   if a>=zero-     then genericPosCeiling a-     else negate $ genericPosFloor $ negate a--genericTruncate :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericTruncate a =-   if a>=zero-     then genericPosFloor a-     else negate $ genericPosFloor $ negate a--genericRound :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericRound a =-   if a>=zero-     then genericPosRound a-     else negate $ genericPosRound $ negate a--genericFraction :: (Ord a, Ring.C a) => a -> a-genericFraction a =-   if a>=zero-     then genericPosFraction a-     else fixFraction $ negate $ genericPosFraction $ negate a--genericSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a)-genericSplitFraction a =-   if a>=zero-     then genericPosSplitFraction a-     else fixSplitFraction $ mapPair (negate, negate) $-          genericPosSplitFraction $ negate a---genericPosFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericPosFloor a =-   snd $-   foldr-      (\(pa,pb) acc@(accA,accB) ->-         let newA = accA+pa-         in  if newA>a then acc else (newA,accB+pb))-      (zero,zero) $-   takeWhile ((a>=) . fst) $-   pairsOfPowersOfTwo--genericPosCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericPosCeiling a =-   snd $-   (\(ps,u:_) ->-      foldr-         (\(pa,pb) acc@(accA,accB) ->-            let newA = accA-pa-            in  if newA>=a then (newA,accB-pb) else acc)-         u ps) $-   span ((a>) . fst) $-   (zero,zero) : pairsOfPowersOfTwo--{--genericPosFloorDigits :: (Ord a, Ring.C a, Ring.C b) => a -> ((a,b), [Bool])-genericPosFloorDigits a =-   List.mapAccumR-      (\acc@(accA,accB) (pa,pb) ->-         let newA = accA+pa-             b = newA<=a-         in  (if b then (newA,accB+pb) else acc, b))-      (zero,zero) $-   takeWhile ((a>=) . fst) $-   pairsOfPowersOfTwo--}--genericHalfPosFloorDigits :: (Ord a, Ring.C a, Ring.C b) => a -> ((a,b), [Bool])-genericHalfPosFloorDigits a =-   List.mapAccumR-      (\acc@(accA,accB) (pa,pb) ->-         let newA = accA+pa-             b = newA<=a-         in  (if b then (newA,accB+pb) else acc, b))-      (zero,zero) $-   takeWhile ((a>=) . fst) $-   zip powersOfTwo (zero:powersOfTwo)--genericPosRound :: (Ord a, Ring.C a, Ring.C b) => a -> b-genericPosRound a =-   let a2 = 2*a-       ((ai,bi), ds) = genericHalfPosFloorDigits a2-   in  if ai==a2-         then-           case ds of-             True : True : _ -> bi+one-             _ -> bi-         else-           case ds of-             True : _ -> bi+one-             _ -> bi--genericPosFraction :: (Ord a, Ring.C a) => a -> a-genericPosFraction a =-   foldr-      (\p acc ->-         if p>acc then acc else acc-p)-      a $-   takeWhile (a>=) $-   powersOfTwo--genericPosSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a)-genericPosSplitFraction a =-   foldr-      (\(pb,pa) acc@(accB,accA) ->-         if pa>accA then acc else (accB+pb,accA-pa))-      (zero,a) $-   takeWhile ((a>=) . snd) $-   pairsOfPowersOfTwo-+instance (ToInteger.C a, PID.C a) => C (Ratio.T a) where
src/Algebra/RealIntegral.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Generally before using 'quot' and 'rem', think twice. In most cases 'divMod' and friends are the right choice,@@ -16,12 +16,11 @@    C(quot, rem, quotRem),    ) where +import qualified Algebra.ZeroTestable   as ZeroTestable import qualified Algebra.IntegralDomain as Integral-import qualified Algebra.Real           as Real-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive+import qualified Algebra.Absolute       as Absolute -import Algebra.Real (signum, )+import Algebra.Absolute (signum, ) import Algebra.IntegralDomain (divMod, ) import Algebra.Ring (one, ) -- fromInteger import Algebra.Additive (zero, (+), (-), )@@ -29,9 +28,9 @@ import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  ) import Data.Word (Word, Word8, Word16, Word32, Word64, ) -import PreludeBase+import NumericPrelude.Base import qualified Prelude as P-import Prelude (Int, Integer, )+import Prelude (Integer, )   infixl 7 `quot`, `rem`@@ -46,7 +45,7 @@ Minimal definition: nothing required -} -class (Real.C a, Integral.C a) => C a where+class (Absolute.C a, ZeroTestable.C a, Ord a, Integral.C a) => C a where     quot, rem        :: a -> a -> a     quotRem          :: a -> a -> (a,a)
+ src/Algebra/RealRing.hs view
@@ -0,0 +1,737 @@+{-# LANGUAGE RebindableSyntax #-}+module Algebra.RealRing where++import qualified Algebra.RealRing98 as RealRing98++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+import qualified Algebra.ToRational     as ToRational+import qualified Algebra.ToInteger      as ToInteger+import qualified Algebra.Absolute       as Absolute++import qualified Algebra.OrderDecision as OrdDec+import Algebra.OrderDecision ((<?), (>=?), )++import Algebra.Field          (fromRational, )+import Algebra.RealIntegral   (quotRem, )+import Algebra.IntegralDomain (divMod, even, )+import Algebra.Ring           ((*), fromInteger, one, )+import Algebra.Additive       ((+), (-), negate, zero, )+import Algebra.ZeroTestable   (isZero, )+import Algebra.ToInteger      (fromIntegral, )++import qualified Number.Ratio as Ratio+import Number.Ratio (T((:%)), Rational)++import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  )+import Data.Word (Word, Word8, Word16, Word32, Word64, )++import qualified GHC.Float as GHC+import Data.List as List+import Data.Tuple.HT (mapFst, mapPair, )+import Prelude (Integer, Float, Double, )+import qualified Prelude as P+import NumericPrelude.Base+++{- $setup+>>> import qualified Algebra.RealRing as RealRing+>>> import Data.Tuple.HT (mapFst)+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>> infix 4 =~=+>>>+>>> (=~=) :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool+>>> (f =~= g) x = f x == g x+-}+++{- |+Minimal complete definition:+     'splitFraction' or 'floor'++There are probably more laws, but some laws are++> splitFraction x === (fromInteger (floor x), fraction x)+> fromInteger (floor x) + fraction x === x+> floor x       <= x       x <  floor x + 1+> ceiling x - 1 <  x       x <= ceiling x+> 0 <= fraction x          fraction x < 1++>               - ceiling x === floor (-x)+>                truncate x === signum x * floor (abs x)+>    ceiling (toRational x) === ceiling x :: Integer+>   truncate (toRational x) === truncate x :: Integer+>      floor (toRational x) === floor x :: Integer++The new function 'fraction' doesn't return the integer part of the number.+This also removes a type ambiguity if the integer part is not needed.++Many people will associate rounding with fractional numbers,+and thus they are surprised about the superclass being @Ring@ not @Field@.+The reason is that all of these methods can be defined+exclusively with functions from @Ord@ and @Ring@.+The implementations of 'genericFloor' and other functions demonstrate that.+They implement power-of-two-algorithms+like the one for finding the number of digits of an 'Integer'+in FixedPoint-fractions module.+They are even reasonably efficient.++I am still uncertain whether it was a good idea+to add instances for @Integer@ and friends,+since calling @floor@ or @fraction@ on an integer may well indicate a bug.+The rounding functions are just the identity function+and 'fraction' is constant zero.+However, I decided to associate our class with @Ring@ rather than @Field@,+after I found myself using repeated subtraction and testing+rather than just calling @fraction@,+just in order to get the constraint @(Ring a, Ord a)@+that was more general than @(RealField a)@.++For the results of the rounding functions+we have chosen the constraint @Ring@ instead of @ToInteger@,+since this is more flexible to use,+but it still signals to the user that only integral numbers can be returned.+This is so, because the plain @Ring@ class only provides+@zero@, @one@ and operations that allow to reach all natural numbers but not more.+++As an aside, let me note the similarities+between @splitFraction x@ and @divMod x 1@ (if that were defined).+In particular, it might make sense to unify the rounding modes somehow.++The new methods 'fraction' and 'splitFraction'+differ from 'Prelude.properFraction' semantics.+They always round to 'floor'.+This means that the fraction is always non-negative and+is always smaller than 1.+This is more useful in practice and+can be generalised to more than real numbers.+Since every 'Number.Ratio.T' denominator type+supports 'Algebra.IntegralDomain.divMod',+every 'Number.Ratio.T' can provide 'fraction' and 'splitFraction',+e.g. fractions of polynomials.+However the @Ring@ constraint for the ''integral'' part of 'splitFraction'+is too weak in order to generate polynomials.+After all, I am uncertain whether this would be useful or not.++Can there be a separate class for+'fraction', 'splitFraction', 'floor' and 'ceiling'+since they do not need reals and their ordering?++We might also add a round method,+that rounds 0.5 always up or always down.+This is much more efficient in inner loops+and is acceptable or even preferable for many applications.+-}++class (Absolute.C a, Ord a) => C a where+    {-# MINIMAL splitFraction | floor #-}+    {- |+    prop> \x -> (x::Rational) == (uncurry (+) $ mapFst fromInteger $ splitFraction x)+    prop> \x -> uncurry (==) $ mapFst (((x::Double)-) . fromInteger) $ splitFraction x+    prop> \x -> uncurry (==) $ mapFst (((x::Rational)-) . fromInteger) $ splitFraction x+    prop> \x -> splitFraction x == (floor (x::Double) :: Integer, fraction x)+    prop> \x -> splitFraction x == (floor (x::Rational) :: Integer, fraction x)+    -}+    splitFraction    :: (Ring.C b) => a -> (b,a)+    {- |+    prop> \x -> let y = fraction (x::Double) in 0<=y && y<1+    prop> \x -> let y = fraction (x::Rational) in 0<=y && y<1+    -}+    fraction :: a -> a+    {- |+    prop> \x -> ceiling (-x) == negate (floor (x::Double) :: Integer)+    prop> \x -> ceiling (-x) == negate (floor (x::Rational) :: Integer)+    -}+    ceiling, floor   :: (Ring.C b) => a -> b+    truncate         :: (Ring.C b) => a -> b+    round            :: (ToInteger.C b) => a -> b+++    splitFraction x   =  (floor x, fraction x)++    fraction x   =  x - fromInteger (floor x)++    floor x      =  fromInteger (fst (splitFraction x))++    ceiling x    =  - floor (-x)++--    truncate x   =  signum x * floor (abs x)+    truncate x =+       if x>=0+         then floor x+         else ceiling x++    {-+    The ToInteger constraint can be lifted to Ring+    if use Integer temporarily.+    I expect this would not be efficient in many cases.+    -}+    round x =+       let (n,r) = splitFraction x+       in  case compare (2*r) one of+              LT -> n+              EQ -> if even n then n else n+1+              GT -> n+1+++{- |+This function rounds to the closest integer.+For @fraction x == 0.5@ it rounds away from zero.+This function is not the result of an ingenious mathematical insight,+but is simply a kind of rounding that is the fastest+on IEEE floating point architectures.+-}+{-# NOINLINE [2] roundSimple #-}+roundSimple :: (C a, Ring.C b) => a -> b+roundSimple x =+   let (n,r) = splitFraction x+   in  case compare (2*r) one of+          LT -> n+          EQ -> if x<0 then n else n+1+          GT -> n+1+++instance (ToInteger.C a, PID.C a) => C (Ratio.T a) where+    splitFraction (x:%y) = (fromIntegral q, r:%y)+                               where (q,r) = divMod x y++instance C Integer where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromInteger x, zero)+    fraction      _ = zero+    floor         x = fromInteger x+    ceiling       x = fromInteger x+    round         x = fromInteger x+    truncate      x = fromInteger x++instance C Int where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Int8 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Int16 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Int32 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Int64 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Word8 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Word16 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Word32 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Word64 where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction x = (fromIntegral x, zero)+    fraction      _ = zero+    floor         x = fromIntegral x+    ceiling       x = fromIntegral x+    round         x = fromIntegral x+    truncate      x = fromIntegral x++instance C Float where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction = fastSplitFraction GHC.float2Int GHC.int2Float+    fraction      = RealRing98.fastFraction (GHC.int2Float . GHC.float2Int)+    floor         = fromInteger . P.floor+    ceiling       = fromInteger . P.ceiling+    round         = fromInteger . P.round+    truncate      = fromInteger . P.truncate++instance C Double where+    {-# INLINE splitFraction #-}+    {-# INLINE fraction #-}+    {-# INLINE floor #-}+    {-# INLINE ceiling #-}+    {-# INLINE round #-}+    {-# INLINE truncate #-}+    splitFraction = fastSplitFraction GHC.double2Int GHC.int2Double+    fraction      = RealRing98.fastFraction (GHC.int2Double . GHC.double2Int)+    floor         = fromInteger . P.floor+    ceiling       = fromInteger . P.ceiling+    round         = fromInteger . P.round+    truncate      = fromInteger . P.truncate+++{-# INLINE fastSplitFraction #-}+fastSplitFraction :: (P.RealFrac a, Absolute.C a, Ring.C b) =>+   (a -> Int) -> (Int -> a) -> a -> (b,a)+fastSplitFraction trunc toFloat x =+   fixSplitFraction $+   if toFloat minBound <= x && x <= toFloat maxBound+     then case trunc x of n -> (fromIntegral n, x - toFloat n)+     else case P.properFraction x of (n,f) -> (fromInteger n, f)++{-# INLINE fixSplitFraction #-}+fixSplitFraction :: (Ring.C a, Ring.C b, Ord a) => (b,a) -> (b,a)+fixSplitFraction (n,f) =+   --  if x>=0 || f==0+   if f>=0+     then (n,   f)+     else (n-1, f+1)++{-# INLINE fixFraction #-}+fixFraction :: (Ring.C a, Ord a) => a -> a+fixFraction y =+   if y>=0 then y else y+1++{-+mapM_ (\n -> let x = fromInteger n / 10 in print (x, floorInt GHC.double2Int GHC.int2Double x)) [-20,-19..20]+-}++{-# INLINE splitFractionInt #-}+splitFractionInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> (Int, a)+splitFractionInt trunc toFloat x =+   let n = trunc x+   in  fixSplitFraction (n, x - toFloat n)++{-# INLINE floorInt #-}+floorInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int+floorInt trunc toFloat x =+   let n = trunc x+   in  if x >= toFloat n+         then n+         else pred n++{-# INLINE ceilingInt #-}+ceilingInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int+ceilingInt trunc toFloat x =+   let n = trunc x+   in  if x <= toFloat n+         then n+         else succ n++{-# INLINE roundInt #-}+roundInt :: (Field.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int+roundInt trunc toFloat x =+   let half = 0.5 -- P.fromRational+       halfUp = x+half+       n = floorInt trunc toFloat halfUp+   in  if toFloat n == halfUp  &&  P.odd n+         then pred n+         else n++{-# INLINE roundSimpleInt #-}+roundSimpleInt ::+   (Field.C a, Absolute.C a, Ord a) =>+   (a -> Int) -> (Int -> a) -> a -> Int+roundSimpleInt trunc _toFloat x =+   trunc (x + Absolute.signum x * 0.5)++++{- RULES maybe used, when Prelude implementations become more efficient+     "NP.round    :: Float -> Int"    round    = P.round    :: Float -> Int;+     "NP.truncate :: Float -> Int"    truncate = P.truncate :: Float -> Int;+     "NP.floor    :: Float -> Int"    floor    = P.floor    :: Float -> Int;+     "NP.ceiling  :: Float -> Int"    ceiling  = P.ceiling  :: Float -> Int;+     "NP.round    :: Double -> Int"   round    = P.round    :: Double -> Int;+     "NP.truncate :: Double -> Int"   truncate = P.truncate :: Double -> Int;+     "NP.floor    :: Double -> Int"   floor    = P.floor    :: Double -> Int;+     "NP.ceiling  :: Double -> Int"   ceiling  = P.ceiling  :: Double -> Int;+  -}++-- these rules will also be needed for Int16 et.al.+{-# RULES+     "NP.round       :: Float -> Int"    round    = roundInt       GHC.float2Int  GHC.int2Float;+     "NP.roundSimple :: Float -> Int"    round    = roundSimpleInt GHC.float2Int  GHC.int2Float;+     "NP.truncate    :: Float -> Int"    truncate =                GHC.float2Int               ;+     "NP.floor       :: Float -> Int"    floor    = floorInt       GHC.float2Int  GHC.int2Float;+     "NP.ceiling     :: Float -> Int"    ceiling  = ceilingInt     GHC.float2Int  GHC.int2Float;+     "NP.round       :: Double -> Int"   round    = roundInt       GHC.double2Int GHC.int2Double;+     "NP.roundSimple :: Double -> Int"   round    = roundSimpleInt GHC.double2Int GHC.int2Double;+     "NP.truncate    :: Double -> Int"   truncate =                GHC.double2Int               ;+     "NP.floor       :: Double -> Int"   floor    = floorInt       GHC.double2Int GHC.int2Double;+     "NP.ceiling     :: Double -> Int"   ceiling  = ceilingInt     GHC.double2Int GHC.int2Double;++     "NP.splitFraction :: Float ->  (Int, Float)"  splitFraction = splitFractionInt GHC.float2Int GHC.int2Float;+     "NP.splitFraction :: Double -> (Int, Double)" splitFraction = splitFractionInt GHC.double2Int GHC.int2Double;+  #-}++-- generated by GenerateRules.hs+{-# RULES+     "NP.round       :: a -> Int8"    round       = (P.fromIntegral :: Int -> Int8) . round;+     "NP.roundSimple :: a -> Int8"    roundSimple = (P.fromIntegral :: Int -> Int8) . roundSimple;+     "NP.truncate    :: a -> Int8"    truncate    = (P.fromIntegral :: Int -> Int8) . truncate;+     "NP.floor       :: a -> Int8"    floor       = (P.fromIntegral :: Int -> Int8) . floor;+     "NP.ceiling     :: a -> Int8"    ceiling     = (P.fromIntegral :: Int -> Int8) . ceiling;+     "NP.round       :: a -> Int16"   round       = (P.fromIntegral :: Int -> Int16) . round;+     "NP.roundSimple :: a -> Int16"   roundSimple = (P.fromIntegral :: Int -> Int16) . roundSimple;+     "NP.truncate    :: a -> Int16"   truncate    = (P.fromIntegral :: Int -> Int16) . truncate;+     "NP.floor       :: a -> Int16"   floor       = (P.fromIntegral :: Int -> Int16) . floor;+     "NP.ceiling     :: a -> Int16"   ceiling     = (P.fromIntegral :: Int -> Int16) . ceiling;+     "NP.round       :: a -> Int32"   round       = (P.fromIntegral :: Int -> Int32) . round;+     "NP.roundSimple :: a -> Int32"   roundSimple = (P.fromIntegral :: Int -> Int32) . roundSimple;+     "NP.truncate    :: a -> Int32"   truncate    = (P.fromIntegral :: Int -> Int32) . truncate;+     "NP.floor       :: a -> Int32"   floor       = (P.fromIntegral :: Int -> Int32) . floor;+     "NP.ceiling     :: a -> Int32"   ceiling     = (P.fromIntegral :: Int -> Int32) . ceiling;+     "NP.round       :: a -> Int64"   round       = (P.fromIntegral :: Int -> Int64) . round;+     "NP.roundSimple :: a -> Int64"   roundSimple = (P.fromIntegral :: Int -> Int64) . roundSimple;+     "NP.truncate    :: a -> Int64"   truncate    = (P.fromIntegral :: Int -> Int64) . truncate;+     "NP.floor       :: a -> Int64"   floor       = (P.fromIntegral :: Int -> Int64) . floor;+     "NP.ceiling     :: a -> Int64"   ceiling     = (P.fromIntegral :: Int -> Int64) . ceiling;+     "NP.round       :: a -> Word"    round       = (P.fromIntegral :: Int -> Word) . round;+     "NP.roundSimple :: a -> Word"    roundSimple = (P.fromIntegral :: Int -> Word) . roundSimple;+     "NP.truncate    :: a -> Word"    truncate    = (P.fromIntegral :: Int -> Word) . truncate;+     "NP.floor       :: a -> Word"    floor       = (P.fromIntegral :: Int -> Word) . floor;+     "NP.ceiling     :: a -> Word"    ceiling     = (P.fromIntegral :: Int -> Word) . ceiling;+     "NP.round       :: a -> Word8"   round       = (P.fromIntegral :: Int -> Word8) . round;+     "NP.roundSimple :: a -> Word8"   roundSimple = (P.fromIntegral :: Int -> Word8) . roundSimple;+     "NP.truncate    :: a -> Word8"   truncate    = (P.fromIntegral :: Int -> Word8) . truncate;+     "NP.floor       :: a -> Word8"   floor       = (P.fromIntegral :: Int -> Word8) . floor;+     "NP.ceiling     :: a -> Word8"   ceiling     = (P.fromIntegral :: Int -> Word8) . ceiling;+     "NP.round       :: a -> Word16"  round       = (P.fromIntegral :: Int -> Word16) . round;+     "NP.roundSimple :: a -> Word16"  roundSimple = (P.fromIntegral :: Int -> Word16) . roundSimple;+     "NP.truncate    :: a -> Word16"  truncate    = (P.fromIntegral :: Int -> Word16) . truncate;+     "NP.floor       :: a -> Word16"  floor       = (P.fromIntegral :: Int -> Word16) . floor;+     "NP.ceiling     :: a -> Word16"  ceiling     = (P.fromIntegral :: Int -> Word16) . ceiling;+     "NP.round       :: a -> Word32"  round       = (P.fromIntegral :: Int -> Word32) . round;+     "NP.roundSimple :: a -> Word32"  roundSimple = (P.fromIntegral :: Int -> Word32) . roundSimple;+     "NP.truncate    :: a -> Word32"  truncate    = (P.fromIntegral :: Int -> Word32) . truncate;+     "NP.floor       :: a -> Word32"  floor       = (P.fromIntegral :: Int -> Word32) . floor;+     "NP.ceiling     :: a -> Word32"  ceiling     = (P.fromIntegral :: Int -> Word32) . ceiling;+     "NP.round       :: a -> Word64"  round       = (P.fromIntegral :: Int -> Word64) . round;+     "NP.roundSimple :: a -> Word64"  roundSimple = (P.fromIntegral :: Int -> Word64) . roundSimple;+     "NP.truncate    :: a -> Word64"  truncate    = (P.fromIntegral :: Int -> Word64) . truncate;+     "NP.floor       :: a -> Word64"  floor       = (P.fromIntegral :: Int -> Word64) . floor;+     "NP.ceiling     :: a -> Word64"  ceiling     = (P.fromIntegral :: Int -> Word64) . ceiling;++     "NP.splitFraction :: a -> (Int8,a)"     splitFraction = mapFst (P.fromIntegral :: Int -> Int8) . splitFraction;+     "NP.splitFraction :: a -> (Int16,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Int16) . splitFraction;+     "NP.splitFraction :: a -> (Int32,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Int32) . splitFraction;+     "NP.splitFraction :: a -> (Int64,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Int64) . splitFraction;+     "NP.splitFraction :: a -> (Word,a)"     splitFraction = mapFst (P.fromIntegral :: Int -> Word) . splitFraction;+     "NP.splitFraction :: a -> (Word8,a)"    splitFraction = mapFst (P.fromIntegral :: Int -> Word8) . splitFraction;+     "NP.splitFraction :: a -> (Word16,a)"   splitFraction = mapFst (P.fromIntegral :: Int -> Word16) . splitFraction;+     "NP.splitFraction :: a -> (Word32,a)"   splitFraction = mapFst (P.fromIntegral :: Int -> Word32) . splitFraction;+     "NP.splitFraction :: a -> (Word64,a)"   splitFraction = mapFst (P.fromIntegral :: Int -> Word64) . splitFraction;+  #-}+++{- | TODO: Should be moved to a continued fraction module. -}++approxRational :: (ToRational.C a, C a) => a -> a -> Rational+approxRational rat eps    =  simplest (rat-eps) (rat+eps)+        where simplest x y | y < x      =  simplest y x+                           | x == y     =  xr+                           | x > 0      =  simplest' n d n' d'+                           | y < 0      =  - simplest' (-n') d' (-n) d+                           | otherwise  =  0 :% 1+                                        where xr@(n:%d) = ToRational.toRational x+                                              (n':%d')  = ToRational.toRational y++              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+                        | isZero r   =  q :% 1+                        | q /= q'    =  (q+1) :% 1+                        | otherwise  =  (q*n''+d'') :% n''+                                     where (q,r)      =  quotRem n d+                                           (q',r')    =  quotRem n' d'+                                           (n'':%d'') =  simplest' d' r' d r+++-- * generic implementation of round functions++powersOfTwo :: (Ring.C a) => [a]+powersOfTwo = iterate (2*) one++pairsOfPowersOfTwo :: (Ring.C a, Ring.C b) => [(a,b)]+pairsOfPowersOfTwo =+   zip powersOfTwo powersOfTwo++{- |+The generic rounding functions need a number of operations+proportional to the number of binary digits of the integer portion.+If operations like multiplication with two and comparison+need time proportional to the number of binary digits,+then the overall rounding requires quadratic time.++prop> RealRing.genericFloor =~= (NP.floor :: Double -> Integer)+prop> RealRing.genericFloor =~= (NP.floor :: Rational -> Integer)+-}+genericFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericFloor a =+   if a>=zero+     then genericPosFloor a+     else negate $ genericPosCeiling $ negate a++{- |+prop> RealRing.genericCeiling =~= (NP.ceiling :: Double -> Integer)+prop> RealRing.genericCeiling =~= (NP.ceiling :: Rational -> Integer)+-}+genericCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericCeiling a =+   if a>=zero+     then genericPosCeiling a+     else negate $ genericPosFloor $ negate a++{- |+prop> RealRing.genericTruncate =~= (NP.truncate :: Double -> Integer)+prop> RealRing.genericTruncate =~= (NP.truncate :: Rational -> Integer)+-}+genericTruncate :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericTruncate a =+   if a>=zero+     then genericPosFloor a+     else negate $ genericPosFloor $ negate a++{- |+prop> RealRing.genericRound =~= (NP.round :: Double -> Integer)+prop> RealRing.genericRound =~= (NP.round :: Rational -> Integer)+-}+genericRound :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericRound a =+   if a>=zero+     then genericPosRound a+     else negate $ genericPosRound $ negate a++{- |+prop> RealRing.genericFraction =~= (NP.fraction :: Double -> Double)+prop> RealRing.genericFraction =~= (NP.fraction :: Rational -> Rational)+-}+genericFraction :: (Ord a, Ring.C a) => a -> a+genericFraction a =+   if a>=zero+     then genericPosFraction a+     else fixFraction $ negate $ genericPosFraction $ negate a++{- |+prop> RealRing.genericSplitFraction =~= (NP.splitFraction :: Double -> (Integer,Double))+prop> RealRing.genericSplitFraction =~= (NP.splitFraction :: Rational -> (Integer,Rational))+-}+genericSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a)+genericSplitFraction a =+   if a>=zero+     then genericPosSplitFraction a+     else fixSplitFraction $ mapPair (negate, negate) $+          genericPosSplitFraction $ negate a+++genericPosFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericPosFloor a =+   snd $+   foldr+      (\(pa,pb) acc@(accA,accB) ->+         let newA = accA+pa+         in  if newA>a then acc else (newA,accB+pb))+      (zero,zero) $+   takeWhile ((a>=) . fst) $+   pairsOfPowersOfTwo++genericPosCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericPosCeiling a =+   snd $+   (\(ps,u:_) ->+      foldr+         (\(pa,pb) acc@(accA,accB) ->+            let newA = accA-pa+            in  if newA>=a then (newA,accB-pb) else acc)+         u ps) $+   span ((a>) . fst) $+   (zero,zero) : pairsOfPowersOfTwo++{-+genericPosFloorDigits :: (Ord a, Ring.C a, Ring.C b) => a -> ((a,b), [Bool])+genericPosFloorDigits a =+   List.mapAccumR+      (\acc@(accA,accB) (pa,pb) ->+         let newA = accA+pa+             b = newA<=a+         in  (if b then (newA,accB+pb) else acc, b))+      (zero,zero) $+   takeWhile ((a>=) . fst) $+   pairsOfPowersOfTwo+-}++genericHalfPosFloorDigits :: (Ord a, Ring.C a, Ring.C b) => a -> ((a,b), [Bool])+genericHalfPosFloorDigits a =+   List.mapAccumR+      (\acc@(accA,accB) (pa,pb) ->+         let newA = accA+pa+             b = newA<=a+         in  (if b then (newA,accB+pb) else acc, b))+      (zero,zero) $+   takeWhile ((a>=) . fst) $+   zip powersOfTwo (zero:powersOfTwo)++genericPosRound :: (Ord a, Ring.C a, Ring.C b) => a -> b+genericPosRound a =+   let a2 = 2*a+       ((ai,bi), ds) = genericHalfPosFloorDigits a2+   in  if ai==a2+         then+           case ds of+             True : True : _ -> bi+one+             _ -> bi+         else+           case ds of+             True : _ -> bi+one+             _ -> bi++genericPosFraction :: (Ord a, Ring.C a) => a -> a+genericPosFraction a =+   foldr+      (\p acc ->+         if p>acc then acc else acc-p)+      a $+   takeWhile (a>=) $+   powersOfTwo++genericPosSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a)+genericPosSplitFraction a =+   foldr+      (\(pb,pa) acc@(accB,accA) ->+         if pa>accA then acc else (accB+pb,accA-pa))+      (zero,a) $+   takeWhile ((a>=) . snd) $+   pairsOfPowersOfTwo+++{- |+Needs linear time with respect to the number of digits.++This and other functions using OrderDecision+like @floor@ where argument and result are the same+may be moved to a new module.+-}+decisionPosFraction :: (OrdDec.C a, Ring.C a) => a -> a+decisionPosFraction a0 =+   (\ps ->+      foldr+         (\p cont a ->+            (a<?one) a $ cont $+            (a>=?p) (a-p) a)+         (error "decisionPosFraction: end of list should never be reached")+         ps a0) $+   concatMap (reverse . flip take powersOfTwo) powersOfTwo++{-+Works but needs quadratic time with respect to the number of digits.+I feel that there must be something more efficient.+-}+decisionPosFractionSqrTime :: (OrdDec.C a, Ring.C a) => a -> a+decisionPosFractionSqrTime a0 =+   (\ps ->+      foldr+         (\p cont a ->+            (a<?one) a $ cont $+            (a>=?p) (a-p) a)+         (error "decisionPosFraction: end of list should never be reached")+         ps a0) $+   concatMap reverse $+   inits powersOfTwo
+ src/Algebra/RealRing98.hs view
@@ -0,0 +1,39 @@+module Algebra.RealRing98 where++{-# INLINE fastSplitFraction #-}+fastSplitFraction :: (RealFrac a, Integral b) =>+   (a -> Int) -> (Int -> a) -> a -> (b,a)+fastSplitFraction trunc toFloat x =+   fixSplitFraction $+   if toFloat minBound <= x && x <= toFloat maxBound+     then case trunc x of n -> (fromIntegral n, x - toFloat n)+     else case properFraction x of (n,f) -> (fromInteger n, f)++{-# INLINE fixSplitFraction #-}+fixSplitFraction :: (Num a, Num b, Ord a) => (b,a) -> (b,a)+fixSplitFraction (n,f) =+   --  if x>=0 || f==0+   if f>=0+     then (n,   f)+     else (n-1, f+1)+++{-# INLINE fastFraction #-}+fastFraction :: (RealFrac a) => (a -> a) -> a -> a+fastFraction trunc x =+   fixFraction $+   if fromIntegral (minBound :: Int) <= x && x <= fromIntegral (maxBound :: Int)+     then x - trunc x+     else signedFraction x++{-# INLINE signedFraction #-}+signedFraction :: (RealFrac a) => a -> a+signedFraction x =+   let second :: (Integer, a) -> a+       second = snd+   in  second (properFraction x)++{-# INLINE fixFraction #-}+fixFraction :: (Real a) => a -> a+fixFraction y =+   if y>=0 then y else y+1
src/Algebra/RealTranscendental.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.RealTranscendental where  import qualified Algebra.Transcendental      as Trans@@ -12,7 +12,7 @@ import Data.Bool.HT (select, )  import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base
src/Algebra/RightModule.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.RightModule where@@ -6,8 +6,6 @@ import qualified Algebra.Ring     as Ring import qualified Algebra.Additive as Additive --- import NumericPrelude-import qualified Prelude   -- Is this right?
src/Algebra/Ring.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Ring (     {- * Class -}     C,@@ -29,18 +29,18 @@ import Algebra.Additive(zero, (+), negate, sum)  import Data.Function.HT (powerAssociative, )-import NumericPrelude.List (zipWithMatch, )+import NumericPrelude.List (zipWithChecked, )  import Test.QuickCheck ((==>), Property)  import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  ) import Data.Word (Word, Word8, Word16, Word32, Word64, ) -import PreludeBase-import Prelude(Integer,Int,Float,Double)+import NumericPrelude.Base+import Prelude (Integer, Float, Double, )+import qualified Data.Complex as Complex98 import qualified Data.Ratio as Ratio98 import qualified Prelude as P--- import Test.QuickCheck   infixl 7 *@@ -64,6 +64,7 @@ -}  class (Additive.C a) => C a where+    {-# MINIMAL (*), (one | fromInteger) #-}     (*)         :: a -> a -> a     one         :: a     fromInteger :: Integer -> a@@ -105,7 +106,7 @@   scalarProduct :: C a => [a] -> [a] -> a-scalarProduct as bs = sum (zipWithMatch (*) as bs)+scalarProduct as bs = sum (zipWithChecked (*) as bs)   {- * Instances for atomic types -}@@ -252,6 +253,14 @@    {-# INLINE one #-}    {-# INLINE fromInteger #-}    {-# INLINE (*) #-}-   one                 =  1+   one                 =  P.fromInteger 1+   fromInteger         =  P.fromInteger+   (*)                 =  (P.*)++instance (P.RealFloat a) => C (Complex98.Complex a) where+   {-# INLINE one #-}+   {-# INLINE fromInteger #-}+   {-# INLINE (*) #-}+   one                 =  P.fromInteger 1    fromInteger         =  P.fromInteger    (*)                 =  (P.*)
src/Algebra/ToInteger.hs view
@@ -1,7 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {---fglasgow-exts for RULES- The orphan instance could be fixed by making this module mutually recursive with ToRational.hs, but that's not worth the complication.@@ -26,8 +24,8 @@ import Data.Word (Word, Word8, Word16, Word32, Word64, )  import qualified Prelude as P-import PreludeBase-import Prelude (Int, Integer, Float, Double, )+import NumericPrelude.Base+import Prelude (Integer, Float, Double, )   {- |@@ -41,16 +39,17 @@  Conversions must be lossless, that is, they do not round in any way.-For rounding see "Algebra.RealField".-With the instances for 'Prelude.Float' and 'Prelude.Double'-we acknowledge that these types actually represent rationals-rather than (approximated) real numbers.-However, this contradicts to the 'Algebra.Transcendental.C' instance.+For rounding see "Algebra.RealRing".++I think that the RealIntegral superclass is too restrictive.+Non-negative numbers are not a ring,+but can be easily converted to Integers. -} class (ToRational.C a, RealIntegral.C a) => C a where    toInteger :: a -> Integer  +{-# NOINLINE [2] fromIntegral #-} fromIntegral :: (C a, Ring.C b) => a -> b fromIntegral = fromInteger . toInteger
src/Algebra/ToRational.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.ToRational where -import qualified Algebra.Real           as Real+import qualified Algebra.ZeroTestable as ZeroTestable+import qualified Algebra.Field    as Field+import qualified Algebra.Absolute as Absolute import Algebra.Field (fromRational, ) import Algebra.Ring (fromInteger, ) @@ -11,47 +13,90 @@ import Data.Word (Word, Word8, Word16, Word32, Word64, )  import qualified Prelude as P-import PreludeBase-import Prelude(Int,Integer,Float,Double)+import NumericPrelude.Base+import Prelude (Integer, Float, Double, )  {- | This class allows lossless conversion from any representation of a rational to the fixed 'Rational' type. \"Lossless\" means - don't do any rounding.-For rounding see "Algebra.RealField".+For rounding see "Algebra.RealRing". With the instances for 'Float' and 'Double' we acknowledge that these types actually represent rationals rather than (approximated) real numbers.-However, this contradicts to the 'Algebra.Transcendental'+However, this contradicts to the 'Algebra.Transcendental' class.  Laws that must be satisfied by instances:  >  fromRational' . toRational === id -}-class (Real.C a) => C a where+class (Absolute.C a, ZeroTestable.C a, Ord a) => C a where    -- | Lossless conversion from any representation of a rational to 'Rational'    toRational :: a -> Rational  instance C Integer where-   {-#INLINE toRational #-}+   {-# INLINE toRational #-}    toRational = fromInteger  instance C Float where-   {-#INLINE toRational #-}+   {-# INLINE toRational #-}    toRational = fromRational . P.toRational  instance C Double where-   {-#INLINE toRational #-}+   {-# INLINE toRational #-}    toRational = fromRational . P.toRational -instance C Int     where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Int8    where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Int16   where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Int32   where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Int64   where {-#INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Int    where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Int8   where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Int16  where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Int32  where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Int64  where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Word    where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Word8   where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Word16  where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Word32  where {-#INLINE toRational #-}; toRational = toRational . P.toInteger-instance C Word64  where {-#INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Word   where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Word8  where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Word16 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Word32 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+instance C Word64 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger+++{- |+It should hold++> realToField = fromRational' . toRational++but it should be much more efficient for particular pairs of types,+such as converting 'Float' to 'Double'.+This achieved by optimizer rules.+-}+{-# NOINLINE [2] realToField #-}+realToField :: (C a, Field.C b) => a -> b+realToField = Field.fromRational' . toRational++{-# RULES+     "NP.realToField :: Integer  -> Float "  realToField = P.realToFrac :: Integer  -> Float ;+     "NP.realToField :: Int      -> Float "  realToField = P.realToFrac :: Int      -> Float ;+     "NP.realToField :: Int8     -> Float "  realToField = P.realToFrac :: Int8     -> Float ;+     "NP.realToField :: Int16    -> Float "  realToField = P.realToFrac :: Int16    -> Float ;+     "NP.realToField :: Int32    -> Float "  realToField = P.realToFrac :: Int32    -> Float ;+     "NP.realToField :: Int64    -> Float "  realToField = P.realToFrac :: Int64    -> Float ;+     "NP.realToField :: Word     -> Float "  realToField = P.realToFrac :: Word     -> Float ;+     "NP.realToField :: Word8    -> Float "  realToField = P.realToFrac :: Word8    -> Float ;+     "NP.realToField :: Word16   -> Float "  realToField = P.realToFrac :: Word16   -> Float ;+     "NP.realToField :: Word32   -> Float "  realToField = P.realToFrac :: Word32   -> Float ;+     "NP.realToField :: Word64   -> Float "  realToField = P.realToFrac :: Word64   -> Float ;+     "NP.realToField :: Float    -> Float "  realToField = P.realToFrac :: Float    -> Float ;+     "NP.realToField :: Double   -> Float "  realToField = P.realToFrac :: Double   -> Float ;+     "NP.realToField :: Integer  -> Double"  realToField = P.realToFrac :: Integer  -> Double;+     "NP.realToField :: Int      -> Double"  realToField = P.realToFrac :: Int      -> Double;+     "NP.realToField :: Int8     -> Double"  realToField = P.realToFrac :: Int8     -> Double;+     "NP.realToField :: Int16    -> Double"  realToField = P.realToFrac :: Int16    -> Double;+     "NP.realToField :: Int32    -> Double"  realToField = P.realToFrac :: Int32    -> Double;+     "NP.realToField :: Int64    -> Double"  realToField = P.realToFrac :: Int64    -> Double;+     "NP.realToField :: Word     -> Double"  realToField = P.realToFrac :: Word     -> Double;+     "NP.realToField :: Word8    -> Double"  realToField = P.realToFrac :: Word8    -> Double;+     "NP.realToField :: Word16   -> Double"  realToField = P.realToFrac :: Word16   -> Double;+     "NP.realToField :: Word32   -> Double"  realToField = P.realToFrac :: Word32   -> Double;+     "NP.realToField :: Word64   -> Double"  realToField = P.realToFrac :: Word64   -> Double;+     "NP.realToField :: Float    -> Double"  realToField = P.realToFrac :: Float    -> Double;+     "NP.realToField :: Double   -> Double"  realToField = P.realToFrac :: Double   -> Double;+  #-}
src/Algebra/Transcendental.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Transcendental where  import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.Ring      as Ring-import qualified Algebra.Additive  as Additive  import qualified Algebra.Laws as Laws @@ -13,7 +11,7 @@ import Algebra.Additive  ((+), (-), negate)  import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   infixr 8  **, ^?@@ -31,9 +29,10 @@ branch cuts, etc.  Minimal complete definition:-     pi, exp, log, sin, cos, asin, acos, atan+     pi, exp, (log or logBase), sin, cos, atan -} class (Algebraic.C a) => C a where+    {-# MINIMAL pi, exp, (log | logBase), sin, cos, atan #-}     pi                  :: a     exp, log            :: a -> a     logBase, (**)       :: a -> a -> a@@ -42,16 +41,10 @@     sinh, cosh, tanh    :: a -> a     asinh, acosh, atanh :: a -> a -    {-# INLINE pi #-}-    {-# INLINE exp #-}-    {-# INLINE log #-}     {-# INLINE logBase #-}     {-# INLINE (**) #-}-    {-# INLINE sin #-}     {-# INLINE tan #-}-    {-# INLINE cos #-}     {-# INLINE asin #-}-    {-# INLINE atan #-}     {-# INLINE acos #-}     {-# INLINE sinh #-}     {-# INLINE tanh #-}@@ -62,6 +55,7 @@      x ** y           =  exp (log x * y)     logBase x y      =  log y / log x+    log              =  logBase (exp 1)      tan  x           =  sin x / cos x
src/Algebra/Units.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.Units (     {- * Class -}     C,@@ -22,7 +22,6 @@  import qualified Algebra.IntegralDomain as Integral import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable  import qualified Algebra.Laws           as Laws@@ -34,8 +33,8 @@  import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  ) -import PreludeBase-import Prelude (Integer, Int)+import NumericPrelude.Base+import Prelude (Integer, ) import qualified Prelude as P import Test.QuickCheck ((==>), Property) @@ -70,11 +69,12 @@ -}  class (Integral.C a) => C a where+  {-# MINIMAL isUnit, (stdUnit | stdUnitInv) #-}   isUnit :: a -> Bool   stdAssociate, stdUnit, stdUnitInv :: a -> a    stdAssociate x = x * stdUnitInv x-  stdUnit      x = div one (stdUnitInv x)  -- should be safeDiv+  stdUnit      x = div one (stdUnitInv x)  -- should be divChecked   stdUnitInv   x = div one (stdUnit x)  @@ -84,7 +84,7 @@  intQuery :: (P.Integral a, Ring.C a) => a -> Bool intQuery = flip elem [one, negate one]-{- constraint must be replaced by NumericPrelude.Real -}+{- constraint must be replaced by NumericPrelude.Absolute -} intAssociate, intStandard, intStandardInverse ::    (P.Integral a, Ring.C a, ZeroTestable.C a) => a -> a intAssociate = P.abs
src/Algebra/Vector.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright   :  (c) Henning Thielemann 2004-2005 @@ -18,7 +18,6 @@ import Algebra.Additive ((+))  import Data.List (zipWith, foldl)--- import Data.Functor (Functor, fmap)  import Prelude((.), (==), Bool, Functor, fmap) import qualified Prelude as P
src/Algebra/VectorSpace.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.VectorSpace where@@ -8,7 +8,8 @@ import qualified Algebra.PrincipalIdealDomain as PID import qualified Number.Ratio   as Ratio --- import NumericPrelude+import qualified Data.Complex as Complex98+ import qualified Prelude as P  @@ -32,3 +33,5 @@ instance (C a b) => C a [b]  instance (C a b) => C a (c -> b)++instance (C a b, P.RealFloat b) => C a (Complex98.Complex b)
src/Algebra/ZeroTestable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Algebra.ZeroTestable where  import qualified Algebra.Additive as Additive@@ -6,9 +6,8 @@ import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  ) import Data.Word (Word, Word8, Word16, Word32, Word64, ) --- import qualified Prelude as P-import Prelude(Int,Integer,Float,Double)-import PreludeBase+import Prelude (Integer, Float, Double, )+import NumericPrelude.Base  {- | Maybe the naming should be according to Algebra.Unit:
src/MathObj/Algebra.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright    :   (c) Mikael Johansson 2006 Maintainer   :   mik@math.uni-jena.de@@ -24,7 +24,7 @@ import qualified Data.Map as Map import Data.List(intersperse) -import PreludeBase(Ord,Eq,{-Read,-}Show,(++),($),+import NumericPrelude.Base(Ord,Eq,{-Read,-}Show,(++),($),                    concat,map,show)
src/MathObj/DiscreteMap.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -41,8 +41,7 @@ import qualified Data.Map as Map import Data.Map (Map) -import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base  -- FIXME: Should this be implemented by isZero? -- | Remove all zero values from the map.
− src/MathObj/Gaussian/Bell.hs 
@@ -1,289 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{--Complex translated Gaussian bell curve-with amplitude abstracted away.--}-module MathObj.Gaussian.Bell where--import qualified MathObj.Polynomial as Poly-import qualified Number.Complex as Complex--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field          as Field-import qualified Algebra.Real           as Real-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive--import Number.Complex ((+:), )-import Algebra.Transcendental (pi, )-import Algebra.Ring ((*), (^), )-import Algebra.Additive ((+), )--import Test.QuickCheck (Arbitrary, arbitrary, )-import Control.Monad (liftM4, )---- import Prelude (($))-import NumericPrelude-import PreludeBase hiding (reverse, )---data T a = Cons {amp :: a, c0, c1 :: Complex.T a, c2 :: a}-   deriving (Eq, Show)--instance (Real.C a, Arbitrary a) => Arbitrary (T a) where-   arbitrary =-      liftM4-         (\k a b c -> Cons k a b (1 + abs c))-         arbitrary arbitrary arbitrary arbitrary---constant :: Ring.C a => T a-constant = Cons one zero zero zero--{- |-eigenfunction of 'fourier'--}-unit :: Ring.C a => T a-unit = Cons one zero zero one--{-# INLINE evaluate #-}-evaluate :: (Trans.C a) =>-   T a -> a -> Complex.T a-evaluate f x =-   Complex.scale-     (sqrt (amp f))-     (Complex.exp $ Complex.scale (-pi) $-      c0 f + Complex.scale x (c1 f) + Complex.fromReal (c2 f * x^2))--evaluateSqRt :: (Trans.C a) =>-   T a -> a -> Complex.T a-evaluateSqRt f x0 =-   Complex.scale-     (sqrt (amp f))-     (let x = sqrt pi * x0-      in  Complex.exp $ negate $-          c0 f + Complex.scale x (c1 f) + Complex.fromReal (c2 f * x^2))--exponentPolynomial :: (Additive.C a) =>-   T a -> Poly.T (Complex.T a)-exponentPolynomial f =-   Poly.fromCoeffs [c0 f, c1 f, Complex.fromReal (c2 f)]---variance :: (Trans.C a) =>-   T a -> a-variance f =-   recip $ c2 f * 2*pi--multiply :: (Ring.C a) =>-   T a -> T a -> T a-multiply f g =-   Cons-      (amp f * amp g)-      (c0 f + c0 g) (c1 f + c1 g) (c2 f + c2 g)---{--let x=Cons (1+:3) (4+:5) (7::Rational); y=Cons (1+:4) (3+:2) (5::Rational)--}-convolve :: (Field.C a) =>-   T a -> T a -> T a-convolve f g =-   let s = c2 f + c2 g-       {--       fd = f1/(2*f2)-       gd = g1/(2*g2)-       c = f2*g2/(f2+g2)--       c*(fd+gd) = (f1*g2+f2*g1)/(2*(f2+g2)) = b/2--       c*(fd+gd)^2 - fd^2*f2 - gd^2*g2-         = f2*g2*(fd+gd)^2/(f2 + g2) - (fd^2*f2 + gd^2*g2)-         = (f2*g2*(fd+gd)^2 - (f2+g2)*(fd^2*f2+gd^2*g2)) / (f2 + g2)-         = (2*f2*g2*fd*gd - (fd^2*f2^2+gd^2*g2^2)) / (f2 + g2)-         = (2*f1*g1 - (f1^2+g1^2)) / (4*(f2 + g2))-         = -(f1 - g1)^2/(4*(f2 + g2))-       -}-   in  Cons-          ((amp f * amp g) / (c2 f + c2 g))-          (c0 f + c0 g-              - Complex.scale (recip (4*s)) ((c1 f - c1 g)^2))-          (Complex.scale (c2 g / s) (c1 f) +-           Complex.scale (c2 f / s) (c1 g))-          (c2 f * c2 g / s)-            -- recip $ recip (c2 f) + recip (c2 g)-{--   Cons-      (c0 f + c0 g) (c1 f + c1 g)-      (recip $ recip (c2 f) + recip (c2 g))--}--convolveByTranslation :: (Field.C a) =>-   T a -> T a -> T a-convolveByTranslation f0 g0 =-   let fd = Complex.scale (recip (2 * c2 f0)) $ c1 f0-       gd = Complex.scale (recip (2 * c2 g0)) $ c1 g0-       f1 = translateComplex fd f0-       g1 = translateComplex gd g0-   in  translateComplex (negate $ fd + gd) $-       Cons-          ((amp f0 * amp g0) / (c2 f0 + c2 g0))-          (c0 f1 + c0 g1) zero-          (recip $ recip (c2 f1) + recip (c2 g1))--convolveByFourier :: (Field.C a) =>-   T a -> T a -> T a-convolveByFourier f g =-   reverse $ fourier $ multiply (fourier f) (fourier g)--fourier :: (Field.C a) =>-   T a -> T a-fourier f =-   let a = c0 f-       b = c1 f-       c = c2 f-       rc = recip c-   in  Cons-          (amp f / c2 f)-          (Complex.scale (rc/4) (-b^2) + a)-          (Complex.scale rc $ Complex.quarterRight b)-          rc--fourierByTranslation :: (Field.C a) =>-   T a -> T a-fourierByTranslation f =-   translateComplex (Complex.scale (1/2) $ Complex.quarterLeft $ c1 f) $-   Cons (amp f / c2 f) (c0 f) zero (recip $ c2 f)--{--a + b*x + c*x^2- = c*(a/c + b/c*x + x^2)- = c*((x-b/(2*c))^2 + (4*a*c+b^2)/(4*c^2))- = c*(x-b/(2*c))^2 + (4*a*c+b^2)/(4*c)--fourier ->-   x^2/c - i*b/c*x + (4*a*c+b^2)/(4*c)--fourier (x -> exp(-pi*c*(x-t)^2))- = fourier $ translate t $ shrink (sqrt c) $ x -> exp(-pi*x^2)- = modulate t $ dilate (sqrt c) $ fourier $ x -> exp(-pi*x^2)- = modulate t $ dilate (sqrt c) $ x -> exp(-pi*x^2)- = modulate t $ x -> exp(-pi*x^2/c)- = x -> exp(-pi*x^2/c) * exp(-2*pi*i*x*t)- = x -> exp(-pi*(x^2/c - 2*i*x*t))--}--{--b*x + c*x^2- = c*(b/c*x + x^2)- = c*((x-br/(2*c))^2 + i*x*bi/c - br^2/(4*c^2))- = c*(x-br/(2*c))^2 + i*x*bi - br^2/(4*c)--fourier ->-   (x+bi/2)^2/c - i*br/c*(x+bi/2) - br^2/(4*c)- = (1/c) * ((x+bi/2)^2 - i*br*(x+bi/2) + (br/2)^2)- = (1/c) * (x^2 - i*b*x + -(br/2)^2 + (bi/2)^2 - i*br*bi/2)- = (1/c) * (x^2 - i*b*x - (br^2-bi^2+2*br*bi*i)^2 /4)- = (1/c) * (x^2 - i*b*x - b^2 / 4)- = (1/c) * (x^2 - i*b*x + (i*b/2)^2)- = (1/c) * (x - i*b/2)^2--Example:-  (x-b)^2 = b^2 - 2*b*x + x^2-    ->  (- i*2*b*x + x^2)---fourier (x -> exp(-pi*(c*(x-t)^2 + 2*i*m*x)))- = fourier $ modulate m $ translate t $ shrink (sqrt c) $ x -> exp(-pi*x^2)- = translate (-m) $ modulate t $ dilate (sqrt c) $ fourier $ x -> exp(-pi*x^2)- = translate (-m) $ modulate t $ dilate (sqrt c) $ x -> exp(-pi*x^2)- = translate (-m) $ modulate t $ x -> exp(-pi*x^2/c)- = translate (-m) $ x -> exp(-pi*x^2/c) * exp(-2*pi*i*x*t)- = x -> exp(-pi*(x+m)^2/c) * exp(-2*pi*i*(x+m)*t)- = x -> exp(-pi*((x+m)^2/c - 2*i*(x+m)*t))--}--{--fourier (Cons a 0 0) =-  Cons a 0 infinity--fourier (Cons 0 0 c) =-  Cons 0 0 (recip c)--fourier (Cons 0 b 1) =-  Cons 0 (i*b) 1--}--translate :: Ring.C a => a -> T a -> T a-translate d f =-   let a = c0 f-       b = c1 f-       c = c2 f-   in  Cons-          (amp f)-          (Complex.fromReal (c*d^2) - Complex.scale d b + a)-          (Complex.fromReal (-2*c*d) + b)-          c--translateComplex :: Ring.C a => Complex.T a -> T a -> T a-translateComplex d f =-   let a = c0 f-       b = c1 f-       c = c2 f-   in  Cons-          (amp f)-          (Complex.scale c (d^2) - b*d + a)-          (Complex.scale (-2*c) d + b)-          c--modulate :: Ring.C a => a -> T a -> T a-modulate d f =-   Cons-      (amp f)-      (c0 f)-      (c1 f + (zero +: 2*d))-      (c2 f)--turn :: Ring.C a => a -> T a -> T a-turn d f =-   Cons-      (amp f)-      (c0 f + (zero +: 2*d))-      (c1 f)-      (c2 f)--reverse :: Additive.C a => T a -> T a-reverse f =-   f{c1 = negate $ c1 f}---dilate :: Field.C a => a -> T a -> T a-dilate k f =-   Cons-      (amp f)-      (c0 f)-      (Complex.scale (recip k) $ c1 f)-      (c2 f / k^2)--shrink :: Ring.C a => a -> T a -> T a-shrink k f =-   Cons-      (amp f)-      (c0 f)-      (Complex.scale k $ c1 f)-      (k^2 * c2 f)--amplify :: (Ring.C a) => a -> T a -> T a-amplify k f =-   Cons-      (k^2 * amp f)-      (c0 f)-      (c1 f)-      (c2 f)---{- laws-fourier (convolve f g) = fourier f * fourier g--fourier (fourier f) = reverse f--}
− src/MathObj/Gaussian/Example.hs 
@@ -1,227 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{--Reciprocal of variance of a Gaussian bell curve.-We describe the curve only in terms of its variance-thus we represent a bell curve at the coordinate origin-neglecting its amplitude.--We could also define the amplitude as @root 4 c@,-thus preserving L2 norm being one,-but then @dilate@ and @shrink@ also include an amplification.--We could do some projective geometry in the exponent-in order to also have zero variance,-which corresponds to the dirac impulse.--}-module MathObj.Gaussian.Example where--import qualified MathObj.Gaussian.Polynomial as PolyBell-import qualified MathObj.Gaussian.Bell as Bell-import qualified MathObj.Gaussian.Variance as Var--import qualified MathObj.Polynomial as Poly--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic      as Algebraic-import qualified Algebra.Field          as Field--- import qualified Algebra.Real           as Real-import qualified Algebra.Ring           as Ring--- import qualified Algebra.Additive       as Additive--import qualified Number.Complex as Complex--import Algebra.Transcendental (pi, )-import Algebra.Algebraic (root, )-import Algebra.Ring ((*), (^), )--import Number.Complex ((+:), )--import qualified Numerics.Function as Func-import qualified Numerics.Fourier as Fourier-import qualified Numerics.Integration as Integ-import qualified Numerics.Differentiation as Diff--import qualified Graphics.Gnuplot.Simple as GP--import Control.Applicative (liftA2, )---- import System.Exit (ExitCode, )---- import Prelude (($))-import NumericPrelude-import PreludeBase-import qualified Prelude as P---curve0 :: Var.T Double-curve0 = curve0a--curve0a :: Var.T Double-curve0a = Var.Cons 1.4 3.3--curve0b :: Var.T Double-curve0b = Var.Cons 2.2 1.7--variance0 :: (Double, Double)-variance0 =-   (Var.variance curve0,-    (Integ.rectangular 1000 (-2,2) $ liftA2 (*) (^2) (Var.evaluate curve0)) /-    (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0))--norm10 :: (Double, Double)-norm10 =-   (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0,-    Var.norm1 curve0)--norm20 :: (Double, Double)-norm20 =-   (sqrt $ Integ.rectangular 1000 (-2,2) $ (^2) . Var.evaluate curve0,-    Var.norm2 curve0)--norm30 :: (Double, Double)-norm30 =-   (root 3 $ Integ.rectangular 1000 (-2,2) $ (^3) . Var.evaluate curve0,-    Var.normP 3 curve0)--fourier0 :: IO ()-fourier0 =-   GP.plotFuncs []-      (GP.linearScale 100 (-2,2))-      [Var.evaluate $ Var.fourier curve0,-       Fourier.analysisTransformOneReal 100 (-2,2) $ Var.evaluate curve0]--multiply0 :: IO ()-multiply0 =-   GP.plotFuncs []-      (GP.linearScale 100 (-1,1))-      [Var.evaluate $ Var.multiply curve0a curve0b,-       liftA2 (*) (Var.evaluate curve0a) (Var.evaluate curve0b)]--convolve0 :: IO ()-convolve0 =-   GP.plotFuncs []-      (GP.linearScale 100 (-2,2))-      [Var.evaluate $ Var.convolve curve0a curve0b,-       Integ.convolve 1000 (-3,3) (Var.evaluate curve0a) (Var.evaluate curve0b)]---curve1 :: Bell.T Double-curve1 = curve1a--curve1a :: Bell.T Double-curve1a = Bell.Cons 1.4 (0.1+:0.3) ((-0.2)+:1.4) 2.3--curve1b :: Bell.T Double-curve1b = Bell.Cons 2.2 ((-0.3)+:2.1) (0.2+:(-0.4)) 1.7--variance1 :: (Double, Double)-variance1 =-   (Bell.variance curve1,-    (Integ.rectangular 1000 (-2,2) $-        liftA2 (*) (^2)-           (Complex.magnitudeSqr .-            Func.translateRight-               (Complex.real (Bell.c1 curve1) / (2 * Bell.c2 curve1))-               (Bell.evaluate curve1))) /-    (Integ.rectangular 1000 (-2,2) $ Complex.magnitude . Bell.evaluate curve1))--{- the norm depends on too much things-norm0vs1 :: (Double, Double)-norm0vs1 =-   ((Integ.rectangular 1000 (-5,5) $ Var.evaluate curve0)-         * exp (- Complex.real (Bell.c0 curve1)),-    Integ.rectangular 1000 (-5,5) $ Complex.magnitude . Bell.evaluate curve1)--}--fourier1 :: IO ()-fourier1 =-   GP.plotFuncs []-      (GP.linearScale 100 (-5,5))-      [Complex.real . (Bell.evaluate $ Bell.fourier curve1),-       fourierAnalysisReal 100 (-2,2) $ Bell.evaluate curve1]---curve2 :: PolyBell.T Double-curve2 =-   PolyBell.Cons---      Bell.unit---      (Bell.Cons 1.4 (0.1+:0.3) 0 1.2)---      (Bell.Cons 1.4 (0.1+:0.3) ((-0.2)+:1.4) 1)-      curve1---      (Poly.fromCoeffs [one])---      (Poly.fromCoeffs [zero,one])---      (Poly.fromCoeffs [zero,zero,one])---      (Poly.fromCoeffs [0,Complex.imaginaryUnit])-      (Poly.fromCoeffs [1.4+:(-0.1),0.8+:(0.1),(-1.1)+:0.3])--differentiate2 :: IO ()-differentiate2 =-   GP.plotFuncs []-      (GP.linearScale 100 (-2,2))-      [Complex.real . (PolyBell.evaluateSqRt $ PolyBell.differentiate curve2),-       ((/ sqrt pi) . ) $ Diff.diff (1e-5) $ Complex.real . PolyBell.evaluateSqRt curve2]--fourier2 :: IO ()-fourier2 =-   GP.plotFuncs []-      (GP.linearScale 100 (-5,5))-      [Complex.real . (PolyBell.evaluateSqRt $ PolyBell.fourier curve2),-       fourierAnalysisReal 100 (-2,2) $ PolyBell.evaluateSqRt curve2]----fourierAnalysisReal ::-   (P.Floating a) =>-   Integer -> (a, a) -> (a -> Complex.T a) -> a -> a-fourierAnalysisReal n rng f =-   liftA2 (P.-)-      (Fourier.analysisTransformOneReal n rng (Complex.real . f))-      (Fourier.analysisTransformOneImag n rng (Complex.imag . f))---{- |-Try to approximate @\x -> exp (-x^2) * x@-by a difference of translated Gaussian bells.--exp(-x^2) * x-  ==  exp(-(a+b*x+c*x^2)) - exp(-(a-b*x+c*x^2))-  ==  exp(-(a+c*x^2)) * (exp(-b*x) - exp(b*x))-  ==  exp(-(a+c*x^2)) * 2*sinh (b*x)--It holds-  lim (\b x -> sinh (b*x) / b)  =  id--}-diffApprox :: IO ()-diffApprox =-   let amp = (2*b)^- (-2)-       a = 0-       {--       amp = 1-       a = log (2 * abs b)-       -}-       b = -0.1-       c = 1-       ac = Complex.fromReal a-       bc = Complex.fromReal b-   in  GP.plotFuncs []-          (GP.linearScale 100 (-2,2::Double))-          [Complex.real .-           (PolyBell.evaluateSqRt $-              PolyBell.Cons Bell.unit (Poly.fromCoeffs [zero,one])),-           Complex.real .-           liftA2 (-)-             (PolyBell.evaluateSqRt $-                PolyBell.Cons (Bell.Cons amp ac bc c) (Poly.fromCoeffs [one]))-             (PolyBell.evaluateSqRt $-                PolyBell.Cons (Bell.Cons amp ac (-bc) c) (Poly.fromCoeffs [one]))]---polyApprox :: IO ()-polyApprox =-   GP.plotFuncs []-      (GP.linearScale 100 (-2,2::Double))-      [Complex.real .-         PolyBell.evaluateSqRt curve2,-       Complex.real . sum .-         mapM (\(amp,b) -> \x -> amp * Bell.evaluateSqRt b x)-         (PolyBell.approximateByBells 0.1 curve2)]
− src/MathObj/Gaussian/Polynomial.hs 
@@ -1,384 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{--Complex Gaussian bell multiplied with a polynomial.--In order to make this free of @pi@ factors,-we have to choose @recip (sqrt pi)@-as unit for translations and modulations,-for linear factors and in the differentiation.--}-{--ToDo:--* In order to avoid the weird @sqrt pi@ factor,-  use a polynomial expression in @pi@.--* sum of multiple bells using Data.Map from exponent polynomial to coefficient polynomial-  use of Algebra object.--* Projective geometry in order to support Dirac impulse.--}-module MathObj.Gaussian.Polynomial where--import qualified MathObj.Gaussian.Bell as Bell--import qualified MathObj.LaurentPolynomial as LPoly-import qualified MathObj.Polynomial as Poly-import qualified Number.Complex     as Complex--import qualified Algebra.ZeroTestable   as ZeroTestable-import qualified Algebra.Differential   as Differential-import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field          as Field-import qualified Algebra.Real           as Real-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive--import Algebra.Transcendental (pi, )-import Algebra.Ring ((*), )--- import Algebra.Additive ((+))--import qualified Data.Record.HT as Rec-import qualified Data.List as List-import Data.Function.HT (nest, )-import Data.Eq.HT (equating, )-import Data.List.HT (mapAdjacent, )-import Data.Tuple.HT (forcePair, )--import Test.QuickCheck (Arbitrary, arbitrary, )-import Control.Monad (liftM2, )--import NumericPrelude-import PreludeBase hiding (reverse, )--- import Prelude ()---data T a = Cons {bell :: Bell.T a, polynomial :: Poly.T (Complex.T a)}-   deriving (Show)--instance Real.C a => Eq (T a) where-   (==) = equal--{--The derived Eq is not correct.-We have to combine the amplitude of the bell with the polynomial,-respecting signs and the square root of the bell amplitude.--}-equal :: Real.C a => T a -> T a -> Bool-equal x y =-   let bx = bell x-       by = bell y-       csign c =-          Complex.real c > 0 ||-          (Complex.real c == 0 && Complex.imag c > 0)-       scaleSqr b =-          map (\c -> (Complex.scale (Bell.amp b) (c^2), csign c)) .-          Poly.coeffs . polynomial-   in  Rec.equal-          (equating Bell.c0 :-           equating Bell.c1 :-           equating Bell.c2 :-           [])-          bx by-       &&-       scaleSqr by x == scaleSqr bx y---instance (Real.C a, Arbitrary a) => Arbitrary (T a) where-   arbitrary =---      liftM2 Cons arbitrary arbitrary-      liftM2 Cons-         arbitrary-         -- we have to restrict the number of polynomial coefficients,-         -- since with the quadratic time algorithms like fourier and convolve,-         -- in connection with Rational slow down tests too much.-         (fmap (Poly.fromCoeffs . take 5 . Poly.coeffs) arbitrary)----{-# INLINE evaluateSqRt #-}-evaluateSqRt :: (Trans.C a) =>-   T a -> a -> Complex.T a-evaluateSqRt f x =-   Bell.evaluateSqRt (bell f) x *-   Poly.evaluate (polynomial f) (Complex.fromReal $ sqrt pi * x)-{- ToDo: evaluating a complex polynomial for a real argument can be optimized -}---constant :: (Ring.C a) => T a-constant =-   Cons Bell.constant (Poly.const one)--scale :: (Ring.C a) => a -> T a -> T a-scale x f =-   f{polynomial = fmap (Complex.scale x) $ polynomial f}--scaleComplex :: (Ring.C a) => Complex.T a -> T a -> T a-scaleComplex x f =-   f{polynomial = fmap (x*) $ polynomial f}---eigenfunction :: (Field.C a) => Int -> T a-eigenfunction =-   eigenfunctionDifferential--eigenfunction0 :: (Ring.C a) => T a-eigenfunction0 =-   Cons Bell.unit (Poly.fromCoeffs [one])--eigenfunction1 :: (Ring.C a) => T a-eigenfunction1 =-   Cons Bell.unit (Poly.fromCoeffs [zero, one])--eigenfunction2 :: (Field.C a) => T a-eigenfunction2 =-   Cons Bell.unit (Poly.fromCoeffs [-(1/4), zero, one])--eigenfunction3 :: (Field.C a) => T a-eigenfunction3 =-   Cons Bell.unit (Poly.fromCoeffs [zero, -(3/4), zero, one])---eigenfunctionDifferential :: (Field.C a) => Int -> T a-eigenfunctionDifferential n =-   (\f -> f{bell = Bell.unit}) $-   nest n (scale (-1/4) . differentiate) $-   Cons (Bell.Cons one zero zero 2) one--eigenfunctionIterative :: (Field.C a, Real.C a) => Int -> T a-eigenfunctionIterative n =-   fst . head . dropWhile (uncurry (/=)) . mapAdjacent (,) $-   eigenfunctionIteration $-   Cons-      Bell.unit-      (Poly.fromCoeffs $ replicate n zero ++ [one])--eigenfunctionIteration :: (Field.C a) => T a -> [T a]-eigenfunctionIteration =-   iterate (\x ->-      let y = fourier x-          px = polynomial x-          py = polynomial y-          c = last (Poly.coeffs px) / last (Poly.coeffs py)-      in  y{polynomial = fmap (0.5*) (px + fmap (c*) py)})---multiply :: (Ring.C a) =>-   T a -> T a -> T a-multiply f g =-   Cons-      (Bell.multiply (bell f) (bell g))-      (polynomial f * polynomial g)--convolve :: (Field.C a) =>-   T a -> T a -> T a-convolve f g =-   reverse $ fourier $ multiply (fourier f) (fourier g)--{--We use a Horner like scheme-in order to translate multiplications with @id@-to differentations on the Fourier side.-Quadratic runtime.--fourier (Cons bell (Poly.const a + Poly.shift f))-  = fourier (Cons bell (Poly.const a)) + fourier (Cons bell (Poly.shift f))-  = fourier (Cons bell (Poly.const a)) + C * differentiate (fourier (Cons bell f))--}-fourier :: (Field.C a) =>-   T a -> T a-fourier f =-   foldr-      (\c p ->-          let q = differentiate p-          in  q{polynomial =-                   Poly.const c +-                   fmap (Complex.scale (1/2) . Complex.quarterLeft) (polynomial q)})-      (Cons (Bell.fourier $ bell f) zero) $-   Poly.coeffs $ polynomial f--{--Differentiate and divide by @sqrt pi@ in order to stay in a ring.-This way, we do not need to fiddle with pi factors.--}-differentiate :: (Ring.C a) => T a -> T a-differentiate f =-   f{polynomial =-        Differential.differentiate (polynomial f)-        - Differential.differentiate (Bell.exponentPolynomial (bell f))-           * polynomial f}--{--snd $ integrate $ differentiate (Cons Bell.unit (Poly.fromCoeffs [7,7,7,7]) :: T Double)--}-integrate ::-   (Field.C a, ZeroTestable.C a) =>-   T a -> (Complex.T a, T a)-integrate f =-   let fs = Poly.coeffs $ polynomial f-       (ys,~[r]) =-          Poly.divModRev-             {--             We need the shortening convention of 'zipWith'-             in order to limit the result list,-             we cannot use list instance for (-).-             -}-             (zipWith (-)-                (0 : 0 : diffRev ys)-                (List.reverse fs))-             (List.reverse $ Poly.coeffs $-              Differential.differentiate $-              Bell.exponentPolynomial $ bell f)-   in  forcePair $-       if null fs-         then (zero, f)-         else (r, f{polynomial = Poly.fromCoeffs $ List.reverse ys})--diffRev :: Ring.C a => [a] -> [a]-diffRev xs =-   zipWith (*) xs-      (drop 1 (iterate (subtract 1) (fromIntegral $ length xs)))--translate :: Ring.C a => a -> T a -> T a-translate d =-   translateComplex (Complex.fromReal d)--translateComplex :: Ring.C a => Complex.T a -> T a -> T a-translateComplex d f =-   Cons-      (Bell.translateComplex d $ bell f)-      (Poly.translate d $ polynomial f)--modulate :: Ring.C a => a -> T a -> T a-modulate d f =-   Cons-      (Bell.modulate d $ bell f)-      (polynomial f)--turn :: Ring.C a => a -> T a -> T a-turn d f =-   Cons-      (Bell.turn d $ bell f)-      (polynomial f)--reverse :: Additive.C a => T a -> T a-reverse f =-   Cons-      (Bell.reverse $ bell f)-      (Poly.reverse $ polynomial f)--dilate :: Field.C a => a -> T a -> T a-dilate k f =-   Cons-      (Bell.dilate k $ bell f)-      (Poly.dilate (Complex.fromReal k) $ polynomial f)--shrink :: Ring.C a => a -> T a -> T a-shrink k f =-   Cons-      (Bell.shrink k $ bell f)-      (Poly.shrink (Complex.fromReal k) $ polynomial f)--{--We could also amplify the polynomial coefficients.--}-amplify :: Ring.C a => a -> T a -> T a-amplify k f =-   Cons-      (Bell.amplify k $ bell f)-      (polynomial f)---{- |-Approximate a @T a@ using a linear combination of translated @Bell.T a@.-The smaller the unit (e.g. 0.1, 0.01, 0.001)-the better the approximation but the worse the numeric properties.--We cannot put all information into @amp@ of @Bell@,-since @amp@ must be real, but is complex here by construction.-We really need at least signed amplitudes at this place,-since we want to represent differences of Gaussians.--}-approximateByBells ::-   Field.C a =>-   a -> T a -> [(Complex.T a, Bell.T a)]-approximateByBells unit f =-   let b = bell f-       amps =-          -- approximateByBellsByTranslation-          approximateByBellsAtOnce-             unit-             (Complex.scale (recip (2 * Bell.c2 b)) (Bell.c1 b))-             (recip (2*unit*Bell.c2 b))-             (polynomial f)-   in  zip (LPoly.coeffs amps) $-       map-          (\d -> Bell.translate d b)-          (laurentAbscissas (unit/2) amps)--approximateByBellsAtOnce ::-   Field.C a =>-   a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a)-approximateByBellsAtOnce unit d s p =-   foldr-      (\x amps0 ->-         {--         Decompose (bell t * (t-d)) = bell t * t - bell t * d-         -}-         let y = fmap (Complex.scale s) amps0-         in  -- \t -> bell t * t-             --    ~   (translate unit bell - translate (-unit) bell) / unit-             LPoly.shift 1 y --             LPoly.shift (-1) y +-             -- bell t * d-             zipWithAbscissas-                (\t z -> (Complex.fromReal t - d) * z)-                (unit/2) amps0 +-             LPoly.const x)-      (LPoly.fromCoeffs [])-      (Poly.coeffs p)--approximateByBellsByTranslation ::-   Field.C a =>-   a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a)-approximateByBellsByTranslation unit d s p =-   foldr-      (\x amps0 ->-         {--         Decompose (bell t * (t-d)) = bell t * t - bell t * d-         -}-         let y = fmap (Complex.scale s) amps0-         in  -- \t -> bell t * t-             --    ~   (translate unit bell - translate (-unit) bell) / unit-             LPoly.shift 1 y --             LPoly.shift (-1) y +-             -- bell t * d-             zipWithAbscissas Complex.scale (unit/2) amps0 +-             LPoly.const x)-      (LPoly.fromCoeffs [])-      (Poly.coeffs $ Poly.translate d p)--zipWithAbscissas ::-   (Ring.C a) =>-   (a -> b -> c) -> a -> LPoly.T b -> LPoly.T c-zipWithAbscissas h unit y =-   LPoly.fromShiftCoeffs (LPoly.expon y) $-   zipWith h-      (laurentAbscissas unit y)-      (LPoly.coeffs y)--laurentAbscissas :: Ring.C a => a -> LPoly.T c -> [a]-laurentAbscissas unit =-   map (\d -> fromIntegral d * unit) .-   iterate (1+) . LPoly.expon---{- No Ring instance for Gaussians-instance (Ring.C a) => Differential.C (T a) where-   differentiate = differentiate--}--{- laws-differentiate (f*g) =-   (differentiate f) * g + f * (differentiate g)--}
− src/MathObj/Gaussian/Variance.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{--We represent a Gaussian bell curve in terms of the reciprocal of its variance-and its value at the origin.--We could do some projective geometry in the exponent-in order to also have zero variance,-which corresponds to the dirac impulse.--}-module MathObj.Gaussian.Variance where--import qualified MathObj.Polynomial as Poly--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Algebraic      as Algebraic-import qualified Algebra.Field          as Field-import qualified Algebra.Real           as Real-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive--{--import Algebra.Transcendental (pi, )-import Algebra.Ring ((*), (^), )-import Algebra.Additive ((+))--}-import Test.QuickCheck (Arbitrary, arbitrary, )-import Control.Monad (liftM2, )---- import Prelude (($))-import NumericPrelude-import PreludeBase---data T a = Cons {amp, c :: a}-   deriving (Eq, Show)--instance (Real.C a, Arbitrary a) => Arbitrary (T a) where-   arbitrary =-      liftM2 Cons-         arbitrary-         (fmap ((1+) . abs) arbitrary)---constant :: Ring.C a => T a-constant = Cons one zero--{-# INLINE evaluate #-}-evaluate :: (Trans.C a) =>-   T a -> a -> a-evaluate f x =-   sqrt (amp f) * exp (-pi * c f * x^2)--exponentPolynomial :: (Additive.C a) =>-   T a -> Poly.T a-exponentPolynomial f =-   Poly.fromCoeffs [zero, zero, c f]---norm1 :: (Algebraic.C a, Real.C a) => T a -> a-norm1 f =-   sqrt $ abs (amp f) / c f--norm2 :: (Algebraic.C a, Real.C a) => T a -> a-norm2 f =-   sqrt $ abs (amp f) / (sqrt $ 2 * c f)--normP :: (Trans.C a, Real.C a) => a -> T a -> a-normP p f =-   sqrt (abs (amp f)) * (p * c f) ^? (- recip (2*p))---variance :: (Trans.C a) =>-   T a -> a-variance f =-   recip $ c f * 2*pi--multiply :: (Ring.C a) =>-   T a -> T a -> T a-multiply f g =-   Cons (amp f * amp g) (c f + c g)--{- |-> convolve x y t =->    integrate $ \s -> x s * y(t-s)--}-convolve :: (Field.C a) =>-   T a -> T a -> T a-convolve f g =-   Cons-      (amp f * amp g / (c f + c g))-      (recip $ recip (c f) + recip (c g))--{- |-> fourier x f =->    integrate $ \t -> x t * cis (-2*pi*t*f)--}-fourier :: (Field.C a) =>-   T a -> T a-fourier f =-   Cons (amp f / c f) (recip $ c f)-{--fourier (t -> exp(-(a*t)^2))--}--dilate :: (Field.C a) => a -> T a -> T a-dilate k f =-   Cons (amp f) $ c f / k^2--shrink :: (Ring.C a) => a -> T a -> T a-shrink k f =-   Cons (amp f) $ c f * k^2--amplify :: (Ring.C a) => a -> T a -> T a-amplify k f =-   Cons (k^2 * amp f) $ c f---{- laws-fourier (convolve f g) = multiply (fourier f) (fourier g)--dilate k (dilate m f) = dilate (k*m) f--dilate k (shrink k f) = f--variance (dilate k f) = k^2 * variance f--variance (convolve f g) = variance f + variance g--}
src/MathObj/LaurentPolynomial.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |@@ -14,6 +14,7 @@  import qualified MathObj.Polynomial  as Poly import qualified MathObj.PowerSeries as PS+import qualified MathObj.PowerSeries.Core as PSCore  import qualified Algebra.VectorSpace  as VectorSpace import qualified Algebra.Module       as Module@@ -25,14 +26,10 @@  import qualified Number.Complex as Complex -import Algebra.ZeroTestable(isZero)-import Algebra.Module((*>))--import qualified PreludeBase as P-import qualified NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP -import PreludeBase    hiding (const, reverse, )-import NumericPrelude hiding (div, negate, )+import NumericPrelude.Base    hiding (const, reverse, )+import NumericPrelude.Numeric hiding (div, negate, )  import qualified Data.List as List import Data.List.HT (mapAdjacent)@@ -163,7 +160,7 @@  addShifted :: Additive.C a => Int -> [a] -> [a] -> [a] addShifted del px py =-   let recurse 0 x      = PS.add x py+   let recurse 0 x      = PSCore.add x py        recurse d []     = replicate d zero ++ py        recurse d (x:xs) = x : recurse (d-1) xs    in  if del >= 0@@ -186,9 +183,6 @@  {- * Module -} -scale :: Ring.C a => a -> [a] -> [a]-scale = Poly.scale- instance Vector.C T where    zero  = zero    (<+>) = (+)@@ -203,7 +197,7 @@ {- * Ring -}  mul :: Ring.C a => T a -> T a -> T a-mul (Cons xt x) (Cons yt y) = Cons (xt+yt) (PS.mul x y)+mul (Cons xt x) (Cons yt y) = Cons (xt+yt) (PSCore.mul x y)  instance (Ring.C a) => Ring.C (T a) where     one           = const one@@ -218,7 +212,7 @@    let (xzero,x) = span isZero xs        (yzero,y) = span isZero ys    in  Cons (xt - yt + length xzero - length yzero)-            (PS.divide x y)+            (PSCore.divide x y)  instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where    (/) = div
src/MathObj/Matrix.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |@@ -18,7 +18,7 @@ but no additional parameters.  ToDo:- - Matrix inverse, determinant+ - Matrix inverse, determinant (see htam:Matrix) -}  module MathObj.Matrix (@@ -27,6 +27,7 @@    transpose,    rows,    columns,+   index,    fromRows,    fromColumns,    fromList,@@ -58,24 +59,65 @@ import Control.Monad (liftM2, ) import Control.Exception (assert, ) +import Data.Function.HT (powerAssociative, ) import Data.Tuple.HT (swap, mapFst, ) import Data.List.HT (outerProduct, )+import Text.Show.HT (concatS, ) -import NumericPrelude (Int, )-import PreludeBase hiding (zipWith, )+import NumericPrelude.Numeric (Int, )+import NumericPrelude.Base hiding (zipWith, )  +{- $setup+>>> import qualified MathObj.Matrix as Matrix+>>> import qualified Algebra.Ring as Ring+>>> import qualified Algebra.Laws as Laws+>>> import Test.NumericPrelude.Utility ((/\))+>>> import qualified Test.QuickCheck as QC+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base as P+>>> import Prelude ()+>>>+>>> import Control.Monad (replicateM, join)+>>> import Control.Applicative (liftA2)+>>> import Data.Function.HT (nest)+>>>+>>> genDimension :: QC.Gen Int+>>> genDimension = QC.choose (0,20)+>>>+>>> genMatrixFor :: (QC.Arbitrary a) => Int -> Int -> QC.Gen (Matrix.T a)+>>> genMatrixFor m n =+>>>    fmap (Matrix.fromList m n) $ replicateM (m*n) QC.arbitrary+>>>+>>> genMatrix :: (QC.Arbitrary a) => QC.Gen (Matrix.T a)+>>> genMatrix = join $ liftA2 genMatrixFor genDimension genDimension+>>>+>>> genIntMatrix :: QC.Gen (Matrix.T Integer)+>>> genIntMatrix = genMatrix+>>>+>>> genFactorMatrix :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a)+>>> genFactorMatrix a = genMatrixFor (Matrix.numColumns a) =<< genDimension+>>>+>>> genSameMatrix :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a)+>>> genSameMatrix = uncurry genMatrixFor . Matrix.dimension+-}++ {- | A matrix is a twodimensional array, indexed by integers. -}-data T a =+newtype T a =    Cons (Array (Dimension, Dimension) a)-      deriving (Eq,Ord,Read)+      deriving (Eq, Ord, Read)  type Dimension = Int  {- | Transposition of matrices is just transposition in the sense of Data.List.++prop> genIntMatrix /\ \a -> Matrix.rows a == Matrix.columns (Matrix.transpose a)+prop> genIntMatrix /\ \a -> Matrix.columns a == Matrix.rows (Matrix.transpose a)+prop> genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (+) (+) a b -} transpose :: T a -> T a transpose (Cons m) =@@ -83,15 +125,21 @@    in  Cons (ixmap (swap lower, swap upper) swap m)  rows :: T a -> [[a]]-rows (Cons m) =+rows mM@(Cons m) =    let ((lr,lc), (ur,uc)) = bounds m-   in  outerProduct (curry(m!)) (range (lr,ur)) (range (lc,uc))+   in  outerProduct (index mM) (range (lr,ur)) (range (lc,uc))  columns :: T a -> [[a]]-columns (Cons m) =+columns mM@(Cons m) =    let ((lr,lc), (ur,uc)) = bounds m-   in  outerProduct (flip(curry(m!))) (range (lc,uc)) (range (lr,ur))+   in  outerProduct (flip (index mM)) (range (lc,uc)) (range (lr,ur)) +index :: T a -> Dimension -> Dimension -> a+index (Cons m) i j = m ! (i,j)++{- |+prop> genIntMatrix /\ \a -> a == uncurry Matrix.fromRows (Matrix.dimension a) (Matrix.rows a)+-} fromRows :: Dimension -> Dimension -> [[a]] -> T a fromRows m n =    Cons .@@ -100,6 +148,9 @@    List.zipWith (\r -> map (\(c,x) -> ((r,c),x))) allIndices .    map (zip allIndices) +{- |+prop> genIntMatrix /\ \a -> a == uncurry Matrix.fromColumns (Matrix.dimension a) (Matrix.columns a)+-} fromColumns :: Dimension -> Dimension -> [[a]] -> T a fromColumns m n =    Cons .@@ -129,9 +180,6 @@    map (List.intersperse (' ':) . map (showsPrec 11)) .    rows -concatS :: [ShowS] -> ShowS-concatS = flip (foldr ($))- dimension :: T a -> (Dimension,Dimension) dimension (Cons m) = uncurry subtract (bounds m) + (1,1) @@ -143,6 +191,10 @@  -- These implementations may benefit from a better exception than -- just assertions to validate dimensionalities+{- |+prop> genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.commutative (+) a b+prop> genIntMatrix /\ \a -> genSameMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.associative (+) a b c+-} instance (Additive.C a) => Additive.C (T a) where    (+) = zipWith (+)    (-) = zipWith (-)@@ -156,6 +208,9 @@    in  assert (d == dimension nM) $          uncurry fromList d (List.zipWith op em en) +{- |+prop> genIntMatrix /\ \a -> Laws.identity (+) (uncurry Matrix.zero $ Matrix.dimension a) a+-} zero :: (Additive.C a) => Dimension -> Dimension -> T a zero m n =    fromList m n $@@ -169,6 +224,9 @@       (indexBounds n n)       (map (\i -> ((i,i), Ring.one)) (indexRange n)) +{- |+prop> genDimension /\ \n -> Matrix.one n == Matrix.diagonal (replicate n Ring.one :: [Integer])+-} diagonal :: (Additive.C a) => [a] -> T a diagonal xs =    let n = List.length xs@@ -180,12 +238,25 @@ scale :: (Ring.C a) => a -> T a -> T a scale s = Vector.functorScale s +{- |+prop> genIntMatrix /\ \a -> Laws.leftIdentity  (*) (Matrix.one (Matrix.numRows a)) a+prop> genIntMatrix /\ \a -> Laws.rightIdentity (*) (Matrix.one (Matrix.numColumns a)) a+prop> genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (*) (flip (*)) a b+prop> genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genFactorMatrix b /\ \c -> Laws.associative (*) a b c+prop> genIntMatrix /\ \b -> genSameMatrix b /\ \c -> genFactorMatrix b /\ \a -> Laws.leftDistributive (*) (+) a b c+prop> genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.rightDistributive (*) (+) a b c+prop> QC.choose (0,10) /\ \k -> genDimension /\ \n -> genMatrixFor n n /\ \a -> a^k == nest (fromInteger k) ((a::Matrix.T Integer)*) (Matrix.one n)+-} instance (Ring.C a) => Ring.C (T a) where    mM * nM =       assert (numColumns mM == numRows nM) $-      fromList (numRows mM) (numColumns nM)-         (liftM2 scalarProduct (rows mM) (columns nM))+      fromList (numRows mM) (numColumns nM) $+      liftM2 scalarProduct (rows mM) (columns nM)    fromInteger n = fromList 1 1 [fromInteger n]+   mM ^ n =+      assert (numColumns mM == numRows mM) $+      assert (n >= Additive.zero) $+      powerAssociative (*) (one (numColumns mM)) mM n  instance Functor T where    fmap f (Cons m) = Cons (fmap f m)
src/MathObj/Monoid.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module MathObj.Monoid where  import qualified Algebra.PrincipalIdealDomain as PID@@ -7,7 +7,7 @@ import Algebra.Additive (zero, ) import Algebra.Monoid (C, idt, (<*>), ) -import PreludeBase+import NumericPrelude.Base  {- | It is only a monoid for non-negative numbers.
src/MathObj/PartialFraction.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright    :   (c) Henning Thielemann 2007 Maintainer   :   numericprelude@henning-thielemann.de@@ -16,7 +16,6 @@ import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.IntegralDomain       as Integral import qualified Number.Ratio                 as Ratio-import qualified Algebra.Field                as Field import qualified Algebra.Ring                 as Ring import qualified Algebra.Additive             as Additive import qualified Algebra.ZeroTestable         as ZeroTestable@@ -30,21 +29,89 @@ import Algebra.Additive((+), zero, negate) import Algebra.ZeroTestable (isZero) +import qualified Data.List.Reverse.StrictSpine as Rev+import qualified Data.List.Match as Match import qualified Data.List as List--import Data.Map(Map) import qualified Data.Map as Map-import Data.Maybe(fromMaybe, )-import qualified Data.List.Match as Match-import Data.List.HT (dropWhileRev, )-import Data.List (group, sortBy, mapAccumR, )+import Data.Map (Map)+import Data.List (group, sortBy, mapAccumR)+import Data.Maybe (fromMaybe) -import PreludeBase hiding (zipWith)+import NumericPrelude.Base hiding (zipWith) -import NumericPrelude(Int, fromInteger)+import NumericPrelude.Numeric(Int, fromInteger)  +{- $setup+>>> import qualified MathObj.PartialFraction as PartialFraction+>>> import qualified MathObj.Polynomial.Core as PolyCore+>>> import qualified MathObj.Polynomial as Poly+>>> import qualified Algebra.PrincipalIdealDomain as PID+>>> import qualified Algebra.Indexable as Indexable+>>> import qualified Algebra.Laws as Laws+>>> import qualified Number.Ratio as Ratio+>>> import Test.NumericPrelude.Utility ((/\))+>>> import qualified Test.QuickCheck as QC+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base as P+>>> import Prelude ()+>>>+>>> import Control.Applicative (liftA2)+>>>+>>> {- |+>>> Generator of irreducible elements for tests.+>>> Choosing from a list of examples is a simple yet effective design.+>>> If we would construct irreducible elements by a clever algorithm+>>> we might obtain multiple primes only rarely.+>>> -} --+>>> genSmallPrime :: QC.Gen Integer+>>> genSmallPrime =+>>>    let primes = [2,3,5,7,11,13]+>>>    in  QC.elements (primes ++ map negate primes)+>>>+>>> genPartialFractionInt :: QC.Gen (PartialFraction.T Integer)+>>> genPartialFractionInt =+>>>    liftA2 PartialFraction.fromFactoredFraction+>>>       (QC.listOf genSmallPrime) QC.arbitrary+>>>+>>>+>>> genIrreduciblePolynomial :: QC.Gen (Poly.T Rational)+>>> genIrreduciblePolynomial = do+>>>    QC.NonZero unit <- QC.arbitrary+>>>    fmap (Poly.fromCoeffs . map (unit*)) $+>>>       QC.elements [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]]+>>>+>>> genPartialFractionPoly :: QC.Gen (PartialFraction.T (Poly.T Rational))+>>> genPartialFractionPoly =+>>>    liftA2 PartialFraction.fromFactoredFraction+>>>       (fmap (take 3) $ QC.listOf genIrreduciblePolynomial)+>>>       (fmap (Poly.fromCoeffs . PolyCore.normalize . take 5) QC.arbitrary)+>>>+>>>+>>> fractionConv :: (PID.C a, Indexable.C a) => [a] -> a -> Bool+>>> fractionConv xs y =+>>>    PartialFraction.toFraction (PartialFraction.fromFactoredFraction xs y) ==+>>>    y % product xs+>>>+>>> fractionConvAlt :: (PID.C a, Indexable.C a) => [a] -> a -> Bool+>>> fractionConvAlt xs y =+>>>    PartialFraction.fromFactoredFraction xs y ==+>>>    PartialFraction.fromFactoredFractionAlt xs y+>>>+>>> scaleInt :: (PID.C a, Indexable.C a) => a -> PartialFraction.T a -> Bool+>>> scaleInt k a =+>>>    PartialFraction.toFraction (PartialFraction.scaleInt k a) ==+>>>    Ratio.scale k (PartialFraction.toFraction a)+>>>+>>> add, sub, mul ::+>>>    (PID.C a, Indexable.C a) =>+>>>    PartialFraction.T a -> PartialFraction.T a -> Bool+>>> add = Laws.homomorphism PartialFraction.toFraction (+) (+)+>>> sub = Laws.homomorphism PartialFraction.toFraction (-) (-)+>>> mul = Laws.homomorphism PartialFraction.toFraction (*) (*)+-} + {- | @Cons z (indexMapFromList [(x0,[y00,y01]), (x1,[y10]), (x2,[y20,y21,y22])])@ represents the partial fraction@@ -124,6 +191,9 @@ There are more direct methods for special cases like polynomials over rational numbers where the denominators are linear factors.++prop> QC.listOf genSmallPrime /\ fractionConv+prop> fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConv -} fromFactoredFraction :: (PID.C a, Indexable.C a) => [a] -> a -> T a fromFactoredFraction denoms0 numer0 =@@ -146,6 +216,10 @@        -- Is reduceHeads also necessary for polynomial partial fractions?    in  removeZeros $ reduceHeads $ Cons intPart (indexMapFromList pairs) +{- |+prop> QC.listOf genSmallPrime /\ fractionConvAlt+prop> fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConvAlt+-} fromFactoredFractionAlt :: (PID.C a, Indexable.C a) => [a] -> a -> T a fromFactoredFractionAlt denoms numer =    foldl (\p d -> scaleFrac (one%d) p) (fromValue numer) denoms@@ -206,9 +280,7 @@ -} removeZeros :: (Indexable.C a, ZeroTestable.C a) => T a -> T a removeZeros (Cons z m) =-   Cons z $-   Map.filter (not . null) $-   Map.map (dropWhileRev isZero) m+   Cons z $ Map.filter (not . null) $ Map.map (Rev.dropWhile isZero) m   {-@@ -221,7 +293,16 @@ zipWith opS opV (Cons za ma) (Cons zb mb) =    Cons (opS za zb) (Map.unionWith opV ma mb) -instance (Indexable.C a, Integral.C a, ZeroTestable.C a) => Additive.C (T a) where+{- |+prop> genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> add x y+prop> genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> sub x y++prop> genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> add x y+prop> genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> sub x y+-}+instance+   (Indexable.C a, Integral.C a, ZeroTestable.C a) =>+      Additive.C (T a) where    a + b = removeZeros $ normalizeModulo $ zipWith (+) (+) a b    {- This implementation is attracting but wrong.      It fails if terms are present in b that are missing in a.@@ -271,8 +352,8 @@    in  if (isZero r)          then ((q*a, q*b), zero)          else-           let fx = safeDiv dx g-               fy = safeDiv dy g+           let fx = divChecked dx g+               fy = divChecked dy g                (g,(k,c)) = extendedGCD (g^2) (fx*fy)  given dx=fx*g and dy=fy*g with fx and fy are relatively prime:@@ -344,6 +425,10 @@              (uncurry (:) . carryRipple ds . map (ns*))              scaleFracs m) +{- |+prop> genPartialFractionInt /\ \x k -> scaleInt k x+prop> genPartialFractionPoly /\ \x k -> scaleInt k x+-} scaleInt :: (PID.C a, Indexable.C a) => a -> T a -> T a scaleInt x (Cons z m) =    removeZeros $ normalizeModulo $@@ -360,6 +445,10 @@                  scaleFrac (one%d) (scaleInt numer a + acc)) zero l)            (indexMapToList m)) +{- |+prop> genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> mul x y+prop> genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> mul x y+-} mulFast :: (PID.C a, Indexable.C a) => T a -> T a -> T a mulFast pa pb =    let ra = toFactoredFraction pa
src/MathObj/Permutation.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright    :   (c) Henning Thielemann 2006 Maintainer   :   numericprelude@henning-thielemann.de@@ -16,8 +16,6 @@  import Data.Array(Ix) --- import NumericPrelude (Integer)-import PreludeBase   {- |
src/MathObj/Permutation/CycleList.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright    :   (c) Mikael Johansson 2006 Maintainer   :   mik@math.uni-jena.de@@ -19,8 +19,8 @@  import qualified Data.List.Match as Match import Data.Maybe.HT (toMaybe)-import NumericPrelude (fromInteger)-import PreludeBase+import NumericPrelude.Numeric (fromInteger)+import NumericPrelude.Base   type Cycle i = [i]
src/MathObj/Permutation/CycleList/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright    :   (c) Henning Thielemann 2006 Maintainer   :   numericprelude@henning-thielemann.de@@ -12,20 +12,13 @@ import qualified MathObj.Permutation.Table     as PermTable import qualified MathObj.Permutation           as Perm -{--import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive-import Algebra.Ring((*),one,fromInteger)-import Algebra.Additive((+))--}-import Algebra.Monoid((<*>)) import qualified Algebra.Monoid as Monoid+import Algebra.Monoid((<*>)) -import Data.Array((!), Ix) import qualified Data.Array as Array+import Data.Array((!), Ix) --- import NumericPrelude (Integer)-import PreludeBase hiding (cycle)+import NumericPrelude.Base hiding (cycle)  {- | We shall make a little bit of a hack here, enabling us to use additive
src/MathObj/Permutation/Table.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright    :   (c) Henning Thielemann 2006 Maintainer   :   numericprelude@henning-thielemann.de@@ -23,8 +23,7 @@ import Data.Tuple.HT (swap, ) import Data.Maybe.HT (toMaybe, ) --- import NumericPrelude (Integer)-import PreludeBase hiding (cycle)+import NumericPrelude.Base hiding (cycle)   type T i = Array i i
src/MathObj/Polynomial.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -44,20 +44,17 @@ -}  module MathObj.Polynomial-   (T, fromCoeffs, coeffs,+   (T, fromCoeffs, coeffs, degree,     showsExpressionPrec, const,     evaluate, evaluateCoeffVector, evaluateArgVector,-    compose, equal, add, sub, negate,-    horner, hornerCoeffVector, hornerArgVector,-    shift, unShift,-    mul, scale, divMod, divModRev,-    tensorProduct, tensorProductAlt,-    mulShear, mulShearTranspose,-    progression, differentiate, integrate, integrateInt,-    fromRoots, alternate, reverse,+    collinear,+    integrate,+    compose, fromRoots, reverse,     translate, dilate, shrink, ) where +import qualified MathObj.Polynomial.Core as Core+ import qualified Algebra.Differential         as Differential import qualified Algebra.VectorSpace          as VectorSpace import qualified Algebra.Module               as Module@@ -71,29 +68,51 @@ import qualified Algebra.ZeroTestable         as ZeroTestable import qualified Algebra.Indexable            as Indexable -import Algebra.Module((*>))-import Algebra.ZeroTestable(isZero)- import Control.Monad (liftM, ) import qualified Data.List as List-import NumericPrelude.List (zipWithOverlap, )-import Data.Tuple.HT (mapPair, mapFst, forcePair, )-import Data.List.HT-          (dropWhileRev, switchL, shear, shearTranspose, outerProduct, )  import Test.QuickCheck (Arbitrary(arbitrary)) -import qualified Prelude     as P98-import qualified PreludeBase as P-import qualified NumericPrelude as NP+import qualified MathObj.Wrapper.Haskell98 as W98 -import PreludeBase    hiding (const, reverse, )-import NumericPrelude hiding (divMod, negate, stdUnit, )+import NumericPrelude.Base    hiding (const, reverse, )+import NumericPrelude.Numeric +import qualified Prelude as P98 ++{- $setup+>>> import qualified MathObj.Polynomial as Poly+>>> import qualified Algebra.IntegralDomain as Integral+>>> import qualified Algebra.Laws as Laws+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>> intPoly :: Poly.T Integer -> Poly.T Integer+>>> intPoly = id+>>>+>>> ratioPoly :: Poly.T Rational -> Poly.T Rational+>>> ratioPoly = id+-}++{- |+prop> Laws.identity (+) zero . intPoly+prop> Laws.commutative (+) . intPoly+prop> Laws.associative (+) . intPoly+prop> Laws.identity (*) one . intPoly+prop> Laws.commutative (*) . intPoly+prop> Laws.associative (*) . intPoly+prop> Laws.leftDistributive (*) (+) . intPoly+prop> Integral.propInverse . ratioPoly+-} newtype T a = Cons {coeffs :: [a]} +{-+>>> import Test.QuickCheck ((==>))+-} + {-# INLINE fromCoeffs #-} fromCoeffs :: [a] -> T a fromCoeffs = lift0@@ -110,13 +129,19 @@ lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) +degree :: (ZeroTestable.C a) => T a -> Maybe Int+degree x =+   case Core.normalize (coeffs x) of+      [] -> Nothing+      (_:xs) -> Just $ length xs+ {- Functor instance is e.g. useful for showing polynomials in residue rings. @fmap (ResidueClass.concrete 7) (polynomial [1,4,4::ResidueClass.T Integer] * polynomial [1,5,6])@ -}  instance Functor T where-  fmap f (Cons xs) = Cons (map f xs)+   fmap f (Cons xs) = Cons (map f xs)  {-# INLINE plusPrec #-} {-# INLINE appPrec #-}@@ -125,8 +150,8 @@ appPrec  = 10  instance (Show a) => Show (T a) where-  showsPrec p (Cons xs) =-    showParen (p >= appPrec) (showString "Polynomial.fromCoeffs " . shows xs)+   showsPrec p (Cons xs) =+      showParen (p >= appPrec) (showString "Polynomial.fromCoeffs " . shows xs)  {-# INLINE showsExpressionPrec #-} showsExpressionPrec :: (Show a, ZeroTestable.C a, Additive.C a) =>@@ -147,28 +172,10 @@            (foldl (.) id $ List.intersperse (showString " + ") $             map (uncurry showsTerm) terms) -{- |-Horner's scheme for evaluating a polynomial in a ring.--}-{-# INLINE horner #-}-horner :: Ring.C a => a -> [a] -> a-horner x = foldr (\c val -> c+x*val) zero -{- |-Horner's scheme for evaluating a polynomial in a module.--}-{-# INLINE hornerCoeffVector #-}-hornerCoeffVector :: Module.C a v => a -> [v] -> v-hornerCoeffVector x = foldr (\c val -> c+x*>val) zero--{-# INLINE hornerArgVector #-}-hornerArgVector :: (Module.C a v, Ring.C v) => v -> [a] -> v-hornerArgVector x = foldr (\c val -> c*>one+val*x) zero-- {-# INLINE evaluate #-} evaluate :: Ring.C a => T a -> a -> a-evaluate (Cons y) x = horner x y+evaluate (Cons y) x = Core.horner x y  {- | Here the coefficients are vectors,@@ -176,7 +183,7 @@ -} {-# INLINE evaluateCoeffVector #-} evaluateCoeffVector :: Module.C a v => T v -> a -> v-evaluateCoeffVector (Cons y) x = hornerCoeffVector x y+evaluateCoeffVector (Cons y) x = Core.hornerCoeffVector x y  {- | Here the argument is a vector,@@ -185,7 +192,7 @@ -} {-# INLINE evaluateArgVector #-} evaluateArgVector :: (Module.C a v, Ring.C v) => T a -> v -> v-evaluateArgVector (Cons y) x = hornerArgVector x y+evaluateArgVector (Cons y) x = Core.hornerArgVector x y  {- | 'compose' is the functional composition of polynomials.@@ -195,70 +202,35 @@ -}  -- compose :: Module.C a b => T b -> T a -> T a--- compose (Cons x) y = horner y (map const x)+-- compose (Cons x) y = Core.horner y (map const x) {-# INLINE compose #-} compose :: (Ring.C a) => T a -> T a -> T a-compose (Cons x) y = horner y (map const x)--{- |-It's also helpful to put a polynomial in canonical form.-'normalize' strips leading coefficients that are zero.--}--{-# INLINE normalize #-}-normalize :: (ZeroTestable.C a) => [a] -> [a]-normalize = dropWhileRev isZero--{- |-Multiply by the variable, used internally.--}--{-# INLINE shift #-}-shift :: (Additive.C a) => [a] -> [a]-shift [] = []-shift l  = zero : l--{-# INLINE unShift #-}-unShift :: [a] -> [a]-unShift []     = []-unShift (_:xs) = xs+compose (Cons x) y = Core.horner y (map const x)  {-# INLINE const #-} const :: a -> T a const x = lift0 [x] -{-# INLINE equal #-}-equal :: (Eq a, ZeroTestable.C a) => [a] -> [a] -> Bool-equal x y = and (zipWithOverlap isZero isZero (==) x y) +collinear :: (Eq a, Ring.C a) => T a -> T a -> Bool+collinear (Cons x) (Cons y) = Core.collinear x y++ instance (Eq a, ZeroTestable.C a) => Eq (T a) where-  (Cons x) == (Cons y) = equal x y+   (Cons x) == (Cons y) = Core.equal x y  instance (Indexable.C a, ZeroTestable.C a) => Indexable.C (T a) where-  compare = Indexable.liftCompare coeffs+   compare = Indexable.liftCompare coeffs  instance (ZeroTestable.C a) => ZeroTestable.C (T a) where-  isZero (Cons x) = isZero x+   isZero (Cons x) = isZero x  -add, sub :: (Additive.C a) => [a] -> [a] -> [a]-add = (+)-sub = (-)--{-# INLINE negate #-}-negate :: (Additive.C a) => [a] -> [a]-negate = map NP.negate- instance (Additive.C a) => Additive.C (T a) where-  (+)    = lift2 add-  (-)    = lift2 sub-  zero   = lift0 []-  negate = lift1 negate---{-# INLINE scale #-}-scale :: Ring.C a => a -> [a] -> [a]-scale s = map (s*)+   (+)    = lift2 Core.add+   (-)    = lift2 Core.sub+   zero   = lift0 []+   negate = lift1 Core.negate   instance Vector.C T where@@ -272,81 +244,29 @@ instance (Field.C a, Module.C a b) => VectorSpace.C a (T b)  -{-# INLINE tensorProduct #-}-tensorProduct :: Ring.C a => [a] -> [a] -> [[a]]-tensorProduct = outerProduct (*)--tensorProductAlt :: Ring.C a => [a] -> [a] -> [[a]]-tensorProductAlt xs ys = map (flip scale ys) xs--{- |-'mul' is fast if the second argument is a short polynomial,-'MathObj.PowerSeries.**' relies on that fact.--}--{-# INLINE mul #-}-mul :: Ring.C a => [a] -> [a] -> [a]-{- prevent from generation of many zeros-   if the first operand is the empty list -}-mul [] = P.const []-mul xs = foldr (\y zs -> let (v:vs) = scale y xs in v : add vs zs) []--- this one fails on infinite lists---    mul xs = foldr (\y zs -> add (scale y xs) (shift zs)) []--{-# INLINE mulShear #-}-mulShear :: Ring.C a => [a] -> [a] -> [a]-mulShear xs ys = map sum (shear (tensorProduct xs ys))--{-# INLINE mulShearTranspose #-}-mulShearTranspose :: Ring.C a => [a] -> [a] -> [a]-mulShearTranspose xs ys = map sum (shearTranspose (tensorProduct xs ys))- instance (Ring.C a) => Ring.C (T a) where-  one         = const one-  fromInteger = const . fromInteger-  (*)         = lift2 mul+   one         = const one+   fromInteger = const . fromInteger+   (*)         = lift2 Core.mul  -divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a])-divMod x y =-   mapPair (List.reverse, List.reverse) $-   divModRev (List.reverse x) (List.reverse y)--{--snd $ Poly.divMod (repeat (1::Double)) [1,1]+{- |+The 'Integral.C' instance is intensionally built+from the 'Field.C' structure of the polynomial coefficients.+If we would use @Integral.C a@ superclass,+then the Euclidean algorithm could not determine+the greatest common divisor of e.g. @[1,1]@ and @[2]@. -}-divModRev :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a])-divModRev x y =-   let (y0:ys) = dropWhile isZero y-       -- the second parameter represents lazily (length x - length y)-       aux xs' =-         forcePair .-         switchL-           ([], xs')-           (P.const $-              let (x0:xs) = xs'-                  q0      = x0/y0-              in  mapFst (q0:) . aux (sub xs (scale q0 ys)))-   in  if isZero y-         then error "MathObj.Polynomial: division by zero"-         else aux x (drop (length y - 1) x)- instance (ZeroTestable.C a, Field.C a) => Integral.C (T a) where-  divMod (Cons x) (Cons y) =-     let (d,m) = divMod x y-     in  (Cons d, Cons m)--{-# INLINE stdUnit #-}-stdUnit :: (ZeroTestable.C a, Ring.C a) => [a] -> a-stdUnit x = case normalize x of-    [] -> one-    l  -> last l+   divMod (Cons x) (Cons y) =+      let (d,m) = Core.divMod x y+      in  (Cons d, Cons m)  instance (ZeroTestable.C a, Field.C a) => Units.C (T a) where-  isUnit (Cons []) = False-  isUnit (Cons (x0:xs)) = not (isZero x0) && all isZero xs-  stdUnit    (Cons x) = const        (stdUnit x)-  stdUnitInv (Cons x) = const (recip (stdUnit x))+   isUnit (Cons []) = False+   isUnit (Cons (x0:xs)) = not (isZero x0) && all isZero xs+   stdUnit    (Cons x) = const        (Core.stdUnit x)+   stdUnitInv (Cons x) = const (recip (Core.stdUnit x))  {- Polynomials are a Euclidean domain, so no instance is necessary@@ -355,80 +275,41 @@  instance (ZeroTestable.C a, Field.C a) => PID.C (T a) -{-# INLINE progression #-}-progression :: Ring.C a => [a]-progression = iterate (one+) one -{-# INLINE differentiate #-}-differentiate :: (Ring.C a) => [a] -> [a]-differentiate = zipWith (*) progression . drop 1+instance (Ring.C a) => Differential.C (T a) where+   differentiate = lift1 Core.differentiate + {-# INLINE integrate #-}-integrate :: (Field.C a) => a -> [a] -> [a]-integrate c x = c : zipWith (/) x progression+integrate :: (Field.C a) => a -> T a -> T a+integrate = lift1 . Core.integrate -{- |-Integrates if it is possible to represent the integrated polynomial-in the given ring.-Otherwise undefined coefficients occur.--}-{-# INLINE integrateInt #-}-integrateInt :: (ZeroTestable.C a, Integral.C a) => a -> [a] -> [a]-integrateInt c x =-   c : zipWith Integral.safeDiv x progression  -instance (Ring.C a) => Differential.C (T a) where-  differentiate = lift1 differentiate-- {-# INLINE fromRoots #-} fromRoots :: (Ring.C a) => [a] -> T a-fromRoots = Cons . foldl (flip mulLinearFactor) [1]--{-# INLINE mulLinearFactor #-}-mulLinearFactor :: Ring.C a => a -> [a] -> [a]-mulLinearFactor x yt@(y:ys) = Additive.negate (x*y) : yt - scale x ys-mulLinearFactor _ [] = []--{-# INLINE alternate #-}-alternate :: Additive.C a => [a] -> [a]-alternate = zipWith ($) (cycle [id, Additive.negate])+fromRoots = Cons . foldl (flip Core.mulLinearFactor) [one]  {-# INLINE reverse #-} reverse :: Additive.C a => T a -> T a-reverse = lift1 alternate+reverse = lift1 Core.alternate  translate :: Ring.C a => a -> T a -> T a translate d =-   lift1 $ foldr (\c p -> [c] + mulLinearFactor d p) []+   lift1 $ foldr (\c p -> [c] + Core.mulLinearFactor d p) []  shrink :: Ring.C a => a -> T a -> T a-shrink k =-   lift1 $ zipWith (*) (iterate (k*) one)+shrink = lift1 . Core.shrink  dilate :: Field.C a => a -> T a -> T a-dilate = shrink . Field.recip+dilate = lift1 . Core.dilate -{--see htam: Wavelet/DyadicResultant -resultant :: Ring.C a => [a] -> [a] -> [a]-resultant xs ys =--discriminant :: Ring.C a => [a] -> a-discriminant xs =-   let degree = genericLength xs-   in  parityFlip (safeDiv (degree*(degree-1)) 2)-                  (resultant xs (differentiate xs))-          `safeDiv` last xs--}- instance (Arbitrary a, ZeroTestable.C a) => Arbitrary (T a) where-   arbitrary = liftM (fromCoeffs . normalize) arbitrary+   arbitrary = liftM (fromCoeffs . Core.normalize) arbitrary  -{- * legacy instances -}+-- * Haskell 98 legacy instances  {- | It is disputable whether polynomials shall be represented by number literals or not.@@ -437,19 +318,20 @@ in  (x^2+x+1)*(x-1) However the output looks much different. -}-{-# INLINE legacyInstance #-}-legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"+{-# INLINE notImplemented #-}+notImplemented :: String -> a+notImplemented name =+   error $ "MathObj.Polynomial: method " ++ name ++ " cannot be implemented" -instance (Ring.C a, Eq a, Show a, ZeroTestable.C a) => P98.Num (T a) where-   fromInteger = const . fromInteger-   negate = Additive.negate -- for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance+-- legacy instances for use of numeric literals in GHCi+instance (P98.Num a) => P98.Num (T a) where+   fromInteger = const . P98.fromInteger+   negate = W98.unliftF1 Additive.negate+   (+)    = W98.unliftF2 (Additive.+)+   (*)    = W98.unliftF2 (Ring.*)+   abs    = notImplemented "abs"+   signum = notImplemented "signum" -instance (Field.C a, Eq a, Show a, ZeroTestable.C a) => P98.Fractional (T a) where-   fromRational = const . fromRational-   (/) = legacyInstance+instance (P98.Fractional a) => P98.Fractional (T a) where+   fromRational = const . P98.fromRational+   (/) = notImplemented "(/)"
+ src/MathObj/Polynomial/Core.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE RebindableSyntax #-}+{- |+This module implements polynomial functions on plain lists.+We use such functions in order to implement methods of other datatypes.++The module organization differs from that of @ResidueClass@:+Here the @Polynomial@ module exports the type+that fits to the NumericPrelude type classes,+whereas in @ResidueClass@ the sub-modules export various flavors of them.+-}+module MathObj.Polynomial.Core (+   horner, hornerCoeffVector, hornerArgVector,+   normalize,+   shift, unShift,+   equal,+   add, sub, negate,+   scale, collinear,+   tensorProduct, tensorProductAlt,+   mul, mulShear, mulShearTranspose,+   divMod, divModRev,+   stdUnit,+   progression, differentiate, integrate, integrateInt,+   mulLinearFactor,+   alternate, dilate, shrink,+   ) where++import qualified Algebra.Module               as Module+import qualified Algebra.Field                as Field+import qualified Algebra.IntegralDomain       as Integral+import qualified Algebra.Ring                 as Ring+import qualified Algebra.Additive             as Additive+import qualified Algebra.ZeroTestable         as ZeroTestable++import qualified Data.List.Reverse.StrictSpine as Rev+import qualified Data.List as List+import NumericPrelude.List (zipWithOverlap, )+import Data.Tuple.HT (mapPair, mapFst, forcePair, )+import Data.List.HT (switchL, shear, shearTranspose, outerProduct)++import qualified NumericPrelude.Base as P+import qualified NumericPrelude.Numeric as NP++import NumericPrelude.Base    hiding (const, reverse, )+import NumericPrelude.Numeric hiding (divMod, negate, stdUnit, )+++{- $setup+>>> import qualified MathObj.Polynomial.Core as PolyCore+>>> import qualified MathObj.Polynomial as Poly+>>> import qualified Data.List as List+>>> import qualified Test.QuickCheck as QC+>>> import Test.QuickCheck ((==>))+>>> import Data.Tuple.HT (mapPair, mapSnd)+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>> intPoly :: [Integer] -> [Integer]+>>> intPoly = id+>>>+>>> ratioPoly :: [Rational] -> [Rational]+>>> ratioPoly = id+-}+++{- |+Horner's scheme for evaluating a polynomial in a ring.+-}+{-# INLINE horner #-}+horner :: Ring.C a => a -> [a] -> a+horner x = foldr (\c val -> c+x*val) zero++{- |+Horner's scheme for evaluating a polynomial in a module.+-}+{-# INLINE hornerCoeffVector #-}+hornerCoeffVector :: Module.C a v => a -> [v] -> v+hornerCoeffVector x = foldr (\c val -> c+x*>val) zero++{-# INLINE hornerArgVector #-}+hornerArgVector :: (Module.C a v, Ring.C v) => v -> [a] -> v+hornerArgVector x = foldr (\c val -> c*>one+val*x) zero+++{- |+It's also helpful to put a polynomial in canonical form.+'normalize' strips leading coefficients that are zero.+-}+{-# INLINE normalize #-}+normalize :: (ZeroTestable.C a) => [a] -> [a]+normalize = Rev.dropWhile isZero++{- |+Multiply by the variable, used internally.+-}+{-# INLINE shift #-}+shift :: (Additive.C a) => [a] -> [a]+shift [] = []+shift l  = zero : l++{-# INLINE unShift #-}+unShift :: [a] -> [a]+unShift []     = []+unShift (_:xs) = xs++{-# INLINE equal #-}+equal :: (Eq a, ZeroTestable.C a) => [a] -> [a] -> Bool+equal x y = and (zipWithOverlap isZero isZero (==) x y)+++add, sub :: (Additive.C a) => [a] -> [a] -> [a]+add = (+)+sub = (-)++{-# INLINE negate #-}+negate :: (Additive.C a) => [a] -> [a]+negate = map NP.negate+++{-# INLINE scale #-}+scale :: Ring.C a => a -> [a] -> [a]+scale s = map (s*)+++collinear :: (Eq a, Ring.C a) => [a] -> [a] -> Bool+collinear (x:xs) (y:ys) =+   if x==zero && y==zero+     then collinear xs ys+     else scale x ys == scale y xs+-- here at least one of xs and ys is empty+collinear xs ys =+   all (==zero) xs && all (==zero) ys+++{- |+prop> \(QC.NonEmpty xs) (QC.NonEmpty ys) -> PolyCore.tensorProduct xs ys == List.transpose (PolyCore.tensorProduct ys (intPoly xs))+-}+{-# INLINE tensorProduct #-}+tensorProduct :: Ring.C a => [a] -> [a] -> [[a]]+tensorProduct = outerProduct (*)++tensorProductAlt :: Ring.C a => [a] -> [a] -> [[a]]+tensorProductAlt xs ys = map (flip scale ys) xs+++{- |+'mul' is fast if the second argument is a short polynomial,+'MathObj.PowerSeries.**' relies on that fact.+-}++{-# INLINE mul #-}+mul :: Ring.C a => [a] -> [a] -> [a]+{- prevent from generation of many zeros+   if the first operand is the empty list -}+mul [] = P.const []+mul xs = foldr (\y zs -> let (v:vs) = scale y xs in v : add vs zs) []+-- this one fails on infinite lists+--    mul xs = foldr (\y zs -> add (scale y xs) (shift zs)) []++{- |+prop> \xs ys  ->  PolyCore.equal (intPoly $ PolyCore.mul xs ys) (PolyCore.mulShear xs ys)+-}+{-# INLINE mulShear #-}+mulShear :: Ring.C a => [a] -> [a] -> [a]+mulShear xs ys = map sum (shear (tensorProduct xs ys))++{-# INLINE mulShearTranspose #-}+mulShearTranspose :: Ring.C a => [a] -> [a] -> [a]+mulShearTranspose xs ys = map sum (shearTranspose (tensorProduct xs ys))+++{- |+prop> \x y -> case (PolyCore.normalize x, PolyCore.normalize y) of (nx, ny) -> not (null (ratioPoly ny)) ==> mapSnd PolyCore.normalize (PolyCore.divMod nx ny) == mapPair (PolyCore.normalize, PolyCore.normalize) (PolyCore.divMod x y)+prop> \x y -> not (isZero (ratioPoly y)) ==> let z = fst $ PolyCore.divMod (Poly.coeffs x) y in  PolyCore.normalize z == z+prop> \x y -> case PolyCore.normalize $ ratioPoly y of ny -> not (null ny) ==> List.length (snd $ PolyCore.divMod x y) < List.length ny+-}+divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a])+divMod x y =+   mapPair (List.reverse, List.reverse) $+   divModRev (List.reverse x) (List.reverse y)++{-+snd $ Poly.divMod (repeat (1::Double)) [1,1]+-}+{- |+The modulus will always have one element less than the divisor.+This means that the modulus will be denormalized in some cases,+e.g. @mod [2,1,1] [1,1,1] == [1,0]@ instead of @[1]@.+-}+divModRev :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a])+divModRev x y =+   case dropWhile isZero y of+      [] -> error "MathObj.Polynomial: division by zero"+      y0:ys ->+         let -- the second parameter represents lazily (length x - length (normalize y))+             aux xs' =+               forcePair .+               switchL+                 ([], xs')+                 (P.const $+                    let (x0:xs) = xs'+                        q0      = x0/y0+                    in  mapFst (q0:) . aux (sub xs (scale q0 ys)))+         in  aux x (drop (length ys) x)++{-# INLINE stdUnit #-}+stdUnit :: (ZeroTestable.C a, Ring.C a) => [a] -> a+stdUnit x = case normalize x of+    [] -> one+    l  -> last l+++{-# INLINE progression #-}+progression :: Ring.C a => [a]+progression = iterate (one+) one++{-# INLINE differentiate #-}+differentiate :: (Ring.C a) => [a] -> [a]+differentiate = zipWith (*) progression . drop 1++{-# INLINE integrate #-}+integrate :: (Field.C a) => a -> [a] -> [a]+integrate c x = c : zipWith (/) x progression++{- |+Integrates if it is possible to represent the integrated polynomial+in the given ring.+Otherwise undefined coefficients occur.+-}+{-# INLINE integrateInt #-}+integrateInt :: (ZeroTestable.C a, Integral.C a) => a -> [a] -> [a]+integrateInt c x =+   c : zipWith Integral.divChecked x progression+++{-# INLINE mulLinearFactor #-}+mulLinearFactor :: Ring.C a => a -> [a] -> [a]+mulLinearFactor x yt@(y:ys) = Additive.negate (x*y) : yt - scale x ys+mulLinearFactor _ [] = []++{-# INLINE alternate #-}+alternate :: Additive.C a => [a] -> [a]+alternate = zipWith ($) (cycle [id, Additive.negate])++{-# INLINE shrink #-}+shrink :: Ring.C a => a -> [a] -> [a]+shrink k = zipWith (*) (iterate (k*) one)++{-# INLINE dilate #-}+dilate :: Field.C a => a -> [a] -> [a]+dilate = shrink . Field.recip+++{-+see htam: Wavelet/DyadicResultant++resultant :: Ring.C a => [a] -> [a] -> [a]+resultant xs ys =++discriminant :: Ring.C a => [a] -> a+discriminant xs =+   let degree = genericLength xs+   in  parityFlip (divChecked (degree*(degree-1)) 2)+                  (resultant xs (differentiate xs))+          `divChecked` last xs+-}+
src/MathObj/PowerSeries.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}  {- |-Power series, either finite or unbounded.  (zipWith does exactly the-right thing to make it work almost transparently.)+Power series, either finite or unbounded.+(zipWith does exactly the right thing to make it work almost transparently.) -}- module MathObj.PowerSeries where -import qualified MathObj.Polynomial     as Poly+import qualified MathObj.PowerSeries.Core as Core+import qualified MathObj.Polynomial.Core as Poly  import qualified Algebra.Differential   as Differential import qualified Algebra.IntegralDomain as Integral@@ -23,17 +23,19 @@ import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable -import Algebra.Module((*>))-import Algebra.ZeroTestable(isZero)+import NumericPrelude.Base    hiding (const)+import NumericPrelude.Numeric -import qualified Data.List.Match as Match-import qualified NumericPrelude as NP-import qualified PreludeBase as P -import PreludeBase    hiding (const)-import NumericPrelude hiding (negate, stdUnit, divMod,-                              sqrt, exp, log,-                              sin, cos, tan, asin, acos, atan)+{- $setup+>>> import qualified MathObj.PowerSeries.Core as PS+>>> import qualified MathObj.PowerSeries as PST+>>> import qualified Test.QuickCheck as QC+>>> import Test.NumericPrelude.Utility (equalTrunc, (/\))+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base as P+>>> import Prelude ()+-}   newtype T a = Cons {coeffs :: [a]} deriving (Ord)@@ -64,15 +66,15 @@ -}  instance Functor T where-  fmap f (Cons xs) = Cons (map f xs)+   fmap f (Cons xs) = Cons (map f xs)  {-# INLINE appPrec #-} appPrec :: Int appPrec  = 10  instance (Show a) => Show (T a) where-  showsPrec p (Cons xs) =-    showParen (p >= appPrec) (showString "PowerSeries.fromCoeffs " . shows xs)+   showsPrec p (Cons xs) =+     showParen (p >= appPrec) (showString "PowerSeries.fromCoeffs " . shows xs)   {-# INLINE truncate #-}@@ -82,132 +84,66 @@ {- | Evaluate (truncated) power series. -}-{-# INLINE eval #-}-eval :: Ring.C a => [a] -> a -> a-eval = flip Poly.horner- {-# INLINE evaluate #-} evaluate :: Ring.C a => T a -> a -> a-evaluate (Cons y) = eval y+evaluate (Cons y) = Core.evaluate y  {- | Evaluate (truncated) power series. -}-{-# INLINE evalCoeffVector #-}-evalCoeffVector :: Module.C a v => [v] -> a -> v-evalCoeffVector = flip Poly.hornerCoeffVector- {-# INLINE evaluateCoeffVector #-} evaluateCoeffVector :: Module.C a v => T v -> a -> v-evaluateCoeffVector (Cons y) = evalCoeffVector y+evaluateCoeffVector (Cons y) = Core.evaluateCoeffVector y  -{-# INLINE evalArgVector #-}-evalArgVector :: (Module.C a v, Ring.C v) => [a] -> v -> v-evalArgVector = flip Poly.hornerArgVector- {-# INLINE evaluateArgVector #-} evaluateArgVector :: (Module.C a v, Ring.C v) => T a -> v -> v-evaluateArgVector (Cons y) = evalArgVector y+evaluateArgVector (Cons y) = Core.evaluateArgVector y  {- | Evaluate approximations that is evaluate all truncations of the series. -}-{-# INLINE approx #-}-approx :: Ring.C a => [a] -> a -> [a]-approx y x =-   scanl (+) zero (zipWith (*) (iterate (x*) 1) y)- {-# INLINE approximate #-} approximate :: Ring.C a => T a -> a -> [a]-approximate (Cons y) = approx y+approximate (Cons y) = Core.approximate y   {- | Evaluate approximations that is evaluate all truncations of the series. -}-{-# INLINE approxCoeffVector #-}-approxCoeffVector :: Module.C a v => [v] -> a -> [v]-approxCoeffVector y x =-   scanl (+) zero (zipWith (*>) (iterate (x*) 1) y)- {-# INLINE approximateCoeffVector #-} approximateCoeffVector :: Module.C a v => T v -> a -> [v]-approximateCoeffVector (Cons y) = approxCoeffVector y+approximateCoeffVector (Cons y) = Core.approximateCoeffVector y   {- | Evaluate approximations that is evaluate all truncations of the series. -}-{-# INLINE approxArgVector #-}-approxArgVector :: (Module.C a v, Ring.C v) => [a] -> v -> [v]-approxArgVector y x =-   scanl (+) zero (zipWith (*>) y (iterate (x*) 1))- {-# INLINE approximateArgVector #-} approximateArgVector :: (Module.C a v, Ring.C v) => T a -> v -> [v]-approximateArgVector (Cons y) = approxArgVector y---{- * Simple series manipulation -}--{- |-For the series of a real function @f@-compute the series for @\x -> f (-x)@--}--alternate :: Additive.C a => [a] -> [a]-alternate = zipWith id (cycle [id, NP.negate])--{- |-For the series of a real function @f@-compute the series for @\x -> (f x + f (-x)) \/ 2@--}--holes2 :: Additive.C a => [a] -> [a]-holes2 = zipWith id (cycle [id, P.const zero])--{- |-For the series of a real function @f@-compute the real series for @\x -> (f (i*x) + f (-i*x)) \/ 2@--}-holes2alternate :: Additive.C a => [a] -> [a]-holes2alternate =-   zipWith id (cycle [id, P.const zero, NP.negate, P.const zero])+approximateArgVector (Cons y) = Core.approximateArgVector y  -{- * Series arithmetic -}--add, sub :: (Additive.C a) => [a] -> [a] -> [a]-add = Poly.add-sub = Poly.sub--negate :: (Additive.C a) => [a] -> [a]-negate = Poly.negate--scale :: Ring.C a => a -> [a] -> [a]-scale = Poly.scale--mul :: Ring.C a => [a] -> [a] -> [a]-mul = Poly.mul- {- Note that the derived instances only make sense for finite series. -}  instance (Eq a, ZeroTestable.C a) => Eq (T a) where-    (Cons x) == (Cons y) = Poly.equal x y+   (Cons x) == (Cons y) = Poly.equal x y  instance (Additive.C a) => Additive.C (T a) where-    negate = lift1 Poly.negate-    (+)    = lift2 Poly.add-    (-)    = lift2 Poly.sub-    zero   = lift0 []+   negate = lift1 Poly.negate+   (+)    = lift2 Poly.add+   (-)    = lift2 Poly.sub+   zero   = lift0 [] +{- |+prop> QC.choose (1,10) /\ \expon (QC.Positive x) xs -> let xt = x:xs in  equalTrunc 15 (PS.pow (const x) (1 % expon) (PST.coeffs (PST.fromCoeffs xt ^ expon)) ++ repeat zero) (xt ++ repeat zero)+-} instance (Ring.C a) => Ring.C (T a) where-    one           = const one-    fromInteger n = const (fromInteger n)-    (*)           = lift2 mul+   one           = const one+   fromInteger n = const (fromInteger n)+   (*)           = lift2 Core.mul  instance Vector.C T where    zero  = zero@@ -215,190 +151,45 @@    (*>)  = Vector.functorScale  instance (Module.C a b) => Module.C a (T b) where-    (*>) x = lift1 (x *>)+   (*>) x = lift1 (x *>)  instance (Field.C a, Module.C a b) => VectorSpace.C a (T b) -stripLeadZero :: (ZeroTestable.C a) => [a] -> [a] -> ([a],[a])-stripLeadZero (x:xs) (y:ys) =-  if isZero x && isZero y-    then stripLeadZero xs ys-    else (x:xs,y:ys)-stripLeadZero xs ys = (xs,ys) -{- |-Divide two series where the absolute term of the divisor is non-zero.-That is, power series with leading non-zero terms are the units-in the ring of power series.--Knuth: Seminumerical algorithms--}-divide :: (Field.C a) => [a] -> [a] -> [a]-divide (x:xs) (y:ys) =-   let zs = map (/y) (x : sub xs (mul zs ys))-   in  zs-divide [] _ = []-divide _ [] = error "PowerSeries.divide: division by empty series"--{- |-Divide two series also if the divisor has leading zeros.--}-divideStripZero :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> [a]-divideStripZero x' y' =-   let (x0,y0) = stripLeadZero x' y'-   in  if null y0 || isZero (head y0)-         then error "PowerSeries.divideStripZero: Division by zero."-         else divide x0 y0-- instance (Field.C a) => Field.C (T a) where-  (/) = lift2 divide+   (/) = lift2 Core.divide  -divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a],[a])-divMod xs ys =-   let (yZero,yRem) = span isZero ys-       (xMod, xRem) = Match.splitAt yZero xs-   in  (divide xRem yRem, xMod)- instance (ZeroTestable.C a, Field.C a) => Integral.C (T a) where-  divMod (Cons x) (Cons y) =-     let (d,m) = divMod x y-     in  (Cons d, Cons m)+   divMod (Cons x) (Cons y) =+      let (d,m) = Core.divMod x y+      in  (Cons d, Cons m)  -progression :: Ring.C a => [a]-progression = Poly.progression--recipProgression :: (Field.C a) => [a]-recipProgression = map recip progression--differentiate :: (Ring.C a) => [a] -> [a]-differentiate = Poly.differentiate--integrate :: (Field.C a) => a -> [a] -> [a]-integrate = Poly.integrate- instance (Ring.C a) => Differential.C (T a) where-  differentiate = lift1 differentiate+   differentiate = lift1 Core.differentiate  -{- |-We need to compute the square root only of the first term.-That is, if the first term is rational,-then all terms of the series are rational.--}--sqrt :: Field.C a => (a -> a) -> [a] -> [a]-sqrt _ [] = []-sqrt f0 (x:xs) =-   let y  = f0 x-       ys = map (/(y+y)) (xs - (0 : mul ys ys))-   in  y:ys--{--pow alpha t = t^alpha-(pow alpha . x)' = alpha * (pow (alpha-1) . x) * x'-alpha * (pow alpha . x) = x * x' * (pow alpha . x)'-y = pow alpha . x-alpha * y = x * x' * y'--}--{- |-Input series must start with non-zero term.--}-pow :: (Field.C a) => (a -> a) -> a -> [a] -> [a]-pow f0 expon x =-   let y  = integrate (f0 (head x)) y'-       y' = scale expon (divide y (mul x (differentiate x)))-   in  y- instance (Algebraic.C a) => Algebraic.C (T a) where-   sqrt   = lift1 (sqrt Algebraic.sqrt)-   x ^/ y = lift1 (pow (Algebraic.^/ y)+   sqrt   = lift1 (Core.sqrt Algebraic.sqrt)+   x ^/ y = lift1 (Core.pow (Algebraic.^/ y)                        (fromRational' y)) x -{- |-The first term needs a transcendent computation but the others do not.-That's why we accept a function which computes the first term. -> (exp . x)' =   (exp . x) * x'-> (sin . x)' =   (cos . x) * x'-> (cos . x)' = - (sin . x) * x'--}--exp :: Field.C a => (a -> a) -> [a] -> [a]-exp f0 x =-   let x' = differentiate x-       y  = integrate (f0 (head x)) (mul y x')-   in  y--sinCos :: Field.C a => (a -> (a,a)) -> [a] -> ([a],[a])-sinCos f0 x =-   let (y0Sin, y0Cos) = f0 (head x)-       x'   = differentiate x-       ySin = integrate y0Sin         (mul yCos x')-       yCos = integrate y0Cos (negate (mul ySin x'))-   in  (ySin, yCos)--sinCosScalar :: Transcendental.C a => a -> (a,a)-sinCosScalar x = (Transcendental.sin x, Transcendental.cos x)--sin, cos :: Field.C a => (a -> (a,a)) -> [a] -> [a]-sin f0 = fst . sinCos f0-cos f0 = snd . sinCos f0--tan :: (Field.C a) => (a -> (a,a)) -> [a] -> [a]-tan f0 = uncurry divide . sinCos f0--{--(log x)' == x'/x-(asin x)' == (acos x) == x'/sqrt(1-x^2)-(atan x)' == x'/(1+x^2)--}--{- |-Input series must start with non-zero term.--}-log :: (Field.C a) => (a -> a) -> [a] -> [a]-log f0 x = integrate (f0 (head x)) (derivedLog x)--{- |-Computes @(log x)'@, that is @x'\/x@--}-derivedLog :: (Field.C a) => [a] -> [a]-derivedLog x = divide (differentiate x) x--atan :: (Field.C a) => (a -> a) -> [a] -> [a]-atan f0 x =-   let x' = differentiate x-   in  integrate (f0 (head x)) (divide x' ([1] + mul x x))--asin, acos :: (Field.C a) =>-   (a -> a) -> (a -> a) -> [a] -> [a]-asin sqrt0 f0 x =-   let x' = differentiate x-   in  integrate (f0 (head x))-                 (divide x' (sqrt sqrt0 ([1] - mul x x)))-acos = asin---- instance (Transcendental.C a) =>              Transcendental.C (T a) where-   pi = const NP.pi-   exp = lift1 (exp Transcendental.exp)-   sin = lift1 (sin sinCosScalar)-   cos = lift1 (cos sinCosScalar)-   tan = lift1 (tan sinCosScalar)+   pi = const Transcendental.pi+   exp = lift1 (Core.exp Transcendental.exp)+   sin = lift1 (Core.sin Core.sinCosScalar)+   cos = lift1 (Core.cos Core.sinCosScalar)+   tan = lift1 (Core.tan Core.sinCosScalar)    x ** y = Transcendental.exp (Transcendental.log x * y)                 {- This order of multiplication is especially fast                    when y is a singleton. -}-   log  = lift1 (log  Transcendental.log)-   asin = lift1 (asin Algebraic.sqrt Transcendental.asin)-   acos = lift1 (acos Algebraic.sqrt Transcendental.acos)-   atan = lift1 (atan Transcendental.atan)+   log  = lift1 (Core.log  Transcendental.log)+   asin = lift1 (Core.asin Algebraic.sqrt Transcendental.asin)+   acos = lift1 (Core.acos Algebraic.sqrt Transcendental.acos)+   atan = lift1 (Core.atan Transcendental.atan)  {- | It fulfills@@ -410,46 +201,11 @@ compose (Cons (x:_)) (Cons []) = Cons [x] compose (Cons x) (Cons (y:ys)) =    if isZero y-     then Cons (comp x ys)+     then Cons (Core.compose x ys)      else error "PowerSeries.compose: inner series must not have an absolute term." -{- |-Since the inner series must start with a zero,-the first term is omitted in y.--}-comp :: (Ring.C a) => [a] -> [a] -> [a]-comp xs y = foldr (\x acc -> x : mul y acc) [] xs---{- |-Compose two power series where the outer series-can be developed for any expansion point.-To be more precise:-The outer series must be expanded with respect to the leading term-of the inner series.--}-composeTaylor :: Ring.C a => (a -> [a]) -> [a] -> [a]-composeTaylor x (y:ys) = comp (x y) ys-composeTaylor x []     = x 0----{--(x . y) = id-(x' . y) * y' = 1-y' = 1 / (x' . y)--}--{- |-This function returns the series of the function in the form:-(point of the expansion, power series)--This is exceptionally slow and needs cubic run-time.--}+shrink :: Ring.C a => a -> T a -> T a+shrink = lift1 . Poly.shrink -inv :: (Field.C a) => [a] -> (a, [a])-inv x =-   let y' = divide [1] (comp (differentiate x) (tail y))-       y  = integrate 0 y'-            -- the first term is zero, which is required for composition-   in  (head x, y)+dilate :: Field.C a => a -> T a -> T a+dilate = lift1 . Poly.dilate
+ src/MathObj/PowerSeries/Core.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE RebindableSyntax #-}+module MathObj.PowerSeries.Core where++import qualified MathObj.Polynomial.Core as Poly++import qualified Algebra.Module         as Module+import qualified Algebra.Transcendental as Transcendental+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive+import qualified Algebra.ZeroTestable   as ZeroTestable++import qualified Data.List.Match as Match+import qualified NumericPrelude.Numeric as NP+import qualified NumericPrelude.Base as P++import NumericPrelude.Base    hiding (const)+import NumericPrelude.Numeric hiding (negate, stdUnit, divMod,+                              sqrt, exp, log,+                              sin, cos, tan, asin, acos, atan)+++{- $setup+>>> import qualified MathObj.PowerSeries.Core as PS+>>> import qualified MathObj.PowerSeries.Example as PSE+>>> import Test.NumericPrelude.Utility (equalTrunc, (/\))+>>> import qualified Test.QuickCheck as QC+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base as P+>>> import Prelude ()+>>> import Control.Applicative (liftA3)+>>>+>>> checkHoles ::+>>>    Int -> ([Rational] -> [Rational]) ->+>>>    Rational -> [Rational] -> QC.Property+>>> checkHoles trunc f x xs =+>>>    QC.choose (1,10) /\ \expon ->+>>>    equalTrunc trunc+>>>       (f (PS.insertHoles expon (x:xs)) ++ repeat zero)+>>>       (PS.insertHoles expon (f (x:xs)) ++ repeat zero)+>>>+>>> genInvertible :: QC.Gen [Rational]+>>> genInvertible =+>>>    liftA3 (\x0 x1 xs -> x0:x1:xs)+>>>       QC.arbitrary (fmap QC.getNonZero QC.arbitrary) QC.arbitrary+-}+++{-# INLINE evaluate #-}+evaluate :: Ring.C a => [a] -> a -> a+evaluate = flip Poly.horner++{-# INLINE evaluateCoeffVector #-}+evaluateCoeffVector :: Module.C a v => [v] -> a -> v+evaluateCoeffVector = flip Poly.hornerCoeffVector++{-# INLINE evaluateArgVector #-}+evaluateArgVector :: (Module.C a v, Ring.C v) => [a] -> v -> v+evaluateArgVector = flip Poly.hornerArgVector+++{-# INLINE approximate #-}+approximate :: Ring.C a => [a] -> a -> [a]+approximate y x =+   scanl (+) zero (zipWith (*) (iterate (x*) 1) y)++{-# INLINE approximateCoeffVector #-}+approximateCoeffVector :: Module.C a v => [v] -> a -> [v]+approximateCoeffVector y x =+   scanl (+) zero (zipWith (*>) (iterate (x*) 1) y)++{-# INLINE approximateArgVector #-}+approximateArgVector :: (Module.C a v, Ring.C v) => [a] -> v -> [v]+approximateArgVector y x =+   scanl (+) zero (zipWith (*>) y (iterate (x*) 1))+++{- * Simple series manipulation -}++{- |+For the series of a real function @f@+compute the series for @\x -> f (-x)@+-}++alternate :: Additive.C a => [a] -> [a]+alternate = zipWith id (cycle [id, NP.negate])++{- |+For the series of a real function @f@+compute the series for @\x -> (f x + f (-x)) \/ 2@+-}++holes2 :: Additive.C a => [a] -> [a]+holes2 = zipWith id (cycle [id, P.const zero])++{- |+For the series of a real function @f@+compute the real series for @\x -> (f (i*x) + f (-i*x)) \/ 2@+-}+holes2alternate :: Additive.C a => [a] -> [a]+holes2alternate =+   zipWith id (cycle [id, P.const zero, NP.negate, P.const zero])+++{- |+For power series of @f x@, compute the power series of @f(x^n)@.++prop> QC.choose (1,10) /\ \m -> QC.choose (1,10) /\ \n xs -> equalTrunc 100 (PS.insertHoles m $ PS.insertHoles n xs) (PS.insertHoles (m*n) xs)+-}+insertHoles :: Additive.C a => Int -> [a] -> [a]+insertHoles n =+   if n<=0+     then error $ "insertHoles requires positive exponent, but got " ++ show n+     else concatMap (\x -> x : replicate (n-1) zero)+++{- * Series arithmetic -}++add, sub :: (Additive.C a) => [a] -> [a] -> [a]+add = Poly.add+sub = Poly.sub++negate :: (Additive.C a) => [a] -> [a]+negate = Poly.negate++scale :: Ring.C a => a -> [a] -> [a]+scale = Poly.scale++mul :: Ring.C a => [a] -> [a] -> [a]+mul = Poly.mul+++stripLeadZero :: (ZeroTestable.C a) => [a] -> [a] -> ([a],[a])+stripLeadZero (x:xs) (y:ys) =+  if isZero x && isZero y+    then stripLeadZero xs ys+    else (x:xs,y:ys)+stripLeadZero xs ys = (xs,ys)+++divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a],[a])+divMod xs ys =+   let (yZero,yRem) = span isZero ys+       (xMod, xRem) = Match.splitAt yZero xs+   in  (divide xRem yRem, xMod)++{- |+Divide two series where the absolute term of the divisor is non-zero.+That is, power series with leading non-zero terms are the units+in the ring of power series.++Knuth: Seminumerical algorithms+-}+divide :: (Field.C a) => [a] -> [a] -> [a]+divide (x:xs) (y:ys) =+   let zs = map (/y) (x : sub xs (mul zs ys))+   in  zs+divide [] _ = []+divide _ [] = error "PowerSeries.divide: division by empty series"++{- |+Divide two series also if the divisor has leading zeros.+-}+divideStripZero :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> [a]+divideStripZero x' y' =+   let (x0,y0) = stripLeadZero x' y'+   in  if null y0 || isZero (head y0)+         then error "PowerSeries.divideStripZero: Division by zero."+         else divide x0 y0+++progression :: Ring.C a => [a]+progression = Poly.progression++recipProgression :: (Field.C a) => [a]+recipProgression = map recip progression++differentiate :: (Ring.C a) => [a] -> [a]+differentiate = Poly.differentiate++integrate :: (Field.C a) => a -> [a] -> [a]+integrate = Poly.integrate+++{- |+We need to compute the square root only of the first term.+That is, if the first term is rational,+then all terms of the series are rational.++prop> equalTrunc 50 PSE.sqrtExpl (PS.sqrt (\1 -> 1) [1,1])+prop> equalTrunc 500 (1:1:repeat 0) (PS.sqrt (\1 -> 1) (PS.mul [1,1] [1,1]))+prop> checkHoles 50 (PS.sqrt (\1 -> 1)) 1+-}+sqrt :: Field.C a => (a -> a) -> [a] -> [a]+sqrt _ [] = []+sqrt f0 (x:xs) =+   let y  = f0 x+       ys = map (/(y+y)) (xs - (0 : mul ys ys))+   in  y:ys++{-+pow alpha t = t^alpha+(pow alpha . x)' = alpha * (pow (alpha-1) . x) * x'+(pow alpha . x)' * x = alpha * (pow alpha . x) * x'++y = pow alpha . x+y' * x = alpha * y * x'++This yields an implementation that is a fused+exp (alpha * log x)+-}++{- |+Input series must start with a non-zero term,+even better with a positive one.++prop> equalTrunc 100 (PSE.powExpl (-1/3)) (PS.pow (\1 -> 1) (-1/3) [1,1])+prop> equalTrunc 50 (PSE.powExpl (-1/3)) (PS.exp (\0 -> 1) (PS.scale (-1/3) PSE.log))+prop> checkHoles 30 (PS.pow (\1 -> 1) (1/3)) 1+prop> checkHoles 30 (PS.pow (\1 -> 1) (2/5)) 1+-}+pow :: (Field.C a) => (a -> a) -> a -> [a] -> [a]+pow f0 expon x =+   let y  = integrate (f0 (head x)) y'+       y' = scale expon (mul y (derivedLog x))+   in  y+++{- |+The first term needs a transcendent computation but the others do not.+That's why we accept a function which computes the first term.++> (exp . x)' =   (exp . x) * x'+> (sin . x)' =   (cos . x) * x'+> (cos . x)' = - (sin . x) * x'++prop> equalTrunc 500 PSE.expExpl (PS.exp (\0 -> 1) [0,1])+prop> equalTrunc 100 (1:1:repeat 0) (PS.exp (\0 -> 1) PSE.log)+prop> checkHoles 30 (PS.exp (\0 -> 1)) 0+-}+exp :: Field.C a => (a -> a) -> [a] -> [a]+exp f0 x =+   let x' = differentiate x+       y  = integrate (f0 (head x)) (mul y x')+   in  y++sinCos :: Field.C a => (a -> (a,a)) -> [a] -> ([a],[a])+sinCos f0 x =+   let (y0Sin, y0Cos) = f0 (head x)+       x'   = differentiate x+       ySin = integrate y0Sin         (mul yCos x')+       yCos = integrate y0Cos (negate (mul ySin x'))+   in  (ySin, yCos)++sinCosScalar :: Transcendental.C a => a -> (a,a)+sinCosScalar x = (Transcendental.sin x, Transcendental.cos x)++{- |+prop> equalTrunc 500 PSE.sinExpl (PS.sin (\0 -> (0,1)) [0,1])+prop> equalTrunc 50 (0:1:repeat 0) (PS.sin (\0 -> (0,1)) PSE.asin)+prop> checkHoles 20 (PS.sin (\0 -> (0,1))) 0+-}+sin :: Field.C a => (a -> (a,a)) -> [a] -> [a]+sin f0 = fst . sinCos f0+{- |+prop> equalTrunc 500 PSE.cosExpl (PS.cos (\0 -> (0,1)) [0,1])+prop> checkHoles 20 (PS.cos (\0 -> (0,1))) 0+-}+cos :: Field.C a => (a -> (a,a)) -> [a] -> [a]+cos f0 = snd . sinCos f0++{- |+prop> equalTrunc 50 PSE.tanExpl (PS.tan (\0 -> (0,1)) [0,1])+prop> equalTrunc 50 (0:1:repeat 0) (PS.tan (\0 -> (0,1)) PSE.atan)+prop> checkHoles 20 (PS.tan (\0 -> (0,1))) 0+-}+tan :: (Field.C a) => (a -> (a,a)) -> [a] -> [a]+tan f0 = uncurry divide . sinCos f0++{-+(log x)' == x'/x+(asin x)' == (acos x) == x'/sqrt(1-x^2)+(atan x)' == x'/(1+x^2)+-}++{- |+Input series must start with non-zero term.++prop> equalTrunc 500 PSE.logExpl (PS.log (\1 -> 0) [1,1])+prop> equalTrunc 100 (0:1:repeat 0) (PS.log (\1 -> 0) PSE.exp)+prop> checkHoles 30 (PS.log (\1 -> 0)) 1+-}+log :: (Field.C a) => (a -> a) -> [a] -> [a]+log f0 x = integrate (f0 (head x)) (derivedLog x)++{- |+Computes @(log x)'@, that is @x'\/x@+-}+derivedLog :: (Field.C a) => [a] -> [a]+derivedLog x = divide (differentiate x) x++{- |+prop> equalTrunc 500 PSE.atan (PS.atan (\0 -> 0) [0,1])+prop> equalTrunc 50 (0:1:repeat 0) (PS.atan (\0 -> 0) PSE.tan)+prop> checkHoles 20 (PS.atan (\0 -> 0)) 0+-}+atan :: (Field.C a) => (a -> a) -> [a] -> [a]+atan f0 x =+   let x' = differentiate x+   in  integrate (f0 (head x)) (divide x' ([1] + mul x x))++{- |+prop> equalTrunc 100 (0:1:repeat 0) (PS.asin (\1 -> 1) (\0 -> 0) PSE.sin)+prop> equalTrunc 50 PSE.asin (PS.asin (\1 -> 1) (\0 -> 0) [0,1])+prop> checkHoles 30 (PS.asin (\1 -> 1) (\0 -> 0)) 0+-}+asin :: (Field.C a) => (a -> a) -> (a -> a) -> [a] -> [a]+asin sqrt0 f0 x =+   let x' = differentiate x+   in  integrate (f0 (head x))+                 (divide x' (sqrt sqrt0 ([1] - mul x x)))++{- |+Would be a nice test, but we cannot compute exactly with 'pi':++> equalTrunc 50 PSE.acos (PS.acos (\1 -> 1) (\0 -> pi/2) [0,1])+-}+acos :: (Field.C a) => (a -> a) -> (a -> a) -> [a] -> [a]+acos = asin++{- |+Since the inner series must start with a zero,+the first term is omitted in y.+-}+compose :: (Ring.C a) => [a] -> [a] -> [a]+compose xs y = foldr (\x acc -> x : mul y acc) [] xs+++{- |+Compose two power series where the outer series+can be developed for any expansion point.+To be more precise:+The outer series must be expanded with respect to the leading term+of the inner series.+-}+composeTaylor :: Ring.C a => (a -> [a]) -> [a] -> [a]+composeTaylor x (y:ys) = compose (x y) ys+composeTaylor x []     = x 0+++{-+X(t) = t*x(t)+R(t) = t*r(t)++r(t) = 1 / (x(r(t)*t))+R(t)/t+   = 1 / (x(R(t)))+   = 1 / (X(R(t)) / R(t))+   = 1 / (t / R(t))+-}++{- |+This function returns the series of the inverse function in the form:+(point of the expansion, power series).++That is, say we have the equation:++> y = a + f(x)++where function f is given by a power series with f(0) = 0.+We want to solve for x:++> x = f^-1(y-a)++If you pass the power series of @a+f(x)@ to 'inv',+you get @(a, f^-1)@ as answer, where @f^-1@ is a power series.++The linear term of @f@ (the coefficient of @x@) must be non-zero.++This needs cubic run-time and thus is exceptionally slow.+Computing inverse series for special power series might be faster.++prop> genInvertible /\ \xs -> let (y,ys) = PS.inv xs; (z,zs) = PS.invDiff xs in y==z && equalTrunc 15 ys zs+-}+-- how about NonEmpty.T here?+inv :: (Eq a, Field.C a) => [a] -> (a, [a])+inv [] = error "inv: power series must be non-zero"+inv (x:xs) =+   (x, let r = divide [1] (compose xs r) in 0 : r)+++{-+(x . y) = id+(x' . y) * y' = 1+y' = 1 / (x' . y)+-}++{-+Like 'inv' but with a slightly cumbersome implementation.+-}+invDiff :: (Field.C a) => [a] -> (a, [a])+invDiff x =+   let y' = divide [1] (compose (differentiate x) (tail y))+       y  = integrate 0 y'+            -- the first term is zero, which is required for composition+   in  (head x, y)
src/MathObj/PowerSeries/DifferentialEquation.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Lazy evaluation allows for the solution  of differential equations in terms of power series.@@ -11,14 +11,14 @@  module MathObj.PowerSeries.DifferentialEquation where -import qualified MathObj.PowerSeries         as PS+import qualified MathObj.PowerSeries.Core    as PS import qualified MathObj.PowerSeries.Example as PSE  import qualified Algebra.Field        as Field import qualified Algebra.ZeroTestable as ZeroTestable -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |
src/MathObj/PowerSeries/Example.hs view
@@ -1,24 +1,33 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module MathObj.PowerSeries.Example where -import qualified MathObj.PowerSeries as PS+import qualified MathObj.PowerSeries.Core as PS  import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable import qualified Algebra.Transcendental as Transcendental  import Algebra.Additive (zero, subtract, negate) -import Data.List (map, tail, cycle, zipWith, scanl, intersperse)-import Data.List.HT (sieve)+import Data.List (intersperse, )+import Data.List.HT (sieve, ) -import NumericPrelude (one, (*), (/),+import NumericPrelude.Numeric (one, (*), (/),                        fromInteger, {-fromRational,-} pi)-import PreludeBase -- (Bool, const, map, zipWith, id, (&&), (==))+import NumericPrelude.Base -- (Bool, const, map, zipWith, id, (&&), (==))  +{- $setup+>>> import qualified MathObj.PowerSeries.Core as PS+>>> import qualified MathObj.PowerSeries.Example as PSE+>>> import Test.NumericPrelude.Utility (equalTrunc)+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base as P+>>> import Prelude ()+-}++ {- * Default implementations. -}  recip :: (Ring.C a) => [a]@@ -42,6 +51,8 @@ cosh  = coshODE atanh = atanhODE ++-- | prop> \m n -> equalTrunc 30 (PS.mul (PSE.pow m) (PSE.pow n)) (PSE.pow (m+n)) pow :: (Field.C a) => a -> [a] pow = powExpl sqrt = sqrtExpl@@ -52,34 +63,54 @@ recipExpl :: (Ring.C a) => [a] recipExpl = cycle [1,-1] -expExpl, sinExpl, cosExpl :: (Field.C a) => [a]+-- | prop> equalTrunc 500 PSE.expExpl PSE.expODE+expExpl :: (Field.C a) => [a] expExpl = scanl (*) one PS.recipProgression+-- | prop> equalTrunc 500 PSE.sinExpl PSE.sinODE+sinExpl :: (Field.C a) => [a] sinExpl = zero : PS.holes2alternate (tail expExpl)-cosExpl =        PS.holes2alternate       expExpl+-- | prop> equalTrunc 500 PSE.cosExpl PSE.cosODE+cosExpl :: (Field.C a) => [a]+cosExpl = PS.holes2alternate expExpl -tanExpl, tanExplSieve :: (ZeroTestable.C a, Field.C a) => [a]+-- | prop> equalTrunc 50 PSE.tanExpl PSE.tanODE+tanExpl :: (ZeroTestable.C a, Field.C a) => [a] tanExpl = PS.divide sinExpl cosExpl -- ignore zero values+-- | prop> equalTrunc 50 PSE.tanExpl PSE.tanExplSieve+tanExplSieve :: (ZeroTestable.C a, Field.C a) => [a] tanExplSieve =    concatMap       (\x -> [zero,x])       (PS.divide (sieve 2 (tail sin)) (sieve 2 cos)) -logExpl, atanExpl, sqrtExpl :: (Field.C a) => [a]+-- | prop> equalTrunc 500 PSE.logExpl PSE.logODE+logExpl :: (Field.C a) => [a] logExpl  = zero : PS.alternate       PS.recipProgression+-- | prop> equalTrunc 500 PSE.atanExpl PSE.atanODE+atanExpl :: (Field.C a) => [a] atanExpl = zero : PS.holes2alternate PS.recipProgression -sinhExpl, coshExpl, atanhExpl :: (Field.C a) => [a]+-- | prop> equalTrunc 500 PSE.sinhExpl PSE.sinhODE+sinhExpl :: (Field.C a) => [a] sinhExpl  = zero : PS.holes2 (tail expExpl)+-- | prop> equalTrunc 500 PSE.coshExpl PSE.coshODE+coshExpl :: (Field.C a) => [a] coshExpl  =        PS.holes2       expExpl+-- | prop> equalTrunc 500 PSE.atanhExpl PSE.atanhODE+atanhExpl :: (Field.C a) => [a] atanhExpl = zero : PS.holes2 PS.recipProgression  {- * Power series of (1+x)^expon using the binomial series. -} +-- | prop> \expon -> equalTrunc 50 (PSE.powODE expon) (PSE.powExpl expon) powExpl :: (Field.C a) => a -> [a] powExpl expon =    scanl (*) 1 (zipWith (/)       (iterate (subtract 1) expon) PS.progression)++-- | prop> equalTrunc 100 PSE.sqrtExpl PSE.sqrtODE+sqrtExpl :: (Field.C a) => [a] sqrtExpl = powExpl (1/2)  {- |@@ -110,11 +141,13 @@        == cos x ^ (-2) -} -expODE, sinODE, cosODE, tanODE, tanODESieve :: (Field.C a) => [a]+expODE, sinODE, cosODE, tanODE :: (Field.C a) => [a] expODE = PS.integrate 1 expODE sinODE = PS.integrate 0 cosODE cosODE = PS.integrate 1 (PS.negate sinODE) tanODE = PS.integrate 0 (PS.add [1] (PS.mul tanODE tanODE))+-- | prop> equalTrunc 50 PSE.tanODE PSE.tanODESieve+tanODESieve :: (Field.C a) => [a] tanODESieve =    -- sieve is too strict here because it wants to detect end of lists    let tan2 = map head (iterate (drop 2) (tail tanODESieve))@@ -126,9 +159,11 @@ atan' x == 1/(1+x^2) -} -logODE, recipCircle, asinODE, atanODE, sqrtODE :: (Field.C a) => [a]+logODE, recipCircle, atanODE, sqrtODE :: (Field.C a) => [a] logODE  = PS.integrate zero recip recipCircle = intersperse zero (PS.alternate (powODE (-1/2)))+-- | prop> equalTrunc 50 PSE.asinODE (snd $ PS.inv PSE.sinODE)+asinODE :: (Field.C a) => [a] asinODE = PS.integrate 0 recipCircle atanODE = PS.integrate zero (cycle [1,0,-1,0]) sqrtODE = powODE (1/2)
src/MathObj/PowerSeries/Mean.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | This module computes power series for representing some means as generalized $f$-means.@@ -6,7 +6,9 @@ module MathObj.PowerSeries.Mean where  import qualified MathObj.PowerSeries2        as PS2+import qualified MathObj.PowerSeries2.Core   as PS2Core import qualified MathObj.PowerSeries         as PS+import qualified MathObj.PowerSeries.Core    as PSCore import qualified MathObj.PowerSeries.Example as PSE  import qualified Algebra.Field as Field@@ -14,8 +16,8 @@  import Data.List.HT (shearTranspose) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base  {- $M_f$ is a generalized $f$-mean (quasi-arithmetic) if@@ -73,8 +75,8 @@  diffComp :: (Ring.C a) => [a] -> [a] -> [a] diffComp ys x =-   map sum (shearTranspose (tail (zipWith PS.scale ys-                    (map tail (iterate (PS.mul x) [1])))))+   map sum (shearTranspose (tail (zipWith PSCore.scale ys+                    (map tail (iterate (PSCore.mul x) [1])))))  {- Now we solve@@ -87,7 +89,7 @@ logarithmic :: (Field.C a) => [a] logarithmic =    let -- series for \frac{2\cdot x}{\ln(1+2\cdot x)}-       fracLn = PS.divide [2]+       fracLn = PSCore.divide [2]                       (tail (zipWith (*) (iterate (2*) 1) PSE.log))        fDiffFracLn = diffComp f (tail fracLn)        f = 0 : 1 : zipWith (/) fDiffFracLn@@ -118,7 +120,7 @@ $M(1+t,1) = \sqrt{1+t+t^2/2}$ -} quadratic :: (Field.C a, Eq a) => [a]-quadratic = PS.sqrt (\1 -> 1) [1,1,1/2]+quadratic = PSCore.sqrt (\1 -> 1) [1,1,1/2]  quadraticMVF :: (Field.C a) => [a] quadraticMVF =@@ -126,8 +128,8 @@    -- [1,1,1,1,1/2,1/2]    [1,1,1,1,1/2,-1/14] --- map (\x -> PS.coeffs (meanValueDiff2 quadratic2 [1,1,1,1,1/2,x] !! 4) !! 2) (GNUPlot.linearScale 10 (-0.071429,-1/14::Double))--- take 20 $ Numerics.ZeroFinder.RegulaFalsi.zero (-1,0) (\x -> PS.coeffs (meanValueDiff2 quadratic2 [1::Double,1,1,1,1/2,x] !! 4) !! 2)+-- map (\x -> PSCore.coeffs (meanValueDiff2 quadratic2 [1,1,1,1,1/2,x] !! 4) !! 2) (GNUPlot.linearScale 10 (-0.071429,-1/14::Double))+-- take 20 $ Numerics.ZeroFinder.RegulaFalsi.zero (-1,0) (\x -> PSCore.coeffs (meanValueDiff2 quadratic2 [1::Double,1,1,1,1/2,x] !! 4) !! 2)  {- Result: It seems,@@ -139,8 +141,8 @@ quadraticDiff :: (Field.C a, Eq a) => [a] quadraticDiff =    let divDiffPS = tail quadraticMVF -- (f(1+t)-f(1))/((1+t)-1)-       (1, invPS) = PS.inv (PS.differentiate quadraticMVF)-       meanValuePS = PS.composeTaylor (\1 -> invPS) divDiffPS+       (1, invPS) = PSCore.inv (PSCore.differentiate quadraticMVF)+       meanValuePS = PSCore.composeTaylor (\1 -> invPS) divDiffPS        {- instead of computing an inverse series           we could also apply (compose) the derived series           to the series of the quadratic mean. -}@@ -151,11 +153,11 @@  $M(1+x,1+y) = \sqrt{1+x+y+(x^2+y^2)/2}$ -}-quadratic2 :: (Field.C a, Eq a) => PS2.Core a+quadratic2 :: (Field.C a, Eq a) => PS2Core.T a quadratic2 =-   PS2.sqrt (\1 -> 1) [[1],[1,1],[1/2,0,1/2]]+   PS2Core.sqrt (\1 -> 1) [[1],[1,1],[1/2,0,1/2]] -quadraticDiff2 :: (Field.C a, Eq a) => PS2.Core a+quadraticDiff2 :: (Field.C a, Eq a) => PS2Core.T a quadraticDiff2 =    meanValueDiff2 quadratic2 quadraticMVF @@ -176,15 +178,15 @@ {- $M(1+x,1+y) = 2/(recip (1+x) + recip (1+y))$ -}-harmonic2 :: (Field.C a, Eq a) => PS2.Core a+harmonic2 :: (Field.C a, Eq a) => PS2Core.T a harmonic2 =    let rec = PS.fromCoeffs PSE.recip-   in  PS2.divide [[2]] $+   in  PS2Core.divide [[2]] $        PS2.coeffs $           PS2.fromPowerSeries0 rec +           PS2.fromPowerSeries1 rec -harmonicDiff2 :: (Field.C a, Eq a) => PS2.Core a+harmonicDiff2 :: (Field.C a, Eq a) => PS2Core.T a harmonicDiff2 =    meanValueDiff2 harmonic2 harmonicMVF @@ -196,10 +198,10 @@ {- $M(1+x,1+y) = 1+x/2+y/2$ -}-arithmetic2 :: (Field.C a, Eq a) => PS2.Core a+arithmetic2 :: (Field.C a, Eq a) => PS2Core.T a arithmetic2 = [[1],[1/2,1/2]] -arithmeticDiff2 :: (Field.C a, Eq a) => PS2.Core a+arithmeticDiff2 :: (Field.C a, Eq a) => PS2Core.T a arithmeticDiff2 =    meanValueDiff2 arithmetic2 arithmeticMVF @@ -210,11 +212,11 @@ {- $M(1+x,1+y) = \sqrt{(1+x)·(1+y)}$ -}-geometric2 :: (Field.C a, Eq a) => PS2.Core a+geometric2 :: (Field.C a, Eq a) => PS2Core.T a geometric2 =-   PS2.sqrt (\1 -> 1) [[1],[1,1],[0,1,0]]+   PS2Core.sqrt (\1 -> 1) [[1],[1,1],[0,1,0]] -geometricDiff2 :: (Field.C a, Eq a) => PS2.Core a+geometricDiff2 :: (Field.C a, Eq a) => PS2Core.T a geometricDiff2 =    meanValueDiff2 geometric2 geometricMVF @@ -222,11 +224,11 @@   meanValueDiff2 :: (Field.C a, Eq a) =>-   PS2.Core a -> [a] -> PS2.Core a+   PS2Core.T a -> [a] -> PS2Core.T a meanValueDiff2 mean2 curve =    let -- (f(1+x)-f(1+y)) / (x-y)        divDiffPS =           zipWith replicate [1..] $ tail curve        meanValuePS =-          PS2.comp (PS.differentiate curve) (tail mean2)+          PS2Core.compose (PSCore.differentiate curve) (tail mean2)    in  meanValuePS - divDiffPS
src/MathObj/PowerSeries2.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,10 +8,10 @@  module MathObj.PowerSeries2 where -import qualified MathObj.PowerSeries    as PS-import qualified MathObj.Polynomial     as Poly+import qualified MathObj.PowerSeries2.Core as Core+import qualified MathObj.PowerSeries as PS+import qualified MathObj.Polynomial.Core as Poly -import qualified Algebra.Differential   as Differential import qualified Algebra.Vector         as Vector import qualified Algebra.Algebraic      as Algebraic import qualified Algebra.Field          as Field@@ -19,16 +19,11 @@ import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable -import qualified NumericPrelude as NP-import qualified PreludeBase as P- import Data.List (isPrefixOf, ) import qualified Data.List.Match as Match -import PreludeBase    hiding (const)-import NumericPrelude hiding (negate, stdUnit,-                              sqrt, exp, log,-                              sin, cos, tan, asin, acos, atan)+import NumericPrelude.Base    hiding (const)+import NumericPrelude.Numeric  {- | In order to handle both variables equivalently@@ -41,9 +36,8 @@ Although the sub-lists are always finite and thus are more like polynomials than power series, division and square root computation are easier to implement for power series. -}-newtype T a = Cons {coeffs :: Core a} deriving (Ord)+newtype T a = Cons {coeffs :: Core.T a} deriving (Ord) -type Core a = [[a]]  isValid :: [[a]] -> Bool isValid = flip isPrefixOf [1..] . map length@@ -73,71 +67,50 @@    map (:[]) (PS.coeffs x)  -lift0 :: Core a -> T a+lift0 :: Core.T a -> T a lift0 = Cons -lift1 :: (Core a -> Core a) -> (T a -> T a)+lift1 :: (Core.T a -> Core.T a) -> (T a -> T a) lift1 f (Cons x0) = Cons (f x0) -lift2 :: (Core a -> Core a -> Core a) -> (T a -> T a -> T a)+lift2 :: (Core.T a -> Core.T a -> Core.T a) -> (T a -> T a -> T a) lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1)  -lift0fromPowerSeries :: [PS.T a] -> Core a-lift0fromPowerSeries = map PS.coeffs--lift1fromPowerSeries :: ([PS.T a] -> [PS.T a]) -> (Core a -> Core a)-lift1fromPowerSeries f x0 = map PS.coeffs (f (map PS.fromCoeffs x0))--lift2fromPowerSeries :: ([PS.T a] -> [PS.T a] -> [PS.T a]) -> (Core a -> Core a -> Core a)-lift2fromPowerSeries f x0 x1 = map PS.coeffs (f (map PS.fromCoeffs x0) (map PS.fromCoeffs x1))-- const :: a -> T a const x = lift0 [[x]]  +{-# INLINE truncate #-}+truncate :: Int -> T a -> T a+truncate n = lift1 (take n)++ instance Functor T where-  fmap f (Cons xs) = Cons (map (map f) xs)+   fmap f (Cons xs) = Cons (map (map f) xs)  appPrec :: Int appPrec  = 10  instance (Show a) => Show (T a) where-  showsPrec p (Cons xs) =-    showParen (p >= appPrec) (showString "PowerSeries2.fromCoeffs " . shows xs)---{- * Series arithmetic -}--add, sub :: (Additive.C a) => Core a -> Core a -> Core a-add = PS.add-sub = PS.sub--negate :: (Additive.C a) => Core a -> Core a-negate = PS.negate+   showsPrec p (Cons xs) =+      showParen (p >= appPrec) (showString "PowerSeries2.fromCoeffs " . shows xs)   instance (Eq a, ZeroTestable.C a) => Eq (T a) where-    (Cons x) == (Cons y) = Poly.equal x y+   (Cons x) == (Cons y) = Poly.equal x y  instance (Additive.C a) => Additive.C (T a) where-    negate = lift1 PS.negate-    (+)    = lift2 PS.add-    (-)    = lift2 PS.sub-    zero   = lift0 []+   negate = lift1 Core.negate+   (+)    = lift2 Core.add+   (-)    = lift2 Core.sub+   zero   = lift0 []  -scale :: Ring.C a => a -> Core a -> Core a-scale = map . (Vector.*>)--mul :: Ring.C a => Core a -> Core a -> Core a-mul = lift2fromPowerSeries PS.mul- instance (Ring.C a) => Ring.C (T a) where-    one           = const one-    fromInteger n = const (fromInteger n)-    (*)           = lift2 mul+   one           = const one+   fromInteger n = const (fromInteger n)+   (*)           = lift2 Core.mul  instance Vector.C T where    zero  = zero@@ -145,50 +118,10 @@    (*>)  = Vector.functorScale  -divide :: (Field.C a) =>-   Core a -> Core a -> Core a-divide = lift2fromPowerSeries PS.divide-- instance (Field.C a) => Field.C (T a) where-  (/) = lift2 divide---sqrt :: (Field.C a) =>-   (a -> a) -> Core a -> Core a-sqrt fSqRt = lift1fromPowerSeries $ PS.sqrt (PS.const . (\[x] -> fSqRt x) . PS.coeffs)+   (/) = lift2 Core.divide   instance (Algebraic.C a) => Algebraic.C (T a) where-   sqrt   = lift1 (sqrt Algebraic.sqrt)---   x ^/ y = lift1 (pow (Algebraic.^/ y)---                       (fromRational' y)) x---swapVariables :: Core a -> Core a-swapVariables = map reverse---differentiate0 :: (Ring.C a) => Core a -> Core a-differentiate0 =-   swapVariables . differentiate1 . swapVariables--differentiate1 :: (Ring.C a) => Core a -> Core a-differentiate1 = lift1fromPowerSeries $ map Differential.differentiate--integrate0 :: (Field.C a) => [a] -> Core a -> Core a-integrate0 cs =-   swapVariables . integrate1 cs . swapVariables--integrate1 :: (Field.C a) => [a] -> Core a -> Core a-integrate1 = zipWith PS.integrate-----{- |-Since the inner series must start with a zero,-the first term is omitted in y.--}-comp :: (Ring.C a) => [a] -> Core a -> Core a-comp = lift1fromPowerSeries . PS.comp . map PS.const+   sqrt   = lift1 (Core.sqrt Algebraic.sqrt)+   x ^/ y = lift1 (Core.pow (Algebraic.^/ y) (fromRational' y)) x
+ src/MathObj/PowerSeries2/Core.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RebindableSyntax #-}+module MathObj.PowerSeries2.Core where++import qualified MathObj.PowerSeries as PS+import qualified MathObj.PowerSeries.Core as PSCore++import qualified Algebra.Differential   as Differential+import qualified Algebra.Vector         as Vector+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import NumericPrelude.Base+++type T a = [[a]]+++lift0fromPowerSeries :: [PS.T a] -> T a+lift0fromPowerSeries = map PS.coeffs++lift1fromPowerSeries ::+   ([PS.T a] -> [PS.T a]) -> (T a -> T a)+lift1fromPowerSeries f x0 =+   map PS.coeffs (f (map PS.fromCoeffs x0))++lift2fromPowerSeries ::+   ([PS.T a] -> [PS.T a] -> [PS.T a]) -> (T a -> T a -> T a)+lift2fromPowerSeries f x0 x1 =+   map PS.coeffs (f (map PS.fromCoeffs x0) (map PS.fromCoeffs x1))+++{- * Series arithmetic -}++add, sub :: (Additive.C a) => T a -> T a -> T a+add = PSCore.add+sub = PSCore.sub++negate :: (Additive.C a) => T a -> T a+negate = PSCore.negate+++scale :: Ring.C a => a -> T a -> T a+scale = map . (Vector.*>)++mul :: Ring.C a => T a -> T a -> T a+mul = lift2fromPowerSeries PSCore.mul+++divide :: (Field.C a) =>+   T a -> T a -> T a+divide = lift2fromPowerSeries PSCore.divide+++sqrt :: (Field.C a) =>+   (a -> a) -> T a -> T a+sqrt fSqRt =+   lift1fromPowerSeries $+   PSCore.sqrt (PS.const . (\[x] -> fSqRt x) . PS.coeffs)++pow :: (Field.C a) =>+   (a -> a) -> a -> T a -> T a+pow fPow expon =+   lift1fromPowerSeries $+   PSCore.pow (PS.const . (\[x] -> fPow x) . PS.coeffs) (PS.const expon)+++swapVariables :: T a -> T a+swapVariables = map reverse+++differentiate0 :: (Ring.C a) => T a -> T a+differentiate0 =+   swapVariables . differentiate1 . swapVariables++differentiate1 :: (Ring.C a) => T a -> T a+differentiate1 = lift1fromPowerSeries $ map Differential.differentiate++integrate0 :: (Field.C a) => [a] -> T a -> T a+integrate0 cs =+   swapVariables . integrate1 cs . swapVariables++integrate1 :: (Field.C a) => [a] -> T a -> T a+integrate1 = zipWith PSCore.integrate++++{- |+Since the inner series must start with a zero,+the first term is omitted in y.+-}+compose :: (Ring.C a) => [a] -> T a -> T a+compose = lift1fromPowerSeries . PSCore.compose . map PS.const
src/MathObj/PowerSum.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |@@ -16,8 +16,9 @@ -} module MathObj.PowerSum where -import qualified MathObj.Polynomial  as Poly-import qualified MathObj.PowerSeries as PS+import qualified MathObj.Polynomial as Poly+import qualified MathObj.Polynomial.Core as PolyCore+import qualified MathObj.PowerSeries.Core as PS  import qualified Algebra.VectorSpace  as VectorSpace import qualified Algebra.Module       as Module@@ -28,14 +29,12 @@ import qualified Algebra.Additive     as Additive import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.Module((*>))- import Control.Monad(liftM2) import qualified Data.List as List import Data.List.HT (shearTranspose, sieve) -import PreludeBase as P hiding (const)-import NumericPrelude as NP+import NumericPrelude.Base as P hiding (const)+import NumericPrelude.Numeric as NP   newtype T a = Cons {sums :: [a]}@@ -91,11 +90,11 @@ fromElemSym :: (Eq a, Ring.C a) => [a] -> [a] fromElemSym s =    fromIntegral (length s - 1) :-      Poly.alternate (divOneFlip s (Poly.differentiate s))+      PolyCore.alternate (divOneFlip s (PolyCore.differentiate s))  divOneFlip :: (Eq a, Ring.C a) => [a] -> [a] -> [a] divOneFlip (1:xs) =-   let aux (y:ys) = y : aux (ys - Poly.scale y xs)+   let aux (y:ys) = y : aux (ys - PolyCore.scale y xs)        aux [] = []    in  aux divOneFlip _ =@@ -104,19 +103,19 @@ fromElemSymDenormalized :: (Field.C a, ZeroTestable.C a) => [a] -> [a] fromElemSymDenormalized s =    fromIntegral (length s - 1) :-      Poly.alternate (PS.derivedLog s)+      PolyCore.alternate (PS.derivedLog s)   toElemSym :: (Field.C a, ZeroTestable.C a) => [a] -> [a] toElemSym p =-   let s' = Poly.mul (Poly.alternate (tail p)) s-       s  = Poly.integrate 1 s'+   let s' = PolyCore.mul (PolyCore.alternate (tail p)) s+       s  = PolyCore.integrate 1 s'    in  s  toElemSymInt :: (Integral.C a, ZeroTestable.C a) => [a] -> [a] toElemSymInt p =-   let s' = Poly.mul (Poly.alternate (tail p)) s-       s  = Poly.integrateInt 1 s'+   let s' = PolyCore.mul (PolyCore.alternate (tail p)) s+       s  = PolyCore.integrateInt 1 s'    in  s  @@ -125,11 +124,11 @@ fromPolynomial =    let aux s =           fromIntegral (length s - 1) :-             Poly.negate (PS.derivedLog s)+             PolyCore.negate (PS.derivedLog s)    in  aux . reverse . Poly.coeffs  elemSymFromPolynomial :: Additive.C a => Poly.T a -> [a]-elemSymFromPolynomial = Poly.alternate . reverse . Poly.coeffs+elemSymFromPolynomial = PolyCore.alternate . reverse . Poly.coeffs  {- toPolynomial is not possible because this had to consume the whole sum sequence. -} @@ -154,13 +153,13 @@ {- Use binomial expansion of (x+y)^n -} add :: (Ring.C a) => [a] -> [a] -> [a] add xs ys =-   let powers = shearTranspose (Poly.tensorProduct xs ys)+   let powers = shearTranspose (PolyCore.tensorProduct xs ys)    in  zipWith Ring.scalarProduct binomials powers  instance (Ring.C a) => Additive.C (T a) where    zero   = const zero    (+)    = lift2 add-   negate = lift1 Poly.alternate+   negate = lift1 PolyCore.alternate   {- * Ring -}@@ -230,4 +229,4 @@        yp = fromPolynomial (Poly.fromRoots ys)        ze = elemSymFromPolynomial (Poly.fromRoots zs)    in  zipWith (==) (toElemSym (powerOp xp yp)) ze-       -- Poly.equal (toElemSym (powerOp xp yp)) ze+       -- PolyCore.equal (toElemSym (powerOp xp yp)) ze
+ src/MathObj/RefinementMask2.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE RebindableSyntax #-}+module MathObj.RefinementMask2 (+   T, coeffs, fromCoeffs,+   fromPolynomial,+   toPolynomial,+   toPolynomialFast,+   refinePolynomial,+   convolvePolynomial,+   convolveTruncatedPowerPolynomials,+   ) where++import qualified MathObj.Polynomial as Poly+import qualified MathObj.Polynomial.Core as PolyCore+import qualified Algebra.RealField as RealField+import qualified Algebra.Field  as Field+import qualified Algebra.Ring   as Ring+import qualified Algebra.Vector as Vector++import qualified Data.List as List+import qualified Data.List.HT as ListHT+import qualified Data.List.Match as Match+import Data.Maybe (fromMaybe, )+import Control.Monad (liftM2, )++import qualified Test.QuickCheck as QC++import qualified NumericPrelude.List.Generic as NPList+import NumericPrelude.Base+import NumericPrelude.Numeric+++{- $setup+>>> import qualified MathObj.RefinementMask2 as Mask+>>> import qualified MathObj.Polynomial      as Poly+>>> import qualified MathObj.Polynomial.Core as PolyCore+>>>+>>> import qualified Algebra.Differential as D+>>> import qualified Algebra.Ring as Ring+>>> import Test.NumericPrelude.Utility ((/\))+>>> import qualified Test.QuickCheck as QC+>>> import NumericPrelude.Numeric as NP+>>> import NumericPrelude.Base as P+>>> import Prelude ()+>>>+>>> import Data.Function.HT (nest)+>>> import Data.Maybe (fromMaybe)+>>>+>>>+>>> hasMultipleZero :: (Ring.C a, Eq a) => Int -> a -> Poly.T a -> Bool+>>> hasMultipleZero n x poly =+>>>    all (zero==) $ take n $+>>>    map (flip Poly.evaluate x) $+>>>    iterate D.differentiate poly+>>>+>>> genAdmissibleMask :: QC.Gen (Mask.T Rational, Poly.T Rational)+>>> genAdmissibleMask =+>>>    QC.suchThatMap QC.arbitrary $+>>>       \mask -> fmap ((,) mask) $ Mask.toPolynomial mask+>>>+>>> polyFromMask :: Mask.T a -> Poly.T a+>>> polyFromMask = Poly.fromCoeffs . Mask.coeffs+>>>+>>> genShortPolynomial :: Int -> QC.Gen (Poly.T Rational)+>>> genShortPolynomial n =+>>>    fmap (Poly.fromCoeffs . PolyCore.normalize . take n) $ QC.arbitrary+-}+++newtype T a = Cons {coeffs :: [a]}+++{-# INLINE fromCoeffs #-}+fromCoeffs :: [a] -> T a+fromCoeffs = lift0++{-# INLINE lift0 #-}+lift0 :: [a] -> T a+lift0 = Cons++{-+{-# INLINE lift1 #-}+lift1 :: ([a] -> [a]) -> (T a -> T a)+lift1 f (Cons x0) = Cons (f x0)++{-# INLINE lift2 #-}+lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a)+lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1)+-}++{-+Functor instance is e.g. useful for converting number types,+say 'Rational' to 'Double'.+-}++instance Functor T where+   fmap f (Cons xs) = Cons (map f xs)++{-# INLINE appPrec #-}+appPrec :: Int+appPrec  = 10++instance (Show a) => Show (T a) where+   showsPrec p (Cons xs) =+      showParen (p >= appPrec)+         (showString "RefinementMask2.fromCoeffs " . shows xs)++instance (QC.Arbitrary a, Field.C a) => QC.Arbitrary (T a) where+   arbitrary =+      liftM2+         (\degree body ->+            let s = sum body+            in  Cons $ map ((2 ^- degree - s) / NPList.lengthLeft body +) body)+         (QC.choose (-5,0)) QC.arbitrary+++{- |+Determine mask by Gauss elimination.++R - alternating binomial coefficients+L - differences of translated polynomials in columns++p2 = L * R^(-1) * m++R * L^(-1) * p2 = m+++prop> genAdmissibleMask /\ \(mask,poly) -> hasMultipleZero (fromMaybe 0 $ Poly.degree poly) 1 (polyFromMask (Mask.fromPolynomial poly) - polyFromMask mask)++prop> genShortPolynomial 5 /\ \poly -> maybe False (Poly.collinear poly) $ Mask.toPolynomial $ Mask.fromPolynomial poly+-}+fromPolynomial ::+   (Field.C a) => Poly.T a -> T a+fromPolynomial poly =+   fromCoeffs $+   foldr (\p ps ->+      ListHT.mapAdjacent (-) (p:ps++[0]))+      [] $+   foldr (\(db,dp) cs ->+      ListHT.switchR+         (error "RefinementMask2.fromPolynomial: polynomial should be non-empty")+         (\dps dpe ->+            cs ++ [(db - Ring.scalarProduct dps cs) / dpe])+         dp) [] $+   zip+      (Poly.coeffs $ Poly.dilate 2 poly)+      (List.transpose $+       Match.take (Poly.coeffs poly) $+       map Poly.coeffs $+       iterate polynomialDifference poly)++polynomialDifference ::+   (Ring.C a) => Poly.T a -> Poly.T a+polynomialDifference poly =+   Poly.fromCoeffs $ init $ Poly.coeffs $+   Poly.translate 1 poly - poly++{- |+If the mask does not sum up to a power of @1/2@+then the function returns 'Nothing'.++>>> fmap ((6::Rational) *>) $ Mask.toPolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005::Rational])+Just (Polynomial.fromCoeffs [-12732 % 109375,272 % 625,-18 % 25,1 % 1])+-}+toPolynomial ::+   (RealField.C a) => T a -> Maybe (Poly.T a)+toPolynomial (Cons []) = Just $ Poly.fromCoeffs []+toPolynomial mask =+   let s = sum $ coeffs mask+       ks = reverse $ takeWhile (<=1) $ iterate (2*) s+   in  case ks of+          1:ks0 ->+             Just $+             foldl+                (\p k ->+                   let ip = Poly.integrate zero p+                   in  ip + Poly.const (correctConstant (fmap (k/s*) mask) ip))+                (Poly.const 1) ks0+          _ -> Nothing++{-+The constant term must be zero,+higher terms must already satisfy the refinement constraint.+-}+correctConstant ::+   (Field.C a) => T a -> Poly.T a -> a+correctConstant mask poly =+   let refined = refinePolynomial mask poly+   in  head (Poly.coeffs refined) / (1 - sum (coeffs mask))++toPolynomialFast ::+   (RealField.C a) => T a -> Maybe (Poly.T a)+toPolynomialFast mask =+   let s = sum $ coeffs mask+       ks = reverse $ takeWhile (<=1) $ iterate (2*) s+   in  case ks of+          1:ks0 ->+             Just $+             foldl+                (\p k ->+                   let ip = Poly.integrate zero p+                       c = head (Poly.coeffs (refinePolynomial mask ip))+                   in  ip + Poly.const (c*k / ((1-k)*s)))+                (Poly.const 1) ks0+          _ -> Nothing++{- |+prop> genShortPolynomial 5 /\ \poly -> poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly++>>> fmap (round :: Double -> Integer) $ fmap (1000000*) $ nest 50 (Mask.refinePolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005])) (Poly.fromCoeffs [0,0,0,1])+Polynomial.fromCoeffs [-116407,435200,-720000,1000000]+-}+refinePolynomial ::+   (Ring.C a) => T a -> Poly.T a -> Poly.T a+refinePolynomial mask =+   Poly.shrink 2 .+   Vector.linearComb (coeffs mask) .+   iterate (Poly.translate 1)++convolve ::+   (Ring.C a) => T a -> T a -> T a+convolve x y =+   fromCoeffs $+   PolyCore.mul (coeffs x) (coeffs y)++{- |+Convolve polynomials via refinement mask.++(mask x + ux*(-1,1)^degree x) * (mask y + uy*(-1,1)^degree y)+-}+convolvePolynomial ::+   (RealField.C a) =>+   Poly.T a -> Poly.T a -> Poly.T a+convolvePolynomial x y =+   fromMaybe+      (error "RefinementMask2.convolvePolynomial: leading term should always be correct") $+   toPolynomial $ fmap (/2) $+   convolve (fromPolynomial x) (fromPolynomial y)++{-+This function interprets all monomials as truncated power functions,+that is power functions that are set to zero for negative arguments.+However the convolution implied by this interpretation+cannot be represented by means of mask convolution.+See for instance:++*MathObj.RefinementMask2> let x = Poly.fromCoeffs [1,1] :: Poly.T Rational+*MathObj.RefinementMask2> fromPolynomial $ convolvePolynomial2 x x+RefinementMask2.fromCoeffs [1 % 3,-1 % 8,-1 % 8,1 % 24]++The obtained mask cannot be factored,+thus it is not a complete square.+But maybe it becomes a square if we add u*(-1,1)^4.+However this mask has sum 1/8 and the added term has sum 0,+thus the sum of the modified mask is still 1/8 and thus not a square.+-}+convolveTruncatedPowerPolynomials ::+   (RealField.C a) =>+   Poly.T a -> Poly.T a -> Poly.T a+convolveTruncatedPowerPolynomials x y =+   let facs = scanl (*) 1 $ iterate (1+) 1+       xl = Poly.coeffs x+       yl = Poly.coeffs y+   in  Poly.integrate 0 $+       Poly.fromCoeffs $+       zipWith (flip (/)) facs $+       PolyCore.mul+          (zipWith (*) facs xl)+          (zipWith (*) facs yl)
src/MathObj/RootSet.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright   :  (c) Henning Thielemann 2004-2005 @@ -15,8 +15,9 @@ -} module MathObj.RootSet where -import qualified MathObj.Polynomial  as Poly-import qualified MathObj.PowerSum    as PowerSum+import qualified MathObj.Polynomial      as Poly+import qualified MathObj.Polynomial.Core as PolyCore+import qualified MathObj.PowerSum        as PowerSum  import qualified Algebra.Algebraic    as Algebraic import qualified Algebra.IntegralDomain as Integral@@ -25,11 +26,14 @@ import qualified Algebra.Additive     as Additive import qualified Algebra.ZeroTestable as ZeroTestable +import qualified Algebra.RealRing     as RealRing+ import qualified Data.List.Match as Match-import Control.Monad (liftM2)+import qualified Data.List.Key as Key+import Control.Monad (liftM2, replicateM, ) -import PreludeBase as P hiding (const)-import NumericPrelude as NP+import NumericPrelude.Base as P hiding (const)+import NumericPrelude.Numeric as NP   newtype T a = Cons {coeffs :: [a]}@@ -51,11 +55,11 @@ const x = Cons [1,x]  -toPolynomial :: Poly.T a -> T a-toPolynomial xs = Cons (reverse (Poly.coeffs xs))+toPolynomial :: T a -> Poly.T a+toPolynomial (Cons xs) = Poly.fromCoeffs (reverse xs) -fromPolynomial :: T a -> Poly.T a-fromPolynomial (Cons xs) = Poly.fromCoeffs (reverse xs)+fromPolynomial :: Poly.T a -> T a+fromPolynomial xs = Cons (reverse (Poly.coeffs xs))   @@ -69,7 +73,7 @@ {- | cf. 'MathObj.Polynomial.mulLinearFactor' -} addRoot :: Ring.C a => a -> [a] -> [a] addRoot x yt@(y:ys) =-   y : (ys + Poly.scale x yt)+   y : (ys + PolyCore.scale x yt) addRoot _ [] =    error "addRoot: list of elementar symmetric terms must consist at least of a 1" @@ -132,7 +136,7 @@ instance (Field.C a, ZeroTestable.C a) => Additive.C (T a) where    zero   = const zero    (+)    = lift2 add-   negate = lift1 Poly.alternate+   negate = lift1 PolyCore.alternate   {- * Ring -}@@ -168,3 +172,32 @@  instance (Field.C a, ZeroTestable.C a) => Algebraic.C (T a) where    root n = lift1 (PowerSum.root n)++++{- |+Given an approximation of a root,+the degree of the polynomial and maximum value of coefficients,+find candidates of polynomials that have approximately this root+and show the actual value of the polynomial at the given root approximation.++This algorithm runs easily into a stack overflow, I do not know why.+We may also employ a more sophisticated integer relation algorithm,+like PSLQ and friends.+-}+{-# SPECIALISE approxPolynomial ::+       Int -> Integer -> Double -> (Double, Poly.T Double) #-}+{-# SPECIALISE approxPolynomial ::+       Int -> Integer -> Float -> (Float, Poly.T Float) #-}+approxPolynomial ::+   (RealRing.C a) =>+   Int -> Integer -> a -> (a, Poly.T a)+approxPolynomial d maxCoeff x =+   let powers = take (d+1) $ iterate (x*) one+   in  -- List.minimumBy (\a b -> compare (abs (fst a)) (abs (fst b))) $+       Key.minimum (abs . fst) $+       map+          ((\cs -> (sum $ zipWith (*) powers cs, Poly.fromCoeffs cs)) . reverse)+          (liftM2 (:)+             (map fromInteger [1 .. maxCoeff])+             (replicateM d $ map fromInteger [-maxCoeff .. maxCoeff]))
+ src/MathObj/Wrapper/Haskell98.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{- |+A wrapper that provides instances of Haskell 98 and NumericPrelude+numeric type classes+for types that have Haskell 98 instances.+-}+module MathObj.Wrapper.Haskell98 where++import qualified Algebra.Absolute as Absolute+import qualified Algebra.Additive as Additive+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.FloatingPoint as Float+import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.RealField as RealField+import qualified Algebra.RealIntegral as RealIntegral+import qualified Algebra.RealRing as RealRing+import qualified Algebra.RealTranscendental as RealTrans+import qualified Algebra.Ring as Ring+import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.ToRational as ToRational+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Units as Units+import qualified Algebra.ZeroTestable as ZeroTestable++import qualified Number.Ratio as Ratio++import qualified Algebra.RealRing98 as RealRing98++import Data.Ix (Ix, )++import Data.Tuple.HT (mapPair, )+++{- |+This makes a type usable in the NumericPrelude framework+that was initially implemented for Haskell98 typeclasses.+E.g. if @a@ is in class 'Num',+then @T a@ is both in class 'Num' and in 'Ring.C'.++You can even lift container types.+If @Polynomial a@ is in 'Num' for all types @a@ that are in 'Num',+then @T (Polynomial (MathObj.Wrapper.NumericPrelude.T a))@+is in 'Ring.C' for all types @a@ that are in 'Ring.C'.+-}+newtype T a = Cons {decons :: a}+   deriving+      (Show, Eq, Ord, Ix, Bounded, Enum,+       Num, Integral, Fractional, Floating,+       Real, RealFrac, RealFloat)+++{-# INLINE lift1 #-}+lift1 :: (a -> b) -> T a -> T b+lift1 f (Cons a) = Cons (f a)++{-# INLINE lift2 #-}+lift2 :: (a -> b -> c) -> T a -> T b -> T c+lift2 f (Cons a) (Cons b) = Cons (f a b)+++{-# INLINE unliftF1 #-}+unliftF1 :: Functor f => (f (T a) -> f (T b)) -> f a -> f b+unliftF1 f a = fmap decons $ f (fmap Cons a)++{-# INLINE unliftF2 #-}+unliftF2 :: Functor f => (f (T a) -> f (T b) -> f (T c)) -> f a -> f b -> f c+unliftF2 f a b = fmap decons $ f (fmap Cons a) (fmap Cons b)+++instance Functor T where+   {-# INLINE fmap #-}+   fmap f (Cons a) = Cons (f a)+++instance Num a => Additive.C (T a) where+   zero = 0+   (+) = lift2 (+)+   (-) = lift2 (-)+   negate = lift1 negate++instance (Num a) => Ring.C (T a) where+   fromInteger = Cons . fromInteger+   (*) = lift2 (*)+   (^) a n = lift1 (^n) a++instance (Fractional a) => Field.C (T a) where+   fromRational' r = Cons (fromRational (Ratio.toRational98 r))+   (/) = lift2 (/)+   recip = lift1 recip+   (^-) a n = lift1 (^^n) a++instance (Floating a) => Algebraic.C (T a) where+   sqrt = lift1 sqrt+   (^/) a r = lift1 (** fromRational (Ratio.toRational98 r)) a+   root n a = lift1 (** recip (fromInteger n)) a++instance (Floating a) => Trans.C (T a) where+   pi      = Cons pi+   log     = lift1 log+   exp     = lift1 exp+   logBase = lift2 logBase+   (**)    = lift2 (**)+   cos     = lift1 cos+   tan     = lift1 tan+   sin     = lift1 sin+   acos    = lift1 acos+   atan    = lift1 atan+   asin    = lift1 asin+   cosh    = lift1 cosh+   tanh    = lift1 tanh+   sinh    = lift1 sinh+   acosh   = lift1 acosh+   atanh   = lift1 atanh+   asinh   = lift1 asinh++instance (Integral a) => Integral.C (T a) where+   div = lift2 div+   mod = lift2 mod+   divMod (Cons a) (Cons b) =+      mapPair (Cons, Cons) (divMod a b)++instance (Integral a) => Units.C (T a) where+   isUnit = unimplemented "isUnit"+   stdAssociate = unimplemented "stdAssociate"+   stdUnit = unimplemented "stdUnit"+   stdUnitInv = unimplemented "stdUnitInv"++instance (Integral a) => PID.C (T a) where+   gcd = gcd+   lcm = lcm++instance (Eq a, Num a) => ZeroTestable.C (T a) where+   isZero (Cons a) = a==0++instance (Num a) => Absolute.C (T a) where+   abs = abs+   signum = signum++instance (RealFrac a) => RealRing.C (T a) where+   splitFraction (Cons a) =+      mapPair (Ring.fromInteger, Cons)+         (RealRing98.fixSplitFraction (properFraction a))+   fraction (Cons a) =+      Cons (RealRing98.fixFraction (RealRing98.signedFraction a))+   ceiling (Cons a) = Ring.fromInteger (ceiling a)+   floor (Cons a) = Ring.fromInteger (floor a)+   truncate (Cons a) = Ring.fromInteger (truncate a)+   round (Cons a) = Ring.fromInteger (round a)++instance (RealFrac a) => RealField.C (T a) where++instance (RealFloat a) => RealTrans.C (T a) where+   atan2 = atan2++instance (Integral a) => RealIntegral.C (T a) where+   quot = lift2 quot+   rem = lift2 rem+   quotRem (Cons a) (Cons b) =+      mapPair (Cons, Cons) (quotRem a b)++instance (Integral a) => ToInteger.C (T a) where+   toInteger (Cons a) = toInteger a++instance (Real a) => ToRational.C (T a) where+   toRational (Cons a) = Field.fromRational (toRational a)++instance (RealFloat a) => Float.C (T a) where+   radix = floatRadix . decons+   digits = floatDigits . decons+   range = floatRange . decons+   decode = decodeFloat . decons+   encode m = Cons . encodeFloat m+   exponent = exponent . decons+   significand = lift1 significand+   scale = lift1 . scaleFloat+   isNaN = isNaN . decons+   isInfinite = isInfinite . decons+   isDenormalized = isDenormalized . decons+   isNegativeZero = isNegativeZero . decons+   isIEEE = isIEEE . decons++++unimplemented :: String -> a+unimplemented name =+   error (name ++ "cannot be implemented in terms of Haskell98 type classes")
+ src/MathObj/Wrapper/NumericPrelude.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{- |+A wrapper that provides instances of Haskell 98 and NumericPrelude+numeric type classes+for types that have NumericPrelude instances.+-}+module MathObj.Wrapper.NumericPrelude where++import qualified Algebra.Absolute as Absolute+import qualified Algebra.Additive as Additive+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.FloatingPoint as Float+import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.RealField as RealField+import qualified Algebra.RealIntegral as RealIntegral+import qualified Algebra.RealRing as RealRing+import qualified Algebra.RealTranscendental as RealTrans+import qualified Algebra.Ring as Ring+import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.ToRational as ToRational+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Units as Units+import qualified Algebra.ZeroTestable as ZeroTestable++import qualified Algebra.NormedSpace.Euclidean as NormEuc+import qualified Algebra.NormedSpace.Maximum as NormMax+import qualified Algebra.NormedSpace.Sum as NormSum+import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Differential as Differential+import qualified Algebra.DivisibleSpace as Divisible+import qualified Algebra.VectorSpace as VectorSpace+import qualified Algebra.Module as Module++import qualified Number.Ratio as Ratio++import Data.Ix (Ix, )++import Data.Tuple.HT (mapPair, )+++{- |+This makes a type usable with Haskell98 type classes+that was initially implemented for NumericPrelude typeclasses.+E.g. if @a@ is in class 'Ring.C',+then @T a@ is both in class 'Num' and in 'Ring.C'.++You can even lift container types.+If @Polynomial a@ is in 'Ring.C' for all types @a@ that are in 'Ring.C',+then @T (Polynomial (MathObj.Wrapper.Haskell98.T a))@+is in 'Num' for all types @a@ that are in 'Num'.+-}+newtype T a = Cons {decons :: a}+   deriving+      (Show, Eq, Ord, Ix, Bounded, Enum,+       Ring.C, Additive.C, Field.C, Algebraic.C, Trans.C,+       Integral.C, PID.C, Units.C,+       Absolute.C, ZeroTestable.C,+       RealField.C, RealIntegral.C, RealRing.C, RealTrans.C,+       ToInteger.C, ToRational.C, Float.C,+       Differential.C)++{-# INLINE lift1 #-}+lift1 :: (a -> b) -> T a -> T b+lift1 f (Cons a) = Cons (f a)++{-# INLINE lift2 #-}+lift2 :: (a -> b -> c) -> T a -> T b -> T c+lift2 f (Cons a) (Cons b) = Cons (f a b)+++instance Functor T where+   {-# INLINE fmap #-}+   fmap f (Cons a) = Cons (f a)+++{-+instance Enum a => Enum (T a) where+   succ (Cons n) = Cons (succ n)+   pred (Cons n) = Cons (pred n)+   toEnum n = Cons (toEnum n)+   fromEnum (Cons n) = fromEnum n+   enumFrom (Cons n) =+      map Cons (enumFrom n)+   enumFromThen (Cons n) (Cons m) =+      map Cons (enumFromThen n m)+   enumFromTo (Cons n) (Cons m) =+      map Cons (enumFromTo n m)+   enumFromThenTo (Cons n) (Cons m) (Cons p) =+      map Cons (enumFromThenTo n m p)+-}++instance (Ring.C a, Absolute.C a, Eq a, Show a) => Num (T a) where+   (+) = lift2 (Additive.+)+   (-) = lift2 (Additive.-)+   negate = lift1 Additive.negate++   fromInteger = Cons . Ring.fromInteger+   (*) = lift2 (Ring.*)++   abs = lift1 Absolute.abs+   signum = lift1 Absolute.signum++instance (RealIntegral.C a, Absolute.C a, ToInteger.C a, Ord a, Enum a, Show a) => Integral (T a) where+   quot = lift2 RealIntegral.quot+   rem = lift2 RealIntegral.rem+   quotRem (Cons a) (Cons b) =+      mapPair (Cons, Cons) (RealIntegral.quotRem a b)+   div = lift2 Integral.div+   mod = lift2 Integral.mod+   divMod (Cons a) (Cons b) =+      mapPair (Cons, Cons) (Integral.divMod a b)+   toInteger (Cons a) = ToInteger.toInteger a++instance (Field.C a, Absolute.C a, Eq a, Show a) => Fractional (T a) where+   (/) = lift2 (Field./)+   recip = lift1 Field.recip+   fromRational = Cons . Field.fromRational++instance (Trans.C a, Absolute.C a, Eq a, Show a) => Floating (T a) where+   sqrt    = lift1 Algebraic.sqrt+   pi      = Cons Trans.pi+   log     = lift1 Trans.log+   exp     = lift1 Trans.exp+   logBase = lift2 Trans.logBase+   (**)    = lift2 (Trans.**)+   cos     = lift1 Trans.cos+   tan     = lift1 Trans.tan+   sin     = lift1 Trans.sin+   acos    = lift1 Trans.acos+   atan    = lift1 Trans.atan+   asin    = lift1 Trans.asin+   cosh    = lift1 Trans.cosh+   tanh    = lift1 Trans.tanh+   sinh    = lift1 Trans.sinh+   acosh   = lift1 Trans.acosh+   atanh   = lift1 Trans.atanh+   asinh   = lift1 Trans.asinh++instance (ToRational.C a, Absolute.C a, Ord a, Show a) => Real (T a) where+   toRational (Cons a) =+      Ratio.toRational98 (ToRational.toRational a)++instance (Field.C a, RealRing.C a, ToRational.C a, Absolute.C a, Ord a, Show a) => RealFrac (T a) where+   properFraction (Cons a) =+      let b = RealRing.truncate a+      in  (fromInteger b, Cons (a Additive.- Ring.fromInteger b))+   ceiling (Cons a) = fromInteger (RealRing.ceiling a)+   floor (Cons a) = fromInteger (RealRing.floor a)+   truncate (Cons a) = fromInteger (RealRing.truncate a)+   round (Cons a) = fromInteger (RealRing.round a)++instance (RealTrans.C a, Float.C a, ToRational.C a, Absolute.C a, Ord a, Show a) => RealFloat (T a) where+   atan2 = RealTrans.atan2+   floatRadix = Float.radix . decons+   floatDigits = Float.digits . decons+   floatRange = Float.range . decons+   decodeFloat = Float.decode . decons+   encodeFloat m = Cons . Float.encode m+   exponent = Float.exponent . decons+   significand = lift1 Float.significand+   scaleFloat = lift1 . Float.scale+   isNaN = Float.isNaN . decons+   isInfinite = Float.isInfinite . decons+   isDenormalized = Float.isDenormalized . decons+   isNegativeZero = Float.isNegativeZero . decons+   isIEEE = Float.isIEEE . decons++{-+instance Additive.C (T a) where+instance Ring.C (T a) where+instance Field.C (T a) where+instance Algebraic.C (T a) where+instance Trans.C (T a) where++instance Units.C (T a) where+instance Integral.C (T a) where+instance PID.C (T a) where++instance ZeroTestable.C (T a) where+instance Absolute.C (T a) where+instance (Ord a) => RealField.C (T a) where+instance (Ord a) => RealIntegral.C (T a) where+instance (Ord a) => RealRing.C (T a) where+instance (Ord a) => RealTrans.C (T a) where++instance (Ord a) => ToInteger.C (T a) where+instance (Ord a) => ToRational.C (T a) where+-}++instance Module.C a v => Module.C (T a) (T v) where+   (*>) = lift2 (Module.*>)++instance VectorSpace.C a v => VectorSpace.C (T a) (T v) where++instance Divisible.C a v => Divisible.C (T a) (T v) where+   (</>) = lift2 (Divisible.</>)++instance OccScalar.C a v => OccScalar.C (T a) (T v) where+   toScalar = lift1 OccScalar.toScalar+   toMaybeScalar (Cons a) = fmap Cons (OccScalar.toMaybeScalar a)+   fromScalar = lift1 OccScalar.fromScalar++instance NormEuc.Sqr a v => NormEuc.Sqr (T a) (T v) where+   normSqr = lift1 NormEuc.normSqr++instance NormEuc.C a v => NormEuc.C (T a) (T v) where+   norm = lift1 NormEuc.norm++instance NormMax.C a v => NormMax.C (T a) (T v) where+   norm = lift1 NormMax.norm++instance NormSum.C a v => NormSum.C (T a) (T v) where+   norm = lift1 NormSum.norm+++unimplemented :: String -> a+unimplemented name =+   error (name ++ "cannot be implemented in terms of NumericPrelude type classes")
− src/MyPrelude.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module MyPrelude(module NumericPrelude, module PreludeBase, max, min, abs) where-import NumericPrelude hiding (abs)-import PreludeBase hiding (max,min)-import Algebra.Lattice (max,min,abs)
src/Number/Complex.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- Rules should be processed -}@@ -32,6 +32,7 @@         fromPolar,         cis,         signum,+        signumNorm,         toPolar,         magnitude,         magnitudeSqr,@@ -47,12 +48,12 @@         defltPow,         )  where --- import qualified Number.Ratio as Ratio  import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum       as NormedSum import qualified Algebra.NormedSpace.Maximum   as NormedMax +import qualified Algebra.OccasionallyScalar as OccScalar import qualified Algebra.VectorSpace        as VectorSpace import qualified Algebra.Module             as Module import qualified Algebra.Vector             as Vector@@ -63,15 +64,14 @@ import qualified Algebra.Units              as Units import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.IntegralDomain     as Integral-import qualified Algebra.Real               as Real+import qualified Algebra.RealRing           as RealRing+import qualified Algebra.Absolute           as Absolute import qualified Algebra.Ring               as Ring import qualified Algebra.Additive           as Additive import qualified Algebra.ZeroTestable       as ZeroTestable import qualified Algebra.Indexable          as Indexable -import Algebra.ZeroTestable(isZero)-import Algebra.Module((*>), (<*>.*>), )-import Algebra.Algebraic((^/), )+import Algebra.Module((<*>.*>), )  import qualified NumericPrelude.Elementwise as Elem import Algebra.Additive ((<*>.+), (<*>.-), (<*>.-$), )@@ -81,16 +81,17 @@ import Control.Applicative (liftA2, )  import Test.QuickCheck (Arbitrary, arbitrary, )-import Control.Monad (liftM2, )+import Control.Monad (liftM2, guard, ) +import qualified MathObj.Wrapper.Haskell98 as W98+ import qualified Prelude as P-import PreludeBase-import NumericPrelude hiding (signum, exp, )+import NumericPrelude.Base+import NumericPrelude.Numeric hiding (signum, exp, ) import Text.Show.HT (showsInfixPrec, ) import Text.Read.HT (readsInfixPrec, )  --- import qualified Data.Typeable as Ty  infix  6  +:, `Cons` @@ -122,6 +123,10 @@ instance (Read a) => Read (T a) where    readsPrec prec = readsInfixPrec "+:" plusPrec prec (+:) +instance Functor T where+   {-# INLINE fmap #-}+   fmap f (Cons x y) = Cons (f x) (f y)+ instance (Arbitrary a) => Arbitrary (T a) where    {-# INLINE arbitrary #-}    arbitrary = liftM2 Cons arbitrary arbitrary@@ -165,7 +170,7 @@ {- SPECIALISE scale :: Double -> T Double -> T Double -} {-# INLINE scale #-} scale :: (Ring.C a) => a -> T a -> T a-scale r (Cons x y) =  Cons (r * x) (r * y)+scale r =  fmap (r*)  -- | Exponential of a complex number with minimal type class constraints. {-# INLINE exp #-}@@ -181,16 +186,25 @@  {- | Scale a complex number to magnitude 1. -For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@,-but oriented in the positive real direction, whereas @'signum' z@-has the phase of @z@, but unit magnitude.+For a complex number @z@,+@'abs' z@ is a number with the magnitude of @z@,+but oriented in the positive real direction,+whereas @'signum' z@ has the phase of @z@, but unit magnitude. -}+ {- SPECIALISE signum :: T Double -> T Double -}-{-# INLINE signum #-}-signum :: (Algebraic.C a, NormedEuc.C a a, ZeroTestable.C a) => T a -> T a+signum :: (Algebraic.C a, ZeroTestable.C a) => T a -> T a signum z =    if isZero z      then zero+     else scale (recip (magnitude z)) z++{- SPECIALISE signumNorm :: T Double -> T Double -}+{-# INLINE signumNorm #-}+signumNorm :: (Algebraic.C a, NormedEuc.C a a, ZeroTestable.C a) => T a -> T a+signumNorm z =+   if isZero z+     then zero      else scale (recip (NormedEuc.norm z)) z  -- | Form a complex number from polar components of magnitude and phase.@@ -206,7 +220,7 @@ cis :: (Trans.C a) => a -> T a cis theta =  Cons (cos theta) (sin theta) -propPolar :: (RealTrans.C a) => T a -> Bool+propPolar :: (RealTrans.C a, ZeroTestable.C a) => T a -> Bool propPolar z =  uncurry fromPolar (toPolar z) == z  @@ -262,7 +276,7 @@ the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase. -}-toPolar :: (RealTrans.C a) => T a -> (a,a)+toPolar :: (RealTrans.C a, ZeroTestable.C a) => T a -> (a,a) toPolar z = (magnitude z, phase z)  @@ -305,6 +319,14 @@     {-# INLINE fromInteger #-}     fromInteger                 =  fromReal . fromInteger +instance  (Absolute.C a, Algebraic.C a, ZeroTestable.C a) => Absolute.C (T a)  where+    {- SPECIALISE instance Absolute.C (T Float) -}+    {- SPECIALISE instance Absolute.C (T Double) -}+    {-# INLINE abs #-}+    {-# INLINE signum #-}+    abs x  = Cons (magnitude x) zero+    signum = signum+ instance Vector.C T where    {-# INLINE zero #-}    zero  = zero@@ -338,12 +360,19 @@    {-# INLINE norm #-}    norm x = max (NormedMax.norm (real x)) (NormedMax.norm (imag x)) +instance (Show v, ZeroTestable.C v, Additive.C v, OccScalar.C a v) => OccScalar.C a (T v) where+   toScalar        = OccScalar.toScalarShow+   toMaybeScalar x =+      guard (isZero (imag x)) >>+      OccScalar.toMaybeScalar (real x)+   fromScalar      = fromReal . OccScalar.fromScalar + {-   In this implementation the complex plane is structured   as an orthogonal grid induced by the divisor z'.   The coordinate of a cell within this grid is returned as quotient-  and the position with a cell is returned as remainder.+  and the position of the cell in the grid is returned as remainder.   The magnitude of the remainder might be larger than that of the divisor   thus the Euclidean algorithm can fail. -}@@ -352,9 +381,7 @@     divMod z z' =        let denom = magnitudeSqr z'            zBig  = z * conjugate z'-           re    = divMod (real zBig) denom-           im    = divMod (imag zBig) denom-           q     = Cons (fst re) (fst im)+           q     = fmap (flip div denom) zBig        in  (q, z-q*z')  @@ -457,7 +484,7 @@   {-# INLINE defltPow #-}-defltPow :: (RealTrans.C a) =>+defltPow :: (RealTrans.C a, ZeroTestable.C a) =>     Rational -> T a -> T a defltPow r x =     let (mag,arg) = toPolar x@@ -474,21 +501,22 @@     power  =  defltPow  -instance  (Real.C a, Algebraic.C a, Power a) =>+instance  (RealRing.C a, Algebraic.C a, Power a) =>           Algebraic.C (T a)  where+    -- | the real part of the result is always non-negative     {-# INLINE sqrt #-}     sqrt z@(Cons x y)  =  if z == zero                             then zero                             else-                              let v'    = abs y / (u'*2)-                                  u'    = sqrt ((magnitude z + abs x) / 2)+                              let u'    = sqrt ((magnitude z + abs x) / 2)+                                  v'    = abs y / (u'*2)                                   (u,v) = if x < 0 then (v',u') else (u',v')                               in  Cons u (if y < 0 then -v else v)     {-# INLINE (^/) #-}     (^/) = flip power  -instance  (Real.C a, RealTrans.C a, Power a) =>+instance  (RealRing.C a, RealTrans.C a, ZeroTestable.C a, Power a) =>           Trans.C (T a)  where     {- SPECIALISE instance Trans.C (T Float) -}     {- SPECIALISE instance Trans.C (T Double) -}@@ -525,29 +553,25 @@ -}  -{- * legacy instances -}--{-# INLINE legacyInstance #-}-legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"+-- * Haskell 98 legacy instances -instance (Ring.C a, Eq a, Show a) => P.Num (T a) where+-- legacy instances for use of numeric literals in GHCi+instance (P.Floating a, Eq a) => P.Num (T a) where    {-# INLINE fromInteger #-}-   fromInteger = fromReal . fromInteger+   fromInteger n = Cons (P.fromInteger n) (P.fromInteger 0)    {-# INLINE negate #-}-   negate = negate -- for unary minus+   negate = W98.unliftF1 Additive.negate    {-# INLINE (+) #-}-   (+)    = legacyInstance+   (+)    = W98.unliftF2 (Additive.+)    {-# INLINE (*) #-}-   (*)    = legacyInstance+   (*)    = W98.unliftF2 (Ring.*)    {-# INLINE abs #-}-   abs    = legacyInstance+   abs    = W98.unliftF1 Absolute.abs    {-# INLINE signum #-}-   signum = legacyInstance+   signum = W98.unliftF1 Absolute.signum -instance (Field.C a, Eq a, Show a) => P.Fractional (T a) where+instance (P.Floating a, Eq a) => P.Fractional (T a) where    {-# INLINE fromRational #-}-   fromRational = fromRational+   fromRational x = Cons (P.fromRational x) (P.fromInteger 0)    {-# INLINE (/) #-}-   (/) = legacyInstance+   (/) = W98.unliftF2 (Field./)
src/Number/DimensionTerm.hs view
@@ -1,14 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2008-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable-- See "Algebra.DimensionTerm". -} @@ -20,7 +12,7 @@ import qualified Algebra.Module        as Module import qualified Algebra.Algebraic     as Algebraic import qualified Algebra.Field         as Field-import qualified Algebra.Real          as Real+import qualified Algebra.Absolute      as Absolute import qualified Algebra.Ring          as Ring import qualified Algebra.Additive      as Additive @@ -31,8 +23,10 @@  import System.Random (Random, randomR, random) +import Control.DeepSeq (NFData(rnf), )+ import Data.Tuple.HT (mapFst, )-import PreludeBase+import NumericPrelude.Base import Prelude ()  @@ -51,7 +45,10 @@             (showString "DimensionNumber.fromNumberWithDimension " . showsPrec Dim.appPrec u .              showString " " . showsPrec Dim.appPrec z) +instance NFData a => NFData (T u a) where+   rnf (Cons x) = rnf x + fromNumber :: a -> Scalar a fromNumber = Cons @@ -139,11 +136,11 @@ sqrt (Cons x) = Cons (Algebraic.sqrt x)  -abs :: (Dim.C u, Real.C a) => T u a -> T u a-abs (Cons x) = Cons (Real.abs x)+abs :: (Dim.C u, Absolute.C a) => T u a -> T u a+abs (Cons x) = Cons (Absolute.abs x) -absSignum :: (Dim.C u, Real.C a) => T u a -> (T u a, a)-absSignum x0@(Cons x) = (abs x0, Real.signum x)+absSignum :: (Dim.C u, Absolute.C a) => T u a -> (T u a, a)+absSignum x0@(Cons x) = (abs x0, Absolute.signum x)  scale, (*&) :: (Dim.C u, Ring.C a) =>    a -> T u a -> T u a
src/Number/DimensionTerm/SI.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2003-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable- Special physical units: SI unit system -} @@ -38,15 +31,13 @@     SI.exa,   SI.zetta, SI.yotta,     ) where --- import qualified Algebra.Transcendental      as Trans import qualified Algebra.Field               as Field --- import qualified Algebra.DimensionTerm as Dim import qualified Number.DimensionTerm  as DN import qualified Number.SI.Unit as SI --- aimport PreludeBase hiding (length)-import NumericPrelude hiding (one)+-- aimport NumericPrelude.Base hiding (length)+import NumericPrelude.Numeric hiding (one)   second  :: Field.C a => DN.Time        a
src/Number/FixedPoint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Copyright   :  (c) Henning Thielemann 2006 @@ -16,31 +16,30 @@ -} module Number.FixedPoint where -import qualified Algebra.RealField    as RealField-import qualified Algebra.Additive       as Additive--- import qualified Algebra.ZeroTestable   as ZeroTestable+import qualified Algebra.RealRing    as RealRing import qualified Algebra.Transcendental as Trans import qualified MathObj.PowerSeries.Example as PSE +import qualified Data.List.Reverse.StrictElement as Rev import NumericPrelude.List (mapLast, ) import Data.Function.HT (powerAssociative, )-import Data.List.HT (dropWhileRev, padLeft, )+import Data.List.HT (padLeft) import Data.Maybe.HT (toMaybe, ) import Data.List (transpose, unfoldr, ) import Data.Char (intToDigit, ) -import PreludeBase-import NumericPrelude hiding (recip, sqrt, exp, sin, cos, tan,+import NumericPrelude.Base+import NumericPrelude.Numeric hiding (recip, sqrt, exp, sin, cos, tan,                               fromRational') -import qualified NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP   {- ** Conversion -}  {- ** other number types -} -fromFloat :: RealField.C a => Integer -> a -> Integer+fromFloat :: RealRing.C a => Integer -> a -> Integer fromFloat den x =    round (x * NP.fromInteger den) @@ -60,7 +59,7 @@        basis = ringPower packetSize 10        (int,frac) = toPositional basis den x    in  show int ++ "." ++-          concat (mapLast (dropWhileRev ('0'==))+          concat (mapLast (Rev.dropWhile ('0'==))              (map (padLeft '0' packetSize . show) frac))  showPositionalHex :: Integer -> Integer -> String@@ -123,6 +122,12 @@ {- Maybe we can speed up the algorithm by calling sqrt recursively on deflated arguments.++ToDo:+The algorithm just computes floor(sqrt(den*x)).+We might factor out the algorithm for (floor.sqrt)+and move it to a different module+together with Fermat factors and so on. -} sqrt :: Integer -> Integer -> Integer sqrt den x =
src/Number/FixedPoint/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Number.FixedPoint.Check where  import qualified Number.FixedPoint as FP@@ -7,18 +7,18 @@  import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic      as Algebraic-import qualified Algebra.RealField      as RealField+import qualified Algebra.RealRing      as RealRing import qualified Algebra.Field          as Field-import qualified Algebra.Real           as Real+import qualified Algebra.Absolute           as Absolute import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable -import PreludeBase-import NumericPrelude   hiding (fromRational')+import NumericPrelude.Base+import NumericPrelude.Numeric   hiding (fromRational')  import qualified Prelude        as P98-import qualified NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP   {- * Types -}@@ -33,7 +33,7 @@  {- ** other number types -} -fromFloat :: RealField.C a => Integer -> a -> T+fromFloat :: RealRing.C a => Integer -> a -> T fromFloat den x =    cons den (FP.fromFloat den x) @@ -45,7 +45,7 @@ fromRational' den x =    cons den (round (x * NP.fromInteger den)) -fromFloatBasis :: RealField.C a => Integer -> Int -> a -> T+fromFloatBasis :: RealRing.C a => Integer -> Int -> a -> T fromFloatBasis basis numDigits =    fromFloat (ringPower numDigits basis) @@ -165,30 +165,26 @@    compare (Cons xd xn) (Cons yd yn) =       commonDenominator xd yd (compare xn yn) -instance Real.C T where+instance Absolute.C T where    abs = lift1 (const abs)-   -- use default implementation for signum+   signum = Absolute.signumOrd -instance RealField.C T where+instance RealRing.C T where    splitFraction (Cons xd xn) =       let (int, frac) = divMod xd xn       in  (fromInteger int, Cons xd frac)   --- legacy instances for work with GHCi-legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"-+-- legacy instances for use of numeric literals in GHCi instance P98.Num T where    fromInteger = fromInteger' defltDenominator-   negate = negate --for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance+   negate = negate -- for unary minus+   (+)    = (+)+   (*)    = (*)+   abs    = abs+   signum = signum  instance P98.Fractional T where    fromRational = fromRational' defltDenominator . fromRational-   (/) = legacyInstance+   (/) = (/)
src/Number/GaloisField2p32m5.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {- | This number type is intended for tests of functions over fields,@@ -7,11 +7,12 @@ For 'Rational' this would not be possible.  However, be aware that sums of non-zero elements may yield zero.-Thus division is not always safe, where it is for rational numbers.+Thus division is not always defined, where it is for rational numbers. -} module Number.GaloisField2p32m5 where  import qualified Number.ResidueClass as RC+import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.Module   as Module import qualified Algebra.Field    as Field import qualified Algebra.Ring     as Ring@@ -25,10 +26,34 @@  import Test.QuickCheck (Arbitrary(arbitrary), ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  +{- $setup+>>> import qualified Number.GaloisField2p32m5 as GF+>>> import qualified Algebra.Laws as Laws+>>> import Test.QuickCheck ((==>))+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>> gf :: GF.T -> GF.T+>>> gf = id+-}++{- |+prop> Laws.identity (+) zero . gf+prop> Laws.commutative (+) . gf+prop> Laws.associative (+) . gf+prop> Laws.inverse (+) negate zero . gf+prop> \x -> Laws.inverse (+) (x-) (gf x)+prop> Laws.identity (*) one . gf+prop> Laws.commutative (*) . gf+prop> Laws.associative (*) . gf+prop> \y -> gf y /= zero ==> Laws.inverse (*) recip one y+prop> \y x -> gf y /= zero ==> Laws.inverse (*) (x/) x y+-} newtype T = Cons {decons :: Word32}    deriving Eq @@ -90,3 +115,6 @@  instance Module.C T T where    (*>) = (*)++instance ZeroTestable.C T where+   isZero x  =  zero == x
src/Number/NonNegative.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -XNoImplicitPrelude -fno-warn-orphans #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  {- Rationale for -fno-warn-orphans:@@ -33,26 +34,24 @@ import qualified Algebra.NonNegative        as NonNeg import qualified Algebra.Transcendental     as Trans import qualified Algebra.Algebraic          as Algebraic-import qualified Algebra.RealField          as RealField+import qualified Algebra.RealRing          as RealRing import qualified Algebra.Field              as Field import qualified Algebra.RealIntegral       as RealIntegral import qualified Algebra.IntegralDomain     as Integral-import qualified Algebra.Real               as Real+import qualified Algebra.Absolute               as Absolute import qualified Algebra.Ring               as Ring import qualified Algebra.Additive           as Additive+import qualified Algebra.Monoid             as Monoid import qualified Algebra.ZeroTestable       as ZeroTestable  import qualified Algebra.ToInteger          as ToInteger import qualified Algebra.ToRational         as ToRational--- import Test.QuickCheck (Arbitrary(arbitrary))  import qualified Number.Ratio as R -import qualified Prelude as P--import PreludeBase+import NumericPrelude.Base import Data.Tuple.HT (mapSnd, mapPair, )-import NumericPrelude hiding (Int, Integer, Float, Double, Rational, )+import NumericPrelude.Numeric hiding (Int, Integer, Float, Double, Rational, )   {- |@@ -114,8 +113,13 @@ instance ZeroTestable.C a => ZeroTestable.C (T a) where    isZero = isZero . toNumber +instance (Additive.C a) => Monoid.C (T a) where+   idt = fromNumberUnsafe Additive.zero+   x <*> y = fromNumberUnsafe (toNumber x + toNumber y)+--   mconcat = fromNumberUnsafe . sum . map toNumber+ instance (Ord a, Additive.C a) => NonNeg.C (T a) where-   x -| y = fromNumberClip (toNumber x - toNumber y)+   split = NonNeg.splitDefault toNumber fromNumberUnsafe  instance (Ord a, Additive.C a) => Additive.C (T a) where    zero   = fromNumberUnsafe zero@@ -127,7 +131,7 @@    (*)    = lift2 (*)    fromInteger = fromNumberWrap "fromInteger" . fromInteger -instance ToRational.C a => ToRational.C (T a) where+instance (Ord a, ToRational.C a) => ToRational.C (T a) where    toRational = ToRational.toRational . toNumber  instance ToInteger.C a => ToInteger.C (T a) where@@ -167,11 +171,11 @@    (/) = lift2 (/)  -instance (ZeroTestable.C a, Real.C a) => Real.C (T a) where+instance (ZeroTestable.C a, Ord a, Absolute.C a) => Absolute.C (T a) where    abs    = lift abs    signum = lift signum -instance (RealField.C a) => RealField.C (T a) where+instance (ZeroTestable.C a, RealRing.C a) => RealRing.C (T a) where    splitFraction = mapSnd fromNumberUnsafe . splitFraction . toNumber    truncate = truncate . toNumber    round    = round    . toNumber
src/Number/NonNegativeChunky.hs view
@@ -1,5 +1,5 @@ {- |-Copyright   :  (c) Henning Thielemann 2007+Copyright   :  (c) Henning Thielemann 2007-2010  Maintainer  :  haskell@henning-thielemann.de Stability   :  stable@@ -17,14 +17,14 @@ -} module Number.NonNegativeChunky    (T, fromChunks, toChunks, fromNumber, toNumber, fromChunky98, toChunky98,-    minMaxDiff, normalize, isNull, isPositive) where+    minMaxDiff, normalize, isNull, isPositive,+    divModLazy, divModStrict, ) where -import qualified Numeric.NonNegative.ChunkyPrivate as Chunky98+import qualified Numeric.NonNegative.Chunky as Chunky98 import qualified Numeric.NonNegative.Class as NonNeg98  import qualified Algebra.NonNegative  as NonNeg-import qualified Algebra.Field        as Field-import qualified Algebra.Real         as Real+import qualified Algebra.Absolute     as Absolute import qualified Algebra.Ring         as Ring import qualified Algebra.Additive     as Additive import qualified Algebra.ToInteger    as ToInteger@@ -32,21 +32,22 @@ import qualified Algebra.IntegralDomain as Integral import qualified Algebra.RealIntegral as RealIntegral import qualified Algebra.ZeroTestable as ZeroTestable-import Algebra.ZeroTestable (isZero, )  import qualified Algebra.Monoid as Monoid import qualified Data.Monoid as Mn98+import qualified Data.Semigroup as Sg98  import Control.Monad (liftM, liftM2, )+import Data.Tuple.HT (mapFst, mapSnd, mapPair, )  import Test.QuickCheck (Arbitrary(arbitrary)) -import NumericPrelude-import Data.Tuple.HT (mapFst, mapPair, )-import PreludeBase-import qualified Prelude     as P98+import NumericPrelude.Numeric+import NumericPrelude.Base +import qualified Prelude as P98 + {- | A chunky non-negative number is a list of non-negative numbers. It represents the sum of the list elements.@@ -71,7 +72,7 @@ toChunks = decons  fromChunky98 :: (NonNeg.C a, NonNeg98.C a) => Chunky98.T a -> T a-fromChunky98 = fromChunks . Chunky98.toChunksUnsafe+fromChunky98 = fromChunks . Chunky98.toChunks  toChunky98 :: (NonNeg.C a, NonNeg98.C a) => T a -> Chunky98.T a toChunky98 = Chunky98.fromChunks . toChunks@@ -80,7 +81,7 @@ fromNumber = fromChunks . (:[])  toNumber :: NonNeg.C a => T a -> a-toNumber =  sum . toChunks+toNumber =  Monoid.cumulate . toChunks   @@ -92,10 +93,10 @@ Remove zero chunks. -} normalize :: NonNeg.C a => T a -> T a-normalize = fromChunks . filter (>zero) . toChunks+normalize = fromChunks . filter (> NonNeg.zero) . toChunks  isNullList :: NonNeg.C a => [a] -> Bool-isNullList = null . filter (>zero)+isNullList = null . filter (> NonNeg.zero)  isNull :: NonNeg.C a => T a -> Bool isNull = isNullList . toChunks@@ -130,48 +131,44 @@      else error ("Numeric.NonNegative.Chunky."++funcName++": negative number")  -glue :: (NonNeg.C a) => [a] -> [a] -> ([a], [a], Bool)-glue [] ys = ([], ys, True)-glue xs [] = ([], xs, False)+glue :: (NonNeg.C a) => [a] -> [a] -> ([a], (Bool, [a]))+glue [] ys = ([], (True,  ys))+glue xs [] = ([], (False, xs)) glue (x:xs) (y:ys) =-   let (z,(zs,rs,b)) =-           case compare x y of-              LT -> (x, glue xs ((y-x):ys))-              GT -> (y, glue ((x-y):xs) ys)-              EQ -> (x, glue xs ys)-   in  (z:zs,rs,b)+   let (z,~(zs,brs)) =+          flip mapSnd (NonNeg.split x y) $+          \(b,d) ->+             if b+               then glue xs $+                    if NonNeg.zero == d+                      then ys else d:ys+               else glue (d:xs) ys+   in  (z:zs,brs) -{- |-In @minMaxDiff x y == (z,r,b)@-@z@ represents @min x y@,-@r@ represents @max x y - min x y@,-and @x<y  ==>  b@ or @x>y  ==>  not b@,- for @x==y@ the value of b is arbitrary.--}-minMaxDiff :: (NonNeg.C a) => T a -> T a -> (T a, T a, Bool)+minMaxDiff :: (NonNeg.C a) => T a -> T a -> (T a, (Bool, T a)) minMaxDiff (Cons xs) (Cons ys) =-   let (zs, rs, b) = glue xs ys-   in  (Cons zs, Cons rs, b)+   let (zs, (b, rs)) = glue xs ys+   in  (Cons zs, (b, Cons rs))  equalList :: (NonNeg.C a) => [a] -> [a] -> Bool equalList x y =-   let (_,r,_) = glue x y-   in  isNullList r+   isNullList $ snd $ snd $ glue x y  compareList :: (NonNeg.C a) => [a] -> [a] -> Ordering compareList x y =-   let (_,r,b) = glue x y+   let (b,r) = snd $ glue x y    in  if isNullList r          then EQ          else if b then LT else GT  minList :: (NonNeg.C a) => [a] -> [a] -> [a] minList x y =-   let (z,_,_) = glue x y in z+   fst $ glue x y  maxList :: (NonNeg.C a) => [a] -> [a] -> [a] maxList x y =-   let (z,r,_) = glue x y in z++r+   -- matching the inner pair lazily is important+   let (z,~(_,r)) = glue x y in z++r   instance (NonNeg.C a) => Eq (T a) where@@ -184,12 +181,9 @@   instance (NonNeg.C a) => NonNeg.C (T a) where-   (-|) =-      lift2 (\x w ->-         let sub _ [] = []-             sub z (y:ys) =-                if z<y then (y-z):ys else sub (z-y) ys-         in  foldr sub x w)+   split (Cons xs) (Cons ys) =+      let (zs, ~(b, rs)) = glue xs ys+      in  (Cons zs, (b, Cons rs))  instance (ZeroTestable.C a) => ZeroTestable.C (T a) where    isZero = isNullZT@@ -197,9 +191,9 @@ instance (NonNeg.C a) => Additive.C (T a) where    zero  = Monoid.idt    (+)   = (Monoid.<*>)-   x - y =-      let (_,d,b) = glue (toChunks x) (toChunks y)-          d' = fromChunks d+   (Cons x) - (Cons y) =+      let (b,d) = snd $ glue x y+          d' = Cons d       in check "-" (not b || isNull d') d'    negate x = check "negate" (isNull x) x {-@@ -213,7 +207,7 @@    (*)   = lift2 (liftM2 (*))    fromInteger = fromNumber . fromInteger -instance (Ring.C a, ZeroTestable.C a, NonNeg.C a) => Real.C (T a) where+instance (Ring.C a, ZeroTestable.C a, NonNeg.C a) => Absolute.C (T a) where    abs    = id    signum = fromNumber . (\b -> if b then one else zero) . isPositive @@ -229,21 +223,56 @@    rem  = mod    quotRem = divMod +{- |+'divMod' is implemented in terms of 'divModStrict'.+If it is needed we could also provide a function+that accesses the divisor first in a lazy way+and then uses a strict divisor for subsequent rounds of the subtraction loop.+This way we can handle the cases \"dividend smaller than divisor\"+and \"dividend greater than divisor\" in a lazy and efficient way.+However changing the way of operation within one number is also not nice.+-} instance (Ord a, Integral.C a, NonNeg.C a) => Integral.C (T a) where-   divMod x0 y0 =-      let y = toChunks y0-          recurse x =-             let (r,d,b) = glue y x-             in  if not b-                   then ([], r)-                   else mapFst (one:) (recurse d)-      in  mapPair-             (fromChunks, fromChunks)-             (recurse (toChunks x0))+   divMod x y =+      mapSnd fromNumber $+      divModStrict x (toNumber y) +{- |+divModLazy accesses the divisor in a lazy way.+However this is only relevant if the dividend is smaller than the divisor.+For large dividends the divisor will be accessed multiple times+but since it is already fully evaluated it could also be strict.+-}+divModLazy ::+   (Ring.C a, NonNeg.C a) =>+   T a -> T a -> (T a, T a)+divModLazy x0 y0 =+   let y = toChunks y0+       recourse x =+          let (r,~(b,d)) = glue y x+          in  if not b+                then ([], r)+                else mapFst (one:) (recourse d)+   in  mapPair+          (fromChunks, fromChunks)+          (recourse (toChunks x0)) +{- |+This function has a strict divisor+and maintains the chunk structure of the dividend at a smaller scale.+-}+divModStrict ::+   (Integral.C a, NonNeg.C a) =>+   T a -> a -> (T a, a)+divModStrict x0 y =+   let recourse [] r = ([], r)+       recourse (x:xs) r0 =+          case divMod (x+r0) y of+             (q,r1) -> mapFst (q:) $ recourse xs r1+   in  mapFst fromChunks $ recourse (toChunks x0) zero  + instance (Show a) => Show (T a) where    showsPrec p x =       showParen (p>10)@@ -255,27 +284,53 @@   -{- * legacy instances -}+-- * Haskell 98 legacy instances -legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"+fromChunky98_ :: (NonNeg98.C a) => Chunky98.T a -> T a+fromChunky98_ = Cons . Chunky98.toChunks -instance (Ring.C a, Eq a, Show a, NonNeg.C a) => P98.Num (T a) where-   fromInteger = fromNumber . fromInteger-   negate = Additive.negate -- for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance+toChunky98_ :: (NonNeg98.C a) => T a -> Chunky98.T a+toChunky98_ = Chunky98.fromChunks . decons -instance (Field.C a, Eq a, Show a, NonNeg.C a) => P98.Fractional (T a) where-   fromRational = fromNumber . fromRational-   (/) = legacyInstance+fromNumber_ :: a -> T a+fromNumber_ = Cons . (:[]) +{-# INLINE lift98_1 #-}+lift98_1 ::+   (NonNeg98.C a, NonNeg98.C b) =>+   (Chunky98.T a -> Chunky98.T b) -> T a -> T b+lift98_1 f a = fromChunky98_ (f (toChunky98_ a))++{-# INLINE lift98_2 #-}+lift98_2 ::+   (NonNeg98.C a, NonNeg98.C b, NonNeg98.C c) =>+   (Chunky98.T a -> Chunky98.T b -> Chunky98.T c) -> T a -> T b -> T c+lift98_2 f a b = fromChunky98_ (f (toChunky98_ a) (toChunky98_ b))+++{-# INLINE notImplemented #-}+notImplemented :: String -> a+notImplemented name =+   error $ "Number.NonNegativeChunky: method " ++ name ++ " cannot be implemented"++instance (NonNeg98.C a, P98.Num a) => P98.Num (T a) where+   fromInteger = fromNumber_ . P98.fromInteger+   negate = lift98_1 P98.negate+   (+)    = lift98_2 (P98.+)+   (*)    = lift98_2 (P98.*)+   abs    = lift98_1 P98.abs+   signum = lift98_1 P98.signum++instance (NonNeg98.C a, P98.Fractional a) => P98.Fractional (T a) where+   fromRational = fromNumber_ . P98.fromRational+   (/) = notImplemented "(/)"++instance (NonNeg.C a) => Sg98.Semigroup (T a) where+   (<>) = (Monoid.<*>)+ instance (NonNeg.C a) => Mn98.Monoid (T a) where    mempty  = Monoid.idt-   mappend = (Monoid.<*>)+   mappend = (Sg98.<>)  instance (NonNeg.C a) => Monoid.C (T a) where    idt   = Cons []
src/Number/OccasionallyScalarExpression.hs view
@@ -1,14 +1,7 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2004-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  multi-type parameter classes (vector space)- Physical expressions track the operations made on physical values so we are able to give detailed information on how to resolve unit violations.@@ -19,19 +12,18 @@ import qualified Algebra.Transcendental      as Trans import qualified Algebra.Algebraic           as Algebraic import qualified Algebra.Field               as Field-import qualified Algebra.Real                as Real+import qualified Algebra.Absolute                as Absolute import qualified Algebra.Ring                as Ring import qualified Algebra.Additive            as Additive import qualified Algebra.ZeroTestable        as ZeroTestable -import Algebra.Algebraic (sqrt, (^/)) import qualified Algebra.OccasionallyScalar as OccScalar  import Data.Maybe(fromMaybe) import Data.Array(listArray,(!)) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- | A value of type 'T' stores information on how to resolve unit violations.@@ -123,7 +115,7 @@ instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where   isZero (Cons _ x) = isZero x -instance (Real.C v) => Real.C (T a v) where+instance (Absolute.C v) => Absolute.C (T a v) where   {- are these definitions sensible? -}   abs    = lift abs   signum = lift signum
src/Number/PartiallyTranscendental.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Define Transcendental functions on arbitrary fields. These functions are defined for only a few (in most cases only one) arguments,-that's why discourage making these types instances of 'Algebra.Transcendental.C'.+that's why we discourage making these types instances of 'Algebra.Transcendental.C'. But instances of 'Algebra.Transcendental.C' can be useful when working with power series.-If you intent to work with power series with 'Rational' coefficients,+If you intend to work with power series with 'Rational' coefficients, you might consider using @MathObj.PowerSeries.T (Number.PartiallyTranscendental.T Rational)@ instead of @MathObj.PowerSeries.T Rational@. -}@@ -15,10 +15,9 @@ import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive--- import qualified Algebra.ZeroTestable   as ZeroTestable -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base  import qualified Prelude as P @@ -74,18 +73,15 @@   -legacyInstance :: a-legacyInstance = error "legacy Ring instance for simple input of numeric literals"-- instance (P.Num a) => P.Num (T a) where-   fromInteger n = lift0 $ P.fromInteger n-   negate = P.negate -- for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance+   fromInteger = lift0 . P.fromInteger+   negate = lift1 P.negate+   (+)    = lift2 (P.+)+   (-)    = lift2 (P.-)+   (*)    = lift2 (P.*)+   abs    = lift1 P.abs+   signum = lift1 P.signum -instance (P.Num a) => P.Fractional (T a) where+instance (P.Fractional a) => P.Fractional (T a) where    fromRational = P.fromRational-   (/) = legacyInstance+   (/) = lift2 (P./)
src/Number/Peano.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright    :   (c) Henning Thielemann 2007+Copyright    :   (c) Henning Thielemann 2007-2012 Maintainer   :   numericprelude@henning-thielemann.de Stability    :   provisional Portability  :   portable@@ -15,26 +15,29 @@ import qualified Algebra.Units                as Units import qualified Algebra.RealIntegral         as RealIntegral import qualified Algebra.IntegralDomain       as Integral-import qualified Algebra.Real                 as Real+import qualified Algebra.Absolute             as Absolute import qualified Algebra.Ring                 as Ring import qualified Algebra.Additive             as Additive import qualified Algebra.ZeroTestable         as ZeroTestable import qualified Algebra.Indexable            as Indexable+import qualified Algebra.Monoid               as Monoid  import qualified Algebra.ToInteger            as ToInteger import qualified Algebra.ToRational           as ToRational import qualified Algebra.NonNegative          as NonNeg +import qualified Algebra.EqualityDecision as EqDec+import qualified Algebra.OrderDecision    as OrdDec+ import Data.Maybe (catMaybes, ) import Data.Array(Ix(..)) -import qualified Prelude     as P98-import qualified PreludeBase as P-import qualified NumericPrelude as NP import Data.List.HT (mapAdjacent, shearTranspose, )+import Data.Tuple.HT (mapFst, ) -import PreludeBase-import NumericPrelude+import qualified Prelude as P98+import NumericPrelude.Base+import NumericPrelude.Numeric   data T = Zero@@ -119,6 +122,26 @@    enumFromThenTo =    -} ++{- |+If all values are completely defined,+then it holds++> if b then x else y == ifLazy b x y++However if @b@ is undefined,+then it is at least known that the result is larger than @min x y@.+-}+ifLazy :: Bool -> T -> T -> T+ifLazy b (Succ x) (Succ y) = Succ (ifLazy b x y)+ifLazy b x y = if b then x else y++instance EqDec.C T where+   (==?) x y = ifLazy (x==y)++instance OrdDec.C T where+   (<=?) x y le gt = ifLazy (x<=y) le gt+ {- The default instance is good for compare, but fails for min and max.@@ -158,12 +181,12 @@ -} argMinFull :: (T,a) -> (T,a) -> (T,a) argMinFull (x0,xv) (y0,yv) =-   let recurse (Succ x) (Succ y) =-          let (z,zv) = recurse x y+   let recourse (Succ x) (Succ y) =+          let (z,zv) = recourse x y           in  (Succ z, zv)-       recurse Zero _ = (Zero,xv)-       recurse _    _ = (Zero,yv)-   in  recurse x0 y0+       recourse Zero _ = (Zero,xv)+       recourse _    _ = (Zero,yv)+   in  recourse x0 y0  {- | On equality the first operand is returned.@@ -177,12 +200,12 @@  argMaxFull :: (T,a) -> (T,a) -> (T,a) argMaxFull (x0,xv) (y0,yv) =-   let recurse (Succ x) (Succ y) =-          let (z,zv) = recurse x y+   let recourse (Succ x) (Succ y) =+          let (z,zv) = recourse x y           in  (Succ z, zv)-       recurse x Zero = (x,xv)-       recurse _ y    = (y,yv)-   in  recurse x0 y0+       recourse x Zero = (x,xv)+       recourse _ y    = (y,yv)+   in  recourse x0 y0  {- | On equality the first operand is returned.@@ -221,24 +244,23 @@  toListMaybe :: a -> T -> [Maybe a] toListMaybe a =-   let recurse Zero     = [Just a]-       recurse (Succ x) = Nothing : recurse x-   in  recurse+   let recourse Zero     = [Just a]+       recourse (Succ x) = Nothing : recourse x+   in  recourse  {- |-In @glue x y == (z,r,b)@+In @glue x y == (z,(b,r))@ @z@ represents @min x y@, @r@ represents @max x y - min x y@, and @x<=y  ==  b@.  Cf. Numeric.NonNegative.Chunky -}-glue :: T -> T -> (T, T, Bool)-glue Zero ys = (Zero, ys, True)-glue xs Zero = (Zero, xs, False)+glue :: T -> T -> (T, (Bool, T))+glue Zero ys = (Zero, (True, ys))+glue xs Zero = (Zero, (False, xs)) glue (Succ xs) (Succ ys) =-   let (common, difference, sign) = glue xs ys-   in  (Succ common, difference, sign)+   mapFst Succ $ glue xs ys  {- Implementation notes:@@ -256,7 +278,7 @@    and . catMaybes . concat .    shearTranspose .    mapAdjacent (\x y ->-      let (costs0,_,le) = glue x y+      let (costs0,(le,_)) = glue x y       in  toListMaybe le costs0)  @@ -277,7 +299,7 @@ infixr 3 &&~ (&&~) :: Valuable Bool -> Valuable Bool -> Valuable Bool (&&~) (Valuable xc xb) (Valuable yc yb) =-   let (minc,difc,le) = glue xc yc+   let (minc,~(le,difc)) = glue xc yc        (bCheap,bExpensive) =           if le             then (xb,yb)@@ -296,7 +318,7 @@  leW :: T -> T -> Valuable Bool leW x y =-   let (minc,_difc,le) = glue x y+   let (minc,~(le,_difc)) = glue x y    in  Valuable minc le  isAscendingW :: [T] -> Valuable Bool@@ -313,7 +335,7 @@  -- instances -instance Real.C T where+instance Absolute.C T where    signum Zero     = zero    signum (Succ _) = one    abs             = id@@ -338,12 +360,13 @@             then (zero,x)             else let (q,r) = divMod d y in (succ q,r) +instance Monoid.C T where+   idt = zero+   (<*>) = add+   cumulate = foldr add Zero+ instance NonNeg.C T where-   (-|) x y =-      let (isNeg,d) = subNeg y x-      in  if isNeg-            then zero-            else d+   split = glue  instance Ix T where    range = uncurry enumFromTo@@ -376,9 +399,10 @@   -legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"+{-# INLINE notImplemented #-}+notImplemented :: String -> a+notImplemented name =+   error $ "Number.Peano: method " ++ name ++ " cannot be implemented"  instance P98.Num T where    fromInteger = Ring.fromInteger@@ -386,8 +410,8 @@    (+) = add    (-) = sub    (*) = mul-   signum = legacyInstance-   abs = legacyInstance+   abs    = notImplemented "abs"+   signum = notImplemented "signum"  -- for use with genericLength et.al. instance P98.Real T where
src/Number/Physical.hs view
@@ -1,14 +1,7 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2003-2006-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  generic instances- Numeric values combined with abstract Physical Units -} @@ -23,24 +16,23 @@ import qualified Algebra.Transcendental      as Trans import qualified Algebra.Algebraic           as Algebraic import qualified Algebra.Field               as Field-import qualified Algebra.Real                as Real+import qualified Algebra.Absolute            as Absolute import qualified Algebra.Ring                as Ring import qualified Algebra.Additive            as Additive import qualified Algebra.ZeroTestable        as ZeroTestable  import qualified Algebra.ToInteger      as ToInteger -import Algebra.Algebraic (sqrt, (^/))- import qualified Number.Ratio as Ratio -import Control.Monad(guard,liftM,liftM2)+import Control.Monad (guard, liftM, liftM2, ap)+import Control.Applicative (Applicative(pure, (<*>)))  import Data.Maybe.HT(toMaybe) import Data.Maybe(fromMaybe) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   -- | A Physics.Quantity.Value.T combines a numeric value with a physical unit.@@ -167,7 +159,7 @@   I need absolute values for sample rates and amplitudes.   There the second interpretation is needed. -}-instance (Ord i, Real.C a) => Real.C (T i a) where+instance (Ord i, Absolute.C a) => Absolute.C (T i a) where   abs               = lift abs   signum (Cons _ x) = fromScalarSingle (signum x) @@ -179,8 +171,7 @@ instance (Ord i, Algebraic.C a) => Algebraic.C (T i a) where   sqrt (Cons xu x) = Cons (Unit.ratScale 0.5 xu) (sqrt x)   Cons xu x ^/ y =-     let y' = fromRational' (toRational y)-     in  Cons (Unit.ratScale y' xu) (x ^/ y)+     Cons (Unit.ratScale (fromRational' y) xu) (x ^/ y)  instance (Ord i, Trans.C a) => Trans.C (T i a) where   pi      = fromScalarSingle pi@@ -229,9 +220,13 @@     then fromScalarSingle (f x)     else error "Physics.Quantity.Value.fmap: function for scalars, only" +instance Applicative (T a) where+   (<*>) = ap+   pure = fromScalarSingle+ instance Monad (T i) where-  (>>=) (Cons xu x) f =+   (>>=) (Cons xu x) f =     if Unit.isScalar xu     then f x     else error "Physics.Quantity.Value.(>>=): function for scalars, only"-  return = fromScalarSingle+   return = pure
src/Number/Physical/Read.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2004-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  multi-parameter type classes (VectorSpace.hs)- Convert a human readable string to a physical value. -} @@ -15,15 +8,14 @@ import qualified Number.Physical        as Value import qualified Number.Physical.UnitDatabase as Db import qualified Algebra.VectorSpace as VectorSpace--- import Algebra.Module((*>)) import qualified Algebra.Field       as Field import qualified Data.Map as Map import Data.Map (Map) import Text.ParserCombinators.Parsec import Control.Monad(liftM) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  mulPrec :: Int mulPrec = 7@@ -69,7 +61,7 @@ parseProductTail :: Parser [(String, Integer)] parseProductTail =    let parseTail c f = -         do ignoreSpace (char c)+         do _ <- ignoreSpace (char c)             p <- ignoreSpace parsePower             t <- parseProductTail             return (f p : t)
src/Number/Physical/Show.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2004-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  multi-parameter type classes (VectorSpace.hs, Normalization.hs)- Convert a physical value to a human readable string. -} @@ -24,8 +17,8 @@ import Data.List(find) import Data.Maybe(mapMaybe) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   mulPrec :: Int
src/Number/Physical/Unit.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2003-2006-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable- Abstract Physical Units -} @@ -21,8 +14,8 @@  import Data.Maybe.HT(toMaybe) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  {- | A Unit.T is a sparse vector with integer entries    Each map n->m means that the unit of the n-th dimension@@ -30,8 +23,8 @@     Example: Let the quantity of length (meter, m) be the zeroth dimension    and let the quantity of time (second, s) be the first dimension,-   then the composed unit "m_s²" corresponds to the Map-   [(0,1),(1,-2)]+   then the composed unit @m/s^2@ corresponds to the Map+   @[(0,1),(1,-2)]@.     In future I want to have more abstraction here,    e.g. a type class from the Edison project@@ -78,7 +71,7 @@                in  toMaybe (denominator y == 1) (numerator y))  -{- impossible because Unit.T is a type synonyme but not a data type+{- impossible because Unit.T is a type synonym but not a data type instance Show (Unit.T i) where   show = show.toVector -}
src/Number/Physical/UnitDatabase.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2003-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable- Tools for creating a data base of physical units and for extracting data from it -}@@ -16,14 +9,13 @@ import qualified Number.Physical.Unit as Unit import qualified Algebra.Field as Field --- import Algebra.Module((*>)) import Algebra.NormedSpace.Sum(norm)  import Data.Maybe.HT (toMaybe) import Data.List (findIndices, partition, unfoldr, find, minimumBy) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  type T i a = [UnitSet i a]
src/Number/Positional.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2006-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-- Exact Real Arithmetic - Computable reals. Inspired by ''The most unreliable technique for computing pi.'' See also <http://www.haskell.org/haskellwiki/Exact_real_arithmetic> .@@ -14,19 +7,17 @@ module Number.Positional where  import qualified MathObj.LaurentPolynomial as LPoly-import qualified MathObj.Polynomial        as Poly+import qualified MathObj.Polynomial.Core   as Poly  import qualified Algebra.IntegralDomain as Integral import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive import qualified Algebra.ToInteger      as ToInteger  import qualified Prelude as P98-import qualified PreludeBase as P-import qualified NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP -import PreludeBase-import NumericPrelude hiding (sqrt, tan, one, zero, )+import NumericPrelude.Base+import NumericPrelude.Numeric hiding (sqrt, tan, one, zero, )  import qualified Data.List as List import Data.Char (intToDigit)@@ -43,7 +34,7 @@   {--bugs:+FIXME:  defltBase = 10 defltExp = 4@@ -65,7 +56,7 @@  moveToZero :: Basis -> Digit -> (Digit,Digit) moveToZero b n =-   let b2 = NP.div b 2+   let b2 = div b 2        (q,r) = divMod (n+b2) b    in  (q,r-b2) @@ -429,7 +420,7 @@        This would create finite representations        in some cases (input is finite, and the result is finite)        but will cause infinite loop otherwise.-       dropWhileRev (0==) . compressMant bDst+       Rev.dropWhile (0==) . compressMant bDst        -}        cmpr (mag,xs) = (mag - unit, compressMant bSrc xs) @@ -493,7 +484,80 @@    fst (trimUntil bnd (sub b x y)) == bnd  +{- |+If all values are completely defined,+then it holds +> if b then x else y == ifLazy b x y++However if @b@ is undefined,+then it is at least known that the result is between @x@ and @y@.+-}+ifLazy :: Basis -> Bool -> T -> T -> T+ifLazy b c x@(xe, _) y@(ye, _) =+   let ze = max xe ye+       xm = alignMant b ze x+       ym = alignMant b ze y+       recurse :: Mantissa -> Mantissa -> Mantissa+       recurse xs0 ys0 =+          withTwoMantissas xs0 ys0 [] $ \(x0,xs1) (y0,ys1) ->+          if abs (y0-x0) > 2+            then if c then xs0 else ys0+            else+              {-+              @x0==y0 || c@ means that in case of @x0==y0@+              we do not have to check @c@.+              -}+              withTwoMantissas xs1 ys1 ((if x0==y0 || c then x0 else y0) : []) $+                  \(x1,xs2) (y1,ys2) ->+                {-+                We can choose @z0@ only when knowing also x1 and y1.+                Because of x0x1 = 09 and y0y1 = 19+                we may always choose the larger one of x0 and y0+                in order to get admissible digit z1.+                But this would be wrong for x0x1 = 0(-9) and y0y1 = 1(-9).+                -}+                let z0  = mean2 b (x0,x1) (y0,y1)+                    x1' = x1+(x0-z0)*b+                    y1' = y1+(y0-z0)*b+                in  if abs x1' < b  &&  abs y1' < b+                      then z0 : recurse (x1':xs2) (y1':ys2)+                      else if c then xs0 else ys0+   in  (ze, recurse xm ym)++{- |+> mean2 b (x0,x1) (y0,y1)++computes @ round ((x0.x1 + y0.y1)/2) @,+where @x0.x1@ and @y0.y1@ are positional rational numbers+with respect to basis @b@+-}+{-# INLINE mean2 #-}+mean2 :: Basis -> (Digit,Digit) -> (Digit,Digit) -> Digit+mean2 b (x0,x1) (y0,y1) =+   ((x0+y0+1)*b + (x1+y1)) `div` (2*b)++{-+In a first trial I used++> zipMantissas :: Mantissa -> Mantissa -> [(Digit, Digit)]++for implementation of ifLazy.+However, this required to extract digits from the pairs+after the decision for an argument.+With withTwoMantissas we can just return a pointer to the original list.+-}+withTwoMantissas ::+   Mantissa -> Mantissa ->+   a ->+   ((Digit,Mantissa) -> (Digit,Mantissa) -> a) ->+   a+withTwoMantissas [] [] r _ = r+withTwoMantissas [] (y:ys) _ f = f (0,[]) (y,ys)+withTwoMantissas (x:xs) [] _ f = f (x,xs) (0,[])+withTwoMantissas (x:xs) (y:ys) _ f = f (x,xs) (y,ys)++ align :: Basis -> Exponent -> T -> T align b ye x = (ye, alignMant b ye x) @@ -524,20 +588,20 @@  {- * arithmetic -} -fromLaurent :: LPoly.T Int -> T+fromLaurent :: LPoly.T Digit -> T fromLaurent (LPoly.Cons nxe xm) = (NP.negate nxe, xm) -toLaurent :: T -> LPoly.T Int+toLaurent :: T -> LPoly.T Digit toLaurent (xe, xm) = LPoly.Cons (NP.negate xe) xm  liftLaurent2 ::-   (LPoly.T Int -> LPoly.T Int -> LPoly.T Int) ->+   (LPoly.T Digit -> LPoly.T Digit -> LPoly.T Digit) ->       (T -> T -> T) liftLaurent2 f x y =    fromLaurent (f (toLaurent x) (toLaurent y))  liftLaurentMany ::-   ([LPoly.T Int] -> LPoly.T Int) ->+   ([LPoly.T Digit] -> LPoly.T Digit) ->       ([T] -> T) liftLaurentMany f =    fromLaurent . f . map toLaurent@@ -708,7 +772,9 @@    let (ye,ym) = until ((>=b) . abs . head . snd)                        (decreaseExp b)                        (ye',ym')-   in  nest 3 trimOnce (compress b (xe-ye, divMant b ym xm))+   in  if null xm+         then (xe,xm)+         else nest 3 trimOnce (compress b (xe-ye, divMant b ym xm))  divMant :: Basis -> Mantissa -> Mantissa -> Mantissa divMant _ [] _   = error "Number.Positional: division by zero"@@ -746,7 +812,7 @@ Fast division for small integral divisors, which occur for instance in summands of power series. -}-divIntMant :: Basis -> Int -> Mantissa -> Mantissa+divIntMant :: Basis -> Digit -> Mantissa -> Mantissa divIntMant b y xInit =    List.unfoldr (\(r,rxs) ->              let rb = r*b@@ -759,7 +825,7 @@            (0,xInit)  -- this version is simple but ignores the possibility of a terminating result-divIntMantInf :: Basis -> Int -> Mantissa -> Mantissa+divIntMantInf :: Basis -> Digit -> Mantissa -> Mantissa divIntMantInf b y =    map fst . tail .       scanl (\(_,r) x -> divMod (r*b+x) y) (undefined,0) .@@ -1243,7 +1309,7 @@ {- | Efficient computation of Arcus tangens of an argument of the form @1\/n@. -}-arctanStem :: Basis -> Int -> T+arctanStem :: Basis -> Digit -> T arctanStem b n =    let x = (0, divIntMant b n [1])        divN2 = divInt b n . divInt b (-n)
src/Number/Positional/Check.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2006-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-- Interface to "Number.Positional" which dynamically checks for equal bases. -} module Number.Positional.Check where@@ -15,22 +8,24 @@  import qualified Number.Complex as Complex --- import qualified Algebra.Module             as Module import qualified Algebra.RealTranscendental as RealTrans import qualified Algebra.Transcendental     as Trans import qualified Algebra.Algebraic          as Algebraic import qualified Algebra.RealField          as RealField import qualified Algebra.Field              as Field-import qualified Algebra.Real               as Real+import qualified Algebra.RealRing           as RealRing+import qualified Algebra.Absolute           as Absolute import qualified Algebra.Ring               as Ring import qualified Algebra.Additive           as Additive import qualified Algebra.ZeroTestable       as ZeroTestable -import qualified PreludeBase as P+import qualified Algebra.EqualityDecision as EqDec+import qualified Algebra.OrderDecision    as OrdDec+ import qualified Prelude     as P98 -import PreludeBase as P-import NumericPrelude as NP+import NumericPrelude.Base as P+import NumericPrelude.Numeric as NP   {- |@@ -51,7 +46,7 @@ and cannot be made unique in finite time. This way we avoid infinite carry ripples. -}-data T = Cons {base :: Int, exponent :: Int, mantissa :: Pos.Mantissa}+data T = Cons {base :: Pos.Basis, exponent :: Int, mantissa :: Pos.Mantissa}    deriving (Show)  @@ -77,7 +72,7 @@    in  prependDigit (fst (head ys)) (Cons b ex digits)  -prependDigit :: Int -> T -> T+prependDigit :: Pos.Digit -> T -> T prependDigit 0 x = x prependDigit x (Cons b ex xs) =    Cons b (ex+1) (x:xs)@@ -86,30 +81,37 @@  {- * conversions -} -lift0 :: (Int -> Pos.T) -> T+lift0 :: (Pos.Basis -> Pos.T) -> T lift0 op =    uncurry (Cons defltBase) (op defltBase) -lift1 :: (Int -> Pos.T -> Pos.T) -> T -> T+lift1 :: (Pos.Basis -> Pos.T -> Pos.T) -> T -> T lift1 op (Cons xb xe xm) =    uncurry (Cons xb) (op xb (xe, xm)) -lift2 :: (Int -> Pos.T -> Pos.T -> Pos.T) -> T -> T -> T+lift2 :: (Pos.Basis -> Pos.T -> Pos.T -> Pos.T) -> T -> T -> T lift2 op (Cons xb xe xm) (Cons yb ye ym) =-   let zb = commonBasis xb yb-   in  uncurry (Cons zb) (op xb (xe, xm) (ye, ym))+   let b = commonBasis xb yb+   in  uncurry (Cons b) (op b (xe, xm) (ye, ym)) +{-+lift4 :: (Int -> Pos.T -> Pos.T -> Pos.T -> Pos.T -> Pos.T) -> T -> T -> T -> T -> T+lift4 op (Cons xb xe xm) (Cons yb ye ym) (Cons zb ze zm) (Cons wb we wm) =+   let b = xb `commonBasis` yb `commonBasis` zb `commonBasis` wb+   in  uncurry (Cons b) (op b (xe, xm) (ye, ym) (ze, zm) (we, wm))+-}+ commonBasis :: Pos.Basis -> Pos.Basis -> Pos.Basis commonBasis xb yb =    if xb == yb      then xb      else error "Number.Positional: bases differ" -fromBaseInteger :: Int -> Integer -> T+fromBaseInteger :: Pos.Basis -> Integer -> T fromBaseInteger b n =    uncurry (Cons b) (Pos.fromBaseInteger b n) -fromBaseRational :: Int -> Rational -> T+fromBaseRational :: Pos.Basis -> Rational -> T fromBaseRational b r =    uncurry (Cons b) (Pos.fromBaseRational b r) @@ -178,6 +180,19 @@    cosh   = lift1 (\b -> snd . Pos.cosSinh b)    -} +{-+The way EqDec and OrdDec are instantiated+it is possible to have different bases+for the arguments for comparison+and the arguments between we decide.+However, I would not rely on this.+-}+instance EqDec.C T where+   x==?y  =  lift2 (\b -> Pos.ifLazy b (x==y))++instance OrdDec.C T where+   x<=?y  =  lift2 (\b -> Pos.ifLazy b (x<=y))+ instance ZeroTestable.C T where    isZero (Cons xb xe xm) =       Pos.cmp xb (xe,xm) Pos.zero == EQ@@ -190,15 +205,17 @@    compare (Cons xb xe xm) (Cons yb ye ym) =       Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym) -instance Real.C T where+instance Absolute.C T where    abs = lift1 (const Pos.absolute)-   -- use default implementation for signum+   signum = Absolute.signumOrd -instance RealField.C T where+instance RealRing.C T where    splitFraction (Cons xb xe xm) =       let (int, frac) = Pos.toFixedPoint xb (xe,xm)       in  (fromInteger int, Cons xb (-1) frac) +instance RealField.C T where+ instance RealTrans.C T where    atan2  = lift2 (curry . Pos.angle) @@ -211,22 +228,18 @@   --- legacy instances for work with GHCi-legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"-+-- legacy instances for use of numeric literals in GHCi instance P98.Num T where    fromInteger = fromBaseInteger defltBase-   negate = negate --for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance+   negate = negate -- for unary minus+   (+)    = (+)+   (*)    = (*)+   abs    = abs+   signum = signum  instance P98.Fractional T where    fromRational = fromBaseRational defltBase . fromRational-   (/) = legacyInstance+   (/) = (/)   {-
src/Number/Quaternion.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |@@ -46,8 +46,7 @@ import qualified Algebra.Additive     as Additive import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.ZeroTestable(isZero)-import Algebra.Module((*>), (<*>.*>), )+import Algebra.Module((<*>.*>), )  import qualified Number.Complex as Complex @@ -56,13 +55,11 @@ import qualified NumericPrelude.Elementwise as Elem import Algebra.Additive ((<*>.+), (<*>.-), (<*>.-$), ) --- import qualified Data.Typeable as Ty import Data.Array (Array, (!)) import qualified Data.Array as Array -import qualified Prelude as P-import PreludeBase-import NumericPrelude hiding (signum)+import NumericPrelude.Base+import NumericPrelude.Numeric hiding (signum) import Text.Show.HT (showsInfixPrec, ) import Text.Read.HT (readsInfixPrec, ) @@ -104,34 +101,34 @@  -- | The conjugate of a quaternion. {-# SPECIALISE conjugate :: T Double -> T Double #-}-conjugate	 :: (Additive.C a) => T a -> T a+conjugate        :: (Additive.C a) => T a -> T a conjugate (Cons r i) =  Cons r (negate i)  -- | Scale a quaternion by a real number. {-# SPECIALISE scale :: Double -> T Double -> T Double #-}-scale		 :: (Ring.C a) => a -> T a -> T a+scale            :: (Ring.C a) => a -> T a -> T a scale r (Cons xr xi) =  Cons (r * xr) (scaleImag r xi)  -- | like Module.*> but without additional class dependency-scaleImag	 :: (Ring.C a) => a -> (a,a,a) -> (a,a,a)+scaleImag        :: (Ring.C a) => a -> (a,a,a) -> (a,a,a) scaleImag r (xi,xj,xk) =  (r * xi, r * xj, r * xk)  -- | the same as NormedEuc.normSqr but with a simpler type class constraint-normSqr		 :: (Ring.C a) => T a -> a+normSqr          :: (Ring.C a) => T a -> a normSqr (Cons xr xi) = xr*xr + scalarProduct xi xi -norm		 :: (Algebraic.C a) => T a -> a+norm             :: (Algebraic.C a) => T a -> a norm x = sqrt (normSqr x)  -- | scale a quaternion into a unit quaternion-normalize	 :: (Algebraic.C a) => T a -> T a+normalize        :: (Algebraic.C a) => T a -> T a normalize x = scale (recip (norm x)) x -scalarProduct	 :: (Ring.C a) => (a,a,a) -> (a,a,a) -> a+scalarProduct    :: (Ring.C a) => (a,a,a) -> (a,a,a) -> a scalarProduct (xi,xj,xk) (yi,yj,yk) =    xi*yi + xj*yj + xk*yk -crossProduct	 :: (Ring.C a) => (a,a,a) -> (a,a,a) -> (a,a,a)+crossProduct     :: (Ring.C a) => (a,a,a) -> (a,a,a) -> (a,a,a) crossProduct (xi,xj,xk) (yi,yj,yk) =    (xj*yk - xk*yj, xk*yi - xi*yk, xi*yj - xj*yi) @@ -141,11 +138,11 @@ @similarity (cos(a\/2) +:: scaleImag (sin(a\/2)) v) (0 +:: x) == (0 +:: y)@ where @y@ results from rotating @x@ around the axis @v@ by the angle @a@. -}-similarity	 :: (Field.C a) => T a -> T a -> T a+similarity       :: (Field.C a) => T a -> T a -> T a similarity c x = c*x/c  {--rotate	 :: (Field.C a) =>+rotate   :: (Field.C a) =>       (a,a,a)  {- ^ rotation axis, must be normalized -}    -> T a    -> T a@@ -266,9 +263,9 @@ instance (Ring.C a) => Ring.C (T a)  where    {-# SPECIALISE instance Ring.C (T Float) #-}    {-# SPECIALISE instance Ring.C (T Double) #-}-   one				=  Cons one zero-   fromInteger			=  fromReal . fromInteger-   (Cons xr xi) * (Cons yr yi)	=+   one                          =  Cons one zero+   fromInteger                  =  fromReal . fromInteger+   (Cons xr xi) * (Cons yr yi)  =        Cons (xr*yr - scalarProduct xi yi)             (scaleImag xr yi + scaleImag yr xi +              crossProduct xi yi)
src/Number/Ratio.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- | Module      :  Number.Ratio-Copyright   :  (c) Henning Thielemann, Dylan Thurston 2006+Copyright   :  (c) Henning Thielemann 2011-2012+               (c) Dylan Thurston 2006  Maintainer  :  numericprelude@henning-thielemann.de Stability   :  provisional@@ -11,10 +12,11 @@ -}  module Number.Ratio-	(-	  T((:%), numerator, denominator), (%),+        (+          T((:%), numerator, denominator), (%),           Rational,           fromValue,+          recip,            scale,           split,@@ -24,19 +26,19 @@         )  where  import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.Units                as Units-import qualified Algebra.Real                 as Real+import qualified Algebra.Units                as Unit+import qualified Algebra.Absolute             as Absolute import qualified Algebra.Ring                 as Ring import qualified Algebra.Additive             as Additive import qualified Algebra.ZeroTestable         as ZeroTestable import qualified Algebra.Indexable            as Indexable -import Algebra.PrincipalIdealDomain (gcd)-import Algebra.Units (stdUnitInv, stdAssociate)-import Algebra.IntegralDomain (div, divMod)-import Algebra.Ring (one, (*), fromInteger)-import Algebra.Additive (zero, (+), (-), negate)-import Algebra.ZeroTestable (isZero)+import Algebra.PrincipalIdealDomain (gcd, )+import Algebra.Units (stdUnitInv, stdAssociate, )+import Algebra.IntegralDomain (div, divMod, )+import Algebra.Ring (one, (*), (^), fromInteger, )+import Algebra.Additive (zero, (+), (-), negate, )+import Algebra.ZeroTestable (isZero, )  import Control.Monad(liftM, liftM2, ) @@ -50,7 +52,7 @@ import qualified Data.Ratio as Ratio98  import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   infixl 7 %@@ -72,7 +74,7 @@        (n:%d) = s%y    in  ((n*x):%d) -{- | similar to 'Algebra.RealField.splitFraction' -}+{- | similar to 'Algebra.RealRing.splitFraction' -} split :: (PID.C a) => T a -> (a, T a) split (x:%y) =    let (q,r) = divMod x y@@ -93,19 +95,38 @@  instance (PID.C a) => Additive.C (T a) where     zero                =  fromValue zero-    (x:%y) + (x':%y')   =  (x*y' + x'*y) % (y*y')+--    (x:%y) + (x':%y')   =  (x*y' + x'*y) % (y*y')+    {-+    This version reduces the size of intermediate results.+    Is it also faster than the naive version?+    The final (%) includes another gcd computation,+    but it is still needed since e.g.+    5:%7 + (-5):%7 shall be simplified to 0:%1, not 0:%7 .+    -}+    (x:%y) + (x':%y')   =+       let d = gcd y y'+           y0  = div y  d+           y0' = div y' d+       in  (x*y0' + x'*y0) % (y0*y')     negate (x:%y)       =  (-x) :% y  instance (PID.C a) => Ring.C (T a) where     one                 =  fromValue one     fromInteger x       =  fromValue $ fromInteger x     (x:%y) * (x':%y')   =  (x * x') % (y * y')+    (x:%y) ^ n          =  (x ^ n) :% (y ^ n) -instance (Real.C a, PID.C a) => Real.C (T a) where-    abs (x:%y)          =  Real.abs x :% y-    signum (x:%_)       =  Real.signum x :% one+instance (Absolute.C a, PID.C a) => Absolute.C (T a) where+    abs (x:%y)          =  Absolute.abs x :% y+    signum (x:%_)       =  Absolute.signum x :% one +recip :: (ZeroTestable.C a, Unit.C a) => T a -> T a+recip (x:%y) =+   if isZero y+     then error "Ratio.recip: division by zero"+     else (y * stdUnitInv x) :% stdAssociate x + liftOrd :: Ring.C a => (a -> a -> b) -> (T a -> T a -> b) liftOrd f (x:%y) (x':%y') = f (x * y') (x' * y) @@ -208,30 +229,56 @@ -- * Legacy Instances  --- | Necessary when mixing NumericPrelude Rationals with Prelude98 Rationals+-- | Necessary when mixing NumericPrelude.Numeric Rationals with Prelude98 Rationals -toRational98 :: (P.Integral a, PID.C a) => T a -> Ratio98.Ratio a+toRational98 :: (P.Integral a) => T a -> Ratio98.Ratio a toRational98 x = numerator x Ratio98.% denominator x +fromRational98 :: (P.Integral a) => Ratio98.Ratio a -> T a+fromRational98 x = Ratio98.numerator x :% Ratio98.denominator x -legacyInstance :: String -> a-legacyInstance op =-   error ("Ratio." ++ op ++ ": legacy Ring instance for simple input of numeric literals") +{-# INLINE lift1 #-}+lift1 ::+   (P.Integral a, P.Integral b) =>+   (Ratio98.Ratio a -> Ratio98.Ratio b) -> T a -> T b+lift1 f a = fromRational98 (f (toRational98 a)) --- instance (P.Num a, PID.C a) => P.Num (T a) where-instance (P.Num a, PID.C a, Real.C a) => P.Num (T a) where+{-# INLINE lift2 #-}+lift2 ::+   (P.Integral a, P.Integral b, P.Integral c) =>+   (Ratio98.Ratio a -> Ratio98.Ratio b -> Ratio98.Ratio c) -> T a -> T b -> T c+lift2 f a b = fromRational98 (f (toRational98 a) (toRational98 b))+++instance (P.Integral a) => P.Num (T a) where+   fromInteger n = P.fromInteger n :% P.fromInteger 1+   negate = lift1 P.negate+   (+)    = lift2 (P.+)+   (*)    = lift2 (P.*)+   abs    = lift1 P.abs+   signum = lift1 P.signum++instance (P.Integral a) => P.Fractional (T a) where+   fromRational x =+      P.fromInteger (Ratio98.numerator x) :%+      P.fromInteger (Ratio98.denominator x)+   (/) = lift2 (P./)+   recip = lift1 P.recip++{- causes an import cycle+instance (P.Integral a) => P.Num (T a) where    fromInteger n = P.fromInteger n % 1-   negate = negate -- for unary minus-   (+)    = legacyInstance "(+)"-   (*)    = legacyInstance "(*)"-   abs    = Real.abs -- needed for Arbitrary instance of NonNegative.Ratio-   signum = legacyInstance "signum"+   negate = W98.unliftF1 P.negate+   (+)    = W98.unliftF2 (+)+   (*)    = W98.unliftF2 (*)+   abs    = W98.unliftF1 abs+   signum = W98.unliftF1 P.signum --- instance (P.Num a, PID.C a) => P.Fractional (T a) where-instance (P.Num a, PID.C a, Real.C a) => P.Fractional (T a) where+instance (P.Integral a) => P.Fractional (T a) where --   fromRational = Field.fromRational    fromRational x =       fromInteger (Ratio98.numerator x) :%       fromInteger (Ratio98.denominator x)-   (/) = legacyInstance "(/)"+   recip = recip+-}
src/Number/ResidueClass.hs view
@@ -1,15 +1,11 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Number.ResidueClass where  import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.IntegralDomain as Integral-import qualified Algebra.Additive       as Additive-import qualified Algebra.ZeroTestable   as ZeroTestable -import Algebra.ZeroTestable(isZero)--import PreludeBase-import NumericPrelude hiding (recip)+import NumericPrelude.Base+import NumericPrelude.Numeric hiding (recip) import Data.Maybe.HT (toMaybe) import Data.Maybe (fromMaybe)
src/Number/ResidueClass/Check.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Number.ResidueClass.Check where  import qualified Number.ResidueClass as Res@@ -12,13 +12,15 @@  import Algebra.ZeroTestable(isZero) -import PreludeBase-import NumericPrelude (Int, Integer, mod, )+import qualified Data.Function.HT as Func import Data.Maybe.HT (toMaybe, ) import Text.Show.HT (showsInfixPrec, ) import Text.Read.HT (readsInfixPrec, ) +import NumericPrelude.Base+import NumericPrelude.Numeric (Int, Integer, mod, (*), ) + infix 7 /:, `Cons`  {- |@@ -99,17 +101,18 @@     isZero (Cons _ r)   =  isZero r  instance  (Eq a, Integral.C a) => Additive.C (T a)  where-    zero		=  error "no generic zero in a residue class, use ResidueClass.zero"-    (+)			=  lift2 Res.add-    (-)			=  lift2 Res.sub-    negate		=  lift1 Res.neg+    zero                =  error "no generic zero in a residue class, use ResidueClass.zero"+    (+)                 =  lift2 Res.add+    (-)                 =  lift2 Res.sub+    negate              =  lift1 Res.neg  instance  (Eq a, Integral.C a) => Ring.C (T a)  where-    one			=  error "no generic one in a residue class, use ResidueClass.one"-    (*)			=  lift2 Res.mul-    fromInteger		=  error "no generic integer in a residue class, use ResidueClass.fromInteger"+    one                 =  error "no generic one in a residue class, use ResidueClass.one"+    (*)                 =  lift2 Res.mul+    fromInteger         =  error "no generic integer in a residue class, use ResidueClass.fromInteger"+    x^n                 =  Func.powerAssociative (*) (one (modulus x)) x n  instance  (Eq a, PID.C a) => Field.C (T a)  where-    (/)			=  lift2 Res.divide+    (/)                 =  lift2 Res.divide     recip               =  lift1 (flip Res.divide Ring.one)-    fromRational'	=  error "no conversion from rational to residue class"+    fromRational'       =  error "no conversion from rational to residue class"
src/Number/ResidueClass/Func.hs view
@@ -1,19 +1,24 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Number.ResidueClass.Func where  import qualified Number.ResidueClass as Res  import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.IntegralDomain as Integral-import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive+import qualified Algebra.IntegralDomain   as Integral+import qualified Algebra.Field            as Field+import qualified Algebra.Ring             as Ring+import qualified Algebra.Additive         as Additive+import qualified Algebra.EqualityDecision as EqDec -import PreludeBase-import NumericPrelude hiding (zero, one, )+import Algebra.EqualityDecision ((==?), ) +import qualified MathObj.Wrapper.Haskell98 as W98++import NumericPrelude.Base+import NumericPrelude.Numeric hiding (zero, one, )+ import qualified Prelude        as P-import qualified NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP  {- | Here a residue class is a representative@@ -54,21 +59,25 @@ equal m (Cons x) (Cons y)  =  x m == y m  +instance  (EqDec.C a) => EqDec.C (T a)  where+    (==?) (Cons x) (Cons y) (Cons eq) (Cons noteq) =+       Cons (\m -> (x m ==? y m) (eq m) (noteq m))+ instance  (Integral.C a) => Additive.C (T a)  where-    zero		=  zero-    (+)			=  lift2 Res.add-    (-)			=  lift2 Res.sub-    negate		=  lift1 Res.neg+    zero                =  zero+    (+)                 =  lift2 Res.add+    (-)                 =  lift2 Res.sub+    negate              =  lift1 Res.neg  instance  (Integral.C a) => Ring.C (T a)  where-    one			=  one-    (*)			=  lift2 Res.mul-    fromInteger		=  Number.ResidueClass.Func.fromInteger+    one                 =  one+    (*)                 =  lift2 Res.mul+    fromInteger         =  Number.ResidueClass.Func.fromInteger  instance  (PID.C a) => Field.C (T a)  where-    (/)			=  lift2 Res.divide+    (/)                 =  lift2 Res.divide     recip               =  (NP.one /)-    fromRational'	=  error "no conversion from rational to residue class"+    fromRational'       =  error "no conversion from rational to residue class"   {-@@ -76,21 +85,32 @@ But Prelude.fromInteger requires Prelude.Num instance. -} --- legacy instances for work with GHCi-legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"+{-# INLINE notImplemented #-}+notImplemented :: String -> a+notImplemented name =+   error $ "ResidueClass.Func: method " ++ name ++ " cannot be implemented" -instance (P.Num a, Integral.C a) => P.Num (T a) where-   fromInteger = Number.ResidueClass.Func.fromInteger-   negate = negate --for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance +lift98_1 :: (W98.T a -> W98.T a -> W98.T a) -> T a -> T a+lift98_1 f (Cons x) =+   Cons $ \m -> W98.decons $ f (W98.Cons m) (W98.Cons $ x m)++lift98_2 :: (W98.T a -> W98.T a -> W98.T a -> W98.T a) -> T a -> T a -> T a+lift98_2 f (Cons x) (Cons y) =+   Cons $ \m -> W98.decons $ f (W98.Cons m) (W98.Cons $ x m) (W98.Cons $ y m)+++-- legacy instances for use of numeric literals in GHCi+instance (P.Integral a) => P.Num (T a) where+   fromInteger = Cons . P.mod . P.fromInteger+   negate = lift98_1 Res.neg+   (+)    = lift98_2 Res.add+   (*)    = lift98_2 Res.mul+   abs    = notImplemented "abs"+   signum = notImplemented "signum"+ instance Eq (T a) where-   (==) = error "ResidueClass.Func: (==) not implemented"+   (==) = notImplemented "(==)"  instance Show (T a) where-   show = error "ResidueClass.Func: 'show' not implemented"+   show = notImplemented "show"
src/Number/ResidueClass/Maybe.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Number.ResidueClass.Maybe where  import qualified Number.ResidueClass as Res@@ -8,10 +8,8 @@ import qualified Algebra.Additive       as Additive import qualified Algebra.ZeroTestable   as ZeroTestable -import Algebra.ZeroTestable(isZero)--import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  infix 7 /:, `Cons` @@ -71,12 +69,12 @@         else error "ResidueClass.(==): Incompatible operands"  instance  (Eq a, Integral.C a) => Additive.C (T a)  where-    zero		=  Cons Nothing zero-    (+)			=  lift2 Res.add (+)-    (-)			=  lift2 Res.sub (-)-    negate (Cons m r)	=  Cons m (negate r)+    zero                =  Cons Nothing zero+    (+)                 =  lift2 Res.add (+)+    (-)                 =  lift2 Res.sub (-)+    negate (Cons m r)   =  Cons m (negate r)  instance  (Eq a, Integral.C a) => Ring.C (T a)  where-    one			=  Cons Nothing one-    (*)			=  lift2 Res.mul (*)-    fromInteger		=  Cons Nothing . fromInteger+    one                 =  Cons Nothing one+    (*)                 =  lift2 Res.mul (*)+    fromInteger         =  Cons Nothing . fromInteger
src/Number/ResidueClass/Reader.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} module Number.ResidueClass.Reader where  import qualified Number.ResidueClass as Res@@ -8,19 +8,18 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric -import Control.Monad (liftM2, liftM4)--- import Control.Monad.Reader (MonadReader)+import Control.Monad (liftM, liftM2, liftM4, ap)+import Control.Applicative (Applicative(pure, (<*>))) -import qualified Prelude        as P-import qualified NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP   {- | T is a Reader monad but does not need functional dependencies-like that from the Monad Template Library.+like that from the Monad Transformer Library. -} newtype T a b = Cons {toFunc :: a -> b} @@ -41,9 +40,16 @@ fromInteger = fromRepresentative . NP.fromInteger  +instance Functor (T a) where+   fmap = liftM++instance Applicative (T a) where+   (<*>) = ap+   pure = Cons . const+ instance Monad (T a) where    (Cons x) >>= y  =  Cons (\r -> toFunc (y (x r)) r)-   return = Cons . const+   return = pure
+ src/Number/Root.hs view
@@ -0,0 +1,102 @@+{-+ToDo:+having the root exponent as type-level number would be nice+there is a package for basic type-level number support+-}+module Number.Root where++import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import qualified MathObj.RootSet as RootSet+import qualified Number.Ratio as Ratio++import Algebra.IntegralDomain (divChecked, )++import qualified NumericPrelude.Numeric as NP+import NumericPrelude.Numeric hiding (recip, )+import NumericPrelude.Base+import Prelude ()++{- |+The root degree must be positive.+This way we can implement multiplication+using only multiplication from type @a@.+-}+data T a = Cons Integer a+   deriving (Show)++{- |+When you use @fmap@ you must assert that+@forall n. fmap f (Cons d x) == fmap f (Cons (n*d) (x^n))@+-}+instance Functor T where+   fmap f (Cons d x) = Cons d (f x)++fromNumber :: a -> T a+fromNumber = Cons 1++toNumber :: Algebraic.C a => T a -> a+toNumber (Cons n x) = Algebraic.root n x++toRootSet :: Ring.C a => T a -> RootSet.T a+toRootSet (Cons d x) =+   RootSet.lift0 ([negate x] ++ replicate (pred (fromInteger d)) zero ++ [one])+++commonDegree :: Ring.C a => T a -> T a -> T (a,a)+commonDegree (Cons xd x) (Cons yd y) =+   let zd = lcm xd yd+   in  Cons zd (x ^ divChecked zd xd, y ^ divChecked zd yd)++instance (Eq a, Ring.C a) => Eq (T a) where+   x == y  =+      case commonDegree x y of+         Cons _ (xn,yn) -> xn==yn++instance (Ord a, Ring.C a) => Ord (T a) where+   compare x y  =+      case commonDegree x y of+         Cons _ (xn,yn) -> compare xn yn+++mul :: Ring.C a => T a -> T a -> T a+mul x y = fmap (uncurry (*)) $ commonDegree x y++div :: Field.C a => T a -> T a -> T a+div x y = fmap (uncurry (/)) $ commonDegree x y++recip :: Field.C a => T a -> T a+recip = fmap NP.recip++{- |+exponent must be non-negative+-}+cardinalPower :: Ring.C a => Integer -> T a -> T a+cardinalPower n (Cons d x) =+   let m = gcd n d+   in  Cons (divChecked d m) (x ^ divChecked n m)++{- |+exponent can be negative+-}+integerPower :: Field.C a => Integer -> T a -> T a+integerPower n =+   if n<0+     then cardinalPower (-n) . recip+     else cardinalPower n++rationalPower :: Field.C a => Rational -> T a -> T a+rationalPower n =+   integerPower (Ratio.numerator n) .+   root (Ratio.denominator n)++{- |+exponent must be positive+-}+root :: Ring.C a => Integer -> T a -> T a+root n (Cons d x) = Cons (d*n) x++sqrt :: Ring.C a => T a -> T a+sqrt = root 2
src/Number/SI.hs view
@@ -1,14 +1,8 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- |-Copyright   :  (c) Henning Thielemann 2003-2006-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable- Numerical values equipped with SI units. This is considered as the user front-end. -}@@ -33,25 +27,23 @@ import qualified Algebra.Transcendental      as Trans import qualified Algebra.Algebraic           as Algebraic import qualified Algebra.Field               as Field-import qualified Algebra.Real                as Real+import qualified Algebra.Absolute                as Absolute import qualified Algebra.Ring                as Ring import qualified Algebra.Additive            as Additive import qualified Algebra.ZeroTestable        as ZeroTestable -import Algebra.Algebraic (sqrt, (^/), )- import Data.Tuple.HT (mapFst, ) +import qualified MathObj.Wrapper.Haskell98 as W98+ import qualified Prelude as P -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   newtype T a v = Cons (PValue v)-{- LANGUAGE GeneralizedNewtypeDeriving allows even this-   deriving (Monad, Functor)--}+   deriving (Functor)  type PValue v = Value.T Dimension v @@ -145,7 +137,7 @@   (<=)    = lift2Gen (<=)   (>=)    = lift2Gen (>=) -instance (Real.C v) => Real.C (T a v) where+instance (Absolute.C v) => Absolute.C (T a v) where   abs    = lift abs   signum = lift signum @@ -251,21 +243,14 @@   --- legacy instances for work with GHCi-legacyInstance :: a-legacyInstance =-   error "legacy Ring.C instance for simple input of numeric literals"--instance (Ord a, Trans.C a, NormedMax.C a v, P.Num v, Ring.C v) =>-      P.Num (T a v) where-   fromInteger = fromInteger-   negate = negate -- for unary minus-   (+)    = legacyInstance-   (*)    = legacyInstance-   abs    = legacyInstance-   signum = legacyInstance+instance (P.Num v) => P.Num (T a v) where+   fromInteger = fromScalarSingle . P.fromInteger+   negate = W98.unliftF1 Additive.negate+   (+)    = W98.unliftF2 (Additive.+)+   (*)    = W98.unliftF2 (Ring.*)+   abs    = W98.unliftF1 Absolute.abs+   signum = W98.unliftF1 Absolute.signum -instance (Ord a, Trans.C a, NormedMax.C a v, P.Num v, Field.C v) =>-      P.Fractional (T a v) where-   fromRational = fromRational-   (/) = legacyInstance+instance (P.Fractional v) => P.Fractional (T a v) where+   fromRational = fromScalarSingle . P.fromRational+   (/) = W98.unliftF2 (Field./)
src/Number/SI/Unit.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {- |-Copyright   :  (c) Henning Thielemann 2003-License     :  GPL--Maintainer  :  numericprelude@henning-thielemann.de-Stability   :  provisional-Portability :  portable- Special physical units: SI unit system -} @@ -20,8 +13,8 @@ import Number.Physical.UnitDatabase(initScale, initUnitSet) import Data.Maybe(catMaybes) -import PreludeBase hiding (length)-import NumericPrelude hiding (one)+import NumericPrelude.Base hiding (length)+import NumericPrelude.Numeric hiding (one)  data Dimension =    Length | Time | Mass | Charge |
src/NumericPrelude.hs view
@@ -1,44 +1,9 @@-{-# LANGUAGE NoImplicitPrelude #-}-module NumericPrelude (-    {- Additive -} (+), (-), negate, zero, subtract, sum, sum1,-    {- ZeroTestable -} isZero,-    {- Ring -} (*), one, fromInteger, (^), ringPower, sqr, product, product1,-    {- IntegralDomain -} div, mod, divMod, divides, even, odd,-    {- Field -} (/), recip, fromRational', (^-), fieldPower, fromRational,-    {- Algebraic -} (^/), sqrt,-    {- Transcendental -}-        pi, exp, log, logBase, (**), (^?), sin, cos, tan,-        asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh,-    {- Real -} abs, signum,-    {- RealIntegral -} quot, rem, quotRem,-    {- RealFrac -} splitFraction, fraction, truncate, round, ceiling, floor, approxRational,-    {- RealTrans -} atan2,-    {- ToRational -} toRational,-    {- ToInteger -} toInteger, fromIntegral,-    {- Units -} isUnit, stdAssociate, stdUnit, stdUnitInv,-    {- PID -} extendedGCD, gcd, lcm, euclid, extendedEuclid,-    {- Ratio -} Rational, (%), numerator, denominator,-    Integer, Int, Float, Double,-    {- Module -} (*>)-) where--import Number.Ratio (Rational, (%), numerator, denominator)--import Algebra.Module((*>))-import Algebra.RealTranscendental(atan2)-import Algebra.Transcendental-import Algebra.Algebraic((^/), sqrt)-import Algebra.RealField(splitFraction, fraction, truncate, round, ceiling, floor, approxRational, )-import Algebra.Field((/), (^-), recip, fromRational', fromRational, )-import Algebra.PrincipalIdealDomain (extendedGCD, gcd, lcm, euclid, extendedEuclid)-import Algebra.Units (isUnit, stdAssociate, stdUnit, stdUnitInv)-import Algebra.RealIntegral (quot, rem, quotRem, )-import Algebra.IntegralDomain (div, mod, divMod, divides, even, odd)-import Algebra.Real (abs, signum, )-import Algebra.Ring (one, fromInteger, (*), (^), sqr, product, product1)-import Algebra.Additive (zero, (+), (-), negate, subtract, sum, sum1)-import Algebra.ZeroTestable (isZero)-import Algebra.ToInteger (ringPower, fieldPower, toInteger, fromIntegral, )-import Algebra.ToRational (toRational, )+module NumericPrelude+   (module NumericPrelude.Numeric,+    module NumericPrelude.Base,+    max, min, abs, ) where -import Prelude (Int, Integer, Float, Double)+import NumericPrelude.Numeric hiding (abs, )+import NumericPrelude.Base    hiding (max, min, )+import Prelude ()+import Algebra.Lattice (max, min, abs, )
+ src/NumericPrelude/Base.hs view
@@ -0,0 +1,138 @@+{- |+The only point of this module is+to reexport items that we want from the standard Prelude.+-}++module NumericPrelude.Base (+   (P.!!),+   (P.$),+   (P.$!),+   (P.&&),+   (P.++),+   (P..),+   (P.=<<),+   P.Bool(..),+   P.Bounded(..),+   P.Char,+   P.Either(..),+   P.Enum(..),+   P.Eq(..),+   P.FilePath,+   P.Functor(..),+   P.IO,+   P.IOError,+   P.Maybe(..),+   P.Monad(..), P.fail,+   P.Ord(..),+   P.Ordering(..),+   P.Read(..),+   P.ReadS,+   P.Show(..),+   P.ShowS,+   P.String,+   P.all,+   P.and,+   P.any,+   P.appendFile,+   P.asTypeOf,+   P.break,+   P.concat,+   P.concatMap,+   P.const,+   P.curry,+   P.cycle,+   P.drop,+   P.dropWhile,+   P.either,+   P.elem,+   P.error,+   P.filter,+   P.flip,+   P.foldl,+   P.foldl1,+   P.foldr,+   P.foldr1,+   P.fst,+   P.getChar,+   P.getContents,+   P.getLine,+   P.head,+   P.id,+   P.init,+   P.interact,+   P.ioError,+   P.iterate,+   P.last,+   P.length,+   P.lex,+   P.lines,+   P.lookup,+   P.map,+   P.mapM,+   P.mapM_,+   P.maximum,+   P.maybe,+   P.minimum,+   P.not,+   P.notElem,+   P.null,+   P.or,+   P.otherwise,+   P.print,+   P.putChar,+   P.putStr,+   P.putStrLn,+   P.read,+   P.readFile,+   P.readIO,+   P.readLn,+   P.readParen,+   P.reads,+   P.realToFrac,+   P.repeat,+   P.replicate,+   P.reverse,+   P.scanl,+   P.scanl1,+   P.scanr,+   P.scanr1,+   P.seq,+   P.sequence,+   P.sequence_,+   P.showChar,+   P.showParen,+   P.showString,+   P.shows,+   P.snd,+   P.span,+   P.splitAt,+   P.tail,+   P.take,+   P.takeWhile,+   P.uncurry,+   P.undefined,+   P.unlines,+   P.until,+   P.unwords,+   P.unzip,+   P.unzip3,+   P.userError,+   P.words,+   P.writeFile,+   P.zip,+   P.zip3,+   P.zipWith,+   P.zipWith3,+   (P.||),++   catch,+   ifThenElse,+   ) where++import qualified System.IO.Error as IOError+import qualified Prelude as P+import Prelude (IO)+import Data.Bool.HT (ifThenElse, )++catch :: IO a -> (P.IOError -> IO a) -> IO a+catch = IOError.catchIOError
src/NumericPrelude/Elementwise.hs view
@@ -28,6 +28,19 @@ run2 :: T (x,y) a -> x -> y -> a run2 = curry . run +{-# INLINE run3 #-}+run3 :: T (x,y,z) a -> x -> y -> z -> a+run3 e x y z = run e (x,y,z)++{-# INLINE run4 #-}+run4 :: T (x,y,z,w) a -> x -> y -> z -> w -> a+run4 e x y z w = run e (x,y,z,w)++{-# INLINE run5 #-}+run5 :: T (x,y,z,u,w) a -> x -> y -> z -> u -> w -> a+run5 e x y z u w = run e (x,y,z,u,w)++ instance Functor (T v) where    {-# INLINE fmap #-}    fmap f (Cons e) =
src/NumericPrelude/List.hs view
@@ -26,20 +26,19 @@        aux [] ys = map fb ys    in  aux -{- | Zip two lists which must be of the same length.-    This is checked only lazily, that is unequal lengths are detected only-    if the list is evaluated completely.-    But it is more strict than @zipWithPad undefined f@-    since the latter one may succeed on unequal length list if @f@ is lazy. -}-zipWithMatch+{-+This is exported as Checked.zipWith.+We need to define it here in order to prevent an import cycle.+-}+zipWithChecked    :: (a -> b -> c)   {-^ function applied to corresponding elements of the lists -}    -> [a]    -> [b]    -> [c]-zipWithMatch f =+zipWithChecked f =    let aux (x:xs) (y:ys) = f x y : aux xs ys        aux []     []     = []-       aux _      _      = error "zipWith: lists must have the same length"+       aux _      _      = error "Checked.zipWith: lists must have the same length"    in  aux
+ src/NumericPrelude/List/Checked.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RebindableSyntax #-}+{- |+Some functions that are counterparts of functions from "Data.List"+using NumericPrelude.Numeric type classes.+They are distinct in that they check for valid arguments,+e.g. the length argument of 'take' must be at most the length of the input list.+However, since many Haskell programs rely on the absence of such checks,+we did not make these the default implementations+as in "NumericPrelude.List.Generic".+-}+module NumericPrelude.List.Checked+   (take, drop, splitAt, (!!), zipWith,+   ) where++import qualified Algebra.ToInteger  as ToInteger+import Algebra.Ring (one, )+import Algebra.Additive (zero, (-), )++import Data.Tuple.HT (mapFst, )++import qualified NumericPrelude.List as NPList++import NumericPrelude.Base hiding (take, drop, splitAt, length, replicate, (!!), zipWith, )+++moduleError :: String -> String -> a+moduleError name msg =+   error $ "NumericPrelude.List.Left." ++ name ++ ": " ++ msg++{- |+Taken number of elements must be at most the length of the list,+otherwise the end of the list is undefined.+-}+take :: (ToInteger.C n) => n -> [a] -> [a]+take n =+   if n<=zero+     then const []+     else \xt ->+       case xt of+          [] -> moduleError "take" "index out of range"+          (x:xs) -> x : take (n-one) xs++{- |+Dropped number of elements must be at most the length of the list,+otherwise the end of the list is undefined.+-}+drop :: (ToInteger.C n) => n -> [a] -> [a]+drop n =+   if n<=zero+     then id+     else \xt ->+       case xt of+          [] -> moduleError "drop" "index out of range"+          (_:xs) -> drop (n-one) xs++{- |+Split position must be at most the length of the list,+otherwise the end of the first list and the second list are undefined.+-}+splitAt :: (ToInteger.C n) => n -> [a] -> ([a], [a])+splitAt n xt =+   if n<=zero+     then ([], xt)+     else+       case xt of+          [] -> moduleError "splitAt" "index out of range"+          (x:xs) -> mapFst (x:) $ splitAt (n-one) xs++{- |+The index must be smaller than the length of the list,+otherwise the result is undefined.+-}+(!!) :: (ToInteger.C n) => [a] -> n -> a+(!!) [] _ = moduleError "(!!)" "index out of range"+(!!) (x:xs) n =+   if n<=zero+     then x+     else (!!) xs (n-one)+++{- |+Zip two lists which must be of the same length.+This is checked only lazily, that is unequal lengths are detected only+if the list is evaluated completely.+But it is more strict than @zipWithPad undefined f@+since the latter one may succeed on unequal length list if @f@ is lazy.+-}+zipWith+   :: (a -> b -> c)   {-^ function applied to corresponding elements of the lists -}+   -> [a]+   -> [b]+   -> [c]+zipWith = NPList.zipWithChecked
+ src/NumericPrelude/List/Generic.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE RebindableSyntax #-}+{- |+Functions that are counterparts of the @generic@ functions in "Data.List"+using NumericPrelude.Numeric type classes.+For input arguments we use the restrictive @ToInteger@ constraint,+although in principle @RealRing@ would be enough.+However we think that @take 0.5 xs@ is rather a bug than a feature,+thus we forbid fractional types.+On the other hand fractional types as result can be quite handy,+e.g. in @average xs = sum xs / length xs@.+-}+module NumericPrelude.List.Generic+   ((!!), lengthLeft, lengthRight, replicate,+    take, drop, splitAt,+    findIndex, elemIndex, findIndices, elemIndices,+   ) where++import NumericPrelude.List.Checked ((!!), )++import qualified Algebra.ToInteger  as ToInteger+import qualified Algebra.Ring       as Ring+import Algebra.Ring (one, )+import Algebra.Additive (zero, (+), (-), )++import qualified Data.Maybe         as Maybe+import Data.Tuple.HT (mapFst, )++import NumericPrelude.Base as List+   hiding (take, drop, splitAt, length, replicate, (!!), )+++replicate :: (ToInteger.C n) => n -> a -> [a]+replicate n x = take n (List.repeat x)++take :: (ToInteger.C n) => n -> [a] -> [a]+take _ [] = []+take n (x:xs) =+   if n<=zero+     then []+     else x : take (n-one) xs++drop :: (ToInteger.C n) => n -> [a] -> [a]+drop _ [] = []+drop n xt@(_:xs) =+   if n<=zero+     then xt+     else drop (n-one) xs++splitAt :: (ToInteger.C n) => n -> [a] -> ([a], [a])+splitAt _ [] = ([], [])+splitAt n xt@(x:xs) =+   if n<=zero+     then ([], xt)+     else mapFst (x:) $ splitAt (n-one) xs+++{- |+Left associative length computation+that is appropriate for types like @Integer@.+-}+lengthLeft :: (Ring.C n) => [a] -> n+lengthLeft = List.foldl (\n _ -> n+one) zero++{- |+Right associative length computation+that is appropriate for types like @Peano@ number.+-}+lengthRight :: (Ring.C n) => [a] -> n+lengthRight = List.foldr (\_ n -> one+n) zero++elemIndex :: (Ring.C n, Eq a) => a -> [a] -> Maybe n+elemIndex e = findIndex (e==)++elemIndices :: (Ring.C n, Eq a) => a -> [a] -> [n]+elemIndices e = findIndices (e==)++findIndex :: Ring.C n => (a -> Bool) -> [a] -> Maybe n+findIndex p = Maybe.listToMaybe . findIndices p++findIndices :: Ring.C n => (a -> Bool) -> [a] -> [n]+findIndices p =+   map fst .+   filter (p . snd) .+   zip (iterate (one+) zero)
+ src/NumericPrelude/Numeric.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE RebindableSyntax #-}+module NumericPrelude.Numeric (+    {- Additive -} (+), (-), negate, zero, subtract, sum, sum1,+    {- ZeroTestable -} isZero,+    {- Ring -} (*), one, fromInteger, (^), ringPower, sqr, product, product1,+    {- IntegralDomain -} div, mod, divMod, divides, even, odd,+    {- Field -} (/), recip, fromRational', (^-), fieldPower, fromRational,+    {- Algebraic -} (^/), sqrt,+    {- Transcendental -}+        pi, exp, log, logBase, (**), (^?), sin, cos, tan,+        asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh,+    {- Absolute -} abs, signum,+    {- RealIntegral -} quot, rem, quotRem,+    {- RealFrac -} splitFraction, fraction, truncate, round, ceiling, floor, approxRational,+    {- RealTrans -} atan2,+    {- ToRational -} toRational,+    {- ToInteger -} toInteger, fromIntegral,+    {- Units -} isUnit, stdAssociate, stdUnit, stdUnitInv,+    {- PID -} extendedGCD, gcd, lcm, euclid, extendedEuclid,+    {- Ratio -} Rational, (%), numerator, denominator,+    Integer, Int, Float, Double,+    {- Module -} (*>)+) where++import Number.Ratio (Rational, (%), numerator, denominator)++import Algebra.Module((*>))+import Algebra.RealTranscendental(atan2)+import Algebra.Transcendental+import Algebra.Algebraic((^/), sqrt)+import Algebra.RealRing(splitFraction, fraction, truncate, round, ceiling, floor, approxRational, )+import Algebra.Field((/), (^-), recip, fromRational', fromRational, )+import Algebra.PrincipalIdealDomain (extendedGCD, gcd, lcm, euclid, extendedEuclid)+import Algebra.Units (isUnit, stdAssociate, stdUnit, stdUnitInv)+import Algebra.RealIntegral (quot, rem, quotRem, )+import Algebra.IntegralDomain (div, mod, divMod, divides, even, odd)+import Algebra.Absolute (abs, signum, )+import Algebra.Ring (one, fromInteger, (*), (^), sqr, product, product1)+import Algebra.Additive (zero, (+), (-), negate, subtract, sum, sum1)+import Algebra.ZeroTestable (isZero)+import Algebra.ToInteger (ringPower, fieldPower, toInteger, fromIntegral, )+import Algebra.ToRational (toRational, )++import Prelude (Int, Integer, Float, Double)
− src/PreludeBase.hs 
@@ -1,12 +0,0 @@-{- |-The only point of this module is-to reexport items that we want from the standard Prelude.--}--module PreludeBase (module Prelude) where-import Prelude hiding(-       Int, Integer, Float, Double, Rational, Num(..), Real(..),-       Integral(..), Fractional(..), Floating(..), RealFrac(..),-       RealFloat(..), subtract, even, odd,-       gcd, lcm, (^), (^^), sum, product,-       fromIntegral, fromRational)
+ test/Demo.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE RebindableSyntax #-}+module Main where++import Number.Complex((+:), (-:), )+import qualified Number.Complex as Complex+import Number.Physical      as Value+import Number.SI            as SIValue -- units+import Number.SI.Unit       as SIUnit  -- unit prefixes+          (pico, nano, micro, milli, centi, deci,+           deca, hecto, kilo, mega, giga, tera, peta)+import Number.OccasionallyScalarExpression as Expr++import qualified Number.NonNegativeChunky as Chunky+import qualified Number.NonNegative       as NonNegW+import qualified Number.Positional.Check  as Real+import qualified Number.FixedPoint.Check  as FixedPoint+import qualified Number.ResidueClass.Func as ResidueClass+import qualified Number.Peano             as Peano++import qualified MathObj.Polynomial          as Polynomial+import qualified MathObj.LaurentPolynomial   as LaurentPolynomial+import qualified MathObj.PowerSeries         as PowerSeries+import qualified MathObj.PowerSeries.Example as PowerSeriesExample+import qualified MathObj.PartialFraction     as PartialFraction++import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Field                as Field+import qualified Algebra.ZeroTestable         as ZeroTestable+import qualified Algebra.Indexable            as Indexable++import Data.List (genericTake, genericLength)++import NumericPrelude.Base+import NumericPrelude.Numeric+++{- * Physical units -}++-- some shorthands for common usage+type SIDouble  = SIValue.T Double Double+type SIComplex = SIValue.T Double (Complex.T Double)++{- this advice seems not to be targeted to ghc's interactive mode+default (SIDouble)+-}+++++test :: [SIDouble]+test =+   let lengthScales = map (\n->10^-n*meter) [-10..6]+       areaScales = map (\n->10^-n*meter^2) [-10..6]+   in  lengthScales ++ map recip lengthScales +++       areaScales   ++ map recip areaScales +++       map ((meter*gramm/second)^-) [-5..5] +++       take 16 (iterate (10*) (10e-10*meter/gramm)) +++       [1/meter^2, 1/meter, meter, meter^2,+        second, hertz,+        meter*second, second/meter, meter/second, 1/meter/second,+        volt/meter,newton/meter,+        gramm]++testComplex :: SIComplex+testComplex = (2 :: Double) *> (SIValue.fromScalarSingle (3+:4)*milli*second)++testMagnitude :: SIDouble+testMagnitude = SIValue.lift (Value.lift Complex.magnitude) testComplex++testExpr :: Expr.T Double SIDouble+testExpr = sin (5 / (3+1) * fromValue meter)++testPrefixes :: [SIDouble]+testPrefixes =+   [pico, nano, micro, milli, centi, deci,+    deca, hecto, kilo, mega, giga, tera, peta]+++{- * Reals -}++testReal :: String+testReal = Real.defltShow (sqrt 2 + log 2 * pi)++testComplexReal :: Complex.T Real.T+testComplexReal = exp (0 +: pi) + exp (0 -: pi)++showReal :: Real.T -> String+showReal = Real.defltShow+++{- * Fixed point numbers -}++testFixedPoint :: String+testFixedPoint = FixedPoint.defltShow (sqrt 2 + log 2 * pi)++showFixedPoint :: FixedPoint.T -> String+showFixedPoint = FixedPoint.defltShow+++{- * Residue classes -}++testResidueClass :: Integer+testResidueClass = ResidueClass.concrete 7 (5*3/2)++polyResidueClass :: (ZeroTestable.C a, Field.C a) =>+   [a] -> ResidueClass.T (Polynomial.T a)+polyResidueClass = ResidueClass.fromRepresentative . polynomial++{- That's strange:+The residue class implementation should constantly compute mod+and thus should be much faster.+I assume that this is an effect of missing sharing.+The functions which represent a residue class are shared,+but not their values.++*Main> mod (3^3000000) 2 :: Integer+1+(2.47 secs, 24541080 bytes)+*Main> ResidueClass.concrete 2 (3^3000000) :: Integer+1+(7.33 secs, 515047072 bytes)+-}+++{- * Polynomials and power series -}++polynomial :: [a] -> Polynomial.T a+polynomial = Polynomial.fromCoeffs++powerSeries :: [a] -> PowerSeries.T a+powerSeries = PowerSeries.fromCoeffs++laurentPolynomial :: Int -> [a] -> LaurentPolynomial.T a+laurentPolynomial = LaurentPolynomial.fromShiftCoeffs++tanSeries :: PowerSeries.T Rational+tanSeries = powerSeries PowerSeriesExample.tan+++{- * Partial fractions -}++partialFraction :: (PID.C a, Indexable.C a) =>+   [a] -> a -> PartialFraction.T a+partialFraction = PartialFraction.fromFactoredFraction++{- |+An example from wavelet theory: lifting coefficients of the CDF wavelet family.+-}+cdfFraction :: PartialFraction.T (Polynomial.T Rational)+cdfFraction =+   partialFraction+      (map polynomial [[-4,1],[0,1],[4,1]])+      (product (map polynomial [[-2,1],[2,1]]))++{- |+The same example with different notation,+that relies on numerical literals being used for polynomials.+-}+cdfFractionNum :: PartialFraction.T (Polynomial.T Rational)+cdfFractionNum =+   let x = polynomial [0,1]+   in  partialFraction [x-4,x,x+4] ((x-2)*(x+2))+++{- * Peano numbers -}+testPeano :: Peano.T+testPeano = minimum [Peano.infinity, 2, Peano.infinity, 4]++testPeanoList :: [Char]+testPeanoList =+   genericTake (genericLength (repeat 'a') :: Peano.T) ['a'..'z']++testChunky :: Chunky.T NonNegW.Int+testChunky = (2+3)*(1+5)+++main :: IO ()+main = print test
− test/Gaussian.hs 
@@ -1,6 +0,0 @@-module Main where--import qualified MathObj.Gaussian.Example as Example--main :: IO ()-main = Example.polyApprox
− test/Test.hs 
@@ -1,173 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Main where--import Number.Complex((+:), (-:), )-import qualified Number.Complex as Complex-import Number.Physical      as Value-import Number.SI            as SIValue -- units-import Number.SI.Unit       as SIUnit  -- unit prefixes-          (pico, nano, micro, milli, centi, deci,-           deca, hecto, kilo, mega, giga, tera, peta)-import Number.OccasionallyScalarExpression as Expr--import qualified Number.Positional.Check  as Real-import qualified Number.FixedPoint.Check  as FixedPoint-import qualified Number.ResidueClass.Func as ResidueClass-import qualified Number.Peano             as Peano--import qualified MathObj.Polynomial          as Polynomial-import qualified MathObj.LaurentPolynomial   as LaurentPolynomial-import qualified MathObj.PowerSeries         as PowerSeries-import qualified MathObj.PowerSeries.Example as PowerSeriesExample-import qualified MathObj.PartialFraction     as PartialFraction--import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.Field                as Field-import qualified Algebra.ZeroTestable         as ZeroTestable-import qualified Algebra.Indexable            as Indexable--import Data.List (genericTake, genericLength)--import PreludeBase-import NumericPrelude---{- * Physical units -}---- some shorthands for common usage-type SIDouble  = SIValue.T Double Double-type SIComplex = SIValue.T Double (Complex.T Double)--{- this advice seems not to be targeted to ghc's interactive mode-default (SIDouble)--}-----test :: [SIDouble]-test =-   let lengthScales = map (\n->10^-n*meter) [-10..6]-       areaScales = map (\n->10^-n*meter^2) [-10..6]-   in  lengthScales ++ map recip lengthScales ++-       areaScales   ++ map recip areaScales ++-       map ((meter*gramm/second)^-) [-5..5] ++-       take 16 (iterate (10*) (10e-10*meter/gramm)) ++-       [1/meter^2, 1/meter, meter, meter^2,-        second, hertz,-        meter*second, second/meter, meter/second, 1/meter/second,-        volt/meter,newton/meter,-        gramm]--testComplex :: SIComplex-testComplex = (2 :: Double) *> (SIValue.fromScalarSingle (3+:4)*milli*second)--testMagnitude :: SIDouble-testMagnitude = SIValue.lift (Value.lift Complex.magnitude) testComplex--testExpr :: Expr.T Double SIDouble-testExpr = sin (5 / (3+1) * fromValue meter)--testPrefixes :: [SIDouble]-testPrefixes =-   [pico, nano, micro, milli, centi, deci,-    deca, hecto, kilo, mega, giga, tera, peta]---{- * Reals -}--testReal :: String-testReal = Real.defltShow (sqrt 2 + log 2 * pi)--testComplexReal :: Complex.T Real.T-testComplexReal = exp (0 +: pi) + exp (0 -: pi)--showReal :: Real.T -> String-showReal = Real.defltShow---{- * Fixed point numbers -}--testFixedPoint :: String-testFixedPoint = FixedPoint.defltShow (sqrt 2 + log 2 * pi)--showFixedPoint :: FixedPoint.T -> String-showFixedPoint = FixedPoint.defltShow---{- * Residue classes -}--testResidueClass :: Integer-testResidueClass = ResidueClass.concrete 7 (5*3/2)--polyResidueClass :: (ZeroTestable.C a, Field.C a) =>-   [a] -> ResidueClass.T (Polynomial.T a)-polyResidueClass = ResidueClass.fromRepresentative . polynomial--{- That's strange:-The residue class implementation should constantly compute mod-and thus should be much faster.-I assume that this is an effect of missing sharing.-The functions which represent a residue class are shared,-but not their values.--*Main> mod (3^3000000) 2 :: Integer-1-(2.47 secs, 24541080 bytes)-*Main> ResidueClass.concrete 2 (3^3000000) :: Integer-1-(7.33 secs, 515047072 bytes)--}---{- * Polynomials and power series -}--polynomial :: [a] -> Polynomial.T a-polynomial = Polynomial.fromCoeffs--powerSeries :: [a] -> PowerSeries.T a-powerSeries = PowerSeries.fromCoeffs--laurentPolynomial :: Int -> [a] -> LaurentPolynomial.T a-laurentPolynomial = LaurentPolynomial.fromShiftCoeffs--tanSeries :: PowerSeries.T Rational-tanSeries = powerSeries PowerSeriesExample.tan---{- * Partial fractions -}--partialFraction :: (PID.C a, Indexable.C a) =>-   [a] -> a -> PartialFraction.T a-partialFraction = PartialFraction.fromFactoredFraction--{- |-An example from wavelet theory: lifting coefficients of the CDF wavelet family.--}-cdfFraction :: PartialFraction.T (Polynomial.T Rational)-cdfFraction =-   partialFraction-      (map polynomial [[-4,1],[0,1],[4,1]])-      (product (map polynomial [[-2,1],[2,1]]))--{- |-The same example with different notation,-that relies on numerical literals being used for polynomials.--}-cdfFractionNum :: PartialFraction.T (Polynomial.T Rational)-cdfFractionNum =-   let x = polynomial [0,1]-   in  partialFraction [x-4,x,x+4] ((x-2)*(x+2))---{- * Peano numbers -}-testPeano :: Peano.T-testPeano = minimum [Peano.infinity, 2, Peano.infinity, 4]--testPeanoList :: [Char]-testPeanoList =-   genericTake (genericLength (repeat 'a') :: Peano.T) ['a'..'z']---main :: IO ()-main = print test
+ test/Test/Algebra/Additive.hs view
@@ -0,0 +1,28 @@+-- Do not edit! Automatically created with doctest-extract from src/Algebra/Additive.hs+{-# LINE 42 "src/Algebra/Additive.hs" #-}++module Test.Algebra.Additive where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 43 "src/Algebra/Additive.hs" #-}+import     qualified Algebra.Additive as A+import     qualified Test.QuickCheck as QC++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Algebra.Additive:108: "+{-# LINE 108 "src/Algebra/Additive.hs" #-}+ DocTest.property+{-# LINE 108 "src/Algebra/Additive.hs" #-}+     (\(QC.NonEmpty ns) -> A.sum ns == (A.sum1 ns :: Integer))+ DocTest.printPrefix "Algebra.Additive:121: "+{-# LINE 121 "src/Algebra/Additive.hs" #-}+ DocTest.property+{-# LINE 121 "src/Algebra/Additive.hs" #-}+     (\ns -> A.sum ns == (A.sumNestedAssociative ns :: Integer))+ DocTest.printPrefix "Algebra.Additive:136: "+{-# LINE 136 "src/Algebra/Additive.hs" #-}+ DocTest.property+{-# LINE 136 "src/Algebra/Additive.hs" #-}+     (\ns -> A.sum ns == (A.sumNestedCommutative ns :: Integer))
+ test/Test/Algebra/IntegralDomain.hs view
@@ -0,0 +1,41 @@+-- Do not edit! Automatically created with doctest-extract from src/Algebra/IntegralDomain.hs+{-# LINE 54 "src/Algebra/IntegralDomain.hs" #-}++module Test.Algebra.IntegralDomain where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 55 "src/Algebra/IntegralDomain.hs" #-}+import     Algebra.IntegralDomain (roundDown, roundUp, divUp)+import     qualified Test.QuickCheck as QC+import     NumericPrelude.Base as P+import     NumericPrelude.Numeric as NP+import     Prelude ()++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Algebra.IntegralDomain:108: "+{-# LINE 108 "src/Algebra/IntegralDomain.hs" #-}+ DocTest.property+{-# LINE 108 "src/Algebra/IntegralDomain.hs" #-}+         (\n (QC.NonZero m) -> let (q,r) = divMod n m in n == (q*m+r :: Integer))+ DocTest.printPrefix "Algebra.IntegralDomain:198: "+{-# LINE 198 "src/Algebra/IntegralDomain.hs" #-}+ DocTest.property+{-# LINE 198 "src/Algebra/IntegralDomain.hs" #-}+     (\n (QC.NonZero m) -> div n m * m == (roundDown n m :: Integer))+ DocTest.printPrefix "Algebra.IntegralDomain:208: "+{-# LINE 208 "src/Algebra/IntegralDomain.hs" #-}+ DocTest.property+{-# LINE 208 "src/Algebra/IntegralDomain.hs" #-}+     (\n (QC.NonZero m) -> divUp n m * m == (roundUp n m :: Integer))+ DocTest.printPrefix "Algebra.IntegralDomain:209: "+{-# LINE 209 "src/Algebra/IntegralDomain.hs" #-}+ DocTest.property+{-# LINE 209 "src/Algebra/IntegralDomain.hs" #-}+     (\n (QC.Positive m) -> let x = roundDown n m in  n-m < x && x <= (n :: Integer))+ DocTest.printPrefix "Algebra.IntegralDomain:210: "+{-# LINE 210 "src/Algebra/IntegralDomain.hs" #-}+ DocTest.property+{-# LINE 210 "src/Algebra/IntegralDomain.hs" #-}+     (\n (QC.NonZero m) -> - roundDown n m == (roundUp (-n) m :: Integer))
+ test/Test/Algebra/PrincipalIdealDomain.hs view
@@ -0,0 +1,49 @@+-- Do not edit! Automatically created with doctest-extract from src/Algebra/PrincipalIdealDomain.hs+{-# LINE 64 "src/Algebra/PrincipalIdealDomain.hs" #-}++module Test.Algebra.PrincipalIdealDomain where++import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest++{-# LINE 65 "src/Algebra/PrincipalIdealDomain.hs" #-}+import     qualified Algebra.PrincipalIdealDomain as PID+import     Test.NumericPrelude.Utility ((/\))+import     qualified Test.QuickCheck as QC++genResidueClass     :: QC.Gen (Integer,Integer)+genResidueClass     = do+       m <- fmap QC.getNonZero $ QC.arbitrary+       a <- QC.choose (min 0 $ 1+m, max 0 $ m-1)+       return (m,a)++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Algebra.PrincipalIdealDomain:305: "+{-# LINE 305 "src/Algebra/PrincipalIdealDomain.hs" #-}+ DocTest.property+{-# LINE 305 "src/Algebra/PrincipalIdealDomain.hs" #-}+     (QC.listOf genResidueClass /\ \xs -> case PID.chineseRemainderMulti xs of Nothing -> True; Just (n,b) -> abs n == abs (foldl lcm 1 (map fst xs)) && map snd xs == map (mod b . fst) xs)+ DocTest.printPrefix "Algebra.PrincipalIdealDomain:306: "+{-# LINE 306 "src/Algebra/PrincipalIdealDomain.hs" #-}+ DocTest.property+{-# LINE 306 "src/Algebra/PrincipalIdealDomain.hs" #-}+     (\(QC.NonEmpty ms) b -> let xs = map (\(QC.NonZero m) -> (m, mod b m)) ms in case PID.chineseRemainderMulti xs of Nothing -> False; Just (n,c) -> abs n == abs (foldl lcm 1 (map QC.getNonZero ms)) && mod b n == (c::Integer))+ DocTest.printPrefix "Algebra.PrincipalIdealDomain:298: "+{-# LINE 298 "src/Algebra/PrincipalIdealDomain.hs" #-}+ DocTest.example+{-# LINE 298 "src/Algebra/PrincipalIdealDomain.hs" #-}+   (PID.chineseRemainderMulti [(100,21), (10000,2021::Integer)])+  [ExpectedLine [LineChunk "Just (10000,2021)"]]+ DocTest.printPrefix "Algebra.PrincipalIdealDomain:300: "+{-# LINE 300 "src/Algebra/PrincipalIdealDomain.hs" #-}+ DocTest.example+{-# LINE 300 "src/Algebra/PrincipalIdealDomain.hs" #-}+   (PID.chineseRemainderMulti [(97,90),(99,10),(100,0::Integer)])+  [ExpectedLine [LineChunk "Just (960300,100000)"]]+ DocTest.printPrefix "Algebra.PrincipalIdealDomain:302: "+{-# LINE 302 "src/Algebra/PrincipalIdealDomain.hs" #-}+ DocTest.example+{-# LINE 302 "src/Algebra/PrincipalIdealDomain.hs" #-}+   (PID.chineseRemainderMulti [(95,30),(97,27),(98,8),(99,1::Integer)])+  [ExpectedLine [LineChunk "Just (89403930,1000000)"]]
+ test/Test/Algebra/RealRing.hs view
@@ -0,0 +1,126 @@+-- Do not edit! Automatically created with doctest-extract from src/Algebra/RealRing.hs+{-# LINE 38 "src/Algebra/RealRing.hs" #-}++module Test.Algebra.RealRing where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 39 "src/Algebra/RealRing.hs" #-}+import     qualified Algebra.RealRing as RealRing+import     Data.Tuple.HT (mapFst)+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base+import     Prelude ()++infix     4 =~=++(=~=)     :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool+(f     =~= g) x = f x == g x++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Algebra.RealRing:134: "+{-# LINE 134 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 134 "src/Algebra/RealRing.hs" #-}+         (\x -> (x::Rational) == (uncurry (+) $ mapFst fromInteger $ splitFraction x))+ DocTest.printPrefix "Algebra.RealRing:135: "+{-# LINE 135 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 135 "src/Algebra/RealRing.hs" #-}+         (\x -> uncurry (==) $ mapFst (((x::Double)-) . fromInteger) $ splitFraction x)+ DocTest.printPrefix "Algebra.RealRing:136: "+{-# LINE 136 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 136 "src/Algebra/RealRing.hs" #-}+         (\x -> uncurry (==) $ mapFst (((x::Rational)-) . fromInteger) $ splitFraction x)+ DocTest.printPrefix "Algebra.RealRing:137: "+{-# LINE 137 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 137 "src/Algebra/RealRing.hs" #-}+         (\x -> splitFraction x == (floor (x::Double) :: Integer, fraction x))+ DocTest.printPrefix "Algebra.RealRing:138: "+{-# LINE 138 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 138 "src/Algebra/RealRing.hs" #-}+         (\x -> splitFraction x == (floor (x::Rational) :: Integer, fraction x))+ DocTest.printPrefix "Algebra.RealRing:142: "+{-# LINE 142 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 142 "src/Algebra/RealRing.hs" #-}+         (\x -> let y = fraction (x::Double) in 0<=y && y<1)+ DocTest.printPrefix "Algebra.RealRing:143: "+{-# LINE 143 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 143 "src/Algebra/RealRing.hs" #-}+         (\x -> let y = fraction (x::Rational) in 0<=y && y<1)+ DocTest.printPrefix "Algebra.RealRing:147: "+{-# LINE 147 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 147 "src/Algebra/RealRing.hs" #-}+         (\x -> ceiling (-x) == negate (floor (x::Double) :: Integer))+ DocTest.printPrefix "Algebra.RealRing:148: "+{-# LINE 148 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 148 "src/Algebra/RealRing.hs" #-}+         (\x -> ceiling (-x) == negate (floor (x::Rational) :: Integer))+ DocTest.printPrefix "Algebra.RealRing:564: "+{-# LINE 564 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 564 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericFloor =~= (NP.floor :: Double -> Integer))+ DocTest.printPrefix "Algebra.RealRing:565: "+{-# LINE 565 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 565 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericFloor =~= (NP.floor :: Rational -> Integer))+ DocTest.printPrefix "Algebra.RealRing:574: "+{-# LINE 574 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 574 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericCeiling =~= (NP.ceiling :: Double -> Integer))+ DocTest.printPrefix "Algebra.RealRing:575: "+{-# LINE 575 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 575 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericCeiling =~= (NP.ceiling :: Rational -> Integer))+ DocTest.printPrefix "Algebra.RealRing:584: "+{-# LINE 584 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 584 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericTruncate =~= (NP.truncate :: Double -> Integer))+ DocTest.printPrefix "Algebra.RealRing:585: "+{-# LINE 585 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 585 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericTruncate =~= (NP.truncate :: Rational -> Integer))+ DocTest.printPrefix "Algebra.RealRing:594: "+{-# LINE 594 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 594 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericRound =~= (NP.round :: Double -> Integer))+ DocTest.printPrefix "Algebra.RealRing:595: "+{-# LINE 595 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 595 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericRound =~= (NP.round :: Rational -> Integer))+ DocTest.printPrefix "Algebra.RealRing:604: "+{-# LINE 604 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 604 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericFraction =~= (NP.fraction :: Double -> Double))+ DocTest.printPrefix "Algebra.RealRing:605: "+{-# LINE 605 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 605 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericFraction =~= (NP.fraction :: Rational -> Rational))+ DocTest.printPrefix "Algebra.RealRing:614: "+{-# LINE 614 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 614 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericSplitFraction =~= (NP.splitFraction :: Double -> (Integer,Double)))+ DocTest.printPrefix "Algebra.RealRing:615: "+{-# LINE 615 "src/Algebra/RealRing.hs" #-}+ DocTest.property+{-# LINE 615 "src/Algebra/RealRing.hs" #-}+     (RealRing.genericSplitFraction =~= (NP.splitFraction :: Rational -> (Integer,Rational)))
test/Test/MathObj/Gaussian/Bell.hs view
@@ -1,96 +1,157 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.Gaussian.Bell where--import qualified MathObj.Gaussian.Bell as G---- import qualified Algebra.Ring           as Ring--import qualified Algebra.Laws as Laws+-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/Bell.hs+{-# LINE 30 "gaussian/MathObj/Gaussian/Bell.hs" #-} -import qualified Number.Complex as Complex+module Test.MathObj.Gaussian.Bell where -import Test.NumericPrelude.Utility (testUnit)-import Test.QuickCheck (Testable, quickCheck, (==>))-import qualified Test.HUnit as HUnit+import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest -import Data.Function.HT (nest, )+{-# LINE 31 "gaussian/MathObj/Gaussian/Bell.hs" #-}+import     qualified MathObj.Gaussian.Bell as G+import     qualified Algebra.ZeroTestable as ZeroTestable+import     qualified Algebra.Laws as Laws+import     qualified Number.Complex as Complex+import     Number.Complex ((+:))+import     NumericPrelude.Base as P+import     NumericPrelude.Numeric as NP+import     Prelude ()+import     qualified Test.QuickCheck as QC+import     Data.Function.HT (Id, nest) -import PreludeBase as P-import NumericPrelude as NP+asRational     :: Id (G.T Rational)+asRational     = id +withRational     :: Id (G.T Rational -> a)+withRational     = id -simple ::-   (Testable t) =>-   (G.T Rational -> t) -> IO ()-simple f =-   quickCheck (\x -> f (x :: G.T Rational))+isConstant     :: ZeroTestable.C a => G.T a -> Bool+isConstant     (G.Cons _amp _a b c) = isZero b && isZero c -tests :: HUnit.Test-tests =-   HUnit.TestLabel "polynomial" $-   HUnit.TestList $-   map testUnit $-{--      ("convolution, dirac",-          simple $ Laws.identity (+) zero) :--}-      ("convolution, commutative",-          simple $ Laws.commutative G.convolve) :-      ("convolution, associative",-          simple $ Laws.associative G.convolve) :-      ("multiplication, one",-          simple $ Laws.identity G.multiply G.constant) :-      ("multiplication, commutative",-          simple $ Laws.commutative G.multiply) :-      ("multiplication, associative",-          simple $ Laws.associative G.multiply) :-      ("convolution, multplication, fourier",-          simple $ \x y ->-             G.fourier (G.convolve x y)-              == G.multiply (G.fourier x) (G.fourier y)) :-      ("convolution via translation",-          simple $ \x y ->-             G.convolve x y-              == G.convolveByTranslation x y) :-      ("convolution via fourier",-          simple $ \x y ->-             G.convolve x y-              == G.convolveByFourier x y) :-      ("fourier reverse",-          simple $ \x -> nest 2 G.fourier x == G.reverse x) :-      ("reverse identity",-          simple $ \x -> nest 2 G.reverse x == x) :-      ("fourier unit",-          quickCheck $ G.fourier G.unit == (G.unit :: G.T Rational)) :-      ("translate additive",-          simple $ \x a b ->-             G.translate a (G.translate b x) == G.translate (a+b) x) :-      ("translateComplex additive",-          simple $ \x a b ->-             G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x) :-      ("translateComplex real",-          simple $ \x a ->-             G.translateComplex (Complex.fromReal a) x == G.translate a x) :-      ("modulate additive",-          simple $ \x a b ->-             G.modulate a (G.modulate b x) == G.modulate (a+b) x) :-      ("commute translate modulate",-          simple $ \x a b ->-             G.modulate b (G.translate a x)-              == G.turn (a*b) (G.translate a (G.modulate b x))) :-      ("fourier translate",-          simple $ \x a ->-             G.fourier (G.translate a x)-              == G.modulate a (G.fourier x)) :-      ("dilate multiplicative",-          simple $ \x a b -> a>0 && b>0 ==>-             G.dilate a (G.dilate b x) == G.dilate (a*b) x) :-      ("dilate by shrink",-          simple $ \x a -> a>0 ==>-             G.shrink a x == G.dilate (recip a) x) :-      ("fourier dilate",-          simple $ \x a -> a>0 ==>-             G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) :-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Gaussian.Bell:108: "+{-# LINE 108 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 108 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (Laws.identity G.multiply G.constant . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Bell:109: "+{-# LINE 109 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 109 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (Laws.commutative G.multiply . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Bell:110: "+{-# LINE 110 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 110 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (Laws.associative G.multiply . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Bell:152: "+{-# LINE 152 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 152 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (Laws.commutative G.convolve . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Bell:153: "+{-# LINE 153 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 153 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (Laws.associative G.convolve . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Bell:161: "+{-# LINE 161 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 161 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (isConstant . G.convolve G.constant . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Bell:149: "+{-# LINE 149 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.example+{-# LINE 149 "gaussian/MathObj/Gaussian/Bell.hs" #-}+   (let x=G.Cons 2 (1+:3) (4+:5) (7::Rational); y=G.Cons 7 (1+:4) (3+:2) (5::Rational) in G.convolve x y)+  [ExpectedLine [LineChunk "Cons {amp = 7 % 6, c0 = 13 % 6 +: 55 % 8, c1 = 41 % 12 +: 13 % 4, c2 = 35 % 12}"]]+ DocTest.printPrefix "MathObj.Gaussian.Bell:200: "+{-# LINE 200 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 200 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x y -> G.convolve x y == G.convolveByTranslation x y)+ DocTest.printPrefix "MathObj.Gaussian.Bell:217: "+{-# LINE 217 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 217 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x y -> G.convolve x y == G.convolveByFourier x y)+ DocTest.printPrefix "MathObj.Gaussian.Bell:225: "+{-# LINE 225 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 225 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y))+ DocTest.printPrefix "MathObj.Gaussian.Bell:226: "+{-# LINE 226 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 226 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x -> nest 2 G.fourier x == G.reverse x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:227: "+{-# LINE 227 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 227 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (G.fourier G.unit == (asRational G.unit))+ DocTest.printPrefix "MathObj.Gaussian.Bell:228: "+{-# LINE 228 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 228 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x))+ DocTest.printPrefix "MathObj.Gaussian.Bell:229: "+{-# LINE 229 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 229 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x)))+ DocTest.printPrefix "MathObj.Gaussian.Bell:244: "+{-# LINE 244 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 244 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x -> G.fourier x == G.fourierByTranslation x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:312: "+{-# LINE 312 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 312 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:326: "+{-# LINE 326 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 326 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:327: "+{-# LINE 327 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 327 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:341: "+{-# LINE 341 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 341 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:342: "+{-# LINE 342 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 342 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x)))+ DocTest.printPrefix "MathObj.Gaussian.Bell:361: "+{-# LINE 361 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 361 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x -> nest 2 G.reverse x == x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:369: "+{-# LINE 369 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 369 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:370: "+{-# LINE 370 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 370 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:381: "+{-# LINE 381 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 381 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x)+ DocTest.printPrefix "MathObj.Gaussian.Bell:382: "+{-# LINE 382 "gaussian/MathObj/Gaussian/Bell.hs" #-}+ DocTest.property+{-# LINE 382 "gaussian/MathObj/Gaussian/Bell.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x)
+ test/Test/MathObj/Gaussian/ExponentTuple.hs view
@@ -0,0 +1,26 @@+-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/ExponentTuple.hs+{-# LINE 14 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-}++module Test.MathObj.Gaussian.ExponentTuple where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 15 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-}+import     MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates))+import     MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates))+import     NumericPrelude.Base as P+import     NumericPrelude.Numeric as NP+import     Prelude ()++test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Gaussian.ExponentTuple:26: "+{-# LINE 26 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-}+ DocTest.property+{-# LINE 26 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-}+     (\(HoelderConjugates p q)  ->  p>=1 && q>=1 && 1/p + 1/q == 1)+ DocTest.printPrefix "MathObj.Gaussian.ExponentTuple:53: "+{-# LINE 53 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-}+ DocTest.property+{-# LINE 53 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-}+     (\(YoungConjugates p q r)  ->  p>=1 && q>=1 && r>=1 && 1/p + 1/q == 1/r + 1)
test/Test/MathObj/Gaussian/Polynomial.hs view
@@ -1,144 +1,215 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.Gaussian.Polynomial where--import qualified MathObj.Gaussian.Polynomial as G-import qualified MathObj.Gaussian.Bell as B--import qualified MathObj.Polynomial as Poly---- import qualified Algebra.Ring           as Ring--import qualified Algebra.Laws as Laws+-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/Polynomial.hs+{-# LINE 60 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} -import qualified Number.Complex as Complex+{-# OPTIONS_GHC -XRebindableSyntax #-} -import Test.NumericPrelude.Utility (testUnit)-import Test.QuickCheck (Testable, quickCheck, (==>))-import qualified Test.HUnit as HUnit+module Test.MathObj.Gaussian.Polynomial where -import qualified Number.NonNegative as NonNeg-import Data.Function.HT (nest, )-import Data.Tuple.HT (mapSnd, )+import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest --- import Debug.Trace (trace, )+{-# LINE 63 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+import     qualified MathObj.Gaussian.Polynomial as G+import     qualified MathObj.Gaussian.Bell as Bell+import     qualified MathObj.Polynomial as Poly+import     qualified Algebra.Laws as Laws+import     qualified Number.Complex as Complex+import     Number.Complex ((+:))+import     NumericPrelude.Base as P+import     NumericPrelude.Numeric as NP+import     qualified Test.QuickCheck as QC+import     Data.Function.HT (Id, nest)+import     Data.Tuple.HT (mapSnd) -import PreludeBase as P-import NumericPrelude as NP+asRational     :: Id (G.T Rational)+asRational     = id +withRational     :: Id (G.T Rational -> a)+withRational     = id -simple ::-   (Testable t) =>-   (G.T Rational -> t) -> IO ()-simple f =-   quickCheck (\x -> f (x :: G.T Rational))+mulLinear2i     :: Id (G.T Rational)+mulLinear2i     x =+       x{G.polynomial = Poly.fromCoeffs [0, 0+:2] * G.polynomial x} -tests :: HUnit.Test-tests =-   HUnit.TestLabel "polynomial" $-   HUnit.TestList $-   map testUnit $-   testList+rotateQuarter     :: Int -> Id (G.T Rational)+rotateQuarter     n =+       G.scaleComplex (negate Complex.imaginaryUnit ^ fromIntegral n) -testList :: [(String, IO ())]-testList =-{--      ("convolution, dirac",-          simple $ Laws.identity (+) zero) :--}-      ("convolution, commutative",-          simple $ Laws.commutative G.convolve) :---          simple $ \x -> Laws.commutative G.convolve (trace (show x) x)) :-      ("convolution, associative",-          simple $ Laws.associative G.convolve) :-      ("multiplication, one",-          simple $ Laws.identity G.multiply G.constant) :-      ("multiplication, commutative",-          simple $ Laws.commutative G.multiply) :-      ("multiplication, associative",-          simple $ Laws.associative G.multiply) :-      ("convolution, multplication, fourier",-          simple $ \x y ->-             G.fourier (G.convolve x y)-              == G.multiply (G.fourier x) (G.fourier y)) :-      ("fourier reverse",-          simple $ \x -> nest 2 G.fourier x == G.reverse x) :-      ("reverse identity",-          simple $ \x -> nest 2 G.reverse x == x) :-      ("fourier eigenfunction differential",-          quickCheck $ \m ->-             m <= 15 ==>-                let n = NonNeg.toNumber m-                    x = G.eigenfunctionDifferential n :: G.T Rational-                    k = Complex.conjugate Complex.imaginaryUnit ^ fromIntegral n-                in  G.fourier x  ==  G.scaleComplex k x) :-      ("fourier eigenfunction iterative",-          quickCheck $ \m ->-             m <= 15 ==>-                let n = NonNeg.toNumber m-                    x = G.eigenfunctionIterative n :: G.T Rational-                    k = Complex.conjugate Complex.imaginaryUnit ^ fromIntegral n-                in  G.fourier x  ==  G.scaleComplex k x) :-{- this does not hold, both functions compute different eigenbases-      ("fourier eigenfunction diff vs. iterative",-          quickCheck $ \n ->-             n <= 15 ==>-                G.eigenfunctionDifferential n ==-                (G.eigenfunctionIterative n :: G.T Rational)) :--}-      ("translate additive",-          simple $ \x a b ->-             G.translate a (G.translate b x) == G.translate (a+b) x) :-      ("translateComplex additive",-          simple $ \x a b ->-             G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x) :-      ("translateComplex real",-          simple $ \x a ->-             G.translateComplex (Complex.fromReal a) x == G.translate a x) :-      ("modulate additive",-          simple $ \x a b ->-             G.modulate a (G.modulate b x) == G.modulate (a+b) x) :-      ("commute translate modulate",-          simple $ \x a b ->-             G.modulate b (G.translate a x)-              == G.turn (a*b) (G.translate a (G.modulate b x))) :-      ("fourier translate",-          simple $ \x a ->-             G.fourier (G.translate a x)-              == G.modulate a (G.fourier x)) :-      ("dilate multiplicative",-          simple $ \x a b -> a>0 && b>0 ==>-             G.dilate a (G.dilate b x) == G.dilate (a*b) x) :-      ("dilate by shrink",-          simple $ \x a -> a>0 ==>-             G.shrink a x == G.dilate (recip a) x) :-      ("fourier dilate",-          simple $ \x a -> a>0 ==>-             G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) :-      ("integrate differentiate",-          simple $ \x ->-             G.integrate (G.differentiate x) == (zero, x)) :-      ("fourier differentiate",-          simple $ \x ->-             G.fourier (G.differentiate x) ==-              let y = G.fourier x-              in  y{G.polynomial =-                      Poly.fromCoeffs [0, 0 Complex.+: 2] * G.polynomial y}) :-      ("approximate by bells, translate",-          simple $ \x unit d -> unit/=0 ==>-             G.approximateByBells unit (G.translateComplex d x) ==-             map (mapSnd (B.translateComplex d)) (G.approximateByBells unit x)) :-      ("approximate by bells, dilate",-          simple $ \x unit d -> unit/=0 && d/=0 ==>-             G.approximateByBells unit (G.dilate d x) ==-             map (mapSnd (B.dilate d)) (G.approximateByBells (unit/d) x)) :-      ("approximate by bells, shrink",-          simple $ \x unit d -> unit/=0 && d/=0 ==>-             G.approximateByBells unit (G.shrink d x) ==-             map (mapSnd (B.shrink d)) (G.approximateByBells (unit*d) x)) :-      ("approximate by bells, different implementations",-          quickCheck $ \unit d s p -> unit/=0 ==>-             G.approximateByBellsAtOnce unit d s (p::Poly.T (Complex.T Rational)) ==-             G.approximateByBellsByTranslation unit d s p) :-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:185: "+{-# LINE 185 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 185 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (QC.forAll (QC.choose (0,3)) $ \n -> G.eigenfunctionDifferential n == asRational (G.eigenfunctionIterative n))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:193: "+{-# LINE 193 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 193 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+          (G.eigenfunction0  ==  asRational (G.eigenfunctionDifferential 0))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:198: "+{-# LINE 198 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 198 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+          (G.eigenfunction1  ==  asRational (G.eigenfunctionDifferential 1))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:203: "+{-# LINE 203 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 203 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+          (G.eigenfunction2  ==  asRational (G.eigenfunctionDifferential 2))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:208: "+{-# LINE 208 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 208 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+          (G.eigenfunction3  ==  asRational (G.eigenfunctionDifferential 3))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:215: "+{-# LINE 215 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 215 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionDifferential n in G.fourier x  ==  rotateQuarter n x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:224: "+{-# LINE 224 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 224 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionIterative n in G.fourier x  ==  rotateQuarter n x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:246: "+{-# LINE 246 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 246 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ Laws.identity G.multiply G.constant)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:247: "+{-# LINE 247 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 247 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ Laws.commutative G.multiply)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:248: "+{-# LINE 248 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 248 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ Laws.associative G.multiply)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:258: "+{-# LINE 258 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 258 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ Laws.commutative G.convolve)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:259: "+{-# LINE 259 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 259 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ Laws.associative G.convolve)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:301: "+{-# LINE 301 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 301 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:302: "+{-# LINE 302 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 302 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x -> nest 2 G.fourier x == G.reverse x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:303: "+{-# LINE 303 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 303 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:304: "+{-# LINE 304 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 304 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x)))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:305: "+{-# LINE 305 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 305 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x -> G.fourier (G.differentiate x) == mulLinear2i (G.fourier x))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:323: "+{-# LINE 323 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 323 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x y -> G.convolve (G.differentiate x) y == G.convolve x (G.differentiate y))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:348: "+{-# LINE 348 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 348 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x -> G.integrate (G.differentiate x) == (zero, x))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:349: "+{-# LINE 349 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 349 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x@(G.Cons b p) -> let (xoff,xint) = G.integrate x in G.differentiate xint == G.Cons b (p + Poly.const xoff))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:345: "+{-# LINE 345 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.example+{-# LINE 345 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+   (snd $ G.integrate $ G.differentiate $ G.Cons Bell.unit (Poly.fromCoeffs [7,7,7,7 :: Complex.T Rational]))+  [ExpectedLine [LineChunk "Cons {bell = Cons {amp = 1 % 1, c0 = 0 % 1 +: 0 % 1, c1 = 0 % 1 +: 0 % 1, c2 = 1 % 1}, polynomial = Polynomial.fromCoeffs [7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1]}"]]+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:409: "+{-# LINE 409 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 409 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:416: "+{-# LINE 416 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 416 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:417: "+{-# LINE 417 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 417 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:426: "+{-# LINE 426 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 426 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:427: "+{-# LINE 427 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 427 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x)))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:442: "+{-# LINE 442 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 442 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x -> nest 2 G.reverse x == x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:451: "+{-# LINE 451 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 451 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:452: "+{-# LINE 452 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 452 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:461: "+{-# LINE 461 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 461 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:462: "+{-# LINE 462 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 462 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x)+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:490: "+{-# LINE 490 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 490 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.NonZero unit) d -> G.approximateByBells unit (G.translateComplex d x) == map (mapSnd (Bell.translateComplex d)) (G.approximateByBells unit x))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:491: "+{-# LINE 491 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 491 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.dilate d x) == map (mapSnd (Bell.dilate d)) (G.approximateByBells (unit/d) x))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:492: "+{-# LINE 492 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 492 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.shrink d x) == map (mapSnd (Bell.shrink d)) (G.approximateByBells (unit*d) x))+ DocTest.printPrefix "MathObj.Gaussian.Polynomial:512: "+{-# LINE 512 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+ DocTest.property+{-# LINE 512 "gaussian/MathObj/Gaussian/Polynomial.hs" #-}+     (\(QC.NonZero unit) d s p0 -> let p = Poly.fromCoeffs $ take 10 p0 in G.approximateByBellsAtOnce unit d s p == G.approximateByBellsByTranslation unit d (s::Rational) p)
test/Test/MathObj/Gaussian/Variance.hs view
@@ -1,62 +1,142 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.Gaussian.Variance where--import qualified MathObj.Gaussian.Variance as G---- import qualified Algebra.Ring           as Ring--import qualified Algebra.Laws as Laws+-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/Variance.hs+{-# LINE 34 "gaussian/MathObj/Gaussian/Variance.hs" #-} -import Test.NumericPrelude.Utility (testUnit)-import Test.QuickCheck (Testable, quickCheck, (==>))-import qualified Test.HUnit as HUnit+module Test.MathObj.Gaussian.Variance where -import Data.Function.HT (nest, )+import qualified Test.DocTest.Driver as DocTest -import PreludeBase as P-import NumericPrelude as NP+{-# LINE 35 "gaussian/MathObj/Gaussian/Variance.hs" #-}+import     qualified MathObj.Gaussian.Variance as G+import     MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates))+import     MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates))+import     qualified Algebra.Laws as Laws+import     qualified Number.Root as Root+import     NumericPrelude.Base as P+import     NumericPrelude.Numeric as NP+import     Prelude ()+import     qualified Test.QuickCheck as QC+import     Data.Function.HT (Id, nest) +asRational     :: Id (G.T Rational)+asRational     = id -simple ::-   (Testable t) =>-   (G.T Rational -> t) -> IO ()-simple f =-   quickCheck (\x -> f (x :: G.T Rational))+withRational     :: Id (G.T Rational -> a)+withRational     = id -tests :: HUnit.Test-tests =-   HUnit.TestLabel "polynomial" $-   HUnit.TestList $-   map testUnit $-{--      ("convolution, dirac",-          simple $ Laws.identity (+) zero) :--}-      ("convolution, commutative",-          simple $ Laws.commutative G.convolve) :-      ("convolution, associative",-          simple $ Laws.associative G.convolve) :-      ("multiplication, one",-          simple $ Laws.identity G.multiply G.constant) :-      ("multiplication, commutative",-          simple $ Laws.commutative G.multiply) :-      ("multiplication, associative",-          simple $ Laws.associative G.multiply) :-      ("convolution via fourier",-          simple $ \x y ->-             G.fourier (G.convolve x y)-              == G.multiply (G.fourier x) (G.fourier y)) :-      ("fourier identity",-          simple $ \x -> nest 4 G.fourier x == x) :-      ("dilate multiplicative",-          simple $ \x a b -> a>0 && b>0 ==>-             G.dilate a (G.dilate b x) == G.dilate (a*b) x) :-      ("dilate by shrink",-          simple $ \x a -> a>0 ==>-             G.shrink a x == G.dilate (recip a) x) :-      ("fourier dilate",-          simple $ \x a -> a>0 ==>-             G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) :-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Gaussian.Variance:95: "+{-# LINE 95 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 95 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y -> G.scalarProductRoot x y <= G.norm2Root x `Root.mul` G.norm2Root y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:99: "+{-# LINE 99 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 99 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y -> G.scalarProductRoot x y <= G.norm1Root x `Root.mul` G.normInfRoot y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:100: "+{-# LINE 100 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 100 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y (HoelderConjugates p q) -> G.scalarProductRoot x y <= G.normPRoot p x `Root.mul` G.normPRoot q y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:108: "+{-# LINE 108 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 108 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x -> G.norm1Root x == G.normPRoot 1 x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:114: "+{-# LINE 114 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 114 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x -> G.norm2Root x == G.normPRoot 2 x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:186: "+{-# LINE 186 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 186 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.varianceRational (G.dilate a x) == a^2 * G.varianceRational x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:187: "+{-# LINE 187 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 187 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y -> G.varianceRational (G.convolve x y) == G.varianceRational x + G.varianceRational y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:193: "+{-# LINE 193 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 193 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (Laws.identity G.multiply G.constant . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Variance:194: "+{-# LINE 194 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 194 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (Laws.commutative G.multiply . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Variance:195: "+{-# LINE 195 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 195 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (Laws.associative G.multiply . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Variance:228: "+{-# LINE 228 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 228 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (Laws.commutative G.convolve . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Variance:229: "+{-# LINE 229 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 229 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (Laws.associative G.convolve . asRational)+ DocTest.printPrefix "MathObj.Gaussian.Variance:233: "+{-# LINE 233 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 233 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y -> G.normInfRoot (G.convolve x y) <= G.norm1Root x `Root.mul` G.normInfRoot y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:234: "+{-# LINE 234 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 234 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y (HoelderConjugates p q) -> G.normInfRoot (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:235: "+{-# LINE 235 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 235 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y (YoungConjugates p q r) -> G.normPRoot r (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y)+ DocTest.printPrefix "MathObj.Gaussian.Variance:251: "+{-# LINE 251 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 251 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y))+ DocTest.printPrefix "MathObj.Gaussian.Variance:252: "+{-# LINE 252 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 252 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x -> nest 4 G.fourier x == x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:253: "+{-# LINE 253 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 253 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x)))+ DocTest.printPrefix "MathObj.Gaussian.Variance:254: "+{-# LINE 254 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 254 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x y -> G.scalarProductRoot x y == G.scalarProductRoot (G.fourier x) (G.fourier y))+ DocTest.printPrefix "MathObj.Gaussian.Variance:265: "+{-# LINE 265 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 265 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:266: "+{-# LINE 266 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 266 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:273: "+{-# LINE 273 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 273 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x)+ DocTest.printPrefix "MathObj.Gaussian.Variance:274: "+{-# LINE 274 "gaussian/MathObj/Gaussian/Variance.hs" #-}+ DocTest.property+{-# LINE 274 "gaussian/MathObj/Gaussian/Variance.hs" #-}+     (withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x)
test/Test/MathObj/Matrix.hs view
@@ -1,96 +1,122 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.Matrix where--import qualified MathObj.Matrix as Matrix--import qualified Algebra.Ring           as Ring+-- Do not edit! Automatically created with doctest-extract from src/MathObj/Matrix.hs+{-# LINE 71 "src/MathObj/Matrix.hs" #-} -import qualified Algebra.Laws as Laws+module Test.MathObj.Matrix where -import qualified Number.NonNegative as NonNeg+import qualified Test.DocTest.Driver as DocTest -import qualified System.Random as Random+{-# LINE 72 "src/MathObj/Matrix.hs" #-}+import     qualified MathObj.Matrix as Matrix+import     qualified Algebra.Ring as Ring+import     qualified Algebra.Laws as Laws+import     Test.NumericPrelude.Utility ((/\))+import     qualified Test.QuickCheck as QC+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base as P+import     Prelude () -import Test.NumericPrelude.Utility (testUnit, )-import Test.QuickCheck (quickCheck, )-import qualified Test.HUnit as HUnit+import     Control.Monad (replicateM, join)+import     Control.Applicative (liftA2)+import     Data.Function.HT (nest) +genDimension     :: QC.Gen Int+genDimension     = QC.choose (0,20) -import PreludeBase as P-import NumericPrelude as NP+genMatrixFor     :: (QC.Arbitrary a) => Int -> Int -> QC.Gen (Matrix.T a)+genMatrixFor     m n =+       fmap (Matrix.fromList m n) $ replicateM (m*n) QC.arbitrary +genMatrix     :: (QC.Arbitrary a) => QC.Gen (Matrix.T a)+genMatrix     = join $ liftA2 genMatrixFor genDimension genDimension -type Seed = Int-type Dimension = NonNeg.Int+genIntMatrix     :: QC.Gen (Matrix.T Integer)+genIntMatrix     = genMatrix -random :: Dimension -> Dimension -> Seed -> Matrix.T Integer-random mn nn seed =-   fst $-   Matrix.random (NonNeg.toNumber mn) (NonNeg.toNumber nn) $-   Random.mkStdGen seed+genFactorMatrix     :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a)+genFactorMatrix     a = genMatrixFor (Matrix.numColumns a) =<< genDimension +genSameMatrix     :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a)+genSameMatrix     = uncurry genMatrixFor . Matrix.dimension -tests :: HUnit.Test-tests =-   HUnit.TestLabel "matrix" $-   HUnit.TestList $-   map testUnit $-      ("dimension",-          quickCheck (\m n a ->-             (NonNeg.toNumber m, NonNeg.toNumber n) == Matrix.dimension (random m n a))) :-      ("to and from rows",-          quickCheck (\m n a' ->-             let a = random m n a'-             in  a == Matrix.fromRows (NonNeg.toNumber m) (NonNeg.toNumber n) (Matrix.rows a))) :-      ("to and from columns",-          quickCheck (\m n a' ->-             let a = random m n a'-             in  a == Matrix.fromColumns (NonNeg.toNumber m) (NonNeg.toNumber n) (Matrix.columns a))) :-      ("transpose, rows, columns",-          quickCheck (\m n a' ->-             let a = random m n a'-             in  Matrix.rows a == Matrix.columns (Matrix.transpose a))) :-      ("transpose, columns, rows",-          quickCheck (\m n a' ->-             let a = random m n a'-             in  Matrix.columns a == Matrix.rows (Matrix.transpose a))) :-      ("addition, zero",-          quickCheck (\m n a ->-             Laws.identity (+) (Matrix.zero (NonNeg.toNumber m) (NonNeg.toNumber n)) (random m n a))) :-      ("addition, commutative",-          quickCheck (\m n a b ->-             Laws.commutative (+) (random m n a) (random m n b))) :-      ("addition, associative",-          quickCheck (\m n a b c ->-             Laws.associative (+) (random m n a) (random m n b) (random m n c))) :-      ("addition, transpose",-          quickCheck (\m n a b ->-             Laws.homomorphism Matrix.transpose (+) (+) (random m n a) (random m n b))) :-      ("one, diagonal",-          quickCheck (\n' ->-             let n = NonNeg.toNumber n'-             in Matrix.one n == (Matrix.diagonal $ replicate n Ring.one :: Matrix.T Integer))) :-      ("multiplication, one left",-          quickCheck (\m n a ->-             Laws.leftIdentity  (*) (Matrix.one (NonNeg.toNumber m)) (random m n a))) :-      ("multiplication, one right",-          quickCheck (\m n a ->-             Laws.rightIdentity (*) (Matrix.one (NonNeg.toNumber n)) (random m n a))) :-      ("multiplication, associative",-          quickCheck (\k l m n a b c ->-             Laws.associative (*) (random k l a) (random l m b) (random m n c))) :-      ("multiplication and addition, distributive left",-          quickCheck (\l m n a b c ->-             Laws.leftDistributive (*) (+) (random n l a) (random m n b) (random m n c))) :-      ("multiplication and addition, distributive right",-          quickCheck (\l m n a b c ->-             Laws.rightDistributive (*) (+) (random l m a) (random m n b) (random m n c))) :-      ("multiplication, transpose",-          quickCheck (\l m n a b ->-             Laws.homomorphism Matrix.transpose (*) (flip (*)) (random l m a) (random m n b))) :-{--      ("division",       quickCheck (\x -> Integral.propInverse (x :: Poly.T Rational))) :--}-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Matrix:118: "+{-# LINE 118 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 118 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> Matrix.rows a == Matrix.columns (Matrix.transpose a))+ DocTest.printPrefix "MathObj.Matrix:119: "+{-# LINE 119 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 119 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> Matrix.columns a == Matrix.rows (Matrix.transpose a))+ DocTest.printPrefix "MathObj.Matrix:120: "+{-# LINE 120 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 120 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (+) (+) a b)+ DocTest.printPrefix "MathObj.Matrix:141: "+{-# LINE 141 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 141 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> a == uncurry Matrix.fromRows (Matrix.dimension a) (Matrix.rows a))+ DocTest.printPrefix "MathObj.Matrix:152: "+{-# LINE 152 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 152 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> a == uncurry Matrix.fromColumns (Matrix.dimension a) (Matrix.columns a))+ DocTest.printPrefix "MathObj.Matrix:195: "+{-# LINE 195 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 195 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.commutative (+) a b)+ DocTest.printPrefix "MathObj.Matrix:196: "+{-# LINE 196 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 196 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> genSameMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.associative (+) a b c)+ DocTest.printPrefix "MathObj.Matrix:212: "+{-# LINE 212 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 212 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> Laws.identity (+) (uncurry Matrix.zero $ Matrix.dimension a) a)+ DocTest.printPrefix "MathObj.Matrix:228: "+{-# LINE 228 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 228 "src/MathObj/Matrix.hs" #-}+     (genDimension /\ \n -> Matrix.one n == Matrix.diagonal (replicate n Ring.one :: [Integer]))+ DocTest.printPrefix "MathObj.Matrix:242: "+{-# LINE 242 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 242 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> Laws.leftIdentity  (*) (Matrix.one (Matrix.numRows a)) a)+ DocTest.printPrefix "MathObj.Matrix:243: "+{-# LINE 243 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 243 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> Laws.rightIdentity (*) (Matrix.one (Matrix.numColumns a)) a)+ DocTest.printPrefix "MathObj.Matrix:244: "+{-# LINE 244 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 244 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (*) (flip (*)) a b)+ DocTest.printPrefix "MathObj.Matrix:245: "+{-# LINE 245 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 245 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genFactorMatrix b /\ \c -> Laws.associative (*) a b c)+ DocTest.printPrefix "MathObj.Matrix:246: "+{-# LINE 246 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 246 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \b -> genSameMatrix b /\ \c -> genFactorMatrix b /\ \a -> Laws.leftDistributive (*) (+) a b c)+ DocTest.printPrefix "MathObj.Matrix:247: "+{-# LINE 247 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 247 "src/MathObj/Matrix.hs" #-}+     (genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.rightDistributive (*) (+) a b c)+ DocTest.printPrefix "MathObj.Matrix:248: "+{-# LINE 248 "src/MathObj/Matrix.hs" #-}+ DocTest.property+{-# LINE 248 "src/MathObj/Matrix.hs" #-}+     (QC.choose (0,10) /\ \k -> genDimension /\ \n -> genMatrixFor n n /\ \a -> a^k == nest (fromInteger k) ((a::Matrix.T Integer)*) (Matrix.one n))
test/Test/MathObj/PartialFraction.hs view
@@ -1,205 +1,137 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.PartialFraction where--import qualified MathObj.PartialFraction      as PartialFraction-import qualified MathObj.Polynomial           as Poly-import qualified Number.Ratio                 as Ratio--import qualified Algebra.PrincipalIdealDomain as PID-import qualified Algebra.Ring                 as Ring-import qualified Algebra.Indexable            as Indexable-import qualified Algebra.Vector               as Vector--- import Algebra.Vector((*>))--import qualified Algebra.Laws as Laws-import qualified Test.QuickCheck as QC--import Control.Monad.HT as M-import Test.NumericPrelude.Utility (testUnit)-import Test.QuickCheck (quickCheck)-import qualified Test.HUnit as HUnit---import PreludeBase as P-import NumericPrelude as NP---{- * Properties for generic types -}--fractionConv :: (PID.C a, Indexable.C a) => [a] -> a -> Bool-fractionConv xs y =-   PartialFraction.toFraction (PartialFraction.fromFactoredFraction xs y) ==-   y % product xs--fractionConvAlt :: (PID.C a, Indexable.C a) => [a] -> a -> Bool-fractionConvAlt xs y =-   PartialFraction.fromFactoredFraction xs y ==-   PartialFraction.fromFactoredFractionAlt xs y--scaleInt :: (PID.C a, Indexable.C a) => a -> PartialFraction.T a -> Bool-scaleInt k a =-   PartialFraction.toFraction (PartialFraction.scaleInt k a) ==-   Ratio.scale k (PartialFraction.toFraction a)--add :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool-add = Laws.homomorphism PartialFraction.toFraction (+) (+)--sub :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool-sub = Laws.homomorphism PartialFraction.toFraction (-) (-)--mul :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool-mul = Laws.homomorphism PartialFraction.toFraction (*) (*)----{- * Properties for Integers -}--{- |-Arbitrary instance of that type generates irreducible elements for tests.-Choosing from a list of examples is a simple yet effective design.-If we would construct irreducible elements by a clever algorithm-we might obtain multiple primes only rarely.--}-newtype SmallPrime = SmallPrime {intFromSmallPrime :: Integer}--type IntFraction = ([SmallPrime],Integer)--instance QC.Arbitrary SmallPrime where-   arbitrary =-      let primes = [2,3,5,7,11,13]-      in  fmap SmallPrime $ QC.elements (primes ++ map negate primes)--instance Show SmallPrime where-   show = show . intFromSmallPrime---fractionConvInt :: [SmallPrime] -> Integer -> Bool-fractionConvInt =-   fractionConv . map intFromSmallPrime--fractionConvAltInt :: [SmallPrime] -> Integer -> Bool-fractionConvAltInt =-   fractionConvAlt . map intFromSmallPrime--fromSmallPrimes :: IntFraction -> PartialFraction.T Integer-fromSmallPrimes (xs,y) =-   PartialFraction.fromFactoredFraction (map intFromSmallPrime xs) y---scaleIntInt :: Integer -> IntFraction -> Bool-scaleIntInt k a =-   scaleInt k (fromSmallPrimes a)--addInt :: IntFraction -> IntFraction -> Bool-addInt q0 q1 =-   add-      (fromSmallPrimes q0)-      (fromSmallPrimes q1)--subInt :: IntFraction -> IntFraction -> Bool-subInt q0 q1 =-   sub-      (fromSmallPrimes q0)-      (fromSmallPrimes q1)--mulInt :: IntFraction -> IntFraction -> Bool-mulInt q0 q1 =-   mul-      (fromSmallPrimes q0)-      (fromSmallPrimes q1)---intTests :: HUnit.Test-intTests =-   HUnit.TestLabel "integer" $-   HUnit.TestList $-   map testUnit $-      ("conversion between partial and ordinary fraction", quickCheck fractionConvInt) :-      ("two conversion routines from factored fractions", quickCheck fractionConvAltInt) :-      ("integer scaling", quickCheck scaleIntInt) :-      ("addition", quickCheck addInt) :-      ("subtraction", quickCheck subInt) :-      ("multiplication", quickCheck mulInt) :-      []+-- Do not edit! Automatically created with doctest-extract from src/MathObj/PartialFraction.hs+{-# LINE 45 "src/MathObj/PartialFraction.hs" #-} +module Test.MathObj.PartialFraction where -{- * Properties for Polynomials -}+import qualified Test.DocTest.Driver as DocTest -newtype IrredPoly = IrredPoly {polyFromIrredPoly :: Poly.T Rational}+{-# LINE 46 "src/MathObj/PartialFraction.hs" #-}+import     qualified MathObj.PartialFraction as PartialFraction+import     qualified MathObj.Polynomial.Core as PolyCore+import     qualified MathObj.Polynomial as Poly+import     qualified Algebra.PrincipalIdealDomain as PID+import     qualified Algebra.Indexable as Indexable+import     qualified Algebra.Laws as Laws+import     qualified Number.Ratio as Ratio+import     Test.NumericPrelude.Utility ((/\))+import     qualified Test.QuickCheck as QC+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base as P+import     Prelude () -type RatPolynomial = Poly.T Rational-type PolyFraction = ([IrredPoly],RatPolynomial)+import     Control.Applicative (liftA2) -instance QC.Arbitrary IrredPoly where-   arbitrary =-      do poly <- QC.elements (map Poly.fromCoeffs [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]])-         unit <- M.until (not. isZero) QC.arbitrary-         return (IrredPoly (unit Vector.*> poly))+{-     |+Generator     of irreducible elements for tests.+Choosing     from a list of examples is a simple yet effective design.+If     we would construct irreducible elements by a clever algorithm+we     might obtain multiple primes only rarely.+-}     --+genSmallPrime     :: QC.Gen Integer+genSmallPrime     =+       let primes = [2,3,5,7,11,13]+       in  QC.elements (primes ++ map negate primes) -instance Show IrredPoly where-   show = show . polyFromIrredPoly+genPartialFractionInt     :: QC.Gen (PartialFraction.T Integer)+genPartialFractionInt     =+       liftA2 PartialFraction.fromFactoredFraction+          (QC.listOf genSmallPrime) QC.arbitrary  -fractionConvPoly :: [IrredPoly] -> RatPolynomial -> Bool-fractionConvPoly =-   fractionConv . map polyFromIrredPoly--fractionConvAltPoly :: [IrredPoly] -> RatPolynomial -> Bool-fractionConvAltPoly =-   fractionConvAlt . map polyFromIrredPoly+genIrreduciblePolynomial     :: QC.Gen (Poly.T Rational)+genIrreduciblePolynomial     = do+       QC.NonZero unit <- QC.arbitrary+       fmap (Poly.fromCoeffs . map (unit*)) $+          QC.elements [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]] -fromIrredPolys :: PolyFraction -> PartialFraction.T RatPolynomial-fromIrredPolys (xs,y) =-   PartialFraction.fromFactoredFraction (map polyFromIrredPoly xs) y+genPartialFractionPoly     :: QC.Gen (PartialFraction.T (Poly.T Rational))+genPartialFractionPoly     =+       liftA2 PartialFraction.fromFactoredFraction+          (fmap (take 3) $ QC.listOf genIrreduciblePolynomial)+          (fmap (Poly.fromCoeffs . PolyCore.normalize . take 5) QC.arbitrary)  -scaleIntPoly :: RatPolynomial -> PolyFraction -> Bool-scaleIntPoly k a =-   scaleInt k (fromIrredPolys a)--addPoly :: PolyFraction -> PolyFraction -> Bool-addPoly q0 q1 =-   add-      (fromIrredPolys q0)-      (fromIrredPolys q1)--subPoly :: PolyFraction -> PolyFraction -> Bool-subPoly q0 q1 =-   sub-      (fromIrredPolys q0)-      (fromIrredPolys q1)--mulPoly :: PolyFraction -> PolyFraction -> Bool-mulPoly q0 q1 =-   mul-      (fromIrredPolys q0)-      (fromIrredPolys q1)-+fractionConv     :: (PID.C a, Indexable.C a) => [a] -> a -> Bool+fractionConv     xs y =+       PartialFraction.toFraction (PartialFraction.fromFactoredFraction xs y) ==+       y % product xs +fractionConvAlt     :: (PID.C a, Indexable.C a) => [a] -> a -> Bool+fractionConvAlt     xs y =+       PartialFraction.fromFactoredFraction xs y ==+       PartialFraction.fromFactoredFractionAlt xs y -polyTests :: HUnit.Test-polyTests =-   HUnit.TestLabel "polynomial" $-   HUnit.TestList $-   map testUnit $-{- this test fails, because addition may result in leading zero coefficients,-      that is, polynomial addition does not contain a normalization-      if it would contain one, we would exclude computable reals -}--- wrong     ("conversion between partial and ordinary fraction", quickCheck fractionConvPoly) :--- wrong     ("two conversion routines from factored fractions", quickCheck fractionConvAltPoly) :--- too slow      ("integer scaling", quickCheck scaleIntPoly) :--- too slow      ("addition", quickCheck addPoly) :--- too slow      ("subtraction", quickCheck subPoly) :--- too slow      ("multiplication", quickCheck mulPoly) :-      []+scaleInt     :: (PID.C a, Indexable.C a) => a -> PartialFraction.T a -> Bool+scaleInt     k a =+       PartialFraction.toFraction (PartialFraction.scaleInt k a) ==+       Ratio.scale k (PartialFraction.toFraction a) +add,     sub, mul ::+       (PID.C a, Indexable.C a) =>+       PartialFraction.T a -> PartialFraction.T a -> Bool+add     = Laws.homomorphism PartialFraction.toFraction (+) (+)+sub     = Laws.homomorphism PartialFraction.toFraction (-) (-)+mul     = Laws.homomorphism PartialFraction.toFraction (*) (*) -tests :: HUnit.Test-tests =-   HUnit.TestLabel "partial fraction" $-   HUnit.TestList $-      intTests :---      polyTests :-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.PartialFraction:195: "+{-# LINE 195 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 195 "src/MathObj/PartialFraction.hs" #-}+     (QC.listOf genSmallPrime /\ fractionConv)+ DocTest.printPrefix "MathObj.PartialFraction:196: "+{-# LINE 196 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 196 "src/MathObj/PartialFraction.hs" #-}+     (fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConv)+ DocTest.printPrefix "MathObj.PartialFraction:220: "+{-# LINE 220 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 220 "src/MathObj/PartialFraction.hs" #-}+     (QC.listOf genSmallPrime /\ fractionConvAlt)+ DocTest.printPrefix "MathObj.PartialFraction:221: "+{-# LINE 221 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 221 "src/MathObj/PartialFraction.hs" #-}+     (fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConvAlt)+ DocTest.printPrefix "MathObj.PartialFraction:297: "+{-# LINE 297 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 297 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> add x y)+ DocTest.printPrefix "MathObj.PartialFraction:298: "+{-# LINE 298 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 298 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> sub x y)+ DocTest.printPrefix "MathObj.PartialFraction:300: "+{-# LINE 300 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 300 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> add x y)+ DocTest.printPrefix "MathObj.PartialFraction:301: "+{-# LINE 301 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 301 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> sub x y)+ DocTest.printPrefix "MathObj.PartialFraction:429: "+{-# LINE 429 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 429 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionInt /\ \x k -> scaleInt k x)+ DocTest.printPrefix "MathObj.PartialFraction:430: "+{-# LINE 430 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 430 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionPoly /\ \x k -> scaleInt k x)+ DocTest.printPrefix "MathObj.PartialFraction:449: "+{-# LINE 449 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 449 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> mul x y)+ DocTest.printPrefix "MathObj.PartialFraction:450: "+{-# LINE 450 "src/MathObj/PartialFraction.hs" #-}+ DocTest.property+{-# LINE 450 "src/MathObj/PartialFraction.hs" #-}+     (genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> mul x y)
test/Test/MathObj/Polynomial.hs view
@@ -1,57 +1,63 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.Polynomial where--import qualified MathObj.Polynomial as Poly--import qualified Algebra.IntegralDomain as Integral-import qualified Algebra.Ring           as Ring--import qualified Algebra.ZeroTestable   as ZeroTestable-import qualified Algebra.Laws as Laws--import qualified Data.List as List--import Test.NumericPrelude.Utility (testUnit)-import Test.QuickCheck (Property, quickCheck, (==>), Testable, )-import qualified Test.HUnit as HUnit---import PreludeBase as P-import NumericPrelude as NP---tensorProductTranspose :: (Ring.C a, Eq a) => [a] -> [a] -> Property-tensorProductTranspose xs ys =-   not (null xs) && not (null ys) ==>-      Poly.tensorProduct xs ys == List.transpose (Poly.tensorProduct ys xs)-+-- Do not edit! Automatically created with doctest-extract from src/MathObj/Polynomial.hs+{-# LINE 84 "src/MathObj/Polynomial.hs" #-} -mul :: (Ring.C a, Eq a, ZeroTestable.C a) => [a] -> [a] -> Bool-mul xs ys  =  Poly.equal (Poly.mul xs ys) (Poly.mulShear xs ys)+module Test.MathObj.Polynomial where +import qualified Test.DocTest.Driver as DocTest -test :: Testable a => (Poly.T Integer -> a) -> IO ()-test = quickCheck+{-# LINE 85 "src/MathObj/Polynomial.hs" #-}+import     qualified MathObj.Polynomial as Poly+import     qualified Algebra.IntegralDomain as Integral+import     qualified Algebra.Laws as Laws+import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude () -testRat :: Testable a => (Poly.T Rational -> a) -> IO ()-testRat = quickCheck+intPoly     :: Poly.T Integer -> Poly.T Integer+intPoly     = id +ratioPoly     :: Poly.T Rational -> Poly.T Rational+ratioPoly     = id -tests :: HUnit.Test-tests =-   HUnit.TestLabel "polynomial" $-   HUnit.TestList $-   map testUnit $-      ("tensor product", quickCheck (tensorProductTranspose :: [Integer] -> [Integer] -> Property)) :-      ("mul speed",      quickCheck (mul                    :: [Integer] -> [Integer] -> Bool)) :-      ("addition, zero",         test (Laws.identity (+) zero)) :-      ("addition, commutative",  test (Laws.commutative (+))) :-      ("addition, associative",  test (Laws.associative (+))) :-      ("multiplication, one",          test (Laws.identity (*) one)) :-      ("multiplication, commutative",  test (Laws.commutative (*))) :-      ("multiplication, associative",  test (Laws.associative (*))) :-      ("multiplication and addition, distributive",   test (Laws.leftDistributive (*) (+))) :-      ("division",       testRat (Integral.propInverse)) :-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Polynomial:100: "+{-# LINE 100 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 100 "src/MathObj/Polynomial.hs" #-}+     (Laws.identity (+) zero . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:101: "+{-# LINE 101 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 101 "src/MathObj/Polynomial.hs" #-}+     (Laws.commutative (+) . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:102: "+{-# LINE 102 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 102 "src/MathObj/Polynomial.hs" #-}+     (Laws.associative (+) . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:103: "+{-# LINE 103 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 103 "src/MathObj/Polynomial.hs" #-}+     (Laws.identity (*) one . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:104: "+{-# LINE 104 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 104 "src/MathObj/Polynomial.hs" #-}+     (Laws.commutative (*) . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:105: "+{-# LINE 105 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 105 "src/MathObj/Polynomial.hs" #-}+     (Laws.associative (*) . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:106: "+{-# LINE 106 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 106 "src/MathObj/Polynomial.hs" #-}+     (Laws.leftDistributive (*) (+) . intPoly)+ DocTest.printPrefix "MathObj.Polynomial:107: "+{-# LINE 107 "src/MathObj/Polynomial.hs" #-}+ DocTest.property+{-# LINE 107 "src/MathObj/Polynomial.hs" #-}+     (Integral.propInverse . ratioPoly)
+ test/Test/MathObj/Polynomial/Core.hs view
@@ -0,0 +1,51 @@+-- Do not edit! Automatically created with doctest-extract from src/MathObj/Polynomial/Core.hs+{-# LINE 47 "src/MathObj/Polynomial/Core.hs" #-}++module Test.MathObj.Polynomial.Core where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 48 "src/MathObj/Polynomial/Core.hs" #-}+import     qualified MathObj.Polynomial.Core as PolyCore+import     qualified MathObj.Polynomial as Poly+import     qualified Data.List as List+import     qualified Test.QuickCheck as QC+import     Test.QuickCheck ((==>))+import     Data.Tuple.HT (mapPair, mapSnd)+import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude ()++intPoly     :: [Integer] -> [Integer]+intPoly     = id++ratioPoly     :: [Rational] -> [Rational]+ratioPoly     = id++test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.Polynomial.Core:136: "+{-# LINE 136 "src/MathObj/Polynomial/Core.hs" #-}+ DocTest.property+{-# LINE 136 "src/MathObj/Polynomial/Core.hs" #-}+     (\(QC.NonEmpty xs) (QC.NonEmpty ys) -> PolyCore.tensorProduct xs ys == List.transpose (PolyCore.tensorProduct ys (intPoly xs)))+ DocTest.printPrefix "MathObj.Polynomial.Core:161: "+{-# LINE 161 "src/MathObj/Polynomial/Core.hs" #-}+ DocTest.property+{-# LINE 161 "src/MathObj/Polynomial/Core.hs" #-}+     (\xs ys  ->  PolyCore.equal (intPoly $ PolyCore.mul xs ys) (PolyCore.mulShear xs ys))+ DocTest.printPrefix "MathObj.Polynomial.Core:173: "+{-# LINE 173 "src/MathObj/Polynomial/Core.hs" #-}+ DocTest.property+{-# LINE 173 "src/MathObj/Polynomial/Core.hs" #-}+     (\x y -> case (PolyCore.normalize x, PolyCore.normalize y) of (nx, ny) -> not (null (ratioPoly ny)) ==> mapSnd PolyCore.normalize (PolyCore.divMod nx ny) == mapPair (PolyCore.normalize, PolyCore.normalize) (PolyCore.divMod x y))+ DocTest.printPrefix "MathObj.Polynomial.Core:174: "+{-# LINE 174 "src/MathObj/Polynomial/Core.hs" #-}+ DocTest.property+{-# LINE 174 "src/MathObj/Polynomial/Core.hs" #-}+     (\x y -> not (isZero (ratioPoly y)) ==> let z = fst $ PolyCore.divMod (Poly.coeffs x) y in  PolyCore.normalize z == z)+ DocTest.printPrefix "MathObj.Polynomial.Core:175: "+{-# LINE 175 "src/MathObj/Polynomial/Core.hs" #-}+ DocTest.property+{-# LINE 175 "src/MathObj/Polynomial/Core.hs" #-}+     (\x y -> case PolyCore.normalize $ ratioPoly y of ny -> not (null ny) ==> List.length (snd $ PolyCore.divMod x y) < List.length ny)
test/Test/MathObj/PowerSeries.hs view
@@ -1,103 +1,23 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Test.MathObj.PowerSeries where--import qualified MathObj.PowerSeries         as PS-import qualified MathObj.PowerSeries.Example as PSE--import Test.NumericPrelude.Utility (equalInfLists {- , testUnit -} )--- import Test.QuickCheck (Property, quickCheck, (==>))-import qualified Test.HUnit as HUnit---import PreludeBase as P-import NumericPrelude as NP---identitiesExplODE, identitiesSeriesFunction, identitiesInverses ::-   [(String, Int, [Rational],[Rational])]--identitiesExplODE =-   ("exp",   500, PSE.expExpl,   PSE.expODE) :-   ("sin",   500, PSE.sinExpl,   PSE.sinODE) :-   ("cos",   500, PSE.cosExpl,   PSE.cosODE) :-   ("tan",    50, PSE.tanExpl,   PSE.tanODE) :-   ("tan",    50, PSE.tanExpl,   PSE.tanExplSieve) :-   ("tan",    50, PSE.tanODE,    PSE.tanODESieve) :-   ("log",   500, PSE.logExpl,   PSE.logODE) :-   ("asin",   50, PSE.asinODE,   snd (PS.inv PSE.sinODE)) :-   ("atan",  500, PSE.atanExpl,  PSE.atanODE) :-   ("sinh",  500, PSE.sinhExpl,  PSE.sinhODE) :-   ("cosh",  500, PSE.coshExpl,  PSE.coshODE) :-   ("atanh", 500, PSE.atanhExpl, PSE.atanhODE) :-   ("sqrt",  100, PSE.sqrtExpl,  PSE.sqrtODE) :-   []--identitiesSeriesFunction =-   ("exp",   500, PSE.expExpl,  PS.exp (\0 -> 1) [0,1]) :-   ("sin",   500, PSE.sinExpl,  PS.sin (\0 -> (0,1)) [0,1]) :-   ("cos",   500, PSE.cosExpl,  PS.cos (\0 -> (0,1)) [0,1]) :-   ("tan",    50, PSE.tanExpl,  PS.tan (\0 -> (0,1)) [0,1]) :-   ("sqrt",   50, PSE.sqrtExpl, PS.sqrt (\1 -> 1) [1,1]) :-   ("power", 500, PSE.powExpl (-1/3), PS.pow (\1 -> 1) (-1/3) [1,1]) :-   ("power",  50, PSE.powExpl (-1/3), PS.exp (\0 -> 1) (PS.scale (-1/3) PSE.log)) :-   ("log",   500, PSE.logExpl, PS.log (\1 -> 0) [1,1]) :-   ("asin",   50, PSE.asin, PS.asin (\1 -> 1) (\0 -> 0) [0,1]) :- --  ("acos",  50, PSE.acos, PS.acos (\1 -> 1) (\0 -> pi/2) [0,1]) :-   ("atan",  500, PSE.atan, PS.atan (\0 -> 0) [0,1]) :-   []--identitiesInverses =-   ("exp",   100, 1:1:repeat 0, PS.exp  (\0 -> 1) PSE.log) :-   ("log",   100, 0:1:repeat 0, PS.log  (\1 -> 0) PSE.exp) :-   ("tan",    50, 0:1:repeat 0, PS.tan  (\0 -> (0,1)) PSE.atan) :-   ("atan",   50, 0:1:repeat 0, PS.atan (\0 -> 0) PSE.tan) :-   ("sin",    50, 0:1:repeat 0, PS.sin  (\0 -> (0,1)) PSE.asin) :-   ("asin",  100, 0:1:repeat 0, PS.asin (\1 -> 1) (\0 -> 0) PSE.sin) :-   ("sqrt",  500, 1:1:repeat 0, PS.sqrt (\1 -> 1) (PS.mul [1,1] [1,1])) :-   []--testSeriesIdentity :: (String, Int, [Rational], [Rational]) -> HUnit.Test-testSeriesIdentity (label, len, x, y) =-   HUnit.test (HUnit.assertBool label (equalInfLists len [x,y]))--testSeriesIdentities ::-   String -> [(String, Int, [Rational], [Rational])] -> HUnit.Test-testSeriesIdentities label ids =-   HUnit.TestLabel label $-     HUnit.TestList $ map testSeriesIdentity ids--checkSeriesIdentities ::-   [(String, Int, [Rational], [Rational])] -> [(String,Bool)]-checkSeriesIdentities =-   map (\(label, len, x, y) -> (label, equalInfLists len [x,y]))---+-- Do not edit! Automatically created with doctest-extract from src/MathObj/PowerSeries.hs+{-# LINE 30 "src/MathObj/PowerSeries.hs" #-} -powerMult :: Rational -> Rational -> Bool-powerMult exp0 exp1 =-   PS.mul (PSE.pow exp0) (PSE.pow exp1)  ==  PSE.pow (exp0+exp1)+module Test.MathObj.PowerSeries where -powerExplODE :: Rational -> Bool-powerExplODE expon =-   PSE.powODE expon == PSE.powExpl expon+import qualified Test.DocTest.Driver as DocTest +{-# LINE 31 "src/MathObj/PowerSeries.hs" #-}+import     qualified MathObj.PowerSeries.Core as PS+import     qualified MathObj.PowerSeries as PST+import     qualified Test.QuickCheck as QC+import     Test.NumericPrelude.Utility (equalTrunc, (/\))+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base as P+import     Prelude () -tests :: HUnit.Test-tests =-   HUnit.TestLabel "power series" $-   HUnit.TestList [-      testSeriesIdentities "explicit vs. ODE solution" identitiesExplODE,-      testSeriesIdentities "transcendent functions of series" identitiesSeriesFunction,-      testSeriesIdentities "inverses of some series" identitiesInverses-{--      HUnit.TestLabel "laws" $-      HUnit.TestList $-         map testUnit $-            ("products of powers",     quickCheck (powerMult)) :-            ("power explicit vs. ODE", quickCheck (powerExplODE)) :-            []--}-    ]+test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.PowerSeries:141: "+{-# LINE 141 "src/MathObj/PowerSeries.hs" #-}+ DocTest.property+{-# LINE 141 "src/MathObj/PowerSeries.hs" #-}+     (QC.choose (1,10) /\ \expon (QC.Positive x) xs -> let xt = x:xs in  equalTrunc 15 (PS.pow (const x) (1 % expon) (PST.coeffs (PST.fromCoeffs xt ^ expon)) ++ repeat zero) (xt ++ repeat zero))
+ test/Test/MathObj/PowerSeries/Core.hs view
@@ -0,0 +1,178 @@+-- Do not edit! Automatically created with doctest-extract from src/MathObj/PowerSeries/Core.hs+{-# LINE 23 "src/MathObj/PowerSeries/Core.hs" #-}++module Test.MathObj.PowerSeries.Core where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 24 "src/MathObj/PowerSeries/Core.hs" #-}+import     qualified MathObj.PowerSeries.Core as PS+import     qualified MathObj.PowerSeries.Example as PSE+import     Test.NumericPrelude.Utility (equalTrunc, (/\))+import     qualified Test.QuickCheck as QC+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base as P+import     Prelude ()+import     Control.Applicative (liftA3)++checkHoles     ::+       Int -> ([Rational] -> [Rational]) ->+       Rational -> [Rational] -> QC.Property+checkHoles     trunc f x xs =+       QC.choose (1,10) /\ \expon ->+       equalTrunc trunc+          (f (PS.insertHoles expon (x:xs)) ++ repeat zero)+          (PS.insertHoles expon (f (x:xs)) ++ repeat zero)++genInvertible     :: QC.Gen [Rational]+genInvertible     =+       liftA3 (\x0 x1 xs -> x0:x1:xs)+          QC.arbitrary (fmap QC.getNonZero QC.arbitrary) QC.arbitrary++test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.PowerSeries.Core:108: "+{-# LINE 108 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 108 "src/MathObj/PowerSeries/Core.hs" #-}+     (QC.choose (1,10) /\ \m -> QC.choose (1,10) /\ \n xs -> equalTrunc 100 (PS.insertHoles m $ PS.insertHoles n xs) (PS.insertHoles (m*n) xs))+ DocTest.printPrefix "MathObj.PowerSeries.Core:190: "+{-# LINE 190 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 190 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 PSE.sqrtExpl (PS.sqrt (\1 -> 1) [1,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:191: "+{-# LINE 191 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 191 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 500 (1:1:repeat 0) (PS.sqrt (\1 -> 1) (PS.mul [1,1] [1,1])))+ DocTest.printPrefix "MathObj.PowerSeries.Core:192: "+{-# LINE 192 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 192 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 50 (PS.sqrt (\1 -> 1)) 1)+ DocTest.printPrefix "MathObj.PowerSeries.Core:217: "+{-# LINE 217 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 217 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 100 (PSE.powExpl (-1/3)) (PS.pow (\1 -> 1) (-1/3) [1,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:218: "+{-# LINE 218 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 218 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 (PSE.powExpl (-1/3)) (PS.exp (\0 -> 1) (PS.scale (-1/3) PSE.log)))+ DocTest.printPrefix "MathObj.PowerSeries.Core:219: "+{-# LINE 219 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 219 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 30 (PS.pow (\1 -> 1) (1/3)) 1)+ DocTest.printPrefix "MathObj.PowerSeries.Core:220: "+{-# LINE 220 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 220 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 30 (PS.pow (\1 -> 1) (2/5)) 1)+ DocTest.printPrefix "MathObj.PowerSeries.Core:237: "+{-# LINE 237 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 237 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 500 PSE.expExpl (PS.exp (\0 -> 1) [0,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:238: "+{-# LINE 238 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 238 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 100 (1:1:repeat 0) (PS.exp (\0 -> 1) PSE.log))+ DocTest.printPrefix "MathObj.PowerSeries.Core:239: "+{-# LINE 239 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 239 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 30 (PS.exp (\0 -> 1)) 0)+ DocTest.printPrefix "MathObj.PowerSeries.Core:259: "+{-# LINE 259 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 259 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 500 PSE.sinExpl (PS.sin (\0 -> (0,1)) [0,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:260: "+{-# LINE 260 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 260 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 (0:1:repeat 0) (PS.sin (\0 -> (0,1)) PSE.asin))+ DocTest.printPrefix "MathObj.PowerSeries.Core:261: "+{-# LINE 261 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 261 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 20 (PS.sin (\0 -> (0,1))) 0)+ DocTest.printPrefix "MathObj.PowerSeries.Core:266: "+{-# LINE 266 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 266 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 500 PSE.cosExpl (PS.cos (\0 -> (0,1)) [0,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:267: "+{-# LINE 267 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 267 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 20 (PS.cos (\0 -> (0,1))) 0)+ DocTest.printPrefix "MathObj.PowerSeries.Core:273: "+{-# LINE 273 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 273 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 PSE.tanExpl (PS.tan (\0 -> (0,1)) [0,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:274: "+{-# LINE 274 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 274 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 (0:1:repeat 0) (PS.tan (\0 -> (0,1)) PSE.atan))+ DocTest.printPrefix "MathObj.PowerSeries.Core:275: "+{-# LINE 275 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 275 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 20 (PS.tan (\0 -> (0,1))) 0)+ DocTest.printPrefix "MathObj.PowerSeries.Core:289: "+{-# LINE 289 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 289 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 500 PSE.logExpl (PS.log (\1 -> 0) [1,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:290: "+{-# LINE 290 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 290 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 100 (0:1:repeat 0) (PS.log (\1 -> 0) PSE.exp))+ DocTest.printPrefix "MathObj.PowerSeries.Core:291: "+{-# LINE 291 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 291 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 30 (PS.log (\1 -> 0)) 1)+ DocTest.printPrefix "MathObj.PowerSeries.Core:303: "+{-# LINE 303 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 303 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 500 PSE.atan (PS.atan (\0 -> 0) [0,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:304: "+{-# LINE 304 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 304 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 (0:1:repeat 0) (PS.atan (\0 -> 0) PSE.tan))+ DocTest.printPrefix "MathObj.PowerSeries.Core:305: "+{-# LINE 305 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 305 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 20 (PS.atan (\0 -> 0)) 0)+ DocTest.printPrefix "MathObj.PowerSeries.Core:313: "+{-# LINE 313 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 313 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 100 (0:1:repeat 0) (PS.asin (\1 -> 1) (\0 -> 0) PSE.sin))+ DocTest.printPrefix "MathObj.PowerSeries.Core:314: "+{-# LINE 314 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 314 "src/MathObj/PowerSeries/Core.hs" #-}+     (equalTrunc 50 PSE.asin (PS.asin (\1 -> 1) (\0 -> 0) [0,1]))+ DocTest.printPrefix "MathObj.PowerSeries.Core:315: "+{-# LINE 315 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 315 "src/MathObj/PowerSeries/Core.hs" #-}+     (checkHoles 30 (PS.asin (\1 -> 1) (\0 -> 0)) 0)+ DocTest.printPrefix "MathObj.PowerSeries.Core:383: "+{-# LINE 383 "src/MathObj/PowerSeries/Core.hs" #-}+ DocTest.property+{-# LINE 383 "src/MathObj/PowerSeries/Core.hs" #-}+     (genInvertible /\ \xs -> let (y,ys) = PS.inv xs; (z,zs) = PS.invDiff xs in y==z && equalTrunc 15 ys zs)
+ test/Test/MathObj/PowerSeries/Example.hs view
@@ -0,0 +1,92 @@+-- Do not edit! Automatically created with doctest-extract from src/MathObj/PowerSeries/Example.hs+{-# LINE 21 "src/MathObj/PowerSeries/Example.hs" #-}++module Test.MathObj.PowerSeries.Example where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 22 "src/MathObj/PowerSeries/Example.hs" #-}+import     qualified MathObj.PowerSeries.Core as PS+import     qualified MathObj.PowerSeries.Example as PSE+import     Test.NumericPrelude.Utility (equalTrunc)+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base as P+import     Prelude ()++test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.PowerSeries.Example:55: "+{-# LINE 55 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 55 "src/MathObj/PowerSeries/Example.hs" #-}+          (\m n -> equalTrunc 30 (PS.mul (PSE.pow m) (PSE.pow n)) (PSE.pow (m+n)))+ DocTest.printPrefix "MathObj.PowerSeries.Example:66: "+{-# LINE 66 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 66 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.expExpl PSE.expODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:69: "+{-# LINE 69 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 69 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.sinExpl PSE.sinODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:72: "+{-# LINE 72 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 72 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.cosExpl PSE.cosODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:76: "+{-# LINE 76 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 76 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 50 PSE.tanExpl PSE.tanODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:80: "+{-# LINE 80 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 80 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 50 PSE.tanExpl PSE.tanExplSieve)+ DocTest.printPrefix "MathObj.PowerSeries.Example:87: "+{-# LINE 87 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 87 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.logExpl PSE.logODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:90: "+{-# LINE 90 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 90 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.atanExpl PSE.atanODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:94: "+{-# LINE 94 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 94 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.sinhExpl PSE.sinhODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:97: "+{-# LINE 97 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 97 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.coshExpl PSE.coshODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:100: "+{-# LINE 100 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 100 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 500 PSE.atanhExpl PSE.atanhODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:106: "+{-# LINE 106 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 106 "src/MathObj/PowerSeries/Example.hs" #-}+          (\expon -> equalTrunc 50 (PSE.powODE expon) (PSE.powExpl expon))+ DocTest.printPrefix "MathObj.PowerSeries.Example:112: "+{-# LINE 112 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 112 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 100 PSE.sqrtExpl PSE.sqrtODE)+ DocTest.printPrefix "MathObj.PowerSeries.Example:149: "+{-# LINE 149 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 149 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 50 PSE.tanODE PSE.tanODESieve)+ DocTest.printPrefix "MathObj.PowerSeries.Example:165: "+{-# LINE 165 "src/MathObj/PowerSeries/Example.hs" #-}+ DocTest.property+{-# LINE 165 "src/MathObj/PowerSeries/Example.hs" #-}+          (equalTrunc 50 PSE.asinODE (snd $ PS.inv PSE.sinODE))
+ test/Test/MathObj/RefinementMask2.hs view
@@ -0,0 +1,72 @@+-- Do not edit! Automatically created with doctest-extract from src/MathObj/RefinementMask2.hs+{-# LINE 32 "src/MathObj/RefinementMask2.hs" #-}++module Test.MathObj.RefinementMask2 where++import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest++{-# LINE 33 "src/MathObj/RefinementMask2.hs" #-}+import     qualified MathObj.RefinementMask2 as Mask+import     qualified MathObj.Polynomial      as Poly+import     qualified MathObj.Polynomial.Core as PolyCore++import     qualified Algebra.Differential as D+import     qualified Algebra.Ring as Ring+import     Test.NumericPrelude.Utility ((/\))+import     qualified Test.QuickCheck as QC+import     NumericPrelude.Numeric as NP+import     NumericPrelude.Base as P+import     Prelude ()++import     Data.Function.HT (nest)+import     Data.Maybe (fromMaybe)+++hasMultipleZero     :: (Ring.C a, Eq a) => Int -> a -> Poly.T a -> Bool+hasMultipleZero     n x poly =+       all (zero==) $ take n $+       map (flip Poly.evaluate x) $+       iterate D.differentiate poly++genAdmissibleMask     :: QC.Gen (Mask.T Rational, Poly.T Rational)+genAdmissibleMask     =+       QC.suchThatMap QC.arbitrary $+          \mask -> fmap ((,) mask) $ Mask.toPolynomial mask++polyFromMask     :: Mask.T a -> Poly.T a+polyFromMask     = Poly.fromCoeffs . Mask.coeffs++genShortPolynomial     :: Int -> QC.Gen (Poly.T Rational)+genShortPolynomial     n =+       fmap (Poly.fromCoeffs . PolyCore.normalize . take n) $ QC.arbitrary++test :: DocTest.T ()+test = do+ DocTest.printPrefix "MathObj.RefinementMask2:127: "+{-# LINE 127 "src/MathObj/RefinementMask2.hs" #-}+ DocTest.property+{-# LINE 127 "src/MathObj/RefinementMask2.hs" #-}+     (genAdmissibleMask /\ \(mask,poly) -> hasMultipleZero (fromMaybe 0 $ Poly.degree poly) 1 (polyFromMask (Mask.fromPolynomial poly) - polyFromMask mask))+ DocTest.printPrefix "MathObj.RefinementMask2:129: "+{-# LINE 129 "src/MathObj/RefinementMask2.hs" #-}+ DocTest.property+{-# LINE 129 "src/MathObj/RefinementMask2.hs" #-}+     (genShortPolynomial 5 /\ \poly -> maybe False (Poly.collinear poly) $ Mask.toPolynomial $ Mask.fromPolynomial poly)+ DocTest.printPrefix "MathObj.RefinementMask2:161: "+{-# LINE 161 "src/MathObj/RefinementMask2.hs" #-}+ DocTest.example+{-# LINE 161 "src/MathObj/RefinementMask2.hs" #-}+   (fmap ((6::Rational) *>) $ Mask.toPolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005::Rational]))+  [ExpectedLine [LineChunk "Just (Polynomial.fromCoeffs [-12732 % 109375,272 % 625,-18 % 25,1 % 1])"]]+ DocTest.printPrefix "MathObj.RefinementMask2:207: "+{-# LINE 207 "src/MathObj/RefinementMask2.hs" #-}+ DocTest.property+{-# LINE 207 "src/MathObj/RefinementMask2.hs" #-}+     (genShortPolynomial 5 /\ \poly -> poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly)+ DocTest.printPrefix "MathObj.RefinementMask2:209: "+{-# LINE 209 "src/MathObj/RefinementMask2.hs" #-}+ DocTest.example+{-# LINE 209 "src/MathObj/RefinementMask2.hs" #-}+   (fmap (round :: Double -> Integer) $ fmap (1000000*) $ nest 50 (Mask.refinePolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005])) (Poly.fromCoeffs [0,0,0,1]))+  [ExpectedLine [LineChunk "Polynomial.fromCoeffs [-116407,435200,-720000,1000000]"]]
+ test/Test/Number/ComplexSquareRoot.hs view
@@ -0,0 +1,56 @@+-- Do not edit! Automatically created with doctest-extract from playground/Number/ComplexSquareRoot.hs+{-# LINE 21 "playground/Number/ComplexSquareRoot.hs" #-}++module Test.Number.ComplexSquareRoot where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 22 "playground/Number/ComplexSquareRoot.hs" #-}+import     qualified Number.ComplexSquareRoot as SR+import     qualified Number.Complex as Complex+import     qualified Algebra.Laws as Laws+import     Test.QuickCheck ((==>))+import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude ()++sr     :: SR.T Rational -> SR.T Rational+sr     = id++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Number.ComplexSquareRoot:42: "+{-# LINE 42 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 42 "playground/Number/ComplexSquareRoot.hs" #-}+     (Laws.identity SR.mul SR.one . sr)+ DocTest.printPrefix "Number.ComplexSquareRoot:43: "+{-# LINE 43 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 43 "playground/Number/ComplexSquareRoot.hs" #-}+     (Laws.commutative SR.mul . sr)+ DocTest.printPrefix "Number.ComplexSquareRoot:44: "+{-# LINE 44 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 44 "playground/Number/ComplexSquareRoot.hs" #-}+     (Laws.associative SR.mul . sr)+ DocTest.printPrefix "Number.ComplexSquareRoot:45: "+{-# LINE 45 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 45 "playground/Number/ComplexSquareRoot.hs" #-}+     (Laws.homomorphism SR.fromNumber (\x y -> x * (y :: Complex.T Rational)) SR.mul)+ DocTest.printPrefix "Number.ComplexSquareRoot:46: "+{-# LINE 46 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 46 "playground/Number/ComplexSquareRoot.hs" #-}+     (Laws.rightIdentity SR.div SR.one . sr)+ DocTest.printPrefix "Number.ComplexSquareRoot:47: "+{-# LINE 47 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 47 "playground/Number/ComplexSquareRoot.hs" #-}+     (\x -> not (isZero x) ==> SR.recip (SR.recip x) == sr x)+ DocTest.printPrefix "Number.ComplexSquareRoot:48: "+{-# LINE 48 "playground/Number/ComplexSquareRoot.hs" #-}+ DocTest.property+{-# LINE 48 "playground/Number/ComplexSquareRoot.hs" #-}+     (\x -> not (isZero x) ==> Laws.inverse SR.mul SR.recip SR.one (sr x))
test/Test/Number/GaloisField2p32m5.hs view
@@ -1,37 +1,70 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Test.Number.GaloisField2p32m5 where--import qualified Number.GaloisField2p32m5 as GF--import qualified Algebra.Laws as Laws--import Test.NumericPrelude.Utility (testUnit)-import Test.QuickCheck (Testable, quickCheck, (==>))-import qualified Test.HUnit as HUnit-+-- Do not edit! Automatically created with doctest-extract from src/Number/GaloisField2p32m5.hs+{-# LINE 33 "src/Number/GaloisField2p32m5.hs" #-} -import PreludeBase as P-import NumericPrelude as NP+module Test.Number.GaloisField2p32m5 where +import qualified Test.DocTest.Driver as DocTest -test :: Testable a => (GF.T -> a) -> IO ()-test = quickCheck+{-# LINE 34 "src/Number/GaloisField2p32m5.hs" #-}+import     qualified Number.GaloisField2p32m5 as GF+import     qualified Algebra.Laws as Laws+import     Test.QuickCheck ((==>))+import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude () +gf     :: GF.T -> GF.T+gf     = id -tests :: HUnit.Test-tests =-   HUnit.TestLabel "galois field 2^32-5" $-   HUnit.TestList $-   map testUnit $-      ("addition, zero",         test (Laws.identity (+) zero)) :-      ("addition, commutative",  test (Laws.commutative (+))) :-      ("addition, associative",  test (Laws.associative (+))) :-      ("addition, negate",       test (Laws.inverse (+) negate zero)) :-      ("addition, subtract",     test (\x -> Laws.inverse (+) (x-) x)) :-      ("multiplication, one",          test (Laws.identity (*) one)) :-      ("multiplication, commutative",  test (Laws.commutative (*))) :-      ("multiplication, associative",  test (Laws.associative (*))) :-      ("multiplication, recip",        test (\y -> y /= 0 ==> Laws.inverse (*) recip one y)) :-      ("multiplication, division",     test (\y x -> y /= 0 ==> Laws.inverse (*) (x/) x y)) :-      ("multiplication and addition, distributive",   test (Laws.leftDistributive (*) (+))) :-      []+test :: DocTest.T ()+test = do+ DocTest.printPrefix "Number.GaloisField2p32m5:46: "+{-# LINE 46 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 46 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.identity (+) zero . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:47: "+{-# LINE 47 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 47 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.commutative (+) . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:48: "+{-# LINE 48 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 48 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.associative (+) . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:49: "+{-# LINE 49 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 49 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.inverse (+) negate zero . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:50: "+{-# LINE 50 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 50 "src/Number/GaloisField2p32m5.hs" #-}+     (\x -> Laws.inverse (+) (x-) (gf x))+ DocTest.printPrefix "Number.GaloisField2p32m5:51: "+{-# LINE 51 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 51 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.identity (*) one . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:52: "+{-# LINE 52 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 52 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.commutative (*) . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:53: "+{-# LINE 53 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 53 "src/Number/GaloisField2p32m5.hs" #-}+     (Laws.associative (*) . gf)+ DocTest.printPrefix "Number.GaloisField2p32m5:54: "+{-# LINE 54 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 54 "src/Number/GaloisField2p32m5.hs" #-}+     (\y -> gf y /= zero ==> Laws.inverse (*) recip one y)+ DocTest.printPrefix "Number.GaloisField2p32m5:55: "+{-# LINE 55 "src/Number/GaloisField2p32m5.hs" #-}+ DocTest.property+{-# LINE 55 "src/Number/GaloisField2p32m5.hs" #-}+     (\y x -> gf y /= zero ==> Laws.inverse (*) (x/) x y)
test/Test/NumericPrelude/Utility.hs view
@@ -1,21 +1,17 @@--- cf. utility-ht Test.Utility module Test.NumericPrelude.Utility where -import Data.List.HT (mapAdjacent, )-import qualified Data.List as List-import qualified Test.HUnit as HUnit+import qualified Test.QuickCheck as QC +import qualified NumericPrelude.Numeric as NP -testUnit :: (String, IO ()) -> HUnit.Test-testUnit (label, check) =-   HUnit.TestLabel label (HUnit.TestCase check)+import Data.Eq.HT (equating) --- compare the lists simultaneously-equalLists :: Eq a => [[a]] -> Bool-equalLists xs =-   let equalElems ys =-          and (mapAdjacent (==) ys)  &&  length xs == length ys-   in  all equalElems (List.transpose xs) -equalInfLists :: Eq a => Int -> [[a]] -> Bool-equalInfLists n xs = equalLists (map (take n) xs)+equalTrunc :: Int -> [NP.Rational] -> [NP.Rational] -> Bool+equalTrunc n = equating (take n)+++infixr 0 /\++(/\) :: (Show a, QC.Testable test) => QC.Gen a -> (a -> test) -> QC.Property+(/\) = QC.forAll
test/Test/Run.hs view
@@ -1,28 +1,44 @@+-- Do not edit! Automatically created with doctest-extract. module Main where -import qualified Test.Algebra.RealRing as RealRing-import qualified Test.MathObj.Gaussian.Polynomial as GaussPoly-import qualified Test.MathObj.Gaussian.Variance as GaussVariance-import qualified Test.MathObj.Gaussian.Bell as GaussBell-import qualified Test.MathObj.PartialFraction as PartialFraction-import qualified Test.MathObj.Matrix  as Matrix-import qualified Test.MathObj.Polynomial  as Polynomial-import qualified Test.MathObj.PowerSeries as PowerSeries-import qualified Test.Number.GaloisField2p32m5 as GF-import qualified Test.HUnit.Text as HUnitText-import qualified Test.HUnit as HUnit+import qualified Test.Algebra.Additive+import qualified Test.Algebra.IntegralDomain+import qualified Test.Algebra.PrincipalIdealDomain+import qualified Test.Algebra.RealRing+import qualified Test.MathObj.Gaussian.Bell+import qualified Test.MathObj.Gaussian.Polynomial+import qualified Test.MathObj.Gaussian.ExponentTuple+import qualified Test.MathObj.Gaussian.Variance+import qualified Test.MathObj.Matrix+import qualified Test.MathObj.PartialFraction+import qualified Test.MathObj.Polynomial+import qualified Test.MathObj.Polynomial.Core+import qualified Test.MathObj.PowerSeries+import qualified Test.MathObj.PowerSeries.Core+import qualified Test.MathObj.PowerSeries.Example+import qualified Test.MathObj.RefinementMask2+import qualified Test.Number.ComplexSquareRoot+import qualified Test.Number.GaloisField2p32m5 +import qualified Test.DocTest.Driver as DocTest+ main :: IO ()-main =-   do HUnitText.runTestTT (HUnit.TestList $-         RealRing.tests :-         GaussVariance.tests :-         GaussBell.tests :-         GaussPoly.tests :-         PartialFraction.tests :-         Matrix.tests :-         Polynomial.tests :-         PowerSeries.tests :-         GF.tests :-         [])-      return ()+main = DocTest.run $ do+    Test.Algebra.Additive.test+    Test.Algebra.IntegralDomain.test+    Test.Algebra.PrincipalIdealDomain.test+    Test.Algebra.RealRing.test+    Test.MathObj.Gaussian.Bell.test+    Test.MathObj.Gaussian.Polynomial.test+    Test.MathObj.Gaussian.ExponentTuple.test+    Test.MathObj.Gaussian.Variance.test+    Test.MathObj.Matrix.test+    Test.MathObj.PartialFraction.test+    Test.MathObj.Polynomial.test+    Test.MathObj.Polynomial.Core.test+    Test.MathObj.PowerSeries.test+    Test.MathObj.PowerSeries.Core.test+    Test.MathObj.PowerSeries.Example.test+    Test.MathObj.RefinementMask2.test+    Test.Number.ComplexSquareRoot.test+    Test.Number.GaloisField2p32m5.test